use strict;
use warnings;
-our $VERSION = '0.08_01';
+our $VERSION = '0.18';
use URI;
-use URI::Escape ();
-use overload '""' => \&as_string;
+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,
+);
-my $unsafe = q(^A-Za-z0-9\-_.~!\$\&'()*+,;=:/?\[\]#@);
-
-=head1 NAME
+sub new {
+ my $class = shift;
+ my $templ = shift || die 'No template provided';
+ my $self = bless { template => $templ, _vars => {} } => $class;
-URI::Template - Object for handling URI templates
+ $self->_study;
-=head1 SYNOPSIS
+ return $self;
+}
- use URI::Template;
- my $template = URI::Template->new( 'http://example.com/{x}' );
- my $uri = $template->process( x => 'y' );
- # uri is a URI object with value 'http://example.com/y'
+sub _quote {
+ my ( $val, $safe ) = @_;
+ $safe ||= '';
- my %result = $template->deparse( $uri );
- # %result is ( x => 'y' )
+ # try to mirror python's urllib quote
+ my $unsafe = '^A-Za-z0-9\-\._' . $safe;
+ return URI::Escape::uri_escape_utf8( Unicode::Normalize::NFKC( $val ),
+ $unsafe );
+}
-=head1 DESCRIPTION
+sub _tostring {
+ my ( $var, $value, $exp ) = @_;
+ my $safe = $exp->{ safe };
-This is an initial attempt to provide a wrapper around URI templates
-as described at http://www.ietf.org/internet-drafts/draft-gregorio-uritemplate-01.txt
+ 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 );
+ }
-=head1 INSTALLATION
+ return;
+}
-To install this module via Module::Build:
+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 );
+ }
- perl Build.PL
- ./Build # or `perl Build`
- ./Build test # or `perl Build test`
- ./Build install # or `perl Build install`
+ return;
+}
-To install this module via ExtUtils::MakeMaker:
+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 );
+ }
+}
- perl Makefile.PL
- make
- make test
- make install
+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 );
+ }
-=head1 METHODS
+ return;
+}
-=head2 new( $template )
+sub _study {
+ my ( $self ) = @_;
+ my @hunks = grep { defined && length } split /(\{.+?\})/, $self->template;
+ for ( @hunks ) {
+ next unless /^\{(.+?)\}$/;
+ $_ = $self->_compile_expansion( $1 );
+ }
+ $self->{ studied } = \@hunks;
+}
-Creates a new L<URI::Template> instance with the template passed in
-as the first parameter.
+sub _compile_expansion {
+ my ( $self, $str ) = @_;
-=cut
+ my %exp = ( op => '', vars => [], str => $str );
+ if ( $str =~ /^([+#.\/;?&|!\@])(.+)/ ) {
+ $exp{ op } = $1;
+ $exp{ str } = $2;
+ }
-sub new {
- my $class = shift;
- my $templ = shift || die 'No template provided';
- my $self = bless { template => $templ }, $class;
+ $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 } }++;
+
+ push @{ $exp{ vars } }, \%var;
+ }
- return $self;
-}
+ my $join = $exp{ op };
+ my $start = $exp{ op };
-=head2 as_string( )
+ 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 = ',';
+ }
-Returns the original template string. Also used when the object is
-stringified.
+ if ( !exists $TOSTRING{ $exp{ op } } ) {
+ die 'Invalid operation "' . $exp{ op } . '"';
+ }
-=cut
+ return sub {
+ my $variables = shift;
-sub as_string {
- return $_[ 0 ]->{ template };
-}
+ my @return;
+ for my $var ( @{ $exp{ vars } } ) {
+ my $value;
+ if ( exists $variables->{ $var->{ name } } ) {
+ $value = $variables->{ $var->{ name } };
+ }
+ $value = $var->{ default } if !defined $value;
-=head2 variables( )
+ next unless defined $value;
-Returns an array of variable names found in the template. NB: they
-are returned in random order.
+ my $expand = $TOSTRING{ $exp{ op } }->( $var, $value, \%exp );
-=cut
+ push @return, $expand if defined $expand;
+ }
-sub variables {
- my $self = shift;
- my %vars = map { $_ => 1 } $self->all_variables;
- return keys %vars;
+ return $start . join( $join, @return ) if @return;
+ return '';
+ };
}
-=head2 all_variables( )
-
-Returns an array of variable names found as they appear in template --
-in order, duplicates included.
+sub template {
+ return $_[ 0 ]->{ template };
+}
-=cut
+sub variables {
+ return keys %{ $_[ 0 ]->{ _vars } };
+}
-sub all_variables {
+sub expansions {
my $self = shift;
- my @vars = $self->as_string =~ /{(.+?)}/g;
- return @vars;
+ return grep { ref } @{ $self->{ studied } };
}
-=head2 process( %vars|\@values )
-
-Given a list of key-value pairs or an array ref of values (for
-positional substitution), it will URI escape the values and
-substitute them in to the template. Returns a URI object.
-
-=cut
-
sub process {
my $self = shift;
return URI->new( $self->process_to_string( @_ ) );
}
-=head2 process_to_string( %vars|\@values )
-
-Processes input like the C<process> method, but doesn't
-inflate the result to a URI object.
-
-=cut
-
sub process_to_string {
my $self = shift;
+ my $arg = @_ == 1 ? $_[ 0 ] : { @_ };
+ my $str = '';
- if( ref $_[ 0 ] ) {
- return $self->_process_by_position( @_ );
- }
- else {
- return $self->_process_by_key( @_ );
+ for my $hunk ( @{ $self->{ studied } } ) {
+ if ( !ref $hunk ) { $str .= $hunk; next; }
+
+ $str .= $hunk->( $arg );
}
+
+ return $str;
}
-sub _process_by_key {
- my $self = shift;
- my @vars = $self->variables;
- my %params = @_;
- my $uri = $self->as_string;
+1;
- # fix undef vals
- for my $var ( @vars ) {
- $params{ $var } = defined $params{ $var }
- ? URI::Escape::uri_escape( $params{ $var }, $unsafe )
- : '';
- }
+__END__
- my $regex = '\{(' . join( '|', map quotemeta, @vars ) . ')\}';
- $uri =~ s/$regex/$params{$1}/eg;
+=head1 NAME
- return $uri;
-}
+URI::Template - Object for handling URI templates (RFC 6570)
-sub _process_by_position {
- my $self = shift;
- my @params = @{ $_[ 0 ] };
+=head1 SYNOPSIS
- my $uri = $self->as_string;
+ use URI::Template;
+ my $template = URI::Template->new( 'http://example.com/{x}' );
+ my $uri = $template->process( x => 'y' );
+ # uri is a URI object with value 'http://example.com/y'
- $uri =~ s/{(.+?)}/@params
- ? defined $params[ 0 ]
- ? URI::Escape::uri_escape( shift @params, $unsafe )
- : ''
- : ''/eg;
+=head1 DESCRIPTION
- return $uri;
-}
+This module provides a wrapper around URI templates as described in RFC 6570:
+L<< http://tools.ietf.org/html/rfc6570 >>.
-=head2 deparse( $uri )
+=head1 INSTALLATION
-Does some rudimentary deparsing of a uri based on the current template.
-Returns a hash with the extracted values.
+ perl Makefile.PL
+ make
+ make test
+ make install
-=cut
+=head1 METHODS
-sub deparse {
- my $self = shift;
- my $uri = shift;
+=head2 new( $template )
- if( !$self->{ deparse_re } ) {
- my $templ = $self->as_string;
- $self->{ vars_list } = [ $templ =~ /{(.+?)}/g ];
- $templ =~ s/{.+?}/(.+?)/g;
- $self->{ deparse_re } = qr/$templ/;
- }
+Creates a new L<URI::Template> instance with the template passed in
+as the first parameter.
- my @matches = $uri =~ $self->{ deparse_re };
+=head2 template
- my %results;
- @results{ @{ $self->{ vars_list } } } = @matches;
- return %results;
-}
+This method returns the original template string.
+
+=head2 variables
-=head1 AUTHOR
+Returns an array of unique variable names found in the template. NB: they are returned in random order.
-=over 4
+=head2 expansions
+
+This method returns an list of expansions found in the template. Currently,
+these are just coderefs. In the future, they will be more interesting.
+
+=head2 process( \%vars )
+
+Given a list of key-value pairs or an array ref of values (for
+positional substitution), it will URI escape the values and
+substitute them in to the template. Returns a URI object.
+
+=head2 process_to_string( \%vars )
+
+Processes input like the C<process> method, but doesn't inflate the result to a
+URI object.
+
+=head1 AUTHORS
+
+=over 4
=item * Brian Cassidy E<lt>bricas@cpan.orgE<gt>
+=item * Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
+
=back
=head1 COPYRIGHT AND LICENSE
-Copyright 2007 by Brian Cassidy
+Copyright 2007-2013 by Brian Cassidy
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
-
-1;
projects / liburi-template-perl.git / blobdiff