X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=Debian%2FDgit.pm;h=3d97848ff2df75b96491a8fc2ac2d6bd5224a86a;hp=6854a7cffd74dff3ae7a7d236d41cb5c42fc4088;hb=be85ba38f1d9099179b6b6cc7cafac769ccf11da;hpb=3c607d65d5675be05fb41f87fd74cd3a00016b65 diff --git a/Debian/Dgit.pm b/Debian/Dgit.pm index 6854a7cf..3d97848f 100644 --- a/Debian/Dgit.pm +++ b/Debian/Dgit.pm @@ -28,6 +28,8 @@ use IO::Handle; use Config; use Digest::SHA; use Data::Dumper; +use IPC::Open2; +use File::Path; BEGIN { use Exporter (); @@ -35,24 +37,31 @@ BEGIN { $VERSION = 1.00; @ISA = qw(Exporter); - @EXPORT = qw(setup_sigwarn + @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_report_cmd failedcmd - cmdoutput cmdoutput_errok - git_rev_parse git_get_ref git_for_each_ref + waitstatusmsg failedcmd_waitstatus + failedcmd_report_cmd failedcmd + runcmd cmdoutput cmdoutput_errok + 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 $series_filename_re $branchprefix initdebug enabledebug enabledebuglevel printdebug debugcmd $debugprefix *debuglevel *DEBUG - shellquote printcmd messagequote); + shellquote printcmd messagequote + $negate_harmful_gitattrs + git_slurp_config_src + workarea_setup); # implicitly uses $main::us - %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO)] ); + %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO NOCOMMITCHECK)] ); @EXPORT_OK = @{ $EXPORT_TAGS{policyflags} }; } @@ -61,7 +70,10 @@ 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'; +our $series_filename_re = qr{(?:^|\.)series(?!\n)$}s; # policy hook exit status bits # see dgit-repos-server head comment for documentation @@ -69,14 +81,28 @@ 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 $negate_harmful_gitattrs = "-text -eol -crlf -ident -filter"; + +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; }; } @@ -118,6 +144,7 @@ sub messagequote ($) { sub shellquote { my @out; local $_; + defined or confess 'internal error' foreach @_; foreach my $a (@_) { $_ = $a; if (!length || m{[^-=_./:0-9a-z]}i) { @@ -143,16 +170,22 @@ sub debugcmd { printcmd(\*DEBUG,$debugprefix.$extraprefix,@_) if $debuglevel>0; } +sub dep14_version_mangle ($) { + my ($v) = @_; + # DEP-14 patch proposed 2016-11-09 "Version Mangling" + $v =~ y/~:/_%/; + $v =~ s/\.(?=\.|$|lock$)/.#/g; + return $v; +} + sub debiantag_old ($$) { my ($v,$distro) = @_; - $v =~ y/~:/_%/; - return "$distro/$v"; + return "$distro/". dep14_version_mangle $v; } sub debiantag_new ($$) { my ($v,$distro) = @_; - $v =~ y/~:/_%/; - return "archive/$distro/$v"; + return "archive/$distro/".dep14_version_mangle $v; } sub debiantags ($$) { @@ -223,6 +256,16 @@ sub failedcmd_report_cmd { { local ($!); printcmd \*STDERR, _us().": $intro:", @_ or die $!; }; } +sub failedcmd_waitstatus { + if ($? < 0) { + return "failed to fork/exec: $!"; + } elsif ($?) { + return "subprocess ".waitstatusmsg(); + } else { + return "subprocess produced invalid output"; + } +} + sub failedcmd { # Expects $!,$? as set by close - see below. # To use with system(), set $?=-1 first. @@ -236,13 +279,13 @@ sub failedcmd { # program failed trashed $? >0 system # syscall failure $! >0 unchanged system failedcmd_report_cmd undef, @_; - if ($? < 0) { - fail "failed to fork/exec: $!"; - } elsif ($?) { - fail "subprocess ".waitstatusmsg(); - } else { - fail "subprocess produced invalid output"; - } + fail failedcmd_waitstatus(); +} + +sub runcmd { + debugcmd "+",@_; + $!=0; $?=-1; + failedcmd @_ if system @_; } sub cmdoutput_errok { @@ -277,7 +320,9 @@ sub link_ltarget ($$) { if (-l _) { $old = cmdoutput qw(realpath --), $old; } - link $old, $new or die "link $old $new: $!"; + my $r = link $old, $new; + $r = symlink $old, $new if !$r && $!==EXDEV; + $r or die "(sym)link $old $new: $!"; } sub hashfile ($) { @@ -291,6 +336,29 @@ 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); @@ -350,4 +418,50 @@ sub is_fast_fwd ($$) { } } +sub git_slurp_config_src ($) { + my ($src) = @_; + # returns $r such that $r->{KEY}[] = VALUE + my @cmd = (qw(git config -z --get-regexp), "--$src", qw(.*)); + debugcmd "|",@cmd; + + local ($debuglevel) = $debuglevel-2; + local $/="\0"; + + my $r = { }; + open GITS, "-|", @cmd or die $!; + while () { + chomp or die; + printdebug "=> ", (messagequote $_), "\n"; + m/\n/ or die "$_ ?"; + push @{ $r->{$`} }, $'; #'; + } + $!=0; $?=0; + close GITS + or ($!==0 && $?==256) + or failedcmd @cmd; + return $r; +} + +sub workarea_setup ($) { + # for use in the workarea + my ($t_local_git_cfg) = @_; + # should be run in a directory .git/FOO/BAR of a working tree + runcmd qw(git init -q); + runcmd qw(git config gc.auto 0); + foreach my $copy (qw(user.email user.name user.useConfigOnly + core.sharedRepository + core.compression core.looseCompression + core.bigFileThreshold core.fsyncObjectFiles)) { + my $v = $t_local_git_cfg->{$copy}; + next unless $v; + runcmd qw(git config), $copy, $_ foreach @$v; + } + rmtree('.git/objects'); + symlink '../../../../objects','.git/objects' or die $!; + ensuredir '.git/info'; + open GA, "> .git/info/attributes" or die $!; + print GA "* $negate_harmful_gitattrs\n" or die $!; + close GA or die $!; +} + 1;