Mojolicious-Plugin-CGI-0.38/000755 000765 000024 00000000000 13117562745 016756 5ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.38/.perltidyrc000644 000765 000024 00000000714 13106404365 021131 0ustar00jhthorsenstaff000000 000000 -pbp # Start with Perl Best Practices -w # Show all warnings -iob # Ignore old breakpoints -l=100 # Characters per line -mbl=2 # No more than 2 blank lines -i=2 # Indentation is 2 columns -ci=2 # Continuation indentation is 2 columns -vt=0 # Less vertical tightness -pt=2 # High parenthesis tightness -bt=2 # High brace tightness -sbt=2 # High square bracket tightness -isbc # Don't indent comments without leading space Mojolicious-Plugin-CGI-0.38/.ship.conf000644 000765 000024 00000000524 13106404365 020636 0ustar00jhthorsenstaff000000 000000 # Generated by git-ship. See 'git-ship --man' for help or https://github.com/jhthorsen/app-git-ship class = App::git::ship::perl project_name = homepage = https://github.com/jhthorsen/mojolicious-plugin-cgi bugtracker = https://github.com/jhthorsen/mojolicious-plugin-cgi/issues license = artistic_2 build_test_options = # Example: -l -j8 Mojolicious-Plugin-CGI-0.38/.travis.yml000644 000765 000024 00000000410 13106404365 021051 0ustar00jhthorsenstaff000000 000000 language: perl perl: - "5.20" - "5.14" - "5.10" env: - "HARNESS_OPTIONS=j1 TEST_POD=1 TEST_MORBO=1" install: - "cpanm -n Test::Pod Test::Pod::Coverage Parallel::ForkManager Proc::ProcessTable" - "cpanm -n --installdeps ." notifications: email: false Mojolicious-Plugin-CGI-0.38/Changes000644 000765 000024 00000010252 13117562744 020250 0ustar00jhthorsenstaff000000 000000 Revision history for perl distribution Mojolicious-Plugin-CGI 0.38 2017-06-12T21:05:08+0200 - Bumped Mojolicious version to 7.28 #27 0.37 2017-05-15T22:01:59+0200 - Stop using deprecated "spurt" #26 0.36 2016-10-27T11:55:46+0200 - Fix setting $ENV{PATH_INFO} with UTF-8 characters Contributor: kensanata 0.35 2016-10-13T10:04:50+0200 - Skipping tests on Windows 0.34 2016-06-10T19:41:37-0700 - zombies.t cannot run without File::Which 0.33 2016-06-07T15:46:09-0500 - Fix zombies left behind #20 #21 #22 0.32 2016-04-17T14:34:17+0200 - Fix passing on %ENV to cgi script #19 0.31 2016-04-11T18:17:20+0200 - Avoid making CPAN dist with files from t/cgi-bin 0.30 2016-04-11T18:06:04+0200 - Will generate all the cgi-scripts with $^X 0.29 2016-04-09T10:54:27+0200 - Replace "/usr/bin/perl" with "/usr/bin/env perl" in tests 0.28 2016-04-06T16:22:50+0200 - Try to fix "Could not run CGI script" test failures 0.27 2016-04-01T14:09:59+0200 - Refactored the module - Add $c->cgi->run(...) helper - Fix bug when exec() fail in child - Remove "ioloop" attribute - Remove "emulate_environment" method 0.26 2016-03-10T22:15:51+0100 - Expose all headers as environment variables #18 0.25 2015-11-27T11:49:54+0100 - Made post.t optional 0.24 2015-11-11T22:16:33+0100 - Add "run" option for running CGI code from a callback instead of script #17 - Add HTTP_IF_NONE_MATCH to environement #17 - Add support for reading the "Status" header - Improved NPH script support #17 0.23 2015-07-16T07:43:59+0200 - Try to fix waiting for finished CGI scripts, without checking return value from waitpid() 0.22 2015-07-14T17:32:59+0200 - Fix "Bareword found where operator expected at t/gh-16-loop_reset.t line 35" - Try to fix waiting for finished CGI scripts 0.21 2015-07-12T15:26:05+0200 - Fix "Can't call method "write" on an undefined value" #16 - Disabled "no leaky leaks" test 0.20 2015-03-13T08:27:48Z - t/post.t leaky pipes test works on osx (timgimyee) 0.19 2015-02-08T14:24:43Z - Will not test SERVER_ADMIN variable 0.18 2015-01-30T09:57:46Z - Fix SCRIPT_NAME environment variable - Fix minimum Mojolicious version in cpanfile #13 0.17 2015-01-15T17:19:57Z - Add support for QUERY_STRING with ";" instead of "&" 0.16 2015-01-02T13:24:59Z - Require Mojolicious 5.08 0.15 2014-12-14T15:24:14Z - Fix CPAN testers and HTTP_HOST regexp 0.14 2014-12-12T13:27:17Z - Fix multipart test content length value Contributor: leejo 0.13 2014-11-17T15:13:31Z - Reset IOLoop in fork to prevent fork from receiving connections 0.12 2014-10-05T18:44:58Z - Change default CGI logging prefix to "CGI:$name:$pid" - Fix _waitpids() actually checks hanging processes 0.11 2014-10-05T10:58:12Z - Default STDERR logging goes to app log - Refactored the code using IO::Pipely - env() is an attribute - Tried to fix REMOTE_HOST from Authorization header, closes #10 0.10 2014-10-02T21:31:18Z - Fix Can't use string ("") as a HASH ref while "strict refs" in use at Mojolicious::Routes::Pattern line 63. 0.09 2014-06-13T11:56:31Z - Add README.pod to MANIFEST.SKIP https://github.com/jhthorsen/mojolicious-plugin-cgi/issues/9 0.08 2014-05-14T10:29:24Z - Flushing STDERR as well - Fix REMOTE_HOST test on windows http://www.cpantesters.org/cpan/report/99cac79a-725d-1014-82ca-1dcb5cf4d ae8 REMOTE_HOST=599DSOLIMANO01.cowen.corp != localhost 0.07 2013-11-17T14:11:59Z - Reads userinfo from request path - Add support for errlog - Fix PATH_INFO and SCRIPT_NAME 0.0601 2013-10-01T12:36:25Z - Add repository to Makefile.PL 0.06 2013-09-24T09:43:37Z - Add support multipart requests lee@givengain.ch 0.0501 2013-08-26T18:35:24Z - Fix waitpid before kill, because of defunc children 0.05 2013-08-23T16:31:13Z - Fix pipe leak - Support 302 redirects - Add better error handling - Will check if child is running 0.0401 2013-08-16T23:24:58Z - Fix NAME in Makefile.PL 0.04 2013-08-16T09:15:16Z - Add before hook which can modify query string 0.0301 2013-08-08T12:31:28Z - Need to waitpid to avoid defunct processes 0.03 2013-08-08T12:23:36Z - CGI script is now non-blocking 0.02 2013-08-05T12:45:43Z - Fix compat with older perls. 0.01 2013-07-11T11:40:26Z - Add basic support for calling CGI scripts Mojolicious-Plugin-CGI-0.38/cpanfile000644 000765 000024 00000000374 13117562661 020463 0ustar00jhthorsenstaff000000 000000 # You can install this projct with curl -L http://cpanmin.us | perl - https://github.com/jhthorsen/mojolicious-plugin-cgi/archive/master.tar.gz requires "IO::Pipely" => "0.005"; requires "Mojolicious" => "7.28"; test_requires "Test::More" => "0.88"; Mojolicious-Plugin-CGI-0.38/lib/000755 000765 000024 00000000000 13117562745 017524 5ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.38/Makefile.PL000644 000765 000024 00000001541 13117562744 020730 0ustar00jhthorsenstaff000000 000000 # Generated by git-ship. See 'git-ship --man' for help or https://github.com/jhthorsen/app-git-ship use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Mojolicious::Plugin::CGI', AUTHOR => 'Jan Henning Thorsen ', LICENSE => 'artistic_2', ABSTRACT_FROM => 'lib/Mojolicious/Plugin/CGI.pm', VERSION_FROM => 'lib/Mojolicious/Plugin/CGI.pm', EXE_FILES => [qw( )], META_MERGE => { resources => { bugtracker => 'https://github.com/jhthorsen/mojolicious-plugin-cgi/issues', homepage => 'https://github.com/jhthorsen/mojolicious-plugin-cgi', repository => 'https://github.com/jhthorsen/mojolicious-plugin-cgi.git', }, }, BUILD_REQUIRES => { 'Test::More' => '0.88' } , PREREQ_PM => { 'IO::Pipely' => '0.005', 'Mojolicious' => '7.28' } , test => {TESTS => (-e 'META.yml' ? 't/*.t' : 't/*.t xt/*.t')}, ); Mojolicious-Plugin-CGI-0.38/MANIFEST000644 000765 000024 00000001201 13117562745 020101 0ustar00jhthorsenstaff000000 000000 .perltidyrc .ship.conf .travis.yml Changes cpanfile lib/Mojolicious/Plugin/CGI.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP pm_to_blib README t/00-basic.t t/bar.txt t/basic.t t/before.t t/encoding.t t/errlog.t t/foo.txt t/gh-16-loop_reset.t t/Helper.pm t/helper.t t/multipart.t t/not-found.t t/not-modified.t t/nph-borked.t t/nph.t t/post.t t/query-string-with-semicolon.t t/redirect.t t/remote-user.t t/run.t t/test_file_with_a_long_filename.txt t/zombies.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Mojolicious-Plugin-CGI-0.38/MANIFEST.SKIP000644 000765 000024 00000000145 13106404414 020636 0ustar00jhthorsenstaff000000 000000 ^mypp.yml .git \.old \.swp ~$ ^blib/ ^Makefile$ ^MYMETA* ^README.pod ^Mojolicious-Plugin-CGI cgi-bin Mojolicious-Plugin-CGI-0.38/META.json000664 000765 000024 00000002440 13117562745 020401 0ustar00jhthorsenstaff000000 000000 { "abstract" : "Run CGI script from Mojolicious", "author" : [ "Jan Henning Thorsen " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Mojolicious-Plugin-CGI", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0.88" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "IO::Pipely" : "0.005", "Mojolicious" : "7.28" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/jhthorsen/mojolicious-plugin-cgi/issues" }, "homepage" : "https://github.com/jhthorsen/mojolicious-plugin-cgi", "repository" : { "url" : "https://github.com/jhthorsen/mojolicious-plugin-cgi.git" } }, "version" : "0.38", "x_serialization_backend" : "JSON::PP version 2.27300_01" } Mojolicious-Plugin-CGI-0.38/META.yml000664 000765 000024 00000001465 13117562745 020237 0ustar00jhthorsenstaff000000 000000 --- abstract: 'Run CGI script from Mojolicious' author: - 'Jan Henning Thorsen ' build_requires: Test::More: '0.88' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Mojolicious-Plugin-CGI no_index: directory: - t - inc requires: IO::Pipely: '0.005' Mojolicious: '7.28' resources: bugtracker: https://github.com/jhthorsen/mojolicious-plugin-cgi/issues homepage: https://github.com/jhthorsen/mojolicious-plugin-cgi repository: https://github.com/jhthorsen/mojolicious-plugin-cgi.git version: '0.38' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Mojolicious-Plugin-CGI-0.38/pm_to_blib000644 000765 000024 00000000000 13106404611 020756 0ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.38/README000644 000765 000024 00000010443 13117562744 017637 0ustar00jhthorsenstaff000000 000000 NAME Mojolicious::Plugin::CGI - Run CGI script from Mojolicious VERSION 0.38 DESCRIPTION This plugin enable Mojolicious to run Perl CGI scripts. It does so by forking a new process with a modified environment and reads the STDOUT in a non-blocking manner. SYNOPSIS Standard usage use Mojolicious::Lite; plugin CGI => [ "/cgi-bin/script" => "/path/to/cgi/script.pl" ]; Using the code above is enough to run "script.pl" when accessing . Complex usage plugin CGI => { # Specify the script and mount point script => "/path/to/cgi/script.pl", route => "/some/route", # %ENV variables visible from inside the CGI script env => {}, # default is \%ENV # Path to where STDERR from cgi script goes errlog => "/path/to/file.log", # The "before" hook is called before script start # It receives a Mojolicious::Controller which can be modified before => sub { my $c = shift; $c->req->url->query->param(a => 123); }, }; The above contains all the options you can pass on to the plugin. Helper plugin "CGI"; # GET /cgi-bin/some-script.cgi/path/info?x=123 get "/cgi-bin/#script_name/*path_info" => {path_info => ''}, sub { my $c = shift; my $name = $c->stash("script_name"); $c->cgi->run(script => File::Spec->rel2abs("/path/to/cgi/$name")); }; The helper can take most the arguments that "register" takes, with the exception of "support_semicolon_in_query_string". It is critical that "script_name" and "path_info" is present in stash. If the values are extracted directly from the path or set manually does not matter. Note that the helper is registered in all of the examples. Running code refs plugin CGI => { route => "/some/path", run => sub { my $cgi = CGI->new; # ... } }; Instead of calling a script, you can run a code block when accessing the route. This is (pretty much) safe, even if the code block modifies global state, since it runs in a separate fork/process. Support for semicolon in query string plugin CGI => { support_semicolon_in_query_string => 1, ... }; The code above need to be added before other plugins or handler which use "url" in Mojo::Message::Request. It will inject a "before_dispatch" hook which saves the original QUERY_STRING, before it is split on "&" in Mojo::Parameters. ATTRIBUTES env Holds a hash ref containing the environment variables that should be used when starting the CGI script. Defaults to %ENV when this module was loaded. This plugin will create a set of environment variables depenendent on the request passed in which is according to the CGI spec. In addition to "env", these dynamic variables are set: CONTENT_LENGTH, CONTENT_TYPE, HTTPS, PATH, PATH_INFO, QUERY_STRING, REMOTE_ADDR, REMOTE_HOST, REMOTE_PORT, REMOTE_USER, REQUEST_METHOD, SCRIPT_NAME, SERVER_PORT, SERVER_PROTOCOL. Additional static variables: GATEWAY_INTERFACE = "CGI/1.1" SERVER_ADMIN = $ENV{USER} SCRIPT_FILENAME = Script name given as argument to register. SERVER_NAME = Sys::Hostname::hostname() SERVER_SOFTWARE = "Mojolicious::Plugin::CGI" Plus all headers are exposed. Examples: .----------------------------------------. | Header | Variable | |-----------------|----------------------| | Referer | HTTP_REFERER | | User-Agent | HTTP_USER_AGENT | | X-Forwarded-For | HTTP_X_FORWARDED_FOR | '----------------------------------------' register $self->register($app, [ $route => $script ]); $self->register($app, %args); $self->register($app, \%args); "route" and path need to exist as keys in %args unless given as plain arguments. $route can be either a plain path or a route object. COPYRIGHT AND LICENSE Copyright (C) 2014, Jan Henning Thorsen This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. AUTHOR Jan Henning Thorsen - "jhthorsen@cpan.org" Mojolicious-Plugin-CGI-0.38/t/000755 000765 000024 00000000000 13117562745 017221 5ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.38/t/00-basic.t000644 000765 000024 00000002142 13106404365 020672 0ustar00jhthorsenstaff000000 000000 use Test::More; use File::Find; if (($ENV{HARNESS_PERL_SWITCHES} || '') =~ /Devel::Cover/) { plan skip_all => 'HARNESS_PERL_SWITCHES =~ /Devel::Cover/'; } if (!eval 'use Test::Pod; 1') { *Test::Pod::pod_file_ok = sub { SKIP: { skip "pod_file_ok(@_) (Test::Pod is required)", 1 } }; } if (!eval 'use Test::Pod::Coverage; 1') { *Test::Pod::Coverage::pod_coverage_ok = sub { SKIP: { skip "pod_coverage_ok(@_) (Test::Pod::Coverage is required)", 1 } }; } if (!eval 'use Test::CPAN::Changes; 1') { *Test::CPAN::Changes::changes_file_ok = sub { SKIP: { skip "changes_ok(@_) (Test::CPAN::Changes is required)", 4 } }; } find({wanted => sub { /\.pm$/ and push @files, $File::Find::name }, no_chdir => 1}, -e 'blib' ? 'blib' : 'lib',); plan tests => @files * 3 + 4; for my $file (@files) { my $module = $file; $module =~ s,\.pm$,,; $module =~ s,.*/?lib/,,; $module =~ s,/,::,g; ok eval "use $module; 1", "use $module" or diag $@; Test::Pod::pod_file_ok($file); Test::Pod::Coverage::pod_coverage_ok($module, {also_private => [qr/^[A-Z_]+$/],}); } Test::CPAN::Changes::changes_file_ok(); Mojolicious-Plugin-CGI-0.38/t/bar.txt000644 000765 000024 00000000024 13106404365 020511 0ustar00jhthorsenstaff000000 000000 even more data here Mojolicious-Plugin-CGI-0.38/t/basic.t000644 000765 000024 00000004651 13106404365 020464 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; $ENV{THE_ANSWER} = 42; use Mojolicious::Lite; plugin CGI => ['/working' => cgi_script('basic.pl')]; plugin CGI => {route => '/env/basic', script => cgi_script('env.cgi')}; my $t = Test::Mojo->new; $t->get_ok('/working')->status_is(200)->header_is('Content-Type' => 'text/custom') ->content_is("basic stuff\n"); $t->get_ok($t->tx->req->url->clone->path('/env/basic/foo')->query(query => 123))->status_is(200) ->content_like(qr{^ENVIRONMENT}m, 'ENVIRONMENT') ->content_like(qr{^CONTENT_LENGTH=0}m, 'CONTENT_LENGTH=0') ->content_like(qr{^CONTENT_TYPE=}m, 'CONTENT_TYPE=') ->content_like(qr{^GATEWAY_INTERFACE=CGI/1\.1}m, 'GATEWAY_INTERFACE=CGI/1\.1') ->content_like(qr{^HTTPS=NO}m, 'HTTPS=NO')->content_like(qr{^HTTP_COOKIE=}m, 'HTTP_COOKIE=') ->content_like(qr{^HTTP_HOST=(localhost|127\.0\.0\.1):\d+}m, 'HTTP_HOST=localhost:\d+') ->content_like(qr{^HTTP_REFERER=}m, 'HTTP_REFERER=') ->content_like(qr{^HTTP_USER_AGENT=Mojolicious \(Perl\)}m, 'HTTP_USER_AGENT=Mojolicious \(Perl\)') ->content_like(qr{^PATH_INFO=/foo}m, 'PATH_INFO=/foo') ->content_like(qr{^QUERY_STRING=query=123}m, 'QUERY_STRING=query=123') ->content_like(qr{^REMOTE_ADDR=\d+\S+}m, 'REMOTE_ADDR=\d+\S+') ->content_like(qr{^REMOTE_HOST=[\w\.]+}m, 'REMOTE_HOST=[\w\.]+') ->content_like(qr{^REMOTE_PORT=\w+}m, 'REMOTE_PORT=\w+') ->content_like(qr{^REMOTE_USER=}m, 'REMOTE_USER=') ->content_like(qr{^REQUEST_METHOD=GET}m, 'REQUEST_METHOD=GET') ->content_like(qr{^SCRIPT_FILENAME=\S+/t/cgi-bin/env\.cgi}m, 'SCRIPT_FILENAME=\S+/t/cgi-bin/env\.cgi') ->content_like(qr{^SCRIPT_NAME=/env/basic\W*$}m, 'SCRIPT_NAME=env/basic') ->content_like(qr{^SERVER_PORT=\d+}m, 'SERVER_PORT=\d+') ->content_like(qr{^SERVER_PROTOCOL=HTTP}m, 'SERVER_PROTOCOL=HTTP') ->content_like(qr{^SERVER_SOFTWARE=Mojolicious::Plugin::CGI}m, 'SERVER_SOFTWARE=Mojolicious::Plugin::CGI')->content_like(qr{^THE_ANSWER=42}m, 'THE_ANSWER=42'); $t->get_ok('/env/basic/foo' => {'Referer' => 'http://thorsen.pm', 'X-Forwarded-For' => '1.2.3.4'}) ->status_is(200) ->content_like(qr{^HTTP_REFERER=http://thorsen\.pm}m, 'HTTP_REFERER=http://thorsen.pm') ->content_like(qr{^HTTP_X_FORWARDED_FOR=1\.2\.3\.4}m, 'HTTP_X_FORWARDED_FOR=1.2.3.4'); done_testing; Mojolicious-Plugin-CGI-0.38/t/before.t000644 000765 000024 00000001035 13106404365 020636 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; use Mojolicious::Lite; plugin CGI => { route => '/user/:id', script => cgi_script('env.cgi'), before => sub { my $c = shift; my $query = $c->req->url->query; $query->param(id => $c->stash('id')); $query->param(other_value => 123); }, }; Test::Mojo->new->get_ok('/user/42')->status_is(200) ->content_like(qr{^QUERY_STRING=id=42}m, 'QUERY_STRING=id=42') ->content_like(qr{^QUERY_STRING=.*other_value=123}m, 'QUERY_STRING=...other_value=123'); done_testing; Mojolicious-Plugin-CGI-0.38/t/encoding.t000644 000765 000024 00000001320 13106404365 021157 0ustar00jhthorsenstaff000000 000000 use utf8; use lib '.'; use t::Helper; use Mojo::UserAgent; use Mojo::Util 'decode'; { use Mojolicious::Lite; use Mojo::Util 'decode'; plugin CGI => { route => '/', run => sub { diag "PATH_INFO=$ENV{PATH_INFO}"; print "HTTP/1.1 200 OK\r\n"; print "Content-Type: text/plain; charset=UTF-8\r\n"; print "\r\n"; print "p=$ENV{PATH_INFO}\n"; }, }; } # Application is alive my $t = Test::Mojo->new; my @w; $t->get_ok("/foo")->status_is(200)->content_is("p=/foo\n", 'ascii'); $t->get_ok("/föö")->status_is(200)->content_is("p=/föö\n", 'umlauts'); $t->get_ok("/fö’")->status_is(200)->content_is("p=/fö’\n", 'quote'); is "@w", "", "no warnings"; done_testing(); Mojolicious-Plugin-CGI-0.38/t/errlog.t000644 000765 000024 00000001370 13106404365 020670 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; unlink 't/err.log'; my $app = Mojolicious->new; my $t = Test::Mojo->new($app); my ($s, @err); $app->plugin(CGI => {route => '/err', script => cgi_script('errlog')}); $app->log->on( message => sub { my ($log, $level, $message) = @_; push @err, $message if $level eq 'warn'; } ); $t->get_ok('/err'); like $err[0], qr{\[CGI:errlog:\d+\] yikes! at .*errlog line 4}, 'logged stderr'; $app = Mojolicious->new; $t = Test::Mojo->new($app); $app->plugin(CGI => {route => '/err', script => cgi_script('errlog'), errlog => 't/err.log'}); $t->get_ok('/err'); $s = -s 't/err.log'; ok $s, 't/err.log has data'; $t->get_ok('/err'); ok -s 't/err.log' >= $s * 2, 't/err.log has more data'; unlink 't/err.log'; done_testing; Mojolicious-Plugin-CGI-0.38/t/foo.txt000644 000765 000024 00000000017 13106404365 020532 0ustar00jhthorsenstaff000000 000000 some more data Mojolicious-Plugin-CGI-0.38/t/gh-16-loop_reset.t000644 000765 000024 00000003601 13106404365 022370 0ustar00jhthorsenstaff000000 000000 BEGIN { $ENV{MOJO_REACTOR} = 'Mojo::Reactor::Poll' } use Mojo::Base -strict; use Test::More; plan skip_all => 'set TEST_MORBO to enable this test (developer only!)' unless $ENV{TEST_MORBO}; plan skip_all => 'Parallel::ForkManager is not available' unless eval 'require Parallel::ForkManager;1'; plan skip_all => 't/cgi-bin/slow.pl' unless -x 't/cgi-bin/slow.pl'; use File::Spec::Functions 'catdir'; use File::Temp 'tempdir'; use IO::Socket::INET; use Mojo::File 'path'; use Mojo::IOLoop::Server; use Mojo::Server::Daemon; use Mojo::Server::Morbo; use Mojo::UserAgent; # Prepare script my $n = 5; my $dir = tempdir CLEANUP => 1; my $script = catdir $dir, 'myapp.pl'; my $morbo = Mojo::Server::Morbo->new(watch => [$script]); path($script)->spurt(<<'EOF'); use Mojolicious::Lite; app->log->level('fatal'); plugin CGI => ['/slow' => 't/cgi-bin/slow.pl']; app->start; EOF # Start my $port = Mojo::IOLoop::Server->generate_port; # assume morbo is in the same dir as the perl runing this test # this is not WIN32 compatible, and 5.14+, but since dev test only... (my $prefix = $^X) =~ s!/perl[^/]*$!!; my $pid = open my $server, '-|', $^X, "$prefix/morbo", '-l', "http://127.0.0.1:$port", $script; sleep 1 until _server_running($port); my $ua = Mojo::UserAgent->new; my $pm = Parallel::ForkManager->new($n); $pm->run_on_finish( sub { my ($pid, $exit_code, $ident, $exit_signal, $core_dump, $data) = @_; my ($is_finished, $code, $body) = @$data; ok $is_finished, 'transaction is finished'; is $code, 200, 'right status'; } ); foreach my $req (1 .. $n) { $pm->start and next; my $tx = $ua->get("http://127.0.0.1:$port/slow"); $pm->finish(0, [$tx->is_finished, $tx->res->code, $tx->res->body]); } $pm->wait_all_children; kill 'INT', $pid; sleep 1 while _server_running($port); done_testing(); sub _server_running { IO::Socket::INET->new(PeerAddr => '127.0.0.1', PeerPort => shift) } Mojolicious-Plugin-CGI-0.38/t/Helper.pm000644 000765 000024 00000004645 13106404365 020776 0ustar00jhthorsenstaff000000 000000 package t::Helper; use Mojo::Base -strict; use File::Basename; use File::Spec::Functions qw(catdir catfile); use Mojolicious; use Mojo::Loader; use Test::Mojo; use Test::More; sub cgi_script { my $template = shift; my $script = catfile 't', 'cgi-bin', $template; mkdir catdir qw(t cgi-bin); open my $CGI_BIN, '>', $script or Test::More::plan(skip_all => "write $script: $!"); print $CGI_BIN "#!$^X\n"; print $CGI_BIN "use strict;\nuse warnings;\n"; print $CGI_BIN Mojo::Loader::data_section(__PACKAGE__, $template); close $CGI_BIN; eval { chmod 0755, $script }; return $script; } sub import { my $class = shift; my $caller = caller; Test::More::plan(skip_all => 'Skipping tests on Windows.') if $^O eq 'Win32'; eval <<"HERE"; package $caller; use Mojo::Base -strict; use Test::Mojo; use Test::More; HERE Mojo::Util::monkey_patch($caller => cgi_script => \&cgi_script); } 1; __DATA__ @@ basic.pl print "Content-Type: text/custom\n\r\n\rbasic stuff\n"; @@ env print "Content-Type: text/plain\n\r"; print "\n\rENVIRON"; print "MENT\n"; print "$_=$ENV{$_}\n" for sort keys %ENV; @@ env.cgi print "Content-Type: text/plain\n\r"; print "\n\rENVIRON"; print "MENT\n"; print "$_=$ENV{$_}\n" for sort keys %ENV; @@ errlog warn "yikes!"; print "Content-Type: text/plain\n\r\n\r"; print "yayayyaya\n"; @@ file_upload print "Content-Type: text/custom\n\r\n\r"; print "$$\n"; print "=== $ENV{$_}\n" for qw/CONTENT_TYPE CONTENT_LENGTH/; print "--- $_" while ; @@ not-found.pl print "Status: 404 Not Found\r\n"; print "Content-Type: text/html; charset=ISO-8859-1\r\n"; print "\r\n"; print "

