sub printdone {
if (!$dryrun_level) {
- progress "dgit ok: @_";
+ progress "$us ok: @_";
} else {
progress "would be ok: @_ (but dry run only)";
}
our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
our %defcfg = ('dgit.default.distro' => 'debian',
+ 'dgit-suite.*-security.distro' => 'debian-security',
'dgit.default.username' => '',
'dgit.default.archive-query-default-component' => 'main',
'dgit.default.ssh' => 'ssh',
'dgit.default.archive-query' => 'madison:',
'dgit.default.sshpsql-dbname' => 'service=projectb',
+ 'dgit.default.aptget-components' => 'main',
'dgit.default.dgit-tag-format' => 'new,old,maint',
# old means "repo server accepts pushes with old dgit tags"
# new means "repo server accepts pushes with new dgit tags"
'dgit-distro.debian.git-url-suffix' => '',
'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
+ 'dgit-distro.debian-security.archive-query' => 'aptget:',
+ 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
+ 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
+ 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
+ 'dgit-distro.debian-security.nominal-distro' => 'debian',
'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
'dgit-distro.ubuntu.git-check' => 'false',
sub archive_query ($;@) {
my ($method) = shift @_;
+ fail "this operation does not support multiple comma-separated suites"
+ if $isuite =~ m/,/;
my $query = access_cfg('archive-query','RETURN-UNDEF');
$query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
my $proto = $1;
sub aptget_cache_clean {
runcmd_ordryrun_local qw(sh -ec),
- 'cd "$1"; pwd; find -atime +30 -type f -print0 | xargs -0r echo rm --',
+ 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
'x', $aptget_base;
}
foreach my $name (qw(Codename Suite)) {
my $val = $release->{$name};
if (defined $val) {
+ printdebug "release file $name: $val\n";
$val =~ m/^$suite_re$/o or fail
"Release file ($aptget_releasefile) specifies intolerable $name";
cfg_apply_map(\$val, 'suite rmap',
$csuite = archive_query('canonicalise_suite');
if ($isuite ne $csuite) {
progress "canonical suite name for $isuite is $csuite";
+ } else {
+ progress "canonical suite name is $csuite";
}
}
return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
}
+sub fetch_from_archive_record_1 ($) {
+ my ($hash) = @_;
+ runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
+ 'DGIT_ARCHIVE', $hash;
+ cmdoutput @git, qw(log -n2), $hash;
+ # ... gives git a chance to complain if our commit is malformed
+}
+
+sub fetch_from_archive_record_2 ($) {
+ my ($hash) = @_;
+ my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
+ if (act_local()) {
+ cmdoutput @upd_cmd;
+ } else {
+ dryrun_report @upd_cmd;
+ }
+}
+
sub fetch_from_archive () {
ensure_setup_existing_tree();
if $lastpush_hash;
$chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
- runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
- 'DGIT_ARCHIVE', $hash;
- cmdoutput @git, qw(log -n2), $hash;
- # ... gives git a chance to complain if our commit is malformed
+ fetch_from_archive_record_1($hash);
if (defined $skew_warning_vsn) {
mkpath '.git/dgit';
}
if ($lastfetch_hash ne $hash) {
- my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
- if (act_local()) {
- cmdoutput @upd_cmd;
- } else {
- dryrun_report @upd_cmd;
- }
+ fetch_from_archive_record_2($hash);
}
lrfetchref_used lrfetchref();
setup_useremail();
}
+sub multisuite_suite_child ($$$) {
+ my ($tsuite, $merginputs, $fn) = @_;
+ # in child, sets things up, calls $fn->(), and returns undef
+ # in parent, returns canonical suite name for $tsuite
+ my $canonsuitefh = IO::File::new_tmpfile;
+ my $pid = fork // die $!;
+ if (!$pid) {
+ $isuite = $tsuite;
+ $us .= " [$isuite]";
+ $debugprefix .= " ";
+ progress "fetching $tsuite...";
+ canonicalise_suite();
+ print $canonsuitefh $csuite, "\n" or die $!;
+ close $canonsuitefh or die $!;
+ $fn->();
+ return undef;
+ }
+ waitpid $pid,0 == $pid or die $!;
+ fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
+ seek $canonsuitefh,0,0 or die $!;
+ local $csuite = <$canonsuitefh>;
+ die $! unless defined $csuite && chomp $csuite;
+ if ($? == 256*4) {
+ printdebug "multisuite $tsuite missing\n";
+ return $csuite;
+ }
+ printdebug "multisuite $tsuite ok (canon=$csuite)\n";
+ push @$merginputs, {
+ Ref => lrref,
+ Info => $csuite,
+ };
+ return $csuite;
+}
+
+sub fork_for_multisuite ($) {
+ my ($before_fetch_merge) = @_;
+ # if nothing unusual, just returns ''
+ #
+ # if multisuite:
+ # returns 0 to caller in child, to do first of the specified suites
+ # in child, $csuite is not yet set
+ #
+ # returns 1 to caller in parent, to finish up anything needed after
+ # in parent, $csuite is set to canonicalised portmanteau
+
+ my $org_isuite = $isuite;
+ my @suites = split /\,/, $isuite;
+ return '' unless @suites > 1;
+ printdebug "fork_for_multisuite: @suites\n";
+
+ my @mergeinputs;
+
+ my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
+ sub { });
+ return 0 unless defined $cbasesuite;
+
+ fail "package $package missing in (base suite) $cbasesuite"
+ unless @mergeinputs;
+
+ my @csuites = ($cbasesuite);
+
+ $before_fetch_merge->();
+
+ foreach my $tsuite (@suites[1..$#suites]) {
+ my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
+ sub {
+ @end = ();
+ fetch();
+ exit 0;
+ });
+ # xxx collecte the ref here
+
+ $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
+ push @csuites, $csubsuite;
+ }
+
+ foreach my $mi (@mergeinputs) {
+ my $ref = git_get_ref $mi->{Ref};
+ die "$mi->{Ref} ?" unless length $ref;
+ $mi->{Commit} = $ref;
+ }
+
+ $csuite = join ",", @csuites;
+
+ my $previous = git_get_ref lrref;
+ if ($previous) {
+ unshift @mergeinputs, {
+ Commit => $previous,
+ Info => "local combined tracking branch",
+ Warning =>
+ "archive seems to have rewound: local tracking branch is ahead!",
+ };
+ }
+
+ foreach my $ix (0..$#mergeinputs) {
+ $mergeinputs[$ix]{Index} = $ix;
+ }
+
+ @mergeinputs = sort {
+ -version_compare(mergeinfo_version $a,
+ mergeinfo_version $b) # highest version first
+ or
+ $a->{Index} <=> $b->{Index}; # earliest in spec first
+ } @mergeinputs;
+
+ my @needed;
+
+ NEEDED:
+ foreach my $mi (@mergeinputs) {
+ printdebug "multisuite merge check $mi->{Info}\n";
+ foreach my $previous (@needed) {
+ next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
+ printdebug "multisuite merge un-needed $previous->{Info}\n";
+ next NEEDED;
+ }
+ push @needed, $mi;
+ printdebug "multisuite merge this-needed\n";
+ $mi->{Character} = '+';
+ }
+
+ $needed[0]{Character} = '*';
+
+ my $output = $needed[0]{Commit};
+
+ if (@needed > 1) {
+ printdebug "multisuite merge nontrivial\n";
+ my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
+
+ my $commit = "tree $tree\n";
+ my $msg = "Combine archive branches $csuite [dgit]\n\n".
+ "Input branches:\n";
+
+ foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
+ printdebug "multisuite merge include $mi->{Info}\n";
+ $mi->{Character} //= ' ';
+ $commit .= "parent $mi->{Commit}\n";
+ $msg .= sprintf " %s %-25s %s\n",
+ $mi->{Character},
+ (mergeinfo_version $mi),
+ $mi->{Info};
+ }
+ my $authline = clogp_authline mergeinfo_getclogp $needed[0];
+ $msg .= "\nKey\n".
+ " * marks the highest version branch, which choose to use\n".
+ " + marks each branch which was not already an ancestor\n\n".
+ "[dgit multi-suite $csuite]\n";
+ $commit .=
+ "author $authline\n".
+ "committer $authline\n\n";
+ $output = make_commit_text $commit.$msg;
+ printdebug "multisuite merge generated $output\n";
+ }
+
+ fetch_from_archive_record_1($output);
+ fetch_from_archive_record_2($output);
+
+ progress "calculated combined tracking suite $csuite";
+
+ return 1;
+}
+
+sub clone_set_head () {
+ open H, "> .git/HEAD" or die $!;
+ print H "ref: ".lref()."\n" or die $!;
+ close H or die $!;
+}
+sub clone_finish ($) {
+ my ($dstdir) = @_;
+ runcmd @git, qw(reset --hard), lrref();
+ runcmd qw(bash -ec), <<'END';
+ set -o pipefail
+ git ls-tree -r --name-only -z HEAD | \
+ xargs -0r touch -r . --
+END
+ printdone "ready for work in $dstdir";
+}
+
sub clone ($) {
my ($dstdir) = @_;
- canonicalise_suite();
badusage "dry run makes no sense with clone" unless act_local();
+
+ my $multi_fetched = fork_for_multisuite(sub {
+ printdebug "multi clone before fetch merge\n";
+ changedir $dstdir;
+ });
+ if ($multi_fetched) {
+ printdebug "multi clone after fetch merge\n";
+ clone_set_head();
+ clone_finish($dstdir);
+ exit 0;
+ }
+ printdebug "clone main body\n";
+
+ canonicalise_suite();
my $hasgit = check_for_git();
mkdir $dstdir or fail "create \`$dstdir': $!";
changedir $dstdir;
runcmd @git, qw(init -q);
+ clone_set_head();
my $giturl = access_giturl(1);
if (defined $giturl) {
- open H, "> .git/HEAD" or die $!;
- print H "ref: ".lref()."\n" or die $!;
- close H or die $!;
runcmd @git, qw(remote add), 'origin', $giturl;
}
if ($hasgit) {
runcmd @git, qw(remote add vcs-git), $vcsgiturl;
}
setup_new_tree();
- runcmd @git, qw(reset --hard), lrref();
- runcmd qw(bash -ec), <<'END';
- set -o pipefail
- git ls-tree -r --name-only -z HEAD | \
- xargs -0r touch -r . --
-END
- printdone "ready for work in $dstdir";
+ clone_finish($dstdir);
}
sub fetch () {
+ canonicalise_suite();
if (check_for_git()) {
git_fetch_us();
}
}
sub pull () {
- fetch();
+ my $multi_fetched = fork_for_multisuite(sub { });
+ fetch() unless $multi_fetched; # parent
+ return if $multi_fetched eq '0'; # child
runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
lrref();
printdone "fetched to ".lrref()." and merged into HEAD";
return if $!==&ENOENT;
die "chdir $cwd_remove: $!";
}
+ printdebug "clone rmonerror removing $dstdir\n";
if (stat $dstdir) {
rmtree($dstdir) or die "remove $dstdir: $!\n";
} elsif (grep { $! == $_ }
$package = getfield $sourcep, 'Source';
}
if (@ARGV==0) {
-# $isuite = branchsuite(); # this doesn't work because dak hates canons
+ $isuite = branchsuite();
if (!$isuite) {
my $clogp = parsechangelog();
$isuite = getfield $clogp, 'Distribution';
}
- canonicalise_suite();
- progress "fetching from suite $csuite";
} elsif (@ARGV==1) {
($isuite) = @ARGV;
- canonicalise_suite();
} else {
badusage "incorrect arguments to dgit fetch or dgit pull";
}
sub cmd_fetch {
parseopts();
fetchpullargs();
+ my $multi_fetched = fork_for_multisuite(sub { });
+ exit 0 if $multi_fetched;
fetch();
}
~ianmdlvl / dgit.git / blobdiff