From fd4f46b563663298840413d9b0d6961720458c1b Mon Sep 17 00:00:00 2001 From: Aaron Trevena Date: Wed, 19 Jul 2006 14:18:10 +0000 Subject: [PATCH] fixes to url tests to handle ordering of arguments and to fix horrid code in tests git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@512 48953598-375a-da11-a14b-00016c27c3ee --- Changes | 1 + MANIFEST | 16 ++- META.yml | 2 +- lib/Maypole.pm | 2 +- t/pathtools.t | 309 ++++++++++++++++++++++--------------------------- 5 files changed, 159 insertions(+), 171 deletions(-) diff --git a/Changes b/Changes index b8304b0..940512d 100644 --- a/Changes +++ b/Changes @@ -96,6 +96,7 @@ Documentation: Added Maypole::Manual::Terminology - updated Maypole::Manual::View - updated Maypole::View:TT + Examples of fancy forms and templates using new features Requirements: HTTP::Body now required diff --git a/MANIFEST b/MANIFEST index 03fec8e..d5515b9 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3,6 +3,20 @@ ex/BeerDB.pm ex/BeerDB/Base.pm ex/BeerDB/Beer.pm ex/beerdb.sql +ex/fancy_example/BeerDB.pm +ex/fancy_example/beerdb.sql +ex/fancy_example/BeerDB/Base.pm +ex/fancy_example/BeerDB/Beer.pm +ex/fancy_example/BeerDB/Brewery.pm +ex/fancy_example/BeerDB/Drinker.pm +ex/fancy_example/templates/custom/addnew +ex/fancy_example/templates/custom/display_inputs +ex/fancy_example/templates/custom/display_search_inputs +ex/fancy_example/templates/custom/edit +ex/fancy_example/templates/custom/header +ex/fancy_example/templates/custom/maypole.css +ex/fancy_example/templates/custom/metadata +ex/fancy_example/templates/custom/search_form lib/Apache/MVC.pm lib/CGI/Maypole.pm lib/CGI/Untaint/Maypole.pm @@ -36,7 +50,7 @@ lib/Maypole/View/TT.pm Makefile.PL MANIFEST MANIFEST.SKIP -META.yml Module meta-data (added by MakeMaker) +META.yml README AUTHORS t/01basics.t diff --git a/META.yml b/META.yml index ba1ea3f..2cae870 100644 --- a/META.yml +++ b/META.yml @@ -1,7 +1,7 @@ # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Maypole -version: 2.11 +version: 2.11_pre4 version_from: lib/Maypole.pm installdirs: site requires: diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 4941742..0d0250d 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -12,7 +12,7 @@ use URI::QueryParam; use NEXT; use File::MMagic::XS qw(:compat); -our $VERSION = '2.11'; +our $VERSION = '2.11_pre4'; our $mmagic = File::MMagic::XS->new(); # proposed privacy conventions: diff --git a/t/pathtools.t b/t/pathtools.t index b148429..08f4b60 100644 --- a/t/pathtools.t +++ b/t/pathtools.t @@ -1,190 +1,163 @@ #!/usr/bin/perl use strict; use warnings; -use Test::More tests => 304; +use Test::More tests => 172; use Test::MockModule; -# module compilation +use CGI; +use URI; + use Maypole; # simple test class that inherits from Maypole { - package MyDriver; - @MyDriver::ISA = 'Maypole'; - @MyDriver::VERSION = 1; + package MyDriver; + @MyDriver::ISA = 'Maypole'; + @MyDriver::VERSION = 1; } # back to package main; my $driver_class = 'MyDriver'; - my $r = $driver_class->new; +my $query = { list => [ qw/ fee fi fo / ], string => 'baz', number => 4 }; + +my $query_string = '?number=4&string=baz&list=fee&list=fi&list=fo'; + +my @bases = ( 'http://www.example.com', + 'http://www.example.com/', 'http://www.example.com/foo', + 'http://www.example.com/foo/', ); + # 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'; - - 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); - } + 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); + + my $expected = $base_or_slash.$test->{expect}; + + my ($uri_basepath,$uri_query) = split(/\?/,$uri); + + warn "\nuri : '$uri'\nexpected : '$expected'\n"; + warn "uri_basepath : $uri_basepath, uri_query : $uri_query\n"; + + my $q_got = new CGI($uri_query); + + if ($uri_query) { + # check query params + # list => [ qw/ fee fi fo / ], string => 'baz', number => 4 + is($q_got->param('string'),'baz','string param correct'); + is($q_got->param('number'),4,'number param correct'); + is_deeply([$q_got->param('list')],[ qw/ fee fi fo / ],'list param correct'); + } + ok(URI::eq($expected,$uri_basepath),'host and path match'); + } -} + } +} ; + # 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); - } - } - } -} + # 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}; + + 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'; + + my ($uri_path,$uri_query) = split(/\?/,$path); + my $q_got = new CGI($uri_query); + + my $expected = $expect =~ m|^/| ? "$base_no_slash$expect" : "$base_or_slash$expect"; + if ($uri_query) { + # check query params + # list => [ qw/ fee fi fo / ], string => 'baz', number => 4 + is($q_got->param('string'),'baz','string param correct'); + is($q_got->param('number'),4,'number param correct'); + is_deeply([$q_got->param('list')],[ qw/ fee fi fo / ],'list param correct'); + } + ok(URI::eq($expected,$uri_path),'host and path match'); + + } + } + } +}; -- 2.39.2