File Coverage

blib/lib/Test/Mock/Net/FTP.pm
Criterion Covered Total %
statement 290 292 99.3
branch 79 84 94.0
condition 5 6 83.3
subroutine 78 80 97.5
pod 52 52 100.0
total 504 514 98.0


line stmt bran cond sub pod time code
1             package Test::Mock::Net::FTP;
2 18     18   270132 use strict;
  18         44  
  18         443  
3 18     18   89 use warnings;
  18         39  
  18         394  
4              
5 18     18   5722 use File::Copy;
  18         49230  
  18         1007  
6 18     18   1208 use File::Spec::Functions qw( catdir splitdir rootdir catfile curdir rel2abs abs2rel );
  18         1923  
  18         993  
7 18     18   99 use File::Basename;
  18         36  
  18         858  
8 18     18   92 use Cwd qw(getcwd);
  18         35  
  18         544  
9 18     18   87 use Carp;
  18         40  
  18         802  
10 18     18   98 use File::Path qw(make_path remove_tree);
  18         44  
  18         722  
11 18     18   7703 use File::Slurp;
  18         210449  
  18         48723  
12              
13             our $VERSION = '0.04';
14              
15             # stopwords for Spellunker
16              
17             =for stopwords pasv ascii alloc cwd cdup pwd rmdir dir mkdir ls filesize mdtm nlst retr stor stou appe login quot
18              
19             =head1 NAME
20              
21             Test::Mock::Net::FTP - Mock Object for Net::FTP
22              
23             =head1 SYNOPSIS
24              
25             use strict;
26             use warnings;
27              
28             use Test::More;
29             use Test::Mock::Net::FTP;
30              
31             Test::Mock::Net::FTP::mock_prepare(
32             'somehost.example.com' => {
33             'user1'=> {
34             password => 'secret',
35             dir => ['./ftpserver', '/ftproot'],
36             override => {
37             ls => sub {
38             return qw(aaa bbb ccc);
39             },
40             },
41             },
42             }
43             );
44             my $ftp = Test::Mock::Net::FTP->new('somehost.example.com');
45             $ftp->login('user1', 'secret');
46             $ftp->cwd('datadir');
47             $ftp->get('file1');
48             my @files = $ftp->ls();# => ('aaa', 'bbb', 'ccc');
49             $ftp->quit();
50             # or
51             use Test::Mock::Net::FTP qw(intercept);
52             some_method_using_ftp();
53              
54             =head1 DESCRIPTION
55              
56             Test::Mock::Net::FTP is Mock Object for Net::FTP. This module behave like FTP server, but only use local filesystem.(not using socket).
57              
58             =head1 NOTICE
59              
60             =over 4
61              
62             =item
63             This module is implemented all Net::FTP's methods, but some methods are 'do nothing' currently. These methods behavior may be changed in future release.
64              
65             =item
66             This module works in only Unix-like systems(does not work in MS-Windows).
67              
68             =item
69             Some errors are not reproduced in this module.
70              
71             =item
72             If you don't like default implementation of methods in this module, you can use override (or RT to me :-)
73              
74             =back
75              
76             =cut
77              
78             my %mock_server;
79             my $cwd_when_prepared;
80              
81             =head1 METHODS
82              
83             =cut
84              
85             =head2 C
86              
87             prepare FTP server in your local filesystem.
88              
89             =cut
90              
91             sub mock_prepare {
92 184     184 1 144055 my %args = @_;
93 184         956 %mock_server = %args;
94 184         987 $cwd_when_prepared = getcwd();
95             }
96              
97             =head2 C
98              
99             mock's current directory
100              
101             =cut
102              
103             sub mock_pwd {
104 58     58 1 578 my ($self) = @_;
105 58         147 return catdir($self->mock_physical_root, $self->_mock_cwd);
106             }
107              
108             =head2 C
109              
110             mock's physical root directory
111              
112             =cut
113              
114             sub mock_physical_root {
115 84     84 1 2295 my ($self) = @_;
116 84         525 return $self->{mock_physical_root};
117             }
118              
119             =head2 C
120              
121             return current connection mode (port or pasv)
122              
123             =cut
124              
125             sub mock_connection_mode {
126 5     5 1 28 my ($self) = @_;
127              
128 5         20 return $self->{mock_connection_mode};
129             }
130              
131             =head2 C
132              
133             return current port no
134              
135             =cut
136              
137             sub mock_port_no {
138 5     5 1 11 my ($self) = @_;
139              
140 5         18 return $self->{mock_port_no};
141             }
142              
143             =head2 C
144              
145             return current transfer mode(ascii or binary)
146              
147             =cut
148              
149             sub mock_transfer_mode {
150 3     3 1 11 my ($self) = @_;
151              
152 3         12 return $self->{mock_transfer_mode};
153             }
154              
155             =head2 C
156              
157             return command history
158              
159             my $ftp = Test::Mock::Net::FTP->new('somehost');
160             $ftp->login('somehost', 'passwd');
161             $ftp->ls('dir1');
162             my @history = $ftp->mock_command_history();
163             # => ( ['login', 'somehost', 'passwd'], ['ls', 'dir1']);
164              
165             =cut
166              
167             sub mock_command_history {
168 43     43 1 231 my ($self) = @_;
169              
170 43         64 return @{ $self->{mock_command_history} };
  43         193  
171             }
172              
173             sub _push_mock_command_history {
174 562     562   1354 my ($self, $method_name, @args) = @_;
175 562         975 shift @args; #discard $self;
176 562         870 push @{ $self->{mock_command_history} }, [$method_name, @args];
  562         1825  
177             }
178              
179             =head2 C
180              
181             clear command history
182              
183             =cut
184              
185             sub mock_clear_command_history {
186 83     83 1 323 my ($self) = @_;
187              
188 83         308 $self->{mock_command_history} = [];
189             }
190              
191              
192             =head2 C
193              
194             create new instance
195              
196             =cut
197              
198             sub new {
199 251     251 1 102988 my ($class, $host, %opts ) = @_;
200 251 100       833 return if ( !exists $mock_server{$host} );
201              
202 250         630 my ($connection_mode, $port_no) = _connection_mode_and_port_no(%opts);
203              
204 250         1492 my $self = {
205             mock_host => $host,
206             mock_physical_root => '',
207             mock_server_root => '',
208             mock_transfer_mode => 'ascii',
209             mock_connection_mode => $connection_mode,
210             mock_port_no => $port_no,
211             message => '',
212             mock_command_history => [],
213             };
214 250         754 bless $self, $class;
215             }
216              
217             sub _connection_mode_and_port_no {
218 250     250   497 my (%opts) = @_;
219 250 100 66     1596 my $connection_mode = ((!defined $opts{Passive} && !defined $opts{Port} ) || !!$opts{Passive}) ? 'pasv' : 'port';
220             my $port_no = $connection_mode eq 'pasv' ? ''
221             : defined $opts{Port} ? $opts{Port}
222 250 100       627 : '20';
    100          
223 250         656 return ($connection_mode, $port_no);
224             }
225              
226             =head2 C
227              
228             login mock FTP server. this method IS NOT allowed to be overridden.
229              
230             =cut
231              
232             sub login {
233 251     251 1 1867 my ($self, $user, $pass) = @_;
234 251         763 $self->_push_mock_command_history('login', @_);
235              
236 251 100       671 if ( $self->_mock_login_auth( $user, $pass) ) {# auth success
237 250         864 my $cwd = getcwd();
238 250         2677 chdir $cwd_when_prepared;# chdir for absolute path
239 250         556 my $mock_server_for_user = $mock_server{$self->{mock_host}}->{$user};
240 250         402 my $dir = $mock_server_for_user->{dir};
241 250 100       1077 $self->{mock_physical_root} = rel2abs($dir->[0]) if defined $dir->[0];
242 250         4699 $self->{mock_server_root} = $dir->[1];
243 250         505 $self->{mock_cwd} = rootdir();
244 250         449 $self->{mock_override} = $mock_server_for_user->{override};
245 250         1640 chdir $cwd;
246 250         682 return 1;
247             }
248 1         2 $self->{message} = 'Login incorrect.';
249 1         4 return;
250             }
251              
252             sub _mock_login_auth {
253 251     251   479 my ($self, $user, $pass) = @_;
254              
255 251         589 my $server_user = $mock_server{$self->{mock_host}}->{$user};
256 251 100       611 return if !defined $server_user; #user not found
257              
258 250         464 my $server_password = $server_user->{password};
259 250         769 return $server_password eq $pass;
260             }
261              
262             =head2 C
263              
264             authorize.
265             default implementation is 'do nothing'. this method is allowed to be overridden.
266              
267             =cut
268              
269              
270             =head2 C
271              
272             default implementation for authorize. this method should be used in overridden method.
273              
274             =cut
275              
276             sub mock_default_authorize {
277 1     1 1 3 my ($self, $auth, $resp) = @_;
278 1         23 return 1;
279             }
280              
281             =head2 C
282              
283             execute SITE command.
284             default implementation is 'do nothing'. this method is allowed to be overridden.
285              
286             =cut
287              
288              
289             =head2 C
290              
291             default implementation for site. this method should be used in overridden method.
292              
293             =cut
294              
295             sub mock_default_site {
296 1     1 1 3 my ($self, @args) = @_;
297 1         3 return 1;
298             }
299              
300             =head2 C
301              
302             enter ascii mode.
303             mock_transfer_mode() returns 'ascii'.
304             this method is allowed to be overridden.
305              
306             =cut
307              
308              
309             =head2 C
310              
311             default implementation for ascii. this method should be used in overridden method.
312              
313             =cut
314              
315             sub mock_default_ascii {
316 1     1 1 3 my ($self) = @_;
317 1         3 $self->{mock_transfer_mode} = 'ascii';
318             }
319              
320             =head2 C
321              
322             enter binary mode.
323             mock_transfer_mode() returns 'binary'.
324             this method is allowed to be overridden.
325              
326             =cut
327              
328              
329             =head2 C
330              
331             default implementation for binary. this method should be used in overridden method.
332              
333             =cut
334              
335             sub mock_default_binary {
336 1     1 1 3 my ($self) = @_;
337 1         3 $self->{mock_transfer_mode} = 'binary';
338             }
339              
340             =head2 C
341              
342             rename remote file.
343             this method is allowed to be overridden.
344              
345             =cut
346              
347              
348             =head2 C
349              
350             default implementation for rename. this method should be used in overridden method.
351              
352             =cut
353              
354             sub mock_default_rename {
355 2     2 1 6 my ($self, $oldname, $newname) = @_;
356 2 100       5 unless( CORE::rename $self->_abs_remote($oldname), $self->_abs_remote($newname) ) {
357 1         9 $self->{message} = sprintf("%s: %s\n", $oldname, $!);
358 1         6 return;
359             }
360             }
361              
362             =head2 C
363              
364             delete remote file.
365             this method is allowed to be overridden.
366              
367             =cut
368              
369              
370             =head2 C
371              
372             default implementation for delete. this method should be used in overridden method.
373              
374             =cut
375              
376             sub mock_default_delete {
377 2     2 1 6 my ($self, $filename) = @_;
378              
379 2 100       5 unless( unlink $self->_abs_remote($filename) ) {
380 1         10 $self->{message} = sprintf("%s: %s\n", $filename, $!);
381 1         5 return;
382             }
383             }
384              
385             =head2 C
386              
387             change (mock) server current directory
388             this method is allowed to be overridden.
389              
390             =cut
391              
392              
393             =head2 C
394              
395             default implementation for cwd. this method should be used in overridden method.
396              
397             =cut
398              
399             sub mock_default_cwd {
400 34     34 1 105 my ($self, $dirs) = @_;
401              
402 34 100       150 if ( !defined $dirs ) {
    100          
403 5         17 $self->{mock_cwd} = rootdir();
404 5         11 $dirs = "";
405             }
406              
407             # if an absolute path, start at root
408             elsif ( $dirs =~ m|^/| ) {
409 2         4 $self->{mock_cwd} = rootdir();
410             }
411              
412 34         124 my $backup_cwd = $self->_mock_cwd;
413 34         124 for my $dir ( splitdir($dirs) ) {
414 43         265 $self->_mock_cwd_each($dir);
415             }
416 34         261 $self->{mock_cwd} =~ s/^$self->{mock_server_root}//;#for absolute path
417 34         106 return $self->_mock_check_pwd($backup_cwd);
418             }
419              
420             =head2 C
421              
422             change (mock) server directory to parent
423             this method is allowed to be overridden.
424              
425             =cut
426              
427              
428             =head2 C
429              
430             default implementation for cdup. this method should be used in overridden method.
431              
432             =cut
433              
434             sub mock_default_cdup {
435 4     4 1 8 my ($self) = @_;
436 4         9 my $backup_cwd = $self->_mock_cwd;
437 4         8 $self->{mock_cwd} = dirname($self->_mock_cwd);# to updir
438 4         13 return $self->_mock_check_pwd($backup_cwd);
439             }
440              
441             =head2 C
442              
443             return (mock) server current directory
444             this method is allowed to be overridden.
445              
446             =cut
447              
448              
449             =head2 C
450              
451             default implementation for pwd. this method should be used in overridden method.
452              
453             =cut
454              
455             sub mock_default_pwd {
456 13     13 1 23 my ($self) = @_;
457 13         34 return catdir($self->{mock_server_root}, $self->_mock_cwd);
458             }
459              
460             sub _mock_cwd_each {
461 43     43   106 my ($self, $dir) = @_;
462              
463 43 100       101 if ( $dir eq '..' ) {
464 3         14 $self->cdup();
465             }
466             else {
467 40         88 $self->{mock_cwd} = catdir($self->_mock_cwd, $dir);
468             }
469             }
470              
471             # check if mock server directory "phisically" exists.
472             sub _mock_check_pwd {
473 38     38   90 my ($self, $backup_cwd) = @_;
474              
475 38 100       110 if ( ! -d $self->mock_pwd ) {
476 1         3 $self->{mock_cwd} = $backup_cwd;
477 1         3 $self->{message} = 'Failed to change directory.';
478 1         5 return 0;
479             }
480 37         141 return 1;
481             }
482              
483             =head2 C
484              
485             restart. currently do_nothing
486             this method is allowed to be overridden.
487              
488             =cut
489              
490              
491             =head2 C
492              
493             default implementation for restart. this method should be used in overridden method.
494              
495             =cut
496              
497             sub mock_default_restart {
498 1     1 1 3 my ($self, $where) = @_;
499 1         2 return 1;
500             }
501              
502             =head2 C
503              
504             rmdir to remove (mock) server. when $recursive_bool is true, dir is recursively removed.
505             this method is allowed to be overridden.
506              
507             =cut
508              
509              
510             =head2 C
511              
512             default implementation for rmdir. this method should be used in overridden method.
513              
514             =cut
515              
516             sub mock_default_rmdir {
517 4     4 1 11 my ($self, $dirname, $recursive_bool) = @_;
518 4 100       9 if ( !!$recursive_bool ) {
519 2 100       5 unless( remove_tree( $self->_abs_remote($dirname) ) ) {
520 1         9 $self->{message} = sprintf("%s: %s", $dirname, $!);
521 1         6 return;
522             }
523             }
524             else {
525 2 100       5 unless( CORE::rmdir $self->_abs_remote($dirname) ) {
526 1         12 $self->{message} = sprintf("%s: %s", $dirname, $!);
527 1         6 return;
528             }
529             }
530             }
531              
532             =head2 C
533              
534             mkdir to remove (mock) server. when $recursive_bool is true, dir is recursively create.
535             this method is allowed to be overridden.
536              
537             =cut
538              
539              
540             =head2 C
541              
542             default implementation for mkdir. this method should be used in overridden method.
543              
544             =cut
545              
546             sub mock_default_mkdir {
547 5     5 1 12 my ($self, $dirname, $recursive_bool) = @_;
548 5 100       13 if ( !!$recursive_bool ) {
549 2 100       9 unless( make_path( $self->_abs_remote($dirname) ) ) {
550 1         12 $self->{message} = sprintf("%s: %s", $dirname, $!);
551 1         8 return;
552             }
553             }
554             else {
555 3 100       19 unless( CORE::mkdir $self->_abs_remote($dirname) ) {
556 1         14 $self->{message} = sprintf("%s: %s", $dirname, $!);
557 1         8 return;
558             }
559             }
560             }
561              
562             =head2 C
563              
564             alloc.
565             default implementation is 'do nothing'. this method is allowed to be overridden.
566              
567             =cut
568              
569              
570             =head2 C
571              
572             default implementation for alloc. this method should be used in overridden method.
573              
574             =cut
575              
576             sub mock_default_alloc {
577 1     1 1 3 my ($self, $size, $record_size) = @_;
578 1         2 return 1;
579             }
580              
581             =head2 C
582              
583             list file(s) in server directory.
584             this method is allowed to be overridden.
585              
586             =cut
587              
588              
589             =head2 C
590              
591             default implementation for ls. this method should be used in overridden method.
592              
593             =cut
594              
595             sub mock_default_ls {
596 4     4 1 9 my ($self, $dir) = @_;
597              
598 4         10 my @ls = $self->_list_files($dir);
599 4 100       13 my @result = (defined $dir)? map{ catfile($dir, $_) } @ls : @ls;
  6         25  
600              
601 4 100       17 return @result if ( wantarray() );
602 1         4 return \@result;
603             }
604              
605             sub _list_files {
606 4     4   9 my ($self, $dir) = @_;
607 4         8 my $target_dir = $self->_relative_remote($dir);
608 4 50       119 opendir my $dh, $target_dir or die $!;
609 4         43 my @files = sort grep { $_ !~ /^\.?\.$/ } readdir($dh);
  16         60  
610 4         27 closedir $dh;
611 4         17 return @files;
612             }
613              
614             =head2 C
615              
616             list file(s) with detail information(ex. filesize) in server directory.
617             this method is allowed to be overridden.
618              
619             =cut
620              
621              
622             =head2 C
623              
624             default implementation for dir. this method should be used in overridden method.
625              
626             =cut
627              
628             sub mock_default_dir {
629 4     4 1 11 my ($self, $dir) = @_;
630 4         21 my $target_dir = $self->_relative_remote($dir);
631 4         24 local $ENV{LC_ALL} = "C";
632 4         11306 my @dir = split(/\n/, `ls -l $target_dir`);
633              
634 4 100       104 return @dir if ( wantarray() );
635 1         23 return \@dir;
636             }
637              
638             =head2 C
639              
640             get file from mock FTP server
641             this method is allowed to be overridden.
642              
643             =cut
644              
645              
646             =head2 mock_default_get( $remote_file, [$local_file] )
647              
648             default implementation for get. this method should be used in overridden method.
649              
650             =cut
651              
652             sub mock_default_get {
653 5     5 1 14 my($self, $remote_file, $local_file) = @_;
654 5 100       146 $local_file = basename($remote_file) if ( !defined $local_file );
655 5 100       20 unless( copy( $self->_abs_remote($remote_file),
656             $self->_abs_local($local_file) ) ) {
657 1         116 $self->{message} = sprintf("%s: %s", $remote_file, $!);
658 1         8 return;
659             }
660              
661 4         974 return $local_file;
662             }
663              
664              
665             =head2 C
666              
667             put a file to mock FTP server
668             this method is allowed to be overridden.
669              
670             =cut
671              
672              
673             =head2 C
674              
675             default implementation for put. this method should be used in overridden method.
676              
677             =cut
678              
679             sub mock_default_put {
680 9     9 1 24 my ($self, $local_file, $remote_file) = @_;
681 9 100       238 $remote_file = basename($local_file) if ( !defined $remote_file );
682 9 100       34 unless ( copy( $self->_abs_local($local_file),
683             $self->_abs_remote($remote_file) ) ) {
684 1         269 carp "Cannot open Local file $remote_file: $!";
685 1         70 return;
686             }
687              
688 8         2219 return $remote_file;
689             }
690              
691             =head2 C
692              
693             same as put() but if same file exists in server. rename to unique filename
694             (in this module, simply add suffix .1(.2, .3...). and suffix is limited to 1024)
695             this method is allowed to be overridden.
696              
697             =cut
698              
699              
700             sub _unique_new_name {
701 2     2   5 my ($self, $remote_file) = @_;
702              
703 2         4 my $suffix = "";
704 2         6 my $newfile = $remote_file;
705 2         10 for ( my $i=1; $i<=1024; $i++ ) {
706 3 100       12 last if ( !-e $self->_abs_remote($newfile) );
707 1         3 $suffix = ".$i";
708 1         5 $newfile = $remote_file . $suffix;
709             }
710 2         9 return $newfile;
711             }
712              
713             =head2 C
714              
715             default implementation for put_unique. this method should be used in overridden method.
716              
717             =cut
718              
719             sub mock_default_put_unique {
720 2     2 1 7 my ($self, $local_file, $remote_file) = @_;
721 2 50       51 $remote_file = basename($local_file) if ( !defined $remote_file );
722              
723 2         9 my $newfile = $self->_unique_new_name($remote_file);
724 2 100       8 unless ( copy( $self->_abs_local($local_file),
725             $self->_abs_remote($newfile) ) ) {
726 1         176 carp "Cannot open Local file $remote_file: $!";
727 1         59 $self->{mock_unique_name} = undef;
728 1         5 return;
729             }
730 1         212 $self->{mock_unique_name} = $newfile;
731             }
732              
733              
734             =head2 C
735              
736             put a file to mock FTP server. if file already exists, append file contents in server file.
737             this method is allowed to be overridden.
738              
739             =cut
740              
741              
742             =head2 C
743              
744             default implementation for append. this method should be used in overridden method.
745              
746             =cut
747              
748             sub mock_default_append {
749 9     9 1 30 my ($self, $local_file, $remote_file) = @_;
750              
751 9 100       278 $remote_file = basename($local_file) if ( !defined $remote_file );
752 9         28 my $local_contents = eval { read_file( $self->_abs_local($local_file) ) };
  9         35  
753 9 100       1102 if ( $@ ) {
754 1         104 carp "Cannot open Local file $remote_file: $!";
755 1         98 return;
756             }
757 8         37 write_file( $self->_abs_remote($remote_file), { append => 1 }, $local_contents);
758             }
759              
760             =head2 C
761              
762             return unique filename when put_unique() called.
763             this method is allowed to be overridden.
764              
765             =cut
766              
767              
768             =head2 C
769              
770             default implementation for unique_name. this method should be used in overridden method.
771              
772             =cut
773              
774             sub mock_default_unique_name {
775 2     2 1 6 my($self) = @_;
776              
777 2         10 return $self->{mock_unique_name};
778             }
779              
780             =head2 C
781              
782             returns file modification time in remote (mock) server.
783             this method is allowed to be overridden.
784              
785             =cut
786              
787             =head2 C
788              
789             default implementation for mdtm. this method should be used in overridden method.
790              
791             =cut
792              
793             sub mock_default_mdtm {
794 1     1 1 3 my ($self, $filename) = @_;
795 1         3 my $mdtm = ( stat $self->_abs_remote($filename) )[9];
796 1         6 return $mdtm;
797             }
798              
799             =head2 C
800              
801             returns filesize in remote (mock) server.
802             this method is allowed to be overridden.
803              
804             =cut
805              
806              
807             =head2 C
808              
809             default implementation for size. this method should be used in overridden method.
810              
811             =cut
812              
813             sub mock_default_size {
814 1     1 1 8 my ($self, $filename) = @_;
815 1         5 my $size = ( stat $self->_abs_remote($filename) )[7];
816 1         6 return $size;
817             }
818              
819             =head2 C
820              
821             supported.
822             default implementation is 'do nothing'. this method is allowed to be overridden.
823              
824             =cut
825              
826              
827             =head2 C
828              
829             default implementation for supported. this method should be used in overridden method.
830              
831             =cut
832              
833             sub mock_default_supported {
834 1     1 1 3 my ($self, $cmd) = @_;
835 1         4 return 1;
836             }
837              
838              
839             =head2 C
840              
841             hash.
842             default implementation is 'do nothing'. this method is allowed to be overridden.
843              
844             =cut
845              
846              
847             =head2 C
848              
849             default implementation for hash. this method should be used in overridden method.
850              
851             =cut
852              
853             sub mock_default_hash {
854 1     1 1 3 my ($self, $filehandle_glob_ref, $bytes_per_hash_mark) = @_;
855 1         3 return 1;
856             }
857              
858              
859             =head2 C
860              
861             feature. currently returns list of $cmd.
862             this method is allowed to be overridden.
863              
864             =cut
865              
866              
867             =head2 C
868              
869             default implementation for feature. this method should be used in overridden method.
870              
871             =cut
872              
873             sub mock_default_feature {
874 1     1 1 4 my ($self, $cmd) = @_;
875 1         10 return ($cmd);
876             }
877              
878             =head2 C
879              
880             nlst.
881             default implementation is 'do nothing'. this method is allowed to be overridden.
882              
883             =cut
884              
885             =head2 C
886              
887             default implementation for nlst. this method should be used in overridden method.
888              
889             =cut
890              
891             sub mock_default_nlst {
892 1     1 1 4 my ($self, $dir) = @_;
893 1         3 return 1;
894             }
895              
896             =head2 C
897              
898             list.
899             default implementation is 'do nothing'. this method is allowed to be overridden.
900              
901             =cut
902              
903              
904             =head2 C
905              
906             default implementation for list. this method should be used in overridden method.
907              
908             =cut
909              
910             sub mock_default_list {
911 1     1 1 3 my ($self, $dir) = @_;
912 1         3 return 1;
913             }
914              
915             =head2 C
916              
917             retr.
918             default implementation is 'do nothing'. this method is allowed to be overridden.
919              
920             =cut
921              
922              
923             =head2 C
924              
925             default implementation for retr. this method should be used in overridden method.
926              
927             =cut
928              
929             sub mock_default_retr {
930 1     1 1 4 my ($self, $file) = @_;
931 1         3 return 1;
932             }
933              
934             =head2 C
935              
936             stor.
937             default implementation is 'do nothing'. this method is allowed to be overridden.
938              
939             =cut
940              
941              
942             =head2 C
943              
944             default implementation for stor. this method should be used in overridden method.
945              
946             =cut
947              
948             sub mock_default_stor {
949 1     1 1 3 my ($self, $file) = @_;
950 1         2 return 1;
951             }
952              
953             =head2 C
954              
955             stou. currently do_nothing.
956              
957             =cut
958              
959              
960             =head2 C
961              
962             default implementation for stor. this method should be used in overridden method.
963              
964             =cut
965              
966             sub mock_default_stou {
967 1     1 1 4 my ($self, $file) = @_;
968 1         3 return 1;
969             }
970              
971             =head2 C
972              
973             appe.
974             default implementation is 'do nothing'. this method is allowed to be overridden.
975              
976             =cut
977              
978              
979             =head2 C
980              
981             default implementation for appe. this method should be used in overridden method.
982              
983             =cut
984              
985             sub mock_default_appe {
986 1     1 1 4 my ($self, $file) = @_;
987 1         3 return 1;
988             }
989              
990             =head2 C
991              
992             specify data connection to port-mode.
993              
994             after called this method, mock_connection_mode() returns 'port' and
995             mock_port_no() returns specified $port_no.
996              
997             this method is allowed to be overridden.
998              
999             =cut
1000              
1001              
1002             =head2 C
1003              
1004             default implementation for port. this method should be used in overridden method.
1005              
1006             =cut
1007              
1008             sub mock_default_port {
1009 1     1 1 3 my ($self, $port_no) = @_;
1010 1         3 $self->{mock_connection_mode} = 'port';
1011 1         3 $self->{mock_port_no} = $port_no;
1012             }
1013              
1014             =head2 C
1015              
1016             specify data connection to passive-mode.
1017             after called this method, mock_connection_mode() returns 'pasv' and
1018             mock_port_no() returns ''
1019              
1020             this method is allowed to be overridden.
1021              
1022             =cut
1023              
1024              
1025             =head2 C
1026              
1027             default implementation for pasv. this method should be used in overridden method.
1028              
1029             =cut
1030              
1031             sub mock_default_pasv {
1032 1     1 1 3 my ($self) = @_;
1033 1         2 $self->{mock_connection_mode} = 'pasv';
1034 1         3 $self->{mock_port_no} = '';
1035             }
1036              
1037             =head2 C
1038              
1039             pasv_xfer.
1040             default implementation is 'do nothing'. this method is allowed to be overridden.
1041              
1042             =cut
1043              
1044              
1045             =head2 C
1046              
1047             default implementation for psv_xfer. this method should be used in overridden method.
1048              
1049             =cut
1050              
1051             sub mock_default_pasv_xfer {
1052 1     1 1 3 my ($self) = @_;
1053 1         3 return 1;
1054             }
1055              
1056              
1057             =head2 C
1058              
1059             pasv_xfer_unique.
1060             default implementation is 'do nothing'. this method is allowed to be overridden.
1061              
1062             =cut
1063              
1064              
1065             =head2 C
1066              
1067             default implementation for psv_xfer_unique. this method should be used in overridden method.
1068              
1069             =cut
1070              
1071             sub mock_default_pasv_xfer_unique {
1072 1     1 1 3 my ($self) = @_;
1073 1         3 return 1;
1074             }
1075              
1076             =head2 C
1077              
1078             pasv_wait.
1079             default implementation is 'do nothing'. this method is allowed to be overridden.
1080              
1081             =cut
1082              
1083              
1084             =head2 C
1085              
1086             default implementation for pasv_wait. this method should be used in overridden method.
1087              
1088             =cut
1089              
1090             sub mock_default_pasv_wait {
1091 1     1 1 4 my ($self) = @_;
1092 1         2 return 1;
1093             }
1094              
1095              
1096             =head2 C
1097              
1098             abort.
1099             default implementation is 'do nothing'. this method is allowed to be overridden.
1100              
1101             =cut
1102              
1103              
1104             =head2 C
1105              
1106             default implementation for abort. this method should be used in overridden method.
1107              
1108             =cut
1109              
1110             sub mock_default_abort {
1111 0     0 1 0 my ($self) = @_;
1112 0         0 return 1;
1113             }
1114              
1115             =head2 C
1116              
1117             quit.
1118             default implementation is 'do nothing'. this method is allowed to be overridden.
1119              
1120             =cut
1121              
1122              
1123             =head2 C
1124              
1125             default implementation for quit. this method should be used in overridden method.
1126              
1127             =cut
1128              
1129             sub mock_default_quit {
1130 10     10 1 20 my ($self) = @_;
1131 10         19 return 1;
1132             }
1133              
1134              
1135             =head2 C
1136              
1137             quot.
1138             default implementation is 'do nothing'. this method is allowed to be overridden.
1139              
1140             =cut
1141              
1142              
1143             =head2 C
1144              
1145             default implementation for quot. this method should be used in overridden method.
1146              
1147             =cut
1148              
1149             sub mock_default_quot {
1150 1     1 1 3 my ($self) = @_;
1151 1         2 return 1;
1152             }
1153              
1154              
1155             =head2 C
1156              
1157             close connection mock FTP server.
1158             default implementation is 'do nothing'. this method is allowed to be overridden.
1159              
1160             =cut
1161              
1162              
1163             =head2 C
1164              
1165             default implementation for close. this method should be used in overridden method.
1166              
1167             =cut
1168              
1169             sub mock_default_close {
1170 3     3 1 6 my ($self) = @_;
1171 3         11 return 1;
1172             }
1173              
1174             sub _mock_abs2rel {
1175 52     52   118 my ($self, $path) = @_;
1176              
1177 52 100 100     439 if (defined $path && $path =~ /^$self->{mock_server_root}/ ) { #absolute path
1178 6         98 $path =~ s/^$self->{mock_server_root}//;
1179             }
1180 52         146 return $path;
1181             }
1182              
1183             sub _relative_remote {
1184 8     8   17 my ($self, $path) = @_;
1185              
1186 8         19 $path = $self->_mock_abs2rel($path);
1187              
1188 8 100       23 return $self->mock_pwd if !defined $path;
1189 6         18 return catdir($self->mock_pwd, $path);
1190             }
1191              
1192              
1193             sub _abs_remote {
1194 44     44   111 my ($self, $remote_path) = @_;
1195              
1196 44 100       1059 my $remote_dir = dirname($remote_path) eq curdir() ? $self->{mock_cwd} : dirname($remote_path) ;
1197 44         157 $remote_dir = $self->_mock_abs2rel($remote_dir);
1198              
1199 44         2447 return catfile($self->{mock_physical_root}, $remote_dir, basename($remote_path))
1200             }
1201              
1202             sub _abs_local {
1203 25     25   68 my ($self, $local_path) = @_;
1204              
1205 25         48 my $root = rootdir();
1206 25 100       183 return $local_path if ( $local_path =~ m{^$root} );
1207              
1208 22 100       745 my $local_dir = dirname($local_path) eq curdir() ? getcwd() : dirname($local_path);
1209 22         493 return catfile($local_dir, basename($local_path));
1210             }
1211              
1212             =head2 C
1213              
1214             return messages from mock FTP server
1215             this method is allowed to be overridden.
1216              
1217             =cut
1218              
1219             sub message {
1220 51     51 1 236 my ($self) = @_;
1221              
1222 51         147 $self->_push_mock_command_history('message', @_);
1223             # do not clear $self->{message}, that's why this definition is still remain(not in AUTOLOAD)
1224 51 100       153 goto &{ $self->{mock_override}->{message} } if ( exists $self->{mock_override}->{message} );
  2         8  
1225              
1226 49         115 return $self->mock_default_message();
1227             }
1228              
1229             =head2 C
1230              
1231             default implementation for message. this method should be used in overridden method.
1232              
1233             =cut
1234              
1235             sub mock_default_message {
1236 49     49 1 87 my ($self) = @_;
1237 49         181 return $self->{message};
1238             }
1239              
1240             sub _mock_cwd {
1241 153     153   339 my ($self) = @_;
1242 153 50       1453 return (defined $self->{mock_cwd}) ? $self->{mock_cwd} : "";
1243             }
1244              
1245              
1246             sub import {
1247 30     30   6577 my ($package, @args) = @_;
1248 30         10089 for my $arg ( @args ) {
1249 2 50       10 _mock_intercept() if ( $arg eq 'intercept' );
1250             }
1251             }
1252              
1253             sub _mock_intercept {
1254 18     18   10541 use Net::FTP;
  18         1307377  
  18         1076  
1255 18     18   160 no warnings 'redefine';
  18         54  
  18         4421  
1256             *Net::FTP::new = sub {
1257 2     2   1733 my $class = shift;#discard $class
1258 2         17 return Test::Mock::Net::FTP->new(@_);
1259             }
1260 2     2   124 }
1261              
1262       0     sub DESTROY {} #for AUTOLOAD
1263              
1264             sub AUTOLOAD {
1265 260     260   23638 my ($self) = @_;
1266 260         480 my $method = our $AUTOLOAD;
1267 260         1335 $method =~ s/.*:://o;
1268              
1269 260         1817 my @methods = (
1270             'unique_name', 'size', 'mdtm',
1271             'message', 'cwd', 'cdup',
1272             'put', 'append', 'put_unique',
1273             'get', 'rename', 'delete',
1274             'mkdir', 'rmdir', 'port',
1275             'pasv', 'binary', 'ascii',
1276             'quit', 'close', 'abort',
1277             'site', 'hash', 'alloc',
1278             'nlst', 'list', 'retr',
1279             'stou', 'stor', 'appe',
1280             'quot', 'supported', 'authorize',
1281             'feature', 'restart', 'pasv_xfer',
1282             'pasv_xfer_unique', 'pasv_wait', 'ls',
1283             'dir', 'pwd',
1284             );
1285              
1286 260 50       584 if( grep{ $_ eq $method } @methods ) {
  10660         17400  
1287 260         793 $self->_push_mock_command_history($method, @_);
1288 260         521 $self->{message} = '';
1289              
1290 260 100       643 if ( exists $self->{mock_override}->{$method} ) {# override in mock_prepare
1291 125         181 goto &{ $self->{mock_override}->{$method} }
  125         542  
1292             }
1293             else { #not overridden (call default method)
1294 135         202 goto &{ "mock_default_$method" };
  135         789  
1295             }
1296             }
1297             }
1298              
1299             1;
1300              
1301              
1302             =head1 AUTHOR
1303              
1304             Takuya Tsuchida Etsucchi at cpan.orgE
1305              
1306             =head1 SEE ALSO
1307              
1308             L
1309              
1310             =head1 REPOSITORY
1311              
1312             L
1313              
1314              
1315             =head1 COPYRIGHT AND LICENSE
1316              
1317             Copyright (c) 2009-2011 Takuya Tsuchida
1318              
1319             This library is free software; you can redistribute it and/or modify
1320             it under the same terms as Perl itself.
1321              
1322             =cut