releasing/cbrtools/perl/RemoteSite/FTP/Experimental.pm
author srilekhas
Fri, 08 Oct 2010 21:02:28 +0100
changeset 650 8f038057ffa5
parent 602 3145852acc89
permissions -rw-r--r--
Added in fix to Bug 2149
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
602
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     1
# RemoteSite::FTP.pm
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     2
#
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     3
#Copyright (c) 2000-2006, The Perl Foundation. All rights reserved.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     4
#This program is free software; you can redistribute it and/or modify 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
package RemoteSite::FTP::Experimental;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     8
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
     9
use strict;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    10
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    11
use RemoteSite::FTP;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    12
use vars qw(@ISA);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    13
@ISA=("RemoteSite::FTP");
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    14
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    15
sub DirList {
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    16
  my $self = shift;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    17
  my $remoteDir = shift;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    18
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    19
  print "Listing FTP directory $remoteDir\n" if ($self->{verbose});
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    20
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    21
  my $dirlist_retries = 3;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    22
  
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    23
  $remoteDir =~ s{\\}{\/}g;   #convert back slashes to forward slashes
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    24
  
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    25
  my $retry;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    26
  for ($retry = 0; $retry < $dirlist_retries; $retry++) {
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    27
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    28
    unless ($self->Connected()) {
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    29
      $self->Connect();
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    30
    }
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    31
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    32
    # The Net::FTP module that we're using here has two options for listing the contents 
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    33
    # of a directory. They are the 'ls' and 'dir' calls.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    34
    # The 'ls' call is great, and just returns a list of the items. But, irritatingly, it
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    35
    # misses out directories: the returned list just contains names of *files*.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    36
    # dir is better, in some ways, as it lists directories too, but its output format
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    37
    # varies from one FTP site to the next. So we have to stick with ls.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    38
    print "About to call dir(\"$remoteDir\")\n" if ($self->{verbose});
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    39
    my %hash = $self->dir($remoteDir);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    40
    my @items = keys %hash;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    41
    @items = grep { $_ ne "." && $_ ne ".." } @items;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    42
    @items = map { "$remoteDir/$_" } @items; # prepend the path as that's the output format
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    43
      # that is expected of this function
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    44
    return \@items;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    45
  }
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    46
  die "Error: have tried to list \"$remoteDir\" $retry times with no success - giving up\n";
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    47
}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    48
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    49
# Code from Net::FTP::Common v 4.0a
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    50
sub dir {       
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    51
  my ($self, $directory) = @_;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    52
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    53
  my $ftp = $self->{ftp};
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    54
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    55
  my $dir = $ftp->dir($directory);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    56
  if (!defined($dir)) {
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    57
    return ();
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    58
  } else
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    59
  {
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    60
    my %HoH;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    61
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    62
    # Comments were made on this code in this thread:
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    63
    # http://perlmonks.org/index.pl?node_id=287552
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    64
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    65
    foreach (@{$dir})
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    66
        {
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    67
	      $_ = m#([a-z-]*)\s*([0-9]*)\s*([0-9a-zA-Z]*)\s*([0-9a-zA-Z]*)\s*([0-9]*)\s*([A-Za-z]*)\s*([0-9]*)\s*([0-9A-Za-z:]*)\s*([\w*\W*\s*\S*]*)#;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    68
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    69
        my $perm = $1;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    70
        my $inode = $2;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    71
        my $owner = $3;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    72
        my $group = $4;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    73
        my $size = $5;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    74
        my $month = $6;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    75
        my $day = $7;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    76
        my $yearOrTime = $8;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    77
        my $name = $9;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    78
        my $linkTarget;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    79
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    80
        if ( $' =~ m#\s*->\s*([A-Za-z0-9.-/]*)# )       # it's a symlink
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    81
                { $linkTarget = $1; }
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    82
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    83
        $HoH{$name}{perm} = $perm;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    84
        $HoH{$name}{inode} = $inode;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    85
        $HoH{$name}{owner} = $owner;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    86
        $HoH{$name}{group} = $group;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    87
        $HoH{$name}{size} = $size;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    88
        $HoH{$name}{month} = $month;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    89
        $HoH{$name}{day} = $day;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    90
        $HoH{$name}{yearOrTime} =  $yearOrTime;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    91
        $HoH{$name}{linkTarget} = $linkTarget;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    92
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    93
        }
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    94
  return(%HoH);
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    95
  }
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    96
}
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    97
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    98
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
    99
1;
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   100
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   101
=head1 NAME
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   102
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   103
RemoteSite::FTP::Experimental.pm - Access a remote FTP site.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   104
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   105
=head1 DESCRIPTION
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   106
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   107
C<RemoteSite::FTP::Experimental> is inherited from the abstract base class C<RemoteSite>, implementing the abstract methods required for transfer of files to and from a remote site when the remote site is an FTP server.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   108
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   109
This class differs from C<RemoteSite::FTP> only in using a different mechanism for listing the contents of directories on FTP sites.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   110
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   111
=head1 KNOWN BUGS
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   112
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   113
None
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   114
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   115
=head1 COPYRIGHT
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   116
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   117
Copyright (c) 2000-2006, The Perl Foundation. All rights reserved.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   118
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   119
3145852acc89 add releasing to new structure
jjkang
parents:
diff changeset
   120
=cut