view release on metacpan or  search on metacpan

inc/inc_File-Fetch/File/Fetch.pm  view on Meta::CPAN

    use File::Fetch;

    ### build a File::Fetch object ###
    my $ff = File::Fetch->new(uri => 'http://some.where.com/dir/a.txt');

    ### fetch the uri to cwd() ###
    my $where = $ff->fetch() or die $ff->error;

    ### fetch the uri to /tmp ###
    my $where = $ff->fetch( to => '/tmp' );

    ### parsed bits from the uri ###
    $ff->uri;
    $ff->scheme;
    $ff->host;
    $ff->path;
    $ff->file;

=head1 DESCRIPTION

File::Fetch is a generic file fetching mechanism.

It allows you to fetch any file pointed to by a C<ftp>, C<http>,
C<file>, or C<rsync> uri by a number of different means.

See the C<HOW IT WORKS> section further down for details.

=head1 ACCESSORS

A C<File::Fetch> object has the following accessors

=over 4

=item $ff->uri

The uri you passed to the constructor

=item $ff->scheme

The scheme from the uri (like 'file', 'http', etc)

=item $ff->host

The hostname in the uri.  Will be empty if host was originally
'localhost' for a 'file://' url.

=item $ff->vol

On operating systems with the concept of a volume the second element
of a file:// is considered to the be volume specification for the file.
Thus on Win32 this routine returns the volume, on other operating
systems this returns nothing.

On Windows this value may be empty if the uri is to a network share, in
which case the 'share' property will be defined. Additionally, volume
specifications that use '|' as ':' will be converted on read to use ':'.

On VMS, which has a volume concept, this field will be empty because VMS
file specifications are converted to absolute UNIX format and the volume
information is transparently included.

=item $ff->share

On systems with the concept of a network share (currently only Windows) returns
the sharename from a file://// url.  On other operating systems returns empty.

=item $ff->path

The path from the uri, will be at least a single '/'.

=item $ff->file

The name of the remote file. For the local file name, the
result of $ff->output_file will be used.

=item $ff->file_default

The name of the default local file, that $ff->output_file falls back to if
it would otherwise return no filename. For example when fetching a URI like
http://www.abc.net.au/ the contents retrieved may be from a remote file called
'index.html'. The default value of this attribute is literally 'file_default'.

=cut


##########################
### Object & Accessors ###
##########################

{
    ### template for autogenerated accessors ###
    my $Tmpl = {
        scheme          => { default => 'http' },
        host            => { default => 'localhost' },
        path            => { default => '/' },
        file            => { required => 1 },
        uri             => { required => 1 },
        vol             => { default => '' }, # windows for file:// uris
        share           => { default => '' }, # windows for file:// uris
        file_default    => { default => 'file_default' },
        _error_msg      => { no_override => 1 },
        _error_msg_long => { no_override => 1 },
    };

    for my $method ( keys %$Tmpl ) {
        no strict 'refs';
        *$method = sub {
                        my $self = shift;
                        $self->{$method} = $_[0] if @_;
                        return $self->{$method};
                    }
    }

    sub _create {
        my $class = shift;
        my %hash  = @_;

        my $args = check( $Tmpl, \%hash ) or return;

        bless $args, $class;

inc/inc_File-Fetch/File/Fetch.pm  view on Meta::CPAN

### Simple IO::Socket::INET fetching ###
sub _iosock_fetch {
    my $self = shift;
    my %hash = @_;

    my ($to);
    my $tmpl = {
        to  => { required => 1, store => \$to }
    };
    check( $tmpl, \%hash ) or return;

    my $use_list = {
        'IO::Socket::INET' => '0.0',
        'IO::Select'       => '0.0',
    };

    if( can_load(modules => $use_list) ) {
        my $sock = IO::Socket::INET->new(
            PeerHost => $self->host,
            ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ),
        );

        unless ( $sock ) {
            return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!));
        }

        my $fh = FileHandle->new;

        # Check open()

        unless ( $fh->open($to,'>') ) {
            return $self->_error(loc(
                 "Could not open '%1' for writing: %2",$to,$!));
        }

        $fh->autoflush(1);
        binmode $fh;

        my $path = File::Spec::Unix->catfile( $self->path, $self->file );
        my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a";
        $sock->send( $req );

        my $select = IO::Select->new( $sock );

        my $resp = '';
        my $normal = 0;
        while ( $select->can_read( $TIMEOUT || 60 ) ) {
          my $ret = $sock->sysread( $resp, 4096, length($resp) );
          if ( !defined $ret or $ret == 0 ) {
            $select->remove( $sock );
            $normal++;
          }
        }
        close $sock;

        unless ( $normal ) {
            return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
        }

        # Check the "response"
        # Strip preceding blank lines apparently they are allowed (RFC 2616 4.1)
        $resp =~ s/^(\x0d?\x0a)+//;
        # Check it is an HTTP response
        unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) {
            return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host));
        }

        # Check for OK
        my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i;
        unless ( $code eq '200' ) {
            return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
        }

        {
          local $\;
          print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
        }
        close $fh;
        return $to;

    } else {
        $METHOD_FAIL->{'iosock'} = 1;
        return;
    }
}

### Net::FTP fetching
sub _netftp_fetch {
    my $self = shift;
    my %hash = @_;

    my ($to);
    my $tmpl = {
        to  => { required => 1, store => \$to }
    };
    check( $tmpl, \%hash ) or return;

    ### required modules ###
    my $use_list = { 'Net::FTP' => 0 };

    if( can_load( modules => $use_list ) ) {

        ### make connection ###
        my $ftp;
        my @options = ($self->host);
        push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
        unless( $ftp = Net::FTP->new( @options ) ) {
            return $self->_error(loc("Ftp creation failed: %1",$@));
        }

        ### login ###
        unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
            return $self->_error(loc("Could not login to '%1'",$self->host));
        }

        ### set binary mode, just in case ###
        $ftp->binary;

        ### create the remote path
        ### remember remote paths are unix paths! [#11483]
        my $remote = File::Spec::Unix->catfile( $self->path, $self->file );