ftp.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

  my ($ftp, $where) = @_;

  ${*$ftp}{'net_ftp_rest'} = $where;

  return undef;
}


sub mkdir {
  @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';

  my ($ftp, $dir, $recurse) = @_;

  $ftp->_MKD($dir) || $recurse
    or return undef;

  my $path = $dir;

  unless ($ftp->ok) {
    my @path = split(m#(?=/+)#, $dir);

    $path = "";

    while (@path) {
      $path .= shift @path;

      $ftp->_MKD($path);

      $path = $ftp->_extract_path($path);
    }

    # If the creation of the last element was not successful, see if we
    # can cd to it, if so then return path

    unless ($ftp->ok) {
      my ($status, $message) = ($ftp->status, $ftp->message);
      my $pwd = $ftp->pwd;

      if ($pwd && $ftp->cwd($dir)) {
        $path = $dir;
        $ftp->cwd($pwd);
      }
      else {
        undef $path;
      }
      $ftp->set_status($status, $message);
    }
  }

  $path;
}


sub delete {
  @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';

  $_[0]->_DELE($_[1]);
}


sub put        { shift->_store_cmd("stor", @_) }
sub put_unique { shift->_store_cmd("stou", @_) }
sub append     { shift->_store_cmd("appe", @_) }


sub nlst { shift->_data_cmd("NLST", @_) }
sub list { shift->_data_cmd("LIST", @_) }
sub retr { shift->_data_cmd("RETR", @_) }
sub stor { shift->_data_cmd("STOR", @_) }
sub stou { shift->_data_cmd("STOU", @_) }
sub appe { shift->_data_cmd("APPE", @_) }


sub _store_cmd {
  my ($ftp, $cmd, $local, $remote) = @_;
  my ($loc, $sock, $len, $buf);
  local *FD;

  my $localfd = ref($local) || ref(\$local) eq "GLOB";

  unless (defined $remote) {
    croak 'Must specify remote filename with stream input'
      if $localfd;

    require File::Basename;
    $remote = File::Basename::basename($local);
  }
  if (defined ${*$ftp}{'net_ftp_allo'}) {
    delete ${*$ftp}{'net_ftp_allo'};
  }
  else {

    # if the user hasn't already invoked the alloc method since the last
    # _store_cmd call, figure out if the local file is a regular file(not
    # a pipe, or device) and if so get the file size from stat, and send
    # an ALLO command before sending the STOR, STOU, or APPE command.
    my $size = do { local $^W; -f $local && -s _ };    # no ALLO if sending data from a pipe
    $ftp->_ALLO($size) if $size;
  }
  croak("Bad remote filename '$remote'\n")
    if $remote =~ /[\r\n]/s;

  if ($localfd) {
    $loc = $local;
  }
  else {
    $loc = \*FD;

    unless (sysopen($loc, $local, O_RDONLY)) {
      carp "Cannot open Local file $local: $!\n";
      return undef;
    }
  }

  if ($ftp->type eq 'I' && !binmode($loc)) {
    carp "Cannot binmode Local file $local: $!\n";
    return undef;
  }

  delete ${*$ftp}{'net_ftp_port'};
  delete ${*$ftp}{'net_ftp_pasv'};

  $sock = $ftp->_data_cmd($cmd, $remote)
    or return undef;

  $remote = ($ftp->message =~ /FILE:\s*(.*)/)[0]
    if 'STOU' eq uc $cmd;

  my $blksize = ${*$ftp}{'net_ftp_blksize'};

  my ($count, $hashh, $hashb, $ref) = (0);

  ($hashh, $hashb) = @$ref
    if ($ref = ${*$ftp}{'net_ftp_hash'});

  while (1) {
    last unless $len = read($loc, $buf = "", $blksize);

    if (trEBCDIC && $ftp->type ne 'I') {
      $buf = $ftp->toascii($buf);
      $len = length($buf);
    }

    if ($hashh) {
      $count += $len;
      print $hashh "#" x (int($count / $hashb));
      $count %= $hashb;
    }

    my $wlen;
    unless (defined($wlen = $sock->write($buf, $len)) && $wlen == $len) {
      $sock->abort;
      close($loc)
        unless $localfd;
      print $hashh "\n" if $hashh;
      return undef;
    }
  }

  print $hashh "\n" if $hashh;

  close($loc)
    unless $localfd;

  $sock->close()
    or return undef;

  if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/) {
    require File::Basename;
    $remote = File::Basename::basename($+);
  }

  return $remote;
}


sub port {
  @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';

  my ($ftp, $port) = @_;
  my $ok;

  delete ${*$ftp}{'net_ftp_intern_port'};

  unless (defined $port) {

    # create a Listen socket at same address as the command socket

    ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(
      Listen    => 5,
      Proto     => 'tcp',
      Timeout   => $ftp->timeout,
      LocalAddr => $ftp->sockhost,
    );

    my $listen = ${*$ftp}{'net_ftp_listen'};

    my ($myport, @myaddr) = ($listen->sockport, split(/\./, $listen->sockhost));

    $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);

    ${*$ftp}{'net_ftp_intern_port'} = 1;
  }

  $ok = $ftp->_PORT($port);

  ${*$ftp}{'net_ftp_port'} = $port;

  $ok;
}


