10 use Unicode::Normalize ();
11 use overload '""' => \&template;
13 my $RESERVED = q(:/?#\[\]\@!\$\&'\(\)\*\+,;=);
18 ';' => \&_tostring_semi,
19 '?' => \&_tostring_query,
20 '&' => \&_tostring_query,
21 '/' => \&_tostring_path,
22 '.' => \&_tostring_path,
27 my $templ = shift || die 'No template provided';
28 my $self = bless { template => $templ, _vars => {} } => $class;
36 my ( $val, $safe ) = @_;
39 # try to mirror python's urllib quote
40 my $unsafe = '^A-Za-z0-9\-\._' . $safe;
41 return URI::Escape::uri_escape_utf8( Unicode::Normalize::NFKC( $val ),
46 my ( $var, $value, $exp ) = @_;
47 my $safe = $exp->{ safe };
49 if ( ref $value eq 'ARRAY' ) {
50 return join( ',', map { _quote( $_, $safe ) } @$value );
52 elsif ( ref $value eq 'HASH' ) {
57 . ( $var->{ explode } ? '=' : ',' )
58 . _quote( $value->{ $_ }, $safe )
62 elsif ( defined $value ) {
64 substr( $value, 0, $var->{ prefix } || length( $value ) ),
72 my ( $var, $value, $exp ) = @_;
73 my $safe = $exp->{ safe };
74 my $join = $exp->{ op };
75 $join = '&' if $exp->{ op } eq '?';
77 if ( ref $value eq 'ARRAY' ) {
78 if ( $var->{ explode } ) {
80 map { $var->{ name } . '=' . _quote( $_, $safe ) } @$value );
83 return $var->{ name } . '='
84 . join( ',', map { _quote( $_, $safe ) } @$value );
87 elsif ( ref $value eq 'HASH' ) {
88 if ( $var->{ explode } ) {
92 _quote( $_, $safe ) . '='
93 . _quote( $value->{ $_ }, $safe )
98 return $var->{ name } . '=' . join(
101 _quote( $_, $safe ) . ','
102 . _quote( $value->{ $_ }, $safe )
107 elsif ( defined $value ) {
108 return $var->{ name } unless length( $value );
112 substr( $value, 0, $var->{ prefix } || length( $value ) ),
119 sub _tostring_query {
120 my ( $var, $value, $exp ) = @_;
121 my $safe = $exp->{ safe };
122 my $join = $exp->{ op };
123 $join = '&' if $exp->{ op } =~ /[?&]/;
125 if ( ref $value eq 'ARRAY' ) {
127 if ( $var->{ explode } ) {
129 map { $var->{ name } . '=' . _quote( $_, $safe ) } @$value );
132 return $var->{ name } . '='
133 . join( ',', map { _quote( $_, $safe ) } @$value );
136 elsif ( ref $value eq 'HASH' ) {
137 return if !keys %$value;
138 if ( $var->{ explode } ) {
142 _quote( $_, $safe ) . '='
143 . _quote( $value->{ $_ }, $safe )
148 return $var->{ name } . '=' . join(
151 _quote( $_, $safe ) . ','
152 . _quote( $value->{ $_ }, $safe )
157 elsif ( defined $value ) {
158 return $var->{ name } . '=' unless length( $value );
162 substr( $value, 0, $var->{ prefix } || length( $value ) ),
168 my ( $var, $value, $exp ) = @_;
169 my $safe = $exp->{ safe };
170 my $join = $exp->{ op };
172 if ( ref $value eq 'ARRAY' ) {
173 return unless @$value;
175 ( $var->{ explode } ? $join : ',' ),
176 map { _quote( $_, $safe ) } @$value
179 elsif ( ref $value eq 'HASH' ) {
181 ( $var->{ explode } ? $join : ',' ),
184 . ( $var->{ explode } ? '=' : ',' )
185 . _quote( $value->{ $_ }, $safe )
189 elsif ( defined $value ) {
191 substr( $value, 0, $var->{ prefix } || length( $value ) ),
200 my @hunks = grep { defined && length } split /(\{.+?\})/, $self->template;
202 next unless /^\{(.+?)\}$/;
203 $_ = $self->_compile_expansion( $1 );
205 $self->{ studied } = \@hunks;
208 sub _compile_expansion {
209 my ( $self, $str ) = @_;
211 my %exp = ( op => '', vars => [], str => $str );
212 if ( $str =~ /^([+#.\/;?&|!\@])(.+)/ ) {
217 $exp{ safe } = $RESERVED if $exp{ op } =~ m{[+#]};
219 for my $varspec ( split( ',', delete $exp{ str } ) ) {
220 my %var = ( name => $varspec );
221 if ( $varspec =~ /=/ ) {
222 @var{ 'name', 'default' } = split( /=/, $varspec, 2 );
224 if ( $var{ name } =~ s{\*$}{} ) {
227 elsif ( $var{ name } =~ /:/ ) {
228 @var{ 'name', 'prefix' } = split( /:/, $var{ name }, 2 );
229 if ( $var{ prefix } =~ m{[^0-9]} ) {
230 die 'Non-numeric prefix specified';
234 # remove "optional" flag (for opensearch compatibility)
235 $var{ name } =~ s{\?$}{};
236 $self->{ _vars }->{ $var{ name } }++;
238 push @{ $exp{ vars } }, \%var;
241 my $join = $exp{ op };
242 my $start = $exp{ op };
244 if ( $exp{ op } eq '+' ) {
248 elsif ( $exp{ op } eq '#' ) {
251 elsif ( $exp{ op } eq '?' ) {
254 elsif ( $exp{ op } eq '&' ) {
257 elsif ( $exp{ op } eq '' ) {
261 if ( !exists $TOSTRING{ $exp{ op } } ) {
262 die 'Invalid operation "' . $exp{ op } . '"';
266 my $variables = shift;
269 for my $var ( @{ $exp{ vars } } ) {
271 if ( exists $variables->{ $var->{ name } } ) {
272 $value = $variables->{ $var->{ name } };
274 $value = $var->{ default } if !defined $value;
276 next unless defined $value;
278 my $expand = $TOSTRING{ $exp{ op } }->( $var, $value, \%exp );
280 push @return, $expand if defined $expand;
283 return $start . join( $join, @return ) if @return;
289 return $_[ 0 ]->{ template };
293 return keys %{ $_[ 0 ]->{ _vars } };
298 return grep { ref } @{ $self->{ studied } };
303 return URI->new( $self->process_to_string( @_ ) );
306 sub process_to_string {
308 my $arg = @_ == 1 ? $_[ 0 ] : { @_ };
311 for my $hunk ( @{ $self->{ studied } } ) {
312 if ( !ref $hunk ) { $str .= $hunk; next; }
314 $str .= $hunk->( $arg );
326 URI::Template - Object for handling URI templates (RFC 6570)
331 my $template = URI::Template->new( 'http://example.com/{x}' );
332 my $uri = $template->process( x => 'y' );
333 # uri is a URI object with value 'http://example.com/y'
337 This module provides a wrapper around URI templates as described in RFC 6570:
338 L<< http://tools.ietf.org/html/rfc6570 >>.
349 =head2 new( $template )
351 Creates a new L<URI::Template> instance with the template passed in
352 as the first parameter.
356 This method returns the original template string.
360 Returns an array of unique variable names found in the template. NB: they are returned in random order.
364 This method returns an list of expansions found in the template. Currently,
365 these are just coderefs. In the future, they will be more interesting.
367 =head2 process( \%vars )
369 Given a list of key-value pairs or an array ref of values (for
370 positional substitution), it will URI escape the values and
371 substitute them in to the template. Returns a URI object.
373 =head2 process_to_string( \%vars )
375 Processes input like the C<process> method, but doesn't inflate the result to a
382 =item * Brian Cassidy E<lt>bricas@cpan.orgE<gt>
384 =item * Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
388 =head1 COPYRIGHT AND LICENSE
390 Copyright 2007-2013 by Brian Cassidy
392 This library is free software; you can redistribute it and/or modify
393 it under the same terms as Perl itself.