lib/URI/Template.pm

   1 package URI::Template;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.21';
   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     return sort {$_[ 0 ]->{ _vars }->{ $a } <=> $_[ 0 ]->{ _vars }->{ $b } } keys %{ $_[ 0 ]->{ _vars } };
 307 }
 308
 309 sub expansions {
 310     my $self = shift;
 311     return grep { ref } @{ $self->{ studied } };
 312 }
 313
 314 sub process {
 315     my $self = shift;
 316     return URI->new( $self->process_to_string( @_ ) );
 317 }
 318
 319 sub process_to_string {
 320     my $self = shift;
 321     my $arg  = @_ == 1 ? $_[ 0 ] : { @_ };
 322     my $str  = '';
 323
 324     for my $hunk ( @{ $self->{ studied } } ) {
 325         if ( !ref $hunk ) { $str .= $hunk; next; }
 326
 327         $str .= $hunk->( $arg );
 328     }
 329
 330     return $str;
 331 }
 332
 333 1;
 334
 335 __END__
 336
 337 =head1 NAME
 338
 339 URI::Template - Object for handling URI templates (RFC 6570)
 340
 341 =head1 SYNOPSIS
 342
 343     use URI::Template;
 344
 345     my $template = URI::Template->new( 'http://example.com/{x}' );
 346     my $uri      = $template->process( x => 'y' );
 347
 348     # or
 349
 350     my $template = URI::Template->new();
 351     $template->template( 'http://example.com/{x}' );
 352     my $uri      = $template->process( x => 'y' );
 353
 354     # uri is a URI object with value 'http://example.com/y'
 355
 356 =head1 DESCRIPTION
 357
 358 This module provides a wrapper around URI templates as described in RFC 6570:
 359 L<< http://tools.ietf.org/html/rfc6570 >>.
 360
 361 =head1 INSTALLATION
 362
 363     perl Makefile.PL
 364     make
 365     make test
 366     make install
 367
 368 =head1 METHODS
 369
 370 =head2 new( $template )
 371
 372 Creates a new L<URI::Template> instance with the template passed in
 373 as the first parameter (optional).
 374
 375 =head2 template( $template )
 376
 377 This method returns the original template string. If provided, it will also set and parse a
 378 new template string.
 379
 380 =head2 variables
 381
 382 Returns an array of unique variable names found in the template (in the order of appearance).
 383
 384 =head2 expansions
 385
 386 This method returns an list of expansions found in the template.  Currently,
 387 these are just coderefs.  In the future, they will be more interesting.
 388
 389 =head2 process( \%vars )
 390
 391 Given a list of key-value pairs or an array ref of values (for
 392 positional substitution), it will URI escape the values and
 393 substitute them in to the template. Returns a URI object.
 394
 395 =head2 process_to_string( \%vars )
 396
 397 Processes input like the C<process> method, but doesn't inflate the result to a
 398 URI object.
 399
 400 =head1 AUTHORS
 401
 402 =over 4
 403
 404 =item * Brian Cassidy E<lt>bricas@cpan.orgE<gt>
 405
 406 =item * Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
 407
 408 =back
 409
 410 =head1 COPYRIGHT AND LICENSE
 411
 412 Copyright 2007-2015 by Brian Cassidy
 413
 414 This library is free software; you can redistribute it and/or modify
 415 it under the same terms as Perl itself.
 416
 417 =cut