releasing/cbrtools/perl/Net/FTP/dataconn.pm
author lorewang
Wed, 01 Dec 2010 16:05:36 +0800
changeset 715 e0739b8406dd
parent 602 3145852acc89
permissions -rw-r--r--
Specify extenal tool with path
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
602
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     1
# COPYRIGHT 1996-2000 Graham Barr. All rights reserved.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     2
# 
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     3
# This library is free software; you can redistribute it and/or modify
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     4
# it under the same terms as Perl itself.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     5
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     6
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     7
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     8
##
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     9
## Generic data connection package
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    10
##
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    11
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    12
package Net::FTP::dataconn;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    13
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    14
use Carp;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    15
use vars qw(@ISA $timeout $VERSION);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    16
use Net::Cmd;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    17
use Errno;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    18
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    19
$VERSION = '0.11';
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    20
@ISA = qw(IO::Socket::INET);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    21
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    22
sub reading
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    23
{
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    24
 my $data = shift;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    25
 ${*$data}{'net_ftp_bytesread'} = 0;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    26
}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    27
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    28
sub abort
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    29
{
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    30
 my $data = shift;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    31
 my $ftp  = ${*$data}{'net_ftp_cmd'};
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    32
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    33
 # no need to abort if we have finished the xfer
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    34
 return $data->close
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    35
    if ${*$data}{'net_ftp_eof'};
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    36
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    37
 # for some reason if we continously open RETR connections and not
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    38
 # read a single byte, then abort them after a while the server will
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    39
 # close our connection, this prevents the unexpected EOF on the
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    40
 # command channel -- GMB
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    41
 if(exists ${*$data}{'net_ftp_bytesread'}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    42
	&& (${*$data}{'net_ftp_bytesread'} == 0)) {
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    43
   my $buf="";
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    44
   my $timeout = $data->timeout;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    45
   $data->can_read($timeout) && sysread($data,$buf,1);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    46
 }
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    47
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    48
 ${*$data}{'net_ftp_eof'} = 1; # fake
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    49
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    50
 $ftp->abort; # this will close me
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    51
}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    52
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    53
sub _close
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    54
{
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    55
 my $data = shift;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    56
 my $ftp  = ${*$data}{'net_ftp_cmd'};
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    57
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    58
 $data->SUPER::close();
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    59
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    60
 delete ${*$ftp}{'net_ftp_dataconn'}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    61
    if exists ${*$ftp}{'net_ftp_dataconn'} &&
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    62
        $data == ${*$ftp}{'net_ftp_dataconn'};
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    63
}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    64
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    65
sub close
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    66
{
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    67
 my $data = shift;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    68
 my $ftp  = ${*$data}{'net_ftp_cmd'};
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    69
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    70
 if(exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) {
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    71
   my $junk;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    72
   $data->read($junk,1,0);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    73
   return $data->abort unless ${*$data}{'net_ftp_eof'};
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    74
 }
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    75
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    76
 $data->_close;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    77
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    78
 $ftp->response() == CMD_OK &&
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    79
    $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ &&
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    80
    (${*$ftp}{'net_ftp_unique'} = $1);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    81
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    82
 $ftp->status == CMD_OK;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    83
}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    84
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    85
sub _select {
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    86
 my ($data, $timeout, $do_read) = @_;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    87
 my ($rin,$rout,$win,$wout,$tout,$nfound);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    88
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    89
 vec($rin='',fileno($data),1) = 1;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    90
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    91
 ($win, $rin) = ($rin, $win) unless $do_read;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    92
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    93
 while (1) {
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    94
   $nfound = select($rout=$rin, $wout=$win, undef, $tout=$timeout);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    95
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    96
   last if $nfound >= 0;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    97
   
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    98
   croak "select: $!"
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    99
     unless $!{EINTR};
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   100
 }
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   101
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   102
 $nfound;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   103
}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   104
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   105
sub can_read
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   106
{
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   107
 _select(@_[0,1],1);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   108
}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   109
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   110
sub can_write
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   111
{
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   112
 _select(@_[0,1],0);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   113
}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   114
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   115
sub cmd
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   116
{
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   117
 my $ftp = shift;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   118
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   119
 ${*$ftp}{'net_ftp_cmd'};
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   120
}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   121
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   122
sub bytes_read {
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   123
 my $ftp = shift;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   124
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   125
 ${*$ftp}{'net_ftp_bytesread'} || 0;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   126
}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   127
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   128
1;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   129
__END__
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   130
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   131
=head1 COPYRIGHT
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   132
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   133
COPYRIGHT
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   134
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   135
  © 1996-2000 Graham Barr. All rights reserved.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   136
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   137
This library is free software; you can redistribute it and/or modify
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   138
it under the same terms as Perl itself.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   139
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   140
=cut