This page is missing\n"; @@ not-modified.pl print "Status: 304 Not Modified\r\n"; print "X-Test: if-none-match seen: $ENV{HTTP_IF_NONE_MATCH}\r\n"; print "\r\n"; @@ nph-borked.pl # When SERVER_PROTOCOL is set to "HTTP", the CGI module will just print HTTP and # no version! print "HTTP 403 Payment Required\r\n"; print "Content-Type: text/html; charset=ISO-8859-1\r\n"; print "\r\n"; print "

This is the borked paywall.\n"; @@ nph.pl print "HTTP/1.1 403 Payment Required\r\n"; print "Content-Type: text/html; charset=ISO-8859-1\r\n"; print "\r\n"; print "

This is the paywall.\n"; @@ postman print "Content-Type: text/custom\n\r\n\r"; print "$$\n"; print "--- $_" while ; @@ redirect.pl print "Location: http://somewhereelse.com\n\r\n\r"; @@ slow.pl sleep 1; print "Content-Type: text/custom\n\r\n\rHello Morbo!\n"; Mojolicious-Plugin-CGI-0.38/t/helper.t000644 000765 000024 00000002377 13106404365 020665 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; use Mojolicious::Lite; plugin "CGI"; get "/cgi-bin/#script_name/*path_info" => {path_info => ''}, sub { my $c = shift; my $script_name = $c->stash('script_name'); $script_name = "$script_name.cgi" unless $script_name =~ /\.cgi$/; $c->cgi->run(script => File::Spec->rel2abs(cgi_script($script_name))); }; my $t = Test::Mojo->new; $t->get_ok('/cgi-bin/nope.cgi/foo')->status_is(500)->content_like(qr{Could not run CGI script}); $t->get_ok('/cgi-bin/env.cgi/some/path/info?query=123')->status_is(200) ->content_like(qr{^PATH_INFO=/some/path/info}m, 'PATH_INFO') ->content_like(qr{^QUERY_STRING=query=123}m, 'QUERY_STRING') ->content_like(qr{^SCRIPT_FILENAME=\S+/t/cgi-bin/env\.cgi$}m, 'SCRIPT_FILENAME') ->content_like(qr{^SCRIPT_NAME=/cgi-bin/env\.cgi$}m, 'SCRIPT_NAME'); $t->get_ok('/cgi-bin/env/some/path/info?query=123')->status_is(200) ->content_like(qr{^PATH_INFO=/some/path/info}m, 'PATH_INFO') ->content_like(qr{^QUERY_STRING=query=123}m, 'QUERY_STRING') ->content_like(qr{^SCRIPT_FILENAME=\S+/t/cgi-bin/env\.cgi$}m, 'SCRIPT_FILENAME') ->content_like(qr{^SCRIPT_NAME=/cgi-bin/env$}m, 'SCRIPT_NAME'); done_testing; Mojolicious-Plugin-CGI-0.38/t/multipart.t000644 000765 000024 00000001534 13106404365 021421 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; use Mojolicious::Lite; plugin CGI => ['/file_upload' => cgi_script('file_upload')]; my $t = Test::Mojo->new; $t->post_ok( '/file_upload' => form => { mytext => [ {file => 't/foo.txt'}, {file => 't/bar.txt'}, {file => 't/test_file_with_a_long_filename.txt'}, ] } ); $t->status_is(200); $t->content_like( qr{^\d+ === multipart/form-data; boundary=(\w+) === \d+ --- --\1\r --- Content-Disposition: form-data; name="mytext"; filename="foo\.txt"\r --- \r --- some more --- data --- \r --- --\1\r --- Content-Disposition: form-data; name="mytext"; filename="bar\.txt"\r --- \r --- even more --- data here --- \r --- --\1\r --- Content-Disposition: form-data; name="mytext"; filename="test_file_with_a_long_filename\.txt"\r --- \r --- and yet more --- data in here --- \r --- --\1--}s ); done_testing; Mojolicious-Plugin-CGI-0.38/t/not-found.t000644 000765 000024 00000000343 13106404365 021306 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; use Mojolicious::Lite; plugin CGI => ['/not-found' => cgi_script('not-found.pl')]; Test::Mojo->new->get_ok('/not-found', {})->status_is(404)->content_like(qr'This page is missing'); done_testing; Mojolicious-Plugin-CGI-0.38/t/not-modified.t000644 000765 000024 00000000423 13106404365 021752 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; use Mojolicious::Lite; plugin CGI => ['/not-modified' => cgi_script('not-modified.pl')]; Test::Mojo->new->get_ok('/not-modified' => {'If-None-Match' => 'ABC'})->status_is(304) ->header_is('X-Test' => 'if-none-match seen: ABC'); done_testing; Mojolicious-Plugin-CGI-0.38/t/nph-borked.t000644 000765 000024 00000000357 13106404365 021433 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; use Mojolicious::Lite; plugin CGI => ['/nph-borked' => cgi_script('nph-borked.pl')]; Test::Mojo->new->get_ok('/nph-borked', {})->status_is(403) ->content_like(qr'This is the borked paywall'); done_testing; Mojolicious-Plugin-CGI-0.38/t/nph.t000644 000765 000024 00000000320 13106404365 020155 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; use Mojolicious::Lite; plugin CGI => ['/nph' => cgi_script('nph.pl')]; Test::Mojo->new->get_ok('/nph', {})->status_is(403)->content_like(qr'This is the paywall'); done_testing; Mojolicious-Plugin-CGI-0.38/t/post.t000644 000765 000024 00000003612 13106404365 020364 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; # http://cpantesters.org/cpan/report/dc79de2e-c956-11e4-9245-4861e0bfc7aa # http://cpantesters.org/cpan/report/676eae4c-24f6-11e5-ad16-fd611bfff594 # http://cpantesters.org/cpan/report/908763b4-24f6-11e5-8c9c-b46a1bfff594 # http://cpantesters.org/cpan/report/1c1f3f16-8a17-11e5-b552-e159351a082c plan skip_all => 'TEST_PIPES=1; No idea how to test this consistently' unless $ENV{TEST_PIPES}; my @pipes = get_pipes(); my %LSOF_PIPE; # Map lsof DEVICE and NAME to same pipe. use Mojolicious::Lite; plugin CGI => ['/postman' => 't/cgi-bin/postman']; my $t = Test::Mojo->new; $t->post_ok('/postman', {}, "some\ndata\n")->status_is(200)->content_like(qr{^\d+\n--- some\n--- data\n$}); my $pid = $t->tx->res->body =~ /(\d+)/ ? $1 : 0; ok !(kill 0, $pid), "child $pid is taken care of ($$, @{[time]})" or is waitpid($pid, 0), $pid, "waitpid $pid, 0 ($$, @{[time]})"; is_deeply \@pipes, [get_pipes()], 'no leaky leaks'; sub get_pipes { return diag "test for leaky pipes under Debian build", 1 if $ENV{DEBIAN_BUILD}; my @pipes; if (-d "/proc/$$/fd") { for my $fd (glob "/proc/$$/fd/*") { my $pts = readlink sprintf '/proc/%s/fd/%s', $$, +(split '/', $fd)[-1] or next; push @pipes, $pts if $pts =~ /pipe:/; } } elsif (`which lsof` =~ /\blsof$/) { # Output of `lsof` for pipe looks like this: # COMMAND PID USER FD TYPE DEVICE SIZE/OFF NODE NAME # perl5.18 57806 moejoe 3 PIPE 0xd52803906b02a64f 16384 ->0xd52803907288254f for (`lsof -p $$`) { / PIPE / or next; my ($device, $name) = /\b(0x[[:xdigit:]]+)/g; my $pipe = $LSOF_PIPE{$device} || $LSOF_PIPE{$name} || $device; $LSOF_PIPE{$device} = $LSOF_PIPE{$name} = $pipe; push @pipes, $pipe; } } else { diag "unable to test leaky pipes"; } return sort @pipes; } done_testing; Mojolicious-Plugin-CGI-0.38/t/query-string-with-semicolon.t000644 000765 000024 00000001155 13106404365 025007 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; my $this_will_mess_up; use Mojolicious::Lite; plugin CGI => {support_semicolon_in_query_string => 1}; app->hook( before_dispatch => sub { my $c = shift; $this_will_mess_up = $c->req->url->query->param('a'); } ); plugin CGI => {route => '/env/basic', script => cgi_script('env.cgi'), env => {}}; my $t = Test::Mojo->new; $t->get_ok('/env/basic/foo?a=1;b=2')->status_is(200) ->content_like(qr{^QUERY_STRING=a=1;b=2}m, 'QUERY_STRING with semicolon'); local $TODO = 'mojolicious cannot parse query with semicolon'; is $this_will_mess_up, '1', 'not messed up'; done_testing; Mojolicious-Plugin-CGI-0.38/t/redirect.t000644 000765 000024 00000000400 13106404365 021170 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; use Mojolicious::Lite; plugin CGI => ['/redirect' => cgi_script('redirect.pl')]; Test::Mojo->new->get_ok('/redirect', {})->status_is(302) ->header_is('Location' => 'http://somewhereelse.com')->content_is(''); done_testing; Mojolicious-Plugin-CGI-0.38/t/remote-user.t000644 000765 000024 00000001234 13106404365 021644 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; use Mojolicious::Lite; plugin CGI => {route => '/auth', script => cgi_script('env.cgi'), env => {}}; my $t = Test::Mojo->new; $t->get_ok('/auth')->status_is(200)->status_is(200) ->content_like(qr{^REMOTE_USER=}m, 'REMOTE_USER='); $t->get_ok($t->tx->req->url->clone->userinfo('Aladdin:foopass'), {'Authorization' => ''}) ->status_is(200)->content_like(qr{^REMOTE_USER=Aladdin$}m, 'REMOTE_USER=Aladdin'); $t->get_ok( $t->tx->req->url->clone->userinfo('whatever:foopass'), {'Authorization' => 'Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ=='} )->status_is(200)->content_like(qr{^REMOTE_USER=Aladdin$}m, 'REMOTE_USER=Aladdin'); done_testing; Mojolicious-Plugin-CGI-0.38/t/run.t000644 000765 000024 00000000534 13106404365 020203 0ustar00jhthorsenstaff000000 000000 use lib '.'; use t::Helper; use Mojolicious::Lite; plugin CGI => { route => '/', run => sub { print "HTTP/1.1 200 OK\r\n"; print "Content-Type: text/html; charset=ISO-8859-1\r\n"; print "\r\n"; print "

