git-debrebase: classify: provide Why for Unknown

[dgit.git] / Debian / Dgit.pm

diff --git a/Debian/Dgit.pm b/Debian/Dgit.pm
index f299450b94eb7b52ce0fff60ec73613924f9cf92..ec402e4d270598e3f7f6ec725812ab7582c8c7a4 100644 (file)
--- a/Debian/Dgit.pm
+++ b/Debian/Dgit.pm
@@ -49,11 +49,15 @@ BEGIN {
                      failedcmd_report_cmd failedcmd
                       runcmd cmdoutput cmdoutput_errok
                       git_rev_parse git_cat_file
                      failedcmd_report_cmd failedcmd
                       runcmd cmdoutput cmdoutput_errok
                       git_rev_parse git_cat_file

-                     git_get_ref git_for_each_ref
+                     git_get_ref git_get_symref git_for_each_ref

                       git_for_each_tag_referring is_fast_fwd
                       git_for_each_tag_referring is_fast_fwd

+                     git_check_unmodified

                       $package_re $component_re $deliberately_re
                      $distro_re $versiontag_re $series_filename_re
                       $package_re $component_re $deliberately_re
                      $distro_re $versiontag_re $series_filename_re

+                     $extra_orig_namepart_re
+                     $git_null_obj

                       $branchprefix
                       $branchprefix

+                     $ffq_refprefix

                       initdebug enabledebug enabledebuglevel
                       printdebug debugcmd
                       $debugprefix *debuglevel *DEBUG
                       initdebug enabledebug enabledebuglevel
                       printdebug debugcmd
                       $debugprefix *debuglevel *DEBUG


@@ -80,6 +84,9 @@ our $distro_re = $component_re;
 our $versiontag_re = qr{[-+.\%_0-9a-zA-Z/]+};
 our $branchprefix = 'dgit';
 our $series_filename_re = qr{(?:^|\.)series(?!\n)$}s;
 our $versiontag_re = qr{[-+.\%_0-9a-zA-Z/]+};
 our $branchprefix = 'dgit';
 our $series_filename_re = qr{(?:^|\.)series(?!\n)$}s;

+our $extra_orig_namepart_re = qr{[-0-9a-z]+};
+our $git_null_obj = '0' x 40;
+our $ffq_refprefix = 'ffq-prev';

 
 # policy hook exit status bits
 # see dgit-repos-server head comment for documentation
 
 # policy hook exit status bits
 # see dgit-repos-server head comment for documentation


@@ -108,7 +115,7 @@ sub forkcheck_mainprocess () {
 sub setup_sigwarn () {
     forkcheck_setup();
     $SIG{__WARN__} = sub { 
 sub setup_sigwarn () {
     forkcheck_setup();
     $SIG{__WARN__} = sub { 

-       die $_[0] if forkcheck_mainprocess;
+       confess $_[0] if forkcheck_mainprocess;

     };
 }
 
     };
 }
 


@@ -348,11 +355,21 @@ sub git_rev_parse ($) {
     return cmdoutput qw(git rev-parse), "$_[0]~0";
 }
 
     return cmdoutput qw(git rev-parse), "$_[0]~0";
 }
 

-sub git_cat_file ($) {
-    my ($objname) = @_;
+sub git_cat_file ($;$) {
+    my ($objname, $etype) = @_;

     # => ($type, $data) or ('missing', undef)
     # in scalar context, just the data
     # => ($type, $data) or ('missing', undef)
     # in scalar context, just the data

+    # if $etype defined, dies unless type is $etype or in @$etype

     our ($gcf_pid, $gcf_i, $gcf_o);
     our ($gcf_pid, $gcf_i, $gcf_o);

+    my $chk = sub {
+       my ($gtype, $data) = @_;
+       if ($etype) {
+           $etype = [$etype] unless ref $etype;
+           confess "$objname expected @$etype but is $gtype"
+               unless grep { $gtype eq $_ } @$etype;
+       }
+       return ($gtype, $data);
+    };

     if (!$gcf_pid) {
        my @cmd = qw(git cat-file --batch);
        debugcmd "GCF|", @cmd;
     if (!$gcf_pid) {
        my @cmd = qw(git cat-file --batch);
        debugcmd "GCF|", @cmd;


@@ -362,13 +379,26 @@ sub git_cat_file ($) {
     print $gcf_i $objname, "\n" or die $!;
     my $x = <$gcf_o>;
     printdebug "GCF<| ", $x;
     print $gcf_i $objname, "\n" or die $!;
     my $x = <$gcf_o>;
     printdebug "GCF<| ", $x;

-    if ($x =~ m/ (missing)$/) { return ($1, undef); }
+    if ($x =~ m/ (missing)$/) { return $chk->($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 ($_) $!";
     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);
+    return $chk->($type, $data);
+}
+
+sub git_get_symref (;$) {
+    my ($symref) = @_;  $symref //= 'HEAD';
+    # => undef if not a symref, otherwise refs/...
+    my @cmd = (qw(git symbolic-ref -q HEAD));
+    my $branch = cmdoutput_errok @cmd;
+    if (!defined $branch) {
+       $?==256 or failedcmd @cmd;
+    } else {
+       chomp $branch;
+    }
+    return $branch;

 }
 
 sub git_for_each_ref ($$;$) {
 }
 
 sub git_for_each_ref ($$;$) {


@@ -418,6 +448,25 @@ sub git_for_each_tag_referring ($$) {
     });
 }
 
     });
 }
 

+sub git_check_unmodified () {
+    foreach my $cached (qw(0 1)) {
+       my @cmd = qw(git diff --quiet);
+       push @cmd, qw(--cached) if $cached;
+       push @cmd, qw(HEAD);
+       debugcmd "+",@cmd;
+       $!=0; $?=-1; system @cmd;
+       return if !$?;
+       if ($?==256) {
+           fail
+               $cached
+               ? "git index contains changes (does not match HEAD)"
+               : "working tree is dirty (does not match HEAD)";
+       } else {
+           failedcmd @cmd;
+       }
+    }
+}
+

 sub is_fast_fwd ($$) {
     my ($ancestor,$child) = @_;
     my @cmd = (qw(git merge-base), $ancestor, $child);
 sub is_fast_fwd ($$) {
     my ($ancestor,$child) = @_;
     my @cmd = (qw(git merge-base), $ancestor, $child);