use File::Basename;
use Dpkg::Version;
use POSIX;
+use IPC::Open2;
+use File::Temp;
our $our_version = 'UNRELEASED'; ###substituted###
our $isuite = 'unstable';
our $idistro;
our $package;
+our @ropts;
our $sign = 1;
our $dryrun = 0;
our (@debsign) = qw(debsign);
our (@gpg) = qw(gpg);
our (@sbuild) = qw(sbuild -A);
+our (@ssh) = qw(ssh);
+our (@dgit) = qw(dgit);
our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
our (@dpkggenchanges) = qw(dpkg-genchanges);
'debsign' => \@debsign,
'gpg' => \@gpg,
'sbuild' => \@sbuild,
+ 'ssh' => \@ssh,
+ 'dgit' => \@dgit,
'dpkg-source' => \@dpkgsource,
'dpkg-buildpackage' => \@dpkgbuildpackage,
'dpkg-genchanges' => \@dpkggenchanges,
return "+".rrref().":".lrref();
}
-our $ua;
+#---------- remote protocol support, common ----------
-sub responder_send_command ($) {
- my ($command) = @_;
- return unless $we_are_responder;
- # called even without $we_are_responder
- print DEBUG "<< $command\n";
- print $command, "\n" or die $!;
-}
+# remote push initiator/responder protocol:
+# < dgit-remote-push-ready [optional extra info ignored by old initiators]
+#
+# > file begin parsed-changelog
+# [indicates that output of dpkg-parsechangelog follows]
+# > data-block NBYTES
+# > [NBYTES bytes of data (no newline)]
+# [maybe some more blocks]
+# > data-end
+#
+# > file begin dsc
+# [etc]
+#
+# > file begin changes
+# [etc]
+#
+# > want signed-tag
+# [indicates that signed tag is wanted]
+# < data-block NBYTES
+# < [NBYTES bytes of data (no newline)]
+# [maybe some more blocks]
+# < data-end
+# < files-end
+#
+# > want signed-changes-dsc
+# < data-block NBYTES [transfer of signed changes]
+# [etc]
+# < data-block NBYTES [transfer of signed dsc]
+# [etc]
+# < files-end
+#
+# > complete
-sub progress {
- if ($we_are_responder) {
- my $m = join '', @_;
- responder_send_command "progress ".length($m) or die $!;
- print $m or die $!;
- } else {
- print @_, "\n";
- }
+sub badproto ($$) {
+ my ($fh, $m) = @_;
+ fail "connection lost: $!" if $fh->error;
+ fail "connection terminated" if $fh->eof;
+ fail "protocol violation; $m not expected";
}
-sub protocol_send_file ($) {
- my ($fh, $cmdprefix, $ourfn) = @_;
+sub protocol_expect ($&) {
+ my ($fh, $match) = @_;
+ local $_;
+ $_ = <$fh>;
+ defined && chomp or badproto $fh, "eof";
+ return if &$match;
+ badproto $fh, "\`$_'";
+}
+
+sub protocol_send_file ($$) {
+ my ($fh, $ourfn) = @_;
open PF, "<", $ourfn or die "$ourfn: $!";
- print $fh "$cmdprefix begin\n" or die $!;
for (;;) {
my $d;
my $got = read PF, $d, 65536;
die "$ourfn: $!" unless defined $got;
last if $got;
- print $fh "$keyword block ".length($d)."\n" or die $!;
+ print $fh "data-block ".length($d)."\n" or die $!;
print $d or die $!;
}
- print $fh "$keyword end\n" or die $!;
+ print $fh "data-end\n" or die $!;
close PF;
}
+sub protocol_read_bytes ($$) {
+ my ($fh, $nbytes) = @_;
+ $nbytes =~ m/^\d{1,6}$/ or badproto \*RO, "bad byte count";
+ my $d;
+ my $got = read $fh, $d, $nbytes;
+ $got==$nbytes or badproto $fh, "eof during data block";
+ return $d;
+}
+
+sub protocol_receive_file ($$) {
+ my ($fh, $ourfn) = @_;
+ open PF, ">", $ourfn or die "$ourfn: $!";
+ for (;;) {
+ protocol_expect \*STDIN, { m/^data-block (.*})$|data-end$/ };
+ length $1 or last;
+ my $d = protocol_read_bytes \*STDIN, $1;
+ print PF $d or die $!;
+ }
+}
+
+#---------- remote protocol support, responder ----------
+
+sub responder_send_command ($) {
+ my ($command) = @_;
+ return unless $we_are_responder;
+ # called even without $we_are_responder
+ print DEBUG "<< $command\n";
+ print $command, "\n" or die $!;
+}
+
sub responder_send_file ($$) {
my ($keyword, $ourfn) = @_;
return unless $we_are_responder;
- print DEBUG "responder sending $keyword $ourfn\n";
- protocol_send_file(\*STDOUT, "upload $keyword");
+ responder_send_command "file begin $cmdprefix";
+ protocol_send_file \*STDOUT, $ourfn;
}
sub responder_receive_files ($@) {
my ($keyword, @ourfns) = @_;
die unless $we_are_responder;
-
+ responder_send_command "want $keyword";
+ foreach my $fn (@ourfns) {
+ protocol_receive_file \*STDIN, $fn;
+ }
+ protocol_expect \*STDIN, { m/^files-end$/ };
+}
+
+#---------- remote protocol support, initiator ----------
+
+sub initiator_expect (&) {
+ my ($match) = @_;
+ protocol_expect \*RO, &$match;
+}
+
+#---------- end remote code ----------
+
+sub progress {
+ if ($we_are_responder) {
+ my $m = join '', @_;
+ responder_send_command "progress ".length($m) or die $!;
+ print $m or die $!;
+ } else {
+ print @_, "\n";
+ }
}
+our $ua;
+
sub url_get {
if (!$ua) {
$ua = LWP::UserAgent->new();
exit 8;
}
+sub nextarg {
+ @ARGV or badusage "too few arguments";
+ return scalar shift @ARGV;
+}
+
sub cmd_help () {
print $helpmsg or die $!;
exit 0;
dopush();
}
+#---------- remote commands' implementation ----------
+
sub cmd_remote_push_responder {
my ($nrargs) = shift @ARGV;
my (@rargs) = @ARGV[0..$nrargs-1];
my ($dir) = @rargs;
chdir $dir or die "$dir: $!";
$we_are_remote = 1;
+ $|=1;
responder_send_command("dgit-remote-push-ready");
&cmd_push;
}
+our $i_tmp;
+
+sub i_cleanup {
+ local ($@);
+ return unless defined $i_tmp;
+ chdir "/" or die $!;
+ eval { rmtree $i_tmp; };
+}
+
+sub cmd_rpush {
+ my $host = nextarg;
+ my $dir;
+ if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
+ $host = $1;
+ $dir = $'; #';
+ } else {
+ $dir = nextarg;
+ }
+ $dir =~ s{^-}{./-};
+ my @rargs = ($dir);
+ my @rdgit;
+ push @rdgit, @dgit
+ push @rdgit, @ropts;
+ push @rdgit, (scalar @rargs), @rargs;
+ push @rdgit, @ARGV;
+ my @cmd = (@ssh, $host, shellquote @rdgit);
+ my $pid = open2(\*RO, \*RI, @cmd);
+ eval {
+ $i_tmp = tempdir();
+ chdir $i_tmp or die "$i_tmp $!";
+ initiator_expect { m/^dgit-remote-push-ready/ };
+ for (;;) {
+ initiator_expect { m/^(\S+)(?: (.*))?$/ };
+ my ($icmd,$iargs) = ($1, $2);
+ i_method "i_resp_", $icmd, $iargs;
+ }
+ };
+ i_cleanup();
+ die $@;
+ }
+}
+
+#---------- building etc. ----------
+
our $version;
our $sourcechanges;
our $dscfn;
build_maybe_quilt_fixup();
}
+#---------- argument parsing and main program ----------
+
sub cmd_version {
print "dgit version $our_version\n" or die $!;
exit 0;
last if m/^--?$/;
if (m/^--/) {
if (m/^--dry-run$/) {
+ push @ropts, $_;
$dryrun=1;
} elsif (m/^--no-sign$/) {
+ push @ropts, $_;
$sign=0;
} elsif (m/^--help$/) {
cmd_help();
} elsif (m/^--version$/) {
cmd_version();
} elsif (m/^--new$/) {
+ push @ropts, $_;
$new_package=1;
} elsif (m/^--(\w+)=(.*)/s &&
($om = $opts_opt_map{$1}) &&
length $om->[0]) {
+ push @ropts, $_;
$om->[0] = $2;
} elsif (m/^--(\w+):(.*)/s &&
($om = $opts_opt_map{$1})) {
+ push @ropts, $_;
push @$om, $2;
} elsif (m/^--existing-package=(.*)/s) {
+ push @ropts, $_;
$existing_package = $1;
} elsif (m/^--distro=(.*)/s) {
+ push @ropts, $_;
$idistro = $1;
} elsif (m/^--clean=(dpkg-source|git|none)$/s) {
+ push @ropts, $_;
$cleanmode = $1;
} elsif (m/^--clean=(.*)$/s) {
badusage "unknown cleaning mode \`$1'";
} elsif (m/^--ignore-dirty$/s) {
+ push @ropts, $_;
$ignoredirty = 1;
} elsif (m/^--no-quilt-fixup$/s) {
+ push @ropts, $_;
$noquilt = 1;
} else {
badusage "unknown long option \`$_'";
} else {
while (m/^-./s) {
if (s/^-n/-/) {
+ push @ropts, $_;
$dryrun=1;
} elsif (s/^-h/-/) {
cmd_help();
} elsif (s/^-D/-/) {
+ push @ropts, $_;
open DEBUG, ">&STDERR" or die $!;
$debug++;
} elsif (s/^-N/-/) {
+ push @ropts, $_;
$new_package=1;
} elsif (m/^-[vm]/) {
+ push @ropts, $_;
push @changesopts, $_;
$_ = '';
} elsif (s/^-c(.*=.*)//s) {
+ push @ropts, $_;
push @git, '-c', $1;
} elsif (s/^-d(.*)//s) {
+ push @ropts, $_;
$idistro = $1;
} elsif (s/^-C(.*)//s) {
+ push @ropts, $_;
$changesfile = $1;
} elsif (s/^-k(.*)//s) {
$keyid=$1;
} elsif (s/^-wn//s) {
+ push @ropts, $_;
$cleanmode = 'none';
} elsif (s/^-wg//s) {
+ push @ropts, $_;
$cleanmode = 'git';
} elsif (s/^-wd//s) {
+ push @ropts, $_;
$cleanmode = 'dpkg-source';
} else {
badusage "unknown short option \`$_'";
~ianmdlvl / dgit.git / blobdiff