lib/URI/Template.pm

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