--- eperl_old.pl 2010-06-19 14:34:39.000000000 +0000
+++ eperl_new.pl 2010-06-19 14:47:55.000000000 +0000
@@ -129,6 +129,9 @@
(If script needs to read stdin, like a post .cgi)
-1, --eval Run in a single process using `eval'
(default for MSWin32 as can't fork)
+ -S, --errorscript=PATH use a custom error script rather than the buit-in default
+ message. Warning: do not use this argument in the error
+ page itself, or you could end up with an infinite loop!
-- Following options are args to the ePerl script
);
@@ -161,14 +164,7 @@
$opt{'perl'} = $^X;
$opt{'CaseDelimiters'} = 1;
- if ($ENV{'PATH_TRANSLATED'}) {
- # We're being called in a CGI environment, so @ARGV contains
- # the search keywords, not the files or options to process
- @files = ($ENV{'PATH_TRANSLATED'});
- # Check for "nph-"
- $opt{'mode'} = basename($ENV{'PATH_TRANSLATED'}) =~ /^nph-/ ? "n" : "c";
- } else {
-
+ @ARGV = split(" ", @ARGV[0]) if $#ARGV == 1; # weird behaviour in shebang: all args passed as only one, so split them here!
while ($#ARGV>=0) {
my $arg=shift(@ARGV);
if ($arg =~ /^-(h|-help)$/) { usage(\%opt); }
@@ -196,6 +192,7 @@
if ($arg =~ /^-(s|-strict)$/) { $opt{'strict'}=1; next; }
if ($arg =~ /^-(t|-tmpfile)$/) { $opt{'tmpfile'}=1; next; }
if ($arg =~ /^-(1|-eval)$/) { $opt{'eval'}=1; next; }
+ if ($arg =~ /^-(S|-errorscript=)(.+)?$/) { $opt{'errorscript'}=arg(); next; }
if ($arg =~ /^-(r|-readme)$/) { readme(); exit(0); }
if ($arg =~ /^-(l|-license)$/) { license(); exit(0); }
@@ -209,18 +206,17 @@
# Mode if not specified
$opt{'mode'} = "f" unless ($opt{'mode'});
$opt{'mode'} = "f" if ($opt{'mode'} =~ /^filter$/i);
- $opt{'mode'} = "c" if ($opt{'mode'} =~ /^cgi$/i);
- $opt{'mode'} = "n" if ($opt{'mode'} =~ /^nph-cgi$/i);
+ $opt{'mode'} = "c" if ($opt{'mode'} =~ /^cgi$/i || $ENV{"SCRIPT_FILENAME"});
+ $opt{'mode'} = "n" if ($opt{'mode'} =~ /^nph-cgi$/i || $ENV{"SCRIPT_SRC_PATH_FILE"} =~ /^nph/i);
# And check for it based on PROGNAME
$opt{'mode'} = "n" if ($PROGNAME =~ /^nph-/i);
- }
-
usage(\%opt,"Unsupported mode: $opt{'mode'}") unless ($opt{'mode'} =~ /^[fcn]$/);
if ($opt{'mode'} ne "f") {
CGI::Carp->import('fatalsToBrowser'); # Output HTML for errors
$opt{'convert-entity'} = 1;
$opt{'preprocess'} = 1;
+ @files = $ENV{"SCRIPT_FILENAME"} if $opt{'mode'} ne "f";
if ($CGI_NEEDS_ALLOWED_FILE_EXT) {
foreach my $file (@files) {
usage(\%opt,"File `$file' is not allowed to be interpreted by ePerl (wrong extension!)",1)
@@ -503,17 +499,24 @@
# Write to a tmpfile, execute that
my $TMPFILE;
+my $TMPERRFILE;
sub start_perl_tmpfile {
my ($opt_H) = @_;
my $file = "$TMPDIR/$PROGNAME.$$";
usage($opt_H,"Tmpfile already exists?? [$file]",1) if (-f $file);
+ my $errfile = "$TMPDIR/$PROGNAME.err.$$";
+ usage($opt_H,"Tmperrfile already exists?? [$errfile]",1) if (-f $errfile);
my $save = umask 077; # Some added safety
$opt_H->{'ph'} = new IO::File;
+ $opt_H->{'pherr'} = new IO::File;
usage($opt_H,"Couldn't create tmpfile [$file]",1)
unless $opt_H->{'ph'}->open(">$file");
+ usage($opt_H,"Couldn't create tmperrfile [$errfile]",1)
+ unless $opt_H->{'pherr'}->open(">$errfile");
$TMPFILE = $file;
+ $TMPERRFILE = $errfile;
umask $save;
$SIG{'INT'}='interrupt';
$SIG{'TERM'}='interrupt';
@@ -521,7 +524,10 @@
$SIG{'SUSP'}='interrupt';
$SIG{'QUIT'}='interrupt';
}
-sub clean_tmpfile { unlink $TMPFILE if $TMPFILE && -f $TMPFILE; }
+sub clean_tmpfile {
+ unlink $TMPFILE if $TMPFILE && -f $TMPFILE;
+ unlink $TMPERRFILE if $TMPERRFILE && -f $TMPERRFILE;
+}
sub interrupt { print STDERR "[$PROGNAME] **INTERRUPT**"; clean_tmpfile(); exit; }
# Just open a normal pipe to a perl process, redirect STDOUT
@@ -797,9 +803,38 @@
# Dangerous race condition here!
usage($opt_H,"Tmpfile disappeared?? [$TMPFILE]",1)
unless $TMPFILE && -r $TMPFILE;
- system("$opt_H->{'perl'} $opt_H->{'perl_opts'} $TMPFILE @ARGV");
+ my $output = `$opt_H->{'perl'} $opt_H->{'perl_opts'} $TMPFILE @ARGV 2>$TMPERRFILE`;
$ret = $?;
+ $opt_H->{'pherr'}->close;
+ my $exit = $ret >> 8;
+ my $int = $ret & 127;
+ my $core = $ret & 128;
+ $exit|=0xffffff00 if $exit>>7;
+ $exit = sprintf("%d",$exit);
+ if ($exit || $int || $core) { # Ok, there was an error!
+ # read-open the error file
+ my $errfile = "$TMPDIR/$PROGNAME.err.$$";
+ usage($opt_H,"Tmperrfile already removed?? [$errfile]",1) unless (-f $errfile);
+ $opt_H->{'pherr'} = new IO::File;
+ $opt_H->{'pherr'}->open("<$errfile");
+ my $error = "";
+ $error .= "[$PROGNAME] Interpretor returned error [$exit]\n" if ($exit);
+ $error .= "[$PROGNAME] **INTERRUPT**\n" if $int;
+ $error .= "[$PROGNAME] (Core dump)\n" if $core;
+ $error .= "$opt_H->{'start_file'} syntax OK\n" if ($opt_H->{'syntax_check'} && !$ret);
+ if ($error && $opt_H->{'mode'} eq "f") {
+ print STDERR $error;
+ } elsif ($error) {
+ redirect_output($opt_H);
+ chomp $error;
+ html_error($opt_H,$error,$opt_H->{'pherr'}->getlines);
+ $opt_H->{'pherr'}->close;
+ }
+ } else {
+ print $output;
+ }
clean_tmpfile();
+ exit($exit); # Exit here directly
} elsif ($opt_H->{'eval'}) {
# eval method
@@ -1139,12 +1174,23 @@
if ($opt_H->{'mode'} eq "n") {
my $proto = $ENV{'SERVER_PROTOCOL'} || "HTTP/1.0";
- print SEND_OUT "$proto 200 OK\n";
+ print SEND_OUT "$proto 500 Internal Server Error\n";
my $server = $ENV{'SERVER_SOFTWARE'} || "unknown-server/0.0";
print SEND_OUT "Server: $server ePerl/$VERSION Perl/$]\n";
print SEND_OUT "Date: ".localtime(time)."\n";
print SEND_OUT "Connection: close\n";
}
+ else {
+ print SEND_OUT "Status: 500\n";
+ }
+ if ($opt_H->{'errorscript'}) {
+ $ENV{'REDIRECT_STATUS'} = 500;
+ $ENV{'REDIRECT_ERROR_NOTES'} = "$error
";
+ $ENV{'REDIRECT_ERROR_NOTES'} = "$error: @err
" if @err;
+ my $errorscript = $opt_H->{'errorscript'};
+ print SEND_OUT `$errorscript`;
+ }
+ else {
print SEND_OUT <