<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package Apache::PerlRun;

use strict;
use vars qw($Debug);
use Apache::Constants qw(:common &amp;OPT_EXECCGI);

BEGIN {
    OPT_EXECCGI() if $ENV{MOD_PERL}; #preload, :common are alread pre-loaded
}

unless (defined $Apache::Registry::NameWithVirtualHost) {
    $Apache::Registry::NameWithVirtualHost = 1;
}

unless (defined $Apache::Registry::MarkLine) {
    $Apache::Registry::MarkLine = 1;
}

$Debug ||= 0;
my $Is_Win32 = $^O eq "MSWin32";

sub new {
    my($class, $r) = @_;
    my $filename = $r-&gt;filename;
    $r-&gt;warn("Apache::PerlRun-&gt;new for $filename in process $$")
	if $Debug &amp;&amp; $Debug &amp; 4;

    return bless {r=&gt;$r}, $class;
}

sub can_compile {
    my($pr) = @_;
    my $r = $pr-&gt;{r};
    my $filename = $r-&gt;filename;
#XXX reported problems with $r-&gt;finfo
#    if (-r $r-&gt;finfo &amp;&amp; -s _) {
    if (-r $filename &amp;&amp; -s _) {
	if (!($r-&gt;allow_options &amp; OPT_EXECCGI)) {
	    $r-&gt;log_reason("Options ExecCGI is off in this directory",
			   $filename);
	    return FORBIDDEN;
 	}
	if (-d _) {
	    return DECLINED;
	}
	unless (-x _ or $Is_Win32) {
	    $r-&gt;log_reason("file permissions deny server execution",
			   $filename);
	    return FORBIDDEN;
	}

	$pr-&gt;{'mtime'} = -M _;
	return wantarray ? (OK, $pr-&gt;{'mtime'}) : OK;
    }
    $r-&gt;log_error("$filename not found or unable to stat");
    return NOT_FOUND;
}

sub mark_line {
    my $filename = shift-&gt;{r}-&gt;filename;
    return $Apache::Registry::MarkLine ?
	"\n#line 1 $filename\n" : "";
}

sub sub_wrap {
    my($pr, $code, $package) = @_;

    $code    ||= $pr-&gt;{'code'};
    $package ||= $pr-&gt;{'namespace'};

    my $line = $pr-&gt;mark_line;
    my $sub = join(
		    '',
		    'package ',
		    $package,
		    ';use Apache qw(exit);',
		    'sub handler {',
		    $line,
		    $$code,
		    "\n}", # last line comment without newline?
		    );
    $pr-&gt;{'sub'} = \$sub;
}

sub cached {
    my($pr) = @_;
    exists $Apache::Registry-&gt;{$pr-&gt;namespace}{'mtime'};
}

sub should_compile {
    my($pr, $package, $mtime) = @_;
    $package ||= $pr-&gt;{'namespace'};
    $mtime   ||= $pr-&gt;{'mtime'};
    !($pr-&gt;cached
    &amp;&amp;
      $Apache::Registry-&gt;{$package}{'mtime'} &lt;= $mtime);
}

sub set_mtime {
    my($pr, $mtime, $package) = @_;
    $mtime   ||= $pr-&gt;{'mtime'};
    $package ||= $pr-&gt;{'namespace'};
    $Apache::Registry-&gt;{$package}{'mtime'} = $mtime;
}

sub compile {
    my($pr, $eval) = @_;
    $eval ||= $pr-&gt;{'sub'};
    my $r = $pr-&gt;{r};
    $r-&gt;clear_rgy_endav;
    $r-&gt;log_error("Apache::PerlRun-&gt;compile") if $Debug &amp;&amp; $Debug &amp; 4;
    Apache-&gt;untaint($$eval);
    {
	no strict; #so eval'd code doesn't inherit our bits
	eval $$eval;
    }
    $r-&gt;stash_rgy_endav;
    return $pr-&gt;error_check;
}

