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.

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 # curl buildservice:5352/source/home:jnweiger/vim

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

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

24 my $cfg = {

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

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

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

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

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

30 };

32 {

33 package CredUserAgent;

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

36 sub new

37 {

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

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

40 $self;

41 }

42 sub get_basic_credentials

43 {

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

45 my $netloc = $uri->host_port;

47 unless ($self->{auth})

48 {

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

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

51 {

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

53 return (undef, undef);

54 }

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

56 {

57 chomp $line;

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

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

60 }

61 close IN;

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

63 }

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

65 }

66 }

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

70 sub cred_get

71 {

72 my ($url) = @_;

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

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

75 return $r->content;

76 }

78 sub cred_getstore

79 {

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

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

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

83 $r->code;

84 }

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

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

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

90 chomp $cfg->{apiurl};

91 chomp $cfg->{project};

92 chomp $cfg->{package};

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

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

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

98 {

100 die qq{osc_expand_link $version;

101

102 Usage:

103

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

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

106 $0

107

108 to resolve a _link.

109

110 or

111

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

113

114 to review internal buildservice data.

115

116 or

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

118

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

120 $0 linked \\*.spec

121

122 to retrieve the original specfile behind a link.

123

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

125

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

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

128 {

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

130 my $file = $2;

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

132 print STDERR "$url\n";

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

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

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

136 mkdir("linked");

137

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

139 {

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

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

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

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

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

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

146 $file = @match[0];

147 }

148 $url .= "/$file";

149

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

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

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

153 exit 0;

154 }

155

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

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

158 print cred_get($url);

159 exit 0;

160 }

161

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

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

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

165

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

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

168 {

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

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

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

172 }

173

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

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

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

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

178 {

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

180 {

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

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

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

184 $md5->addfile(*IN);

185 close IN;

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

187 {

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

189 }

190 else

191 {

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

193 }

194 next;

195 }

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

197 # fixme: xsrcmd5 is obsolete.

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

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

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

201 }

202 exit 0;

203 ##########################################################################

204

205 sub slurp_file

206 {

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

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

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

210 close IN;

211 return $body;

212 }

213

214

215 #################################################################

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

217 ## 2006-12-15, jw

218 ##

219 ## xml_parse assumes correct container closing.

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

221 ## Thus xml_parse is not suitable for HTML.

222 ##

223 sub xml_parse

224 {

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

226 my %xml;

227 my @stack = ();

228 my $t = \%xml;

229

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

231 my @tags = find_tags($text);

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

233 {

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

235 my $cdata = '';

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

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

238 {

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

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

241 }

242 else

243 {

244 $cdata = substr $text, $s;

245 }

246

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

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

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

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

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

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

253

254 my $x = {};

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

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

257

258 if (!$close)

259 {

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

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

262 {

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

264 }

265 else

266 {

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

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

269 }

270 }

271

272

273 if ($close)

274 {

275 $t = pop @stack;

276 }

277 elsif ($nest)

278 {

279 push @stack, $t;

280 $t = $x;

281 }

282 }

283

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

285 scalar_cdata($t);

286 return $t;

287 }

288

289 ##

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

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

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

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

294 ##

295 sub xml_slurp_file

296 {

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

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

299 {

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

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

302 }

303

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

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

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

307 {

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

309 unless scalar keys %$xml == 1;

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

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

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

313 }

314 return $xml;

315 }

316

317 sub xml_escape

318 {

319 my ($text) = @_;

320

321 ## XML::Simple does just that:

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

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

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

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

326 return $text;

327 }

328

329 sub xml_unescape

330 {

331 my ($text) = @_;

332

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

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

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

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

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

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

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

340

341 return $text;

342 }

343

344 ##

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

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

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

348 ##

349 sub scalar_cdata

350 {

351 my ($hash) = @_;

352 my $selftag = '.scalar_cdata_running';

353

354 return unless ref $hash eq 'HASH';

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

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

357

358 for my $key (keys %$hash)

359 {

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

361 if (ref $val eq 'ARRAY')

362 {

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

364 {

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

366 }

367 }

368 elsif (ref $val eq 'HASH')

369 {

370 my @k = keys %$val;

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

372 {

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

374 }

375 else

376 {

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

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

379 }

380 }

381 }

382 delete $hash->{$selftag};

383 }

384

385

386 ##

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

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

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

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

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

392 ## unreliable.

393 ##

394 sub find_tags

395 {

396 my ($text) = @_;

397 my $last = '';

398 my @tags;

399 my $inquotes = 0;

400 my $incomment = 0;

401

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

403 {

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

405

406 if ($inquotes)

407 {

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

409 next;

410 }

411

412 if ($incomment)

413 {

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

415 next;

416 }

417

418 if ($what eq '"')

419 {

420 $inquotes = 1;

421 next;

422 }

423

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

425 {

426 $incomment = 1;

427 next;

428 }

429

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

431

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

433 {

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

435 }

436

437 if ($what eq '<')

438 {

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

440 }

441

442 $last = $what;

443 }

444 return @tags;

445 }

446

447 ##

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

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

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

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

452 ##

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

454 sub xml_add_attr

455 {

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

457 $how = 'plain' unless $how;

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

459 $how = lc $how;

460

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

462

463 if ($how eq 'hash')

464 {

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

466 $how = 'merge';

467 ## fallthrough

468 }

469 if ($how eq 'merge')

470 {

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

472 {

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

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

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

476 {

477 ## redefinition. promote to array and push.

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

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

480 }

481 else

482 {

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

484 }

485 }

486 return $hash;

487 }

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

489 }

490

491 #################################################################