Provide --force-unrepresentable.

[dgit.git] / dgit

diff --git a/dgit b/dgit
index f1f952ac3b179d45ac2bd9f647c4a545df8391ea..5fa500c65cc7ff2393d0ceb6fdce458b52446954 100755 (executable)
--- a/dgit
+++ b/dgit
@@ -73,6 +73,8 @@ our $tagformat_want;
 our $tagformat;
 our $tagformatfn;
 
 our $tagformat;
 our $tagformatfn;
 

+our %forceopts = map { $_=>0 } qw(unrepresentable);
+

 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
 
 our $suite_re = '[-+.0-9a-z]+';
 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
 
 our $suite_re = '[-+.0-9a-z]+';


@@ -222,6 +224,12 @@ END {
 
 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
 
 
 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
 

+sub forceable_fail ($$) {
+    my ($forceoptsl, $msg) = @_;
+    fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
+    print STDERR "warning: overriding problem due to --force:\n". $msg;
+}
+

 sub no_such_package () {
     print STDERR "$us: package $package does not exist in suite $isuite\n";
     exit 4;
 sub no_such_package () {
     print STDERR "$us: package $package does not exist in suite $isuite\n";
     exit 4;


@@ -955,7 +963,7 @@ sub pool_dsc_subpath ($$) {
 
 sub archive_api_query_cmd ($) {
     my ($subpath) = @_;
 
 sub archive_api_query_cmd ($) {
     my ($subpath) = @_;

-    my @cmd = qw(curl -sS);
+    my @cmd = (@curl, qw(-sS));

     my $url = access_cfg('archive-query-url');
     if ($url =~ m#^https://([-.0-9a-z]+)/#) {
        my $host = $1;
     my $url = access_cfg('archive-query-url');
     if ($url =~ m#^https://([-.0-9a-z]+)/#) {
        my $host = $1;


@@ -989,7 +997,16 @@ sub api_query ($$) {
     badcfg "ftpmasterapi archive query method takes no data part"
        if length $data;
     my @cmd = archive_api_query_cmd($subpath);
     badcfg "ftpmasterapi archive query method takes no data part"
        if length $data;
     my @cmd = archive_api_query_cmd($subpath);

+    my $url = $cmd[$#cmd];
+    push @cmd, qw(-w %{http_code});

     my $json = cmdoutput @cmd;
     my $json = cmdoutput @cmd;

+    unless ($json =~ s/\d+\d+\d$//) {
+       failedcmd_report_cmd undef, @cmd;
+       fail "curl failed to print 3-digit HTTP code";
+    }
+    my $code = $&;
+    fail "fetch of $url gave HTTP code $code"
+       unless $url =~ m#^file://# or $code =~ m/^2/;

     return decode_json($json);
 }
 
     return decode_json($json);
 }
 


@@ -1321,7 +1338,7 @@ sub check_for_git () {
        my $suffix = access_cfg('git-check-suffix','git-suffix',
                                'RETURN-UNDEF') // '.git';
        my $url = "$prefix/$package$suffix";
        my $suffix = access_cfg('git-check-suffix','git-suffix',
                                'RETURN-UNDEF') // '.git';
        my $url = "$prefix/$package$suffix";

-       my @cmd = (qw(curl -sS -I), $url);
+       my @cmd = (@curl, qw(-sS -I), $url);

        my $result = cmdoutput @cmd;
        $result =~ s/^\S+ 200 .*\n\r?\n//;
        # curl -sS -I with https_proxy prints
        my $result = cmdoutput @cmd;
        $result =~ s/^\S+ 200 .*\n\r?\n//;
        # curl -sS -I with https_proxy prints


@@ -4596,7 +4613,7 @@ END
     if (@unrepres) {
        print STDERR "dgit:  cannot represent change: $_->[1]: $_->[0]\n"
            foreach @unrepres;
     if (@unrepres) {
        print STDERR "dgit:  cannot represent change: $_->[1]: $_->[0]\n"
            foreach @unrepres;

-       fail <<END;
+       forceable_fail [qw(unrepresentable)], <<END;

 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
 END
     }
 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
 END
     }


@@ -5010,6 +5027,7 @@ sub cmd_archive_api_query {
     badusage "need only 1 subpath argument" unless @ARGV==1;
     my ($subpath) = @ARGV;
     my @cmd = archive_api_query_cmd($subpath);
     badusage "need only 1 subpath argument" unless @ARGV==1;
     my ($subpath) = @ARGV;
     my @cmd = archive_api_query_cmd($subpath);

+    push @cmd, qw(-f);

     debugcmd ">",@cmd;
     exec @cmd or fail "exec curl: $!\n";
 }
     debugcmd ">",@cmd;
     exec @cmd or fail "exec curl: $!\n";
 }


@@ -5166,6 +5184,10 @@ sub parseopts () {
            } elsif (m/^--deliberately-($deliberately_re)$/s) {
                push @ropts, $_;
                push @deliberatelies, $&;
            } elsif (m/^--deliberately-($deliberately_re)$/s) {
                push @ropts, $_;
                push @deliberatelies, $&;

+           } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
+               push @ropts, $&;
+               $forceopts{$1} = 1;
+               $_='';

            } elsif (m/^--dgit-tag-format=(old|new)$/s) {
                # undocumented, for testing
                push @ropts, $_;
            } elsif (m/^--dgit-tag-format=(old|new)$/s) {
                # undocumented, for testing
                push @ropts, $_;