File Coverage

lib/URI/Template/Restrict.pm

Criterion	Covered	Total	%
statement	70	70	100.0
branch	14	18	77.7
condition	3	6	50.0
subroutine	16	16	100.0
pod	6	6	100.0
total	109	116	93.9

package URI::Template::Restrict;

use 5.008_001;
use strict;
use warnings;
use base 'Class::Accessor::Fast';
use overload '""' => \&template, fallback => 1;
use List::MoreUtils qw(uniq);
use Unicode::Normalize qw(NFKC);
use URI;
use URI::Escape qw(uri_escape_utf8);
use URI::Template::Restrict::Expansion;

our $VERSION = '0.06';

__PACKAGE__->mk_accessors(qw'template segments');

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

    my @segments =
        map {
            /^\{(.+?)\}$/
                ? URI::Template::Restrict::Expansion->new($1)
                : $_
        }
        grep { defined && length }
        split /(\{.+?\})/, $template;

    my $self = { template => $template, segments => [@segments] };
    return bless $self, $class;
}

sub expansions {
    return grep { ref $_ } @{ $_[0]->segments };
}

sub variables {
    return
        uniq
        sort
        map { $_->name }
        map { ref $_ eq 'ARRAY' ? @$_ : $_ }
        map { $_->vars }
        $_[0]->expansions;
}

# ----------------------------------------------------------------------
# Draft 03 - 4.4. URI Template Substitution
# ----------------------------------------------------------------------
# * MUST convert every variable value into a sequence of characters in
#   ( unreserved / pct-encoded ).
# * Normalizes the string using NFKC, converts it to UTF-8, and then
#   every octet of the UTF-8 string that falls outside of ( unreserved )
#   MUST be percent-encoded.
# ----------------------------------------------------------------------
sub process {
    my $self = shift;
    return URI->new($self->process_to_string(@_));
}

sub process_to_string {
    my $self = shift;
    my $args = ref $_[0] ? shift : { @_ };
    my $vars = {};

    for my $key (keys %$args) {
        my $value = $args->{$key};
        next if ref $value and ref $value ne 'ARRAY';
        $vars->{$key} = ref $value
            ? [ map { uri_escape_utf8(NFKC($_)) } @$value ]
            : uri_escape_utf8(NFKC($value));
    }

    return join '', map { ref $_ ? $_->process($vars) : $_ } @{ $self->segments };
}

sub extract {
    my ($self, $uri) = @_;

    my $re = join '', map { ref $_ ? '('.$_->pattern.')' : quotemeta $_ } @{ $self->segments };
    my @match = $uri =~ /$re/;

    my @expansions = $self->expansions;
    return unless @match and @match == @expansions;

    my @vars;
    while (@match > 0) {
        my $match = shift @match;
        my $expansion = shift @expansions;
        push @vars, $expansion->extract($match);
    }

    return %{{ @vars }};
}

1;

=head1 NAME

URI::Template::Restrict - restricted URI Templates handler

=head1 SYNOPSIS

    use URI::Template::Restrict;

    my $template = URI::Template::Restrict->new(
        'http://example.com/{foo}'
    );

    my $uri = $template->process(foo => 'y');
    # $uri: "http://example.com/y"

    my %result = $template->extract($uri);
    # %result: (foo => 'y')

=head1 DESCRIPTION

This is a restricted URI Templates handler. URI Templates is described at
L.

This module supports B except B<-opt> and
B<-neg> operators.

=head1 METHODS

=head2 new($template)

Creates a new instance with the template.

=head2 process(%vars)

Given a hash of key-value pairs. It will URI escape the values,
substitute them in to the template, and return a L object.

=head2 process_to_string(%vars)

Processes input like the process method, but doesn't inflate the
result to a L object.

=head2 extract($uri)

Extracts variables from an uri based on the current template.
Returns a hash with the extracted values.

=head1 PROPERTIES

=head2 template

Returns the original template string.

=head2 variables

Returns a list of unique variable names found in the template.

=head2 expansions

Returns a list of L objects found
in the template.

=head1 AUTHOR

NAKAGAWA Masaki [e-mail]

=head1 LICENSE

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

=head1 SEE ALSO

L, L

=cut