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

diff --git a/Changes b/Changes
index b8304b01a3a731c3d4cc3caabf8cf1c7f9fb3766..940512dd96b39cefde76def8f15ea52b1d163391 100644 (file)
--- 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 03fec8eab825a6401abf400d9165a7f74d1d9505..d5515b9fd6253edc1a6f2e2ef9e84d8e3330e105 100644 (file)
--- 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 ba1ea3f3c82095687249d94a14d13f1792ab2d72..2cae8709c2ed2a574b5381a122d21804e9539489 100644 (file)
--- 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 494174273f36e0421ca612487cbdb44434930e32..0d0250dfcbde82a88953658dab393326a57504dc 100644 (file)
--- 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 b148429e3944f2e04634fe634071548ca46fda90..08f4b6017d2a9bdbeb905b8808bb54f5d1c2b56f 100644 (file)
--- 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');
+
+      }
+    }
+  }
+};