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