+ some TT2 options need to be set on the Template::Provider

+ M::CLI - accommodate different combinations of trailing slash on the uri_base & request url, add tests to t/01basics.t
+ Improve error messages from BeerDB if SQLite datasource doesn't exist
+ header_field_names() requires HTTP::Headers >= 1.59

git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@318 48953598-375a-da11-a14b-00016c27c3ee

diff --git a/Makefile.PL b/Makefile.PL
index ad8fcdbcaac3289447e642be2edd7250c66c35da..d5e76ab93d7c2f622fecda6e92f0e929ce641570 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -21,7 +21,7 @@ WriteMakefile(
         UNIVERSAL::require               => 0,
         URI::QueryParam                  => 0,
         CGI::Simple                      => 0,
-        HTTP::Headers                    => 0,
+        HTTP::Headers                    => 1.59,
         Template                         => 0,
         Template::Plugin::Class          => 0,
         Test::MockModule                 => 0,
@@ -46,17 +46,14 @@ sub has_module {
 
 if ( !-e "t/beerdb.db" ) {
     print "Making SQLite DB\n";
-    eval { require DBD::SQLite };
-    my $dbh;
-    if ($@) {
-        eval { require DBD::SQLite2 };
-        die "No, wait, we don't have SQLite installed. Never mind\n" if $@;
-        require DBI;
-        $dbh = DBI->connect("dbi:SQLite2:dbname=t/beerdb.db");
-    } else {
-        require DBI;
-        $dbh = DBI->connect("dbi:SQLite:dbname=t/beerdb.db");
-    }
+    my $driver = 'SQLite';
+    eval { require DBD::SQLite } or do {
+        print "Error loading DBD::SQLite, trying DBD::SQLite2\n";
+        eval {require DBD::SQLite2} ? $driver = 'SQLite2'
+            : die "DBD::SQLite2 is not installed";
+    };
+    require DBI;
+    my $dbh = DBI->connect("dbi:$driver:dbname=t/beerdb.db");
     my $sql = join( '', (<DATA>) );
 
     for my $statement ( split /;/, $sql ) {

diff --git a/ex/BeerDB.pm b/ex/BeerDB.pm
index 6df04914611ad19d1f176209c53c49917015cac4..e276830c4e10d18620783e10cecb6b937a9cc634 100644 (file)
--- a/ex/BeerDB.pm
+++ b/ex/BeerDB.pm
@@ -3,16 +3,23 @@ use Maypole::Application;
 use Class::DBI::Loader::Relationship;
 
 sub debug { $ENV{BEERDB_DEBUG} }
+# This is the sample application.  Change this to the path to your
+# database. (or use mysql or something)
+use constant DBI_DRIVER => 'SQLite';
+use constant DATASOURCE => 't/beerdb.db';
 
 BEGIN {
-# This is the sample application. Change this to the path to your
-# database. (or use mysql or something)
-eval { require DBD::SQLite };
-if ($@) {
-   BeerDB->setup("dbi:SQLite2:t/beerdb.db");
-} else {
-    BeerDB->setup("dbi:SQLite:t/beerdb.db");
-}
+    my $dbi_driver = DBI_DRIVER;
+    if ($dbi_driver =~ /^SQLite/) {
+        die sprintf "SQLite datasource '%s' not found, correct the path or "
+            . "recreate the database by running Makefile.PL", DATASOURCE
+            unless -e DATASOURCE;
+        eval "require DBD::SQLite";
+        if ($@) {
+            eval "require DBD::SQLite2" && dbi_driver = 'SQLite2';
+        }
+    }
+    BeerDB->setup(join ':', "dbi", $dbi_driver, DATASOURCE);
 }
 
 # Give it a name.
@@ -20,12 +27,12 @@ BeerDB->config->application_name('The Beer Database');
 
 # Change this to the root of the web space.
 BeerDB->config->uri_base("http://localhost/beerdb/");
-#BeerDB->config->{uri_base} = "http://neo.trinity-house.org.uk/beerdb/";
+#BeerDB->config->uri_base("http://neo.trinity-house.org.uk/beerdb/");
 
 BeerDB->config->rows_per_page(10);
 
 # Handpumps should not show up.
-BeerDB->config->{display_tables} = [qw[beer brewery pub style]];
+BeerDB->config->display_tables([qw[beer brewery pub style]]);
 BeerDB::Brewery->untaint_columns( printable => [qw/name notes url/] );
 BeerDB::Style->untaint_columns( printable => [qw/name notes/] );
 BeerDB::Beer->untaint_columns(

diff --git a/lib/CGI/Maypole.pm b/lib/CGI/Maypole.pm
index 793d47fb1d5c3ea1032841719281e05afc35fb4e..99cf27f92b2a1b295fe9872057db093523430bb2 100644 (file)
--- a/lib/CGI/Maypole.pm
+++ b/lib/CGI/Maypole.pm
@@ -58,7 +58,7 @@ sub send_output {
         -charset         => $r->{document_encoding},
         -content_length  => do { use bytes; length $r->{output} },
     );
-    foreach ($r->headers_out->header_field_names) {
+    foreach ($r->headers_out->field_names) {
         next if /^Content-(Type|Length)/;
         $headers{"-$_"} = $r->headers_out->get($_);
     }

diff --git a/lib/Maypole/CLI.pm b/lib/Maypole/CLI.pm
index 81a2fd5083b2e2d4d10908895ae1ad7fa8af04fa..3839521e2d8112e03bb8eb9971551a28f691843c 100644 (file)
--- a/lib/Maypole/CLI.pm
+++ b/lib/Maypole/CLI.pm
@@ -29,9 +29,10 @@ sub get_template_root { $ENV{MAYPOLE_TEMPLATES} || "." }
 sub parse_location {
     my $self = shift;
     my $url  = URI->new( shift @ARGV );
-    my $root = URI->new( $self->config->uri_base )->path;
+    (my $uri_base = $self->config->uri_base) =~ s:/$::;
+    my $root = URI->new( $uri_base )->path;
     $self->{path} = $url->path;
-    $self->{path} =~ s/^$root//i if $root;
+    $self->{path} =~ s:^$root/?::i if $root;
     $self->parse_path;
     $self->parse_args($url);
 }

diff --git a/lib/Maypole/View/TT.pm b/lib/Maypole/View/TT.pm
index 042a1b5824da5e0cd16921c6da0920fa9386d78b..40fa5651dcc9480db76f856e5f1a0a40e8aeb44b 100644 (file)
--- a/lib/Maypole/View/TT.pm
+++ b/lib/Maypole/View/TT.pm
@@ -10,13 +10,20 @@ our $VERSION = "1." . sprintf "%04d", q$Rev$ =~ /: (\d+)/;
 sub template {
     my ( $self, $r ) = @_;
 
-    my $view_options = $r->config->view_options || {};
-    $self->{provider} ||= Template::Provider->new();
-    $self->{tt}       ||= Template->new({
-        COMPILE_DIR    => catdir(tmpdir(), $r->config->application_name),
-        %$view_options,
-        LOAD_TEMPLATES => [ $self->{provider} ],
-    });
+    unless ($self->{tt}) {
+        my $view_options = $r->config->view_options || {};
+        (my $driver_name = ref $r) =~ s/::/_/g;
+        my $compile_dir  = catdir(tmpdir(), $driver_name);
+        $self->{provider} = Template::Provider->new(
+            COMPILE_DIR    => $compile_dir,
+            %$view_options,
+        );
+        $self->{tt}       = Template->new({
+            COMPILE_DIR    => $compile_dir,
+            %$view_options,
+            LOAD_TEMPLATES => [ $self->{provider} ],
+        });
+    }
 
     $self->{provider}->include_path([ $self->paths($r) ]);
 

diff --git a/t/01basics.t b/t/01basics.t
index 9c3d4b9531cbcf6d05a972e85d4fe00af2d7c206..2b1518dead6a4b6a2d34c9c766d65d83b14bd5d4 100644 (file)
--- a/t/01basics.t
+++ b/t/01basics.t
@@ -1,17 +1,35 @@
 # vim:ft=perl
 use Test::More;
 use lib 'ex'; # Where BeerDB should live
-BEGIN { if (eval { require BeerDB }) { 
-            plan tests => 12;
-        } else { Test::More->import(skip_all =>"SQLite not working or BeerDB module could not be loaded: $@") }
-      }
+BEGIN {
+    eval { require BeerDB };
+    Test::More->import( skip_all =>
+        "SQLite not working or BeerDB module could not be loaded: $@"
+    ) if $@;
+
+    plan tests => 15;
+}
 use Maypole::CLI qw(BeerDB);
 use Maypole::Constants;
 $ENV{MAYPOLE_TEMPLATES} = "t/templates";
 
 isa_ok( (bless {},"BeerDB") , "Maypole");
 
-like(BeerDB->call_url("http://localhost/beerdb/"), qr/frontpage/, "Got the front page");
+BeerDB->config->view_options({COMPILE_DIR => '/home/simon/dev/maypole/compiled'});
+
+# Test the effect of trailing slash on config->uri_base and request URI
+(my $uri_base = BeerDB->config->uri_base) =~ s:/$::;
+BeerDB->config->uri_base($uri_base);
+like(BeerDB->call_url("http://localhost/beerdb/"), qr/frontpage/,
+     "Got frontpage, trailing '/' on request but not uri_base");
+like(BeerDB->call_url("http://localhost/beerdb"), qr/frontpage/,
+     "Got frontpage, no trailing '/' on request or uri_base");
+BeerDB->config->uri_base($uri_base . '/');
+like(BeerDB->call_url("http://localhost/beerdb/"), qr/frontpage/,
+     "Got frontpage, trailing '/' on uri_base and request");
+like(BeerDB->call_url("http://localhost/beerdb"), qr/frontpage/,
+     "Got frontpage, trailing '/' on uri_base but not request");
+
 like(BeerDB->call_url("http://localhost/beerdb/beer/list"), qr/Organic Best/, "Found a beer in the list");
 my (%classdata)=split /\n/, BeerDB->call_url("http://localhost/beerdb/beer/classdata");
 is ($classdata{plural},'beers','classdata.plural');