File Coverage

blib/lib/Wx/Perl/FSHandler/LWP.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

package Wx::Perl::FSHandler::LWP;

=head1 NAME

C - file system handler based upon LWP

=head1 SYNOPSIS

  my $ua = LWP::UserAgent->new;

  # customize the User Agent, set proxy, supported protocols, ...

  my $handler = Wx::Perl::FSHandler::LWP->new( $ua );

  Wx::FileSystem::AddHandler( $handler );

=head1 DESCRIPTION

The C is a C
implementation based upon C, and is meant as a
superior replacement for C.

=cut

use Wx::FS;

use strict;
use base 'Wx::PlFileSystemHandler';

use LWP::UserAgent;
use IO::Scalar;

our $VERSION = '0.03';

=head2 new

  my $handler = Wx::Perl::FSHandler::LWP->new( $ua );

Creates a new instance. C<$ua> must be an object of class
C, which will be used to handle requests.

=cut

sub new {
    my( $class, $ua ) = @_;
    my $self = $class->SUPER::new;

    $self->{user_agent} = $ua;

    return $self;
}

=head2 CanOpen

Called internally by C. Calls C
on the user agent to determine if the location can be opened.

=cut

sub CanOpen {
    my( $self, $location ) = @_;
    my $uri = URI->new( $location );

    return $self->user_agent->is_protocol_supported( $uri->scheme );
}

=head2 OpenFile

Called internally by C. Uses the user agent to fetch
the URL and returns a C representing the result.

=cut

sub OpenFile {
    my( $self, $fs, $location ) = @_;

    # work around bug in Wx::FileSystem: remove artificial '//'
    if(    index( $location, $fs->GetPath ) == 0
        && substr( $location, length( $fs->GetPath ) - 1, 2 ) eq '//' ) {
        substr $location, length( $fs->GetPath ) - 1, 2, '/';
    }
    my $uri = URI->new( $location );
    my $request = HTTP::Request->new( 'GET', $uri );
    my $response = $self->user_agent->request( $request, undef );

    return undef unless $response->is_success;

    my $value = $response->content;
    my $fh = IO::Scalar->new( \$value );
    my $file = Wx::FSFile->new( $fh, $response->base,
                                scalar $response->content_type,
                                $uri->fragment || '' );

    return $file;
}

=head2 user_agent

  my $ua = $handler->user_agent;

Returns the C object used to handle requests.

=cut

sub user_agent   { $_[0]->{user_agent} }

=head1 ENVIRONMENTAL VARIABLES

See L.

=head1 AUTHOR

Mattia Barbon

=head1 LICENSE

Copyright (c) 2003, 2006 Mattia Barbon.

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

=head1 SEE ALSO

L

wxFileSystem and wxFileSystemHandler in wxPerl documentation.

=cut

1;