SCP.pm

   1 package Net::SCP;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA @EXPORT_OK $scp);
   5 use Exporter;
   6 use Carp;
   7 use File::Basename;
   8 use String::ShellQuote;
   9 use IO::Handle;
  10 use Net::SSH qw(sshopen3);
  11 use IPC::Open3;
  12
  13 @ISA = qw(Exporter);
  14 @EXPORT_OK = qw( scp iscp );
  15 $VERSION = '0.03';
  16
  17 $scp = "scp";
  18
  19 =head1 NAME
  20
  21 Net::SCP - Perl extension for secure copy protocol
  22
  23 =head1 SYNOPSIS
  24
  25   #procedural interface
  26   use Net::SCP qw(scp iscp);
  27   scp($source, $destination);
  28   iscp($source, $destination); #shows command, asks for confirmation, and
  29                                #allows user to type a password on tty
  30
  31   #OO interface
  32   $scp = Net::SCP->new( "hostname", "username" );
  33   #with named params
  34   $scp = Net::SCP->new( { "host"=>$hostname, "user"=>$username } );
  35   $scp->get("filename") or die $scp->{errstr};
  36   $scp->put("filename") or die $scp->{errstr};
  37   #tmtowtdi
  38   $scp = new Net::SCP;
  39   $scp->scp($source, $destination);
  40
  41   #Net::FTP-style
  42   $scp = Net::SCP->new("hostname");
  43   $scp->login("user");
  44   $scp->cwd("/dir");
  45   $scp->size("file");
  46   $scp->get("file");
  47   $scp->quit;
  48
  49 =head1 DESCRIPTION
  50
  51 Simple wrappers around ssh and scp commands.
  52
  53 =head1 SUBROUTINES
  54
  55 =over 4
  56
  57 =item scp SOURCE, DESTINATION
  58
  59 Can be called either as a subroutine or a method; however, the subroutine
  60 interface is depriciated.
  61
  62 Calls scp in batch mode, with the B<-B> B<-p> B<-q> and B<-r> options.
  63 Returns false upon error, with a text error message accessable in
  64 $scp->{errstr}.
  65
  66 Returns false and sets the B<errstr> attribute if there is an error.
  67
  68 =cut
  69
  70 sub scp {
  71   my $self = ref($_[0]) ? shift : {};
  72   my($src, $dest, $interact) = @_;
  73   my $flags = '-p';
  74   $flags .= 'r' unless &_islocal($src) && ! -d $src;
  75   my @cmd = ( $scp, $flags, $src, $dest );
  76   if ( ( defined($interact) && $interact )
  77        || ( defined($self->{interact}) && $self->{interact} ) ) {
  78     print join(' ', @cmd), "\n";
  79     unless ( &_yesno ) {
  80       $self->{errstr} = "User declined";
  81       return 0;
  82     }
  83   } else {
  84     $flags .= 'qB';
  85   }
  86   my($reader, $writer, $error ) =
  87     ( new IO::Handle, new IO::Handle, new IO::Handle );
  88   $writer->autoflush(1);#  $error->autoflush(1);
  89   my $pid = open3($writer, $reader, $error, @cmd );
  90   waitpid $pid, 0;
  91   if ( $? >> 8 ) {
  92     my $errstr = join('', <$error>);
  93     #chomp(my $errstr = <$error>);
  94     $self->{errstr} = $errstr;
  95     0;
  96   } else {
  97     1;
  98   }
  99 }
 100
 101 =item iscp SOURCE, DESTINATION
 102
 103 Can be called either as a subroutine or a method; however, the subroutine
 104 interface is depriciated.
 105
 106 Prints the scp command to be execute, waits for the user to confirm, and
 107 (optionally) executes scp, with the B<-p> and B<-r> flags.
 108
 109 Returns false and sets the B<errstr> attribute if there is an error.
 110
 111 =cut
 112
 113 sub iscp {
 114   if ( ref($_[0]) ) {
 115     my $self = shift;
 116     $self->{'interact'} = 1;
 117     $self->scp(@_);
 118   } else {
 119     scp(@_, 1);
 120   }
 121 }
 122
 123 sub _yesno {
 124   print "Proceed [y/N]:";
 125   my $x = scalar(<STDIN>);
 126   $x =~ /^y/i;
 127 }
 128
 129 sub _islocal {
 130   shift !~ /^[^:]+:/
 131 }
 132
 133 =back
 134
 135 =head1 METHODS
 136
 137 =over 4
 138
 139 =item new HOSTNAME [ USER ] | HASHREF
 140
 141 This is the constructor for a new Net::SCP object.  You must specify a
 142 hostname, and may optionally provide a user.  Alternatively, you may pass a
 143 hashref of named params, with the following keys:
 144
 145     host - hostname
 146     user - username
 147     interactive - bool
 148     cwd - current working directory on remote server
 149
 150 =cut
 151
 152 sub new {
 153   my $proto = shift;
 154   my $class = ref($proto) || $proto;
 155   my $self;
 156   if ( ref($_[0]) ) {
 157     $self = shift;
 158   } else {
 159     $self = {
 160               'host'        => shift,
 161               'user'        => ( scalar(@_) ? shift : '' ),
 162               'interactive' => 0,
 163               'cwd'         => '',
 164             };
 165   }
 166   bless($self, $class);
 167 }
 168
 169 =item login [USER]
 170
 171 Compatibility method.  Optionally sets the user.
 172
 173 =cut
 174
 175 sub login {
 176   my($self, $user) = @_;
 177   $self->{'user'} = $user if $user;
 178 }
 179
 180 =item cwd CWD
 181
 182 Sets the cwd (used for a subsequent get or put request without a full pathname).
 183
 184 =cut
 185
 186 sub cwd {
 187   my($self, $cwd) = @_;
 188   $self->{'cwd'} = $cwd || '/';
 189 }
 190
 191 =item get REMOTE_FILE [, LOCAL_FILE]
 192
 193 Uses scp to transfer REMOTE_FILE from the remote host.  If a local filename is
 194 omitted, uses the basename of the remote file.
 195
 196 =cut
 197
 198 sub get {
 199   my($self, $remote, $local) = @_;
 200   $remote = $self->{'cwd'}. "/$remote" if $self->{'cwd'} && $remote !~ /^\//;
 201   $local ||= basename($remote);
 202   my $source = $self->{'host'}. ":$remote";
 203   $source = $self->{'user'}. '@'. $source if $self->{'user'};
 204   scp($source,$local);
 205 }
 206
 207 =item size FILE
 208
 209 Returns the size in bytes for the given file as stored on the remote server.
 210 Returns 0 on error, and sets the B<errstr> attribute.  In the case of an actual
 211 zero-length file on the remote server, the special value '0e0' is returned,
 212 which evaluates to zero when used as a number, but is true.
 213
 214 (Implementation note: An ssh connection is established to the remote machine
 215 and wc is used to determine the file size.)
 216
 217 =cut
 218
 219 sub size {
 220   my($self, $file) = @_;
 221   $file = $self->{'cwd'}. "/$file" if $self->{'cwd'} && $file !~ /^\//;
 222   my $host = $self->{'host'};
 223   $host = $self->{'user'}. '@'. $host if $self->{'user'};
 224   my($reader, $writer, $error ) =
 225     ( new IO::Handle, new IO::Handle, new IO::Handle );
 226   $writer->autoflush(1);#  $error->autoflush(1);
 227   #sshopen2($host, $reader, $writer, 'wc', '-c ', shell_quote($file) );
 228   my $pid =
 229     sshopen3($host, $writer, $reader, $error, 'wc', '-c ', shell_quote($file) );
 230   waitpid $pid, 0;
 231   if ( $? >> 8 ) {
 232     chomp(my $errstr = <$error>);
 233     $self->{errstr} = $errstr || "wc exited with status ". $?>>8;
 234     0;
 235   } else {
 236     chomp( my $size = <$reader> || 0 );
 237     if ( $size =~ /^\s*(\d+)/ ) {
 238       $1 ? $1 : '0e0';
 239     } else {
 240       $self->{errstr} = "unparsable output from remote wc: $size";
 241       0;
 242     }
 243   }
 244 }
 245
 246 =item put LOCAL_FILE [, REMOTE_FILE]
 247
 248 Uses scp to trasnfer LOCAL_FILE to the remote host.  If a remote filename is
 249 omitted, uses the basename of the local file.
 250
 251 =cut
 252
 253 sub put {
 254   my($self, $local, $remote) = @_;
 255   $remote ||= basename($local);
 256   $remote = $self->{'cwd'}. "/$remote" if $self->{'cwd'} && $remote !~ /^\//;
 257   my $dest = $self->{'host'}. ":$remote";
 258   $dest = $self->{'user'}. '@'. $dest if $self->{'user'};
 259   warn "scp $local $dest\n";
 260   scp($local, $dest);
 261 }
 262
 263 =item binary
 264
 265 Compatibility method: does nothing; returns true.
 266
 267 =cut
 268
 269 sub binary { 1; }
 270
 271 =back
 272
 273 =head1 AUTHORS
 274
 275 Ivan Kohler <ivan-netscp_pod@420.am>
 276 Anthony Deaver <bishop@projectmagnus.org>
 277
 278 Thanks to Jon Gunnip <jon@soundbite.com> for fixing a bug with size().
 279
 280 =head1 BUGS
 281
 282 Still has no-OO cruft.
 283
 284 In order to work around some problems with commercial SSH2, if the source file
 285 is on the local system, and is not a directory, the B<-r> flag is omitted.
 286
 287 It's probably better just to use SSH1 or OpenSSH <http://www.openssh.com/>
 288
 289 The Net::FTP-style OO stuff is kinda lame.  And incomplete.
 290
 291 =head1 SEE ALSO
 292
 293 scp(1), ssh(1)
 294
 295 =cut
 296
 297 1;
 298
 299