File Coverage

blib/lib/Net/SFTP.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             # $Id: SFTP.pm,v 1.35 2005/10/05 06:19:36 dbrobins Exp $
2              
3             package Net::SFTP;
4 2     2   1631 use strict;
  2         4  
  2         76  
5              
6 2     2   1246 use Net::SFTP::Constants qw( :fxp :flags :status :att SSH2_FILEXFER_VERSION );
  2         4  
  2         14  
7 2     2   1740 use Net::SFTP::Util qw( fx2txt );
  2         4  
  2         109  
8 2     2   1184 use Net::SFTP::Attributes;
  0            
  0            
9             use Net::SFTP::Buffer;
10             use Net::SSH::Perl::Constants qw( :msg2 );
11             use Net::SSH::Perl 1.24;
12              
13             use Carp qw( carp croak );
14              
15             use vars qw( $VERSION );
16             $VERSION = '0.10';
17              
18             use constant COPY_SIZE => 8192;
19              
20             sub new {
21             my $class = shift;
22             my $sftp = bless { }, $class;
23             $sftp->{host} = shift;
24             $sftp->init(@_);
25             }
26              
27             # call the warning handler with the object and message
28             sub warn {
29             my ($sftp,$msg,$status) = @_;
30             $msg .= ': '.fx2txt($status) if defined $status;
31             $sftp->{status} = $status || SSH2_FX_OK;
32             $sftp->{warn_h}->($sftp,$msg);
33             }
34              
35             # returns last SSH error, or SSH2_FX_OK (only useful after failure)
36             sub status {
37             my $sftp = shift;
38             my $status = $sftp->{status};
39             wantarray ? ($status,fx2txt($status)) : $status
40             }
41              
42             # returns the new object
43             sub init {
44             my $sftp = shift;
45             my %param = @_;
46             $sftp->{debug} = delete $param{debug};
47             $sftp->{status} = SSH2_FX_OK;
48              
49             $param{ssh_args} ||= [];
50             $param{ssh_args} = [%{$param{ssh_args}}]
51             if UNIVERSAL::isa($param{ssh_args},'HASH');
52              
53             $param{warn} = 1 if not defined $param{warn}; # default
54             $sftp->{warn_h} = delete $param{warn} || sub {}; # false => ignore
55             $sftp->{warn_h} = sub { carp $_[1] } # true => emit warning
56             if $sftp->{warn_h} and not ref $sftp->{warn_h};
57              
58             $sftp->{_msg_id} = 0;
59              
60             my $ssh = Net::SSH::Perl->new($sftp->{host}, protocol => 2,
61             debug => $sftp->{debug}, @{ $param{ssh_args} });
62             $ssh->login($param{user}, $param{password}, 'supress_shell');
63             $sftp->{ssh} = $ssh;
64              
65             my $channel = $sftp->_open_channel;
66             $sftp->{channel} = $channel;
67              
68             $sftp->do_init;
69              
70             $sftp;
71             }
72              
73             # returns the new channel object
74             sub _open_channel {
75             my $sftp = shift;
76             my $ssh = $sftp->{ssh};
77              
78             my $channel = $ssh->_session_channel;
79             $channel->open;
80              
81             $channel->register_handler(SSH2_MSG_CHANNEL_OPEN_CONFIRMATION, sub {
82             my($c, $packet) = @_;
83             $c->{ssh}->debug("Sending subsystem: sftp");
84             my $r_packet = $c->request_start("subsystem", 1);
85             $r_packet->put_str("sftp");
86             $r_packet->send;
87             });
88              
89             my $subsystem_reply = sub {
90             my($c, $packet) = @_;
91             my $id = $packet->get_int32;
92             if ($packet->type == SSH2_MSG_CHANNEL_FAILURE) {
93             $c->{ssh}->fatal_disconnect("Request for " .
94             "subsystem 'sftp' failed on channel '$id'");
95             }
96             $c->{ssh}->break_client_loop;
97             };
98              
99             my $cmgr = $ssh->channel_mgr;
100             $cmgr->register_handler(SSH2_MSG_CHANNEL_FAILURE, $subsystem_reply);
101             $cmgr->register_handler(SSH2_MSG_CHANNEL_SUCCESS, $subsystem_reply);
102              
103             $sftp->{incoming} = Net::SFTP::Buffer->new;
104             my $incoming = $sftp->{incoming};
105             $channel->register_handler("_output_buffer", sub {
106             my($c, $buffer) = @_;
107             $incoming->append($buffer->bytes);
108             $c->{ssh}->break_client_loop;
109             });
110              
111             ## Get channel confirmation, etc. Break once we get a response
112             ## to subsystem execution.
113             $ssh->client_loop;
114              
115             $channel;
116             }
117              
118             sub do_init {
119             my $sftp = shift;
120             my $ssh = $sftp->{ssh};
121              
122             $sftp->debug("Sending SSH2_FXP_INIT");
123             my $msg = $sftp->new_msg(SSH2_FXP_INIT);
124             $msg->put_int32(SSH2_FILEXFER_VERSION);
125             $sftp->send_msg($msg);
126              
127             $msg = $sftp->get_msg;
128             my $type = $msg->get_int8;
129             if ($type != SSH2_FXP_VERSION) {
130             croak "Invalid packet back from SSH2_FXP_INIT (type $type)";
131             }
132             my $version = $msg->get_int32;
133             $sftp->debug("Remote version: $version");
134              
135             ## XXX Check for extensions.
136             }
137              
138             sub debug {
139             my $sftp = shift;
140             if ($sftp->{debug}) {
141             $sftp->{ssh}->debug("sftp: @_");
142             }
143             }
144              
145             ## Server -> client methods.
146              
147             # reads SSH2_FXP_STATUS packet and returns Net::SFTP::Attributes object or undef
148             sub get_attrs {
149             my $sftp = shift;
150             my($expected_id) = @_;
151             my $msg = $sftp->get_msg;
152             my $type = $msg->get_int8;
153             my $id = $msg->get_int32;
154             $sftp->debug("Received stat reply T:$type I:$id");
155             croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
156             if ($type == SSH2_FXP_STATUS) {
157             my $status = $msg->get_int32;
158             $sftp->warn("Couldn't stat remote file",$status);
159             return;
160             }
161             elsif ($type != SSH2_FXP_ATTRS) {
162             croak "Expected SSH2_FXP_ATTRS packet, got $type";
163             }
164             $msg->get_attributes;
165             }
166              
167             # reads SSH2_FXP_STATUS packet and returns SFTP status value
168             sub get_status {
169             my $sftp = shift;
170             my($expected_id) = @_;
171             my $msg = $sftp->get_msg;
172             my $type = $msg->get_int8;
173             my $id = $msg->get_int32;
174              
175             croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
176             if ($type != SSH2_FXP_STATUS) {
177             croak "Expected SSH2_FXP_STATUS packet, got $type";
178             }
179              
180             $msg->get_int32;
181             }
182              
183             # reads SSH2_FXP_HANDLE packet and returns handle, or undef on failure
184             sub get_handle {
185             my $sftp = shift;
186             my($expected_id) = @_;
187              
188             my $msg = $sftp->get_msg;
189             my $type = $msg->get_int8;
190             my $id = $msg->get_int32;
191              
192             croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
193             if ($type == SSH2_FXP_STATUS) {
194             my $status = $msg->get_int32;
195             $sftp->warn("Couldn't get handle",$status);
196             return;
197             }
198             elsif ($type != SSH2_FXP_HANDLE) {
199             croak "Expected SSH2_FXP_HANDLE packet, got $type";
200             }
201              
202             $msg->get_str;
203             }
204              
205             ## Client -> server methods.
206              
207             sub _send_str_request {
208             my $sftp = shift;
209             my($code, $str) = @_;
210             my($msg, $id) = $sftp->new_msg_w_id($code);
211             $msg->put_str($str);
212             $sftp->send_msg($msg);
213             $sftp->debug("Sent message T:$code I:$id");
214             $id;
215             }
216              
217             sub _send_str_attrs_request {
218             my $sftp = shift;
219             my($code, $str, $a) = @_;
220             my($msg, $id) = $sftp->new_msg_w_id($code);
221             $msg->put_str($str);
222             $msg->put_attributes($a);
223             $sftp->send_msg($msg);
224             $sftp->debug("Sent message T:$code I:$id");
225             $id;
226             }
227              
228             sub _check_ok_status {
229             my $status = $_[0]->get_status($_[1]);
230             $_[0]->warn("Couldn't $_[2]",$status) unless $status == SSH2_FX_OK;
231             $status;
232             }
233              
234             ## SSH2_FXP_OPEN (3)
235             # returns handle on success, undef on failure
236             sub do_open {
237             my $sftp = shift;
238             my($path, $flags, $a) = @_;
239             $a ||= Net::SFTP::Attributes->new;
240             my($msg, $id) = $sftp->new_msg_w_id(SSH2_FXP_OPEN);
241             $msg->put_str($path);
242             $msg->put_int32($flags);
243             $msg->put_attributes($a);
244             $sftp->send_msg($msg);
245             $sftp->debug("Sent SSH2_FXP_OPEN I:$id P:$path");
246             $sftp->get_handle($id);
247             }
248              
249             ## SSH2_FXP_READ (4)
250             # returns data on success, (undef,$status) on failure
251             sub do_read {
252             my $sftp = shift;
253             my($handle, $offset, $size) = @_;
254             $size ||= COPY_SIZE;
255             my($msg, $expected_id) = $sftp->new_msg_w_id(SSH2_FXP_READ);
256             $msg->put_str($handle);
257             $msg->put_int64(int $offset);
258             $msg->put_int32($size);
259             $sftp->send_msg($msg);
260             $sftp->debug("Sent message SSH2_FXP_READ I:$expected_id O:$offset");
261             $msg = $sftp->get_msg;
262             my $type = $msg->get_int8;
263             my $id = $msg->get_int32;
264             $sftp->debug("Received reply T:$type I:$id");
265             croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
266             if ($type == SSH2_FXP_STATUS) {
267             my $status = $msg->get_int32;
268             if ($status != SSH2_FX_EOF) {
269             $sftp->warn("Couldn't read from remote file",$status);
270             $sftp->do_close($handle);
271             }
272             return(undef, $status);
273             }
274             elsif ($type != SSH2_FXP_DATA) {
275             croak "Expected SSH2_FXP_DATA packet, got $type";
276             }
277             $msg->get_str;
278             }
279              
280             ## SSH2_FXP_WRITE (6)
281             # returns status (SSH2_FX_OK on success)
282             sub do_write {
283             my $sftp = shift;
284             my($handle, $offset, $data) = @_;
285             my($msg, $id) = $sftp->new_msg_w_id(SSH2_FXP_WRITE);
286             $msg->put_str($handle);
287             $msg->put_int64(int $offset);
288             $msg->put_str($data);
289             $sftp->send_msg($msg);
290             $sftp->debug("Sent message SSH2_FXP_WRITE I:$id O:$offset");
291             my $status = $sftp->_check_ok_status($id,'write to remote file');
292             $sftp->do_close($handle) unless $status == SSH2_FX_OK;
293             return $status;
294             }
295              
296             ## SSH2_FXP_LSTAT (7), SSH2_FXP_FSTAT (8), SSH2_FXP_STAT (17)
297             # these all return a Net::SFTP::Attributes object on success, undef on failure
298             sub do_lstat { $_[0]->_do_stat(SSH2_FXP_LSTAT, $_[1]) }
299             sub do_fstat { $_[0]->_do_stat(SSH2_FXP_FSTAT, $_[1]) }
300             sub do_stat { $_[0]->_do_stat(SSH2_FXP_STAT , $_[1]) }
301             sub _do_stat {
302             my $sftp = shift;
303             my $id = $sftp->_send_str_request(@_);
304             $sftp->get_attrs($id);
305             }
306              
307             ## SSH2_FXP_OPENDIR (11)
308             sub do_opendir {
309             my $sftp = shift;
310             my $id = $sftp->_send_str_request(SSH2_FXP_OPENDIR, @_);
311             $sftp->get_handle($id);
312             }
313              
314             ## SSH2_FXP_CLOSE (4), SSH2_FXP_REMOVE (13),
315             ## SSH2_FXP_MKDIR (14), SSH2_FXP_RMDIR (15),
316             ## SSH2_FXP_SETSTAT (9), SSH2_FXP_FSETSTAT (10)
317             # all of these return a status (SSH2_FX_OK on success)
318             {
319             no strict 'refs';
320             *do_close = _gen_simple_method(SSH2_FXP_CLOSE, 'close file');
321             *do_remove = _gen_simple_method(SSH2_FXP_REMOVE, 'delete file');
322             *do_mkdir = _gen_simple_method(SSH2_FXP_MKDIR, 'create directory');
323             *do_rmdir = _gen_simple_method(SSH2_FXP_RMDIR, 'remove directory');
324             *do_setstat = _gen_simple_method(SSH2_FXP_SETSTAT , 'setstat');
325             *do_fsetstat = _gen_simple_method(SSH2_FXP_FSETSTAT , 'fsetstat');
326             }
327              
328             sub _gen_simple_method {
329             my($code, $msg) = @_;
330             sub {
331             my $sftp = shift;
332             my $id = @_ > 1 ?
333             $sftp->_send_str_attrs_request($code, @_) :
334             $sftp->_send_str_request($code, @_);
335             $sftp->_check_ok_status($id, $msg);
336             };
337             }
338              
339             ## SSH2_FXP_REALPATH (16)
340             sub do_realpath {
341             my $sftp = shift;
342             my($path) = @_;
343             my $expected_id = $sftp->_send_str_request(SSH2_FXP_REALPATH, $path);
344             my $msg = $sftp->get_msg;
345             my $type = $msg->get_int8;
346             my $id = $msg->get_int32;
347             croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
348             if ($type == SSH2_FXP_STATUS) {
349             my $status = $msg->get_int32;
350             $sftp->warn("Couldn't canonicalise $path",$status);
351             return;
352             }
353             elsif ($type != SSH2_FXP_NAME) {
354             croak "Expected SSH2_FXP_NAME packet, got $type";
355             }
356             my $count = $msg->get_int32;
357             croak "Got multiple names ($count) from SSH2_FXP_REALPATH"
358             unless $count == 1;
359             $msg->get_str; ## Filename.
360             }
361              
362             ## SSH2_FXP_RENAME (18)
363             sub do_rename {
364             my $sftp = shift;
365             my($old, $new) = @_;
366             my($msg, $id) = $sftp->new_msg_w_id(SSH2_FXP_RENAME);
367             $msg->put_str($old);
368             $msg->put_str($new);
369             $sftp->send_msg($msg);
370             $sftp->debug("Sent message SSH2_FXP_RENAME '$old' => '$new'");
371             $sftp->_check_ok_status($id, "rename '$old' to '$new'");
372             }
373              
374             ## High-level client -> server methods.
375              
376             # always returns undef on failure
377             # if local filename is provided, returns '' on success, else file contents
378             sub get {
379             my $sftp = shift;
380             my($remote, $local, $cb) = @_;
381             my $ssh = $sftp->{ssh};
382             my $want = defined wantarray ? 1 : 0;
383              
384             my $a = $sftp->do_stat($remote) or return;
385             my $handle = $sftp->do_open($remote, SSH2_FXF_READ);
386             return unless defined $handle;
387              
388             local *FH;
389             if ($local) {
390             open FH, ">$local" or
391             $sftp->do_close($handle), croak "Can't open $local: $!";
392             binmode FH or
393             $sftp->do_close($handle), croak "Can't binmode FH: $!";
394             }
395              
396             my $offset = 0;
397             my $ret = '';
398             while (1) {
399             my($data, $status) = $sftp->do_read($handle, $offset, COPY_SIZE);
400             last if defined $status && $status == SSH2_FX_EOF;
401             return unless $data;
402             my $len = length($data);
403             croak "Received more data than asked for $len > " . COPY_SIZE
404             if $len > COPY_SIZE;
405             $sftp->debug("In read loop, got $len offset $offset");
406             $cb->($sftp, $data, $offset, $a->size) if defined $cb;
407             if ($local) {
408             print FH $data;
409             }
410             elsif ($want) {
411             $ret .= $data;
412             }
413             $offset += $len;
414             }
415             $sftp->do_close($handle);
416              
417             if ($local) {
418             close FH;
419             my $flags = $a->flags;
420             my $mode = $flags & SSH2_FILEXFER_ATTR_PERMISSIONS ?
421             $a->perm & 0777 : 0666;
422             chmod $mode, $local or croak "Can't chmod $local: $!";
423              
424             if ($flags & SSH2_FILEXFER_ATTR_ACMODTIME) {
425             utime $a->atime, $a->mtime, $local or
426             croak "Can't utime $local: $!";
427             }
428             }
429             $ret;
430             }
431              
432             sub put {
433             my $sftp = shift;
434             my($local, $remote, $cb) = @_;
435             my $ssh = $sftp->{ssh};
436              
437             my @stat = stat $local or croak "Can't stat local $local: $!";
438             my $size = $stat[7];
439             my $a = Net::SFTP::Attributes->new(Stat => \@stat);
440             my $flags = $a->flags;
441             $flags &= ~SSH2_FILEXFER_ATTR_SIZE;
442             $flags &= ~SSH2_FILEXFER_ATTR_UIDGID;
443             $a->flags($flags);
444             $a->perm( $a->perm & 0777 );
445              
446             local *FH;
447             open FH, $local or croak "Can't open local file $local: $!";
448             binmode FH or croak "Can't binmode FH: $!";
449              
450             my $handle = $sftp->do_open($remote, SSH2_FXF_WRITE | SSH2_FXF_CREAT |
451             SSH2_FXF_TRUNC, $a); # check status for info
452             return unless defined $handle;
453              
454             my $offset = 0;
455             while (1) {
456             my($len, $data, $msg, $id);
457             $len = read FH, $data, COPY_SIZE;
458             last unless $len;
459             $cb->($sftp, $data, $offset, $size) if defined $cb;
460             my $status = $sftp->do_write($handle, $offset, $data);
461             if ($status != SSH2_FX_OK) {
462             close FH;
463             return;
464             }
465             $sftp->debug("In write loop, got $len offset $offset");
466             $offset += $len;
467             }
468              
469             close FH or $sftp->warn("Can't close local file $local: $!");
470              
471             # ignore failures here, the transmission is the important part
472             $sftp->do_fsetstat($handle, $a);
473             $sftp->do_close($handle);
474             return 1;
475             }
476              
477             # returns ()/undef on error, directory list/reference to same otherwise
478             sub ls {
479             my $sftp = shift;
480             my($remote, $code) = @_;
481             my @dir;
482             my $handle = $sftp->do_opendir($remote);
483             return unless defined $handle;
484              
485             while (1) {
486             my $expected_id = $sftp->_send_str_request(SSH2_FXP_READDIR, $handle);
487             my $msg = $sftp->get_msg;
488             my $type = $msg->get_int8;
489             my $id = $msg->get_int32;
490             $sftp->debug("Received reply T:$type I:$id");
491              
492             croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
493             if ($type == SSH2_FXP_STATUS) {
494             my $status = $msg->get_int32;
495             $sftp->debug("Received SSH2_FXP_STATUS $status");
496             if ($status == SSH2_FX_EOF) {
497             last;
498             }
499             else {
500             $sftp->warn("Couldn't read directory",$status);
501             $sftp->do_close($handle);
502             return;
503             }
504             }
505             elsif ($type != SSH2_FXP_NAME) {
506             croak "Expected SSH2_FXP_NAME packet, got $type";
507             }
508              
509             my $count = $msg->get_int32;
510             last unless $count;
511             $sftp->debug("Received $count SSH2_FXP_NAME responses");
512             for my $i (0..$count-1) {
513             my $fname = $msg->get_str;
514             my $lname = $msg->get_str;
515             my $a = $msg->get_attributes;
516             my $rec = {
517             filename => $fname,
518             longname => $lname,
519             a => $a,
520             };
521             if ($code && ref($code) eq "CODE") {
522             $code->($rec);
523             }
524             else {
525             push @dir, $rec;
526             }
527             }
528             }
529             $sftp->do_close($handle);
530             wantarray ? @dir : \@dir;
531             }
532              
533             ## Messaging methods--messages are essentially sub-packets.
534              
535             sub msg_id { $_[0]->{_msg_id}++ }
536              
537             sub new_msg {
538             my $sftp = shift;
539             my($code) = @_;
540             my $msg = Net::SFTP::Buffer->new;
541             $msg->put_int8($code);
542             $msg;
543             }
544              
545             sub new_msg_w_id {
546             my $sftp = shift;
547             my($code, $sid) = @_;
548             my $msg = $sftp->new_msg($code);
549             my $id = defined $sid ? $sid : $sftp->msg_id;
550             $msg->put_int32($id);
551             ($msg, $id);
552             }
553              
554             sub send_msg {
555             my $sftp = shift;
556             my($buf) = @_;
557             my $b = Net::SFTP::Buffer->new;
558             $b->put_int32($buf->length);
559             $b->append($buf->bytes);
560             $sftp->{channel}->send_data($b->bytes);
561             }
562              
563             sub get_msg {
564             my $sftp = shift;
565             my $buf = $sftp->{incoming};
566             my $len;
567             unless ($buf->length > 4) {
568             $sftp->{ssh}->client_loop;
569             croak "Connection closed" unless $buf->length > 4;
570             $len = unpack "N", $buf->bytes(0, 4, '');
571             croak "Received message too long $len" if $len > 256 * 1024;
572             while ($buf->length < $len) {
573             $sftp->{ssh}->client_loop;
574             }
575             }
576             my $b = Net::SFTP::Buffer->new;
577             $b->append( $buf->bytes(0, $len, '') );
578             $b;
579             }
580              
581             1;
582             __END__