1package CGI::PSGI;
2
3use strict;
4use 5.008_001;
5our $VERSION = '0.15';
6
7use base qw(CGI);
8
9sub new {
10    my($class, $env) = @_;
11    CGI::initialize_globals();
12
13    my $self = bless {
14        psgi_env     => $env,
15        use_tempfile => 1,
16    }, $class;
17
18    local *ENV = $env;
19    local $CGI::MOD_PERL = 0;
20    $self->SUPER::init;
21
22    $self;
23}
24
25sub env {
26    $_[0]->{psgi_env};
27}
28
29sub read_from_client {
30    my($self, $buff, $len, $offset) = @_;
31    $self->{psgi_env}{'psgi.input'}->read($$buff, $len, $offset);
32}
33
34# copied from CGI.pm
35sub read_from_stdin {
36    my($self, $buff) = @_;
37
38    my($eoffound) = 0;
39    my($localbuf) = '';
40    my($tempbuf) = '';
41    my($bufsiz) = 1024;
42    my($res);
43
44    while ($eoffound == 0) {
45        $res = $self->{psgi_env}{'psgi.input'}->read($tempbuf, $bufsiz, 0);
46
47        if ( !defined($res) ) {
48            # TODO: how to do error reporting ?
49            $eoffound = 1;
50            last;
51        }
52        if ( $res == 0 ) {
53            $eoffound = 1;
54            last;
55        }
56        $localbuf .= $tempbuf;
57    }
58
59    $$buff = $localbuf;
60
61    return $res;
62}
63
64# copied and rearanged from CGI::header
65sub psgi_header {
66    my($self, @p) = @_;
67
68    my(@header);
69
70    my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
71        CGI::rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
72                        'STATUS',['COOKIE','COOKIES'],'TARGET',
73                        'EXPIRES','NPH','CHARSET',
74                        'ATTACHMENT','P3P'],@p);
75
76    # CR escaping for values, per RFC 822
77    for my $header ($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) {
78        if (defined $header) {
79            # From RFC 822:
80            # Unfolding  is  accomplished  by regarding   CRLF   immediately
81            # followed  by  a  LWSP-char  as equivalent to the LWSP-char.
82            $header =~ s/$CGI::CRLF(\s)/$1/g;
83
84            # All other uses of newlines are invalid input.
85            if ($header =~ m/$CGI::CRLF|\015|\012/) {
86                # shorten very long values in the diagnostic
87                $header = substr($header,0,72).'...' if (length $header > 72);
88                die "Invalid header value contains a newline not followed by whitespace: $header";
89            }
90        }
91   }
92
93    $type ||= 'text/html' unless defined($type);
94    if (defined $charset) {
95        $self->charset($charset);
96    } else {
97        $charset = $self->charset if $type =~ /^text\//;
98    }
99    $charset ||= '';
100
101    # rearrange() was designed for the HTML portion, so we
102    # need to fix it up a little.
103    my @other_headers;
104    for (@other) {
105        # Don't use \s because of perl bug 21951
106        next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
107        $header =~ s/^(\w)(.*)/"\u$1\L$2"/e;
108        push @other_headers, $header, $self->unescapeHTML($value);
109    }
110
111    $type .= "; charset=$charset"
112        if     $type ne ''
113           and $type !~ /\bcharset\b/
114           and defined $charset
115           and $charset ne '';
116
117    # Maybe future compatibility.  Maybe not.
118    my $protocol = $self->{psgi_env}{SERVER_PROTOCOL} || 'HTTP/1.0';
119
120    push(@header, "Window-Target", $target) if $target;
121    if ($p3p) {
122        $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
123        push(@header,"P3P", qq(policyref="/w3c/p3p.xml", CP="$p3p"));
124    }
125
126    # push all the cookies -- there may be several
127    if ($cookie) {
128        my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
129        for (@cookie) {
130            my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
131            push(@header,"Set-Cookie", $cs) if $cs ne '';
132        }
133    }
134    # if the user indicates an expiration time, then we need
135    # both an Expires and a Date header (so that the browser is
136    # uses OUR clock)
137    push(@header,"Expires", CGI::expires($expires,'http'))
138        if $expires;
139    push(@header,"Date", CGI::expires(0,'http')) if $expires || $cookie || $nph;
140    push(@header,"Pragma", "no-cache") if $self->cache();
141    push(@header,"Content-Disposition", "attachment; filename=\"$attachment\"") if $attachment;
142    push(@header, @other_headers);
143
144    push(@header,"Content-Type", $type) if $type ne '';
145
146    $status ||= "200";
147    $status =~ s/\D*$//;
148
149    return $status, \@header;
150}
151
152# Ported from CGI.pm's redirect() method.
153sub psgi_redirect {
154    my ($self,@p) = @_;
155    my($url,$target,$status,$cookie,$nph,@other) =
156         CGI::rearrange([['LOCATION','URI','URL'],'TARGET','STATUS',['COOKIE','COOKIES'],'NPH'],@p);
157    $status = '302 Found' unless defined $status;
158    $url ||= $self->self_url;
159    my(@o);
160    for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
161    unshift(@o,
162	 '-Status'  => $status,
163	 '-Location'=> $url,
164	 '-nph'     => $nph);
165    unshift(@o,'-Target'=>$target) if $target;
166    unshift(@o,'-Type'=>'');
167    my @unescaped;
168    unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
169    return $self->psgi_header((map {$self->unescapeHTML($_)} @o),@unescaped);
170}
171
172# The list is auto generated and modified with:
173# perl -nle '/^sub (\w+)/ and $sub=$1; \
174#   /^}\s*$/ and do { print $sub if $code{$sub} =~ /([\%\$]ENV|http\()/; undef $sub };\
175#   $code{$sub} .= "$_\n" if $sub; \
176#   /^\s*package [^C]/ and exit' \
177# `perldoc -l CGI`
178for my $method (qw(
179    url_param
180    url
181    cookie
182    raw_cookie
183    _name_and_path_from_env
184    request_method
185    content_type
186    path_translated
187    request_uri
188    Accept
189    user_agent
190    virtual_host
191    remote_host
192    remote_addr
193    referrer
194    server_name
195    server_software
196    virtual_port
197    server_port
198    server_protocol
199    http
200    https
201    remote_ident
202    auth_type
203    remote_user
204    user_name
205    read_multipart
206    read_multipart_related
207)) {
208    no strict 'refs';
209    *$method = sub {
210        my $self  = shift;
211        my $super = "SUPER::$method";
212        local *ENV = $self->{psgi_env};
213        $self->$super(@_);
214    };
215}
216
217sub DESTROY {
218    my $self = shift;
219    CGI::initialize_globals();
220}
221
2221;
223__END__
224
225=encoding utf-8
226
227=for stopwords
228
229=head1 NAME
230
231CGI::PSGI - Adapt CGI.pm to the PSGI protocol
232
233=head1 SYNOPSIS
234
235  use CGI::PSGI;
236
237  my $app = sub {
238      my $env = shift;
239      my $q = CGI::PSGI->new($env);
240      return [ $q->psgi_header, [ $body ] ];
241  };
242
243=head1 DESCRIPTION
244
245This module is for web application framework developers who currently uses
246L<CGI> to handle query parameters, and would like for the frameworks to comply
247with the L<PSGI> protocol.
248
249Only slight modifications should be required if the framework is already
250collecting the body content to print to STDOUT at one place (rather using
251the print-as-you-go approach).
252
253On the other hand, if you are an "end user" of CGI.pm and have a CGI script
254that you want to run under PSGI web servers, this module might not be what you
255want.  Take a look at L<CGI::Emulate::PSGI> instead.
256
257Your application, typically the web application framework adapter
258should update the code to do C<< CGI::PSGI->new($env) >> instead of
259C<< CGI->new >> to create a new CGI object. (This is similar to how
260L<CGI::Fast> object is initialized in a FastCGI environment.)
261
262=head1 INTERFACES SUPPORTED
263
264Only the object-oriented interface of CGI.pm is supported through CGI::PSGI.
265This means you should always create an object with C<< CGI::PSGI->new($env) >>
266and should call methods on the object.
267
268The function-based interface like C<< use CGI ':standard' >> does not work with this module.
269
270=head1 METHODS
271
272CGI::PSGI adds the following extra methods to CGI.pm:
273
274=head2 env
275
276  $env = $cgi->env;
277
278Returns the PSGI environment in a hash reference. This allows CGI.pm-based
279application frameworks such as L<CGI::Application> to access PSGI extensions,
280typically set by Plack Middleware components.
281
282So if you enable L<Plack::Middleware::Session>, your application and
283plugin developers can access the session via:
284
285  $cgi->env->{'plack.session'}->get("foo");
286
287Of course this should be coded carefully by checking the existence of
288C<env> method as well as the hash key C<plack.session>.
289
290=head2 psgi_header
291
292 my ($status_code, $headers_aref) = $cgi->psgi_header(%args);
293
294Works like CGI.pm's L<header()>, but the return format is modified. It returns
295an array with the status code and arrayref of header pairs that PSGI
296requires.
297
298If your application doesn't use C<< $cgi->header >>, you can ignore this
299method and generate the status code and headers arrayref another way.
300
301=head2 psgi_redirect
302
303 my ($status_code, $headers_aref) = $cgi->psgi_redirect(%args);
304
305Works like CGI.pm's L<redirect()>, but the return format is modified. It
306returns an array with the status code and arrayref of header pairs that PSGI
307requires.
308
309If your application doesn't use C<< $cgi->redirect >>, you can ignore this
310method and generate the status code and headers arrayref another way.
311
312=head1 LIMITATIONS
313
314Do not use L<CGI::Pretty> or something similar in your controller. The
315module messes up L<CGI>'s DIY autoloader and breaks CGI::PSGI (and
316potentially other) inheritance.
317
318=head1 AUTHOR
319
320Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
321
322Mark Stosberg E<lt>mark@summersault.comE<gt>
323
324=head1 LICENSE
325
326This library is free software; you can redistribute it and/or modify
327it under the same terms as Perl itself.
328
329=head1 SEE ALSO
330
331L<CGI>, L<CGI::Emulate::PSGI>
332
333=cut
334