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

URI-Template-Restrict documentation Contained in the URI-Template-Restrict distribution.

Index

Code Index:

NAME

Top

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

SYNOPSIS

Top

    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')

DESCRIPTION

Top

This is a restricted URI Templates handler. URI Templates is described at http://bitworking.org/projects/URI-Templates/.

This module supports draft-gregorio-uritemplate-03 except -opt and -neg operators.

METHODS

Top

new($template)

Creates a new instance with the template.

process(%vars)

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

process_to_string(%vars)

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

extract($uri)

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

PROPERTIES

Top

template

Returns the original template string.

variables

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

expansions

Returns a list of URI::Template::Restrict::Expansion objects found in the template.

AUTHOR

Top

NAKAGAWA Masaki <masaki@cpan.org>

LICENSE

Top

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

SEE ALSO

Top

URI::Template, http://bitworking.org/projects/URI-Templates/

URI-Template-Restrict documentation Contained in the URI-Template-Restrict distribution. 
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;