lib/URI/Template.pm

   1 package URI::Template;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.08_01';
   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 To install this module via Module::Build:
  36
  37         perl Build.PL
  38         ./Build         # or `perl Build`
  39         ./Build test    # or `perl Build test`
  40         ./Build install # or `perl Build install`
  41
  42 To install this module via ExtUtils::MakeMaker:
  43
  44         perl Makefile.PL
  45         make
  46         make test
  47         make install
  48
  49 =head1 METHODS
  50
  51 =head2 new( $template )
  52
  53 Creates a new L<URI::Template> instance with the template passed in
  54 as the first parameter.
  55
  56 =cut
  57
  58 sub new {
  59     my $class = shift;
  60     my $templ = shift || die 'No template provided';
  61     my $self  = bless { template => $templ }, $class;
  62
  63     return $self;
  64 }
  65
  66 =head2 as_string( )
  67
  68 Returns the original template string. Also used when the object is
  69 stringified.
  70
  71 =cut
  72
  73 sub as_string {
  74     return $_[ 0 ]->{ template };
  75 }
  76
  77 =head2 variables( )
  78
  79 Returns an array of variable names found in the template. NB: they
  80 are returned in random order.
  81
  82 =cut
  83
  84 sub variables {
  85     my $self = shift;
  86     my %vars = map { $_ => 1 } $self->all_variables;
  87     return keys %vars;
  88 }
  89
  90 =head2 all_variables( )
  91
  92 Returns an array of variable names found as they appear in template --
  93 in order, duplicates included.
  94
  95 =cut
  96
  97 sub all_variables {
  98     my $self = shift;
  99     my @vars = $self->as_string =~ /{(.+?)}/g;
 100     return @vars;
 101 }
 102
 103 =head2 process( %vars|\@values )
 104
 105 Given a list of key-value pairs or an array ref of values (for
 106 positional substitution), it will URI escape the values and
 107 substitute them in to the template. Returns a URI object.
 108
 109 =cut
 110
 111 sub process {
 112     my $self = shift;
 113     return URI->new( $self->process_to_string( @_ ) );
 114 }
 115
 116 =head2 process_to_string( %vars|\@values )
 117
 118 Processes input like the C<process> method, but doesn't
 119 inflate the result to a URI object.
 120
 121 =cut
 122
 123 sub process_to_string {
 124     my $self = shift;
 125
 126     if( ref $_[ 0 ] ) {
 127         return $self->_process_by_position( @_ );
 128     }
 129     else {
 130         return $self->_process_by_key( @_ );
 131     }
 132 }
 133
 134 sub _process_by_key {
 135     my $self   = shift;
 136     my @vars   = $self->variables;
 137     my %params = @_;
 138     my $uri    = $self->as_string;
 139
 140     # fix undef vals
 141     for my $var ( @vars ) {
 142         $params{ $var } = defined $params{ $var }
 143             ? URI::Escape::uri_escape( $params{ $var }, $unsafe )
 144             : '';
 145     }
 146
 147     my $regex = '\{(' . join( '|', map quotemeta, @vars ) . ')\}';
 148     $uri =~ s/$regex/$params{$1}/eg;
 149
 150     return $uri;
 151 }
 152
 153 sub _process_by_position {
 154     my $self   = shift;
 155     my @params = @{ $_[ 0 ] };
 156
 157     my $uri = $self->as_string;
 158
 159     $uri =~ s/{(.+?)}/@params
 160         ? defined $params[ 0 ]
 161             ? URI::Escape::uri_escape( shift @params, $unsafe )
 162             : ''
 163         : ''/eg;
 164
 165     return $uri;
 166 }
 167
 168 =head2 deparse( $uri )
 169
 170 Does some rudimentary deparsing of a uri based on the current template.
 171 Returns a hash with the extracted values.
 172
 173 =cut
 174
 175 sub deparse {
 176     my $self = shift;
 177     my $uri  = shift;
 178
 179     if( !$self->{ deparse_re } ) {
 180        my $templ = $self->as_string;
 181        $self->{ vars_list } = [ $templ =~ /{(.+?)}/g ];
 182        $templ =~ s/{.+?}/(.+?)/g;
 183        $self->{ deparse_re } = qr/$templ/;
 184     }
 185
 186     my @matches = $uri =~ $self->{ deparse_re };
 187
 188     my %results;
 189     @results{ @{ $self->{ vars_list } } } = @matches;
 190     return %results;
 191 }
 192
 193 =head1 AUTHOR
 194
 195 =over 4
 196
 197 =item * Brian Cassidy E<lt>bricas@cpan.orgE<gt>
 198
 199 =back
 200
 201 =head1 COPYRIGHT AND LICENSE
 202
 203 Copyright 2007 by Brian Cassidy
 204
 205 This library is free software; you can redistribute it and/or modify
 206 it under the same terms as Perl itself.
 207
 208 =cut
 209
 210 1;