File Coverage

blib/lib/Net/FSP.pm
Criterion Covered Total %
statement 33 283 11.6
branch 0 136 0.0
condition 0 28 0.0
subroutine 11 59 18.6
pod 20 20 100.0
total 64 526 12.1


line stmt bran cond sub pod time code
1             package Net::FSP;
2 1     1   22393 use 5.006;
  1         4  
  1         40  
3 1     1   5 use strict;
  1         2  
  1         30  
4 1     1   4 use warnings;
  1         5  
  1         55  
5             our $VERSION = 0.16;
6              
7 1     1   5 use Carp qw/croak/;
  1         1  
  1         66  
8 1     1   847 use Socket qw/PF_INET SOCK_DGRAM sockaddr_in inet_aton INADDR_ANY/;
  1         3838  
  1         303  
9 1     1   797 use Errno qw/EAGAIN ENOBUFS EHOSTUNREACH ECONNREFUSED EHOSTDOWN ENETDOWN EPIPE EINTR/;
  1         1305  
  1         132  
10 1     1   6 use Fcntl qw/F_GETFL F_SETFL O_NONBLOCK/;
  1         1  
  1         44  
11 1     1   748 use Symbol qw/gensym/;
  1         807  
  1         60  
12              
13 1     1   490 use Net::FSP::File;
  1         4  
  1         27  
14 1     1   468 use Net::FSP::Dir;
  1         2  
  1         24  
15 1     1   471 use Net::FSP::Handle;
  1         3  
  1         4568  
