X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=Debian%2FDgit.pm;h=37cbc51b68e52116705d1988cf040eef36919bda;hb=f643d6182a1490fe9969c1ed02306518699e0ebd;hp=f68ebd228366676e97e4921bcffd6446bf6345c9;hpb=f82da50bcda81c6b3751e172dc943d4c348f4f72;p=dgit.git diff --git a/Debian/Dgit.pm b/Debian/Dgit.pm index f68ebd22..37cbc51b 100644 --- a/Debian/Dgit.pm +++ b/Debian/Dgit.pm @@ -7,6 +7,7 @@ use warnings; use POSIX; use IO::Handle; +use Config; BEGIN { use Exporter (); @@ -15,12 +16,17 @@ BEGIN { $VERSION = 1.00; @ISA = qw(Exporter); @EXPORT = qw(debiantag server_branch server_ref - stat_exists git_for_each_ref - $package_re $component_re $branchprefix + stat_exists fail ensuredir waitstatusmsg failedcmd + cmdoutput cmdoutput_errok + git_rev_parse git_get_ref git_for_each_ref + git_for_each_tag_referring is_fast_fwd + $package_re $component_re $deliberately_re + $branchprefix initdebug enabledebug enabledebuglevel printdebug debugcmd $debugprefix *debuglevel *DEBUG shellquote printcmd); + # implicitly uses $main::us %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO)] ); @EXPORT_OK = @{ $EXPORT_TAGS{policyflags} }; } @@ -29,54 +35,15 @@ our @EXPORT_OK; our $package_re = '[0-9a-z][-+.0-9a-z]*'; our $component_re = '[0-9a-zA-Z][-+.0-9a-zA-Z]*'; +our $deliberately_re = "(?:TEST-)?$package_re"; our $branchprefix = 'dgit'; # policy hook exit status bits # see dgit-repos-server head comment for documentation -# 1 is reserved in case something fails with `exit 1' +# 1 is reserved in case something fails with `exit 1' and to spot +# dynamic loader, runtime, etc., failures, which report 127 or 255 sub NOFFCHECK () { return 0x2; } sub FRESHREPO () { return 0x4; } -# 0x80 is reserved - -sub debiantag ($) { - my ($v) = @_; - $v =~ y/~:/_%/; - return "debian/$v"; -} - -sub server_branch ($) { return "$branchprefix/$_[0]"; } -sub server_ref ($) { return "refs/".server_branch($_[0]); } - -sub stat_exists ($) { - my ($f) = @_; - return 1 if stat $f; - return 0 if $!==&ENOENT; - die "stat $f: $!"; -} - -sub git_for_each_ref ($$) { - my ($pattern,$func) = @_; - # calls $func->($objid,$objtype,$fullrefname,$reftail); - # $reftail is RHS of ref after refs/\w+/ - # breaks if $pattern matches any ref `refs/blah' where blah has no `/' - my $fh = new IO::File "-|", qw(git for-each-ref), $pattern or die $!; - while (<$fh>) { - m#^(\w+)\s+(\w+)\s+(refs/\w+/(\S+))\s# or die "$_ ?"; - $func->($1,$2,$3,$4); - } - $!=0; $?=0; close $fh or die "$pattern $? $!"; -} - -sub git_for_each_tag_referring ($$) { - my ($objreferring, $func) = @_; - # calls $func->($objid,$fullrefname,$tagname); - git_for_each_ref('refs/tags', sub { - my ($objid,$objtype,$fullrefname,$tagname) = @_; - next unless $objtype eq 'tag'; - next if defined $objreferring and $objid ne $objreferring; - $func->($objid,$fullrefname,$tagname); - }); -} our $debugprefix; our $debuglevel = 0; @@ -93,8 +60,12 @@ sub enabledebug () { } sub enabledebuglevel ($) { + my ($newlevel) = @_; # may be undef (eg from env var) die if $debuglevel; - $debuglevel = $_[0] + 0; + $newlevel //= 0; + $newlevel += 0; + return unless $newlevel; + $debuglevel = $newlevel; enabledebug(); } @@ -130,4 +101,148 @@ sub debugcmd { printcmd(\*DEBUG,$debugprefix.$extraprefix,@_) if $debuglevel>0; } +sub debiantag ($) { + my ($v) = @_; + $v =~ y/~:/_%/; + return "debian/$v"; +} + +sub server_branch ($) { return "$branchprefix/$_[0]"; } +sub server_ref ($) { return "refs/".server_branch($_[0]); } + +sub stat_exists ($) { + my ($f) = @_; + return 1 if stat $f; + return 0 if $!==&ENOENT; + die "stat $f: $!"; +} + +sub _us () { + $::us // ($0 =~ m#[^/]*$#, $&); +} + +sub fail { + my $s = "@_\n"; + my $prefix = _us().": "; + $s =~ s/^/$prefix/gm; + die $s; +} + +sub ensuredir ($) { + my ($dir) = @_; # does not create parents + return if mkdir $dir; + return if $! == EEXIST; + die "mkdir $dir: $!"; +} + +our @signames = split / /, $Config{sig_name}; + +sub waitstatusmsg () { + if (!$?) { + return "terminated, reporting successful completion"; + } elsif (!($? & 255)) { + return "failed with error exit status ".WEXITSTATUS($?); + } elsif (WIFSIGNALED($?)) { + my $signum=WTERMSIG($?); + return "died due to fatal signal ". + ($signames[$signum] // "number $signum"). + ($? & 128 ? " (core dumped)" : ""); # POSIX(3pm) has no WCOREDUMP + } else { + return "failed with unknown wait status ".$?; + } +} + +sub failedcmd { + { local ($!); printcmd \*STDERR, _us().": failed command:", @_ or die $!; }; + if ($!) { + fail "failed to fork/exec: $!"; + } elsif ($?) { + fail "subprocess ".waitstatusmsg(); + } else { + fail "subprocess produced invalid output"; + } +} + +sub cmdoutput_errok { + die Dumper(\@_)." ?" if grep { !defined } @_; + debugcmd "|",@_; + open P, "-|", @_ or die $!; + my $d; + $!=0; $?=0; + { local $/ = undef; $d =
; }
+ die $! if P->error;
+ if (!close P) { printdebug "=>!$?\n"; return undef; }
+ chomp $d;
+ $d =~ m/^.*/;
+ printdebug "=> \`$&'",(length $' ? '...' : ''),"\n" if $debuglevel>0; #';
+ return $d;
+}
+
+sub cmdoutput {
+ my $d = cmdoutput_errok @_;
+ defined $d or failedcmd @_;
+ return $d;
+}
+
+sub git_rev_parse ($) {
+ return cmdoutput qw(git rev-parse), "$_[0]~0";
+}
+
+sub git_for_each_ref ($$;$) {
+ my ($pattern,$func,$gitdir) = @_;
+ # calls $func->($objid,$objtype,$fullrefname,$reftail);
+ # $reftail is RHS of ref after refs/[^/]+/
+ # breaks if $pattern matches any ref `refs/blah' where blah has no `/'
+ my @cmd = (qw(git for-each-ref), $pattern);
+ if (defined $gitdir) {
+ @cmd = ('sh','-ec','cd "$1"; shift; exec "$@"','x', $gitdir, @cmd);
+ }
+ open GFER, "-|", @cmd or die $!;
+ debugcmd "|", @cmd;
+ while (