view release on metacpan or  search on metacpan

mod/Apache/ePerl.pm  view on Meta::CPAN

#
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 19%s%s",
                        $dow[$wday], $moy[$mon], $mday, $hour, $min, $sec, $year,
                        $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-19%02d %02d:%02d",
                        $mday, $mon+1, $year, $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;
    }