9 use URI::Escape qw(uri_escape_utf8);
10 use Unicode::Normalize;
11 use overload '""' => \&template;
15 URI::Template - Object for handling URI templates
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'
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
38 =head2 new( $template )
40 Creates a new L<URI::Template> instance with the template passed in
41 as the first parameter.
47 my $templ = shift || die 'No template provided';
48 my $self = bless { template => $templ, _vars => {} } => $class;
57 my @hunks = grep { defined && length } split /(\{.+?\})/, $self->template;
59 next unless /^\{(.+?)\}$/;
60 $_ = $self->_compile_expansion($1);
62 $self->{studied} = \@hunks;
66 my ($self, $exp) = @_;
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"
79 push @pairs, $key . '=' . $val;
81 return join $exp->{arg}, @pairs;
86 my ($self, $exp) = @_;
88 Carp::croak "-opt accepts exactly one argument" if @{ $exp->{vars} } != 1;
90 my $value = $exp->{arg};
91 my $varname = $exp->{vars}->[0]->[0];
95 return '' unless exists $var->{$varname} and defined $var->{$varname};
96 return '' if ref $var->{$varname} and not @{ $var->{$varname} };
103 my ($self, $exp) = @_;
105 Carp::croak "-neg accepts exactly one argument" if @{ $exp->{vars} } != 1;
107 my $value = $exp->{arg};
108 my $varname = $exp->{vars}->[0]->[0];
112 return $value unless exists $var->{$varname} && defined $var->{$varname};
113 return $value if ref $var->{$varname} && ! @{ $var->{$varname} };
120 my ($self, $exp) = @_;
122 Carp::croak "-prefix accepts exactly one argument" if @{$exp->{vars}} != 1;
124 my $prefix = $exp->{arg};
125 my $name = $exp->{vars}->[0]->[0];
129 return '' unless exists $var->{$name} && defined $var->{$name};
130 my $array = ref $var->{$name} ? $var->{$name} : [ $var->{$name} ];
131 return '' unless @$array;
133 return join '', map { "$prefix$_" } @$array;
138 my ($self, $exp) = @_;
140 Carp::croak "-suffix accepts exactly one argument" if @{$exp->{vars}} != 1;
142 my $suffix = $exp->{arg};
143 my $name = $exp->{vars}->[0]->[0];
147 return '' unless exists $var->{$name} && defined $var->{$name};
148 my $array = ref $var->{$name} ? $var->{$name} : [ $var->{$name} ];
149 return '' unless @$array;
151 return join '', map { "$_$suffix" } @$array;
156 my ($self, $exp) = @_;
158 Carp::croak "-list accepts exactly one argument" if @{$exp->{vars}} != 1;
160 my $joiner = $exp->{arg};
161 my $name = $exp->{vars}->[0]->[0];
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};
169 return '' unless my @array = @{ $var->{$name} };
171 return join $joiner, @array;
175 # not op_gen_* as it is not an op from the spec
177 my( $self, $exp ) = @_;
178 my( $var, $default ) = split( /=/, $exp, 2 );
179 $default = '' if !defined $default;
182 return exists $_[0]->{$var} ? $_[0]->{$var} : $default;
186 sub _compile_expansion {
187 my ($self, $str) = @_;
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}");
195 return $self->$code($exp);
198 # remove "optional" flag (for opensearch compatibility)
201 my @var = $self->_op_fill_var( $str );
202 $self->{ _vars }->{ $var[ 0 ] }++;
208 This method returns the original template string.
213 return $_[ 0 ]->{ template };
218 Returns an array of unique variable names found in the template. NB: they are returned in random order.
223 return keys %{ $_[ 0 ]->{ _vars } };
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.
235 return grep { ref } @{ $self->{studied} };
238 =head2 process( \%vars )
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.
248 return URI->new( $self->process_to_string( @_ ) );
251 =head2 process_to_string( \%vars )
253 Processes input like the C<process> method, but doesn't inflate the result to a
258 sub process_to_string {
260 my $arg = @_ == 1 ? $_[0] : { @_ };
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}));
271 for my $hunk (@{ $self->{studied} }) {
272 if (! ref $hunk) { $str .= $hunk; next; }
274 $str .= $hunk->(\%data);
282 Brian Cassidy E<lt>bricas@cpan.orgE<gt>
284 Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
286 =head1 COPYRIGHT AND LICENSE
288 Copyright 2007-2009 by Brian Cassidy
290 This library is free software; you can redistribute it and/or modify
291 it under the same terms as Perl itself.