X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=e489150ec790f0959449d5d749e0bfba00e6bfa5;hp=f821299f4d06e129de1be4ba6093fac50c867789;hb=71adb54977f6ecda0911b9fbb4af7f785a76cb08;hpb=05db7ab051736bb106467e7f83b9e45684dd227c diff --git a/dgit b/dgit index f821299f..e489150e 100755 --- a/dgit +++ b/dgit @@ -74,7 +74,11 @@ our $tagformat_want; our $tagformat; our $tagformatfn; -our %forceopts = map { $_=>0 } qw(unrepresentable); +our %forceopts = map { $_=>0 } + qw(unrepresentable unsupported-source-format + dsc-changes-mismatch + import-gitapply-absurd + import-gitapply-no-absurd); our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)"); @@ -236,6 +240,14 @@ sub forceable_fail ($$) { print STDERR "warning: overriding problem due to --force:\n". $msg; } +sub forceing ($) { + my ($forceoptsl) = @_; + my @got = grep { $forceopts{$_} } @$forceoptsl; + return 0 unless @got; + print STDERR + "warning: skipping checks or functionality due to --force-$got[0]\n"; +} + sub no_such_package () { print STDERR "$us: package $package does not exist in suite $isuite\n"; exit 4; @@ -950,13 +962,13 @@ sub must_getcwd () { our %rmad; -sub archive_query ($) { - my ($method) = @_; +sub archive_query ($;@) { + my ($method) = shift @_; my $query = access_cfg('archive-query','RETURN-UNDEF'); $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'"; my $proto = $1; my $data = $'; #'; - { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); } + { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); } } sub pool_dsc_subpath ($$) { @@ -997,9 +1009,9 @@ sub archive_api_query_cmd ($) { return @cmd; } -sub api_query ($$) { +sub api_query ($$;$) { use JSON; - my ($data, $subpath) = @_; + my ($data, $subpath, $ok404) = @_; badcfg "ftpmasterapi archive query method takes no data part" if length $data; my @cmd = archive_api_query_cmd($subpath); @@ -1011,6 +1023,7 @@ sub api_query ($$) { fail "curl failed to print 3-digit HTTP code"; } my $code = $&; + return undef if $code eq '404' && $ok404; fail "fetch of $url gave HTTP code $code" unless $url =~ m#^file://# or $code =~ m/^2/; return decode_json($json); @@ -1067,6 +1080,15 @@ sub archive_query_ftpmasterapi () { return @rows; } +sub file_in_archive_ftpmasterapi { + my ($proto,$data,$filename) = @_; + my $pat = $filename; + $pat =~ s/_/\\_/g; + $pat = "%/$pat"; + $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge; + my $info = api_query($data, "file_in_archive/$pat", 1); +} + #---------- `madison' archive query method ---------- sub archive_query_madison { @@ -1115,6 +1137,8 @@ sub canonicalise_suite_madison { return $r[0][2]; } +sub file_in_archive_madison { return undef; } + #---------- `sshpsql' archive query method ---------- sub sshpsql ($$$) { @@ -1190,6 +1214,8 @@ END return $rows[0]; } +sub file_in_archive_sshpsql ($$$) { return undef; } + #---------- `dummycat' archive query method ---------- sub canonicalise_suite_dummycat ($$) { @@ -1231,6 +1257,8 @@ sub archive_query_dummycat ($$) { return sort { -version_compare($a->[0],$b->[0]); } @rows; } +sub file_in_archive_dummycat () { return undef; } + #---------- tag format handling ---------- sub access_cfg_tagformats () { @@ -1308,7 +1336,9 @@ sub get_archive_dsc () { $dsc = parsecontrolfh($dscfh,$dscurl,1); printdebug Dumper($dsc) if $debuglevel>1; my $fmt = getfield $dsc, 'Format'; - fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt}; + $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)], + "unsupported source format $fmt, sorry"; + $dsc_checked = !!$digester; printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n"; return; @@ -1450,9 +1480,9 @@ sub mktree_in_ud_from_only_subdir (;$) { } our @files_csum_info_fields = - (['Checksums-Sha256','Digest::SHA', 'new(256)'], - ['Checksums-Sha1', 'Digest::SHA', 'new(1)'], - ['Files', 'Digest::MD5', 'new()']); + (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'], + ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'], + ['Files', 'Digest::MD5', 'new()', 'md5sum']); sub dsc_files_info () { foreach my $csumi (@files_csum_info_fields) { @@ -1964,9 +1994,15 @@ END $path = "$absurdity:$path"; progress "$us: trying slow absurd-git-apply..."; rename "../../gbp-pq-output","../../gbp-pq-output.0" + or $!==ENOENT or die $!; } eval { + die "forbid absurd git-apply\n" if $use_absurd + && forceing [qw(import-gitapply-no-absurd)]; + die "only absurd git-apply!\n" if !$use_absurd + && forceing [qw(import-gitapply-absurd)]; + local $ENV{PATH} = $path if $use_absurd; my @showcmd = (gbp_pq, qw(import)); @@ -2930,12 +2966,12 @@ sub splitbrain_pseudomerge ($$$$) { # this: $dgitview' # + return $dgitview unless defined $archive_hash; + printdebug "splitbrain_pseudomerge...\n"; my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash); - return $dgitview unless defined $archive_hash; - if (!defined $overwrite_version) { progress "Checking that HEAD inciudes all changes in archive..."; } @@ -3200,11 +3236,12 @@ END my $dgithead = $actualhead; my $maintviewhead = undef; + my $upstreamversion = $clogp->{Version}; + $upstreamversion =~ s/-[^-]*$//; + if (madformat_wantfixup($format)) { # user might have not used dgit build, so maybe do this now: if (quiltmode_splitbrain()) { - my $upstreamversion = $clogp->{Version}; - $upstreamversion =~ s/-[^-]*$//; changedir $ud; quilt_make_fake_dsc($upstreamversion); my $cachekey; @@ -3288,7 +3325,8 @@ END # Check that changes and .dsc agree enough $changesfile =~ m{[^/]*$}; - files_compare_inputs($dsc, parsecontrol($changesfile,$&)); + files_compare_inputs($dsc, parsecontrol($changesfile,$&)) + unless forceing [qw(dsc-changes-mismatch)]; # Checks complete, we're going to try and go ahead: @@ -4870,11 +4908,87 @@ sub massage_dbp_args ($;$) { return $r; } +sub in_parent (&) { + my ($fn) = @_; + my $wasdir = must_getcwd(); + changedir ".."; + $fn->(); + changedir $wasdir; +} + +sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent) + my ($msg_if_onlyone) = @_; + # If there is only one .changes file, fail with $msg_if_onlyone, + # or if that is undef, be a no-op. + # Returns the changes file to report to the user. + my $pat = changespat $version; + my @changesfiles = glob $pat; + @changesfiles = sort { + ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/) + or $a cmp $b + } @changesfiles; + my $result; + if (@changesfiles==1) { + fail < 0) { build_source(); + midbuild_checkchanges_vanilla $wantsrc; } else { build_prep(); } @@ -4884,7 +4998,7 @@ sub cmd_build { runcmd_ordryrun_local @dbp; } maybe_unapply_patches_again(); - printdone "build successful\n"; + postbuild_mergechanges_vanilla $wantsrc; } sub pre_gbp_build { @@ -4909,6 +5023,7 @@ sub cmd_gbp_build { if ($wantsrc > 0) { build_source(); + midbuild_checkchanges_vanilla $wantsrc; } else { if (!$clean_using_builder) { push @cmd, '--git-cleaner=true'; @@ -4920,7 +5035,7 @@ sub cmd_gbp_build { push @cmd, changesopts(); runcmd_ordryrun_local @cmd, @ARGV; } - printdone "build successful\n"; + postbuild_mergechanges_vanilla $wantsrc; } sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0 @@ -4993,53 +5108,22 @@ sub cmd_build_source { sub cmd_sbuild { build_source(); - my $pat = changespat $version; - if (!$rmchanges) { - my @unwanted = map { s#^\.\./##; $_; } glob "../$pat"; - @unwanted = grep { $_ ne changespat $version,'source' } @unwanted; - fail < $a =~ m/_source\.changes$/) - or $a cmp $b - } @changesfiles; - fail <