/usr/share/perl5/Apache/ePerl.pm

##        ____           _ 
##    ___|  _ \ ___ _ __| |
##   / _ \ |_) / _ \ '__| |
##  |  __/  __/  __/ |  | |
##   \___|_|   \___|_|  |_|
## 
##  ePerl -- Embedded Perl 5 Language
##
##  ePerl interprets an ASCII file bristled with Perl 5 program statements
##  by evaluating the Perl 5 code while passing through the plain ASCII
##  data. It can operate both as a standard Unix filter for general file
##  generation tasks and as a powerful Webserver scripting language for
##  dynamic HTML page programming. 
##
##  ======================================================================
##
##  Copyright (c) 1996,1997 Ralf S. Engelschall, All rights reserved.
##
##  This program is free software; it may be redistributed and/or modified
##  only under the terms of either the Artistic License or the GNU General
##  Public License, which may be found in the ePerl source distribution.
##  Look at the files ARTISTIC and COPYING or run ``eperl -l'' to receive
##  a built-in copy of both license files.
##
##  This program is distributed in the hope that it will be useful, but
##  WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either the
##  Artistic License or the GNU General Public License for more details.
##
##  ======================================================================
##
##  ePerl.pm -- Fast emulated Embedded Perl (ePerl) facility
##

package Apache::ePerl;


#   requirements and runtime behaviour
require 5.00325;
use strict;
use vars qw($VERSION);
use vars qw($nDone $nOk $nFail $Cache $Config);

#   imports
use Carp;
use Apache ();
use Apache::Debug;
use Apache::Constants qw(:common OPT_EXECCGI);
use FileHandle ();
use File::Basename qw(dirname);
use Parse::ePerl;

