#!/usr/bin/perl
use
FCGI;
use
Socket;
use
POSIX
qw(setsid)
;
require
'syscall.ph'
;
&daemonize
;
END() { } BEGIN() { }
*CORE::GLOBAL::exit
=
sub
{
die
"fakeexit\nrc="
.
shift
().
"\n"
; };
eval
q{exit}
;
if
($@) {
exit
unless
$@ =~ /^fakeexit/;
};
&main
;
sub
daemonize() {
chdir
'/'
or
die
"Can't chdir to /: $!"
;
defined
(
my
$pid
=
fork
) or
die
"Can't fork: $!"
;
exit
if
$pid
;
setsid or
die
"Can't start a new session: $!"
;
umask
0;
}
sub
main {
$socket
= FCGI::OpenSocket(
"/tmp/perl-fastcgi.sock"
, 10 );
$request
= FCGI::Request( \
*STDIN
, \
*STDOUT
, \
*STDERR
, \
%req_params
,
$socket
);
if
(
$request
) { request_loop()};
FCGI::CloseSocket(
$socket
);
}
sub
request_loop {
while
(
$request
->Accept() >= 0 ) {
$stdin_passthrough
=
''
;
$req_len
= 0 +
$req_params
{
'CONTENT_LENGTH'
};
if
((
$req_params
{
'REQUEST_METHOD'
} eq
'POST'
) && (
$req_len
!= 0) ){
my
$bytes_read
= 0;
while
(
$bytes_read
<
$req_len
) {
my
$data
=
''
;
my
$bytes
=
read
(STDIN,
$data
, (
$req_len
-
$bytes_read
));
last
if
(
$bytes
== 0 || !
defined
(
$bytes
));
$stdin_passthrough
.=
$data
;
$bytes_read
+=
$bytes
;
}
}
if
( (-x
$req_params
{SCRIPT_FILENAME}) &&
(-s
$req_params
{SCRIPT_FILENAME}) &&
(-r
$req_params
{SCRIPT_FILENAME})
){
pipe
(CHILD_RD, PARENT_WR);
my
$pid
=
open
(KID_TO_READ,
"-|"
);
unless
(
defined
(
$pid
)) {
print
(
"Content-type: text/plain\r\n\r\n"
);
print
"Error: CGI app returned no output - "
;
print
"Executing $req_params{SCRIPT_FILENAME} failed !\n"
;
next
;
}
if
(
$pid
> 0) {
close
(CHILD_RD);
print
PARENT_WR
$stdin_passthrough
;
close
(PARENT_WR);
while
(
my
$s
= <KID_TO_READ>) {
print
$s
; }
close
KID_TO_READ;
waitpid
(
$pid
, 0);
}
else
{
foreach
$key
(
keys
%req_params
){
$ENV
{
$key
} =
$req_params
{
$key
};
}
if
(
$req_params
{SCRIPT_FILENAME} =~ /^(.*)\/[^\/]+$/) {
chdir
$1;
}
close
(PARENT_WR);
close
(STDIN);
syscall
(
&SYS_dup2
,
fileno
(CHILD_RD), 0);
exec
(
$req_params
{SCRIPT_FILENAME});
die
(
"exec failed"
);
}
}
else
{
print
(
"Content-type: text/plain\r\n\r\n"
);
print
"Error: No such CGI app - $req_params{SCRIPT_FILENAME} may not "
;
print
"exist or is not executable by this process.\n"
;
}
}
}