URI::SmartURI - Subclassable and hostless URIs

    my $uri = URI::SmartURI->new(
        'http://host/foo/',
        { reference => 'http://host/bar/' }
    );

    my $hostless = $uri->hostless; # '/foo/'

    $hostless->absolute; # 'http://host/foo/'

    $uri->relative; # '../foo/'

    my $uri = URI::SmartURI->new('http://dev.catalyst.perl.org/');

    my $uri = URI::SmartURI->new('/dev.catalyst.perl.org/new-wiki/', 'http');

    my $uri = URI::SmartURI->new(
        'http://search.cpan.org/~jrockway/Catalyst-Manual-5.701003/', 
        { reference => 'http://search.cpan.org/' }
    );

    use URI::SmartURI '-import_uri_mods';
    use URI::SmartURI::WithBase;
    use URI::SmartURI::URL;

    my $url = URI::SmartURI::URL->new(...); # URI::URL proxy

    use URI::SmartURI '-import_uri_mods';
    use URI::SmartURI::Escape qw(%escapes);

    perldoc URI::SmartURI

package URI::SmartURI;

use Moose;
use mro 'c3';

our $VERSION = '0.031';

use URI;
use URI::URL;
use URI::QueryParam;
use File::Find::Rule;
use File::Spec::Functions qw/splitpath splitdir catfile catpath/;
use List::MoreUtils 'firstidx';
use Scalar::Util 'blessed';
use List::Util 'first';
use Exporter ();
use Class::C3::Componentised;

use namespace::clean -except => 'meta';

has 'obj'           => (is => 'ro', isa => 'Object');
has 'factory_class' => (is => 'ro', isa => 'ClassName');
has 'reference'     => (is => 'rw', isa => 'Maybe[Str]');

sub new {
    my ($class, $uri, $opts) = @_;

    $opts = { scheme => $opts }
        unless ref($opts) && ref($opts) eq 'HASH';

    my $self = {
        obj       => URI->new($class->_deflate_uris($uri, $opts->{scheme})),
        reference => $opts->{reference},
        factory_class => $class
    };

    bless $self, $class->_make_uri_class(blessed $self->{obj}, 1);
}

sub new_abs {
    my $class = shift;

    my $self = {
        obj => URI->new_abs($class->_deflate_uris(@_)),
        factory_class => $class
    };

    bless $self, $class->_make_uri_class(blessed $self->{obj}, 1);
}

sub newlocal {
    my $class = shift;

    my $self = {
        obj => URI::URL->newlocal($class->_deflate_uris(@_)),
        factory_class => $class
    };

    bless $self, $class->_make_uri_class(blessed $self->{obj}, 1);
}

sub hostless {
    my $uri = $_[0]->clone;

    $uri->scheme('');
    $uri->host('');
    $uri->port('');

    $uri->factory_class->new(($uri =~ m!^[/:]*(/.*)!), $_[0]->_opts);
}

sub relative { $_[0]->rel($_[0]->reference) }

sub absolute { $_[0]->abs($_[0]->reference) }

use overload
    '""' => sub { "".$_[0]->obj },
    '==' =>
        sub { overload::StrVal($_[0]->obj) eq overload::StrVal($_[1]->obj) },
    fallback => 1;

sub eq {
    my ($self, $other) = @_;

# Support URI::eq($first, $second) syntax. Not inheritance-safe :(
    $self = blessed $self ? $self : __PACKAGE__->new($self);

    return $self->obj->eq(ref $other eq blessed $self ? $other->obj : $other);
}

# The gory details

sub AUTOLOAD {
    use vars qw/$CAN $AUTOLOAD/;
    no strict 'refs';
    my $self   = $_[0];
# stolen from URI sources
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);

    return if ! blessed $self || ! blessed $self->obj
                              || $method eq 'DESTROY'
                              || ! $self->obj->can($method);

    my $class  = $self->factory_class;

    my $sub    = blessed($self)."::$method";

    *{$sub} = sub {
        my $self = shift;
        my @res;
        if (wantarray) {
            @res    = $self->obj->$method($class->_deflate_uris(@_));
        } else {
            $res[0] = $self->obj->$method($class->_deflate_uris(@_));
        }
        @res = $class->_inflate_uris(
            \@res,
            $method ne 'scheme' ? $self->_opts : {}
        );

        return wantarray ? @res : $res[0];
    };

    Class::C3::reinitialize;
    
    $CAN ? \&$sub : goto &$sub;
}

sub can { # of PORK BRAINS in MILK GRAVY, yum!!!
    no strict 'refs';
    use vars qw/$CAN $AUTOLOAD/;
    my ($self, $method) = @_;

    my $existing = eval { $self->next::method($method) };
    undef $@;
    return $existing if $existing;

    local $AUTOLOAD = ref($self)."::$method";
    local $CAN      = 1;

    $self->$method
}

