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