File Coverage

blib/lib/URI/Template.pm

Criterion	Covered	Total	%
statement	96	169	56.8
branch	34	104	32.6
condition	4	17	23.5
subroutine	16	20	80.0
pod	6	6	100.0
total	156	316	49.3

package URI::Template;

use strict;
use warnings;

our $VERSION = '0.23';

use URI;
use URI::Escape        ();
use Unicode::Normalize ();
use overload '""' => \&template;

my $RESERVED = q(:/?#\[\]\@!\$\&'\(\)\*\+,;=);
my %TOSTRING = (
    ''  => \&_tostring,
    '+' => \&_tostring,
    '#' => \&_tostring,
    ';' => \&_tostring_semi,
    '?' => \&_tostring_query,
    '&' => \&_tostring_query,
    '/' => \&_tostring_path,
    '.' => \&_tostring_path,
);

sub new {
    my $class = shift;
    my $templ = shift;
    $templ = '' unless defined $templ;
    my $self  = bless { template => $templ, _vars => {} } => $class;

    $self->_study;

    return $self;
}

sub _quote {
    my ( $val, $safe ) = @_;
    $safe ||= '';
    my $unsafe = '^A-Za-z0-9\-\._' . $safe;

    ## Where RESERVED are allowed to pass-through, so are
    ## already-pct-encoded values
    if( $safe ) {
        my (@chunks) = split(/(%[0-9A-Fa-f]{2})/, $val);

        # even chunks are not %xx, odd chunks are
        return join '',
            map { $_ % 2
                  ? $chunks[$_]
                  : URI::Escape::uri_escape_utf8( Unicode::Normalize::NFKC($chunks[$_]), $unsafe ) } 0..$#chunks;

    }

    # try to mirror python's urllib quote
    return URI::Escape::uri_escape_utf8( Unicode::Normalize::NFKC( $val ),
        $unsafe );
}

sub _tostring {
    my ( $var, $value, $exp ) = @_;
    my $safe = $exp->{ safe };

    if ( ref $value eq 'ARRAY' ) {
        return join( ',', map { _quote( $_, $safe ) } @$value );
    }
    elsif ( ref $value eq 'HASH' ) {
        return join(
            ',',
            map {
                _quote( $_, $safe )
                    . ( $var->{ explode } ? '=' : ',' )
                    . _quote( $value->{ $_ }, $safe )
                } sort keys %$value
        );
    }
    elsif ( defined $value ) {
        return _quote(
            substr( $value, 0, $var->{ prefix } || length( $value ) ),
            $safe );
    }

    return;
}

sub _tostring_semi {
    my ( $var, $value, $exp ) = @_;
    my $safe = $exp->{ safe };
    my $join = $exp->{ op };
    $join = '&' if $exp->{ op } eq '?';

    if ( ref $value eq 'ARRAY' ) {
        if ( $var->{ explode } ) {
            return join( $join,
                map { $var->{ name } . '=' . _quote( $_, $safe ) } @$value );
        }
        else {
            return $var->{ name } . '='
                . join( ',', map { _quote( $_, $safe ) } @$value );
        }
    }
    elsif ( ref $value eq 'HASH' ) {
        if ( $var->{ explode } ) {
            return join(
                $join,
                map {
                    _quote( $_, $safe ) . '='
                        . _quote( $value->{ $_ }, $safe )
                    } sort keys %$value
            );
        }
        else {
            return $var->{ name } . '=' . join(
                ',',
                map {
                    _quote( $_, $safe ) . ','
                        . _quote( $value->{ $_ }, $safe )
                    } sort keys %$value
            );
        }
    }
    elsif ( defined $value ) {
        return $var->{ name } unless length( $value );
        return
            $var->{ name } . '='
            . _quote(
            substr( $value, 0, $var->{ prefix } || length( $value ) ),
            $safe );
    }

    return;
}

sub _tostring_query {
    my ( $var, $value, $exp ) = @_;
    my $safe = $exp->{ safe };
    my $join = $exp->{ op };
    $join = '&' if $exp->{ op } =~ /[?&]/;

    if ( ref $value eq 'ARRAY' ) {
        return if !@$value;
        if ( $var->{ explode } ) {
            return join( $join,
                map { $var->{ name } . '=' . _quote( $_, $safe ) } @$value );
        }
        else {
            return $var->{ name } . '='
                . join( ',', map { _quote( $_, $safe ) } @$value );
        }
    }
    elsif ( ref $value eq 'HASH' ) {
        return if !keys %$value;
        if ( $var->{ explode } ) {
            return join(
                $join,
                map {
                    _quote( $_, $safe ) . '='
                        . _quote( $value->{ $_ }, $safe )
                    } sort keys %$value
            );
        }
        else {
            return $var->{ name } . '=' . join(
                ',',
                map {
                    _quote( $_, $safe ) . ','
                        . _quote( $value->{ $_ }, $safe )
                    } sort keys %$value
            );
        }
    }
    elsif ( defined $value ) {
        return $var->{ name } . '=' unless length( $value );
        return
            $var->{ name } . '='
            . _quote(
            substr( $value, 0, $var->{ prefix } || length( $value ) ),
            $safe );
    }
}

sub _tostring_path {
    my ( $var, $value, $exp ) = @_;
    my $safe = $exp->{ safe };
    my $join = $exp->{ op };

    if ( ref $value eq 'ARRAY' ) {
        return unless @$value;
        return join(
            ( $var->{ explode } ? $join : ',' ),
            map { _quote( $_, $safe ) } @$value
        );
    }
    elsif ( ref $value eq 'HASH' ) {
        return join(
            ( $var->{ explode } ? $join : ',' ),
            map {
                _quote( $_, $safe )
                    . ( $var->{ explode } ? '=' : ',' )
                    . _quote( $value->{ $_ }, $safe )
                } sort keys %$value
        );
    }
    elsif ( defined $value ) {
        return _quote(
            substr( $value, 0, $var->{ prefix } || length( $value ) ),
            $safe );
    }

    return;
}

sub _study {
    my ( $self ) = @_;
    my @hunks = grep { defined && length } split /(\{.+?\})/, $self->template;
    my $pos = 1;
    for ( @hunks ) {
        next unless /^\{(.+?)\}$/;
        $_ = $self->_compile_expansion( $1, $pos++ );
    }
    $self->{ studied } = \@hunks;
}

sub _compile_expansion {
    my ( $self, $str, $pos ) = @_;

    my %exp = ( op => '', vars => [], str => $str );
    if ( $str =~ /^([+#.\/;?&|!\@])(.+)/ ) {
        $exp{ op }  = $1;
        $exp{ str } = $2;
    }

    $exp{ safe } = $RESERVED if $exp{ op } =~ m{[+#]};

    for my $varspec ( split( ',', delete $exp{ str } ) ) {
        my %var = ( name => $varspec );
        if ( $varspec =~ /=/ ) {
            @var{ 'name', 'default' } = split( /=/, $varspec, 2 );
        }
        if ( $var{ name } =~ s{\*$}{} ) {
            $var{ explode } = 1;
        }
        elsif ( $var{ name } =~ /:/ ) {
            @var{ 'name', 'prefix' } = split( /:/, $var{ name }, 2 );
            if ( $var{ prefix } =~ m{[^0-9]} ) {
                die 'Non-numeric prefix specified';
            }
        }

        # remove "optional" flag (for opensearch compatibility)
        $var{ name } =~ s{\?$}{};
        $self->{ _vars }->{ $var{ name } } = $pos;

        push @{ $exp{ vars } }, \%var;
    }

    my $join  = $exp{ op };
    my $start = $exp{ op };

    if ( $exp{ op } eq '+' ) {
        $start = '';
        $join  = ',';
    }
    elsif ( $exp{ op } eq '#' ) {
        $join = ',';
    }
    elsif ( $exp{ op } eq '?' ) {
        $join = '&';
    }
    elsif ( $exp{ op } eq '&' ) {
        $join = '&';
    }
    elsif ( $exp{ op } eq '' ) {
        $join = ',';
    }

    if ( !exists $TOSTRING{ $exp{ op } } ) {
        die 'Invalid operation "' . $exp{ op } . '"';
    }

    return sub {
        my $variables = shift;

        my @return;
        for my $var ( @{ $exp{ vars } } ) {
            my $value;
            if ( exists $variables->{ $var->{ name } } ) {
                $value = $variables->{ $var->{ name } };
            }
            $value = $var->{ default } if !defined $value;

            next unless defined $value;

            my $expand = $TOSTRING{ $exp{ op } }->( $var, $value, \%exp );

            push @return, $expand if defined $expand;
        }

        return $start . join( $join, @return ) if @return;
        return '';
    };
}

sub template {
    my $self = shift;
    my $templ = shift;

    #   Update template
    if ( defined $templ && $templ ne $self->{ template } ) {
        $self->{ template } = $templ;
        $self->{ _vars } = {};
        $self->_study;
        return $self;
    }

    return $self->{ template };
}

sub variables {
    my @vars = sort {$_[ 0 ]->{ _vars }->{ $a } <=> $_[ 0 ]->{ _vars }->{ $b } } keys %{ $_[ 0 ]->{ _vars } };
    return @vars;
}

sub expansions {
    my $self = shift;
    return grep { ref } @{ $self->{ studied } };
}

sub process {
    my $self = shift;
    return URI->new( $self->process_to_string( @_ ) );
}

sub process_to_string {
    my $self = shift;
    my $arg  = @_ == 1 ? $_[ 0 ] : { @_ };
    my $str  = '';

    for my $hunk ( @{ $self->{ studied } } ) {
        if ( !ref $hunk ) { $str .= $hunk; next; }

        $str .= $hunk->( $arg );
    }

    return $str;
}

1;

__END__