]> git.decadent.org.uk Git - dak.git/blob - scripts/debian/ssh-move
fix the simpler of the pychecker errors
[dak.git] / scripts / debian / ssh-move
1 #! /usr/bin/perl -w
2 use strict;
3
4 use IPC::Open2;
5
6 $ENV{LANG} = "C";
7
8 # The protocol consists of repeated exchanges of the following:
9 #
10 #   S: <filename>
11 #   S: <each line of file, with dot-stuffing as in SMTP>
12 #   S: .
13 #   C: [writes file]
14 #   C: <filename>
15 #   S: [unlinks file]
16
17 my $server = 0;
18 my $verbose = 0;
19 my $nonint = 0;
20 my $sshidentity;
21 my $sshmovepath = 'ssh-move';
22 my $fromdir;
23 my $todir;
24
25 while (@ARGV) {
26     local $_ = shift @ARGV;
27     if (/^--server$/) {
28         $server = 1;
29     } elsif (/^--verbose$/) {
30         $verbose = 1;
31     } elsif (/^--ssh-identity$/) {
32         $sshidentity = shift @ARGV;
33     } elsif (/^--ssh-move-path$/) {
34         $sshmovepath = shift @ARGV;
35     } elsif (/^--from-directory$/) {
36         $fromdir = shift @ARGV;
37     } elsif (/^--to-directory$/) {
38         $todir = shift @ARGV;
39     } elsif (/^--non-interactive$/) {
40         $nonint = 1;
41     } else {
42         unshift @ARGV, $_;
43         last;
44     }
45 }
46
47 local $| = 1;
48
49
50 my ($in, $out) = (*STDIN, *STDOUT);
51
52 unless ($nonint) {
53     my $servername = shift @ARGV;
54     local (*READER, *WRITER);
55
56     my @args = ('ssh');
57     push @args, '-i', $sshidentity if defined $sshidentity;
58
59     push @args, $servername, $sshmovepath;
60     push @args, '--server' unless ($server);
61     push @args, '--to-directory', $todir if (defined $todir && $server);
62     push @args, '--from-directory', $fromdir if (defined $fromdir && !$server);
63     push @args, '--non-interactive';
64     push @args, map quotemeta, @ARGV unless ($server);
65
66     my $pid = open2 (\*READER, \*WRITER, @args);
67
68     ($in, $out) = (*READER, *WRITER);
69 }
70
71 sub server ()
72 {
73     chdir $fromdir if defined $fromdir;
74
75     my @files = map glob, @ARGV;
76
77     for my $file (@files) {
78         print $out "$file\n" or die "can't print to client: $!";
79         open FILE, "< $file" or die "can't open $file: $!\n";
80         local $_;
81         while (<FILE>) {
82             chomp;
83             $_ = ".$_" if /^\./;
84             print $out "$_\n" or die "can't print to client: $!";
85         }
86         print $out ".\n" or die "can't print to client: $!";
87
88         my $confirm = <$in>;
89         chomp $confirm if defined $confirm;
90         unlink $file if defined $confirm and $confirm eq $file;
91     }
92 }
93
94 sub client ()
95 {
96     chdir $todir if defined $todir;
97
98     my $file;
99     while (defined ($file = <$in>)) {
100         chomp $file;
101         print STDERR $file if $verbose;
102         (my $tmpfile = $file) =~ s[.*/][];
103         $tmpfile .= ".$$.tmp";
104         # TODO: unlink $tmpfile if things go wrong
105         open TMP, "> $tmpfile" or die "can't open $tmpfile: $!";
106         local $_;
107         while (<$in>) {
108             chomp;
109             if ($_ eq '.') {
110                 close TMP or die "can't close $tmpfile: $!";
111                 rename $tmpfile, $file
112                     or die "can't rename $tmpfile to $file: $!";
113                 print $out "$file\n" or die "can't print to server: $!";
114                 last;
115             } else {
116                 s/^\.//;
117                 print TMP "$_\n" or die "can't print to $tmpfile: $!";
118             }
119         }
120         print STDERR " ok\n" if $verbose;
121     }
122 }
123
124 if ($server) {
125     server ();
126 } else {
127     client ();
128 }