+sub dryrun_report {
+ printcmd(\*STDOUT,"#",@_);
+}
+
+sub runcmd_ordryrun {
+ if (!$dryrun) {
+ runcmd @_;
+ } else {
+ dryrun_report @_;
+ }
+}
+
+our $helpmsg = <<END;
+main usages:
+ dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
+ dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
+ dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
+ dgit [dgit-opts] push [dgit-opts] [suite]
+important dgit options:
+ -k<keyid> sign tag and package with <keyid> instead of default
+ --dry-run -n do not change anything, but go through the motions
+ --new -N allow introducing a new package
+ --debug -D increase debug level
+ -c<name>=<value> set git config option (used directly by dgit too)
+END
+
+our $later_warning_msg = <<END;
+Perhaps the upload is stuck in incoming. Using the version from git.
+END
+
+sub badusage {
+ print STDERR "$us: @_\n", $helpmsg or die $!;
+ exit 8;
+}
+
+sub helponly () {
+ print $helpmsg or die $!;
+ exit 0;
+}
+
+our %defcfg = ('dgit.default.distro' => 'debian',
+ 'dgit.default.username' => '',
+ 'dgit.default.archive-query-default-component' => 'main',
+ 'dgit.default.ssh' => 'ssh',
+ 'dgit-distro.debian.git-host' => 'git.debian.org',
+ 'dgit-distro.debian.git-proto' => 'git+ssh://',
+ 'dgit-distro.debian.git-path' => '/git/dgit-repos',
+ 'dgit-distro.debian.git-check' => 'ssh-cmd',
+ 'dgit-distro.debian.git-create' => 'ssh-cmd',
+ 'dgit-distro.debian.sshdakls-host' => 'coccia.debian.org',
+ 'dgit-distro.debian.sshdakls-dir' =>
+ '/srv/ftp-master.debian.org/ftp/dists',
+ 'dgit-distro.debian.mirror' => 'http://http.debian.net/debian/');
+
+sub cfg {
+ foreach my $c (@_) {
+ return undef if $c =~ /RETURN-UNDEF/;
+ my @cmd = (@git, qw(config --), $c);
+ my $v;
+ {
+ local ($debug) = $debug-1;
+ $v = cmdoutput_errok @cmd;
+ };
+ if ($?==0) {
+ return $v;
+ } elsif ($?!=256) {
+ failedcmd @cmd;
+ }
+ my $dv = $defcfg{$c};
+ return $dv if defined $dv;
+ }
+ badcfg "need value for one of: @_";
+}
+
+sub access_distro () {
+ return cfg("dgit-suite.$isuite.distro",
+ "dgit.default.distro");
+}
+
+sub access_cfg (@) {
+ my (@keys) = @_;
+ my $distro = $idistro || access_distro();
+ my $value = cfg(map { ("dgit-distro.$distro.$_",
+ "dgit.default.$_") } @keys);
+ return $value;
+}
+
+sub access_someuserhost ($) {
+ my ($some) = @_;
+ my $user = access_cfg("$some-user",'username');
+ my $host = access_cfg("$some-host");
+ return length($user) ? "$user\@$host" : $host;
+}
+
+sub access_gituserhost () {
+ return access_someuserhost('git');
+}
+
+sub access_giturl () {
+ my $url = access_cfg('git-url','RETURN-UNDEF');
+ if (!defined $url) {
+ $url =
+ access_cfg('git-proto').
+ access_gituserhost().
+ access_cfg('git-path');
+ }
+ return "$url/$package.git";
+}
+
+sub parsecontrolfh ($$@) {
+ my ($fh, $desc, @opts) = @_;
+ my %opts = ('name' => $desc, @opts);
+ my $c = Dpkg::Control::Hash->new(%opts);
+ $c->parse($fh) or die "parsing of $desc failed";
+ return $c;
+}
+
+sub parsecontrol {
+ my ($file, $desc) = @_;
+ my $fh = new IO::Handle;
+ open $fh, '<', $file or die "$file: $!";
+ my $c = parsecontrolfh($fh,$desc);
+ $fh->error and die $!;
+ close $fh;
+ return $c;
+}
+
+sub getfield ($$) {
+ my ($dctrl,$field) = @_;
+ my $v = $dctrl->{$field};
+ return $v if defined $v;
+ fail "missing field $field in ".$v->get_option('name');
+}
+
+sub parsechangelog {
+ my $c = Dpkg::Control::Hash->new();
+ my $p = new IO::Handle;
+ my @cmd = (qw(dpkg-parsechangelog));
+ open $p, '-|', @cmd or die $!;
+ $c->parse($p);
+ $?=0; $!=0; close $p or failedcmd @cmd;
+ return $c;
+}
+
+our %rmad;
+
+sub archive_query ($) {
+ my ($method) = @_;
+ my $query = access_cfg('archive-query','RETURN-UNDEF');
+ if (!defined $query) {
+ my $distro = access_distro();
+ if ($distro eq 'debian') {
+ $query = "sshdakls:".
+ access_someuserhost('sshdakls').':'.
+ access_cfg('sshdakls-dir');
+ } else {
+ $query = "madison:$distro";
+ }
+ }
+ $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
+ my $proto = $1;
+ my $data = $'; #';
+ { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
+}
+
+sub archive_query_madison ($$) {
+ my ($proto,$data) = @_;
+ die unless $proto eq 'madison';
+ $rmad{$package} ||= cmdoutput
+ qw(rmadison -asource),"-s$isuite","-u$data",$package;
+ my $rmad = $rmad{$package};
+ return madison_parse($rmad);
+}
+
+sub archive_query_sshdakls ($$) {
+ my ($proto,$data) = @_;
+ $data =~ s/:.*// or badcfg "invalid sshdakls method string \`$data'";
+ my $dakls = cmdoutput
+ access_cfg('ssh'), $data, qw(dak ls -asource),"-s$isuite",$package;
+ return madison_parse($dakls);
+}
+
+sub canonicalise_suite_sshdakls ($$) {
+ my ($proto,$data) = @_;
+ $data =~ m/:/ or badcfg "invalid sshdakls method string \`$data'";
+ my @cmd =
+ (access_cfg('ssh'), $`,
+ "set -e; cd $';".
+ " if test -h $isuite; then readlink $isuite; exit 0; fi;".
+ " if test -d $isuite; then echo $isuite; exit 0; fi;".
+ " exit 1");
+ my $dakls = cmdoutput @cmd;
+ failedcmd @cmd unless $dakls =~ m/^\w/;
+ return $dakls;
+}
+
+sub madison_parse ($) {
+ my ($rmad) = @_;
+ my @out;
+ foreach my $l (split /\n/, $rmad) {
+ $l =~ m{^ \s*( [^ \t|]+ )\s* \|
+ \s*( [^ \t|]+ )\s* \|
+ \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
+ \s*( [^ \t|]+ )\s* }x or die "$rmad $?";
+ $1 eq $package or die "$rmad $package ?";
+ my $vsn = $2;
+ my $newsuite = $3;
+ my $component;
+ if (defined $4) {
+ $component = $4;
+ } else {
+ $component = access_cfg('archive-query-default-component');
+ }
+ $5 eq 'source' or die "$rmad ?";
+ my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
+ my $subpath = "/pool/$component/$prefix/$package/${package}_$vsn.dsc";
+ push @out, [$vsn,$subpath,$newsuite];
+ }
+ return sort { -version_compare_string($a->[0],$b->[0]); } @out;
+}
+
+sub canonicalise_suite_madison ($$) {
+ my @r = archive_query_madison($_[0],$_[1]);
+ @r or fail
+ "unable to canonicalise suite using package $package".
+ " which does not appear to exist in suite $isuite;".
+ " --existing-package may help";
+ return $r[0][2];
+}
+
+sub canonicalise_suite () {
+ $csuite = archive_query('canonicalise_suite');
+ if ($isuite ne $csuite) {
+ # madison canonicalises for us
+ print "canonical suite name for $isuite is $csuite\n";
+ }
+}
+
+sub get_archive_dsc () {
+ canonicalise_suite();
+ my @vsns = archive_query('archive_query');
+ foreach my $vinfo (@vsns) {
+ my ($vsn,$subpath) = @$vinfo;
+ $dscurl = access_cfg('mirror').$subpath;
+ $dscdata = url_get($dscurl);
+ next unless defined $dscdata;
+ $dscurl = access_cfg('mirror').$subpath;
+ $dscdata = url_get($dscurl);
+ my $dscfh = new IO::File \$dscdata, '<' or die $!;
+ print DEBUG Dumper($dscdata) if $debug>1;
+ $dsc = parsecontrolfh($dscfh,$dscurl, allow_pgp=>1);
+ print DEBUG Dumper($dsc) if $debug>1;
+ my $fmt = getfield $dsc, 'Format';
+ fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
+ return $dsc;
+ }
+ return undef;
+}
+
+sub check_for_git () {
+ # returns 0 or 1
+ my $how = access_cfg('git-check');
+ if ($how eq 'ssh-cmd') {
+ my @cmd =
+ (access_cfg('ssh'),access_gituserhost(),
+ " set -e; cd ".access_cfg('git-path').";".
+ " if test -d $package.git; then echo 1; else echo 0; fi");
+ my $r= cmdoutput @cmd;
+ failedcmd @cmd unless $r =~ m/^[01]$/;
+ return $r+0;
+ } else {
+ badcfg "unknown git-check \`$how'";
+ }
+}
+
+sub create_remote_git_repo () {
+ my $how = access_cfg('git-create');
+ if ($how eq 'ssh-cmd') {
+ runcmd_ordryrun
+ (access_cfg('ssh'),access_gituserhost(),
+ "set -e; cd ".access_cfg('git-path').";".
+ " cp -a _template $package.git");
+ } else {
+ badcfg "unknown git-create \`$how'";
+ }
+}
+
+our ($dsc_hash,$upload_hash);
+
+our $ud = '.git/dgit/unpack';
+
+sub prep_ud () {