lib/URI/Template.pm

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