sub run {
    my $pr = shift;
    my $package = $pr-&gt;{'namespace'};
    my $r = $pr-&gt;{r};

    my $rc = OK;
    my $cv = \&amp;{"$package\::handler"};

    my $oldwarn = $^W;
    eval { $rc = &amp;{$cv}($r, @_) } if $r-&gt;seqno;
    $pr-&gt;{status} = $rc;
    $^W = $oldwarn;

    my $errsv = "";
    if($@) {
	$errsv = $@;
	$@ = ''; #XXX fix me, if we don't do this Apache::exit() breaks
	$@{$r-&gt;uri} = $errsv;
    }

    if($errsv) {
	$r-&gt;log_error($errsv);
	return SERVER_ERROR;
    }

    return wantarray ? (OK, $rc) : OK;
}

sub status {
    shift-&gt;{r}-&gt;status;
}

sub namespace_from {
    my($pr) = @_;
    my $r = $pr-&gt;{r};

    my $uri = $r-&gt;uri;

    $r-&gt;log_error(sprintf "Apache::PerlRun-&gt;namespace escaping %s",
		  $uri) if $Debug &amp;&amp; $Debug &amp; 4;

    my $path_info = $r-&gt;path_info;
    my $script_name = $path_info &amp;&amp; $uri =~ /$path_info$/ ?
	substr($uri, 0, length($uri)-length($path_info)) :
	$uri;

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

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

    return $script_name;
}

sub namespace {
    my($pr, $root) = @_;
    return $pr-&gt;{'namespace'} if $pr-&gt;{'namespace'};

    my $script_name = $pr-&gt;namespace_from;

    # 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;

    $Apache::Registry::curstash = $script_name;
 
    $root ||= "Apache::ROOT";

    $pr-&gt;{r}-&gt;log_error("Apache::PerlRun-&gt;namespace: package $root$script_name")
	if $Debug &amp;&amp; $Debug &amp; 4;

    $pr-&gt;{'namespace'} = $root.$script_name;
    return $pr-&gt;{'namespace'};
}

sub readscript {
    my $pr = shift;
    $pr-&gt;{'code'} = $pr-&gt;{r}-&gt;slurp_filename;
}

sub error_check {
    my $pr = shift;
    if ($@ and substr($@,0,4) ne " at ") {
	$pr-&gt;{r}-&gt;log_error("PerlRun: `$@'");
	$@{$pr-&gt;{r}-&gt;uri} = $@;
	$@ = ''; #XXX fix me, if we don't do this Apache::exit() breaks	
	return SERVER_ERROR;
    }
    return OK;
}

#XXX not good enough yet
my(%switches) = (
   'T' =&gt; sub {
       Apache::warn("Apache::PerlRun: T switch ignored, ".
		    "enable with 'PerlTaintCheck On'\n")
	   unless $Apache::__T; "";
   },
   'w' =&gt; sub { 'BEGIN {$^W = 1;}; $^W = 1;' },
);

sub parse_cmdline {
    my($pr, $code) = @_;
    $code ||= $pr-&gt;{'code'};
    my($line) = $$code =~ /^(.*)$/m;
    my(@cmdline) = split /\s+/, $line;
    return $code unless @cmdline;
    return $code unless shift(@cmdline) =~ /^\#!/;
    my($s, @s, $prepend);
    $prepend = "";
    for $s (@cmdline) {
	next unless $s =~ s/^-//;
	last if substr($s,0,1) eq "-";
	for (split //, $s) {
	    next unless $switches{$_};
	    #print STDERR "parsed `$_' switch\n";
	    $prepend .= &amp;{$switches{$_}};
	}
    }
    $$code =~ s/^/$prepend/ if $prepend;
    return $code;
}

sub chdir_file {
    my($pr, $dir) = @_;
    my $r = $pr-&gt;{r};
    $r-&gt;chdir_file($dir ? $dir : $r-&gt;filename);
}

sub set_script_name {
    *0 = \(shift-&gt;{r}-&gt;filename);
}

