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.04';
  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;
  76   if ( ( defined($interact) && $interact )
  77        || ( defined($self->{interact}) && $self->{interact} ) ) {
  78     @cmd = ( $scp, $flags, $src, $dest );
  79     print join(' ', @cmd), "\n";
  80     unless ( &_yesno ) {
  81       $self->{errstr} = "User declined";
  82       return 0;
  83     }
  84   } else {
  85     $flags .= 'qB';
  86     @cmd = ( $scp, $flags, $src, $dest );
  87   }
  88   my($reader, $writer, $error ) =
  89     ( new IO::Handle, new IO::Handle, new IO::Handle );
  90   $writer->autoflush(1);#  $error->autoflush(1);
  91   my $pid = open3($writer, $reader, $error, @cmd );
  92   waitpid $pid, 0;
  93   if ( $? >> 8 ) {
  94     my $errstr = join('', <$error>);
  95     #chomp(my $errstr = <$error>);
  96     $self->{errstr} = $errstr;
  97     0;
  98   } else {
  99     1;
 100   }
 101 }
 102
 103 =item iscp SOURCE, DESTINATION
 104
 105 Can be called either as a subroutine or a method; however, the subroutine
 106 interface is depriciated.
 107
 108 Prints the scp command to be execute, waits for the user to confirm, and
 109 (optionally) executes scp, with the B<-p> and B<-r> flags.
 110
 111 Returns false and sets the B<errstr> attribute if there is an error.
 112
 113 =cut
 114
 115 sub iscp {
 116   if ( ref($_[0]) ) {
 117     my $self = shift;
 118     $self->{'interact'} = 1;
 119     $self->scp(@_);
 120   } else {
 121     scp(@_, 1);
 122   }
 123 }
 124
 125 sub _yesno {
 126   print "Proceed [y/N]:";
 127   my $x = scalar(<STDIN>);
 128   $x =~ /^y/i;
 129 }
 130
 131 sub _islocal {
 132   shift !~ /^[^:]+:/
 133 }
 134
 135 =back
 136
 137 =head1 METHODS
 138
 139 =over 4
 140
 141 =item new HOSTNAME [ USER ] | HASHREF
 142
 143 This is the constructor for a new Net::SCP object.  You must specify a
 144 hostname, and may optionally provide a user.  Alternatively, you may pass a
 145 hashref of named params, with the following keys:
 146
 147     host - hostname
 148     user - username
 149     interactive - bool
 150     cwd - current working directory on remote server
 151
 152 =cut
 153
 154 sub new {
 155   my $proto = shift;
 156   my $class = ref($proto) || $proto;
 157   my $self;
 158   if ( ref($_[0]) ) {
 159     $self = shift;
 160   } else {
 161     $self = {
 162               'host'        => shift,
 163               'user'        => ( scalar(@_) ? shift : '' ),
 164               'interactive' => 0,
 165               'cwd'         => '',
 166             };
 167   }
 168   bless($self, $class);
 169 }
 170
 171 =item login [USER]
 172
 173 Compatibility method.  Optionally sets the user.
 174
 175 =cut
 176
 177 sub login {
 178   my($self, $user) = @_;
 179   $self->{'user'} = $user if $user;
 180 }
 181
 182 =item cwd CWD
 183
 184 Sets the cwd (used for a subsequent get or put request without a full pathname).
 185
 186 =cut
 187
 188 sub cwd {
 189   my($self, $cwd) = @_;
 190   $self->{'cwd'} = $cwd || '/';
 191 }
 192
 193 =item get REMOTE_FILE [, LOCAL_FILE]
 194
 195 Uses scp to transfer REMOTE_FILE from the remote host.  If a local filename is
 196 omitted, uses the basename of the remote file.
 197
 198 =cut
 199
 200 sub get {
 201   my($self, $remote, $local) = @_;
 202   $remote = $self->{'cwd'}. "/$remote" if $self->{'cwd'} && $remote !~ /^\//;
 203   $local ||= basename($remote);
 204   my $source = $self->{'host'}. ":$remote";
 205   $source = $self->{'user'}. '@'. $source if $self->{'user'};
 206   scp($source,$local);
 207 }
 208
 209 =item size FILE
 210
 211 Returns the size in bytes for the given file as stored on the remote server.
 212 Returns 0 on error, and sets the B<errstr> attribute.  In the case of an actual
 213 zero-length file on the remote server, the special value '0e0' is returned,
 214 which evaluates to zero when used as a number, but is true.
 215
 216 (Implementation note: An ssh connection is established to the remote machine
 217 and wc is used to determine the file size.)
 218
 219 =cut
 220
 221 sub size {
 222   my($self, $file) = @_;
 223   $file = $self->{'cwd'}. "/$file" if $self->{'cwd'} && $file !~ /^\//;
 224   my $host = $self->{'host'};
 225   $host = $self->{'user'}. '@'. $host if $self->{'user'};
 226   my($reader, $writer, $error ) =
 227     ( new IO::Handle, new IO::Handle, new IO::Handle );
 228   $writer->autoflush(1);#  $error->autoflush(1);
 229   #sshopen2($host, $reader, $writer, 'wc', '-c ', shell_quote($file) );
 230   my $pid =
 231     sshopen3($host, $writer, $reader, $error, 'wc', '-c ', shell_quote($file) );
 232   waitpid $pid, 0;
 233   if ( $? >> 8 ) {
 234     chomp(my $errstr = <$error>);
 235     $self->{errstr} = $errstr || "wc exited with status ". $?>>8;
 236     0;
 237   } else {
 238     chomp( my $size = <$reader> || 0 );
 239     if ( $size =~ /^\s*(\d+)/ ) {
 240       $1 ? $1 : '0e0';
 241     } else {
 242       $self->{errstr} = "unparsable output from remote wc: $size";
 243       0;
 244     }
 245   }
 246 }
 247
 248 =item put LOCAL_FILE [, REMOTE_FILE]
 249
 250 Uses scp to trasnfer LOCAL_FILE to the remote host.  If a remote filename is
 251 omitted, uses the basename of the local file.
 252
 253 =cut
 254
 255 sub put {
 256   my($self, $local, $remote) = @_;
 257   $remote ||= basename($local);
 258   $remote = $self->{'cwd'}. "/$remote" if $self->{'cwd'} && $remote !~ /^\//;
 259   my $dest = $self->{'host'}. ":$remote";
 260   $dest = $self->{'user'}. '@'. $dest if $self->{'user'};
 261   warn "scp $local $dest\n";
 262   scp($local, $dest);
 263 }
 264
 265 =item binary
 266
 267 Compatibility method: does nothing; returns true.
 268
 269 =cut
 270
 271 sub binary { 1; }
 272
 273 =back
 274
 275 =head1 AUTHORS
 276
 277 Ivan Kohler <ivan-netscp_pod@420.am>
 278 Anthony Deaver <bishop@projectmagnus.org>
 279
 280 Thanks to Jon Gunnip <jon@soundbite.com> for fixing a bug with size().
 281
 282 =head1 BUGS
 283
 284 Still has no-OO cruft.
 285
 286 In order to work around some problems with commercial SSH2, if the source file
 287 is on the local system, and is not a directory, the B<-r> flag is omitted.
 288
 289 It's probably better just to use SSH1 or OpenSSH <http://www.openssh.com/>
 290
 291 The Net::FTP-style OO stuff is kinda lame.  And incomplete.
 292
 293 =head1 SEE ALSO
 294
 295 scp(1), ssh(1)
 296
 297 =cut
 298
 299 1;
 300
 301