File Coverage

blib/lib/URI/CrawlableHash.pm

Criterion	Covered	Total	%
statement	70	73	95.8
branch	14	22	63.6
condition	2	4	50.0
subroutine	16	16	100.0
pod	1	7	14.2
total	103	122	84.4

package URI::CrawlableHash;

use strict;
use warnings;
our $VERSION = '0.02';

use URI;
use URI::Escape;
use Guard;

sub convert_always {
    my ( $class, $option ) = @_;
    no warnings 'redefine';

    $option ||= "query";

    my $orig = URI->can('new');
    my $conv  = $class->can("convert_to_" . $option);
    unless ($conv) { die "unknown option: " . $option }

    no strict "refs";

    *{'URI::new'} = sub {
        my $self = $orig->(@_);
        if ($self) {
           $conv->($self);
        }
    };

    if ( defined wantarray ) {
        return guard {
            *{"URI::new"} = $orig;
        };
    }
}

sub convert_to_query {
    my $self = shift;
    if ($self->has_crawlable_hash) {
        $self->fragment_to_query
    } else {
        $self
    }
}

sub convert_to_hash {
    my $self = shift;
    if ($self->has_escaped_fragment) {
        $self->query_to_fragment
    } else {
        $self
    }
}

sub URI::has_crawlable_hash {
    my ($uri) = @_;
    ($uri->fragment || "") =~/^!/
}

sub URI::has_escaped_fragment {
    my ($uri) = @_;
    my %hash = $uri->query_form;
    $hash{_escaped_fragment_} ? 1 : undef;
}

sub URI::fragment_to_query {
    my $self = shift;
    return $self unless $self->has_crawlable_hash;

    my $fragment = $self->fragment;
    $fragment =~s/^!//;
    my $q = "_escaped_fragment_=" . uri_escape($fragment, "\x00-\x20\x23\x25\x26\x2b\x7f-\xff");
    if ($self->query) {
        my $old = $self->query;
        $old =~s/_escaped_fragment_=[^\&]*$//;
        my $delimiter = $old ? "&" : "";
        $self->query( $old . $delimiter . $q );
    } else {
        $self->query($q);
    }
    $self->fragment(undef);
    $self;
}

sub URI::query_to_fragment {
    my $self = shift;
    return $self unless $self->has_escaped_fragment;

    my %query = $self->query_form;
    my $escaped = delete $query{_escaped_fragment_};

    my $old = $self->query;
    $old =~s/\&?_escaped_fragment_=[^\&]*$//;

    if ($old) {
        $self->query($old)
    } else {
        $self->query(undef);
    }

    $self->fragment('!' . uri_unescape($escaped));
    $self;
}

1;
__END__