Commit | Line | Data |
2140e65c |
1 | package Catty::Controller::Root; |
2 | |
3 | use strict; |
4 | use warnings; |
2140e65c |
5 | use base qw/ Catalyst::Controller /; |
6 | |
7 | use Cwd; |
8 | use MIME::Base64; |
9 | use Encode (); |
10 | |
11 | __PACKAGE__->config( namespace => '' ); |
12 | |
13 | sub default : Private { |
14 | my ( $self, $context ) = @_; |
15 | my $html = html( "Root", "This is the root page" ); |
16 | $context->response->content_type("text/html"); |
17 | $context->response->output($html); |
18 | } |
19 | |
20 | sub hello : Global { |
21 | my ( $self, $context ) = @_; |
22 | my $str = Encode::encode('utf-8', "\x{263A}"); # ☺ |
23 | my $html = html( "Hello", "Hi there! $str" ); |
24 | $context->response->content_type("text/html; charset=utf-8"); |
25 | $context->response->output($html); |
26 | } |
27 | |
28 | # absolute redirect |
29 | sub hi : Global { |
30 | my ( $self, $context ) = @_; |
31 | my $where = $context->uri_for('hello'); |
32 | $context->response->redirect($where); |
33 | return; |
34 | } |
35 | |
36 | # partial (relative) redirect |
37 | sub greetings : Global { |
38 | my ( $self, $context ) = @_; |
39 | $context->response->redirect("hello"); |
40 | return; |
41 | } |
42 | |
43 | # redirect to a redirect |
44 | sub bonjour : Global { |
45 | my ( $self, $context ) = @_; |
46 | my $where = $context->uri_for('hi'); |
47 | $context->response->redirect($where); |
48 | return; |
49 | } |
50 | |
51 | sub check_auth_basic : Global { |
52 | my ( $self, $context ) = @_; |
53 | |
54 | my $auth = $context->req->headers->authorization; |
55 | ($auth) = $auth =~ /Basic\s(.*)/i; |
56 | $auth = decode_base64($auth); |
57 | |
58 | if ( $auth eq "user:pass" ) { |
59 | my $html = html( "Auth", "This is the auth page" ); |
60 | $context->response->content_type("text/html"); |
61 | $context->response->output($html); |
62 | return $context; |
63 | } else { |
64 | my $html = html( "Auth", "Auth Failed!" ); |
65 | $context->response->content_type("text/html"); |
66 | $context->response->output($html); |
67 | $context->response->status("401"); |
68 | return $context; |
69 | } |
70 | } |
71 | |
72 | sub redirect_with_500 : Global { |
73 | my ( $self, $c ) = @_; |
74 | $DB::single = 1; |
75 | $c->res->redirect( $c->uri_for("/bonjour")); |
76 | die "erk!"; |
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 | sub user_agent : Global { |
131 | my ( $self, $c ) = @_; |
132 | |
133 | my $html = html($c->req->user_agent, $c->req->user_agent); |
134 | $c->response->content_type("text/html; charset=utf-8"); |
135 | $c->response->output( $html ); |
136 | |
137 | } |
138 | |
127272a7 |
139 | # per https://rt.cpan.org/Ticket/Display.html?id=36442 |
140 | sub bad_content_encoding :Global { |
141 | my($self, $c) = @_; |
142 | $c->res->content_encoding('duff'); |
143 | $c->res->body('foo'); |
144 | } |
145 | |
74649ca9 |
146 | sub redirect_to_utf8_upgraded_string { |
147 | my($self, $c) = @_; |
148 | my $where = $c->uri_for('hello')->stringify; |
149 | utf8::upgrade($where); |
150 | $c->res->redirect($where); |
151 | } |
152 | |
2140e65c |
153 | 1; |
154 | |