From f834c17bfe033b0d13388a654a7369d7bab9c07f Mon Sep 17 00:00:00 2001 From: Mathieu CARBONNEAUX OSUAGWU Date: Mon, 4 Nov 2024 21:04:15 +0100 Subject: [PATCH] merge of https://github.com/perl-catalyst/FCGI/perl in perl --- perl/.cvsignore | 13 + perl/ChangeLog | 361 ++++++++++++------ perl/FCGI.PL | 571 ---------------------------- perl/FCGI.XL | 629 ------------------------------- perl/FCGI.pm | 265 +++++++++++++ perl/FCGI.xs | 496 ++++++++++++++++++++++++ perl/MANIFEST | 21 +- perl/MANIFEST.SKIP | 15 + perl/Makefile.PL | 203 +++++----- perl/README | 2 +- perl/{echo.PL => eg/echo.pl} | 13 +- perl/{remote.PL => eg/remote.pl} | 9 +- perl/eg/threaded.pl | 48 +++ perl/oldinterface.pod | 50 --- perl/{test.pl => t/01-load.t} | 0 perl/t/02-unix_domain_socket.t | 94 +++++ perl/threaded.PL | 52 --- perl/version.pm | 3 - 18 files changed, 1298 insertions(+), 1547 deletions(-) create mode 100644 perl/.cvsignore delete mode 100644 perl/FCGI.PL delete mode 100644 perl/FCGI.XL create mode 100644 perl/FCGI.pm create mode 100644 perl/FCGI.xs create mode 100644 perl/MANIFEST.SKIP rename perl/{echo.PL => eg/echo.pl} (84%) rename perl/{remote.PL => eg/remote.pl} (85%) create mode 100644 perl/eg/threaded.pl delete mode 100644 perl/oldinterface.pod rename perl/{test.pl => t/01-load.t} (100%) create mode 100644 perl/t/02-unix_domain_socket.t delete mode 100644 perl/threaded.PL delete mode 100644 perl/version.pm diff --git a/perl/.cvsignore b/perl/.cvsignore new file mode 100644 index 0000000..6d7d6ea --- /dev/null +++ b/perl/.cvsignore @@ -0,0 +1,13 @@ +*~ +bak .bak *.bak +blib +*.old +*.fpl +FCGI.c FCGI.bs FCGI.cfg FCGI.def FCGI.pm FCGI.xs +Makefile +pm_to_blib +*.obj *.o +fcgi_config.* fcgi_config_x86.h configure +config.cache config.status config.log + + diff --git a/perl/ChangeLog b/perl/ChangeLog index b9a3f12..fdc301e 100644 --- a/perl/ChangeLog +++ b/perl/ChangeLog @@ -1,97 +1,212 @@ - o Add FILENO method which returns a defined but invalid value to +Release history for FCGI + +Version 0.82 -- 2021-07-31 + + - fix failing skip tests on MSWin32 + +Version 0.81 -- 2021-07-31 + + - Add dependency to FCGI::Client 0.09 so as to not depend on Any::Moose, + which is deprecated. (Michal Josef Špaček, PR #7) + - fix test failures on MSWin32 ((Michal Josef Špaček, PR #8) + +Version 0.80 -- 2021-07-24 + + - Add test for FCGI over unix domain socket (Michal Josef Špaček, PR #6) + +Version 0.79 -- 2019-12-14 + + - Check socket path length in OS_CreateLocalIpcFd() and OS_FcgiConnect() + to avoid buffer overrun (Petr Písař, pull request #5) + - Fix a memory leak in ProcessManagementRecord() (Petr Písař, pull request #4) + +Version 0.78 -- 2015-03-07 + + - make copyright and license information more visible (RT#112535) + +Version 0.77 -- 2014-08-05 + + - re-release to remove build artifacts that should not have been shipped + +Version 0.76 -- 2014-08-05 + + - On Android, set TMPDIR before calling configure (RT#97680, Brian Fraser) + +Version 0.75 -- 2014-07-17 + + - deprecated APIs removed (chansen) + - broken PP implementation removed (chansen) + - retooled distribution so FCGI.pm and FCGI.xs exist as-is, rather than + being generated by FCGI.PL and FCGI.XL (chansen) + +Version 0.74 -- 24 Sep 2011 + - Stop leaking information across requests when using the deprecated + and undocumented old FCGI interface. This is CVE-2011-2766. + - Only discard input stream if FCGI_KEEP_CONN is set in + FCGI_BeginRequestBody flags. + +Version 0.73 -- 19 May 2011 + - Stop claiming we ship a file called -e in the MANIFEST. + +Version 0.72 -- 19 May 2011 + - Clean up Makefile.PL and restore compatibility with recent + ExtUtils::MakeMaker versions. + +Version 0.71_03 -- 28 Apr 2011 + - Remove support for sfio which is an optional (and not enabled by default) + compile option to perl that is never used. + - Fix FCGI::Stream::READ() to warn() instead of croak() incase of + wide characters which cannot be gracefully downgraded. + - Fix warnings due to wide characters being mangled to note that accepting + them is deprecated and will stop working at some point. + - Various fixes to FCGI::Stream::READ() to improve handling of error and + edge cases. + - croak if called with invalid number of arguments + - croak if length is negative + - croak if offset is outside string + - pad scalar if offset is greater than length + - Fix in FCGX_Finish_r to discard any remaining data in input stream + which otherwise ends up in next request. This fixes multiple requests + being broken if something goes wrong whilst reading the initial request. + This discarding is done silently, as RFC 3875 says a script is not + obliged to read any of the data. + - Fixed indent style and braces to be consistent, swapped tabs for spaces + in indenting. + +Version 0.71_02 -- 28 Apr 2011 + - Change the Request function to pass FAIL_ON_INTR into the XS + RequestX function. This prevents the fcgi C client code from + looping around their accept() call. This change means that + when using CGI::Fast, and the process recieves SIGTERM or + SIGHUP, the error statusis correctly passed back up, allowing process + managers (such as FCGI::ProcManager) to correctly handle cleanly exiting. + +Version 0.71_01 -- 24 Aug 2010 + - Restore old behavior when un-downgradeable uft8 is sent to FCGI. + The first time this happens, a warning will be issued, but subsequently + the bytes will be sent through raw (causing double encoding etc). + If the character string can be downgraded safely, then it will still be. + use warnings FATAL => 'utf8'; can be used to make undowngradeable strings + throw an exception. + - Fix PRINT retval (Closes: RT#57697). + +Version 0.71 -- 1 Apr 2010 Florian Ragwitz + - Fix some more defined(%hash) warnings on perl 5.12. + +Version 0.70 -- 22 Mar 2010 Tomas Doran + - Fix use of defined %hash which becomes deprecated in perl 5.12 + +Version 0.69 -- 15 Feb 2010 Matt S Trout + - No changes since the previous development release. + +Version 0.68_02 -- 13 Jan 2010 Matt S Trout + - Make the PRINT method return a boolean value rather than the + number of bytes written, previous patch was incorrect. + +Version 0.68_01 -- 10 Jan 2010 Matt S Trout + - Force signal handler installation so that we correctly install handlers + for SIGPIPE. Fixes RT#5100 + - Make the PRINT method return the number of bytes written rather than + undef to be consistent with the IO:: interface. Fixes RT#24347 + + - Fix UTF-8 double encoding when FCGI is passed octets by downgrading + them into bytes correctly. Fixes RT#52400 + +Version 0.68 -- 31 Dec 2009 Matt S Trout + - No changes since the previous development release. + +Version 0.67_01 -- 20 Dec 2009 Matt S Trout + - Add FILENO method which returns a defined but invalid value to placate things such as IPC::Run which call fileno to check if a filehandle is open. Closes bugs: http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=544540 http://rt.cpan.org/Public/Bug/Display.html?id=50972 - Removes need for upstream patch in OpenBSD + Removes need for upstream patch in OpenBSD + - Call the fcgi lib's attach/detach + +Version 0.67 -- 22 December 2002 Sven Verdoolaege -Version 0.68 -- 21 June 2003 Sven Verdoolaege + - Fixes for pure perl version based on report and patch + from "Kurtis D. Rader" + - FCGI_UndoBinding perl 5.8.0 compatibility + Reported by Marko Asplund + - Fix problem with fcgi_config.h on win32. + Reported by Igor Franchuk + - Add minimal tests - o Call the fcgi lib's attach/detach +Version 0.66 -- 5 September 2002 Sven Verdoolaege -Version 0.67 -- 22 December 2002 Sven Verdoolaege + - perl 5.8.0 compatibility fix by Autrijus + - library fixes from Rob - o Fixes for pure perl version based on report and patch - from "Kurtis D. Rader" - o FCGI_UndoBinding perl 5.8.0 compatibility - Reported by Marko Asplund - o Fix problem with fcgi_config.h on win32. - Reported by Igor Franchuk - o Add minimal tests +Version 0.65 -- 19 February 2002 Sven Verdoolaege -Version 0.66 -- 5 September 2002 Sven Verdoolaege + - fix perl 5.005 compatibility problem + - fix strict warning - o perl 5.8.0 compatibility fix by Autrijus - o library fixes from Rob +Version 0.64 -- 25 September 2001 Sven Verdoolaege +Version 0.63 -- 24 September 2001 Sven Verdoolaege -Version 0.65 -- 19 February 2002 Sven Verdoolaege + - Update build process - o fix perl 5.005 compatibility problem - o fix strict warning +Version 0.62 -- 21 September 2001 Sven Verdoolaege -Version 0.64 -- 25 September 2001 Sven Verdoolaege -Version 0.63 -- 24 September 2001 Sven Verdoolaege + - Move version number to separate file - o Update build process +Version 0.61 -- 20 September 2001 Sven Verdoolaege -Version 0.62 -- 21 September 2001 Sven Verdoolaege + - Fix refcounting bug + - Add GetEnvironment for pure version + - Add LastCall method + - Allow filehandle for Request's socket parameter + - library fixes ("Rob Saccoccio" ) - o Move version number to separate file +Version 0.60 -- 8 July 2001 Sven Verdoolaege -Version 0.61 -- 20 September 2001 Sven Verdoolaege + - Allow specification of purity on command line + (suggested by Rob Brown ) + - Fix bug in pure perl implementation + - Don't try to compile anything on pure perl build + - Add BINMODE method + - Add comment on socket permissions - o Fix refcounting bug - o Add GetEnvironment for pure version - o Add LastCall method - o Allow filehandle for Request's socket parameter - o library fixes ("Rob Saccoccio" ) +Version 0.59 -- 31 December 2000 Sven Verdoolaege -Version 0.60 -- 8 July 2001 Sven Verdoolaege + - preliminary pure perl implementation + - copy win32 configuration file instead of moving it + - convert echo.fpl to new interface - o Allow specification of purity on command line - (suggested by Rob Brown ) - o Fix bug in pure perl implementation - o Don't try to compile anything on pure perl build - o Add BINMODE method - o Add comment on socket permissions +Version 0.58 -- 15 November 2000 Sven Verdoolaege -Version 0.59 -- 31 December 2000 Sven Verdoolaege + - fix bug introduced in 0.57 - o preliminary pure perl implementation - o copy win32 configuration file instead of moving it - o convert echo.fpl to new interface +Version 0.57 -- 12 November 2000 Sven Verdoolaege -Version 0.58 -- 15 November 2000 Sven Verdoolaege + - don't flush unbound request - o fix bug introduced in 0.57 +Version 0.56 -- 3 November 2000 Sven Verdoolaege -Version 0.57 -- 12 November 2000 Sven Verdoolaege + - add example remote.fpl + - provide access to the Request parameters + - add IsFastCGI method + - fix warn handler (Andrew Pimlott ) - o don't flush unbound request +Version 0.55 -- 18 October 2000 Sven Verdoolaege -Version 0.56 -- 3 November 2000 Sven Verdoolaege + - small documentation fix + - compilation issues with older perls fixed + - library initialization when using sockets fixed - o add example remote.fpl - o provide access to the Request parameters - o add IsFastCGI method - o fix warn handler (Andrew Pimlott ) +Version 0.54 -- 8 October 2000 Sven Verdoolaege -Version 0.55 -- 18 October 2000 Sven Verdoolaege + - library fixes ("Rob Saccoccio" ) + - compilation issues with newer gcc + - completely untested OPEN and READLINE methods - o small documentation fix - o compilation issues with older perls fixed - o library initialization when using sockets fixed - -Version 0.54 -- 8 October 2000 Sven Verdoolaege - - o library fixes ("Rob Saccoccio" ) - o compilation issues with newer gcc - o completely untested OPEN and READLINE methods +Version 0.53 -- 10 July 2000 Sven Verdoolaege -Version 0.53 -- 10 July 2000 Sven Verdoolaege - - o sfio version compiles again + - sfio version compiles again Version 0.52 -- 12 April 2000 Sven Verdoolaege @@ -101,141 +216,141 @@ Version 0.50 -- 10 April 2000 Sven Verdoolaege Version 0.49 -- 9 April 2000 Sven Verdoolaege - o General clean-ups - o Allow attaching/detaching - o Changed DESTROY behaviour - o Fixed default warn/die handler of old interface - o Document new interface + - General clean-ups + - Allow attaching/detaching + - Changed DESTROY behaviour + - Fixed default warn/die handler of old interface + - Document new interface Version 0.48 -- 27 August 1999 Sven Verdoolaege - o perl 5.005_60 compatibility - o locking on platforms that need it - o support for remote connections + - perl 5.005_60 compatibility + - locking on platforms that need it + - support for remote connections Version 0.47 -- 31 July 1999 Sven Verdoolaege - o move PRINTF into correct package - o deprecated set_exit_status - o general cleanup, moving old non thread safe interface - from xs to perl + - move PRINTF into correct package + - deprecated set_exit_status + - general cleanup, moving old non thread safe interface + from xs to perl Version 0.46 -- 30 July 1999 Sven Verdoolaege - o new thread safe interface - o new threaded example program + - new thread safe interface + - new threaded example program Version 0.45 -- 8 March 1999 Sven Verdoolaege - o FCGI.pm now part of the devel kit - o library fixes ("Rob Saccoccio" ) - o allow bypassing of installation of handlers - o ActivePerl compatibility (Murray Nesbitt ) + - FCGI.pm now part of the devel kit + - library fixes ("Rob Saccoccio" ) + - allow bypassing of installation of handlers + - ActivePerl compatibility (Murray Nesbitt ) Version 0.43 -- 22 December 1998 Sven Verdoolaege - o POST on bigendians (Paul GABORIT ) - o Some win32 changes (Monty ) - o library fixes ("Rob Saccoccio" ) + - POST on bigendians (Paul GABORIT ) + - Some win32 changes (Monty ) + - library fixes ("Rob Saccoccio" ) Version 0.42 -- 28 August 1998 Sven Verdoolaege - o environ fixes ? - o print NULLs (Ken Alexander ) - o PRINTF support - o set version in FCGI.pm - o library fixes ("Rob Saccoccio" ) + - environ fixes ? + - print NULLs (Ken Alexander ) + - PRINTF support + - set version in FCGI.pm + - library fixes ("Rob Saccoccio" ) Version 0.41 -- 29 July 1998 Sven Verdoolaege - o Compiles with perl 5.005 + - Compiles with perl 5.005 Version 0.40 -- 15 July 1998 Sven Verdoolaege - o Added default die hook - o Minimal documentation + - Added default die hook + - Minimal documentation Version 0.39 -- 3 July 1998 Sven Verdoolaege - o Fixed read bug + - Fixed read bug Version 0.38 -- 28 June 1998 Sven Verdoolaege - o Fixed flush bug - o Added default warn hook + - Fixed flush bug + - Added default warn hook Version 0.37 -- 27 June 1998 Sven Verdoolaege - o More support for tied handles - o Added flush function + - More support for tied handles + - Added flush function Version 0.36 -- 23 June 1998 Sven Verdoolaege - o More support for tied handles (GETC and autoflushing) + - More support for tied handles (GETC and autoflushing) Version 0.35 -- 22 June 1998 Sven Verdoolaege - o Added forgotten typemap + - Added forgotten typemap Version 0.34 -- 17 June 1998 Sven Verdoolaege - - o No longer force sfio less compile - o Update os_unix.c from fcgi2.0b2.1 - o Small documentation changes + + - No longer force sfio less compile + - Update os_unix.c from fcgi2.0b2.1 + - Small documentation changes Version 0.33 -- 16 June 1998 Sven Verdoolaege - o More support for tied handles + - More support for tied handles Version 0.32 -- 16 June 1998 Sven Verdoolaege - o Preliminary support for tied handles (doesn't require sfio) - o Force sfio less compile - o Changed prototype of set_exit_status + - Preliminary support for tied handles (doesn't require sfio) + - Force sfio less compile + - Changed protoype of set_exit_status Version 0.31 -- 13 July 1997 Sven Verdoolaege - o Applied solaris accept patch from - Chip Salzenberg - o Preliminary support glibc's cookie mechanism + - Applied solaris accept patch from + Chip Salzenberg + - Preliminary support glibc's cookie mechanism Version 0.30 -- 24 June 1997 Sven Verdoolaege - o Added forgotten library files + - Added forgotten library files Version 0.29 -- 10 June 1997 Sven Verdoolaege - o Updated library files from fastcgi 2.02b - o Use installed library/include file if found + - Updated library files from fastcgi 2.02b + - Use installed library/include file if found Version 0.28 -- 24 February 1997 Sven Verdoolaege - o Initialization of %ENV did not change environ. Fixed. - Problem reported by Jan Drehmer + - Intialization of %ENV did not change environ. Fixed. + Problem reported by Jan Drehmer Version 0.26 -- 19 February 1997 Sven Verdoolaege - o Flush output when $| is set to eliminate a problem reported - by echo@echo.cica.fr + - Flush output when $| is set to eliminate a problem reported + by echo@echo.cica.fr Version 0.25 -- 13 October 1996 Sven Verdoolaege - o Eliminate some warnings - o Check whether perl is compiled with sfio support + - Eliminate some warnings + - Check whether perl is compiled with sfio support Version 0.25 -- 25 September 1996 Sven Verdoolaege - o First public release - o Additional bugfixes + - First public release + - Additional bugfixes Version 0.21 -- 20 September 1996 Sven Verdoolaege - o Bugfix + - Bugfix Version 0.2 -- 19 September 1996 Sven Verdoolaege - o First Version based on sfio + - First Version based on sfio Version 0.1 -- 12 June 1996 - o Original version from Open Market's FastCGI Developer's Kit + - Original version from Open Market's FastCGI Developer's Kit diff --git a/perl/FCGI.PL b/perl/FCGI.PL deleted file mode 100644 index ccf183c..0000000 --- a/perl/FCGI.PL +++ /dev/null @@ -1,571 +0,0 @@ -use Config; -use ExtUtils::MakeMaker; - -do './FCGI.cfg' or die "no FCGI.cfg"; - -open OUT, ">FCGI.pm"; - -print "Generating FCGI.pm\n"; -print OUT <<'EOP'; -# $Id: FCGI.PL,v 1.37 2002/12/15 20:02:48 skimo Exp $ - -package FCGI; - -require Exporter; -require DynaLoader; - -@ISA = qw(Exporter DynaLoader); -# Items to export into callers namespace by default. Note: do not export -# names by default without a very good reason. Use EXPORT_OK instead. -# Do not simply export all your public functions/methods/constants. -@EXPORT = qw( - -); - -EOP - -print OUT '$VERSION = '.MM->parse_version('version.pm').";\n\n"; - -print OUT "bootstrap FCGI;\n" unless ($pure); - -print OUT <<'EOP' if ($pure); -use Symbol; -use POSIX 'ENOTCONN'; - -use constant VERSION_1 => 1; - -use constant BEGIN_REQUEST => 1; -use constant PARAMS => 4; -use constant FCGI_STDIN => 5; -use constant FCGI_STDOUT => 6; -use constant FCGI_STDERR => 7; - -use constant RESPONDER => 1; -use constant AUTHORIZER => 2; -use constant FILTER => 3; - -%FCGI::rolenames = (RESPONDER, "RESPONDER", - AUTHORIZER, "AUTHORIZER", - FILTER, "FILTER", - ); - -# This only works on Unix; anyone familiar with Windows is welcome -# to give a hand here -sub IsFastCGI { - my ($req) = @_; - $req->{isfastcgi} = - (!defined getpeername shift->{listen_sock}) && $! == ENOTCONN - unless exists $req->{isfastcgi}; - return $req->{isfastcgi}; -} - -sub GetEnvironment { - return shift->{'env'}; -} - -sub read_nv_len { - my ($stream) = @_; - my $buf; - return undef unless read $stream, $buf, 1, 0; - my ($len) = unpack("C", $buf); - if ($len & 0x80) { - $buf = pack("C", $len & 0x7F); - return undef unless read $stream, $buf, 3, 1; - $len = unpack("N", $buf); - } - $len; -} - -sub RequestX { - my $self = { - in => shift, - out => shift, - err => shift, - env => shift, - socket => shift, - flags => shift, - last => 0, - }; - open $self->{listen_sock}, "<&=0"; - bless $self, "FCGI"; -} - -my $run_once = 0; - -sub Accept { - my ($req) = @_; - - unless ($req->IsFastCGI()) { - return -1 if $run_once; - - $run_once = 1; - return 0; - } - $req->Finish(); - $req->{socket} = gensym(); - if ($req->{last} || !accept($req->{socket}, $req->{listen_sock})) { - $req->{error} = "accept"; - return -1; - } - my ($type, $id, $body) = $req->read_record(); - if ($type != BEGIN_REQUEST) { - $req->{error} = "begin request"; - return -1; - } - my ($role, $flags) = unpack("nC", $body); - $req->{role} = $role; - $req->{flags} = $flags; - $req->{id} = $id; - - %{$req->{env}} = (); - $req->{env}{FCGI_ROLE} = $FCGI::rolenames{$req->{role}}; - my $param = FCGI::Stream->new($req, PARAMS); - my ($nlen, $vlen); - while (defined($nlen = read_nv_len($param)) && - defined($vlen = read_nv_len($param))) { - my ($name, $val); - read $param, $name, $nlen; - read $param, $val, $vlen; - $req->{env}{$name} = $val; - } - $req->Bind; - $req->{accepted} = 1; - - return 0; -} - -sub UndoBindings { - my ($req) = @_; - untie ${$req->{in}}; - untie ${$req->{out}}; - untie ${$req->{err}}; - $req->{bound} = 0; -} - -sub Bind { - my ($req) = @_; - tie ${$req->{in}}, 'FCGI::Stream', $req, FCGI_STDIN; - tie ${$req->{out}}, 'FCGI::Stream', $req, FCGI_STDOUT; - tie ${$req->{err}}, 'FCGI::Stream', $req, FCGI_STDERR; - $req->{bound} = 1; -} - -sub Attach { - my ($req) = @_; - $req->Bind() if ($req->{accepted} && !$req->{bound}); -} - -sub Detach { - my ($req) = @_; - $req->UndoBindings() if ($req->{accepted} && $req->{bound}); -} - -sub Finish { - my ($req) = @_; - return unless $req->{accepted}; - if ($req->{bound}) { - $req->UndoBindings(); - # apparently these are harmful - # close ${$req->{out}}; - # close ${$req->{err}}; - } - $req->{accepted} = 0; -} - -sub LastCall { - shift->{last} = 1; -} - -sub DESTROY { - shift->Finish(); -} - -sub read_record { - my ($self) = @_; - my ($header, $body); - - read($self->{socket}, $header, 8); - my ($version, $type, $id, $clen, $plen) = unpack("CCnnC", $header); - read($self->{socket}, $body, $clen+$plen); - $body = undef if $clen == 0; - ($type, $id, $body); -} - -sub read { - my ($self, $rtype, $len) = @_; - while (length $self->{buf} < $len) { - my ($type, $id, $buf) = $self->read_record(); - return undef unless defined $buf; - if ($type != $rtype) { - $self->{error} = "unexpected stream type"; - return 0; - } - $self->{buf} .= $buf; - } - my ($newbuf, $result) = (substr($self->{buf}, $len), - substr($self->{buf}, 0, $len)); - $self->{buf} = $newbuf; - $result; -} - -sub Flush { - my ($req) = @_; -} - -sub write { - my ($self, $type, $content, $len) = @_; - return unless $len > 0; - $self->write_record($type, $content, $len); -} - -sub write_record { - my ($self, $type, $content, $length) = @_; - my $offset = 0; - while ($length > 0) { - my $len = $length > 32*1024 ? 32*1024 : $length; - my $padlen = (8 - ($len % 8)) % 8; - my $templ = "CCnnCxa${len}x$padlen"; - my $data = pack($templ, - VERSION_1, $type, $self->{id}, $len, $padlen, - substr($content, $offset, $len)); - syswrite $self->{socket}, $data; - $length -= $len; - $offset += $len; - } -} - -{ package FCGI::Stream; - -sub new { - my ($class, $src, $type) = @_; - my $handle = do { \local *FH }; - tie($$handle, $class, $src, $type); - $handle; -} - -sub TIEHANDLE { - my ($class, $src, $type) = @_; - bless { src => $src, type => $type }, $class; -} - -sub READ { - my ($stream, undef, $len, $offset) = @_; - my ($ref) = \$_[1]; - my $buf = $stream->{src}->read($stream->{type}, $len); - return undef unless defined $buf; - substr($$ref, $offset, 0, $buf); - length $buf; -} - -sub PRINT { - my ($stream) = shift; - for (@_) { - $stream->{src}->write($stream->{type}, $_, length($_)); - } -} - -sub CLOSE { - my ($stream) = @_; - $stream->{src}->write_record($stream->{type}, undef, 0); -} - -} - -EOP -print OUT while ; -close OUT; -__END__ - -# Preloaded methods go here. - -# Autoload methods go after __END__, and are processed by the autosplit program. - -*FAIL_ACCEPT_ON_INTR = sub() { 1 }; - -sub Request(;***$*$) { - my @defaults = (\*STDIN, \*STDOUT, \*STDERR, \%ENV, 0, 0); - $_[4] = fileno($_[4]) if defined($_[4]) && defined(fileno($_[4])); - splice @defaults,0,@_,@_; - RequestX(@defaults); -} - -sub accept() { - warn "accept called as a method; you probably wanted to call Accept" if @_; - if (defined %FCGI::ENV) { - %ENV = %FCGI::ENV; - } else { - %FCGI::ENV = %ENV; - } - my $rc = Accept($global_request); - for (keys %FCGI::ENV) { - $ENV{$_} = $FCGI::ENV{$_} unless exists $ENV{$_}; - } - - # not SFIO - $SIG{__WARN__} = $warn_handler if (tied (*STDIN)); - $SIG{__DIE__} = $die_handler if (tied (*STDIN)); - - return $rc; -} - -sub finish() { - warn "finish called as a method; you probably wanted to call Finish" if @_; - %ENV = %FCGI::ENV if (defined %FCGI::ENV); - - # not SFIO - if (tied (*STDIN)) { - delete $SIG{__WARN__} if ($SIG{__WARN__} == $warn_handler); - delete $SIG{__DIE__} if ($SIG{__DIE__} == $die_handler); - } - - Finish ($global_request); -} - -sub flush() { - warn "flush called as a method; you probably wanted to call Flush" if @_; - Flush($global_request); -} - -sub detach() { - warn "detach called as a method; you probably wanted to call Detach" if @_; - Detach($global_request); -} - -sub attach() { - warn "attach called as a method; you probably wanted to call Attach" if @_; - Attach($global_request); -} - -# deprecated -sub set_exit_status { -} - -sub start_filter_data() { - StartFilterData($global_request); -} - -$global_request = Request(); -$warn_handler = sub { print STDERR @_ }; -$die_handler = sub { print STDERR @_ unless $^S }; - -package FCGI::Stream; - -sub PRINTF { - shift->PRINT(sprintf(shift, @_)); -} - -sub BINMODE { -} - -sub READLINE { - my $stream = shift; - my ($s, $c); - my $rs = $/ eq '' ? "\n\n" : $/; - my $l = substr $rs, -1; - my $len = length $rs; - - $c = $stream->GETC(); - if ($/ eq '') { - while ($c eq "\n") { - $c = $stream->GETC(); - } - } - while (defined $c) { - $s .= $c; - last if $c eq $l and substr($s, -$len) eq $rs; - $c = $stream->GETC(); - } - $s; -} - -sub OPEN { - $_[0]->CLOSE; - if (@_ == 2) { - return open($_[0], $_[1]); - } else { - my $rc; - eval("$rc = open($_[0], $_[1], $_[2])"); - die $@ if $@; - return $rc; - } -} - -# Some things (e.g. IPC::Run) use fileno to determine if a filehandle is open, -# so we return a defined, but meaningless value. (-1 being the error return -# value from the syscall in c, meaning it can never be a valid fd no) -# Probably a better alternative would be to return the fcgi stream fd. -sub FILENO { -1 } - -1; - -=pod - -=head1 NAME - -FCGI - Fast CGI module - -=head1 SYNOPSIS - - use FCGI; - - my $count = 0; - my $request = FCGI::Request(); - - while($request->Accept() >= 0) { - print("Content-type: text/html\r\n\r\n", ++$count); - } - -=head1 DESCRIPTION - -Functions: - -=over 4 - -=item FCGI::Request - -Creates a request handle. It has the following optional parameters: - -=over 8 - -=item input perl file handle (default: \*STDIN) - -=item output perl file handle (default: \*STDOUT) - -=item error perl file handle (default: \*STDERR) - -These filehandles will be setup to act as input/output/error -on successful Accept. - -=item environment hash reference (default: \%ENV) - -The hash will be populated with the environment. - -=item socket (default: 0) - -Socket to communicate with the server. -Can be the result of the OpenSocket function. -For the moment, it's the file descriptor of the socket -that should be passed. This may change in the future. - -You should only use your own socket if your program -is not started by a process manager such as mod_fastcgi -(except for the FastCgiExternalServer case) or cgi-fcgi. -If you use the option, you have to let your FastCGI -server know which port (and possibly server) your program -is listening on. -See remote.pl for an example. - -=item flags (default: 0) - -Possible values: - -=over 12 - -=item FCGI::FAIL_ACCEPT_ON_INTR - -If set, Accept will fail if interrupted. -It not set, it will just keep on waiting. - -=back - -=back - -Example usage: - my $req = FCGI::Request; - -or: - my %env; - my $in = new IO::Handle; - my $out = new IO::Handle; - my $err = new IO::Handle; - my $req = FCGI::Request($in, $out, $err, \%env); - -=item FCGI::OpenSocket(path, backlog) - -Creates a socket suitable to use as an argument to Request. - -=over 8 - -=item path - -Pathname of socket or colon followed by local tcp port. -Note that some systems take file permissions into account -on Unix domain sockets, so you'll have to make sure that -the server can write to the created file, by changing -the umask before the call and/or changing permissions and/or -group of the file afterwards. - -=item backlog - -Maximum length of the queue of pending connections. -If a connection -request arrives with the queue full the client may receive -an error with an indication of ECONNREFUSED. - -=back - -=item FCGI::CloseSocket(socket) - -Close a socket opened with OpenSocket. - -=item $req->Accept() - -Accepts a connection on $req, attaching the filehandles and -populating the environment hash. -Returns 0 on success. -If a connection has been accepted before, the old -one will be finished first. - -Note that unlike with the old interface, no die and warn -handlers are installed by default. This means that if -you are not running an sfio enabled perl, any warn or -die message will not end up in the server's log by default. -It is advised you set up die and warn handlers yourself. -FCGI.pm contains an example of die and warn handlers. - -=item $req->Finish() - -Finishes accepted connection. -Also detaches filehandles. - -=item $req->Flush() - -Flushes accepted connection. - -=item $req->Detach() - -Temporarily detaches filehandles on an accepted connection. - -=item $req->Attach() - -Re-attaches filehandles on an accepted connection. - -=item $req->LastCall() - -Tells the library not to accept any more requests on this handle. -It should be safe to call this method from signal handlers. - -Note that this method is still experimental and everything -about it, including its name, is subject to change. - -=item $env = $req->GetEnvironment() - -Returns the environment parameter passed to FCGI::Request. - -=item ($in, $out, $err) = $req->GetHandles() - -Returns the file handle parameters passed to FCGI::Request. - -=item $isfcgi = $req->IsFastCGI() - -Returns whether or not the program was run as a FastCGI. - -=back - -=head1 AUTHOR - -Sven Verdoolaege - -=cut - -__END__ diff --git a/perl/FCGI.XL b/perl/FCGI.XL deleted file mode 100644 index 29f5b34..0000000 --- a/perl/FCGI.XL +++ /dev/null @@ -1,629 +0,0 @@ -use Config; - -open OUT, ">FCGI.xs"; - -print "Generating FCGI.xs for Perl version $]\n"; -#unless (exists $Config{apiversion} && $Config{apiversion} >= 5.005) -unless ($] >= 5.005) { - for (qw(sv_undef diehook warnhook in_eval)) { - print OUT "#define PL_$_ $_\n" - } -} -print OUT while ; -close OUT; -__END__ -/* $Id: FCGI.XL,v 1.10 2003/06/22 00:24:11 robs Exp $ */ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include "fcgi_config.h" -#include "fcgiapp.h" -#include "fastcgi.h" - -#ifndef FALSE -#define FALSE (0) -#endif - -#ifndef TRUE -#define TRUE (1) -#endif - -#ifndef dTHX -#define dTHX -#endif - -#ifndef INT2PTR -#define INT2PTR(a,b) ((a) (b)) -#endif - -#ifdef USE_SFIO -typedef struct -{ - Sfdisc_t disc; - FCGX_Stream *stream; -} FCGI_Disc; - -static ssize_t -sffcgiread(f, buf, n, disc) -Sfio_t* f; /* stream involved */ -Void_t* buf; /* buffer to read into */ -size_t n; /* number of bytes to read */ -Sfdisc_t* disc; /* discipline */ -{ - return FCGX_GetStr(buf, n, ((FCGI_Disc *)disc)->stream); -} - -static ssize_t -sffcgiwrite(f, buf, n, disc) -Sfio_t* f; /* stream involved */ -const Void_t* buf; /* buffer to read into */ -size_t n; /* number of bytes to read */ -Sfdisc_t* disc; /* discipline */ -{ - n = FCGX_PutStr(buf, n, ((FCGI_Disc *)disc)->stream); - FCGX_FFlush(((FCGI_Disc *)disc)->stream); - return n; -} - -Sfdisc_t * -sfdcnewfcgi(stream) - FCGX_Stream *stream; -{ - FCGI_Disc* disc; - - New(1000,disc,1,FCGI_Disc); - if (!disc) return (Sfdisc_t *)disc; - - disc->disc.exceptf = (Sfexcept_f)NULL; - disc->disc.seekf = (Sfseek_f)NULL; - disc->disc.readf = sffcgiread; - disc->disc.writef = sffcgiwrite; - disc->stream = stream; - return (Sfdisc_t *)disc; -} - -Sfdisc_t * -sfdcdelfcgi(disc) - Sfdisc_t* disc; -{ - Safefree(disc); - return 0; -} -#endif - -#if defined(USE_LOCKING) && defined(USE_THREADS) -static perl_mutex accept_mutex; -#endif - -typedef struct FCGP_Request { - int accepted; - int bound; - SV* svin; - SV* svout; - SV* sverr; - GV* gv[3]; - HV* hvEnv; - FCGX_Request* requestPtr; -#ifdef USE_SFIO - int sfcreated[3]; - IO* io[3]; -#endif -} FCGP_Request; - -static void FCGI_Finish(FCGP_Request* request); - -static void -FCGI_Flush(FCGP_Request* request) -{ - dTHX; - - if(!request->bound) { - return; - } -#ifdef USE_SFIO - sfsync(IoOFP(GvIOp(request->gv[1]))); - sfsync(IoOFP(GvIOp(request->gv[2]))); -#else - FCGX_FFlush(INT2PTR(FCGX_Stream *, SvIV((SV*) SvRV(request->svout)))); - FCGX_FFlush(INT2PTR(FCGX_Stream *, SvIV((SV*) SvRV(request->sverr)))); -#endif -} - -static void -FCGI_UndoBinding(FCGP_Request* request) -{ - dTHX; - -#ifdef USE_SFIO - sfdcdelfcgi(sfdisc(IoIFP(request->io[0]), SF_POPDISC)); - sfdcdelfcgi(sfdisc(IoOFP(request->io[1]), SF_POPDISC)); - sfdcdelfcgi(sfdisc(IoOFP(request->io[2]), SF_POPDISC)); -#else -# ifdef USE_PERLIO - sv_unmagic((SV *)GvIOp(request->gv[0]), 'q'); - sv_unmagic((SV *)GvIOp(request->gv[1]), 'q'); - sv_unmagic((SV *)GvIOp(request->gv[2]), 'q'); -# else - sv_unmagic((SV *)request->gv[0], 'q'); - sv_unmagic((SV *)request->gv[1], 'q'); - sv_unmagic((SV *)request->gv[2], 'q'); -# endif -#endif - request->bound = FALSE; -} - -static void -FCGI_Bind(FCGP_Request* request) -{ - dTHX; - -#ifdef USE_SFIO - sfdisc(IoIFP(request->io[0]), sfdcnewfcgi(request->requestPtr->in)); - sfdisc(IoOFP(request->io[1]), sfdcnewfcgi(request->requestPtr->out)); - sfdisc(IoOFP(request->io[2]), sfdcnewfcgi(request->requestPtr->err)); -#else -# ifdef USE_PERLIO - /* For tied filehandles, we apply tiedscalar magic to the IO - slot of the GP rather than the GV itself. */ - - if (!GvIOp(request->gv[1])) - GvIOp(request->gv[1]) = newIO(); - if (!GvIOp(request->gv[2])) - GvIOp(request->gv[2]) = newIO(); - if (!GvIOp(request->gv[0])) - GvIOp(request->gv[0]) = newIO(); - - sv_magic((SV *)GvIOp(request->gv[1]), request->svout, 'q', Nullch, 0); - sv_magic((SV *)GvIOp(request->gv[2]), request->sverr, 'q', Nullch, 0); - sv_magic((SV *)GvIOp(request->gv[0]), request->svin, 'q', Nullch, 0); -# else - sv_magic((SV *)request->gv[1], request->svout, 'q', Nullch, 0); - sv_magic((SV *)request->gv[2], request->sverr, 'q', Nullch, 0); - sv_magic((SV *)request->gv[0], request->svin, 'q', Nullch, 0); -# endif -#endif - request->bound = TRUE; -} - -static void -populate_env(envp, hv) -char **envp; -HV *hv; -{ - int i; - char *p, *p1; - SV *sv; - dTHX; - - hv_clear(hv); - for(i = 0; ; i++) { - if((p = envp[i]) == NULL) { - break; - } - p1 = strchr(p, '='); - assert(p1 != NULL); - sv = newSVpv(p1 + 1, 0); - /* call magic for this value ourselves */ - hv_store(hv, p, p1 - p, sv, 0); - SvSETMAGIC(sv); - } -} - -static int -FCGI_IsFastCGI(FCGP_Request* request) -{ - static int isCGI = -1; /* -1: not checked; 0: FCGI; 1: CGI */ - - if (request->requestPtr->listen_sock == FCGI_LISTENSOCK_FILENO) { - if (isCGI == -1) - isCGI = FCGX_IsCGI(); - return !isCGI; - } - - /* A explicit socket is being used -> assume FastCGI */ - return 1; -} - -static int -FCGI_Accept(FCGP_Request* request) -{ - dTHX; - - if (!FCGI_IsFastCGI(request)) { - static int been_here = 0; - - /* - * Not first call to FCGI_Accept and running as CGI means - * application is done. - */ - if (been_here) - return EOF; - - been_here = 1; - } else { -#ifdef USE_SFIO - int i; -#endif - FCGX_Request *fcgx_req = request->requestPtr; - int acceptResult; - - FCGI_Finish(request); -#if defined(USE_LOCKING) && defined(USE_THREADS) - MUTEX_LOCK(&accept_mutex); -#endif - acceptResult = FCGX_Accept_r(fcgx_req); -#if defined(USE_LOCKING) && defined(USE_THREADS) - MUTEX_UNLOCK(&accept_mutex); -#endif - if(acceptResult < 0) { - return acceptResult; - } - - populate_env(fcgx_req->envp, request->hvEnv); - -#ifdef USE_SFIO - for (i = 0; i < 3; ++i) { - request->io[i] = GvIOn(request->gv[i]); - if (!(i == 0 ? IoIFP(request->io[i]) - : IoOFP(request->io[i]))) { - IoIFP(request->io[i]) = sftmp(0); - /*IoIFP(request->io[i]) = sfnew(NULL, NULL, SF_UNBOUND, 0, - SF_STRING | (i ? SF_WRITE : SF_READ));*/ - if (i != 0) - IoOFP(request->io[i]) = IoIFP(request->io[i]); - request->sfcreated[i] = TRUE; - } - } -#else - if (!request->svout) { - newSVrv(request->svout = newSV(0), "FCGI::Stream"); - newSVrv(request->sverr = newSV(0), "FCGI::Stream"); - newSVrv(request->svin = newSV(0), "FCGI::Stream"); - } - sv_setiv(SvRV(request->svout), INT2PTR(IV, fcgx_req->out)); - sv_setiv(SvRV(request->sverr), INT2PTR(IV, fcgx_req->err)); - sv_setiv(SvRV(request->svin), INT2PTR(IV, fcgx_req->in)); -#endif - FCGI_Bind(request); - request->accepted = TRUE; - } - return 0; -} - -static void -FCGI_Finish(FCGP_Request* request) -{ -#ifdef USE_SFIO - int i; -#endif - int was_bound; - dTHX; - - if(!request->accepted) { - return; - } - - if (was_bound = request->bound) { - FCGI_UndoBinding(request); - } -#ifdef USE_SFIO - for (i = 0; i < 3; ++i) { - if (request->sfcreated[i]) { - sfclose(IoIFP(request->io[i])); - IoIFP(request->io[i]) = IoOFP(request->io[i]) = Nullfp; - request->sfcreated[i] = FALSE; - } - } -#endif - if (was_bound) - FCGX_Finish_r(request->requestPtr); - else - FCGX_Free(request->requestPtr, 1); - request->accepted = FALSE; -} - -static int -FCGI_StartFilterData(FCGP_Request* request) -{ - return request->requestPtr->in ? - FCGX_StartFilterData(request->requestPtr->in) : -1; -} - -static FCGP_Request * -FCGI_Request(in, out, err, env, socket, flags) - GV* in; - GV* out; - GV* err; - HV* env; - int socket; - int flags; -{ - FCGX_Request* fcgx_req; - FCGP_Request* req; - - Newz(551, fcgx_req, 1, FCGX_Request); - FCGX_InitRequest(fcgx_req, socket, flags); - Newz(551, req, 1, FCGP_Request); - req->requestPtr = fcgx_req; - SvREFCNT_inc(in); - req->gv[0] = in; - SvREFCNT_inc(out); - req->gv[1] = out; - SvREFCNT_inc(err); - req->gv[2] = err; - SvREFCNT_inc(env); - req->hvEnv = env; - - return req; -} - -static void -FCGI_Release_Request(FCGP_Request *req) -{ - SvREFCNT_dec(req->gv[0]); - SvREFCNT_dec(req->gv[1]); - SvREFCNT_dec(req->gv[2]); - SvREFCNT_dec(req->hvEnv); - FCGI_Finish(req); - Safefree(req->requestPtr); - Safefree(req); -} - -static void -FCGI_Init() -{ -#if defined(USE_LOCKING) && defined(USE_THREADS) - dTHX; - - MUTEX_INIT(&accept_mutex); -#endif - - FCGX_Init(); -} - -typedef FCGX_Stream * FCGI__Stream; -typedef FCGP_Request * FCGI; -typedef GV* GLOBREF; -typedef HV* HASHREF; - -MODULE = FCGI PACKAGE = FCGI PREFIX = FCGI_ - -BOOT: - FCGI_Init(); - -SV * -RequestX(in, out, err, env, socket, flags) - GLOBREF in; - GLOBREF out; - GLOBREF err; - HASHREF env; - int socket; - int flags; - - PROTOTYPE: ***$$$ - CODE: - RETVAL = sv_setref_pv(newSV(0), "FCGI", - FCGI_Request(in, out, err, env, socket, flags)); - - OUTPUT: - RETVAL - -int -OpenSocket(path, backlog) - char* path; - int backlog; - - PROTOTYPE: $$ - CODE: - RETVAL = FCGX_OpenSocket(path, backlog); - OUTPUT: - RETVAL - -void -CloseSocket(socket) - int socket; - - PROTOTYPE: $ - CODE: - close(socket); - -int -FCGI_Accept(request) - - FCGI request; - - PROTOTYPE: $ - -void -FCGI_Finish(request) - FCGI request; - - PROTOTYPE: $ - -void -FCGI_Flush(request) - FCGI request; - - PROTOTYPE: $ - -HV * -GetEnvironment(request) - FCGI request; - - PROTOTYPE: $ - - CODE: - RETVAL = request->hvEnv; - - OUTPUT: - RETVAL - -void -GetHandles(request) - FCGI request; - - PROTOTYPE: $ - - PREINIT: - int i; - - PPCODE: - EXTEND(sp,3); - for (i = 0; i < 3; ++i) - PUSHs(sv_2mortal(newRV((SV *) request->gv[i]))); - -int -FCGI_IsFastCGI(request) - FCGI request; - - PROTOTYPE: $ - -void -Detach(request) - FCGI request; - - PROTOTYPE: $ - - CODE: - if (request->accepted && request->bound) { - FCGI_UndoBinding(request); - FCGX_Detach(request->requestPtr); - } - -void -Attach(request) - FCGI request; - - PROTOTYPE: $ - - CODE: - if (request->accepted && !request->bound) { - FCGI_Bind(request); - FCGX_Attach(request->requestPtr); - } - -void -LastCall(request) - FCGI request; - - PROTOTYPE: $ - - CODE: - FCGX_ShutdownPending(); - -int -FCGI_StartFilterData(request) - - FCGI request; - - PROTOTYPE: $ - -void -DESTROY(request) - FCGI request; - - CODE: - FCGI_Release_Request(request); - - - -MODULE = FCGI PACKAGE = FCGI::Stream - -#ifndef USE_SFIO - -void -PRINT(stream, ...) - FCGI::Stream stream; - - PREINIT: - int n; - - CODE: - for (n = 1; n < items; ++n) { - STRLEN len; - register char *tmps = (char *)SvPV(ST(n),len); - FCGX_PutStr(tmps, len, stream); - } - if (SvTRUEx(perl_get_sv("|", FALSE))) - FCGX_FFlush(stream); - -int -WRITE(stream, bufsv, len, ...) - FCGI::Stream stream; - SV * bufsv; - int len; - - PREINIT: - int offset; - char * buf; - STRLEN blen; - int n; - - CODE: - offset = (items == 4) ? (int)SvIV(ST(3)) : 0; - buf = SvPV(bufsv, blen); - if (offset < 0) offset += blen; - if (len > blen - offset) - len = blen - offset; - if (offset < 0 || offset >= blen || - (n = FCGX_PutStr(buf+offset, len, stream)) < 0) - ST(0) = &PL_sv_undef; - else { - ST(0) = sv_newmortal(); - sv_setpvf(ST(0), "%c", n); - } - -int -READ(stream, bufsv, len, ...) - FCGI::Stream stream; - SV * bufsv; - int len; - - PREINIT: - int offset; - char * buf; - - CODE: - offset = (items == 4) ? (int)SvIV(ST(3)) : 0; - if (! SvOK(bufsv)) - sv_setpvn(bufsv, "", 0); - buf = SvGROW(bufsv, len+offset+1); - len = FCGX_GetStr(buf+offset, len, stream); - SvCUR_set(bufsv, len+offset); - *SvEND(bufsv) = '\0'; - (void)SvPOK_only(bufsv); - SvSETMAGIC(bufsv); - RETVAL = len; - - OUTPUT: - RETVAL - -SV * -GETC(stream) - FCGI::Stream stream; - - PREINIT: - int retval; - - CODE: - if ((retval = FCGX_GetChar(stream)) != -1) { - ST(0) = sv_newmortal(); - sv_setpvf(ST(0), "%c", retval); - } else ST(0) = &PL_sv_undef; - -bool -CLOSE(stream) - FCGI::Stream stream; - -# ALIAS: -# DESTROY = 1 - - CODE: - RETVAL = FCGX_FClose(stream) != -1; - - OUTPUT: - RETVAL - -#endif diff --git a/perl/FCGI.pm b/perl/FCGI.pm new file mode 100644 index 0000000..674a1b0 --- /dev/null +++ b/perl/FCGI.pm @@ -0,0 +1,265 @@ +package FCGI; +use strict; + +BEGIN { + our $VERSION = '0.82'; + + require XSLoader; + XSLoader::load(__PACKAGE__, $VERSION); +} + +sub FAIL_ACCEPT_ON_INTR () { 1 }; + +sub Request(;***$*$) { + my @defaults = (\*STDIN, \*STDOUT, \*STDERR, \%ENV, 0, FAIL_ACCEPT_ON_INTR); + $_[4] = fileno($_[4]) if defined($_[4]) && defined(fileno($_[4])); + splice @defaults,0,@_,@_; + &RequestX(@defaults); +} + +package FCGI::Stream; +use strict; + +sub PRINTF { + shift->PRINT(sprintf(shift, @_)); +} + +sub BINMODE { +} + +sub READLINE { + my $stream = shift; + my ($s, $c); + my $rs = $/ eq '' ? "\n\n" : $/; + my $l = substr $rs, -1; + my $len = length $rs; + + $c = $stream->GETC(); + if ($/ eq '') { + while ($c eq "\n") { + $c = $stream->GETC(); + } + } + while (defined $c) { + $s .= $c; + last if $c eq $l and substr($s, -$len) eq $rs; + $c = $stream->GETC(); + } + $s; +} + +sub OPEN { + require Carp; + Carp::croak(q/Operation 'OPEN' not supported on FCGI::Stream handle/); +} + +sub SEEK { + require Carp; + Carp::croak(q/Operation 'SEEK' not supported on FCGI::Stream handle/); +} + +sub TELL { + require Carp; + Carp::croak(q/Operation 'TELL' not supported on FCGI::Stream handle/); +} + +sub TIEHANDLE { + require Carp; + Carp::croak(q/Operation 'TIEHANDLE' not supported on FCGI::Stream handle/); +} + +1; + +=pod + +=head1 NAME + +FCGI - Fast CGI module + +=head1 SYNOPSIS + + use FCGI; + + my $count = 0; + my $request = FCGI::Request(); + + while($request->Accept() >= 0) { + print("Content-type: text/html\r\n\r\n", ++$count); + } + +=head1 DESCRIPTION + +Functions: + +=over 4 + +=item FCGI::Request + +Creates a request handle. It has the following optional parameters: + +=over 8 + +=item input perl file handle (default: \*STDIN) + +=item output perl file handle (default: \*STDOUT) + +=item error perl file handle (default: \*STDERR) + +These filehandles will be setup to act as input/output/error +on successful Accept. + +=item environment hash reference (default: \%ENV) + +The hash will be populated with the environment. + +=item socket (default: 0) + +Socket to communicate with the server. +Can be the result of the OpenSocket function. +For the moment, it's the file descriptor of the socket +that should be passed. This may change in the future. + +You should only use your own socket if your program +is not started by a process manager such as mod_fastcgi +(except for the FastCgiExternalServer case) or cgi-fcgi. +If you use the option, you have to let your FastCGI +server know which port (and possibly server) your program +is listening on. +See remote.pl for an example. + +=item flags (default: FCGI::FAIL_ACCEPT_ON_INTR) + +Possible values: + +=over 12 + +=item FCGI::FAIL_ACCEPT_ON_INTR + +If set, Accept will fail if interrupted. +It not set, it will just keep on waiting. + +=back + +=back + +Example usage: + my $req = FCGI::Request; + +or: + my %env; + my $in = new IO::Handle; + my $out = new IO::Handle; + my $err = new IO::Handle; + my $req = FCGI::Request($in, $out, $err, \%env); + +=item FCGI::OpenSocket(path, backlog) + +Creates a socket suitable to use as an argument to Request. + +=over 8 + +=item path + +Pathname of socket or colon followed by local tcp port. +Note that some systems take file permissions into account +on Unix domain sockets, so you'll have to make sure that +the server can write to the created file, by changing +the umask before the call and/or changing permissions and/or +group of the file afterwards. + +=item backlog + +Maximum length of the queue of pending connections. +If a connection +request arrives with the queue full the client may receive +an error with an indication of ECONNREFUSED. + +=back + +=item FCGI::CloseSocket(socket) + +Close a socket opened with OpenSocket. + +=item $req->Accept() + +Accepts a connection on $req, attaching the filehandles and +populating the environment hash. +Returns 0 on success. +If a connection has been accepted before, the old +one will be finished first. + +Note that unlike with the old interface, no die and warn +handlers are installed by default. This means that if +you are not running an sfio enabled perl, any warn or +die message will not end up in the server's log by default. +It is advised you set up die and warn handlers yourself. +FCGI.pm contains an example of die and warn handlers. + +=item $req->Finish() + +Finishes accepted connection. +Also detaches filehandles. + +=item $req->Flush() + +Flushes accepted connection. + +=item $req->Detach() + +Temporarily detaches filehandles on an accepted connection. + +=item $req->Attach() + +Re-attaches filehandles on an accepted connection. + +=item $req->LastCall() + +Tells the library not to accept any more requests on this handle. +It should be safe to call this method from signal handlers. + +Note that this method is still experimental and everything +about it, including its name, is subject to change. + +=item $env = $req->GetEnvironment() + +Returns the environment parameter passed to FCGI::Request. + +=item ($in, $out, $err) = $req->GetHandles() + +Returns the file handle parameters passed to FCGI::Request. + +=item $isfcgi = $req->IsFastCGI() + +Returns whether or not the program was run as a FastCGI. + +=back + +=head1 LIMITATIONS + +FCGI.pm isn't Unicode aware, only characters within the range 0x00-0xFF are +supported. Attempts to output strings containing characters above 0xFF results +in a exception: (F) C. + +Users who wants the previous (FCGI.pm <= 0.68) incorrect behavior can disable the +exception by using the C pragma. + + { + use bytes; + print "\x{263A}"; + } + + +=head1 AUTHOR + +Sven Verdoolaege + +=head1 COPYRIGHT AND LICENCE + +This software is copyrighted (c) 1996 by by Open Market, Inc. + +See the LICENSE file in this distribution for information on usage and +redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +=cut + +__END__ diff --git a/perl/FCGI.xs b/perl/FCGI.xs new file mode 100644 index 0000000..3d89dec --- /dev/null +++ b/perl/FCGI.xs @@ -0,0 +1,496 @@ +/* $Id: FCGI.XL,v 1.10 2003/06/22 00:24:11 robs Exp $ */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "fcgi_config.h" +#include "fcgiapp.h" +#include "fastcgi.h" + +#ifndef FALSE +#define FALSE (0) +#endif + +#ifndef TRUE +#define TRUE (1) +#endif + +#ifndef dTHX +#define dTHX +#endif + +#ifndef INT2PTR +#define INT2PTR(a,b) ((a) (b)) +#endif + +/* Deprecation added 2010-10-05. The deprecated functionality should not be + * removed for at least a year after that. */ +#define WIDE_CHAR_DEPRECATION_MSG "Use of wide characters in %s is deprecated" \ + " and will stop working in a future version of FCGI" + +#if defined(USE_ITHREADS) +static perl_mutex accept_mutex; +#endif + +typedef struct FCGP_Request { + int accepted; + int bound; + SV* svin; + SV* svout; + SV* sverr; + GV* gv[3]; + HV* hvEnv; + FCGX_Request* requestPtr; +} FCGP_Request; + +static void FCGI_Finish(FCGP_Request* request); + +static void +FCGI_Flush(FCGP_Request* request) { + dTHX; + if(!request->bound) + return; + FCGX_FFlush(INT2PTR(FCGX_Stream *, SvIV((SV*) SvRV(request->svout)))); + FCGX_FFlush(INT2PTR(FCGX_Stream *, SvIV((SV*) SvRV(request->sverr)))); +} + +static void +FCGI_UndoBinding(FCGP_Request* request) { + dTHX; +#ifdef USE_PERLIO + sv_unmagic((SV *)GvIOp(request->gv[0]), 'q'); + sv_unmagic((SV *)GvIOp(request->gv[1]), 'q'); + sv_unmagic((SV *)GvIOp(request->gv[2]), 'q'); +#else + sv_unmagic((SV *)request->gv[0], 'q'); + sv_unmagic((SV *)request->gv[1], 'q'); + sv_unmagic((SV *)request->gv[2], 'q'); +#endif + request->bound = FALSE; +} + +static void +FCGI_Bind(FCGP_Request* request) { + dTHX; +#ifdef USE_PERLIO + /* For tied filehandles, we apply tiedscalar magic to the IO + slot of the GP rather than the GV itself. */ + + if (!GvIOp(request->gv[1])) + GvIOp(request->gv[1]) = newIO(); + if (!GvIOp(request->gv[2])) + GvIOp(request->gv[2]) = newIO(); + if (!GvIOp(request->gv[0])) + GvIOp(request->gv[0]) = newIO(); + + sv_magic((SV *)GvIOp(request->gv[1]), request->svout, 'q', Nullch, 0); + sv_magic((SV *)GvIOp(request->gv[2]), request->sverr, 'q', Nullch, 0); + sv_magic((SV *)GvIOp(request->gv[0]), request->svin, 'q', Nullch, 0); +#else + sv_magic((SV *)request->gv[1], request->svout, 'q', Nullch, 0); + sv_magic((SV *)request->gv[2], request->sverr, 'q', Nullch, 0); + sv_magic((SV *)request->gv[0], request->svin, 'q', Nullch, 0); +#endif + request->bound = TRUE; +} + +static void +populate_env(char **envp, HV *hv) { + int i; + char *p, *p1; + SV *sv; + dTHX; + + hv_clear(hv); + for(i = 0; ; i++) { + if((p = envp[i]) == NULL) + break; + p1 = strchr(p, '='); + assert(p1 != NULL); + sv = newSVpv(p1 + 1, 0); + /* call magic for this value ourselves */ + hv_store(hv, p, p1 - p, sv, 0); + SvSETMAGIC(sv); + } +} + +static int +FCGI_IsFastCGI(FCGP_Request* request) { + static int isCGI = -1; /* -1: not checked; 0: FCGI; 1: CGI */ + + if (request->requestPtr->listen_sock == FCGI_LISTENSOCK_FILENO) { + if (isCGI == -1) + isCGI = FCGX_IsCGI(); + return !isCGI; + } + + /* A explicit socket is being used -> assume FastCGI */ + return 1; +} + +static int +FCGI_Accept(FCGP_Request* request) { + dTHX; + + if (!FCGI_IsFastCGI(request)) { + static int been_here = 0; + + /* + * Not first call to FCGI_Accept and running as CGI means + * application is done. + */ + if (been_here) + return EOF; + been_here = 1; + } + else { + FCGX_Request *fcgx_req = request->requestPtr; + int acceptResult; + + FCGI_Finish(request); +#if defined(USE_ITHREADS) + MUTEX_LOCK(&accept_mutex); +#endif + acceptResult = FCGX_Accept_r(fcgx_req); +#if defined(USE_ITHREADS) + MUTEX_UNLOCK(&accept_mutex); +#endif + if(acceptResult < 0) { + return acceptResult; + } + + populate_env(fcgx_req->envp, request->hvEnv); + + if (!request->svout) { + newSVrv(request->svout = newSV(0), "FCGI::Stream"); + newSVrv(request->sverr = newSV(0), "FCGI::Stream"); + newSVrv(request->svin = newSV(0), "FCGI::Stream"); + } + sv_setiv(SvRV(request->svout), INT2PTR(IV, fcgx_req->out)); + sv_setiv(SvRV(request->sverr), INT2PTR(IV, fcgx_req->err)); + sv_setiv(SvRV(request->svin), INT2PTR(IV, fcgx_req->in)); + FCGI_Bind(request); + request->accepted = TRUE; + } + return 0; +} + +static void +FCGI_Finish(FCGP_Request* request) { + int was_bound; + dTHX; + + if(!request->accepted) + return; + + if (was_bound = request->bound) + FCGI_UndoBinding(request); + if (was_bound) + FCGX_Finish_r(request->requestPtr); + else + FCGX_Free(request->requestPtr, 1); + request->accepted = FALSE; +} + +static int +FCGI_StartFilterData(FCGP_Request* request) { + return request->requestPtr->in ? + FCGX_StartFilterData(request->requestPtr->in) : -1; +} + +static FCGP_Request * +FCGI_Request(GV *in, GV *out, GV *err, HV *env, int socket, int flags) { + FCGX_Request* fcgx_req; + FCGP_Request* req; + + Newz(551, fcgx_req, 1, FCGX_Request); + FCGX_InitRequest(fcgx_req, socket, flags); + Newz(551, req, 1, FCGP_Request); + req->requestPtr = fcgx_req; + SvREFCNT_inc(in); + req->gv[0] = in; + SvREFCNT_inc(out); + req->gv[1] = out; + SvREFCNT_inc(err); + req->gv[2] = err; + SvREFCNT_inc(env); + req->hvEnv = env; + + return req; +} + +static void +FCGI_Release_Request(FCGP_Request *req) { + SvREFCNT_dec(req->gv[0]); + SvREFCNT_dec(req->gv[1]); + SvREFCNT_dec(req->gv[2]); + SvREFCNT_dec(req->hvEnv); + FCGI_Finish(req); + Safefree(req->requestPtr); + Safefree(req); +} + +static void +FCGI_Init() { +#if defined(USE_ITHREADS) + dTHX; + MUTEX_INIT(&accept_mutex); +#endif + FCGX_Init(); +} + +typedef FCGX_Stream* FCGI__Stream; +typedef FCGP_Request* FCGI; +typedef GV* GLOBREF; +typedef HV* HASHREF; + +MODULE = FCGI PACKAGE = FCGI PREFIX = FCGI_ + +BOOT: + FCGI_Init(); + +SV * +RequestX(in, out, err, env, socket, flags) + GLOBREF in; + GLOBREF out; + GLOBREF err; + HASHREF env; + int socket; + int flags; + PROTOTYPE: ***$$$ + CODE: + RETVAL = sv_setref_pv(newSV(0), "FCGI", + FCGI_Request(in, out, err, env, socket, flags)); + OUTPUT: + RETVAL + +int +OpenSocket(path, backlog) + char* path; + int backlog; + PROTOTYPE: $$ + CODE: + RETVAL = FCGX_OpenSocket(path, backlog); + OUTPUT: + RETVAL + +void +CloseSocket(socket) + int socket; + PROTOTYPE: $ + CODE: + close(socket); + +int +FCGI_Accept(request) + FCGI request; + PROTOTYPE: $ + +void +FCGI_Finish(request) + FCGI request; + PROTOTYPE: $ + +void +FCGI_Flush(request) + FCGI request; + PROTOTYPE: $ + +HV * +GetEnvironment(request) + FCGI request; + PROTOTYPE: $ + CODE: + RETVAL = request->hvEnv; + OUTPUT: + RETVAL + +void +GetHandles(request) + FCGI request; + PROTOTYPE: $ + PREINIT: + int i; + PPCODE: + EXTEND(sp,3); + for (i = 0; i < 3; ++i) + PUSHs(sv_2mortal(newRV((SV *) request->gv[i]))); + +int +FCGI_IsFastCGI(request) + FCGI request; + PROTOTYPE: $ + +void +Detach(request) + FCGI request; + PROTOTYPE: $ + CODE: + if (request->accepted && request->bound) { + FCGI_UndoBinding(request); + FCGX_Detach(request->requestPtr); + } + +void +Attach(request) + FCGI request; + PROTOTYPE: $ + CODE: + if (request->accepted && !request->bound) { + FCGI_Bind(request); + FCGX_Attach(request->requestPtr); + } + +void +LastCall(request) + FCGI request; + PROTOTYPE: $ + CODE: + FCGX_ShutdownPending(); + +int +FCGI_StartFilterData(request) + FCGI request; + PROTOTYPE: $ + +void +DESTROY(request) + FCGI request; + CODE: + FCGI_Release_Request(request); + +MODULE = FCGI PACKAGE = FCGI::Stream + +SV * +PRINT(stream, ...) + FCGI::Stream stream; + PREINIT: + int n; + STRLEN len; + register char *str; + bool ok = TRUE; + CODE: + for (n = 1; ok && n < items; ++n) { +#ifdef DO_UTF8 + if (DO_UTF8(ST(n)) && !sv_utf8_downgrade(ST(n), 1) && ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, WIDE_CHAR_DEPRECATION_MSG, + "FCGI::Stream::PRINT"); +#endif + str = (char *)SvPV(ST(n),len); + if (FCGX_PutStr(str, len, stream) < 0) + ok = FALSE; + } + if (ok && SvTRUEx(perl_get_sv("|", FALSE)) && FCGX_FFlush(stream) < 0) + ok = FALSE; + RETVAL = ok ? &PL_sv_yes : &PL_sv_undef; + OUTPUT: + RETVAL + +int +WRITE(stream, bufsv, len, ...) + FCGI::Stream stream; + SV *bufsv; + int len; + PREINIT: + int offset; + char *buf; + STRLEN blen; + int n; + CODE: + offset = (items == 4) ? (int)SvIV(ST(3)) : 0; +#ifdef DO_UTF8 + if (DO_UTF8(bufsv) && !sv_utf8_downgrade(bufsv, 1) && ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, WIDE_CHAR_DEPRECATION_MSG, + "FCGI::Stream::WRITE"); +#endif + buf = SvPV(bufsv, blen); + if (offset < 0) offset += blen; + if (len > blen - offset) + len = blen - offset; + if (offset < 0 || offset >= blen || + (n = FCGX_PutStr(buf+offset, len, stream)) < 0) + ST(0) = &PL_sv_undef; + else { + ST(0) = sv_newmortal(); + sv_setiv(ST(0), n); + } + +void +READ(stream, bufsv, len, ...) + FCGI::Stream stream; + SV *bufsv; + int len; + PREINIT: + int offset = 0; + char *buf; + STRLEN blen; + CODE: + if (items < 3 || items > 4) + croak("Usage: FCGI::Stream::READ(STREAM, SCALAR, LENGTH [, OFFSET ])"); + if (len < 0) + croak("Negative length"); + if (!SvOK(bufsv)) + sv_setpvn(bufsv, "", 0); +#ifdef DO_UTF8 + if (DO_UTF8(bufsv) && !sv_utf8_downgrade(bufsv, 1) && ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, WIDE_CHAR_DEPRECATION_MSG, + "FCGI::Stream::READ"); +#endif + buf = SvPV_force(bufsv, blen); + if (items == 4) { + offset = SvIV(ST(3)); + if (offset < 0) { + if (-offset > (int)blen) + croak("Offset outside string"); + offset += blen; + } + } + buf = SvGROW(bufsv, len + offset + 1); + if (offset > blen) + Zero(buf + blen, offset - blen, char); + len = FCGX_GetStr(buf + offset, len, stream); + SvCUR_set(bufsv, len + offset); + *SvEND(bufsv) = '\0'; + (void)SvPOK_only(bufsv); + SvSETMAGIC(bufsv); + XSRETURN_IV(len); + +SV * +GETC(stream) + FCGI::Stream stream; + PREINIT: + int retval; + CODE: + if ((retval = FCGX_GetChar(stream)) != -1) { + ST(0) = sv_newmortal(); + sv_setpvf(ST(0), "%c", retval); + } + else + ST(0) = &PL_sv_undef; + +SV * +EOF(stream, called=0) + FCGI::Stream stream; + IV called; + CODE: + RETVAL = boolSV(FCGX_HasSeenEOF(stream)); + OUTPUT: + RETVAL + +void +FILENO(stream) + FCGI::Stream stream; + CODE: + if (FCGX_HasSeenEOF(stream) != 0) + XSRETURN_UNDEF; + else + XSRETURN_IV(-1); + +bool +CLOSE(stream) + FCGI::Stream stream; + CODE: + RETVAL = FCGX_FClose(stream) != -1; + OUTPUT: + RETVAL diff --git a/perl/MANIFEST b/perl/MANIFEST index 07ded82..591b0b3 100644 --- a/perl/MANIFEST +++ b/perl/MANIFEST @@ -1,16 +1,17 @@ ChangeLog -FCGI.PL -FCGI.XL -MANIFEST -Makefile.PL -README configure configure.in configure.readme -echo.PL +eg/echo.pl +eg/remote.pl +eg/threaded.pl +FCGI.pm +FCGI.xs fcgi_config.h.in -remote.PL -test.pl -threaded.PL +Makefile.PL +MANIFEST This list of files +MANIFEST.SKIP +README +t/01-load.t +t/02-unix_domain_socket.t typemap -version.pm diff --git a/perl/MANIFEST.SKIP b/perl/MANIFEST.SKIP new file mode 100644 index 0000000..eacaede --- /dev/null +++ b/perl/MANIFEST.SKIP @@ -0,0 +1,15 @@ +#!include_default +^\. +\.bs$ +\.c$ +\.o$ +^FCGI- +^FCGI\.cfg$ +^aclocal\.m4$ +^autom4te\.cache +^config\. +^config\.log$ +^config\.status$ +^distrib$ +^fcgi_config\.h$ +!^fcgi_config\.h\.in$ diff --git a/perl/Makefile.PL b/perl/Makefile.PL index dfceab4..a389f0c 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -1,64 +1,60 @@ # $Id: Makefile.PL,v 1.33 2002/12/15 19:40:19 skimo Exp $ +use 5.006; use ExtUtils::MakeMaker; use IO::File; use Config; use Cwd 'cwd'; use Getopt::Long; +use File::Copy qw(copy); @h1 = qw(fastcgi.h fcgiapp.h fcgimisc.h fcgios.h); @h = (@h1, 'fcgi_config.h'); @o = qw(FCGI.o); -@dist1 = qw(LICENSE.TERMS); +@dist1 = qw(LICENSE); @dist2 = qw(fcgiapp.c os_unix.c os_win32.c); @dist3 = (@h1, qw(fcgi_config_x86.h)); -GetOptions ("pure-perl!" => \$pure, - "use-installed:s" => \$useinstalled); -$pure = "0" unless defined $pure; -open(CFG,">FCGI.cfg"); -print CFG "\$pure = $pure;1;\n"; -close CFG; +GetOptions ("use-installed:s" => \$useinstalled); $libfound = 0; @libs = (); -if (! $pure) { - my $cwd = cwd(); - my $devkit = "$cwd/.."; - - if (defined $useinstalled) { - require ExtUtils::Liblist; - my $libspec = $useinstalled ? "-L$useinstalled/lib " : ""; - $libspec .= "-lfcgi"; - my @l = MM->ext($libspec); - if ($l[0] || $l[1] || $l[2]) { - $prefix = "$useinstalled/include" if $useinstalled; - $libfound = 1; - push @libs, $libspec; - } +my $cwd = cwd(); +my $devkit = "$cwd/.."; + +if (defined $useinstalled) { + require ExtUtils::Liblist; + my $libspec = $useinstalled ? "-L$useinstalled/lib " : ""; + $libspec .= "-lfcgi"; + my @l = MM->ext($libspec); + if ($l[0] || $l[1] || $l[2]) { + $prefix = "$useinstalled/include" if $useinstalled; + $libfound = 1; + push @libs, $libspec; } - if (!$libfound && -d "$devkit/libfcgi" && -d "$devkit/include") { - # devkit - if (grep { ! -f "$devkit/include/$_" } @dist3 - or grep { ! -f "$devkit/libfcgi/$_" } @dist2) - { - warn "This appears to be a FastCGI devkit distribution, " . - "but one or more FastCGI library files are missing. \n" . - "Please check the integrity of the distribution.\n"; - exit -1; - } - - my $extrarules = join "\n", - map { $b = $_; $b =~ s/\.c$//; my $s="$devkit/libfcgi/$b.c"; - "$b\$(OBJ_EXT): $s\n\t". - '$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) '."$s\n"; } - @dist2; - eval 'package MY; sub postamble { $extrarules; }'; - $prefix = $devkit; +} +if (!$libfound && -d "$devkit/libfcgi" && -d "$devkit/include") { + # devkit + if (grep { ! -f "$devkit/include/$_" } @dist3 + or grep { ! -f "$devkit/libfcgi/$_" } @dist2) + { + warn "This appears to be a FastCGI devkit distribution, " . + "but one or more FastCGI library files are missing. \n" . + "Please check the integrity of the distribution.\n"; + exit -1; } + + my $extrarules = join "\n", + map { $b = $_; $b =~ s/\.c$//; my $s="$devkit/libfcgi/$b.c"; + "$b\$(OBJ_EXT): $s\n\t". + '$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) '."$s\n"; } + @dist2; + eval 'package MY; sub postamble { $extrarules; }'; + $prefix = $devkit; } + $sys = $^O eq 'MSWin32' ? 'win32' : 'unix'; push @o, "fcgiapp.o", "os_$sys.o" unless $libfound; $inc = '-I.' unless $libfound; @@ -70,81 +66,108 @@ push(@extras, CAPI => 'TRUE') push(@extras, ABSTRACT => 'Fast CGI module', - AUTHOR => 'Sven Verdoolaege (skimo@kotnet.org)') - if ($ExtUtils::MakeMaker::VERSION >= 5.4301); - -$plfiles = { 'echo.PL' => 'echo.fpl', - 'remote.PL' => 'remote.fpl', - 'threaded.PL' => 'threaded.fpl', - 'FCGI.PL' => 'FCGI.pm', - }; -$plfiles->{'FCGI.XL'} = 'FCGI.xs' unless $pure; -if ($pure) { - push @extras, - LINKTYPE => ' '; -} else { - - if ("$sys" eq "win32") { - push @libs, ":nosearch -lws2_32"; - push @extras, 'DEFINE' => '-DDLLAPI=__declspec(dllexport)'; - } + AUTHOR => 'Sven Verdoolaege (skimo@kotnet.org)' +) if ($ExtUtils::MakeMaker::VERSION >= 5.4301); + +push @extras, META_MERGE => { + 'meta-spec' => { version => 2 }, + dynamic_config => 0, + resources => { + repository => { + # this is the real repository + # r/w: catagits@git.shadowcat.co.uk:fcgi2.git + # r/o: git://git.shadowcat.co.uk/catagits/fcgi2.git + # web: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits/fcgi2.git + # this is a mirror, but can receive pull requests + url => 'https://github.com/perl-catalyst/FCGI.git', + web => 'https://github.com/perl-catalyst/FCGI', + type => 'git', + }, + bugtracker => { + mailto => 'bug-FCGI@rt.cpan.org', + web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=FCGI', + }, + }, +} if $ExtUtils::MakeMaker::VERSION >= 6.46; - push @extras, - 'LIBS' => [ "@libs" ], - 'OBJECT' => "@o", - 'INC' => $inc; +push(@extras, + MIN_PERL_VERSION => '5.006', +) if $ExtUtils::MakeMaker::VERSION >= 6.48; + +# not strictly necessary as everything is in core... +#push(@extras, +# CONFIGURE_REQUIRES => { +# ... +# }, +#) if $ExtUtils::MakeMaker::VERSION >= 6.51_03; + +if ("$sys" eq "win32") { + push @libs, ":nosearch -lws2_32"; + push @extras, 'DEFINE' => '-DDLLAPI=__declspec(dllexport)'; } - + +push @extras, + 'LIBS' => [ "@libs" ], + 'OBJECT' => "@o", + 'INC' => $inc; + # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. # Work around bug in previous versions of MakeMaker WriteMakefile( - 'NAME' => 'FCGI', - 'VERSION_FROM' => 'version.pm', - 'dist' => { 'COMPRESS' => 'gzip -9f', - 'SUFFIX' => 'gz', - 'PREOP' => '$(CP) '.join(' ', - map {"../$_"} @dist1, - (map {"libfcgi/$_"} @dist2), - map {"include/$_"} @dist3).' $(DISTVNAME);'. - '$(CP) MANIFEST MANIFEST.old;'. - 'echo -e '. join('\\\n',@dist1,@dist2,@dist3) . - '>> $(DISTVNAME)/MANIFEST', - 'POSTOP' => - '$(MV) MANIFEST.old MANIFEST', - }, - 'clean' => { FILES => 'config.cache fcgi_config.h' . - ' FCGI.xs FCGI.c FCGI.cfg ' . - (join ' ', values %$plfiles)}, - 'PL_FILES' => $plfiles, - PM => {'FCGI.pm' => '$(INST_ARCHLIBDIR)/FCGI.pm'}, + 'NAME' => 'FCGI', + 'VERSION_FROM' => 'FCGI.pm', + 'dist' => { + 'COMPRESS' => 'gzip -9f', + 'SUFFIX' => 'gz', + 'PREOP' => '$(CP) '.join(' ', + map {"../$_"} @dist1, + (map {"libfcgi/$_"} @dist2), + map {"include/$_"} @dist3).' $(DISTVNAME);'. + '$(CP) MANIFEST MANIFEST.old;'. + '$(ECHO) '. join('\\\n',@dist1,@dist2,@dist3) . + '>> $(DISTVNAME)/MANIFEST', + 'POSTOP' => + '$(MV) MANIFEST.old MANIFEST', + }, + 'clean' => { FILES => 'config.cache fcgi_config.h fcgi_config.h.in' . + ' FCGI.c aclocal.m4 autom4te.cache config.log config.status' . + ' FCGI.cfg' }, + 'realclean' => { FILES => 'configure MANIFEST.SKIP.bak MANIFEST.bak Makefile.old' }, + PM => {'FCGI.pm' => '$(INST_ARCHLIBDIR)/FCGI.pm'}, + PREREQ_PM => {'XSLoader' => '0'}, + TEST_REQUIRES => { + 'Config' => 0, + 'FCGI::Client' => 0.09, + 'File::Temp' => 0, + 'IO::Socket' => 0, + 'Test::More' => 0, + }, @extras, ); -exit if -f 'fcgi_config.h' or $libfound or $pure; +exit if -f 'fcgi_config.h' or $libfound; # CPAN and no installed lib found if ($sys eq "win32") { # configure will almost certainly not run on a normal NT install, # use the pregenerated configuration file - use File::Copy qw(copy); print "Using prebuilt fcgi_config.h file for Windows\n"; unlink("fcgi_config.h"); my $confdir = $prefix ? "$prefix/include/" : ''; die $! unless copy("${confdir}fcgi_config_x86.h","fcgi_config.h"); - - # Win can't deal with existence of FCGI.xs or absence of FCGI.c - unlink("FCGI.xs"); - open(F, ">FCGI.c"); close(F); - $now = time; $before = $now - 600; - utime $before, $before, "FCGI.c"; - utime $now, $now, "FCGI.PL"; } else { print "Running ./configure for you\n"; print "Please read configure.readme for information on how to run it yourself\n"; $ENV{'CC'} = $Config{'cc'}; + if ( $^O eq 'android' && !$ENV{'TMPDIR'} ) { + # See http://stackoverflow.com/a/15417261 + require File::Spec; + $ENV{'TMPDIR'} = File::Spec->tmpdir(); + } system("$Config{sh} configure"); } + diff --git a/perl/README b/perl/README index 50d96ee..5a428ee 100644 --- a/perl/README +++ b/perl/README @@ -1,7 +1,7 @@ $Id: README,v 1.7 2001/10/04 08:08:34 skimo Exp $ Copyright (c) 1996 Open Market, Inc. - See the file "LICENSE.TERMS" for information on usage and redistribution + See the file "LICENSE" for information on usage and redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. Copyright (c) 1996-1998 Sven Verdoolaege diff --git a/perl/echo.PL b/perl/eg/echo.pl similarity index 84% rename from perl/echo.PL rename to perl/eg/echo.pl index 9f3c928..f4901ff 100644 --- a/perl/echo.PL +++ b/perl/eg/echo.pl @@ -1,24 +1,17 @@ -use Config; +#!/usr/bin/perl -open OUT, ">echo.fpl"; -print OUT "#!$Config{perlpath}\n"; -print OUT while ; -close OUT; -chmod 0755, "echo.fpl"; -__END__ -# # echo-perl -- # # Produce a page containing all FastCGI inputs # # Copyright (c) 1996 Open Market, Inc. # -# See the file "LICENSE.TERMS" for information on usage and redistribution +# See the file "LICENSE" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # $Id: echo.PL,v 1.2 2000/12/14 13:46:23 skimo Exp $ # -# Changed by skimo to demonstrate autoflushing 1997/02/19 +# Changed by skimo to demostrate autoflushing 1997/02/19 # use FCGI; diff --git a/perl/remote.PL b/perl/eg/remote.pl similarity index 85% rename from perl/remote.PL rename to perl/eg/remote.pl index bcfdd7f..5326041 100644 --- a/perl/remote.PL +++ b/perl/eg/remote.pl @@ -1,11 +1,4 @@ -use Config; - -open OUT, ">remote.fpl"; -print OUT "#!$Config{perlpath}\n"; -print OUT while ; -close OUT; -chmod 0755, "remote.fpl"; -__END__ +#!/usr/bin/perl # An example of using a remote script with an Apache webserver. # Run this Perl program on "otherhost" to bind port 8888 and wait # for FCGI requests from the webserver. diff --git a/perl/eg/threaded.pl b/perl/eg/threaded.pl new file mode 100644 index 0000000..639b48f --- /dev/null +++ b/perl/eg/threaded.pl @@ -0,0 +1,48 @@ +#!/usr/bin/perl +use strict; +use warnings; +use threads; +use threads::shared; + +use FCGI qw[]; +use IO::Handle qw[]; + +use constant THREAD_COUNT => 5; + +my @count : shared = (0, (0) x THREAD_COUNT); + +sub worker { + my $k = shift; + my %env; + my $in = IO::Handle->new; + my $out = IO::Handle->new; + my $err = IO::Handle->new; + + my $request = FCGI::Request($in, $out, $err, \%env); + + while ($request->Accept >= 0) { + print $out + "Content-type: text/html\r\n", + "\r\n", + "FastCGI Hello! (multi-threaded perl, fcgiapp library)", + "