sub ls  { shift->_list_cmd("NLST", @_); }
sub dir { shift->_list_cmd("LIST", @_); }


sub pasv {
  @_ == 1 or croak 'usage: $ftp->pasv()';

  my $ftp = shift;

  delete ${*$ftp}{'net_ftp_intern_port'};

  $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
    ? ${*$ftp}{'net_ftp_pasv'} = $1
    : undef;
}


sub unique_name {
  my $ftp = shift;
  ${*$ftp}{'net_ftp_unique'} || undef;
}


sub supported {
  @_ == 2 or croak 'usage: $ftp->supported( CMD )';
  my $ftp  = shift;
  my $cmd  = uc shift;
  my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};

  return $hash->{$cmd}
    if exists $hash->{$cmd};

  return $hash->{$cmd} = 0
    unless $ftp->_HELP($cmd);

  my $text = $ftp->message;
  if ($text =~ /following\s+commands/i) {
    $text =~ s/^.*\n//;
    while ($text =~ /(\*?)(\w+)(\*?)/sg) {
      $hash->{"\U$2"} = !length("$1$3");
    }
  }
  else {
    $hash->{$cmd} = $text !~ /unimplemented/i;
  }

  $hash->{$cmd} ||= 0;
}

##
## Deprecated methods
##


sub lsl {
  carp "Use of Net::FTP::lsl deprecated, use 'dir'"
    if $^W;
  goto &dir;
}


sub authorise {
  carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
    if $^W;
  goto &authorize;
}


##
## Private methods
##


sub _extract_path {
  my ($ftp, $path) = @_;

  # This tries to work both with and without the quote doubling
  # convention (RFC 959 requires it, but the first 3 servers I checked
  # didn't implement it).  It will fail on a server which uses a quote in
  # the message which isn't a part of or surrounding the path.
  $ftp->ok
    && $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/
    && ($path = $1) =~ s/\"\"/\"/g;

  $path;
}

##
## Communication methods
##


sub _dataconn {
  my $ftp  = shift;
  my $data = undef;
  my $pkg  = "Net::FTP::" . $ftp->type;

  eval "require " . $pkg;

  $pkg =~ s/ /_/g;

  delete ${*$ftp}{'net_ftp_dataconn'};

  if (defined ${*$ftp}{'net_ftp_pasv'}) {
    my @port = map { 0 + $_ } split(/,/, ${*$ftp}{'net_ftp_pasv'});

    $data = $pkg->new(
      PeerAddr  => join(".", @port[0 .. 3]),
      PeerPort  => $port[4] * 256 + $port[5],
      LocalAddr => ${*$ftp}{'net_ftp_localaddr'},
      Proto     => 'tcp'
    );
  }
  elsif (defined ${*$ftp}{'net_ftp_listen'}) {
    $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
    close(delete ${*$ftp}{'net_ftp_listen'});
  }

  if ($data) {
    ${*$data} = "";
    $data->timeout($ftp->timeout);
    ${*$ftp}{'net_ftp_dataconn'} = $data;
    ${*$data}{'net_ftp_cmd'}     = $ftp;
    ${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'};
  }

  $data;
}


sub _list_cmd {
  my $ftp = shift;
  my $cmd = uc shift;

  delete ${*$ftp}{'net_ftp_port'};
  delete ${*$ftp}{'net_ftp_pasv'};

  my $data = $ftp->_data_cmd($cmd, @_);

  return
    unless (defined $data);

  require Net::FTP::A;
  bless $data, "Net::FTP::A";    # Force ASCII mode

  my $databuf = '';
  my $buf     = '';
  my $blksize = ${*$ftp}{'net_ftp_blksize'};

  while ($data->read($databuf, $blksize)) {
    $buf .= $databuf;
  }

  my $list = [split(/\n/, $buf)];

  $data->close();

  if (trEBCDIC) {
    for (@$list) { $_ = $ftp->toebcdic($_) }
  }

  wantarray
    ? @{$list}
    : $list;
}


sub _data_cmd {
  my $ftp   = shift;
  my $cmd   = uc shift;
  my $ok    = 1;
  my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
  my $arg;

  for $arg (@_) {
    croak("Bad argument '$arg'\n")
      if $arg =~ /[\r\n]/s;
  }

  if ( ${*$ftp}{'net_ftp_passive'}
    && !defined ${*$ftp}{'net_ftp_pasv'}
    && !defined ${*$ftp}{'net_ftp_port'})
  {
    my $data = undef;

    $ok = defined $ftp->pasv;
    $ok = $ftp->_REST($where)
      if $ok && $where;

    if ($ok) {
      $ftp->command($cmd, @_);
      $data = $ftp->_dataconn();
      $ok   = CMD_INFO == $ftp->response();
      if ($ok) {
        $data->reading
          if $data && $cmd =~ /RETR|LIST|NLST/;
        return $data;
      }
      $data->_close
        if $data;
    }
    return undef;
  }

  $ok = $ftp->port
    unless (defined ${*$ftp}{'net_ftp_port'}
    || defined ${*$ftp}{'net_ftp_pasv'});

  $ok = $ftp->_REST($where)
    if $ok && $where;

  return undef
    unless $ok;

  $ftp->command($cmd, @_);

  return 1
    if (defined ${*$ftp}{'net_ftp_pasv'});

  $ok = CMD_INFO == $ftp->response();

  return $ok
    unless exists ${*$ftp}{'net_ftp_intern_port'};

  if ($ok) {
    my $data = $ftp->_dataconn();

    $data->reading
      if $data && $cmd =~ /RETR|LIST|NLST/;

    return $data;
  }


  close(delete ${*$ftp}{'net_ftp_listen'});

  return undef;
}

##
## Over-ride methods (Net::Cmd)
##


sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; }


