[14489] | 1 | ## $Id: //depot/libnet/Net/FTP/A.pm#17 $
|
---|
| 2 | ## Package to read/write on ASCII data connections
|
---|
| 3 | ##
|
---|
| 4 |
|
---|
| 5 | package Net::FTP::A;
|
---|
| 6 | use strict;
|
---|
| 7 | use vars qw(@ISA $buf $VERSION);
|
---|
| 8 | use Carp;
|
---|
| 9 |
|
---|
| 10 | require Net::FTP::dataconn;
|
---|
| 11 |
|
---|
| 12 | @ISA = qw(Net::FTP::dataconn);
|
---|
| 13 | $VERSION = "1.16";
|
---|
| 14 |
|
---|
| 15 | sub read {
|
---|
| 16 | my $data = shift;
|
---|
| 17 | local *buf = \$_[0]; shift;
|
---|
| 18 | my $size = shift || croak 'read($buf,$size,[$offset])';
|
---|
| 19 | my $timeout = @_ ? shift : $data->timeout;
|
---|
| 20 |
|
---|
| 21 | if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) {
|
---|
| 22 | my $blksize = ${*$data}{'net_ftp_blksize'};
|
---|
| 23 | $blksize = $size if $size > $blksize;
|
---|
| 24 |
|
---|
| 25 | my $l = 0;
|
---|
| 26 | my $n;
|
---|
| 27 |
|
---|
| 28 | READ:
|
---|
| 29 | {
|
---|
| 30 | my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : '';
|
---|
| 31 |
|
---|
| 32 | $data->can_read($timeout) or
|
---|
| 33 | croak "Timeout";
|
---|
| 34 |
|
---|
| 35 | if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) {
|
---|
| 36 | ${*$data}{'net_ftp_bytesread'} += $n;
|
---|
| 37 | ${*$data}{'net_ftp_cr'} = substr($readbuf,-1) eq "\015"
|
---|
| 38 | ? chop($readbuf)
|
---|
| 39 | : undef;
|
---|
| 40 | }
|
---|
| 41 | else {
|
---|
| 42 | return undef
|
---|
| 43 | unless defined $n;
|
---|
| 44 |
|
---|
| 45 | ${*$data}{'net_ftp_eof'} = 1;
|
---|
| 46 | }
|
---|
| 47 |
|
---|
| 48 | $readbuf =~ s/\015\012/\n/sgo;
|
---|
| 49 | ${*$data} .= $readbuf;
|
---|
| 50 |
|
---|
| 51 | unless (length(${*$data})) {
|
---|
| 52 |
|
---|
| 53 | redo READ
|
---|
| 54 | if($n > 0);
|
---|
| 55 |
|
---|
| 56 | $size = length(${*$data})
|
---|
| 57 | if($n == 0);
|
---|
| 58 | }
|
---|
| 59 | }
|
---|
| 60 | }
|
---|
| 61 |
|
---|
| 62 | $buf = substr(${*$data},0,$size);
|
---|
| 63 | substr(${*$data},0,$size) = '';
|
---|
| 64 |
|
---|
| 65 | length $buf;
|
---|
| 66 | }
|
---|
| 67 |
|
---|
| 68 | sub write {
|
---|
| 69 | my $data = shift;
|
---|
| 70 | local *buf = \$_[0]; shift;
|
---|
| 71 | my $size = shift || croak 'write($buf,$size,[$timeout])';
|
---|
| 72 | my $timeout = @_ ? shift : $data->timeout;
|
---|
| 73 |
|
---|
| 74 | (my $tmp = substr($buf,0,$size)) =~ s/\r?\n/\015\012/sg;
|
---|
| 75 |
|
---|
| 76 | # If the remote server has closed the connection we will be signal'd
|
---|
| 77 | # when we write. This can happen if the disk on the remote server fills up
|
---|
| 78 |
|
---|
| 79 | local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
|
---|
| 80 |
|
---|
| 81 | my $len = length($tmp);
|
---|
| 82 | my $off = 0;
|
---|
| 83 | my $wrote = 0;
|
---|
| 84 |
|
---|
| 85 | my $blksize = ${*$data}{'net_ftp_blksize'};
|
---|
| 86 |
|
---|
| 87 | while($len) {
|
---|
| 88 | $data->can_write($timeout) or
|
---|
| 89 | croak "Timeout";
|
---|
| 90 |
|
---|
| 91 | $off += $wrote;
|
---|
| 92 | $wrote = syswrite($data, substr($tmp,$off), $len > $blksize ? $blksize : $len);
|
---|
| 93 | return undef
|
---|
| 94 | unless defined($wrote);
|
---|
| 95 | $len -= $wrote;
|
---|
| 96 | }
|
---|
| 97 |
|
---|
| 98 | $size;
|
---|
| 99 | }
|
---|
| 100 |
|
---|
| 101 | 1;
|
---|