lib/URI/Template.pm

   1 package URI::Template;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.16';
   7
   8 use URI;
   9 use URI::Escape        ();
  10 use Unicode::Normalize ();
  11 use overload '""' => \&template;
  12
  13 my $RESERVED = q(:/?#\[\]\@!\$\&'\(\)\*\+,;=);
  14 my %TOSTRING = (
  15     ''  => \&_tostring,
  16     '+' => \&_tostring,
  17     '#' => \&_tostring,
  18     ';' => \&_tostring_semi,
  19     '?' => \&_tostring_query,
  20     '&' => \&_tostring_query,
  21     '/' => \&_tostring_path,
  22     '.' => \&_tostring_path,
  23 );
  24
  25 sub new {
  26     my $class = shift;
  27     my $templ = shift || die 'No template provided';
  28     my $self  = bless { template => $templ, _vars => {} } => $class;
  29
  30     $self->_study;
  31
  32     return $self;
  33 }
  34
  35 sub _quote {
  36     my ( $val, $safe ) = @_;
  37     $safe ||= '';
  38
  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 ),
  42         $unsafe );
  43 }
  44
  45 sub _tostring {
  46     my ( $var, $value, $exp ) = @_;
  47     my $safe = $exp->{ safe };
  48
  49     if ( ref $value eq 'ARRAY' ) {
  50         return join( ',', map { _quote( $_, $safe ) } @$value );
  51     }
  52     elsif ( ref $value eq 'HASH' ) {
  53         return join(
  54             ',',
  55             map {
  56                 _quote( $_, $safe )
  57                     . ( $var->{ explode } ? '=' : ',' )
  58                     . _quote( $value->{ $_ }, $safe )
  59                 } sort keys %$value
  60         );
  61     }
  62     elsif ( defined $value ) {
  63         return _quote(
  64             substr( $value, 0, $var->{ prefix } || length( $value ) ),
  65             $safe );
  66     }
  67
  68     return;
  69 }
  70
  71 sub _tostring_semi {
  72     my ( $var, $value, $exp ) = @_;
  73     my $safe = $exp->{ safe };
  74     my $join = $exp->{ op };
  75     $join = '&' if $exp->{ op } eq '?';
  76
  77     if ( ref $value eq 'ARRAY' ) {
  78         if ( $var->{ explode } ) {
  79             return join( $join,
  80                 map { $var->{ name } . '=' . _quote( $_, $safe ) } @$value );
  81         }
  82         else {
  83             return $var->{ name } . '='
  84                 . join( ',', map { _quote( $_, $safe ) } @$value );
  85         }
  86     }
  87     elsif ( ref $value eq 'HASH' ) {
  88         if ( $var->{ explode } ) {
  89             return join(
  90                 $join,
  91                 map {
  92                     _quote( $_, $safe ) . '='
  93                         . _quote( $value->{ $_ }, $safe )
  94                     } sort keys %$value
  95             );
  96         }
  97         else {
  98             return $var->{ name } . '=' . join(
  99                 ',',
 100                 map {
 101                     _quote( $_, $safe ) . ','
 102                         . _quote( $value->{ $_ }, $safe )
 103                     } sort keys %$value
 104             );
 105         }
 106     }
 107     elsif ( defined $value ) {
 108         return $var->{ name } unless length( $value );
 109         return
 110             $var->{ name } . '='
 111             . _quote(
 112             substr( $value, 0, $var->{ prefix } || length( $value ) ),
 113             $safe );
 114     }
 115
 116     return;
 117 }
 118
 119 sub _tostring_query {
 120     my ( $var, $value, $exp ) = @_;
 121     my $safe = $exp->{ safe };
 122     my $join = $exp->{ op };
 123     $join = '&' if $exp->{ op } =~ /[?&]/;
 124
 125     if ( ref $value eq 'ARRAY' ) {
 126         return unless @$value;
 127         if ( $var->{ explode } ) {
 128             return join( $join,
 129                 map { $var->{ name } . '=' . _quote( $_, $safe ) } @$value );
 130         }
 131         else {
 132             return $var->{ name } . '='
 133                 . join( ',', map { _quote( $_, $safe ) } @$value );
 134         }
 135     }
 136     elsif ( ref $value eq 'HASH' ) {
 137         return unless keys %$value;
 138         if ( $var->{ explode } ) {
 139             return join(
 140                 $join,
 141                 map {
 142                     _quote( $_, $safe ) . '='
 143                         . _quote( $value->{ $_ }, $safe )
 144                     } sort keys %$value
 145             );
 146         }
 147         else {
 148             return $var->{ name } . '=' . join(
 149                 ',',
 150                 map {
 151                     _quote( $_, $safe ) . ','
 152                         . _quote( $value->{ $_ }, $safe )
 153                     } sort keys %$value
 154             );
 155         }
 156     }
 157     elsif ( defined $value ) {
 158         return $var->{ name } . '=' unless length( $value );
 159         return
 160             $var->{ name } . '='
 161             . _quote(
 162             substr( $value, 0, $var->{ prefix } || length( $value ) ),
 163             $safe );
 164     }
 165 }
 166
 167 sub _tostring_path {
 168     my ( $var, $value, $exp ) = @_;
 169     my $safe = $exp->{ safe };
 170     my $join = $exp->{ op };
 171
 172     if ( ref $value eq 'ARRAY' ) {
 173         return unless @$value;
 174         return join(
 175             ( $var->{ explode } ? $join : ',' ),
 176             map { _quote( $_, $safe ) } @$value
 177         );
 178     }
 179     elsif ( ref $value eq 'HASH' ) {
 180         return join(
 181             ( $var->{ explode } ? $join : ',' ),
 182             map {
 183                 _quote( $_, $safe )
 184                     . ( $var->{ explode } ? '=' : ',' )
 185                     . _quote( $value->{ $_ }, $safe )
 186                 } sort keys %$value
 187         );
 188     }
 189     elsif ( defined $value ) {
 190         return _quote(
 191             substr( $value, 0, $var->{ prefix } || length( $value ) ),
 192             $safe );
 193     }
 194
 195     return;
 196 }
 197
 198 sub _study {
 199     my ( $self ) = @_;
 200     my @hunks = grep { defined && length } split /(\{.+?\})/, $self->template;
 201     for ( @hunks ) {
 202         next unless /^\{(.+?)\}$/;
 203         $_ = $self->_compile_expansion( $1 );
 204     }
 205     $self->{ studied } = \@hunks;
 206 }
 207
 208 sub _compile_expansion {
 209     my ( $self, $str ) = @_;
 210
 211     my %exp = ( op => '', vars => [], str => $str );
 212     if ( $str =~ /^([+#.\/;?&|!\@])(.+)/ ) {
 213         $exp{ op }  = $1;
 214         $exp{ str } = $2;
 215     }
 216
 217     $exp{ safe } = $RESERVED if $exp{ op } =~ m{[+#]};
 218
 219     for my $varspec ( split( ',', delete $exp{ str } ) ) {
 220         my %var = ( name => $varspec );
 221         if ( $varspec =~ /=/ ) {
 222             @var{ 'name', 'default' } = split( /=/, $varspec, 2 );
 223         }
 224         if ( $var{ name } =~ s{\*$}{} ) {
 225             $var{ explode } = 1;
 226         }
 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';
 231             }
 232         }
 233
 234         # remove "optional" flag (for opensearch compatibility)
 235         $var{ name } =~ s{\?$}{};
 236         $self->{ _vars }->{ $var{ name } }++;
 237
 238         push @{ $exp{ vars } }, \%var;
 239     }
 240
 241     my $join  = $exp{ op };
 242     my $start = $exp{ op };
 243
 244     if ( $exp{ op } eq '+' ) {
 245         $start = '';
 246         $join  = ',';
 247     }
 248     elsif ( $exp{ op } eq '#' ) {
 249         $join = ',';
 250     }
 251     elsif ( $exp{ op } eq '?' ) {
 252         $join = '&';
 253     }
 254     elsif ( $exp{ op } eq '&' ) {
 255         $join = '&';
 256     }
 257     elsif ( $exp{ op } eq '' ) {
 258         $join = ',';
 259     }
 260
 261     if ( !exists $TOSTRING{ $exp{ op } } ) {
 262         die 'Invalid operation "' . $exp{ op } . '"';
 263     }
 264
 265     return sub {
 266         my $variables = shift;
 267
 268         my @return;
 269         for my $var ( @{ $exp{ vars } } ) {
 270             my $value;
 271             if ( exists $variables->{ $var->{ name } } ) {
 272                 $value = $variables->{ $var->{ name } };
 273             }
 274             $value = $var->{ default } if !defined $value;
 275
 276             next unless defined $value;
 277
 278             my $expand = $TOSTRING{ $exp{ op } }->( $var, $value, \%exp );
 279
 280             push @return, $expand if defined $expand;
 281         }
 282
 283         return $start . join( $join, @return ) if @return;
 284         return '';
 285     };
 286 }
 287
 288 sub template {
 289     return $_[ 0 ]->{ template };
 290 }
 291
 292 sub variables {
 293     return keys %{ $_[ 0 ]->{ _vars } };
 294 }
 295
 296 sub expansions {
 297     my $self = shift;
 298     return grep { ref } @{ $self->{ studied } };
 299 }
 300
 301 sub process {
 302     my $self = shift;
 303     return URI->new( $self->process_to_string( @_ ) );
 304 }
 305
 306 sub process_to_string {
 307     my $self = shift;
 308     my $arg  = @_ == 1 ? $_[ 0 ] : { @_ };
 309     my $str  = '';
 310
 311     for my $hunk ( @{ $self->{ studied } } ) {
 312         if ( !ref $hunk ) { $str .= $hunk; next; }
 313
 314         $str .= $hunk->( $arg );
 315     }
 316
 317     return $str;
 318 }
 319
 320 1;
 321
 322 __END__
 323
 324 =head1 NAME
 325
 326 URI::Template - Object for handling URI templates (RFC 6570)
 327
 328 =head1 SYNOPSIS
 329
 330     use URI::Template;
 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'
 334
 335 =head1 DESCRIPTION
 336
 337 This module provides a wrapper around URI templates as described in RFC 6570:
 338 http://tools.ietf.org/html/rfc6570
 339
 340 =head1 INSTALLATION
 341
 342     perl Makefile.PL
 343     make
 344     make test
 345     make install
 346
 347 =head1 METHODS
 348
 349 =head2 new( $template )
 350
 351 Creates a new L<URI::Template> instance with the template passed in
 352 as the first parameter.
 353
 354 =head2 template
 355
 356 This method returns the original template string.
 357
 358 =head2 variables
 359
 360 Returns an array of unique variable names found in the template. NB: they are returned in random order.
 361
 362 =head2 expansions
 363
 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.
 366
 367 =head2 process( \%vars )
 368
 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.
 372
 373 =head2 process_to_string( \%vars )
 374
 375 Processes input like the C<process> method, but doesn't inflate the result to a
 376 URI object.
 377
 378 =head1 AUTHORS
 379
 380 =over 4
 381
 382 =item * Brian Cassidy E<lt>bricas@cpan.orgE<gt>
 383
 384 =item * Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
 385
 386 =back
 387
 388 =head1 COPYRIGHT AND LICENSE
 389
 390 Copyright 2007-2012 by Brian Cassidy
 391
 392 This library is free software; you can redistribute it and/or modify
 393 it under the same terms as Perl itself.
 394
 395 =cut