root/trunk/Padre/lib/Padre/File/FTP.pm @ 9218

package Padre::File::FTP;

use 5.008;
use strict;
use warnings;

use Padre::File;
use File::Temp;

our $VERSION = '0.50';
our @ISA     = 'Padre::File';

sub new {
        my $class = shift;

        my $url = shift;

        # Create myself
        my $self = bless { filename => $url }, $class;

        # Using the config is optional, tests and other usages should run without
        my $config = eval { return Padre->ide->config; };
        if (defined($config)) {
                $self->{_timeout} = $config->file_ftp_timeout;
                $self->{_passive} = $config->file_ftp_passive;
        } else {
                # Use defaults if we have no config
                $self->{_timeout} = 60;
                $self->{_passive} = 1;
        }

        # Don't add a new overall-dependency to Padre:
        eval { require Net::FTP; };
        if ($@) {

                $self->{error} = 'Net::FTP is not installed, Padre::File::FTP currently depends on it.';
                return $self;
        }

##### START URL parsing #####

##### NO REGEX's below this line (except the parser)! #####

        # TO DO: Improve URL parsing
        if ( $url !~ /ftp\:\/?\/?((.+?)(\:(.+?))?\@)?([a-z0-9\-\.]+)(\:(\d+))?(\/.+)$/i ) {

                # URL parsing failed
                # TO DO: Warning should go to a user popup not to the text console
                $self->{error} = 'Unable to parse ' . $url;
                return $self;
        }


        # Login data
        if ( defined($2) ) {
                $self->{_user} = $2;
                $self->{_pass} = $4 if defined($4);
        } else {
                $self->{_user} = 'ftp';
                $self->{_pass} = 'padre_user@devnull.perlide.org';
        }

        # Host & port
        $self->{_host} = $5;
        $self->{_port} = $7 || 21;

        # Path & filename
        $self->{_file} = $8;

##### END URL parsing, regex is allowed again #####

        if ( !defined( $self->{_pass} ) ) {

                # TO DO: Ask the user for a password
        }

        # TO DO: Handle aborted/timed out connections

        # Create FTP object and connection
        $self->{_ftp} = Net::FTP->new(
                Host    => $self->{_host},
                Port    => $self->{_port},
                Timeout => $self->{_timeout},
                Passive => $self->{_passive},

                #               Debug => 3, # Enable for FTP-debugging to STDERR
        );

        if ( !defined( $self->{_ftp} ) ) {

                $self->{error} = 'Error connecting to ' . $self->{_host} . ':' . $self->{_port} . ': ' . $@;
                return $self;
        }

        if ( !$self->{_ftp}->login( $self->{_user}, $self->{_pass} ) ) {

                $self->{error} = 'Error logging in on ' . $self->{_host} . ':' . $self->{_port} . ': ' . $@;
                return $self;
        }

        $self->{_ftp}->binary;

        $self->{protocol} = 'ftp'; # Should not be overridden

        $self->{_file_temp} = File::Temp->new( UNLINK => 1 );
        $self->{_tmpfile} = $self->{_file_temp}->filename;

        return $self;
}

sub can_run {
        return 0;
}

sub size {
        my $self = shift;
        return if !defined( $self->{_ftp} );
        return $self->{_ftp}->size( $self->{_file} );
}

sub _todo_mode {
        my $self = shift;
        return 33024; # Currently fixed: read-only textfile
}

sub _todo_mtime {
        my $self = shift;

        # The file-changed-on-disk - function requests this frequently:
        if ( defined( $self->{_cached_mtime_time} ) and ( $self->{_cached_mtime_time} > ( time - 60 ) ) ) {
                return $self->{_cached_mtime_value};
        }

        require HTTP::Date; # Part of LWP which is required for this module but not for Padre
        my ( $Content, $Result ) = $self->_request('HEAD');

        $self->{_cached_mtime_value} = HTTP::Date::str2time( $Result->header('Last-Modified') );
        $self->{_cached_mtime_time}  = time;

        return $self->{_cached_mtime_value};
}

sub exists {
        my $self = shift;
        return if !defined( $self->{_ftp} );

        # Cache basename value
        my $basename = $self->basename;

        for ($self->{_ftp}->ls($self->{_file})) {
                return 1 if $_ eq $self->{_file};
                return 1 if $_ eq $basename;
        }

        # Fallback if ->ls didn't help. A file heaving a size should exist.
        return 1 if $self->size;

        return 0;
}

sub basename {
        my $self = shift;

        my $name = $self->{_file};
        $name =~ s/^.*\///;

        return $name;
}

# This method should return the dirname to be used inside Padre, not the one
# used on the FTP-server.
sub dirname {
        my $self = shift;

        my $dir = $self->{filename};
        $dir =~ s/\/[^\/]*$//;

        return $dir;
}

sub read {
        my $self = shift;

        return if !defined( $self->{_ftp} );

        # TO DO: Better error handling
        $self->{_ftp}->get( $self->{_file}, $self->{_tmpfile} ) or $self->{error} = $@;
        open my $tmpfh, $self->{_tmpfile};
        return join( '', <$tmpfh> );
}

sub readonly {

        # TO DO: Check file access
        return 0;
}

sub write {
        my $self    = shift;
        my $content = shift;
        my $encode  = shift || ''; # undef encode = default, but undef will trigger a warning

        return if !defined( $self->{_ftp} );

        my $fh;
        if ( !open $fh, ">$encode", $self->{_tmpfile} ) {
                $self->{error} = $!;
                return 0;
        }
        print {$fh} $content;
        close $fh;

        # TO DO: Better error handling
        $self->{_ftp}->put( $self->{_tmpfile}, $self->{_file} ) or warn $@;

        return 1;
}

###############################################################################
### Internal FTP helper functions

sub _ftp_dirname {
        my $self = shift;

        my $dir = $self->{_file};
        $dir =~ s/\/[^\/]*$//;

        return $dir;
}


1;

# Copyright 2008-2009 The Padre development team as listed in Padre.pm.
# LICENSE
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl 5 itself.