t/lib/Catty.pm

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