# Preload some URI classes, the ones that come in files anyway,
# but only if asked to.
sub import {
    no strict 'refs';
    my $class = shift;

    return unless $_[0] && $_[0] eq '-import_uri_mods';

# File::Find::Rule is not taint safe, and Module::Starter suggests running
# tests in taint mode. Thanks for helping me with this one Somni!!!
# UPDATE: I turned off taint in tests because it breaks local::lib
    {
        no warnings 'redefine';
        my $getcwd = \&File::Find::Rule::getcwd;
        *File::Find::Rule::getcwd = sub { $getcwd->() =~ m!^(.*)\z! };
        # What are portably valid characters in a directory name anyway?
    }

    my @uri_pms = grep !/SmartURI\.pm\z/,
        File::Find::Rule->extras({untaint => 1})->file->name('*.pm')
        ->in( File::Find::Rule->extras({untaint => 1})->directory
            ->maxdepth(1)->name('URI')->in(
                grep { !ref($_) && -d $_ } @INC
            )
        );

    my @new_uri_pms;

    for (@uri_pms) {
        my ($vol, $dir, $file) = splitpath $_;

        my @dir          = grep $_ ne '', splitdir $dir;
        my @rel_dir      = @dir[(firstidx { $_ eq 'URI' } @dir) ..  $#dir];
        my $mod          = join '::' => @rel_dir, ($file =~ /^(.*)\.pm\z/);

        my $new_class    = $class->_make_uri_class($mod, 0);

        push @new_uri_pms, (join '/' => (split /::/, $new_class)) . '.pm';
    }

# HLAGHALAGHLAGHLAGHLAGH
    push @INC, sub {
        if (first { $_ eq $_[1] } @new_uri_pms) {
            open my $fh, '<', \"1;\n";
            return $fh;
        }
    };

    Class::C3::reinitialize;
}

sub _opts { +{
    reference => $_[0]->reference || undef,
    scheme => $_[0]->scheme || undef
} }

sub _resolve_uri_class {
    my ($class, $uri_class) = @_;

    (my $new_class = $uri_class) =~ s/^URI::/${class}::/;

    return $new_class;
}

sub _make_uri_class {
    my ($class, $uri_class, $re_init_c3) = @_;

    my $new_uri_class = $class->_resolve_uri_class($uri_class);

    no strict 'refs';
    no warnings 'redefine';

    unless (%{$new_uri_class.'::'}) {
        Class::C3::Componentised->inject_base(
            $new_uri_class, $class, 'Exporter'
        );

        *{$new_uri_class.'::new'} = sub {
            eval "require $uri_class";
            bless {
                obj => $uri_class->new($class->_deflate_uris(@_[1..$#_])),
                factory_class => $class
            }, $new_uri_class;
        };

        *{$new_uri_class.'::import'} = sub {
            shift; # $class

            eval "require $uri_class;";
            # URI doesn't use tags, thank god...
            my @vars = grep /^\W/, @_;
            my @subs = (@{$uri_class.'::EXPORT'}, grep /^\w/, @_);

            if (@vars) {
                my $import = $uri_class->can('import');
                @_ = ($uri_class, @vars);
                goto &$import;
            }

            for (@subs) {
                my $sub   = $uri_class."::$_";
                my $proto = prototype $sub;
                $proto    = $proto ? "($proto)" : '';
                eval qq{
                                        sub ${new_uri_class}::$_ $proto {
                                                my \@res;
                                                if (wantarray) {
                                                        \@res    = &${sub}($class->_deflate_uris(\@_));
                                                } else {
                                                        \$res[0] = &${sub}($class->_deflate_uris(\@_));
                                                }

                                                \@res = $class->_inflate_uris(\\\@res);

                                                return wantarray ? \@res : \$res[0];
                                        }
                                };
            }

            @{$new_uri_class."::EXPORT_OK"} = @subs;

            local $^W; # get rid of more redefined warnings
            $new_uri_class->export_to_level(1, $new_uri_class, @subs);
        };

        Class::C3::reinitialize if $re_init_c3;
    }

    return $new_uri_class;
}

sub _inflate_uris {
    my $class = shift;
    my ($args, $opts) = @_;

    my @res = map { blessed($_) && blessed($_) =~ /^URI::/ ?
            bless {
                    obj => $_,
                    factory_class => $class,
                    (defined $opts ? %$opts : ())
                  },
                $class->_make_uri_class(blessed $_, 1)
          :
                $_
    } @$args;
    @res ? @res == 1 ? $res[0] : @res : ();
}

sub _deflate_uris {
    my $class = shift;
    my @res   = map { blessed $_ && $_->isa($class) ?  $_->{obj} : $_ } @_;
    @res ? @res == 1 ? $res[0] : @res : ();
}

__PACKAGE__->meta->make_immutable(inline_constructor => 0);

'LONG LIVE THE ALMIGHTY BUNGHOLE';

# vim: expandtab shiftwidth=4 tw=80: