Commit | Line | Data |
6bc86362 |
1 | package Catty; |
2 | |
3 | use strict; |
affa35d5 |
4 | use warnings; |
6bc86362 |
5 | |
6 | #use Catalyst; |
db8bd5bb |
7 | use Catalyst; |
6bc86362 |
8 | use Cwd; |
9 | use MIME::Base64; |
db8bd5bb |
10 | use Encode qw//; |
6bc86362 |
11 | |
12 | our $VERSION = '0.01'; |
13 | |
14 | Catty->config( |
15 | name => 'Catty', |
16 | root => cwd . '/t/root', |
17 | ); |
6bc86362 |
18 | Catty->setup(); |
46377765 |
19 | Catty->log->levels("fatal"); |
6bc86362 |
20 | |
21 | sub default : Private { |
22 | my ( $self, $context ) = @_; |
23 | my $html = html( "Root", "This is the root page" ); |
24 | $context->response->content_type("text/html"); |
25 | $context->response->output($html); |
26 | } |
27 | |
28 | sub hello : Global { |
29 | my ( $self, $context ) = @_; |
db8bd5bb |
30 | my $str = Encode::encode('utf-8', "\x{263A}"); # ☺ |
31 | my $html = html( "Hello", "Hi there! $str" ); |
6bc86362 |
32 | $context->response->content_type("text/html; charset=utf-8"); |
33 | $context->response->output($html); |
34 | } |
35 | |
36 | # absolute redirect |
37 | sub hi : Global { |
38 | my ( $self, $context ) = @_; |
39 | my $where = $context->uri_for('hello'); |
40 | $context->response->redirect($where); |
41 | return; |
42 | } |
43 | |
44 | # partial (relative) redirect |
45 | sub greetings : Global { |
46 | my ( $self, $context ) = @_; |
47 | $context->response->redirect("hello"); |
48 | return; |
49 | } |
50 | |
51 | # redirect to a redirect |
52 | sub bonjour : Global { |
53 | my ( $self, $context ) = @_; |
54 | my $where = $context->uri_for('hi'); |
55 | $context->response->redirect($where); |
56 | return; |
57 | } |
58 | |
59 | sub check_auth_basic : Global { |
60 | my ( $self, $context ) = @_; |
61 | |
62 | my $auth = $context->req->headers->authorization; |
63 | ($auth) = $auth =~ /Basic\s(.*)/i; |
64 | $auth = decode_base64($auth); |
65 | |
66 | if ( $auth eq "user:pass" ) { |
67 | my $html = html( "Auth", "This is the auth page" ); |
68 | $context->response->content_type("text/html"); |
69 | $context->response->output($html); |
70 | return $context; |
71 | } else { |
72 | my $html = html( "Auth", "Auth Failed!" ); |
73 | $context->response->content_type("text/html"); |
74 | $context->response->output($html); |
75 | $context->response->status("401"); |
76 | return $context; |
77 | } |
78 | } |
79 | |
affa35d5 |
80 | sub redirect_with_500 : Global { |
81 | my ( $self, $c ) = @_; |
82 | $DB::single = 1; |
83 | $c->res->redirect( $c->uri_for("/bonjour")); |
84 | die "erk!"; |
85 | } |
86 | |
6bc86362 |
87 | sub die : Global { |
88 | my ( $self, $context ) = @_; |
89 | my $html = html( "Die", "This is the die page" ); |
90 | $context->response->content_type("text/html"); |
91 | $context->response->output($html); |
92 | die "erk!"; |
93 | } |
94 | |
254eca41 |
95 | sub name : Global { |
96 | my ($self, $c) = @_; |
97 | |
98 | my $html = html( $c->config->{name}, "This is the die page" ); |
99 | $c->response->content_type("text/html"); |
100 | $c->response->output($html); |
101 | } |
102 | |
1f8dbf85 |
103 | sub host : Global { |
104 | my ($self, $c) = @_; |
105 | |
106 | my $host = $c->req->header('Host') || "<undef>"; |
107 | my $html = html( $c->config->{name}, "Host: $host" ); |
108 | $c->response->content_type("text/html"); |
109 | $c->response->output($html); |
110 | } |
111 | |
6bc86362 |
112 | sub html { |
113 | my ( $title, $body ) = @_; |
114 | return qq{ |
115 | <html> |
116 | <head><title>$title</title></head> |
117 | <body> |
118 | $body |
119 | <a href="/hello/">Hello</a>. |
120 | </body></html> |
121 | }; |
122 | } |
123 | |
124 | sub gzipped : Global { |
125 | my ( $self, $c ) = @_; |
126 | |
127 | # If done properly this test should check the accept-encoding header, but we |
128 | # control both ends, so just always gzip the response. |
129 | require Compress::Zlib; |
130 | |
131 | my $html = html( "Hello", "Hi there! ☺" ); |
132 | $c->response->content_type("text/html; charset=utf-8"); |
133 | $c->response->output( Compress::Zlib::memGzip($html) ); |
134 | $c->response->content_encoding('gzip'); |
135 | $c->response->headers->push_header( 'Vary', 'Accept-Encoding' ); |
136 | } |
137 | |
d6fc3a22 |
138 | sub user_agent : Global { |
139 | my ( $self, $c ) = @_; |
140 | |
141 | my $html = html($c->req->user_agent, $c->req->user_agent); |
142 | $c->response->content_type("text/html; charset=utf-8"); |
143 | $c->response->output( $html ); |
144 | |
145 | } |
146 | |
6bc86362 |
147 | 1; |
148 | |