Maypole::CLI and the beginnings of a test suite.

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

diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm
index 0f917752bf419cc0942a1cf91f65f7a27100ad56..e284b1e54e8df4b03f8aee8878c64fa24959ea5d 100644 (file)
--- a/lib/Apache/MVC.pm
+++ b/lib/Apache/MVC.pm
@@ -16,12 +16,7 @@ sub parse_location {
     my $loc = $self->{ar}->location;
     no warnings 'uninitialized';
     $self->{path} =~ s/^($loc)?\///;
-    $self->{path} ||= "frontpage";
-    my @pi = split /\//, $self->{path};
-    shift @pi while @pi and !$pi[0];
-    $self->{table} = shift @pi;
-    $self->{action} = shift @pi;
-    $self->{args} = \@pi;
+    $self->parse_path;
 
     $self->{params} = { $self->{ar}->content };
     $self->{query}  = { $self->{ar}->args };

diff --git a/lib/Maypole/CLI.pm b/lib/Maypole/CLI.pm
new file mode 100644 (file)
index 0000000..b40dc0f
--- /dev/null
+++ b/lib/Maypole/CLI.pm
@@ -0,0 +1,98 @@
+package Maypole::CLI;
+use UNIVERSAL::require;
+use URI; use URI::QueryParam;
+
+use strict;
+use warnings;
+my $package;
+our $buffer;
+sub import { 
+    $package = $_[1];
+    $package->require;
+    die "Couldn't require $package - $@" if $@;
+    no strict 'refs';
+    unshift @{$package."::ISA"}, "Maypole::CLI";
+}
+
+sub get_request {}
+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;
+    $self->{path} = $url->path;
+    $self->{path} =~ s/^$root//i if $root;
+    $self->parse_path;
+    $self->{query} = $url->query_form_hash;
+}
+
+sub send_output { $buffer = shift->{output} }
+
+# Do it!
+CHECK { if ((caller(0))[1] eq "-e") { 
+            $package->handler() and print $buffer; 
+       } }
+
+1;
+
+=head1 NAME
+
+Maypole::CLI - Command line interface to Maypole for testing and debugging
+
+=head1 SYNOPSIS
+
+  % setenv MAYPOLE_TEMPLATES /var/www/beerdb/
+  % perl -MMaypole::CLI=BeerDB -e1 http://localhost/beerdb/brewery/frontpage
+
+=head1 DESCRIPTION
+
+This module is used to test Maypole sites without going through a web
+server or modifying them to use a CGI frontend. To use it, you should
+first either be in the template root for your Maypole site or set the
+environment variable C<MAYPOLE_TEMPLATES> to the right value.
+
+Next, you import the C<Maypole::CLI> module specifying your base Maypole
+subclass. The usual way to do this is with the C<-M> flag: 
+C<perl -MMaypole::CLI=MyApp>. This is equivalent to:
+
+    use Maypole::CLI qw(MyApp);
+
+Now Maypole will automatically call your application's handler with the
+URL specified as the first command line parameter. This should be the
+full URL, starting from whatever you have defined as the C<uri_base> in
+your application's configuration, and may include query parameters.
+
+The Maypole HTML output should then end up on standard output.
+
+=head1 Support for testing
+
+The module can also be used as part of a test script. 
+
+When used programmatically, rather than from the command line, its
+behaviour is slightly different. 
+
+Although the URL is taken from C<@ARGV> as normal, your application's
+C<handler> method is not called automatically, as it is when used on the
+command line; you need to call it manually. Additionally, when
+C<handler> is called, the output is not printed to standard output but
+stored in C<$Maypole::CLI::buffer>, to allow you to check the contents
+more easily.
+
+For instance, a test script could look like this:
+
+    use Test::More tests => 5;
+    use Maypole::CLI qw(BeerDB);
+    $ENV{MAYPOLE_TEMPLATES} = "t/templates";
+
+    # Hack because isa_ok only supports object isa not class isa
+    isa_ok( (bless {},"BeerDB") , "Maypole");
+
+    @ARGV = ("http://localhost/beerdb/");
+    is(BeerDB->handler, 200, "OK");
+    like($Maypole::CLI::buffer, qr/frontpage/, "Got the front page");
+
+    @ARGV = ("http://localhost/beerdb/beer/list");
+    is(BeerDB->handler, 200, "OK");
+    like($Maypole::CLI::buffer, qr/Organic Best/, "Found a beer in the list");
+

diff --git a/t/1.t b/t/1.t
index fe7939c61ea11109f4702b8823a3420c4837dae5..77c1f9fdef874ff5a28d60a76fc46e2acdebd91b 100644 (file)
--- a/t/1.t
+++ b/t/1.t
@@ -1,3 +1,14 @@
 # vim:ft=perl
-use Test::More 'no_plan';
-use_ok('Apache::MVC');
+use Test::More tests => 5;
+use Maypole::CLI qw(BeerDB);
+$ENV{MAYPOLE_TEMPLATES} = "t/templates";
+
+isa_ok( (bless {},"BeerDB") , "Maypole");
+
+@ARGV = ("http://localhost/beerdb/");
+is(BeerDB->handler, 200, "OK");
+like($Maypole::CLI::buffer, qr/frontpage/, "Got the front page");
+
+@ARGV = ("http://localhost/beerdb/beer/list");
+is(BeerDB->handler, 200, "OK");
+like($Maypole::CLI::buffer, qr/Organic Best/, "Found a beer in the list");

diff --git a/t/templates/custom/frontpage b/t/templates/custom/frontpage
new file mode 100644 (file)
index 0000000..e758fa5
--- /dev/null
+++ b/t/templates/custom/frontpage
@@ -0,0 +1 @@
+This is the frontpage

diff --git a/t/templates/custom/list b/t/templates/custom/list
new file mode 100644 (file)
index 0000000..c5f9229
--- /dev/null
+++ b/t/templates/custom/list
@@ -0,0 +1,5 @@
+# Begin object list
+[% FOR obj = objects %]
+- [% obj.name %]
+[% END %]
+# End object list