#   private version number
$VERSION = do { my @v=("2.2.14"=~/\d+/g); sprintf "%d."."%02d"x$#v,@v }; 

#   globals
$nDone  = 0;
$nOk    = 0;
$nFail  = 0;
$Cache  = {};

#   configuration
$Config = {
    'BeginDelimiter'  => '<?',
    'EndDelimiter'    => '!>',
    'CaseDelimiters'  => 0,
    'ConvertEntities' => 1
};

#
#   send HTML error page
#
sub send_errorpage {
    my ($r, $e, $stderr) = @_;

    $r->content_type('text/html');
    $r->send_http_header;
    $r->print(
        "<html>\n" .
        "<head>\n" .
        "<title>Apache::ePerl: Error</title>\n" .
        "</head>\n" .
        "<body bgcolor=\"#d0d0d0\">\n" .
        "<blockquote>\n" .
        "<h1>Apache::ePerl</h1>\n" .
        "<b>Version $VERSION</b>\n" .
        "<p>\n" .
        "<table bgcolor=\"#d0d0f0\" cellspacing=0 cellpadding=10 border=0>\n" .
        "<tr>\n" .
        "<td bgcolor=\"#b0b0d0\">\n" .
        "<font face=\"Arial, Helvetica\"><b>ERROR:</b></font>\n" .
        "</td>\n" .
        "</tr>\n" .
        "<tr>\n" .
        "<td>\n" .
        "<h2><font color=\"#3333cc\">$e</font></h2>\n" .
        "</td>\n" .
        "</tr>\n" .
        "</table>\n" .
        "<p>\n" .
        "<table bgcolor=\"#e0e0e0\" cellspacing=0 cellpadding=10 border=0>\n" .
        "<tr>\n" . 
        "<td bgcolor=\"#c0c0c0\">\n" .
        "<font face=\"Arial, Helvetica\"><b>Contents of STDERR channel:</b></font>\n" .
        "</td>\n" .
        "</tr>\n" .
        "<tr>\n" . 
        "<td>\n" .
        "<pre>$stderr</pre>\n" .
        "</td>\n" . 
        "</tr>\n" .
        "</table>\n" .
        "</blockquote>\n" .
        "</body>\n" .
        "</html>\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';

    my $uri = $r->uri;
    # turn into a package name, borrowed from great Apache::Registry
    $r->log_error(sprintf "Apache::ePerl::handler examining %s",
              $uri) if $Debug;
    my $path_info = $r->path_info;
    my $script_name = $path_info && $uri =~ /\Q$path_info\E$/ ?
        substr($uri, 0, length($uri)-length($path_info)) :
        $uri;

    $script_name =~ s:/+$:/__INDEX__:;

    if ($Apache::ePerl::NameWithVirtualHost && $r->server->is_virtual) {
        my $name = $r->get_server_name;
        $script_name = join "", $name, $script_name if $name;
    }

    # Escape everything into valid perl identifiers
    $script_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;

    # second pass cares for slashes and words starting with a digit
    $script_name =~ s{
              (/+)       # directory
              (\d?)      # package's first character
             }[
               "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
              ]egx;

    my $package = "Apache::EPERLCACHE$script_name";
    $r->log_error("Apache::ePerl::handler package $package")
       if $Debug;

    #   check cache for existing P-code
    if (not (    $Cache->{$package}
             and $Cache->{$package}->{CODE}
             and $Cache->{$package}->{SIZE}  == $size
             and $Cache->{$package}->{MTIME} == $mtime
             and $Cache->{$package}->{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;
        }

        $data = join(
                '',
                'package ',
                $package,
                ';use Apache qw(exit);',
                $data
               );

        #   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->{$package} = {};
        $Cache->{$package}->{CODE}  = $data;
        $Cache->{$package}->{SIZE}  = $size;
        $Cache->{$package}->{MTIME} = $mtime;
        $Cache->{$package}->{OWNER} = $owner;
    }
  
    #   retrieve precompiled script from cache
    $data = $Cache->{$package}->{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, "<b>Status Information about Apache::ePerl</b><br>");
        push(@s, "Versions: Apache::ePerl <b>$VERSION</b>, Parse::ePerl <b>$Parse::ePerl::VERSION</b>");
        push(@s, "<p>\n");
        push(@s, "<table cellspacing=0 cellpadding=4 border=1>\n");
        push(@s, "<tr>\n");
        push(@s, "<td align=center bgcolor=\"#ccccff\" colspan=2><b>Runtime Statistic</b></td>");
        push(@s, "</tr>\n");
        push(@s, "<tr>\n");
        push(@s, "<td align=right>Interpreted Documents:</td> <td><b>$nDone</b> (<b>$nOk</b> ok, <b>$nFail</b> failed)</td>");
        push(@s, "</tr>\n");
        $cs = 0;
        $cn = 0;
        foreach $e (keys(%{$Cache})) {
            $cn += 1;
            $cs += $Cache->{$e}->{SIZE};
        }
        push(@s, "<tr>\n");
        push(@s, "<td align=right>Cached Documents:</td> <td><b>$cn</b> (<b>$cs</b> bytes)</td>\n");
        push(@s, "</tr>\n");
        push(@s, "</table>\n");
        return \@s;
    }
) if Apache->module('Apache::Status');


#   sometimes Perl wants it...
sub DESTROY { };


1;
##EOF##
__END__

=head1 NAME

Apache::ePerl - Fast emulated Embedded Perl (ePerl) facility

=head1 SYNOPSIS

   #   Apache's httpd.conf file
   #   mandatory: activation of Apache::ePerl
   PerlModule Apache::ePerl
   <Directory /root/of/webmaster/area>
       <Files *.iphtml>
           Options     +ExecCGI
           SetHandler  perl-script
           PerlHandler Apache::ePerl
       </Files>
   </Directory>
   #   optional: configuration of Apache::ePerl
   <Perl>
   $Apache::ePerl::Config->{'BeginDelimiter'}  = '<?';
   $Apache::ePerl::Config->{'EndDelimiter'}    = '!>';
   $Apache::ePerl::Config->{'CaseDelimiters'}  = 0;
   $Apache::ePerl::Config->{'ConvertEntities'} = 1;
   </Perl>
   #   optional: activation of Apache::Status for Apache::ePerl
   <Location /perl-status>
       Options     +ExecCGI
       SetHandler  perl-script
       PerlHandler Apache::Status
   </Location>

=head1 DESCRIPTION

These packages provides a handler function for Apache/mod_perl which can be
used to emulate the stand-alone Server-Side-Scripting-Language I<ePerl> (see
eperl(3) for more details) in a very fast way. This is not a real 100%
replacement for F<nph-eperl> because of reduced functionality under some
special cases, principal runtime restrictions and speedup decisions. For
instance this variant does not (and cannot) provide the SetUID feature of
ePerl nor does it check for allowed filename extensions (speedup!), etc.
Instead it uses further features like object caching which ePerl does not use.

But the accepted bristled source file format is exactly the same as with the
regular ePerl facility, because Apache::ePerl uses the Parse::ePerl package
which provides the original ePerl parser and translator. So, any valid ePerl
which works under F<nph-eperl> can also be used under Apache::ePerl.

The intent is to use this special variant of ePerl for scripts which are
directly under control of the webmaster. In this situation no real security
problems exists for him, because all risk is at his own hands. For the average
user you should B<not> use Apache::ePerl. Instead additionally install the
regular stand-alone ePerl facility (F<nph-eperl>) for those users.

So, the advantage of Apache::ePerl against the regular F<nph-eperl> is better
performance and nothing else. Actually scripts executed under Apache::ePerl
are at least twice as fast as under F<nph-eperl>. The reason its not that
ePerl itself is faster. The reason is the runtime in-core environment of
Apache/mod_perl which does not have any forking overhead.

=head2 Installation and Configuration

First you have to install Apache::ePerl so that Apache/mod_perl can find it.
This is usually done via configuring the ePerl distribution via the same Perl
interpreter as was used when building Apache/mod_perl.

Second, you have to add the following config snippet to Apache's F<httpd.conf>
file:

   PerlModule Apache::ePerl
   <Directory /root/of/webmaster/area>
       <Files *.iphtml>
           Options     +ExecCGI
           SetHandler  perl-script
           PerlHandler Apache::ePerl
       </Files>
   </Directory>

This forces all files under the directory /root/of/webmaster/area/ with
extension .iphtml to be processed by the Apache::ePerl::handler function which
emulates the runtime behavior of the stand-alone "eperl" program (when run as
a SSSL) up to 90%.  

If you're not paranoid about security (for instance driving a stand-alone
webserver without user accounts) you can also just use

   PerlModule Apache::ePerl
   <Files *.iphtml>
       SetHandler  perl-script
       PerlHandler Apache::ePerl
   </Files>

which enables .iphtml files everywhere.

Third, when you want to change the defaults of the ePerl parser, you also can
add something like this to the end of the snippet above.

   <Perl>
   $Apache::ePerl::Config->{'BeginDelimiter'}  = '<?';
   $Apache::ePerl::Config->{'EndDelimiter'}    = '!>';
   $Apache::ePerl::Config->{'CaseDelimiters'}  = 0;
   $Apache::ePerl::Config->{'ConvertEntities'} = 1;
   </Perl>

Fourth, you can additionally enable the mod_perl runtime status which then
automatically enables an Apache::ePerl status handler:

   <Location /perl-status>
       Options     +ExecCGI
       SetHandler  perl-script
       PerlHandler Apache::Status
   </Location>

This enables the URL C</perl-status> in general and the URL
C</perl-status?ePerl> in special. Use it to see how much scripts where run and
how much are still cached.

=head1 AUTHOR

 Ralf S. Engelschall
 rse@engelschall.com
 www.engelschall.com

=head1 HISTORY

Apache::ePerl was first implemented by Mark Imbriaco E<lt>mark@itribe.netE<gt>
in December 1996 as a plain Perl module after he has seen the original ePerl
from Ralf S. Engelschall. It implemented the ePerl idea, but was not
compatible to the original ePerl. In May 1997 Hanno Mueller
E<lt>hmueller@kabel.deE<gt> has taken over the maintenance from Mark I. and
enhanced Apache::ePerl by adding caching for P-Code, adding the missing
C<chdir> stuff, etc. 

Nearly at the same time Ralf S. Engelschall was unhappy of the old
Apache::ePerl from Mark I. and already started to write this version (the one
you are current reading its POD). He has rewritten the complete module from
scratch, but incorporated the P-Code caching idea and the Apache::Status usage
from Hanno M.'s version. The big difference between this one and Mark I.'s or
Hanno M.'s versions are that this version makes use of the new Parse::ePerl
module which itself incorporates the original ePerl parser.  So this version
is more compliant to the original ePerl facility.

=head1 SEE ALSO

Parse::ePerl(3)

Web-References:

  Perl:     perl(1),     http://www.perl.com/
  ePerl:    eperl(1),    http://www.engelschall.com/sw/eperl/
  mod_perl: mod_perl(1), http://perl.apache.org/
  Apache:   httpd(7),    http://www.apache.org/

=cut

##EOF##
eperl 2.2.14-18 / usr / share / perl5 / Apache / ePerl.pm
