Net-FastCGI-0.14/000755 000766 000024 00000000000 12124423015 014157 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/Changes000644 000766 000024 00000010271 12124422621 015455 0ustar00chansenstaff000000 000000 0.14 2012-03-26 - No functional changes in this release - Don't rely on hash keys being ordered in tests, Perl 5.18 introduces a per process randomization. 0.13 2011-02-12 - No functional changes in this release - Added eg/runfcgi.pl, contributed by Paul Evans (LeoNerd) - Added eg/server.pl 0.12 2010-07-14 - Added Net::FastCGI::IO 0.11 2010-04-09 - Documented the goals with this project/distribution - Net::FastCGI::Protocol - Fixed dump_record() to properly escape FCGI_NameValuePair header - Added tests for this - Added get_record_length() - Added documentation and tests - Changed parse_record() to return a list in list context, this makes it more consistent with parse_header() - Added documentation and tests this change - Changed dump_record() to accept a string of octets (old behavior is still supported but deprecated, please change function call to dump_record_body()) This change makes it more consistent with parse_record_body(). - Added documentation and tests this change 0.10 2010-04-02 - Minor optimizations to avoid unnecessary copying of '$content' strings - Fixed dump_record() to properly insert ellipsis when truncating stream content - added tests for this - Added more tests for dump_record() 0.09 2010-03-31 - Added check_params() and dump_record() - added documentation - added test for check_params() and dump_record() (incomplete) - Minor optimizations to build_stream() and build_record() 0.08 2010-02-16 - Documented return value of get_type_name(), get_role_name() and get_protocol_status_name(). - Changed test prerequisite from Test::BinaryData to Test::HexString. - Corrected note about AnyEvent::FCGI, it's capable of multiplexing. 0.07 2010-02-10 - Added notes about existing Perl implementations. - Added references to specifications and white papers. - Minor internal "cosmetic" changes - Added more tests for build_begin_request() and build_end_request() 0.06 2010-02-09 - NOTE: Changed application_status to app_status, this affects users of parse_record() or parse_record_body(). Former was unnecessarily verbose. Latter also matches the component name of FCGI_BeginRequestBody struct. - Added build_begin_request() and build_end_request() - added documentation and tests for these 0.05 2010-02-06 - Net::FastCGI::Constant - Improved documentation - Added @FCGI_TYPE_NAME, @FCGI_ROLE_NAME and @FCGI_PROTOCOL_STATUS_NAME - Re-factored Net::FastCGI::Protocol to use these. - Renamed FCGI_MAX_LEN to FCGI_MAX_CONTENT_LEN - FCGI_MAX_LEN is deprecated and will be removed in a future version. - Net::FastCGI::Protocol - Fixed parse_record() and parse_record_body() to properly detect malformed stream records. - Added tests for this. - Increased segment size in build_stream() from 8192 to 32760 to reflect modern socket buffers. - Updated tests - Documented segment size - Documented scalar return value of parse_header() - Minor documentation updates 0.04 2010-01-30 - Added parse_record() and parse_record_body() - Added tests for these - Added docs (incomplete) - Cleaned up exception messages. Protocol exceptions now have a FastCGI prefix - Fixed parse_params() to correctly detect incomplete FCGI_NameValuePair's - added tests for this - Added tests for build_stream() - Changed parse_header() to return a hash reference in scalar context - added tests for this - Coverage ~90% (stmt:100.0 bran:96.9 cond:92.9) - More tests (and docs) needed to cover all cases 0.03 2010-01-23 - Fixed package loading in Net::FastCGI::Protocol 0.02 2010-01-23 - Removed object oriented implementation, it will eventually be released as a separate distribution with different prerequisites. - Removed unnecessary functions from Net::FastCGI::Protocol - Re-factored internals of Net::FastCGI::Protocol to be more performant. - No major changes planned for existing API in Net::FastCGI::Protocol 0.01_01 2009-10-17 - Initial release. Net-FastCGI-0.14/eg/000755 000766 000024 00000000000 12124423015 014552 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/inc/000755 000766 000024 00000000000 12124423015 014730 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/lib/000755 000766 000024 00000000000 12124423015 014725 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/Makefile.PL000644 000766 000024 00000000657 11356444517 016161 0ustar00chansenstaff000000 000000 use strict; use inc::Module::Install; name 'Net-FastCGI'; perl_version '5.006'; all_from 'lib/Net/FastCGI.pm'; repository 'http://github.com/chansen/p5-net-fastcgi'; requires 'Carp' => '0'; requires 'Exporter' => '0'; test_requires 'Test::More' => '0.47'; test_requires 'Test::Exception' => '0'; test_requires 'Test::HexString' => '0'; tests 't/*.t t/*/*.t'; WriteAll; Net-FastCGI-0.14/MANIFEST000644 000766 000024 00000002450 12124423012 015306 0ustar00chansenstaff000000 000000 Changes eg/runfcgi.pl eg/server.pl inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Net/FastCGI.pm lib/Net/FastCGI.pod lib/Net/FastCGI/Constant.pm lib/Net/FastCGI/Constant.pod lib/Net/FastCGI/IO.pm lib/Net/FastCGI/IO.pod lib/Net/FastCGI/Protocol.pm lib/Net/FastCGI/Protocol.pod lib/Net/FastCGI/Protocol/PP.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml MYMETA.json MYMETA.yml README t/000_load.t t/020_protocol/001_header.t t/020_protocol/005_record_length.t t/020_protocol/010_build_record.t t/020_protocol/015_build_stream.t t/020_protocol/020_begin_request_body.t t/020_protocol/025_begin_request_record.t t/020_protocol/027_begin_request.t t/020_protocol/030_end_request_body.t t/020_protocol/035_end_request_record.t t/020_protocol/037_end_request.t t/020_protocol/040_unknown_type_body.t t/020_protocol/045_unknown_type_record.t t/020_protocol/050_parse_record.t t/020_protocol/055_parse_record_body.t t/020_protocol/060_params.t t/020_protocol/065_record_type.t t/020_protocol/070_names.t t/020_protocol/080_dump_record.t t/020_protocol/085_dump_record_body.t t/lib/myconfig.pm xt/000_pod.t xt/010_pod_coverage.t Net-FastCGI-0.14/MANIFEST.SKIP000644 000766 000024 00000000316 11355722261 016067 0ustar00chansenstaff000000 000000 ^_build ^Build$ ^blib ~$ \.bak$ CVS \.svn \.DS_Store cover_db \..*\.sw.?$ ^Makefile$ ^pm_to_blib$ ^MakeMaker-\d ^blibdirs$ \.old$ ^#.*#$ ^\.# ^TODO$ ^PLANS$ ^doc/ ^dev/ ^benchmarks ^\._.*$ \.shipit \.git.* Net-FastCGI-0.14/META.yml000644 000766 000024 00000001231 12124423012 015422 0ustar00chansenstaff000000 000000 --- abstract: 'FastCGI Toolkit' author: - 'Christian Hansen C' build_requires: ExtUtils::MakeMaker: 6.59 Test::Exception: 0 Test::HexString: 0 Test::More: 0.47 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Net-FastCGI no_index: directory: - inc - t - xt requires: Carp: 0 Exporter: 0 perl: 5.6.0 resources: license: http://dev.perl.org/licenses/ repository: http://github.com/chansen/p5-net-fastcgi version: 0.14 Net-FastCGI-0.14/MYMETA.json000644 000766 000024 00000002320 12124423013 016041 0ustar00chansenstaff000000 000000 { "abstract" : "FastCGI Toolkit", "author" : [ "Christian Hansen C" ], "dynamic_config" : 0, "generated_by" : "Module::Install version 1.06, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Net-FastCGI", "no_index" : { "directory" : [ "inc", "t", "xt" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "6.59", "Test::Exception" : "0", "Test::HexString" : "0", "Test::More" : "0.47" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.59" } }, "runtime" : { "requires" : { "Carp" : "0", "Exporter" : "0", "perl" : "5.006" } } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/chansen/p5-net-fastcgi" } }, "version" : "0.14" } Net-FastCGI-0.14/MYMETA.yml000644 000766 000024 00000001064 12124423012 015674 0ustar00chansenstaff000000 000000 --- abstract: 'FastCGI Toolkit' author: - 'Christian Hansen C' build_requires: ExtUtils::MakeMaker: 6.59 Test::Exception: 0 Test::HexString: 0 Test::More: 0.47 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Net-FastCGI no_index: directory: - t - inc requires: Carp: 0 Exporter: 0 perl: 5.006 version: 0.14 Net-FastCGI-0.14/README000644 000766 000024 00000006702 11417410742 015053 0ustar00chansenstaff000000 000000 NAME Net::FastCGI - FastCGI Toolkit DESCRIPTION This distribution aims to provide a complete API for working with the FastCGI protocol. The primary goal is to provide a function oriented and object oriented API which are not tied to a specific I/O model or framework. Secondary goal is to provide higher level tools/API which can be used for debugging and interoperability testing. PROGRESS The function oriented API is considered feature complete. Net::FastCGI::Protocol provides functions to build and parse all FastCGI v1.0 messages, also provided is a few convenient higher level functions such as "build_begin_request()", "build_end_request()", "parse_record()" and "dump_record()". Work has begun on object oriented implementation and a simple blocking I/O class which is intended for testing and debugging. PACKAGES Net::FastCGI::Constant FastCGI protocol constants. Net::FastCGI::IO Provides functions to read and write FastCGI messages. Net::FastCGI::Protocol Provides functions to build and parse FastCGI messages. ENVIRONMENT Environment variable "NET_FASTCGI_PP" can be set to a true value before loading this package to disable usage of XS implementation. PREREQUISITES Run-Time perl 5.6 or greater. Carp, core module. Exporter, core module. Build-Time In addition to Run-Time: Test::More 0.47 or greater, core module since 5.6.2. Test::Exception. Test::HexString. SEE ALSO Community Official FastCGI site Standards FastCGI Specification Version 1.0 RFC 3875 - The Common Gateway Interface (CGI) Version 1.1 White papers FastCGI: A High-Performance Web Server Interface FastCGI - The Forgotten Treasure Perl implementations AnyEvent::FCGI Application server implementation, built on top of AnyEvent. Supports Responder role. Capable of multiplexing. FCGI Application server implementation, built on top of "libfcgi" (reference implementation). Supports all FastCGI roles. Responds to management records. Processes requests synchronously. FCGI::Async Application server implementation, built on top of IO::Async. Supports Responder role. Responds to management records. Capable of multiplexing. FCGI::Client Client (Web server) implementation. Supports Responder role. FCGI::EV Application server implementation, built on top of EV. Supports Responder role. Mojo::Server::FastCGI Application server implementation. Supports Responder role. Processes requests synchronously. POE::Component::FastCGI Application server implementation, built on top of POE. Supports Responder role. Capable of multiplexing. SUPPORT Please report any bugs or feature requests to "bug-net-fastcgi@rt.cpan.org", or through the web interface at AUTHOR Christian Hansen "chansen@cpan.org" COPYRIGHT Copyright 2008-2010 by Christian Hansen. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-FastCGI-0.14/t/000755 000766 000024 00000000000 12124423015 014422 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/xt/000755 000766 000024 00000000000 12124423015 014612 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/xt/000_pod.t000644 000766 000024 00000000257 11355722261 016156 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use Test::More; BEGIN { eval 'use Test::Pod'; if ($@) { plan skip_all => 'Needs Test::Pod'; } } all_pod_files_ok(); Net-FastCGI-0.14/xt/010_pod_coverage.t000644 000766 000024 00000000752 11355722261 020032 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use Test::More; BEGIN { eval 'use Test::Pod::Coverage'; if ($@) { plan skip_all => 'Needs Test::Pod::Coverage'; } } my @modules = sort grep { !/::(?:PP|XS)$/ } all_modules(); plan tests => scalar(@modules); foreach my $module ( @modules ) { my $params = {}; if ( $module =~ /^Net::FastCGI::Protocol$/ ) { $params->{coverage_class} = 'Pod::Coverage::ExportOnly'; } pod_coverage_ok( $module, $params ); } Net-FastCGI-0.14/t/000_load.t000644 000766 000024 00000000772 11444206242 016120 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 5; BEGIN { use_ok('Net::FastCGI'); use_ok('Net::FastCGI::Constant'); use_ok('Net::FastCGI::IO'); use_ok('Net::FastCGI::Protocol'); if ( $ENV{NET_FASTCGI_PP} ) { use_ok('Net::FastCGI::Protocol::PP'); } else { use_ok('Net::FastCGI::Protocol::XS'); } } diag("Net::FastCGI $Net::FastCGI::VERSION, Perl $], $^X"); diag("NET_FASTCGI_PP=$ENV{NET_FASTCGI_PP}"); Net-FastCGI-0.14/t/020_protocol/000755 000766 000024 00000000000 12124423015 016644 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/t/lib/000755 000766 000024 00000000000 12124423015 015170 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/t/lib/myconfig.pm000644 000766 000024 00000000155 11444206013 017343 0ustar00chansenstaff000000 000000 package myconfig; use strict; BEGIN { $ENV{NET_FASTCGI_PP} = 0 + !(-e "XS.xs" || -e "../XS.xs"); } 1; Net-FastCGI-0.14/t/020_protocol/001_header.t000644 000766 000024 00000003124 11355722261 020653 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 13; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_header parse_header ]); } my @tests = ( # octets type request_id content_length padding_length ["\x01\x00\x00\x00\x00\x00\x00\x00", 0, 0, 0, 0 ], ["\x01\xFF\xFF\xFF\xFF\xFF\xFF\x00", 0xFF, 0xFFFF, 0xFFFF, 0xFF ], ); foreach my $test (@tests) { my $expected = $test->[0]; my $got = build_header(@$test[1..4]); is_hexstr($got, $expected, 'build_header()'); } foreach my $test (@tests) { my @expected = @$test[1..4]; my @got = parse_header($test->[0]); is_deeply(\@got, \@expected, "parse_header() in list context"); } my @components = qw(type request_id content_length padding_length); foreach my $test (@tests) { my $expected; @$expected{@components} = @$test[1..4]; my $got = parse_header($test->[0]); is_deeply($got, $expected, "parse_header() in scalar context"); } throws_ok { parse_header("") } qr/FastCGI: Insufficient .* FCGI_Header/; throws_ok { parse_header(undef) } qr/FastCGI: Insufficient .* FCGI_Header/; throws_ok { parse_header("\x00\x00\x00\x00\x00\x00\x00\x00") } qr/^FastCGI: Protocol version mismatch/; throws_ok { parse_header("\xFF\x00\x00\x00\x00\x00\x00\x00") } qr/^FastCGI: Protocol version mismatch/; throws_ok { build_header() } qr/^Usage: /; throws_ok { parse_header() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/005_record_length.t000644 000766 000024 00000001635 11357605204 022252 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 18; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Constant', qw[:all]); use_ok('Net::FastCGI::Protocol', qw[ build_header build_record get_record_length ]); } is get_record_length(undef), 0, 'get_record_length(undef)'; { for my $len (0..7) { is get_record_length("\x00" x $len), 0, qq; } } { for my $len (8, 16, 32, 64) { my $record = build_record(0, 0, "\x00" x $len); is get_record_length($record), FCGI_HEADER_LEN + $len; } } { my $header = build_header(0, 0, 8192, 250); is get_record_length($header), FCGI_HEADER_LEN + 8192 + 250; } # get_record_length(octets) for (0, 2) { throws_ok { get_record_length((1) x $_) } qr/^Usage: /; } Net-FastCGI-0.14/t/020_protocol/010_build_record.t000644 000766 000024 00000003010 11355722261 022052 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 11; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_record ]); } my @tests = ( # octets type request_id content [ "\x01\x00\x00\x00\x00\x00\x00\x00", 0, 0, undef ], [ "\x01\xFF\xFF\xFF\x00\x00\x00\x00", 0xFF, 0xFFFF, undef ], [ "\x01\x01\x00\x01\x00\x01\x07\x00\x01\x00\x00\x00\x00\x00\x00\x00", 1, 1, "\x01" ], [ "\x01\x01\x00\x01\x00\x05\x03\x00\x01\x01\x01\x01\x01\x00\x00\x00", 1, 1, "\x01\x01\x01\x01\x01" ], [ "\x01\x01\x00\x01\x00\x08\x00\x00\x01\x01\x01\x01\x01\x01\x01\x01", 1, 1, "\x01\x01\x01\x01\x01\x01\x01\x01" ], ); foreach my $test (@tests) { my $expected = $test->[0]; my $got = build_record(@$test[1..3]); is_hexstr($got, $expected, 'build_record()'); } { my $exp = "\x01\x01\x00\x02\x00\x00\x00\x00"; my $got = build_record(1, 2); is_hexstr($got, $exp, 'build_record(1, 2)'); } throws_ok { build_record( 0, 0, "\x00" x (0xFFFF + 1) ) } qr/^Invalid Argument: 'content' cannot exceed/; # build_record(type, request_id [, content]) for (0..1, 4) { throws_ok { build_record((1) x $_) } qr/^Usage: /; } Net-FastCGI-0.14/t/020_protocol/015_build_stream.t000644 000766 000024 00000004644 11355722261 022112 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 12; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_stream ]); } sub TRUE () { !!1 } sub FALSE () { !!0 } my @tests = ( # expected, type, request_id, content, terminate [ "", 1, 1, '', FALSE ], [ "", 1, 1, undef, FALSE ], [ "\x01\x01\x00\x01\x00\x00\x00\x00", 1, 1, '', TRUE ], [ "\x01\x01\x00\x01\x00\x00\x00\x00", 1, 1, undef, TRUE ], [ "\x01\x01\x00\x01\x00\x03\x05\x00" . "FOO\x00\x00\x00\x00\x00", 1, 1, 'FOO', FALSE ], [ "\x01\x01\x00\x01\x00\x03\x05\x00" . "FOO\x00\x00\x00\x00\x00" . "\x01\x01\x00\x01\x00\x00\x00\x00", 1, 1, 'FOO', TRUE ], ); foreach my $test (@tests) { my $expected = $test->[0]; my $got = build_stream(@$test[1..4]); is_hexstr($got, $expected, 'build_stream()'); } { my $header = "\x01\x01\x00\x01\x7F\xF8\x00\x00"; my $content = "x" x 32760; my $trailer = "\x01\x01\x00\x01\x00\x00\x00\x00"; { my $expected = $header . $content; my $got = build_stream(1,1, $content); is_hexstr($got, $expected, 'build_stream(content_length: 32760 terminate:false)'); } { my $expected = $header . $content . $trailer; my $got = build_stream(1,1, $content, 1); is_hexstr($got, $expected, 'build_stream(content_length: 32760 terminate:true)'); } } { my $records = "\x01\x01\x00\x01\x7F\xF8\x00\x00" # H1 . "x" x 32760 # C1 . "\x01\x01\x00\x01\x00\x08\x00\x00" # H2 . "x" x 8 # C2 ; my $content = "x" x 32768; my $trailer = "\x01\x01\x00\x01\x00\x00\x00\x00"; { my $expected = $records; my $got = build_stream(1,1, $content); is_hexstr($got, $records, 'build_stream(content_length: 32768 terminate:false)'); } { my $expected = $records . $trailer; my $got = build_stream(1,1, $content, 1); is_hexstr($got, $expected, 'build_stream(content_length: 32768 terminate:true)'); } } throws_ok { build_stream() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/020_begin_request_body.t000644 000766 000024 00000002211 11355722261 023271 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 9; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_begin_request_body parse_begin_request_body ]); } my @tests = ( # octets role flags [ "\x00\x00\x00\x00\x00\x00\x00\x00", 0, 0 ], [ "\xFF\xFF\xFF\x00\x00\x00\x00\x00", 0xFFFF, 0xFF ], ); foreach my $test (@tests) { my $expected = $test->[0]; my $got = build_begin_request_body(@$test[1..2]); is_hexstr($got, $expected, 'build_begin_request_body()'); } foreach my $test (@tests) { my @expected = @$test[1..2]; my @got = parse_begin_request_body($test->[0]); is_deeply(\@got, \@expected, "parse_begin_request_body()"); } throws_ok { parse_begin_request_body("") } qr/^FastCGI: Insufficient .* FCGI_BeginRequestBody/; throws_ok { parse_begin_request_body(undef) } qr/^FastCGI: Insufficient .* FCGI_BeginRequestBody/; throws_ok { build_begin_request_body() } qr/^Usage: /; throws_ok { parse_begin_request_body() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/025_begin_request_record.t000644 000766 000024 00000001437 11355722261 023630 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 4; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_begin_request_record ]); } my @tests = ( # octets request_id role flags [ "\x01\x01\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", 0, 0, 0 ], [ "\x01\x01\xFF\xFF\x00\x08\x00\x00\xFF\xFF\xFF\x00\x00\x00\x00\x00", 0xFFFF, 0xFFFF, 0xFF ], ); foreach my $test (@tests) { my $expected = $test->[0]; my $got = build_begin_request_record(@$test[1..3]); is_hexstr($got, $expected, 'build_begin_request_record()'); } throws_ok { build_begin_request_record() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/027_begin_request.t000644 000766 000024 00000006472 11355722261 022300 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 15; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_begin_request ]); use_ok('Net::FastCGI::Constant', qw[ :type :role ]); } { my $begin = "\x01\x01\x00\x01\x00\x08\x00\x00" # FCGI_Header id=1 . "\x00\x01\x00\x00\x00\x00\x00\x00"; # FCGI_BeginRequestBody role=FCGI_RESPONDER my $params = "\x01\x04\x00\x01\x00\x00\x00\x00"; # FCGI_Header type=FCGI_PARAMS { my $exp = $begin . $params; my $got = build_begin_request(1, FCGI_RESPONDER, 0, {}); is_hexstr($got, $exp, q); } my $stdin = "\x01\x05\x00\x01\x00\x00\x00\x00"; # FCGI_Header type=FCGI_STDIN { my $exp = $begin . $params . $stdin; my $got = build_begin_request(1, FCGI_RESPONDER, 0, {}, ''); is_hexstr($got, $exp, q); } { my $exp = $begin . $params . $stdin; my $got = build_begin_request(1, FCGI_RESPONDER, 0, {}, undef); is_hexstr($got, $exp, q); } my $data = "\x01\x08\x00\x01\x00\x00\x00\x00"; # FCGI_Header type=FCGI_DATA { my $exp = $begin . $params . $stdin . $data; my $got = build_begin_request(1, FCGI_RESPONDER, 0, {}, '', undef); is_hexstr($got, $exp, q); } { my $exp = $begin . $params . $stdin . $data; my $got = build_begin_request(1, FCGI_RESPONDER, 0, {}, undef, ''); is_hexstr($got, $exp, q); } } { my $begin = "\x01\x01\x00\x01\x00\x08\x00\x00" # FCGI_Header id=1 . "\x00\x01\x00\x00\x00\x00\x00\x00"; # FCGI_BeginRequestBody role=FCGI_RESPONDER my $params = "\x01\x04\x00\x01\x00\x08\x00\x00" # FCGI_Header type=FCGI_PARAMS . "\x03\x03FooBar" . "\x01\x04\x00\x01\x00\x00\x00\x00"; { my $exp = $begin . $params; my $got = build_begin_request(1, FCGI_RESPONDER, 0, { Foo => 'Bar' }); is_hexstr($got, $exp, q!build_begin_request(1, FCGI_RESPONDER, 0, { Foo => 'Bar' })!); } my $stdin = "\x01\x05\x00\x01\x03\xFC\x04\x00" # FCGI_Header type=FCGI_STDIN . "x" x 1020 . "\0" x 4 . "\x01\x05\x00\x01\x00\x00\x00\x00"; { my $exp = $begin . $params . $stdin; my $got = build_begin_request(1, FCGI_RESPONDER, 0, { Foo => 'Bar' }, 'x' x 1020); is_hexstr($got, $exp, q!build_begin_request(1, FCGI_RESPONDER, 0, { Foo => 'Bar' }, 'x' x 1020)!); } my $data = "\x01\x08\x00\x01\x04\x00\x00\x00" # FCGI_Header type=FCGI_DATA . "y" x 1024 . "\x01\x08\x00\x01\x00\x00\x00\x00"; { my $exp = $begin . $params . $stdin . $data; my $got = build_begin_request(1, FCGI_RESPONDER, 0, { Foo => 'Bar' }, 'x' x 1020, 'y' x 1024); is_hexstr($got, $exp, q!build_begin_request(1, FCGI_RESPONDER, 0, { Foo => 'Bar' }, 'x' x 1020, 'y' x 1024)!); } } # build_begin_request(request_id, role, flags, params [, stdin [, data]]) for (0..3, 7) { throws_ok { build_begin_request((1) x $_) } qr/^Usage: /; } Net-FastCGI-0.14/t/020_protocol/030_end_request_body.t000644 000766 000024 00000002242 11355722261 022760 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 9; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_end_request_body parse_end_request_body ]); } my @tests = ( # octets app_status protocol_status [ "\x00\x00\x00\x00\x00\x00\x00\x00", 0, 0 ], [ "\xFF\xFF\xFF\xFF\xFF\x00\x00\x00", 0xFFFFFFFF, 0xFF ], ); foreach my $test (@tests) { my $expected = $test->[0]; my $got = build_end_request_body(@$test[1..2]); is_hexstr($got, $expected, 'build_end_request_body()'); } foreach my $test (@tests) { my @expected = @$test[1..2]; my @got = parse_end_request_body($test->[0]); is_deeply(\@got, \@expected, "parse_end_request_body()"); } throws_ok { parse_end_request_body("") } qr/^FastCGI: Insufficient .* FCGI_EndRequestBody/; throws_ok { parse_end_request_body(undef) } qr/^FastCGI: Insufficient .* FCGI_EndRequestBody/; throws_ok { build_end_request_body() } qr/^Usage: /; throws_ok { parse_end_request_body() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/035_end_request_record.t000644 000766 000024 00000001512 11355722261 023305 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 4; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_end_request_record ]); } my @tests = ( # octets request_id app_status protocol_status [ "\x01\x03\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", 0, 0, 0 ], [ "\x01\x03\xFF\xFF\x00\x08\x00\x00\xFF\xFF\xFF\xFF\xFF\x00\x00\x00", 0xFFFF, 0xFFFFFFFF, 0xFF ], ); foreach my $test (@tests) { my $expected = $test->[0]; my $got = build_end_request_record(@$test[1..3]); is_hexstr($got, $expected, 'build_end_request_record()'); } throws_ok { build_end_request_record() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/037_end_request.t000644 000766 000024 00000005327 11355722261 021761 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 13; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_end_request ]); use_ok('Net::FastCGI::Constant', qw[ :type :protocol_status ]); } { my $end = "\x01\x03\x00\x01\x00\x08\x00\x00" # FCGI_Header id=1 . "\x00\x00\x00\x00\x00\x00\x00\x00" # FCGI_EndRequestBody ; { my $got = build_end_request(1, 0, FCGI_REQUEST_COMPLETE); is_hexstr($got, $end, q); } my $stdout = "\x01\x06\x00\x01\x00\x00\x00\x00"; # FCGI_Header type=FCGI_STDOUT { my $exp = $stdout . $end; my $got = build_end_request(1, 0, FCGI_REQUEST_COMPLETE, ''); is_hexstr($got, $exp, q); } { my $exp = $stdout . $end; my $got = build_end_request(1, 0, FCGI_REQUEST_COMPLETE, undef); is_hexstr($got, $exp, q); } my $stderr = "\x01\x07\x00\x01\x00\x00\x00\x00"; # FCGI_Header type=FCGI_STDERR { my $exp = $stdout . $stderr . $end; my $got = build_end_request(1, 0, FCGI_REQUEST_COMPLETE, '', undef); is_hexstr($got, $exp, q); } { my $exp = $stdout . $stderr . $end; my $got = build_end_request(1, 0, FCGI_REQUEST_COMPLETE, undef, ''); is_hexstr($got, $exp, q); } } { my $end = "\x01\x03\x00\x01\x00\x08\x00\x00" # FCGI_Header id=1 . "\x00\x00\x00\x00\x00\x00\x00\x00" # FCGI_EndRequestBody ; my $stdout = "\x01\x06\x00\x01\x03\xFC\x04\x00" # FCGI_Header type=FCGI_STDOUT . "x" x 1020 . "\0" x 4 . "\x01\x06\x00\x01\x00\x00\x00\x00"; { my $exp = $stdout . $end; my $got = build_end_request(1, 0, FCGI_REQUEST_COMPLETE, 'x' x 1020); is_hexstr($got, $exp, q); } my $stderr = "\x01\x07\x00\x01\x04\x00\x00\x00" # FCGI_Header type=FCGI_STDERR . "y" x 1024 . "\x01\x07\x00\x01\x00\x00\x00\x00"; { my $exp = $stdout . $stderr . $end; my $got = build_end_request(1, 0, FCGI_REQUEST_COMPLETE, 'x' x 1020, 'y' x 1024); is_hexstr($got, $exp, q); } } # build_end_request(request_id, app_status, protocol_status [, stdout [, stderr]]) for (0..2, 6) { throws_ok { build_end_request((1) x $_) } qr/^Usage: /; } Net-FastCGI-0.14/t/020_protocol/040_unknown_type_body.t000644 000766 000024 00000002144 11355722261 023204 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 9; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_unknown_type_body parse_unknown_type_body ]); } my @tests = ( # octets type [ "\x00\x00\x00\x00\x00\x00\x00\x00", 0 ], [ "\xFF\x00\x00\x00\x00\x00\x00\x00", 0xFF ], ); foreach my $test (@tests) { my $expected = $test->[0]; my $got = build_unknown_type_body($test->[1]); is_hexstr($got, $expected, 'build_unknown_type_body()'); } foreach my $test (@tests) { my @expected = $test->[1]; my @got = parse_unknown_type_body($test->[0]); is_deeply(\@got, \@expected, "parse_unknown_type_body()"); } throws_ok { parse_unknown_type_body("") } qr/^^FastCGI: Insufficient .* FCGI_UnknownTypeBody/; throws_ok { parse_unknown_type_body(undef) } qr/^^FastCGI: Insufficient .* FCGI_UnknownTypeBody/; throws_ok { build_unknown_type_body() } qr/^Usage: /; throws_ok { parse_unknown_type_body() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/045_unknown_type_record.t000644 000766 000024 00000001332 11355722261 023530 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 4; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_unknown_type_record ]); } my @tests = ( # octets type [ "\x01\x0B\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", 0 ], [ "\x01\x0B\x00\x00\x00\x08\x00\x00\xFF\x00\x00\x00\x00\x00\x00\x00", 0xFF ], ); foreach my $test (@tests) { my $expected = $test->[0]; my $got = build_unknown_type_record($test->[1]); is_hexstr($got, $expected, 'build_unknown_type_record()'); } throws_ok { build_unknown_type_record() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/050_parse_record.t000644 000766 000024 00000012247 11357564724 022117 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 54; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Constant', qw[:all]); use_ok('Net::FastCGI::Protocol', qw[ build_header build_record build_stream parse_record ]); } my @records_ok = ( [ "\x01\x01\x00\x01\x00\x08\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", "\x00\x01\x00\x00\x00\x00\x00\x00", { type => FCGI_BEGIN_REQUEST, request_id => 1, role => FCGI_RESPONDER, flags => 0 } ], [ "\x01\x02\x00\x01\x00\x00\x00\x00", "", { type => FCGI_ABORT_REQUEST, request_id => 1 } ], [ "\x01\x03\x00\x01\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", "\x00\x00\x00\x00\x00\x00\x00\x00", { type => FCGI_END_REQUEST, request_id => 1, protocol_status => 0, app_status => 0 } ], [ "\x01\x04\x00d\x00\x0B\x05\x00FCGI_PARAMS\x00\x00\x00\x00\x00", "FCGI_PARAMS", { type => FCGI_PARAMS, request_id => 100, content => 'FCGI_PARAMS' } ], [ "\x01\x05\x00\xC8\x00\x0A\x06\x00FCGI_STDIN\x00\x00\x00\x00\x00\x00", "FCGI_STDIN", { type => FCGI_STDIN, request_id => 200, content => 'FCGI_STDIN' } ], [ "\x01\x06\x01\x2C\x00\x0B\x05\x00FCGI_STDOUT\x00\x00\x00\x00\x00", "FCGI_STDOUT", { type => FCGI_STDOUT, request_id => 300, content => 'FCGI_STDOUT' } ], [ "\x01\x07\x01\x90\x00\x0B\x05\x00FCGI_STDERR\x00\x00\x00\x00\x00", "FCGI_STDERR", { type => FCGI_STDERR, request_id => 400, content => 'FCGI_STDERR' } ], [ "\x01\x08\x01\xF4\x00\x09\x07\x00FCGI_DATA\x00\x00\x00\x00\x00\x00\x00", "FCGI_DATA", { type => FCGI_DATA, request_id => 500, content => 'FCGI_DATA' } ], [ "\x01\x09\x00\x00\x00\x0D\x03\x00\x03\x03BarBaZ\x03\x00FOO\x00\x00\x00", "\x03\x03BarBaZ\x03\x00FOO", { type => FCGI_GET_VALUES, request_id => FCGI_NULL_REQUEST_ID, values => { FOO => '', Bar => 'BaZ' } } ], [ "\x01\x0A\x00\x00\x00\x17\x01\x00\x04\x01BETA2\x05\x01ALPHA1\x05\x01GAMMA3\x00", "\x04\x01BETA2\x05\x01ALPHA1\x05\x01GAMMA3", { type => FCGI_GET_VALUES_RESULT, request_id => FCGI_NULL_REQUEST_ID, values => { ALPHA => 1, BETA => 2, GAMMA => 3 } } ], [ "\x01\x0B\x00\x00\x00\x08\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00", "\x64\x00\x00\x00\x00\x00\x00\x00", { type => FCGI_UNKNOWN_TYPE, request_id => FCGI_NULL_REQUEST_ID, unknown_type => 100 } ], [ "\x01\x6F\x00\xDE\x00\x04\x04\x00oops\x00\x00\x00\x00", "oops", { type => 111, request_id => 222, content => 'oops' } ], [ "\x01\xFF\xFF\xFF\x00\x00\x00\x00", "", { type => 0xFF, request_id => 0xFFFF } ], ); foreach my $test (@records_ok) { my $expected = $test->[2]; my $got = parse_record($test->[0]); is_deeply($got, $expected, "parse_record() in scalar context"); } foreach my $test (@records_ok) { my @expected = ($test->[2]->{type}, $test->[2]->{request_id}, $test->[1]); my @got = parse_record($test->[0]); is_deeply(\@got, \@expected, "parse_record() in list context"); } my @headers_malformed = ( # type, request_id, content_length, padding_length [ FCGI_BEGIN_REQUEST, 0, 0, 0 ], [ FCGI_BEGIN_REQUEST, 1, 0, 0 ], [ FCGI_ABORT_REQUEST, 0, 0, 0 ], [ FCGI_END_REQUEST, 0, 0, 0 ], [ FCGI_END_REQUEST, 1, 0, 0 ], [ FCGI_PARAMS, 0, 0, 0 ], [ FCGI_STDIN, 0, 0, 0 ], [ FCGI_STDOUT, 0, 0, 0 ], [ FCGI_STDERR, 0, 0, 0 ], [ FCGI_DATA, 0, 0, 0 ], [ FCGI_GET_VALUES, 1, 0, 0 ], [ FCGI_GET_VALUES_RESULT, 1, 0, 0 ], [ FCGI_UNKNOWN_TYPE, 0, 0, 0 ], [ FCGI_UNKNOWN_TYPE, 1, 0, 0 ] ); foreach my $test (@headers_malformed) { my $octets = build_header(@$test); throws_ok { parse_record($octets) } qr/^FastCGI: Malformed/; } { my $octets = build_header(FCGI_ABORT_REQUEST, 1, 8, 0) . "\x00" x 8; throws_ok { parse_record($octets) } qr/^FastCGI: Malformed/; } my @stream_types = ( FCGI_PARAMS, FCGI_STDIN, FCGI_STDOUT, FCGI_STDERR, FCGI_DATA ); foreach my $type (@stream_types) { my $expected = { type => $type, request_id => 1, content => '' }; my $octets = build_record($type, 1, ''); my $got = parse_record($octets); is_deeply($got, $expected, "parse_record(stream record) in scalar context"); } foreach my $type (@stream_types) { my @expected = ($type, 1, ''); my $octets = build_record($type, 1, ''); my @got = parse_record($octets); is_deeply(\@got, \@expected, "parse_record(stream record) in list context"); } throws_ok { parse_record() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/055_parse_record_body.t000644 000766 000024 00000004710 11442517412 023120 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 33; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Constant', qw[:all]); use_ok('Net::FastCGI::Protocol', qw[ build_header build_record build_stream parse_record_body ]); } my @ok = ( [ "\x00\x01\x01\x00\x00\x00\x00\x00", { type => FCGI_BEGIN_REQUEST, request_id => 1, role => 1, flags => 1 } ], [ "\x00\x00\x00\x01\x01\x00\x00\x00", { type => FCGI_END_REQUEST, request_id => 1, app_status => 1, protocol_status => 1 } ], [ undef, { type => FCGI_STDIN, request_id => 1, content => '' } ], [ "", { type => FCGI_PARAMS, request_id => 1, content => '' } ], [ "\x01\x01A1\x01\x01B2", { type => FCGI_GET_VALUES, request_id => FCGI_NULL_REQUEST_ID, values => { A => 1, B => 2 } } ], [ undef, { type => FCGI_GET_VALUES_RESULT, request_id => FCGI_NULL_REQUEST_ID, values => {} } ] ); foreach my $test (@ok) { my $exp = $test->[1]; my $got = parse_record_body($exp->{type}, $exp->{request_id}, $test->[0]); is_deeply($got, $exp, "parse_record_body()"); } my @malformed = ( # type, request_id [ FCGI_BEGIN_REQUEST, 0 ], [ FCGI_END_REQUEST, 0 ], [ FCGI_PARAMS, 0 ], [ FCGI_STDIN, 0 ], [ FCGI_STDOUT, 0 ], [ FCGI_STDERR, 0 ], [ FCGI_DATA, 0 ], [ FCGI_GET_VALUES, 1 ], [ FCGI_GET_VALUES_RESULT, 1 ], [ FCGI_UNKNOWN_TYPE, 1 ] ); foreach my $test (@malformed) { my ($type, $request_id) = @$test; throws_ok { parse_record_body($type, $request_id, '') } qr/^FastCGI: Malformed/; } { my $content = "\x00" x (FCGI_MAX_CONTENT_LEN + 1); foreach my $type (0..12) { throws_ok { parse_record_body($type, 0, $content) } qr/^Invalid Argument: 'content' cannot exceed/; } } # parse_record_body(type, request_id, content) for (0, 4) { throws_ok { parse_record_body((1) x $_) } qr/^Usage: /; } Net-FastCGI-0.14/t/020_protocol/060_params.t000644 000766 000024 00000004435 12124421445 020714 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 38; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[ build_params check_params parse_params ]); } sub TRUE () { !!1 } sub FALSE () { !!0 } my @tests = ( # octets params [ "", { } ], [ "\x00\x00", { '' => '' }, ], [ "\x01\x01\x31\x31", { 1 => 1 }, ], [ "\x01\x01\x41\x42\x01\x01\x43\x44\x01\x01\x45\x46", { A => 'B', C => 'D', E => 'F' } ], ); foreach my $test (@tests) { my ($expected, $params) = @$test; my $got = join '', map { build_params({ $_ => $params->{$_} }) } sort keys %$params; is_hexstr($got, $expected, 'build_params()'); } is_hexstr("\x03\x00foo", build_params({foo => undef}), 'build_params({foo => undef})'); is_hexstr("\x7F\x00" . "x" x 127, build_params({ "x" x 127 => '' })); is_hexstr("\x00\x7F" . "x" x 127, build_params({ '' => "x" x 127 })); is_hexstr("\x80\x00\x00\x80\x00" . "x" x 128, build_params({ "x" x 128 => '' })); is_hexstr("\x00\x80\x00\x00\x80" . "x" x 128, build_params({ '' => "x" x 128 })); foreach my $test (@tests) { my $expected = $test->[1]; my $got = parse_params($test->[0]); is_deeply($got, $expected, 'parse_params()'); } foreach my $test (@tests) { my $octets = $test->[0]; is(check_params($octets), TRUE, 'check_params(octets) eq TRUE'); } my @insufficient = ( "\x00", "\x01", "\x00\x01", "\x01\x00", "\x00\xFF", "\x01\xFF\x00", "\x00\x80\x00\x00\x80", "\x80\x00\x00\x80\x00", ); foreach my $test (@insufficient) { throws_ok { parse_params($test) } qr/^FastCGI: Insufficient .* FCGI_NameValuePair/; } foreach my $test (@insufficient) { is(check_params($test), FALSE, 'check_params(octets) eq FALSE'); } is(check_params(undef), FALSE, 'check_params(undef) eq FALSE'); throws_ok { check_params() } qr/^Usage: /; throws_ok { build_params() } qr/^Usage: /; throws_ok { parse_params() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/065_record_type.t000644 000766 000024 00000004506 11355722261 021761 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 55; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Constant', qw[ :type ] ); use_ok('Net::FastCGI::Protocol', qw[ is_discrete_type is_known_type is_management_type is_stream_type ] ); } sub TRUE () { !!1 } sub FALSE () { !!0 } { my @known = ( FCGI_BEGIN_REQUEST, FCGI_ABORT_REQUEST, FCGI_END_REQUEST, FCGI_PARAMS, FCGI_STDIN, FCGI_STDOUT, FCGI_STDERR, FCGI_DATA, FCGI_GET_VALUES, FCGI_GET_VALUES_RESULT, FCGI_UNKNOWN_TYPE, FCGI_MAXTYPE, ); foreach my $type (@known) { is( is_known_type($type), TRUE, qq/is_known_type($type) = true/ ); } } { my @discrete = ( FCGI_BEGIN_REQUEST, FCGI_ABORT_REQUEST, FCGI_END_REQUEST, FCGI_GET_VALUES, FCGI_GET_VALUES_RESULT, FCGI_UNKNOWN_TYPE, ); foreach my $type ( @discrete ) { is( is_stream_type($type), FALSE, qq/is_stream_type($type) = false/ ); is( is_discrete_type($type), TRUE, qq/is_discrete_type($type) = true/ ); } } { my @management = ( FCGI_GET_VALUES, FCGI_GET_VALUES_RESULT, FCGI_UNKNOWN_TYPE, ); foreach my $type (@management) { is( is_management_type($type), TRUE, qq/is_management_type($type) = true/ ); } } { my @stream = ( FCGI_PARAMS, FCGI_STDIN, FCGI_STDOUT, FCGI_STDERR, FCGI_DATA, ); foreach my $type (@stream) { is( is_stream_type($type), TRUE, qq/is_stream_type($type) = true/ ); is( is_discrete_type($type), FALSE, qq/is_discrete_type($type) = false/ ); } } { my @subnames = qw( is_known_type is_discrete_type is_management_type is_stream_type ); foreach my $name (@subnames) { my $sub = __PACKAGE__->can($name); is($sub->($_), FALSE, qq/$name($_) = false/) for (-10, 0, 12); } } throws_ok { is_known_type() } qr/^Usage: /; throws_ok { is_discrete_type() } qr/^Usage: /; throws_ok { is_management_type() } qr/^Usage: /; throws_ok { is_stream_type() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/070_names.t000644 000766 000024 00000004654 11355722261 020545 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 29; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Constant', qw[ :type :role :protocol_status ] ); use_ok('Net::FastCGI::Protocol', qw[ get_type_name get_role_name get_protocol_status_name ] ); } { my @tests = ( [ FCGI_BEGIN_REQUEST, 'FCGI_BEGIN_REQUEST' ], [ FCGI_ABORT_REQUEST, 'FCGI_ABORT_REQUEST' ], [ FCGI_END_REQUEST, 'FCGI_END_REQUEST' ], [ FCGI_PARAMS, 'FCGI_PARAMS' ], [ FCGI_STDIN, 'FCGI_STDIN' ], [ FCGI_STDOUT, 'FCGI_STDOUT' ], [ FCGI_STDERR, 'FCGI_STDERR' ], [ FCGI_DATA, 'FCGI_DATA' ], [ FCGI_GET_VALUES, 'FCGI_GET_VALUES' ], [ FCGI_GET_VALUES_RESULT, 'FCGI_GET_VALUES_RESULT' ], [ FCGI_UNKNOWN_TYPE, 'FCGI_UNKNOWN_TYPE' ], ); foreach my $test ( @tests ) { my ( $type, $name ) = @$test; is( get_type_name($type), $name, qq/get_type_name($type) = $name/ ); } foreach my $type ( 0, 0xFF ) { is(get_type_name($type), sprintf('0x%.2X', $type)); } } { my @tests = ( [ FCGI_RESPONDER, 'FCGI_RESPONDER' ], [ FCGI_AUTHORIZER, 'FCGI_AUTHORIZER' ], [ FCGI_FILTER, 'FCGI_FILTER' ], ); foreach my $test ( @tests ) { my ( $role, $name ) = @$test; is( get_role_name($role), $name, qq/get_role_name($role) = $name/ ); } foreach my $role ( 0, 0xFF, 0xFFFF ) { is(get_role_name($role), sprintf('0x%.4X', $role)); } } { my @tests = ( [ FCGI_REQUEST_COMPLETE, 'FCGI_REQUEST_COMPLETE' ], [ FCGI_CANT_MPX_CONN, 'FCGI_CANT_MPX_CONN' ], [ FCGI_OVERLOADED, 'FCGI_OVERLOADED' ], [ FCGI_UNKNOWN_ROLE, 'FCGI_UNKNOWN_ROLE' ], ); foreach my $test ( @tests ) { my ( $status, $name ) = @$test; is( get_protocol_status_name($status), $name, qq/get_protocol_status_name($status) = $name/ ); } is(get_protocol_status_name(0xFF), '0xFF'); } throws_ok { get_type_name() } qr/^Usage: /; throws_ok { get_role_name() } qr/^Usage: /; throws_ok { get_protocol_status_name() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/080_dump_record.t000644 000766 000024 00000002402 11357656617 021750 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 9; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Protocol', qw[build_record dump_record]); } { my $record = build_record(0, 0, "\x00\x01\x02\x03\x04\x05\x06\x07"); my $dump = dump_record($record); like $dump, qr/\A \{0x00, \s 0, \s "\\x00\\x01\\x02\\x03\\x04\\x05\\x06\\x07"\}/x; } { my $record = build_record(0, 0, "\x00\x01\x02\x03\x04\x05\x06\x07"); for my $len (0, 8) { my $dump = dump_record(substr($record, 0, $len)); like $dump, qr/\A \{ Malformed \s FCGI_Record }/x, "Insufficient octets"; } } { for my $header ("\x00\x00\x00\x00\x00\x00\x00\x00", "\xFF\x00\x00\x00\x00\x00\x00\x00") { my $dump = dump_record($header); like $dump, qr/\A \{ Malformed \s FCGI_Record }/x, "Protocol version mismatch"; } } # dump_record(type, request_id [, content]) deprecated { my $dump = dump_record(0, 0); like $dump, qr/\A \{0x00, \s 0, \s ""\}/x; } { my $dump = dump_record(0, 0, "\x00\x01\x02\x03\x04\x05\x06\x07"); like $dump, qr/\A \{0x00, \s 0, \s "\\x00\\x01\\x02\\x03\\x04\\x05\\x06\\x07"\}/x; } # dump_record(octets) throws_ok { dump_record() } qr/^Usage: /; Net-FastCGI-0.14/t/020_protocol/085_dump_record_body.t000644 000766 000024 00000011200 11357606136 022755 0ustar00chansenstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib', 'lib'; use myconfig; use Test::More tests => 64; use Test::HexString; use Test::Exception; BEGIN { use_ok('Net::FastCGI::Constant', qw[:all]); use_ok('Net::FastCGI::Protocol', qw[:all]); } my @KNOWN_TYPES = ( FCGI_BEGIN_REQUEST, FCGI_ABORT_REQUEST, FCGI_END_REQUEST, FCGI_PARAMS, FCGI_STDIN, FCGI_STDOUT, FCGI_STDERR, FCGI_DATA, FCGI_GET_VALUES, FCGI_GET_VALUES_RESULT, FCGI_UNKNOWN_TYPE, ); foreach my $type (@KNOWN_TYPES) { like dump_record_body($type, 0), qr/\A\{ $FCGI_TYPE_NAME[$type]\, \s+ 0/x; } foreach my $type (FCGI_PARAMS, FCGI_GET_VALUES, FCGI_GET_VALUES_RESULT) { my $name = $FCGI_TYPE_NAME[$type]; { my $dump = dump_record_body($type, 1, ''); like $dump, qr/\A \{ $name\, \s+ 1\, \s ""/x; } { my $dump = dump_record_body($type, 1, build_params({ '' => '' })); like $dump, qr/\A \{ $name\, \s+ 1\, \s "\\000\\000"/x; } { my $dump = dump_record_body($type, 1, build_params({ 'Foo' => '' })); like $dump, qr/\A \{ $name\, \s+ 1\, \s "\\003\\000Foo"/x; } { my $dump = dump_record_body($type, 1, build_params({ "Foo\r\n" => "\x01\x02" })); like $dump, qr/\A \{ $name\, \s+ 1\, \s "\\005\\002Foo\\r\\n\\x01\\x02/x; } { my $dump = dump_record_body($type, 1, build_params({ 'x' => 'y' x 128 })); like $dump, qr/\A \{ $name\, \s+ 1\, \s "\\001\\200\\000\\000\\200 x y+/x; } { my $dump = dump_record_body($type, 1, "\001\001"); like $dump, qr/\A \{ $name\, \s+ 1\, \s Malformed \s FCGI_NameValuePair/x; } } # Streams { my @tests = ( [ FCGI_STDIN, 1, "Foo\r\n\t", qr/\A \{ FCGI_STDIN\, \s+ 1\, \s \"Foo\\r\\n\\t/x ], [ FCGI_STDOUT, 1, "\x00\x01\x02\x03\x04\x05\x06\x07", qr/\A \{ FCGI_STDOUT\, \s+ 1\, \s \"\\x00\\x01\\x02\\x03\\x04\\x05\\x06\\x07/x ], [ FCGI_STDERR, 1, "Foo \x01\x02 Bar\n", qr/\A \{ FCGI_STDERR\, \s+ 1\, \s \"Foo\x20\\x01\\x02\x20Bar\\n/x ], [ FCGI_DATA, 1, 'x' x 80, qr/\A \{ FCGI_DATA\, \s+ 1\, \s \" x+ \s \.\.\./x ], ); foreach my $test (@tests) { my ($type, $request_id, $content, $expected) = @$test; my $dump = dump_record_body($type, $request_id, $content); like $dump, $expected; } } # FCGI_BEGIN_REQUEST { my @tests = ( [ build_begin_request_body(FCGI_RESPONDER, FCGI_KEEP_CONN), qr/\A \{ FCGI_BEGIN_REQUEST\, \s+ 1\, \s \{ FCGI_RESPONDER\, \s+ FCGI_KEEP_CONN\}/x ], [ build_begin_request_body(FCGI_FILTER, FCGI_KEEP_CONN | 0x10), qr/\A \{ FCGI_BEGIN_REQUEST\, \s+ 1\, \s \{ FCGI_FILTER\, \s+ FCGI_KEEP_CONN|0x10\}/x ], [ build_begin_request_body(FCGI_AUTHORIZER, 0), qr/\A \{ FCGI_BEGIN_REQUEST\, \s+ 1\, \s \{ FCGI_AUTHORIZER\, \s+ 0\}/x ], [ build_begin_request_body(0, 0x80), qr/\A \{ FCGI_BEGIN_REQUEST\, \s+ 1\, \s \{ 0x0000\, \s+ 0x80\}/x ], map([ $_, qr/\A \{ FCGI_BEGIN_REQUEST\, \s+ 1\, \s \{ Malformed \s FCGI_BeginRequestBody/x ], ('', "\x00" x 10)), ); foreach my $test (@tests) { my ($content, $expected) = @$test; my $dump = dump_record_body(FCGI_BEGIN_REQUEST, 1, $content); like $dump, $expected; } } # FCGI_END_REQUEST { my @tests = ( [ build_end_request_body(10, 0x80), qr/\A \{ FCGI_END_REQUEST\, \s+ 1\, \s \{ 10\, \s+ 0x80\}/x ], map([ $_, qr/\A \{ FCGI_END_REQUEST\, \s+ 1\, \s \{ Malformed \s FCGI_EndRequestBody/x ], ('', "\x00" x 10)), map([ build_end_request_body(0, $_), qr/\A \{ FCGI_END_REQUEST\, \s+ 1\, \s \{ 0\, \s+ $FCGI_PROTOCOL_STATUS_NAME[$_]\}/x ], (0..3)), ); foreach my $test (@tests) { my ($content, $expected) = @$test; my $dump = dump_record_body(FCGI_END_REQUEST, 1, $content); like $dump, $expected; } } # FCGI_UNKNOWN_TYPE { my @tests = ( [ build_unknown_type_body(0), qr/\A \{ FCGI_UNKNOWN_TYPE\, \s+ 0\, \s \{ 0/x ], map([ build_unknown_type_body($_), qr/\A \{ FCGI_UNKNOWN_TYPE\, \s+ 0\, \s \{ $FCGI_TYPE_NAME[$_]/x ], @KNOWN_TYPES), map([ $_, qr/\A \{ FCGI_UNKNOWN_TYPE\, \s+ 0\, \s \{ Malformed \s FCGI_UnknownTypeBody/x ], ('', "\x00" x 10)), ); foreach my $test (@tests) { my ($content, $expected) = @$test; my $dump = dump_record_body(FCGI_UNKNOWN_TYPE, 0, $content); like $dump, $expected; } } throws_ok { dump_record_body() } qr/^Usage: /; throws_ok { dump_record_body(0, 0, undef, 0) } qr/^Usage: /; Net-FastCGI-0.14/lib/Net/000755 000766 000024 00000000000 12124423015 015453 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/lib/Net/FastCGI/000755 000766 000024 00000000000 12124423015 016673 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/lib/Net/FastCGI.pm000644 000766 000024 00000000207 12124422667 017244 0ustar00chansenstaff000000 000000 package Net::FastCGI; use strict; use warnings; our $VERSION = '0.14'; use Net::FastCGI::Constant; use Net::FastCGI::Protocol; 1; Net-FastCGI-0.14/lib/Net/FastCGI.pod000644 000766 000024 00000007040 11417410556 017412 0ustar00chansenstaff000000 000000 =head1 NAME Net::FastCGI - FastCGI Toolkit =head1 DESCRIPTION This distribution aims to provide a complete API for working with the FastCGI protocol. The primary goal is to provide a function oriented and object oriented API which are not tied to a specific I/O model or framework. Secondary goal is to provide higher level tools/API which can be used for debugging and interoperability testing. =head1 PROGRESS The function oriented API is considered feature complete. L provides functions to build and parse all FastCGI v1.0 messages, also provided is a few convenient higher level functions such as C, C, C and C. Work has begun on object oriented implementation and a simple blocking I/O class which is intended for testing and debugging. =head1 PACKAGES =over 4 =item L FastCGI protocol constants. =item L Provides functions to read and write FastCGI messages. =item L Provides functions to build and parse FastCGI messages. =back =head1 ENVIRONMENT Environment variable C can be set to a true value before loading this package to disable usage of XS implementation. =head1 PREREQUISITES =head2 Run-Time =over 4 =item L 5.6 or greater. =item L, core module. =item L, core module. =back =head2 Build-Time In addition to Run-Time: =over 4 =item L 0.47 or greater, core module since 5.6.2. =item L. =item L. =back =head1 SEE ALSO =head2 Community =over 4 =item Official FastCGI site L =back =head2 Standards =over 4 =item FastCGI Specification Version 1.0 L =item RFC 3875 - The Common Gateway Interface (CGI) Version 1.1 L =back =head2 White papers =over 4 =item FastCGI: A High-Performance Web Server Interface L =item FastCGI - The Forgotten Treasure L =back =head2 Perl implementations =over 4 =item L Application server implementation, built on top of L. Supports Responder role. Capable of multiplexing. =item L Application server implementation, built on top of C (reference implementation). Supports all FastCGI roles. Responds to management records. Processes requests synchronously. =item L Application server implementation, built on top of L. Supports Responder role. Responds to management records. Capable of multiplexing. =item L Client (Web server) implementation. Supports Responder role. =item L Application server implementation, built on top of L. Supports Responder role. =item L Application server implementation. Supports Responder role. Processes requests synchronously. =item L Application server implementation, built on top of L. Supports Responder role. Capable of multiplexing. =back =head1 SUPPORT Please report any bugs or feature requests to C, or through the web interface at L =head1 AUTHOR Christian Hansen C =head1 COPYRIGHT Copyright 2008-2010 by Christian Hansen. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-FastCGI-0.14/lib/Net/FastCGI/Constant.pm000644 000766 000024 00000014157 12124422643 021040 0ustar00chansenstaff000000 000000 package Net::FastCGI::Constant; use strict; use warnings; BEGIN { our $VERSION = '0.14'; my @common = qw[ FCGI_MAX_CONTENT_LEN FCGI_MAX_LEN FCGI_HEADER_LEN FCGI_VERSION_1 FCGI_NULL_REQUEST_ID ]; my @type = qw[ FCGI_BEGIN_REQUEST FCGI_ABORT_REQUEST FCGI_END_REQUEST FCGI_PARAMS FCGI_STDIN FCGI_STDOUT FCGI_STDERR FCGI_DATA FCGI_GET_VALUES FCGI_GET_VALUES_RESULT FCGI_UNKNOWN_TYPE FCGI_MAXTYPE ]; my @role = qw[ FCGI_RESPONDER FCGI_AUTHORIZER FCGI_FILTER ]; my @flag = qw[ FCGI_KEEP_CONN ]; my @protocol_status = qw[ FCGI_REQUEST_COMPLETE FCGI_CANT_MPX_CONN FCGI_OVERLOADED FCGI_UNKNOWN_ROLE ]; my @value = qw[ FCGI_MAX_CONNS FCGI_MAX_REQS FCGI_MPXS_CONNS ]; my @pack = qw[ FCGI_Header FCGI_BeginRequestBody FCGI_EndRequestBody FCGI_UnknownTypeBody ]; my @name = qw[ @FCGI_TYPE_NAME @FCGI_RECORD_NAME @FCGI_ROLE_NAME @FCGI_PROTOCOL_STATUS_NAME ]; our @EXPORT_OK = ( @common, @type, @role, @flag, @protocol_status, @value, @pack, @name ); our %EXPORT_TAGS = ( all => \@EXPORT_OK, common => \@common, type => \@type, role => \@role, flag => \@flag, protocol_status => \@protocol_status, value => \@value, pack => \@pack ); our @FCGI_TYPE_NAME = ( undef, # 0 'FCGI_BEGIN_REQUEST', # 1 'FCGI_ABORT_REQUEST', # 2 'FCGI_END_REQUEST', # 3 'FCGI_PARAMS', # 4 'FCGI_STDIN', # 5 'FCGI_STDOUT', # 6 'FCGI_STDERR', # 7 'FCGI_DATA', # 8 'FCGI_GET_VALUES', # 9 'FCGI_GET_VALUES_RESULT', # 10 'FCGI_UNKNOWN_TYPE' # 11 ); our @FCGI_RECORD_NAME = ( undef, # 0 'FCGI_BeginRequestRecord', # 1 'FCGI_AbortRequestRecord', # 2 'FCGI_EndRequestRecord', # 3 'FCGI_ParamsRecord', # 4 'FCGI_StdinRecord', # 5 'FCGI_StdoutRecord', # 6 'FCGI_StderrRecord', # 7 'FCGI_DataRecord', # 8 'FCGI_GetValuesRecord', # 9 'FCGI_GetValuesResultRecord', # 10 'FCGI_UnknownTypeRecord', # 11 ); our @FCGI_ROLE_NAME = ( undef, # 0 'FCGI_RESPONDER', # 1 'FCGI_AUTHORIZER', # 2 'FCGI_FILTER', # 3 ); our @FCGI_PROTOCOL_STATUS_NAME = ( 'FCGI_REQUEST_COMPLETE', # 0 'FCGI_CANT_MPX_CONN', # 1 'FCGI_OVERLOADED', # 2 'FCGI_UNKNOWN_ROLE', # 3 ); if (Internals->can('SvREADONLY')) { # 5.8 Internals::SvREADONLY(@FCGI_TYPE_NAME, 1); Internals::SvREADONLY(@FCGI_RECORD_NAME, 1); Internals::SvREADONLY(@FCGI_ROLE_NAME, 1); Internals::SvREADONLY(@FCGI_PROTOCOL_STATUS_NAME, 1); Internals::SvREADONLY($_, 1) for @FCGI_TYPE_NAME, @FCGI_RECORD_NAME, @FCGI_ROLE_NAME, @FCGI_PROTOCOL_STATUS_NAME; } require Exporter; *import = \&Exporter::import; } sub FCGI_LISTENSOCK_FILENO () { 0 } # common sub FCGI_MAX_CONTENT_LEN () { 0xFFFF } sub FCGI_MAX_LEN () { 0xFFFF } # deprecated sub FCGI_HEADER_LEN () { 8 } sub FCGI_VERSION_1 () { 1 } sub FCGI_NULL_REQUEST_ID () { 0 } # type sub FCGI_BEGIN_REQUEST () { 1 } sub FCGI_ABORT_REQUEST () { 2 } sub FCGI_END_REQUEST () { 3 } sub FCGI_PARAMS () { 4 } sub FCGI_STDIN () { 5 } sub FCGI_STDOUT () { 6 } sub FCGI_STDERR () { 7 } sub FCGI_DATA () { 8 } sub FCGI_GET_VALUES () { 9 } sub FCGI_GET_VALUES_RESULT () { 10 } sub FCGI_UNKNOWN_TYPE () { 11 } sub FCGI_MAXTYPE () { FCGI_UNKNOWN_TYPE } # role sub FCGI_RESPONDER () { 1 } sub FCGI_AUTHORIZER () { 2 } sub FCGI_FILTER () { 3 } # flags sub FCGI_KEEP_CONN () { 1 } # protocol status sub FCGI_REQUEST_COMPLETE () { 0 } sub FCGI_CANT_MPX_CONN () { 1 } sub FCGI_OVERLOADED () { 2 } sub FCGI_UNKNOWN_ROLE () { 3 } # value sub FCGI_MAX_CONNS () { 'FCGI_MAX_CONNS' } sub FCGI_MAX_REQS () { 'FCGI_MAX_REQS' } sub FCGI_MPXS_CONNS () { 'FCGI_MPXS_CONNS' } # pack sub FCGI_Header () { 'CCnnCx' } sub FCGI_BeginRequestBody () { 'nCx5' } sub FCGI_EndRequestBody () { 'NCx3' } sub FCGI_UnknownTypeBody () { 'Cx7' } 1; Net-FastCGI-0.14/lib/Net/FastCGI/Constant.pod000644 000766 000024 00000012662 11363555467 021224 0ustar00chansenstaff000000 000000 =head1 NAME Net::FastCGI::Constant - FastCGI protocol constants. =head1 DESCRIPTION FastCGI protocol constants. =head1 CONSTANTS Constants can either be imported individually or in sets grouped by tag names. The tag names are: =head2 C<:common> =over 4 =item C Maximum number of octets that the content component of the record can hold. (C<65535>) =item C Number of octets in C. (C<8>) =item C Value for C component of C. (C<1>) =item C Value for C component of C. (C<0>) =back =head2 C<:type> Values for C component of C. =over 4 =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =item C =back =head2 C<:flag> Mask for C component of C. =over 4 =item C =back =head2 C<:role> Values for C component of C. =over 4 =item C =item C =item C =back =head2 C<:protocol_status> Values for C component of C. =over 4 =item C =item C =item C =item C =back =head2 C<:value> Variable names for C / C records. =over 4 =item C =item C =item C =back =head2 C<:pack> C / C templates =over 4 =item C Octet/ 0 | 1 | / | | | 0 1 2 3 4 5 6 7 | 0 1 2 3 4 5 6 7 | +-----------------+-----------------+ 0 | Version | Type | +-----------------+-----------------+ 2 | Request ID | +-----------------+-----------------+ 4 | Content Length | +-----------------+-----------------+ 6 | Padding Length | Reserved | +-----------------+-----------------+ Total 8 octets Template: CCnnCx my ($version, $type, $request_id, $content_length, $padding_length) = unpack(FCGI_Header, $octets); =item C Octet/ 0 | 1 | / | | | 0 1 2 3 4 5 6 7 | 0 1 2 3 4 5 6 7 | +-----------------+-----------------+ 0 | Role | +-----------------+-----------------+ 2 | Flags | | +-----------------+ + 4 | | + Reserved + 6 | | +-----------------+-----------------+ Total 8 octets Template: nCx5 my ($role, $flags) = unpack(FCGI_BeginRequestBody, $octets); =item C Octet/ 0 | 1 | / | | | 0 1 2 3 4 5 6 7 | 0 1 2 3 4 5 6 7 | +-----------------+-----------------+ 0 | | + Application Status + 2 | | +-----------------+-----------------+ 4 | Protocol Status | | +-----------------+ Reserved + 6 | | +-----------------+-----------------+ Total 8 octets Template: NCx3 my ($app_status, $protocol_status) = unpack(FCGI_EndRequestBody, $octets); =item C Octet/ 0 | 1 | / | | | 0 1 2 3 4 5 6 7 | 0 1 2 3 4 5 6 7 | +-----------------+-----------------+ 0 | Unknown Type | | +-----------------+ + 2 | | + + 4 | Reserved | + + 6 | | +-----------------+-----------------+ Total 8 octets Template: Cx7 my $unknown_type = unpack(FCGI_UnknownTypeBody, $octets); =back =head2 C<:name> Arrays containing names of value components. These are read-only. =over 4 =item C<@FCGI_TYPE_NAME> print $FCGI_TYPE_NAME[FCGI_BEGIN_REQUEST]; # FCGI_BEGIN_REQUEST =item C<@FCGI_ROLE_NAME> print $FCGI_ROLE_NAME[FCGI_RESPONDER]; # FCGI_RESPONDER =item C<@FCGI_PROTOCOL_STATUS_NAME> print $FCGI_PROTOCOL_STATUS_NAME[FCGI_OVERLOADED]; # FCGI_OVERLOADED =back I It's not safe to assume that C works for validation purposes, index C<0> might be C. Use boolean context instead: ($FCGI_TYPE_NAME[$type]) || die; =head1 EXPORTS None by default. All functions can be exported using the C<:all> tag or individually. =head1 SEE ALSO =over 4 =item L =back =head1 AUTHOR Christian Hansen C =head1 COPYRIGHT Copyright 2008-2010 by Christian Hansen. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-FastCGI-0.14/lib/Net/FastCGI/IO.pm000644 000766 000024 00000012642 12124422652 017553 0ustar00chansenstaff000000 000000 package Net::FastCGI::IO; use strict; use warnings; use warnings::register; use Carp qw[]; use Errno qw[EBADF EINTR EPIPE]; use Net::FastCGI::Constant qw[FCGI_HEADER_LEN]; use Net::FastCGI::Protocol qw[build_header build_record build_stream parse_header parse_record]; BEGIN { our $VERSION = '0.14'; our @EXPORT_OK = qw[ can_read can_write read_header read_record write_header write_record write_stream ]; our %EXPORT_TAGS = ( all => \@EXPORT_OK ); require Exporter; *import = \&Exporter::import; eval q; } *throw = \&Carp::croak; sub read_header { @_ == 1 || throw(q/Usage: read_header(fh)/); my ($fh) = @_; my $len = FCGI_HEADER_LEN; my $off = 0; my $buf; while ($len) { my $r = sysread($fh, $buf, $len, $off); if (defined $r) { last unless $r; $len -= $r; $off += $r; } elsif ($! != EINTR) { warnings::warn(qq) if warnings::enabled; return; } } if ($len) { $! = $off ? EPIPE : 0; warnings::warn(q) if $off && warnings::enabled; return; } return parse_header($buf); } sub write_header { @_ == 5 || throw(q/Usage: write_header(fh, type, request_id, content_length, padding_length)/); my $fh = shift; my $buf = &build_header; my $len = FCGI_HEADER_LEN; my $off = 0; while () { my $r = syswrite($fh, $buf, $len, $off); if (defined $r) { $len -= $r; $off += $r; last unless $len; } elsif ($! != EINTR) { warnings::warn(qq) if warnings::enabled; return undef; } } return $off; } sub read_record { @_ == 1 || throw(q/Usage: read_record(fh)/); my ($fh) = @_; my $len = FCGI_HEADER_LEN; my $off = 0; my $buf; while ($len) { my $r = sysread($fh, $buf, $len, $off); if (defined $r) { last unless $r; $len -= $r; $off += $r; if (!$len && $off == FCGI_HEADER_LEN) { $len = vec($buf, 2, 16) # Content Length + vec($buf, 6, 8); # Padding Length } } elsif ($! != EINTR) { warnings::warn(qq) if warnings::enabled; return; } } if ($len) { $! = $off ? EPIPE : 0; warnings::warn(q) if $off && warnings::enabled; return; } return parse_record($buf); } sub write_record { @_ == 4 || @_ == 5 || throw(q/Usage: write_record(fh, type, request_id [, content])/); my $fh = shift; my $buf = &build_record; my $len = length $buf; my $off = 0; while () { my $r = syswrite($fh, $buf, $len, $off); if (defined $r) { $len -= $r; $off += $r; last unless $len; } elsif ($! != EINTR) { warnings::warn(qq) if warnings::enabled; return undef; } } return $off; } sub write_stream { @_ == 4 || @_ == 5 || throw(q/Usage: write_stream(fh, type, request_id, content [, terminate])/); my $fh = shift; my $buf = &build_stream; my $len = length $buf; my $off = 0; while () { my $r = syswrite($fh, $buf, $len, $off); if (defined $r) { $len -= $r; $off += $r; last unless $len; } elsif ($! != EINTR) { warnings::warn(qq) if warnings::enabled; return undef; } } return $off; } sub can_read (*$) { @_ == 2 || throw(q/Usage: can_read(fh, timeout)/); my ($fh, $timeout) = @_; my $fd = fileno($fh); unless (defined $fd && $fd >= 0) { $! = EBADF; return undef; } my $initial = time; my $pending = $timeout; my $nfound; vec(my $fdset = '', $fd, 1) = 1; while () { $nfound = select($fdset, undef, undef, $pending); if ($nfound == -1) { return undef unless $! == EINTR; redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; $nfound = 0; } last; } $! = 0; return $nfound; } sub can_write (*$) { @_ == 2 || throw(q/Usage: can_write(fh, timeout)/); my ($fh, $timeout) = @_; my $fd = fileno($fh); unless (defined $fd && $fd >= 0) { $! = EBADF; return undef; } my $initial = time; my $pending = $timeout; my $nfound; vec(my $fdset = '', $fd, 1) = 1; while () { $nfound = select(undef, $fdset, undef, $pending); if ($nfound == -1) { return undef unless $! == EINTR; redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; $nfound = 0; } last; } $! = 0; return $nfound; } 1; Net-FastCGI-0.14/lib/Net/FastCGI/IO.pod000644 000766 000024 00000021606 11364263646 017734 0ustar00chansenstaff000000 000000 =head1 NAME Net::FastCGI::IO - Provides functions to read and write FastCGI messages. =head1 SYNOPSIS # FCGI_Header @values = read_header($fh); $header = read_header($fh); $result = write_header($fh, $type, $request_id, $content_length, $padding_length); # FCGI_Record @values = read_record($fh); $record = read_record($fh); $result = write_record($fh, $type, $request_id); $result = write_record($fh, $type, $request_id, $content); # FCGI_Record Stream $result = write_stream($fh, $type, $request_id, $content); $result = write_stream($fh, $type, $request_id, $content, $terminate); # I/O ready $result = can_read($fh, $timeout); $result = can_write($fh, $timeout); =head1 DESCRIPTION Provides unbuffered blocking I/O functions to read and write FastCGI messages. =head1 FUNCTIONS =head2 read_header Attempts to read a C from file handle C<$fh>. I ($type, $request_id, $content_length, $padding_length) = read_header($fh); $header = read_header($fh); say $header->{type}; say $header->{request_id}; say $header->{content_length}; say $header->{padding_length}; I =over 4 =item C<$fh> The file handle to read from. Must be a file handle with a file descriptor. File handle mode should be set to binary. =back I Upon successful completion, the return value of L. Otherwise, a false value (C in scalar context and an empty list in list context). If C reaches end-of-file before reading any octets, it returns a false value. If unsuccessful, C returns a false value and C<$!> contains the error from the C call. If C encounters end-of-file after some but not all of the needed octets, the function returns a false value and sets C<$!> to C. I The implementation calls C in a loop, restarting if C returns C with C<$!> set to C. If C does not provide all the requested octets, C continues to call C until either all the octets have been read, reaches end-of-file or an error occurs. =head2 read_record Attempts to read a C from file handle C<$fh>. I ($type, $request_id, $content) = read_record($fh); $record = read_record($fh); say $record->{type}; say $record->{request_id}; I =over 4 =item C<$fh> The file handle to read from. Must be a file handle with a file descriptor. File handle mode should be set to binary. =back I Upon successful completion, the return value of L. Otherwise, a false value (C in scalar context and an empty list in list context). If C reaches end-of-file before reading any octets, it returns a false value. If unsuccessful, C returns a false value and C<$!> contains the error from the C call. If C encounters end-of-file after some but not all of the needed octets, the function returns a false value and sets C<$!> to C. I The implementation calls C in a loop, restarting if C returns C with C<$!> set to C. If C does not provide all the requested octets, C continues to call C until either all the octets have been read, reaches end-of-file or an error occurs. =head2 write_header Attempts to write a C to file handle C<$fh>. I $result = write_header($fh, $type, $request_id, $content_length, $padding_length); I =over 4 =item C<$fh> The file handle to write to. Must be a file handle with a file descriptor. File handle mode should be set to binary. =item C<$type> An unsigned 8-bit integer. =item C<$request_id> An unsigned 16-bit integer. =item C<$content_length> An unsigned 16-bit integer. =item C<$padding_length> An unsigned 8-bit integer. =back I =over 4 =item C<$result> Upon successful completion, the number of octets actually written. Otherwise, C and C<$!> contains the error from the C call. =back I The implementation calls C in a loop, restarting if C returns C with C<$!> set to C. If C does not output all the requested octets, C continues to call C until all the octets have been written or an error occurs. =head2 write_record Attempts to write a C to file handle C<$fh>. I $result = write_record($fh, $type, $request_id); $result = write_record($fh, $type, $request_id, $content); I =over 4 =item C<$fh> The file handle to write to. Must be a file handle with a file descriptor. File handle mode should be set to binary. =item C<$type> An unsigned 8-bit integer. =item C<$request_id> An unsigned 16-bit integer. =item C<$content> (optional) A string of octets containing the content, cannot exceed 65535 octets in length. =back I =over 4 =item C<$result> Upon successful completion, the number of octets actually written. Otherwise, C and C<$!> contains the error from the C call. =back I The implementation calls C in a loop, restarting if C returns C with C<$!> set to C. If C does not output all the requested octets, C continues to call C until all the octets have been written or an error occurs. =head2 write_stream Attempts to write a C stream to file handle C<$fh>. I $result = write_stream($fh, $type, $request_id, $content); $result = write_stream($fh, $type, $request_id, $content, $terminate); I =over 4 =item C<$fh> The file handle to write to. Must be a file handle with a file descriptor. File handle mode should be set to binary. =item C<$type> An unsigned 8-bit integer. =item C<$request_id> An unsigned 16-bit integer. =item C<$content> A string of octets containing the stream content. =item C<$terminate> (optional) A boolean indicating whether or not the stream should be terminated. Defaults to false. =back I =over 4 =item C<$result> Upon successful completion, the number of octets actually written. Otherwise, C and C<$!> contains the error from the C call. =back I The implementation calls C in a loop, restarting if C returns C with C<$!> set to C. If C does not output all the requested octets, C continues to call C until all the octets have been written or an error occurs. =head2 can_read Determines wheter or not the given file handle C<$fh> is ready for reading within the given timeout C<$timeout>. I $result = can_read($fh, $timeout); I =over 4 =item C<$fh> The file handle to test for readiness. Must be a file handle with a file descriptor. =item C<$timeout> Maximum interval to wait. Can be set to either a non-negative numeric value or C for infinite wait. =back I Upon successful completion, C<0> or C<1>. Otherwise, C and C<$!> contains the C in a loop, restarting if C error. I The implementation calls C returns C<-1> with C<$!> set to C and C<$timeout> has not elapsed. =head1 EXPORTS None by default. All functions can be exported using the C<:all> tag or individually. =head1 DIAGNOSTICS =over 4 =item B<(F)> Usage: %s Subroutine called with wrong number of arguments. =item B<(W Net::FastCGI::IO)> FastCGI: Could not read %s =item B<(W Net::FastCGI::IO)> FastCGI: Could not write %s =back =head1 SEE ALSO =over 4 =item FastCGI Specification Version 1.0 L =item The Common Gateway Interface (CGI) Version 1.1 L =item L =item L =back =head1 AUTHOR Christian Hansen C =head1 COPYRIGHT Copyright 2008-2010 by Christian Hansen. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-FastCGI-0.14/lib/Net/FastCGI/Protocol/000755 000766 000024 00000000000 12124423015 020474 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/lib/Net/FastCGI/Protocol.pm000644 000766 000024 00000015042 12124422663 021044 0ustar00chansenstaff000000 000000 package Net::FastCGI::Protocol; use strict; use warnings; use Carp qw[croak]; use Net::FastCGI qw[]; use Net::FastCGI::Constant qw[:type :common FCGI_KEEP_CONN]; BEGIN { our $VERSION = '0.14'; our @EXPORT_OK = qw[ build_begin_request build_begin_request_body build_begin_request_record build_end_request build_end_request_body build_end_request_record build_header build_params build_record build_stream build_unknown_type_body build_unknown_type_record check_params parse_begin_request_body parse_end_request_body parse_header parse_params parse_record parse_record_body parse_unknown_type_body get_record_length get_type_name get_role_name get_protocol_status_name is_known_type is_management_type is_discrete_type is_stream_type ]; our %EXPORT_TAGS = ( all => \@EXPORT_OK ); my $use_pp = $ENV{NET_FASTCGI_PP} || $ENV{NET_FASTCGI_PROTOCOL_PP}; if (!$use_pp) { eval { require Net::FastCGI::Protocol::XS; }; $use_pp = !!$@; } if ($use_pp) { require Net::FastCGI::Protocol::PP; Net::FastCGI::Protocol::PP->import(@EXPORT_OK); } else { Net::FastCGI::Protocol::XS->import(@EXPORT_OK); } # shared between XS and PP implementation push @EXPORT_OK, 'dump_record', 'dump_record_body'; require Exporter; *import = \&Exporter::import; } our $DUMP_RECORD_MAX = 78; # undocumented our $DUMP_RECORD_ALIGN = !!0; # undocumented my %ESCAPES = ( "\a" => "\\a", "\b" => "\\b", "\t" => "\\t", "\n" => "\\n", "\f" => "\\f", "\r" => "\\r", ); sub dump_record { goto \&dump_record_body if (@_ == 2 || @_ == 3); # deprecated @_ == 1 || croak(q/Usage: dump_record(octets)/); my $len = &get_record_length; ($len && $len <= length $_[0] && vec($_[0], 0, 8) == FCGI_VERSION_1) || return '{Malformed FCGI_Record}'; return dump_record_body(&parse_record); } sub dump_record_body { @_ == 2 || @_ == 3 || croak(q/Usage: dump_record_body(type, request_id [, content])/); my ($type, $request_id) = @_; my $content_length = defined $_[2] ? length $_[2] : 0; my $max = $DUMP_RECORD_MAX > 0 ? $DUMP_RECORD_MAX : FCGI_MAX_CONTENT_LEN; my $out = ''; if ( $type == FCGI_PARAMS || $type == FCGI_GET_VALUES || $type == FCGI_GET_VALUES_RESULT) { if ($content_length == 0) { $out = q[""]; } elsif (check_params($_[2])) { my ($off, $klen, $vlen) = (0); while ($off < $content_length) { my $pos = $off; for ($klen, $vlen) { $_ = vec($_[2], $off, 8); $_ = vec(substr($_[2], $off, 4), 0, 32) & 0x7FFF_FFFF if $_ > 0x7F; $off += $_ > 0x7F ? 4 : 1; } my $head = substr($_[2], $pos, $off - $pos); $head =~ s/(.)/sprintf('\\%.3o',ord($1))/egs; $out .= $head; my $body = substr($_[2], $off, $klen + $vlen); for ($body) { s/([\\\"])/\\$1/g; s/([\a\b\t\n\f\r])/$ESCAPES{$1}/g; s/([^\x20-\x7E])/sprintf('\\x%.2X',ord($1))/eg; } $out .= $body; $off += $klen + $vlen; last if $off > $max; } substr($out, $max - 5) = ' ... ' if length $out > $max; $out = qq["$out"]; } else { $out = 'Malformed FCGI_NameValuePair(s)'; } } elsif ( $type == FCGI_BEGIN_REQUEST || $type == FCGI_END_REQUEST || $type == FCGI_UNKNOWN_TYPE) { if ($content_length != 8) { my $name = $type == FCGI_BEGIN_REQUEST ? 'FCGI_BeginRequestBody' : $type == FCGI_END_REQUEST ? 'FCGI_EndRequestBody' : 'FCGI_UnknownTypeBody'; $out = sprintf '{Malformed %s (expected 8 octets got %d)}', $name, $content_length; } elsif ($type == FCGI_BEGIN_REQUEST) { my ($role, $flags) = parse_begin_request_body($_[2]); if ($flags != 0) { my @set; if ($flags & FCGI_KEEP_CONN) { $flags &= ~FCGI_KEEP_CONN; push @set, 'FCGI_KEEP_CONN'; } if ($flags) { push @set, sprintf '0x%.2X', $flags; } $flags = join '|', @set; } $out = sprintf '{%s, %s}', get_role_name($role), $flags; } elsif($type == FCGI_END_REQUEST) { my ($astatus, $pstatus) = parse_end_request_body($_[2]); $out = sprintf '{%d, %s}', $astatus, get_protocol_status_name($pstatus); } else { my $unknown_type = parse_unknown_type_body($_[2]); $out = sprintf '{%s}', get_type_name($unknown_type); } } elsif ($content_length) { my $looks_like_binary = do { my $count = () = $_[2] =~ /[\r\n\t\x20-\x7E]/g; ($count / $content_length) < 0.7; }; $out = substr($_[2], 0, $max + 1); for ($out) { if ($looks_like_binary) { s/(.)/sprintf('\\x%.2X',ord($1))/egs; } else { s/([\\\"])/\\$1/g; s/([\a\b\t\n\f\r])/$ESCAPES{$1}/g; s/([^\x20-\x7E])/sprintf('\\x%.2X',ord($1))/eg; } } substr($out, $max - 5) = ' ... ' if length $out > $max; $out = qq["$out"]; } else { $out = q[""]; } my $name = get_type_name($type); my $width = 0; $width = 27 - length $name # length("FCGI_GET_VALUES_RESULT") == 22 if $DUMP_RECORD_ALIGN; # + length(0xFFFF) == 5 return sprintf '{%s, %*d, %s}', $name, $width, $request_id, $out; } 1; Net-FastCGI-0.14/lib/Net/FastCGI/Protocol.pod000644 000766 000024 00000044577 11363560227 021234 0ustar00chansenstaff000000 000000 =head1 NAME Net::FastCGI::Protocol - Provides functions to build and parse FastCGI messages. =head1 SYNOPSIS # FCGI_Header $octets = build_header($type, $request_id, $content_length, $padding_length); @values = parse_header($octets); $header = parse_header($octets); # FCGI_BeginRequestBody $octets = build_begin_request_body($role, $flags); @values = parse_begin_request_body($octets); # FCGI_EndRequestBody $octets = build_end_request_body($app_status, $protocol_status); @values = parse_end_request_body($octets); # FCGI_UnknownTypeBody $octets = build_unknown_type_body($type); @values = parse_unknown_type_body($octets); # FCGI_BeginRequestRecord $octets = build_begin_request_record($request_id, $role, $flags); # FCGI_EndRequestRecord $octets = build_end_request_record($request_id, $app_status, $protocol_status); # FCGI_UnknownTypeRecord $octets = build_unknown_type_record($type); # FCGI_NameValuePair's $octets = build_params($params); $params = parse_params($octets); $bool = check_params($octets); # FCGI_Record $octets = build_record($type, $request_id); $octets = build_record($type, $request_id, $content); @values = parse_record($octets); $record = parse_record($octets); $record = parse_record_body($type, $request_id, $content); # FCGI_Record Debugging / Tracing $string = dump_record($octets); $string = dump_record_body($type, $request_id, $content); # FCGI_Record Stream $octets = build_stream($type, $request_id, $content); $octets = build_stream($type, $request_id, $content, $terminate); # Begin Request $octets = build_begin_request($request_id, $role, $flags, $params); $octets = build_begin_request($request_id, $role, $flags, $params, $stdin); $octets = build_begin_request($request_id, $role, $flags, $params, $stdin, $data); # End Request $octets = build_end_request($request_id, $app_status, $protocol_status); $octets = build_end_request($request_id, $app_status, $protocol_status, $stdout); $octets = build_end_request($request_id, $app_status, $protocol_status, $stdout, $stderr); =head1 DESCRIPTION Provides functions to build and parse FastCGI messages. =head1 FUNCTIONS Please note that all functions in this package expects octets, not unicode strings. It's the callers responsibility to ensure this. If any of theese functions is called with unicode strings containing code points above 255, they will most likely produce malformed messages. =head2 build_begin_request Builds a Begin Request message. I $octets = build_begin_request($request_id, $role, $flags, $params); $octets = build_begin_request($request_id, $role, $flags, $params, $stdin); $octets = build_begin_request($request_id, $role, $flags, $params, $stdin, $data); I =over 4 =item C<$request_id> An unsigned 16-bit integer. Identifier of the request. =item C<$role> An unsigned 16-bit integer. This should be set to either C, C or C. =item C<$flags> An unsigned 8-bit integer. This should be set to either C<0> or contain the mask C if a persistent connection is desired. =item C<$params> A hash reference containing name-value pairs. This is the CGI environ that the application expects. =item C<$stdin> (optional) A string of octets containing the C content. This should only be provided if C<$role> is set to either C or C. The C stream is terminated if provided. =item C<$data> (optional) A string of octets containing the C content. This should only be provided if C<$role> is set to C. The C stream is terminated if provided. =back I =over 4 =item C<$octets> A string of octets containing the message. =back =head2 build_begin_request_body Builds a C. I $octets = build_begin_request_body($role, $flags); I =over 4 =item C<$role> An unsigned 16-bit integer. =item C<$flags> An unsigned 8-bit integer. =back I =over 4 =item C<$octets> A string of octets containing the body. String is 8 octets in length. =back =head2 build_begin_request_record Builds a C. I $octets = build_begin_request_record($request_id, $role, $flags); I =over 4 =item C<$request_id> An unsigned 16-bit integer. =item C<$role> An unsigned 16-bit integer. =item C<$flags> An unsigned 8-bit integer. =back I =over 4 =item C<$octets> A string of octets containing the record. String is 16 octets in length. =back =head2 build_end_request Builds a End Request message I $octets = build_end_request($request_id, $app_status, $protocol_status); $octets = build_end_request($request_id, $app_status, $protocol_status, $stdout); $octets = build_end_request($request_id, $app_status, $protocol_status, $stdout, $stderr); I =over 4 =item C<$request_id> An unsigned 16-bit integer. Identifier of the request. =item C<$app_status> An unsigned 32-bit integer. Application status code of the request. =item C<$protocol_status> An unsigned 8-bit integer. This should be set to either C, C, C or C. =item C<$stdout> (optional) A string of octets containing the C content. The C stream is terminated if provided. =item C<$stderr> (optional) A string of octets containing the C content. The C stream is terminated if provided. =back I =over 4 =item C<$octets> A string of octets containing the message. =back I This function is equivalent to C if called without C<$stdout> and C<$stderr>. =head2 build_end_request_body Builds a C. I $octets = build_end_request_body($app_status, $protocol_status); I =over 4 =item C<$app_status> An unsigned 32-bit integer. =item C<$protocol_status> An unsigned 8-bit integer. =back I =over 4 =item C<$octets> A string of octets containing the body. String is 8 octets in length. =back =head2 build_end_request_record Builds a C. I $octets = build_end_request_record($request_id, $app_status, $protocol_status); I =over 4 =item C<$request_id> An unsigned 16-bit integer. =item C<$app_status> An unsigned 32-bit integer. =item C<$protocol_status> An unsigned 8-bit integer. =back I =over 4 =item C<$octets> A string of octets containing the record. String is 16 octets in length. =back =head2 build_header Builds a C. I $octets = build_header($type, $request_id, $content_length, $padding_length); I =over 4 =item C<$type> An unsigned 8-bit integer. =item C<$request_id> An unsigned 16-bit integer. =item C<$content_length> An unsigned 16-bit integer. =item C<$padding_length> An unsigned 8-bit integer. =back I =over 4 =item C<$octets> A string of octets containing the header. String is 8 octets in length. =back =head2 build_params Builds C's. I $octets = build_params($params); I =over 4 =item C<$params> A hash reference containing name-value pairs. =back I =over 4 =item C<$octets> =back =head2 build_record Builds a C. I $octets = build_record($type, $request_id); $octets = build_record($type, $request_id, $content); I =over 4 =item C<$type> An unsigned 8-bit integer. =item C<$request_id> An unsigned 16-bit integer. =item C<$content> (optional) A string of octets containing the content, cannot exceed 65535 octets in length. =back I =over 4 =item C<$octets> A string of octets containing the record. =back I Follows the recommendation in specification and pads the record by 8-(content_length mod 8) zero-octets. =head2 build_stream Builds a series of stream records. I $octets = build_stream($type, $request_id, $content); $octets = build_stream($type, $request_id, $content, $terminate); I =over 4 =item C<$type> An unsigned 8-bit integer. =item C<$request_id> An unsigned 16-bit integer. =item C<$content> A string of octets containing the stream content. =item C<$terminate> (optional) A boolean indicating whether or not the stream should be terminated. Defaults to false. =back I =over 4 =item C<$octets> A string of octets containing the stream. =back I Stream is not terminated if C<$content> is empty unless C<$terminate> is set. C<$content> is split in segment sizes of 32760 octets (32768 - FCGI_HEADER_LEN). =head2 build_unknown_type_body Builds a C. I $octets = build_unknown_type_body($type); I =over 4 =item C<$type> An unsigned 8-bit integer. =back I =over 4 =item C<$octets> A string of octets containing the body. String is 8 octets in length. =back =head2 build_unknown_type_record Builds a C. I $octets = build_unknown_type_record($type); I =over 4 =item C<$type> An unsigned 8-bit integer. =back I =over 4 =item C<$octets> A string of octets containing the record. String is 16 octets in length. =back =head2 check_params Determine wheter or not params is well-formed. I $boolean = check_params($octets); I =over 4 =item C<$octets> A string of octets containing C's. =back I =over 4 =item C<$boolean> A boolean indicating whether or not C<$octets> consist of well-formed C's. =back =head2 dump_record Dump a C. I $string = dump_record($octets); I =over 4 =item C<$octets> A string of octets containing at least one record. =back I =over 4 =item C<$string> A short (less than 100 characters) string representation of the record in printable US-ASCII. =back =head2 dump_record_body Dump a C. I $string = dump_record_body($type, $request_id); $string = dump_record_body($type, $request_id, $content); I =over 4 =item C<$type> An unsigned 8-bit integer. =item C<$request_id> An unsigned 16-bit integer. =item C<$content> (optional) A string of octets containing the content. =back I =over 4 =item C<$string> A short (less than 100 characters) string representation of the record in printable US-ASCII. =back =head2 parse_begin_request_body Parses a C. I ($role, $flags) = parse_begin_request_body($octets); I =over 4 =item C<$octets> A string of octets containing the body, must be greater than or equal to 8 octets in length. =back I =over 4 =item C<$role> An unsigned 16-bit integer. =item C<$flags> An unsigned 8-bit integer. =back =head2 parse_end_request_body Parses a C. I ($app_status, $protocol_status) = parse_end_request_body($octets); I =over 4 =item C<$octets> A string of octets containing the body, must be greater than or equal to 8 octets in length. =back I =over 4 =item C<$app_status> An unsigned 32-bit integer. =item C<$flags> An unsigned 8-bit integer. =back =head2 parse_header Parses a C. I ($type, $request_id, $content_length, $padding_length) = parse_header($octets); $header = parse_header($octets); say $header->{type}; say $header->{request_id}; say $header->{content_length}; say $header->{padding_length}; I =over 4 =item C<$octets> A string of octets containing the header, must be greater than or equal to 8 octets in length. =back I In list context: =over 4 =item C<$type> An unsigned 8-bit integer. =item C<$request_id> An unsigned 16-bit integer. =item C<$content_length> An unsigned 16-bit integer. =item C<$padding_length> An unsigned 8-bit integer. =back In scalar context a hash reference containing above variable names as keys. =head2 parse_params Parses C's. I $params = parse_params($octets); I =over 4 =item C<$octets> A string of octets containing C's. =back I =over 4 =item C<$params> A hash reference containing name-value pairs. =back =head2 parse_record Parses a C. I ($type, $request_id, $content) = parse_record($octets); $record = parse_record($octets); say $record->{type}; say $record->{request_id}; I =over 4 =item C<$octets> A string of octets containing at least one record. =back I In list context: =over 4 =item C<$type> An unsigned 8-bit integer. =item C<$request_id> An unsigned 16-bit integer. =item C<$content> A string of octets containing the record content. =back In scalar context a hash reference containing the C components. See L. =head2 parse_record_body Parses a C. I $record = parse_record_body($type, $request_id, $content); say $record->{type}; say $record->{request_id}; I =over 4 =item C<$type> An unsigned 8-bit integer. =item C<$request_id> An unsigned 16-bit integer. =item C<$content> A string of octets containing the record content. =back I A hash reference which represents the C. The content depends on the type of record. All record types have the keys: C and C. =over 4 =item C =over 8 =item C An unsigned 16-bit integer. =item C An unsigned 8-bit integer. =back =item C =over 8 =item C An unsigned 32-bit integer. =item C An unsigned 8-bit integer. =back =item C =item C =item C =item C =item C =over 8 =item C A string of octets containing the content of the stream. =back =item C =item C =over 8 =item C A hash reference containing name-value pairs. =back =item C =over 8 =item C An unsigned 8-bit integer. =back =back =head2 parse_unknown_type_body Parses a C. I $type = parse_unknown_type_body($octets); I =over 4 =item C<$octets> C<$octets> must be greater than or equal to 8 octets in length. =back I =over 4 =item C<$type> An unsigned 8-bit integer. =back =head2 get_record_length I $length = get_record_length($octets); I =over 4 =item C<$octets> A string of octets containing at least one C. =back I =over 4 =item C<$length> An unsigned integer containing the length of record in octets. If C<$octets> contains insufficient octets C<(< FCGI_HEADER_LEN)> C<0> is returned. =back =head2 get_type_name I $name = get_type_name($type); $name = get_type_name(FCGI_BEGIN_REQUEST); # 'FCGI_BEGIN_REQUEST' $name = get_type_name(255); # '0xFF' I =over 4 =item C<$type> An unsigned 8-bit integer. =back I =over 4 =item C<$name> A string containing the name of the type. If C<$type> is not a known v1.0 type, a hexadecimal value is returned. =back I See also L. =head2 get_role_name I $name = get_role_name($type); $name = get_role_name(FCGI_RESPONDER); # 'FCGI_RESPONDER' $name = get_role_name(65535); # '0xFFFF' I =over 4 =item C<$role> An unsigned 16-bit integer. =back I =over 4 =item C<$name> A string containing the name of the role. If C<$role> is not a known v1.0 role, a hexadecimal value is returned. =back I See also L. =head2 get_protocol_status_name I $name = get_protocol_status_name($protocol_status); $name = get_protocol_status_name(FCGI_REQUEST_COMPLETE); # 'FCGI_REQUEST_COMPLETE' $name = get_protocol_status_name(255); # '0xFF' I =over 4 =item C<$protocol_status> An unsigned 8-bit integer. =back I =over 4 =item C<$name> A string containing the name of the protocol status. If C<$protocol_status> is not a known v1.0 protocol status code, a hexadecimal value is returned. =back I See also L. =head2 is_known_type I $boolean = is_known_type($type); I =over 4 =item C<$type> An unsigned 8-bit integer. =back I =over 4 =item C<$boolean> A boolean indicating whether or not C<$type> is a known FastCGI v1.0 type. =back =head2 is_management_type I $boolean = is_management_type($type); I =over 4 =item C<$type> An unsigned 8-bit integer. =back I =over 4 =item C<$boolean> A boolean indicating whether or not C<$type> is a management type. =back =head2 is_discrete_type I $boolean = is_discrete_type($type); I =over 4 =item C<$type> An unsigned 8-bit integer. =back I =over 4 =item C<$boolean> A boolean indicating whether or not C<$type> is a discrete type. =back =head2 is_stream_type I $boolean = is_stream_type($type); I =over 4 =item C<$type> An unsigned 8-bit integer. =back I =over 4 =item C<$boolean> A boolean indicating whether or not C<$type> is a stream type. =back =head1 EXPORTS None by default. All functions can be exported using the C<:all> tag or individually. =head1 DIAGNOSTICS =over 4 =item B<(F)> Usage: %s Subroutine called with wrong number of arguments. =item B<(F)> Invalid Argument: %s =item B<(F)> FastCGI: Insufficient number of octets to parse %s =item B<(F)> FastCGI: Malformed record %s =item B<(F)> FastCGI: Protocol version mismatch (0x%.2X) =back =head1 SEE ALSO =over 4 =item FastCGI Specification Version 1.0 L =item The Common Gateway Interface (CGI) Version 1.1 L =item L =back =head1 AUTHOR Christian Hansen C =head1 COPYRIGHT Copyright 2008-2010 by Christian Hansen. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-FastCGI-0.14/lib/Net/FastCGI/Protocol/PP.pm000644 000766 000024 00000032644 12124422657 021375 0ustar00chansenstaff000000 000000 package Net::FastCGI::Protocol::PP; use strict; use warnings; use Carp qw[]; use Net::FastCGI::Constant qw[:all]; BEGIN { our $VERSION = '0.14'; our @EXPORT_OK = qw[ build_begin_request build_begin_request_body build_begin_request_record build_end_request build_end_request_body build_end_request_record build_header build_params build_record build_stream build_unknown_type_body build_unknown_type_record check_params parse_begin_request_body parse_end_request_body parse_header parse_params parse_record parse_record_body parse_unknown_type_body is_known_type is_management_type is_discrete_type is_stream_type get_record_length get_role_name get_type_name get_protocol_status_name ]; our %EXPORT_TAGS = ( all => \@EXPORT_OK ); require Exporter; *import = \&Exporter::import; } sub TRUE () { !!1 } sub FALSE () { !!0 } sub ERRMSG_OCTETS () { q/FastCGI: Insufficient number of octets to parse %s/ } sub ERRMSG_MALFORMED () { q/FastCGI: Malformed record %s/ } sub ERRMSG_VERSION () { q/FastCGI: Protocol version mismatch (0x%.2X)/ } sub ERRMSG_OCTETS_LE () { q/Invalid Argument: '%s' cannot exceed %u octets in length/ } sub throw { @_ = ( sprintf($_[0], @_[1..$#_]) ) if @_ > 1; goto \&Carp::croak; } # FCGI_Header sub build_header { @_ == 4 || throw(q/Usage: build_header(type, request_id, content_length, padding_length)/); return pack(FCGI_Header, FCGI_VERSION_1, @_); } sub parse_header { @_ == 1 || throw(q/Usage: parse_header(octets)/); (defined $_[0] && length $_[0] >= 8) || throw(ERRMSG_OCTETS, q/FCGI_Header/); (vec($_[0], 0, 8) == FCGI_VERSION_1) || throw(ERRMSG_VERSION, unpack('C', $_[0])); return unpack('xCnnCx', $_[0]) if wantarray; my %header; @header{qw(type request_id content_length padding_length)} = unpack('xCnnCx', $_[0]); return \%header; } # FCGI_BeginRequestBody sub build_begin_request_body { @_ == 2 || throw(q/Usage: build_begin_request_body(role, flags)/); return pack(FCGI_BeginRequestBody, @_); } sub parse_begin_request_body { @_ == 1 || throw(q/Usage: parse_begin_request_body(octets)/); (defined $_[0] && length $_[0] >= 8) || throw(ERRMSG_OCTETS, q/FCGI_BeginRequestBody/); return unpack(FCGI_BeginRequestBody, $_[0]); } # FCGI_EndRequestBody sub build_end_request_body { @_ == 2 || throw(q/Usage: build_end_request_body(app_status, protocol_status)/); return pack(FCGI_EndRequestBody, @_); } sub parse_end_request_body { @_ == 1 || throw(q/Usage: parse_end_request_body(octets)/); (defined $_[0] && length $_[0] >= 8) || throw(ERRMSG_OCTETS, q/FCGI_EndRequestBody/); return unpack(FCGI_EndRequestBody, $_[0]); } # FCGI_UnknownTypeBody sub build_unknown_type_body { @_ == 1 || throw(q/Usage: build_unknown_type_body(type)/); return pack(FCGI_UnknownTypeBody, @_); } sub parse_unknown_type_body { @_ == 1 || throw(q/Usage: parse_unknown_type_body(octets)/); (defined $_[0] && length $_[0] >= 8) || throw(ERRMSG_OCTETS, q/FCGI_UnknownTypeBody/); return unpack(FCGI_UnknownTypeBody, $_[0]); } # FCGI_BeginRequestRecord sub build_begin_request_record { @_ == 3 || throw(q/Usage: build_begin_request_record(request_id, role, flags)/); my ($request_id, $role, $flags) = @_; return build_record(FCGI_BEGIN_REQUEST, $request_id, build_begin_request_body($role, $flags)); } # FCGI_EndRequestRecord sub build_end_request_record { @_ == 3 || throw(q/Usage: build_end_request_record(request_id, app_status, protocol_status)/); my ($request_id, $app_status, $protocol_status) = @_; return build_record(FCGI_END_REQUEST, $request_id, build_end_request_body($app_status, $protocol_status)); } # FCGI_UnknownTypeRecord sub build_unknown_type_record { @_ == 1 || throw(q/Usage: build_unknown_type_record(type)/); my ($type) = @_; return build_record(FCGI_UNKNOWN_TYPE, FCGI_NULL_REQUEST_ID, build_unknown_type_body($type)); } sub build_record { @_ == 2 || @_ == 3 || throw(q/Usage: build_record(type, request_id [, content])/); my ($type, $request_id) = @_; my $content_length = defined $_[2] ? length $_[2] : 0; my $padding_length = (8 - ($content_length % 8)) % 8; ($content_length <= FCGI_MAX_CONTENT_LEN) || throw(ERRMSG_OCTETS_LE, q/content/, FCGI_MAX_CONTENT_LEN); my $res = build_header($type, $request_id, $content_length, $padding_length); if ($content_length) { $res .= $_[2]; } if ($padding_length) { $res .= "\x00" x $padding_length; } return $res; } sub parse_record { @_ == 1 || throw(q/Usage: parse_record(octets)/); my ($type, $request_id, $content_length) = &parse_header; (length $_[0] >= FCGI_HEADER_LEN + $content_length) || throw(ERRMSG_OCTETS, q/FCGI_Record/); return wantarray ? ($type, $request_id, substr($_[0], FCGI_HEADER_LEN, $content_length)) : parse_record_body($type, $request_id, substr($_[0], FCGI_HEADER_LEN, $content_length)); } sub parse_record_body { @_ == 3 || throw(q/Usage: parse_record_body(type, request_id, content)/); my ($type, $request_id) = @_; my $content_length = defined $_[2] ? length $_[2] : 0; ($content_length <= FCGI_MAX_CONTENT_LEN) || throw(ERRMSG_OCTETS_LE, q/content/, FCGI_MAX_CONTENT_LEN); my %record = (type => $type, request_id => $request_id); if ($type == FCGI_BEGIN_REQUEST) { ($request_id != FCGI_NULL_REQUEST_ID && $content_length == 8) || throw(ERRMSG_MALFORMED, q/FCGI_BeginRequestRecord/); @record{ qw(role flags) } = parse_begin_request_body($_[2]); } elsif ($type == FCGI_ABORT_REQUEST) { ($request_id != FCGI_NULL_REQUEST_ID && $content_length == 0) || throw(ERRMSG_MALFORMED, q/FCGI_AbortRequestRecord/); } elsif ($type == FCGI_END_REQUEST) { ($request_id != FCGI_NULL_REQUEST_ID && $content_length == 8) || throw(ERRMSG_MALFORMED, q/FCGI_EndRequestRecord/); @record{ qw(app_status protocol_status) } = parse_end_request_body($_[2]); } elsif ( $type == FCGI_PARAMS || $type == FCGI_STDIN || $type == FCGI_STDOUT || $type == FCGI_STDERR || $type == FCGI_DATA) { ($request_id != FCGI_NULL_REQUEST_ID) || throw(ERRMSG_MALFORMED, $FCGI_RECORD_NAME[$type]); $record{content} = $content_length ? $_[2] : ''; } elsif ( $type == FCGI_GET_VALUES || $type == FCGI_GET_VALUES_RESULT) { ($request_id == FCGI_NULL_REQUEST_ID) || throw(ERRMSG_MALFORMED, $FCGI_RECORD_NAME[$type]); $record{values} = parse_params($_[2]); } elsif ($type == FCGI_UNKNOWN_TYPE) { ($request_id == FCGI_NULL_REQUEST_ID && $content_length == 8) || throw(ERRMSG_MALFORMED, q/FCGI_UnknownTypeRecord/); $record{unknown_type} = parse_unknown_type_body($_[2]); } else { # unknown record type, pass content so caller can decide appropriate action $record{content} = $_[2] if $content_length; } return \%record; } # Reference implementation use 8192 (libfcgi) sub FCGI_SEGMENT_LEN () { 32768 - FCGI_HEADER_LEN } sub build_stream { @_ == 3 || @_ == 4 || throw(q/Usage: build_stream(type, request_id, content [, terminate])/); my ($type, $request_id, undef, $terminate) = @_; my $len = defined $_[2] ? length $_[2] : 0; my $res = ''; if ($len) { if ($len < FCGI_SEGMENT_LEN) { $res = build_record($type, $request_id, $_[2]); } else { my $header = build_header($type, $request_id, FCGI_SEGMENT_LEN, 0); my $off = 0; while ($len >= FCGI_SEGMENT_LEN) { $res .= $header; $res .= substr($_[2], $off, FCGI_SEGMENT_LEN); $len -= FCGI_SEGMENT_LEN; $off += FCGI_SEGMENT_LEN; } if ($len) { $res .= build_record($type, $request_id, substr($_[2], $off, $len)); } } } if ($terminate) { $res .= build_header($type, $request_id, 0, 0); } return $res; } sub build_params { @_ == 1 || throw(q/Usage: build_params(params)/); my ($params) = @_; my $res = ''; while (my ($key, $val) = each(%$params)) { for ($key, $val) { my $len = defined $_ ? length : 0; $res .= $len < 0x80 ? pack('C', $len) : pack('N', $len | 0x8000_0000); } $res .= $key; $res .= $val if defined $val; } return $res; } sub parse_params { @_ == 1 || throw(q/Usage: parse_params(octets)/); my ($octets) = @_; (defined $octets) || return +{}; my ($params, $klen, $vlen) = ({}, 0, 0); while (length $octets) { for ($klen, $vlen) { (1 <= length $octets) || throw(ERRMSG_OCTETS, q/FCGI_NameValuePair/); $_ = vec(substr($octets, 0, 1, ''), 0, 8); next if $_ < 0x80; (3 <= length $octets) || throw(ERRMSG_OCTETS, q/FCGI_NameValuePair/); $_ = vec(pack('C', $_ & 0x7F) . substr($octets, 0, 3, ''), 0, 32); } ($klen + $vlen <= length $octets) || throw(ERRMSG_OCTETS, q/FCGI_NameValuePair/); my $key = substr($octets, 0, $klen, ''); $params->{$key} = substr($octets, 0, $vlen, ''); } return $params; } sub check_params { @_ == 1 || throw(q/Usage: check_params(octets)/); (defined $_[0]) || return FALSE; my ($len, $off, $klen, $vlen) = (length $_[0], 0, 0, 0); while ($off < $len) { for ($klen, $vlen) { (($off += 1) <= $len) || return FALSE; $_ = vec($_[0], $off - 1, 8); next if $_ < 0x80; (($off += 3) <= $len) || return FALSE; $_ = vec(substr($_[0], $off - 4, 4), 0, 32) & 0x7FFF_FFFF; } (($off += $klen + $vlen) <= $len) || return FALSE; } return TRUE; } sub build_begin_request { (@_ >= 4 && @_ <= 6) || throw(q/Usage: build_begin_request(request_id, role, flags, params [, stdin [, data]])/); my ($request_id, $role, $flags, $params) = @_; my $r = build_begin_request_record($request_id, $role, $flags) . build_stream(FCGI_PARAMS, $request_id, build_params($params), TRUE); if (@_ > 4) { $r .= build_stream(FCGI_STDIN, $request_id, $_[4], TRUE); if (@_ > 5) { $r .= build_stream(FCGI_DATA, $request_id, $_[5], TRUE); } } return $r; } sub build_end_request { (@_ >= 3 && @_ <= 5) || throw(q/Usage: build_end_request(request_id, app_status, protocol_status [, stdout [, stderr]])/); my ($request_id, $app_status, $protocol_status) = @_; my $r; if (@_ > 3) { $r .= build_stream(FCGI_STDOUT, $request_id, $_[3], TRUE); if (@_ > 4) { $r .= build_stream(FCGI_STDERR, $request_id, $_[4], TRUE); } } $r .= build_end_request_record($request_id, $app_status, $protocol_status); return $r; } sub get_record_length { @_ == 1 || throw(q/Usage: get_record_length(octets)/); (defined $_[0] && length $_[0] >= FCGI_HEADER_LEN) || return 0; return FCGI_HEADER_LEN + vec($_[0], 2, 16) # contentLength + vec($_[0], 6, 8); # paddingLength } sub is_known_type { @_ == 1 || throw(q/Usage: is_known_type(type)/); my ($type) = @_; return ($type > 0 && $type <= FCGI_MAXTYPE); } sub is_discrete_type { @_ == 1 || throw(q/Usage: is_discrete_type(type)/); my ($type) = @_; return ( $type == FCGI_BEGIN_REQUEST || $type == FCGI_ABORT_REQUEST || $type == FCGI_END_REQUEST || $type == FCGI_GET_VALUES || $type == FCGI_GET_VALUES_RESULT || $type == FCGI_UNKNOWN_TYPE ); } sub is_management_type { @_ == 1 || throw(q/Usage: is_management_type(type)/); my ($type) = @_; return ( $type == FCGI_GET_VALUES || $type == FCGI_GET_VALUES_RESULT || $type == FCGI_UNKNOWN_TYPE ); } sub is_stream_type { @_ == 1 || throw(q/Usage: is_stream_type(type)/); my ($type) = @_; return ( $type == FCGI_PARAMS || $type == FCGI_STDIN || $type == FCGI_STDOUT || $type == FCGI_STDERR || $type == FCGI_DATA ); } sub get_type_name { @_ == 1 || throw(q/Usage: get_type_name(type)/); my ($type) = @_; return $FCGI_TYPE_NAME[$type] || sprintf('0x%.2X', $type); } sub get_role_name { @_ == 1 || throw(q/Usage: get_role_name(role)/); my ($role) = @_; return $FCGI_ROLE_NAME[$role] || sprintf('0x%.4X', $role); } sub get_protocol_status_name { @_ == 1 || throw(q/Usage: get_protocol_status_name(protocol_status)/); my ($status) = @_; return $FCGI_PROTOCOL_STATUS_NAME[$status] || sprintf('0x%.2X', $status); } 1; Net-FastCGI-0.14/inc/Module/000755 000766 000024 00000000000 12124423015 016155 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/inc/Module/Install/000755 000766 000024 00000000000 12124423015 017563 5ustar00chansenstaff000000 000000 Net-FastCGI-0.14/inc/Module/Install.pm000644 000766 000024 00000030135 12124423011 020117 0ustar00chansenstaff000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Net-FastCGI-0.14/inc/Module/Install/Base.pm000644 000766 000024 00000002147 12124423012 020774 0ustar00chansenstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Net-FastCGI-0.14/inc/Module/Install/Can.pm000644 000766 000024 00000006157 12124423012 020630 0ustar00chansenstaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Net-FastCGI-0.14/inc/Module/Install/Fetch.pm000644 000766 000024 00000004627 12124423012 021160 0ustar00chansenstaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Net-FastCGI-0.14/inc/Module/Install/Makefile.pm000644 000766 000024 00000027437 12124423012 021650 0ustar00chansenstaff000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Net-FastCGI-0.14/inc/Module/Install/Metadata.pm000644 000766 000024 00000043277 12124423012 021653 0ustar00chansenstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Net-FastCGI-0.14/inc/Module/Install/Win32.pm000644 000766 000024 00000003403 12124423012 021020 0ustar00chansenstaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Net-FastCGI-0.14/inc/Module/Install/WriteAll.pm000644 000766 000024 00000002376 12124423012 021651 0ustar00chansenstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Net-FastCGI-0.14/eg/runfcgi.pl000755 000766 000024 00000012723 11741364002 016560 0ustar00chansenstaff000000 000000 #!/usr/bin/perl # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # (C) Paul Evans, 2010 -- leonerd@leonerd.org.uk use strict; use warnings; use Getopt::Long; use Net::FastCGI::IO qw( read_record ); use Net::FastCGI::Constant qw( :common :type :role ); use Net::FastCGI::Protocol qw( build_begin_request_body build_params parse_end_request_body ); sub write_record { Net::FastCGI::IO::write_record(@_) or die "Cannot write_record - $!"; } my %env = ( REQUEST_METHOD => "GET", SCRIPT_NAME => "", SERVER_NAME => "server", SERVER_PORT => 80, SERVER_PROTOCOL => "HTTP/1.1", ); my $stdin_from; my $filter_stdout; sub usage { print <<"EOF"; $0 [options] CONNECT URL Runs the FastCGI found at CONNECT, as if it had received the URL CONNECT may be any of exec:PATH Execute as a child process with socket on STDIN unix:PATH Find a UNIX socket on the given path tcp:HOST:PORT Connect to the given port on the given host HOST:PORT as above options may be: --body Print just the HTTP response body --no-body Print just the HTTP response headers without the body -m, --method METHOD Use the specified method (default "GET") -p, --post Method is POST, pass STDIN --put Method is PUT, pass STDIN --stdin PATH Read STDIN from specified path, "-" means real script EOF } GetOptions( 'body' => sub { defined $filter_stdout and die "Cannot --no-body and --body\n"; $filter_stdout = "body"; }, 'no-body' => sub { defined $filter_stdout and die "Cannot --no-body and --body\n"; $filter_stdout = "headers"; }, 'm|method=s' => \$env{REQUEST_METHOD}, 'p|post' => sub { $env{REQUEST_METHOD} = "POST"; $stdin_from = "-"; }, 'put' => sub { $env{REQUEST_METHOD} = "PUT"; $stdin_from = "-"; }, 'stdin=s' => \$stdin_from, 'help' => sub { usage; exit(0) }, ) or exit(1); my $connect = shift @ARGV or die "Require connection string\n"; my $url = shift @ARGV or die "Require a URL"; if( $url =~ s{^http(s?)://([^/:]+)(?::([^/]+))?}{} ) { $env{HTTPS} = "on" if $1; $env{SERVER_NAME} = $2; $env{SERVER_PORT} = $3 || ( $1 ? 443 : 80 ); } $env{REQUEST_URI} = $url; my ( $path, $query ) = $url =~ m/^(.*)(?:\?(.*))$/; $env{PATH_INFO} = $path; $env{QUERY_STRING} = $query; my $socket; if( $connect =~ m/^unix:(.*)$/ ) { my $path = $1; require IO::Socket::UNIX; $socket = IO::Socket::UNIX->new( Peer => $path, ) or die "Cannot connect - $!\n"; } elsif( $connect =~ m/^exec:(.*)$/ ) { my $script = $1; require IO::Socket::INET; my $listener = IO::Socket::INET->new( LocalHost => "localhost", Listen => 1, ) or die "Cannot listen - $@"; defined( my $kid = fork ) or die "Cannot fork - $!"; END { defined $kid and kill TERM => $kid } if( $kid == 0 ) { close STDIN; open STDIN, "<&", $listener or die "Cannot dup $listener to STDIN - $!"; close $listener; exec { $script } $script or die "Cannot exec $script - $!"; } $socket = IO::Socket::INET->new( PeerHost => $listener->sockhost, PeerPort => $listener->sockport, ) or die "Cannot connect - $@"; close $listener; } elsif( $connect =~ m/^(?:tcp:)?(.*):(.+?)$/ ) { my $host = $1 || "localhost"; my $port = $2; my $class = eval { require IO::Socket::IP and "IO::Socket::IP" } || do { require IO::Socket::INET and "IO::Socket::INET" }; $socket = $class->new( PeerHost => $host, PeerPort => $port, ) or die "Cannot connect - $@\n"; } else { die "Cannot recognise connection string '$connect'\n"; } write_record( $socket, FCGI_BEGIN_REQUEST, 1, build_begin_request_body( FCGI_RESPONDER, 0 ) ); write_record( $socket, FCGI_PARAMS, 1, build_params( \%env ) ); write_record( $socket, FCGI_PARAMS, 1, "" ); if( defined $stdin_from ) { my $stdin; if( $stdin_from eq "-" ) { $stdin = \*STDIN; } else { open $stdin, "<", $stdin_from or die "Cannot open $stdin_from for input - $!"; } while( read( $stdin, my $buffer, 8192 ) ) { write_record( $socket, FCGI_STDIN, 1, $buffer ); } } write_record( $socket, FCGI_STDIN, 1, "" ); my $stdout = ""; while(1) { my ( $type, $id, $content ) = read_record( $socket ) or $! and die "Cannot read_record - $!" or last; if( $type == FCGI_STDOUT ) { if( !defined $filter_stdout ) { print STDOUT $content; } elsif( $filter_stdout eq "headers" ) { my $oldlen = length $stdout; $stdout .= $content; if( $stdout =~ m/\r\n\r\n/ ) { # Print only the bit we haven't done yet print STDOUT substr( $stdout, $oldlen, $+[0] - $oldlen ); $filter_stdout = 1; # I.e. suppress the lot } else { print STDOUT $content; } } elsif( $filter_stdout eq "body" ) { $stdout .= $content; if( $stdout =~ m/\r\n\r\n/ ) { print STDOUT substr( $stdout, $+[0] ); $filter_stdout = undef; } } } elsif( $type == FCGI_STDERR ) { print STDERR $content; } elsif( $type == FCGI_END_REQUEST ) { my ( $app_status, $protocol_status ) = parse_end_request_body( $content ); exit $app_status; } else { die "Unrecognised FastCGI request type $type\n"; } } Net-FastCGI-0.14/eg/server.pl000755 000766 000024 00000012603 11560264550 016434 0ustar00chansenstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use IO::Socket qw[]; use PerlIO::scalar qw[]; use Net::FastCGI::Constant qw[:type :role :flag :protocol_status FCGI_NULL_REQUEST_ID]; use Net::FastCGI::IO qw[read_record write_record write_stream]; use Net::FastCGI::Protocol qw[build_end_request_body build_unknown_type_body build_params parse_begin_request_body parse_params dump_record_body ]; my %FCGI_VALUES = ( FCGI_MAX_CONNS => 1, # maximum number of concurrent transport connections this application will accept FCGI_MAX_REQS => 1, # maximum number of concurrent requests this application will accept FCGI_MPXS_CONNS => 0, # multiplex ); sub handle_connection { my ($socket, $on_request) = @_; my ( $current_id, # id of the request we are currently processing $stdin, # buffer for stdin $stdout, # buffer for stdout $stderr, # buffer for stderr $params, # buffer for params (environ) $keep_conn ); # more requests on this connection? ($current_id, $stdin, $stdout, $stderr, $params) = (0, '', '', '', '', ''); use warnings FATAL => 'Net::FastCGI::IO'; while () { my ($type, $request_id, $content) = read_record($socket) or last; if ($request_id == FCGI_NULL_REQUEST_ID) { if ($type == FCGI_GET_VALUES) { my $values = parse_params($content); my %params = map { $_ => $FCGI_VALUES{$_} } grep { exists $FCGI_VALUES{$_} } keys %{$values}; write_record($socket, FCGI_GET_VALUES_RESULT, FCGI_NULL_REQUEST_ID, build_params(\%params)); } else { write_record($socket, FCGI_UNKNOWN_TYPE, FCGI_NULL_REQUEST_ID, build_unknown_type_body($type)); } } elsif ($type == FCGI_BEGIN_REQUEST) { my ($role, $flags) = parse_begin_request_body($content); if ($current_id || $role != FCGI_RESPONDER) { my $status = $current_id ? FCGI_CANT_MPX_CONN : FCGI_UNKNOWN_ROLE; write_record($socket, FCGI_END_REQUEST, $request_id, build_end_request_body(0, $status)); } else { $current_id = $request_id; $keep_conn = ($flags & FCGI_KEEP_CONN); } } elsif ($request_id != $current_id) { # ignore inactive requests (FastCGI Specification 3.3) } elsif ($type == FCGI_ABORT_REQUEST) { $current_id = 0; ($stdin, $stdout, $stderr, $params) = ('', '', '', ''); } elsif ($type == FCGI_PARAMS) { $params .= $content; } elsif ($type == FCGI_STDIN) { $stdin .= $content; unless (length $content) { # process request open(my $in, '<', \$stdin) || die(qq/Couldn't open scalar as a file handle: $!/); open(my $out, '>', \$stdout) || die(qq/Couldn't open scalar as a file handle: $!/); open(my $err, '>', \$stderr) || die(qq/Couldn't open scalar as a file handle: $!/); my $environ = parse_params($params); eval { $on_request->($environ, $in, $out, $err); }; if (my $e = $@) { warn(qq/Caught an exception in request callback: '$e'/); $stdout = "Status: 500 Internal Server Error\n\n"; } write_stream($socket, FCGI_STDOUT, $current_id, $stdout, 1); write_stream($socket, FCGI_STDERR, $current_id, $stderr, 1) if length $stderr; write_record($socket, FCGI_END_REQUEST, $current_id, build_end_request_body(0, FCGI_REQUEST_COMPLETE)); # prepare for next request $current_id = 0; ($stdin, $stdout, $stderr, $params) = ('', '', '', ''); last unless $keep_conn; } } else { warn(q/Received an unexpected record: / . dump_record_body($type, $request_id, $content)); } } (!$current_id) || warn(q/Client prematurely closed connection/); } sub handle_request { my ($env, $stdin, $stdout, $stderr) = @_; $env->{GATEWAY_INTERFACE} ||= 'CGI/1.1'; local *ENV = $env; local *STDIN = $stdin; local *STDOUT = $stdout; local *STDERR = $stderr; print "Status: 200 OK\n"; print "Content-Type: text/plain\n\n"; print map { sprintf "%-25s => %s\n", $_, $ENV{$_} } sort keys %ENV; } my $addr = shift(@ARGV) || 'localhost:3000'; my $socket = IO::Socket::INET->new( Listen => 5, LocalAddr => $addr, Reuse => 1, ) or die(qq/Couldn't create INET listener socket <$addr>: '$!'./); print STDERR "Listening for connections on <$addr>\n"; while () { my $connection = $socket->accept or last; eval { handle_connection($connection, \&handle_request); }; if (my $e = $@) { warn(qq/Caught an exception in handle_connection(): '$e'/); } close $connection; }