File Coverage

blib/lib/AnyEvent/FTP/Server/Context/FSRW.pm
Criterion Covered Total %
statement 178 230 77.3
branch 32 62 51.6
condition 6 15 40.0
subroutine 36 36 100.0
pod 0 12 0.0
total 252 355 70.9


line stmt bran cond sub pod time code
1             package AnyEvent::FTP::Server::Context::FSRW;
2              
3 12     12   536513 use strict;
  12         32  
  12         305  
4 12     12   51 use warnings;
  12         20  
  12         223  
5 12     12   186 use 5.010;
  12         36  
6 12     12   1259 use Moo;
  12         26727  
  12         69  
7 12     12   17261 use File::chdir;
  12         28700  
  12         1170  
8 12     12   4380 use File::ShareDir::Dist qw( dist_share );
  12         8821  
  12         45  
9 12     12   4576 use File::Which qw( which );
  12         8977  
  12         562  
10 12     12   2219 use File::Temp qw( tempfile );
  12         57310  
  12         660  
11 12     12   4609 use Capture::Tiny qw( capture );
  12         37656  
  12         1588  
12              
13             extends 'AnyEvent::FTP::Server::Context::FS';
14              
15             # ABSTRACT: FTP Server client context class with full read/write access
16             our $VERSION = '0.19'; # VERSION
17              
18              
19             with 'AnyEvent::FTP::Server::Role::TransferPrep';
20              
21              
22             sub _layer
23             {
24 46 100   46   417 $_[0]->type eq 'A' ? $_[0]->ascii_layer : ':raw';
25             }
26              
27 2     2 0 7 sub help_retr { 'RETR pathname' }
28              
29             sub cmd_retr
30             {
31 21     21 0 52 my($self, $con, $req) = @_;
32              
33 21         52 my $fn = $req->args;
34              
35 21 50       76 unless(defined $self->data)
36             {
37 0         0 $con->send_response(425 => 'Unable to build data connection');
38 0         0 return;
39             }
40              
41 21         44 eval {
42 12     12   4018 use autodie;
  12         103181  
  12         60  
43 21         122 local $CWD = $self->cwd;
44              
45 21 50 0     1201 if(-f $fn)
    0          
46             {
47             # TODO: re-write so that this does not blocks
48 21 100       143 my $type = $self->type eq 'A' ? 'ASCII' : 'Binary';
49 21         175 my $size = -s $fn;
50 21         218 $con->send_response(150 => "Opening $type mode data connection for $fn ($size bytes)");
51 21         149 open my $fh, '<', $fn;
52 21         5758 binmode $fh, $self->_layer;
53 21 100       2448 seek $fh, $self->restart_offset, 0 if $self->restart_offset;
54 21         869 $self->data->push_write(do { local $/; <$fh> });
  21         70  
  21         928  
55 21         913 close $fh;
56 21         2625 $self->data->push_shutdown;
57 21         562 $con->send_response(226 => 'Transfer complete');
58             }
59             elsif(-e $fn && !-d $fn)
60             {
61 0         0 $con->send_response(550 => 'Permission denied');
62             }
63             else
64             {
65 0         0 $con->send_response(550 => 'No such file');
66             }
67             };
68 21 50       524 if(my $error = $@)
69             {
70 0         0 warn $error;
71 0 0       0 if(eval { $error->can('errno') })
  0         0  
72 0         0 { $con->send_response(550 => $error->errno) }
73             else
74 0         0 { $con->send_response(550 => 'Internal error') }
75             };
76 21         90 $self->clear_data;
77 21         66 $self->done;
78             }
79              
80              
81 2     2 0 8 sub help_nlst { 'NLST [ (pathname)]' }
82              
83             sub cmd_nlst
84             {
85 11     11 0 45 my($self, $con, $req) = @_;
86              
87 11   100     36 my $dir = $req->args || '.';
88              
89 11 50       40 unless(defined $self->data)
90             {
91 0         0 $con->send_response(425 => 'Unable to build data connection');
92 0         0 return;
93             }
94              
95 11         21 eval {
96 12     12   73140 use autodie;
  12         26  
  12         51  
97 11         40 local $CWD = $self->cwd;
98              
99 11         478 $con->send_response(150 => "Opening ASCII mode data connection for file list");
100 11         17 my $dh;
101 11         59 opendir $dh, $dir;
102             my @list =
103 11 100       2683 map { $req->args ? join('/', $dir, $_) : $_ }
  21         60  
104             sort
105             grep !/^\.\.?$/,
106             readdir $dh;
107 11         54 closedir $dh;
108 11         1349 $self->data->push_write(join '', map { $_ . "\015\012" } @list);
  21         77  
109 11         417 $self->data->push_shutdown;
110 11         282 $con->send_response(226 => 'Transfer complete');
111             };
112 11 50       252 if(my $error = $@)
113             {
114 0         0 warn $error;
115 0 0       0 if(eval { $error->can('errno') })
  0         0  
116 0         0 { $con->send_response(550 => $error->errno) }
117             else
118 0         0 { $con->send_response(550 => 'Internal error') }
119             };
120 11         50 $self->clear_data;
121 11         40 $self->done;
122             }
123              
124              
125 2     2 0 8 sub help_list { 'LIST [ pathname]' }
126              
127             sub cmd_list
128             {
129 8     8 0 46 my($self, $con, $req) = @_;
130              
131 8   100     38 my $dir = $req->args || '.';
132 8 50       54 $dir = '.' if $dir eq '-l';
133              
134 8 50       35 unless(defined $self->data)
135             {
136 0         0 $con->send_response(425 => 'Unable to build data connection');
137 0         0 return;
138             }
139              
140 8         12 eval {
141 12     12   58481 use autodie;
  12         25  
  12         53  
142              
143 8         89 my @cmd = _shared_cmd('ls', '-l', $dir);
144              
145 8         48 local $CWD = $self->cwd;
146              
147 8         390 $con->send_response(150 => "Opening ASCII mode data connection for file list");
148 8         11 my $dh;
149 8         46 opendir $dh, $dir;
150              
151 8     8   1238 $self->data->push_write(join "\015\012", split /\n/, scalar capture { system @cmd });
  8         58766  
152 8         9597 closedir $dh;
153 8         1823 $self->data->push_write("\015\012");
154 8         483 $self->data->push_shutdown;
155 8         425 $con->send_response(226 => 'Transfer complete');
156             };
157 8 50       491 if(my $error = $@)
158             {
159 0         0 warn $error;
160 0 0       0 if(eval { $error->can('errno') })
  0         0  
161 0         0 { $con->send_response(550 => $error->errno) }
162             else
163 0         0 { $con->send_response(550 => 'Internal error') }
164             };
165 8         132 $self->clear_data;
166 8         126 $self->done;
167             }
168              
169              
170 2     2 0 7 sub help_stor { 'STOR pathname' }
171              
172             sub cmd_stor
173             {
174 15     15 0 48 my($self, $con, $req) = @_;
175              
176 15         50 my $fn = $req->args;
177              
178 15 50       58 unless(defined $self->data)
179             {
180 0         0 $con->send_response(425 => 'Unable to build data connection');
181 0         0 return;
182             }
183              
184 15         25 eval {
185 12     12   57857 use autodie;
  12         27  
  12         56  
186 15         47 local $CWD = $self->cwd;
187              
188 15 100       703 my $type = $self->type eq 'A' ? 'ASCII' : 'Binary';
189 15         121 $con->send_response(150 => "Opening $type mode data connection for $fn");
190              
191 15         82 open my $fh, '>', $fn;
192 15         5060 binmode $fh, $self->_layer;
193             $self->data->on_read(sub {
194             $self->data->push_read(sub {
195 30         1168 print $fh $_[0]{rbuf};
196 30         91 $_[0]{rbuf} = '';
197 15     15   1399 });
198 15         3266 });
199             $self->data->on_error(sub {
200 15     15   283 close $fh;
201 15         2846 $self->data->push_shutdown;
202 15         714 $con->send_response(226 => 'Transfer complete');
203 15         68 $self->clear_data;
204 15         41 $self->done;
205 15         673 });
206             };
207 15 50       468 if(my $error = $@)
208             {
209 0         0 warn $error;
210 0 0       0 if(eval { $error->can('errno') })
  0         0  
211 0         0 { $con->send_response(550 => $error->errno) }
212             else
213 0         0 { $con->send_response(550 => 'Internal error') }
214 0         0 $self->clear_data;
215 0         0 $self->done;
216             };
217             }
218              
219              
220 2     2 0 7 sub help_appe { 'APPE pathname' }
221              
222             sub cmd_appe
223             {
224 7     7 0 42 my($self, $con, $req) = @_;
225              
226 7         39 my $fn = $req->args;
227              
228 7 50       49 unless(defined $self->data)
229             {
230 0         0 $con->send_response(425 => 'Unable to build data connection');
231 0         0 return;
232             }
233              
234 7         19 eval {
235 12     12   61606 use autodie;
  12         25  
  12         61  
236 7         42 local $CWD = $self->cwd;
237              
238 7 100       597 my $type = $self->type eq 'A' ? 'ASCII' : 'Binary';
239 7         70 $con->send_response(150 => "Opening $type mode data connection for $fn");
240              
241 7         59 open my $fh, '>>', $fn;
242 7         4027 binmode $fh, $self->_layer;
243             $self->data->on_read(sub {
244             $self->data->push_read(sub {
245 16         768 print $fh $_[0]{rbuf};
246 16         51 $_[0]{rbuf} = '';
247 7     7   748 });
248 7         1864 });
249             $self->data->on_error(sub {
250 7     7   191 close $fh;
251 7         2216 $self->data->push_shutdown;
252 7         459 $con->send_response(226 => 'Transfer complete');
253 7         45 $self->clear_data;
254 7         35 $self->done;
255 7         380 });
256             };
257 7 50       295 if(my $error = $@)
258             {
259 0         0 warn $error;
260 0 0       0 if(eval { $error->can('errno') })
  0         0  
261 0         0 { $con->send_response(550 => $error->errno) }
262             else
263 0         0 { $con->send_response(550 => 'Internal error') }
264 0         0 $self->clear_data;
265 0         0 $self->done;
266             };
267             }
268              
269              
270 2     2 0 15 sub help_stou { 'STOU (store unique filename)' }
271              
272             sub cmd_stou
273             {
274 3     3 0 18 my($self, $con, $req) = @_;
275              
276 3         18 my $fn = $req->args;
277              
278 3 50       19 unless(defined $self->data)
279             {
280 0         0 $con->send_response(425 => 'Unable to build data connection');
281 0         0 return;
282             }
283              
284 3         11 eval {
285 12     12   71249 use autodie;
  12         26  
  12         63  
286 3         16 local $CWD = $self->cwd;
287              
288 3         129 my $fh;
289              
290 3 50 33     15 if($fn && ! -e $fn)
291             {
292 0         0 open $fh, '>', $fn;
293             }
294             else
295             {
296 3         25 ($fh,$fn) = tempfile( "aefXXXXXX", TMPDIR => 0 )
297             }
298              
299 3 100       1049 my $type = $self->type eq 'A' ? 'ASCII' : 'Binary';
300 3         26 $con->send_response(150 => "FILE: $fn");
301              
302 3         17 binmode $fh, $self->_layer;
303             $self->data->on_read(sub {
304             $self->data->push_read(sub {
305 6         245 print $fh $_[0]{rbuf};
306 6         30 $_[0]{rbuf} = '';
307 3     3   337 });
308 3         2141 });
309             $self->data->on_error(sub {
310 3     3   73 close $fh;
311 3         1836 $self->data->push_shutdown;
312 3         189 $con->send_response(226 => 'Transfer complete');
313 3         17 $self->clear_data;
314 3         13 $self->done;
315 3         163 });
316             };
317 3 50       118 if(my $error = $@)
318             {
319 0         0 warn $error;
320 0 0       0 if(eval { $error->can('errno') })
  0         0  
321 0         0 { $con->send_response(550 => $error->errno) }
322             else
323 0         0 { $con->send_response(550 => 'Internal error') }
324 0         0 $self->clear_data;
325 0         0 $self->done;
326             };
327             }
328              
329             {
330             state $always_use_bundled_cmd = $ENV{ANYEVENT_FTP_BUNDLED_CMD};
331             my %shared;
332             sub _shared_cmd
333             {
334 9     9   129230 my ($cmd, @args) = @_;
335              
336 9 100       42 unless (defined $shared{$cmd}) {
337 2         10 my $which = which $cmd;
338 2 50 33     405 if ($which && !$always_use_bundled_cmd) {
339 2         9 $shared{$cmd} = [ $which ];
340             }
341             else {
342 0   0     0 $shared{$cmd} = [
343             $^X, # use the same Perl
344             File::Spec->catfile((dist_share('AnyEvent-FTP') or die "unable to find share directory") , 'ppt', "$cmd.pl"),
345             ];
346             }
347             }
348              
349 9         14 return @{ $shared{$cmd} }, @args;
  9         40  
350             }
351             }
352              
353             1;
354              
355             __END__