lib/URI/Template.pm

   1 package URI::Template;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.12';
   7
   8 use URI;
   9 use URI::Escape ();
  10 use overload '""' => \&as_string;
  11
  12 my $unsafe = q(^A-Za-z0-9\-_.~!\$\&'()*+,;=:/?\[\]#@);
  13
  14 =head1 NAME
  15
  16 URI::Template - Object for handling URI templates
  17
  18 =head1 SYNOPSIS
  19
  20     use URI::Template;
  21     my $template = URI::Template->new( 'http://example.com/{x}' );
  22     my $uri      = $template->process( x => 'y' );
  23     # uri is a URI object with value 'http://example.com/y'
  24
  25     my %result = $template->deparse( $uri );
  26     # %result is ( x => 'y' )
  27
  28 =head1 DESCRIPTION
  29
  30 This is an initial attempt to provide a wrapper around URI templates
  31 as described at http://www.ietf.org/internet-drafts/draft-gregorio-uritemplate-01.txt
  32
  33 =head1 INSTALLATION
  34
  35     perl Makefile.PL
  36     make
  37     make test
  38     make install
  39
  40 =head1 METHODS
  41
  42 =head2 new( $template )
  43
  44 Creates a new L<URI::Template> instance with the template passed in
  45 as the first parameter.
  46
  47 =cut
  48
  49 sub new {
  50     my $class = shift;
  51     my $templ = shift || die 'No template provided';
  52     my $self  = bless { template => $templ }, $class;
  53
  54     return $self;
  55 }
  56
  57 =head2 as_string( )
  58
  59 Returns the original template string. Also used when the object is
  60 stringified.
  61
  62 =cut
  63
  64 sub as_string {
  65     return $_[ 0 ]->{ template };
  66 }
  67
  68 =head2 variables( )
  69
  70 Returns an array of unique variable names found in the template.
  71 NB: they are returned in random order.
  72
  73 =cut
  74
  75 sub variables {
  76     my $self = shift;
  77     my %vars = map { $_ => 1 } $self->all_variables;
  78     return keys %vars;
  79 }
  80
  81 =head2 all_variables( )
  82
  83 Returns an array of variable names found as they appear in template --
  84 in order, duplicates included.
  85
  86 =cut
  87
  88 sub all_variables {
  89     my $self = shift;
  90     my @vars = $self->as_string =~ /{(.+?)}/g;
  91     return @vars;
  92 }
  93
  94 =head2 process( %vars|\@values )
  95
  96 Given a list of key-value pairs or an array ref of values (for
  97 positional substitution), it will URI escape the values and
  98 substitute them in to the template. Returns a URI object.
  99
 100 =cut
 101
 102 sub process {
 103     my $self = shift;
 104     return URI->new( $self->process_to_string( @_ ) );
 105 }
 106
 107 =head2 process_to_string( %vars|\@values )
 108
 109 Processes input like the C<process> method, but doesn't
 110 inflate the result to a URI object.
 111
 112 =cut
 113
 114 sub process_to_string {
 115     my $self = shift;
 116
 117     if ( ref $_[ 0 ] ) {
 118         return $self->_process_by_position( @_ );
 119     }
 120     else {
 121         return $self->_process_by_key( @_ );
 122     }
 123 }
 124
 125 sub _process_by_key {
 126     my $self   = shift;
 127     my @vars   = $self->variables;
 128     my %params = @_;
 129     my $uri    = $self->as_string;
 130
 131     # fix undef vals
 132     for my $var ( @vars ) {
 133         $params{ $var }
 134             = defined $params{ $var }
 135             ? URI::Escape::uri_escape( $params{ $var }, $unsafe )
 136             : '';
 137     }
 138
 139     my $regex = '\{(' . join( '|', map quotemeta, @vars ) . ')\}';
 140     $uri =~ s/$regex/$params{$1}/eg;
 141
 142     return $uri;
 143 }
 144
 145 sub _process_by_position {
 146     my $self   = shift;
 147     my @params = @{ $_[ 0 ] };
 148
 149     my $uri = $self->as_string;
 150
 151     $uri =~ s/{(.+?)}/@params
 152         ? defined $params[ 0 ]
 153             ? URI::Escape::uri_escape( shift @params, $unsafe )
 154             : ''
 155         : ''/eg;
 156
 157     return $uri;
 158 }
 159
 160 =head2 deparse( $uri )
 161
 162 Does some rudimentary deparsing of a uri based on the current template.
 163 Returns a hash with the extracted values.
 164
 165 =cut
 166
 167 sub deparse {
 168     my $self = shift;
 169     my $uri  = shift;
 170
 171     if ( !$self->{ deparse_re } ) {
 172         my $templ = $self->as_string;
 173         $self->{ vars_list } = [ $templ =~ /{(.+?)}/g ];
 174         $templ =~ s/{.+?}/(.+?)/g;
 175         # If the template ends w/ a match, then make it greedy.
 176         $templ =~ s/\Q(.+?)\E$/(.+)/;
 177         $self->{ deparse_re } = qr/$templ/;
 178     }
 179
 180     my @matches = $uri =~ $self->{ deparse_re };
 181
 182     my %results;
 183     @results{ @{ $self->{ vars_list } } } = @matches;
 184     return %results;
 185 }
 186
 187 =head1 AUTHOR
 188
 189 Brian Cassidy E<lt>bricas@cpan.orgE<gt>
 190
 191 =head1 COPYRIGHT AND LICENSE
 192
 193 Copyright 2008 by Brian Cassidy
 194
 195 This library is free software; you can redistribute it and/or modify
 196 it under the same terms as Perl itself.
 197
 198 =cut
 199
 200 1;