16              
17             my $HEADER_SIZE = 12;
18             my $LISTING_HEADER_SIZE = 9;
19             my $LISTING_ALIGNMENT = 4;
20             my $SIXTEEN_BITS = 0xFFFF;
21             my $DEFAULT_MAX_SIZE = 1024;
22             my $NO_POS = 0;
23              
24             my %code_for = (
25             version => 0x10,
26             info => 0x11, #future
27             'err' => 0x40,
28             get_dir => 0x41,
29             get_file => 0x42,
30             put_file => 0x43,
31             install => 0x44,
32             del_file => 0x45,
33             del_dir => 0x46,
34             get_pro => 0x47,
35             set_pro => 0x48,
36             make_dir => 0x49,
37             say_bye => 0x4A,
38             grab_file => 0x4B,
39             grab_done => 0x4C,
40             stat_file => 0x4D,
41             move_file => 0x4E,
42             ch_passw => 0x4F, #future
43             );
44             my %type_of = (
45             0x00 => 'end',
46             0x01 => 'file',
47             0x02 => 'dir',
48             0x2A => 'skip',
49             );
50              
51             my %pos_must_match_for = map { $code_for{$_} => 1 } qw/info get_dir get_file put_file grab_file/;
52              
53             my @info = qw/logging read-only reverse-lookup private-mode throughput-control extra-data/;
54             my @mods = qw/owner delete create mkdir private readme list rename/;
55              
56             my %is_nonfatal = map { $_ => 1 } (ENOBUFS, EHOSTUNREACH, ECONNREFUSED, EHOSTDOWN, ENETDOWN, EPIPE, EAGAIN, EINTR);
57              
58             my %connect_sub_for = (
59             ipv4 => \&_connect_ipv4,
60             ipv6 => \&_connect_ipv6,
61             );
62              
63             my %dispatch_for = (
64             file => 'Net::FSP::File',
65             dir => 'Net::FSP::Dir',
66             );
67              
68             my %default_options = (
69             remote_port => 21,
70             local_port => 0,
71             local_adress => undef,
72             min_delay => 1.34,
73             max_delay => 60,
74             delay_factor => 1.5,
75             max_payload_size => $DEFAULT_MAX_SIZE,
76             password => undef,
77             key => 0,
78             network_layer => 'ipv4',
79             current_dir => '/',
80             );
81              
82             # Constructor and helper functions
83             sub new {
84 0     0 1   my ($class, $remote_host, $options) = @_;
85 0 0         croak 'Hostname undefined' if not defined $remote_host;
86 0   0       $options ||= {};
87 0           my %self = (
88             %default_options,
89 0           %{$options},
90             remote_host => $remote_host,
91             message_id => int rand 65_536,
92             rin => '',
93             );
94 0           for my $size (qw/read_size write_size listing_size/) {
95 0   0       $self{$size} ||= $self{max_payload_size};
96             }
97 0           my $self = bless \%self, $class;
98 0 0         my $connector = $connect_sub_for{ $self->{network_layer} } or croak 'No such network layer';
99 0           $self->$connector();
100 0           $self->_prepare_socket();
101 0           $self->change_dir($self->{current_dir});
102 0           return $self;
103             }
104              
105             sub _connect_ipv4 {
106 0     0     my $self = shift;
107              
108 0 0         socket $self->{socket}, PF_INET, SOCK_DGRAM, 0 or croak "Could not make socket: $!";
109 0 0         my $local_address = $self->{local_address} ? inet_aton($self->{local_address}) : INADDR_ANY or croak "No such localhost: $!";
    0          
110 0 0         bind $self->{socket}, sockaddr_in($self->{local_port}, $local_address) or croak "Could not bind: $!";
111 0 0         my $packed_ip = inet_aton($self->{remote_host}) or croak "No such host '$self->{remote_host}'";
112 0 0         connect $self->{socket}, sockaddr_in($self->{remote_port}, $packed_ip) or croak "Could not connect to remote host: $!";
113 0           return;
114             }
115              
116             sub _connect_ipv6 {
117 0     0     my $self = shift;
118 0           require Socket6;
119              
120 0           my $family = Socket6::PF_INET6();
121 0 0         socket $self->{socket}, $family, SOCK_DGRAM, 0 or croak "Could not make socket: $!";
122 0 0 0       my $local_ip = $self->{local_address} ? Socket6::inet_pton($family, $self->{local_address}) || croak "No such localhost: $!" : Socket6::in6addr_any();
123 0 0         bind $self->{socket}, Socket6::pack_sockaddr_in6($self->{local_port}, $local_ip) or croak "Could not bind: $!";
124 0 0         my $packed_ip = Socket6::gethostbyname2($self->{remote_host}, $family) or croak "No such host '$self->{remote_host}'";
125 0 0         connect $self->{socket}, Socket6::pack_sockaddr_in6($self->{remote_port}, $packed_ip) or croak "Could not connect to remote host: $!";
126 0           return;
127             }
128              
129             sub _prepare_socket {
130 0     0     my $self = shift;
131 0           binmode $self->{socket}, ':raw';
132 0 0         my $flags = fcntl $self->{socket}, F_GETFL, 0 or croak "Can't get flags for the socket: $!";
133 0 0         fcntl $self->{socket}, F_SETFL, $flags | O_NONBLOCK or croak "Can't set flags for the socket: $!";
134 0           vec($self->{rin}, fileno $self->{socket}, 1) = 1;
135 0           return;
136             }
137              
138             # send_receive and helpers
139              
140             sub _checksum {
141 0     0     my ($package, $sum) = @_;
142 0           $sum += unpack '%32a*', $package;
143 0           return ($sum + ($sum >> 8)) & 0xFF;
144             }
145              
146             sub _pack_request {
147 0     0     my ($self, $send_command, $send_pos, $send_data, $send_extra) = @_;
148 0           $self->{message_id} = $self->{message_id} + 1 & $SIXTEEN_BITS;
149 0           my $request = pack 'CxnnnN a*a*', $code_for{$send_command}, $self->{key}, $self->{message_id}, length $send_data, $send_pos, $send_data, $send_extra;
150 0           vec($request, 1, 8) = _checksum($request, length $request);
151 0           return $request;
152             }
153              
154             sub _check_fatal {
155 0     0     my $message = shift;
156 0 0         croak "$message: $!" if not $is_nonfatal{ $! + 0 };
157 0           return;
158             }
159              
160             sub _receive {
161 0     0     my ($self, $response) = @_;
162 0 0         return defined recv $self->{socket}, ${$response}, $self->{max_payload_size} + $HEADER_SIZE, 0 or _check_fatal('Could not receive');
  0            
163             }
164              
165             sub _send {
166 0     0     my ($self, $request) = @_;
167 0 0         send $self->{socket}, $request, 0 or _check_fatal('Could not send');
168 0           return;
169             }
170              
171             sub _replies_pending {
172 0     0     my $self = shift;
173 0   0       my $delay = shift || 0;
174 0           return scalar select my $rout = $self->{rin}, undef, undef, $delay;
175             }
176              
177             sub _unpack_response {
178 0     0     my ($self, $response) = @_;
179 0           my %fields;
180 0           @fields{ 'command', 'checksum', 'key', 'message_id', 'length', 'pos', 'fulldata' } = unpack 'CCnnnN a*', $response;
181 0           @fields{ 'data', 'extra' } = unpack "a[$fields{length}]a*", $fields{fulldata};
182 0           return %fields;
183             }
184              
185             sub _response_is_correct {
186 0     0     my ($self, $value_for, $response, $send_command, $send_pos) = @_;
187 0           vec($response, 1, 8) = 0;
188             return
189 0 0 0       $value_for->{checksum} == _checksum($response, 0)
      0        
      0        
      0        
190             and length $value_for->{fulldata} >= $value_for->{length}
191             and ($value_for->{command} == $code_for{$send_command} || $value_for->{command} == $code_for{err})
192             and not($pos_must_match_for{ $value_for->{command} } && $send_pos != $value_for->{pos});
193             }
194              
195             # the main networking function, known as interact() in the C library.
196             sub _send_receive {
197 0     0     my ($self, $send_command, $send_pos, $send_data, $send_extra) = @_;
198 0 0         $send_extra = '' if not defined $send_extra;
199              
200 0           my $request = $self->_pack_request($send_command, $send_pos, $send_data, $send_extra);
201             ATTEMPT:
202 0           for (my $delay = $self->{min_delay} ; $delay < $self->{max_delay} ; $delay *= $self->{delay_factor}) {
203 0 0         if (not $self->_replies_pending) {
204 0           $self->_send($request);
205 0 0         next ATTEMPT if not $self->_replies_pending($delay);
206             }
207 0 0         next ATTEMPT if not $self->_receive(\my $response);
208 0 0         next ATTEMPT if length $response < $HEADER_SIZE;
209 0           my %response = $self->_unpack_response($response);
210 0 0         next ATTEMPT if not $self->_response_is_correct(\%response, $response, $send_command, $send_pos);
211 0           $self->{key} = $response{key};
212 0 0         redo ATTEMPT if $response{message_id} != $self->{message_id};
213              
214 0 0         croak sprintf 'Received error from server: %s', unpack 'Z*', $response{data} if $response{command} == $code_for{err};
215 0 0         return wantarray ? @response{ 'data', 'extra' } : $response{data};
216             }
217 0           croak 'Remote server not responding';
218             }
219              
220             #the rest...
221              
222             sub _make_remote {
223 0     0     my ($self, $name) = @_;
224 0 0         my @current = $name =~ m{ \A / }xms ? () : split m{ / }x, $self->{current_dir};
225 0           my @future = grep { !/ \A \.? \z /xms } split m{ / }x, $name;
  0            
226 0           for my $step (@future) {
227 0 0         if ($step eq '..') {
228 0 0         croak 'Can\'t go outside of root directory' if @current == 0;
229 0           pop @current;
230             }
231             else {
232 0           push @current, $step;
233             }
234             }
235 0           return join '/', @current;
236             }
237              
238             sub _convert_filename {
239 0     0     my ($self, $filename, $escaped) = @_;
240 0 0         my $path = defined $escaped ? $filename : $self->_make_remote($filename);
241 0 0         return sprintf "%s%s\0", $path, defined $self->{password} ? "\n" . $self->{password} : '';
242             }
243              
244             sub _connected {
245 0     0     my $self = shift;
246 0           return $self->{key} != 0;
247             }
248              
249             sub DESTROY {
250 0     0     my $self = shift;
251 0 0         $self->say_bye if $self->_connected;
252 0 0         close $self->{socket} or croak "Couldn't close socket?!: $!";
253 0           return;
254             }
255              
256             sub current_dir {
257 0     0 1   my $self = shift;
258 0           return $self->{current_dir};
259             }
260              
261             sub change_dir {
262 0     0 1   my ($self, $newdir) = @_;
263 0           $newdir = $self->_make_remote($newdir);
264 0           $self->_send_receive('get_pro', $NO_POS, $self->_convert_filename($newdir, 1));
265 0           my $olddir = $self->{current_dir};
266 0           $self->{current_dir} = Net::FSP::Dir->new($self, $self->{current_dir}, %{ $self->stat_file($newdir, 1) });
  0            
267 0           return $olddir;
268             }
269              
270             sub say_bye {
271 0     0 1   my $self = shift;
272 0           $self->_send_receive('say_bye', $NO_POS, '');
273 0           $self->{key} = 0;
274 0           return;
275             }
276              
277             sub server_version {
278 0     0 1   my $self = shift;
279 0           my $version = unpack 'Z*', scalar $self->_send_receive('version', $NO_POS, '');
280 0           chomp $version;
281 0           return $version;
282             }
283              
284             sub server_config {
285 0     0 1   my $self = shift;
286 0           my (undef, $extra) = $self->_send_receive('version', $NO_POS, '');
287 0           my @extra = unpack 'b5', $extra;
288 0           my %prot = map { $info[$_] => $extra[$_] } 0..$#info;
  0            
289 0           return \%prot;
290             }
291              
292             sub cat_file {
293 0     0 1   my ($self, $filename) = @_;
294 0           my $return_value = '';
295 0     0     $self->download_file($filename, sub { $return_value .= $_[0] });
  0            
296 0           return $return_value;
297             }
298              
299             sub _get_reader {
300 0     0     my ($self, $code, $filename, $pos_ref) = @_;
301 0           my $remote_name = $self->_convert_filename($filename);
302 0 0         my $extra = $self->{read_size} != $DEFAULT_MAX_SIZE ? pack 'n', $self->{read_size} : '';
303             return sub {
304 0     0     my $block = $self->_send_receive($code, ${$pos_ref}, $remote_name, $extra);
  0            
305 0           ${$pos_ref} += length $block;
  0            
306 0           return $block;
307 0           };
308             }
309              
310             sub _download_to {
311 0     0     my ($self, $code, $filename, $add) = @_;
312 0           my $pos = 0;
313 0           my $reader = $self->_get_reader($code, $filename, \$pos);
314             BLOCK:
315 0           while (1) {
316 0           my $block = $reader->();
317 0 0         last BLOCK if length $block == 0;
318 0           $add->($block);
319             }
320 0           return;
321             }
322              
323             sub download_file {
324 0     0 1   my ($self, $filename, $other) = @_;
325 0 0         if (ref($other) eq '') {
    0          
326 0 0         open my $fh, '>:raw', $other or croak "Couldn't open file '$other' for writing: $!";
327 0           $self->download_file($filename, $fh);
328 0 0         close $fh or croak "Couldn't close filehandle: $!";
329             }
330             elsif (ref($other) eq 'GLOB') {
331 0 0   0     $self->_download_to('get_file', $filename, sub { print {$other} @_ or croak "Couldn't write: $!" });
  0            
  0            
332             }
333             else {
334 0           $self->_download_to('get_file', $filename, $other);
335             }
336 0           return;
337             }
338              
339             sub grab_file {
340 0     0 1   my ($self, $filename, $other) = @_;
341 0 0         if (ref($other) eq '') {
    0          
342 0 0         open my $fh, '>:raw', $other or croak "Couldn't open file '$other' for writing: $!";
343 0           $self->grab_file($filename, $fh);
344 0 0         close $fh or croak "Couldn't close filehandle: $!";
345             }
346             elsif (ref($other) eq 'GLOB') {
347 0 0   0     $self->_download_to('grab_file', $filename, sub { print {$other} @_ or croak "Couldn't write: $!" });
  0            
  0            
348             }
349             else {
350 0           $self->_download_to('grab_file', $filename, $other);
351             }
352 0           $self->_send_receive('grab_done', $NO_POS, $self->_convert_filename($filename));
353 0           return;
354             }
355              
356             sub list_dir {
357 0     0 1   my ($self, $raw_dir) = @_;
358 0           my $remote_dir = $self->_make_remote($raw_dir);
359 0           my $dirname = $self->_convert_filename($remote_dir, 1);
360              
361 0 0         my $extra = $self->{listing_size} != $DEFAULT_MAX_SIZE ? pack 'n', $self->{listing_size} : '';
362 0           my ($data, $cursor, @entries) = ('', 0);
363              
364             ENTRY:
365 0           while (1) {
366 0 0         if (length($data) < $LISTING_HEADER_SIZE) {
367 0           $data = $self->_send_receive('get_dir', $cursor++, $dirname, $extra);
368             }
369              
370 0           my ($time, $size, $type_id) = unpack 'NNC', substr $data, 0, $LISTING_HEADER_SIZE, '';
371 0           my $type = $type_of{$type_id};
372              
373 0 0 0       if ($type eq 'end') {
    0          
    0          
374 0           last ENTRY;
375             }
376             elsif ($type eq 'file' or $type eq 'dir') {
377 0 0         my ($filename) = $data =~ / \A ( [^\0]+ ) /xms or croak 'No filename present?!';
378 0           my $padding = $LISTING_ALIGNMENT - (length($filename) + $LISTING_HEADER_SIZE) % $LISTING_ALIGNMENT;
379 0           substr $data, 0, length($filename) + $padding, '';
380 0 0 0       next ENTRY if $filename eq '.' or $filename eq '..';
381 0           my ($link) = $filename =~ s/ \n ( [^\n]+ ) \z //xms;
382 0 0         push @entries, $dispatch_for{$type}->new(
383             $self,
384             "$remote_dir/$filename",
385             time => $time,
386             size => $size,
387             type => $type,
388             (length $link ? (link => $link) : ()),
389             );
390             }
391             elsif ($type eq 'skip') {
392 0           $data = $self->_send_receive('get_dir', $cursor++, $dirname, $extra);
393             }
394             }
395 0           return @entries;
396             }
397              
398             sub stat_file {
399 0     0 1   my ($self, $filename, $escaped) = @_;
400 0           my ($time, $size, $type_id) = unpack 'NNC', $self->_send_receive('stat_file', $NO_POS, $self->_convert_filename($filename, $escaped));
401 0           my $type = $type_of{$type_id};
402 0 0         croak "No such file '$filename'" if $type eq 'end';
403 0 0         if (wantarray) {
404 0           return ($time, $size, $type);
405             }
406             else {
407 0           return $dispatch_for{$type}->new($self, $filename, size => $size, type => $type, time => $time);
408             }
409             }
410              
411             sub _get_writer {
412 0     0     my ($self, $filename, $timestamp, $handle) = @_;
413 0           my $position = 0;
414 0 0         croak 'You can only write one file at the same time' if $self->{writing};
415 0           $self->{writing} = 1;
416             return sub {
417 0     0     my $part = shift;
418 0 0         if (defined $part) {
419 0           $self->_send_receive('put_file', $position, $part);
420 0           $position += length $part;
421 0           chomp $part;
422             }
423             else {
424 0 0         $self->_send_receive('install', $NO_POS, $self->_convert_filename($filename), defined $timestamp ? pack('N', $timestamp) : '');
425 0           $self->{writing} = 0;
426             }
427 0           };
428             }
429              
430             sub _upload_to {
431 0     0     my ($self, $filename, $sub, $timestamp) = @_;
432 0           my $writer = $self->_get_writer($filename, $timestamp);
433 0           while (1) {
434 0           my $part = $sub->($self->{write_size});
435 0           $writer->($part);
436 0 0         last if not defined $part;
437             }
438 0           return;
439             }
440              
441             sub upload_file {
442 0     0 1   my ($self, $filename, $other, $timestamp) = @_;
443 0 0         if (ref($other) eq '') {
    0          
444 0 0         open my $fh, '<:raw', $other or croak "Couldn't open file '$other' for reading: $!";
445 0           $self->upload_file($filename, $fh, $timestamp);
446 0 0         close $fh or croak "Couldn't close filehandle!?: $!";
447             }
448             elsif (ref($other) eq 'GLOB') {
449             $self->_upload_to(
450             $filename,
451             sub {
452 0 0   0     defined read $other, my $return_value, $_[0] or croak "Couldn't read: $!";
453 0 0         return length $return_value ? $return_value : undef;
454             },
455 0           $timestamp
456             );
457             }
458             else {
459 0           $self->_upload_to($filename, $other, $timestamp);
460             }
461 0           return;
462             }
463              
464             sub remove_file {
465 0     0 1   my ($self, $filename) = @_;
466 0           $self->_send_receive('del_file', $NO_POS, $self->_convert_filename($filename));
467 0           return;
468             }
469              
470             sub remove_dir {
471 0     0 1   my ($self, $filename) = @_;
472 0           $self->_send_receive('del_dir', $NO_POS, $self->_convert_filename($filename));
473 0           return;
474             }
475              
476             sub _protection_helper {
477 0     0     my ($self, $command, $filename, $extra) = @_;
478 0           my $protection = ($self->_send_receive($command, $NO_POS, $self->_convert_filename($filename), $extra))[1];
479 0           my @bits = split //x, unpack 'b8', $protection;
480 0           my %prot = map { $mods[$_] => $bits[$_] } 0..$#mods;
  0            
481 0           return \%prot;
482             }
483              
484             sub get_readme {
485 0     0 1   my ($self, $filename) = @_;
486 0           return scalar $self->_send_receive('get_pro', $NO_POS, $self->_convert_filename($filename));
487             }
488              
489             sub get_protection {
490 0     0 1   my ($self, $filename) = @_;
491 0           return $self->_protection_helper('get_pro', $self->_convert_filename($filename));
492             }
493              
494             sub set_protection {
495 0     0 1   my ($self, $filename, $mod) = @_;
496 0           return $self->_protection_helper('set_pro', $filename, $mod);
497             }
498              
499             sub make_dir {
500 0     0 1   my ($self, $filename) = @_;
501 0           $self->_send_receive('make_dir', $NO_POS, $self->_convert_filename($filename));
502 0           return;
503             }
504              
505             sub move_file {
506 0     0 1   my ($self, $old_name, $new_name) = @_;
507 0           $self->_send_receive('move_file', $NO_POS, $self->_convert_filename($old_name), $self->_convert_filename($new_name));
508 0           return;
509             }
510              
511             sub CLONE_SKIP {
512 0     0     return 1;
513             }
514              
515             sub open_file {
516 0     0 1   my ($self, $filename, $mode) = @_;
517 0           my $ret = gensym;
518 0 0         tie *{$ret}, 'Net::FSP::Handle', $self, $filename, $mode or croak "Could not open remote file $filename: $!";
  0            
519 0           return $ret;
520             }
521              
522             1;
523              
524             __END__