lib/URI/Template.pm

   1 package URI::Template;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.09';
   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 } = defined $params{ $var }
 134             ? URI::Escape::uri_escape( $params{ $var }, $unsafe )
 135             : '';
 136     }
 137
 138     my $regex = '\{(' . join( '|', map quotemeta, @vars ) . ')\}';
 139     $uri =~ s/$regex/$params{$1}/eg;
 140
 141     return $uri;
 142 }
 143
 144 sub _process_by_position {
 145     my $self   = shift;
 146     my @params = @{ $_[ 0 ] };
 147
 148     my $uri = $self->as_string;
 149
 150     $uri =~ s/{(.+?)}/@params
 151         ? defined $params[ 0 ]
 152             ? URI::Escape::uri_escape( shift @params, $unsafe )
 153             : ''
 154         : ''/eg;
 155
 156     return $uri;
 157 }
 158
 159 =head2 deparse( $uri )
 160
 161 Does some rudimentary deparsing of a uri based on the current template.
 162 Returns a hash with the extracted values.
 163
 164 =cut
 165
 166 sub deparse {
 167     my $self = shift;
 168     my $uri  = shift;
 169
 170     if( !$self->{ deparse_re } ) {
 171        my $templ = $self->as_string;
 172        $self->{ vars_list } = [ $templ =~ /{(.+?)}/g ];
 173        $templ =~ s/{.+?}/(.+?)/g;
 174        $self->{ deparse_re } = qr/$templ/;
 175     }
 176
 177     my @matches = $uri =~ $self->{ deparse_re };
 178
 179     my %results;
 180     @results{ @{ $self->{ vars_list } } } = @matches;
 181     return %results;
 182 }
 183
 184 =head1 AUTHOR
 185
 186 Brian Cassidy E<lt>bricas@cpan.orgE<gt>
 187
 188 =head1 COPYRIGHT AND LICENSE
 189
 190 Copyright 2007 by Brian Cassidy
 191
 192 This library is free software; you can redistribute it and/or modify
 193 it under the same terms as Perl itself.
 194
 195 =cut
 196
 197 1;