+our ($dscdata,$dscurl,$dsc);
+
+sub printcmd {
+ my $fh = shift @_;
+ my $intro = shift @_;
+ print $fh $intro or die $!;
+ local $_;
+ foreach my $a (@_) {
+ $_ = $a;
+ if (s{['\\]}{\\$&}g || m{\s} || m{[^-_./0-9a-z]}i) {
+ print $fh " '$_'" or die $!;
+ } else {
+ print $fh " $_" or die $!;
+ }
+ }
+ print $fh "\n" or die $!;
+}
+
+sub runcmd {
+ printcmd(\*DEBUG,"+",@_) if $debug>0;
+ $!=0; $?=0;
+ die "@_ $! $?" if system @_;
+}
+
+sub printdone {
+ if (!$dryrun) {
+ print "dgit ok: @_\n";
+ } else {
+ print "would be ok: @_ (but dry run only)\n";
+ }
+}
+
+sub cmdoutput_errok {
+ die Dumper(\@_)." ?" if grep { !defined } @_;
+ printcmd(\*DEBUG,"|",@_) if $debug>0;
+ open P, "-|", @_ or die $!;
+ my $d;
+ $!=0; $?=0;
+ { local $/ = undef; $d = <P>; }
+ die if P->error;
+ if (!close P) { print DEBUG "=>!$?\n" if $debug>0; return undef; }
+ chomp $d;
+ $d =~ m/^.*/;
+ print DEBUG "=> \`$&'",(length $' ? '...' : ''),"\n" if $debug>0; #';
+ return $d;
+}
+
+sub cmdoutput {
+ my $d = cmdoutput_errok @_;
+ defined $d or die "@_ $? $!";
+ return $d;
+}
+
+sub dryrun_report {
+ printcmd(\*STDOUT,"#",@_);
+}
+
+sub runcmd_ordryrun {
+ if (!$dryrun) {
+ runcmd @_;
+ } else {
+ dryrun_report @_;
+ }
+}
+
+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 (@_) {
+ my $v;
+ {
+ local ($debug) = $debug-1;
+ $v = cmdoutput_errok(@git, qw(config --), $c);
+ };
+ if ($?==0) {
+ return $v;
+ } elsif ($?!=256) {
+ die "$c $?";
+ }
+ my $dv = $defcfg{$c};
+ return $dv if defined $dv;
+ }
+ return undef;
+}
+
+sub access_distro () {
+ return cfg("dgit-suite.$isuite.distro",
+ "dgit.default.distro");
+}
+
+sub access_cfg (@) {
+ my (@keys) = @_;
+ my $distro = 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 defined($user) && length($user) ? "$user\@$host" : $host;
+}
+
+sub access_gituserhost () {
+ return access_someuserhost('git');
+}
+
+sub access_giturl () {
+ my $url = access_cfg('git-url');
+ if (!defined $url) {
+ $url =
+ access_cfg('git-proto').
+ access_gituserhost().
+ access_cfg('git-path');
+ }
+ return "$url/$package.git";
+}
+
+sub parsecontrol {
+ my $c = Dpkg::Control::Hash->new();
+ $c->load(@_) or return undef;
+ return $c;
+}
+
+sub parsechangelog {
+ my $c = Dpkg::Control::Hash->new();
+ my $p = new IO::Handle;
+ open $p, '-|', qw(dpkg-parsechangelog) or die $!;
+ $c->parse($p);
+ $?=0; $!=0; close $p or die "$! $?";
+ return $c;
+}
+
+our %rmad;
+
+sub archive_query ($) {
+ my ($method) = @_;
+ my $query = access_cfg('archive-query');
+ if (!$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 die "$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 die "$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 die "$data ?";
+ my $dakls = cmdoutput
+ 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";
+ die unless $dakls =~ m/^\w/;
+ return $dakls;
+}
+
+sub madison_parse ($) {
+ my ($rmad) = @_;
+ if (!length $rmad) {
+ return ();
+ }
+ $rmad =~ 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";
+ return ($vsn,$subpath,$newsuite);
+}
+
+sub canonicalise_suite_madison ($$) {
+ my @r = archive_query_madison($_[0],$_[1]);
+ @r or die;
+ return $r[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";
+ }
+}
+