t/lib/Catty.pm

   1 package Catty;
   2
   3 use strict;
   4 use warnings;
   5
   6 #use Catalyst;
   7 use Catalyst;
   8 use Cwd;
   9 use MIME::Base64;
  10 use Encode qw//;
  11
  12 our $VERSION = '0.01';
  13
  14 Catty->config(
  15     name => 'Catty',
  16     root => cwd . '/t/root',
  17 );
  18 Catty->setup();
  19 Catty->log->levels("fatal");
  20
  21 sub default : Private {
  22     my ( $self, $context ) = @_;
  23     my $html = html( "Root", "This is the root page" );
  24     $context->response->content_type("text/html");
  25     $context->response->output($html);
  26 }
  27
  28 sub hello : Global {
  29     my ( $self, $context ) = @_;
  30     my $str = Encode::encode('utf-8', "\x{263A}"); # ☺
  31     my $html = html( "Hello", "Hi there! $str" );
  32     $context->response->content_type("text/html; charset=utf-8");
  33     $context->response->output($html);
  34 }
  35
  36 # absolute redirect
  37 sub hi : Global {
  38     my ( $self, $context ) = @_;
  39     my $where = $context->uri_for('hello');
  40     $context->response->redirect($where);
  41     return;
  42 }
  43
  44 # partial (relative) redirect
  45 sub greetings : Global {
  46     my ( $self, $context ) = @_;
  47     $context->response->redirect("hello");
  48     return;
  49 }
  50
  51 # redirect to a redirect
  52 sub bonjour : Global {
  53     my ( $self, $context ) = @_;
  54     my $where = $context->uri_for('hi');
  55     $context->response->redirect($where);
  56     return;
  57 }
  58
  59 sub check_auth_basic : Global {
  60     my ( $self, $context ) = @_;
  61
  62     my $auth = $context->req->headers->authorization;
  63     ($auth) = $auth =~ /Basic\s(.*)/i;
  64     $auth = decode_base64($auth);
  65
  66     if ( $auth eq "user:pass" ) {
  67         my $html = html( "Auth", "This is the auth page" );
  68         $context->response->content_type("text/html");
  69         $context->response->output($html);
  70         return $context;
  71     } else {
  72         my $html = html( "Auth", "Auth Failed!" );
  73         $context->response->content_type("text/html");
  74         $context->response->output($html);
  75         $context->response->status("401");
  76         return $context;
  77     }
  78 }
  79
  80 sub redirect_with_500 : Global {
  81     my ( $self, $c ) = @_;
  82     $DB::single = 1;
  83     $c->res->redirect( $c->uri_for("/bonjour"));
  84     die "erk!";
  85 }
  86
  87 sub die : Global {
  88     my ( $self, $context ) = @_;
  89     my $html = html( "Die", "This is the die page" );
  90     $context->response->content_type("text/html");
  91     $context->response->output($html);
  92     die "erk!";
  93 }
  94
  95 sub name : Global {
  96     my ($self, $c) = @_;
  97
  98     my $html = html( $c->config->{name}, "This is the die page" );
  99     $c->response->content_type("text/html");
 100     $c->response->output($html);
 101 }
 102
 103 sub host : Global {
 104     my ($self, $c) = @_;
 105
 106     my $host = $c->req->header('Host') || "<undef>";
 107     my $html = html( $c->config->{name}, "Host: $host" );
 108     $c->response->content_type("text/html");
 109     $c->response->output($html);
 110 }
 111
 112 sub html {
 113     my ( $title, $body ) = @_;
 114     return qq{
 115 <html>
 116 <head><title>$title</title></head>
 117 <body>
 118 $body
 119 <a href="/hello/">Hello</a>.
 120 </body></html>
 121 };
 122 }
 123
 124 sub gzipped : Global {
 125     my ( $self, $c ) = @_;
 126
 127   # If done properly this test should check the accept-encoding header, but we
 128   # control both ends, so just always gzip the response.
 129     require Compress::Zlib;
 130
 131     my $html = html( "Hello", "Hi there! ☺" );
 132     $c->response->content_type("text/html; charset=utf-8");
 133     $c->response->output( Compress::Zlib::memGzip($html) );
 134     $c->response->content_encoding('gzip');
 135     $c->response->headers->push_header( 'Vary', 'Accept-Encoding' );
 136 }
 137
 138 sub user_agent : Global {
 139     my ( $self, $c ) = @_;
 140
 141     my $html = html($c->req->user_agent, $c->req->user_agent);
 142     $c->response->content_type("text/html; charset=utf-8");
 143     $c->response->output( $html );
 144
 145 }
 146
 147 1;
 148