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.

11 use Data::Dumper;

12 use LWP::UserAgent;

13 use HTTP::Status;

14 use Digest::MD5;

16 my $version = '0.4';

17 my $verbose = 1;

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

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

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

23 my $cfg = {

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

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

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

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

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

29 };

31 {

32 package CredUserAgent;

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

35 sub new

36 {

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

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

39 $self;

40 }

41 sub get_basic_credentials

42 {

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

44 my $netloc = $uri->host_port;

46 unless ($self->{auth})

47 {

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

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

50 {

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

52 return (undef, undef);

53 }

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

55 {

56 chomp $line;

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

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

59 }

60 close IN;

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

62 }

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

64 }

65 }

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

69 sub cred_get

70 {

71 my ($url) = @_;

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

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

74 return $r->content;

75 }

77 sub cred_getstore

78 {

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

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

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

82 $r->code;

83 }

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

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

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

89 chomp $cfg->{apiurl};

90 chomp $cfg->{project};

91 chomp $cfg->{package};

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

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

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

97 {

99 die qq{osc_expand_link $version;

100

101 Usage:

102

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

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

105 $0

106

107 to resolve a _link.

108

109 or

110

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

112

113 to review internal buildservice data.

114

115 or

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

117

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

119 $0 linked \\*.spec

120

121 to retrieve the original specfile behind a link.

122

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

124

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

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

127 {

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

129 my $file = $2;

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

131 print STDERR "$url\n";

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

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

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

135 mkdir("linked");

136

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

138 {

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

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

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

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

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

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

145 $file = $match[0];

146 }

147 $url .= "/$file";

148

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

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

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

152 exit 0;

153 }

154

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

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

157 print cred_get($url);

158 exit 0;

159 }

160

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

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

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

164

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

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

167 {

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

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

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

171 }

172

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

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

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

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

177 {

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

179 {

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

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

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

183 $md5->addfile(*IN);

184 close IN;

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

186 {

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

188 }

189 else

190 {

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

192 }

193 next;

194 }

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

196 # fixme: xsrcmd5 is obsolete.

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

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

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

200 }

201 exit 0;

202 ##########################################################################

203

204 sub slurp_file

205 {

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

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

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

209 close IN;

210 return $body;

211 }

212

213

214 #################################################################

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

216 ## 2006-12-15, jw

217 ##

218 ## xml_parse assumes correct container closing.

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

220 ## Thus xml_parse is not suitable for HTML.

221 ##

222 sub xml_parse

223 {

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

225 my %xml;

226 my @stack = ();

227 my $t = \%xml;

228

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

230 my @tags = find_tags($text);

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

232 {

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

234 my $cdata = '';

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

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

237 {

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

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

240 }

241 else

242 {

243 $cdata = substr $text, $s;

244 }

245

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

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

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

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

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

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

252

253 my $x = {};

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

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

256

257 if (!$close)

258 {

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

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

261 {

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

263 }

264 else

265 {

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

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

268 }

269 }

270

271

272 if ($close)

273 {

274 $t = pop @stack;

275 }

276 elsif ($nest)

277 {

278 push @stack, $t;

279 $t = $x;

280 }

281 }

282

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

284 scalar_cdata($t);

285 return $t;

286 }

287

288 ##

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

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

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

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

293 ##

294 sub xml_slurp_file

295 {

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

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

298 {

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

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

301 }

302

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

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

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

306 {

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

308 unless scalar keys %$xml == 1;

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

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

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

312 }

313 return $xml;

314 }

315

316 sub xml_escape

317 {

318 my ($text) = @_;

319

320 ## XML::Simple does just that:

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

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

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

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

325 return $text;

326 }

327

328 sub xml_unescape

329 {

330 my ($text) = @_;

331

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

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

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

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

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

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

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

339

340 return $text;

341 }

342

343 ##

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

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

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

347 ##

348 sub scalar_cdata

349 {

350 my ($hash) = @_;

351 my $selftag = '.scalar_cdata_running';

352

353 return unless ref $hash eq 'HASH';

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

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

356

357 for my $key (keys %$hash)

358 {

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

360 if (ref $val eq 'ARRAY')

361 {

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

363 {

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

365 }

366 }

367 elsif (ref $val eq 'HASH')

368 {

369 my @k = keys %$val;

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

371 {

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

373 }

374 else

375 {

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

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

378 }

379 }

380 }

381 delete $hash->{$selftag};

382 }

383

384 ##

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

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

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

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

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

390 ## unreliable.

391 ##

392 sub find_tags

393 {

394 my ($text) = @_;

395 my $last = '';

396 my @tags;

397 my $inquotes = 0;

398 my $incomment = 0;

399

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

401 {

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

403

404 if ($inquotes)

405 {

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

407 next;

408 }

409

410 if ($incomment)

411 {

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

413 next;

414 }

415

416 if ($what eq '"')

417 {

418 $inquotes = 1;

419 next;

420 }

421

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

423 {

424 $incomment = 1;

425 next;

426 }

427

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

429

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

431 {

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

433 }

434

435 if ($what eq '<')

436 {

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

438 }

439

440 $last = $what;

441 }

442 return @tags;

443 }

444

445 ##

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

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

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

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

450 ##

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

452 sub xml_add_attr

453 {

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

455 $how = 'plain' unless $how;

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

457 $how = lc $how;

458

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

460

461 if ($how eq 'hash')

462 {

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

464 $how = 'merge';

465 ## fallthrough

466 }

467 if ($how eq 'merge')

468 {

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

470 {

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

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

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

474 {

475 ## redefinition. promote to array and push.

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

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

478 }

479 else

480 {

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

482 }

483 }

484 return $hash;

485 }

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

487 }