CGI::Prototype::Mecha - test CGI::Prototype applications with WWW::Mechanize

  use CGI::Prototype::Mecha;
  my $m = CGI::Prototype::Mecha->new(protoapp => 'My::App');

  $m->get('http://mecha/');
  ok $m->success, "fetched welcome page" or $m->diag_response;
  like $m->content, qr/Select a task/, "welcome page content verified";

package CGI::Prototype::Mecha;
use base qw(WWW::Mechanize);

our $VERSION = "0.21";

use strict;

BEGIN { require Test::More; *diag = \&Test::More::diag }

require CGI;

my $OUTPUT;			# has to be visible to "new" and "simple_request"

sub new {			# extend SUPER::new
  my $class = shift;
  my %options = @_;

  my $protoapp = delete $options{protoapp}
    or die "missing protoapp class name";
  my $self = $class->SUPER::new(%options);
  eval "require $protoapp";	# bring in the code
  die $@ if $@;			# throw up if needed
  $self->{protoapp} = $protoapp->reflect; # mirror
  $self->{protoapp}->addSlots
    (display => sub {
       my $self = shift;
       my $output = shift;
       $OUTPUT .= $output;
     },
    );
  return $self;
}

sub simple_request {
  my $self = shift;
  my $request = shift;
  if (@_ and defined($_[0])) {			# oops can't handle this...
    require Data::Dumper;
    die "extra parameters:", Data::Dumper::Dumper(\@_);
  }

  my $mirror = $self->{protoapp};
  my $uri = URI->new($request->uri);
  unless ($uri->scheme eq "http" and $uri->host eq "mecha") {
    ## eventually, return $self->SUPER::simple_request($request)
    ## warn "returning 404 for $uri";
    return HTTP::Response->new(404, 'not found', [], "$uri");
  }
  ## warn "setting up request:\n", $request->as_string;

  ## now set up the fake "CGI" environment so CGI.pm does the right thing
  local %ENV = %ENV;		# will clear out when we exit this scope

  $ENV{REQUEST_METHOD} = $request->method;
  $ENV{QUERY_STRING} = $uri->query;
  $ENV{SCRIPT_NAME} = "";
  $ENV{PATH_INFO} = "/" . $uri->rel("http://mecha/")->path; # not quite right
  $ENV{SERVER_NAME} = $uri->host;
  $ENV{SERVER_ADDR} = $uri->host;
  $ENV{SERVER_PORT} = $uri->port;

  $request->headers->scan
    (sub {
       my ($header, $value) = @_;
       if (lc $header eq "content-length") {
	 $ENV{CONTENT_LENGTH} = $value;
       } elsif (lc $header eq "content-type") {
	 $ENV{CONTENT_TYPE} = $value;
       } else {
	 (my $env = uc "HTTP_$header") =~ tr/-/_/;
	 ## warn "setting \$ENV{$env} to $value\n";
	 $ENV{$env} = $value;
       }
     }
    );


  $OUTPUT = "";

  {
    require File::Temp;
    my $fh = File::Temp::tempfile();
    print {$fh} $request->content;
    seek $fh, 0, 0;
    local *STDIN = $fh;		# provide alternate STDIN for content

    CGI::_reset_globals();	# because it needs it

    eval { $mirror->object->activate };
  }
  if ($@) {
    ## warn "returning 500 for $@";
    return HTTP::Response->new(500, 'internal error', [], "$@");
  }
  my $msg = HTTP::Message->parse($OUTPUT);
  my ($status, $message) = $msg->header('status') ?
    split ' ', $msg->header('status'), 2 : (200, 'ok');
  ## warn "## status is $status message is $message";
  my $response = HTTP::Response->new($status, $message,
				     $msg->headers, $msg->content);
  $response->request($request);
  ## warn "returning response:\n", $response->as_string;
  $response;
}

sub diag_response {
  diag(join '', shift->res->as_string);
}

sub diag_links {
  for (shift->links) {
    diag(join "", $_->text, " to ", $_->url);
  }
}

sub diag_forms {
  for (shift->forms) {
    diag(join "", $_->dump);
  }
}

1;

__END__