gitorious.org Git - opensuse:osc.git/blob

1 #! /usr/bin/perl -w

2 #

3 # osc_expand_link.pl -- a tool to help osc build packages where an _link exists.

5 #

6 # 2006-12-12, jw

7 # 2006-12-15, jw, v0.2 -- {files}{error} gets printed if present.

8 # 2008-03-25, jw, v0.3 -- go via api using iChains and ~/.oscrc

9 # 2008-03-26, jw, v0.4 -- added linked file retrieval and usage.

10 # 2009-10-21, jw, added obsolete warning, in favour of osc co -e

12 use Data::Dumper;

13 use LWP::UserAgent;

14 use HTTP::Status;

15 use Digest::MD5;

17 my $version = '0.4';

18 my $verbose = 1;

20 print "This $0 is obsolete. Please use instead: osc co -e\n";

21 sleep 5;

23 # curl buildservice:5352/source/home:jnweiger/vim

24 # curl 'buildservice:5352/source/home:jnweiger/vim?rev=d90bfab4301f758e0d82cf09aa263d37'

25 # curl 'buildservice:5352/source/home:jnweiger/vim/vim.spec?rev=d90bfab4301f758e0d82cf09aa263d37'

27 my $cfg = {

28 apiurl => slurp_file(".osc/_apiurl", 1),

29 package => slurp_file(".osc/_package", 1),

30 project => slurp_file(".osc/_project", 1),

31 files => xml_slurp_file(".osc/_files", { container => 'directory', attr => 'merge' }),

32 link => xml_slurp_file(".osc/_link", { container => 'link', attr => 'merge' }),

33 };

35 {

36 package CredUserAgent;

37 @ISA = qw(LWP::UserAgent);

39 sub new

40 {

41 my $self = LWP::UserAgent::new(@_);

42 $self->agent("osc_expand_link.pl/$version");

43 $self;

44 }

45 sub get_basic_credentials

46 {

47 my ($self, $realm, $uri) = @_;

48 my $netloc = $uri->host_port;

50 unless ($self->{auth})

51 {

52 print STDERR "Auth for $realm at $netloc\n";

53 unless (open IN, "<", "$ENV{HOME}/.oscrc")

54 {

55 print STDERR "$ENV{HOME}/.oscrc: $!\n";

56 return (undef, undef);

57 }

58 while (defined (my $line = <IN>))

59 {

60 chomp $line;

61 $self->{auth}{pass} = $1 if $line =~ m{^pass\s*=\s*(\S+)};

62 $self->{auth}{user} = $1 if $line =~ m{^user\s*=\s*(\S+)};

63 }

64 close IN;

65 print STDERR "~/.oscrc: user=$self->{auth}{user}\n";

66 }

67 return ($self->{auth}{user},$self->{auth}{pass});

68 }

69 }

71 my $ua = CredUserAgent->new (keep_alive => 1);

73 sub cred_get

74 {

75 my ($url) = @_;

76 my $r = $ua->get($url);

77 die "$url: " . $r->status_line . "\n" unless $r->is_success;

78 return $r->content;

79 }

81 sub cred_getstore

82 {

83 my ($url, $file) = @_;

84 my $r = $ua->get($url, ':content_file' => $file);

85 die "$url: " . $r->status_line . "\n" unless $r->is_success;

86 $r->code;

87 }

89 $cfg->{apiurl} ||= 'https://api.opensuse.org';

90 $cfg->{project} ||= '<Project>';

91 $cfg->{package} ||= '<Package>';

93 chomp $cfg->{apiurl};

94 chomp $cfg->{project};

95 chomp $cfg->{package};

97 my $source = "$cfg->{apiurl}/source";

98 my $url = "$source/$cfg->{project}/$cfg->{package}";

100 if (my $url = $ARGV[0])

