[Catalyst-commits] r13029 - Test-WWW-Mechanize-Catalyst/trunk/t/lib
t0m at dev.catalyst.perl.org
t0m at dev.catalyst.perl.org
Mon Mar 8 01:08:29 GMT 2010
Author: t0m
Date: 2010-03-08 01:08:29 +0000 (Mon, 08 Mar 2010)
New Revision: 13029
Modified:
Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm
Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession.pm
Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm
Log:
Fix appclass actions in the tests
Modified: Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm 2010-03-08 00:56:38 UTC (rev 13028)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm 2010-03-08 01:08:29 UTC (rev 13029)
@@ -3,146 +3,16 @@
use strict;
use warnings;
-#use Catalyst;
use Catalyst;
+
use Cwd;
-use MIME::Base64;
-use Encode qw//;
-our $VERSION = '0.01';
-
-Catty->config(
+__PACKAGE__->config(
name => 'Catty',
root => cwd . '/t/root',
);
-Catty->setup();
-Catty->log->levels("fatal");
+__PACKAGE__->setup();
+__PACKAGE__->log->levels("fatal");
-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') || "<undef>";
- 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{
-<html>
-<head><title>$title</title></head>
-<body>
-$body
-<a href="/hello/">Hello</a>.
-</body></html>
-};
-}
-
-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 = 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 );
-
-}
-
1;
Modified: Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession.pm 2010-03-08 00:56:38 UTC (rev 13028)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession.pm 2010-03-08 01:08:29 UTC (rev 13029)
@@ -1,60 +1,21 @@
package CattySession;
use strict;
+use warnings;
-#use Catalyst;
use Catalyst qw/
Session
Session::State::Cookie
Session::Store::Dummy
- /;
+/;
use Cwd;
-use MIME::Base64;
-our $VERSION = '0.01';
-
-CattySession->config(
+__PACKAGE__->config(
name => 'CattySession',
root => cwd . '/t/root',
);
-CattySession->setup();
+__PACKAGE__->setup;
-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{
-<html>
-<head><title>$title</title></head>
-<body>
-$body
-<a href="/hello/">Hello</a>.
-</body></html>
-};
-}
-
1;
Modified: Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm 2010-03-08 00:56:38 UTC (rev 13028)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm 2010-03-08 01:08:29 UTC (rev 13029)
@@ -2,38 +2,10 @@
use strict;
use warnings;
use Catalyst qw/-Engine=HTTP/;
-our $VERSION = '0.01';
__PACKAGE__->config( name => 'ExternalCatty' );
__PACKAGE__->setup;
-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[
-<html>
-<head>
- <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
- <title>$title</title>
-</head>
-<body>$body</body>
-</html>
-];
-}
-
# The Cat HTTP server background option is useless here :-(
# Thus we have to provide our own background method.
sub background {
More information about the Catalyst-commits
mailing list