normalize apiurl
[opensuse:osc.git] / osc_expand_link.pl
1 #! /usr/bin/perl -w
2 #
3 # osc_expand_link.pl -- a tool to help osc build packages where an _link exists.
4 # (C) 2006 jw@suse.de, distribute under GPL v2.
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
11
12 use Data::Dumper;
13 use LWP::UserAgent;
14 use HTTP::Status;
15 use Digest::MD5;
16
17 my $version = '0.4';
18 my $verbose = 1;
19
20 print "This $0 is obsolete. Please use instead: osc co -e\n";
21 sleep 5;
22
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'
26
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 };
34
35 {
36   package CredUserAgent;
37   @ISA = qw(LWP::UserAgent);
38
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;
49
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 }
70
71 my $ua = CredUserAgent->new (keep_alive => 1);
72
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 }
80
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 }
88
89 $cfg->{apiurl}  ||= 'https://api.opensuse.org';
90 $cfg->{project} ||= '<Project>';
91 $cfg->{package} ||= '<Package>';
92
93 chomp $cfg->{apiurl};
94 chomp $cfg->{project};
95 chomp $cfg->{package};
96
97 my $source = "$cfg->{apiurl}/source";
98 my $url = "$source/$cfg->{project}/$cfg->{package}";
99
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{&}{&amp;}g;
326   $text =~ s{<}{&lt;}g;
327   $text =~ s{>}{&gt;}g;
328   $text =~ s{"}{&quot;}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{&lt;}{<}g;
340   $text =~ s{&gt;}{>}g;
341   $text =~ s{&quot;}{"}g;
342   $text =~ s{&amp;}{&}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 }