#!/usr/bin/perl

# This script is an example of how IO::All can be extended for handling
# various kinds of URIs. Currently it works for http:, ftp:, file: (GET only),
# and mailto: ("PUT" only)

use strict;
use warnings;
IO::All::URI->import;

die "please give two URIs, filenames, or somethings\n" unless (@ARGV >= 2);
io(shift) > io(shift);

#################################

package IO::All::URI;

use IO::All '-Base';

my $ua; # The LWP user agent. It is created the first time it's used

sub new {
    my $new = super;
    my $name = shift;

    return $new->lwp($name) if $name =~ /^(https?|ftp|file):/;
    return $new->mailer($name) if $name =~ /^mailto:/;
    $new;
}

sub lwp {
    my $name = shift;
    $self->name($name);
    $self;
}

# I use Mail::Mailer instead of POSTing to a mailto: URI with LWP because
# this seemed simpler and I already had it. However, the other option still
# exists and it would introduce fewer dependencies.
sub mailer {
    require Mail::Mailer;
    require URI;

    my $name = shift;
    $self->name($name);
    $self->is_open(1);

    # Uppercase first letter in header names
    my $i = 1;
    my %headers = map { $_ = ucfirst if $i++ % 2; $_ } 
        URI->new($name)->headers;

    # create mailer
    my $mailer = Mail::Mailer->new->open(\%headers);
    $self->io_handle($mailer);
    $self;
}

sub open {
    # this regex check wouldn't be duplicated if I added an lwp IO type
    # instead of using 'file'! Bad form of laziness...
    if ($self->name =~ /^(https?|ftp|file):/) {
        $self->open_lwp(@_);
    } else {
        super;
    }
}

# note that this method only handles the < and > modes.
sub open_lwp {
    # create user agent if it hasn't been created already
    require LWP::UserAgent;
    $ua ||= LWP::UserAgent->new;

    $self->is_open(1);

    # find out the file mode
    my ($mode) = @_;
    $self->mode($mode) if defined $mode;
    $self->mode('<') unless defined $self->mode;
    $mode = $self->mode;

    my $name = $self->name;
    my $fh;
    my $content;
    if ($mode eq '<') { # GET
        my $content = $ua->get($name)->content or die "couldn't get $name\n";
        # create filehandle
        CORE::open($fh, "<", \$content);
        $self->io_handle($fh);
    } elsif ($mode eq '>') { # PUT
        CORE::open($fh, "+>", \$content);
        $self->io_handle($fh);
    } else {
        die "invalid mode '$mode' for lwp open\n";
    }
    $self;
}

sub close {
    if ($self->name =~ /^(https?|ftp|file):/) {
        $self->close_lwp(@_);
    } else {
        super;
    }
}

# This is the method that actually sends PUT requests, because we wait until
# we have the whole content before sending it.
sub close_lwp {
    if ($self->mode eq '>') { # PUT
        $self->is_open(0);
        my $name = $self->name;

        # get the content back. This is probably a roundabout way of doing it,
        # but I wasn't sure I wanted to add another field to the IO::ALL
        # object...

        my $fh = $self->io_handle;
        seek $fh, 0, 0;
        my $content = do { local $/; <$fh> };

        # LWP request
        my $req = HTTP::Request->new(PUT => $name, undef,  $content);
        my $res = $ua->request($req);
        unless ($res->is_success) {
            die "PUT error: " . $res->status_line . "\n";
        }
    }
    $self;
}

# This is not a very efficient way of copying large files, but it's a quick
# hack while I add 'uri' as a type in the overload_table. This should work
# for files and uris (including mailer).
sub overload_file_to_file() {
    my $temp;
    $_[1] > $temp;
    $temp > $_[2];
}

# same here
sub overload_file_from_file() {
    my $temp;
    $_[2] > $temp;
    $temp > $_[1];
}


# This is to ensure that PUT requests are done automatically. Another option
# would be to create an intermediate filehandle object for the URI, which would
# be destroyed when the IO::All object falls out of scope. This seemed simpler.
sub DESTROY {
    $self->close;
    super;
}