File Coverage

blib/lib/Net/SFTP/Foreign/Compat.pm
Criterion Covered Total %
statement 32 110 29.0
branch 2 44 4.5
condition 0 14 0.0
subroutine 8 27 29.6
pod 5 9 55.5
total 47 204 23.0


line stmt bran cond sub pod time code
1             package Net::SFTP::Foreign::Compat;
2              
3             our $VERSION = '1.70_05';
4              
5 1     1   57502 use warnings;
  1         7  
  1         28  
6 1     1   4 use strict;
  1         1  
  1         16  
7 1     1   3 use Carp;
  1         2  
  1         342  
8              
9             require Net::SFTP::Foreign;
10             require Net::SFTP::Foreign::Constants;
11             require Net::SFTP::Foreign::Attributes::Compat;
12              
13             our @ISA = qw(Net::SFTP::Foreign);
14              
15             my $supplant;
16              
17             sub import {
18 2     2   606 for my $arg (@_[1..$#_]) {
19 1 50       3 if ($arg eq ':supplant') {
20             # print STDERR "suplanting Net::SFTP...\n";
21 1 50       4 if (!$supplant) {
22 1         1 $supplant = 1;
23              
24 1         13 @Net::SFTP::ISA = qw(Net::SFTP::Foreign::Compat);
25 1         14 @Net::SFTP::Attributes::ISA = qw(Net::SFTP::Foreign::Attributes::Compat);
26 1         13 @Net::SFTP::Constant::ISA = qw(Net::SFTP::Foreign::Constants);
27              
28 1         6 $INC{q(Net/SFTP.pm)} = $INC{q(Net/SFTP/Foreign/Compat.pm)};
29 1         2 $INC{q(Net/SFTP/Attributes.pm)} = $INC{q(Net/SFTP/Foreign/Compat.pm)};
30 1         15 $INC{q(Net/SFTP/Constants.pm)} = $INC{q(Net/SFTP/Foreign/Compat.pm)};
31              
32             }
33             }
34             else {
35 0         0 croak "invalid import tag '$arg'"
36             }
37             }
38             }
39              
40             our %DEFAULTS = ( put => [best_effort => 1],
41             get => [best_effort => 1],
42             ls => [],
43             new => [] );
44              
45             BEGIN {
46 1     1   13 my @forbidden = qw( setcwd cwd open opendir sftpread sftpwrite
47             seek tell eof write flush read getc lstat stat
48             fstat remove rmdir mkdir setstat fsetstat
49             close closedir readdir realpath readlink
50             rename symlink abort get_content join glob
51             rremove rget rput error die_on_error );
52              
53 1         3 for my $method (@forbidden) {
54 37         61 my $super = "SUPER::$method";
55 1     1   7 no strict 'refs';
  1         1  
  1         88  
56 37         1117 *{$method} = sub {
57 0 0   0   0 unless (index((caller)[0], "Net::SFTP::Foreign") == 0) {
58 0         0 croak "Method '$method' is not available from " . __PACKAGE__
59             . ", use the real Net::SFTP::Foreign if you want it!";
60             }
61 0         0 shift->$super(@_);
62 37         119 };
63             }
64             }
65              
66             sub new {
67 0     0 1 0 my ($class, $host, %opts) = @_;
68              
69 0         0 my $warn;
70 0 0       0 if (exists $opts{warn}) {
71 0   0 0   0 $warn = delete($opts{warn}) || sub {};
72             }
73             else {
74 0     0   0 $warn = sub { warn(CORE::join '', @_, "\n") };
  0         0  
75             }
76              
77 0         0 my $sftp = $class->SUPER::new($host, @{$DEFAULTS{new}}, %opts);
  0         0  
78              
79 0         0 $sftp->{_compat_warn} = $warn;
80              
81 0         0 return $sftp;
82              
83             }
84              
85             sub _warn {
86 0     0   0 my $sftp = shift;
87 0 0       0 if (my $w = $sftp->{_compat_warn}) {
88 0         0 $w->(@_);
89             }
90             }
91              
92             sub _warn_error {
93 0     0   0 my $sftp = shift;
94 0 0       0 if (my $e = $sftp->SUPER::error) {
95 0         0 $sftp->_warn($e);
96             }
97             }
98              
99             sub status {
100 0     0 1 0 my $status = shift->SUPER::status;
101 0 0       0 return wantarray ? ($status + 0, "$status") : $status + 0;
102             }
103              
104             sub get {
105 0 0 0 0 1 0 croak '$Usage: $sftp->get($local, $remote, $cb)' if @_ < 2 or @_ > 4;
106 0         0 my ($sftp, $remote, $local, $cb) = @_;
107              
108 0         0 my $save = defined(wantarray);
109 0         0 my @content;
110             my @cb;
111 0 0 0     0 if (defined $cb or $save) {
112             @cb = ( callback => sub {
113 0     0   0 my ($sftp, $data, $off, $size) = @_;
114 0 0       0 $cb->($sftp, $data, $off, $size) if $cb;
115 0 0       0 push @content, $data if $save
116 0         0 });
117             }
118              
119             $sftp->SUPER::get($remote, $local,
120 0 0       0 @{$DEFAULTS{get}},
  0         0  
121             dont_save => !defined($local),
122             @cb)
123             or return undef;
124              
125 0 0       0 if ($save) {
126 0         0 return CORE::join('', @content);
127             }
128             }
129              
130             sub put {
131 0 0 0 0 1 0 croak '$Usage: $sftp->put($local, $remote, $cb)' if @_ < 3 or @_ > 4;
132 0         0 my ($sftp, $local, $remote, $cb) = @_;
133              
134             $sftp->SUPER::put($local, $remote,
135 0         0 @{$DEFAULTS{put}},
  0         0  
136             callback => $cb);
137 0         0 $sftp->_warn_error;
138 0         0 !$sftp->SUPER::error;
139             }
140              
141             sub ls {
142 0 0 0 0 1 0 croak '$Usage: $sftp->ls($path, $cb)' if @_ < 2 or @_ > 3;
143 0         0 my ($sftp, $path, $cb) = @_;
144 0 0       0 if ($cb) {
145             $sftp->SUPER::ls($path,
146 0         0 @{$DEFAULTS{ls}},
147 0     0   0 wanted => sub { _rebless_attrs($_[1]->{a});
148 0         0 $cb->($_[1]);
149 0         0 0 } );
  0         0  
150 0         0 return ();
151             }
152             else {
153 0 0       0 if (my $ls = $sftp->SUPER::ls($path, @{$DEFAULTS{ls}})) {
  0         0  
154 0         0 _rebless_attrs($_->{a}) for @$ls;
155 0         0 return @$ls;
156             }
157             return ()
158 0         0 }
159             }
160              
161 0     0 0 0 sub do_open { shift->SUPER::open(@_) }
162              
163 0     0 0 0 sub do_opendir { shift->SUPER::opendir(@_) }
164              
165 0     0 0 0 sub do_realpath { shift->SUPER::realpath(@_) }
166              
167             sub do_read {
168 0     0 0 0 my $sftp = shift;
169 0         0 my $read = $sftp->SUPER::sftpread(@_);
170 0         0 $sftp->_warn_error;
171 0 0       0 if (wantarray) {
172 0         0 return ($read, $sftp->status);
173             }
174             else {
175 0         0 return $read
176             }
177             }
178              
179             sub _gen_do_and_status {
180 8     8   17 my $method = "SUPER::" . shift;
181             return sub {
182 0     0   0 my $sftp = shift;
183 0         0 $sftp->$method(@_);
184 0         0 $sftp->_warn_error;
185 0         0 $sftp->status;
186             }
187 8         28 }
188              
189             *do_write = _gen_do_and_status('sftpwrite');
190             *do_close = _gen_do_and_status('close');
191             *do_setstat = _gen_do_and_status('setstat');
192             *do_fsetstat = _gen_do_and_status('setstat');
193             *do_remove = _gen_do_and_status('remove');
194             *do_rename = _gen_do_and_status('rename');
195             *do_mkdir = _gen_do_and_status('mkdir');
196             *do_rmdir = _gen_do_and_status('rmdir');
197              
198             sub _rebless_attrs {
199 0     0   0 my $a = shift;
200 0 0       0 if ($a) {
201 0 0       0 bless $a, ( $supplant
202             ? "Net::SFTP::Attributes"
203             : "Net::SFTP::Foreign::Attributes::Compat" );
204             }
205 0         0 $a;
206             }
207              
208             sub _gen_do_stat {
209 3     3   5 my $name = shift;
210 3         5 my $method = "SUPER::$name";
211             return sub {
212 0 0   0     croak '$Usage: $sftp->'.$name.'($local, $remote, $cb)' if @_ != 2;
213 0           my $sftp = shift;
214 0 0         if (my $a = $sftp->$method(@_)) {
215 0           return _rebless_attrs($a);
216             }
217             else {
218 0           $sftp->_warn_error;
219 0           return undef;
220             }
221             }
222 3         7 }
223              
224             *do_lstat = _gen_do_stat('lstat');
225             *do_fstat = _gen_do_stat('fstat');
226             *do_stat = _gen_do_stat('stat');
227              
228              
229             1;
230              
231             __END__