perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From do...@hyperreal.org
Subject cvs commit: modperl/t/conf httpd.conf.pl
Date Tue, 22 Sep 1998 14:05:41 GMT
dougm       98/09/22 07:05:41

  Modified:    .        MANIFEST
               lib/Apache PerlRun.pm
               t/conf   httpd.conf.pl
  Log:
  new Apache::PerlRun methods to replace Apache::Registry mess
  
  Revision  Changes    Path
  1.39      +1 -0      modperl/MANIFEST
  
  Index: MANIFEST
  ===================================================================
  RCS file: /export/home/cvs/modperl/MANIFEST,v
  retrieving revision 1.38
  retrieving revision 1.39
  diff -u -r1.38 -r1.39
  --- MANIFEST	1998/09/19 17:28:08	1.38
  +++ MANIFEST	1998/09/22 14:05:39	1.39
  @@ -49,6 +49,7 @@
   lib/Apache/PerlRun.pm
   lib/Apache/PerlSections.pm
   lib/Apache/Registry.pm
  +lib/Apache/RegistryNG.pm
   lib/Apache/RegistryLoader.pm
   lib/Apache/Resource.pm
   #lib/Apache/Safe.pm
  
  
  
  1.8       +140 -54   modperl/lib/Apache/PerlRun.pm
  
  Index: PerlRun.pm
  ===================================================================
  RCS file: /export/home/cvs/modperl/lib/Apache/PerlRun.pm,v
  retrieving revision 1.7
  retrieving revision 1.8
  diff -u -r1.7 -r1.8
  --- PerlRun.pm	1998/09/19 17:38:15	1.7
  +++ PerlRun.pm	1998/09/22 14:05:40	1.8
  @@ -8,6 +8,10 @@
       $Apache::Registry::NameWithVirtualHost = 1;
   }
   
  +unless (defined $Apache::Registry::MarkLine) {
  +    $Apache::Registry::MarkLine = 1;
  +}
  +
   $Debug ||= 0;
   my $Is_Win32 = $^O eq "MSWin32";
   
  @@ -23,62 +27,139 @@
   	$r = Apache->request;
       }
       my $filename = $r->filename;
  -    $r->log_error("Apache::PerlRun->new for $filename in process $$")
  +    $r->warn("Apache::PerlRun->new for $filename in process $$")
   	if $Debug && $Debug & 4;
   
  -    bless $r, $class;
  +    bless {
  +	'_r' => $r,
  +    }, $class;
   }
   
   sub can_compile {
  -    my($r) = @_;
  -    my $filename = $r->filename;
  +    my($pr) = @_;
  +    my $filename = $pr->filename;
       if (-r $filename && -s _) {
  -	if (!($r->allow_options & OPT_EXECCGI)) {
  -	    $r->log_reason("Options ExecCGI is off in this directory",
  +	if (!($pr->allow_options & OPT_EXECCGI)) {
  +	    $pr->log_reason("Options ExecCGI is off in this directory",
   			   $filename);
   	    return FORBIDDEN;
    	}
   	if (-d _) {
  -	    $r->log_reason("attempt to invoke directory as script", $filename);
  +	    $pr->log_reason("attempt to invoke directory as script", $filename);
   	    return FORBIDDEN;
   	}
   	unless (-x _ or $Is_Win32) {
  -	    $r->log_reason("file permissions deny server execution",
  +	    $pr->log_reason("file permissions deny server execution",
   			   $filename);
   	    return FORBIDDEN;
   	}
   
  -	return wantarray ? (OK, -M _) : OK;
  +	$pr->{'mtime'} = -M _;
  +	return wantarray ? (OK, $pr->{'mtime'}) : OK;
       }
       return NOT_FOUND;
   }
   
  +sub mark_line {
  +    my($pr) = @_;
  +    my $filename = $pr->filename;
  +    return $Apache::Registry::MarkLine ?
  +	"\n#line 1 $filename\n" : "";
  +}
  +
  +sub sub_wrap {
  +    my($pr, $code, $package) = @_;
  +
  +    $code    ||= $pr->{'code'};
  +    $package ||= $pr->{'namespace'};
  +
  +    my $line = $pr->mark_line;
  +    my $sub = join(
  +		    '',
  +		    'package ',
  +		    $package,
  +		    ';use Apache qw(exit);',
  +		    'sub handler {',
  +		    $line,
  +		    $$code,
  +		    "\n}", # last line comment without newline?
  +		    );
  +    $pr->{'sub'} = \$sub;
  +}
  +
  +sub should_compile {
  +    my($pr, $package, $mtime) = @_;
  +    $package ||= $pr->{'namespace'};
  +    $mtime   ||= $pr->{'mtime'};
  +    !(exists $Apache::Registry->{$package}{'mtime'}
  +    &&
  +      $Apache::Registry->{$package}{'mtime'} <= $mtime);
  +}
  +
  +sub update_mtime {
  +    my($pr, $mtime, $package) = @_;
  +    $mtime   ||= $pr->{'mtime'};
  +    $package ||= $pr->{'namespace'};
  +    $Apache::Registry->{$package}{'mtime'} = $mtime;
  +}
  +
   sub compile {
  -    my($r, $eval) = @_;
  -    $r->log_error("Apache::PerlRun->compile") if $Debug && $Debug & 4;
  +    my($pr, $eval) = @_;
  +    $eval ||= $pr->{'sub'};
  +    $pr->clear_rgy_endav;
  +    $pr->log_error("Apache::PerlRun->compile") if $Debug && $Debug &
4;
       Apache->untaint($$eval);
       {
   	no strict; #so eval'd code doesn't inherit our bits
   	eval $$eval;
       }
  +    $pr->stash_rgy_endav;
  +    return $pr->error_check;
  +}
  +
  +sub run {
  +    my($pr) = @_;
  +    my $package = $pr->{'namespace'};
  +
  +    my $rc = OK;
  +    my $cv = \&{"$package\::handler"};
  +    eval { $rc = &{$cv}($pr->{'_r'}, @_) } if $pr->seqno;
  +    $pr->{status} = $rc;
  +
  +    my $errsv = "";
  +    if($@) {
  +	$errsv = $@;
  +	$@ = ''; #XXX fix me, if we don't do this Apache::exit() breaks
  +	$@{$pr->uri} = $errsv;
  +    }
  +
  +    if($errsv) {
  +	$pr->log_error($errsv);
  +	return SERVER_ERROR;
  +    }
  +
  +    return wantarray ? (OK, $rc) : OK;
  +}
  +
  +sub status {
  +    shift->{'_r'}->status;
   }
   
   sub namespace {
  -    my($r, $root) = @_;
  +    my($pr, $root) = @_;
   
  -    my $uri = $r->uri; 
  +    my $uri = $pr->uri; 
       $uri = "/__INDEX__" if $uri eq "/";
  -    $r->log_error(sprintf "Apache::PerlRun->namespace escaping %s",
  +    $pr->log_error(sprintf "Apache::PerlRun->namespace escaping %s",
   		  $uri) if $Debug && $Debug & 4;
   
  -    my $script_name = $r->path_info ?
  -	substr($uri, 0, length($uri)-length($r->path_info)) :
  +    my $script_name = $pr->path_info ?
  +	substr($uri, 0, length($uri)-length($pr->path_info)) :
   	    $uri;
   
       if($Apache::Registry::NameWithVirtualHost) {
  -	my $srv = $r->server;
  -	$script_name = join "", $srv->server_hostname, $script_name
  -	    if $srv->is_virtual;
  +	my $name = $pr->get_server_name;
  +	$script_name = join "", $name, $script_name if $name;
       }
   
       # Escape everything into valid perl identifiers
  @@ -91,35 +172,28 @@
   			 }[
   			   "::" . ($2 ? sprintf("_%2x",unpack("C",$2)) : "")
   			  ]egx;
  -
  -    $Apache::Registry::curstash = $script_name if 
  -	scalar(caller) eq "Apache::Registry";
   
  +    $Apache::Registry::curstash = $script_name;
  + 
       $root ||= "Apache::ROOT";
   
  -    $r->log_error("Apache::PerlRun->namespace: package $root$script_name")
  +    $pr->log_error("Apache::PerlRun->namespace: package $root$script_name")
   	if $Debug && $Debug & 4;
   
  -    return $root.$script_name;
  +    $pr->{'namespace'} = $root.$script_name;
  +    return $pr->{'namespace'};
   }
   
   sub readscript {
  -    my $r = shift;
  -    my $filename = $r->filename;
  -    $r->log_error("Apache::PerlRun->readscript $filename")
  -	    if $Debug && $Debug & 4;
  -    my $fh = Apache::gensym(__PACKAGE__);
  -    open $fh, $filename;
  -    local $/;
  -    my $code = <$fh>;
  -    return \$code;
  +    my $pr = shift;
  +    $pr->{'code'} = $pr->slurp_filename;
   }
   
   sub error_check {
  -    my $r = shift;
  +    my $pr = shift;
       if ($@ and substr($@,0,4) ne " at ") {
  -	$r->log_error("PerlRun: `$@'");
  -	$@{$r->uri} = $@;
  +	$pr->log_error("PerlRun: `$@'");
  +	$@{$pr->uri} = $@;
   	$@ = ''; #XXX fix me, if we don't do this Apache::exit() breaks	
   	return SERVER_ERROR;
       }
  @@ -137,11 +211,12 @@
   );
   
   sub parse_cmdline {
  -    my($r, $sub) = @_;
  -    my($line) = $$sub =~ /^(.*)$/m;
  +    my($pr, $code) = @_;
  +    $code ||= $pr->{'code'};
  +    my($line) = $$code =~ /^(.*)$/m;
       my(@cmdline) = split /\s+/, $line;
  -    return $sub unless @cmdline;
  -    return $sub unless shift(@cmdline) =~ /^\#!/;
  +    return $code unless @cmdline;
  +    return $code unless shift(@cmdline) =~ /^\#!/;
       my($s, @s, $prepend);
       $prepend = "";
       for $s (@cmdline) {
  @@ -153,41 +228,52 @@
   	    $prepend .= &{$switches{$_}};
   	}
       }
  -    $$sub =~ s/^/$prepend/ if $prepend;
  -    return $sub;
  +    $$code =~ s/^/$prepend/ if $prepend;
  +    return $code;
  +}
  +
  +sub chdir_file {
  +    my($pr, $dir) = @_;
  +    $pr->{'_r'}->chdir_file($dir ? $dir : $pr->filename);
   }
   
  +sub set_script_name {
  +    my($pr) = @_;
  +    *0 = \$pr->filename;
  +}
  +
   sub handler {
       my $r = shift;
  -
  -    my $rc = can_compile($r);
  +    my $pr = Apache::PerlRun->new($r);
  +    my $rc = $pr->can_compile;
       return $rc unless $rc == OK;
  -
  -    my $package = namespace($r);
  -    my $code = readscript($r);
  -    parse_cmdline($r, $code);
   
  -    *0 = \$r->filename;
  -    $r->chdir_file;
  +    my $package = $pr->namespace;
  +    my $code = $pr->readscript;
  +    $pr->parse_cmdline($code);
  +
  +    $pr->set_script_name;
  +    $pr->chdir_file;
  +    my $line = $pr->mark_line;
       local %INC = %INC;
   
       my $eval = join '',
   		    'package ',
   		    $package,
   		    ';use Apache qw(exit);',
  -		    "\n#line 1 ", $r->filename, "\n",
  +                    $line,
   		    $$code,
                       "\n";
  -    compile($r, \$eval);
  +    $rc = $pr->compile(\$eval);
   
  -    chdir $Apache::Server::CWD;
  +    $pr->chdir_file("$Apache::Server::CWD/");
   
       {   #flush the namespace
   	no strict;
   	%{$package.'::'} = ();
       }
   
  -    return error_check($r);
  +    return $rc;
   }
   
   1;
  
  
  
  1.18      +2 -1      modperl/t/conf/httpd.conf.pl
  
  Index: httpd.conf.pl
  ===================================================================
  RCS file: /export/home/cvs/modperl/t/conf/httpd.conf.pl,v
  retrieving revision 1.17
  retrieving revision 1.18
  diff -u -r1.17 -r1.18
  --- httpd.conf.pl	1998/09/17 23:07:27	1.17
  +++ httpd.conf.pl	1998/09/22 14:05:41	1.18
  @@ -31,6 +31,7 @@
   #!perl
   use Apache ();
   use Apache::Registry ();
  +use Apache::RegistryNG ();
   
   Apache::Server->register_cleanup(sub { 
       warn "Apache::Server registered cleanup called for $$\n";
  @@ -121,7 +122,7 @@
   
   my @mod_perl = (
       SetHandler  => "perl-script",
  -    PerlHandler => "Apache::Registry",
  +    PerlHandler => "Apache::RegistryNG",
       Options     => "ExecCGI",
   );
   
  
  
  

Mime
View raw message