lib/Net/FTP/RetrHandle.pm

   1 package Net::FTP::RetrHandle;
   2 our $VERSION = '0.2';
   3
   4 use warnings;
   5 use strict;
   6
   7 use constant DEFAULT_MAX_SKIPSIZE => 1024 * 1024 * 2;
   8 use constant DEFAULT_BLOCKSIZE => 10240; # Net::FTP's default
   9
  10 use base 'IO::Seekable';
  11 # We don't use base 'IO::Handle'; it currently confuses Archive::Zip.
  12
  13 use Carp;
  14 use Scalar::Util;
  15
  16
  17 =head1 NAME
  18
  19 Net::FTP::RetrHandle - Tied or IO::Handle-compatible interface to a file retrieved by FTP
  20
  21 =head1 SYNOPSIS
  22
  23 Provides a file reading interface for reading all or parts of files
  24 located on a remote FTP server, including emulation of C<seek> and
  25 support for downloading only the parts of the file requested.
  26
  27 =head1 DESCRIPTION
  28
  29 Support for skipping the beginning of the file is implemented with the
  30 FTP C<REST> command, which starts a retrieval at any point in the
  31 file.  Support for skipping the end of the file is implemented with
  32 the FTP C<ABOR> command, which stops the transfer.  With these two
  33 commands and some careful tracking of the current file position, we're
  34 able to reliably emulate a C<seek/read> pair, and get only the parts
  35 of the file that are actually read.
  36
  37 This was originally designed for use with
  38 L<Archive::Zip|Archive::Zip>; it's reliable enough that the table of
  39 contents and individual files can be extracted from a remote ZIP
  40 archive without downloading the whole thing.  See L<EXAMPLES> below.
  41
  42 An interface compatible with L<IO::Handle|IO::Handle> is provided,
  43 along with a C<tie>-based interface.
  44
  45 Remember that an FTP server can only do one thing at a time, so make
  46 sure to C<close> your connection before asking the FTP server to do
  47 nything else.
  48
  49 =head1 CONSTRUCTOR
  50
  51 =head2 new ( $ftp, $filename, options... )
  52
  53 Creates a new L<IO::Handle|IO::Handle>-compatible object to fetch all
  54 or parts of C<$filename> using the FTP connection C<$ftp>.
  55
  56 Available options:
  57
  58 =over 4
  59
  60 =item MaxSkipSize => $size
  61
  62 If we need to move forward in a file or close the connection,
  63 sometimes it's faster to just read the bytes we don't need than to
  64 abort the connection and restart. This setting tells how many
  65 unnecessary bytes we're willing to read rather than abort.  An
  66 appropriate setting depends on the speed of transferring files and the
  67 speed of reconnecting to the server.
  68
  69 =item BlockSize => $size
  70
  71 When doing buffered reads, how many bytes to read at once.  The
  72 default is the same as the default for L<Net::FTP|Net::FTP>, so it's
  73 generally best to leave it alone.
  74
  75 =item AlreadyBinary => $bool
  76
  77 If set to a true value, we assume the server is already in binary
  78 mode, and don't try to set it.
  79
  80 =back
  81
  82 =cut
  83 use constant USAGE => "Usage: Net::FTP::RetrHandle\->new(ftp => \$ftp_obj, filename => \$filename)\n";
  84 sub new
  85 {
  86   my $class = shift;
  87   my $ftp = shift
  88     or croak USAGE;
  89   my $filename = shift
  90     or croak USAGE;
  91   my $self = { MaxSkipSize => DEFAULT_MAX_SKIPSIZE,
  92                BlockSize => DEFAULT_BLOCKSIZE,
  93                @_,
  94                ftp => $ftp, filename => $filename,
  95                pos => 0, nextpos => 0};
  96   $self->{size} = $self->{ftp}->size($self->{filename})
  97     or return undef;
  98   $self->{ftp}->binary()
  99     unless ($self->{AlreadyBinary});
 100
 101   bless $self,$class;
 102 }
 103
 104 =head1 METHODS
 105
 106 Most of the methods implemented behave exactly like those from
 107 L<IO::Handle|IO::Handle>.
 108
 109 These methods are implemented: C<binmode>, C<clearerr>, C<close>, C<eof>,
 110 C<error>, C<getc>, C<getline>, C<getlines>, C<getpos>, C<read>,
 111 C<seek>, C<setpos>, C<sysseek>, C<tell>, C<ungetc>, C<opened>.
 112
 113 =cut ;
 114
 115 sub opened { 1; }
 116
 117 sub seek
 118 {
 119   my $self = shift;
 120   my $pos = shift || 0;
 121   my $whence = shift || 0;
 122   warn "   SEEK: self=$self, pos=$pos, whence=$whence\n"
 123     if ($ENV{DEBUG});
 124   my $curpos = $self->tell();
 125   my $newpos = _newpos($self->tell(),$self->{size},$pos,$whence);
 126   my $ret;
 127   if ($newpos == $curpos)
 128   {
 129     return $curpos;
 130   }
 131   elsif (defined($self->{_buf}) and ($newpos > $curpos) and ($newpos < ($curpos + length($self->{_buf}))))
 132   {
 133     # Just seeking within the buffer (or not at all)
 134     substr($self->{_buf},0,$newpos - $curpos,'');
 135     $ret = $newpos;
 136   }
 137   else
 138   {
 139     $ret = $self->sysseek($newpos,0);
 140     $self->{_buf} = '';
 141   }
 142   return $ret;
 143 }
 144
 145 sub _newpos
 146 {
 147
 148   my($curpos,$size,$pos,$whence)=@_;
 149   if ($whence == 0) # seek_set
 150   {
 151     return $pos;
 152   }
 153   elsif ($whence == 1) # seek_cur
 154   {
 155     return $curpos + $pos;
 156   }
 157   elsif ($whence == 2) # seek_end
 158   {
 159     return $size + $pos;
 160   }
 161   else
 162   {
 163     die "Invalid value $whence for whence!";
 164   }
 165 }
 166
 167 sub sysseek
 168 {
 169   my $self = shift;
 170   my $pos = shift || 0;
 171   my $whence = shift || 0;
 172   warn "SYSSEEK: self=$self, pos=$pos, whence=$whence\n"
 173     if ($ENV{DEBUG});
 174   my $newpos = _newpos($self->{nextpos},$self->{size},$pos,$whence);
 175
 176   $self->{eof}=undef;
 177   return $self->{nextpos}=$newpos;
 178 }
 179
 180 sub tell
 181 {
 182   my $self = shift;
 183   return $self->{nextpos} - (defined($self->{_buf}) ? length($self->{_buf}) : 0);
 184 }
 185
 186 # WARNING: ASCII mode probably breaks seek.
 187 sub binmode
 188 {
 189   my $self = shift;
 190   my $mode = shift || ':raw';
 191   return if (defined($self->{curmode}) && ($self->{curmode} eq $mode));
 192   if (defined($mode) and $mode eq ':crlf')
 193   {
 194     $self->_finish_connection();
 195     $self->{ftp}->ascii()
 196       or return $self->seterr();
 197   }
 198   else
 199   {
 200     $self->_finish_connection();
 201     $self->{ftp}->binary()
 202       or return $self->seterr();
 203   }
 204   $self->{curmode} = $mode;
 205 }
 206
 207 sub _min
 208 {
 209   return $_[0] < $_[1] ? $_[0] : $_[1];
 210 }
 211
 212 sub _max
 213 {
 214   return $_[0] > $_[1] ? $_[0] : $_[1];
 215 }
 216
 217 sub read
 218 {
 219   my $self = shift;
 220 #  return $self->sysread(@_);
 221
 222   my(undef,$len,$offset)=@_;
 223   $offset ||= 0;
 224   warn "READ(buf,$len,$offset)\n"
 225     if ($ENV{DEBUG});
 226
 227   if (!defined($self->{_buf}) || length($self->{_buf}) <= 0)
 228   {
 229     $self->sysread($self->{_buf},_max($len,$self->{BlockSize}))
 230       or return 0;
 231   }
 232   elsif (length($self->{_buf}) < $len)
 233   {
 234     $self->sysread($self->{_buf},_max($len-length($self->{_buf}),$self->{BlockSize}),length($self->{_buf}));
 235   }
 236   my $ret = _min($len,length($self->{_buf}));
 237   if (!defined($_[0])) { $_[0] = '' }
 238   substr($_[0],$offset) = substr($self->{_buf},0,$len,'');
 239   $self->{read_count}++;
 240
 241   return $ret;
 242 }
 243
 244 sub sysread
 245 {
 246   my $self = shift;
 247   if ($self->{eof})
 248   {
 249     return 0;
 250   }
 251
 252   my(undef,$len,$offset) = @_;
 253   $offset ||= 0;
 254
 255   warn "SYSREAD(buf,$len,$offset)\n"
 256     if ($ENV{DEBUG});
 257   if ($self->{nextpos} >= $self->{size})
 258   {
 259     $self->{eof} = 1;
 260     $self->{pos} = $self->{nextpos};
 261     return 0;
 262   }
 263
 264   if ($self->{pos} != $self->{nextpos})
 265   {
 266     # They seeked.
 267     if ($self->{ftp_running})
 268     {
 269       warn "Seek detected, nextpos=$self->{nextpos}, pos=$self->{pos}, MaxSkipSize=$self->{MaxSkipSize}\n"
 270         if ($ENV{DEBUG});
 271       if ($self->{nextpos} > $self->{pos} and ($self->{nextpos} - $self->{pos}) < $self->{MaxSkipSize})
 272       {
 273         my $br = $self->{nextpos}-$self->{pos};
 274         warn "Reading $br bytes to skip ahead\n"
 275           if ($ENV{DEBUG});
 276         my $junkbuff;
 277         while ($br > 0)
 278         {
 279           warn "Trying to read $br more bytes\n"
 280             if ($ENV{DEBUG});
 281           my $b = $self->{ftp_data}->read($junkbuff,$br);
 282           if ($b == 0)
 283           {
 284             $self->_at_eof();
 285             return 0;
 286           }
 287           elsif (!defined($b) || $b < 0)
 288           {
 289             return $self->seterr();
 290           }
 291           else
 292           {
 293             $br -= $b;
 294           }
 295         }
 296         $self->{pos}=$self->{nextpos};
 297       }
 298       else
 299       {
 300         warn "Aborting connection to move to new position\n"
 301           if ($ENV{DEBUG});
 302         $self->_finish_connection();
 303       }
 304     }
 305   }
 306
 307   if (!$self->{ftp_running})
 308   {
 309     $self->{ftp}->restart($self->{nextpos});
 310     $self->{ftp_data} = $self->{ftp}->retr($self->{filename})
 311       or return $self->seterr();
 312     $self->{ftp_running} = 1;
 313     $self->{pos}=$self->{nextpos};
 314   }
 315
 316   my $tmpbuf;
 317   my $rb = $self->{ftp_data}->read($tmpbuf,$len);
 318   if ($rb == 0)
 319   {
 320     $self->_at_eof();
 321     return 0;
 322   }
 323   elsif (!defined($rb) || $rb < 0)
 324   {
 325     return $self->seterr();
 326   }
 327
 328   if (!defined($_[0])) { $_[0] = '' }
 329   substr($_[0],$offset) = $tmpbuf;
 330   $self->{pos} += $rb;
 331   $self->{nextpos} += $rb;
 332
 333   $self->{sysread_count}++;
 334   $rb;
 335 }
 336
 337 sub _at_eof
 338 {
 339   my $self = shift;
 340   $self->{eof}=1;
 341   $self->_finish_connection();
 342 #  $self->{ftp_data}->_close();
 343   $self->{ftp_running} = $self->{ftp_data} = undef;
 344 }
 345
 346 sub _finish_connection
 347 {
 348   my $self = shift;
 349   warn "_finish_connection\n"
 350     if ($ENV{DEBUG});
 351   return unless ($self->{ftp_running});
 352
 353   if ($self->{size} - $self->{pos} < $self->{MaxSkipSize})
 354   {
 355     warn "Skipping " . ($self->{size}-$self->{pos}) . " bytes\n"
 356       if ($ENV{DEBUG});
 357     my $junkbuff;
 358     my $br;
 359     while(($br = $self->{ftp_data}->read($junkbuff,8192)))
 360     {
 361       # Read until EOF or error
 362     }
 363     defined($br)
 364       or $self->seterr();
 365   }
 366   warn "Shutting down existing FTP DATA session...\n"
 367     if ($ENV{DEBUG});
 368
 369   my $closeret;
 370   {
 371     eval {
 372       $closeret = $self->{ftp_data}->close();
 373     };
 374     # Work around a timeout bug in Net::FTP
 375     if ($@ && $@ =~ /^Timeout /)
 376     {
 377       warn "Timeout closing connection, retrying...\n"
 378         if ($ENV{DEBUG});
 379       select(undef,undef,undef,1);
 380       redo;
 381     }
 382   }
 383
 384   $self->{ftp_running} = $self->{ftp_data} = undef;
 385   return $closeret ? 1 : $self->seterr();
 386 }
 387
 388 sub write
 389 {
 390   die "Only reading currently supported";
 391 }
 392
 393 sub close
 394 {
 395   my $self = shift;
 396   return $self->{ftp_data} ? $self->_finish_connection()
 397                            : 1;
 398 }
 399
 400 sub eof
 401 {
 402   my $self = shift;
 403   if ($self->{eof})
 404   {
 405     return 1;
 406   }
 407
 408   my $c = $self->getc;
 409   if (!defined($c))
 410   {
 411     return 1;
 412   }
 413   $self->ungetc(ord($c));
 414   return undef;
 415 }
 416
 417 sub getc
 418 {
 419   my $self = shift;
 420   my $c;
 421   my $rb = $self->read($c,1);
 422   if ($rb < 1)
 423   {
 424     return undef;
 425   }
 426   return $c;
 427 }
 428
 429 sub ungetc
 430 {
 431   my $self = shift;
 432   # Note that $c is the ordinal value of a character, not the
 433   # character itself (for some reason)
 434   my($c)=@_;
 435   $self->{_buf} = chr($c) . $self->{_buf};
 436 }
 437
 438 sub getline
 439 {
 440   my $self = shift;
 441   if (!defined($/))
 442   {
 443     my $buf;
 444     while($self->read($buf,$self->{BlockSize},length($buf)) > 0)
 445     {
 446       # Keep going
 447     }
 448     return $buf;
 449   }
 450   elsif (ref($/) && looks_like_number ${$/} )
 451   {
 452     my $buf;
 453     $self->read($buf,${$/})
 454       or return undef;
 455     return $buf;
 456   }
 457
 458   my $rs;
 459   if ($/ eq '')
 460   {
 461     $rs = "\n\n";
 462   }
 463   else
 464   {
 465     $rs = $/;
 466   }
 467   my $eol;
 468   if (!defined($self->{_buf})) { $self->{_buf} = '' }
 469   while (($eol=index($self->{_buf},$rs)) < $[)
 470   {
 471     if ($self->{eof})
 472     {
 473       # return what's left
 474       if (length($self->{_buf}) == 0)
 475       {
 476         return undef;
 477       }
 478       else
 479       {
 480         return substr($self->{_buf},0,length($self->{_buf}),'');
 481       }
 482     }
 483     else
 484     {
 485       $self->sysread($self->{_buf},$self->{BlockSize},length($self->{_buf}));
 486     }
 487   }
 488   # OK, we should have a match.
 489   my $tmpbuf = substr($self->{_buf},0,$eol+length($rs),'');
 490   while ($/ eq '' and substr($self->{_buf},0,1) eq "\n")
 491   {
 492     substr($self->{_buf},0,1)='';
 493   }
 494   return $tmpbuf;
 495 }
 496
 497 sub getlines
 498 {
 499   my $self = shift;
 500   my @lines;
 501   my $line;
 502   while (defined($line = $self->getline()))
 503   {
 504     push(@lines,$line);
 505   }
 506   @lines;
 507 }
 508
 509 sub error
 510 {
 511   return undef;
 512 }
 513
 514 sub seterr
 515 {
 516   my $self = shift;
 517   $self->{_error} = 1;
 518   return undef;
 519 }
 520
 521 sub clearerr
 522 {
 523   my $self = shift;
 524   $self->{_error} = undef;
 525   return 0;
 526 }
 527
 528 sub getpos
 529 {
 530   my $self = shift;
 531   return $self->tell();
 532 }
 533
 534 sub setpos
 535 {
 536   my $self = shift;
 537   return $self->seek(@_);
 538 }
 539
 540 sub DESTROY
 541 {
 542   my $self = shift;
 543   if (UNIVERSAL::isa($self,'GLOB'))
 544   {
 545     $self = tied *$self
 546         or die "$self not tied?...";
 547   }
 548   if ($self->{ftp_data})
 549   {
 550     $self->_finish_connection();
 551   }
 552   warn "sysread called ".$self->{sysread_count}." times.\n"
 553     if ($ENV{DEBUG});
 554 }
 555
 556 =head1 TIED INTERFACE
 557
 558 Instead of a L<IO::Handle|IO::Handle>-compatible interface, you can
 559 use a C<tie>-based interface to use the standard Perl I/O operators.
 560 You can use it like this:
 561
 562   use Net::FTP::RetrHandle;
 563   # Create FTP object in $ftp
 564   # Store filename in $filename
 565   tie *FH, 'Net::FTP::RetrHandle', $ftp, $filename
 566     or die "Error in tie!\n";
 567
 568 =cut
 569   ;
 570 sub TIEHANDLE
 571 {
 572   my $class = shift;
 573   my $obj = $class->new(@_);
 574   $obj;
 575 }
 576
 577 sub READ
 578 {
 579   my $self = shift;
 580   $self->read(@_);
 581 }
 582
 583 sub READLINE
 584 {
 585   my $self = shift;
 586   return wantarray ? $self->getlines(@_)
 587                    : $self->getline(@_);
 588 }
 589
 590 sub GETC
 591 {
 592   my $self = shift;
 593   return $self->getc(@_);
 594 }
 595
 596 sub SEEK
 597 {
 598   my $self = shift;
 599   return $self->seek(@_);
 600 }
 601
 602 sub SYSSEEK
 603 {
 604   my $self = shift;
 605   return $self->sysseek(@_);
 606 }
 607
 608 sub TELL
 609 {
 610   my $self = shift;
 611   return $self->tell();
 612 }
 613
 614 sub CLOSE
 615 {
 616   my $self = shift;
 617   return $self->close(@_);
 618 }
 619
 620 sub EOF
 621 {
 622   my $self = shift;
 623   return $self->eof(@_);
 624
 625 }
 626 sub UNTIE
 627 {
 628   tied($_[0])->close(@_);
 629 }
 630
 631 =head1 EXAMPLE
 632
 633 Here's an example of listing a Zip file without downloading the whole
 634 thing:
 635
 636     #!/usr/bin/perl
 637
 638     use warnings;
 639     use strict;
 640
 641     use Net::FTP;
 642     use Net::FTP::AutoReconnect;
 643     use Net::FTP::RetrHandle;
 644     use Archive::Zip;
 645
 646     my $ftp = Net::FTP::AutoReconnect->new("ftp.info-zip.com", Debug => $ENV{DEBUG})
 647         or die "connect error\n";
 648     $ftp->login('anonymous','example@example.com')
 649         or die "login error\n";
 650     $ftp->cwd('/pub/infozip/UNIX/LINUX')
 651         or die "cwd error\n";
 652     my $fh = Net::FTP::RetrHandle->new($ftp,'unz551x-glibc.zip')
 653         or die "Couldn't get handle to remote file\n";
 654     my $zip = Archive::Zip->new($fh)
 655         or die "Couldn't create Zip object\n";
 656     foreach my $fn ($zip->memberNames())
 657     {
 658       print "unz551-glibc.zip: $fn\n";
 659     }
 660
 661
 662 =head1 AUTHOR
 663
 664 Scott Gifford <sgifford@suspectclass.com>
 665
 666 =head1 BUGS
 667
 668 The distinction between tied filehandles and C<IO::Handle>-compatible
 669 filehandles should be blurrier.  It seems like other file handle
 670 objects you can freely mix method calls and traditional Perl
 671 operations, but I can't figure out how to do it.
 672
 673 Many FTP servers don't like frequent connection aborts.  If that's the
 674 case, try L<Net::FTP::AutoReconnect>, which will hide much of that
 675 from you.
 676
 677 If the filehandle is tied and created with C<gensym>, C<readline>
 678 doesn't work with older versions of Perl.  No idea why.
 679
 680 =head1 SEE ALSO
 681
 682 L<Net::FTP>, L<Net::FTP::AutoReconnect>, L<IO::Handle>.
 683
 684 =head1 COPYRIGHT
 685
 686 Copyright (c) 2006 Scott Gifford. All rights reserved.  This program
 687 is free software; you can redistribute it and/or modify it under the
 688 same terms as Perl itself.
 689
 690 =cut
 691
 692 1;