t/lib/Catty.pm

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