- remove setting of deprecated attributes
[opensuse:build-service.git] / src / backend / bs_srcserver
1 #!/usr/bin/perl -w
2 #
3 # Copyright (c) 2006, 2007 Michael Schroeder, Novell Inc.
4 # Copyright (c) 2008 Adrian Schroeter, Novell Inc.
5 #
6 # This program is free software; you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License version 2 as
8 # published by the Free Software Foundation.
9 #
10 # This program is distributed in the hope that it will be useful,
11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 # GNU General Public License for more details.
14 #
15 # You should have received a copy of the GNU General Public License
16 # along with this program (see the file COPYING); if not, write to the
17 # Free Software Foundation, Inc.,
18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
19 #
20 ################################################################
21 #
22 # The Source Server
23 #
24
25 BEGIN {
26   my ($wd) = $0 =~ m-(.*)/- ;
27   $wd ||= '.';
28   chdir($wd);
29   unshift @INC,  "$wd/build";
30   unshift @INC,  "$wd";
31 }
32
33 use XML::Structured ':bytes';
34 use Digest::MD5 ();
35 use Data::Dumper;
36 use Storable ();
37 use Symbol;
38
39 use BSConfig;
40 use BSRPC ':https';
41 use BSServer;
42 use BSUtil;
43 use BSFileDB;
44 use BSXML;
45 use BSVerify;
46 use BSHandoff;
47 use BSWatcher ':https';
48 use BSXPath;
49 use BSStdServer;
50 use BSSrcdiff;
51 use Build;
52 use BSHermes;
53
54 use BSXPath;
55 use BSXPathKeys;
56 use BSDB;
57 use BSDBIndex;
58
59 use strict;
60
61 my $port = 5352;        #'SR'
62 $port = $1 if $BSConfig::srcserver =~ /:(\d+)$/;
63
64 my $projectsdir = "$BSConfig::bsdir/projects";
65 my $eventdir = "$BSConfig::bsdir/events";
66 my $srcrep = "$BSConfig::bsdir/sources";
67 my $requestsdir = "$BSConfig::bsdir/requests";
68 my $rundir = $BSConfig::rundir || "$BSConfig::bsdir/run";
69 my $diffcache = "$BSConfig::bsdir/diffcache";
70
71 my $reqindexdb = "$BSConfig::bsdir/db/request";
72 my $extrepodb = "$BSConfig::bsdir/db/published";
73
74 my $remotecache = "$BSConfig::bsdir/remotecache";
75
76 my $srcrevlay = [qw{rev vrev srcmd5 version time user comment requestid}];
77 my $eventlay = [qw{number time type project package repository arch}];
78
79 my $ajaxsocket = "$rundir/bs_srcserver.ajax";
80 my $uploaddir = "$srcrep/:upload";
81
82 my %packagequota;
83
84 sub notify_repservers {
85   my ($type, $projid, $packid) = @_;
86
87   my $ev = {'type' => $type, 'project' => $projid};
88   $ev->{'package'} = $packid if defined $packid;
89   addevent($ev);
90
91   my @args = ("type=$type", "project=$projid");
92   push @args, "package=$packid" if defined $packid;
93   for my $rrserver ($BSConfig::reposerver) {
94     eval {
95       BSRPC::rpc("$rrserver/event", undef, @args);
96     };
97     print "warning: $rrserver: $@" if $@;
98   }
99 }
100
101 sub sourceupdate {
102   my ($projid, $packid, $lockfile) = @_;
103
104   return unless $BSConfig::serviceserver;
105   die("No project defined for source update!") if !defined $projid;
106   die("No package defined for source update!") if !defined $packid;
107   # collect current sources to POST them
108   my $rev = getrev($projid, $packid);
109   my $files = lsrev($rev);
110   my @send = map {{'name' => $_, 'filename' => "$srcrep/$packid/$files->{$_}-$_"}} sort(keys %$files);
111   # Run the source update in own process (do not wait for it)
112   my $pid;
113   if (!($pid = xfork())) {
114     my $odir = "$srcrep/:service/$$";
115     BSUtil::cleandir($odir) if -d $odir;
116     mkdir_p($odir);
117     my $receive = BSRPC::rpc({
118       'uri'       => "$BSConfig::serviceserver/sourceupdate/$projid/$packid",
119       'request'   => 'POST',
120       'headers'   => [ 'Content-Type: application/x-cpio' ],
121       'chunked'   => 1,
122       'data'      => \&BSHTTP::cpio_sender,
123       'cpiofiles' => \@send,
124       'directory' => $odir,
125       'timeout'   => 60,
126       'withmd5'   => 1,
127       'receiver:application/x-cpio' => \&BSHTTP::cpio_receiver,
128     }, undef);
129
130     # and update source repository with the result
131     if ($receive) {
132       my $files = lsrev($rev);
133       # drop all existing service files
134       for my $pfile (keys %$files) {
135         delete $files->{$pfile} if $pfile =~ /^_service[_:]/;
136       }
137       # add new service files
138 #      for my $pfile (map {$_->{'name'} => 1} @$receive) {    # }
139       for my $pfile (ls($odir)) {
140         die("ERROR: bs_service returned a non-_service file\n") unless $pfile =~ /^_service[_:]/;
141         $files->{$pfile} = addfile($projid, $packid, "$odir/$pfile", $pfile);
142       }
143       addrev($projid, $packid, $files, "_service", "generated via source service", undef);
144       rmdir($odir);
145       unlink($lockfile);
146       notify_repservers('package', $projid, $packid);
147     } else {
148       rmdir($odir);
149       unlink($lockfile);
150       die("ERROR: empty source result from service, not even a _service_error\n");
151     }
152   }
153 }
154
155
156 #
157 # run the productconverter on _product to create/update/delete
158 # all _product:xxx packages
159 #
160 sub expandproduct {
161   my ($projid, $packid, $files, $user, $fail) = @_;
162
163   if (!$files) {
164     # gone!
165     my @packages = grep {/^\Q${packid}:\E/} findpackages($projid);
166     for my $opid (@packages) {
167       unlink("$projectsdir/$projid.pkg/$opid.upload-MD5SUMS");
168       unlink("$projectsdir/$projid.pkg/$opid.rev");
169       unlink("$projectsdir/$projid.pkg/$opid.xml");
170       notify_repservers('package', $projid, $opid);
171     }
172     return 1;
173   }
174   my $dir = "$uploaddir/expandproduct_$$";
175   BSUtil::cleandir($dir);
176   mkdir_p($dir);
177   for my $file (sort keys %$files) {
178     link("$srcrep/$packid/$files->{$file}-$file", "$dir/$file") || die("link $srcrep/$packid/$files->{$file}-$file $dir/$file: $!\n");
179   }
180   my @prods = grep {/.product$/}  sort keys %$files;
181   my %pids;
182   for my $prod (@prods) {
183     print "converting product $prod\n";
184     my $odir = "$dir/$prod.out";
185     my $olog = "$dir/$prod.logfile";
186     system('rm', '-rf', $odir) if -d $odir;
187     unlink($olog) if -e $olog;
188     mkdir_p($odir);
189     # run product converter and read stdout
190     my $pid;
191     if (!($pid = xfork())) {
192       delete $SIG{'__DIE__'};
193       open(STDOUT, '>>', $olog) || die("$olog: $!\n");
194       open(STDERR, '>&STDOUT');
195       $| = 1;
196       exec("./bs_productconvert", "$dir/$prod", $odir, $projid);
197       die("bs_productconvert: $!\n");
198     }
199     waitpid($pid, 0) == $pid || die("waitpid $pid: $!\n");
200     if ($?) {
201       my $s = readstr($olog);
202       warn("bs_productconvert failed: $?\n");
203       BSUtil::cleandir($dir);
204       rmdir($dir);
205       die($s) if $fail;
206       return undef;
207     }
208     my @out = sort(ls($odir));
209     if (!@out) {
210       warn("bs_productconvert produced nothing\n");
211       BSUtil::cleandir($dir);
212       rmdir($dir);
213       return undef;
214     }
215     for my $p (@out) {
216       my $pdir = "$odir/$p";
217       my $pid = $p;
218       $pid =~ s/^_product[_:]//;
219       $pid =~ s/[:\000-\037]/_/sg;
220       $pid = "$packid:$pid";
221       $pids{$pid} = 1;
222       my %pfiles;
223       for my $pfile (sort(ls($pdir))) {
224         next if $pfile eq '_meta';
225         $pfiles{$pfile} = addfile($projid, $pid, "$pdir/$pfile", $pfile);
226       }
227       my $srcmd5 = addmeta($projid, $pid, \%pfiles);
228       my @oldrevs = BSFileDB::fdb_getall("$projectsdir/$projid.pkg/$pid.rev", $srcrevlay);
229       if (@oldrevs == 1 && $oldrevs[0]->{'srcmd5'} eq $srcmd5 && $oldrevs[0]->{'rev'}) {
230         # we're lucky, no change
231         next;
232       }
233       mkdir_p("$projectsdir/$projid.pkg");
234       my $prev = {'srcmd5' => $srcmd5, 'time' => time(), 'user' => $user, 'comment' => 'autogenerated', 'version' => '1', 'vrev' => '1'};
235       unlink("$projectsdir/$projid.pkg/$pid.rev");
236       BSFileDB::fdb_add_i("$projectsdir/$projid.pkg/$pid.rev", $srcrevlay, $prev);
237       if (! -e "$projectsdir/$projid.pkg/$pid.xml") {
238         my $pidpack = {
239          'name' => $pid,
240          'title' => $pid,
241          'description' => "autogenerated from $packid by source server",
242         };
243         $pidpack = readxml("$pdir/_meta", $BSXML::pack, 0) if ( -e "$pdir/_meta" );
244         writexml("$projectsdir/$projid.pkg/.$pid.xml", "$projectsdir/$projid.pkg/$pid.xml", $pidpack, $BSXML::pack);
245       }
246       rmdir($pdir);
247       notify_repservers('package', $projid, $pid);
248     }
249     rmdir($odir);
250   }
251   BSUtil::cleandir($dir);
252   rmdir($dir);
253   # now do away with the old packages
254   my @packages = grep {/^\Q${packid}:\E/} findpackages($projid);
255   @packages = grep {!$pids{$_}} @packages;
256   for my $opid (@packages) {
257     unlink("$projectsdir/$projid.pkg/$opid.upload-MD5SUMS");
258     unlink("$projectsdir/$projid.pkg/$opid.rev");
259     unlink("$projectsdir/$projid.pkg/$opid.xml");
260     notify_repservers('package', $projid, $opid);
261   }
262   return 1;
263 }
264
265 #
266 # return version and release of commit
267 #
268 sub getcommitinfo {
269   my ($projid, $packid, $srcmd5, $files) = @_;
270
271   # get version/release from rpm spec/deb dsc/kiwi xml file
272   my $version = 'unknown';
273   my $release;
274   my $bconf = Build::read_config('noarch');
275   for my $type ('spec', 'dsc', 'kiwi') {
276     my $rev = {'project' => $projid, 'package' => $packid, 'srcmd5' => $srcmd5};
277     my $file = findfile($rev, undef, $type, $files);
278     next unless defined $file;
279     my $d = Build::parse($bconf, "$srcrep/$packid/$files->{$file}-$file");
280     next unless defined $d->{'version'};
281     $version = $d->{'version'};
282     $release = $d->{'release'} if defined $d->{'release'};
283     last;
284   }
285   if (defined($release)) {
286     if ($release =~ /(\d+)\.<B_CNT>/) {
287       $release = $1;
288     } elsif ($release =~ /<RELEASE(\d+)>/) {
289       $release = $1;
290     } elsif ($release =~ /^(\d+)/) {
291       $release = $1;
292     } else {
293       $release = '0';
294     }
295   }
296   $release ||= '0';
297   return ($version, $release);
298 }
299
300
301 ###########################################################################
302 ###
303 ###  low level source handling: tree and revision management
304 ###
305
306 #
307 # add a file to the repository
308 #
309 sub addfile {
310   my ($projid, $packid, $tmpfile, $filename, $md5) = @_;
311
312   if (!$md5) {
313     open(F, '<', $tmpfile) || die("$tmpfile: $!\n");
314     my $ctx = Digest::MD5->new;
315     $ctx->addfile(*F);
316     close F;
317     $md5 = $ctx->hexdigest();
318   }
319   if (! -e "$srcrep/$packid/$md5-$filename") {
320     if (!rename($tmpfile, "$srcrep/$packid/$md5-$filename")) {
321       mkdir_p("$srcrep/$packid");
322       rename($tmpfile, "$srcrep/$packid/$md5-$filename") || die("rename $tmpfile $srcrep/$packid/$md5-$filename: $!\n");
323     }
324   } else {
325     unlink($tmpfile);
326   }
327   return $md5;
328 }
329
330 #
331 # make files available in oprojid/opackid available from projid/packid
332 #
333 sub copyfiles {
334   my ($projid, $packid, $oprojid, $opackid, $files, $except) = @_;
335
336   return if $packid eq $opackid;
337   return unless %$files;
338   mkdir_p("$srcrep/$packid");
339   for my $f (sort keys %$files) {
340     next if $except && $except->{$f};
341     next if -e "$srcrep/$packid/$files->{$f}-$f";
342     link("$srcrep/$opackid/$files->{$f}-$f", "$srcrep/$packid/$files->{$f}-$f");
343     die("link error $srcrep/$opackid/$files->{$f}-$f\n") unless -e "$srcrep/$packid/$files->{$f}-$f";
344   }
345 }
346
347 #
348 # get a revision object from a revision identifier
349 #
350 sub getrev {
351   my ($projid, $packid, $rev) = @_;
352   die("bad projid\n") if $projid =~ /\// || $projid =~ /^\./;
353   return {'project' => $projid, 'package' => $packid, 'srcmd5' => 'pattern', 'rev' => 'pattern'} if $packid eq '_pattern';
354   die("bad packid\n") if $packid =~ /\// || $packid =~ /^\./;
355   if (! -e "$projectsdir/$projid.pkg/$packid.xml") {
356     return remote_getrev($projid, $packid, $rev);
357   }
358   undef $rev if $rev && ($rev eq 'latest' || $rev eq 'build');
359   undef $rev if $rev && $rev eq 'upload' && ! -e "$projectsdir/$projid.pkg/$packid.upload-MD5SUMS";
360   if (!defined($rev)) {
361     $rev = BSFileDB::fdb_getlast("$projectsdir/$projid.pkg/$packid.rev", $srcrevlay);
362     $rev = {'srcmd5' => 'empty'} unless $rev;
363   } elsif ($rev =~ /^[0-9a-f]{32}$/) {
364     return undef unless -e "$projectsdir/$projid.pkg/$packid.rev";
365     $rev = {'srcmd5' => $rev, 'rev' => $rev};
366   } elsif ($rev eq 'upload') {
367     $rev = {'srcmd5' => 'upload', 'rev' => 'upload'}
368   } elsif ($rev eq 'repository') {
369     $rev = {'srcmd5' => 'empty', 'rev' => 'repository'}
370   } else {
371     $rev = BSFileDB::fdb_getmatch("$projectsdir/$projid.pkg/$packid.rev", $srcrevlay, 'rev', $rev);
372   }
373   $rev->{'project'} = $projid;
374   $rev->{'package'} = $packid;
375   return $rev;
376 }
377
378 sub addmeta {
379   my ($projid, $packid, $files, $rev) = @_;
380
381   # calculate new meta sum
382   my $meta = '';
383   $meta .= "$files->{$_}  $_\n" for sort keys %$files;
384   my $srcmd5 = Digest::MD5::md5_hex($meta);
385   if ($rev && $rev eq 'upload') {
386     mkdir_p($uploaddir);
387     mkdir_p("$projectsdir/$projid.pkg");
388     writestr("$uploaddir/$$", "$projectsdir/$projid.pkg/$packid.upload-MD5SUMS", $meta);
389   } elsif ($rev && $rev eq 'pattern') {
390     if ($meta ne '') {
391       mkdir_p($uploaddir);
392       mkdir_p("$projectsdir/$projid.pkg");
393       writestr("$uploaddir/$$", "$projectsdir/$projid.pkg/pattern-MD5SUMS", $meta);
394     } else {
395       unlink("$projectsdir/$projid.pkg/pattern-MD5SUMS");
396     }
397   } elsif (! -e "$srcrep/$packid/$srcmd5-MD5SUMS") {
398     mkdir_p($uploaddir);
399     mkdir_p("$srcrep/$packid");
400     writestr("$uploaddir/$$", "$srcrep/$packid/$srcmd5-MD5SUMS", $meta);
401   }
402   return $srcmd5;
403 }
404
405 # like addmeta, but adds link information. also stores
406 # under the "wrong" md5sum.
407 sub addmeta_link {
408   my ($projid, $packid, $files, $srcmd5, $linkinfo) = @_;
409
410   if (! -e "$srcrep/$packid/$srcmd5-MD5SUMS") {
411     my $meta = '';
412     $meta .= "$files->{$_}  $_\n" for sort keys %$files;
413     $meta .= "$linkinfo->{'srcmd5'}  /LINK\n";
414     $meta .= "$linkinfo->{'lsrcmd5'}  /LOCAL\n";
415     mkdir_p($uploaddir);
416     mkdir_p("$srcrep/$packid");
417     writestr("$uploaddir/$$", "$srcrep/$packid/$srcmd5-MD5SUMS", $meta);
418   }
419 }
420
421
422 #
423 # create a new revision from a file list, returns revision object
424 #
425 sub addrev {
426   my ($projid, $packid, $files, $user, $comment, $target, $requestid) = @_;
427   die("project '$projid' does not exist\n") unless -e "$projectsdir/$projid.xml";
428   if ($packid eq '_pattern') {
429     my $srcmd5 = addmeta($projid, $packid, $files, 'pattern');
430     notify_repservers('project', $projid);
431     return {'project' => $projid, 'package' => $packid, 'rev' => 'pattern', 'srcmd5' => $srcmd5};
432   }
433   die("package '$packid' is read-only\n") if $packid =~ /^_product:/;
434   die("package '$packid' does not exist\n") unless -e "$projectsdir/$projid.pkg/$packid.xml";
435   if ($target && $target eq 'upload') {
436     my $srcmd5 = addmeta($projid, $packid, $files, 'upload');
437     my $filename = (keys %$files)[0];
438     BSHermes::notify("SRCSRV_UPLOAD", {project => $projid, package => $packid, filename => $filename, user => $user});
439     return {'project' => $projid, 'package' => $packid, 'rev' => 'upload', 'srcmd5' => $srcmd5};
440   } elsif ($target && $target eq 'repository') {
441     # repository only upload.
442     return {'project' => $projid, 'package' => $packid, 'rev' => 'repository', 'srcmd5' => 'empty'};
443   } elsif (defined($target)) {
444     # internal version only upload.
445     my $srcmd5 = addmeta($projid, $packid, $files);
446     return {'project' => $projid, 'package' => $packid, 'rev' => $srcmd5, 'srcmd5' => $srcmd5};
447   }
448   die("bad projid\n") if $projid =~ /\// || $projid =~ /^\./;
449   die("bad packid\n") if $packid =~ /\// || $packid =~ /^\./;
450   die("bad files\n") if grep {/\//} keys %$files;
451   die("bad files\n") if grep {!/^[0-9a-f]{32}$/} values %$files;
452
453   if ($packid eq '_product') {
454     expandproduct($projid, $packid, $files, $user, 1);
455   } elsif ($packid =~ /^_patchinfo:/) {
456     # FIXME: we may should allow source links (with diff) here
457     die("bad files in patchinfo container\n") if grep {$_ ne '_patchinfo'} keys %$files;
458     if ($files->{'_patchinfo'}) {
459       my $p = readxml("$srcrep/$packid/$files->{'_patchinfo'}-_patchinfo", $BSXML::patchinfo);
460       BSVerify::verify_patchinfo($p);
461     }
462   }
463
464   my $srcmd5 = addmeta($projid, $packid, $files);
465   my ($version, $release) = getcommitinfo($projid, $packid, $srcmd5, $files);
466   $user = str2utf8($user) if $user;
467   $comment = str2utf8($comment) if $comment;
468   my $rev = {'srcmd5' => $srcmd5, 'time' => time(), 'user' => $user, 'comment' => $comment, 'version' => $version, 'vrev' => $release, 'requestid' => $requestid};
469   
470   my $rev_old = getrev($projid, $packid);
471   my $files_old = lsrev($rev_old);
472   my $filestr = BSHermes::generate_commit_flist($files_old, $files);
473
474   $rev = BSFileDB::fdb_add_i2("$projectsdir/$projid.pkg/$packid.rev", $srcrevlay, $rev, 'vrev', 'version', $version);
475
476   # send out hermes notification
477   BSHermes::notify("SRCSRV_COMMIT", {project => $projid, package => $packid, files => $filestr, rev => $rev->{'rev'}, user => $user, comment => $comment});
478   $rev_old->{'version'} = "unknown" unless defined($rev_old->{'version'});
479   BSHermes::notify("SRCSRV_VERSION_CHANGE", {project => $projid, package => $packid, files => $filestr, rev => $rev->{'rev'},
480                                              oldversion => $rev_old->{'version'}, newversion => $version, user => $user, comment => $comment})
481     if $version ne $rev_old->{'version'};
482
483   # add missing data to complete the revision object
484   $rev->{'project'} = $projid;
485   $rev->{'package'} = $packid;
486
487   # kill upload revision as we did a real commit
488   unlink("$projectsdir/$projid.pkg/$packid.upload-MD5SUMS");
489
490   notify_repservers('package', $projid, $packid);
491   return $rev;
492 }
493
494 #
495 # retrieve the file list of a revision object or tree object
496 # store merge info in linkinfo if available
497 #
498 sub lsrev {
499   my ($rev, $linkinfo) = @_;
500
501   die("nothing known\n") unless $rev;
502   my $projid = $rev->{'project'};
503   my $packid = $rev->{'package'};
504   my $srcmd5 = $rev->{'srcmd5'};
505   die("revision project missing\n") unless defined $projid;
506   die("revision package missing\n") unless defined $packid;
507   die("no such revision\n") unless defined $srcmd5;
508   local *F;
509   die("bad packid\n") if $packid =~ /\// || $packid =~ /^\./;
510   if ($srcmd5 eq 'upload') {
511     open(F, '<', "$projectsdir/$projid.pkg/$packid.upload-MD5SUMS") || die("$packid/$srcmd5-$packid: not in repository\n");
512   } elsif ($srcmd5 eq 'pattern') {
513     open(F, '<', "$projectsdir/$projid.pkg/pattern-MD5SUMS") || return {};
514   } elsif ($srcmd5 eq 'empty' || $srcmd5 eq 'd41d8cd98f00b204e9800998ecf8427e') {
515     return {};
516   } else {
517     die("bad srcmd5 '$srcmd5'\n") if $srcmd5 !~ /^[0-9a-f]{32}$/;
518     if (!open(F, '<', "$srcrep/$packid/$srcmd5-MD5SUMS")) {
519       return {'_linkerror' => $srcmd5} if -e "$srcrep/$packid/$srcmd5-_linkerror";
520       die("$packid/$srcmd5-$packid: not in repository\n");
521     }
522   }
523   my @files = <F>;
524   close F;
525   chomp @files;
526   my $files = {map {substr($_, 34) => substr($_, 0, 32)} @files};
527   if ($linkinfo) {
528     $linkinfo->{'lsrcmd5'} = $files->{'/LOCAL'} if $files->{'/LOCAL'};
529     $linkinfo->{'srcmd5'} = $files->{'/LINK'} if $files->{'/LINK'};
530   }
531   delete $files->{'/LINK'};
532   delete $files->{'/LOCAL'};
533   return $files;
534 }
535
536
537 # find last revision that consisted of the tree object
538 sub findlastrev {
539   my ($tree) = @_;
540   my $rev = BSFileDB::fdb_getmatch("$projectsdir/$tree->{'project'}.pkg/$tree->{'package'}.rev", $srcrevlay, 'srcmd5', $tree->{'srcmd5'});
541   return undef unless $rev;
542   $rev->{'project'} = $tree->{'project'};
543   $rev->{'package'} = $tree->{'package'};
544   return $rev;
545 }
546
547
548
549 ###########################################################################
550 ###
551 ###  source link handling
552 ###
553
554 sub patchspec {
555   my ($p, $dir, $spec) = @_;
556   local *F;
557   open(F, '<', "$dir/$spec") || die("$dir/$spec: $!\n");
558   my @preamble;
559   while(<F>) {
560     chomp;
561     push @preamble, $_;
562     last if /^\s*%(package|prep|build|install|check|clean|preun|postun|pretrans|posttrans|pre|post|files|changelog|description|triggerpostun|triggerun|triggerin|trigger|verifyscript)(\s|$)/;
563   }
564   my %patches;
565   for (@preamble) {
566     next unless /^patch(\d*)\s*:/i;  
567     $patches{0 + ($1 eq '' ? 0 : $1)} = $_;
568   }
569   my @patches = sort {$a <=> $b} keys %patches;
570   my $nr = 0;
571   if (exists $p->{'after'}) {
572     $nr = 0 + $p->{'after'};
573     $nr++ while $patches{$nr};
574   } else {
575     $nr = $patches[-1] + 1 if @patches;
576   }
577   my @after;
578   @after = map {$patches{$_}} grep {$_ < $nr} @patches if @patches;
579   @after = grep {/^source(\d*)\s*:/i} @preamble if !@after;
580   @after = grep {/^name(\d*)\s*:/i} @preamble if !@after;
581   @after = $preamble[-2] if @preamble > 1 && !@after;
582   return "could not find a place to insert the patch" if !@after;
583   my $nrx = $nr;
584   $nrx = '' if $nrx == 0;
585   local *O;
586   open(O, '>', "$dir/.patchspec$$") || die("$dir/.patchspec$$: $!\n");
587   for (@preamble) {
588     print O "$_\n";
589     next unless @after && $_ eq $after[-1];
590     print O "Patch$nrx: $p->{'name'}\n";
591     @after = ();
592   }
593   if ($preamble[-1] !~ /^\s*%prep(\s|$)/) {
594     while (1) {
595       my $l = <F>;
596       return "specfile has no %prep section" if !defined $l;
597       chomp $l;
598       print O "$l\n";
599       last if $l =~ /^\s*%prep(\s|$)/;
600     }
601   }
602   my @prep;
603   while(<F>) {
604     chomp;
605     push @prep, $_;
606     last if /^\s*%(package|prep|build|install|check|clean|preun|postun|pretrans|posttrans|pre|post|files|changelog|description|triggerpostun|triggerun|triggerin|trigger|verifyscript)(\s|$)/;
607   }
608   %patches = ();
609   my $ln = -1;
610   # find outmost pushd/popd calls and insert new patches after a pushd/popd block
611   # $blevel == 0 indicates the outmost block
612   my %bend = ();
613   my $bln = undef;
614   $$bln = $ln;
615   my $blevel = -1;
616   for (@prep) {
617     $ln++;
618     $blevel++ if /^pushd/;
619     if (/^popd/) {
620       unless ($blevel) {
621         $$bln = $ln;
622         undef $bln;
623         $$bln = $ln;
624       }
625       $blevel--;
626     }
627     next unless /%patch(\d*)(.*)/;
628     if ($1 ne '') {
629       $patches{0 + $1} = $ln;
630       $bend{0 + $1} = $bln if $blevel >= 0;
631       next;
632     }
633     my $pnum = 0;
634     my @a = split(' ', $2);
635     if (! grep {$_ eq '-P'} @a) {
636       $patches{$pnum} = $ln;
637     } else {
638       while (@a) {
639         next if shift(@a) ne '-P';
640         next if !@a || $a[0] !~ /^\d+$/;
641         $pnum = 0 + shift(@a);
642         $patches{$pnum} = $ln;
643       }
644     }
645     $bend{$pnum} = $bln if $blevel >= 0;
646   }
647   return "specfile has broken %prep section" unless $blevel == -1;
648   @patches = sort {$a <=> $b} keys %patches;
649   $nr = 1 + $p->{'after'} if exists $p->{'after'};
650   %patches = map { $_ => exists $bend{$_} ? ${$bend{$_}} : $patches{$_} } @patches;
651   @after = map {$patches{$_}} grep {$_ < $nr} @patches if @patches;
652   @after = ($patches[0] - 1) if !@after && @patches;
653   @after = (@prep - 2) if !@after;
654   my $after = $after[-1];
655   $after = -1 if $after < -1;
656   $ln = -1;
657   push @prep, '' if $after >= @prep;
658   #print "insert %patch after line $after\n";
659   for (@prep) {
660     if (defined($after) && $ln == $after) {
661       print O "pushd $p->{'dir'}\n" if exists $p->{'dir'};
662       if ($p->{'popt'}) {
663         print O "%patch$nrx -p$p->{'popt'}\n";
664       } else {
665         print O "%patch$nrx\n";
666       }
667       print O "popd\n" if exists $p->{'dir'};
668       undef $after;
669     }
670     print O "$_\n";
671     $ln++;
672   }
673   while(<F>) {
674     chomp;
675     print O "$_\n";
676   }
677   close(O) || die("close: $!\n");
678   rename("$dir/.patchspec$$", "$dir/$spec") || die("rename $dir/.patchspec$$ $dir/$spec: $!\n");
679   return '';
680 }
681 # " Make emacs wired syntax highlighting happy
682
683 sub topaddspec {
684   my ($p, $dir, $spec) = @_;
685   local (*F, *O);
686   open(F, '<', "$dir/$spec") || die("$dir/$spec: $!\n");
687   open(O, '>', "$dir/.topaddspec$$") || die("$dir/.topaddspec$$: $!\n");
688   my $text = $p->{'text'};
689   $text = '' if !defined $text;
690   $text .= "\n" if $text ne '' && substr($text, -1, 1) ne "\n";
691   print O $text;
692   while(<F>) {
693     chomp;
694     print O "$_\n";
695   }
696   close(O) || die("close: $!\n");
697   rename("$dir/.topaddspec$$", "$dir/$spec") || die("rename $dir/.topaddspec$$ $dir/$spec: $!\n");
698 }
699
700 #
701 # apply a single link step
702 # store the result under the identifier "$md5"
703 #
704 # if "$md5" is not set, store the result in "$uploaddir/applylink$$"
705 #
706 sub applylink {
707   my ($md5, $lsrc, $llnk) = @_;
708   if ($md5 && -e "$srcrep/$llnk->{'package'}/$md5-_linkerror") {
709     # no need to do all the work again...
710     my $log = readstr("$srcrep/$llnk->{'package'}/$md5-_linkerror", 1);
711     $log ||= "unknown error";
712     chomp $log;
713     $log =~ s/.*\n//s;
714     $log ||= "unknown error";
715     return $log;
716   }
717   my $flnk = lsrev($llnk);
718   my $fsrc = lsrev($lsrc);
719   my $l = $llnk->{'link'};
720   my $patches = $l->{'patches'} || {};
721   my @patches = ();
722   my $simple = 1;
723   my @simple_delete;
724   my $isbranch;
725   if ($l->{'patches'}) {
726     for (@{$l->{'patches'}->{''} || []}) {
727       my $type = (keys %$_)[0];
728       if (!$type) {
729         $simple = 0;
730         next;
731       }
732       if ($type eq 'topadd') {
733         push @patches, { 'type' => $type, 'text' => $_->{$type}};
734         $simple = 0;
735       } elsif ($type eq 'delete') {
736         push @patches, { 'type' => $type, %{$_->{$type} || {}}};
737         push @simple_delete, $patches[-1]->{'name'};
738       } else {
739         push @patches, { 'type' => $type, %{$_->{$type} || {}}};
740         $simple = 0;
741         $isbranch = 1 if $type eq 'branch';
742       }
743     }
744   }
745   $simple = 0 unless $md5;
746   if ($simple) {
747     # simple source link with no patching
748     # copy all files but the ones we have locally
749     copyfiles($llnk->{'project'}, $llnk->{'package'}, $lsrc->{'project'}, $lsrc->{'package'}, $fsrc, $flnk);
750     # calculate meta
751     my $newf = { %$fsrc };
752     for my $f (sort keys %$flnk) {
753       $newf->{$f} = $flnk->{$f} unless $f eq '_link';
754     }
755     delete $newf->{$_} for @simple_delete;
756     # store filelist in md5
757     my $linkinfo = {
758       'srcmd5'  => $lsrc->{'srcmd5'},
759       'lsrcmd5' => $llnk->{'srcmd5'},
760     };
761     addmeta_link($llnk->{'project'}, $llnk->{'package'}, $newf, $md5, $linkinfo);
762     return '';
763   }
764
765   # sanity checking...
766   for my $p (@patches) {
767     return "patch has no type" unless exists $p->{'type'};
768     return "patch has illegal type \'$p->{'type'}\'" unless $p->{'type'} eq 'apply' || $p->{'type'} eq 'add' || $p->{'type'} eq 'topadd' || $p->{'type'} eq 'delete' || $p->{'type'} eq 'branch';
769     if ($p->{'type'} ne 'topadd' && $p->{'type'} ne 'delete' && $p->{'type'} ne 'branch') {
770       return "patch has no patchfile" unless exists $p->{'name'};
771       return "patch \'$p->{'name'}\' does not exist" unless $flnk->{$p->{'name'}};
772     }
773   }
774   my $tmpdir = "$uploaddir/applylink$$";
775   mkdir_p($tmpdir);
776   die("$tmpdir: $!\n") unless -d $tmpdir;
777   unlink("$tmpdir/$_") for ls($tmpdir); # remove old stuff
778   my %apply = map {$_->{'name'} => 1} grep {$_->{'type'} eq 'apply'} @patches;
779   $apply{$_} = 1 for keys %{$llnk->{'ignore'} || {}};   # also ignore those files, used in keeplink
780   my %fl;
781   if (!$isbranch) {
782     for my $f (sort keys %$fsrc) {
783       next if $flnk->{$f} && !$apply{$f};
784       link("$srcrep/$lsrc->{'package'}/$fsrc->{$f}-$f", "$tmpdir/$f") || die("$f: $!\n");
785       $fl{$f} = "$lsrc->{'package'}/$fsrc->{$f}-$f";
786     }
787     for my $f (sort keys %$flnk) {
788       next if $apply{$f} || $f eq '_link';
789       link("$srcrep/$llnk->{'package'}/$flnk->{$f}-$f", "$tmpdir/$f") || die("$f: $!\n");
790       $fl{$f} = "$llnk->{'package'}/$flnk->{$f}-$f";
791     }
792   }
793   my $failed;
794   for my $p (@patches) {
795     my $pn = $p->{'name'};
796     if ($p->{'type'} eq 'delete') {
797       unlink("$tmpdir/$pn");
798       next;
799     }
800     if ($p->{'type'} eq 'branch') {
801       # flnk: mine
802       # fbas: old
803       # fsrc: new
804       my $baserev = $l->{'baserev'};
805       return "no baserev in branch patch" unless $baserev;
806       return "baserev is not srcmd5" unless $baserev =~ /^[0-9a-f]{32}$/s;
807       my %brev = (%$lsrc, 'srcmd5' => $baserev);
808       my $fbas = lsrev(\%brev);
809       return "baserev is link" if $fbas->{'link'};
810       # do 3-way merge
811       my %destnames = (%$fsrc, %$flnk);
812       delete $destnames{'_link'};
813       for my $f (sort {length($a) <=> length($b) || $a cmp $b} keys %destnames) {
814         my $mbas = $fbas->{$f} || '';
815         my $msrc = $fsrc->{$f} || '';
816         my $mlnk = $flnk->{$f} || '';
817         if ($mbas eq $mlnk) {
818           next if $msrc eq '';
819           link("$srcrep/$lsrc->{'package'}/$fsrc->{$f}-$f", "$tmpdir/$f") || die("$fsrc->{$f}-$f: $!\n");
820           $fl{$f} = "$lsrc->{'package'}/$fsrc->{$f}-$f";
821           next;
822         }
823         if ($mbas eq $msrc || $mlnk eq $msrc) {
824           next if $mlnk eq '';
825           link("$srcrep/$llnk->{'package'}/$flnk->{$f}-$f", "$tmpdir/$f") || die("$flnk->{$f}-$f: $!\n");
826           $fl{$f} = "$llnk->{'package'}/$flnk->{$f}-$f";
827           next;
828         }
829         if ($mbas eq '' || $msrc eq '' || $mlnk eq '') {
830           $failed = "conflict in file $f";
831           last;
832         }
833         # run diff3
834         link("$srcrep/$lsrc->{'package'}/$fsrc->{$f}-$f", "$tmpdir/$f.new") || die("link $fsrc->{$f}-$f: $!\n");
835         link("$srcrep/$lsrc->{'package'}/$fbas->{$f}-$f", "$tmpdir/$f.old") || die("link $fbas->{$f}-$f: $!\n");
836         link("$srcrep/$llnk->{'package'}/$flnk->{$f}-$f", "$tmpdir/$f.mine") || die("link $flnk->{$f}-$f: $!\n");
837         if (!isascii("$tmpdir/$f.new") || !isascii("$tmpdir/$f.old") || !isascii("$tmpdir/$f.mine")) {
838           $failed = "conflict in file $f";
839           last;
840         }
841         my $pid;
842         if (!($pid = xfork())) {
843           delete $SIG{'__DIE__'};
844           chdir($tmpdir) || die("$tmpdir: $!\n");
845           open(STDERR, '>>', ".log") || die(".log: $!\n");
846           open(STDOUT, '>', $f) || die("$f: $!\n");
847           print STDERR "running diff3 on $f\n";
848           exec('/usr/bin/diff3', '-m', "$f.mine", "$f.old", "$f.new");
849           die("/usr/bin/diff3: $!\n");
850         }
851         waitpid($pid, 0) == $pid || die("waitpid $pid: $!\n");
852         if ($?) {
853           $failed = "conflict in file $f";
854           last;
855         }
856         unlink("$tmpdir/$f.old");
857         unlink("$tmpdir/$f.new");
858         unlink("$tmpdir/$f.mine");
859       }
860       last if $failed;
861       next;
862     }
863     if ($p->{'type'} eq 'add') {
864       for my $spec (grep {/\.spec$/} ls($tmpdir)) {
865         local *F;
866         open(F, '>>', "$tmpdir/.log") || die("$tmpdir/.log: $!\n");
867         print F "adding patch $pn to $spec\n";
868         close F;
869         my $err = patchspec($p, $tmpdir, $spec);
870         if ($err) {
871           open(F, '>>', "$tmpdir/.log") || die("$tmpdir/.log: $!\n");
872           print F "error: $err\n";
873           close F;
874           $failed = "could not add patch '$pn'";
875           last;
876           unlink("$tmpdir/$_") for ls($tmpdir);
877           rmdir($tmpdir);
878           return "could not add patch '$pn'";
879         }
880         delete $fl{$spec};
881       }
882       last if $failed;
883       next;
884     }
885     if ($p->{'type'} eq 'topadd') {
886       for my $spec (grep {/\.spec$/} ls($tmpdir)) {
887         local *F;
888         open(F, '>>', "$tmpdir/.log") || die("$tmpdir/.log: $!\n");
889         print F "adding text at top of $spec\n";
890         close F;
891         topaddspec($p, $tmpdir, $spec);
892         delete $fl{$spec};
893       }
894       next;
895     }
896     next unless $p->{'type'} eq 'apply';
897     my $pid;
898     if (!($pid = xfork())) {
899       delete $SIG{'__DIE__'};
900       chdir($tmpdir) || die("$tmpdir: $!\n");
901       open(STDIN, '<', "$srcrep/$llnk->{'package'}/$flnk->{$pn}-$pn") || die("$srcrep/$llnk->{'package'}/$flnk->{$pn}-$pn: $!\n");
902       open(STDOUT, '>>', ".log") || die(".log: $!\n");
903       open(STDERR, '>&STDOUT');
904       $| = 1;
905       print "applying patch $pn\n";
906       $::ENV{'TMPDIR'} = '.';
907       # FIXME: new patch is not supporting --unified-reject-files anymore
908       exec('/usr/bin/patch', '--no-backup-if-mismatch', '--unified-reject-files', '--global-reject-file=.rejects', '-g', '0', '-f');
909       die("/usr/bin/patch: $!\n");
910     }
911     waitpid($pid, 0) == $pid || die("waitpid $pid: $!\n");
912     if ($?) {
913       $failed = "could not apply patch '$pn'";
914       last;
915     }
916   }
917   if ($failed) {
918     local *F;
919     # add result as last line
920     open(F, '>>', "$tmpdir/.log") || die("$tmpdir/.log: $!\n");
921     print F "\n$failed\n";
922     close F;
923     # link error marker
924     if ($md5 && !link("$tmpdir/.log", "$srcrep/$llnk->{'package'}/$md5-_linkerror")) {
925       my $err = "link $tmpdir/.log $srcrep/$llnk->{'package'}/$md5-_linkerror: $!\n";
926       die($err) unless -e "$srcrep/$llnk->{'package'}/$md5-_linkerror";
927     }
928     unlink("$tmpdir/$_") for ls($tmpdir);
929     rmdir($tmpdir);
930     return $failed;
931   }
932   my @newf = grep {!/^\./} ls($tmpdir);
933   my $newf = {};
934   local *F;
935   for my $f (@newf) {
936     my @s = stat "$tmpdir/$f";
937     die("$tmpdir/$f: $!\n") unless @s;
938     if ($s[3] > 1 && $fl{$f}) {
939       my @s2 = stat "$srcrep/$fl{$f}";
940       die("$srcrep/$fl{$f}: $!\n") unless @s2;
941       if ("$s[0]/$s[1]" eq "$s2[0]/$s2[1]") {
942         $newf->{$f} = $fl{$f};
943         $newf->{$f} =~ s/.*\///;
944         $newf->{$f} = substr($newf->{$f}, 0, 32);
945         next;
946       }
947     }
948     open(F, '<', "$tmpdir/$f") || die("$tmpdir/$f: $!\n");
949     my $ctx = Digest::MD5->new;
950     $ctx->addfile(*F);
951     close F;
952     $newf->{$f} = $ctx->hexdigest();
953   }
954
955   # if we just want the patched files we're finished
956   if (!$md5) {
957     # rename into md5 form, sort so that there's no collision
958     for my $f (sort {length($b) <=> length($a) || $a cmp $b} @newf) {
959       rename("$tmpdir/$f", "$tmpdir/$newf->{$f}-$f");
960     }
961     return $newf;
962   }
963
964   # otherwise link everything over
965   for my $f (@newf) {
966     addfile($llnk->{'project'}, $llnk->{'package'}, "$tmpdir/$f", $f, $newf->{$f});
967   }
968   # clean up tmpdir
969   unlink("$tmpdir/$_") for ls($tmpdir);
970   rmdir($tmpdir);
971   # store filelist
972   my $linkinfo = {
973     'srcmd5'  => $lsrc->{'srcmd5'},
974     'lsrcmd5' => $llnk->{'srcmd5'},
975   };
976   addmeta_link($llnk->{'project'}, $llnk->{'package'}, $newf, $md5, $linkinfo);
977   return '';
978 }
979
980 #
981 # expand a source link
982 # - returns expanded file list
983 # - side effects:
984 #   modifies $rev->{'srcmd5'}, $rev->{'vrev'}, $rev->{'linkrev'}
985 #   modifies $li->{'srcmd5'}, $li->{'lsrcmd5'}
986 #   modifies $li->{'linked'} if exists
987 #
988 sub handlelinks {
989   my ($rev, $files, $li) = @_;
990
991   my @linkinfo;
992   my %seen;
993   my $projid = $rev->{'project'};
994   my $packid = $rev->{'package'};
995   my $linkrev = $rev->{'linkrev'};
996   push @linkinfo, {'project' => $projid, 'package' => $packid, 'srcmd5' => $rev->{'srcmd5'}, 'rev' => $rev->{'rev'}};
997   delete $rev->{'srcmd5'};
998   delete $rev->{'linkrev'};
999   my $vrev = $rev->{'vrev'};
1000   my $vrevdone;
1001   while ($files->{'_link'}) {
1002     my $l = readxml("$srcrep/$packid/$files->{'_link'}-_link", $BSXML::link, 1);
1003     return '_link is bad' unless $l;
1004     eval {
1005       BSVerify::verify_link($l);
1006     };
1007     if ($@) {
1008       my $err = $@;
1009       $err =~ s/\n$//s;
1010       return "_link is bad: $err";
1011     }
1012     $l->{'project'} = $linkinfo[-1]->{'project'} unless exists $l->{'project'};
1013     $l->{'package'} = $linkinfo[-1]->{'package'} unless exists $l->{'package'};
1014     $linkrev = $l->{'baserev'} if $linkrev && $linkrev eq 'base';
1015     ($l->{'rev'}, $linkrev) = ($linkrev, undef) if $linkrev;
1016     $linkinfo[-1]->{'link'} = $l;
1017     $projid = $l->{'project'};
1018     $packid = $l->{'package'};
1019     my $lrev = $l->{'rev'} || '';
1020     return 'circular package link' if $seen{"$projid/$packid/$lrev"};
1021     $seen{"$projid/$packid/$lrev"} = 1;
1022     # record link target for projpack
1023     push @{$li->{'linked'}}, {'project' => $projid, 'package' => $packid} if $li && $li->{'linked'}; 
1024     eval {
1025       $lrev = getrev($projid, $packid, $l->{'rev'});
1026     };
1027     if ($@) {
1028       my $error = $@;
1029       $error =~ s/\n$//s;
1030       return "$projid $packid: $error";
1031     }
1032     return "linked package '$packid' does not exist in project '$projid'" unless $lrev;
1033     return "linked package '$packid' is empty" if $lrev->{'srcmd5'} eq 'empty';
1034     return "linked package '$packid' is strange" unless $lrev->{'srcmd5'} =~ /^[0-9a-f]{32}$/;
1035     undef $files;
1036     eval {
1037       $files = lsrev($lrev);
1038     };
1039     return 'linked package is not in repository' unless $files;
1040     my $cicount = $l->{'cicount'} || 'add';
1041     if ($cicount eq 'copy') {
1042       $rev->{'vrev'} -= $vrev unless $vrevdone;
1043     } elsif ($cicount eq 'local') {
1044       $vrevdone = 1;
1045     } elsif ($cicount ne 'add') {
1046       return '_link is bad: illegal cicount';
1047     }
1048     $vrev = $lrev->{'vrev'};
1049     $rev->{'vrev'} += $lrev->{'vrev'} unless $vrevdone;
1050     push @linkinfo, {'project' => $projid, 'package' => $packid, 'srcmd5' => $lrev->{'srcmd5'}, 'rev' => $lrev->{'rev'}};
1051   }
1052   my $md5;
1053   my $oldl;
1054   for my $l (reverse @linkinfo) {
1055     if (!$md5) {
1056       $md5 = $l->{'srcmd5'};
1057       $oldl = $l;
1058       next;
1059     }
1060     my $md5c = "$md5  /LINK\n$l->{'srcmd5'}  /LOCAL\n";
1061     $md5 = Digest::MD5::md5_hex($md5c);
1062     if (! -e "$srcrep/$l->{'package'}/$md5-MD5SUMS") {
1063       my $error = applylink($md5, $oldl, $l);
1064       if ($error) {
1065         $rev->{'srcmd5'} = $md5 if $l == $linkinfo[0];
1066         return $error;
1067       }
1068     }
1069     $l->{'srcmd5'} = $md5;
1070     $oldl = $l;
1071   }
1072   $rev->{'srcmd5'} = $md5;
1073   $files = lsrev($rev, $li);
1074   return $files;
1075 }
1076
1077 # returns expanded filelist
1078 # modifies $rev->{'srcmd5'}, $rev->{'vrev'}
1079 sub lsrev_expanded {
1080   my ($rev, $linkinfo) = @_;
1081   my $files = lsrev($rev, $linkinfo);
1082   return $files unless $files->{'_link'};
1083   $files = handlelinks($rev, $files, $linkinfo);
1084   die("$files\n") unless ref $files;
1085   return $files;
1086 }
1087
1088 # add missing target information to linkinfo
1089 sub linkinfo_addtarget {
1090   my ($rev, $linkinfo) = @_;
1091   die("linkinfo_addtarget: linkinfo contains no lsrcmd5?\n") unless $linkinfo->{'lsrcmd5'};
1092   my $files = lsrev({%$rev, 'srcmd5' => $linkinfo->{'lsrcmd5'}});
1093   die("linkinfo_addtarget: not a link?\n") unless $files->{'_link'};
1094   my $projid = $rev->{'project'};
1095   my $packid = $rev->{'package'};
1096   my $l = readxml("$srcrep/$packid/$files->{'_link'}-_link", $BSXML::link);
1097   $linkinfo->{'project'} = defined($l->{'project'}) ? $l->{'project'} : $projid;
1098   $linkinfo->{'package'} = defined($l->{'package'}) ? $l->{'package'} : $packid;
1099   $linkinfo->{'rev'} = $l->{'rev'} if $l->{'rev'};
1100   $linkinfo->{'baserev'} = $l->{'baserev'} if $l->{'baserev'};
1101 }
1102
1103 sub findlastworkinglink {
1104   my ($rev) = @_;
1105
1106   my $projid = $rev->{'project'};
1107   my $packid = $rev->{'package'};
1108   my @cand = grep {s/-MD5SUMS$//} ls("$srcrep/$packid");
1109   my %cand;
1110   for my $cand (@cand) {
1111     my $candrev = {'project' => $projid, 'package' => $packid, 'srcmd5' => $cand};
1112     my %li;
1113     my $files = lsrev($candrev, \%li);
1114     next unless $li{'lsrcmd5'} && $li{'lsrcmd5'} eq $rev->{'srcmd5'};
1115     $cand{$cand} = $li{'srcmd5'};
1116   }
1117   return undef unless %cand;
1118   @cand = sort keys %cand;
1119   return $cand[0] if @cand == 1;
1120
1121   while (1) {
1122     my $lrev = {'project' => $projid, 'package' => $packid, 'srcmd5' => $rev->{'srcmd5'}};
1123     my $lfiles = lsrev($lrev);
1124     return undef unless $lfiles;
1125     my $l = readxml("$srcrep/$packid/$lfiles->{'_link'}-_link", $BSXML::link, 1);
1126     return undef unless $l;
1127     my $projid = $l->{'project'} if exists $l->{'project'};
1128     my $packid = $l->{'package'} if exists $l->{'package'};
1129     my $lastcand;
1130     for my $cand (splice @cand) {
1131       next unless $cand{$cand};
1132       my %li;
1133       my $candrev = {'project' => $projid, 'package' => $packid, 'srcmd5' => $cand{$cand}};
1134       lsrev($candrev, \%li);
1135       $candrev->{'srcmd5'} = $li{'lsrcmd5'} if $li{'lsrcmd5'};
1136       $candrev = findlastrev($candrev);
1137       next unless $candrev;
1138       next if $lastcand && $lastcand->{'rev'} > $candrev->{'rev'};
1139       $cand{$cand} = $li{'srcmd5'} ? $li{'srcmd5'} : undef;
1140       if ($lastcand && $lastcand->{'rev'} == $candrev->{'rev'}) {
1141         push @cand, $cand;
1142         next;
1143       }
1144       @cand = ($cand);
1145       $lastcand = $candrev;
1146     }
1147     return undef unless @cand;
1148     return $cand[0] if @cand == 1;
1149     $rev = $lastcand;
1150   }
1151 }
1152
1153
1154 ###########################################################################
1155 ###
1156 ###  project/package management
1157 ###
1158
1159 sub findprojects {
1160   local *D;
1161   opendir(D, $projectsdir) || die("$projectsdir: $!\n");
1162   my @projids = grep {s/\.xml$//} readdir(D);
1163   closedir(D);
1164   return sort @projids;
1165 }
1166
1167 sub findpackages {
1168   my ($projid) = shift;
1169   opendir(D, "$projectsdir/$projid.pkg") || return ();
1170   my @packids = grep {s/\.xml$//} readdir(D);
1171   closedir(D);
1172   return sort @packids;
1173 }
1174
1175 sub readproj {
1176   my ($projid, $nonfatal) = @_;
1177   my $proj = readxml("$projectsdir/$projid.xml", $BSXML::proj, 1);
1178   die("project '$projid' does not exist\n") if !$proj && !$nonfatal;
1179   return $proj;
1180 }
1181
1182 sub readpack {
1183   my ($projid, $packid, $nonfatal) = @_;
1184   my $pack = readxml("$projectsdir/$projid.pkg/$packid.xml", $BSXML::pack, 1);
1185   if (!$pack && !$nonfatal) {
1186     readproj($projid);
1187     die("package '$packid' does not exist in project '$projid'\n");
1188   }
1189   return $pack;
1190 }
1191
1192 # find matching .spec/.dsc/.kiwi file depending on packid and/or repoid
1193 sub findfile {
1194   my ($rev, $repoid, $ext, $files) = @_;
1195
1196   $files = lsrev($rev) unless $files;
1197   return (undef, undef) unless $files;
1198   my $packid = $rev->{'package'};
1199   return ($files->{"$packid-$repoid.$ext"}, "$packid-$repoid.$ext") if defined($repoid) && $files->{"$packid-$repoid.$ext"};
1200   # 28.4.2009 mls: deleted "&& defined($repoid)"
1201   return ($files->{"$packid.$ext"}, "$packid.$ext") if $files->{"$packid.$ext"};
1202   # try again without last components
1203   if ($packid =~ /^(.*?)\./) {
1204     return ($files->{"$1.$ext"}, "$1.$ext") if $files->{"$1.$ext"};
1205   }
1206   my @files = grep {/\.$ext$/} keys %$files;
1207   @files = grep {/^\Q$packid\E/i} @files if @files > 1;
1208   return ($files->{$files[0]}, $files[0]) if @files == 1;
1209   if (@files > 1) {
1210     if (!defined($repoid)) {
1211       # return (undef, undef);
1212       @files = sort @files;
1213       return ($files->{$files[0]}, $files[0]);
1214     }
1215     @files = grep {/^\Q$packid-$repoid\E/i} @files if @files > 1;
1216     return ($files->{$files[0]}, $files[0]) if @files == 1;
1217   }
1218   return (undef, undef);
1219 }
1220
1221 sub unify {
1222   my %h = map {$_ => 1} @_;
1223   return grep(delete($h{$_}), @_);
1224 }
1225
1226 #########################################################################
1227
1228 # set up kiwi project callback
1229
1230 sub kiwibootcallback {
1231   my ($projid, $packid) = @_;
1232   BSVerify::verify_projid($projid);
1233   BSVerify::verify_packid($packid);
1234   my $rev = getrev($projid, $packid);
1235   my $files = lsrev($rev);
1236   my ($md5, $file) = findfile($rev, undef, 'kiwi', $files);
1237   die("no kiwi file found\n") unless $md5 && $file;
1238   my $xml = readstr("$srcrep/$packid/$md5-$file");
1239   return ($xml, {'project' => $projid, 'package' => $packid, 'srcmd5' => $rev->{'srcmd5'}, 'file' => $file});
1240 }
1241 $Build::Kiwi::bootcallback = \&kiwibootcallback;
1242
1243 #########################################################################
1244
1245 sub getprojquotapackage {
1246   my ($projid) = @_;
1247   if (!exists($packagequota{':packages'})) {
1248     my $quotaxml = readxml($BSConfig::bsquotafile, $BSXML::quota, 1);
1249     for my $p (@{$quotaxml->{'project'} || []}) {
1250       $packagequota{$p->{'name'}} = $p->{'packages'};
1251     }
1252     $packagequota{':packages'} = $quotaxml->{'packages'};
1253   }
1254   while ($projid) {
1255     return $packagequota{$projid} if exists $packagequota{$projid};
1256     last unless $projid =~ s/:[^:]*$//;
1257   }
1258   return $packagequota{':packages'};
1259 }
1260
1261 sub getprojpack {
1262   my ($cgi, $projids, $repoids, $packids, $arch) = @_;
1263   $arch ||= 'noarch';
1264   $projids = [ findprojects() ] unless $projids;
1265   if ($BSConfig::limit_projects && $BSConfig::limit_projects->{$arch}) {
1266     $projids ||= $BSConfig::limit_projects->{$arch};
1267     my %limit_projids = map {$_ => 1} @{$BSConfig::limit_projects->{$arch}};
1268     $projids = [ grep {$limit_projids{$_}} @$projids ];
1269   }
1270   $repoids = { map {$_ => 1} @$repoids } if $repoids;
1271   $packids = { map {$_ => 1} @$packids } if $packids;
1272   my $bconf = Build::read_config($arch);
1273
1274   my %remotemap;
1275   my $withremotemap = $cgi->{'withremotemap'};
1276   my @res;
1277   for my $projid (@$projids) {
1278     my $jinfo = { 'name' => $projid };
1279     if ($withremotemap && !exists($remotemap{$projid})) {
1280       $remotemap{$projid} = remoteprojid($projid);
1281     }
1282     my $proj = readproj($projid, 1);
1283     next unless $proj;
1284     if ($cgi->{'withconfig'}) {
1285       my $config = readstr("$projectsdir/$projid.conf", 1);
1286       if ($config) {
1287         # strip away macro blocks
1288         while ($config =~ /^(.*?\n)?\s*(macros:[^\n]*\n.*)/si) {
1289           my ($c1, $c2) = ($1, $2);
1290           $c1 = '' unless defined $c1;
1291           if ($c2 =~ /^(?:.*?\n)?\s*:macros\s*\n(.*)$/si) {
1292             $config = "$c1$c2";
1293           } else {
1294             $config = $c1;
1295             last;
1296           }
1297         }
1298         $jinfo->{'config'} = $config unless $config =~ /^\s*$/s;
1299       }
1300     }
1301     if ($cgi->{'withsrcmd5'} && -s "$projectsdir/$projid.pkg/pattern-MD5SUMS") {
1302       my $patterns = readstr("$projectsdir/$projid.pkg/pattern-MD5SUMS", 1);
1303       $jinfo->{'patternmd5'} = Digest::MD5::md5_hex($patterns) if $patterns;
1304     }
1305     my @packages;
1306     @packages = findpackages($projid) unless $cgi->{'nopackages'};
1307     next if $repoids && !grep {$repoids->{$_->{'name'}}} @{$proj->{'repository'} || []};
1308     next if $packids && !grep {$packids->{$_}} @packages;
1309     for (qw{title description build publish debuginfo useforbuild remoteurl remoteproject download}) {
1310       $jinfo->{$_} = $proj->{$_} if exists $proj->{$_};
1311     }
1312     # Check build flags in project meta data
1313     # packages inherit the project wide settings and may override them
1314     my $pdisabled;
1315     my $pdisable = {};
1316     my $penable = {};
1317     undef($penable) if $cgi->{'ignoredisable'};
1318     if ($jinfo->{'build'} && $penable) {
1319       for (@{$proj->{'repository'} || []}) {
1320         my $disen = BSUtil::enabled($_->{'name'}, $jinfo->{'build'}, 1, $arch);
1321         if ($disen) {
1322           $penable->{$_->{'name'}} = 1;
1323         } else {
1324           $pdisable->{$_->{'name'}} = 1;
1325         }
1326       }
1327       $pdisabled = 1 if !keys(%$penable);
1328     } else {
1329       # build is enabled
1330       undef($penable);
1331     }
1332
1333     # Check package number quota
1334     my $quota_exceeded;
1335     if ($BSConfig::bsquotafile) {
1336       my $pquota = getprojquotapackage($projid);
1337       $quota_exceeded = 1 if defined($pquota) && @packages > $pquota;
1338     }
1339
1340     if ($cgi->{'withrepos'}) {
1341       if ($repoids) {
1342         $jinfo->{'repository'} = [ grep {$repoids->{$_->{'name'}}} @{$proj->{'repository'} || []} ];
1343       } else {
1344         $jinfo->{'repository'} = $proj->{'repository'} || [];
1345       }
1346       if ($cgi->{'expandedrepos'}) {
1347         for my $repo (@{$jinfo->{'repository'}}) {
1348           my @prps = expandsearchpath($projid, $repo->{'name'});
1349           for my $prp (@prps) {
1350             my @s = split('/', $prp, 2);
1351             if ($withremotemap && !exists($remotemap{$s[0]})) {
1352               $remotemap{$s[0]} = remoteprojid($s[0]);
1353             }
1354             $prp = {'project' => $s[0], 'repository' => $s[1]};
1355           }
1356           $repo->{'path'} = \@prps;
1357         }
1358       }
1359     }
1360     if (!$cgi->{'ignoredisable'} && !grep {!$_->{'status'} || $_->{'status'} ne 'disabled'} @{$proj->{'repository'} || []}) {
1361       # either no repositories or all disabled. No need to check packages
1362       @packages = ();
1363     }
1364     @packages = () if $cgi->{'nopackages'};
1365     my @pinfo;
1366     my %bconfs;
1367
1368     for my $packid (@packages) {
1369
1370       next if $packids && !$packids->{$packid};
1371       my $pinfo = {'name' => $packid};
1372       push @pinfo, $pinfo;
1373       my $pack = readpack($projid, $packid, 1);
1374       if (!$pack) {
1375         $pinfo->{'error'} = 'no metadata';
1376         next;
1377       }
1378       for (qw{build publish debuginfo useforbuild bcntsynctag}) {
1379         $pinfo->{$_} = $pack->{$_} if $pack->{$_};
1380       }
1381       if (!$pinfo->{'build'}) {
1382         $pinfo->{'build'}->{'enable'} = $pack->{'enable'} if $pack->{'enable'};
1383         $pinfo->{'build'}->{'disable'} = $pack->{'disable'} if $pack->{'disable'};
1384       }
1385       my $enable = defined($penable) ? {%$penable} : undef;
1386       my $disable = {%$pdisable};
1387       if (!$cgi->{'ignoredisable'} && $pinfo->{'build'}) {
1388         for (@{$proj->{'repository'} || []}) {
1389           my $default = exists($disable->{$_->{'name'}}) ? 0 : 1;
1390           my $disen = BSUtil::enabled($_->{'name'}, $pinfo->{'build'}, $default, $arch);
1391           if ($disen) {
1392             $enable->{$_->{'name'}} = 1;
1393             delete $disable->{$_->{'name'}};
1394           } else {
1395             $disable->{$_->{'name'}} = 1;
1396             delete $enable->{$_->{'name'}};
1397           }
1398         }
1399       }
1400       undef($disable) if $enable && !keys(%$enable);
1401       undef($enable) if $disable && !keys(%$disable);
1402       if ((!$disable || $pdisabled) && $enable && !%$enable) {
1403         $pinfo->{'error'} = 'disabled';
1404         next;
1405       }
1406       if ($quota_exceeded) {
1407         $pinfo->{'error'} = 'quota exceeded';
1408         next;
1409       }
1410       if ($cgi->{'withsrcmd5'} || $cgi->{'withdeps'}) {
1411         my $rev;
1412         eval {
1413           $rev = getrev($projid, $packid, 'build');
1414         };
1415         if ($@) {
1416           $pinfo->{'error'} = $@;
1417           $pinfo->{'error'} =~ s/\n$//s;
1418           next;
1419         }
1420         if (!$rev || $rev->{'srcmd5'} eq 'empty' || $rev->{'srcmd5'} eq 'd41d8cd98f00b204e9800998ecf8427e') {
1421           $pinfo->{'error'} = 'no source uploaded';
1422           next;
1423         }
1424         $pinfo->{'srcmd5'} = $rev->{'srcmd5'};
1425         $pinfo->{'rev'} = $rev->{'rev'};
1426         my $files;
1427         eval {
1428           $files = lsrev($rev);
1429         };
1430         if ($@) {
1431           $pinfo->{'error'} = $@;
1432           $pinfo->{'error'} =~ s/\n$//s;
1433           next;
1434         }
1435         if ($files->{'_service_error'}) {
1436           $pinfo->{'error'} = 'source service failed';
1437           next;
1438         }
1439         if ($files->{'_link'}) {
1440           my %li = ('linked' => []);
1441           $files = handlelinks($rev, $files, \%li);
1442           $pinfo->{'linked'} = $li{'linked'} if @{$li{'linked'}};
1443           if (!ref $files) {
1444             $pinfo->{'error'} = defined($files) ? $files : "could not get file list";
1445             next;
1446           }
1447           $pinfo->{'srcmd5'} = $rev->{'srcmd5'};
1448           my $meta = '';
1449           $meta .= "$files->{$_}  $_\n" for sort keys %$files;
1450           $pinfo->{'verifymd5'} = Digest::MD5::md5_hex($meta);
1451         }
1452
1453         if ($files->{'_aggregate'}) {
1454           my $aggregatelist = readxml("$srcrep/$packid/$files->{'_aggregate'}-_aggregate", $BSXML::aggregatelist, 1);
1455           if (!$aggregatelist) {
1456             $pinfo->{'error'} = "bad aggregatelist data";
1457             next;
1458           }
1459           eval {
1460             BSVerify::verify_aggregatelist($aggregatelist);
1461           };
1462           if ($@) {
1463             my $err = $@;
1464             $err =~ s/\n$//s;
1465             $pinfo->{'error'} = "bad aggregatelist: $err";
1466             next;
1467           }
1468           $pinfo->{'aggregatelist'} = $aggregatelist;
1469           if (($enable && %$enable) || ($disable && %$disable)) {
1470             my @dinfo = ();
1471             for my $repo (@{$proj->{'repository'} || []}) {
1472               my $repoid = $repo->{'name'};
1473               next if $repoids && !$repoids->{$repoid};
1474               if ((!$disable || $disable->{$repoid}) && !(!$enable || $enable->{$repoid})) {
1475                 push @dinfo, {'repository' => $repoid, 'error' => 'disabled'};
1476                 next;
1477               }
1478             }
1479             $pinfo->{'info'} = \@dinfo if @dinfo;
1480           }
1481         } elsif ($cgi->{'withdeps'}) {
1482           my @dinfo;
1483
1484           # Build config cache for all repositories
1485           for my $repo (@{$proj->{'repository'} || []}) {
1486             my $repoid = $repo->{'name'};
1487             next if $repoids && !$repoids->{$repoid};
1488
1489             my $rinfo = {'repository' => $repoid};
1490             push @dinfo, $rinfo;
1491             if ((!$disable || $disable->{$repoid}) && !(!$enable || $enable->{$repoid})) {
1492               $rinfo->{'error'} = 'disabled';
1493               next;
1494             }
1495             if (!$bconfs{$repoid}) {
1496               print "reading config for $projid/$repoid $arch\n";
1497               my $c;
1498               eval {
1499                 ($c) = getconfig($cgi, $projid, $repoid);
1500               };
1501               if ($@) {
1502                 my $err = $@;
1503                 $err =~ s/\n$//;
1504                 $rinfo->{'error'} = $err;
1505                 next;
1506               }
1507               $c = [ split("\n", $c) ];
1508               $bconfs{$repoid} = Build::read_config($arch, $c);
1509             };
1510             my $conf = $bconfs{$repoid};
1511             my $type = $conf->{'type'};
1512             if (!$type || $type eq 'UNDEFINED') {
1513               $rinfo->{'error'} = 'bad build configuration';
1514               next;
1515             }
1516             my ($md5, $file) = findfile($rev, $repoid, $type, $files);
1517             if (!$md5) {
1518               # no spec/dsc/kiwi file found
1519               if (grep {/\.(?:spec|dsc|kiwi)$/} keys %$files) {
1520                 # only different types available
1521                 $rinfo->{'error'} = 'excluded';
1522               }
1523               next;
1524             }
1525             if ($type eq 'kiwi' && $BSConfig::kiwiprojects) {
1526               my %kiwiprojects = map {$_ => 1} @$BSConfig::kiwiprojects;
1527               if (!$kiwiprojects{$projid}) {
1528                 $rinfo->{'error'} = 'kiwi image building is not enabled for this project';
1529                 next;
1530               }
1531             }
1532             $rinfo->{'file'} = $file;
1533             # get build dependency info
1534             my $d = Build::parse($conf, "$srcrep/$packid/$md5-$file");
1535             data2utf8($d);
1536             if (defined($d->{'name'})) {
1537               my $version = defined($d->{'version'}) ? $d->{'version'} : 'unknown';
1538               $pinfo->{'versrel'} ||= "$version-$rev->{'vrev'}";
1539               $rinfo->{'name'} = $d->{'name'};
1540               $rinfo->{'dep'} = $d->{'deps'};
1541               if ($d->{'prereqs'}) {
1542                 my %deps = map {$_ => 1} (@{$d->{'deps'} || []}, @{$d->{'subpacks'} || []});
1543                 my @prereqs = grep {!$deps{$_} && !/^%/} @{$d->{'prereqs'}};
1544                 $rinfo->{'prereq'} = \@prereqs if @prereqs;
1545               }
1546               # KIWI Products need local arch added, if we have it defined on this server
1547               push @{$d->{'exclarch'}}, 'local' if (defined($d->{'exclarch'}) && $type eq 'kiwi' && $d->{'imagetype'}[0] eq 'product' && defined($BSConfig::localarch));
1548               $rinfo->{'error'} = 'excluded' if $d->{'exclarch'} && !grep {$_ eq $arch} @{$d->{'exclarch'}};
1549               $rinfo->{'error'} = 'excluded' if $d->{'badarch'} && grep {$_ eq $arch} @{$d->{'badarch'}};
1550               for ('imagetype', 'path', 'extrasource') {
1551                 $rinfo->{$_} = $d->{$_} if exists $d->{$_};
1552               }
1553             } else {
1554               $rinfo->{'error'} = "can not parse package name from $file";
1555             }
1556           }
1557           $pinfo->{'info'} = \@dinfo if @dinfo;
1558         }
1559       }
1560     }
1561     $jinfo->{'package'} = \@pinfo;
1562     push @res, $jinfo;
1563   }
1564   my $ret = {'project' => \@res};
1565   if ($withremotemap && %remotemap) {
1566     for (sort keys %remotemap) {
1567       next unless $remotemap{$_};
1568       my $r = {'project' => $_, 'remoteurl' => $remotemap{$_}->{'remoteurl'}, 'remoteproject' => $remotemap{$_}->{'remoteproject'}};
1569       push @{$ret->{'remotemap'}}, $r;
1570     }
1571   }
1572   return ($ret, $BSXML::projpack);
1573 }
1574
1575 sub getprojectlist {
1576   my ($cgi) = @_;
1577   my @projects = findprojects();
1578   @projects = map {{'name' => $_}} @projects;
1579   return ({'entry' => \@projects}, $BSXML::dir);
1580 }
1581
1582 sub getproject {
1583   my ($cgi, $projid) = @_;
1584   # Read the project xml file
1585   my $proj = checkprojrepoarch($projid, undef, undef, 1);
1586   $proj = BSRPC::rpc("$proj->{'remoteurl'}/source/$proj->{'remoteproject'}/_meta", $BSXML::proj) if $proj->{'remoteurl'};
1587   return ($proj, $BSXML::proj);
1588 }
1589
1590 sub createkey {
1591   my ($cgi, $projid) = @_;
1592   die("don't know how to create a key\n") unless $BSConfig::sign;
1593   die("project $projid does not exist\n") unless -s "$projectsdir/$projid.xml";
1594   mkdir_p($uploaddir);
1595   local *F;
1596   my $pubkey = '';
1597   my @keyargs = ('dsa@1024', '800');
1598   my @signargs;
1599   push @signargs, '--project', $projid if $BSConfig::sign_project;
1600   my $obsname = $BSConfig::obsname || 'build.opensuse.org';
1601   open(F, '-|', $BSConfig::sign, @signargs, '-P', "$uploaddir/signkey.$$", '-g', @keyargs , "$projid OBS Project", "$projid\@$obsname") || die("$BSConfig::sign: $!\n");
1602   1 while sysread(F, $pubkey, 4096, length($pubkey));
1603   close(F) || die("$BSConfig::sign: $?\n");
1604   die("sign did not create signkey\n") unless -s "$uploaddir/signkey.$$";
1605   mkdir_p("$projectsdir/$projid.pkg");
1606   writestr("$uploaddir/pubkey.$$", "$projectsdir/$projid.pkg/_pubkey", $pubkey);
1607   if (!rename("$uploaddir/signkey.$$", "$projectsdir/$projid.pkg/_signkey")) {
1608     unlink("$projectsdir/$projid/_pubkey");
1609     die("rename $uploaddir/signkey.$$ $projectsdir/$projid.pkg/_signkey: $!\n");
1610   }
1611   return $BSStdServer::return_ok;
1612 }
1613
1614 sub deletekey {
1615   my ($cgi, $projid) = @_;
1616   if ($BSConfig::forceprojectkeys) {
1617     my $pprojid = $projid;
1618     $pprojid =~ s/:[^:]*$//;
1619     my $sk;
1620     ($sk) = getsignkey({}, $pprojid) if $projid ne $pprojid;
1621     die("must have a key for signing\n") unless $sk;
1622   }
1623   unlink("$projectsdir/$projid.pkg/_signkey");
1624   unlink("$projectsdir/$projid.pkg/_pubkey");
1625   rmdir("$projectsdir/$projid.pkg");
1626   return $BSStdServer::return_ok;
1627 }
1628
1629 sub getpubkey {
1630   my ($cgi, $projid) = @_;
1631   my $pubkey = readstr("$projectsdir/$projid.pkg/_pubkey", 1);
1632   die("$projid: no pubkey available\n") unless $pubkey;
1633   return ($pubkey, 'Content-Type: text/plain');
1634 }
1635
1636 sub projectcmd {
1637   my ($cgi, $projid) = @_;
1638   my $cmd = $cgi->{'cmd'};
1639   return createkey($cgi, $projid) if $cmd eq 'createkey';
1640   die("unknown command '$cmd'\n");
1641 }
1642
1643 sub putproject {
1644   my ($cgi, $projid) = @_;
1645   mkdir_p($uploaddir);
1646   my $uploaded = BSServer::read_file("$uploaddir/$$");
1647   die("upload failed\n") unless $uploaded;
1648   my $proj = readxml("$uploaddir/$$", $BSXML::proj);
1649   $proj->{'name'} = $projid unless defined $proj->{'name'};
1650   BSVerify::verify_proj($proj, $projid);
1651   writexml("$uploaddir/$$.2", undef, $proj, $BSXML::proj);
1652   unlink("$uploaddir/$$");
1653   if (! -e "$projectsdir/$projid.xml") {
1654     BSHermes::notify("SRCSRV_CREATE_PROJECT", { "project" => $projid });
1655   } else {
1656     BSHermes::notify("SRCSRV_UPDATE_PROJECT", { "project" => $projid });
1657   }
1658   mkdir_p("$projectsdir") || die("creating $projectsdir: $!\n");
1659   rename("$uploaddir/$$.2", "$projectsdir/$projid.xml") || die("rename to $projectsdir/$projid.xml: $!\n");
1660   if ($BSConfig::forceprojectkeys) {
1661     my ($sk) = getsignkey({}, $projid);
1662     createkey({}, $projid) if $sk eq '';
1663   }
1664   notify_repservers('project', $projid);
1665
1666   $proj = readproj($projid);
1667   return ($proj, $BSXML::proj);
1668 }
1669
1670 sub delproject {
1671   my ($cgi, $projid) = @_;
1672
1673   die("project '$projid' does not exist\n") unless -e "$projectsdir/$projid.xml";
1674   if (-d "$projectsdir/$projid.pkg") {
1675     # delete those packages and keys
1676     for my $f (ls("$projectsdir/$projid.pkg")) {
1677       unlink("$projectsdir/$projid.pkg/$f");
1678     }
1679     rmdir("$projectsdir/$projid.pkg") || die("rmdir $projectsdir/$projid.pkg: $!\n");
1680   }
1681   unlink("$projectsdir/$projid.conf");
1682   unlink("$projectsdir/$projid.xml");
1683   notify_repservers('project', $projid);
1684
1685   BSHermes::notify("SRCSRV_DELETE_PROJECT", { "project" => $projid });
1686
1687   return $BSStdServer::return_ok;
1688 }
1689
1690 ##########################################################################
1691
1692 sub getpackagelist {
1693   my ($cgi, $projid, $repoid, $arch) = @_;
1694   my $proj = checkprojrepoarch($projid, $repoid, $arch, 1);
1695   if ($proj->{'remoteurl'}) {
1696     return BSRPC::rpc("$proj->{'remoteurl'}/source/$proj->{'remoteproject'}", $BSXML::dir), $BSXML::dir;
1697   }
1698   my @packages = findpackages($projid);
1699   my @plist = map {{'name' => $_}} @packages;
1700   return ({'entry' => \@plist}, $BSXML::dir);
1701 }
1702
1703 sub getpackage {
1704   my ($cgi, $projid, $packid) = @_;
1705   my $proj = checkprojrepoarch($projid, undef, undef, 1);
1706   if ($proj->{'remoteurl'}) {
1707     my $pack = BSRPC::rpc("$proj->{'remoteurl'}/source/$proj->{'remoteproject'}/$packid/_meta", $BSXML::pack);
1708     return ($pack, $BSXML::pack);
1709   }
1710   my $pack = readpack($projid, $packid);
1711   return ($pack, $BSXML::pack);
1712 }
1713
1714 sub putpackage {
1715   my ($cgi, $projid, $packid) = @_;
1716   mkdir_p($uploaddir);
1717   my $uploaded = BSServer::read_file("$uploaddir/$$");
1718   die("upload failed\n") unless $uploaded;
1719   my $pack = readxml("$uploaddir/$$", $BSXML::pack);
1720   $pack->{'name'} = $packid unless defined $pack->{'name'};
1721   BSVerify::verify_pack($pack, $packid);
1722   die("package contains revision data\n") if grep {exists $pack->{$_}} @$srcrevlay;
1723   # XXX
1724   # delete rev stuff, just in case...
1725   # delete $pack->{$_} for @$srcrevlay;
1726   # $pack->{'name'} = $packid;
1727   writexml("$uploaddir/$$.2", undef, $pack, $BSXML::pack);
1728   unlink("$uploaddir/$$");
1729   my $proj = readproj($projid);
1730   die("package '$packid' is read-only\n") if ($packid =~ /^_product:/) && ! -e "$projectsdir/$projid.pkg/$packid.xml";
1731   mkdir_p("$projectsdir/$projid.pkg");
1732   if (! -e "$projectsdir/$projid.pkg/$packid.xml") {
1733     BSHermes::notify("SRCSRV_CREATE_PACKAGE", { "project" => $projid, "package" => $packid});
1734   } else {
1735     BSHermes::notify("SRCSRV_UPDATE_PACKAGE", { "project" => $projid, "package" => $packid});
1736   }
1737   rename("$uploaddir/$$.2", "$projectsdir/$projid.pkg/$packid.xml") || die("rename to $projectsdir/$projid.pkg/$packid.xml: $!\n");
1738 #  my %packages = map {$_->{'name'} => 1} @{$proj->{'package'} || []};
1739 #  if (!$packages{$packid}) {
1740 #    # a new package! add id to project data
1741 #    push @{$proj->{'package'}}, {'name' => $packid};
1742 #    writexml("$uploaddir/$$.3", "$projectsdir/$projid.xml", $proj, $BSXML::proj);
1743 #  }
1744   notify_repservers('package', $projid, $packid);
1745   $pack = readpack($projid, $packid);
1746   return ($pack, $BSXML::pack);
1747 }
1748
1749 sub delpackage {
1750   my ($cgi, $projid, $packid) = @_;
1751   die("project '$projid' does not exist\n") unless -e "$projectsdir/$projid.xml";
1752   die("package '$packid' does not exist in project '$projid'\n") unless -e "$projectsdir/$projid.pkg/$packid.xml";
1753   die("package '$packid' is read-only\n") if $packid =~ /^_product:/;
1754   unlink("$projectsdir/$projid.pkg/$packid.upload-MD5SUMS");
1755   unlink("$projectsdir/$projid.pkg/$packid.rev");
1756   unlink("$projectsdir/$projid.pkg/$packid.xml");
1757   if ($packid eq '_product') {
1758     expandproduct($projid, $packid, undef);
1759   }
1760   notify_repservers('package', $projid, $packid);
1761   BSHermes::notify("SRCSRV_DELETE_PACKAGE", { "project" => $projid, "package" => $packid });
1762
1763   return $BSStdServer::return_ok;
1764 }
1765
1766 sub getpackagehistory {
1767   my ($cgi, $projid, $packid) = @_;
1768   my @res;
1769   for (BSFileDB::fdb_getall("$projectsdir/$projid.pkg/$packid.rev", $srcrevlay)) {
1770     next if $cgi->{'rev'} && $cgi->{'rev'} ne $_->{'rev'} && $cgi->{'rev'} ne $_->{'srcmd5'};
1771     $_->{'comment'} = str2utf8($_->{'comment'}) if $_->{'comment'};
1772     push @res, $_;
1773   }
1774   return ({'revision' => \@res}, $BSXML::revisionlist);
1775 }
1776
1777 ##########################################################################
1778
1779 ##########################################################################
1780
1781 # XXX -> library
1782
1783 sub remoteprojid {
1784   my ($projid) = @_;
1785   my $rsuf = '';
1786   my $origprojid = $projid;
1787
1788   my $proj = readproj($projid, 1);
1789   if ($proj) {
1790     return undef unless $proj->{'remoteurl'};
1791     return undef unless $proj->{'remoteproject'};
1792     return {
1793       'name' => $projid,
1794       'root' => $projid,
1795       'remoteroot' => $proj->{'remoteproject'},
1796       'remoteurl' => $proj->{'remoteurl'},
1797       'remoteproject' => $proj->{'remoteproject'},
1798     };
1799   }
1800   while ($projid =~ /^(.*)(:.*?)$/) {
1801     $projid = $1;
1802     $rsuf = "$2$rsuf";
1803     $proj = readproj($projid, 1);
1804     if ($proj) {
1805       return undef unless $proj->{'remoteurl'};
1806       if ($proj->{'remoteproject'}) {
1807         $rsuf = "$proj->{'remoteproject'}$rsuf";
1808       } else {
1809         $rsuf =~ s/^://;
1810       }
1811       return {
1812         'name' => $origprojid,
1813         'root' => $projid,
1814         'remoteroot' => $proj->{'remoteproject'},
1815         'remoteurl' => $proj->{'remoteurl'},
1816         'remoteproject' => $rsuf,
1817       };
1818     }
1819   }
1820   return undef;
1821 }
1822
1823 sub maptoremote {
1824   my ($proj, $projid) = @_;
1825   return "$proj->{'root'}:$projid" unless $proj->{'remoteroot'};
1826   return $proj->{'root'} if $projid eq $proj->{'remoteroot'};
1827   return '_unavailable' if $projid !~ /^\Q$proj->{'remoteroot'}\E:(.*)$/;
1828   return "$proj->{'root'}:$1";
1829 }
1830
1831 sub fetchremoteproj {
1832   my ($proj, $projid) = @_;
1833   return undef unless $proj && $proj->{'remoteurl'} && $proj->{'remoteproject'};
1834   $projid ||= $proj->{'name'};
1835   print "fetching remote project data for $projid\n";
1836   my $param = {
1837     'uri' => "$proj->{'remoteurl'}/source/$proj->{'remoteproject'}/_meta",
1838     'timeout' => 60,
1839   };
1840   my $rproj = BSRPC::rpc($param, $BSXML::proj);
1841   return undef unless $rproj;
1842   for (qw{name root remoteroot remoteurl remoteproject}) {
1843     $rproj->{$_} = $proj->{$_};
1844   }
1845   return $rproj;
1846 }
1847
1848 sub fetchremoteconfig {
1849   my ($proj, $projid) = @_;
1850   return undef unless $proj && $proj->{'remoteurl'} && $proj->{'remoteproject'};
1851   $projid ||= $proj->{'name'};
1852   print "fetching remote project config for $projid\n";
1853   my $param = {
1854     'uri' => "$proj->{'remoteurl'}/source/$proj->{'remoteproject'}/_config",
1855     'timeout' => 60,
1856   };
1857   return BSRPC::rpc($param, undef);
1858 }
1859
1860 sub remote_getrev {
1861   my ($projid, $packid, $rev) = @_;
1862   my $proj = remoteprojid($projid);
1863   if (!$proj) {
1864     die("package '$packid' does not exist\n") if -e "$projectsdir/$projid.xml";
1865     die("project '$projid' does not exist\n");
1866   }
1867   my @args;
1868   push @args, "expand";
1869   push @args, "rev=$rev" if defined $rev;
1870   my $dir = BSRPC::rpc("$proj->{'remoteurl'}/source/$proj->{'remoteproject'}/$packid", $BSXML::dir, @args);
1871   die("$dir->{'error'}\n") if $dir->{'error'};
1872   $rev = {};
1873   $rev->{'rev'} = $dir->{'rev'} || $dir->{'srcmd5'};
1874   $rev->{'srcmd5'} = $dir->{'srcmd5'};
1875   $rev->{'vrev'} = $dir->{'vrev'};
1876   $rev->{'vrev'} ||= '0';
1877   # now put everything in local srcrep
1878   my $files = {};
1879   for my $entry (@{$dir->{'entry'} || []}) {
1880     $files->{$entry->{'name'}} = $entry->{'md5'};
1881     next if -e "$srcrep/$packid/$entry->{'md5'}-$entry->{'name'}";
1882     mkdir_p($uploaddir);
1883     my $param = {
1884       'uri' => "$proj->{'remoteurl'}/source/$proj->{'remoteproject'}/$packid/$entry->{'name'}",
1885       'filename' => "$uploaddir/$$",
1886       'withmd5' => 1,
1887       'receiver' => \&BSHTTP::file_receiver,
1888     };
1889     my $res = BSRPC::rpc($param, undef, "rev=$rev->{'srcmd5'}");
1890     die("file download failed\n") unless $res && $res->{'md5'} eq $entry->{'md5'};
1891     addfile($projid, $packid, "$uploaddir/$$", $entry->{'name'}, $entry->{'md5'});
1892   }
1893   my $srcmd5 = addmeta($projid, $packid, $files);
1894   if ($dir->{'linkinfo'}) {
1895     $dir->{'srcmd5'} = $rev->{'srcmd5'} = $srcmd5;
1896     $rev->{'rev'} = $rev->{'srcmd5'} unless $dir->{'rev'};
1897   }
1898   die("srcmd5 mismatch\n") if $dir->{'srcmd5'} ne $srcmd5;
1899   $rev->{'project'} = $projid;
1900   $rev->{'package'} = $packid;
1901   return $rev;
1902 }
1903
1904 sub expandsearchpath {
1905   my ($projid, $repoid) = @_;
1906   my %done;
1907   my @ret;
1908   my @path = {project => $projid, repository => $repoid};
1909   while (@path) {
1910     my $t = shift @path;
1911     my $prp = "$t->{'project'}/$t->{'repository'}";
1912     push @ret, $prp unless $done{$prp};
1913     $done{$prp} = 1;
1914     if (!@path) {
1915       last if $done{"/$prp"};
1916       my ($pid, $tid) = ($t->{'project'}, $t->{'repository'});
1917       my $proj = readproj($pid, 1);
1918       if (!$proj) { 
1919         $proj = remoteprojid($pid);
1920         $proj = fetchremoteproj($proj, $pid);
1921         die("project '$pid' does not exist\n") unless $proj;
1922         my @repo = grep {$_->{'name'} eq $tid} @{$proj->{'repository'} || []};
1923         if (@repo && $repo[0]->{'path'}) {
1924           for my $pathel (@{$repo[0]->{'path'}}) {
1925             # map projects to remote
1926             $pathel->{'project'} = maptoremote($proj, $pathel->{'project'});
1927           }
1928         }
1929       }
1930       $done{"/$prp"} = 1;       # mark expanded
1931       my @repo = grep {$_->{'name'} eq $tid} @{$proj->{'repository'} || []};
1932       push @path, @{$repo[0]->{'path'}} if @repo && $repo[0]->{'path'};
1933     }
1934   }
1935   return @ret;
1936 }
1937
1938 sub getconfig {
1939   my ($cgi, $projid, $repoid) = @_;
1940   my @path = expandsearchpath($projid, $repoid);
1941   if ($cgi->{'path'}) {
1942     @path = @{$cgi->{'path'}};
1943     # XXX: commented out to make it consistent to the scheduler
1944     # unshift @path, "$projid/$repoid" unless @path && $path[0] eq "$projid/$repoid";
1945   }
1946   my $config = "%define _project $projid\n";
1947   my $macros = '';
1948
1949   #$macros .= "%vendor openSUSE Build Service\n";
1950
1951   # find the sign project, this is what we use as vendor
1952   my $vprojid = $projid;
1953   while ($vprojid ne '') {
1954     last if -s "$projectsdir/$vprojid.pkg/_signkey";
1955     $vprojid =~ s/[^:]*$//;
1956     $vprojid =~ s/:$//;
1957   }
1958   $vprojid = $projid if $vprojid eq '';
1959   my $obsname = $BSConfig::obsname || 'build.opensuse.org';
1960   $macros .= "%vendor obs://$obsname/$vprojid\n";
1961
1962   $macros .= "%_project $projid\n";
1963   my $lastr = '';
1964
1965   my $distinfo = "$projid / $repoid";
1966   if ($repoid eq 'standard') {
1967     $distinfo = $projid;
1968   } 
1969
1970   for my $prp (reverse @path) {
1971     if ($prp eq "$projid/$repoid") {
1972       $macros .= "\n%distribution $distinfo\n";
1973       $macros .= "%_project $projid\n";
1974     }
1975     my ($p, $r) = split('/', $prp, 2);
1976     my $c;
1977     if (-s "$projectsdir/$p.conf") {
1978       $c = readstr("$projectsdir/$p.conf");
1979     } elsif (!-e "$projectsdir/$p.xml") {
1980       my $proj = remoteprojid($p);
1981       $c = fetchremoteconfig($proj, $p);
1982     }
1983     next unless defined $c;
1984     $config .= "\n### from $p\n";
1985     $config .= "%define _repository $r\n";
1986     if ($c =~ /^(.*\n)?\s*macros:[^\n]*\n(.*)/si) {
1987       $c = defined($1) ? $1 : '';
1988       $macros .= "\n### from $p\n";
1989       $macros .= "%_repository $r\n";
1990       $macros .= $2;
1991       $lastr = $r;
1992     }
1993     $config .= $c;
1994   }
1995   if ($lastr ne $repoid) {
1996     $macros .= "\n### from $projid\n";
1997     $macros .= "%_repository $repoid\n";
1998   }
1999   if (!@path || $path[0] ne "$projid/$repoid") {
2000     $macros .= "\n%distribution $distinfo\n";
2001     $macros .= "%_project $projid\n";
2002   }
2003   if ($BSConfig::extramacros) {
2004     for (sort keys %{$BSConfig::extramacros}) {
2005       $macros .= $BSConfig::extramacros->{$_} if $projid =~ /$_/;
2006     }
2007   }
2008   $config .= "\nMacros:\n$macros" if $macros ne '';
2009   return ($config, 'Content-Type: text/plain');
2010 }
2011
2012 sub getprojectconfig {
2013   my ($cgi, $projid) = @_;
2014   my $proj = readproj($projid);
2015   my $config = readstr("$projectsdir/$projid.conf", 1);
2016   $config = '' unless defined $config;
2017   return ($config, 'Content-Type: text/plain');
2018 }
2019
2020 sub putprojectconfig {
2021   my ($cgi, $projid) = @_;
2022   my $proj = readproj($projid);
2023   mkdir_p($uploaddir);
2024   my $uploaded = BSServer::read_file("$uploaddir/$$");
2025   die("upload failed\n") unless $uploaded;
2026   if (-s "$uploaddir/$$") {
2027     rename("$uploaddir/$$", "$projectsdir/$projid.conf") || die("rename $uploaddir/$$ $projectsdir/$projid.conf: $!\n");
2028   } else {
2029     unlink("$projectsdir/$projid.conf");
2030   }
2031   notify_repservers('project', $projid);
2032   BSHermes::notify("SRCSRV_UPDATE_PROJECT_CONFIG", { "project" => $projid });
2033
2034   return $BSStdServer::return_ok;
2035 }
2036
2037 ##########################################################################
2038
2039 sub getsources {
2040   my ($cgi, $projid, $packid, $srcmd5) = @_;
2041   my $rev = {'project' => $projid, 'package' => $packid, 'srcmd5' => $srcmd5};
2042   my $files = lsrev($rev);
2043   my @send = map {{'name' => $_, 'filename' => "$srcrep/$packid/$files->{$_}-$_"}} keys %$files;
2044   BSServer::reply_cpio(\@send);
2045   return undef;
2046 }
2047
2048 sub getfilelist {
2049   my ($cgi, $projid, $packid) = @_;
2050
2051   my $view = $cgi->{'view'};
2052   my $rev = getrev($projid, $packid, defined($cgi->{'rev'}) ? $cgi->{'rev'} : 'upload');
2053   my $li = {};
2054   my $files = lsrev($rev, $li);
2055
2056   if ($files->{'_link'}) {
2057     if ($cgi->{'emptylink'}) {
2058       my $l = readxml("$srcrep/$packid/$files->{'_link'}-_link", $BSXML::link);
2059       delete $l->{'patches'};
2060       mkdir_p($uploaddir);
2061       writexml("$uploaddir/$$", undef, $l, $BSXML::link);
2062       $files = {};
2063       $files->{'_link'} = addfile($projid, $packid, "$uploaddir/$$", '_link');
2064       $rev = addrev($projid, $packid, $files, undef, undef, '');
2065     }
2066     my %lrev = %$rev;
2067     $lrev{'linkrev'} = $cgi->{'linkrev'} if $cgi->{'linkrev'};
2068     my $lfiles = handlelinks(\%lrev, $files, $li);
2069     if ($cgi->{'expand'}) {
2070       die("$lfiles\n") if !ref $lfiles;
2071       $files = $lfiles;
2072       %$rev = %lrev;
2073       $rev->{'rev'} = $rev->{'srcmd5'};
2074     } else {
2075       delete $lrev{'srcmd5'} if !ref($lfiles) && $lrev{'srcmd5'} && ! -e "$srcrep/$packid/$lrev{'srcmd5'}-_linkerror";
2076       $li->{'xsrcmd5'} = $lrev{'srcmd5'} if $lrev{'srcmd5'};
2077       $li->{'error'} = $lfiles unless ref $lfiles;
2078       $li->{'lsrcmd5'} ||= $rev->{'srcmd5'};
2079       if ($cgi->{'lastworking'}) {
2080         my $lastworking = findlastworkinglink($rev);
2081         $li->{'lastworking'} = $lastworking if $lastworking;
2082       }
2083     }
2084   }
2085
2086   if ($cgi->{'extension'}) {
2087     for (keys %$files) {
2088       delete $files->{$_} unless /\.\Q$cgi->{'extension'}\E$/;
2089     }
2090   }
2091
2092   if ($view && $view eq 'cpio') {
2093     my @files = map {{'name' => $_, 'filename' => "$srcrep/$packid/$files->{$_}-$_"}} sort keys %$files;
2094     BSServer::reply_cpio(\@files);
2095     return undef;
2096   }
2097
2098   my $ret = {};
2099   $ret->{'name'} = $packid;
2100   $ret->{'srcmd5'} = $rev->{'srcmd5'} if $rev->{'srcmd5'} ne 'empty';
2101   $ret->{'rev'} = $rev->{'rev'} if exists $rev->{'rev'};
2102   $ret->{'vrev'} = $rev->{'vrev'} if exists $rev->{'vrev'};
2103   my @res;
2104   for my $filename (sort keys %$files) {
2105     my @s = stat("$srcrep/$packid/$files->{$filename}-$filename");
2106     if (@s) {
2107       push @res, {'name' => $filename, 'md5' => $files->{$filename}, 'size' => $s[7], 'mtime' => $s[9]};
2108     } else {
2109       push @res, {'name' => $filename, 'md5' => $files->{$filename}, 'error' => "$!"};
2110     }
2111   }
2112   if (%$li) {
2113     linkinfo_addtarget($rev, $li) if $li->{'lsrcmd5'};
2114     $ret->{'linkinfo'} = $li;
2115   }
2116   $ret->{'entry'} = \@res;
2117   return ($ret, $BSXML::dir);
2118 }
2119
2120 sub getfile {
2121   my ($cgi, $projid, $packid, $filename) = @_;
2122   die("no filename\n") unless defined($filename) && $filename ne '';
2123   die("bad filename\n") if $filename =~ /\// || $filename =~ /^\./;
2124   my $rev = getrev($projid, $packid, defined($cgi->{'rev'}) ? $cgi->{'rev'} : 'upload');
2125   my $files = lsrev($rev);
2126   die("$filename: no such file\n") unless $files->{$filename};
2127   my @s = stat("$srcrep/$packid/$files->{$filename}-$filename");
2128   die("$srcrep/$packid/$files->{$filename}-$filename: $!\n") unless @s;
2129   BSServer::reply_file("$srcrep/$packid/$files->{$filename}-$filename", "Content-Length: $s[7]");
2130   return undef;
2131 }
2132
2133 sub putfile {
2134   my ($cgi, $projid, $packid, $filename) = @_;
2135   die("no filename\n") unless defined($filename) && $filename ne '';
2136   die("bad filename\n") if $filename =~ /\// || $filename =~ /^\./;
2137   my $rev = getrev($projid, $packid, defined($cgi->{'rev'}) ? $cgi->{'rev'} : 'upload');
2138   die("file '$filename' is read-only\n") if ($filename =~ /^_service:/) && !$cgi->{'force'};
2139   mkdir_p($uploaddir);
2140   my $uploaded = BSServer::read_file("$uploaddir/$$", 'withmd5' => 1);
2141   die("upload failed\n") unless $uploaded;
2142   addfile($projid, $packid, "$uploaddir/$$", $filename, $uploaded->{'md5'});
2143   # create new meta file
2144   my $files = lsrev($rev);
2145   $files->{$filename} = $uploaded->{'md5'};
2146   $files = keeplink($cgi, $projid, $packid, $files) if $cgi->{'keeplink'};
2147   my $user = defined($cgi->{'user'}) ? $cgi->{'user'} : 'unknown';
2148   my $comment = defined($cgi->{'comment'}) ? $cgi->{'comment'} : '';
2149   $rev = addrev($projid, $packid, $files, $user, $comment, $cgi->{'rev'});
2150 # update happens only on commit atm, or we would modify on file upload time ...
2151 # sourceupdate($projid, $packid) if $files->{'_service'} && not ($rev eq 'upload');
2152   delete $rev->{'project'};
2153   delete $rev->{'package'};
2154   return ($rev, $BSXML::revision);
2155 }
2156
2157 sub sourcediff {
2158   my ($cgi, $projid, $packid) = @_;
2159
2160   my $oprojid = exists($cgi->{'oproject'}) ? $cgi->{'oproject'} : $projid;
2161   my $opackid = exists($cgi->{'opackage'}) ? $cgi->{'opackage'} : $packid;
2162   my $fmax = 200;
2163   my $tmax = 16000;
2164
2165   my $rev = getrev($projid, $packid, defined($cgi->{'rev'}) ? $cgi->{'rev'} : 'upload');
2166   my $files = lsrev($rev);
2167   my $orev = $cgi->{'orev'};
2168   if ($projid eq $oprojid && $packid eq $opackid && !defined($cgi->{'orev'}) && $rev->{'rev'}) {
2169     $orev = $rev->{'rev'} - 1;
2170   }
2171   $orev = getrev($oprojid, $opackid, defined($orev) ? $orev : 'latest');
2172   my $ofiles = lsrev($orev);
2173   if ($cgi->{'expand'} || ($files->{'_link'} && !$ofiles->{'_link'}) || ($ofiles->{'_link'} && !$files->{'_link'})) {
2174     # expand links
2175     if ($files->{'_link'}) {
2176       $rev->{'linkrev'} = $cgi->{'linkrev'} if $cgi->{'linkrev'};
2177       $files = handlelinks($rev, $files);
2178       die("bad link: $files\n") unless ref $files;
2179     }
2180     if ($ofiles->{'_link'}) {
2181       $orev->{'linkrev'} = $cgi->{'olinkrev'} if $cgi->{'olinkrev'};
2182       $ofiles = handlelinks($orev, $ofiles);
2183       die("bad link: $ofiles\n") unless ref $ofiles;
2184     }
2185   }
2186   my $cacheid = "$orev->{'srcmd5'}/$rev->{'srcmd5'}";
2187   $cacheid .= "/unified:$cgi->{'unified'}" if $cgi->{'unified'};
2188   $cacheid .= "/fmax:$fmax" if defined $fmax;
2189   $cacheid .= "/tmax:$tmax" if defined $tmax;
2190   $cacheid = Digest::MD5::md5_hex($cacheid);
2191   local *F;
2192   my $cn = "$diffcache/".substr($cacheid, 0, 2)."/$cacheid";
2193   if (open(F, '<', $cn)) {
2194     utime(time, time, $cn);
2195     my @s = stat(F);
2196     BSServer::reply_file(\*F, 'Content-Type: text/plain', "Content-Length: $s[7]");
2197     return undef;
2198   }
2199   my $tmpdir = "$uploaddir/srcdiff$$";
2200   my $d = BSSrcdiff::diff("$srcrep/$opackid", $ofiles, $orev->{'rev'}, "$srcrep/$packid", $files, $rev->{'rev'}, $fmax, $tmax, $tmpdir, $cgi->{'unified'});
2201   mkdir_p("$diffcache/".substr($cacheid, 0, 2));
2202   writestr("$diffcache/.new$$", $cn, $d);
2203   return ($d, 'Content-Type: text/plain');
2204 }
2205
2206 sub linkdiff {
2207   my ($cgi, $projid, $packid) = @_;
2208   my $rev = getrev($projid, $packid, defined($cgi->{'rev'}) ? $cgi->{'rev'} : 'upload');
2209   $rev->{'linkrev'} = $cgi->{'linkrev'} if $cgi->{'linkrev'};
2210   my $linkinfo = {};
2211   my $files = lsrev_expanded($rev, $linkinfo);
2212   die("not a link\n") unless $linkinfo->{'srcmd5'};
2213   linkinfo_addtarget($rev, $linkinfo);
2214   return sourcediff({
2215     'oproject' => $linkinfo->{'project'},
2216     'opackage' => $linkinfo->{'package'},
2217     'orev' => $linkinfo->{'srcmd5'},
2218     'rev' => $rev->{'srcmd5'},
2219   }, $projid, $packid);
2220 }
2221
2222 sub isascii {
2223   my ($file) = @_;
2224   local *F;
2225   open(F, '<', $file) || die("$file: $!\n");
2226   my $buf = '';
2227   sysread(F, $buf, 4096);
2228   close F;
2229   return 1 unless $buf =~ /[\000-\010\016-\037]/s;
2230   return 0;
2231 }
2232
2233 sub rundiff {
2234   my ($file1, $file2, $label, $outfile) = @_;
2235   my $pid;
2236   if (!($pid = xfork())) {
2237     if (!open(STDOUT, '>>', $outfile)) {
2238       print STDERR "$outfile: $!\n";
2239       exit(2);
2240     }
2241     exec('diff', '-up', '--label', "$label.orig", '--label', $label, $file1, $file2);
2242     exit(2);
2243   }
2244   waitpid($pid, 0) == $pid || die("waitpid $pid: $!\n");
2245   my $status = $?;
2246   return 1 if $status == 0 || $status == 0x100;
2247   return undef;
2248 }
2249
2250 sub findprojectpatchname {
2251   my ($files) = @_;
2252
2253   my $i = "";
2254   while ($files->{"project$i.diff"}) {
2255     $i = '0' unless $i;
2256     $i++;
2257   }
2258   return "project$i.diff";
2259 }
2260
2261 #
2262 # we are going to commit files to projid/packid, all data is already present
2263 # in the src repository.
2264 # if it was a link before, try to keep this link
2265 # files: expanded file set
2266 #
2267 sub keeplink {
2268   my ($cgi, $projid, $packid, $files, $orev) = @_;
2269
2270   my $repair = $cgi->{'repairlink'};
2271   return $files if !defined($files) || !%$files;
2272   return $files if $files->{'_link'};
2273   $orev ||= getrev($projid, $packid, 'latest');
2274   my $ofilesl = lsrev($orev);
2275   return $files unless $ofilesl && $ofilesl->{'_link'};
2276   my $l = readxml("$srcrep/$packid/$ofilesl->{'_link'}-_link", $BSXML::link);
2277   my $changedlink = 0;
2278   my %lignore;
2279   my $isbranch;
2280
2281   if (@{$l->{'patches'}->{''} || []} == 1) {
2282     my $type = (keys %{$l->{'patches'}->{''}->[0]})[0];
2283     if ($type eq 'branch') {
2284       $isbranch = 1;
2285     }
2286   }
2287   undef $isbranch if $cgi->{'convertbranchtopatch'};
2288
2289   if (!$isbranch && $l->{'patches'}) {
2290     if ($repair) {
2291       for (@{$l->{'patches'}->{''} || []}) {
2292         my $type = (keys %$_)[0];
2293         if ($type eq 'apply' || $type eq 'delete' || $changedlink) {
2294           $lignore{$_->{$type}->{'name'}} = 1 if $type ne 'topadd' && $type ne 'delete';
2295           $_ = undef;
2296           $changedlink = 1;
2297         }
2298       }
2299     } else {
2300       for (reverse @{$l->{'patches'}->{''} || []}) {
2301         my $type = (keys %$_)[0];
2302         if ($type eq 'apply' || $type eq 'delete' || $type eq 'branch') {
2303           $lignore{$_->{$type}->{'name'}} = 1 if $type eq 'apply';
2304           $_ = undef;
2305           $changedlink = 1;
2306           next;
2307         }
2308         last;
2309       }
2310     }
2311     $l->{'patches'}->{''} = [ grep {defined($_)} @{$l->{'patches'}->{''}} ];
2312   }
2313
2314   my $linkrev = $cgi->{'linkrev'};
2315   $linkrev = $l->{'baserev'} if $linkrev && $linkrev eq 'base';
2316
2317   my $ltgtsrcmd5;
2318   my $ofiles;
2319   my $ofilesdir;
2320   if (!$repair) {
2321     # expand old link
2322     my %olrev = %$orev;
2323     my %li;
2324     $olrev{'linkrev'} = $linkrev if $linkrev;
2325     $ofiles = handlelinks(\%olrev, $ofilesl, \%li);
2326     die("bad link: $ofiles\n") unless ref $ofiles;
2327     $ltgtsrcmd5 = $li{'srcmd5'};
2328     $ofilesdir = "$srcrep/$packid";
2329   }
2330
2331   # get link target file list
2332   my $ltgtprojid = defined($l->{'project'}) ? $l->{'project'} : $projid;
2333   my $ltgtpackid = defined($l->{'package'}) ? $l->{'package'} : $packid;
2334   my $ltgtfiles;
2335   if ($ltgtsrcmd5) {
2336     my $ltgtrev = {'project' => $ltgtprojid, 'package' => $ltgtpackid, 'srcmd5' => $ltgtsrcmd5};
2337     $ltgtfiles = lsrev($ltgtrev);
2338   } else {
2339     my $ltgtrev = getrev($ltgtprojid, $ltgtpackid, $linkrev || $l->{'rev'});
2340     $ltgtfiles = lsrev_expanded($ltgtrev);
2341     $ltgtsrcmd5 = $ltgtrev->{'srcmd5'};
2342   }
2343
2344   # easy for branches: just copy file list and update baserev
2345   if ($isbranch) {
2346     my $nfiles = { %$files };
2347     my $baserev = $linkrev || $ltgtsrcmd5;
2348     if (($l->{'baserev'} || '') ne $baserev) {
2349       $l->{'baserev'} = $baserev;
2350       $l->{'patches'}->{''} = [ { 'branch' => undef} ]; # work around xml problem
2351       mkdir_p($uploaddir);
2352       writexml("$uploaddir/$$", undef, $l, $BSXML::link);
2353       $nfiles->{'_link'} = addfile($projid, $packid, "$uploaddir/$$", '_link')
2354     } else {
2355       $nfiles->{'_link'} = $ofilesl->{'_link'};
2356     }
2357     return $nfiles;
2358   }
2359
2360   if ($cgi->{'convertbranchtopatch'}) {
2361     $ofilesl = {};
2362     $ofiles = $ltgtfiles;
2363     $ofilesdir = "$srcrep/$ltgtpackid";
2364   } elsif ($repair || $changedlink) {
2365     # apply changed link
2366     my $frominfo = {'project' => $ltgtprojid, 'package' => $ltgtpackid, 'srcmd5' => $ltgtsrcmd5};
2367     my $linkinfo = {'project' => $projid, 'package' => $packid, 'srcmd5' => $orev->{'srcmd5'}, 'link' => $l};
2368     $linkinfo->{'ignore'} = \%lignore;
2369     $ofiles = applylink(undef, $frominfo, $linkinfo);
2370     die("bad link: $ofiles\n") unless ref $ofiles;
2371     $ofilesdir = "$uploaddir/applylink$$";
2372   }
2373
2374   #print "-- ofilesl:\n";
2375   #print "  $ofilesl->{$_}  $_\n" for sort keys %$ofilesl;
2376   #print "-- ofiles:\n";
2377   #print "  $ofiles->{$_}  $_\n" for sort keys %$ofiles;
2378   #print "-- files:\n";
2379   #print "  $files->{$_}  $_\n" for sort keys %$files;
2380
2381   # now create diff between old $ofiles and $files
2382   my $nfiles = { %$ofilesl };
2383   delete $nfiles->{$_} for keys %lignore;       # no longer used in link
2384   mkdir_p($uploaddir);
2385   unlink("$uploaddir/$$");
2386   my @dfiles;
2387   for my $file (sort keys %{{%$files, %$ofiles}}) {
2388     if ($ofiles->{$file}) {
2389       if (!$files->{$file}) {
2390         if (!$ltgtfiles->{$file} && $ofilesl->{$file} && $ofilesl->{$file} eq ($ofiles->{$file} || '')) {
2391           # local file no longer needed
2392           delete $nfiles->{$file};
2393         }
2394         push @dfiles, $file;
2395         delete $nfiles->{$file};
2396         next;
2397       }
2398       if ($ofiles->{$file} eq $files->{$file}) {
2399         next;
2400       }
2401       if (!isascii("$srcrep/$packid/$files->{$file}-$file") || !isascii("$ofilesdir/$ofiles->{$file}-$file")) {
2402         $nfiles->{$file} = $files->{$file};
2403         next;
2404       }
2405     } else {
2406       if (!isascii("$srcrep/$packid/$files->{$file}-$file")) {
2407         $nfiles->{$file} = $files->{$file};
2408         next;
2409       }
2410     }
2411     if (($ofilesl->{$file} || '') eq ($ofiles->{$file} || '')) {
2412       # link did not change file, just record new content
2413       if ($files->{$file} eq ($ltgtfiles->{$file} || '')) {
2414         # local overwrite already in link target
2415         delete $nfiles->{$file};
2416         next;
2417       }
2418       $nfiles->{$file} = $files->{$file};
2419       next;
2420     }
2421     # both are ascii, create diff
2422     mkdir_p($uploaddir);
2423     if (!rundiff($ofiles->{$file} ? "$ofilesdir/$ofiles->{$file}-$file" : '/dev/null', "$srcrep/$packid/$files->{$file}-$file", $file, "$uploaddir/$$")) {
2424       $nfiles->{$file} = $files->{$file};
2425     }
2426   }
2427   my $lchanged;
2428   $lchanged = 1 if $changedlink;
2429   for (@dfiles) {
2430     push @{$l->{'patches'}->{''}}, {'delete' => {'name' => $_}};
2431     $lchanged = 1;
2432   }
2433   if (-s "$uploaddir/$$") {
2434     my $ppatch = findprojectpatchname($nfiles);
2435     $nfiles->{$ppatch} = addfile($projid, $packid, "$uploaddir/$$", $ppatch);
2436     push @{$l->{'patches'}->{''}}, {'apply' => {'name' => $ppatch}};
2437     $lchanged = 1;
2438   } else {
2439     unlink("$uploaddir/$$");
2440   }
2441   my $baserev = $linkrev || $ltgtsrcmd5;
2442   if (($l->{'baserev'} || '') ne $baserev) {
2443     $l->{'baserev'} = $baserev;
2444     $lchanged = 1;
2445   }
2446   if ($lchanged) {
2447     writexml("$uploaddir/$$", undef, $l, $BSXML::link);
2448     $nfiles->{'_link'} = addfile($projid, $packid, "$uploaddir/$$", '_link')
2449   }
2450   if ($ofilesdir eq "$uploaddir/applylink$$") {
2451     BSUtil::cleandir("$uploaddir/applylink$$");
2452     rmdir("$uploaddir/applylink$$");
2453   }
2454   return $nfiles;
2455 }
2456
2457 # integrate link from opackid to packid into packid
2458 sub integratelink {
2459   my ($files, $projid, $packid, $rev, $ofiles, $oprojid, $opackid, $l, $orev) = @_;
2460
2461   # append patches from link l to link nl
2462   my $nl = readxml("$srcrep/$packid/$files->{'_link'}-_link", $BSXML::link);
2463
2464   # FIXME: remove hunks from patches that deal with replaced/deleted files
2465   my $nlchanged;
2466   my %dontcopy;
2467   $dontcopy{'_link'} = 1;
2468   my $nlisbranch;
2469   if ($nl->{'patches'}) {
2470     for (@{$nl->{'patches'}->{''} || []}) {
2471       my $type = (keys %$_)[0];
2472       if ($type eq 'add' || $type eq 'apply') {
2473         $dontcopy{$_->{$type}->{'name'}} = 1;
2474       }
2475       $nlisbranch = 1 if $type eq 'branch';
2476     }
2477   }
2478   my $lisbranch;
2479   if ($l->{'patches'}) {
2480     for (@{$l->{'patches'}->{''} || []}) {
2481       my $type = (keys %$_)[0];
2482       $lisbranch = 1 if $type eq 'branch';
2483     }
2484   }
2485
2486   if ($nlisbranch) {
2487     # we linked/branched a branch. expand.
2488     my %xrev = (%$rev, 'linkrev' => 'base');
2489     lsrev_expanded(\%xrev);
2490     my %oxrev = (%$orev, 'linkrev' => $xrev{'srcmd5'});
2491     $ofiles = lsrev_expanded(\%oxrev);
2492     copyfiles($projid, $packid, $oprojid, $opackid, $ofiles);
2493     # find new base
2494     if ($xrev{'srcmd5'} ne $nl->{'baserev'}) {
2495       # update base rev
2496       $nl->{'baserev'} = $xrev{'srcmd5'};
2497       $nlchanged = 1;
2498     }
2499   }
2500
2501   if ($lisbranch && !$nlisbranch) {
2502     # we branched a link. convert branch to link
2503     # and integrate
2504     delete $ofiles->{'_link'};
2505     $ofiles = keeplink({'convertbranchtopatch' => 1, 'linkrev' => 'base'}, $oprojid, $opackid, $ofiles, $orev);
2506     $l = readxml("$srcrep/$opackid/$ofiles->{'_link'}-_link", $BSXML::link);
2507   }
2508
2509   if (!$nlisbranch && $l->{'patches'}) {
2510     for (@{$l->{'patches'}->{''} || []}) {
2511       my $type = (keys %$_)[0];
2512       if ($type eq 'delete' && $files->{$_->{'delete'}->{'name'}}) {
2513         delete $files->{$_->{'delete'}->{'name'}};
2514       } else {
2515         $nlchanged = 1;
2516         $nl->{'patches'} ||= {};
2517         if ($type eq 'apply') {
2518           my $oppatch = $_->{'apply'}->{'name'};
2519           if ($files->{$oppatch}) {
2520             $dontcopy{$oppatch} = 1;
2521             # argh, patch file already exists, rename...
2522             my $ppatch = findprojectpatchname($files);
2523             mkdir_p($uploaddir);
2524             unlink("$uploaddir/$$");
2525             link("$srcrep/$opackid/$ofiles->{$oppatch}-$oppatch", "$uploaddir/$$") || die("link $srcrep/$opackid/$ofiles->{$oppatch}-$oppatch $uploaddir/$$: $!\n");
2526             $files->{$ppatch} = addfile($projid, $packid, "$uploaddir/$$", $ppatch);
2527             push @{$nl->{'patches'}->{''}}, {'apply' => {'name' => $ppatch}};
2528             next;
2529           }
2530         }
2531         if ($type eq 'add') {
2532           my $oppatch = $_->{'add'}->{'name'};
2533           die("cannot apply patch $oppatch twice\n") if $dontcopy{$oppatch};
2534         }
2535         push @{$nl->{'patches'}->{''}}, $_;
2536       }
2537     }
2538   }
2539   if ($nlchanged) {
2540     mkdir_p($uploaddir);
2541     writexml("$uploaddir/$$", undef, $nl, $BSXML::link);
2542     $files->{'_link'} = addfile($projid, $packid, "$uploaddir/$$", '_link')
2543   }
2544   for (sort keys %$ofiles) {
2545     next if $dontcopy{$_};
2546     $files->{$_} = $ofiles->{$_};
2547   }
2548   return $files;
2549 }
2550
2551 sub sourcecommit {
2552   my ($cgi, $projid, $packid) = @_;
2553   my $rev = getrev($projid, $packid, defined($cgi->{'rev'}) ? $cgi->{'rev'} : 'upload');
2554   my $files = lsrev($rev);
2555   $files = keeplink($cgi, $projid, $packid, $files) if $cgi->{'keeplink'};
2556   my $user = defined($cgi->{'user'}) ? $cgi->{'user'} : 'unknown';
2557   my $comment = defined($cgi->{'comment'}) ? $cgi->{'comment'} : '';
2558   $rev = addrev($projid, $packid, $files, $user, $comment);
2559   if ($files->{'_service'} && !$cgi->{'noservice'}) {
2560     my $sslockfile = "$eventdir/service/${projid}::$packid";
2561     mkdir_p("$eventdir/service");
2562     BSUtil::touch($sslockfile);
2563     sourceupdate($projid, $packid, $sslockfile);
2564   }
2565   delete $rev->{'project'};
2566   delete $rev->{'package'};
2567   return ($rev, $BSXML::revision);
2568 }
2569
2570 sub sourcecommitfilelist {
2571   my ($cgi, $projid, $packid) = @_;
2572   mkdir_p($uploaddir);
2573   my $uploaded = BSServer::read_file("$uploaddir/$$");
2574   die("upload failed\n") unless $uploaded;
2575   my $fl = readxml("$uploaddir/$$", $BSXML::dir);
2576   unlink("$srcrep/:upload/$$");
2577   # make sure we know every file
2578   my @missing;
2579   my $files = {};
2580   for my $entry (@{$fl->{'entry'} || []}) {
2581     BSVerify::verify_filename($entry->{'name'});
2582     BSVerify::verify_md5($entry->{'md5'});
2583     if (! -e "$srcrep/$packid/$entry->{'md5'}-$entry->{'name'}") {
2584       push @missing, $entry;
2585     } else {
2586       die("duplicate file: $entry->{'name'}\n") if exists $files->{$entry->{'name'}};
2587       $files->{$entry->{'name'}} = $entry->{'md5'};
2588     }
2589   }
2590   if (@missing) {
2591     my $res = {'name' => $packid, 'error' => 'missing', 'entry' => \@missing};
2592     return ($res, $BSXML::dir);
2593   }
2594
2595   $files = keeplink($cgi, $projid, $packid, $files) if $cgi->{'keeplink'};
2596   my $user = defined($cgi->{'user'}) ? $cgi->{'user'} : 'unknown';
2597   my $comment = defined($cgi->{'comment'}) ? $cgi->{'comment'} : '';
2598   if (-e "$projectsdir/$projid.pkg/$packid.upload-MD5SUMS") {
2599     # autocommit old update revision so that it doesn't get lost
2600     my $uploadrev = {'project' => $projid, 'package' => $packid, 'srcmd5' => 'upload'};
2601     my $uploadfiles = lsrev($uploadrev);
2602     addrev($projid, $packid, $uploadfiles, $user, 'autocommit');
2603   }
2604   my $rev = addrev($projid, $packid, $files, $user, $comment);
2605
2606   $cgi->{'rev'} = $rev->{'rev'};
2607   return getfilelist($cgi, $projid, $packid);
2608 }
2609
2610 sub sourcecopy {
2611   my ($cgi, $projid, $packid) = @_;
2612   die("illegal rev parameter\n") if $cgi->{'rev'} && $cgi->{'rev'} ne 'upload';
2613   my $oprojid = exists($cgi->{'oproject'}) ? $cgi->{'oproject'} : $projid;
2614   my $opackid = exists($cgi->{'opackage'}) ? $cgi->{'opackage'} : $packid;
2615   my $orev = $cgi->{'orev'};
2616   $orev = getrev($oprojid, $opackid, defined($orev) ? $orev : 'latest');
2617   $orev->{'linkrev'} = $cgi->{'olinkrev'} if $cgi->{'olinkrev'};
2618   my $files = lsrev($orev);
2619   die("need a revision to copy\n") if !$cgi->{'rev'} && !$cgi->{'orev'} && $oprojid eq $projid && $opackid eq $packid && !($files->{'_link'} && $cgi->{'expand'});
2620
2621   my $autosimplifylink;
2622
2623   if ($files->{'_link'} && !$cgi->{'dontupdatesource'} && !$cgi->{'rev'}) {
2624     # fix me: do this in a more generic way
2625     my $ol = readxml("$srcrep/$opackid/$files->{'_link'}-_link", $BSXML::link, 1);
2626     if ($ol) {
2627       my $lprojid = $oprojid;
2628       my $lpackid = $opackid;
2629       my $lrev = $ol->{'rev'};
2630       $lprojid = $ol->{'project'} if exists $ol->{'project'};
2631       $lpackid = $ol->{'package'} if exists $ol->{'package'};
2632       if ($lprojid eq $projid && $lpackid eq $packid) {
2633         # copy destination is target of link
2634         # we're integrating this link
2635         $lrev = getrev($lprojid, $lpackid, $lrev);
2636         my $lfiles = lsrev($lrev);
2637         if ($lfiles->{'_link'} && !$cgi->{'expand'}) {
2638           # link to a link, join
2639           $files = integratelink($lfiles, $lprojid, $lpackid, $lrev, $files, $oprojid, $opackid, $ol, $orev);
2640         } else {
2641           # auto expand
2642           $cgi->{'expand'} = 1;
2643         }
2644         $autosimplifylink = $ol;
2645       }
2646     }
2647   }
2648
2649   if ($files->{'_link'} && $cgi->{'expand'}) {
2650     my %olrev = %$orev;         # copy so that orev still points to unexpanded sources
2651     $files = handlelinks(\%olrev, $files);
2652     die("broken link: $files\n") unless ref $files;
2653   }
2654
2655   copyfiles($projid, $packid, $oprojid, $opackid, $files);
2656
2657   $files = keeplink($cgi, $projid, $packid, $files) if $cgi->{'keeplink'};
2658   my $user = defined($cgi->{'user'}) ? $cgi->{'user'} : 'unknown';
2659   my $comment = defined($cgi->{'comment'}) ? $cgi->{'comment'} : '';
2660   my $rev = addrev($projid, $packid, $files, $user, $comment, $cgi->{'rev'}, $cgi->{'requestid'});
2661
2662   if ($autosimplifylink && !$autosimplifylink->{'rev'}) {
2663     my $isbranch = grep {(keys %$_)[0] eq 'branch'} @{$autosimplifylink->{'patches'}->{''} || []};
2664     if ($isbranch) {
2665       # update base rev so that there are no changes
2666       # FIXME: this is a gross hack...
2667       # we should not need to update the baserev, instead we should change
2668       # the way branches get applied
2669       my $ofiles = lsrev($orev);
2670       delete $ofiles->{'_link'};
2671       copyfiles($projid, $packid, $oprojid, $opackid, $ofiles);
2672       my $newbase = addmeta($projid, $packid, $ofiles);
2673       if ($autosimplifylink->{'baserev'} ne $newbase) {
2674         eval {
2675           my $latestorev = getrev($oprojid, $opackid);
2676           my $latestfiles = lsrev($latestorev);
2677           if ($latestfiles->{'_link'}) {
2678             my $latestl = readxml("$srcrep/$opackid/$latestfiles->{'_link'}-_link", $BSXML::link, 1);
2679             my $latestisbranch = grep {(keys %$_)[0] eq 'branch'} @{$latestl->{'patches'}->{''} || []};
2680             if ($latestisbranch && $latestl->{'baserev'} eq $autosimplifylink->{'baserev'}) {
2681               $latestl->{'baserev'} = $newbase;
2682               $latestl->{'patches'}->{''} = [ { 'branch' => undef} ]; # work around xml problem
2683               mkdir_p($uploaddir);
2684               writexml("$uploaddir/$$", undef, $latestl, $BSXML::link);
2685               $latestfiles->{'_link'} = addfile($oprojid, $opackid, "$uploaddir/$$", '_link');
2686               addrev($oprojid, $opackid, $latestfiles, 'buildservice-autocommit', "baserev update by copy to link target\n", undef, $cgi->{'requestid'});
2687             }
2688           }
2689         };
2690         warn($@) if $@;
2691       }
2692     } else {
2693       eval {
2694         my $latestorev = getrev($oprojid, $opackid);
2695         if ($latestorev->{'srcmd5'} eq $orev->{'srcmd5'}) {
2696           # simplify link
2697           my $nl = {};
2698           $nl->{'project'} = $autosimplifylink->{'project'} if $autosimplifylink->{'project'};
2699           $nl->{'package'} = $autosimplifylink->{'package'} if $autosimplifylink->{'package'};
2700           $nl->{'cicount'} = $autosimplifylink->{'cicount'} if $autosimplifylink->{'cicount'};
2701           mkdir_p($uploaddir);
2702           writexml("$uploaddir/$$", undef, $nl, $BSXML::link);
2703           my $ofiles = {};
2704           $ofiles->{'_link'} = addfile($oprojid, $opackid, "$uploaddir/$$", '_link');
2705           addrev($oprojid, $opackid, $ofiles, 'buildservice-autocommit', "auto commit by copy to link target\n", undef, $cgi->{'requestid'});
2706         }
2707       };
2708       warn($@) if $@;
2709     }
2710   }
2711
2712   delete $rev->{'project'};
2713   delete $rev->{'package'};
2714   return ($rev, $BSXML::revision);
2715 }
2716
2717 sub sourcebranch {
2718   my ($cgi, $projid, $packid) = @_;
2719
2720   my $usebranch = 1;
2721   my $oprojid = exists($cgi->{'oproject'}) ? $cgi->{'oproject'} : $projid;
2722   my $opackid = exists($cgi->{'opackage'}) ? $cgi->{'opackage'} : $packid;
2723   my $orev = $cgi->{'orev'};
2724   die("cannot branch myself\n") if $oprojid eq $projid && $opackid eq $packid;
2725   $orev = getrev($oprojid, $opackid);
2726   $orev->{'linkrev'} = $cgi->{'olinkrev'} if $cgi->{'olinkrev'};
2727   my $files = lsrev_expanded($orev);
2728   my $l = {};
2729   $l->{'project'} = $oprojid if $oprojid ne $projid;
2730   $l->{'package'} = $opackid if $opackid ne $projid;
2731   $l->{'rev'} = $cgi->{'orev'} if defined $cgi->{'orev'};
2732   $l->{'baserev'} = $orev->{'srcmd5'};
2733   my $lfiles = {};
2734   mkdir_p("$srcrep/$packid");
2735   if ($usebranch) {
2736     $l->{'patches'}->{''} = [ { 'branch' => undef} ];
2737     copyfiles($projid, $packid, $oprojid, $opackid, $files);
2738     $lfiles->{$_} = $files->{$_} for keys %$files;
2739   }
2740   mkdir_p($uploaddir);
2741   writexml("$uploaddir/$$", undef, $l, $BSXML::link);
2742   $lfiles->{'_link'} = addfile($projid, $packid, "$uploaddir/$$", '_link');
2743   my $user = defined($cgi->{'user'}) ? $cgi->{'user'} : 'unknown';
2744   my $comment = defined($cgi->{'comment'}) ? $cgi->{'comment'} : '';
2745   my $rev = addrev($projid, $packid, $lfiles, $user, $comment);
2746   delete $rev->{'project'};
2747   delete $rev->{'package'};
2748   return ($rev, $BSXML::revision);
2749 }
2750
2751 sub linktobranch {
2752   my ($cgi, $projid, $packid) = @_;
2753   my $rev = getrev($projid, $packid);
2754   $rev->{'linkrev'} = $cgi->{'linkrev'} if $cgi->{'linkrev'};
2755   my $files = lsrev($rev);
2756   die("package is not a link\n") unless $files->{'_link'};
2757   my $l = readxml("$srcrep/$packid/$files->{'_link'}-_link", $BSXML::link);
2758   die("package is already a branch\n") if $l->{'patches'} && grep {(keys %$_)[0] eq 'branch'} @{$l->{'patches'}->{''} || []};
2759   my $linkinfo = {};
2760   $files = lsrev_expanded($rev, $linkinfo);
2761   $l->{'baserev'} = $linkinfo->{'srcmd5'};
2762   $l->{'patches'}->{''} = [ { 'branch' => undef} ];
2763   mkdir_p($uploaddir);
2764   writexml("$uploaddir/$$", undef, $l, $BSXML::link);
2765   $files->{'_link'} = addfile($projid, $packid, "$uploaddir/$$", '_link');
2766   my $user = defined($cgi->{'user'}) ? $cgi->{'user'} : 'unknown';
2767   my $comment = defined($cgi->{'comment'}) ? $cgi->{'comment'} : '';
2768   $comment ||= "converted link to branch";
2769   $rev = addrev($projid, $packid, $files, $user, $comment);
2770   delete $rev->{'project'};
2771   delete $rev->{'package'};
2772   return ($rev, $BSXML::revision);
2773 }
2774
2775 sub deleteuploadrev {
2776   my ($cgi, $projid, $packid) = @_;
2777   unlink("$projectsdir/$projid.pkg/$packid.upload-MD5SUMS");
2778   return $BSStdServer::return_ok;
2779 }
2780
2781 sub unknowncmd {
2782   my ($cgi, $projid, $packid) = @_;
2783   die("unknown command \"$cgi->{'cmd'}\"\n");
2784 }
2785
2786 sub delfile {
2787   my ($cgi, $projid, $packid, $filename) = @_;
2788   die("no filename\n") unless defined($filename) && $filename ne '';
2789   die("bad filename\n") if $filename =~ /\// || $filename =~ /^\./;
2790   die("file '$filename' is read-only\n") if ($filename =~ /^_service:/) && not $cgi->{'force'};
2791   my $rev = getrev($projid, $packid, defined($cgi->{'rev'}) ? $cgi->{'rev'} : 'upload');
2792   my $files = lsrev($rev);
2793   die("file '$filename' does not exist\n") unless $files->{$filename};
2794   delete $files->{$filename};
2795   $files = keeplink($projid, $packid, $files) if $cgi->{'keeplink'};
2796   my $user = defined($cgi->{'user'}) ? $cgi->{'user'} : 'unknown';
2797   my $comment = defined($cgi->{'comment'}) ? $cgi->{'comment'} : '';
2798   $rev = addrev($projid, $packid, $files, $user, $comment, $cgi->{'rev'});
2799   delete $rev->{'project'};
2800   delete $rev->{'package'};
2801   return ($rev, $BSXML::revision);
2802 }
2803
2804 sub getrepositorylist {
2805   my ($cgi, $projid) = @_;
2806   my $proj = readproj($projid);
2807   my @res = map {{'name' => $_->{'name'}}} @{$proj->{'repository'} || []};
2808   return ({'entry' => \@res}, $BSXML::dir);
2809 }
2810
2811 sub getrepository {
2812   my ($cgi, $projid, $repoid) = @_;
2813   my $proj = readproj($projid);
2814   my $repo = (grep {$_->{'name'} eq $repoid} @{$proj->{'repository'} || []})[0];
2815   die("$repoid: no such repository\n") unless $repo;
2816   return ($repo, $BSXML::repo);
2817 }
2818
2819 sub getarchlist {
2820   my ($cgi, $projid, $repoid) = @_;
2821   my $proj = readproj($projid);
2822   my @repo = grep {$_->{'name'} eq $repoid} @{$proj->{'repository'} || []};
2823   die("$repoid: no such repository\n") unless @repo;
2824   my @res = map {{'name' => $_}} @{$repo[0]->{'arch'} || []};
2825   return ({'entry' => \@res}, $BSXML::dir);
2826 }
2827
2828 sub getresult {
2829   my ($cgi, $projid) = @_;
2830
2831   if ($cgi->{'oldstate'} && !$BSStdServer::isajax) {
2832     my @args = "oldstate=$cgi->{'oldstate'}";
2833     push @args, "lastbuild" if $cgi->{'lastbuild'};
2834     push @args, map {"view=$_"} @{$cgi->{'view'} || []};
2835     push @args, map {"repository=$_"} @{$cgi->{'repository'} || []};
2836     push @args, map {"arch=$_"} @{$cgi->{'arch'} || []};
2837     push @args, map {"package=$_"} @{$cgi->{'package'} || []};
2838     push @args, map {"code=$_"} @{$cgi->{'code'} || []};
2839     BSHandoff::handoff($ajaxsocket, "/build/$projid/_result", undef, @args);
2840     exit(0);
2841   }
2842
2843   my %repoidfilter = map {$_ => 1} @{$cgi->{'repository'} || []};
2844   my %archfilter = map {$_ => 1} @{$cgi->{'arch'} || []};
2845   my %view = map {$_ => 1} @{$cgi->{'view'} || ['status']};
2846   my %code = map {$_ => 1} @{$cgi->{'code'} || []};
2847
2848   my $proj = readproj($projid);
2849   if ($cgi->{'repository'}) {
2850     my %knownrepoids = map {$_->{'name'} => 1} @{$proj->{'repository'} || []};
2851     for (@{$cgi->{'repository'}}) {
2852       die("unknown repository '$_'\n") if !$knownrepoids{$_};
2853     }
2854   }
2855   if ($cgi->{'package'}) {
2856     my %knownpackids = map {$_ => 1} findpackages($projid);
2857     for (@{$cgi->{'package'}}) {
2858       die("unknown package '$_'\n") if !$knownpackids{$_};
2859     }
2860   }
2861   my @prpas;
2862   for my $repo (@{$proj->{'repository'} || []}) {
2863     next if %repoidfilter && !$repoidfilter{$repo->{'name'}};
2864     my @archs = @{$repo->{'arch'} || []};
2865     @archs = grep {$archfilter{$_}} @archs if %archfilter;
2866     push @prpas, map {"$projid/$repo->{'name'}/$_"} @archs;
2867   }
2868
2869   BSWatcher::addfilewatcher("$projectsdir/$projid.xml") if $BSStdServer::isajax;
2870
2871   if (!@prpas) {
2872     my $state = "00000000000000000000000000000000";
2873     return undef if $BSStdServer::isajax && $cgi->{'oldstate'} && $state eq $cgi->{'oldstate'};
2874     return ({'state' => $state}, $BSXML::resultlist);
2875   }
2876
2877   my $ps = {};
2878   # XXX FIXME multiple repo handling
2879   for my $rrserver ($BSConfig::reposerver) {
2880     my @args;
2881     push @args, "lastbuild" if $cgi->{'lastbuild'};
2882     push @args, "oldstate=$cgi->{'oldstate'}" if $cgi->{'oldstate'};
2883     push @args, map {"prpa=$_"} @prpas;
2884     push @args, map {"package=$_"} @{$cgi->{'package'} || []};
2885     push @args, map {"code=$_"} @{$cgi->{'code'} || []};
2886     push @args, "withbinarylist" if $view{'binarylist'};
2887     eval {
2888       $ps = BSWatcher::rpc("$rrserver/_result", $BSXML::resultlist, @args);
2889     };
2890     if ($@) {
2891       print "warning: $rrserver: $@";
2892       $ps = {};
2893     }
2894   }
2895   return if $BSStdServer::isajax && !defined($ps);
2896   if ($view{'summary'}) {
2897     my @order = ('succeeded', 'failed', 'expansion error', 'broken', 'scheduled');
2898     my %order = map {$_ => 1} @order;
2899     for my $p (@{$ps->{'result'} || []}) {
2900       my %sum;
2901       for my $pp (@{$p->{'status'} || []}) {
2902         $sum{$pp->{'code'}}++ if $pp->{'code'};
2903       }
2904       my @sum = grep {exists $sum{$_}} @order;
2905       push @sum, grep {!$order{$_}} sort keys %sum;
2906       $p->{'summary'} = {'statuscount' => [ map {{'code' => $_, 'count' => $sum{$_}}} @sum ] };
2907     }
2908   }
2909   if (!$view{'status'}) {
2910     for my $p (@{$ps->{'result'} || []}) {
2911       delete $p->{'status'};
2912     }
2913   }
2914   return ($ps, $BSXML::resultlist);
2915 }
2916
2917 sub docommand {
2918   my ($cgi, $projid) = @_;
2919
2920   my %repoidfilter = map {$_ => 1} @{$cgi->{'repository'} || []};
2921   my %archfilter = map {$_ => 1} @{$cgi->{'arch'} || []};
2922
2923   my $proj = readproj($projid);
2924   my @prpas;
2925   for my $repo (@{$proj->{'repository'} || []}) {
2926     next if %repoidfilter && !$repoidfilter{$repo->{'name'}};
2927     my @archs = @{$repo->{'arch'} || []};
2928     @archs = grep {$archfilter{$_}} @archs if %archfilter;
2929     push @prpas, map {"$projid/$repo->{'name'}/$_"} @archs;
2930   }
2931   die("no repository defined\n") unless @prpas;
2932   my @packids = @{$cgi->{'package'} || []};
2933   if (@packids) {
2934     my %packids = map {$_ => 1} findpackages($projid);
2935     my @badpacks = grep {!$packids{$_}} @packids;
2936     die("unknown package: @badpacks\n") if @badpacks;
2937   } else {
2938     @packids = findpackages($projid);
2939   }
2940   die("no packages defined\n") unless @packids;
2941   
2942   # XXX FIXME multiple repo handling
2943   my $res;
2944   for my $rrserver ($BSConfig::reposerver) {
2945     my @args;
2946     push @args, map {"prpa=$_"} @prpas;
2947     push @args, map {"package=$_"} @packids;
2948     push @args, map {"code=$_"} @{$cgi->{'code'} || []};
2949     push @args, "cmd=$cgi->{'cmd'}";
2950     $res = BSWatcher::rpc("$rrserver/_command", undef, @args);
2951   }
2952   return $res;
2953 }
2954
2955 sub checkprojrepoarch {
2956   my ($projid, $repoid, $arch, $remoteok) = @_;
2957   my $proj = readproj($projid, 1);
2958   $proj = remoteprojid($projid) if $remoteok && (!$proj || $proj->{'remoteurl'});
2959   die("project '$projid' does not exist\n") if !$proj;
2960   die("project '$projid' is remote\n") if $proj->{'remoteurl'} && !$remoteok;
2961   return $proj if $proj->{'remoteurl'};
2962   return $proj unless defined $repoid;
2963   my $repo = (grep {$_->{'name'} eq $repoid} @{$proj->{'repository'} || []})[0];
2964   die("project has no repository '$repoid'\n") unless $repo;
2965   return $proj unless defined $arch;
2966   die("project has no architecture '$arch'\n") unless grep {$_ eq $arch} @{$repo->{'arch'} || []};
2967   return $proj;
2968 }
2969
2970 sub getbuilddepinfo {
2971   my ($cgi, $projid, $repoid, $arch) = @_;
2972
2973   checkprojrepoarch($projid, $repoid, $arch);
2974   my @args;
2975   push @args, map {"package=$_"} @{$cgi->{'package'} || []};
2976   push @args, "view=$cgi->{'view'}" if $cgi->{'view'};
2977   my $res = BSWatcher::rpc("$BSConfig::reposerver/build/$projid/$repoid/$arch/_builddepinfo", $BSXML::builddepinfo, @args);
2978   return ($res, $BSXML::builddepinfo);
2979 }
2980
2981 sub getjobhistory {
2982   my ($cgi, $projid, $repoid, $arch) = @_;
2983
2984   checkprojrepoarch($projid, $repoid, $arch);
2985   my @args;
2986   push @args, "limit=$cgi->{'limit'}" if $cgi->{'limit'};
2987   push @args, map {"package=$_"} @{$cgi->{'package'} || []};
2988   push @args, map {"code=$_"} @{$cgi->{'code'} || []};
2989   my $res = BSWatcher::rpc("$BSConfig::reposerver/build/$projid/$repoid/$arch/_jobhistory", $BSXML::jobhistlist, @args);
2990   return ($res, $BSXML::jobhistlist);
2991 }
2992
2993
2994 sub getbinarylist {
2995   my ($cgi, $projid, $repoid, $arch, $packid) = @_;
2996
2997   my $proj = checkprojrepoarch($projid, $repoid, $arch, 1);
2998   my $view = $cgi->{'view'};
2999   my @args;
3000   push @args, "view=$view" if $view;
3001   push @args, map {"binary=$_"} @{$cgi->{'binary'} || []};
3002   if ($view && ($view eq 'cache' || $view eq 'cpio' || $view eq 'solv' || $view eq 'solvstate')) {
3003     if (!$BSStdServer::isajax) {
3004       BSHandoff::handoff($ajaxsocket, "/build/$projid/$repoid/$arch/$packid", undef, @args);
3005       exit(0);
3006     }
3007     my $param = {
3008       'uri' => "$BSConfig::reposerver/build/$projid/$repoid/$arch/$packid",
3009       'ignorestatus' => 1,
3010       'receiver' => \&BSServer::reply_receiver,
3011     };
3012     $param->{'uri'} = "$proj->{'remoteurl'}/build/$proj->{'remoteproject'}/$repoid/$arch/$packid" if $proj->{'remoteurl'};
3013     BSWatcher::rpc($param, undef, @args);
3014     return undef;
3015   }
3016   my $uri = "$BSConfig::reposerver/build/$projid/$repoid/$arch/$packid";
3017   $uri = "$proj->{'remoteurl'}/build/$proj->{'remoteproject'}/$repoid/$arch/$packid" if $proj->{'remoteurl'};
3018   if ($view && $view eq 'binaryversions') {
3019     push @args, 'nometa=1' if $cgi->{'nometa'};
3020     my $bvl = BSWatcher::rpc($uri, $BSXML::binaryversionlist, @args);
3021     return ($bvl, $BSXML::binaryversionlist);
3022   }
3023   my $bl = BSWatcher::rpc($uri, $BSXML::binarylist, @args);
3024   return ($bl, $BSXML::binarylist);
3025 }
3026
3027 sub getbinary {
3028   my ($cgi, $projid, $repoid, $arch, $packid, $filename) = @_;
3029   my $proj = checkprojrepoarch($projid, $repoid, $arch, 1);
3030   my $view = $cgi->{'view'} || '';
3031   if ($proj->{'remoteurl'}) {
3032     # hack: reroute to /getbinaries so that our local cache is used
3033     die("can only access remote _repository files\n") unless $packid eq '_repository';
3034     die("cannot use a view for remote binaries\n") if $view;
3035     die("need the raw package name as filename for remote repository access\n") if $filename =~ /\.(?:rpm|deb)$/;
3036     my @args;
3037     push @args, "project=$projid";
3038     push @args, "repository=$repoid";
3039     push @args, "arch=$arch";
3040     push @args, "binaries=$filename";
3041     push @args, "raw=1";
3042     BSHandoff::handoff($ajaxsocket, '/getbinaries', undef, @args);
3043     exit(0);
3044   }
3045   my @args;
3046   push @args, "view=$view" if $view;
3047   my $param = {
3048     'uri' => "$BSConfig::reposerver/build/$projid/$repoid/$arch/$packid/$filename",
3049     'ignorestatus' => 1,
3050     'receiver' => \&BSServer::reply_receiver,
3051   };
3052   BSWatcher::rpc($param, undef, @args);
3053   return undef;
3054 }
3055
3056 sub putbinary {
3057   my ($cgi, $projid, $repoid, $arch, $filename) = @_;
3058   checkprojrepoarch($projid, $repoid, $arch);
3059   my @args;
3060   push @args, 'ignoreolder=1' if $cgi->{'ignoreolder'};
3061   push @args, 'wipe=1' if $cgi->{'wipe'};
3062   my $param = {
3063     'uri' => "$BSConfig::reposerver/build/$projid/$repoid/$arch/_repository/$filename",
3064     'request' => 'PUT',
3065     'data' => \&BSServer::forward_sender,
3066     'chunked' => 1,
3067   };
3068   # XXX add return type checking
3069   return BSWatcher::rpc($param, undef, @args);
3070 }
3071
3072 sub uploadbuild {
3073   my ($cgi, $projid, $repoid, $arch, $packid) = @_;
3074   checkprojrepoarch($projid, $repoid, $arch);
3075   my $param = {
3076     'uri' => "$BSConfig::reposerver/build/$projid/$repoid/$arch/$packid",
3077     'request' => 'POST',
3078     'data' => \&BSServer::forward_sender,
3079     'chunked' => 1,
3080   };
3081   # XXX add return type checking
3082   return BSWatcher::rpc($param, undef);
3083 }
3084
3085
3086 sub getlogfile {
3087   my ($cgi, $projid, $repoid, $arch, $packid) = @_;
3088   checkprojrepoarch($projid, $repoid, $arch);
3089
3090   if (!$cgi->{'start'}) {
3091     # check if the package is broken
3092     my $rev = getrev($projid, $packid, 'build');
3093     my $files = lsrev($rev);
3094     if (ref($files) && $files->{'_link'}) {
3095       $files = handlelinks($rev, $files);
3096       if (!ref $files) {
3097         my $error = "$files\n";
3098         if ($rev->{'srcmd5'}) {
3099           $files = lsrev($rev);
3100           if ($files->{'_linkerror'}) {
3101             $error = readstr("$srcrep/$packid/$files->{'_linkerror'}-_linkerror", 1);
3102           }
3103         }
3104         if ($cgi->{'view'} && $cgi->{'view'} eq 'entry') {
3105           my $entry = {'name' => '_log', 'size' => length($error)};
3106           return ({'entry' => [ $entry ]}, $BSXML::dir);
3107         }
3108         return $error;
3109       }
3110     }
3111   }
3112
3113   my @args;
3114   push @args, 'nostream' if $cgi->{'nostream'};
3115   push @args, "start=$cgi->{'start'}" if defined $cgi->{'start'};
3116   push @args, "end=$cgi->{'end'}" if defined $cgi->{'end'};
3117   push @args, "view=$cgi->{'view'}" if $cgi->{'view'};
3118   if (!$BSStdServer::isajax && !$cgi->{'view'}) {
3119     my $url = "/build/$projid/$repoid/$arch/$packid/_log";
3120     BSHandoff::handoff($ajaxsocket, $url, undef, @args);
3121     exit(0);
3122   }
3123   my $param = {
3124     'uri' => "$BSConfig::reposerver/build/$projid/$repoid/$arch/$packid/_log",
3125     'ignorestatus' => 1,
3126     'receiver' => \&BSServer::reply_receiver,
3127     'joinable' => 1,
3128   };
3129   BSWatcher::rpc($param, undef, @args);
3130   return undef; # always streams result
3131 }
3132
3133 sub getbuildhistory {
3134   my ($cgi, $projid, $repoid, $arch, $packid) = @_;
3135   checkprojrepoarch($projid, $repoid, $arch);
3136   my @args;
3137   push @args, "limit=$cgi->{'limit'}" if $cgi->{'limit'};
3138   my $buildhist = BSWatcher::rpc("$BSConfig::reposerver/build/$projid/$repoid/$arch/$packid/_history", $BSXML::buildhist, @args);
3139   return ($buildhist, $BSXML::buildhist);
3140 }
3141
3142 sub getbuildinfo {
3143   my ($cgi, $projid, $repoid, $arch, $packid) = @_;
3144   checkprojrepoarch($projid, $repoid, $arch);
3145   my @args;
3146   push @args, 'internal=1' if $cgi->{'internal'};
3147   push @args, map {"add=$_"} @{$cgi->{'add'} || []};
3148   my $buildinfo = BSWatcher::rpc("$BSConfig::reposerver/build/$projid/$repoid/$arch/$packid/_buildinfo", $BSXML::buildinfo, @args);
3149   return ($buildinfo, $BSXML::buildinfo);
3150 }
3151
3152 sub getbuildinfo_post {
3153   my ($cgi, $projid, $repoid, $arch, $packid) = @_;
3154   checkprojrepoarch($projid, $repoid, $arch);
3155   my @args;
3156   push @args, map {"add=$_"} @{$cgi->{'add'} || []};
3157   my $param = {
3158     'uri' => "$BSConfig::reposerver/build/$projid/$repoid/$arch/$packid/_buildinfo",
3159     'request' => 'POST',
3160     'data' => \&BSServer::forward_sender,
3161     'chunked' => 1,
3162   };
3163   my $buildinfo = BSWatcher::rpc($param, $BSXML::buildinfo, @args);
3164   return ($buildinfo, $BSXML::buildinfo);
3165 }
3166
3167 sub getbuildreason {
3168   my ($cgi, $projid, $repoid, $arch, $packid) = @_;
3169   checkprojrepoarch($projid, $repoid, $arch);
3170   my $reason = BSWatcher::rpc("$BSConfig::reposerver/build/$projid/$repoid/$arch/$packid/_reason", $BSXML::buildreason);
3171   return ($reason, $BSXML::buildreason);
3172 }
3173
3174 sub getbuildstatus {
3175   my ($cgi, $projid, $repoid, $arch, $packid) = @_;
3176   checkprojrepoarch($projid, $repoid, $arch);
3177   my $status = BSWatcher::rpc("$BSConfig::reposerver/build/$projid/$repoid/$arch/$packid/_status", $BSXML::buildstatus);
3178   return ($status, $BSXML::buildstatus);
3179 }
3180
3181 sub getworkerstatus {
3182   my ($cgi) = @_;
3183   my @args;
3184   push @args, 'scheduleronly' if $cgi->{'scheduleronly'};
3185   push @args, map {"arch=$_"} @{$cgi->{'arch'} || []};
3186   my $ws = BSWatcher::rpc("$BSConfig::reposerver/workerstatus", $BSXML::workerstatus, @args);
3187   delete $_->{'uri'} for @{$ws->{'idle'}};
3188   delete $_->{'uri'} for @{$ws->{'building'}};
3189   return ($ws, $BSXML::workerstatus);
3190 }
3191
3192 sub getajaxstatus {
3193   my ($cgi) = @_;
3194   if (!$BSStdServer::isajax) {
3195     BSHandoff::handoff($ajaxsocket, '/ajaxstatus');