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