\n" . "\n" . "\n" . "\n" ); $r->log_reason("Apache::ePerl: $e", $r->filename); } # # helping functions to create time strings # sub ctime { my ($time) = @_; my @dow = ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' ); my @moy = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' ); my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($time); my ($str) = sprintf("%s %s %2d %02d:%02d:%02d %s%s", $dow[$wday], $moy[$mon], $mday, $hour, $min, $sec, $year+1900, $isdst ? " DST" : ""); return $str; } sub isotime { my ($time) = @_; my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($time); my ($str) = sprintf("%02d-%02d-%04d %02d:%02d", $mday, $mon+1, $year+1900, $hour, $min); return $str; } # # the mod_perl handler # sub handler { my ($r) = @_; my ($filename, $data, $error, $fh); my (%env, $rc, $mtime, $owner, $size, $header, $key, $value, $path, $dir, $file, @S); # statistic $nDone++; # create an request object for Apache::Registory-based # scripts like newer CGI.pm versions Apache->request($r); # import filename from Apache API $filename = $r->filename; # check for invalid filename if (-d $filename) { $r->log_reason("Apache::ePerl: Attempt to invoke directory as ePerl script", $filename); return FORBIDDEN; } if (not (-f _ and -s _)) { $r->log_reason("Apache::ePerl: File not exists, not readable or empty", $filename); return NOT_FOUND; } # check if we are allowed to use ePerl if (not ($r->allow_options & OPT_EXECCGI)) { $r->log_reason("Apache::ePerl: Option ExecCGI is off in this directory", $filename); return FORBIDDEN; } # determine script file information @S = stat(_); $size = $S[7]; $mtime = $S[9]; $owner = (getpwuid($S[4]))[0] || 'UNKNOWN'; # check cache for existing P-code if (not ( $Cache->{$filename} and $Cache->{$filename}->{CODE} and $Cache->{$filename}->{SIZE} == $size and $Cache->{$filename}->{MTIME} == $mtime and $Cache->{$filename}->{OWNER} eq $owner)) { # read script local ($/) = undef; $fh = new FileHandle $filename; $data = <$fh>; $fh->close; # run the preprocessor over the script if (not Parse::ePerl::Preprocess({ Script => $data, Cwd => dirname($filename), Result => \$data })) { &send_errorpage($r, 'Error on preprocessing script', ''); $nFail++; return OK; } # translate the script from bristled # ePerl format to plain Perl format if (not Parse::ePerl::Translate({ Script => $data, BeginDelimiter => $Config->{'BeginDelimiter'}, EndDelimiter => $Config->{'EndDelimiter'}, CaseDelimiters => $Config->{'CaseDelimiters'}, ConvertEntities => $Config->{'ConvertEntities'}, Result => \$data })) { &send_errorpage($r, 'Error on translating script from bristled to plain format', ''); $nFail++; return OK; } # precompile the source into P-code $error = ''; if (not Parse::ePerl::Precompile({ Script => $data, Name => $filename, Cwd => dirname($filename), Result => \$data, Error => \$error })) { &send_errorpage($r, 'Error on precompiling script from plain format to P-code', $error); $nFail++; return OK; } # set the new results $Cache->{$filename} = {}; $Cache->{$filename}->{CODE} = $data; $Cache->{$filename}->{SIZE} = $size; $Cache->{$filename}->{MTIME} = $mtime; $Cache->{$filename}->{OWNER} = $owner; } # retrieve precompiled script from cache $data = $Cache->{$filename}->{CODE}; # create runtime environment %env = $r->cgi_env; $env{'VERSION_LANGUAGE'} = "Perl/$]"; $env{'VERSION_INTERPRETER'} = "ePerl/$VERSION"; $path = 'http://'; $path .= $r->server->server_hostname; $path .= sprintf(':%d', $r->server->port) if ($r->server->port != 80); $path .= $r->uri; ($dir, $file) = ($path =~ m|^(.*/)([^/]*)$|); $env{'SCRIPT_SRC_URL'} = $path; $env{'SCRIPT_SRC_URL_DIR'} = $dir; $env{'SCRIPT_SRC_URL_FILE'} = $file; $path = $filename; ($dir, $file) = ($path =~ m|^(.*/)([^/]*)$|); $env{'SCRIPT_SRC_PATH'} = $path; $env{'SCRIPT_SRC_PATH_DIR'} = $dir; $env{'SCRIPT_SRC_PATH_FILE'} = $file; $env{'SCRIPT_SRC_MODIFIED'} = sprintf("%d", $mtime); $env{'SCRIPT_SRC_MODIFIED_CTIME'} = &ctime($mtime); $env{'SCRIPT_SRC_MODIFIED_ISOTIME'} = &isotime($mtime); $env{'SCRIPT_SRC_SIZE'} = sprintf("%d", $size); $env{'SCRIPT_SRC_OWNER'} = $owner; # evaluate script if (not Parse::ePerl::Evaluate({ Script => $data, Name => $filename, Cwd => dirname($filename), ENV => \%env, Result => \$data, Error => \$error })) { &send_errorpage($r, 'Error on evaluating script from P-code', $error); $nFail++; return OK; } # generate headers if ($data =~ m|^([A-Za-z0-9-]+:\s.+?\n\n)(.*)$|s) { ($header, $data) = ($1, $2); $r->content_type('text/html'); $r->cgi_header_out('Content-Length', sprintf("%d", length($data))); while ($header =~ m|^([A-Za-z0-9-]+):\s+(.+?)\n(.*)$|s) { ($key, $value, $header) = ($1, $2, $3); if ($key =~ m|^Content-Type$|i) { $r->content_type($value); } else { $r->cgi_header_out($key, $value); } } } else { $r->content_type('text/html'); $r->cgi_header_out('Content-Length', sprintf("%d", length($data))); } # send resulting page $r->send_http_header; $r->print($data) if (not $r->header_only); # statistic $nOk++; # make Apache API happy ;_) return OK; } # # optional Apache::Status information # Apache::Status->menu_item( 'ePerl' => 'Apache::ePerl status', sub { my ($r, $q) = @_; my (@s, $cs, $cn, $e); push(@s, "Status Information about Apache::ePerlApache::ePerl
\n" . "Version $VERSION\n" . "\n" . "
\n" . "
\n" . "\n" . " \n" . "\n" . "ERROR:\n" . " \n" . "\n" . " \n" . "\n" . " \n" . "$e
\n" . "\n" . "
\n" . "
\n" . "\n" . " \n" . "\n" . "Contents of STDERR channel:\n" . " \n" . "\n" . " \n" . "\n" . " \n" . "$stderr\n" . "
\n"); push(@s, "
| Runtime Statistic | "); push(@s, "|
| Interpreted Documents: | $nDone ($nOk ok, $nFail failed) | "); push(@s, "
| Cached Documents: | $cn ($cs bytes) | \n"); push(@s, "