root/lang/perl/Net-FTP-Stepstone/trunk/lib/Net/FTP/Stepstone.pm @ 7839

package Net::FTP::Stepstone;

use strict;
use strict;
use base qw(Class::Accessor::Fast);
use File::stat ();
use File::Basename;
use Time::Piece;

our $VERSION = '0.02';
__PACKAGE__->mk_accessors(qw(
    cwd
    lcwd
    stepstone_addr
    stepstone_user
    ftp_addr
    ftp_user
    ftp_pass
    ftp_port
));

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->cwd('.') unless $self->cwd;
    $self->ftp_port(21) unless $self->ftp_port;
    return $self;
}

sub ls {
    my $self = shift;
    my $arg = shift || '';
    my @lines = $self->_ftp_command("ls $arg");
    my @items = ();
    for (@lines) {
        my $name = (split(' ', $_))[8] or next;
        $name =~ m{^\.{1,2}$} and next;
        push @items, $name;
    }
    return @items;
}

sub stat {
    my $self = shift;
    my $arg = shift or return;
    $arg =~ s{/$}{};
    my $dir = dirname($arg);
    my $base = basename($arg);
    my @lines = $self->_ftp_command("ls $dir");
    my $stob;
    for (@lines) {
        (split(' ', $_))[8] eq $base or next;
        $stob = $self->_stat($_);
    }
    return $stob;
}

sub pwd {
    my $self = shift;
    if ($self->cwd eq '.') {
        $self->_ftp_command('');
    }
    return $self->cwd;
}

sub lcd {
    my $self = shift;
    my $arg = shift;
    $self->_ftp_command("lcd $arg");
    $self->lcwd($arg);
}

for my $command (qw(cd get mget)) {
    no strict 'refs';
    *$command = sub {
        my $self = shift;
        my $arg = join ' ', @_;
        my $res = $self->_ftp_command("$command $arg");
        return $res unless $res =~ /^2/;
        return;
    };
}

sub _ftp_command {
    my $self = shift;
    my $command = shift || '';
    $command = "lcd $self->{lcwd}\n".$command if $self->lcwd;
    my $ftp_command = <<EOF;
open $self->{ftp_addr} $self->{ftp_port}
user $self->{ftp_user} $self->{ftp_pass}
prompt
type binary
cd $self->{cwd}
$command
pwd
close
quit
EOF
    my @all = ` echo "$ftp_command" | ssh -l $self->{stepstone_user} $self->{stepstone_addr} ftp -n 2>/dev/null`;
    my @lines = grep {$_ !~ m/not understood|Interactive mode off.|Local directory now/} @all;
    if (my $last_line = $lines[-1]) {
        my ($code, $cwd) = split '"', $last_line;
        if ($code =~ /257/) {
            $self->cwd($cwd);
        } else {
            return $last_line;
        }
    }
    if (scalar @lines > 1) {
        return @lines[0..($#lines -1)];
    }
    return undef;
}

sub _stat {
    my $self = shift;
    my $line = shift;
    my ($mode, $nlink, $user, $group, $size, $month, $date, $time_or_year, $name) = split (" ", $line);
    my ($time, $year);
    if ($time_or_year =~ /:/) {
        $time = $time_or_year;
        $year = Time::Piece->strptime($month, "%b")->mon > localtime->mon ? 
            localtime->year - 1 : localtime->year;
    } else {
        $time = '00:00';
        $year = $time_or_year;
    }
    my $mtime = Time::Piece->strptime(join(' ', $year, $month, $date, $time),"%Y %b %d %H:%M")->epoch;
    my $uid = $self->_getent_passwd($user);
    my $gid = $self->_getent_group($group);
    my $stob = File::stat::populate(
        0,                      # dev
        0,                      # ino
        $self->_mode($mode),    # mode
        $nlink + 0,             # nlink
        $uid + 0,               # uid
        $gid + 0,               # gid
        0,                      # rdev
        $size + 0,              # size
        0,                      # atime
        $mtime + 0,             # mtime
        0,                      # ctime
        1,                      # blksize
        $size + 0,              # blocks
    );
    return $stob;
}

for my $db (qw(group passwd)) {
    no strict 'refs';
    my $command = "_getent_$db";
    *$command = sub {
        my $self = shift;
        my $name = shift;
        my $val = `getent $db $name | cut -d: -f3`;
        chomp $val;
        $val = 99 unless length $val;
        return $val;
    }
}

sub _mode {
    my $self = shift;
    my $mode = shift;
    my $val = 0;
    my ($t,$u,$g,$o) = ($mode =~ /^(.)(...)(...)(...)$/);

    for ($t){
        $val |= 0010000 if /p/;
        $val |= 0020000 if /c/;
        $val |= 0040000 if /d/;
        $val |= 0060000 if /b/;
        $val |= 0100000 if /-/;
        $val |= 0120000 if /l/;
        $val |= 0140000 if /s/;
    }

    for ($u){
        $val |= 0400 if /r/;
        $val |= 0200 if /w/;
        $val |= 0100 if /[xs]/;
        $val |= 04000 if /[sS]/;
    }

    for ($g){
        $val |= 0040 if /r/;
        $val |= 0020 if /w/;
        $val |= 0010 if /[xs]/;
        $val |= 02000 if /[sS]/;
    }

    for ($o){
        $val |= 0004 if /r/;
        $val |= 0002 if /w/;
        $val |= 0001 if /[xt]/;
        $val |= 01000 if /[Tt]/;
    }

    return $val;
}


1;
__END__

=head1 NAME

Net::FTP::Stepstone -

=head1 SYNOPSIS

  use Net::FTP::Stepstone;

=head1 DESCRIPTION

Net::FTP::Stepstone is

=head1 AUTHOR

Author E<lt>author@galaxyE<gt>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

L<>

=cut