diff --git a/lib/CGI.pm b/lib/CGI.pm index f95d70d8..cfaf87bf 100644 --- a/lib/CGI.pm +++ b/lib/CGI.pm @@ -38,6 +38,7 @@ use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN', } $MOD_PERL = 0; # no mod_perl by default +$PSGI = 0; #global settings $POST_MAX = -1; # no limit to uploaded files @@ -1017,9 +1018,9 @@ END_OF_FUNC sub read_from_client { my($self, $buff, $len, $offset) = @_; local $^W=0; # prevent a warning - return $MOD_PERL - ? $self->r->read($$buff, $len, $offset) - : read(\*STDIN, $$buff, $len, $offset); + return $MOD_PERL ? $self->r->read($$buff, $len, $offset) : + $PSGI ? $ENV{'psgi.input'}->read($$buff, $len, $offset) : + read(\*STDIN, $$buff, $len, $offset); } END_OF_FUNC @@ -1042,6 +1043,8 @@ sub read_from_stdin { if ( $MOD_PERL ) { $res = $self->r->read($tempbuf, $bufsiz, 0) } + elsif ( $PSGI ) { + $res = $ENV{'psgi.input'}->read($tempbuf, $bufsiz); else { $res = read(\*STDIN, $tempbuf, $bufsiz); } @@ -1600,7 +1603,16 @@ sub header { if (($MOD_PERL >= 1) && !$nph) { $self->r->send_cgi_header($header); return ''; + } elsif ($PSGI) { + $status =~ s/^(\d+).*$/$1/ if $status; + my $headers = []; + for my $h (@header) { + $h =~ /^([a-zA-Z_\-]+):\s*(.*)$/ + and push @$headers, $1, $2; + } + return $status || 200, $headers; } + return $header; } END_OF_FUNC diff --git a/lib/CGI/PSGI.pm b/lib/CGI/PSGI.pm new file mode 100644 index 00000000..882fa122 --- /dev/null +++ b/lib/CGI/PSGI.pm @@ -0,0 +1,77 @@ +package CGI::PSGI; +use strict; +use CGI; + +# Doesn't do anything useful: see POD +$CGI::PSGI = 1; + +1; + +__END__ + +=head1 NAME + +CGI::PSGI - Adds direct support for PSGI to read params + +=head1 SYNOPSIS + + use CGI::PSGI; + + my $app = sub { + my $env = shift; + local *ENV = $env; + my $query = CGI->new; + + # ... + + my($status, $headers) = $query->header('text/html'); # $headers is an array ref + + return [ $status, $headers, [ $body ] ]; + }; + +=head1 DESCRIPTION + +CGI::PSGI is a pragma module to let CGI read query and input +parameters from PSGI C<$env> hash ref instead of environment variables +and STDIN. This module actually doesn't do anything but is there for +convenience to set the flag C<$CGI::PSGI> variable to 1, and to check +if your CGI.pm supports PSGI input i.e. if the version of CGI doesn't +support CGI::PSGI, C would fail. + +Note that if your existent application prints headers and output to +STDOUT, your script is not ready to be handled as a PSGI application +yet. Take a look at L to convert such a script +into a PSGI application. + +The built-in support for PSGI in CGI module helps you to convert an +existent Web application framework that calls C<< CGI->new >> inside +to get parameters and such. Note that you should localize, or set and +reset the global C<%ENV> hash with the PSGI input C<$env> hash +reference during the lifetime of your application. + +For instance with L, + + use MyApp; # is a CGI::Application app + + use CGI::PSGI; + my $app = sub { + my $env = shift; + local *ENV = $env; + $ENV{CGI_APP_RETURN_ONLY} = 1; + + my $webapp = MyApp->new; + my $body = $webapp->run; + + my($status, $header) = $webapp->query->header; + return [ $status, $header, [ $body ] ]; + }; + +=head1 AUTHOR + +Tatsuhiko Miyagawa Emiyagawa@bulknews.netE + +=head1 SEE ALSO + +L L L L + +=cut diff --git a/t/psgi.t b/t/psgi.t new file mode 100644 index 00000000..644a0e3b --- /dev/null +++ b/t/psgi.t @@ -0,0 +1,131 @@ +# copy of request.t + +use strict; +use warnings; + +use Test::More; + +eval "use 5.008"; +plan skip_all => "$@" if $@; +plan tests => 43; + +use CGI::PSGI (); +use Config; + +my $loaded = 1; + +$| = 1; + +######################### End of black magic. + +# Set up a CGI environment +$ENV{REQUEST_METHOD} = 'GET'; +$ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; +$ENV{PATH_INFO} = '/somewhere/else'; +$ENV{PATH_TRANSLATED} = '/usr/local/somewhere/else'; +$ENV{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; +$ENV{SERVER_PROTOCOL} = 'HTTP/1.0'; +$ENV{SERVER_PORT} = 8080; +$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com'; +$ENV{REQUEST_URI} = "$ENV{SCRIPT_NAME}$ENV{PATH_INFO}?$ENV{QUERY_STRING}"; +$ENV{HTTP_LOVE} = 'true'; + +my $q = new CGI; +ok $q,"CGI::new()"; +is $q->request_method => 'GET',"CGI::request_method()"; +is $q->query_string => 'game=chess;game=checkers;weather=dull',"CGI::query_string()"; +is $q->param(), 2,"CGI::param()"; +is join(' ',sort $q->param()), 'game weather',"CGI::param()"; +is $q->param('game'), 'chess',"CGI::param()"; +is $q->param('weather'), 'dull',"CGI::param()"; +is join(' ',$q->param('game')), 'chess checkers',"CGI::param()"; +ok $q->param(-name=>'foo',-value=>'bar'),'CGI::param() put'; +is $q->param(-name=>'foo'), 'bar','CGI::param() get'; +is $q->query_string, 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"; +is $q->http('love'), 'true',"CGI::http()"; +is $q->script_name, '/cgi-bin/foo.cgi',"CGI::script_name()"; +is $q->url, 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"; +is $q->self_url, + 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + "CGI::url()"; +is $q->url(-absolute=>1), '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'; +is $q->url(-relative=>1), 'foo.cgi','CGI::url(-relative=>1)'; +is $q->url(-relative=>1,-path=>1), 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'; +is $q->url(-relative=>1,-path=>1,-query=>1), + 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', + 'CGI::url(-relative=>1,-path=>1,-query=>1)'; +$q->delete('foo'); +ok !$q->param('foo'),'CGI::delete()'; + +$q->_reset_globals; +$ENV{QUERY_STRING}='mary+had+a+little+lamb'; +ok $q=new CGI,"CGI::new() redux"; +is join(' ',$q->keywords), 'mary had a little lamb','CGI::keywords'; +is join(' ',$q->param('keywords')), 'mary had a little lamb','CGI::keywords'; +ok $q=new CGI('foo=bar&foo=baz'),"CGI::new() redux"; +is $q->param('foo'), 'bar','CGI::param() redux'; +ok $q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2"; +is $q->param('bar'), 'froz',"CGI::param() redux 2"; + +# test tied interface +my $p = $q->Vars; +is $p->{bar}, 'froz',"tied interface fetch"; +$p->{bar} = join("\0",qw(foo bar baz)); +is join(' ',$q->param('bar')), 'foo bar baz','tied interface store'; +ok exists $p->{bar}; + +# test posting +$q->_reset_globals; +{ + my $test_string = 'game=soccer&game=baseball&weather=nice'; + local $ENV{REQUEST_METHOD}='POST'; + local $ENV{CONTENT_LENGTH}=length($test_string); + local $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf'; + + local *STDIN; + open STDIN, '<', \$test_string; + use IO::Handle; + $ENV{'psgi.input'} = *STDIN; + + ok $q=new CGI,"CGI::new() from POST"; + is $q->param('weather'), 'nice',"CGI::param() from POST"; + is $q->url_param('big_balls'), 'basketball',"CGI::url_param()"; +} + +# test url_param +{ + local $ENV{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; + + CGI::_reset_globals; + my $q = CGI->new; + # params present, param and url_param should return true + ok $q->param, 'param() is true if parameters'; + ok $q->url_param, 'url_param() is true if parameters'; + + $ENV{QUERY_STRING} = ''; + + CGI::_reset_globals; + $q = CGI->new; + ok !$q->param, 'param() is false if no parameters'; + ok !$q->url_param, 'url_param() is false if no parameters'; + + $ENV{QUERY_STRING} = 'tiger dragon'; + CGI::_reset_globals; + $q = CGI->new; + + is_deeply [$q->$_] => [ 'keywords' ], "$_ with QS='$ENV{QUERY_STRING}'" + for qw/ param url_param /; + + is_deeply [ sort $q->$_( 'keywords' ) ], [ qw/ dragon tiger / ], + "$_ keywords" for qw/ param url_param /; +} + +{ + my $q = CGI->new; + $q->charset('utf-8'); + my($status, $headers) = $q->header(-status => 302, -content_type => 'text/plain'); + + is $status, 302; + is_deeply $headers, [ 'Status', 302, 'Content-Type', 'text/plain; charset=utf-8' ]; +} +