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("fatal");
  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 name : Global {
  88     my ($self, $c) = @_;
  89
  90     my $html = html( $c->config->{name}, "This is the die page" );
  91     $c->response->content_type("text/html");
  92     $c->response->output($html);
  93 }
  94
  95 sub host : Global {
  96     my ($self, $c) = @_;
  97
  98     my $host = $c->req->header('Host') || "<undef>";
  99     my $html = html( $c->config->{name}, "Host: $host" );
 100     $c->response->content_type("text/html");
 101     $c->response->output($html);
 102 }
 103
 104 sub html {
 105     my ( $title, $body ) = @_;
 106     return qq{
 107 <html>
 108 <head><title>$title</title></head>
 109 <body>
 110 $body
 111 <a href="/hello/">Hello</a>.
 112 </body></html>
 113 };
 114 }
 115
 116 sub gzipped : Global {
 117     my ( $self, $c ) = @_;
 118
 119   # If done properly this test should check the accept-encoding header, but we
 120   # control both ends, so just always gzip the response.
 121     require Compress::Zlib;
 122
 123     my $html = html( "Hello", "Hi there! ☺" );
 124     $c->response->content_type("text/html; charset=utf-8");
 125     $c->response->output( Compress::Zlib::memGzip($html) );
 126     $c->response->content_encoding('gzip');
 127     $c->response->headers->push_header( 'Vary', 'Accept-Encoding' );
 128 }
 129
 130 1;
 131