typo.
[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
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 # 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'
23
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 };
31
32 {
33   package CredUserAgent;
34   @ISA = qw(LWP::UserAgent);
35
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;
46
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 }
67
68 my $ua = CredUserAgent->new (keep_alive => 1);
69
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 }
77
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 }
85
86 $cfg->{apiurl}  ||= 'https://api.opensuse.org';
87 $cfg->{project} ||= '<Project>';
88 $cfg->{package} ||= '<Package>';
89
90 chomp $cfg->{apiurl};
91 chomp $cfg->{project};
92 chomp $cfg->{package};
93
94 my $source = "$cfg->{apiurl}/source";
95 my $url = "$source/$cfg->{project}/$cfg->{package}";
96
97 if (my $url = $ARGV[0])
98   {
99
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{&}{&amp;}g;
323   $text =~ s{<}{&lt;}g;
324   $text =~ s{>}{&gt;}g;
325   $text =~ s{"}{&quot;}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{&lt;}{<}g;
337   $text =~ s{&gt;}{>}g;
338   $text =~ s{&quot;}{"}g;
339   $text =~ s{&amp;}{&}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 #################################################################