Commit | Line | Data |
fc7ec1d9 |
1 | package Catalyst::Engine::CGI; |
2 | |
3 | use strict; |
4 | use base 'Catalyst::Engine'; |
5 | use URI; |
6 | |
7 | require CGI::Simple; |
8 | require CGI::Cookie; |
9 | |
10 | __PACKAGE__->mk_accessors('cgi'); |
11 | |
12 | =head1 NAME |
13 | |
14 | Catalyst::Engine::CGI - The CGI Engine |
15 | |
16 | =head1 SYNOPSIS |
17 | |
18 | See L<Catalyst>. |
19 | |
20 | =head1 DESCRIPTION |
21 | |
22 | This is the CGI engine for Catalyst. |
23 | |
24 | =head2 METHODS |
25 | |
26 | =head3 run |
27 | |
28 | To be called from a CGI script to start the Catalyst application. |
29 | |
30 | =head3 cgi |
31 | |
32 | This config parameter contains the C<CGI::Simple> object. |
33 | |
34 | =head2 OVERLOADED METHODS |
35 | |
36 | This class overloads some methods from C<Catalyst>. |
37 | |
38 | =head3 finalize_headers |
39 | |
40 | =cut |
41 | |
42 | sub finalize_headers { |
43 | my $c = shift; |
44 | my %headers = ( -nph => 1 ); |
45 | $headers{-status} = $c->response->status if $c->response->status; |
46 | for my $name ( $c->response->headers->header_field_names ) { |
47 | $headers{"-$name"} = $c->response->headers->header($name); |
48 | } |
49 | my @cookies; |
50 | while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) { |
51 | push @cookies, $c->cgi->cookie( |
52 | -name => $name, |
53 | -value => $cookie->{value}, |
54 | -expires => $cookie->{expires}, |
55 | -domain => $cookie->{domain}, |
56 | -path => $cookie->{path}, |
57 | -secure => $cookie->{secure} || 0 |
58 | ); |
59 | } |
60 | $headers{-cookie} = \@cookies if @cookies; |
61 | print $c->cgi->header(%headers); |
62 | } |
63 | |
64 | =head3 finalize_output |
65 | |
66 | =cut |
67 | |
68 | sub finalize_output { |
69 | my $c = shift; |
70 | print $c->response->output; |
71 | } |
72 | |
73 | =head3 prepare_cookies |
74 | |
75 | =cut |
76 | |
77 | sub prepare_cookies { shift->req->cookies( { CGI::Cookie->fetch } ) } |
78 | |
79 | =head3 prepare_headers |
80 | |
81 | =cut |
82 | |
83 | sub prepare_headers { |
84 | my $c = shift; |
85 | $c->req->method( $c->cgi->request_method ); |
86 | for my $header ( $c->cgi->http ) { |
87 | ( my $field = $header ) =~ s/^HTTPS?_//; |
88 | $c->req->headers->header( $field => $c->cgi->http($header) ); |
89 | } |
90 | } |
91 | |
92 | =head3 prepare_parameters |
93 | |
94 | =cut |
95 | |
96 | sub prepare_parameters { |
97 | my $c = shift; |
98 | my %vars = $c->cgi->Vars; |
99 | while ( my ( $key, $value ) = each %vars ) { |
100 | my @values = split "\0", $value; |
101 | $vars{$key} = @values <= 1 ? $values[0] : \@values; |
102 | } |
103 | $c->req->parameters( {%vars} ); |
104 | } |
105 | |
106 | =head3 prepare_path |
107 | |
108 | =cut |
109 | |
110 | sub prepare_path { |
111 | my $c = shift; |
112 | $c->req->path( $c->cgi->url( -absolute => 1, -path_info => 1 ) ); |
113 | my $loc = $c->cgi->url( -absolute => 1 ); |
114 | no warnings 'uninitialized'; |
115 | $c->req->{path} =~ s/^($loc)?\///; |
116 | $c->req->{path} .= '/' if $c->req->path eq $loc; |
117 | my $base = $c->cgi->url; |
118 | $base = URI->new($base); |
119 | $base->path('/') if ( $ENV{CATALYST_TEST} || !$base->path ); |
120 | $c->req->base( $base->as_string ); |
121 | } |
122 | |
123 | =head3 prepare_request |
124 | |
125 | =cut |
126 | |
127 | sub prepare_request { shift->cgi( CGI::Simple->new ) } |
128 | |
129 | =head3 prepare_uploads |
130 | |
131 | =cut |
132 | |
133 | sub prepare_uploads { |
134 | my $c = shift; |
135 | for my $name ( $c->cgi->upload ) { |
136 | my $filename = $c->req->params->{$name}; |
137 | $c->req->uploads->{$name} = { |
138 | fh => $c->cgi->upload($filename), |
139 | filename => $filename, |
140 | size => $c->cgi->upload_info( $filename, 'size' ), |
141 | type => $c->cgi->upload_info( $filename, 'mime' ) |
142 | }; |
143 | } |
144 | } |
145 | |
146 | sub run { shift->handler } |
147 | |
148 | =head1 SEE ALSO |
149 | |
150 | L<Catalyst>. |
151 | |
152 | =head1 AUTHOR |
153 | |
154 | Sebastian Riedel, C<sri@cpan.org> |
155 | |
156 | =head1 COPYRIGHT |
157 | |
158 | This program is free software, you can redistribute it and/or modify it under |
159 | the same terms as Perl itself. |
160 | |
161 | =cut |
162 | |
163 | 1; |
164 | ## Please see file perltidy.ERR |