lib/URI/Template.pm

   1 package URI::Template;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.20';
   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     for ( @hunks ) {
 203         next unless /^\{(.+?)\}$/;
 204         $_ = $self->_compile_expansion( $1 );
 205     }
 206     $self->{ studied } = \@hunks;
 207 }
 208
 209 sub _compile_expansion {
 210     my ( $self, $str ) = @_;
 211
 212     my %exp = ( op => '', vars => [], str => $str );
 213     if ( $str =~ /^([+#.\/;?&|!\@])(.+)/ ) {
 214         $exp{ op }  = $1;
 215         $exp{ str } = $2;
 216     }
 217
 218     $exp{ safe } = $RESERVED if $exp{ op } =~ m{[+#]};
 219
 220     for my $varspec ( split( ',', delete $exp{ str } ) ) {
 221         my %var = ( name => $varspec );
 222         if ( $varspec =~ /=/ ) {
 223             @var{ 'name', 'default' } = split( /=/, $varspec, 2 );
 224         }
 225         if ( $var{ name } =~ s{\*$}{} ) {
 226             $var{ explode } = 1;
 227         }
 228         elsif ( $var{ name } =~ /:/ ) {
 229             @var{ 'name', 'prefix' } = split( /:/, $var{ name }, 2 );
 230             if ( $var{ prefix } =~ m{[^0-9]} ) {
 231                 die 'Non-numeric prefix specified';
 232             }
 233         }
 234
 235         # remove "optional" flag (for opensearch compatibility)
 236         $var{ name } =~ s{\?$}{};
 237         $self->{ _vars }->{ $var{ name } }++;
 238
 239         push @{ $exp{ vars } }, \%var;
 240     }
 241
 242     my $join  = $exp{ op };
 243     my $start = $exp{ op };
 244
 245     if ( $exp{ op } eq '+' ) {
 246         $start = '';
 247         $join  = ',';
 248     }
 249     elsif ( $exp{ op } eq '#' ) {
 250         $join = ',';
 251     }
 252     elsif ( $exp{ op } eq '?' ) {
 253         $join = '&';
 254     }
 255     elsif ( $exp{ op } eq '&' ) {
 256         $join = '&';
 257     }
 258     elsif ( $exp{ op } eq '' ) {
 259         $join = ',';
 260     }
 261
 262     if ( !exists $TOSTRING{ $exp{ op } } ) {
 263         die 'Invalid operation "' . $exp{ op } . '"';
 264     }
 265
 266     return sub {
 267         my $variables = shift;
 268
 269         my @return;
 270         for my $var ( @{ $exp{ vars } } ) {
 271             my $value;
 272             if ( exists $variables->{ $var->{ name } } ) {
 273                 $value = $variables->{ $var->{ name } };
 274             }
 275             $value = $var->{ default } if !defined $value;
 276
 277             next unless defined $value;
 278
 279             my $expand = $TOSTRING{ $exp{ op } }->( $var, $value, \%exp );
 280
 281             push @return, $expand if defined $expand;
 282         }
 283
 284         return $start . join( $join, @return ) if @return;
 285         return '';
 286     };
 287 }
 288
 289 sub template {
 290     my $self = shift;
 291     my $templ = shift;
 292
 293     #   Update template
 294     if ( defined $templ && $templ ne $self->{ template } ) {
 295         $self->{ template } = $templ;
 296         $self->{ _vars } = {};
 297         $self->_study;
 298         return $self;
 299     }
 300
 301     return $self->{ template };
 302 }
 303
 304 sub variables {
 305     return keys %{ $_[ 0 ]->{ _vars } };
 306 }
 307
 308 sub expansions {
 309     my $self = shift;
 310     return grep { ref } @{ $self->{ studied } };
 311 }
 312
 313 sub process {
 314     my $self = shift;
 315     return URI->new( $self->process_to_string( @_ ) );
 316 }
 317
 318 sub process_to_string {
 319     my $self = shift;
 320     my $arg  = @_ == 1 ? $_[ 0 ] : { @_ };
 321     my $str  = '';
 322
 323     for my $hunk ( @{ $self->{ studied } } ) {
 324         if ( !ref $hunk ) { $str .= $hunk; next; }
 325
 326         $str .= $hunk->( $arg );
 327     }
 328
 329     return $str;
 330 }
 331
 332 1;
 333
 334 __END__
 335
 336 =head1 NAME
 337
 338 URI::Template - Object for handling URI templates (RFC 6570)
 339
 340 =head1 SYNOPSIS
 341
 342     use URI::Template;
 343
 344     my $template = URI::Template->new( 'http://example.com/{x}' );
 345     my $uri      = $template->process( x => 'y' );
 346
 347     # or
 348
 349     my $template = URI::Template->new();
 350     $template->template( 'http://example.com/{x}' );
 351     my $uri      = $template->process( x => 'y' );
 352
 353     # uri is a URI object with value 'http://example.com/y'
 354
 355 =head1 DESCRIPTION
 356
 357 This module provides a wrapper around URI templates as described in RFC 6570:
 358 L<< http://tools.ietf.org/html/rfc6570 >>.
 359
 360 =head1 INSTALLATION
 361
 362     perl Makefile.PL
 363     make
 364     make test
 365     make install
 366
 367 =head1 METHODS
 368
 369 =head2 new( $template )
 370
 371 Creates a new L<URI::Template> instance with the template passed in
 372 as the first parameter (optional).
 373
 374 =head2 template( $template )
 375
 376 This method returns the original template string. If provided, it will also set and parse a
 377 new template string.
 378
 379 =head2 variables
 380
 381 Returns an array of unique variable names found in the template. NB: they are returned in random order.
 382
 383 =head2 expansions
 384
 385 This method returns an list of expansions found in the template.  Currently,
 386 these are just coderefs.  In the future, they will be more interesting.
 387
 388 =head2 process( \%vars )
 389
 390 Given a list of key-value pairs or an array ref of values (for
 391 positional substitution), it will URI escape the values and
 392 substitute them in to the template. Returns a URI object.
 393
 394 =head2 process_to_string( \%vars )
 395
 396 Processes input like the C<process> method, but doesn't inflate the result to a
 397 URI object.
 398
 399 =head1 AUTHORS
 400
 401 =over 4
 402
 403 =item * Brian Cassidy E<lt>bricas@cpan.orgE<gt>
 404
 405 =item * Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
 406
 407 =back
 408
 409 =head1 COPYRIGHT AND LICENSE
 410
 411 Copyright 2007-2015 by Brian Cassidy
 412
 413 This library is free software; you can redistribute it and/or modify
 414 it under the same terms as Perl itself.
 415
 416 =cut