X-Git-Url: http://erislabs.net/gitweb/?p=liburi-template-perl.git;a=blobdiff_plain;f=lib%2FURI%2FTemplate.pm;h=79c944f95842d52bdcf8e3d13af6b87066382af0;hp=d4831b802a701e02405308ae6c7f538714b4127e;hb=409df7817b5227c763dd2fab0d583b6d1a9656e4;hpb=1b350f7b046bbc833e37a9fba91fc808c0fed41a

diff --git a/lib/URI/Template.pm b/lib/URI/Template.pm
index d4831b8..79c944f 100644
--- a/lib/URI/Template.pm
+++ b/lib/URI/Template.pm
@@ -3,293 +3,393 @@ package URI::Template;
 use strict;
 use warnings;
 
-our $VERSION = '0.15';
+our $VERSION = '0.16';
 
 use URI;
-use URI::Escape qw(uri_escape_utf8);
-use Unicode::Normalize;
+use URI::Escape        ();
+use Unicode::Normalize ();
 use overload '""' => \&template;
 
-=head1 NAME
+my $RESERVED = q(:/?#\[\]\@!\$\&'\(\)\*\+,;=);
+my %TOSTRING = (
+    ''  => \&_tostring,
+    '+' => \&_tostring,
+    '#' => \&_tostring,
+    ';' => \&_tostring_semi,
+    '?' => \&_tostring_query,
+    '&' => \&_tostring_query,
+    '/' => \&_tostring_path,
+    '.' => \&_tostring_path,
+);
 
-URI::Template - Object for handling URI templates
+sub new {
+    my $class = shift;
+    my $templ = shift || die 'No template provided';
+    my $self  = bless { template => $templ, _vars => {} } => $class;
 
-=head1 SYNOPSIS
+    $self->_study;
 
-    use URI::Template;
-    my $template = URI::Template->new( 'http://example.com/{x}' );
-    my $uri      = $template->process( x => 'y' );
-    # uri is a URI object with value 'http://example.com/y'
+    return $self;
+}
 
-=head1 DESCRIPTION
+sub _quote {
+    my ( $val, $safe ) = @_;
+    $safe ||= '';
 
-This is an initial attempt to provide a wrapper around URI templates
-as described at http://www.ietf.org/internet-drafts/draft-gregorio-uritemplate-03.txt
+    # try to mirror python's urllib quote
+    my $unsafe = '^A-Za-z0-9\-\._' . $safe;
+    return URI::Escape::uri_escape_utf8( Unicode::Normalize::NFKC( $val ),
+        $unsafe );
+}
 
-=head1 INSTALLATION
+sub _tostring {
+    my ( $var, $value, $exp ) = @_;
+    my $safe = $exp->{ safe };
 
-    perl Makefile.PL
-    make
-    make test
-    make install
+    if ( ref $value eq 'ARRAY' ) {
+        return join( ',', map { _quote( $_, $safe ) } @$value );
+    }
+    elsif ( ref $value eq 'HASH' ) {
+        return join(
+            ',',
+            map {
+                _quote( $_, $safe )
+                    . ( $var->{ explode } ? '=' : ',' )
+                    . _quote( $value->{ $_ }, $safe )
+                } sort keys %$value
+        );
+    }
+    elsif ( defined $value ) {
+        return _quote(
+            substr( $value, 0, $var->{ prefix } || length( $value ) ),
+            $safe );
+    }
 
-=head1 METHODS
+    return;
+}
 
-=head2 new( $template )
+sub _tostring_semi {
+    my ( $var, $value, $exp ) = @_;
+    my $safe = $exp->{ safe };
+    my $join = $exp->{ op };
+    $join = '&' if $exp->{ op } eq '?';
+
+    if ( ref $value eq 'ARRAY' ) {
+        if ( $var->{ explode } ) {
+            return join( $join,
+                map { $var->{ name } . '=' . _quote( $_, $safe ) } @$value );
+        }
+        else {
+            return $var->{ name } . '='
+                . join( ',', map { _quote( $_, $safe ) } @$value );
+        }
+    }
+    elsif ( ref $value eq 'HASH' ) {
+        if ( $var->{ explode } ) {
+            return join(
+                $join,
+                map {
+                    _quote( $_, $safe ) . '='
+                        . _quote( $value->{ $_ }, $safe )
+                    } sort keys %$value
+            );
+        }
+        else {
+            return $var->{ name } . '=' . join(
+                ',',
+                map {
+                    _quote( $_, $safe ) . ','
+                        . _quote( $value->{ $_ }, $safe )
+                    } sort keys %$value
+            );
+        }
+    }
+    elsif ( defined $value ) {
+        return $var->{ name } unless length( $value );
+        return
+            $var->{ name } . '='
+            . _quote(
+            substr( $value, 0, $var->{ prefix } || length( $value ) ),
+            $safe );
+    }
 
-Creates a new L<URI::Template> instance with the template passed in
-as the first parameter.
+    return;
+}
 
-=cut
+sub _tostring_query {
+    my ( $var, $value, $exp ) = @_;
+    my $safe = $exp->{ safe };
+    my $join = $exp->{ op };
+    $join = '&' if $exp->{ op } =~ /[?&]/;
+
+    if ( ref $value eq 'ARRAY' ) {
+        return unless @$value;
+        if ( $var->{ explode } ) {
+            return join( $join,
+                map { $var->{ name } . '=' . _quote( $_, $safe ) } @$value );
+        }
+        else {
+            return $var->{ name } . '='
+                . join( ',', map { _quote( $_, $safe ) } @$value );
+        }
+    }
+    elsif ( ref $value eq 'HASH' ) {
+        return unless keys %$value;
+        if ( $var->{ explode } ) {
+            return join(
+                $join,
+                map {
+                    _quote( $_, $safe ) . '='
+                        . _quote( $value->{ $_ }, $safe )
+                    } sort keys %$value
+            );
+        }
+        else {
+            return $var->{ name } . '=' . join(
+                ',',
+                map {
+                    _quote( $_, $safe ) . ','
+                        . _quote( $value->{ $_ }, $safe )
+                    } sort keys %$value
+            );
+        }
+    }
+    elsif ( defined $value ) {
+        return $var->{ name } . '=' unless length( $value );
+        return
+            $var->{ name } . '='
+            . _quote(
+            substr( $value, 0, $var->{ prefix } || length( $value ) ),
+            $safe );
+    }
+}
 
-sub new {
-    my $class = shift;
-    my $templ = shift || die 'No template provided';
-    my $self  = bless { template => $templ, _vars => {} } => $class;
-    
-    $self->_study;
+sub _tostring_path {
+    my ( $var, $value, $exp ) = @_;
+    my $safe = $exp->{ safe };
+    my $join = $exp->{ op };
+
+    if ( ref $value eq 'ARRAY' ) {
+        return unless @$value;
+        return join(
+            ( $var->{ explode } ? $join : ',' ),
+            map { _quote( $_, $safe ) } @$value
+        );
+    }
+    elsif ( ref $value eq 'HASH' ) {
+        return join(
+            ( $var->{ explode } ? $join : ',' ),
+            map {
+                _quote( $_, $safe )
+                    . ( $var->{ explode } ? '=' : ',' )
+                    . _quote( $value->{ $_ }, $safe )
+                } sort keys %$value
+        );
+    }
+    elsif ( defined $value ) {
+        return _quote(
+            substr( $value, 0, $var->{ prefix } || length( $value ) ),
+            $safe );
+    }
 
-    return $self;
+    return;
 }
 
 sub _study {
-    my ($self) = @_;
+    my ( $self ) = @_;
     my @hunks = grep { defined && length } split /(\{.+?\})/, $self->template;
-    for (@hunks) {
-      next unless /^\{(.+?)\}$/;
-      $_ = $self->_compile_expansion($1);
+    for ( @hunks ) {
+        next unless /^\{(.+?)\}$/;
+        $_ = $self->_compile_expansion( $1 );
     }
-    $self->{studied} = \@hunks;
+    $self->{ studied } = \@hunks;
 }
 
-sub _op_gen_join {
-  my ($self, $exp) = @_;
-
-  return sub {
-    my ($var) = @_;
+sub _compile_expansion {
+    my ( $self, $str ) = @_;
 
-    my @pairs;
-    for my $keypair (@{ $exp->{vars} }) {
-      my $key = $keypair->[ 0 ];
-      my $val = $keypair->[ 1 ]->( $var );
-      next if !exists $var->{$key} && $val eq '';
-      Carp::croak "invalid variable ($key) supplied to join operator"
-        if ref $var->{$key};
+    my %exp = ( op => '', vars => [], str => $str );
+    if ( $str =~ /^([+#.\/;?&|!\@])(.+)/ ) {
+        $exp{ op }  = $1;
+        $exp{ str } = $2;
+    }
 
-      push @pairs, $key . '=' . $val;
+    $exp{ safe } = $RESERVED if $exp{ op } =~ m{[+#]};
+
+    for my $varspec ( split( ',', delete $exp{ str } ) ) {
+        my %var = ( name => $varspec );
+        if ( $varspec =~ /=/ ) {
+            @var{ 'name', 'default' } = split( /=/, $varspec, 2 );
+        }
+        if ( $var{ name } =~ s{\*$}{} ) {
+            $var{ explode } = 1;
+        }
+        elsif ( $var{ name } =~ /:/ ) {
+            @var{ 'name', 'prefix' } = split( /:/, $var{ name }, 2 );
+            if ( $var{ prefix } =~ m{[^0-9]} ) {
+                die 'Non-numeric prefix specified';
+            }
+        }
+
+        # remove "optional" flag (for opensearch compatibility)
+        $var{ name } =~ s{\?$}{};
+        $self->{ _vars }->{ $var{ name } }++;
+
+        push @{ $exp{ vars } }, \%var;
     }
-    return join $exp->{arg}, @pairs;
-  };
-}
 
-sub _op_gen_opt {
-    my ($self, $exp) = @_;
+    my $join  = $exp{ op };
+    my $start = $exp{ op };
 
-    Carp::croak "-opt accepts exactly one argument" if @{ $exp->{vars} } != 1;
+    if ( $exp{ op } eq '+' ) {
+        $start = '';
+        $join  = ',';
+    }
+    elsif ( $exp{ op } eq '#' ) {
+        $join = ',';
+    }
+    elsif ( $exp{ op } eq '?' ) {
+        $join = '&';
+    }
+    elsif ( $exp{ op } eq '&' ) {
+        $join = '&';
+    }
+    elsif ( $exp{ op } eq '' ) {
+        $join = ',';
+    }
 
-    my $value   = $exp->{arg};
-    my $varname = $exp->{vars}->[0]->[0];
+    if ( !exists $TOSTRING{ $exp{ op } } ) {
+        die 'Invalid operation "' . $exp{ op } . '"';
+    }
 
     return sub {
-      my ($var) = @_;
-      return '' unless exists $var->{$varname} and defined $var->{$varname};
-      return '' if ref $var->{$varname} and not @{ $var->{$varname} };
+        my $variables = shift;
 
-      return $value;
-    };
-}
+        my @return;
+        for my $var ( @{ $exp{ vars } } ) {
+            my $value;
+            if ( exists $variables->{ $var->{ name } } ) {
+                $value = $variables->{ $var->{ name } };
+            }
+            $value = $var->{ default } if !defined $value;
 
-sub _op_gen_neg {
-    my ($self, $exp) = @_;
+            next unless defined $value;
 
-    Carp::croak "-neg accepts exactly one argument" if @{ $exp->{vars} } != 1;
+            my $expand = $TOSTRING{ $exp{ op } }->( $var, $value, \%exp );
 
-    my $value   = $exp->{arg};
-    my $varname = $exp->{vars}->[0]->[0];
-
-    return sub {
-      my ($var) = @_;
-      return $value unless exists $var->{$varname} && defined $var->{$varname};
-      return $value if ref $var->{$varname} && !  @{ $var->{$varname} };
+            push @return, $expand if defined $expand;
+        }
 
-      return '';
+        return $start . join( $join, @return ) if @return;
+        return '';
     };
 }
 
-sub _op_gen_prefix {
-    my ($self, $exp) = @_;
-
-    Carp::croak "-prefix accepts exactly one argument" if @{$exp->{vars}} != 1;
-
-    my $prefix = $exp->{arg};
-    my $name   = $exp->{vars}->[0]->[0];
+sub template {
+    return $_[ 0 ]->{ template };
+}
 
-    return sub {
-      my ($var) = @_;
-      return '' unless exists $var->{$name} && defined $var->{$name};
-      my $array = ref $var->{$name} ? $var->{$name} : [ $var->{$name} ];
-      return '' unless @$array;
+sub variables {
+    return keys %{ $_[ 0 ]->{ _vars } };
+}
 
-      return join '', map { "$prefix$_" } @$array;
-    };
+sub expansions {
+    my $self = shift;
+    return grep { ref } @{ $self->{ studied } };
 }
 
-sub _op_gen_suffix {
-    my ($self, $exp) = @_;
+sub process {
+    my $self = shift;
+    return URI->new( $self->process_to_string( @_ ) );
+}
 
-    Carp::croak "-suffix accepts exactly one argument" if @{$exp->{vars}} != 1;
+sub process_to_string {
+    my $self = shift;
+    my $arg  = @_ == 1 ? $_[ 0 ] : { @_ };
+    my $str  = '';
 
-    my $suffix = $exp->{arg};
-    my $name   = $exp->{vars}->[0]->[0];
+    for my $hunk ( @{ $self->{ studied } } ) {
+        if ( !ref $hunk ) { $str .= $hunk; next; }
 
-    return sub {
-      my ($var) = @_;
-      return '' unless exists $var->{$name} && defined $var->{$name};
-      my $array = ref $var->{$name} ? $var->{$name} : [ $var->{$name} ];
-      return '' unless @$array;
+        $str .= $hunk->( $arg );
+    }
 
-      return join '', map { "$_$suffix" } @$array;
-    };
+    return $str;
 }
 
-sub _op_gen_list {
-    my ($self, $exp) = @_;
+1;
 
-    Carp::croak "-list accepts exactly one argument" if @{$exp->{vars}} != 1;
+__END__
 
-    my $joiner = $exp->{arg};
-    my $name   = $exp->{vars}->[0]->[0];
+=head1 NAME
 
-    return sub {
-      my ($var) = @_;
-      return '' unless exists $var->{$name} && defined $var->{$name};
-      Carp::croak "variable ($name) used in -list must be an array reference"
-        unless ref $var->{$name};
+URI::Template - Object for handling URI templates (RFC 6570)
 
-      return '' unless my @array = @{ $var->{$name} };
+=head1 SYNOPSIS
 
-      return join $joiner, @array;
-    };
-}
+    use URI::Template;
+    my $template = URI::Template->new( 'http://example.com/{x}' );
+    my $uri      = $template->process( x => 'y' );
+    # uri is a URI object with value 'http://example.com/y'
 
-# not op_gen_* as it is not an op from the spec
-sub _op_fill_var {
-    my( $self, $exp ) = @_;
-    my( $var, $default ) = split( /=/, $exp, 2 );
-    $default = '' if !defined $default;
+=head1 DESCRIPTION
 
-    return $var, sub {
-        return exists $_[0]->{$var} ? $_[0]->{$var} : $default;
-    };
-}
+This module provides a wrapper around URI templates as described in RFC 6570: 
+http://tools.ietf.org/html/rfc6570
 
-sub _compile_expansion {
-    my ($self, $str) = @_;
+=head1 INSTALLATION
 
-    if ($str =~ /\A-([a-z]+)\|(.*?)\|(.+)\z/) {
-      my $exp = { op => $1, arg => $2, vars => [ map { [ $self->_op_fill_var( $_ ) ] } split /,/, $3 ] };
-      $self->{ _vars }->{ $_->[ 0 ] }++ for @{ $exp->{ vars } };
-      Carp::croak "unknown expansion operator $exp->{op} in $str"
-        unless my $code = $self->can("_op_gen_$exp->{op}");
+    perl Makefile.PL
+    make
+    make test
+    make install
 
-      return $self->$code($exp);
-    }
+=head1 METHODS
 
-    # remove "optional" flag (for opensearch compatibility)
-    $str =~ s{\?$}{};
+=head2 new( $template )
 
-    my @var = $self->_op_fill_var( $str );
-    $self->{ _vars }->{ $var[ 0 ] }++;
-    return $var[ 1 ];
-}
+Creates a new L<URI::Template> instance with the template passed in
+as the first parameter.
 
 =head2 template
 
 This method returns the original template string.
 
-=cut
-
-sub template {
-    return $_[ 0 ]->{ template };
-}
-
 =head2 variables
 
 Returns an array of unique variable names found in the template. NB: they are returned in random order.
 
-=cut
-
-sub variables {
-    return keys %{ $_[ 0 ]->{ _vars } };
-}
-
 =head2 expansions
 
 This method returns an list of expansions found in the template.  Currently,
 these are just coderefs.  In the future, they will be more interesting.
 
-=cut
-
-sub expansions {
-    my $self = shift;
-    return grep { ref } @{ $self->{studied} };
-}
-
 =head2 process( \%vars )
 
 Given a list of key-value pairs or an array ref of values (for
 positional substitution), it will URI escape the values and
 substitute them in to the template. Returns a URI object.
 
-=cut
-
-sub process {
-    my $self = shift;
-    return URI->new( $self->process_to_string( @_ ) );
-}
-
 =head2 process_to_string( \%vars )
 
 Processes input like the C<process> method, but doesn't inflate the result to a
 URI object.
 
-=cut
-
-sub process_to_string {
-    my $self = shift;
-    my $arg  = @_ == 1 ? $_[0] : { @_ };
-
-    my %data;
-    for my $key (keys %$arg) {
-      $data{ $key } = ref $arg->{$key}
-                    ? [ map { uri_escape_utf8(NFKC($_)) } @{ $arg->{$key} } ]
-                    : uri_escape_utf8(NFKC($arg->{$key}));
-    }
-
-    my $str = '';
+=head1 AUTHORS
 
-    for my $hunk (@{ $self->{studied} }) {
-        if (! ref $hunk) { $str .= $hunk; next; }
+=over 4
 
-        $str .= $hunk->(\%data);
-    }
+=item * Brian Cassidy E<lt>bricas@cpan.orgE<gt>
 
-    return $str;
-}
+=item * Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
 
-=head1 AUTHOR
-
-Brian Cassidy E<lt>bricas@cpan.orgE<gt>
-
-Ricardo SIGNES E<lt>rjbs@cpan.orgE<gt>
+=back
 
 =head1 COPYRIGHT AND LICENSE
 
-Copyright 2007-2009 by Brian Cassidy
+Copyright 2007-2012 by Brian Cassidy
 
 This library is free software; you can redistribute it and/or modify
 it under the same terms as Perl itself. 
 
 =cut
-
-1;