sub handler ($$) {
    my($class, $r);
    if (@_ &gt;= 2) {
	($class, $r) = (shift, shift);
    }
    else {
	($class, $r) = (__PACKAGE__, shift);
    }

    my $pr = $class-&gt;new($r);
    my $rc = $pr-&gt;can_compile;
    return $rc unless $rc == OK;

    my $package = $pr-&gt;namespace;
    my $code = $pr-&gt;readscript;
    $pr-&gt;parse_cmdline($code);

    $pr-&gt;set_script_name;
    $pr-&gt;chdir_file;
    my $line = $pr-&gt;mark_line;
    my %orig_inc = %INC;
    my $eval = join '',
		    'package ',
		    $package,
		    ';use Apache qw(exit);',
                    $line,
		    $$code,
                    "\n";
    $rc = $pr-&gt;compile(\$eval);

    $pr-&gt;chdir_file("$Apache::Server::CWD/");
    #in case .pl files do not declare package ...;
    for (keys %INC) {
	next if $orig_inc{$_};
	next if /\.pm$/;
	delete $INC{$_};
    }

    if(my $opt = $r-&gt;dir_config("PerlRunOnce")) {
	$r-&gt;child_terminate if lc($opt) eq "on";
    }

    $pr-&gt;flush_namespace($package);

    return $rc;
}

BEGIN {
    if ($] &lt; 5.006) {
        $INC{'warnings.pm'} = __FILE__;
        *warnings::unimport = sub {};
    }
}

sub flush_namespace {
    my($self, $package) = @_;
    $package ||= $self-&gt;namespace;

    no strict 'refs';
    my $tab = \%{$package.'::'};

    for (keys %$tab) {
        my $fullname = join '::', $package, $_;
        #code/hash/array/scalar might be imported
        #make sure the gv does not point elsewhere
        #before undefing each
        if (%$fullname) {
            *{$fullname} = {};
            undef %$fullname;
        }
        if (@$fullname) {
            *{$fullname} = [];
            undef @$fullname;
        }
        if ($$fullname) {
            my $tmp; #argh, no such thing as an anonymous scalar
            *{$fullname} = \$tmp;
            undef $$fullname;
        }
        if (defined &amp;$fullname) {
            no warnings;
            local $^W = 0;
            if (my $p = prototype $fullname) {
                *{$fullname} = eval "sub ($p) {}";
            }
            else {
                *{$fullname} = sub {};
            }
	    undef &amp;$fullname;
	}
        if (*{$fullname}{IO}) {
            if (fileno $fullname) {
                close $fullname;
            }
        }
    }
}

1;

__END__

=head1 NAME

Apache::PerlRun - Run unaltered CGI scripts under mod_perl

=head1 SYNOPSIS

 #in httpd.conf

 Alias /cgi-perl/ /perl/apache/scripts/ 
 PerlModule Apache::PerlRun

 &lt;Location /cgi-perl&gt;
 SetHandler perl-script
 PerlHandler Apache::PerlRun
 Options +ExecCGI 
 #optional
 PerlSendHeader On
 ...
 &lt;/Location&gt;

=head1 DESCRIPTION

This module's B&lt;handler&gt; emulates the CGI environment,
allowing programmers to write scripts that run under CGI or
mod_perl without change.  Unlike B&lt;Apache::Registry&gt;, the
B&lt;Apache::PerlRun&gt; handler does not cache the script inside of a
subroutine.  Scripts will be "compiled" every request.  After the
script has run, it's namespace is flushed of all variables and
subroutines.

The B&lt;Apache::Registry&gt; handler is much faster than
B&lt;Apache::PerlRun&gt;.  However, B&lt;Apache::PerlRun&gt; is much faster than
CGI as the fork is still avoided and scripts can use modules which
have been pre-loaded at server startup time.  This module is meant for
"Dirty" CGI Perl scripts which relied on the single request lifetime
of CGI and cannot run under B&lt;Apache::Registry&gt; without cleanup.

=head1 CAVEATS

If your scripts still have problems running under the I&lt;Apache::PerlRun&gt;
handler, the I&lt;PerlRunOnce&gt; option can be used so that the process running
the script will be shutdown.  Add this to your httpd.conf:

 &lt;Location ...&gt;
 PerlSetVar PerlRunOnce On
 ...
 &lt;/Location&gt;

=head1 SEE ALSO

perl(1), mod_perl(3), Apache::Registry(3)

=head1 AUTHOR

Doug MacEachern

=cut
</pre></body></html>