101 {

102

103 die qq{osc_expand_link $version;

104

105 Usage:

106

107 osc co $cfg->{project} $cfg->{package}

108 cd $cfg->{project}/$cfg->{package}

109 $0

110

111 to resolve a _link.

112

113 or

114

115 $0 $cfg->{apiurl}/source/$cfg->{project}/$cfg->{package}

116

117 to review internal buildservice data.

118

119 or

120 $0 $cfg->{apiurl}/source/$cfg->{project}/$cfg->{package}/linked/\\*.spec

121

122 cd $cfg->{project}/$cfg->{package}

123 $0 linked \\*.spec

124

125 to retrieve the original specfile behind a link.

126

127 } if $url =~ m{^-};

128

129 $url = "$url/$ARGV[1]" if $url eq 'linked' and $ARGV[1];

130 if ($url =~ m{^(.*/)?linked/(.*)$})

131 {

132 $url = (defined $1) ? $1 : "$cfg->{project}/$cfg->{package}";

133 my $file = $2;

134 $url = "$source/$url" if $cfg->{apiurl} and $url !~ m{://};

135 print STDERR "$url\n";

136 my $dir = xml_parse(cred_get($url), 'merge');

137 my $li = $dir->{directory}{linkinfo} || die "no linkinfo in $url\n";

138 $url = "$source/$li->{project}/$li->{package}";

139 mkdir("linked");

140

141 if ($file =~ m{\*})

142 {

143 my $dir = xml_parse(cred_get($url), 'merge');

144 $dir = $dir->{directory} if $dir->{directory};

145 my @list = sort map { $_->{name} } @{$dir->{entry}};

146 my $file_re = "\Q$file\E"; $file_re =~ s{\\\*}{\.\*}g;

147 my @match = grep { $_ =~ m{^$file_re$} } @list;

148 die "pattern $file not found in\n @list\n" unless @match;

149 $file = $match[0];

150 }

151 $url .= "/$file";

152

153 print STDERR "$url -> linked/$file\n";

154 my $r = cred_getstore($url, "linked/$file");

155 print STDERR " Error: $r\n" if $r != RC_OK;

156 exit 0;

157 }

158

159 $url = "$cfg->{project}/$cfg->{package}/$url" unless $url =~ m{/};

160 $url = "$source/$url" if $cfg->{apiurl} and $url !~ m{://};

161 print cred_get($url);

162 exit 0;

163 }

164

165 warn "$cfg->{project}/$cfg->{package} error: $cfg->{files}{error}\n" if $cfg->{files}{error};

166 die "$cfg->{project}/$cfg->{package} has no _link\n" unless $cfg->{link};

167 die "$cfg->{project}/$cfg->{package} has no xsrcmd5\n" unless $cfg->{files}{xsrcmd5};

168

169 print STDERR "expanding link to $cfg->{link}{project}/$cfg->{link}{package}\n";

170 if (my $p = $cfg->{link}{patches})

171 {

172 $p = [ $p ] if ref $p ne 'ARRAY';

173 my @p = map { "$_->{apply}{name}" } @$p;

174 print STDERR "applied patches: " . join(',', @p) . "\n";

175 }

176

177 my $dir = xml_parse(cred_get("$url?rev=$cfg->{files}{xsrcmd5}"), 'merge');

178 $dir = $dir->{directory} if defined $dir->{directory};

179 $dir->{entry} = [ $dir->{entry} ] if ref $dir->{entry} ne 'ARRAY';

180 for my $file (@{$dir->{entry}})

181 {

182 if (-f $file->{name})

183 {

184 ## check the md5sum of the existing file and be happy.

185 $md5 = Digest::MD5->new;

186 open IN, "<", $file->{name} or die "md5sum($file->{name} failed: $!";

187 $md5->addfile(*IN);

188 close IN;

189 if ($md5->hexdigest eq $file->{md5})

190 {

191 print STDERR " - $file->{name} (md5 unchanged)\n";

192 }

193 else

194 {

195 print STDERR "Modified: $file->{name}, please commit changes!\n";

196 }

197 next;

198 }

199 print STDERR " get $file->{name}";

200 # fixme: xsrcmd5 is obsolete.

201 # use <linkinfo project="openSUSE:Factory" package="avrdude" xsrcmd5="a39c2bd14c3ad5dbb82edd7909fcdfc4">

202 my $response = cred_getstore("$url/$file->{name}?rev=$cfg->{files}{xsrcmd5}", $file->{name});

203 print STDERR ($response == RC_OK) ? "\n" : " Error:$response\n";

204 }

205 exit 0;

206 ##########################################################################

207

208 sub slurp_file

209 {

210 my ($path, $silent) = @_;

211 open IN, "<", $path or ($silent ? return undef : die "slurp_file($path) failed: $!\n");

212 my $body = join '', <IN>;

213 close IN;

214 return $body;

215 }

216

217

218 #################################################################

219 ## xml parser imported from w3dcm.pl and somewhat expanded.

220 ## 2006-12-15, jw

221 ##

222 ## xml_parse assumes correct container closing.

223 ## Any </...> tag would closes an open <foo>.

224 ## Thus xml_parse is not suitable for HTML.

225 ##

226 sub xml_parse

227 {

228 my ($text, $attr) = @_;

229 my %xml;

230 my @stack = ();

231 my $t = \%xml;

232

233 #print "xml_parse: '$text'\n";

234 my @tags = find_tags($text);

235 for my $i (0 .. $#tags)

236 {

237 my $tag = substr $text, $tags[$i]->{offset}, $tags[$i]->{tag_len};

238 my $cdata = '';

239 my $s = $tags[$i]->{offset} + $tags[$i]->{tag_len};

240 if (defined $tags[$i+1])

241 {

242 my $l = $tags[$i+1]->{offset} - $s;

243 $cdata = substr $text, $s, $l;

244 }

245 else

246 {

247 $cdata = substr $text, $s;

248 }

249

250 # print "tag=$tag\n";

251 my $name = $1 if $tag =~ s{<([\?/]?[\w:-]+)\s*}{};

252 $tag =~ s{>\s*$}{};

253 my $nest = ($tag =~ s{[\?/]$}{}) ? 0 : 1;

254 my $close = ($name =~ s{^/}{}) ? 1 : 0;

255 # print "name=$name, attr='$tag', $close, $nest, '$cdata'\n";

256

257 my $x = {};

258 $x->{-cdata} .= $cdata if $nest;

259 xml_add_attr($x, $tag, $attr) unless $tag eq '';

260

261 if (!$close)

262 {

263 delete $t->{-cdata} if $t->{-cdata} and $t->{-cdata} =~ m{^\s*$};

264 unless ($t->{$name})

265 {

266 $t->{$name} = $x;

267 }

268 else

269 {

270 $t->{$name} = [ $t->{$name} ] unless ref $t->{$name} eq 'ARRAY';

271 push @{$t->{$name}}, $x;

272 }

273 }

274

275

276 if ($close)

277 {

278 $t = pop @stack;

279 }

280 elsif ($nest)

281 {

282 push @stack, $t;

283 $t = $x;

284 }

285 }

286

287 print "stack=", Data::Dumper::Dumper(\@stack) if $verbose > 2;

288 scalar_cdata($t);

289 return $t;

290 }

291

292 ##

293 ## reads a file formatted by xml_make, and returns a hash.

294 ## The toplevel container is removed from that hash, if specified.

295 ## A wildcard '*' can be specified to remove any toplevel container.

296 ## Otherwise the name of the container must match precisely.

297 ##

298 sub xml_slurp_file

299 {

300 my ($file, $opt) = @_;

301 unless (open IN, "<$file")

302 {

303 return undef unless $opt->{die};

304 die "xml_slurp($opt->{container}): cannot read $file: $!\n";

305 }

306

307 my $xml = join '', <IN>; close IN;

308 $xml = xml_parse($xml, $opt->{attr});

309 if (my $container = $opt->{container})

310 {

311 die "xml_slurp($file, '$container') malformed file, should have only one toplevel node.\n"

312 unless scalar keys %$xml == 1;

313 $container = (keys %$xml)[0] if $container eq '' or $container eq '*';

314 die "xml_slurp($file, '$container') toplevel tag missing or wrong.\n" unless $xml->{$container};

315 $xml = $xml->{$container};

316 }

317 return $xml;

318 }

319

320 sub xml_escape

321 {

322 my ($text) = @_;

323

324 ## XML::Simple does just that:

325 $text =~ s{&}{&}g;

326 $text =~ s{<}{<}g;

327 $text =~ s{>}{>}g;

328 $text =~ s{"}{"}g;

329 return $text;

330 }

331

332 sub xml_unescape

333 {

334 my ($text) = @_;

335

336 ## XX: Fimxe: we should handle some more escapes here...

337 ## and better do it in a single pass.

338 $text =~ s{&#([\d]{3});}{chr $1}eg;

339 $text =~ s{<}{<}g;

340 $text =~ s{>}{>}g;

341 $text =~ s{"}{"}g;

342 $text =~ s{&}{&}g;

343

344 return $text;

345 }

346

347 ##

348 ## find all hashes, that contain exactly one key named '-cdata'

349 ## and replace these hashes with the value of that key.

350 ## These values are scalar when created by xml_parse(), hence the name.

351 ##

352 sub scalar_cdata

353 {

354 my ($hash) = @_;

355 my $selftag = '.scalar_cdata_running';

356

357 return unless ref $hash eq 'HASH';

358 return if $hash->{$selftag};

359 $hash->{$selftag} = 1;

360

361 for my $key (keys %$hash)

362 {

363 my $val = $hash->{$key};

364 if (ref $val eq 'ARRAY')

365 {

366 for my $i (0..$#$val)

367 {

368 scalar_cdata($hash->{$key}[$i]);

369 }

370 }

371 elsif (ref $val eq 'HASH')

372 {

373 my @k = keys %$val;

374 if (scalar(@k) == 1 && ($k[0] eq '-cdata'))

375 {

376 $hash->{$key} = $hash->{$key}{-cdata};

377 }

378 else

379 {

380 delete $hash->{$key}{-cdata} if exists $val->{-cdata} && $val->{-cdata} =~ m{^\s*$};

381 scalar_cdata($hash->{$key});

382 }

383 }

384 }

385 delete $hash->{$selftag};

386 }

387

388 ##

389 ## find_tags -- a brute force tag finder.

390 ## This code is robust enough to parse the weirdest HTML.

391 ## An Array containing hashes of { offset, name, tag_len } is returned.

392 ## CDATA is skipped, but can be determined from gaps between tags.

393 ## The name parser may chop names, so XML-style tag names are

394 ## unreliable.

395 ##

396 sub find_tags

397 {

398 my ($text) = @_;

399 my $last = '';

400 my @tags;

401 my $inquotes = 0;

402 my $incomment = 0;

403

404 while ($text =~ m{(|"|>|<)(/?\w*)}g)

405 {

406 my ($offset, $what, $name) = (length $`, $1, $2);

407

408 if ($inquotes)

409 {

410 $inquotes = 0 if $what eq '"';

411 next;

412 }

413

414 if ($incomment)

415 {

416 $incomment = 0 if $what eq '-->';

417 next;

418 }

419

420 if ($what eq '"')

421 {

422 $inquotes = 1;

423 next;

424 }

425

426 if ($what eq '<!--')

427 {

428 $incomment = 1;

429 next;

430 }

431

432 next if $what eq $last; # opening and closing angular brackets are polar.

433

434 if ($what eq '>' and scalar @tags)

435 {

436 $tags[$#tags]{tag_len} = 1 + $offset - $tags[$#tags]{offset};

437 }

438

439 if ($what eq '<')

440 {

441 push @tags, {name => $name, offset => $offset };

442 }

443

444 $last = $what;

445 }

446 return @tags;

447 }

448

449 ##

450 ## how = undef: defaults to '-attr plain'

451 ## how = '-attr plain': add the attributes as one scalar value to hash-element -attr

452 ## how = '-attr hash': add the attributes as a hash-ref to hash-element -attr

453 ## how = 'merge': add the attributes as direct hash elements. (This is irreversible)

454 ##

455 ## attributes are either space-separated, or delimited with '' or "".

456 sub xml_add_attr

457 {

458 my ($hash, $text, $how) = @_;

459 $how = 'plain' unless $how;

460 my $tag = '-attr'; $tag = $1 if $how =~ s{^\s*([\w_:-]+)\s+(.*)$}{$2};

461 $how = lc $how;

462

463 return $hash->{$tag} = $text if $how eq 'plain';

464

465 if ($how eq 'hash')

466 {

467 $hash = $hash->{$tag} = {};

468 $how = 'merge';

469 ## fallthrough

470 }

471 if ($how eq 'merge')

472 {

473 while ($text =~ m{([\w_:-]+)\s*=("[^"]*"|'[^']'|\S*)\s*}g)

474 {

475 my ($key, $val) = ($1, $2);

476 $val =~ s{^"(.*)"$}{$1} unless $val =~ s{^'(.*)'$}{$1};

477 if (defined($hash->{$key}))

478 {

479 ## redefinition. promote to array and push.

480 $hash->{$key} = [ $hash->{$key} ] unless ref $hash->{$key};

481 push @{$hash->{$key}}, $val;

482 }

483 else

484 {

485 $hash->{$key} = $val;

486 }

487 }

488 return $hash;

489 }

490 die "xml_expand_attr: unknown method '$how'\n";

491 }