t/lib/Catty/Controller/Root.pm

   1 package Catty::Controller::Root;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/ Catalyst::Controller /;
   6
   7 use Cwd;
   8 use MIME::Base64;
   9 use Encode ();
  10 use utf8;
  11
  12 __PACKAGE__->config( namespace => '' );
  13
  14 sub default : Private {
  15     my ( $self, $context ) = @_;
  16     my $html = html( "Root", "This is the root page" );
  17     $context->response->content_type("text/html");
  18     $context->response->output($html);
  19 }
  20
  21 sub hello : Global {
  22     my ( $self, $context ) = @_;
  23     my $str = Encode::encode('utf-8', "\x{263A}"); # ☺
  24     my $html = html( "Hello", "Hi there! $str" );
  25     $context->response->content_type("text/html; charset=utf-8");
  26     $context->response->output($html);
  27
  28     # Newer Catalyst auto encodes UTF8, but this test case is borked and expects
  29     # broken utf8 behavior.  We'll make a real UTF8 Test case separately.
  30     $context->clear_encoding if $context->can('clear_encoding'); # Compat with upcoming Catalyst 5.90080
  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 redirect_with_500 : Global {
  78     my ( $self, $c ) = @_;
  79     $DB::single = 1;
  80     $c->res->redirect( $c->uri_for("/bonjour"));
  81     die "erk!";
  82 }
  83
  84 sub die : Global {
  85     my ( $self, $context ) = @_;
  86     my $html = html( "Die", "This is the die page" );
  87     $context->response->content_type("text/html");
  88     $context->response->output($html);
  89     die "erk!";
  90 }
  91
  92 sub name : Global {
  93     my ($self, $c) = @_;
  94
  95     my $html = html( $c->config->{name}, "This is the die page" );
  96     $c->response->content_type("text/html");
  97     $c->response->output($html);
  98 }
  99
 100 sub host : Global {
 101     my ($self, $c) = @_;
 102
 103     my $host = $c->req->header('Host') || "<undef>";
 104     my $html = html( $c->config->{name}, "Host: $host" );
 105     $c->response->content_type("text/html");
 106     $c->response->output($html);
 107 }
 108
 109 sub html {
 110     my ( $title, $body ) = @_;
 111     return qq{
 112 <html>
 113 <head><title>$title</title></head>
 114 <body>
 115 $body
 116 <a href="/hello/">Hello</a>.
 117 </body></html>
 118 };
 119 }
 120
 121 sub gzipped : Global {
 122     my ( $self, $c ) = @_;
 123
 124   # If done properly this test should check the accept-encoding header, but we
 125   # control both ends, so just always gzip the response.
 126     require Compress::Zlib;
 127
 128     my $html = Encode::encode('UTF-8', html( "Hello", "Hi there! ☺" ));
 129     $c->response->content_type("text/html; charset=utf-8");
 130     $c->response->output( Compress::Zlib::memGzip($html) );
 131     $c->response->content_encoding('gzip');
 132     $c->response->headers->push_header( 'Vary', 'Accept-Encoding' );
 133 }
 134
 135 sub user_agent : Global {
 136     my ( $self, $c ) = @_;
 137
 138     my $html = html($c->req->user_agent, $c->req->user_agent);
 139     $c->response->content_type("text/html; charset=utf-8");
 140     $c->response->output( $html );
 141
 142 }
 143
 144 # per https://rt.cpan.org/Ticket/Display.html?id=36442
 145 sub bad_content_encoding :Global {
 146     my($self, $c) = @_;
 147     $c->res->content_encoding('duff');
 148     $c->res->body('foo');
 149 }
 150
 151 sub redirect_to_utf8_upgraded_string : Global {
 152     my($self, $c) = @_;
 153     my $where = $c->uri_for('hello', 'müller')->as_string;
 154     utf8::upgrade($where);
 155     $c->res->redirect($where);
 156 }
 157
 158 1;
 159