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 (); |
705f22fa |
10 | use utf8; |
2140e65c |
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); |
4c96289c |
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 |
2140e65c |
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 | |
182c043a |
128 | my $html = Encode::encode('UTF-8', html( "Hello", "Hi there! ☺" )); |
2140e65c |
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 | |
127272a7 |
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 | |
705f22fa |
151 | sub redirect_to_utf8_upgraded_string : Global { |
74649ca9 |
152 | my($self, $c) = @_; |
705f22fa |
153 | my $where = $c->uri_for('hello', 'müller')->as_string; |
74649ca9 |
154 | utf8::upgrade($where); |
155 | $c->res->redirect($where); |
156 | } |
157 | |
2140e65c |
158 | 1; |
159 | |