Test::WWW::Mechanize::Maypole - Test::WWW::Mechanize for Maypole

    use Test::WWW::Mechanize::Maypole 'BeerDB';

    # or load a test database instead of the one configured in BeerDB.pm:
    #
    # use Test::WWW::Mechanize::Maypole 'BeerDB', 'dbi:SQLite:test-beerdb.db';
    # use Test::WWW::Mechanize::Maypole 'BeerDB', 'dbi:mysql:beer_d_b', 'dhoworth', 'password';

    $ENV{MAYPOLE_TEMPLATES} = 'path/to/templates';

    my $mech = Test::WWW::Mechanize::Maypole->new;

    #
    # basic tests:
    #
    $mech->get_ok( "http://localhost/beerdb/" );

    is( $mech->ct, "text/html" );

    $mech->content_contains( 'This is the frontpage' );

    #
    # logging in and storing cookies:
    #
    $mech->get_ok("http://localhost/beerdb/customer/buybeer");
    $mech->content_contains( 'Login to BeerDB', 'got login page' );

    # specify which form we're interested in
    $mech->form_number(1); # the 1st form    

    # fill in credentials
    $mech->field( 'username' => 'landlord' );
    $mech->field( 'password' => 'handpump' );

    # get a HTTP::Response back
    my $response = $mech->click_button( name => 'submit' );
    like( $response->content, qr/Shop for beer/, 'got customer/buybeer page'  );

    # check our cookies give access to other pages
    $mech->get_ok( "http://localhost/beerdb/customer/edit" );
    $mech->content_contains( 'Update your details', "got customer account edit page");

        


    # ... see Test::WWW::Mechanize for many more test methods

  $mech->get_ok( $page );
  $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
  $mech->content_contains( "David Baird", "My name somewhere" );
  $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );

  use Test::WWW::Mechanize::Maypole 'BeerDB';
  my $mech = Test::WWW::Mechanize::Maypole->new;

    sub new_mech 
    { 
        my ( $url ) = @_;
        my $mech = Test::WWW::Mechanize::Maypole->new; 
        $mech->get_ok( $url, "got something for $url" ) if $url;
        return $mech;
    }

    sub new_logged_in_mech
    {
        my ( $protected_url ) = @_;

        my $mech = new_mech;

        # request something that will get redirected to the login page
        $mech->get("http://localhost/index.html"); 

        # specify which form we're interested in
        $mech->form_number(1); 

        my $user = 'testuser';
        my $pass = 'testpass';

        # fill in credentials
        $mech->field( username => $user );
        $mech->field( password => $pass );

        $mech->click;

        $mech->get_ok( $protected_url, "got something for $url" ) if $protected_url;

        return $mech;
    }

package Test::WWW::Mechanize::Maypole;
use strict;
use warnings;

use HTTP::Status();
use HTTP::Headers::Util;
use URI;
use UNIVERSAL::require;
use NEXT;

use Test::WWW::Mechanize;
use Class::Data::Inheritable;

use base qw/ Test::WWW::Mechanize Class::Data::Inheritable /;

__PACKAGE__->mk_classdata( '_the_app' );

our $VERSION = '0.23';

sub import 
{
    my ( $class, $app, @db_args ) = @_;
    
    if ( @db_args )
    {
        my $args = join ':', @db_args;
        
        eval "package $app;
                sub setup { shift->NEXT::DISTINCT::setup( '$args' ) }";    # qw(@db_args) fails
        die $@ if $@;
    }    
    
    $class->_the_app( $app );
    
    $app->require or die "Couldn't load Maypole app '$app': $@";
    
    my @exports = qw/ send_output parse_location get_template_root parse_args /;
    
    no strict 'refs';
    *{"$app\::$_"} = \&$_ for @exports;
}

    
sub _make_request 
{
    my ( $self, $request ) = @_;
    
    $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;

    # make an HTTP::Response object, to be populated during the handler() call
    my $response = HTTP::Response->new;
    $response->date( time );
    
    # parse_location() normally takes the url from @ARGV, here we provide $request.
    # $response is taken by send_output
    local @ARGV = ( $request, $response );
    
    # handler() calls send_output with no args, so we provide $response via @ARGV
    my $status = $self->_the_app->handler;
    
    # Translate Maypole codes to HTTP::Status codes. Maypole only has 2 codes, OK (0) 
    # and everything else (-1). We'll assume -1 is an error. Note that other codes can 
    # be returned by custom application code - we assume anything else is a proper 
    # HTTP status
    if ( defined $status )
    {
        $status = 200 if $status == 0;
        $status = 500 if $status == -1;
    }
    else
    {
        warn "Undefined response code";
        $status = 500;
    }    

    # $response has now been populated during the handler() call
    $response->code( $status );
    $response->message( HTTP::Status::status_message( $status ) );
    
    $response->header( 'Content-Base', $request->uri );
    $response->request( $request );
    
    $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;
    
    return $response;
}

