1package Net::FTP::Common;
2
3use strict;
4
5use Carp qw(cluck confess);
6use Data::Dumper;
7use Net::FTP;
8
9
10use vars qw(@ISA $VERSION);
11
12@ISA     = qw(Net::FTP);
13
14$VERSION = '7.0.d';
15
16# Preloaded methods go here.
17
18sub new {
19  my $pkg  = shift;
20  my $common_cfg_in = shift;
21  my %netftp_cfg_in = @_;
22
23  my %common_cfg_default =
24    (
25     Host => 'ftp.microsoft.com',
26     RemoteDir  => '/pub',
27#     LocalDir  => '.',   # setup something for $ez->get
28     Type => 'I'
29    );
30
31  my %netftp_cfg_default = ( Debug => 1, Timeout => 240, Passive => 1 );
32
33  # overwrite defaults with values supplied by constructor input
34  @common_cfg_default{keys %$common_cfg_in} = values %$common_cfg_in;
35  @netftp_cfg_default{keys  %netftp_cfg_in} = values  %netftp_cfg_in;
36
37  my $self = {};
38
39  @{$self->{Common}}{keys %common_cfg_default} = values %common_cfg_default;
40  @{$self          }{keys %netftp_cfg_default} = values %netftp_cfg_default;
41
42  my $new_self = { %$self, Common => $self->{Common} } ;
43
44  if (my $file = $self->{Common}{STDERR}) {
45      open DUP, ">$file" or die "cannot dup STDERR to $file: $!";
46      lstat DUP; # kill used only once error
47      open STDERR, ">&DUP";
48  }
49
50  warn "Net::FTP::Common::VERSION = ", $Net::FTP::Common::VERSION
51      if $self->{Debug} ;
52
53
54  bless $new_self, $pkg;
55}
56
57sub config_dump {
58  my $self = shift;
59
60  sprintf '
61Here are the configuration parameters:
62-------------------------------------
63%s
64', Dumper($self);
65
66}
67
68
69sub Common {
70    my $self = shift;
71
72    not (@_ % 2) or die
73"
74Odd number of elements in assignment hash in call to Common().
75Common() is a 'setter' subroutine. You cannot call it with an
76odd number of arguments (e.g. $self->Common('Type') ) and
77expect it to get a value. use GetCommon() for that.
78
79Here is what you passed in.
80", Dumper(\@_);
81
82    my %tmp = @_;
83
84#    warn "HA: ", Dumper(\%tmp,\@_);
85
86    @{$self->{Common}}{keys %tmp} = values %tmp;
87}
88
89sub GetCommon {
90    my ($self,$key) = @_;
91
92    if ($key) {
93	if (defined($self->{Common}{$key})) {
94	    return ($self->{Common}{$key});
95	} else {
96	    return undef;
97	}
98    } else {
99	$self->{Common};
100    }
101}
102
103sub Host {
104    $_[0]->{Common}->{Host}
105
106      or die "Host must be defined when creating a __PACKAGE__ object"
107}
108
109sub NetFTP {
110
111    my ($self, %config) = @_;
112
113    @{$self}{keys %config} = values %config;
114
115}
116
117sub login {
118  my ($self, %config) = @_;
119
120  shift;
121
122  if (@_ % 2) {
123    die sprintf "Do not confuse Net::FTP::Common's login() with Net::FTP's login()
124Net::FTP::Common's login() expects to be supplied a hash.
125E.g. \$ez->login(Host => \$Host)
126
127It was called incorrectly (%s). Program terminating
128%s
129", (join ':', @_), $self->config_dump;
130  }
131
132#  my $ftp_session = Net::FTP->new($self->Host, %{$self->{NetFTP}});
133  my $ftp_session = Net::FTP->new($self->Host, %$self);
134
135#  $ftp_session or return undef;
136  $ftp_session or
137      die sprintf 'FATAL: attempt to create Net::FTP session on host %s failed.
138If you cannot figure out why, supply the configuration parameters when
139emailing the support email list.
140  %s', $self->Host, $self->config_dump;
141
142
143  my $session;
144  my $account = $self->GetCommon('Account');
145  if ($self->GetCommon('User') and $self->GetCommon('Pass')) {
146      $session =
147	  $ftp_session->login($self->GetCommon('User') ,
148			      $self->GetCommon('Pass'),
149			      $account);
150  } else {
151      warn "either User or Pass was not defined. Attempting .netrc for login";
152      $session =
153	  $ftp_session->login;
154  }
155
156  $session and ($self->Common('FTPSession', $ftp_session))
157    and return $ftp_session
158      or
159	warn "error logging in: $!" and return undef;
160
161}
162
163sub ls {
164  my ($self, @config) = @_;
165  my %config=@config;
166
167  my $ftp = $self->prep(%config);
168
169  my $ls = $ftp->ls;
170  if (!defined($ls)) {
171    return ();
172  } else {
173    return @{$ls};
174  }
175}
176
177# contributed by kevin evans
178# this returns a hash of hashes keyed by filename with attributes for each
179sub dir {
180  my ($self, @config) = @_;
181  my %config=@config;
182
183
184  my $ftp = $self->prep(%config);
185
186  my $dir = $ftp->dir;
187  if (!defined($dir)) {
188    return ();
189  } else
190  {
191    my %HoH;
192
193    # Comments were made on this code in this thread:
194    # http://perlmonks.org/index.pl?node_id=287552
195
196    foreach (@{$dir})
197        {
198	    # $_ =~ m#([a-z-]*)\s*([0-9]*)\s*([0-9a-zA-Z]*)\s*([0-9a-zA-Z]*)\s*([0-9]*)\s*([A-Za-z]*)\s*([0-9]*)\s*([0-9A-Za-z:]*)\s*([A-Za-z0-9.-]*)#;
199	  #$_ = m#([a-z-]*)\s*([0-9]*)\s*([0-9a-zA-Z]*)\s*([0-9a-zA-Z]*)\s*([0-9]*)\s*([A-Za-z]*)\s*([0-9]*)\s*([0-9A-Za-z:]*)\s*([\w*\W*\s*\S*]*)#;
200
201=for comment
202
203drwxr-xr-x    8 0        0            4096 Sep 27  2003 .
204drwxr-xr-x    8 0        0            4096 Sep 27  2003 ..
205drwxr-xr-x    3 0        0            4096 Sep 11  2003 .afs
206-rw-r--r--    1 0        0             809 Sep 26  2003 .banner
207----r-xr-x    1 0        0               0 Mar  4  2002 .notar
208-rw-r--r--    1 0        0             796 Sep 27  2003 README
209
210=cut
211
212	  warn "input-line: $_" if $self->{Debug} ;
213
214	  $_ =~ m!^
215	    ([\-FlrwxsStTdD]{10})  # directory and permissions
216	    \s+
217	    (\d+)                  # inode
218	    \s+
219	    (\w+)                  # 2nd number
220	    \s+
221	    (\w+)                  # 3rd number
222	    \s+
223	    (\d+)                  # file/dir size
224	    \s+
225	    (\w{3,4})         # month
226	    \s+
227	    (\d{1,2})         # day
228	    \s+
229	    (\d{1,2}:\d{2}|\d{4})           # year
230	    \s+
231		(.+) # filename
232		  $!x;
233
234
235        my $perm = $1;
236        my $inode = $2;
237        my $owner = $3;
238        my $group = $4;
239        my $size = $5;
240        my $month = $6;
241        my $day = $7;
242        my $yearOrTime = $8;
243        my $name = $9;
244        my $linkTarget;
245
246	  warn "
247        my $perm = $1;
248        my $inode = $2;
249        my $owner = $3;
250        my $group = $4;
251        my $size = $5;
252        my $month = $6;
253        my $day = $7;
254        my $yearOrTime = $8;
255        my $name = $9;
256        my $linkTarget;
257" if $self->{Debug} ;
258
259        if ( $' =~ m#\s*->\s*([A-Za-z0-9.-/]*)# )       # it's a symlink
260                { $linkTarget = $1; }
261
262        $HoH{$name}{perm} = $perm;
263        $HoH{$name}{inode} = $inode;
264        $HoH{$name}{owner} = $owner;
265        $HoH{$name}{group} = $group;
266        $HoH{$name}{size} = $size;
267        $HoH{$name}{month} = $month;
268        $HoH{$name}{day} = $day;
269        $HoH{$name}{yearOrTime} =  $yearOrTime;
270        $HoH{$name}{linkTarget} = $linkTarget;
271
272	  warn "regexp-matches for ($name): ", Dumper(\$HoH{$name}) if $self->{Debug} ;
273
274        }
275  return(%HoH);
276  }
277}
278
279
280
281sub mkdir {
282    my ($self,%config) = @_;
283
284    my $ftp = $self->prep(%config);
285    my $rd =  $self->GetCommon('RemoteDir');
286    my $r  =  $self->GetCommon('Recurse');
287    $ftp->mkdir($rd, $r);
288}
289
290
291sub exists {
292    my ($self,%cfg) = @_;
293
294    my @listing = $self->ls(%cfg);
295
296    my $rf = $self->GetCommon('RemoteFile');
297
298   warn sprintf "[checking @listing for [%s]]", $rf if $self->{Debug} ;
299
300    scalar grep { $_ eq $self->GetCommon('RemoteFile') } @listing;
301}
302
303sub delete {
304    my ($self,%cfg) = @_;
305
306    my $ftp = $self->prep(%cfg);
307    my $rf  = $self->GetCommon('RemoteFile');
308
309
310    warn Dumper \%cfg if $self->{Debug} ;
311
312    $ftp->delete($rf);
313
314}
315
316sub grep {
317
318    my ($self,%cfg) = @_;
319
320#    warn sprintf "self: %s host: %s cfg: %s", $self, $host, Data::Dumper::Dumper(\%cfg);
321
322    my @listing = $self->ls(%cfg);
323
324    grep { $_ =~ /$cfg{Grep}/ } @listing;
325}
326
327sub connected {
328    my $self = shift;
329
330#    warn "CONNECTED SELF ", Dumper($self);
331
332    my $session = $self->GetCommon('FTPSession') or return 0;
333
334    local $@;
335    my $pwd;
336    my $connected = $session->pwd ? 1 : 0;
337#    warn "connected: $connected RESP: $connected";
338    $connected;
339}
340
341sub quit {
342    my $self = shift;
343
344    $self->connected and $self->GetCommon('FTPSession')->quit;
345
346}
347
348
349sub prepped {
350    my $self = shift;
351    my $prepped = $self->GetCommon('FTPSession') and $self->connected;
352    #    warn "prepped: $prepped";
353    $prepped;
354}
355
356sub prep {
357  my $self = shift;
358  my %cfg  = @_;
359
360  $self->Common(%cfg);
361
362# This will not work if the Host changes and you are still connected
363# to the prior host. It might be wise to simply drop connection
364# if the Host key changes, but I don't think I will go there right now.
365#  my $ftp = $self->connected
366#                  ? $self->GetCommon('FTPSession')
367#                  : $self->login ;
368# So instead:
369  my $ftp = $self->login ;
370
371
372  $self->Common(LocalDir => '.') unless
373      $self->GetCommon('LocalDir') ;
374
375  if ($self->{Common}->{RemoteDir}) {
376      $ftp->cwd($self->GetCommon('RemoteDir'))
377  } else {
378      warn "RemoteDir not configured. ftp->cwd will not work. certain Net::FTP usages will failed.";
379  }
380  $ftp->type($self->GetCommon('Type'));
381
382  $ftp;
383}
384
385sub binary {
386    my $self = shift;
387
388    $self->{Common}{Type} = 'I';
389}
390
391sub ascii {
392    my $self = shift;
393
394    $self->{Common}{Type} = 'A';
395}
396
397sub get {
398
399  my ($self,%cfg) = @_;
400
401  my $ftp = $self->prep(%cfg);
402
403  my $r;
404
405  my $file;
406
407  if ($self->GetCommon('LocalFile')) {
408    $file= $self->GetCommon('LocalFile');
409  } else {
410    $file=$self->GetCommon('RemoteFile');
411  }
412
413  my $local_file = join '/', ($self->GetCommon('LocalDir'), $file);
414
415  #  warn "LF: $local_file ", "D: ", Dumper($self);
416
417
418  if ($r = $ftp->get($self->GetCommon('RemoteFile'), $local_file)) {
419    return $r;
420  } else {
421    warn sprintf 'download of %s to %s failed',
422	$self->GetCommon('RemoteFile'), $self->GetCommon('LocalFile');
423    warn
424	'here are the settings in your Net::FTP::Common object: %s',
425	    Dumper($self);
426    return undef;
427  }
428
429
430}
431
432sub file_attr {
433    my $self = shift;
434    my %hash;
435    my @key = qw(LocalFile LocalDir RemoteFile RemoteDir);
436    @hash{@key} = @{$self->{Common}}{@key};
437    %hash;
438}
439
440sub bad_filename {
441    shift =~ /[\r\n]/s;
442}
443
444sub send {
445  my ($self,%cfg) = @_;
446
447  my $ftp = $self->prep(%cfg);
448
449  #  warn "send_self", Dumper($self);
450
451  my %fa = $self->file_attr;
452
453  if (bad_filename($fa{LocalFile})) {
454      warn "filenames may not have CRLF in them. skipping $fa{LocalFile}";
455      return;
456  }
457
458  warn "send_fa: ", Dumper(\%fa) if $self->{Debug} ;
459
460
461  my $lf = sprintf "%s/%s", $fa{LocalDir}, $fa{LocalFile};
462  my $RF = $fa{RemoteFile} ? $fa{RemoteFile} : $fa{LocalFile};
463  my $rf = sprintf "%s/%s", $fa{RemoteDir}, $RF;
464
465  warn "[upload $lf as $rf]" if $self->{Debug} ;
466
467  $ftp->put($lf, $RF) or
468      confess sprintf "upload of %s to %s failed", $lf, $rf;
469}
470
471sub put { goto &send }
472
473sub DESTROY {
474
475
476}
477
478
4791;
480__END__
481
482