Test-WWW-Mechanize-Catalyst-0.62/ 0000755 0003721 0000144 00000000000 13432566046 016312 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/t/ 0000755 0003721 0000144 00000000000 13432566046 016555 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/t/auth-test.t 0000644 0003721 0000144 00000000731 13432343365 020656 0 ustar matthewt users #!perl
use strict;
use warnings;
use lib 'lib';
use Test::More tests => 5;
use lib 't/lib';
use Test::WWW::Mechanize::Catalyst 'Catty';
my $root = "http://localhost";
my $m = Test::WWW::Mechanize::Catalyst->new;
$m->credentials( 'user', 'pass' );
$m->get_ok("$root/check_auth_basic/");
is( $m->ct, "text/html" );
is( $m->status, 200 );
$m->credentials( 'boofar', 'pass' );
$m->get("$root/check_auth_basic/");
is( $m->ct, "text/html" );
is( $m->status, 401 );
Test-WWW-Mechanize-Catalyst-0.62/t/decoded_content.t 0000644 0003721 0000144 00000000526 13432343365 022063 0 ustar matthewt users #!perl
use strict;
use warnings;
use lib 'lib';
use Test::More tests => 2;
use lib 't/lib';
use Test::WWW::Mechanize::Catalyst 'Catty';
my $root = "http://localhost";
my $m = Test::WWW::Mechanize::Catalyst->new;
$m->get_ok("$root/bad_content_encoding/");
# per https://rt.cpan.org/Ticket/Display.html?id=36442
$m->content_contains('foo');
Test-WWW-Mechanize-Catalyst-0.62/t/multi_content_type.t 0000644 0003721 0000144 00000003362 13432343365 022670 0 ustar matthewt users #!perl
use strict;
use warnings;
use lib qw(lib t/lib);
my $PORT;
BEGIN {
$PORT = $ENV{TWMC_TEST_PORT} || 7357;
}
use Test::More;
use Test::Exception;
BEGIN {
diag(
"\n###################################################################\n",
"Starting an external Catalyst HTTP server on port $PORT\n",
"To change the port, please set the TWMC_TEST_PORT env variable.\n",
"(The server will be automatically shut-down right after the tests).\n",
"###################################################################\n"
);
}
# Let's catch interrupts to force the END block execution.
$SIG{INT} = sub { warn "INT:$$"; exit };
use_ok 'ExternalCatty';
my $pid;
($pid, $PORT) = ExternalCatty->background($PORT);
$ENV{CATALYST_SERVER} ||= "http://localhost:$PORT";
use Test::WWW::Mechanize::Catalyst;
my $m = Test::WWW::Mechanize::Catalyst->new;
# Yeah, sorry - wait for the forked process to spin up...
sleep 10;
my $skip = 0;
TRY_CONNECT: {
eval { $m->get('/') };
if ($@ || $m->content =~ /Can't connect to \w+:$PORT/) {
$skip = $@ || $m->content;
diag $m;
}
}
SKIP: {
skip $skip, 9 if $skip;
lives_ok { $m->get_ok( '/', 'Get a multi Content-Type response' ) }
'Survive to a multi Content-Type sting';
is( $m->ct, 'text/html', 'Multi Content-Type Content-Type' );
$m->title_is( 'Root', 'Multi Content-Type title' );
$m->content_contains( "Hello, test \x{263A}!", 'Multi Content-Type body' );
# Test a redirect with a remote server now too.
$m->get_ok( '/hello' );
is($m->uri, "$ENV{CATALYST_SERVER}/");
$m->get_ok( '/host' );
$m->content_contains("Host: localhost:$PORT") or diag $m->content;
}
END {
if ( $pid && $pid != 0 ) {
kill 9, $pid;
}
}
done_testing;
1;
Test-WWW-Mechanize-Catalyst-0.62/t/useragent.t 0000644 0003721 0000144 00000000550 13432343365 020734 0 ustar matthewt users #!perl
use strict;
use warnings;
use lib 'lib';
use Encode qw();
use Test::More tests => 2;
use lib 't/lib';
use Test::WWW::Mechanize::Catalyst 'Catty';
my $root = "http://localhost";
my $agent = 'TestAgent/1.0';
my $m = Test::WWW::Mechanize::Catalyst->new(agent => $agent);
$m->get_ok("$root/user_agent");
$m->title_is($agent, "title is correct: $agent");
Test-WWW-Mechanize-Catalyst-0.62/t/simple.t 0000644 0003721 0000144 00000004052 13432343365 020231 0 ustar matthewt users #!perl
use strict;
use warnings;
use Encode qw();
use Test::More tests => 37;
use lib 't/lib';
BEGIN {
$ENV{CATALYST_DEBUG} = 0;
$ENV{CATTY_DEBUG} = 0;
}
use Test::WWW::Mechanize::Catalyst 'Catty';
my $root = "http://localhost";
my $m = Test::WWW::Mechanize::Catalyst->new( autocheck => 0 );
$m->get_ok("$root/");
is( $m->ct, "text/html" );
$m->title_is("Root");
$m->content_contains("This is the root page");
$m->follow_link_ok( { text => 'Hello' } );
is( $m->base, "http://localhost/hello/" );
is( $m->ct, "text/html" );
$m->title_is("Hello");
my $bytes = "Hi there! ☺";
my $chars = Encode::decode( 'utf-8', $bytes );
$m->content_contains( $chars, qq{content contains "$bytes"});
#use Devel::Peek; Dump $m->content;
#Dump(Encode::decode('utf-8', "Hi there! ☺"));
#exit;
$m->get_ok("/");
is( $m->ct, "text/html" );
$m->title_is("Root");
$m->content_contains("This is the root page");
$m->get_ok("http://example.com/");
is( $m->ct, "text/html" );
$m->title_is("Root");
$m->content_contains("This is the root page");
$m->get_ok("/hello/");
is( $m->ct, "text/html" );
$m->title_is("Hello");
$m->content_contains( $chars, qq{content contains "$bytes"});
SKIP: {
eval { require Compress::Zlib; };
skip "Compress::Zlib needed to test gzip encoding", 4 if $@;
$m->get_ok("/gzipped/");
is( $m->ct, "text/html" );
$m->title_is("Hello");
$m->content_contains( $chars, qq{content contains "$bytes"});
}
$m->get("$root/die/");
is( $m->status, 500 );
$m->content_like( qr!\(en\) Please come back later!);
$m->content_unlike( qr!Hello.!);
$m->get("/die/");
is( $m->status, 500 );
$m->content_like( qr!\(en\) Please come back later!);
$m->content_unlike( qr!Hello.!);
{
no warnings 'redefine';
${Catty::}{debug} = sub { 1 };
$m->{catalyst_debug} = 1;
$m->get("$root/die/");
is( $m->status, 500 );
is( $m->ct, "text/html" );
$m->title_like(qr/Catty on Catalyst/);
$m->content_like(qr/Caught exception in Catty/);
$m->content_like(qr/erk/);
$m->content_like(qr/This is the die page/);
}
Test-WWW-Mechanize-Catalyst-0.62/t/redirect.t 0000644 0003721 0000144 00000005025 13432343365 020542 0 ustar matthewt users #!perl
use strict;
use warnings;
use lib 'lib';
use Test::More;
use lib 't/lib';
use Test::WWW::Mechanize::Catalyst 'Catty';
use HTTP::Request::Common;
use URI;
use Test::utf8;
my $root = "http://localhost";
my $m;
foreach my $where (qw{hi greetings bonjour}) {
$m = Test::WWW::Mechanize::Catalyst->new;
$m->get_ok( "$root/$where", "got something when we $where" );
is( $m->base, "http://localhost/hello", "check got to hello 1/4" );
is( $m->ct, "text/html", "check got to hello 2/4" );
$m->title_is( "Hello",, "check got to hello 3/4" );
$m->content_contains( "Hi there",, "check got to hello 4/4" );
# check that the previous response is still there
my $prev = $m->response->previous;
ok( $prev, "have a previous" );
is( $prev->code, 302, "was a redirect" );
like( $prev->header('Location'), '/hello$/', "to the right place" );
}
# extra checks for bonjour (which is a double redirect)
my $prev = $m->response->previous->previous;
ok( $prev, "have a previous previous" );
is( $prev->code, 302, "was a redirect" );
like( $prev->header('Location'), '/hi$/', "to the right place" );
$m->get("$root/redirect_with_500");
is ($m->status, 500, "Redirect not followed on 500");
my $req = GET "$root/redirect_to_utf8_upgraded_string";
my $loc = $m->_do_catalyst_request($req)->header('Location');
my $uri = URI->new_abs( $loc, $req->uri )->as_string;
is_sane_utf8($uri);
isnt_flagged_utf8($uri);
# Check for max_redirects support
{
$m = Test::WWW::Mechanize::Catalyst->new(max_redirect => 1);
is( $m->max_redirect, 1, 'max_redirect set' );
$m->get( "$root/bonjour" );
ok( !$m->success, "get /bonjour with max_redirect=1 is not a success" );
is( $m->response->redirects, 1, 'redirects only once' );
like( $m->response->header('Client-Warning'), qr/Redirect loop detected/i,
'sets Client-Warning header' );
}
# Make sure we can handle max_redirects=0
{
$m = Test::WWW::Mechanize::Catalyst->new(max_redirect => 0);
$m->get( "$root/hello" );
ok( $m->success, "get /hello with max_redirect=0 succeeds" );
is( $m->response->redirects, 0, 'no redirects' );
ok( !$m->response->header('Client-Warning'), 'no Client-Warning header' );
# shouldn't be redirected if max_redirect == 0
$m->get( "$root/bonjour" );
ok( !$m->success, "get /bonjour with max_redirect=0 is not a success" );
is( $m->response->redirects, 0, 'no redirects' );
like( $m->response->header('Client-Warning'), qr/Redirect loop detected/i,
'sets Client-Warning header' );
}
done_testing;
Test-WWW-Mechanize-Catalyst-0.62/t/two_app.t 0000644 0003721 0000144 00000001163 13432343365 020411 0 ustar matthewt users use strict;
use warnings;
use Test::More;
use lib 't/lib';
BEGIN {
eval {
require Catalyst::Plugin::Session;
require Catalyst::Plugin::Session::State::Cookie;
};
if ($@) {
diag($@);
plan skip_all => "Need Catalyst::Plugin::Session to run this test";
exit 0;
}
}
use Test::WWW::Mechanize::Catalyst;
plan tests => 4;
my $m1 = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
my $m2 = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'CattySession');
$m1->get_ok("/name");
$m1->title_is('Catty');
$m2->get_ok("/name");
$m2->title_is('CattySession');
Test-WWW-Mechanize-Catalyst-0.62/t/cookies.t 0000644 0003721 0000144 00000001054 13432343365 020373 0 ustar matthewt users #!perl
use strict;
use warnings;
use lib 'lib';
use Test::More;
BEGIN {
eval {
require Catalyst::Plugin::Session;
require Catalyst::Plugin::Session::State::Cookie;
};
if ($@) {
diag($@);
plan skip_all => "Need Catalyst::Plugin::Session to run this test";
exit 0;
}
}
use lib 't/lib';
use Test::WWW::Mechanize::Catalyst 'CattySession';
plan tests => 3;
my $m = Test::WWW::Mechanize::Catalyst->new;
$m->credentials( 'user', 'pass' );
$m->get_ok("/");
$m->title_is("Root");
is( $m->status, 200 );
Test-WWW-Mechanize-Catalyst-0.62/t/white_label.t 0000644 0003721 0000144 00000000547 13432343365 021224 0 ustar matthewt users use strict;
use warnings;
use Test::More tests => 4;
use lib 't/lib';
use Test::WWW::Mechanize::Catalyst;
my $m = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
$m->host('foo.com');
$m->get_ok('/host');
$m->content_contains('Host: foo.com');
$m->clear_host;
$m->get_ok('/host');
$m->content_contains('Host: localhost') or diag $m->content;
Test-WWW-Mechanize-Catalyst-0.62/t/pod.t 0000644 0003721 0000144 00000000215 13432343365 017517 0 ustar matthewt users #!perl
use Test::More;
eval "use Test::Pod 1.14";
plan skip_all => "Test::Pod 1.14 required for testing POD: $@" if $@;
all_pod_files_ok();
Test-WWW-Mechanize-Catalyst-0.62/t/utf8.t 0000644 0003721 0000144 00000001652 13432343365 017631 0 ustar matthewt users use utf8;
use warnings;
use strict;
use Test::More;
use Encode 2.21 'decode_utf8', 'encode_utf8';
use lib 't/lib';
{
package MyApp::Controller::Root;
$INC{'MyApp/Controller/Root.pm'} = __FILE__;
use base 'Catalyst::Controller';
sub heart :Path('♥') {
my ($self, $c) = @_;
$c->response->content_type('text/html');
$c->response->body("This is path-heart action ♥
");
}
package MyApp;
use Catalyst;
MyApp->setup;
}
use Test::WWW::Mechanize::Catalyst 'MyApp';
my $root = "http://localhost";
my $m = Test::WWW::Mechanize::Catalyst->new( autocheck => 0 );
if(MyApp->can('encoding') and MyApp->can('clear_encoding') and MyApp->encoding eq 'UTF-8') {
$m->get_ok("$root/root/♥", 'got page');
is( $m->ct, "text/html" );
$m->content_contains("This is path-heart action ♥", 'matched expected content');
} else {
ok 1, 'Skipping the UTF8 Tests for older installed catalyst';
}
done_testing;
Test-WWW-Mechanize-Catalyst-0.62/t/lib/ 0000755 0003721 0000144 00000000000 13432566046 017323 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/t/lib/Catty.pm 0000644 0003721 0000144 00000000314 13432343365 020740 0 ustar matthewt users package Catty;
use strict;
use warnings;
use Catalyst;
use Cwd;
__PACKAGE__->config(
name => 'Catty',
root => cwd . '/t/root',
);
__PACKAGE__->setup();
__PACKAGE__->log->levels("fatal");
1;
Test-WWW-Mechanize-Catalyst-0.62/t/lib/Catty/ 0000755 0003721 0000144 00000000000 13432566046 020407 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/t/lib/Catty/Controller/ 0000755 0003721 0000144 00000000000 13432566046 022532 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/t/lib/Catty/Controller/Root.pm 0000644 0003721 0000144 00000010072 13432343365 024010 0 ustar matthewt users package Catty::Controller::Root;
use strict;
use warnings;
use base qw/ Catalyst::Controller /;
use Cwd;
use MIME::Base64;
use Encode ();
use utf8;
__PACKAGE__->config( namespace => '' );
sub default : Private {
my ( $self, $context ) = @_;
my $html = html( "Root", "This is the root page" );
$context->response->content_type("text/html");
$context->response->output($html);
}
sub hello : Global {
my ( $self, $context ) = @_;
my $str = Encode::encode('utf-8', "\x{263A}"); # ☺
my $html = html( "Hello", "Hi there! $str" );
$context->response->content_type("text/html; charset=utf-8");
$context->response->output($html);
# Newer Catalyst auto encodes UTF8, but this test case is borked and expects
# broken utf8 behavior. We'll make a real UTF8 Test case separately.
$context->clear_encoding if $context->can('clear_encoding'); # Compat with upcoming Catalyst 5.90080
}
# absolute redirect
sub hi : Global {
my ( $self, $context ) = @_;
my $where = $context->uri_for('hello');
$context->response->redirect($where);
return;
}
# partial (relative) redirect
sub greetings : Global {
my ( $self, $context ) = @_;
$context->response->redirect("hello");
return;
}
# redirect to a redirect
sub bonjour : Global {
my ( $self, $context ) = @_;
my $where = $context->uri_for('hi');
$context->response->redirect($where);
return;
}
sub check_auth_basic : Global {
my ( $self, $context ) = @_;
my $auth = $context->req->headers->authorization;
($auth) = $auth =~ /Basic\s(.*)/i;
$auth = decode_base64($auth);
if ( $auth eq "user:pass" ) {
my $html = html( "Auth", "This is the auth page" );
$context->response->content_type("text/html");
$context->response->output($html);
return $context;
} else {
my $html = html( "Auth", "Auth Failed!" );
$context->response->content_type("text/html");
$context->response->output($html);
$context->response->status("401");
return $context;
}
}
sub redirect_with_500 : Global {
my ( $self, $c ) = @_;
$DB::single = 1;
$c->res->redirect( $c->uri_for("/bonjour"));
die "erk!";
}
sub die : Global {
my ( $self, $context ) = @_;
my $html = html( "Die", "This is the die page" );
$context->response->content_type("text/html");
$context->response->output($html);
die "erk!";
}
sub name : Global {
my ($self, $c) = @_;
my $html = html( $c->config->{name}, "This is the die page" );
$c->response->content_type("text/html");
$c->response->output($html);
}
sub host : Global {
my ($self, $c) = @_;
my $host = $c->req->header('Host') || "";
my $html = html( $c->config->{name}, "Host: $host" );
$c->response->content_type("text/html");
$c->response->output($html);
}
sub html {
my ( $title, $body ) = @_;
return qq{
$title
$body
Hello.
};
}
sub gzipped : Global {
my ( $self, $c ) = @_;
# If done properly this test should check the accept-encoding header, but we
# control both ends, so just always gzip the response.
require Compress::Zlib;
my $html = Encode::encode('UTF-8', html( "Hello", "Hi there! ☺" ));
$c->response->content_type("text/html; charset=utf-8");
$c->response->output( Compress::Zlib::memGzip($html) );
$c->response->content_encoding('gzip');
$c->response->headers->push_header( 'Vary', 'Accept-Encoding' );
}
sub user_agent : Global {
my ( $self, $c ) = @_;
my $html = html($c->req->user_agent, $c->req->user_agent);
$c->response->content_type("text/html; charset=utf-8");
$c->response->output( $html );
}
# per https://rt.cpan.org/Ticket/Display.html?id=36442
sub bad_content_encoding :Global {
my($self, $c) = @_;
$c->res->content_encoding('duff');
$c->res->body('foo');
}
sub redirect_to_utf8_upgraded_string : Global {
my($self, $c) = @_;
my $where = $c->uri_for('hello', 'müller')->as_string;
utf8::upgrade($where);
$c->res->redirect($where);
}
1;
Test-WWW-Mechanize-Catalyst-0.62/t/lib/ExternalCatty/ 0000755 0003721 0000144 00000000000 13432566046 022112 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/t/lib/ExternalCatty/Controller/ 0000755 0003721 0000144 00000000000 13432566046 024235 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/t/lib/ExternalCatty/Controller/Root.pm 0000644 0003721 0000144 00000002263 13432343365 025516 0 ustar matthewt users package ExternalCatty::Controller::Root;
use strict;
use warnings;
use base qw/ Catalyst::Controller /;
__PACKAGE__->config( namespace => '' );
sub default : Private {
my ( $self, $c ) = @_;
$c->response->content_type('text/html; charset=utf-8');
$c->response->output( html( 'Root', 'Hello, test ☺!' ) );
# Newer Catalyst auto encodes UTF8, but this test case is borked and expects
# broken utf8 behavior. We'll make a real UTF8 Test case separately.
$c->clear_encoding if $c->can('clear_encoding'); # Compat with upcoming Catalyst 5.90080
}
# redirect to a redirect
sub hello: Global {
my ( $self, $context ) = @_;
my $where = $context->uri_for('/');
$context->response->redirect($where);
return;
}
sub html {
my ( $title, $body ) = @_;
return qq[
$title
$body
];
}
sub host : Global {
my ($self, $c) = @_;
my $host = $c->req->header('Host') || "";
my $html = html( $c->config->{name}, "Host: $host" );
$c->response->content_type("text/html");
$c->response->output($html);
}
1;
Test-WWW-Mechanize-Catalyst-0.62/t/lib/CattySession/ 0000755 0003721 0000144 00000000000 13432566046 021753 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/t/lib/CattySession/Controller/ 0000755 0003721 0000144 00000000000 13432566046 024076 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/t/lib/CattySession/Controller/Root.pm 0000644 0003721 0000144 00000001473 13432343365 025361 0 ustar matthewt users package CattySession::Controller::Root;
use strict;
use warnings;
use base qw/ Catalyst::Controller /;
__PACKAGE__->config( namespace => '' );
sub auto : Private {
my ( $self, $context ) = @_;
if ( $context->session ) {
return 1;
}
}
sub default : Private {
my ( $self, $context ) = @_;
my $html = html( "Root", "This is the root page" );
$context->response->content_type("text/html");
$context->response->output($html);
}
sub name : Global {
my ($self, $c) = @_;
my $html = html( $c->config->{name}, "This is the die page" );
$c->response->content_type("text/html");
$c->response->output($html);
}
sub html {
my ( $title, $body ) = @_;
return qq{
$title
$body
Hello.
};
}
1;
Test-WWW-Mechanize-Catalyst-0.62/t/lib/CattySession.pm 0000644 0003721 0000144 00000000374 13432343365 022312 0 ustar matthewt users package CattySession;
use strict;
use warnings;
use Catalyst qw/
Session
Session::State::Cookie
Session::Store::Dummy
/;
use Cwd;
__PACKAGE__->config(
name => 'CattySession',
root => cwd . '/t/root',
);
__PACKAGE__->setup;
1;
Test-WWW-Mechanize-Catalyst-0.62/t/lib/ExternalCatty.pm 0000644 0003721 0000144 00000002254 13432343365 022450 0 ustar matthewt users package ExternalCatty;
use strict;
use warnings;
use Catalyst;
use Catalyst::ScriptRunner;
use IO::Socket::INET;
__PACKAGE__->config( name => 'ExternalCatty' );
__PACKAGE__->setup;
sub MAX_PORT_TRIES() { 5 }
# The Cat HTTP server background option is useless here :-(
# Thus we have to provide our own background method.
sub background {
my $self = shift;
my $port = shift;
$port = $self->assert_or_find_available_port($port);
my $child = fork;
die "Can't fork Cat HTTP server: $!" unless defined $child;
return($child, $port) if $child;
if ( $^O !~ /MSWin32/ ) {
require POSIX;
POSIX::setsid() or die "Can't start a new session: $!";
}
local @ARGV = ('-p', $port);
Catalyst::ScriptRunner->run(__PACKAGE__, 'Server');
}
sub assert_or_find_available_port {
my($self, $port) = @_;
for my $i (1..MAX_PORT_TRIES) {
IO::Socket::INET->new(
LocalAddr => 'localhost',
LocalPort => $port,
Proto => 'tcp'
) and return $port;
$port += int(rand 100) + 1;
}
die q{Can't find an open port to run external server on after }
. MAX_PORT_TRIES . q{tries};
}
1;
Test-WWW-Mechanize-Catalyst-0.62/README 0000644 0003721 0000144 00000024322 13432565745 017202 0 ustar matthewt users NAME
Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
SYNOPSIS
# We're in a t/*.t test script...
use Test::WWW::Mechanize::Catalyst;
# To test a Catalyst application named 'Catty':
my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
$mech->get_ok("/"); # no hostname needed
is($mech->ct, "text/html");
$mech->title_is("Root", "On the root page");
$mech->content_contains("This is the root page", "Correct content");
$mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
# ... and all other Test::WWW::Mechanize methods
# White label site testing
$mech->host("foo.com");
$mech->get_ok("/");
DESCRIPTION
Catalyst is an elegant MVC Web Application Framework.
Test::WWW::Mechanize is a subclass of WWW::Mechanize that incorporates
features for web application testing. The Test::WWW::Mechanize::Catalyst
module meshes the two to allow easy testing of Catalyst applications
without needing to start up a web server.
Testing web applications has always been a bit tricky, normally
requiring starting a web server for your application and making real
HTTP requests to it. This module allows you to test Catalyst web
applications but does not require a server or issue HTTP requests.
Instead, it passes the HTTP request object directly to Catalyst. Thus
you do not need to use a real hostname: "http://localhost/" will do.
However, this is optional. The following two lines of code do exactly
the same thing:
$mech->get_ok('/action');
$mech->get_ok('http://localhost/action');
Links which do not begin with / or are not for localhost can be handled
as normal Web requests - this is handy if you have an external single
sign-on system. You must set allow_external to true for this:
$mech->allow_external(1);
You can also test a remote server by setting the environment variable
CATALYST_SERVER; for example:
$ CATALYST_SERVER=http://example.com/myapp prove -l t
will run the same tests on the application running at
http://example.com/myapp regardless of whether or not you specify
http:://localhost for Test::WWW::Mechanize::Catalyst.
Furthermore, if you set CATALYST_SERVER, the server will be regarded as
a remote server even if your links point to localhost. Thus, you can use
Test::WWW::Mechanize::Catalyst to test your live webserver running on
your local machine, if you need to test aspects of your deployment
environment (for example, configuration options in an http.conf file)
instead of just the Catalyst request handling.
This makes testing fast and easy. Test::WWW::Mechanize provides
functions for common web testing scenarios. For example:
$mech->get_ok( $page );
$mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
$mech->content_contains( "Andy Lester", "My name somewhere" );
$mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
This module supports cookies automatically.
To use this module you must pass it the name of the application. See the
SYNOPSIS above.
Note that Catalyst has a special development feature: the debug screen.
By default this module will treat responses which are the debug screen
as failures. If you actually want to test debug screens, please use:
$mech->{catalyst_debug} = 1;
An alternative to this module is Catalyst::Test.
CONSTRUCTOR
new
Behaves like, and calls, WWW::Mechanize's "new" method. Any params
passed in get passed to WWW::Mechanize's constructor. Note that we need
to pass the name of the Catalyst application to the "use":
use Test::WWW::Mechanize::Catalyst 'Catty';
my $mech = Test::WWW::Mechanize::Catalyst->new;
METHODS
allow_external
Links which do not begin with / or are not for localhost can be handled
as normal Web requests - this is handy if you have an external single
sign-on system. You must set allow_external to true for this:
$mech->allow_external(1);
head2 catalyst_app
The name of the Catalyst app which we are testing against. Read-only.
host
The host value to set the "Host:" HTTP header to, if none is present
already in the request. If not set (default) then Catalyst::Test will
set this to localhost:80
clear_host
Unset the host attribute.
has_host
Do we have a value set for the host attribute
$mech->get_ok($url, [ \%LWP_options ,] $desc)
A wrapper around WWW::Mechanize's get(), with similar options, except
the second argument needs to be a hash reference, not a hash. Returns
true or false.
$mech->title_is( $str [, $desc ] )
Tells if the title of the page is the given string.
$mech->title_is( "Invoice Summary" );
$mech->title_like( $regex [, $desc ] )
Tells if the title of the page matches the given regex.
$mech->title_like( qr/Invoices for (.+)/
$mech->title_unlike( $regex [, $desc ] )
Tells if the title of the page does NOT match the given regex.
$mech->title_unlike( qr/Invoices for (.+)/
$mech->content_is( $str [, $desc ] )
Tells if the content of the page matches the given string.
$mech->content_contains( $str [, $desc ] )
Tells if the content of the page contains *$str*.
$mech->content_lacks( $str [, $desc ] )
Tells if the content of the page lacks *$str*.
$mech->content_like( $regex [, $desc ] )
Tells if the content of the page matches *$regex*.
$mech->content_unlike( $regex [, $desc ] )
Tells if the content of the page does NOT match *$regex*.
$mech->page_links_ok( [ $desc ] )
Follow all links on the current page and test for HTTP status 200
$mech->page_links_ok('Check all links');
$mech->page_links_content_like( $regex,[ $desc ] )
Follow all links on the current page and test their contents for
*$regex*.
$mech->page_links_content_like( qr/foo/,
'Check all links contain "foo"' );
$mech->page_links_content_unlike( $regex,[ $desc ] )
Follow all links on the current page and test their contents do not
contain the specified regex.
$mech->page_links_content_unlike(qr/Restricted/,
'Check all links do not contain Restricted');
$mech->links_ok( $links [, $desc ] )
Check the current page for specified links and test for HTTP status 200.
The links may be specified as a reference to an array containing
WWW::Mechanize::Link objects, an array of URLs, or a scalar URL name.
my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
$mech->links_ok( \@links, 'Check all links for cnn.com' );
my @links = qw( index.html search.html about.html );
$mech->links_ok( \@links, 'Check main links' );
$mech->links_ok( 'index.html', 'Check link to index' );
$mech->link_status_is( $links, $status [, $desc ] )
Check the current page for specified links and test for HTTP status
passed. The links may be specified as a reference to an array containing
WWW::Mechanize::Link objects, an array of URLs, or a scalar URL name.
my @links = $mech->links();
$mech->link_status_is( \@links, 403,
'Check all links are restricted' );
$mech->link_status_isnt( $links, $status [, $desc ] )
Check the current page for specified links and test for HTTP status
passed. The links may be specified as a reference to an array containing
WWW::Mechanize::Link objects, an array of URLs, or a scalar URL name.
my @links = $mech->links();
$mech->link_status_isnt( \@links, 404,
'Check all links are not 404' );
$mech->link_content_like( $links, $regex [, $desc ] )
Check the current page for specified links and test the content of each
against *$regex*. The links may be specified as a reference to an array
containing WWW::Mechanize::Link objects, an array of URLs, or a scalar
URL name.
my @links = $mech->links();
$mech->link_content_like( \@links, qr/Restricted/,
'Check all links are restricted' );
$mech->link_content_unlike( $links, $regex [, $desc ] )
Check the current page for specified links and test that the content of
each does not match *$regex*. The links may be specified as a reference
to an array containing WWW::Mechanize::Link objects, an array of URLs,
or a scalar URL name.
my @links = $mech->links();
$mech->link_content_like( \@links, qr/Restricted/,
'Check all links are restricted' );
follow_link_ok( \%parms [, $comment] )
Makes a "follow_link()" call and executes tests on the results. The link
must be found, and then followed successfully. Otherwise, this test
fails.
*%parms* is a hashref containing the params to pass to "follow_link()".
Note that the params to "follow_link()" are a hash whereas the parms to
this function are a hashref. You have to call this function like:
$agent->follow_link_ok( {n=>3}, "looking for 3rd link" );
As with other test functions, $comment is optional. If it is supplied
then it will display when running the test harness in verbose mode.
Returns true value if the specified link was found and followed
successfully. The HTTP::Response object returned by follow_link() is not
available.
CAVEATS
External Redirects and allow_external
If you use non-fully qualified urls in your test scripts (i.e. anything
without a host, such as "->get_ok( "/foo")" ) and your app redirects to
an external URL, expect to be bitten once you come back to your
application's urls (it will try to request them on the remote server).
This is due to a limitation in WWW::Mechanize.
One workaround for this is that if you are expecting to redirect to an
external site, clone the TWMC object and use the cloned object for the
external redirect.
SEE ALSO
Related modules which may be of interest: Catalyst,
Test::WWW::Mechanize, WWW::Mechanize.
AUTHOR
Ash Berlin "" (current maintainer)
Original Author: Leon Brocard, ""
COPYRIGHT
Copyright (C) 2005-9, Leon Brocard
LICENSE
This module is free software; you can redistribute it or modify it under
the same terms as Perl itself.
Test-WWW-Mechanize-Catalyst-0.62/inc/ 0000755 0003721 0000144 00000000000 13432566046 017063 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/inc/Module/ 0000755 0003721 0000144 00000000000 13432566046 020310 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/inc/Module/Install.pm 0000644 0003721 0000144 00000027145 13432565745 022272 0 ustar matthewt users #line 1
package Module::Install;
# For any maintainers:
# The load order for Module::Install is a bit magic.
# It goes something like this...
#
# IF ( host has Module::Install installed, creating author mode ) {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
# 3. The installed version of inc::Module::Install loads
# 4. inc::Module::Install calls "require Module::Install"
# 5. The ./inc/ version of Module::Install loads
# } ELSE {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
# 3. The ./inc/ version of Module::Install loads
# }
use 5.006;
use strict 'vars';
use Cwd ();
use File::Find ();
use File::Path ();
use vars qw{$VERSION $MAIN};
BEGIN {
# All Module::Install core packages now require synchronised versions.
# This will be used to ensure we don't accidentally load old or
# different versions of modules.
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
$VERSION = '1.19';
# Storage for the pseudo-singleton
$MAIN = undef;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
#-------------------------------------------------------------
# all of the following checks should be included in import(),
# to allow "eval 'require Module::Install; 1' to test
# installation of Module::Install. (RT #51267)
#-------------------------------------------------------------
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
use inc::${\__PACKAGE__};
not:
use ${\__PACKAGE__};
END_DIE
# This reportedly fixes a rare Win32 UTC file time issue, but
# as this is a non-cross-platform XS module not in the core,
# we shouldn't really depend on it. See RT #24194 for detail.
# (Also, this module only supports Perl 5.6 and above).
eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 ) {
my $s = (stat($0))[9];
# If the modification time is only slightly in the future,
# sleep briefly to remove the problem.
my $a = $s - time;
if ( $a > 0 and $a < 5 ) { sleep 5 }
# Too far in the future, throw an error.
my $t = time;
if ( $s > $t ) { die <<"END_DIE" }
Your installer $0 has a modification time in the future ($s > $t).
This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
}
# Build.PL was formerly supported, but no longer is due to excessive
# difficulty in implementing every single feature twice.
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
Module::Install no longer supports Build.PL.
It was impossible to maintain duel backends, and has been deprecated.
Please remove all Build.PL files and only use the Makefile.PL installer.
END_DIE
#-------------------------------------------------------------
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
#-------------------------------------------------------------
unless ( -f $self->{file} ) {
foreach my $key (keys %INC) {
delete $INC{$key} if $key =~ /Module\/Install/;
}
local $^W;
require "$self->{path}/$self->{dispatch}.pm";
File::Path::mkpath("$self->{prefix}/$self->{author}");
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
$self->{admin}->init;
@_ = ($class, _self => $self);
goto &{"$self->{name}::import"};
}
local $^W;
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{'inc/Module/Install.pm'};
delete $INC{'Module/Install.pm'};
# Save to the singleton
$MAIN = $self;
return 1;
}
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::getcwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::getcwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
unless ($$sym =~ s/([^:]+)$//) {
# XXX: it looks like we can't retrieve the missing function
# via $$sym (usually $main::AUTOLOAD) in this case.
# I'm still wondering if we should slurp Makefile.PL to
# get some context or not ...
my ($package, $file, $line) = caller;
die <<"EOT";
Unknown function is found at $file line $line.
Execution of $file aborted due to runtime errors.
If you're a contributor to a project, you may need to install
some Module::Install extensions from CPAN (or other repository).
If you're a user of a module, please contact the author.
EOT
}
my $method = $1;
if ( uc($method) eq $method ) {
# Do nothing
return;
} elsif ( $method =~ /^_/ and $self->can($method) ) {
# Dispatch to the root M:I class
return $self->$method(@_);
}
# Dispatch to the appropriate plugin
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
}
my @exts = @{$self->{extensions}};
unless ( @exts ) {
@exts = $self->{admin}->load_all_extensions;
}
my %seen;
foreach my $obj ( @exts ) {
while (my ($method, $glob) = each %{ref($obj) . '::'}) {
next unless $obj->can($method);
next if $method =~ /^_/;
next if $method eq uc($method);
$seen{$method}++;
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
delete $INC{'FindBin.pm'};
{
# to suppress the redefine warning
local $SIG{__WARN__} = sub {};
require FindBin;
}
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
$base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS';
$args{dispatch} ||= 'Admin';
$args{prefix} ||= 'inc';
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
$args{bundle} ||= 'inc/BUNDLES';
$args{base} ||= $base_path;
$class =~ s/^\Q$args{prefix}\E:://;
$args{name} ||= $class;
$args{version} ||= $class->VERSION;
unless ( $args{path} ) {
$args{path} = $args{name};
$args{path} =~ s!::!/!g;
}
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
foreach my $obj (@{$self->{extensions}}) {
return $obj if $obj->can($method);
}
my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
my $obj = $admin->load($method, 1);
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
my $should_reload = 0;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
$should_reload = 1;
}
foreach my $rv ( $self->find_extensions($path) ) {
my ($file, $pkg) = @{$rv};
next if $self->{pathnames}{$pkg};
local $@;
my $new = eval { local $^W; require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} =
$should_reload ? delete $INC{$file} : $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( {no_chdir => 1, wanted => sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($File::Find::name);
my $in_pod = 0;
foreach ( split /\n/, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
next if /^\s*#/; # and comments
if ( m/^\s*package\s+($pkg)\s*;/i ) {
$pkg = $1;
last;
}
}
}
push @found, [ $file, $pkg ];
}}, $path ) if -d $path;
@found;
}
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
binmode FH;
my $string = do { local $/; };
close FH or die "close($_[0]): $!";
return $string;
}
sub _readperl {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
return $string;
}
sub _readpod {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
return $string if $_[0] =~ /\.pod\z/;
$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
$string =~ s/^\n+//s;
return $string;
}
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
binmode FH;
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map {
$_ . '0' x (3 - length $_)
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
sub _cmp {
_version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS {
(
defined $_[0]
and
! ref $_[0]
and
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ? $_[0] : undef;
}
1;
# Copyright 2008 - 2012 Adam Kennedy.
Test-WWW-Mechanize-Catalyst-0.62/inc/Module/Install/ 0000755 0003721 0000144 00000000000 13432566046 021716 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/inc/Module/Install/Metadata.pm 0000644 0003721 0000144 00000043302 13432565745 024003 0 ustar matthewt users #line 1
package Module::Install::Metadata;
use strict 'vars';
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
my @boolean_keys = qw{
sign
};
my @scalar_keys = qw{
name
module_name
abstract
version
distribution_type
tests
installdirs
};
my @tuple_keys = qw{
configure_requires
build_requires
requires
recommends
bundles
resources
};
my @resource_keys = qw{
homepage
bugtracker
repository
};
my @array_keys = qw{
keywords
author
};
*authors = \&author;
sub Meta { shift }
sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
sub Meta_ResourceKeys { @resource_keys }
sub Meta_ArrayKeys { @array_keys }
foreach my $key ( @boolean_keys ) {
*$key = sub {
my $self = shift;
if ( defined wantarray and not @_ ) {
return $self->{values}->{$key};
}
$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
return $self;
};
}
foreach my $key ( @scalar_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} = shift;
return $self;
};
}
foreach my $key ( @array_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} ||= [];
push @{$self->{values}->{$key}}, @_;
return $self;
};
}
foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
return () unless $self->{values}->{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
@{ $self->{values}->{resources} };
}
return $self->{values}->{resources}->{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
$self->resources( $key => $uri );
return 1;
};
}
foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} unless @_;
my @added;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @added, [ $module, $version ];
}
push @{ $self->{values}->{$key} }, @added;
return map {@$_} @added;
};
}
# Resource handling
my %lc_resource = map { $_ => 1 } qw{
homepage
license
bugtracker
repository
};
sub resources {
my $self = shift;
while ( @_ ) {
my $name = shift or last;
my $value = shift or next;
if ( $name eq lc $name and ! $lc_resource{$name} ) {
die("Unsupported reserved lowercase resource '$name'");
}
$self->{values}->{resources} ||= [];
push @{ $self->{values}->{resources} }, [ $name, $value ];
}
$self->{values}->{resources};
}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
my $self = shift;
my $value = @_ ? shift : 1;
if ( $self->{values}->{dynamic_config} ) {
# Once dynamic we never change to static, for safety
return 0;
}
$self->{values}->{dynamic_config} = $value ? 1 : 0;
return 1;
}
# Convenience command
sub static_config {
shift->dynamic_config(0);
}
sub perl_version {
my $self = shift;
return $self->{values}->{perl_version} unless @_;
my $version = shift or die(
"Did not provide a value to perl_version()"
);
# Normalize the version
$version = $self->_perl_version($version);
# We don't support the really old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
$self->{values}->{perl_version} = $version;
}
sub all_from {
my ( $self, $file ) = @_;
unless ( defined($file) ) {
my $name = $self->name or die(
"all_from called with no args without setting name() first"
);
$file = join('/', 'lib', split(/-/, $name)) . '.pm';
$file =~ s{.*/}{} unless -e $file;
unless ( -e $file ) {
die("all_from cannot find $file from $name");
}
}
unless ( -f $file ) {
die("The path '$file' does not exist, or is not a file");
}
$self->{values}{all_from} = $file;
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
$pod =~ s/\.pm$/.pod/i;
$pod = $file unless -e $pod;
# Pull the different values
$self->name_from($file) unless $self->name;
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
$self->author_from($pod) unless @{$self->author || []};
$self->license_from($pod) unless $self->license;
$self->abstract_from($pod) unless $self->abstract;
return 1;
}
sub provides {
my $self = shift;
my $provides = ( $self->{values}->{provides} ||= {} );
%$provides = (%$provides, @_) if @_;
return $provides;
}
sub auto_provides {
my $self = shift;
return $self unless $self->is_admin;
unless (-e 'MANIFEST') {
warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
return $self;
}
# Avoid spurious warnings as we are not checking manifest here.
local $SIG{__WARN__} = sub {1};
require ExtUtils::Manifest;
local *ExtUtils::Manifest::manicheck = sub { return };
require Module::Build;
my $build = Module::Build->new(
dist_name => $self->name,
dist_version => $self->version,
license => $self->license,
);
$self->provides( %{ $build->find_dist_packages || {} } );
}
sub feature {
my $self = shift;
my $name = shift;
my $features = ( $self->{values}->{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
# The user used ->feature like ->features by passing in the second
# argument as a reference. Accomodate for that.
$mods = $_[0];
} else {
$mods = \@_;
}
my $count = 0;
push @$features, (
$name => [
map {
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
} @$mods
]
);
return @$features;
}
sub features {
my $self = shift;
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
return $self->{values}->{features}
? @{ $self->{values}->{features} }
: ();
}
sub no_index {
my $self = shift;
my $type = shift;
push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
return $self->{values}->{no_index};
}
sub read {
my $self = shift;
$self->include_deps( 'YAML::Tiny', 0 );
require YAML::Tiny;
my $data = YAML::Tiny::LoadFile('META.yml');
# Call methods explicitly in case user has already set some values.
while ( my ( $key, $value ) = each %$data ) {
next unless $self->can($key);
if ( ref $value eq 'HASH' ) {
while ( my ( $module, $version ) = each %$value ) {
$self->can($key)->($self, $module => $version );
}
} else {
$self->can($key)->($self, $value);
}
}
return $self;
}
sub write {
my $self = shift;
return $self unless $self->is_admin;
$self->admin->write_meta;
return $self;
}
sub version_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
# for version integrity check
$self->makemaker_args( VERSION_FROM => $file );
}
sub abstract_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->abstract(
bless(
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
);
}
# Add both distribution and module name
sub name_from {
my ($self, $file) = @_;
if (
Module::Install::_read($file) =~ m/
^ \s*
package \s*
([\w:]+)
[\s|;]*
/ixms
) {
my ($name, $module_name) = ($1, $1);
$name =~ s{::}{-}g;
$self->name($name);
unless ( $self->module_name ) {
$self->module_name($module_name);
}
} else {
die("Cannot determine name from $file\n");
}
}
sub _extract_perl_version {
if (
$_[0] =~ m/
^\s*
(?:use|require) \s*
v?
([\d_\.]+)
\s* ;
/ixms
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
return $perl_version;
} else {
return;
}
}
sub perl_version_from {
my $self = shift;
my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
if ($perl_version) {
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
return;
}
}
sub author_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
if ($content =~ m/
=head \d \s+ (?:authors?)\b \s*
([^\n]*)
|
=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
([^\n]*)
/ixms) {
my $author = $1 || $2;
# XXX: ugly but should work anyway...
if (eval "require Pod::Escapes; 1") {
# Pod::Escapes has a mapping table.
# It's in core of perl >= 5.9.3, and should be installed
# as one of the Pod::Simple's prereqs, which is a prereq
# of Pod::Text 3.x (see also below).
$author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
{
defined $2
? chr($2)
: defined $Pod::Escapes::Name2character_number{$1}
? chr($Pod::Escapes::Name2character_number{$1})
: do {
warn "Unknown escape: E<$1>";
"E<$1>";
};
}gex;
}
elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
# Pod::Text < 3.0 has yet another mapping table,
# though the table name of 2.x and 1.x are different.
# (1.x is in core of Perl < 5.6, 2.x is in core of
# Perl < 5.9.3)
my $mapping = ($Pod::Text::VERSION < 2)
? \%Pod::Text::HTML_Escapes
: \%Pod::Text::ESCAPES;
$author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
{
defined $2
? chr($2)
: defined $mapping->{$1}
? $mapping->{$1}
: do {
warn "Unknown escape: E<$1>";
"E<$1>";
};
}gex;
}
else {
$author =~ s{E}{<}g;
$author =~ s{E}{>}g;
}
$self->author($author);
} else {
warn "Cannot determine author info from $_[0]\n";
}
}
#Stolen from M::B
my %license_urls = (
perl => 'http://dev.perl.org/licenses/',
apache => 'http://apache.org/licenses/LICENSE-2.0',
apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
artistic => 'http://opensource.org/licenses/artistic-license.php',
artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
lgpl => 'http://opensource.org/licenses/lgpl-license.php',
lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
bsd => 'http://opensource.org/licenses/bsd-license.php',
gpl => 'http://opensource.org/licenses/gpl-license.php',
gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
mit => 'http://opensource.org/licenses/mit-license.php',
mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
open_source => undef,
unrestricted => undef,
restrictive => undef,
unknown => undef,
);
sub license {
my $self = shift;
return $self->{values}->{license} unless @_;
my $license = shift or die(
'Did not provide a value to license()'
);
$license = __extract_license($license) || lc $license;
$self->{values}->{license} = $license;
# Automatically fill in license URLs
if ( $license_urls{$license} ) {
$self->resources( license => $license_urls{$license} );
}
return 1;
}
sub _extract_license {
my $pod = shift;
my $matched;
return __extract_license(
($matched) = $pod =~ m/
(=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
(=head \d.*|=cut.*|)\z
/xms
) || __extract_license(
($matched) = $pod =~ m/
(=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
(=head \d.*|=cut.*|)\z
/xms
);
}
sub __extract_license {
my $license_text = shift or return;
my @phrases = (
'(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
'(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
'Artistic and GPL' => 'perl', 1,
'GNU general public license' => 'gpl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser general public license' => 'lgpl', 1,
'GNU lesser public license' => 'lgpl', 1,
'GNU library general public license' => 'lgpl', 1,
'GNU library public license' => 'lgpl', 1,
'GNU Free Documentation license' => 'unrestricted', 1,
'GNU Affero General Public License' => 'open_source', 1,
'(?:Free)?BSD license' => 'bsd', 1,
'Artistic license 2\.0' => 'artistic_2', 1,
'Artistic license' => 'artistic', 1,
'Apache (?:Software )?license' => 'apache', 1,
'GPL' => 'gpl', 1,
'LGPL' => 'lgpl', 1,
'BSD' => 'bsd', 1,
'Artistic' => 'artistic', 1,
'MIT' => 'mit', 1,
'Mozilla Public License' => 'mozilla', 1,
'Q Public License' => 'open_source', 1,
'OpenSSL License' => 'unrestricted', 1,
'SSLeay License' => 'unrestricted', 1,
'zlib License' => 'open_source', 1,
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s#\s+#\\s+#gs;
if ( $license_text =~ /\b$pattern\b/i ) {
return $license;
}
}
return '';
}
sub license_from {
my $self = shift;
if (my $license=_extract_license(Module::Install::_read($_[0]))) {
$self->license($license);
} else {
warn "Cannot determine license info from $_[0]\n";
return 'unknown';
}
}
sub _extract_bugtracker {
my @links = $_[0] =~ m#L<(
https?\Q://rt.cpan.org/\E[^>]+|
https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
)>#gx;
my %links;
@links{@links}=();
@links=keys %links;
return @links;
}
sub bugtracker_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
my @links = _extract_bugtracker($content);
unless ( @links ) {
warn "Cannot determine bugtracker info from $_[0]\n";
return 0;
}
if ( @links > 1 ) {
warn "Found more than one bugtracker link in $_[0]\n";
return 0;
}
# Set the bugtracker
bugtracker( $links[0] );
return 1;
}
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->requires( $module => $version );
}
}
sub test_requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->test_requires( $module => $version );
}
}
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
# Numify
$v = $v + 0;
}
return $v;
}
sub add_metadata {
my $self = shift;
my %hash = @_;
for my $key (keys %hash) {
warn "add_metadata: $key is not prefixed with 'x_'.\n" .
"Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
$self->{values}->{$key} = $hash{$key};
}
}
######################################################################
# MYMETA Support
sub WriteMyMeta {
die "WriteMyMeta has been deprecated";
}
sub write_mymeta_yaml {
my $self = shift;
# We need YAML::Tiny to write the MYMETA.yml file
unless ( eval { require YAML::Tiny; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.yml\n";
YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}
sub write_mymeta_json {
my $self = shift;
# We need JSON to write the MYMETA.json file
unless ( eval { require JSON; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.json\n";
Module::Install::_write(
'MYMETA.json',
JSON->new->pretty(1)->canonical->encode($meta),
);
}
sub _write_mymeta_data {
my $self = shift;
# If there's no existing META.yml there is nothing we can do
return undef unless -f 'META.yml';
# We need Parse::CPAN::Meta to load the file
unless ( eval { require Parse::CPAN::Meta; 1; } ) {
return undef;
}
# Merge the perl version into the dependencies
my $val = $self->Meta->{values};
my $perl = delete $val->{perl_version};
if ( $perl ) {
$val->{requires} ||= [];
my $requires = $val->{requires};
# Canonize to three-dot version after Perl 5.6
if ( $perl >= 5.006 ) {
$perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
}
unshift @$requires, [ perl => $perl ];
}
# Load the advisory META.yml file
my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
# Overwrite the non-configure dependency hashes
delete $meta->{requires};
delete $meta->{build_requires};
delete $meta->{recommends};
if ( exists $val->{requires} ) {
$meta->{requires} = { map { @$_ } @{ $val->{requires} } };
}
if ( exists $val->{build_requires} ) {
$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
}
return $meta;
}
1;
Test-WWW-Mechanize-Catalyst-0.62/inc/Module/Install/Can.pm 0000644 0003721 0000144 00000006405 13432565745 022767 0 ustar matthewt users #line 1
package Module::Install::Can;
use strict;
use Config ();
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# check if we can load some module
### Upgrade this to not have to load the module if possible
sub can_use {
my ($self, $mod, $ver) = @_;
$mod =~ s{::|\\}{/}g;
$mod .= '.pm' unless $mod =~ /\.pm$/i;
my $pkg = $mod;
$pkg =~ s{/}{::}g;
$pkg =~ s{\.pm$}{}i;
local $@;
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
# Check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
my $_cmd = $cmd;
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
next if $dir eq '';
require File::Spec;
my $abs = File::Spec->catfile($dir, $cmd);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
# Can our C compiler environment build XS files
sub can_xs {
my $self = shift;
# Ensure we have the CBuilder module
$self->configure_requires( 'ExtUtils::CBuilder' => 0.27 );
# Do we have the configure_requires checker?
local $@;
eval "require ExtUtils::CBuilder;";
if ( $@ ) {
# They don't obey configure_requires, so it is
# someone old and delicate. Try to avoid hurting
# them by falling back to an older simpler test.
return $self->can_cc();
}
# Do we have a working C compiler
my $builder = ExtUtils::CBuilder->new(
quiet => 1,
);
unless ( $builder->have_compiler ) {
# No working C compiler
return 0;
}
# Write a C file representative of what XS becomes
require File::Temp;
my ( $FH, $tmpfile ) = File::Temp::tempfile(
"compilexs-XXXXX",
SUFFIX => '.c',
);
binmode $FH;
print $FH <<'END_C';
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
int main(int argc, char **argv) {
return 0;
}
int boot_sanexs() {
return 1;
}
END_C
close $FH;
# Can the C compiler access the same headers XS does
my @libs = ();
my $object = undef;
eval {
local $^W = 0;
$object = $builder->compile(
source => $tmpfile,
);
@libs = $builder->link(
objects => $object,
module_name => 'sanexs',
);
};
my $result = $@ ? 0 : 1;
# Clean up all the build files
foreach ( $tmpfile, $object, @libs ) {
next unless defined $_;
1 while unlink;
}
return $result;
}
# Can we locate a (the) C compiler
sub can_cc {
my $self = shift;
if ($^O eq 'VMS') {
require ExtUtils::CBuilder;
my $builder = ExtUtils::CBuilder->new(
quiet => 1,
);
return $builder->have_compiler;
}
my @chunks = split(/ /, $Config::Config{cc}) or return;
# $Config{cc} may contain args; try to find out the program part
while (@chunks) {
return $self->can_run("@chunks") || (pop(@chunks), next);
}
return;
}
# Fix Cygwin bug on maybe_command();
if ( $^O eq 'cygwin' ) {
require ExtUtils::MM_Cygwin;
require ExtUtils::MM_Win32;
if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
*ExtUtils::MM_Cygwin::maybe_command = sub {
my ($self, $file) = @_;
if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
ExtUtils::MM_Win32->maybe_command($file);
} else {
ExtUtils::MM_Unix->maybe_command($file);
}
}
}
}
1;
__END__
#line 245
Test-WWW-Mechanize-Catalyst-0.62/inc/Module/Install/WriteAll.pm 0000644 0003721 0000144 00000002376 13432565745 024014 0 ustar matthewt users #line 1
package Module::Install::WriteAll;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
sub WriteAll {
my $self = shift;
my %args = (
meta => 1,
sign => 0,
inline => 0,
check_nmake => 1,
@_,
);
$self->sign(1) if $args{sign};
$self->admin->WriteAll(%args) if $self->is_admin;
$self->check_nmake if $args{check_nmake};
unless ( $self->makemaker_args->{PL_FILES} ) {
# XXX: This still may be a bit over-defensive...
unless ($self->makemaker(6.25)) {
$self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
}
}
# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
# we clean it up properly ourself.
$self->realclean_files('MYMETA.yml');
if ( $args{inline} ) {
$self->Inline->write;
} else {
$self->Makefile->write;
}
# The Makefile write process adds a couple of dependencies,
# so write the META.yml files after the Makefile.
if ( $args{meta} ) {
$self->Meta->write;
}
# Experimental support for MYMETA
if ( $ENV{X_MYMETA} ) {
if ( $ENV{X_MYMETA} eq 'JSON' ) {
$self->Meta->write_mymeta_json;
} else {
$self->Meta->write_mymeta_yaml;
}
}
return 1;
}
1;
Test-WWW-Mechanize-Catalyst-0.62/inc/Module/Install/Base.pm 0000644 0003721 0000144 00000002147 13432565745 023137 0 ustar matthewt users #line 1
package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.19';
}
# Suspend handler for "redefined" warnings
BEGIN {
my $w = $SIG{__WARN__};
$SIG{__WARN__} = sub { $w };
}
#line 42
sub new {
my $class = shift;
unless ( defined &{"${class}::call"} ) {
*{"${class}::call"} = sub { shift->_top->call(@_) };
}
unless ( defined &{"${class}::load"} ) {
*{"${class}::load"} = sub { shift->_top->load(@_) };
}
bless { @_ }, $class;
}
#line 61
sub AUTOLOAD {
local $@;
my $func = eval { shift->_top->autoload } or return;
goto &$func;
}
#line 75
sub _top {
$_[0]->{_top};
}
#line 90
sub admin {
$_[0]->_top->{admin}
or
Module::Install::Base::FakeAdmin->new;
}
#line 106
sub is_admin {
! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
use vars qw{$VERSION};
BEGIN {
$VERSION = $Module::Install::Base::VERSION;
}
my $fake;
sub new {
$fake ||= bless(\@_, $_[0]);
}
sub AUTOLOAD {}
sub DESTROY {}
# Restore warning handler
BEGIN {
$SIG{__WARN__} = $SIG{__WARN__}->();
}
1;
#line 159
Test-WWW-Mechanize-Catalyst-0.62/inc/Module/Install/Makefile.pm 0000644 0003721 0000144 00000027437 13432565745 024013 0 ustar matthewt users #line 1
package Module::Install::Makefile;
use strict 'vars';
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub Makefile { $_[0] }
my %seen = ();
sub prompt {
shift;
# Infinite loop protection
my @c = caller();
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
# In automated testing or non-interactive session, always use defaults
if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
goto &ExtUtils::MakeMaker::prompt;
}
}
# Store a cleaned up version of the MakeMaker version,
# since we need to behave differently in a variety of
# ways based on the MM version.
my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
# If we are passed a param, do a "newer than" comparison.
# Otherwise, just return the MakeMaker version.
sub makemaker {
( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
}
# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
# as we only need to know here whether the attribute is an array
# or a hash or something else (which may or may not be appendable).
my %makemaker_argtype = (
C => 'ARRAY',
CONFIG => 'ARRAY',
# CONFIGURE => 'CODE', # ignore
DIR => 'ARRAY',
DL_FUNCS => 'HASH',
DL_VARS => 'ARRAY',
EXCLUDE_EXT => 'ARRAY',
EXE_FILES => 'ARRAY',
FUNCLIST => 'ARRAY',
H => 'ARRAY',
IMPORTS => 'HASH',
INCLUDE_EXT => 'ARRAY',
LIBS => 'ARRAY', # ignore ''
MAN1PODS => 'HASH',
MAN3PODS => 'HASH',
META_ADD => 'HASH',
META_MERGE => 'HASH',
PL_FILES => 'HASH',
PM => 'HASH',
PMLIBDIRS => 'ARRAY',
PMLIBPARENTDIRS => 'ARRAY',
PREREQ_PM => 'HASH',
CONFIGURE_REQUIRES => 'HASH',
SKIP => 'ARRAY',
TYPEMAPS => 'ARRAY',
XS => 'HASH',
# VERSION => ['version',''], # ignore
# _KEEP_AFTER_FLUSH => '',
clean => 'HASH',
depend => 'HASH',
dist => 'HASH',
dynamic_lib=> 'HASH',
linkext => 'HASH',
macro => 'HASH',
postamble => 'HASH',
realclean => 'HASH',
test => 'HASH',
tool_autosplit => 'HASH',
# special cases where you can use makemaker_append
CCFLAGS => 'APPENDABLE',
DEFINE => 'APPENDABLE',
INC => 'APPENDABLE',
LDDLFLAGS => 'APPENDABLE',
LDFROM => 'APPENDABLE',
);
sub makemaker_args {
my ($self, %new_args) = @_;
my $args = ( $self->{makemaker_args} ||= {} );
foreach my $key (keys %new_args) {
if ($makemaker_argtype{$key}) {
if ($makemaker_argtype{$key} eq 'ARRAY') {
$args->{$key} = [] unless defined $args->{$key};
unless (ref $args->{$key} eq 'ARRAY') {
$args->{$key} = [$args->{$key}]
}
push @{$args->{$key}},
ref $new_args{$key} eq 'ARRAY'
? @{$new_args{$key}}
: $new_args{$key};
}
elsif ($makemaker_argtype{$key} eq 'HASH') {
$args->{$key} = {} unless defined $args->{$key};
foreach my $skey (keys %{ $new_args{$key} }) {
$args->{$key}{$skey} = $new_args{$key}{$skey};
}
}
elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
$self->makemaker_append($key => $new_args{$key});
}
}
else {
if (defined $args->{$key}) {
warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
}
$args->{$key} = $new_args{$key};
}
}
return $args;
}
# For mm args that take multiple space-separated args,
# append an argument to the current list.
sub makemaker_append {
my $self = shift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{$name} = defined $args->{$name}
? join( ' ', $args->{$name}, @_ )
: join( ' ', @_ );
}
sub build_subdirs {
my $self = shift;
my $subdirs = $self->makemaker_args->{DIR} ||= [];
for my $subdir (@_) {
push @$subdirs, $subdir;
}
}
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
%$realclean,
FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
sub libs {
my $self = shift;
my $libs = ref $_[0] ? shift : [ shift ];
$self->makemaker_args( LIBS => $libs );
}
sub inc {
my $self = shift;
$self->makemaker_args( INC => shift );
}
sub _wanted_t {
}
sub tests_recursive {
my $self = shift;
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
my %tests = map { $_ => 1 } split / /, ($self->tests || '');
require File::Find;
File::Find::find(
sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
$dir
);
$self->tests( join ' ', sort keys %tests );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
# Check the current Perl version
my $perl_version = $self->perl_version;
if ( $perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
# Make sure we have a new enough MakeMaker
require ExtUtils::MakeMaker;
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
# This previous attempted to inherit the version of
# ExtUtils::MakeMaker in use by the module author, but this
# was found to be untenable as some authors build releases
# using future dev versions of EU:MM that nobody else has.
# Instead, #toolchain suggests we use 6.59 which is the most
# stable version on CPAN at time of writing and is, to quote
# ribasushi, "not terminally fucked, > and tested enough".
# TODO: We will now need to maintain this over time to push
# the version up as new versions are released.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.59 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
}
# Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
$args->{NAME} =~ s/-/::/g;
$args->{VERSION} = $self->version or die <<'EOT';
ERROR: Can't determine distribution version. Please specify it
explicitly via 'version' in Makefile.PL, or set a valid $VERSION
in a module, and provide its file path via 'version_from' (or
'all_from' if you prefer) in Makefile.PL.
EOT
if ( $self->tests ) {
my @tests = split ' ', $self->tests;
my %seen;
$args->{test} = {
TESTS => (join ' ', grep {!$seen{$_}++} @tests),
};
} elsif ( $Module::Install::ExtraTests::use_extratests ) {
# Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
# So, just ignore our xt tests here.
} elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
$args->{test} = {
TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
};
}
if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = join ', ', @{$self->author || []};
}
if ( $self->makemaker(6.10) ) {
$args->{NO_META} = 1;
#$args->{NO_MYMETA} = 1;
}
if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
if ( $self->makemaker(6.31) and $self->license ) {
$args->{LICENSE} = $self->license;
}
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
($self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
# Merge both kinds of requires into BUILD_REQUIRES
my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
%$build_prereq = ( %$build_prereq,
map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
($self->configure_requires, $self->build_requires)
);
# Remove any reference to perl, BUILD_REQUIRES doesn't support it
delete $args->{BUILD_REQUIRES}->{perl};
# Delete bundled dists from prereq_pm, add it to Makefile DIR
my $subdirs = ($args->{DIR} || []);
if ($self->bundles) {
my %processed;
foreach my $bundle (@{ $self->bundles }) {
my ($mod_name, $dist_dir) = @$bundle;
delete $prereq->{$mod_name};
$dist_dir = File::Basename::basename($dist_dir); # dir for building this module
if (not exists $processed{$dist_dir}) {
if (-d $dist_dir) {
# List as sub-directory to be processed by make
push @$subdirs, $dist_dir;
}
# Else do nothing: the module is already present on the system
$processed{$dist_dir} = undef;
}
}
}
unless ( $self->makemaker('6.55_03') ) {
%$prereq = (%$prereq,%$build_prereq);
delete $args->{BUILD_REQUIRES};
}
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
if ( $self->makemaker(6.48) ) {
$args->{MIN_PERL_VERSION} = $perl_version;
}
}
if ($self->installdirs) {
warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
$args->{INSTALLDIRS} = $self->installdirs;
}
my %args = map {
( $_ => $args->{$_} ) } grep {defined($args->{$_} )
} keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
if ( my $preop = $self->admin->preop($user_preop) ) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
sub fix_up_makefile {
my $self = shift;
my $makefile_name = shift;
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
my $postamble = "# Postamble by $top_class $top_version\n"
. ($self->postamble || '');
local *MAKEFILE;
open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
eval { flock MAKEFILE, LOCK_EX };
my $makefile = do { local $/; };
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
$makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
# Module::Install will never be used to build the Core Perl
# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
$makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
seek MAKEFILE, 0, SEEK_SET;
truncate MAKEFILE, 0;
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
1;
}
sub preamble {
my ($self, $text) = @_;
$self->{preamble} = $text . $self->{preamble} if defined $text;
$self->{preamble};
}
sub postamble {
my ($self, $text) = @_;
$self->{postamble} ||= $self->admin->postamble;
$self->{postamble} .= $text if defined $text;
$self->{postamble}
}
1;
__END__
#line 544
Test-WWW-Mechanize-Catalyst-0.62/inc/Module/Install/Win32.pm 0000644 0003721 0000144 00000003403 13432565745 023163 0 ustar matthewt users #line 1
package Module::Install::Win32;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# determine if the user needs nmake, and download it if needed
sub check_nmake {
my $self = shift;
$self->load('can_run');
$self->load('get_file');
require Config;
return unless (
$^O eq 'MSWin32' and
$Config::Config{make} and
$Config::Config{make} =~ /^nmake\b/i and
! $self->can_run('nmake')
);
print "The required 'nmake' executable not found, fetching it...\n";
require File::Basename;
my $rv = $self->get_file(
url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
local_dir => File::Basename::dirname($^X),
size => 51928,
run => 'Nmake15.exe /o > nul',
check_for => 'Nmake.exe',
remove => 1,
);
die <<'END_MESSAGE' unless $rv;
-------------------------------------------------------------------------------
Since you are using Microsoft Windows, you will need the 'nmake' utility
before installation. It's available at:
http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
or
ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
Please download the file manually, save it to a directory in %PATH% (e.g.
C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
that directory, and run "Nmake15.exe" from there; that will create the
'nmake.exe' file needed by this module.
You may then resume the installation process described in README.
-------------------------------------------------------------------------------
END_MESSAGE
}
1;
Test-WWW-Mechanize-Catalyst-0.62/inc/Module/Install/Fetch.pm 0000644 0003721 0000144 00000004627 13432565745 023323 0 ustar matthewt users #line 1
package Module::Install::Fetch;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '1.19';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
LWP::Simple::mirror($args{url}, $file);
}
elsif (eval { require Net::FTP; 1 }) { eval {
# use Net::FTP to get past firewall
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
$ftp->login("anonymous", 'anonymous@example.com');
$ftp->cwd($path);
$ftp->binary;
$ftp->get($file) or (warn("$!\n"), return);
$ftp->quit;
} }
elsif (my $ftp = $self->can_run('ftp')) { eval {
# no Net::FTP, fallback to ftp.exe
require FileHandle;
my $fh = FileHandle->new;
local $SIG{CHLD} = 'IGNORE';
unless ($fh->open("|$ftp -n")) {
warn "Couldn't open ftp: $!\n";
chdir $dir; return;
}
my @dialog = split(/\n/, <<"END_FTP");
open $host
user anonymous anonymous\@example.com
cd $path
binary
get $file $file
quit
END_FTP
foreach (@dialog) { $fh->print("$_\n") }
$fh->close;
} }
else {
warn "No working 'ftp' program available!\n";
chdir $dir; return;
}
unless (-f $file) {
warn "Fetching failed: $@\n";
chdir $dir; return;
}
return if exists $args{size} and -s $file != $args{size};
system($args{run}) if exists $args{run};
unlink($file) if $args{remove};
print(((!exists $args{check_for} or -e $args{check_for})
? "done!" : "failed! ($!)"), "\n");
chdir $dir; return !$?;
}
1;
Test-WWW-Mechanize-Catalyst-0.62/CHANGES 0000644 0003721 0000144 00000013315 13432565624 017311 0 ustar matthewt users Revision history for Perl module Test::WWW::Mechanize::Catalyst:
0.62 Mon Feb 18 17:30 GMT 2019
- The latest 'mst screwed up the last release' release
0.61 Mon Feb 18 14:38 GMT 2019
- Add '.' to inc in Makefile.PL
0.60 Fri Dec 26 22:00 GMT 2014
- Make two test cases compatible with Catalyst 5.90080+ changes
to encoding (UTF8 because default).
- Added a new test case that runs only under 5.90080 and makes
sure that expected UTF8 stuff works.
0.59 Mon Jan 13 11:23 GMT 2014
- Use Class::Load instead of Class::MOP::load_class(). RT#90978
- Fix typos in POD and comments. RT#85171
0.58 Sat Jun 30 17:01 BST 2012
- Fix external server test.
- Fix infinite redirects. RT#76614
- Make fail to start server more verbose. RT#77174
- Fix test skip count. RT#77181
0.57 Wed Apr 4 10:03 BRT 2012
- Fixed RT 52270
0.56 Thu Oct 13 21:05 BRT 2011
- Add port to Host header
0.55 Tue Sep 27 19:20 BST 2011
- Set 'Host' header for remote requests too
0.54 Mon Aug 1 20:49 BST 2011
- change to make sure we support changes in Catalyst::Test introduced
in the Cataplack port.
0.53 Sun Dec 5 23:03 GMT 2010
- Fix tests to work with the upcoming psgi based Catalyst release
as $c->req->header('Host') now more accurately reflects what you
see in a real web server (i.e. the port will not be defined if it
is 80)
- Fix tests to work when the CATALYST_DEBUG environment variable is
set by explicitly setting it to 0 in tests which require it.
0.52 Mon Mar 8 01:25 GMT 2010
- Move actions out of the test applications to avoid deprecation warnings.
- POD corrections by jhannah
- Bump version dependency of Test::WWW::Mechanize to 1.54 to fix RT#44555
- Wrap checks for the appropriate plugins to skip tests inside a BEGIN
block so that they are run before the app tries to be loaded at compile
time, fixing RT#47037
0.51 Mon Mar 16 10:00 GMT 2009
- Doc updates from thejester
- User agent fixes from ANDREMAR
- Fix bug where redirect was followed on a 500 response
- All remote requests (i.e. CATALYST_SERVER env var) now use our own
mechanize object, rather than an unconfigurable one from Catalyst:Test
0.50 Tue Feb 17 09:12 GMT 2009
- Remove warning in HTTP::Cookies
- Call BUILDALL
0.50_2 Thur Feb 12 09:47 GMT 2009
- Make t/multi_content_type.t handle case when server cant be started,
which is almost always due to port in use.
0.50_1 Thur Feb 5 09:02 GMT 2009
- App classname no longer has to be passed to import:
$m = T::W::M::C->new(catalyst_app => 'Catty')
now works.
- Can now use TWMC two test two different apps in the same perl
interpreter due to the above change
- Removed Test::WWW::Mechanize::Catalyst::Aux package as it isn't needed
any more
- Add 'host' accessor for white-label testing
- Moosification
- Can now test against remote CATALYST_SERVER without having to load the
app class
0.45 Mon Nov 24 20:39:19 GMT 2008
- be forwards-compatible with Catalyst 5.80's virtual
domain testing (thanks Jason Gottshall)
0.44 Mon Oct 27 13:48:22 GMT 2008
- fix longstanding bug with recent LWP, requiring
WWW::Mechanize 1.50 (thanks to petdance, mst, dakkar)
- add machine- and human-readable license, add abstract
0.43 Mon Aug 18 15:42:03 BST 2008
- add missing prereqs to Catalyst::Plugin::Session::State::Cookie
and Catalyst::Plugin::Session::Store::Dummy (thanks kd)
0.42 Tue Apr 29 20:25:06 BST 2008
- stop multi_content_type.t killing smoke testing
(patch by Andreas König)
- fix a case where HTTP::Cookies dies when trying to
extract_cookies (patch by Andreas Marienborg)
- add Test::Exception as a prerequisite
0.41 Mon Sep 17 20:28:59 BST 2007
- fix to cope with gzipped content and the test from the
rt.cpan queue about multiple content types
(patch by Ash Berlin)
0.40 Tue Aug 21 20:51:13 BST 2007
- external requests (as per last release) are now only allowed
if you set allow_external (sorry about that)
0.39 Sat Aug 4 08:01:38 BST 2007
- external requests are now allowed (patch by Edmund von der Burg)
- remove Build.PL
0.38 Sat Jun 30 14:07:24 BST 2007
- document and test that you can use URLs without schema
or hostname
- add debug screen error to test diagnostics (patch by
Jonathan Swartz)
- add basic authentication support (patch by Gareth Kirwan)
- add test for charset=utf-8 (patch by Chris Dolan)
- added CATALYST_SERVER mention in the documentation
(patch by Kieren Diment)
0.37 Tue Jun 6 08:54:07 BST 2006
- patch to follow LWP's $m->requests_redirectable() and small
docpatch (thanks to Daniel McBrearty)
- mention Catalyst::Test (thanks to guest)
0.36 Mon Apr 17 11:27:17 BST 2006
- perltidy
- Catalyst debug screens are now failures (thanks to Kieren Diment)
0.35 Tue Jan 22 17:06:00 GMT 2006
- handle redirects (patch by Mark Fowler)
0.33 Tue Jun 7 17:38:45 BST 2005
- we need at least version 1.04 of Test::WWW::Mechanize
(spotted by Jesse Vincent, patch by Shlomi Fish)
0.32 Tue May 3 16:14:40 BST 2005
- removed 'use Image::Size' in test, as spotted by SMPETERS
0.31 Sun Apr 17 10:30:18 BST 2005
- update for Catalyst 5.00
0.30 Fri Mar 25 04:34:50 GMT 2005
- add Test::WWW::Mechanize to prereqs
- remove useless "use URI"
- "borrow" lots of docs from Test::WWW::Mechanize
- Catalyst 4.30 adds support for HTTP::Request objects in
Catalyst::Test::request(), so use it (thanks to Christian Hansen)
0.29 Thu Mar 17 22:42:04 EST 2005
- initial release
Test-WWW-Mechanize-Catalyst-0.62/Makefile.PL 0000644 0003721 0000144 00000002262 13432565737 020274 0 ustar matthewt users #!perl
BEGIN { push @INC, '.' unless $INC[-1] eq '.' }
use inc::Module::Install 0.87;
use strict;
use warnings;
name 'Test-WWW-Mechanize-Catalyst';
perl_version '5.008004';
all_from 'lib/Test/WWW/Mechanize/Catalyst.pm';
requires 'Catalyst' => '5.90';
requires 'Class::Load' => '0.19';
requires 'LWP' => '5.816';
requires 'Test::WWW::Mechanize' => '1.14';
requires 'WWW::Mechanize' => '1.54';
requires 'Moose' => '0.67';
requires 'namespace::clean' => '0.09';
test_requires 'Catalyst::Plugin::Session::State::Cookie' => '0';
test_requires 'Catalyst::Plugin::Session::Store::Dummy' => '0';
test_requires 'Test::Exception' => '0';
test_requires 'Test::More' => '0.88';
test_requires 'Test::utf8' => '0';
if ($Module::Install::AUTHOR) {
system('pod2text lib/Test/WWW/Mechanize/Catalyst.pm > README');
}
resources repository => 'git://git.shadowcat.co.uk/catagits/Test-WWW-Mechanize-Catalyst.git';
WriteAll;
Test-WWW-Mechanize-Catalyst-0.62/MANIFEST 0000644 0003721 0000144 00000001205 13432344205 017430 0 ustar matthewt users CHANGES
inc/Module/Install.pm
inc/Module/Install/Base.pm
inc/Module/Install/Can.pm
inc/Module/Install/Fetch.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/Test/WWW/Mechanize/Catalyst.pm
Makefile.PL
MANIFEST This list of files
META.yml
README
t/auth-test.t
t/cookies.t
t/decoded_content.t
t/lib/Catty.pm
t/lib/Catty/Controller/Root.pm
t/lib/CattySession.pm
t/lib/CattySession/Controller/Root.pm
t/lib/ExternalCatty.pm
t/lib/ExternalCatty/Controller/Root.pm
t/multi_content_type.t
t/pod.t
t/redirect.t
t/simple.t
t/two_app.t
t/useragent.t
t/utf8.t
t/white_label.t
Test-WWW-Mechanize-Catalyst-0.62/META.yml 0000644 0003721 0000144 00000001650 13432565745 017572 0 ustar matthewt users ---
abstract: 'Test::WWW::Mechanize for Catalyst'
author:
- 'Ash Berlin C<< >> (current maintainer)'
build_requires:
Catalyst::Plugin::Session::State::Cookie: 0
Catalyst::Plugin::Session::Store::Dummy: 0
ExtUtils::MakeMaker: 6.59
Test::Exception: 0
Test::More: 0.88
Test::utf8: 0
configure_requires:
ExtUtils::MakeMaker: 6.59
distribution_type: module
dynamic_config: 1
generated_by: 'Module::Install version 1.19'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: Test-WWW-Mechanize-Catalyst
no_index:
directory:
- inc
- t
requires:
Catalyst: 5.90
Class::Load: 0.19
LWP: 5.816
Moose: 0.67
Test::WWW::Mechanize: 1.14
WWW::Mechanize: 1.54
namespace::clean: 0.09
perl: 5.8.4
resources:
license: http://dev.perl.org/licenses/
repository: git://git.shadowcat.co.uk/catagits/Test-WWW-Mechanize-Catalyst.git
version: 0.62
Test-WWW-Mechanize-Catalyst-0.62/lib/ 0000755 0003721 0000144 00000000000 13432566046 017060 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/lib/Test/ 0000755 0003721 0000144 00000000000 13432566046 017777 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/lib/Test/WWW/ 0000755 0003721 0000144 00000000000 13432566046 020463 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/lib/Test/WWW/Mechanize/ 0000755 0003721 0000144 00000000000 13432566046 022366 5 ustar matthewt users Test-WWW-Mechanize-Catalyst-0.62/lib/Test/WWW/Mechanize/Catalyst.pm 0000644 0003721 0000144 00000041630 13432565632 024514 0 ustar matthewt users package Test::WWW::Mechanize::Catalyst;
use Moose;
use Carp qw/croak/;
require Catalyst::Test; # Do not call import
use Class::Load qw(load_class is_class_loaded);
use Encode qw();
use HTML::Entities;
use Test::WWW::Mechanize;
extends 'Test::WWW::Mechanize', 'Moose::Object';
#use namespace::clean -except => 'meta';
our $VERSION = '0.62';
our $APP_CLASS;
my $Test = Test::Builder->new();
has catalyst_app => (
is => 'ro',
predicate => 'has_catalyst_app',
);
has allow_external => (
is => 'rw',
isa => 'Bool',
default => 0
);
has host => (
is => 'rw',
isa => 'Str',
clearer => 'clear_host',
predicate => 'has_host',
);
sub new {
my $class = shift;
my $args = ref $_[0] ? $_[0] : { @_ };
# Dont let LWP complain about options for our attributes
my %attr_options = map {
my $n = $_->init_arg;
defined $n && exists $args->{$n}
? ( $n => delete $args->{$n} )
: ( );
} $class->meta->get_all_attributes;
my $obj = $class->SUPER::new(%$args);
my $self = $class->meta->new_object(
__INSTANCE__ => $obj,
($APP_CLASS ? (catalyst_app => $APP_CLASS) : () ),
%attr_options
);
$self->BUILDALL;
return $self;
}
sub BUILD {
my ($self) = @_;
unless ($ENV{CATALYST_SERVER}) {
croak "catalyst_app attribute is required unless CATALYST_SERVER env variable is set"
unless $self->has_catalyst_app;
load_class($self->catalyst_app)
unless (is_class_loaded($self->catalyst_app));
}
}
sub _make_request {
my ( $self, $request, $arg, $size, $previous) = @_;
my $response = $self->_do_catalyst_request($request);
$response->header( 'Content-Base', $response->request->uri )
unless $response->header('Content-Base');
$self->cookie_jar->extract_cookies($response) if $self->cookie_jar;
# fail tests under the Catalyst debug screen
if ( !$self->{catalyst_debug}
&& $response->code == 500
&& $response->content =~ /on Catalyst \d+\.\d+/ )
{
my ($error)
= ( $response->content =~ /(.*?)<\/code>/s );
$error ||= "unknown error";
decode_entities($error);
$Test->diag("Catalyst error screen: $error");
$response->content('');
$response->content_type('');
}
# NOTE: cargo-culted redirect checking from LWP::UserAgent:
$response->previous($previous) if $previous;
my $redirects = defined $response->redirects ? $response->redirects : 0;
if ($redirects > 0 and $redirects >= $self->max_redirect) {
return $self->_redirect_loop_detected($response);
}
# check if that was a redirect
if ( $response->header('Location')
&& $response->is_redirect
&& $self->redirect_ok( $request, $response ) )
{
return $self->_redirect_loop_detected($response) if $self->max_redirect <= 0;
# TODO: this should probably create the request by cloning the original
# request and modifying it as LWP::UserAgent::request does. But for now...
# *where* do they want us to redirect to?
my $location = $response->header('Location');
# no-one *should* be returning non-absolute URLs, but if they
# are then we'd better cope with it. Let's create a new URI, using
# our request as the base.
my $uri = URI->new_abs( $location, $request->uri )->as_string;
my $referral = HTTP::Request->new( GET => $uri );
return $self->request( $referral, $arg, $size, $response );
} else {
$response->{_raw_content} = $response->content;
}
return $response;
}
sub _redirect_loop_detected {
my ( $self, $response ) = @_;
$response->header("Client-Warning" =>
"Redirect loop detected (max_redirect = " . $self->max_redirect . ")");
$response->{_raw_content} = $response->content;
return $response;
}
sub _set_host_header {
my ( $self, $request ) = @_;
# If there's no Host header, set one.
unless ($request->header('Host')) {
my $host = $self->has_host
? $self->host
: $request->uri->host;
$host .= ':'.$request->uri->_port if $request->uri->_port;
$request->header('Host', $host);
}
}
sub _do_catalyst_request {
my ($self, $request) = @_;
my $uri = $request->uri;
$uri->scheme('http') unless defined $uri->scheme;
$uri->host('localhost') unless defined $uri->host;
$request = $self->prepare_request($request);
$self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
# Woe betide anyone who unsets CATALYST_SERVER
return $self->_do_remote_request($request)
if $ENV{CATALYST_SERVER};
$self->_set_host_header($request);
my $res = $self->_check_external_request($request);
return $res if $res;
my @creds = $self->get_basic_credentials( "Basic", $uri );
$request->authorization_basic( @creds ) if @creds;
require Catalyst;
my $response = $Catalyst::VERSION >= 5.89000 ?
Catalyst::Test::_local_request($self->{catalyst_app}, $request) :
Catalyst::Test::local_request($self->{catalyst_app}, $request);
# LWP would normally do this, but we don't get down that far.
$response->request($request);
return $response
}
sub _check_external_request {
my ($self, $request) = @_;
# If there's no host then definitley not an external request.
$request->uri->can('host_port') or return;
if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) {
return $self->SUPER::_make_request($request);
}
return undef;
}
sub _do_remote_request {
my ($self, $request) = @_;
my $res = $self->_check_external_request($request);
return $res if $res;
my $server = URI->new( $ENV{CATALYST_SERVER} );
if ( $server->path =~ m|^(.+)?/$| ) {
my $path = $1;
$server->path("$path") if $path; # need to be quoted
}
# the request path needs to be sanitised if $server is using a
# non-root path due to potential overlap between request path and
# response path.
if ($server->path) {
# If request path is '/', we have to add a trailing slash to the
# final request URI
my $add_trailing = $request->uri->path eq '/';
my @sp = split '/', $server->path;
my @rp = split '/', $request->uri->path;
shift @sp;shift @rp; # leading /
if (@rp) {
foreach my $sp (@sp) {
$sp eq $rp[0] ? shift @rp : last
}
}
$request->uri->path(join '/', @rp);
if ( $add_trailing ) {
$request->uri->path( $request->uri->path . '/' );
}
}
$request->uri->scheme( $server->scheme );
$request->uri->host( $server->host );
$request->uri->port( $server->port );
$request->uri->path( $server->path . $request->uri->path );
$self->_set_host_header($request);
return $self->SUPER::_make_request($request);
}
sub import {
my ($class, $app) = @_;
if (defined $app) {
load_class($app)
unless (is_class_loaded($app));
$APP_CLASS = $app;
}
}
1;
__END__
=head1 NAME
Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
=head1 SYNOPSIS
# We're in a t/*.t test script...
use Test::WWW::Mechanize::Catalyst;
# To test a Catalyst application named 'Catty':
my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
$mech->get_ok("/"); # no hostname needed
is($mech->ct, "text/html");
$mech->title_is("Root", "On the root page");
$mech->content_contains("This is the root page", "Correct content");
$mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
# ... and all other Test::WWW::Mechanize methods
# White label site testing
$mech->host("foo.com");
$mech->get_ok("/");
=head1 DESCRIPTION
L is an elegant MVC Web Application Framework.
L is a subclass of L that incorporates
features for web application testing. The L
module meshes the two to allow easy testing of L applications without
needing to start up a web server.
Testing web applications has always been a bit tricky, normally
requiring starting a web server for your application and making real HTTP
requests to it. This module allows you to test L web
applications but does not require a server or issue HTTP
requests. Instead, it passes the HTTP request object directly to
L. Thus you do not need to use a real hostname:
"http://localhost/" will do. However, this is optional. The following
two lines of code do exactly the same thing:
$mech->get_ok('/action');
$mech->get_ok('http://localhost/action');
Links which do not begin with / or are not for localhost can be handled
as normal Web requests - this is handy if you have an external
single sign-on system. You must set allow_external to true for this:
$mech->allow_external(1);
You can also test a remote server by setting the environment variable
CATALYST_SERVER; for example:
$ CATALYST_SERVER=http://example.com/myapp prove -l t
will run the same tests on the application running at
http://example.com/myapp regardless of whether or not you specify
http:://localhost for Test::WWW::Mechanize::Catalyst.
Furthermore, if you set CATALYST_SERVER, the server will be regarded
as a remote server even if your links point to localhost. Thus, you
can use Test::WWW::Mechanize::Catalyst to test your live webserver
running on your local machine, if you need to test aspects of your
deployment environment (for example, configuration options in an
http.conf file) instead of just the Catalyst request handling.
This makes testing fast and easy. L provides
functions for common web testing scenarios. For example:
$mech->get_ok( $page );
$mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
$mech->content_contains( "Andy Lester", "My name somewhere" );
$mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
This module supports cookies automatically.
To use this module you must pass it the name of the application. See
the SYNOPSIS above.
Note that Catalyst has a special development feature: the debug
screen. By default this module will treat responses which are the
debug screen as failures. If you actually want to test debug screens,
please use:
$mech->{catalyst_debug} = 1;
An alternative to this module is L.
=head1 CONSTRUCTOR
=head2 new
Behaves like, and calls, L's C method. Any params
passed in get passed to WWW::Mechanize's constructor. Note that we
need to pass the name of the Catalyst application to the "use":
use Test::WWW::Mechanize::Catalyst 'Catty';
my $mech = Test::WWW::Mechanize::Catalyst->new;
=head1 METHODS
=head2 allow_external
Links which do not begin with / or are not for localhost can be handled
as normal Web requests - this is handy if you have an external
single sign-on system. You must set allow_external to true for this:
$mech->allow_external(1);
head2 catalyst_app
The name of the Catalyst app which we are testing against. Read-only.
=head2 host
The host value to set the "Host:" HTTP header to, if none is present already in
the request. If not set (default) then Catalyst::Test will set this to
localhost:80
=head2 clear_host
Unset the host attribute.
=head2 has_host
Do we have a value set for the host attribute
=head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
A wrapper around WWW::Mechanize's get(), with similar options, except the
second argument needs to be a hash reference, not a hash. Returns true or
false.
=head2 $mech->title_is( $str [, $desc ] )
Tells if the title of the page is the given string.
$mech->title_is( "Invoice Summary" );
=head2 $mech->title_like( $regex [, $desc ] )
Tells if the title of the page matches the given regex.
$mech->title_like( qr/Invoices for (.+)/
=head2 $mech->title_unlike( $regex [, $desc ] )
Tells if the title of the page does NOT match the given regex.
$mech->title_unlike( qr/Invoices for (.+)/
=head2 $mech->content_is( $str [, $desc ] )
Tells if the content of the page matches the given string.
=head2 $mech->content_contains( $str [, $desc ] )
Tells if the content of the page contains I<$str>.
=head2 $mech->content_lacks( $str [, $desc ] )
Tells if the content of the page lacks I<$str>.
=head2 $mech->content_like( $regex [, $desc ] )
Tells if the content of the page matches I<$regex>.
=head2 $mech->content_unlike( $regex [, $desc ] )
Tells if the content of the page does NOT match I<$regex>.
=head2 $mech->page_links_ok( [ $desc ] )
Follow all links on the current page and test for HTTP status 200
$mech->page_links_ok('Check all links');
=head2 $mech->page_links_content_like( $regex,[ $desc ] )
Follow all links on the current page and test their contents for I<$regex>.
$mech->page_links_content_like( qr/foo/,
'Check all links contain "foo"' );
=head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
Follow all links on the current page and test their contents do not
contain the specified regex.
$mech->page_links_content_unlike(qr/Restricted/,
'Check all links do not contain Restricted');
=head2 $mech->links_ok( $links [, $desc ] )
Check the current page for specified links and test for HTTP status
200. The links may be specified as a reference to an array containing
L objects, an array of URLs, or a scalar URL
name.
my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
$mech->links_ok( \@links, 'Check all links for cnn.com' );
my @links = qw( index.html search.html about.html );
$mech->links_ok( \@links, 'Check main links' );
$mech->links_ok( 'index.html', 'Check link to index' );
=head2 $mech->link_status_is( $links, $status [, $desc ] )
Check the current page for specified links and test for HTTP status
passed. The links may be specified as a reference to an array
containing L objects, an array of URLs, or a
scalar URL name.
my @links = $mech->links();
$mech->link_status_is( \@links, 403,
'Check all links are restricted' );
=head2 $mech->link_status_isnt( $links, $status [, $desc ] )
Check the current page for specified links and test for HTTP status
passed. The links may be specified as a reference to an array
containing L objects, an array of URLs, or a
scalar URL name.
my @links = $mech->links();
$mech->link_status_isnt( \@links, 404,
'Check all links are not 404' );
=head2 $mech->link_content_like( $links, $regex [, $desc ] )
Check the current page for specified links and test the content of
each against I<$regex>. The links may be specified as a reference to
an array containing L objects, an array of URLs,
or a scalar URL name.
my @links = $mech->links();
$mech->link_content_like( \@links, qr/Restricted/,
'Check all links are restricted' );
=head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
Check the current page for specified links and test that the content of each
does not match I<$regex>. The links may be specified as a reference to
an array containing L objects, an array of URLs,
or a scalar URL name.
my @links = $mech->links();
$mech->link_content_like( \@links, qr/Restricted/,
'Check all links are restricted' );
=head2 follow_link_ok( \%parms [, $comment] )
Makes a C call and executes tests on the results.
The link must be found, and then followed successfully. Otherwise,
this test fails.
I<%parms> is a hashref containing the params to pass to C.
Note that the params to C are a hash whereas the parms to
this function are a hashref. You have to call this function like:
$agent->follow_link_ok( {n=>3}, "looking for 3rd link" );
As with other test functions, C<$comment> is optional. If it is supplied
then it will display when running the test harness in verbose mode.
Returns true value if the specified link was found and followed
successfully. The HTTP::Response object returned by follow_link()
is not available.
=head1 CAVEATS
=head2 External Redirects and allow_external
If you use non-fully qualified urls in your test scripts (i.e. anything without
a host, such as C<< ->get_ok( "/foo") >> ) and your app redirects to an
external URL, expect to be bitten once you come back to your application's urls
(it will try to request them on the remote server). This is due to a limitation
in WWW::Mechanize.
One workaround for this is that if you are expecting to redirect to an external
site, clone the TWMC object and use the cloned object for the external
redirect.
=head1 SEE ALSO
Related modules which may be of interest: L,
L, L.
=head1 AUTHOR
Ash Berlin C<< >> (current maintainer)
Original Author: Leon Brocard, C<< >>
=head1 COPYRIGHT
Copyright (C) 2005-9, Leon Brocard
=head1 LICENSE
This module is free software; you can redistribute it or modify it
under the same terms as Perl itself.