[Catalyst-commits] r13030 - in
Test-WWW-Mechanize-Catalyst/trunk/t/lib: . Catty
Catty/Controller CattySession CattySession/Controller
ExternalCatty ExternalCatty/Controller
t0m at dev.catalyst.perl.org
t0m at dev.catalyst.perl.org
Mon Mar 8 01:17:29 GMT 2010
Author: t0m
Date: 2010-03-08 01:17:29 +0000 (Mon, 08 Mar 2010)
New Revision: 13030
Added:
Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty/
Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty/Controller/
Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty/Controller/Root.pm
Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession/
Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession/Controller/
Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession/Controller/Root.pm
Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty/
Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty/Controller/
Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty/Controller/Root.pm
Log:
Actually add the new bits for rearranged apps
Added: Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty/Controller/Root.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty/Controller/Root.pm (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty/Controller/Root.pm 2010-03-08 01:17:29 UTC (rev 13030)
@@ -0,0 +1,141 @@
+package Catty::Controller::Root;
+
+use strict;
+use warnings;
+
+use base qw/ Catalyst::Controller /;
+
+use Cwd;
+use MIME::Base64;
+use Encode ();
+
+__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') || "<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;
+
Added: Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession/Controller/Root.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession/Controller/Root.pm (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession/Controller/Root.pm 2010-03-08 01:17:29 UTC (rev 13030)
@@ -0,0 +1,47 @@
+package CattySession::Controller::Root;
+
+use strict;
+use warnings;
+
+use base qw/ Catalyst::Controller /;
+
+__PACKAGE__->config( namespace => '' );
+
+sub auto : Private {
+ my ( $self, $context ) = @_;
+ if ( $context->session ) {
+ return 1;
+ }
+
+}
+
+sub default : Private {
+ my ( $self, $context ) = @_;
+ my $html = html( "Root", "This is the root page" );
+ $context->response->content_type("text/html");
+ $context->response->output($html);
+}
+
+sub name : Global {
+ my ($self, $c) = @_;
+
+ my $html = html( $c->config->{name}, "This is the die page" );
+ $c->response->content_type("text/html");
+ $c->response->output($html);
+}
+
+
+sub html {
+ my ( $title, $body ) = @_;
+ return qq{
+<html>
+<head><title>$title</title></head>
+<body>
+$body
+<a href="/hello/">Hello</a>.
+</body></html>
+};
+}
+
+1;
+
Added: Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty/Controller/Root.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty/Controller/Root.pm (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty/Controller/Root.pm 2010-03-08 01:17:29 UTC (rev 13030)
@@ -0,0 +1,37 @@
+package ExternalCatty::Controller::Root;
+use strict;
+use warnings;
+
+use base qw/ Catalyst::Controller /;
+
+__PACKAGE__->config( namespace => '' );
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->response->content_type('text/html; charset=utf-8');
+ $c->response->output( html( 'Root', 'Hello, test ☺!' ) );
+}
+
+# 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>
+];
+}
+
+1;
+
More information about the Catalyst-commits
mailing list