X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=9aadaf0d4753c5231c0d3d6ea95c05311397e4f0;hp=40b8e32aba4a6378f742381076d1812b239c45f1;hb=2ef2809f38beeafcccd904267b82849ddcb17957;hpb=37679efe82686b5fb1ba4d198c6df41a9e1fa52d diff --git a/dgit b/dgit index 40b8e32a..9aadaf0d 100755 --- a/dgit +++ b/dgit @@ -19,7 +19,7 @@ use strict; -use Debian::Dgit; +use Debian::Dgit qw(:DEFAULT :playground); setup_sigwarn(); use IO::Handle; @@ -47,6 +47,8 @@ our $absurdity = undef; ###substituted### our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format our $protovsn; +our $cmd; +our $subcommand; our $isuite; our $idistro; our $package; @@ -249,12 +251,6 @@ sub no_such_package () { exit 4; } -sub changedir ($) { - my ($newdir) = @_; - printdebug "CD $newdir\n"; - chdir $newdir or confess "chdir: $newdir: $!"; -} - sub deliberately ($) { my ($enquiry) = @_; return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies; @@ -493,12 +489,6 @@ sub url_get { our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn); -sub runcmd { - debugcmd "+",@_; - $!=0; $?=-1; - failedcmd @_ if system @_; -} - sub act_local () { return $dryrun_level <= 1; } sub act_scary () { return !$dryrun_level; } @@ -567,7 +557,7 @@ sub nextarg { } sub pre_help () { - no_local_git_cfg(); + not_necessarily_a_tree(); } sub cmd_help () { print $helpmsg or die $!; @@ -647,30 +637,14 @@ our %gitcfgs; our @gitcfgsources = qw(cmdline local global system); sub git_slurp_config () { - local ($debuglevel) = $debuglevel-2; - local $/="\0"; - # This algoritm is a bit subtle, but this is needed so that for # options which we want to be single-valued, we allow the # different config sources to override properly. See #835858. foreach my $src (@gitcfgsources) { next if $src eq 'cmdline'; # we do this ourselves since git doesn't handle it - - my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*)); - debugcmd "|",@cmd; - open GITS, "-|", @cmd or die $!; - while () { - chomp or die; - printdebug "=> ", (messagequote $_), "\n"; - m/\n/ or die "$_ ?"; - push @{ $gitcfgs{$src}{$`} }, $'; #'; - } - $!=0; $?=0; - close GITS - or ($!==0 && $?==256) - or failedcmd @cmd; + $gitcfgs{$src} = git_slurp_config_src $src; } } @@ -707,7 +681,7 @@ sub cfg { "$us: distro or suite appears not to be (properly) supported"; } -sub no_local_git_cfg () { +sub not_necessarily_a_tree () { # needs to be called from pre_* @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources; } @@ -1011,12 +985,6 @@ sub commit_getclogp ($) { $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog"); } -sub must_getcwd () { - my $d = getcwd(); - defined $d or fail "getcwd failed: $!"; - return $d; -} - sub parse_dscdata () { my $dscfh = new IO::File \$dscdata, '<' or die $!; printdebug Dumper($dscdata) if $debuglevel>1; @@ -1700,30 +1668,13 @@ sub create_remote_git_repo () { our ($dsc_hash,$lastpush_mergeinput); our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url); -our $ud = '.git/dgit/unpack'; -sub prep_ud (;$) { - my ($d) = @_; - $d //= $ud; - rmtree($d); - mkpath '.git/dgit'; - mkdir $d or die $!; +sub prep_ud () { + fresh_playground 'dgit/unpack'; } sub mktree_in_ud_here () { - 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 = $gitcfgs{local}{$copy}; - next unless $v; - runcmd qw(git config), $copy, $_ foreach @$v; - } - rmtree('.git/objects'); - symlink '../../../../objects','.git/objects' or die $!; - setup_gitattrs(1); + playtree_setup $gitcfgs{local}; } sub git_write_tree () { @@ -2098,7 +2049,7 @@ sub generate_commits_from_dsc () { # See big comment in fetch_from_archive, below. # See also README.dsc-import. prep_ud(); - changedir $ud; + changedir $playground; my @dfi = dsc_files_info(); foreach my $fi (@dfi) { @@ -2508,8 +2459,8 @@ END @output = $lastpush_mergeinput; } } - changedir '../../../..'; - rmtree($ud); + changedir $maindir; + rmtree $playground; return @output; } @@ -3380,10 +3331,11 @@ END return; } my $af = ".git/info/attributes"; + ensuredir '.git/info'; open GAO, "> $af.new" or die $!; print GAO <(); foreach my $tsuite (@suites[1..$#suites]) { + $tsuite =~ s/^-/$cbasesuite-/; my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs, sub { @end = (); @@ -3911,6 +3864,7 @@ sub splitbrain_pseudomerge ($$$$) { # return $dgitview unless defined $archive_hash; + return $dgitview if deliberately_not_fast_forward(); printdebug "splitbrain_pseudomerge...\n"; @@ -4212,7 +4166,7 @@ END if (madformat_wantfixup($format)) { # user might have not used dgit build, so maybe do this now: if (quiltmode_splitbrain()) { - changedir $ud; + changedir $playground; quilt_make_fake_dsc($upstreamversion); my $cachekey; ($dgithead, $cachekey) = @@ -4225,7 +4179,7 @@ END $actualhead, $dgithead, $archive_hash); $maintviewhead = $actualhead; - changedir '../../../..'; + changedir $maindir; prep_ud(); # so _only_subdir() works, below } else { commit_quilty_patch(); @@ -4256,13 +4210,13 @@ END } } - changedir $ud; + changedir $playground; progress "checking that $dscfn corresponds to HEAD"; runcmd qw(dpkg-source -x --), $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath"; my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package"); check_for_vendor_patches() if madformat($dsc->{format}); - changedir '../../../..'; + changedir $maindir; my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead); debugcmd "+",@diffcmd; $!=0; $?=-1; @@ -4424,7 +4378,7 @@ END } sub pre_clone () { - no_local_git_cfg(); + not_necessarily_a_tree(); } sub cmd_clone { parseopts(); @@ -4527,21 +4481,18 @@ END pull(); } -sub cmd_push { +sub prep_push () { parseopts(); - badusage "-p is not allowed with dgit push" if defined $package; + build_or_push_prep_early(); + pushing(); check_not_dirty(); - my $clogp = parsechangelog(); - $package = getfield $clogp, 'Source'; my $specsuite; if (@ARGV==0) { } elsif (@ARGV==1) { ($specsuite) = (@ARGV); } else { - badusage "incorrect arguments to dgit push"; + badusage "incorrect arguments to dgit $subcommand"; } - $isuite = getfield $clogp, 'Distribution'; - pushing(); if ($new_package) { local ($package) = $existing_package; # this is a hack canonicalise_suite(); @@ -4551,9 +4502,13 @@ sub cmd_push { if (defined $specsuite && $specsuite ne $isuite && $specsuite ne $csuite) { - fail "dgit push: changelog specifies $isuite ($csuite)". + fail "dgit $subcommand: changelog specifies $isuite ($csuite)". " but command line specifies $specsuite"; } +} + +sub cmd_push { + prep_push(); dopush(); } @@ -4637,7 +4592,7 @@ sub i_method { } sub pre_rpush () { - no_local_git_cfg(); + not_necessarily_a_tree(); } sub cmd_rpush { my $host = nextarg; @@ -4889,7 +4844,7 @@ sub quiltify_trees_differ ($$;$$$) { # a list of unrepresentable changes (removals of upstream files # (as messages) local $/=undef; - my @cmd = (@git, qw(diff-tree -z)); + my @cmd = (@git, qw(diff-tree -z --no-renames)); push @cmd, qw(--name-only) unless $unrepres; push @cmd, qw(-r) if $finegrained || $unrepres; push @cmd, $x, $y; @@ -4908,16 +4863,23 @@ sub quiltify_trees_differ ($$;$$$) { if ($unrepres) { eval { - die "not a plain file\n" - unless $newmode =~ m/^10\d{4}$/ || - $oldmode =~ m/^10\d{4}$/; + die "not a plain file or symlink\n" + unless $newmode =~ m/^(?:10|12)\d{4}$/ || + $oldmode =~ m/^(?:10|12)\d{4}$/; if ($oldmode =~ m/[^0]/ && $newmode =~ m/[^0]/) { - die "mode changed\n" if $oldmode ne $newmode; + # both old and new files exist + die "mode or type changed\n" if $oldmode ne $newmode; + die "modified symlink\n" unless $newmode =~ m/^10/; + } elsif ($oldmode =~ m/[^0]/) { + # deletion + die "deletion of symlink\n" + unless $oldmode =~ m/^10/; } else { - die "non-default mode\n" - unless $newmode =~ m/^100644$/ || - $oldmode =~ m/^100644$/; + # creation + die "creation with non-default mode\n" + unless $newmode =~ m/^100644$/ or + $newmode =~ m/^120000$/; } }; if ($@) { @@ -5043,7 +5005,7 @@ END my $dgitview = git_rev_parse 'HEAD'; - changedir '../../../..'; + changedir $maindir; # When we no longer need to support squeeze, use --create-reflog # instead of this: ensuredir ".git/logs/refs/dgit-intern"; @@ -5068,7 +5030,7 @@ END runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache", $dgitview; - changedir '.git/dgit/unpack/work'; + changedir "$playground/work"; my $saved = maybe_split_brain_save $headref, $dgitview, "converted"; progress "dgit view: created ($saved)"; @@ -5272,6 +5234,7 @@ sub quiltify ($$$$) { die "contains unexpected slashes\n" if m{//} || m{/$}; die "contains leading punctuation\n" if m{^\W} || m{/\W}; die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i; + die "is series file\n" if m{$series_filename_re}o; die "too long" if length > 200; }; return $_ unless $@; @@ -5310,6 +5273,7 @@ sub quiltify ($$$$) { $patchname =~ y/-a-z0-9_.+=~//cd; $patchname =~ s/^\W/x-$&/; $patchname = substr($patchname,0,40); + $patchname .= ".patch"; } if (!defined $patchdir) { $patchdir = ''; @@ -5365,7 +5329,7 @@ END my $headref = git_rev_parse('HEAD'); prep_ud(); - changedir $ud; + changedir $playground; my $upstreamversion = upstreamversion $version; @@ -5377,7 +5341,7 @@ END die 'bug' if $split_brain && !$need_split_build_invocation; - changedir '../../../..'; + changedir $maindir; runcmd_ordryrun_local @git, qw(pull --ff-only -q .git/dgit/unpack/work master); } @@ -5488,7 +5452,7 @@ END sub quilt_check_splitbrain_cache ($$) { my ($headref, $upstreamversion) = @_; # Called only if we are in (potentially) split brain mode. - # Called in $ud. + # Called in playground. # Computes the cache key and looks in the cache. # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey) @@ -5844,14 +5808,18 @@ sub cmd_clean () { maybe_unapply_patches_again(); } -sub build_prep_early () { - our $build_prep_early_done //= 0; - return if $build_prep_early_done++; - badusage "-p is not allowed when building" if defined $package; +sub build_or_push_prep_early () { + our $build_or_push_prep_early_done //= 0; + return if $build_or_push_prep_early_done++; + badusage "-p is not allowed with dgit $subcommand" if defined $package; my $clogp = parsechangelog(); $isuite = getfield $clogp, 'Distribution'; $package = getfield $clogp, 'Source'; $version = getfield $clogp, 'Version'; +} + +sub build_prep_early () { + build_or_push_prep_early(); notpushing(); check_not_dirty(); } @@ -6160,10 +6128,10 @@ sub build_source { } else { my @cmd = (@dpkgsource, qw(-b --)); if ($split_brain) { - changedir $ud; + changedir $playground; runcmd_ordryrun_local @cmd, "work"; my @udfiles = <${package}_*>; - changedir "../../.."; + changedir $maindir; foreach my $f (@udfiles) { printdebug "source copy, found $f\n"; next unless @@ -6171,7 +6139,7 @@ sub build_source { ($f =~ m/\.debian\.tar(?:\.\w+)$/ && $f eq srcfn($version, $&)); printdebug "source copy, found $f - renaming\n"; - rename "$ud/$f", "../$f" or $!==ENOENT + rename "$playground/$f", "../$f" or $!==ENOENT or fail "put in place new source file ($f): $!"; } } else { @@ -6345,7 +6313,10 @@ END foreach my $fi (@dfi) { my $f = $fi->{Filename}; my $here = "../$f"; - next if lstat $here; + if (lstat $here) { + next if stat $here; + fail "lstat $here works but stat gives $! !"; + } fail "stat $here: $!" unless $! == ENOENT; my $there = $dscfn; if ($dscfn =~ m#^(?:\./+)?\.\./+#) { @@ -6356,8 +6327,10 @@ END fail "cannot import $dscfn which seems to be inside working tree!"; } $there =~ s#/+[^/]+$## or - fail "cannot import $dscfn which seems to not have a basename"; + fail "import $dscfn requires ../$f, but it does not exist"; $there .= "/$f"; + my $test = $there =~ m{^/} ? $there : "../$there"; + stat $test or fail "import $dscfn requires $test, but: $!"; symlink $there, $here or fail "symlink $there to $here: $!"; progress "made symlink $here -> $there"; # print STDERR Dumper($fi); @@ -6396,7 +6369,7 @@ END } sub pre_archive_api_query () { - no_local_git_cfg(); + not_necessarily_a_tree(); } sub cmd_archive_api_query { badusage "need only 1 subpath argument" unless @ARGV==1; @@ -6415,7 +6388,7 @@ sub repos_server_url () { } sub pre_clone_dgit_repos_server () { - no_local_git_cfg(); + not_necessarily_a_tree(); } sub cmd_clone_dgit_repos_server { badusage "need destination argument" unless @ARGV==1; @@ -6427,7 +6400,7 @@ sub cmd_clone_dgit_repos_server { } sub pre_print_dgit_repos_server_source_url () { - no_local_git_cfg(); + not_necessarily_a_tree(); } sub cmd_print_dgit_repos_server_source_url { badusage "no arguments allowed to dgit print-dgit-repos-server-source-url" @@ -6818,7 +6791,7 @@ if (!@ARGV) { print STDERR $helpmsg or die $!; exit 8; } -my $cmd = shift @ARGV; +$cmd = $subcommand = shift @ARGV; $cmd =~ y/-/_/; my $pre_fn = ${*::}{"pre_$cmd"};