X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=Debian%2FDgit.pm;h=5e0bbd5e63ce0b8f8ddac59b63bbd34476cb9d03;hp=ac44b9ab4c529f712a0c9322d2c1e2b146702250;hb=3fad6db8d44a435d456e9d79e2c6811ac2bc0364;hpb=0711cc9a16065c5e69406eb9d182cc686600a366 diff --git a/Debian/Dgit.pm b/Debian/Dgit.pm index ac44b9ab..5e0bbd5e 100644 --- a/Debian/Dgit.pm +++ b/Debian/Dgit.pm @@ -1,13 +1,34 @@ # -*- perl -*- +# dgit +# Debian::Dgit: functions common to dgit and its helpers and servers +# +# Copyright (C) 2015-2016 Ian Jackson +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . package Debian::Dgit; use strict; use warnings; +use Carp; use POSIX; use IO::Handle; use Config; +use Digest::SHA; +use Data::Dumper; +use IPC::Open2; BEGIN { use Exporter (); @@ -15,21 +36,28 @@ BEGIN { $VERSION = 1.00; @ISA = qw(Exporter); - @EXPORT = qw(setup_sigwarn - debiantag server_branch server_ref - stat_exists fail ensuredir executable_on_path - waitstatusmsg failedcmd + @EXPORT = qw(setup_sigwarn forkcheck_setup forkcheck_mainprocess + dep14_version_mangle + debiantags debiantag_old debiantag_new + server_branch server_ref + stat_exists link_ltarget + hashfile + fail ensuredir executable_on_path + waitstatusmsg failedcmd_waitstatus + failedcmd_report_cmd failedcmd cmdoutput cmdoutput_errok - git_rev_parse git_get_ref git_for_each_ref + git_rev_parse git_cat_file + git_get_ref git_for_each_ref git_for_each_tag_referring is_fast_fwd $package_re $component_re $deliberately_re + $distro_re $versiontag_re $branchprefix initdebug enabledebug enabledebuglevel printdebug debugcmd $debugprefix *debuglevel *DEBUG shellquote printcmd messagequote); # implicitly uses $main::us - %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO)] ); + %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO NOCOMMITCHECK)] ); @EXPORT_OK = @{ $EXPORT_TAGS{policyflags} }; } @@ -38,6 +66,8 @@ 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 $distro_re = $component_re; +our $versiontag_re = qr{[-+.\%_0-9a-zA-Z/]+}; our $branchprefix = 'dgit'; # policy hook exit status bits @@ -46,14 +76,26 @@ our $branchprefix = 'dgit'; # dynamic loader, runtime, etc., failures, which report 127 or 255 sub NOFFCHECK () { return 0x2; } sub FRESHREPO () { return 0x4; } +sub NOCOMMITCHECK () { return 0x8; } our $debugprefix; our $debuglevel = 0; +our $forkcheck_mainprocess; + +sub forkcheck_setup () { + $forkcheck_mainprocess = $$; +} + +sub forkcheck_mainprocess () { + # You must have called forkcheck_setup or setup_sigwarn already + getppid != $forkcheck_mainprocess; +} + sub setup_sigwarn () { - our $sigwarn_mainprocess = $$; + forkcheck_setup(); $SIG{__WARN__} = sub { - die $_[0] unless getppid == $sigwarn_mainprocess; + die $_[0] if forkcheck_mainprocess; }; } @@ -120,10 +162,27 @@ sub debugcmd { printcmd(\*DEBUG,$debugprefix.$extraprefix,@_) if $debuglevel>0; } -sub debiantag ($$) { - my ($v,$distro) = @_; +sub dep14_version_mangle ($) { + my ($v) = @_; + # DEP-14 patch proposed 2016-11-09 "Version Mangling" $v =~ y/~:/_%/; - return "$distro/$v"; + $v =~ s/\.(?=\.|$|lock$)/.#/g; + return $v; +} + +sub debiantag_old ($$) { + my ($v,$distro) = @_; + return "$distro/". dep14_version_mangle $v; +} + +sub debiantag_new ($$) { + my ($v,$distro) = @_; + return "archive/$distro/".dep14_version_mangle $v; +} + +sub debiantags ($$) { + my ($version,$distro) = @_; + map { $_->($version, $distro) } (\&debiantag_new, \&debiantag_old); } sub server_branch ($) { return "$branchprefix/$_[0]"; } @@ -142,6 +201,7 @@ sub _us () { sub fail { my $s = "@_\n"; + $s =~ s/\n\n$/\n/; my $prefix = _us().": "; $s =~ s/^/$prefix/gm; die $s; @@ -182,19 +242,40 @@ sub waitstatusmsg () { } } -sub failedcmd { - { local ($!); printcmd \*STDERR, _us().": failed command:", @_ or die $!; }; - if ($!) { - fail "failed to fork/exec: $!"; +sub failedcmd_report_cmd { + my $intro = shift @_; + $intro //= "failed command"; + { local ($!); printcmd \*STDERR, _us().": $intro:", @_ or die $!; }; +} + +sub failedcmd_waitstatus { + if ($? < 0) { + return "failed to fork/exec: $!"; } elsif ($?) { - fail "subprocess ".waitstatusmsg(); + return "subprocess ".waitstatusmsg(); } else { - fail "subprocess produced invalid output"; + return "subprocess produced invalid output"; } } +sub failedcmd { + # Expects $!,$? as set by close - see below. + # To use with system(), set $?=-1 first. + # + # Actual behaviour of perl operations: + # success $!==0 $?==0 close of piped open + # program failed $!==0 $? >0 close of piped open + # syscall failure $! >0 $?=-1 close of piped open + # failure $! >0 unchanged close of something else + # success trashed $?==0 system + # program failed trashed $? >0 system + # syscall failure $! >0 unchanged system + failedcmd_report_cmd undef, @_; + fail failedcmd_waitstatus(); +} + sub cmdoutput_errok { - die Dumper(\@_)." ?" if grep { !defined } @_; + confess Dumper(\@_)." ?" if grep { !defined } @_; debugcmd "|",@_; open P, "-|", @_ or die "$_[0] $!"; my $d; @@ -219,16 +300,59 @@ sub cmdoutput { return $d; } +sub link_ltarget ($$) { + my ($old,$new) = @_; + lstat $old or return undef; + if (-l _) { + $old = cmdoutput qw(realpath --), $old; + } + my $r = link $old, $new; + $r = symlink $old, $new if !$r && $!==EXDEV; + $r or die "(sym)link $old $new: $!"; +} + +sub hashfile ($) { + my ($fn) = @_; + my $h = Digest::SHA->new(256); + $h->addfile($fn); + return $h->hexdigest(); +} + sub git_rev_parse ($) { return cmdoutput qw(git rev-parse), "$_[0]~0"; } +sub git_cat_file ($) { + my ($objname) = @_; + # => ($type, $data) or ('missing', undef) + # in scalar context, just the data + our ($gcf_pid, $gcf_i, $gcf_o); + if (!$gcf_pid) { + my @cmd = qw(git cat-file --batch); + debugcmd "GCF|", @cmd; + $gcf_pid = open2 $gcf_o, $gcf_i, @cmd or die $!; + } + printdebug "GCF>| ", $objname, "\n"; + print $gcf_i $objname, "\n" or die $!; + my $x = <$gcf_o>; + printdebug "GCF<| ", $x; + if ($x =~ m/ (missing)$/) { return ($1, undef); } + my ($type, $size) = $x =~ m/^.* (\w+) (\d+)\n/ or die "$objname ?"; + my $data; + (read $gcf_o, $data, $size) == $size or die "$objname $!"; + $x = <$gcf_o>; + $x eq "\n" or die "$objname ($_) $!"; + return ($type, $data); +} + 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); + # $pattern may be an array ref to mean multiple patterns + $pattern = [ $pattern ] unless ref $pattern; + my @cmd = (qw(git for-each-ref), @$pattern); if (defined $gitdir) { @cmd = ('sh','-ec','cd "$1"; shift; exec "$@"','x', $gitdir, @cmd); }