lib/URI/Template.pm

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