FastCGI Hello! (multi-threaded perl, fcgiapp library)

", + "Request counts for ", THREAD_COUNT ," threads ", + "running on host $env{SERVER_NAME}"; + + { + lock(@count); + + ++$count[$k]; + + for(my $i = 1; $i <= THREAD_COUNT; $i++) { + print $out $count[$i]; + print $out " "; + } + } + $request->Flush; + sleep(1); + } +} + +$_->join for map { threads->create(\&worker, $_) } 1..THREAD_COUNT; + diff --git a/perl/oldinterface.pod b/perl/oldinterface.pod deleted file mode 100644 index bb288a1..0000000 --- a/perl/oldinterface.pod +++ /dev/null @@ -1,50 +0,0 @@ -=head1 NAME - -FCGI - Fast CGI module - -=head1 SYNOPSIS - - use FCGI; - - $count = 0; - while(FCGI::accept() >= 0) { - print("Content-type: text/html\r\n\r\n", ++$count); - } - -=head1 DESCRIPTION - -Functions: - -=over 4 - -=item FCGI::accept() - -Accepts a connection. Returns 0 on success. -If a connection has been accepted before, the old -one will be finished first. - -=item FCGI::finish() - -Finishes accepted connection. - -=item FCGI::flush() - -Flushes accepted connection. - -=item FCGI::set_exit_status(status) - -Sets the exit status that finish returns to the server. - -=item FCGI::start_filter_data() - -Does anyone use this function ? - -=back - -=head1 AUTHOR - -Sven Verdoolaege - -=cut - -__END__ diff --git a/perl/test.pl b/perl/t/01-load.t similarity index 100% rename from perl/test.pl rename to perl/t/01-load.t diff --git a/perl/t/02-unix_domain_socket.t b/perl/t/02-unix_domain_socket.t new file mode 100644 index 0000000..69d093b --- /dev/null +++ b/perl/t/02-unix_domain_socket.t @@ -0,0 +1,94 @@ +use strict; +use warnings; + +use Config; +use FCGI; +use FCGI::Client; +use File::Temp qw(tempfile); +use IO::Socket; +use Test::More 0.88; + +my $can_fork = $Config{d_fork} + || ( + ($^O eq 'MSWin32' || $^O eq 'NetWare') + and $Config{useithreads} + and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ + ); +if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bSocket\b/) { + plan skip_all => 'Socket extension unavailable'; +} elsif ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/) { + plan skip_all => 'IO extension unavailable'; +} elsif ($^O eq 'os2') { + eval { IO::Socket::pack_sockaddr_un('/foo/bar') || 1 }; + if ($@ !~ /not implemented/) { + plan skip_all => 'compiled without TCP/IP stack v4'; + } +} elsif ($^O =~ m/^(?:qnx|nto|vos)$/ ) { + plan skip_all => "UNIX domain sockets not implemented on $^O"; +} elsif (! $can_fork) { + plan skip_all => 'no fork'; +} elsif ($^O eq 'MSWin32') { + if ($ENV{CONTINUOUS_INTEGRATION}) { + # https://github.com/Perl/perl5/issues/17429 + plan skip_all => 'Skipping on Windows CI'; + } else { + # https://github.com/Perl/perl5/issues/17575 + if (! eval { socket(my $sock, PF_UNIX, SOCK_STREAM, 0) }) { + plan skip_all => "AF_UNIX unavailable or disabled on this platform" + } + } +} + +my (undef, $unix_socket_file) = tempfile(); +my $fcgi_socket = FCGI::OpenSocket($unix_socket_file, 5); + +# Client +if (my $pid = fork()) { + my $right_ret = <<'END'; +Content-Type: text/plain + +END + + my ($stdout, $stderr) = client_request($unix_socket_file); + is($stdout, $right_ret."0\n", 'Test first round on stdout.'); + is($stderr, undef, 'Test first round on stderr.'); + + ($stdout, $stderr) = client_request($unix_socket_file); + is($stdout, $right_ret."1\n", 'Test second round on stdout.'); + is($stderr, undef, 'Test second round on stderr.'); + +# Server +} elsif (defined $pid) { + my $request = FCGI::Request(\*STDIN, \*STDOUT, \*STDERR, \%ENV, $fcgi_socket); + + # Only two cycles. + my $count = 0; + while ($count < 2 && $request->Accept() >= 0) { + print "Content-Type: text/plain\n\n"; + print $count++."\n"; + } + exit; + +} else { + die $!; +} + +# Cleanup. +FCGI::CloseSocket($fcgi_socket); +unlink $unix_socket_file; + +done_testing; + +sub client_request { + my $unix_socket_file = shift; + + my $sock = IO::Socket::UNIX->new( + Peer => $unix_socket_file, + ) or die $!; + my $client = FCGI::Client::Connection->new(sock => $sock); + my ($stdout, $stderr) = $client->request({ + REQUEST_METHOD => 'GET', + }, ''); + + return ($stdout, $stderr); +} diff --git a/perl/threaded.PL b/perl/threaded.PL deleted file mode 100644 index f8a8c62..0000000 --- a/perl/threaded.PL +++ /dev/null @@ -1,52 +0,0 @@ -use Config; - -open OUT, ">threaded.fpl"; -print OUT "#!$Config{perlpath}\n"; -print OUT while ; -close OUT; -chmod 0755, "threaded.fpl"; -__END__ - -use FCGI; -use Thread; -use IO::Handle; - -use constant THREAD_COUNT => 5; - -sub doit { - my $k = shift; - my %env; - my $in = new IO::Handle; - my $out = new IO::Handle; - my $err = new IO::Handle; - - my $request = FCGI::Request($in, $out, $err, \%env); - - while ($request->Accept() >= 0) { - print $out - "Content-type: text/html\r\n", - "\r\n", - "FastCGI Hello! (multi-threaded perl, fcgiapp library)", - "

FastCGI Hello! (multi-threaded perl, fcgiapp library)

", - "Request counts for ", THREAD_COUNT ," threads ", - "running on host $env{SERVER_NAME}

"; - - { - lock(@count); - - ++$count[$k]; - - for(my $i = 0; $i < THREAD_COUNT; ++$i) { - print $out $count[$i]; - print $out " "; - } - } - $request->Flush(); - sleep(1); - } -} - -for ($t = 1; $t < THREAD_COUNT; ++$t) { - new Thread \&doit, $t; -} -doit(0); diff --git a/perl/version.pm b/perl/version.pm deleted file mode 100644 index 1f2ec8d..0000000 --- a/perl/version.pm +++ /dev/null @@ -1,3 +0,0 @@ -package FCGI; - -$VERSION = '0.67';