is a high-performance, enterprise-grade system for backing up Linux and WinXX PCs and laptops to a server’s disk (http/cgi user interface).
| RetrHandle.pm (BackupPC-4.3.2) | : | RetrHandle.pm (BackupPC-4.4.0) |
|---|
| package Net::FTP::RetrHandle; | | package Net::FTP::RetrHandle; |
|
| | |
| our $VERSION = '0.2'; | | our $VERSION = '0.2'; |
| | |
| use warnings; | | use warnings; |
| use strict; | | use strict; |
| | |
| use constant DEFAULT_MAX_SKIPSIZE => 1024 * 1024 * 2; | | use constant DEFAULT_MAX_SKIPSIZE => 1024 * 1024 * 2; |
|
| use constant DEFAULT_BLOCKSIZE => 10240; # Net::FTP's default | | use constant DEFAULT_BLOCKSIZE => 10240; # Net::FTP's default |
| | |
| use base 'IO::Seekable'; | | use base 'IO::Seekable'; |
|
| | |
| # We don't use base 'IO::Handle'; it currently confuses Archive::Zip. | | # We don't use base 'IO::Handle'; it currently confuses Archive::Zip. |
| | |
| use Carp; | | use Carp; |
| use Scalar::Util; | | use Scalar::Util; |
| | |
| =head1 NAME | | =head1 NAME |
| | |
| Net::FTP::RetrHandle - Tied or IO::Handle-compatible interface to a file retriev
ed by FTP | | Net::FTP::RetrHandle - Tied or IO::Handle-compatible interface to a file retriev
ed by FTP |
| | |
| =head1 SYNOPSIS | | =head1 SYNOPSIS |
| | |
| skipping to change at line 82 | | skipping to change at line 84 |
|---|
| generally best to leave it alone. | | generally best to leave it alone. |
| | |
| =item AlreadyBinary => $bool | | =item AlreadyBinary => $bool |
| | |
| If set to a true value, we assume the server is already in binary | | If set to a true value, we assume the server is already in binary |
| mode, and don't try to set it. | | mode, and don't try to set it. |
| | |
| =back | | =back |
| | |
| =cut | | =cut |
|
| | |
| use constant USAGE => "Usage: Net::FTP::RetrHandle\->new(ftp => \$ftp_obj, filen
ame => \$filename)\n"; | | use constant USAGE => "Usage: Net::FTP::RetrHandle\->new(ftp => \$ftp_obj, filen
ame => \$filename)\n"; |
|
| | |
| sub new | | sub new |
| { | | { |
|
| my $class = shift; | | my $class = shift; |
| my $ftp = shift | | my $ftp = shift |
| or croak USAGE; | | or croak USAGE; |
| my $filename = shift | | my $filename = shift |
| or croak USAGE; | | or croak USAGE; |
| my $self = { MaxSkipSize => DEFAULT_MAX_SKIPSIZE, | | my $self = { |
| BlockSize => DEFAULT_BLOCKSIZE, | | MaxSkipSize => DEFAULT_MAX_SKIPSIZE, |
| @_, | | BlockSize => DEFAULT_BLOCKSIZE, |
| ftp => $ftp, filename => $filename, | | @_, |
| pos => 0, nextpos => 0}; | | ftp => $ftp, |
| $self->{size} = $self->{ftp}->size($self->{filename}) | | filename => $filename, |
| or return undef; | | pos => 0, |
| $self->{ftp}->binary() | | nextpos => 0 |
| unless ($self->{AlreadyBinary}); | | }; |
| | $self->{size} = $self->{ftp}->size($self->{filename}) |
| | or return undef; |
| | $self->{ftp}->binary() |
| | unless ( $self->{AlreadyBinary} ); |
| | |
|
| bless $self,$class; | | bless $self, $class; |
| } | | } |
| | |
| =head1 METHODS | | =head1 METHODS |
| | |
| Most of the methods implemented behave exactly like those from | | Most of the methods implemented behave exactly like those from |
| L<IO::Handle|IO::Handle>. | | L<IO::Handle|IO::Handle>. |
| | |
| These methods are implemented: C<binmode>, C<clearerr>, C<close>, C<eof>, | | These methods are implemented: C<binmode>, C<clearerr>, C<close>, C<eof>, |
| C<error>, C<getc>, C<getline>, C<getlines>, C<getpos>, C<read>, | | C<error>, C<getc>, C<getline>, C<getlines>, C<getpos>, C<read>, |
| C<seek>, C<setpos>, C<sysseek>, C<tell>, C<ungetc>, C<opened>. | | C<seek>, C<setpos>, C<sysseek>, C<tell>, C<ungetc>, C<opened>. |
| | |
| =cut ; | | =cut ; |
| | |
| sub opened { 1; } | | sub opened { 1; } |
| | |
| sub seek | | sub seek |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| my $pos = shift || 0; | | my $pos = shift || 0; |
| my $whence = shift || 0; | | my $whence = shift || 0; |
| warn " SEEK: self=$self, pos=$pos, whence=$whence\n" | | warn " SEEK: self=$self, pos=$pos, whence=$whence\n" |
| if ($ENV{DEBUG}); | | if ( $ENV{DEBUG} ); |
| my $curpos = $self->tell(); | | my $curpos = $self->tell(); |
| my $newpos = _newpos($self->tell(),$self->{size},$pos,$whence); | | my $newpos = _newpos($self->tell(), $self->{size}, $pos, $whence); |
| my $ret; | | my $ret; |
| if ($newpos == $curpos) | | if ( $newpos == $curpos ) { |
| { | | return $curpos; |
| return $curpos; | | } elsif ( defined($self->{_buf}) and ($newpos > $curpos) and ($newpos < ($cu |
| } | | rpos + length($self->{_buf}))) ) { |
| elsif (defined($self->{_buf}) and ($newpos > $curpos) and ($newpos < ($curpos | | |
| + length($self->{_buf})))) | | # Just seeking within the buffer (or not at all) |
| { | | substr($self->{_buf}, 0, $newpos - $curpos, ''); |
| # Just seeking within the buffer (or not at all) | | $ret = $newpos; |
| substr($self->{_buf},0,$newpos - $curpos,''); | | } else { |
| $ret = $newpos; | | $ret = $self->sysseek($newpos, 0); |
| } | | $self->{_buf} = ''; |
| else | | } |
| { | | return $ret; |
| $ret = $self->sysseek($newpos,0); | | |
| $self->{_buf} = ''; | | |
| } | | |
| return $ret; | | |
| } | | } |
| | |
| sub _newpos | | sub _newpos |
| { | | { |
|
| | | my($curpos, $size, $pos, $whence) = @_; |
| my($curpos,$size,$pos,$whence)=@_; | | if ( $whence == 0 ) # seek_set |
| if ($whence == 0) # seek_set | | { |
| { | | return $pos; |
| return $pos; | | } elsif ( $whence == 1 ) # seek_cur |
| } | | { |
| elsif ($whence == 1) # seek_cur | | return $curpos + $pos; |
| { | | } elsif ( $whence == 2 ) # seek_end |
| return $curpos + $pos; | | { |
| } | | return $size + $pos; |
| elsif ($whence == 2) # seek_end | | } else { |
| { | | die "Invalid value $whence for whence!"; |
| return $size + $pos; | | } |
| } | | |
| else | | |
| { | | |
| die "Invalid value $whence for whence!"; | | |
| } | | |
| } | | } |
| | |
| sub sysseek | | sub sysseek |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| my $pos = shift || 0; | | my $pos = shift || 0; |
| my $whence = shift || 0; | | my $whence = shift || 0; |
| warn "SYSSEEK: self=$self, pos=$pos, whence=$whence\n" | | warn "SYSSEEK: self=$self, pos=$pos, whence=$whence\n" |
| if ($ENV{DEBUG}); | | if ( $ENV{DEBUG} ); |
| my $newpos = _newpos($self->{nextpos},$self->{size},$pos,$whence); | | my $newpos = _newpos($self->{nextpos}, $self->{size}, $pos, $whence); |
| | |
|
| $self->{eof}=undef; | | $self->{eof} = undef; |
| return $self->{nextpos}=$newpos; | | return $self->{nextpos} = $newpos; |
| } | | } |
| | |
| sub tell | | sub tell |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| return $self->{nextpos} - (defined($self->{_buf}) ? length($self->{_buf}) : 0) | | return $self->{nextpos} - (defined($self->{_buf}) ? length($self->{_buf}) : |
| ; | | 0); |
| } | | } |
| | |
| # WARNING: ASCII mode probably breaks seek. | | # WARNING: ASCII mode probably breaks seek. |
| sub binmode | | sub binmode |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| my $mode = shift || ':raw'; | | my $mode = shift || ':raw'; |
| return if (defined($self->{curmode}) && ($self->{curmode} eq $mode)); | | return if ( defined($self->{curmode}) && ($self->{curmode} eq $mode) ); |
| if (defined($mode) and $mode eq ':crlf') | | if ( defined($mode) and $mode eq ':crlf' ) { |
| { | | $self->_finish_connection(); |
| $self->_finish_connection(); | | $self->{ftp}->ascii() |
| $self->{ftp}->ascii() | | or return $self->seterr(); |
| or return $self->seterr(); | | } else { |
| } | | $self->_finish_connection(); |
| else | | $self->{ftp}->binary() |
| { | | or return $self->seterr(); |
| $self->_finish_connection(); | | } |
| $self->{ftp}->binary() | | $self->{curmode} = $mode; |
| or return $self->seterr(); | | |
| } | | |
| $self->{curmode} = $mode; | | |
| } | | } |
| | |
| sub _min | | sub _min |
| { | | { |
|
| return $_[0] < $_[1] ? $_[0] : $_[1]; | | return $_[0] < $_[1] ? $_[0] : $_[1]; |
| } | | } |
| | |
| sub _max | | sub _max |
| { | | { |
|
| return $_[0] > $_[1] ? $_[0] : $_[1]; | | return $_[0] > $_[1] ? $_[0] : $_[1]; |
| } | | } |
| | |
| sub read | | sub read |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| # return $self->sysread(@_); | | |
| | # return $self->sysread(@_); |
| | |
|
| my(undef,$len,$offset)=@_; | | my(undef, $len, $offset) = @_; |
| $offset ||= 0; | | $offset ||= 0; |
| warn "READ(buf,$len,$offset)\n" | | warn "READ(buf,$len,$offset)\n" |
| if ($ENV{DEBUG}); | | if ( $ENV{DEBUG} ); |
| | | |
| if (!defined($self->{_buf}) || length($self->{_buf}) <= 0) | | if ( !defined($self->{_buf}) || length($self->{_buf}) <= 0 ) { |
| { | | $self->sysread($self->{_buf}, _max($len, $self->{BlockSize})) |
| $self->sysread($self->{_buf},_max($len,$self->{BlockSize})) | | or return 0; |
| or return 0; | | } elsif ( length($self->{_buf}) < $len ) { |
| } | | $self->sysread($self->{_buf}, _max($len - length($self->{_buf}), $self-> |
| elsif (length($self->{_buf}) < $len) | | {BlockSize}), length($self->{_buf})); |
| { | | } |
| $self->sysread($self->{_buf},_max($len-length($self->{_buf}),$self->{BlockSi | | my $ret = _min($len, length($self->{_buf})); |
| ze}),length($self->{_buf})); | | if ( !defined($_[0]) ) { $_[0] = '' } |
| } | | substr($_[0], $offset) = substr($self->{_buf}, 0, $len, ''); |
| my $ret = _min($len,length($self->{_buf})); | | $self->{read_count}++; |
| if (!defined($_[0])) { $_[0] = '' } | | |
| substr($_[0],$offset) = substr($self->{_buf},0,$len,''); | | |
| $self->{read_count}++; | | |
| | |
|
| return $ret; | | return $ret; |
| } | | } |
| | |
| sub sysread | | sub sysread |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| if ($self->{eof}) | | if ( $self->{eof} ) { |
| { | | return 0; |
| return 0; | | } |
| } | | |
| | |
|
| my(undef,$len,$offset) = @_; | | my(undef, $len, $offset) = @_; |
| $offset ||= 0; | | $offset ||= 0; |
| | |
|
| warn "SYSREAD(buf,$len,$offset)\n" | | warn "SYSREAD(buf,$len,$offset)\n" |
| if ($ENV{DEBUG}); | | if ( $ENV{DEBUG} ); |
| if ($self->{nextpos} >= $self->{size}) | | if ( $self->{nextpos} >= $self->{size} ) { |
| { | | $self->{eof} = 1; |
| $self->{eof} = 1; | | $self->{pos} = $self->{nextpos}; |
| $self->{pos} = $self->{nextpos}; | | return 0; |
| return 0; | | } |
| } | | |
| | |
|
| if ($self->{pos} != $self->{nextpos}) | | if ( $self->{pos} != $self->{nextpos} ) { |
| { | | |
| # They seeked. | | # They seeked. |
| if ($self->{ftp_running}) | | if ( $self->{ftp_running} ) { |
| { | | warn "Seek detected, nextpos=$self->{nextpos}, pos=$self->{pos}, Max |
| warn "Seek detected, nextpos=$self->{nextpos}, pos=$self->{pos}, MaxSkipSi | | SkipSize=$self->{MaxSkipSize}\n" |
| ze=$self->{MaxSkipSize}\n" | | if ( $ENV{DEBUG} ); |
| if ($ENV{DEBUG}); | | if ( $self->{nextpos} > $self->{pos} and ($self->{nextpos} - $self-> |
| if ($self->{nextpos} > $self->{pos} and ($self->{nextpos} - $self->{pos}) | | {pos}) < $self->{MaxSkipSize} ) { |
| < $self->{MaxSkipSize}) | | my $br = $self->{nextpos} - $self->{pos}; |
| { | | warn "Reading $br bytes to skip ahead\n" |
| my $br = $self->{nextpos}-$self->{pos}; | | if ( $ENV{DEBUG} ); |
| warn "Reading $br bytes to skip ahead\n" | | my $junkbuff; |
| if ($ENV{DEBUG}); | | while ( $br > 0 ) { |
| my $junkbuff; | | warn "Trying to read $br more bytes\n" |
| while ($br > 0) | | if ( $ENV{DEBUG} ); |
| { | | my $b = $self->{ftp_data}->read($junkbuff, $br); |
| warn "Trying to read $br more bytes\n" | | if ( $b == 0 ) { |
| if ($ENV{DEBUG}); | | $self->_at_eof(); |
| my $b = $self->{ftp_data}->read($junkbuff,$br); | | return 0; |
| if ($b == 0) | | } elsif ( !defined($b) || $b < 0 ) { |
| { | | return $self->seterr(); |
| $self->_at_eof(); | | } else { |
| return 0; | | $br -= $b; |
| } | | } |
| elsif (!defined($b) || $b < 0) | | } |
| { | | $self->{pos} = $self->{nextpos}; |
| return $self->seterr(); | | } else { |
| } | | warn "Aborting connection to move to new position\n" |
| else | | if ( $ENV{DEBUG} ); |
| { | | $self->_finish_connection(); |
| $br -= $b; | | } |
| } | | } |
| } | | } |
| $self->{pos}=$self->{nextpos}; | | |
| } | | if ( !$self->{ftp_running} ) { |
| else | | $self->{ftp}->restart($self->{nextpos}); |
| { | | $self->{ftp_data} = $self->{ftp}->retr($self->{filename}) |
| warn "Aborting connection to move to new position\n" | | or return $self->seterr(); |
| if ($ENV{DEBUG}); | | $self->{ftp_running} = 1; |
| $self->_finish_connection(); | | $self->{pos} = $self->{nextpos}; |
| } | | } |
| } | | |
| } | | my $tmpbuf; |
| | | my $rb = $self->{ftp_data}->read($tmpbuf, $len); |
| if (!$self->{ftp_running}) | | if ( $rb == 0 ) { |
| { | | $self->_at_eof(); |
| $self->{ftp}->restart($self->{nextpos}); | | return 0; |
| $self->{ftp_data} = $self->{ftp}->retr($self->{filename}) | | } elsif ( !defined($rb) || $rb < 0 ) { |
| or return $self->seterr(); | | return $self->seterr(); |
| $self->{ftp_running} = 1; | | } |
| $self->{pos}=$self->{nextpos}; | | |
| } | | |
| | | |
| my $tmpbuf; | | |
| my $rb = $self->{ftp_data}->read($tmpbuf,$len); | | |
| if ($rb == 0) | | |
| { | | |
| $self->_at_eof(); | | |
| return 0; | | |
| } | | |
| elsif (!defined($rb) || $rb < 0) | | |
| { | | |
| return $self->seterr(); | | |
| } | | |
| | | |
| if (!defined($_[0])) { $_[0] = '' } | | |
| substr($_[0],$offset) = $tmpbuf; | | |
| $self->{pos} += $rb; | | |
| $self->{nextpos} += $rb; | | |
| | |
|
| $self->{sysread_count}++; | | if ( !defined($_[0]) ) { $_[0] = '' } |
| $rb; | | substr($_[0], $offset) = $tmpbuf; |
| | $self->{pos} += $rb; |
| | $self->{nextpos} += $rb; |
| | |
| | $self->{sysread_count}++; |
| | $rb; |
| } | | } |
| | |
| sub _at_eof | | sub _at_eof |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| $self->{eof}=1; | | $self->{eof} = 1; |
| $self->_finish_connection(); | | $self->_finish_connection(); |
| # $self->{ftp_data}->_close(); | | |
| $self->{ftp_running} = $self->{ftp_data} = undef; | | # $self->{ftp_data}->_close(); |
| | $self->{ftp_running} = $self->{ftp_data} = undef; |
| } | | } |
| | |
| sub _finish_connection | | sub _finish_connection |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| warn "_finish_connection\n" | | warn "_finish_connection\n" |
| if ($ENV{DEBUG}); | | if ( $ENV{DEBUG} ); |
| return unless ($self->{ftp_running}); | | return unless ( $self->{ftp_running} ); |
| | | |
| if ($self->{size} - $self->{pos} < $self->{MaxSkipSize}) | | if ( $self->{size} - $self->{pos} < $self->{MaxSkipSize} ) { |
| { | | warn "Skipping " . ($self->{size} - $self->{pos}) . " bytes\n" |
| warn "Skipping " . ($self->{size}-$self->{pos}) . " bytes\n" | | if ( $ENV{DEBUG} ); |
| if ($ENV{DEBUG}); | | my $junkbuff; |
| my $junkbuff; | | my $br; |
| my $br; | | while ( ($br = $self->{ftp_data}->read($junkbuff, 8192)) ) { |
| while(($br = $self->{ftp_data}->read($junkbuff,8192))) | | |
| { | | # Read until EOF or error |
| # Read until EOF or error | | } |
| | defined($br) |
| | or $self->seterr(); |
| } | | } |
|
| defined($br) | | warn "Shutting down existing FTP DATA session...\n" |
| or $self->seterr(); | | if ( $ENV{DEBUG} ); |
| } | | |
| warn "Shutting down existing FTP DATA session...\n" | | my $closeret; |
| if ($ENV{DEBUG}); | | |
| | | |
| my $closeret; | | |
| { | | |
| eval { | | |
| $closeret = $self->{ftp_data}->close(); | | |
| }; | | |
| # Work around a timeout bug in Net::FTP | | |
| if ($@ && $@ =~ /^Timeout /) | | |
| { | | { |
|
| warn "Timeout closing connection, retrying...\n" | | eval { $closeret = $self->{ftp_data}->close(); }; |
| if ($ENV{DEBUG}); | | |
| select(undef,undef,undef,1); | | # Work around a timeout bug in Net::FTP |
| redo; | | if ( $@ && $@ =~ /^Timeout / ) { |
| | warn "Timeout closing connection, retrying...\n" |
| | if ( $ENV{DEBUG} ); |
| | select(undef, undef, undef, 1); |
| | redo; |
| | } |
| } | | } |
|
| } | | |
| | |
|
| $self->{ftp_running} = $self->{ftp_data} = undef; | | $self->{ftp_running} = $self->{ftp_data} = undef; |
| return $closeret ? 1 : $self->seterr(); | | return $closeret ? 1 : $self->seterr(); |
| } | | } |
| | |
| sub write | | sub write |
| { | | { |
|
| die "Only reading currently supported"; | | die "Only reading currently supported"; |
| } | | } |
| | |
| sub close | | sub close |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| return $self->{ftp_data} ? $self->_finish_connection() | | return $self->{ftp_data} |
| : 1; | | ? $self->_finish_connection() |
| | : 1; |
| } | | } |
| | |
| sub eof | | sub eof |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| if ($self->{eof}) | | if ( $self->{eof} ) { |
| { | | return 1; |
| return 1; | | } |
| } | | |
| | | my $c = $self->getc; |
| my $c = $self->getc; | | if ( !defined($c) ) { |
| if (!defined($c)) | | return 1; |
| { | | } |
| return 1; | | $self->ungetc(ord($c)); |
| } | | return undef; |
| $self->ungetc(ord($c)); | | |
| return undef; | | |
| } | | } |
| | |
| sub getc | | sub getc |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| my $c; | | my $c; |
| my $rb = $self->read($c,1); | | my $rb = $self->read($c, 1); |
| if ($rb < 1) | | if ( $rb < 1 ) { |
| { | | return undef; |
| return undef; | | } |
| } | | return $c; |
| return $c; | | |
| } | | } |
| | |
| sub ungetc | | sub ungetc |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| # Note that $c is the ordinal value of a character, not the | | |
| # character itself (for some reason) | | # Note that $c is the ordinal value of a character, not the |
| my($c)=@_; | | # character itself (for some reason) |
| $self->{_buf} = chr($c) . $self->{_buf}; | | my($c) = @_; |
| | $self->{_buf} = chr($c) . $self->{_buf}; |
| } | | } |
| | |
| sub getline | | sub getline |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| if (!defined($/)) | | if ( !defined($/) ) { |
| { | | my $buf; |
| my $buf; | | while ( $self->read($buf, $self->{BlockSize}, length($buf)) > 0 ) { |
| while($self->read($buf,$self->{BlockSize},length($buf)) > 0) | | |
| { | | # Keep going |
| # Keep going | | } |
| | return $buf; |
| | } elsif ( ref($/) && looks_like_number ${$/} ) { |
| | my $buf; |
| | $self->read($buf, ${$/}) |
| | or return undef; |
| | return $buf; |
| } | | } |
|
| return $buf; | | |
| } | | |
| elsif (ref($/) && looks_like_number ${$/} ) | | |
| { | | |
| my $buf; | | |
| $self->read($buf,${$/}) | | |
| or return undef; | | |
| return $buf; | | |
| } | | |
| | |
|
| my $rs; | | my $rs; |
| if ($/ eq '') | | if ( $/ eq '' ) { |
| { | | $rs = "\n\n"; |
| $rs = "\n\n"; | | } else { |
| } | | $rs = $/; |
| else | | |
| { | | |
| $rs = $/; | | |
| } | | |
| my $eol; | | |
| if (!defined($self->{_buf})) { $self->{_buf} = '' } | | |
| while (($eol=index($self->{_buf},$rs)) < $[) | | |
| { | | |
| if ($self->{eof}) | | |
| { | | |
| # return what's left | | |
| if (length($self->{_buf}) == 0) | | |
| { | | |
| return undef; | | |
| } | | |
| else | | |
| { | | |
| return substr($self->{_buf},0,length($self->{_buf}),''); | | |
| } | | |
| } | | } |
|
| else | | my $eol; |
| { | | if ( !defined($self->{_buf}) ) { $self->{_buf} = '' } |
| $self->sysread($self->{_buf},$self->{BlockSize},length($self->{_buf})); | | while ( ($eol = index($self->{_buf}, $rs)) < $[ ) { |
| | if ( $self->{eof} ) { |
| | |
| | # return what's left |
| | if ( length($self->{_buf}) == 0 ) { |
| | return undef; |
| | } else { |
| | return substr($self->{_buf}, 0, length($self->{_buf}), ''); |
| | } |
| | } else { |
| | $self->sysread($self->{_buf}, $self->{BlockSize}, length($self->{_bu |
| | f})); |
| | } |
| | } |
| | |
| | # OK, we should have a match. |
| | my $tmpbuf = substr($self->{_buf}, 0, $eol + length($rs), ''); |
| | while ( $/ eq '' and substr($self->{_buf}, 0, 1) eq "\n" ) { |
| | substr($self->{_buf}, 0, 1) = ''; |
| } | | } |
|
| } | | return $tmpbuf; |
| # OK, we should have a match. | | |
| my $tmpbuf = substr($self->{_buf},0,$eol+length($rs),''); | | |
| while ($/ eq '' and substr($self->{_buf},0,1) eq "\n") | | |
| { | | |
| substr($self->{_buf},0,1)=''; | | |
| } | | |
| return $tmpbuf; | | |
| } | | } |
| | |
| sub getlines | | sub getlines |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| my @lines; | | my @lines; |
| my $line; | | my $line; |
| while (defined($line = $self->getline())) | | while ( defined($line = $self->getline()) ) { |
| { | | push(@lines, $line); |
| push(@lines,$line); | | } |
| } | | @lines; |
| @lines; | | |
| } | | } |
| | |
| sub error | | sub error |
| { | | { |
|
| return undef; | | return undef; |
| } | | } |
| | |
| sub seterr | | sub seterr |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| $self->{_error} = 1; | | $self->{_error} = 1; |
| return undef; | | return undef; |
| } | | } |
| | |
| sub clearerr | | sub clearerr |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| $self->{_error} = undef; | | $self->{_error} = undef; |
| return 0; | | return 0; |
| } | | } |
| | |
| sub getpos | | sub getpos |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| return $self->tell(); | | return $self->tell(); |
| } | | } |
| | |
| sub setpos | | sub setpos |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| return $self->seek(@_); | | return $self->seek(@_); |
| } | | } |
| | |
| sub DESTROY | | sub DESTROY |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| if (UNIVERSAL::isa($self,'GLOB')) | | if ( UNIVERSAL::isa($self, 'GLOB') ) { |
| { | | $self = tied *$self |
| $self = tied *$self | | or die "$self not tied?..."; |
| or die "$self not tied?..."; | | } |
| } | | if ( $self->{ftp_data} ) { |
| if ($self->{ftp_data}) | | $self->_finish_connection(); |
| { | | } |
| $self->_finish_connection(); | | warn "sysread called " . $self->{sysread_count} . " times.\n" |
| } | | if ( $ENV{DEBUG} ); |
| warn "sysread called ".$self->{sysread_count}." times.\n" | | |
| if ($ENV{DEBUG}); | | |
| } | | } |
| | |
| =head1 TIED INTERFACE | | =head1 TIED INTERFACE |
| | |
| Instead of a L<IO::Handle|IO::Handle>-compatible interface, you can | | Instead of a L<IO::Handle|IO::Handle>-compatible interface, you can |
| use a C<tie>-based interface to use the standard Perl I/O operators. | | use a C<tie>-based interface to use the standard Perl I/O operators. |
| You can use it like this: | | You can use it like this: |
| | |
| use Net::FTP::RetrHandle; | | use Net::FTP::RetrHandle; |
| # Create FTP object in $ftp | | # Create FTP object in $ftp |
| # Store filename in $filename | | # Store filename in $filename |
| tie *FH, 'Net::FTP::RetrHandle', $ftp, $filename | | tie *FH, 'Net::FTP::RetrHandle', $ftp, $filename |
| or die "Error in tie!\n"; | | or die "Error in tie!\n"; |
| | |
| =cut | | =cut |
|
| ; | | |
| sub TIEHANDLE | | sub TIEHANDLE |
| { | | { |
|
| my $class = shift; | | my $class = shift; |
| my $obj = $class->new(@_); | | my $obj = $class->new(@_); |
| $obj; | | $obj; |
| } | | } |
| | |
| sub READ | | sub READ |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| $self->read(@_); | | $self->read(@_); |
| } | | } |
| | |
| sub READLINE | | sub READLINE |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| return wantarray ? $self->getlines(@_) | | return wantarray |
| : $self->getline(@_); | | ? $self->getlines(@_) |
| | : $self->getline(@_); |
| } | | } |
| | |
| sub GETC | | sub GETC |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| return $self->getc(@_); | | return $self->getc(@_); |
| } | | } |
| | |
| sub SEEK | | sub SEEK |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| return $self->seek(@_); | | return $self->seek(@_); |
| } | | } |
| | |
| sub SYSSEEK | | sub SYSSEEK |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| return $self->sysseek(@_); | | return $self->sysseek(@_); |
| } | | } |
| | |
| sub TELL | | sub TELL |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| return $self->tell(); | | return $self->tell(); |
| } | | } |
| | |
| sub CLOSE | | sub CLOSE |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| return $self->close(@_); | | return $self->close(@_); |
| } | | } |
| | |
| sub EOF | | sub EOF |
| { | | { |
|
| my $self = shift; | | my $self = shift; |
| return $self->eof(@_); | | return $self->eof(@_); |
| | | |
| } | | } |
|
| | |
| sub UNTIE | | sub UNTIE |
| { | | { |
|
| tied($_[0])->close(@_); | | tied($_[0])->close(@_); |
| } | | } |
| | |
| =head1 EXAMPLE | | =head1 EXAMPLE |
| | |
| Here's an example of listing a Zip file without downloading the whole | | Here's an example of listing a Zip file without downloading the whole |
| thing: | | thing: |
| | |
| #!/usr/bin/perl | | #!/usr/bin/perl |
| | |
| use warnings; | | use warnings; |
| | | |
| End of changes. 58 change blocks. |
|---|
| 371 lines changed or deleted | | 333 lines changed or added |
|---|
"Fossies" - the Fresh Open Source Software Archive 