From 8617321ebf13ce6b63d41a65a003d153f2b5cc5e Mon Sep 17 00:00:00 2001 From: Simon Cozens Date: Tue, 21 Dec 2004 17:48:54 +0000 Subject: [PATCH] + 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 --- Makefile.PL | 21 +++++++++------------ ex/BeerDB.pm | 27 +++++++++++++++++---------- lib/CGI/Maypole.pm | 2 +- lib/Maypole/CLI.pm | 5 +++-- lib/Maypole/View/TT.pm | 21 ++++++++++++++------- t/01basics.t | 28 +++++++++++++++++++++++----- 6 files changed, 67 insertions(+), 37 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index ad8fcdb..d5e76ab 100644 --- 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( '', () ); for my $statement ( split /;/, $sql ) { diff --git a/ex/BeerDB.pm b/ex/BeerDB.pm index 6df0491..e276830 100644 --- 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 793d47f..99cf27f 100644 --- 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 81a2fd5..3839521 100644 --- 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 042a1b5..40fa565 100644 --- 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 9c3d4b9..2b1518d 100644 --- 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'); -- 2.39.5