lib/URI/Template.pm

   1 package URI::Template;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.17';
   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         if( !@$value ) {
 127             return if $var->{ explode };
 128             return $var->{ name } . '=';
 129         }
 130         if ( $var->{ explode } ) {
 131             return join( $join,
 132                 map { $var->{ name } . '=' . _quote( $_, $safe ) } @$value );
 133         }
 134         else {
 135             return $var->{ name } . '='
 136                 . join( ',', map { _quote( $_, $safe ) } @$value );
 137         }
 138     }
 139     elsif ( ref $value eq 'HASH' ) {
 140         if( !keys %$value ) {
 141             return if $var->{ explode };
 142             return $var->{ name } . '=';
 143         }
 144         if ( $var->{ explode } ) {
 145             return join(
 146                 $join,
 147                 map {
 148                     _quote( $_, $safe ) . '='
 149                         . _quote( $value->{ $_ }, $safe )
 150                     } sort keys %$value
 151             );
 152         }
 153         else {
 154             return $var->{ name } . '=' . join(
 155                 ',',
 156                 map {
 157                     _quote( $_, $safe ) . ','
 158                         . _quote( $value->{ $_ }, $safe )
 159                     } sort keys %$value
 160             );
 161         }
 162     }
 163     elsif ( defined $value ) {
 164         return $var->{ name } . '=' unless length( $value );
 165         return
 166             $var->{ name } . '='
 167             . _quote(
 168             substr( $value, 0, $var->{ prefix } || length( $value ) ),
 169             $safe );
 170     }
 171 }
 172
 173 sub _tostring_path {
 174     my ( $var, $value, $exp ) = @_;
 175     my $safe = $exp->{ safe };
 176     my $join = $exp->{ op };
 177
 178     if ( ref $value eq 'ARRAY' ) {
 179         return unless @$value;
 180         return join(
 181             ( $var->{ explode } ? $join : ',' ),
 182             map { _quote( $_, $safe ) } @$value
 183         );
 184     }
 185     elsif ( ref $value eq 'HASH' ) {
 186         return join(
 187             ( $var->{ explode } ? $join : ',' ),
 188             map {
 189                 _quote( $_, $safe )
 190                     . ( $var->{ explode } ? '=' : ',' )
 191                     . _quote( $value->{ $_ }, $safe )
 192                 } sort keys %$value
 193         );
 194     }
 195     elsif ( defined $value ) {
 196         return _quote(
 197             substr( $value, 0, $var->{ prefix } || length( $value ) ),
 198             $safe );
 199     }
 200
 201     return;
 202 }
 203
 204 sub _study {
 205     my ( $self ) = @_;
 206     my @hunks = grep { defined && length } split /(\{.+?\})/, $self->template;
 207     for ( @hunks ) {
 208         next unless /^\{(.+?)\}$/;
 209         $_ = $self->_compile_expansion( $1 );
 210     }
 211     $self->{ studied } = \@hunks;
 212 }
 213
 214 sub _compile_expansion {
 215     my ( $self, $str ) = @_;
 216
 217     my %exp = ( op => '', vars => [], str => $str );
 218     if ( $str =~ /^([+#.\/;?&|!\@])(.+)/ ) {
 219         $exp{ op }  = $1;
 220         $exp{ str } = $2;
 221     }
 222
 223     $exp{ safe } = $RESERVED if $exp{ op } =~ m{[+#]};
 224
 225     for my $varspec ( split( ',', delete $exp{ str } ) ) {
 226         my %var = ( name => $varspec );
 227         if ( $varspec =~ /=/ ) {
 228             @var{ 'name', 'default' } = split( /=/, $varspec, 2 );
 229         }
 230         if ( $var{ name } =~ s{\*$}{} ) {
 231             $var{ explode } = 1;
 232         }
 233         elsif ( $var{ name } =~ /:/ ) {
 234             @var{ 'name', 'prefix' } = split( /:/, $var{ name }, 2 );
 235             if ( $var{ prefix } =~ m{[^0-9]} ) {
 236                 die 'Non-numeric prefix specified';
 237             }
 238         }
 239
 240         # remove "optional" flag (for opensearch compatibility)
 241         $var{ name } =~ s{\?$}{};
 242         $self->{ _vars }->{ $var{ name } }++;
 243
 244         push @{ $exp{ vars } }, \%var;
 245     }
 246
 247     my $join  = $exp{ op };
 248     my $start = $exp{ op };
 249
 250     if ( $exp{ op } eq '+' ) {
 251         $start = '';
 252         $join  = ',';
 253     }
 254     elsif ( $exp{ op } eq '#' ) {
 255         $join = ',';
 256     }
 257     elsif ( $exp{ op } eq '?' ) {
 258         $join = '&';
 259     }
 260     elsif ( $exp{ op } eq '&' ) {
 261         $join = '&';
 262     }
 263     elsif ( $exp{ op } eq '' ) {
 264         $join = ',';
 265     }
 266
 267     if ( !exists $TOSTRING{ $exp{ op } } ) {
 268         die 'Invalid operation "' . $exp{ op } . '"';
 269     }
 270
 271     return sub {
 272         my $variables = shift;
 273
 274         my @return;
 275         for my $var ( @{ $exp{ vars } } ) {
 276             my $value;
 277             if ( exists $variables->{ $var->{ name } } ) {
 278                 $value = $variables->{ $var->{ name } };
 279             }
 280             $value = $var->{ default } if !defined $value;
 281
 282             next unless defined $value;
 283
 284             my $expand = $TOSTRING{ $exp{ op } }->( $var, $value, \%exp );
 285
 286             push @return, $expand if defined $expand;
 287         }
 288
 289         return $start . join( $join, @return ) if @return;
 290         return '';
 291     };
 292 }
 293
 294 sub template {
 295     return $_[ 0 ]->{ template };
 296 }
 297
 298 sub variables {
 299     return keys %{ $_[ 0 ]->{ _vars } };
 300 }
 301
 302 sub expansions {
 303     my $self = shift;
 304     return grep { ref } @{ $self->{ studied } };
 305 }
 306
 307 sub process {
 308     my $self = shift;
 309     return URI->new( $self->process_to_string( @_ ) );
 310 }
 311
 312 sub process_to_string {
 313     my $self = shift;
 314     my $arg  = @_ == 1 ? $_[ 0 ] : { @_ };
 315     my $str  = '';
 316
 317     for my $hunk ( @{ $self->{ studied } } ) {
 318         if ( !ref $hunk ) { $str .= $hunk; next; }
 319
 320         $str .= $hunk->( $arg );
 321     }
 322
 323     return $str;
 324 }
 325
 326 1;
 327
 328 __END__
 329
 330 =head1 NAME
 331
 332 URI::Template - Object for handling URI templates (RFC 6570)
 333
 334 =head1 SYNOPSIS
 335
 336     use URI::Template;
 337     my $template = URI::Template->new( 'http://example.com/{x}' );
 338     my $uri      = $template->process( x => 'y' );
 339     # uri is a URI object with value 'http://example.com/y'
 340
 341 =head1 DESCRIPTION
 342
 343 This module provides a wrapper around URI templates as described in RFC 6570:
 344 http://tools.ietf.org/html/rfc6570
 345
 346 =head1 INSTALLATION
 347
 348     perl Makefile.PL
 349     make
 350     make test
 351     make install
 352
 353 =head1 METHODS
 354
 355 =head2 new( $template )
 356
 357 Creates a new L<URI::Template> instance with the template passed in
 358 as the first parameter.
 359
 360 =head2 template
 361
 362 This method returns the original template string.
 363
 364 =head2 variables
 365
 366 Returns an array of unique variable names found in the template. NB: they are returned in random order.
 367
 368 =head2 expansions
 369
 370 This method returns an list of expansions found in the template.  Currently,
 371 these are just coderefs.  In the future, they will be more interesting.
 372
 373 =head2 process( \%vars )
 374
 375 Given a list of key-value pairs or an array ref of values (for
 376 positional substitution), it will URI escape the values and
 377 substitute them in to the template. Returns a URI object.
 378
 379 =head2 process_to_string( \%vars )
 380
 381 Processes input like the C<process> method, but doesn't inflate the result to a
 382 URI object.
 383
 384 =head1 AUTHORS
 385
 386 =over 4
 387
 388 =item * Brian Cassidy E<lt>bricas@cpan.orgE<gt>
 389
 390 =item * Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
 391
 392 =back
 393
 394 =head1 COPYRIGHT AND LICENSE
 395
 396 Copyright 2007-2013 by Brian Cassidy
 397
 398 This library is free software; you can redistribute it and/or modify
 399 it under the same terms as Perl itself.
 400
 401 =cut