#!/usr/local/bin/perl
main: {
$| = 1;
$SIG
{__WARN__} = \
&catch_warnings
;
$SIG
{__DIE__} =
undef
;
$ENV
{REQUEST_METHOD} =
"GET"
;
$ENV
{QUERY_STRING} =
"foo=1"
;
perlcheck_loop();
}
sub
perlcheck_loop {
writelog (
"started"
);
my
$first
= 1;
while
( 1 ) {
writelog (
"waiting on input..."
);
my
$what
= <STDIN>;
chomp
$what
;
writelog (
"got what='$what'"
);
last
if
$what
eq
''
;
if
(
$what
!~ /^(check|execute)/ ) {
print
STDERR
"unknown action: $what\n"
;
last
;
}
my
$execute_dir
= <STDIN>;
chomp
$execute_dir
;
writelog (
"got execute_dir='$execute_dir'"
);
last
if
$execute_dir
eq
''
;
my
$add_lib_dirs
= <STDIN>;
chomp
$add_lib_dirs
;
writelog (
"got add_lib_dirs=$add_lib_dirs"
);
my
$temp_dir
= <STDIN>;
chomp
$temp_dir
;
writelog (
"got temp_dir=$temp_dir"
);
last
if
$temp_dir
eq
''
;
my
$config_dir
= <STDIN>;
chomp
$config_dir
;
writelog (
"got config_dir=$config_dir"
);
my
$delimiter
= <STDIN>;
chomp
$delimiter
;
writelog (
"got delimiter=$delimiter"
);
last
if
$delimiter
eq
''
;
my
$perl_code
;
perlcode:
while
(<STDIN>) {
chomp
;
last
perlcode
if
$_
eq
$delimiter
;
$perl_code
.=
"$_\n"
;
}
my
$error
;
my
@OLD_INC
=
@INC
;
unshift
@INC
,
split
(
":"
,
$add_lib_dirs
);
if
(
$what
eq
'check'
) {
$error
= perlcheck (
$execute_dir
,
$temp_dir
,
\
$perl_code
);
}
else
{
my
(
$filename
) =
$what
=~ /^execute\s+(.*)/;
$error
= perlexecute (
$filename
,
$execute_dir
,
$temp_dir
,
$config_dir
,
\
$perl_code
);
}
@INC
=
@OLD_INC
;
my
$delimiter
=
"__PERLCHECK_REQUEST_FINISHED__"
;
while
(
$error
=~ /
$delimiter
/ ) {
$delimiter
.= $$;
}
print
"$delimiter\n"
;
writelog(
"print error: $error"
);
if
(
$error
) {
print
"$error\n"
;
}
print
"$delimiter\n"
;
$first
= 0;
}
writelog(
"leaving perlcheck_loop"
);
}
sub
perlcheck {
my
(
$dir
,
$temp_dir
,
$perl_sref
) =
@_
;
my
$cwd_dir
= cwd();
if
(
$dir
) {
chdir
$dir
or
return
"Can't chdir to '$dir'"
;
$0 =
"$dir/cipp_perlcheck.cgi"
;
}
$CIPP_Exec::_cipp_in_execute
= 1;
$CIPP_Exec::_cipp_no_http
= 1;
$$perl_sref
=~ s/BEGIN//gs;
$$perl_sref
=~ s/END//gs;
writelog (
$$perl_sref
);
my
$error
= eval_perl_code (
$perl_sref
);
chdir
$cwd_dir
;
return
$error
;
}
sub
perlexecute {
my
(
$catch_file
,
$dir
,
$temp_dir
,
$config_dir
,
$perl_sref
) =
@_
;
writelog (
"perlexecute request started"
);
writelog (
"cd $dir"
);
my
$cwd_dir
= cwd();
if
(
$dir
) {
chdir
$dir
or
return
"Can't chdir to '$dir'"
;
$0 =
"$dir/cipp_perlcheck.cgi"
;
}
writelog (
"save STDOUT"
);
if
( !
open
(SAVESTDOUT,
">&STDOUT"
) ) {
writelog (
"error duping STDOUT"
);
chdir
$cwd_dir
;
return
"can't dup STDOUT"
;
}
writelog (
"close STDOUT"
);
close
STDOUT;
writelog (
"open STDOUT > $catch_file"
);
if
( !
open
(STDOUT,
"> $catch_file"
) ) {
open
(STDOUT,
">&SAVESTDOUT"
);
close
SAVESTDOUT;
chdir
$cwd_dir
;
return
"Can't write '$catch_file'"
;
}
$CIPP_Exec::_cipp_in_execute
= 1;
$CIPP_Exec::_cipp_no_http
= 1;
$$perl_sref
=~ s/BEGIN//gs;
$$perl_sref
=~ s/END//gs;
writelog (
"execute perl code: $0"
);
writelog (
"perl code: "
.
$$perl_sref
);
$CIPP::Runtime::NewSpirit::CONFIG_DIR
=
$config_dir
if
$config_dir
;
writelog (
"config dir: $config_dir"
);
my
$error
= exec_perl_code (
$perl_sref
);
$CIPP::Runtime::NewSpirit::CONFIG_DIR
=
undef
;
writelog (
"cd $cwd_dir"
);
chdir
$cwd_dir
;
writelog (
"restore STDOUT"
);
close
STDOUT;
open
(STDOUT,
">&SAVESTDOUT"
)
or crash(
"Can't restore STDOUT"
);
close
SAVESTDOUT;
writelog (
"request finished"
);
return
$error
;
}
sub
crash {
my
(
$msg
) =
@_
;
writelog (
$msg
);
exit
1;
}
sub
writelog {
my
(
$msg
) =
@_
;
return
if
not -f
"/tmp/do.the.cipp3debug"
;
my
$date
=
scalar
(
localtime
(
time
));
open
(LOG,
">> /tmp/perlcheck.log"
);
select
LOG; $| = 1;
select
STDOUT;
print
LOG
"-"
x 80,
"\n"
;
print
LOG
"cipp_perlcheck.pl: $date $$\t$msg\n"
;
close
LOG;
1;
}
{
my
$__CATCHED__WARNINGS__
;
sub
eval_perl_code {
my
(
$__PERL_CODE_SREF__
) =
@_
;
eval
{
local
$SIG
{ALRM} =
sub
{
die
"CIPP-TIMEOUT"
};
alarm
10;
$__CATCHED__WARNINGS__
=
''
;
no
strict;
eval
"return; "
.
$$__PERL_CODE_SREF__
;
alarm
0;
$__CATCHED__WARNINGS__
.= $@
if
$@ !~ /CIPP-TIMEOUT/;
};
return
$__CATCHED__WARNINGS__
;
}
sub
exec_perl_code {
my
(
$__PERL_CODE_SREF__
) =
@_
;
eval
{
local
$SIG
{ALRM} =
sub
{
die
"CIPP-TIMEOUT"
};
alarm
20;
$__CATCHED__WARNINGS__
=
''
;
no
strict;
eval
$$__PERL_CODE_SREF__
;
alarm
0;
$__CATCHED__WARNINGS__
.= $@
if
$@ !~ /CIPP-TIMEOUT/;
};
return
$__CATCHED__WARNINGS__
;
}
sub
catch_warnings {
$__CATCHED__WARNINGS__
.=
$_
[0];
}
}