X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=Debian%2FDgit.pm;h=5e0bbd5e63ce0b8f8ddac59b63bbd34476cb9d03;hb=3fad6db8d44a435d456e9d79e2c6811ac2bc0364;hp=57ae99418a1fc79bc4e734d15b18a36f09b5f529;hpb=dc204aadf2b4afa84fd002597041fc9e5b981d83;p=dgit.git

diff --git a/Debian/Dgit.pm b/Debian/Dgit.pm
index 57ae9941..5e0bbd5e 100644
--- a/Debian/Dgit.pm
+++ b/Debian/Dgit.pm
@@ -28,6 +28,7 @@ use IO::Handle;
 use Config;
 use Digest::SHA;
 use Data::Dumper;
+use IPC::Open2;
 
 BEGIN {
     use Exporter   ();
@@ -35,7 +36,8 @@ 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
@@ -44,16 +46,18 @@ BEGIN {
                       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} };
 }
 
@@ -62,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
@@ -70,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;
     };
 }
 
@@ -144,16 +162,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 ($$) {
@@ -282,7 +306,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 ($) {
@@ -296,6 +322,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);