sub command {
  my $ftp = shift;

  delete ${*$ftp}{'net_ftp_port'};
  $ftp->SUPER::command(@_);
}


sub response {
  my $ftp  = shift;
  my $code = $ftp->SUPER::response();

  delete ${*$ftp}{'net_ftp_pasv'}
    if ($code != CMD_MORE && $code != CMD_INFO);

  $code;
}


sub parse_response {
  return ($1, $2 eq "-")
    if $_[1] =~ s/^(\d\d\d)([- ]?)//o;

  my $ftp = shift;

  # Darn MS FTP server is a load of CRAP !!!!
  return ()
    unless ${*$ftp}{'net_cmd_code'} + 0;

  (${*$ftp}{'net_cmd_code'}, 1);
}

##
## Allow 2 servers to talk directly
##


sub pasv_xfer_unique {
  my ($sftp, $sfile, $dftp, $dfile) = @_;
  $sftp->pasv_xfer($sfile, $dftp, $dfile, 1);
}


sub pasv_xfer {
  my ($sftp, $sfile, $dftp, $dfile, $unique) = @_;

  ($dfile = $sfile) =~ s#.*/##
    unless (defined $dfile);

  my $port = $sftp->pasv
    or return undef;

  $dftp->port($port)
    or return undef;

  return undef
    unless ($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));

  unless ($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
    $sftp->retr($sfile);
    $dftp->abort;
    $dftp->response();
    return undef;
  }

  $dftp->pasv_wait($sftp);
}


sub pasv_wait {
  @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';

  my ($ftp, $non_pasv) = @_;
  my ($file, $rin, $rout);

  vec($rin = '', fileno($ftp), 1) = 1;
  select($rout = $rin, undef, undef, undef);

  $ftp->response();
  $non_pasv->response();

  return undef
    unless $ftp->ok() && $non_pasv->ok();

  return $1
    if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;

  return $1
    if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;

  return 1;
}


sub feature {
  @_ == 2 or croak 'usage: $ftp->feature( NAME )';
  my ($ftp, $feat) = @_;

  my $feature = ${*$ftp}{net_ftp_feature} ||= do {
    my @feat;

    # Example response
    # 211-Features:
    #  MDTM
    #  REST STREAM
    #  SIZE
    # 211 End

    @feat = map { /^\s+(.*\S)/ } $ftp->message
      if $ftp->_FEAT;

    \@feat;
  };

  return grep { /^\Q$feat\E\b/i } @$feature;
}


sub cmd { shift->command(@_)->response() }

########################################
#
# RFC959 commands
#


sub _ABOR { shift->command("ABOR")->response() == CMD_OK }
sub _ALLO { shift->command("ALLO", @_)->response() == CMD_OK }
sub _CDUP { shift->command("CDUP")->response() == CMD_OK }
sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
sub _PASV { shift->command("PASV")->response() == CMD_OK }
sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
sub _DELE { shift->command("DELE", @_)->response() == CMD_OK }
sub _CWD  { shift->command("CWD", @_)->response() == CMD_OK }
sub _PORT { shift->command("PORT", @_)->response() == CMD_OK }
sub _RMD  { shift->command("RMD", @_)->response() == CMD_OK }
sub _MKD  { shift->command("MKD", @_)->response() == CMD_OK }
sub _PWD  { shift->command("PWD", @_)->response() == CMD_OK }
sub _TYPE { shift->command("TYPE", @_)->response() == CMD_OK }
sub _RNTO { shift->command("RNTO", @_)->response() == CMD_OK }
sub _RESP { shift->command("RESP", @_)->response() == CMD_OK }
sub _MDTM { shift->command("MDTM", @_)->response() == CMD_OK }
sub _SIZE { shift->command("SIZE", @_)->response() == CMD_OK }
sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
sub _STAT { shift->command("STAT", @_)->response() == CMD_OK }
sub _FEAT { shift->command("FEAT", @_)->response() == CMD_OK }
sub _APPE { shift->command("APPE", @_)->response() == CMD_INFO }
sub _LIST { shift->command("LIST", @_)->response() == CMD_INFO }
sub _NLST { shift->command("NLST", @_)->response() == CMD_INFO }
sub _RETR { shift->command("RETR", @_)->response() == CMD_INFO }
sub _STOR { shift->command("STOR", @_)->response() == CMD_INFO }