Test-WWW-Mechanize-Catalyst-0.59/0000755000175000017500000000000012264755650016063 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/lib/0000755000175000017500000000000012264755650016631 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/lib/Test/0000755000175000017500000000000012264755650017550 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/lib/Test/WWW/0000755000175000017500000000000012264755650020234 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/lib/Test/WWW/Mechanize/0000755000175000017500000000000012264755650022137 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/lib/Test/WWW/Mechanize/Catalyst.pm0000644000175000017500000004163012264746170024262 0ustar ilmariilmaripackage 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.59'; 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. Test-WWW-Mechanize-Catalyst-0.59/MANIFEST0000644000175000017500000000117412264755536017222 0ustar ilmariilmariCHANGES 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/white_label.t Test-WWW-Mechanize-Catalyst-0.59/README0000644000175000017500000002432212264755533016746 0ustar ilmariilmariNAME 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.59/t/0000755000175000017500000000000012264755650016326 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/t/auth-test.t0000644000175000017500000000073112264745316020430 0ustar ilmariilmari#!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.59/t/lib/0000755000175000017500000000000012264755650017074 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/t/lib/Catty/0000755000175000017500000000000012264755650020160 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/t/lib/Catty/Controller/0000755000175000017500000000000012264755650022303 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/t/lib/Catty/Controller/Root.pm0000644000175000017500000000746512264745316023576 0ustar ilmariilmaripackage 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); } # 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.59/t/lib/ExternalCatty/0000755000175000017500000000000012264755650021663 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/t/lib/ExternalCatty/Controller/0000755000175000017500000000000012264755650024006 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/t/lib/ExternalCatty/Controller/Root.pm0000644000175000017500000000167212264745316025273 0ustar ilmariilmaripackage 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 ☺!' ) ); } # 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.59/t/lib/CattySession.pm0000644000175000017500000000037412264745316022064 0ustar ilmariilmaripackage 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.59/t/lib/ExternalCatty.pm0000644000175000017500000000225412264745316022222 0ustar ilmariilmaripackage 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.59/t/lib/Catty.pm0000644000175000017500000000031412264745316020512 0ustar ilmariilmaripackage 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.59/t/lib/CattySession/0000755000175000017500000000000012264755650021524 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/t/lib/CattySession/Controller/0000755000175000017500000000000012264755650023647 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/t/lib/CattySession/Controller/Root.pm0000644000175000017500000000147312264745316025133 0ustar ilmariilmaripackage 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.59/t/multi_content_type.t0000644000175000017500000000336212264745316022442 0ustar ilmariilmari#!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.59/t/redirect.t0000644000175000017500000000502512264745316020314 0ustar ilmariilmari#!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.59/t/white_label.t0000644000175000017500000000054712264745316020776 0ustar ilmariilmariuse 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.59/t/cookies.t0000644000175000017500000000105412264745316020145 0ustar ilmariilmari#!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.59/t/simple.t0000644000175000017500000000405212264745316020003 0ustar ilmariilmari#!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.59/t/useragent.t0000644000175000017500000000055012264745316020506 0ustar ilmariilmari#!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.59/t/decoded_content.t0000644000175000017500000000052612264745316021635 0ustar ilmariilmari#!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.59/t/two_app.t0000644000175000017500000000116312264745316020163 0ustar ilmariilmariuse 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.59/t/pod.t0000644000175000017500000000021512264745316017271 0ustar ilmariilmari#!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.59/Makefile.PL0000644000175000017500000000220212264745316020027 0ustar ilmariilmari#!perl 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.59/inc/0000755000175000017500000000000012264755650016634 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/inc/Module/0000755000175000017500000000000012264755650020061 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/inc/Module/Install/0000755000175000017500000000000012264755650021467 5ustar ilmariilmariTest-WWW-Mechanize-Catalyst-0.59/inc/Module/Install/Fetch.pm0000644000175000017500000000462712264755533023067 0ustar ilmariilmari#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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.59/inc/Module/Install/Can.pm0000644000175000017500000000615712264755533022537 0ustar ilmariilmari#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.06'; @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; 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 236 Test-WWW-Mechanize-Catalyst-0.59/inc/Module/Install/Metadata.pm0000644000175000017500000004327712264755532023561 0ustar ilmariilmari#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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 hashs 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.59/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612264755533023560 0ustar ilmariilmari#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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.59/inc/Module/Install/Win32.pm0000644000175000017500000000340312264755533022727 0ustar ilmariilmari#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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.59/inc/Module/Install/Makefile.pm0000644000175000017500000002743712264755533023557 0ustar ilmariilmari#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.06'; @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-seperated 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.59/inc/Module/Install/Base.pm0000644000175000017500000000214712264755532022702 0ustar ilmariilmari#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # 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.59/inc/Module/Install.pm0000644000175000017500000003013512264755532022026 0ustar ilmariilmari#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.005; 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.06'; # 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::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); 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::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $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( 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($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD 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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _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.59/META.yml0000644000175000017500000000165012264755533017336 0ustar ilmariilmari--- 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.06' 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.59 Test-WWW-Mechanize-Catalyst-0.59/CHANGES0000644000175000017500000001245412264746214017060 0ustar ilmariilmariRevision history for Perl module Test::WWW::Mechanize::Catalyst: 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