lib/URI/Template.pm

   1 package URI::Template;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.15';
   7
   8 use URI;
   9 use URI::Escape qw(uri_escape_utf8);
  10 use Unicode::Normalize;
  11 use overload '""' => \&template;
  12
  13 =head1 NAME
  14
  15 URI::Template - Object for handling URI templates
  16
  17 =head1 SYNOPSIS
  18
  19     use URI::Template;
  20     my $template = URI::Template->new( 'http://example.com/{x}' );
  21     my $uri      = $template->process( x => 'y' );
  22     # uri is a URI object with value 'http://example.com/y'
  23
  24 =head1 DESCRIPTION
  25
  26 This is an initial attempt to provide a wrapper around URI templates
  27 as described at http://www.ietf.org/internet-drafts/draft-gregorio-uritemplate-03.txt
  28
  29 =head1 INSTALLATION
  30
  31     perl Makefile.PL
  32     make
  33     make test
  34     make install
  35
  36 =head1 METHODS
  37
  38 =head2 new( $template )
  39
  40 Creates a new L<URI::Template> instance with the template passed in
  41 as the first parameter.
  42
  43 =cut
  44
  45 sub new {
  46     my $class = shift;
  47     my $templ = shift || die 'No template provided';
  48     my $self  = bless { template => $templ, _vars => {} } => $class;
  49
  50     $self->_study;
  51
  52     return $self;
  53 }
  54
  55 sub _study {
  56     my ($self) = @_;
  57     my @hunks = grep { defined && length } split /(\{.+?\})/, $self->template;
  58     for (@hunks) {
  59       next unless /^\{(.+?)\}$/;
  60       $_ = $self->_compile_expansion($1);
  61     }
  62     $self->{studied} = \@hunks;
  63 }
  64
  65 sub _op_gen_join {
  66   my ($self, $exp) = @_;
  67
  68   return sub {
  69     my ($var) = @_;
  70
  71     my @pairs;
  72     for my $keypair (@{ $exp->{vars} }) {
  73       my $key = $keypair->[ 0 ];
  74       my $val = $keypair->[ 1 ]->( $var );
  75       next if !exists $var->{$key} && $val eq '';
  76       Carp::croak "invalid variable ($key) supplied to join operator"
  77         if ref $var->{$key};
  78
  79       push @pairs, $key . '=' . $val;
  80     }
  81     return join $exp->{arg}, @pairs;
  82   };
  83 }
  84
  85 sub _op_gen_opt {
  86     my ($self, $exp) = @_;
  87
  88     Carp::croak "-opt accepts exactly one argument" if @{ $exp->{vars} } != 1;
  89
  90     my $value   = $exp->{arg};
  91     my $varname = $exp->{vars}->[0]->[0];
  92
  93     return sub {
  94       my ($var) = @_;
  95       return '' unless exists $var->{$varname} and defined $var->{$varname};
  96       return '' if ref $var->{$varname} and not @{ $var->{$varname} };
  97
  98       return $value;
  99     };
 100 }
 101
 102 sub _op_gen_neg {
 103     my ($self, $exp) = @_;
 104
 105     Carp::croak "-neg accepts exactly one argument" if @{ $exp->{vars} } != 1;
 106
 107     my $value   = $exp->{arg};
 108     my $varname = $exp->{vars}->[0]->[0];
 109
 110     return sub {
 111       my ($var) = @_;
 112       return $value unless exists $var->{$varname} && defined $var->{$varname};
 113       return $value if ref $var->{$varname} && !  @{ $var->{$varname} };
 114
 115       return '';
 116     };
 117 }
 118
 119 sub _op_gen_prefix {
 120     my ($self, $exp) = @_;
 121
 122     Carp::croak "-prefix accepts exactly one argument" if @{$exp->{vars}} != 1;
 123
 124     my $prefix = $exp->{arg};
 125     my $name   = $exp->{vars}->[0]->[0];
 126
 127     return sub {
 128       my ($var) = @_;
 129       return '' unless exists $var->{$name} && defined $var->{$name};
 130       my $array = ref $var->{$name} ? $var->{$name} : [ $var->{$name} ];
 131       return '' unless @$array;
 132
 133       return join '', map { "$prefix$_" } @$array;
 134     };
 135 }
 136
 137 sub _op_gen_suffix {
 138     my ($self, $exp) = @_;
 139
 140     Carp::croak "-suffix accepts exactly one argument" if @{$exp->{vars}} != 1;
 141
 142     my $suffix = $exp->{arg};
 143     my $name   = $exp->{vars}->[0]->[0];
 144
 145     return sub {
 146       my ($var) = @_;
 147       return '' unless exists $var->{$name} && defined $var->{$name};
 148       my $array = ref $var->{$name} ? $var->{$name} : [ $var->{$name} ];
 149       return '' unless @$array;
 150
 151       return join '', map { "$_$suffix" } @$array;
 152     };
 153 }
 154
 155 sub _op_gen_list {
 156     my ($self, $exp) = @_;
 157
 158     Carp::croak "-list accepts exactly one argument" if @{$exp->{vars}} != 1;
 159
 160     my $joiner = $exp->{arg};
 161     my $name   = $exp->{vars}->[0]->[0];
 162
 163     return sub {
 164       my ($var) = @_;
 165       return '' unless exists $var->{$name} && defined $var->{$name};
 166       Carp::croak "variable ($name) used in -list must be an array reference"
 167         unless ref $var->{$name};
 168
 169       return '' unless my @array = @{ $var->{$name} };
 170
 171       return join $joiner, @array;
 172     };
 173 }
 174
 175 # not op_gen_* as it is not an op from the spec
 176 sub _op_fill_var {
 177     my( $self, $exp ) = @_;
 178     my( $var, $default ) = split( /=/, $exp, 2 );
 179     $default = '' if !defined $default;
 180
 181     return $var, sub {
 182         return exists $_[0]->{$var} ? $_[0]->{$var} : $default;
 183     };
 184 }
 185
 186 sub _compile_expansion {
 187     my ($self, $str) = @_;
 188
 189     if ($str =~ /\A-([a-z]+)\|(.*?)\|(.+)\z/) {
 190       my $exp = { op => $1, arg => $2, vars => [ map { [ $self->_op_fill_var( $_ ) ] } split /,/, $3 ] };
 191       $self->{ _vars }->{ $_->[ 0 ] }++ for @{ $exp->{ vars } };
 192       Carp::croak "unknown expansion operator $exp->{op} in $str"
 193         unless my $code = $self->can("_op_gen_$exp->{op}");
 194
 195       return $self->$code($exp);
 196     }
 197
 198     # remove "optional" flag (for opensearch compatibility)
 199     $str =~ s{\?$}{};
 200
 201     my @var = $self->_op_fill_var( $str );
 202     $self->{ _vars }->{ $var[ 0 ] }++;
 203     return $var[ 1 ];
 204 }
 205
 206 =head2 template
 207
 208 This method returns the original template string.
 209
 210 =cut
 211
 212 sub template {
 213     return $_[ 0 ]->{ template };
 214 }
 215
 216 =head2 variables
 217
 218 Returns an array of unique variable names found in the template. NB: they are returned in random order.
 219
 220 =cut
 221
 222 sub variables {
 223     return keys %{ $_[ 0 ]->{ _vars } };
 224 }
 225
 226 =head2 expansions
 227
 228 This method returns an list of expansions found in the template.  Currently,
 229 these are just coderefs.  In the future, they will be more interesting.
 230
 231 =cut
 232
 233 sub expansions {
 234     my $self = shift;
 235     return grep { ref } @{ $self->{studied} };
 236 }
 237
 238 =head2 process( \%vars )
 239
 240 Given a list of key-value pairs or an array ref of values (for
 241 positional substitution), it will URI escape the values and
 242 substitute them in to the template. Returns a URI object.
 243
 244 =cut
 245
 246 sub process {
 247     my $self = shift;
 248     return URI->new( $self->process_to_string( @_ ) );
 249 }
 250
 251 =head2 process_to_string( \%vars )
 252
 253 Processes input like the C<process> method, but doesn't inflate the result to a
 254 URI object.
 255
 256 =cut
 257
 258 sub process_to_string {
 259     my $self = shift;
 260     my $arg  = @_ == 1 ? $_[0] : { @_ };
 261
 262     my %data;
 263     for my $key (keys %$arg) {
 264       $data{ $key } = ref $arg->{$key}
 265                     ? [ map { uri_escape_utf8(NFKC($_)) } @{ $arg->{$key} } ]
 266                     : uri_escape_utf8(NFKC($arg->{$key}));
 267     }
 268
 269     my $str = '';
 270
 271     for my $hunk (@{ $self->{studied} }) {
 272         if (! ref $hunk) { $str .= $hunk; next; }
 273
 274         $str .= $hunk->(\%data);
 275     }
 276
 277     return $str;
 278 }
 279
 280 =head1 AUTHOR
 281
 282 Brian Cassidy E<lt>bricas@cpan.orgE<gt>
 283
 284 Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
 285
 286 =head1 COPYRIGHT AND LICENSE
 287
 288 Copyright 2007-2009 by Brian Cassidy
 289
 290 This library is free software; you can redistribute it and/or modify
 291 it under the same terms as Perl itself.
 292
 293 =cut
 294
 295 1;