# Called by Maypole::handler(), with no arguments, so $response is placed in @ARGV for 
# retrieval here. This method, and _make_request, are the only places that use the 
# $response object.

# Grabs Maypole::Headers and populates the HTTP::Response object.
sub send_output 
{
    my ( $maypole ) = @_;
    
    my $response = shift @ARGV;
    
    $response->content_type(
        $maypole->{content_type} =~ m/^text/
            ? $maypole->{content_type} . "; charset=" . $maypole->{document_encoding}
            : $maypole->{content_type}
    );
    
    $response->content_length( do { use bytes; length $maypole->{output} } );

    # if there are cookies, this is where they get passed on
    foreach ($maypole->headers_out->field_names) 
    {
        next if /^Content-(Type|Length)/;
        $response->header( $_ => $maypole->headers_out->get($_) );
    }
    
    $response->content( $maypole->{output} );
}

# Called by Maypole::handler() with no arguments. 
sub parse_location
{
    my ( $self ) = @_;
    
    my $request = shift @ARGV;
    
    # This is a HTTP::Headers object.
    my $headers_in = $request->headers;
    
    # Maypole::Headers is a simple subclass of HTTP::Headers
    bless $headers_in, 'Maypole::Headers';
    
    $self->headers_in( $headers_in );
    
    my $uri = $request->uri;
    
    ( my $uri_base = $self->config->uri_base ) =~ s:/$::;
    
    my $root = URI->new( $uri_base )->path;
    
    $self->{path} = $uri->path; 
    $self->{path} =~ s:^$root/?::i;
    
    $self->parse_path;
    $self->parse_args( $request );
}
    
sub parse_args 
{
    my ( $self, $request ) = @_;
    
    # this code stolen from Catalyst::Engine::HTTP::Base::prepare_parameters(), 
    # with **file uploads removed**
    
    my @params;
    
    push( @params, $request->uri->query_form );
    
    if ( $request->content_type eq 'application/x-www-form-urlencoded' ) 
    {
        my $uri = URI->new('http:');
        $uri->query( $request->content );
        push( @params, $uri->query_form );
    }
    
    if ( $request->content_type eq 'multipart/form-data' ) 
    {
        for my $part ( $request->parts ) 
        {
            my $disposition = $part->header('Content-Disposition');
            my %parameters  = @{ ( HTTP::Headers::Util::split_header_words($disposition) )[0] };

            die 'File uploads not supported' if $parameters{filename};
            
            push( @params, $parameters{name}, $part->content );
        }
    }
    
    my %parameters;
    
    # this from Catalyst::Request::param()
    while ( my ( $field, $value ) = splice( @params, 0, 2 ) ) 
    {
        next unless defined $field;

        if ( exists $parameters{$field} ) 
        {
            for ( $parameters{$field} ) 
            {
                $_ = [$_] unless ref($_) eq 'ARRAY';
                push( @$_, $value );
            }
        }
        else 
        {
            $parameters{$field} = $value;
        }
    }
    
    # back to Maypole...    
    $self->params( \%parameters );
    $self->query(  \%parameters );
}

sub get_template_root { $ENV{MAYPOLE_TEMPLATES} || '.' }


1;

__END__