From 55f97a4ef2080f9fa90d5a85b703f23df76aa815 Mon Sep 17 00:00:00 2001 From: David Baird Date: Wed, 12 Oct 2005 01:31:53 +0000 Subject: [PATCH] Added make_path() and make_uri() methods, and pathtools.t to test them. git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@398 48953598-375a-da11-a14b-00016c27c3ee --- MANIFEST | 1 + lib/Maypole.pm | 92 ++++++++++++++++++++++++ t/maypole.t | 6 +- t/pathtools.t | 191 +++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 289 insertions(+), 1 deletion(-) create mode 100644 t/pathtools.t diff --git a/MANIFEST b/MANIFEST index 5f23cef..ad265bd 100644 --- a/MANIFEST +++ b/MANIFEST @@ -40,6 +40,7 @@ t/cgi_maypole.t t/constants.t t/headers.t t/maypole.t +t/pathtools.t t/templates/custom/classdata t/templates/custom/frontpage t/templates/custom/list diff --git a/lib/Maypole.pm b/lib/Maypole.pm index bec9675..14260bd 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -6,6 +6,7 @@ use warnings; use Maypole::Config; use Maypole::Constants; use Maypole::Headers; +use URI(); our $VERSION = '2.11'; @@ -355,6 +356,95 @@ sub parse_path $self->args(\@pi); } +=head3 make_path( %args or \%args or @args ) + +This is the counterpart to C. It generates a path to use +in links, form actions etc. To implement your own path scheme, just override +this method and C. + + %args = ( table => $table, + action => $action, + additional => $additional, # optional - generally an object ID + ); + + \%args = as above, but a ref + + @args = ( $table, $action, $additional ); # $additional is optional + +C can be used as an alternative key to C. + +C<$additional> can be a string, an arrayref, or a hashref. An arrayref is +expanded into extra path elements, whereas a hashref is translated into a query +string. + +=cut + +sub make_path +{ + my $r = shift; + + my %args; + + if (@_ == 1 and ref $_[0] and ref $_[0] eq 'HASH') + { + %args = %{$_[0]}; + } + elsif ( @_ > 1 and @_ < 4 ) + { + $args{table} = shift; + $args{action} = shift; + $args{additional} = shift; + } + else + { + %args = @_; + } + + do { die "no $_" unless $args{$_} } for qw( table action ); + + my $additional = $args{additional} || $args{id}; + + my @add = (); + + if ($additional) + { + # if $additional is a href, make_uri() will transform it into a query + @add = (ref $additional eq 'ARRAY') ? @$additional : ($additional); + } + + my $uri = $r->make_uri($args{table}, $args{action}, @add); + + return $uri->as_string; +} + +=head3 make_uri( @segments ) + +Make a L object given table, action etc. Automatically adds +the C. + +If the final element in C<@segments> is a hash ref, C will render it +as a query string. + +=cut + +sub make_uri +{ + my ($r, @segments) = @_; + + my $query = (ref $segments[-1] eq 'HASH') ? pop(@segments) : undef; + + my $base = $r->config->uri_base; + $base =~ s|/$||; + + my $uri = URI->new($base); + $uri->path_segments($uri->path_segments, grep {length} @segments); + + my $abs_uri = $uri->abs('/'); + $abs_uri->query_form($query) if $query; + return $abs_uri; +} + + # like CGI::param(), but read only sub param { @@ -685,6 +775,8 @@ The named parameters are protocol, domain, path, status and url Only 1 named parameter is required but other than url, they can be combined as required and current values (from the request) will be used in place of any missing arguments. The url argument must be a full url including protocol and can only be combined with status. +=head3 redirect_internal_request + =head3 handler This method sets up the class if it's not done yet, sets some diff --git a/t/maypole.t b/t/maypole.t index 8686254..1941839 100755 --- a/t/maypole.t +++ b/t/maypole.t @@ -28,7 +28,8 @@ my @API = qw/ config init_done view_object params query objects model_class content_type table headers_in headers_out is_model_applicable setup init handler handler_guts call_authenticate call_exception additional_data - authenticate exception parse_path get_template_root get_request + authenticate exception parse_path make_path + make_uri get_template_root get_request parse_location send_output /; @@ -371,6 +372,9 @@ my $mock_table = new Test::MockModule($table_class, no_auto => 1); is($r->action, 'index', '... action defaults to index'); } +# make_uri() and make_path() - see pathtools.t + + # get_template_root() { is(Maypole->get_template_root(), '.', '... returns "."'); diff --git a/t/pathtools.t b/t/pathtools.t new file mode 100644 index 0000000..c8e78d0 --- /dev/null +++ b/t/pathtools.t @@ -0,0 +1,191 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 304; +use Test::MockModule; + +# module compilation +use Maypole; + +# simple test class that inherits from Maypole +{ + package MyDriver; + @MyDriver::ISA = 'Maypole'; + @MyDriver::VERSION = 1; +} + +# back to package main; +my $driver_class = 'MyDriver'; + +my $r = $driver_class->new; + +# make_uri +{ + my @bases = ( '/', '/foo', '/foo/', '', 'http://www.example.com', + 'http://www.example.com/', 'http://www.example.com/foo', + 'http://www.example.com/foo/', ); + + my $query = { string => 'baz', + number => 4, + list => [ qw/ fee fi fo / ], + }; + + my $query_string = '?number=4&string=baz&list=fee&list=fi&list=fo'; + + # expect # send + my @uris = ( + { expect =>'', + send => [ '' ], + }, + { expect => '', + send => [ () ], + }, + { expect => '/table', + send => [ qw( table ) ], + }, + { expect => '/table/action', + send => [ qw( table action ) ], + }, + { expect => '/table/action/id', + send => [ qw( table action id ) ], + }, + + + { expect =>'', + send => [ '', $query ], + }, + { expect => '', + send => [ $query ], + }, + { expect => '/table', + send => [ qw( table ), $query ], + }, + { expect => '/table/action', + send => [ qw( table action ), $query ], + }, + { expect => '/table/action/id', + send => [ qw( table action id ), $query ], + }, + + ); + + foreach my $base (@bases) + { + $driver_class->config->uri_base($base); + + (my $base_no_slash = $base) =~ s|/$||; + my $base_or_slash = $base_no_slash || '/'; + + my $i = 1; + + foreach my $test (@uris) + { + #diag "BASE: $base - URI #$i"; $i++; + + my @s = @{ $test->{send} }; + my $expect = $test->{expect}; + + my $uri = $r->make_uri(@s); + + like("$uri", qr/^\Q$base_or_slash\E/, + "'$uri' starts with '$base_or_slash'"); + + my $q = ref $s[-1] ? $query_string : ''; + + my $msg = + sprintf "'%s' is '%s%s%s': base - '%s' segments - '%s'", + $uri, $base_no_slash, $expect, $q, $base, + @s ? join(', ', @s) : '()'; + + my $reconstructed = $expect =~ m|^/| ? "$base_no_slash$expect$q" : + "$base_or_slash$expect$q"; + + cmp_ok("$uri", 'eq', "$reconstructed" || '/', $msg); + } + } +} + +# make_path +{ + my @bases = ( '/', '/foo', '/foo/', '', 'http://www.example.com', + 'http://www.example.com/', 'http://www.example.com/foo', + 'http://www.example.com/foo/', ); + + my $query = { string => 'baz', + number => 4, + list => [ qw/ fee fi fo / ], + }; + + my $query_string = '?number=4&string=baz&list=fee&list=fi&list=fo'; + + # expect # send + my @uris = ( + { expect => '/table/action', + send => [ qw( table action ) ], + }, + { expect => '/table/action/id', + send => [ qw( table action id ) ], + }, + + + { expect => '/table/action', + send => [ qw( table action ), $query ], + }, + ); + + foreach my $base (@bases) + { + $driver_class->config->uri_base($base); + + (my $base_no_slash = $base) =~ s|/$||; + my $base_or_slash = $base_no_slash || '/'; + + my $i = 1; + + foreach my $test (@uris) + { + #diag "BASE: $base - URI #$i"; $i++; + + my @args = @{ $test->{send} }; + + my %args = ( table => $args[0], + action => $args[1], + additional => $args[2], + ); + + my %arg_sets = ( array => \@args, + hash => \%args, + hashref => \%args, + ); + + my $expect = $test->{expect}; + my @s = @{ $test->{send} }; + + foreach my $set (keys %arg_sets) + { + + my $path; + $path = $r->make_path(@{ $arg_sets{$set} }) if $set eq 'array'; + $path = $r->make_path(%{ $arg_sets{$set} }) if $set eq 'hash'; + $path = $r->make_path($arg_sets{$set}) if $set eq 'hashref'; + + like($path, qr/^\Q$base_or_slash\E/, + "'$path' starts with '$base_or_slash'"); + + my $q = ref $s[-1] ? $query_string : ''; + + my $msg = + sprintf "'%s' is '%s%s%s': base - '%s' segments - '%s'", + $path, $base_no_slash, $expect, $q, $base, + @s ? join(', ', @s) : '()'; + + my $reconstructed = $expect =~ m|^/| + ? "$base_no_slash$expect$q" : + "$base_or_slash$expect$q"; + + cmp_ok($path, 'eq', "$reconstructed" || '/', $msg); + } + } + } +} + -- 2.39.2