Infra: add some more debugging

[dgit.git] / infra / dgit-repos-server

diff --git a/infra/dgit-repos-server b/infra/dgit-repos-server
index 3f9298f2aa3bc61f645235e72c28e813b9b97fcf..8e939d025f904e2e7900cb761b40857fab005f26 100755 (executable)
--- a/infra/dgit-repos-server
+++ b/infra/dgit-repos-server
@@ -25,6 +25,7 @@
 # where AUTH-SPEC is one of
 #   a
 #   mDM.TXT
+# (With --cron AUTH-SPEC is not used and may be the empty string.)
 
 use strict;
 $SIG{__WARN__} = sub { die $_[0]; };
@@ -154,8 +155,9 @@ $SIG{__WARN__} = sub { die $_[0]; };
 #
 # check-list and check-package are invoked via the --cron option.
 # First, without any locking, check-list is called.  It should produce
-# a list of package names.  Then check-package will be invoked for
-# each named package, in each case after taking an appropriate lock.
+# a list of package names (one per line).  Then check-package will be
+# invoked for each named package, in each case after taking an
+# appropriate lock.
 #
 # If policy hook wants to run dgit (or something else in the dgit
 # package), it should use DGIT-LIVE-DIR/dgit (etc.)
@@ -164,6 +166,7 @@ $SIG{__WARN__} = sub { die $_[0]; };
 use POSIX;
 use Fcntl qw(:flock);
 use File::Path qw(rmtree);
+use File::Temp qw(tempfile);
 
 use Debian::Dgit qw(:DEFAULT :policyflags);
 
@@ -323,6 +326,17 @@ sub movetogarbage () {
        or die "$garbagerepo $!";
 }
 
+sub policy_checkpackage () {
+    my $lfh = lockrealtree();
+
+    $policy = policyhook(FRESHREPO,'check-package',$package);
+    if ($policy & FRESHREPO) {
+       movetogarbage();
+    }
+
+    close $lfh;
+}
+
 #----- git-receive-pack -----
 
 sub fixmissing__git_receive_pack () {
@@ -764,7 +778,7 @@ sub onwardpush () {
 }
 
 sub stunthook () {
-    debug "stunthook";
+    debug "stunthook in $workrepo";
     chdir $workrepo or die "chdir $workrepo: $!";
     mkdir "dgit-tmp" or $!==EEXIST or die $!;
     readupdates();
@@ -790,6 +804,7 @@ sub fixmissing__git_upload_pack () {
 
 sub main__git_upload_pack () {
     my $lfh = locksometree($destrepo);
+    debug "git-upload-pack in $destrepo";
     chdir $destrepo or die "$destrepo: $!";
     close $lfh;
     runcmd qw(git upload-pack), ".";
@@ -839,14 +854,7 @@ sub mode_ssh () {
 
     reject "unknown method" unless $mainfunc;
 
-    my $lfh = lockrealtree();
-
-    $policy = policyhook(FRESHREPO,'check-package',$package);
-    if ($policy & FRESHREPO) {
-       movetogarbage;
-    }
-
-    close $lfh;
+    policy_checkpackage();
 
     if (stat_exists realdestrepo) {
        $destrepo = realdestrepo;
@@ -860,6 +868,27 @@ sub mode_ssh () {
     &$mainfunc;
 }
 
+sub mode_cron () {
+    die if @ARGV;
+
+    my $listfh = tempfile();
+    open STDOUT, ">&", $listfh or die $!;
+    policyhook(0,'check-list');
+    open STDOUT, ">&STDERR" or die $!;
+
+    seek $listfh, 0, 0 or die $!;
+    while (<$listfh>) {
+       chomp or die;
+       next if m/^\s*\#/;
+       next unless m/\S/;
+       die unless m/^($package_re)$/;
+       
+       $package = $1;
+       policy_checkpackage();
+    }
+    die $! if $listfh->error;
+}    
+
 sub parseargsdispatch () {
     die unless @ARGV;
 
@@ -872,7 +901,13 @@ sub parseargsdispatch () {
     }
 
     if ($ARGV[0] eq '--pre-receive-hook') {
-       if ($debug) { $debug.="="; }
+       if ($debug) {
+           $debug.="=";
+           debug "in stunthook @ARGV";
+           foreach my $k (sort keys %ENV) {
+               debug "$k=$ENV{$k}" if $k =~  m/^DGIT/;
+           }
+       }
        shift @ARGV;
        @ARGV == 1 or die;
        $package = shift @ARGV;