X-Git-Url: http://erislabs.net/gitweb/?p=liburi-template-perl.git;a=blobdiff_plain;f=lib%2FURI%2FTemplate.pm;h=79c944f95842d52bdcf8e3d13af6b87066382af0;hp=a903cad5b80a56bbb2b39ff077cb86d3a2a9a963;hb=409df7817b5227c763dd2fab0d583b6d1a9656e4;hpb=e0de6ab08282e52476e36abb99a35be9eff9ca8e diff --git a/lib/URI/Template.pm b/lib/URI/Template.pm index a903cad..79c944f 100644 --- a/lib/URI/Template.pm +++ b/lib/URI/Template.pm @@ -3,204 +3,393 @@ package URI::Template; use strict; use warnings; -our $VERSION = '0.08_02'; +our $VERSION = '0.16'; 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\-_.~!\$\&'()*+,;=:/?\[\]#@); +sub new { + my $class = shift; + my $templ = shift || die 'No template provided'; + my $self = bless { template => $templ, _vars => {} } => $class; -=head1 NAME + $self->_study; -URI::Template - Object for handling URI templates + return $self; +} -=head1 SYNOPSIS +sub _quote { + my ( $val, $safe ) = @_; + $safe ||= ''; - 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' + # 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 ); +} - my %result = $template->deparse( $uri ); - # %result is ( x => 'y' ) +sub _tostring { + my ( $var, $value, $exp ) = @_; + my $safe = $exp->{ safe }; -=head1 DESCRIPTION + 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 ); + } -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 + return; +} -=head1 INSTALLATION +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 ); + } -To install this module via Module::Build: + return; +} - perl Build.PL - ./Build # or `perl Build` - ./Build test # or `perl Build test` - ./Build install # or `perl Build install` +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 unless @$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 unless 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 ); + } +} -To install this module via ExtUtils::MakeMaker: +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 ); + } - perl Makefile.PL - make - make test - make install + return; +} -=head1 METHODS +sub _study { + my ( $self ) = @_; + my @hunks = grep { defined && length } split /(\{.+?\})/, $self->template; + for ( @hunks ) { + next unless /^\{(.+?)\}$/; + $_ = $self->_compile_expansion( $1 ); + } + $self->{ studied } = \@hunks; +} -=head2 new( $template ) +sub _compile_expansion { + my ( $self, $str ) = @_; -Creates a new L instance with the template passed in -as the first parameter. + my %exp = ( op => '', vars => [], str => $str ); + if ( $str =~ /^([+#.\/;?&|!\@])(.+)/ ) { + $exp{ op } = $1; + $exp{ str } = $2; + } -=cut + $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; + } -sub new { - my $class = shift; - my $templ = shift || die 'No template provided'; - my $self = bless { template => $templ }, $class; + my $join = $exp{ op }; + my $start = $exp{ op }; - return $self; -} + 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 = ','; + } -=head2 as_string( ) + if ( !exists $TOSTRING{ $exp{ op } } ) { + die 'Invalid operation "' . $exp{ op } . '"'; + } -Returns the original template string. Also used when the object is -stringified. + return sub { + my $variables = shift; -=cut + my @return; + for my $var ( @{ $exp{ vars } } ) { + my $value; + if ( exists $variables->{ $var->{ name } } ) { + $value = $variables->{ $var->{ name } }; + } + $value = $var->{ default } if !defined $value; -sub as_string { - return $_[ 0 ]->{ template }; -} + next unless defined $value; -=head2 variables( ) + my $expand = $TOSTRING{ $exp{ op } }->( $var, $value, \%exp ); -Returns an array of variable names found in the template. NB: they -are returned in random order. + push @return, $expand if defined $expand; + } -=cut + return $start . join( $join, @return ) if @return; + return ''; + }; +} + +sub template { + return $_[ 0 ]->{ template }; +} sub variables { + return keys %{ $_[ 0 ]->{ _vars } }; +} + +sub expansions { + my $self = shift; + return grep { ref } @{ $self->{ studied } }; +} + +sub process { my $self = shift; - my %vars = map { $_ => 1 } $self->all_variables; - return keys %vars; + return URI->new( $self->process_to_string( @_ ) ); } -=head2 all_variables( ) +sub process_to_string { + my $self = shift; + my $arg = @_ == 1 ? $_[ 0 ] : { @_ }; + my $str = ''; -Returns an array of variable names found as they appear in template -- -in order, duplicates included. + for my $hunk ( @{ $self->{ studied } } ) { + if ( !ref $hunk ) { $str .= $hunk; next; } -=cut + $str .= $hunk->( $arg ); + } -sub all_variables { - my $self = shift; - my @vars = $self->as_string =~ /{(.+?)}/g; - return @vars; + return $str; } -=head2 process( %vars|\@values ) +1; -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. +__END__ -=cut +=head1 NAME -sub process { - my $self = shift; - return URI->new( $self->process_to_string( @_ ) ); -} +URI::Template - Object for handling URI templates (RFC 6570) -=head2 process_to_string( %vars|\@values ) +=head1 SYNOPSIS -Processes input like the C method, but doesn't -inflate the result to a URI object. + 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' -=cut +=head1 DESCRIPTION -sub process_to_string { - my $self = shift; +This module provides a wrapper around URI templates as described in RFC 6570: +http://tools.ietf.org/html/rfc6570 - if( ref $_[ 0 ] ) { - return $self->_process_by_position( @_ ); - } - else { - return $self->_process_by_key( @_ ); - } -} +=head1 INSTALLATION -sub _process_by_key { - my $self = shift; - my @vars = $self->variables; - my %params = @_; - my $uri = $self->as_string; + perl Makefile.PL + make + make test + make install - # fix undef vals - for my $var ( @vars ) { - $params{ $var } = defined $params{ $var } - ? URI::Escape::uri_escape( $params{ $var }, $unsafe ) - : ''; - } +=head1 METHODS - my $regex = '\{(' . join( '|', map quotemeta, @vars ) . ')\}'; - $uri =~ s/$regex/$params{$1}/eg; +=head2 new( $template ) - return $uri; -} +Creates a new L instance with the template passed in +as the first parameter. -sub _process_by_position { - my $self = shift; - my @params = @{ $_[ 0 ] }; +=head2 template - my $uri = $self->as_string; +This method returns the original template string. - $uri =~ s/{(.+?)}/@params - ? defined $params[ 0 ] - ? URI::Escape::uri_escape( shift @params, $unsafe ) - : '' - : ''/eg; +=head2 variables - return $uri; -} +Returns an array of unique variable names found in the template. NB: they are returned in random order. -=head2 deparse( $uri ) +=head2 expansions -Does some rudimentary deparsing of a uri based on the current template. -Returns a hash with the extracted values. +This method returns an list of expansions found in the template. Currently, +these are just coderefs. In the future, they will be more interesting. -=cut +=head2 process( \%vars ) -sub deparse { - my $self = shift; - my $uri = shift; +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. - if( !$self->{ deparse_re } ) { - my $templ = $self->as_string; - $self->{ vars_list } = [ $templ =~ /{(.+?)}/g ]; - $templ =~ s/{.+?}/(.+?)/g; - $self->{ deparse_re } = qr/$templ/; - } +=head2 process_to_string( \%vars ) - my @matches = $uri =~ $self->{ deparse_re }; +Processes input like the C method, but doesn't inflate the result to a +URI object. - my %results; - @results{ @{ $self->{ vars_list } } } = @matches; - return %results; -} +=head1 AUTHORS + +=over 4 -=head1 AUTHOR +=item * Brian Cassidy Ebricas@cpan.orgE -Brian Cassidy Ebricas@cpan.orgE +=item * Ricardo SIGNES Erjbs@cpan.orgE + +=back =head1 COPYRIGHT AND LICENSE -Copyright 2007 by Brian Cassidy +Copyright 2007-2012 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;