├── .gitignore ├── t ├── 00_compile.t ├── http.t ├── upload.t ├── redirect.t ├── psgi_headers.t ├── cookie.t └── psgi.t ├── .shipit ├── xt ├── synopsis.t ├── pod.t ├── perlcritic.t └── podspell.t ├── MANIFEST.SKIP ├── Makefile.PL ├── maint └── extract-methods ├── MANIFEST ├── Changes ├── README └── lib └── CGI └── PSGI.pm /.gitignore: -------------------------------------------------------------------------------- 1 | META.yml 2 | Makefile 3 | inc/ 4 | pm_to_blib 5 | *~ 6 | -------------------------------------------------------------------------------- /t/00_compile.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More tests => 1; 3 | 4 | BEGIN { use_ok 'CGI::PSGI' } 5 | -------------------------------------------------------------------------------- /.shipit: -------------------------------------------------------------------------------- 1 | steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN 2 | git.push_to = origin 3 | -------------------------------------------------------------------------------- /xt/synopsis.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval "use Test::Synopsis"; 3 | plan skip_all => "Test::Synopsis required" if $@; 4 | all_synopsis_ok(); 5 | -------------------------------------------------------------------------------- /xt/pod.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval "use Test::Pod 1.00"; 3 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 4 | all_pod_files_ok(); 5 | -------------------------------------------------------------------------------- /xt/perlcritic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | eval q{ use Test::Perl::Critic }; 4 | plan skip_all => "Test::Perl::Critic is not installed." if $@; 5 | all_critic_ok("lib"); 6 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \bRCS\b 2 | \bCVS\b 3 | \.svn/ 4 | \.git/ 5 | ^MANIFEST\. 6 | ^Makefile$ 7 | ~$ 8 | \.old$ 9 | ^blib/ 10 | ^pm_to_blib 11 | ^MakeMaker-\d 12 | \.gz$ 13 | \.cvsignore 14 | \.shipit 15 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use inc::Module::Install; 2 | name 'CGI-PSGI'; 3 | all_from 'lib/CGI/PSGI.pm'; 4 | 5 | requires 'CGI', '3.33'; 6 | 7 | build_requires 'Test::More', 0.88; 8 | author_tests('xt'); 9 | auto_set_repository; 10 | WriteAll; 11 | -------------------------------------------------------------------------------- /xt/podspell.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | eval q{ use Test::Spelling }; 3 | plan skip_all => "Test::Spelling is not installed." if $@; 4 | add_stopwords(); 5 | set_spell_cmd("aspell -l en list"); 6 | all_pod_files_spelling_ok('lib'); 7 | __DATA__ 8 | Tatsuhiko 9 | Miyagawa 10 | -------------------------------------------------------------------------------- /maint/extract-methods: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | chomp(my $file = `perldoc -l CGI`); 3 | open my $io, "<", $file or die $!; 4 | 5 | my $sub; 6 | while (<$io>) { 7 | chomp; 8 | /^sub (\w+)/ and $sub = $1; 9 | /^}\s*$/ and do { 10 | print "$sub\n" if $code{$sub} =~ /([\%\$]ENV|http\()/; undef $sub 11 | }; 12 | $code{$sub} .= "$_\n" if $sub; 13 | /^\s*package [^C]/ and exit; 14 | } 15 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | .gitignore 2 | Changes 3 | inc/Module/Install.pm 4 | inc/Module/Install/AuthorTests.pm 5 | inc/Module/Install/Base.pm 6 | inc/Module/Install/Can.pm 7 | inc/Module/Install/Fetch.pm 8 | inc/Module/Install/Makefile.pm 9 | inc/Module/Install/Metadata.pm 10 | inc/Module/Install/Repository.pm 11 | inc/Module/Install/Win32.pm 12 | inc/Module/Install/WriteAll.pm 13 | lib/CGI/PSGI.pm 14 | Makefile.PL 15 | MANIFEST This list of files 16 | META.yml 17 | README 18 | t/00_compile.t 19 | t/cookie.t 20 | t/http.t 21 | t/psgi.t 22 | t/psgi_headers.t 23 | t/redirect.t 24 | t/upload.t 25 | tools/extract-methods 26 | xt/perlcritic.t 27 | xt/pod.t 28 | xt/podspell.t 29 | xt/synopsis.t 30 | -------------------------------------------------------------------------------- /t/http.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use CGI::PSGI; 3 | use CGI; 4 | 5 | my $env; 6 | $env->{REQUEST_METHOD} = 'GET'; 7 | $env->{HTTP_HOST} = 'virtual.example.com:81'; 8 | $env->{SERVER_NAME} = 'server.example.com'; 9 | $env->{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; 10 | $env->{PATH_INFO} = ''; 11 | $env->{QUERY_STRING} = ''; 12 | $env->{SERVER_PROTOCOL} = 'HTTP/1.0'; 13 | $env->{SERVER_PORT} = 8080; 14 | $env->{REQUEST_URI} = "$env->{SCRIPT_NAME}$env->{PATH_INFO}?$env->{QUERY_STRING}"; 15 | $env->{HTTP_USER_AGENT} = 'Mozilla/5.1'; 16 | $env->{HTTP_REFERER} = 'http://localhost/foo'; 17 | 18 | { 19 | my $q = CGI::PSGI->new($env); 20 | is $q->server_name, 'server.example.com'; 21 | is $q->virtual_host, 'virtual.example.com'; 22 | is $q->virtual_port, 81; 23 | 24 | is $q->user_agent, 'Mozilla/5.1'; 25 | is $q->referer, 'http://localhost/foo'; 26 | } 27 | 28 | done_testing; 29 | -------------------------------------------------------------------------------- /t/upload.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | use CGI::PSGI; 4 | use CGI; 5 | use IO::Handle; 6 | 7 | my $content = do { local $/; }; 8 | $content =~ s/\x0A/\x0D\x0A/g; # LF => CR+LF 9 | open my $input, "<", \$content; 10 | 11 | my $env = { 12 | 'CONTENT_LENGTH' => length $content, 13 | 'CONTENT_TYPE' => 'multipart/form-data; boundary=----BOUNDARY', 14 | 'REQUEST_METHOD' => 'POST', 15 | 'SERVER_PROTOCOL' => 'HTTP/1.0', 16 | 'psgi.input' => $input, 17 | }; 18 | 19 | { 20 | my $q = CGI::PSGI->new($env); 21 | is $q->param("bar"), "BAR"; 22 | 23 | my $fh = $q->upload("upload_foo"); 24 | is $fh, "foo.txt"; 25 | isa_ok $fh, "Fh"; 26 | 27 | my $body = do { local $/; <$fh> }; 28 | is $body, "FOO"; 29 | } 30 | 31 | done_testing; 32 | 33 | __DATA__ 34 | ------BOUNDARY 35 | Content-Disposition: form-data; name="upload_foo"; filename="foo.txt" 36 | Content-Type: text/plain 37 | 38 | FOO 39 | ------BOUNDARY 40 | Content-Disposition: form-data; name="bar" 41 | 42 | BAR 43 | ------BOUNDARY-- 44 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension CGI::PSGI 2 | 3 | 0.15 Tue May 17 13:58:50 PDT 2011 4 | - Updated the list of overriding methods per CGI.pm update 5 | - Added a note that you can't use CGI::Pretty (reported by Maestro) 6 | 7 | 0.14 Sat Dec 25 11:35:52 PST 2010 8 | - Port fixes for header injection from CGI.pm (markstos) 9 | 10 | 0.13 Sat Oct 30 23:09:06 PDT 2010 11 | - Specify Test::More dep 12 | 13 | 0.12 Mon Oct 25 11:06:59 PDT 2010 14 | - Strip Status: header since to conform PSGI spec (clkao) 15 | 16 | 0.11 Sat May 1 04:37:07 PDT 2010 17 | - Upped CGI.pm dependency to 3.33 to fix the upload() issue in perl 5.10 18 | 19 | 0.10 Wed Mar 31 01:14:43 PDT 2010 20 | - Upped CGI.pm dependency to 3.15, released in 2005 and is core in perl 5.8.8 21 | 22 | 0.09 Thu Feb 11 14:47:26 PST 2010 23 | - Added ->psgi_redirect to make migration from CGI.pm even easier (markstos) 24 | - POD overhaul and improvements (markstos) 25 | 26 | 0.07 Tue Jan 12 10:21:19 PST 2010 27 | - Unset $CGI::MOD_PERL in case CGI.pm is preloaded by other non-PSGI apps running on Apache 28 | (confound, sukria) 29 | 30 | 0.06 Wed Jan 6 18:12:45 PST 2010 31 | - Added ->env method to access PSGI env from the object. 32 | 33 | 0.05 Wed Jan 6 00:37:23 PST 2010 34 | - Fixed a bug where uploaded files are not saved in temp files (fujiwara) 35 | 36 | 0.04 Wed Dec 9 16:37:47 PST 2009 37 | - Added virtual_host to the list because bad CGI.pm uses host() as a function not a method (kazuho) 38 | 39 | 0.03 Fri Nov 27 17:32:50 JST 2009 40 | - Speicify CGI.pm dependency since older one has different read_from_client params 41 | 42 | 0.02 Mon Oct 19 20:16:25 PDT 2009 43 | - Fix the test to skip if <= 3.45 not < 3.45 44 | 45 | 0.01 Fri Sep 25 11:24:24 2009 46 | - original version 47 | -------------------------------------------------------------------------------- /t/redirect.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | eval "use 5.008"; 6 | plan skip_all => "$@" if $@; 7 | plan tests => 6; 8 | #plan 'no_plan'; 9 | 10 | use CGI::PSGI (); 11 | 12 | # Set up a CGI environment 13 | my $env; 14 | $env->{REQUEST_METHOD} = 'GET'; 15 | $env->{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; 16 | $env->{PATH_INFO} = '/somewhere/else'; 17 | $env->{PATH_TRANSLATED} = '/usr/local/somewhere/else'; 18 | $env->{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; 19 | $env->{SERVER_PROTOCOL} = 'HTTP/1.0'; 20 | $env->{SERVER_PORT} = 8080; 21 | $env->{SERVER_NAME} = 'the.good.ship.lollypop.com'; 22 | $env->{REQUEST_URI} = "$env->{SCRIPT_NAME}$env->{PATH_INFO}?$env->{QUERY_STRING}"; 23 | $env->{HTTP_LOVE} = 'true'; 24 | 25 | my $q = CGI::PSGI->new($env); 26 | 27 | # These first tree tests are ported from CGI.pm's 'function.t' 28 | { 29 | my $test = 'psgi_redirect($url)'; 30 | my ($status,$headers) = $q->psgi_redirect('http://somewhere.else'); 31 | is($status, 302, "$test - default status"); 32 | is_deeply $headers, [ 'Location' => 'http://somewhere.else' ], "$test - headers array"; 33 | } 34 | { 35 | my $test = 'psgi_redirect() with content type'; 36 | my ($status,$headers) = $q->psgi_redirect( -Location=>'http://somewhere.else',-Type=>'text/html'); 37 | is($status, 302, "$test - status"); 38 | is_deeply $headers, [ 39 | 'Location' => 'http://somewhere.else', 40 | 'Content-Type' => 'text/html; charset=ISO-8859-1', 41 | ], "$test - headers array"; 42 | } 43 | { 44 | my $test = "psgi_redirect() with path and query string"; 45 | my ($status,$headers) = $q->psgi_redirect( -Location=>'http://somewhere.else/bin/foo&bar',-Type=>'text/html'); 46 | is($status, 302, "$test - status"); 47 | is_deeply $headers, [ 48 | 'Location' => 'http://somewhere.else/bin/foo&bar', 49 | 'Content-Type' => 'text/html; charset=ISO-8859-1', 50 | ], "$test - headers array"; 51 | } 52 | 53 | 54 | -------------------------------------------------------------------------------- /t/psgi_headers.t: -------------------------------------------------------------------------------- 1 | 2 | # Test that header generation is spec compliant. 3 | # References: 4 | # http://www.w3.org/Protocols/rfc2616/rfc2616.html 5 | # http://www.w3.org/Protocols/rfc822/3_Lexical.html 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use Test::More 'no_plan'; 11 | 12 | use CGI; 13 | use CGI::PSGI; 14 | 15 | # Set up a CGI environment 16 | my $env; 17 | $env->{REQUEST_METHOD} = 'GET'; 18 | $env->{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; 19 | $env->{PATH_INFO} = '/somewhere/else'; 20 | $env->{PATH_TRANSLATED} = '/usr/local/somewhere/else'; 21 | $env->{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; 22 | $env->{SERVER_PROTOCOL} = 'HTTP/1.0'; 23 | $env->{SERVER_PORT} = 8080; 24 | $env->{SERVER_NAME} = 'the.good.ship.lollypop.com'; 25 | $env->{REQUEST_URI} = "$env->{SCRIPT_NAME}$env->{PATH_INFO}?$env->{QUERY_STRING}"; 26 | $env->{HTTP_LOVE} = 'true'; 27 | 28 | my $cgi = CGI::PSGI->new($env); 29 | 30 | my ($status, $headers) = $cgi->psgi_header( -type => "text/html" ); 31 | is_deeply $headers, [ 'Content-Type' => 'text/html; charset=ISO-8859-1' ], 32 | 'known header, basic case: type => "text/html"'; 33 | 34 | eval { $cgi->psgi_header( -type => "text/html".$CGI::CRLF."evil: stuff" ) }; 35 | like($@,qr/contains a newline/,'invalid header blows up'); 36 | 37 | ($status, $headers) = $cgi->psgi_header( -type => "text/html".$CGI::CRLF." evil: stuff " ); 38 | like $headers->[1], 39 | qr#text/html evil: stuff#, 'known header, with leading and trailing whitespace on the continuation line'; 40 | 41 | eval { $cgi->psgi_header( -foobar => "text/html".$CGI::CRLF."evil: stuff" ) }; 42 | like($@,qr/contains a newline/,'unknown header with CRLF embedded blows up'); 43 | 44 | eval { $cgi->psgi_header( -foobar => "\nContent-type: evil/header" ) }; 45 | like($@,qr/contains a newline/,'header with leading newline blows up'); 46 | 47 | eval { $cgi->psgi_redirect( -type => "text/html".$CGI::CRLF."evil: stuff" ), }; 48 | like($@,qr/contains a newline/,'redirect with known header with CRLF embedded blows up'); 49 | 50 | eval { $cgi->psgi_redirect( -foobar => "text/html".$CGI::CRLF."evil: stuff" ) }; 51 | like($@,qr/contains a newline/,'redirect with unknown header with CRLF embedded blows up'); 52 | 53 | eval { $cgi->psgi_redirect( $CGI::CRLF.$CGI::CRLF."Content-Type: text/html") }; 54 | like($@,qr/contains a newline/,'redirect with leading newlines blows up'); 55 | 56 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | NAME 2 | CGI::PSGI - Adapt CGI.pm to the PSGI protocol 3 | 4 | SYNOPSIS 5 | use CGI::PSGI; 6 | 7 | my $app = sub { 8 | my $env = shift; 9 | my $q = CGI::PSGI->new($env); 10 | return [ $q->psgi_header, [ $body ] ]; 11 | }; 12 | 13 | DESCRIPTION 14 | This module is for web application framework developers who currently 15 | uses CGI to handle query parameters, and would like for the frameworks 16 | to comply with the PSGI protocol. 17 | 18 | Only slight modifications should be required if the framework is already 19 | collecting the body content to print to STDOUT at one place (rather 20 | using the print-as-you-go approach). 21 | 22 | On the other hand, if you are an "end user" of CGI.pm and have a CGI 23 | script that you want to run under PSGI web servers, this module might 24 | not be what you want. Take a look at CGI::Emulate::PSGI instead. 25 | 26 | Your application, typically the web application framework adapter should 27 | update the code to do "CGI::PSGI->new($env)" instead of "CGI->new" to 28 | create a new CGI object. (This is similar to how CGI::Fast object is 29 | initialized in a FastCGI environment.) 30 | 31 | INTERFACES SUPPORTED 32 | Only the object-oriented interface of CGI.pm is supported through 33 | CGI::PSGI. This means you should always create an object with 34 | "CGI::PSGI->new($env)" and should call methods on the object. 35 | 36 | The function-based interface like "use CGI ':standard'" does not work 37 | with this module. 38 | 39 | METHODS 40 | CGI::PSGI adds the following extra methods to CGI.pm: 41 | 42 | env 43 | $env = $cgi->env; 44 | 45 | Returns the PSGI environment in a hash reference. This allows 46 | CGI.pm-based application frameworks such as CGI::Application to access 47 | PSGI extensions, typically set by Plack Middleware components. 48 | 49 | So if you enable Plack::Middleware::Session, your application and plugin 50 | developers can access the session via: 51 | 52 | $cgi->env->{'plack.session'}->get("foo"); 53 | 54 | Of course this should be coded carefully by checking the existence of 55 | "env" method as well as the hash key "plack.session". 56 | 57 | psgi_header 58 | my ($status_code, $headers_aref) = $cgi->psgi_header(%args); 59 | 60 | Works like CGI.pm's header(), but the return format is modified. It 61 | returns an array with the status code and arrayref of header pairs that 62 | PSGI requires. 63 | 64 | If your application doesn't use "$cgi->header", you can ignore this 65 | method and generate the status code and headers arrayref another way. 66 | 67 | psgi_redirect 68 | my ($status_code, $headers_aref) = $cgi->psgi_redirect(%args); 69 | 70 | Works like CGI.pm's redirect(), but the return format is modified. It 71 | returns an array with the status code and arrayref of header pairs that 72 | PSGI requires. 73 | 74 | If your application doesn't use "$cgi->redirect", you can ignore this 75 | method and generate the status code and headers arrayref another way. 76 | 77 | AUTHOR 78 | Tatsuhiko Miyagawa 79 | 80 | Mark Stosberg 81 | 82 | LICENSE 83 | This library is free software; you can redistribute it and/or modify it 84 | under the same terms as Perl itself. 85 | 86 | SEE ALSO 87 | CGI, CGI::Emulate::PSGI 88 | 89 | -------------------------------------------------------------------------------- /t/cookie.t: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl -w 2 | 3 | use strict; 4 | 5 | use Test::More tests => 28; 6 | use CGI::Util qw(escape unescape); 7 | use POSIX qw(strftime); 8 | 9 | #----------------------------------------------------------------------------- 10 | # make sure module loaded 11 | #----------------------------------------------------------------------------- 12 | 13 | BEGIN {use_ok('CGI::Cookie');} 14 | use CGI::PSGI; 15 | 16 | my @test_cookie = ( 17 | 'foo=123; bar=qwerty; baz=wibble; qux=a1', 18 | 'foo=123; bar=qwerty; baz=wibble;', 19 | 'foo=vixen; bar=cow; baz=bitch; qux=politician', 20 | 'foo=a%20phrase; bar=yes%2C%20a%20phrase; baz=%5Ewibble; qux=%27', 21 | ); 22 | 23 | #----------------------------------------------------------------------------- 24 | # Test fetch 25 | #----------------------------------------------------------------------------- 26 | 27 | # Breaks encapsulation to easily adapt to CGI.pm's cookie.t 28 | my $get_cookie = sub { 29 | my $q = CGI::PSGI->new(shift); 30 | $q->cookie; 31 | %{ $q->{'.cookies'} || {} }; 32 | }; 33 | 34 | my $get_raw_cookie = sub { 35 | my $q = CGI::PSGI->new(shift); 36 | $q->raw_cookie('dummy'); 37 | %{ $q->{'.raw_cookies'} || {} }; 38 | }; 39 | 40 | { 41 | # make sure there are no cookies in the environment 42 | delete $ENV{HTTP_COOKIE}; 43 | delete $ENV{COOKIE}; 44 | 45 | # now set a cookie in the environment and try again 46 | my $env = {}; 47 | $env->{HTTP_COOKIE} = $test_cookie[2]; 48 | my %result = $get_cookie->($env); 49 | ok(eq_set([keys %result], [qw(foo bar baz qux)]), 50 | "expected cookies extracted"); 51 | 52 | is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct'); 53 | is($result{foo}->value, 'vixen', "cookie foo is correct"); 54 | is($result{bar}->value, 'cow', "cookie bar is correct"); 55 | is($result{baz}->value, 'bitch', "cookie baz is correct"); 56 | is($result{qux}->value, 'politician', "cookie qux is correct"); 57 | 58 | # Delete that and make sure it goes away 59 | delete $env->{HTTP_COOKIE}; 60 | %result = $get_cookie->($env); 61 | ok(keys %result == 0, "No cookies in environment, returns empty list"); 62 | 63 | # try another cookie in the other environment variable thats supposed to work 64 | $env->{COOKIE} = $test_cookie[3]; 65 | %result = $get_cookie->($env); 66 | ok(eq_set([keys %result], [qw(foo bar baz qux)]), 67 | "expected cookies extracted"); 68 | 69 | is(ref($result{foo}), 'CGI::Cookie', 'Type of objects returned is correct'); 70 | is($result{foo}->value, 'a phrase', "cookie foo is correct"); 71 | is($result{bar}->value, 'yes, a phrase', "cookie bar is correct"); 72 | is($result{baz}->value, '^wibble', "cookie baz is correct"); 73 | is($result{qux}->value, "'", "cookie qux is correct"); 74 | } 75 | 76 | #----------------------------------------------------------------------------- 77 | # Test raw_fetch 78 | #----------------------------------------------------------------------------- 79 | 80 | { 81 | my $env = {}; 82 | my %result = $get_raw_cookie->($env); 83 | ok(keys %result == 0, "No cookies in environment, returns empty list"); 84 | 85 | # now set a cookie in the environment and try again 86 | $env->{HTTP_COOKIE} = $test_cookie[2]; 87 | %result = $get_raw_cookie->($env); 88 | ok(eq_set([keys %result], [qw(foo bar baz qux)]), 89 | "expected cookies extracted"); 90 | 91 | is(ref($result{foo}), '', 'Plain scalar returned'); 92 | is($result{foo}, 'vixen', "cookie foo is correct"); 93 | is($result{bar}, 'cow', "cookie bar is correct"); 94 | is($result{baz}, 'bitch', "cookie baz is correct"); 95 | is($result{qux}, 'politician', "cookie qux is correct"); 96 | 97 | # Delete that and make sure it goes away 98 | delete $env->{HTTP_COOKIE}; 99 | %result = $get_raw_cookie->($env); 100 | ok(keys %result == 0, "No cookies in environment, returns empty list"); 101 | 102 | # try another cookie in the other environment variable thats supposed to work 103 | $env->{COOKIE} = $test_cookie[3]; 104 | %result = $get_raw_cookie->($env); 105 | ok(eq_set([keys %result], [qw(foo bar baz qux)]), 106 | "expected cookies extracted"); 107 | 108 | is(ref($result{foo}), '', 'Plain scalar returned'); 109 | is($result{foo}, 'a%20phrase', "cookie foo is correct"); 110 | is($result{bar}, 'yes%2C%20a%20phrase', "cookie bar is correct"); 111 | is($result{baz}, '%5Ewibble', "cookie baz is correct"); 112 | is($result{qux}, '%27', "cookie qux is correct"); 113 | } 114 | -------------------------------------------------------------------------------- /t/psgi.t: -------------------------------------------------------------------------------- 1 | # copy of request.t 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | eval "use 5.008"; 9 | plan skip_all => "$@" if $@; 10 | plan tests => 36; 11 | 12 | use CGI::PSGI (); 13 | use Config; 14 | 15 | my $loaded = 1; 16 | 17 | $| = 1; 18 | 19 | ######################### End of black magic. 20 | 21 | # Set up a CGI environment 22 | my $env; 23 | $env->{REQUEST_METHOD} = 'GET'; 24 | $env->{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; 25 | $env->{PATH_INFO} = '/somewhere/else'; 26 | $env->{PATH_TRANSLATED} = '/usr/local/somewhere/else'; 27 | $env->{SCRIPT_NAME} = '/cgi-bin/foo.cgi'; 28 | $env->{SERVER_PROTOCOL} = 'HTTP/1.0'; 29 | $env->{SERVER_PORT} = 8080; 30 | $env->{SERVER_NAME} = 'the.good.ship.lollypop.com'; 31 | $env->{REQUEST_URI} = "$env->{SCRIPT_NAME}$env->{PATH_INFO}?$env->{QUERY_STRING}"; 32 | $env->{HTTP_LOVE} = 'true'; 33 | 34 | my $q = CGI::PSGI->new($env); 35 | ok $q,"CGI::new()"; 36 | is $q->request_method => 'GET',"CGI::request_method()"; 37 | is $q->query_string => 'game=chess;game=checkers;weather=dull',"CGI::query_string()"; 38 | is $q->param(), 2,"CGI::param()"; 39 | is join(' ',sort $q->param()), 'game weather',"CGI::param()"; 40 | is $q->param('game'), 'chess',"CGI::param()"; 41 | is $q->param('weather'), 'dull',"CGI::param()"; 42 | is join(' ',$q->param('game')), 'chess checkers',"CGI::param()"; 43 | ok $q->param(-name=>'foo',-value=>'bar'),'CGI::param() put'; 44 | is $q->param(-name=>'foo'), 'bar','CGI::param() get'; 45 | is $q->query_string, 'game=chess;game=checkers;weather=dull;foo=bar',"CGI::query_string() redux"; 46 | is $q->http('love'), 'true',"CGI::http()"; 47 | is $q->script_name, '/cgi-bin/foo.cgi',"CGI::script_name()"; 48 | is $q->url, 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()"; 49 | is $q->self_url, 50 | 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', 51 | "CGI::url()"; 52 | is $q->url(-absolute=>1), '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)'; 53 | is $q->url(-relative=>1), 'foo.cgi','CGI::url(-relative=>1)'; 54 | is $q->url(-relative=>1,-path=>1), 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)'; 55 | is $q->url(-relative=>1,-path=>1,-query=>1), 56 | 'foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar', 57 | 'CGI::url(-relative=>1,-path=>1,-query=>1)'; 58 | $q->delete('foo'); 59 | ok !$q->param('foo'),'CGI::delete()'; 60 | 61 | $q->_reset_globals; 62 | $env->{QUERY_STRING}='mary+had+a+little+lamb'; 63 | ok $q=CGI::PSGI->new($env),"CGI::new() redux"; 64 | is join(' ',$q->keywords), 'mary had a little lamb','CGI::keywords'; 65 | is join(' ',$q->param('keywords')), 'mary had a little lamb','CGI::keywords'; 66 | 67 | # test posting 68 | $q->_reset_globals; 69 | { 70 | my $test_string = 'game=soccer&game=baseball&weather=nice'; 71 | local $env->{REQUEST_METHOD}='POST'; 72 | local $env->{CONTENT_LENGTH}=length($test_string); 73 | local $env->{QUERY_STRING}='big_balls=basketball&small_balls=golf'; 74 | 75 | open my $input, '<', \$test_string; 76 | use IO::Handle; 77 | $env->{'psgi.input'} = $input; 78 | 79 | ok $q=CGI::PSGI->new($env),"CGI::new() from POST"; 80 | is $q->param('weather'), 'nice',"CGI::param() from POST"; 81 | is $q->url_param('big_balls'), 'basketball',"CGI::url_param()"; 82 | } 83 | 84 | # test url_param 85 | { 86 | local $env->{QUERY_STRING} = 'game=chess&game=checkers&weather=dull'; 87 | 88 | my $q = CGI::PSGI->new($env); 89 | # params present, param and url_param should return true 90 | ok $q->param, 'param() is true if parameters'; 91 | ok $q->url_param, 'url_param() is true if parameters'; 92 | 93 | $env->{QUERY_STRING} = ''; 94 | 95 | $q = CGI::PSGI->new($env); 96 | ok !$q->param, 'param() is false if no parameters'; 97 | if (eval { CGI->VERSION(3.46) }) { 98 | ok !$q->url_param, 'url_param() is false if no parameters'; 99 | } else { 100 | # CGI.pm before 3.46 had an inconsistency with url_param and an empty 101 | # query string 102 | my %p = map { $_ => [ $q->url_param($_) ] } $q->url_param; 103 | is_deeply \%p, { keywords => [] }; 104 | } 105 | 106 | $env->{QUERY_STRING} = 'tiger dragon'; 107 | $q = CGI::PSGI->new($env); 108 | 109 | is_deeply [$q->$_] => [ 'keywords' ], "$_ with QS='$env->{QUERY_STRING}'" 110 | for qw/ param url_param /; 111 | 112 | is_deeply [ sort $q->$_( 'keywords' ) ], [ qw/ dragon tiger / ], 113 | "$_ keywords" for qw/ param url_param /; 114 | } 115 | 116 | { 117 | my $q = CGI::PSGI->new($env); 118 | $q->charset('utf-8'); 119 | my($status, $headers) = $q->psgi_header(-status => 302, -content_type => 'text/plain'); 120 | 121 | is $status, 302; 122 | is_deeply $headers, [ 'Content-Type', 'text/plain; charset=utf-8' ]; 123 | } 124 | 125 | -------------------------------------------------------------------------------- /lib/CGI/PSGI.pm: -------------------------------------------------------------------------------- 1 | package CGI::PSGI; 2 | 3 | use strict; 4 | use 5.008_001; 5 | our $VERSION = '0.15'; 6 | 7 | use base qw(CGI); 8 | 9 | sub 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 | 25 | sub env { 26 | $_[0]->{psgi_env}; 27 | } 28 | 29 | sub 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 35 | sub 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 rearranged from CGI::header 65 | sub 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. 153 | sub 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` 178 | for 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 | 217 | sub DESTROY { 218 | my $self = shift; 219 | CGI::initialize_globals(); 220 | } 221 | 222 | 1; 223 | __END__ 224 | 225 | =encoding utf-8 226 | 227 | =for stopwords 228 | 229 | =head1 NAME 230 | 231 | CGI::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 | 245 | This module is for web application framework developers who currently uses 246 | L to handle query parameters, and would like for the frameworks to comply 247 | with the L protocol. 248 | 249 | Only slight modifications should be required if the framework is already 250 | collecting the body content to print to STDOUT at one place (rather using 251 | the print-as-you-go approach). 252 | 253 | On the other hand, if you are an "end user" of CGI.pm and have a CGI script 254 | that you want to run under PSGI web servers, this module might not be what you 255 | want. Take a look at L instead. 256 | 257 | Your application, typically the web application framework adapter 258 | should update the code to do C<< CGI::PSGI->new($env) >> instead of 259 | C<< CGI->new >> to create a new CGI object. (This is similar to how 260 | L object is initialized in a FastCGI environment.) 261 | 262 | =head1 INTERFACES SUPPORTED 263 | 264 | Only the object-oriented interface of CGI.pm is supported through CGI::PSGI. 265 | This means you should always create an object with C<< CGI::PSGI->new($env) >> 266 | and should call methods on the object. 267 | 268 | The function-based interface like C<< use CGI ':standard' >> does not work with this module. 269 | 270 | =head1 METHODS 271 | 272 | CGI::PSGI adds the following extra methods to CGI.pm: 273 | 274 | =head2 env 275 | 276 | $env = $cgi->env; 277 | 278 | Returns the PSGI environment in a hash reference. This allows CGI.pm-based 279 | application frameworks such as L to access PSGI extensions, 280 | typically set by Plack Middleware components. 281 | 282 | So if you enable L, your application and 283 | plugin developers can access the session via: 284 | 285 | $cgi->env->{'plack.session'}->get("foo"); 286 | 287 | Of course this should be coded carefully by checking the existence of 288 | C method as well as the hash key C. 289 | 290 | =head2 psgi_header 291 | 292 | my ($status_code, $headers_aref) = $cgi->psgi_header(%args); 293 | 294 | Works like CGI.pm's L, but the return format is modified. It returns 295 | an array with the status code and arrayref of header pairs that PSGI 296 | requires. 297 | 298 | If your application doesn't use C<< $cgi->header >>, you can ignore this 299 | method 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 | 305 | Works like CGI.pm's L, but the return format is modified. It 306 | returns an array with the status code and arrayref of header pairs that PSGI 307 | requires. 308 | 309 | If your application doesn't use C<< $cgi->redirect >>, you can ignore this 310 | method and generate the status code and headers arrayref another way. 311 | 312 | =head1 LIMITATIONS 313 | 314 | Do not use L or something similar in your controller. The 315 | module messes up L's DIY autoloader and breaks CGI::PSGI (and 316 | potentially other) inheritance. 317 | 318 | =head1 AUTHOR 319 | 320 | Tatsuhiko Miyagawa Emiyagawa@bulknews.netE 321 | 322 | Mark Stosberg Emark@summersault.comE 323 | 324 | =head1 LICENSE 325 | 326 | This library is free software; you can redistribute it and/or modify 327 | it under the same terms as Perl itself. 328 | 329 | =head1 SEE ALSO 330 | 331 | L, L 332 | 333 | =cut 334 | --------------------------------------------------------------------------------