Hi!\n"; }, }; my $t = Test::Mojo->new; $t->get_ok('/')->status_is(200)->content_like(qr/Hi!/); done_testing; Mojolicious-Plugin-CGI-0.38/t/test_file_with_a_long_filename.txt000644 000765 000024 00000000032 13106404365 026134 0ustar00jhthorsenstaff000000 000000 and yet more data in here Mojolicious-Plugin-CGI-0.38/t/zombies.t000644 000765 000024 00000004643 13106404365 021054 0ustar00jhthorsenstaff000000 000000 use Mojo::Base -strict; use Test::More; use File::Spec::Functions 'catfile'; use File::Temp 'tempdir'; use FindBin; use IO::Socket::INET; use Mojo::File 'path'; use Mojo::IOLoop::Server; use Mojo::UserAgent; plan skip_all => $@ unless -e '.git' and eval 'require Proc::ProcessTable && require File::Which && 1'; # Prepare script my $dir = tempdir CLEANUP => 1; my $script = catfile $dir, 'myapp.pl'; my $port = Mojo::IOLoop::Server->generate_port; path($script)->spurt(< { default => { hypnotoad => { inactivity_timeout => 3, listen => ['http://127.0.0.1:$port'], workers => 2 } } }; plugin CGI => { route => '/', script => "$script", # this is required to run the test for 0.26 run => sub { print "HTTP/1.1 200 OK\r\n"; print "Content-Type: text/text; charset=ISO-8859-1\r\n"; print "\r\n"; print "Hello CGI!\n"; }, }; app->start; EOF # Start server my $hypnotoad = File::Which::which('hypnotoad'); open my $start, '-|', $^X, $hypnotoad, $script; sleep 1 while !_port($port); # Remember PID open my $file, '<', catfile($dir, 'hypnotoad.pid'); my $pid = <$file>; chomp $pid; ok $pid, "PID $pid found"; # Application is alive my $ua = Mojo::UserAgent->new; my $tx = $ua->get("http://127.0.0.1:$port/"); is $tx->res->code, 200, 'right status'; is $tx->res->body, "Hello CGI!\n", 'right content'; # Hammer the server my $requests = 20; diag("Hammering the server with $requests requests"); for my $i (1 .. $requests) { $ua->get("http://127.0.0.1:$port/"); sleep 1; } # See whether zombies are reaped my $seconds = 20; my $ts = time; diag("Waiting for the reaper"); for my $i (1 .. $seconds) { sleep 1; last if _zombies() == 0; } my $delta = time - $ts; is _zombies(), 0, "No zombies left after $delta seconds"; # Stop the server open my $stop, '-|', $^X, $hypnotoad, $script, '-s'; sleep 1 while _port($port); # Checking Processes my $alive = kill 0 => $pid; is $alive, 0, "$pid is terminated"; sub _port { IO::Socket::INET->new(PeerAddr => '127.0.0.1', PeerPort => shift) } sub _zombies { my $processes = Proc::ProcessTable->new(enable_ttys => 0); # say join(', ', $processes->fields); my $grp = getpgrp $pid; my $zombies = 0; foreach my $proc (@{$processes->table}) { $zombies++ if $proc->pgrp == $grp and $proc->state eq 'defunct'; } return $zombies; } done_testing(); Mojolicious-Plugin-CGI-0.38/lib/Mojolicious/000755 000765 000024 00000000000 13117562745 022020 5ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.38/lib/Mojolicious/Plugin/000755 000765 000024 00000000000 13117562745 023256 5ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.38/lib/Mojolicious/Plugin/CGI.pm000644 000765 000024 00000030547 13117562744 024226 0ustar00jhthorsenstaff000000 000000 package Mojolicious::Plugin::CGI; use Mojo::Base 'Mojolicious::Plugin'; use File::Basename; use File::Spec; use IO::Pipely 'pipely'; use Mojo::Util qw(b64_decode encode); use POSIX 'WNOHANG'; use Perl::OSType 'is_os_type'; use Socket qw(AF_INET inet_aton); use Sys::Hostname; use constant CHECK_CHILD_INTERVAL => $ENV{CHECK_CHILD_INTERVAL} || 0.01; use constant DEBUG => $ENV{MOJO_PLUGIN_CGI_DEBUG}; use constant IS_WINDOWS => is_os_type('Windows'); use constant READ => 0; use constant WRITE => 1; our $VERSION = '0.38'; our %ORIGINAL_ENV = %ENV; has env => sub { +{%ORIGINAL_ENV} }; sub register { my ($self, $app, $args) = @_; my $pids = $app->{'mojolicious_plugin_cgi.pids'} ||= {}; $args = {route => shift @$args, script => shift @$args} if ref $args eq 'ARRAY'; $args->{env} ||= $self->env; $args->{run} = delete $args->{script} if ref $args->{script} eq 'CODE'; $args->{pids} = $pids; $app->helper('cgi.run' => sub { _run($args, @_) }) unless $app->renderer->helpers->{'cgi.run'}; $app->{'mojolicious_plugin_cgi.tid'} ||= Mojo::IOLoop->recurring(CHECK_CHILD_INTERVAL, sub { local ($?, $!); _waitpids($pids); }); if ($args->{support_semicolon_in_query_string} and !$app->{'mojolicious_plugin_cgi.before_dispatch'}++) { $app->hook( before_dispatch => sub { $_[0]->stash('cgi.query_string' => $_[0]->req->url->query->to_string); } ); } return unless $args->{route}; # just register the helper die "Neither 'run', nor 'script' is specified." unless $args->{run} or $args->{script}; $args->{route} = $app->routes->any("$args->{route}/*path_info", {path_info => ''}) unless ref $args->{route}; $args->{script} = File::Spec->rel2abs($args->{script}) || $args->{script} if $args->{script}; $args->{route}->to(cb => sub { _run($args, @_) }); } sub _child { my ($c, $args, $stdin, $stdout, $stderr) = @_; my @STDERR = @$stderr ? ('>&', fileno $stderr->[WRITE]) : ('>>', $args->{errlog}); Mojo::IOLoop->reset; warn "[CGI:$args->{name}:$$] <<< (@{[$stdin->slurp]})\n" if DEBUG; open STDIN, '<', $stdin->path or die "STDIN @{[$stdin->path]}: $!" if -s $stdin->path; open STDERR, $STDERR[0], $STDERR[1] or die "STDERR: @$stderr: $!"; open STDOUT, '>&', fileno $stdout->[WRITE] or die "STDOUT: $!"; select STDERR; $| = 1; select STDOUT; $| = 1; %ENV = _emulate_environment($c, $args); $args->{run} ? $args->{run}->($c) : exec $args->{script} || die "Could not execute $args->{script}: $!"; eval { POSIX::_exit($!) } unless IS_WINDOWS; eval { CORE::kill KILL => $$ }; exit $!; } sub _emulate_environment { my ($c, $args) = @_; my $tx = $c->tx; my $req = $tx->req; my $headers = $req->headers; my $content_length = $req->content->is_multipart ? $req->body_size : $headers->content_length; my %env_headers = (HTTP_COOKIE => '', HTTP_REFERER => ''); my ($remote_user, $script_name); for my $name (@{$headers->names}) { my $key = uc "http_$name"; $key =~ s!\W!_!g; $env_headers{$key} = $headers->header($name); } if (my $userinfo = $c->req->url->to_abs->userinfo) { $remote_user = $userinfo =~ /([^:]+)/ ? $1 : ''; } elsif (my $authenticate = $headers->authorization) { $remote_user = $authenticate =~ /Basic\s+(.*)/ ? b64_decode $1 : ''; $remote_user = $remote_user =~ /([^:]+)/ ? $1 : ''; } if ($args->{route}) { $script_name = $c->url_for($args->{route}->name, {path_info => ''})->path->to_string; } elsif (my $name = $c->stash('script_name')) { my $name = quotemeta $name; $script_name = $c->req->url->path =~ m!^(.*?/$name)! ? $1 : $c->stash('script_name'); } return ( %{$args->{env}}, CONTENT_LENGTH => $content_length || 0, CONTENT_TYPE => $headers->content_type || '', GATEWAY_INTERFACE => 'CGI/1.1', HTTPS => $req->is_secure ? 'YES' : 'NO', %env_headers, PATH_INFO => '/' . encode('UTF-8', $c->stash('path_info') // ''), QUERY_STRING => $c->stash('cgi.query_string') || $req->url->query->to_string, REMOTE_ADDR => $tx->remote_address, REMOTE_HOST => gethostbyaddr(inet_aton($tx->remote_address || '127.0.0.1'), AF_INET) || '', REMOTE_PORT => $tx->remote_port, REMOTE_USER => $remote_user || '', REQUEST_METHOD => $req->method, SCRIPT_FILENAME => $args->{script} || '', SCRIPT_NAME => $script_name || $args->{name}, SERVER_ADMIN => $ENV{USER} || '', SERVER_NAME => hostname, SERVER_PORT => $tx->local_port, SERVER_PROTOCOL => $req->is_secure ? 'HTTPS' : 'HTTP', # TODO: Version is missing SERVER_SOFTWARE => __PACKAGE__, ); } sub _run { my ($defaults, $c) = (shift, shift); my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}; my $before = $args->{before} || $defaults->{before}; my $stdin = _stdin($c); my @stdout = pipely; my ($pid, $log_key, @stderr); $args->{$_} ||= $defaults->{$_} for qw(env errlog route run script); $args->{name} = $args->{run} ? "$args->{run}" : basename $args->{script}; $c->$before($args) if $before; @stderr = (pipely) unless $args->{errlog}; defined($pid = fork) or die "[CGI:$args->{name}] fork failed: $!"; _child($c, $args, $stdin, \@stdout, \@stderr) unless $pid; $args->{pids}{$pid} = $args->{name}; $log_key = "CGI:$args->{name}:$pid"; $c->app->log->debug("[$log_key] START @{[$args->{script} || $args->{run}]}"); for my $p (\@stdout, \@stderr) { next unless $p->[READ]; close $p->[WRITE]; $p->[READ] = Mojo::IOLoop::Stream->new($p->[READ])->timeout(0); Mojo::IOLoop->stream($p->[READ]); } $c->delay( sub { my ($delay) = @_; $c->stash('cgi.pid' => $pid, 'cgi.stdin' => $stdin); $stderr[READ]->on(read => _stderr_cb($c, $log_key)) if $stderr[READ]; $stdout[READ]->on(read => _stdout_cb($c, $log_key)); $stdout[READ]->on(close => $delay->begin); }, sub { my ($delay) = @_; my $GUARD = 50; warn "[CGI:$args->{name}:$pid] Child closed STDOUT\n" if DEBUG; unlink $stdin->path or die "Could not remove STDIN @{[$stdin->path]}" if -e $stdin->path; local ($?, $!); _waitpids({$pid => $args->{pids}{$pid}}) while $args->{pids}{$pid} and kill 0, $pid and $GUARD--; $defaults->{pids}{$pid} = $args->{pids}{$pid} if kill 0, $pid; return $c->finish if $c->res->code; return $c->render(text => "Could not run CGI script ($?, $!).\n", status => 500); }, ); } sub _stderr_cb { my ($c, $log_key) = @_; my $log = $c->app->log; my $buf = ''; return sub { my ($stream, $chunk) = @_; warn "[$log_key] !!! ($chunk)\n" if DEBUG; $buf .= $chunk; $log->warn("[$log_key] $1") while $buf =~ s!^(.+)[\r\n]+$!!m; }; } sub _stdout_cb { my ($c, $log_key) = @_; my $buf = ''; my $headers; return sub { my ($stream, $chunk) = @_; warn "[$log_key] >>> ($chunk)\n" if DEBUG; # true if HTTP header has been written to client return $c->write($chunk) if $headers; $buf .= $chunk; # false until all headers has been read from the CGI script $buf =~ s/^(.*?\x0a\x0d?\x0a\x0d?)//s or return; $headers = $1; if ($headers =~ /^HTTP/) { $c->res->code($headers =~ m!^HTTP (\d\d\d)! ? $1 : 200); $c->res->parse($headers); } else { $c->res->code($1) if $headers =~ /^Status: (\d\d\d)/m; $c->res->code($headers =~ /Location:/ ? 302 : 200) unless $c->res->code; $c->res->parse($c->res->get_start_line_chunk(0) . $headers); } $c->write($buf) if length $buf; }; } sub _stdin { my $c = shift; my $stdin; if ($c->req->content->is_multipart) { $stdin = Mojo::Asset::File->new; $stdin->add_chunk($c->req->build_body); } else { $stdin = $c->req->content->asset; } return $stdin if $stdin->isa('Mojo::Asset::File'); return Mojo::Asset::File->new->add_chunk($stdin->slurp); } sub _waitpids { my $pids = shift; for my $pid (keys %$pids) { # no idea why i need to do this, but it seems like waitpid() below return -1 if not local $SIG{CHLD} = 'DEFAULT'; next unless waitpid $pid, WNOHANG; my $name = delete $pids->{$pid} || 'unknown'; my ($exit_value, $signal) = ($? >> 8, $? & 127); warn "[CGI:$name:$pid] Child exit_value=$exit_value ($signal)\n" if DEBUG; } } 1; =encoding utf8 =head1 NAME Mojolicious::Plugin::CGI - Run CGI script from Mojolicious =head1 VERSION 0.38 =head1 DESCRIPTION This plugin enable L to run Perl CGI scripts. It does so by forking a new process with a modified environment and reads the STDOUT in a non-blocking manner. =head1 SYNOPSIS =head2 Standard usage use Mojolicious::Lite; plugin CGI => [ "/cgi-bin/script" => "/path/to/cgi/script.pl" ]; Using the code above is enough to run C when accessing L. =head2 Complex usage plugin CGI => { # Specify the script and mount point script => "/path/to/cgi/script.pl", route => "/some/route", # %ENV variables visible from inside the CGI script env => {}, # default is \%ENV # Path to where STDERR from cgi script goes errlog => "/path/to/file.log", # The "before" hook is called before script start # It receives a Mojolicious::Controller which can be modified before => sub { my $c = shift; $c->req->url->query->param(a => 123); }, }; The above contains all the options you can pass on to the plugin. =head2 Helper plugin "CGI"; # GET /cgi-bin/some-script.cgi/path/info?x=123 get "/cgi-bin/#script_name/*path_info" => {path_info => ''}, sub { my $c = shift; my $name = $c->stash("script_name"); $c->cgi->run(script => File::Spec->rel2abs("/path/to/cgi/$name")); }; The helper can take most the arguments that L takes, with the exception of C. It is critical that "script_name" and "path_info" is present in L. If the values are extracted directly from the path or set manually does not matter. Note that the helper is registered in all of the examples. =head2 Running code refs plugin CGI => { route => "/some/path", run => sub { my $cgi = CGI->new; # ... } }; Instead of calling a script, you can run a code block when accessing the route. This is (pretty much) safe, even if the code block modifies global state, since it runs in a separate fork/process. =head2 Support for semicolon in query string plugin CGI => { support_semicolon_in_query_string => 1, ... }; The code above need to be added before other plugins or handler which use L. It will inject a C hook which saves the original QUERY_STRING, before it is split on "&" in L. =head1 ATTRIBUTES =head2 env Holds a hash ref containing the environment variables that should be used when starting the CGI script. Defaults to C<%ENV> when this module was loaded. This plugin will create a set of environment variables depenendent on the request passed in which is according to the CGI spec. In addition to L, these dynamic variables are set: CONTENT_LENGTH, CONTENT_TYPE, HTTPS, PATH, PATH_INFO, QUERY_STRING, REMOTE_ADDR, REMOTE_HOST, REMOTE_PORT, REMOTE_USER, REQUEST_METHOD, SCRIPT_NAME, SERVER_PORT, SERVER_PROTOCOL. Additional static variables: GATEWAY_INTERFACE = "CGI/1.1" SERVER_ADMIN = $ENV{USER} SCRIPT_FILENAME = Script name given as argument to register. SERVER_NAME = Sys::Hostname::hostname() SERVER_SOFTWARE = "Mojolicious::Plugin::CGI" Plus all headers are exposed. Examples: .----------------------------------------. | Header | Variable | |-----------------|----------------------| | Referer | HTTP_REFERER | | User-Agent | HTTP_USER_AGENT | | X-Forwarded-For | HTTP_X_FORWARDED_FOR | '----------------------------------------' =head2 register $self->register($app, [ $route => $script ]); $self->register($app, %args); $self->register($app, \%args); C and L need to exist as keys in C<%args> unless given as plain arguments. C<$route> can be either a plain path or a route object. =head1 COPYRIGHT AND LICENSE Copyright (C) 2014, Jan Henning Thorsen This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. =head1 AUTHOR Jan Henning Thorsen - C =cut