Mojolicious-Plugin-CGI-0.25/000755 000765 000024 00000000000 12626032523 016740 5ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.25/.perltidyrc000644 000765 000024 00000000720 12561726434 021132 0ustar00jhthorsenstaff000000 000000 -pbp # Start with Perl Best Practices -w # Show all warnings -iob # Ignore old breakpoints -l=120 # 120 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.25/.ship.conf000644 000765 000024 00000000524 12561726434 020642 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.25/.travis.yml000644 000765 000024 00000000402 12626032167 021051 0ustar00jhthorsenstaff000000 000000 language: perl perl: - "5.20" - "5.14" - "5.10" env: - "HARNESS_OPTIONS=j1 TEST_POD=1 TEST_MORBO=1 TEST_PIPES=1" install: - "cpanm -n Test::Pod Test::Pod::Coverage Parallel::ForkManager" - "cpanm -n --installdeps ." notifications: email: false Mojolicious-Plugin-CGI-0.25/Changes000644 000765 000024 00000006065 12626032522 020241 0ustar00jhthorsenstaff000000 000000 Revision history for perl distribution Mojolicious-Plugin-CGI 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.25/cpanfile000644 000765 000024 00000000372 12561726434 020457 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" => "5.08"; test_requires "Test::More" => "0.88"; Mojolicious-Plugin-CGI-0.25/example.cgi000755 000765 000024 00000000204 12561726434 021067 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/perl #PERL5LIB=lib ./example.cgi cgi use Mojolicious::Lite; plugin CGI => [ '/' => 't/cgi-bin/working.pl' ]; app->start; Mojolicious-Plugin-CGI-0.25/lib/000755 000765 000024 00000000000 12626032522 017505 5ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.25/Makefile.PL000644 000765 000024 00000001500 12626032522 020705 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' => '5.08' } , test => { TESTS => 't/*.t' }, ); Mojolicious-Plugin-CGI-0.25/META.json000664 000765 000024 00000002344 12626032523 020366 0ustar00jhthorsenstaff000000 000000 { "abstract" : "Run CGI script from Mojolicious", "author" : [ "Jan Henning Thorsen " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001", "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" : "5.08" } } }, "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.25" } Mojolicious-Plugin-CGI-0.25/META.yml000664 000765 000024 00000001375 12626032522 020220 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.0401, CPAN::Meta::Converter version 2.150001' 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: '5.08' 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.25' Mojolicious-Plugin-CGI-0.25/pm_to_blib000644 000765 000024 00000000000 12561726434 020770 0ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.25/README000644 000765 000024 00000006645 12626032522 017632 0ustar00jhthorsenstaff000000 000000 NAME Mojolicious::Plugin::CGI - Run CGI script from Mojolicious VERSION 0.25 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. 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. ioloop Holds a Mojo::IOLoop object. METHODS emulate_environment %env = $self->emulate_environment($c); Returns a hash which contains the environment variables which should be used by the CGI script. In addition to "env", these dynamic variables are set: CONTENT_LENGTH, CONTENT_TYPE, HTTP_COOKIE, HTTP_HOST, HTTP_IF_NONE_MATCH, HTTP_REFERER, HTTP_USER_AGENT, 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" 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.25/t/000755 000765 000024 00000000000 12626032522 017202 5ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.25/t/00-basic.t000644 000765 000024 00000002142 12561726435 020677 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.25/t/bar.txt000644 000765 000024 00000000024 12561726435 020516 0ustar00jhthorsenstaff000000 000000 even more data here Mojolicious-Plugin-CGI-0.25/t/basic.t000644 000765 000024 00000004173 12561726435 020470 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; plan skip_all => 't/cgi-bin/working.pl' unless -x 't/cgi-bin/working.pl'; { use Mojolicious::Lite; plugin CGI => ['/working' => 't/cgi-bin/working.pl']; plugin CGI => {route => '/env/basic', script => 't/cgi-bin/env.cgi', env => {}}; } 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=/env/basic') ->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=')->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'); done_testing; Mojolicious-Plugin-CGI-0.25/t/before.t000644 000765 000024 00000001235 12561726435 020645 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; plan skip_all => 't/cgi-bin/working.pl' unless -x 't/cgi-bin/working.pl'; { use Mojolicious::Lite; plugin CGI => { route => '/user/:id', script => 't/cgi-bin/env.cgi', before => sub { my $c = shift; my $query = $c->req->url->query; $query->param(id => $c->stash('id')); $query->param(other_value => 123); }, }; } my $t = Test::Mojo->new; $t->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.25/t/cgi-bin/000755 000765 000024 00000000000 12626032522 020512 5ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.25/t/errlog.t000644 000765 000024 00000001637 12561726435 020703 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; use Mojolicious; plan skip_all => 't/cgi-bin/errlog' unless -x 't/cgi-bin/errlog'; unlink 't/err.log'; { my $app = Mojolicious->new; my $t = Test::Mojo->new($app); my @err; $app->plugin(CGI => {route => '/err', script => 't/cgi-bin/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 2}, 'logged stderr'; } { my $app = Mojolicious->new; my $t = Test::Mojo->new($app); my $s; $app->plugin(CGI => {route => '/err', script => 't/cgi-bin/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.25/t/foo.txt000644 000765 000024 00000000017 12561726435 020537 0ustar00jhthorsenstaff000000 000000 some more data Mojolicious-Plugin-CGI-0.25/t/gh-16-loop_reset.t000644 000765 000024 00000003652 12561726435 022403 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::IOLoop::Server; use Mojo::Server::Daemon; use Mojo::Server::Morbo; use Mojo::UserAgent; use Mojo::Util 'spurt'; # Prepare script my $n = 5; my $dir = tempdir CLEANUP => 1; my $script = catdir $dir, 'myapp.pl'; my $morbo = Mojo::Server::Morbo->new(watch => [$script]); spurt <<'EOF', $script; 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.25/t/multipart.t000644 000765 000024 00000001673 12561726435 021432 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; plan skip_all => 't/cgi-bin/file_upload' unless -x 't/cgi-bin/file_upload'; { use Mojolicious::Lite; plugin CGI => [ '/file_upload' => 't/cgi-bin/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.25/t/not-found.t000644 000765 000024 00000000554 12620726145 021311 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; plan skip_all => 't/cgi-bin/not-found.pl' unless -x 't/cgi-bin/not-found.pl'; { use Mojolicious::Lite; plugin CGI => [ '/not-found' => 't/cgi-bin/not-found.pl' ]; } my $t = Test::Mojo->new; $t->get_ok('/not-found', {} ) ->status_is(404) ->content_like(qr'This page is missing'); done_testing; Mojolicious-Plugin-CGI-0.25/t/not-modified.t000644 000765 000024 00000000642 12620726145 021754 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; plan skip_all => 't/cgi-bin/not-modified.pl' unless -x 't/cgi-bin/not-modified.pl'; { use Mojolicious::Lite; plugin CGI => [ '/not-modified' => 't/cgi-bin/not-modified.pl' ]; } my $t = Test::Mojo->new; $t->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.25/t/nph-borked.t000644 000765 000024 00000000567 12620726145 021435 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; plan skip_all => 't/cgi-bin/nph-borked.pl' unless -x 't/cgi-bin/nph-borked.pl'; { use Mojolicious::Lite; plugin CGI => [ '/nph-borked' => 't/cgi-bin/nph-borked.pl' ]; } my $t = Test::Mojo->new; $t->get_ok('/nph-borked', {} ) ->status_is(403) ->content_like(qr'This is the borked paywall'); done_testing; Mojolicious-Plugin-CGI-0.25/t/nph.t000644 000765 000024 00000000515 12620726145 020162 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; plan skip_all => 't/cgi-bin/nph.pl' unless -x 't/cgi-bin/nph.pl'; { use Mojolicious::Lite; plugin CGI => [ '/nph' => 't/cgi-bin/nph.pl' ]; } my $t = Test::Mojo->new; $t->get_ok('/nph', {} ) ->status_is(403) ->content_like(qr'This is the paywall'); done_testing; Mojolicious-Plugin-CGI-0.25/t/post.t000644 000765 000024 00000003612 12626032120 020350 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.25/t/query-string-with-semicolon.t000644 000765 000024 00000001351 12561726435 025012 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; plan skip_all => 't/cgi-bin/working.pl' unless -x 't/cgi-bin/working.pl'; 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 => 't/cgi-bin/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.25/t/redirect.t000644 000765 000024 00000000607 12561726435 021206 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; plan skip_all => 't/cgi-bin/redirect.pl' unless -x 't/cgi-bin/redirect.pl'; { use Mojolicious::Lite; plugin CGI => [ '/redirect' => 't/cgi-bin/redirect.pl' ]; } my $t = Test::Mojo->new; $t->get_ok('/redirect', {} ) ->status_is(302) ->header_is('Location' => 'http://somewhereelse.com') ->content_is(''); done_testing; Mojolicious-Plugin-CGI-0.25/t/remote-user.t000644 000765 000024 00000001410 12561726435 021645 0ustar00jhthorsenstaff000000 000000 use warnings; use strict; use Test::More; use Test::Mojo; plan skip_all => 't/cgi-bin/working.pl' unless -x 't/cgi-bin/working.pl'; { use Mojolicious::Lite; plugin CGI => {route => '/auth', script => 't/cgi-bin/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.25/t/test_file_with_a_long_filename.txt000644 000765 000024 00000000032 12561726435 026141 0ustar00jhthorsenstaff000000 000000 and yet more data in here Mojolicious-Plugin-CGI-0.25/t/cgi-bin/env.cgi000755 000765 000024 00000000205 12561726435 022001 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/perl print "Content-Type: text/plain\n\r"; print "\n\rENVIRON"; print "MENT\n"; print "$_=$ENV{$_}\n" for sort keys %ENV; Mojolicious-Plugin-CGI-0.25/t/cgi-bin/errlog000755 000765 000024 00000000142 12561726435 021742 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/env perl warn "yikes!"; print "Content-Type: text/plain\n\r\n\r"; print "yayayyaya\n"; Mojolicious-Plugin-CGI-0.25/t/cgi-bin/file_upload000755 000765 000024 00000000302 12561726435 022731 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; print "Content-Type: text/custom\n\r\n\r"; print "$$\n"; print "=== $ENV{$_}\n" for qw/CONTENT_TYPE CONTENT_LENGTH/; print "--- $_" while ; Mojolicious-Plugin-CGI-0.25/t/cgi-bin/not-found.pl000755 000765 000024 00000000301 12620726145 022762 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; 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"; Mojolicious-Plugin-CGI-0.25/t/cgi-bin/not-modified.pl000755 000765 000024 00000000245 12620726145 023436 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; print "Status: 304 Not Modified\r\n"; print "X-Test: if-none-match seen: $ENV{HTTP_IF_NONE_MATCH}\r\n"; print "\r\n"; Mojolicious-Plugin-CGI-0.25/t/cgi-bin/nph-borked.pl000755 000765 000024 00000000454 12620726145 023113 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; # 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"; Mojolicious-Plugin-CGI-0.25/t/cgi-bin/nph.pl000755 000765 000024 00000000312 12620726145 021640 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; 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"; Mojolicious-Plugin-CGI-0.25/t/cgi-bin/postman000755 000765 000024 00000000205 12561726435 022131 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; print "Content-Type: text/custom\n\r\n\r"; print "$$\n"; print "--- $_" while ; Mojolicious-Plugin-CGI-0.25/t/cgi-bin/redirect.pl000755 000765 000024 00000000142 12561726435 022663 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; print "Location: http://somewhereelse.com\n\r\n\r"; Mojolicious-Plugin-CGI-0.25/t/cgi-bin/slow.pl000755 000765 000024 00000000160 12561726435 022046 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; sleep 1; print "Content-Type: text/custom\n\r\n\rHello Morbo!\n"; Mojolicious-Plugin-CGI-0.25/t/cgi-bin/working.pl000755 000765 000024 00000000146 12561726435 022546 0ustar00jhthorsenstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; print "Content-Type: text/custom\n\r\n\rbasic stuff\n"; Mojolicious-Plugin-CGI-0.25/lib/Mojolicious/000755 000765 000024 00000000000 12626032522 022001 5ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.25/lib/Mojolicious/Plugin/000755 000765 000024 00000000000 12626032522 023237 5ustar00jhthorsenstaff000000 000000 Mojolicious-Plugin-CGI-0.25/lib/Mojolicious/Plugin/CGI.pm000644 000765 000024 00000025244 12626032522 024206 0ustar00jhthorsenstaff000000 000000 package Mojolicious::Plugin::CGI; =head1 NAME Mojolicious::Plugin::CGI - Run CGI script from Mojolicious =head1 VERSION 0.25 =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 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. =cut use Mojo::Base 'Mojolicious::Plugin'; use Mojo::Util 'b64_decode'; use File::Basename; use File::Spec; use Sys::Hostname; use IO::Pipely 'pipely'; use POSIX 'WNOHANG'; use Socket qw( AF_INET inet_aton ); use constant CHUNK_SIZE => 131072; use constant CHECK_CHILD_INTERVAL => $ENV{CHECK_CHILD_INTERVAL} || 0.01; use constant DEBUG => $ENV{MOJO_PLUGIN_CGI_DEBUG} || 0; use constant READ => 0; use constant WRITE => 1; our $VERSION = '0.25'; our %ORIGINAL_ENV = %ENV; =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. =head2 ioloop Holds a L object. =cut has env => sub { +{%ORIGINAL_ENV} }; has ioloop => sub { Mojo::IOLoop->singleton }; =head1 METHODS =head2 emulate_environment %env = $self->emulate_environment($c); Returns a hash which contains the environment variables which should be used by the CGI script. In addition to L, these dynamic variables are set: CONTENT_LENGTH, CONTENT_TYPE, HTTP_COOKIE, HTTP_HOST, HTTP_IF_NONE_MATCH, HTTP_REFERER, HTTP_USER_AGENT, 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" =cut sub emulate_environment { my ($self, $c) = @_; 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 $remote_user = ''; 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 : ''; } return ( %{$self->env}, CONTENT_LENGTH => $content_length || 0, CONTENT_TYPE => $headers->content_type || '', GATEWAY_INTERFACE => 'CGI/1.1', HTTP_COOKIE => $headers->cookie || '', HTTP_HOST => $headers->host || '', HTTP_REFERER => $headers->referrer || '', HTTP_USER_AGENT => $headers->user_agent || '', HTTP_IF_NONE_MATCH => $headers->if_none_match || '', HTTPS => $req->is_secure ? 'YES' : 'NO', #PATH => $req->url->path, PATH_INFO => '/' . ($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 => $self->{script}, SCRIPT_NAME => $c->url_for($self->{route}->name, {path_info => ''})->path->to_string, 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__, ); } =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. =cut sub register { my ($self, $app, $args) = @_; my $pids = $app->defaults->{'mojolicious_plugin_cgi.pids'} ||= {}; my ($before, $name); if (ref $args eq 'ARRAY') { $self->{route} = shift @$args; $self->{script} = shift @$args; } elsif ($args->{support_semicolon_in_query_string}) { $app->hook( before_dispatch => sub { $_[0]->stash('cgi.query_string' => $_[0]->req->url->query->to_string); } ); return; } else { $self->{$_} ||= $args->{$_} for keys %$args; } $before = $self->{before} || sub { }; $app->defaults->{'mojolicious_plugin_cgi.tid'} ||= $self->ioloop->recurring(CHECK_CHILD_INTERVAL, sub { _waitpids($pids); }); $name = basename $self->{script}; $self->{script} = File::Spec->rel2abs($self->{script}) || $self->{script}; $self->{route} = $app->routes->any("$self->{route}/*path_info", {path_info => ''}) unless ref $self->{route}; $self->{route}->to( cb => sub { my $c = shift; my $log = $c->app->log; my @stderr = $self->{errlog} ? () : pipely; my @stdout = pipely; my $stdin = $self->_stdin($c); my $pid; $c->$before; defined($pid = fork) or die "[CGI] Could not fork $name: $!"; unless ($pid) { my @STDERR = @stderr ? ('>&', fileno $stderr[WRITE]) : ('>>', $self->{errlog}); warn "[CGI:$name:$$] <<< (@{[$stdin->slurp]})\n" if DEBUG; %ENV = $self->emulate_environment($c); 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; if (my $code = $self->{run}) { Mojo::IOLoop->reset; # clean up $code->($c); exit; } else { { exec $self->{script} } die "Could not execute $self->{script}: $!"; } } $log->debug("[CGI:$name:$pid] START $self->{script}"); $pids->{$pid} = $name; for my $p (\@stdout, \@stderr) { next unless $p->[READ]; close $p->[WRITE]; $p->[READ] = Mojo::IOLoop::Stream->new($p->[READ])->timeout(0); $self->ioloop->stream($p->[READ]); } $c->delay( sub { my ($delay) = @_; $c->stash('cgi.pid' => $pid, 'cgi.stdin' => $stdin); $stderr[READ]->on(read => $self->_stderr_cb($log, "CGI:$name:$pid")) if $stderr[READ]; $stdout[READ]->on(read => $self->_stdout_cb($c, "CGI:$name:$pid")); $stdout[READ]->on(close => $delay->begin); }, sub { my ($delay) = @_; my $GUARD = 50; warn "[CGI:$name:$pid] Child closed STDOUT\n" if DEBUG; unlink $stdin->path or die "Could not remove STDIN @{[$stdin->path]}" if -e $stdin->path; _waitpids({$pid => $pids->{$pid}}) while $pids->{$pid} and kill 0, $pid and $GUARD--; $c->finish; }, ); } ); } sub _stderr_cb { my ($self, $log, $log_key) = @_; 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 ($self, $c, $log_key) = @_; my $buf = ''; my $headers; return sub { my ($stream, $chunk) = @_; warn "[$log_key] >>> ($chunk)\n" if DEBUG; if ($headers) { # true if HTTP header has been written to client return $c->write($chunk); } $buf .= $chunk; $buf =~ s/^(.*?\x0a\x0d?\x0a\x0d?)//s or return; # false until all headers has been read from the CGI script $headers = $1; if ($headers =~ /^HTTP/) { $c->res->code($1) if $headers =~ m!^HTTP (\d\d\d)!; # borked CGI response if SERVER_PROTOCOL has no version $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 ($self, $c) = @_; 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) { local $SIG{CHLD} = 'DEFAULT'; # no idea why i need to do this, but it seems like waitpid() below return -1 if not local ($?, $!); 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; } } =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 1;