Z#~MOD_PERL1_25_MUP.SAVE6MOD_PERL1_25_MUP.SAVEGBACKUP/VERIFY ROOT$:[MOD_PERL1_25...]*.*;* []MOD_PERL1_25_MUP.SAVE/SAVE LEPAGE A@ sV7.2 _OPNEAR:: _$1$DGA205: AXP72-1R001 ~ s*[MOD_PERL1_25]00README.TXT;1+,!.E/A@ 4-E~-y 0123KPWO56q7Mq89GA@HJ To configure and build mod_perl: 1) Setup V1.25 source tree- 2) Define PERL_ROOT and APACHE$ROOT logicals 3) SET DEF [.MOD_PERL1_25] 4) PERL MAKEFILE.PL "USE_DSO=1" 5) Be sure the line: FULLEXT = mod_perl& is at the beginning of DESCRIP.MMS 6) SET DEF [.SRC.MODULES.PERL] 7) MMS 8) MMS INSTALL 9) SET DEF [---] 10) MMS 11) MMS INSTALL*[MOD_PERL1_25]APACHE.DIR;1+,r.E/A@ 4E-y 0123 KPWOF56)k7)k89GA@HJI  MAKEFILE.PL=8;"*[MOD_PERL1_25.APACHE]MAKEFILE.PL;2+,=8.E/A@ 4|E-r0123KPWO56fz7n89GA@HJuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; if ($^O eq 'VMS') { WriteMakefile( NAME => "Apache", VERSION_FROM => "Apache.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( NAME => "Apache", VERSION_FROM => "Apache.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS # $(PERL) -e "$r = '$root'; print qq{apache$r:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) # $(PERL) -e "$r = '$root'; $i = '$httpd_shr'; print qq{apache$r:[000000]apache$i.exe_alpha/Share\n}" >>$(MMS$TARGET) $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; } "*[MOD_PERL1_25.APACHE]MAKEFILE.PL;1+,;.E/A@ 4E-r0D123 KPWO566A酟7-t酟89GA@HJ N $J)g7 %J)g7J)g7.  1%z1%z1%zuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; WriteMakefile( NAME => "Apache", VERSION_FROM => "Apache.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); *[MOD_PERL1_25]CONNECTION.DIR;1+,t.E/A@ 4E-y 0123 KPWOF56o,k7o,k89GA@HJI  MAKEFILE.PLBB>3&*[MOD_PERL1_25.CONNECTION]MAKEFILE.PL;2+,BB.E/A@ 4gE-t0123KPWO56a_b7gn89GA@HJuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; if ($^O eq 'VMS') { WriteMakefile( 'NAME' => 'Apache::Connection', 'VERSION_FROM' => 'Connection.pm', # finds $VERSION 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( 'NAME' => 'Apache::Connection', 'VERSION_FROM' => 'Connection.pm', # finds $VERSION 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; } &*[MOD_PERL1_25.CONNECTION]MAKEFILE.PL;1+,>3.E/A@ 4E-t0D123 KPWO56+H酟7'酟89GA@HJ N $J)g7 %J)g7J)g7.  1%z1%z1%zuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; WriteMakefile( 'NAME' => 'Apache::Connection', 'VERSION_FROM' => 'Connection.pm', # finds $VERSION 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); *[MOD_PERL1_25]CONSTANTS.DIR;1+, .E/A@ 4E-y 0123 KPWOF56]≪k7]≪k89GA@HJI  MAKEFILE.PL| < %*[MOD_PERL1_25.CONSTANTS]MAKEFILE.PL;2+,| .E/A@ 4gE- 0123KPWO56pb7 $o89GA@HJuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; if ($^O eq 'VMS') { WriteMakefile( NAME => "Apache::Constants", VERSION_FROM => "Constants.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( NAME => "Apache::Constants", VERSION_FROM => "Constants.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; } %*[MOD_PERL1_25.CONSTANTS]MAKEFILE.PL;1+,< .E/A@ 4E- 0D123 KPWO56酟7J酟89GA@HJ N $J)g7 %J)g7J)g7.  1%z1%z1%zuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; WriteMakefile( NAME => "Apache::Constants", VERSION_FROM => "Constants.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); *[MOD_PERL1_25]FILE.DIR;1+,.E/A@ 4E-y 0123 KPWOF56+k7+k89GA@HJI  MAKEFILE.PLc  *[MOD_PERL1_25.FILE]MAKEFILE.PL;2+,c.E/A@ 4gE-0123KPWO56 c7 o89GA@HJuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; if ($^O eq 'VMS') { WriteMakefile( NAME => "Apache::File", VERSION_FROM => "File.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( NAME => "Apache::File", VERSION_FROM => "File.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; }  *[MOD_PERL1_25.FILE]MAKEFILE.PL;1+, .E/A@ 4E-0D123 KPWO56L酟7N酟89GA@HJ N $J)g7 %J)g7J)g7.  :%1a:%1a:%1ause ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; WriteMakefile( NAME => "Apache::File", VERSION_FROM => "File.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); *[MOD_PERL1_25]LEAK.DIR;1+,.E/A@ 4E-y 0123 KPWOF56V̱k7V̱k89GA@HJI  MAKEFILE.PLw<>G *[MOD_PERL1_25.LEAK]MAKEFILE.PL;2+,w<.E/A@ 4gE-0123KPWO56HY$@c7, J1o89GA@HJuse ExtUtils::MakeMaker; if ($^O eq 'VMS') { WriteMakefile( NAME => "Apache::Leak", VERSION_FROM => "Leak.pm", 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( NAME => "Apache::Leak", VERSION_FROM => "Leak.pm", ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; }  *[MOD_PERL1_25.LEAK]MAKEFILE.PL;1+,>G.E/A@ 4Eo-0D123 KPWO56uM9酟7'yj酟89GA@HJ N $J)g7 %J)g7J)g7.  f%f%f%use ExtUtils::MakeMaker; WriteMakefile( NAME => "Apache::Leak", VERSION_FROM => "Leak.pm", ); *[MOD_PERL1_25]LIB.DIR;1+,<.E/A@ 4E-y 0123 KPWOF56utk7utk89GA@HJI APACHE.DIR**[MOD_PERL1_25.LIB]APACHE.DIR;1+,*.E/A@ 4E-<0123 KPWOF56pfp7pfp89GA@HJISRC.PM !*[MOD_PERL1_25.LIB.APACHE]SRC.PM;2+, .E/A@ 4NEh-*0D123KPWO56{7,鐟89GA@HJN $J)g7 %J)g7J)g7(package Apache::src; use strict; use vars qw($VERSION); use File::Path (); use IO::File (); use Cwd (); use Config; #this is stuff ripped out of mod_perl's Makefile.PL #there's still commented out crap #there's still stuff to be added #once it is sane, we'll use these methods in Makefile.PL $VERSION = '0.01'; sub IS_MOD_PERL_BUILD () {grep { -e "$_/lib/mod_perl.pm" } qw(. ..)} my $Is_Win32 = ($^O eq "MSWin32"); my $Is_VMS = ($^O eq 'VMS'); $Apache::src::APXS ||= ""; sub apxs { my $self = shift; eval { require Apache::MyConfig }; my $apxs; my @trys = ($Apache::src::APXS, $Apache::MyConfig::Setup{'APXS'}); unless (IS_MOD_PERL_BUILD) { #if we are building mod_perl via apxs, apxs should already be known #these extra tries are for things built outside of mod_perl #e.g. libapreq push @trys, which("apxs"), "/usr/local/apache/bin/apxs"; } for (@trys) { next unless ($apxs = $_); chomp $apxs; last if -x $apxs; } return "" unless $apxs and -x $apxs; `$apxs @_ 2>/dev/null`; } sub apxs_cflags { my $cflags = __PACKAGE__->apxs("-q" => 'CFLAGS'); #$cflags =~ s/-D\w+=\".*\"//g; #get rid of -Ds with quotes $cflags =~ s/\"/\\\"/g; $cflags; } sub which { my $name = shift; for (split ':', $ENV{PATH}) { my $app = "$_/$name"; return $app if -x $app; } return ""; } sub new { my $class = shift; my $dir; if(IS_MOD_PERL_BUILD) { eval { require "../lib/Apache/MyConfig.pm"; }; unless ($@) { $dir = $Apache::MyConfig::Setup{Apache_Src}; for ($dir, "../$dir", "../../$dir") { last if -d ($dir = $_); } } } unless ($dir) { for (@INC) { last if -d ($dir = "$_/auto/Apache/include"); } } bless { dir => $dir, @_, }, $class; } sub mmn_eq { my($class, $dir) = @_; return 1 if $Is_Win32; #just assume, till Apache::src works under win32 my $instsrc; { local @INC = grep { !/blib/ } @INC; my $instdir; for (@INC) { last if -d ($instdir = "$_/auto/Apache/include"); } $instsrc = $class->new(dir => $instdir); } my $targsrc = $class->new($dir ? (dir => $dir) : ()); my $inst_mmn = $instsrc->module_magic_number; my $targ_mmn = $targsrc->module_magic_number; unless ($inst_mmn && $targ_mmn) { return 0; } if ($inst_mmn == $targ_mmn) { return 1; } print "Installed MMN $inst_mmn does not match target $targ_mmn\n"; return 0; } sub default_dir { eval { require Apache::MyConfig }; return $@ ? '../apache_x.x/src' : $Apache::MyConfig::Setup{Apache_Src}; } sub find { my $self = shift; my %seen = (); my @dirs = (); for my $src_dir ($self->dir, $self->default_dir, <../apache*/src>, <../stronghold*/src>, "../src", "./src") { next unless (-d $src_dir || -l $src_dir); next if $seen{$src_dir}++; =pod next unless $vers = httpd_version($src_dir); unless(exists $vers_map{$vers}) { print STDERR "Apache version '$vers' unsupported\n"; next; } $mft_map{$src_dir} = $vers_map{$vers}; #print STDERR "$src_dir -> $vers_map{$vers}\n"; =cut push @dirs, $src_dir; #$modified{$src_dir} = (stat($src_dir))[9]; } return @dirs; } sub dir { my($self, $dir) = @_; $self->{dir} = $dir if $dir; return $self->{dir}; } sub main { my $self = shift; asrc(shift || $self->dir); } sub asrc { my $d = shift; return $d if -e "$d/httpd.h"; return "$d/include" if -e "$d/include/httpd.h"; return "$d/main" if -e "$d/main/httpd.h"; return Apache::src->apxs("-q" => 'INCLUDEDIR'); } sub module_magic_number { my $self = shift; my $d = asrc(shift || $self->dir); return 0 unless $d; #return $mcache{$d} if $mcache{$d}; my $fh; for (qw(ap_mmn.h http_config.h)) { last if $fh = IO::File->new("$d/$_"); } return 0 unless $fh; my $n; my $mmn_pat = join "|", qw(MODULE_MAGIC_NUMBER_MAJOR MODULE_MAGIC_NUMBER); while(<$fh>) { if(s/^#define\s+($mmn_pat)\s+(\d+).*/$2/) { chomp($n = $_); last; } } $fh->close; #return($mcache{$d} = $n); return $n; } sub httpd_version { my($self, $dir, $vnumber) = @_; $dir = asrc($dir || $self->dir); if($vnumber) { #return $vcache{$dir} if $vcache{$dir}; } my $fh = IO::File->new("$dir/httpd.h") or return undef; my($server, $version, $rest); my($fserver, $fversion, $frest); my($string, $extra, @vers); while(<$fh>) { next unless /^#define/; s/SERVER_PRODUCT \"/\"Apache/; #1.3.13 next unless s/^#define\s+SERVER_(BASE|)(VERSION|REVISION)\s+"(.*)\s*".*/$3/; unless (m:/:) { $_ = "Apache/$_"; #1.3.14, argh } chomp($string = $_); #print STDERR "Examining SERVER_VERSION '$string'..."; #could be something like: #Stronghold-1.4b1-dev Ben-SSL/1.3 Apache/1.1.1 @vers = split /\s+/, $string; foreach (@vers) { next unless ($fserver,$fversion,$frest) = m,^([^/]+)/(\d\.\d+\.?\d*)([^ ]*),i; if($fserver eq "Apache") { ($server, $version) = ($fserver, $fversion); #$frest =~ s/^(a|b)(\d+).*/'_' . (length($2) > 1 ? $2 : "0$2")/e; $version .= $frest if $frest; } } } $fh->close; return $version; } sub find_in_inc { my $name = shift; for (@INC) { my $file; if (-e ($file = "$_/auto/Apache/$name")) { return $file; } } } sub otherldflags { my $self = shift; my @ldflags = (); if ($^O eq "aix") { if (my $file = find_in_inc("mod_perl.exp")) { push @ldflags, "-bI:" . $file; } my $httpdexp = $self->apxs("-q" => 'LIBEXECDIR') . "/httpd.exp"; if (-e $httpdexp) { push @ldflags, "-bI:$httpdexp"; } else { $httpdexp = $self->dir . "/support/httpd.exp"; push @ldflags, "-bI:$httpdexp" if -e $httpdexp; } } return join(' ', @ldflags); } sub typemaps { my $typemaps = []; if (my $file = find_in_inc("typemap")) { push @$typemaps, $file; } if(IS_MOD_PERL_BUILD) { push @$typemaps, "../Apache/typemap"; } return $typemaps; } sub inc { my $self = shift; my $src = $self->dir; my $main = $self->main; my $os = $Is_Win32 ? "win32" : "unix"; $os = 'openvms' if $Is_VMS; my @inc = (); for ($src, "$src/modules/perl", $main, "$src/regex", "$src/os/$os") { push @inc, "-I$_" if -d $_; } my $ssl_dir = "$src/../ssl/include"; unless (-d $ssl_dir) { eval { require Apache::MyConfig }; $ssl_dir = "$Apache::MyConfig::Setup{SSL_BASE}/include"; } push @inc, "-I$ssl_dir" if -d $ssl_dir; my $ainc = $self->apxs("-q" => 'INCLUDEDIR'); push @inc, "-I$ainc" if -d $ainc; return "@inc"; } sub ccflags { my $self = shift; my $cflags = $Config{'ccflags'}; join " ", $cflags, $self->apxs("-q" => 'CFLAGS'); } sub define { my $self = shift; if($Config{usethreads}) { return "-DPERL_THREADS"; } return ""; } =pod my $src = Apache::src->new; for my $path ($src->find) { my $mmn = $src->module_magic_number($path); my $v = $src->httpd_version($path); next unless $v; print "path = $path ($mmn,$v)\n"; my $dir = $src->prompt("Configure with $path?"); } =cut 1; __END__ =head1 NAME Apache::src - Methods for locating and parsing bits of Apache source code =head1 SYNOPSIS use Apache::src (); my $src = Apache::src->new; =head1 DESCRIPTION This module provides methods for locating and parsing bits of Apache source code. =head1 METHODS =over 4 =item new Create an object blessed into the B class. my $src = Apache::src->new; =item dir Top level directory where source files are located. my $dir = $src->dir; -d $dir or die "can't stat $dir $!\n"; =item main Apache's source tree was reorganized during development of version 1.3. So, common header files such as C are in different directories between versions less than 1.3 and those equal to or greater. This method will return the right directory. Example: -e join "/", $src->main, "httpd.h" or die "can't stat httpd.h\n"; =item find Searches for apache source directories, return a list of those found. Example: for my $dir ($src->find) { my $yn = prompt "Configure with $dir ?", "y"; ... } =item inc Print include paths for MakeMaker's B argument to C. Example: use ExtUtils::MakeMaker; use Apache::src (); WriteMakefile( 'NAME' => 'Apache::Module', 'VERSION' => '0.01', 'INC' => Apache::src->new->inc, ); =item module_magic_number Return the B defined in the apache source. Example: my $mmn = $src->module_magic_number; =item httpd_version Return the server version. Example: my $v = $src->httpd_version; =item otherldflags Return other ld flags for MakeMaker's B argument to C. This might be needed on systems like AIX that need special flags to the linker to be able to reference mod_perl or httpd symbols. Example: use ExtUtils::MakeMaker; use Apache::src (); WriteMakefile( 'NAME' => 'Apache::Module', 'VERSION' => '0.01', 'INC' => Apache::src->new->inc, 'dynamic_lib' => { 'OTHERLDFLAGS' => Apache::src->new->otherldflags, }, ); =back =head1 AUTHOR Doug MacEachern !*[MOD_PERL1_25.LIB.APACHE]SRC.PM;1+,.E/A@ 4E)-*0D123 KPWO56d酟7Wn酟89GA@HJ N $J)g7 %J)g7J)g7.  :)]:)]:)]package Apache::src; use strict; use vars qw($VERSION); use File::Path (); use IO::File (); use Cwd (); use Config; #this is stuff ripped out of mod_perl's Makefile.PL #there's still commented out crap #there's still stuff to be added #once it is sane, we'll use these methods in Makefile.PL $VERSION = '0.01'; sub IS_MOD_PERL_BUILD () {grep { -e "$_/lib/mod_perl.pm" } qw(. ..)} my $Is_Win32 = ($^O eq "MSWin32"); $Apache::src::APXS ||= ""; sub apxs { my $self = shift; eval { require Apache::MyConfig }; my $apxs; my @trys = ($Apache::src::APXS, $Apache::MyConfig::Setup{'APXS'}); unless (IS_MOD_PERL_BUILD) { #if we are building mod_perl via apxs, apxs should already be known #these extra tries are for things built outside of mod_perl #e.g. libapreq push @trys, which("apxs"), "/usr/local/apache/bin/apxs"; } for (@trys) { next unless ($apxs = $_); chomp $apxs; last if -x $apxs; } return "" unless $apxs and -x $apxs; `$ ~MOD_PERL1_25_MUP.SAVE*![MOD_PERL1_25.LIB.APACHE]SRC.PM;1EP$apxs @_ 2>/dev/null`; } sub apxs_cflags { my $cflags = __PACKAGE__->apxs("-q" => 'CFLAGS'); #$cflags =~ s/-D\w+=\".*\"//g; #get rid of -Ds with quotes $cflags =~ s/\"/\\\"/g; $cflags; } sub which { my $name = shift; for (split ':', $ENV{PATH}) { my $app = "$_/$name"; return $app if -x $app; } return ""; } sub new { my $class = shift; my $dir; if(IS_MOD_PERL_BUILD) { eval { require "../lib/Apache/MyConfig.pm"; }; unless ($@) { $dir = $Apache::MyConfig::Setup{Apache_Src}; for ($dir, "../$dir", "../../$dir") { last if -d ($dir = $_); } } } unless ($dir) { for (@INC) { last if -d ($dir = "$_/auto/Apache/include"); } } bless { dir => $dir, @_, }, $class; } sub mmn_eq { my($class, $dir) = @_; return 1 if $Is_Win32; #just assume, till Apache::src works under win32 my $instsrc; { local @INC = grep { !/blib/ } @INC; my $instdir; for (@INC) { last if -d ($instdir = "$_/auto/Apache/include"); } $instsrc = $class->new(dir => $instdir); } my $targsrc = $class->new($dir ? (dir => $dir) : ()); my $inst_mmn = $instsrc->module_magic_number; my $targ_mmn = $targsrc->module_magic_number; unless ($inst_mmn && $targ_mmn) { return 0; } if ($inst_mmn == $targ_mmn) { return 1; } print "Installed MMN $inst_mmn does not match target $targ_mmn\n"; return 0; } sub default_dir { eval { require Apache::MyConfig }; return $@ ? '../apache_x.x/src' : $Apache::MyConfig::Setup{Apache_Src}; } sub find { my $self = shift; my %seen = (); my @dirs = (); for my $src_dir ($self->dir, $self->default_dir, <../apache*/src>, <../stronghold*/src>, "../src", "./src") { next unless (-d $src_dir || -l $src_dir); next if $seen{$src_dir}++; =pod next unless $vers = httpd_version($src_dir); unless(exists $vers_map{$vers}) { print STDERR "Apache version '$vers' unsupported\n"; next; } $mft_map{$src_dir} = $vers_map{$vers}; #print STDERR "$src_dir -> $vers_map{$vers}\n"; =cut push @dirs, $src_dir; #$modified{$src_dir} = (stat($src_dir))[9]; } return @dirs; } sub dir { my($self, $dir) = @_; $self->{dir} = $dir if $dir; return $self->{dir}; } sub main { my $self = shift; asrc(shift || $self->dir); } sub asrc { my $d = shift; return $d if -e "$d/httpd.h"; return "$d/include" if -e "$d/include/httpd.h"; return "$d/main" if -e "$d/main/httpd.h"; return Apache::src->apxs("-q" => 'INCLUDEDIR'); } sub module_magic_number { my $self = shift; my $d = asrc(shift || $self->dir); return 0 unless $d; #return $mcache{$d} if $mcache{$d}; my $fh; for (qw(ap_mmn.h http_config.h)) { last if $fh = IO::File->new("$d/$_"); } return 0 unless $fh; my $n; my $mmn_pat = join "|", qw(MODULE_MAGIC_NUMBER_MAJOR MODULE_MAGIC_NUMBER); while(<$fh>) { if(s/^#define\s+($mmn_pat)\s+(\d+).*/$2/) { chomp($n = $_); last; } } $fh->close; #return($mcache{$d} = $n); return $n; } sub httpd_version { my($self, $dir, $vnumber) = @_; $dir = asrc($dir || $self->dir); if($vnumber) { #return $vcache{$dir} if $vcache{$dir}; } my $fh = IO::File->new("$dir/httpd.h") or return undef; my($server, $version, $rest); my($fserver, $fversion, $frest); my($string, $extra, @vers); while(<$fh>) { next unless /^#define/; s/SERVER_PRODUCT \"/\"Apache/; #1.3.13 next unless s/^#define\s+SERVER_(BASE|)(VERSION|REVISION)\s+"(.*)\s*".*/$3/; unless (m:/:) { $_ = "Apache/$_"; #1.3.14, argh } chomp($string = $_); #print STDERR "Examining SERVER_VERSION '$string'..."; #could be something like: #Stronghold-1.4b1-dev Ben-SSL/1.3 Apache/1.1.1 @vers = split /\s+/, $string; foreach (@vers) { next unless ($fserver,$fversion,$frest) = m,^([^/]+)/(\d\.\d+\.?\d*)([^ ]*),i; if($fserver eq "Apache") { ($server, $version) = ($fserver, $fversion); #$frest =~ s/^(a|b)(\d+).*/'_' . (length($2) > 1 ? $2 : "0$2")/e; $version .= $frest if $frest; } } } $fh->close; return $version; } sub find_in_inc { my $name = shift; for (@INC) { my $file; if (-e ($file = "$_/auto/Apache/$name")) { return $file; } } } sub otherldflags { my $self = shift; my @ldflags = (); if ($^O eq "aix") { if (my $file = find_in_inc("mod_perl.exp")) { push @ldflags, "-bI:" . $file; } my $httpdexp = $self->apxs("-q" => 'LIBEXECDIR') . "/httpd.exp"; if (-e $httpdexp) { push @ldflags, "-bI:$httpdexp"; } else { $httpdexp = $self->dir . "/support/httpd.exp"; push @ldflags, "-bI:$httpdexp" if -e $httpdexp; } } return join(' ', @ldflags); } sub typemaps { my $typemaps = []; if (my $file = find_in_inc("typemap")) { push @$typemaps, $file; } if(IS_MOD_PERL_BUILD) { push @$typemaps, "../Apache/typemap"; } return $typemaps; } sub inc { my $self = shift; my $src = $self->dir; my $main = $self->main; my $os = $Is_Win32 ? "win32" : "unix"; my @inc = (); for ($src, "$src/modules/perl", $main, "$src/regex", "$src/os/$os") { push @inc, "-I$_" if -d $_; } my $ssl_dir = "$src/../ssl/include"; unless (-d $ssl_dir) { eval { require Apache::MyConfig }; $ssl_dir = "$Apache::MyConfig::Setup{SSL_BASE}/include"; } push @inc, "-I$ssl_dir" if -d $ssl_dir; my $ainc = $self->apxs("-q" => 'INCLUDEDIR'); push @inc, "-I$ainc" if -d $ainc; return "@inc"; } sub ccflags { my $self = shift; my $cflags = $Config{'ccflags'}; join " ", $cflags, $self->apxs("-q" => 'CFLAGS'); } sub define { my $self = shift; if($Config{usethreads}) { return "-DPERL_THREADS"; } return ""; } =pod my $src = Apache::src->new; for my $path ($src->find) { my $mmn = $src->module_magic_number($path); my $v = $src->httpd_version($path); next unless $v; print "path = $path ($mmn,$v)\n"; my $dir = $src->prompt("Configure with $path?"); } =cut 1; __END__ =head1 NAME Apache::src - Methods for locating and parsing bits of Apache source code =head1 SYNOPSIS use Apache::src (); my $src = Apache::src->new; =head1 DESCRIPTION This module provides methods for locating and parsing bits of Apache source code. =head1 METHODS =over 4 =item new Create an object blessed into the B class. my $src = Apache::src->new; =item dir Top level directory where source files are located. my $dir = $src->dir; -d $dir or die "can't stat $dir $!\n"; =item main Apache's source tree was reorganized during development of version 1.3. So, common header files such as C are in different directories between versions less than 1.3 and those equal to or greater. This method will return the right directory. Example: -e join "/", $src->main, "httpd.h" or die "can't stat httpd.h\n"; =item find Searches for apache source directories, return a list of those found. Example: for my $dir ($src->find) { my $yn = prompt "Configure with $dir ?", "y"; ... } =item inc Print include paths for MakeMaker's B argument to C. Example: use ExtUtils::MakeMaker; use Apache::src (); WriteMakefile( 'NAME' => 'Apache::Module', 'VERSION' => '0.01', 'INC' => Apache::src->new->inc, ); =item module_magic_number Return the B defined in the apache source. Example: my $mmn = $src->module_magic_number; =item httpd_version Return the server version. Example: my $v = $src->httpd_version; =item otherldflags Return other ld flags for MakeMaker's B argument to C. This might be needed on systems like AIX that need special flags to the linker to be able to reference mod_perl or httpd symbols. Example: use ExtUtils::MakeMaker; use Apache::src (); WriteMakefile( 'NAME' => 'Apache::Module', 'VERSION' => '0.01', 'INC' => Apache::src->new->inc, 'dynamic_lib' => { 'OTHERLDFLAGS' => Apache::src->new->otherldflags, }, ); =back =head1 AUTHOR Doug MacEachern *[MOD_PERL1_25]LOG.DIR;1+, .E/A@ 4E-y 0123 KPWOF56k7k89GA@HJI  MAKEFILE.PL*[MOD_PERL1_25.LOG]MAKEFILE.PL;2+,.E/A@ 4gE- 0123KPWO56]pc7wPDBo89GA@HJuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; if ($^O eq 'VMS') { WriteMakefile( NAME => "Apache::Log", VERSION_FROM => "Log.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( NAME => "Apache::Log", VERSION_FROM => "Log.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; } *[MOD_PERL1_25.LOG]MAKEFILE.PL;1+,.E/A@ 4E- 0D123 KPWO56bq酟7酟89GA@HJ N $J)g7 %J)g7J)g7.  1%z1%z1%zuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; WriteMakefile( NAME => "Apache::Log", VERSION_FROM => "Log.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); *[MOD_PERL1_25]MAKEFILE.PL;2+,./A@ 4a-y 0D123KPWO56{;H7LwH89GA@HJN $J)g7 %J)g7J)g7J#!perl BEGIN { $Is_Win32 = ($^O eq "MSWin32"); $Is_Cygwin = ($^O =~ m/cygwin/g); $Is_VMS = ($^O eq "VMS"); if($Is_Win32) { require 5.004_02; } elsif($Is_Cygwin) { require 5.005_03; } else { require 5.003_97; } if ($Is_VMS) { $perl_cmd = "mcr $^X"; require VMS::Filespec; } else { $perl_cmd = $^X; } } sub MMN_130 () { 19980527 } use ExtUtils::MakeMaker; use Config (); use FileHandle (); use DirHandle (); use File::Compare (); use File::Basename qw(dirname); use File::Path qw(mkpath rmtree); use Cwd; use File::Copy qw(cp); use vmsish; #use Apache::ExtUtils qw(%Config); unless (%Config) { *Config = \%Config::Config; } my %vcache = (); #SERVER_VERSION my %mcache = (); #MODULE_MAGIC_NUMBER #version 1.5 that ships with 5.003 is broken! *cp = sub { system "cp @_"; for (@_) { -e $_ or die $! } } if $File::Copy::VERSION < 2.0; my $Is_dougm = (defined($ENV{USER}) && ($ENV{USER} eq "dougm")); my $USE_THREADS; my $thrlib = join '|', qw(-lpthread); if ($] < 5.005_60) { $USE_THREADS = (defined($Config{usethreads}) && ($Config{usethreads} eq "define")); } else { $USE_THREADS = (defined($Config{use5005threads}) && ($Config{use5005threads} eq "define")); } #hmm, seems the #include flip/flop isn't needed anymore #so ignore the stuff above for now $USE_THREADS = $ENV{PERL_USE_THREADS} || 0; require "./lib/mod_perl.pm"; $VERSION = $mod_perl::VERSION = $mod_perl::VERSION; { $VERSION =~ s/(\d\d)(\d\d)$/$1_$2/; } { local *FH; open FH, "Changes"; while() { if(/^=item.*-dev/) { $VERSION .= "-dev"; last; } last if /^=item/; } close FH; } use subs qw(iedit asrc); if($] < 5.004_04) { print < "Ben-SSL", "apache_ssl.c" => "Ben-SSL", "mod_ssl.h" => "Stronghold", "modules/modssl" => "Stronghold", ); unless (-e "t/docs/test.shtml") { cp "t/docs/test.html", "t/docs/test.shtml"; } for (qw(.htaccess hooks.txt)) { my $file = "t/docs/$_"; local *FH; open FH, ">$file" or die "can't write test file: $file: $!"; chmod 0666, $file; close FH; } chmod 0644, "t/conf/mod_perl_srm.conf"; mkdir "t/logs", 0777; chmod 0777, "t/logs"; unless ($Is_Win32 or $Is_VMS) { system "chmod a+x t/net/perl/* t/net/perl/io/*"; } #generated by us at one time or another my(@do_clean) = qw{ t/docs/.htaccess t/docs/hooks.txt src/Configuration lib/Apache/MyConfig.pm Apache/Apache.xs Constants/Constants.xs t/modules/ssi.t t/logs/error_log t/conf/srm.conf t/conf/dev-null t/logs/httpd.pid src/modules/perl/mod_perl_version.h t/net/perl/cgi.pl t/report t/httpd apaci/find_source apaci/apxs_cflags apaci/mod_perl.config }; #t/conf/httpd.conf #t/net/config.pl for(@do_clean) { unlink $_ } unless ($Is_Win32 or $Is_VMS) { rename "t/conf/httpd.conf", "t/conf/httpd.conf.old"; } rmtree "t/docs/stacked", 0, 0; gen_script("t/net/perl/cgi.pl"); gen_script("t/report"); gen_script("apaci/find_source"); gen_script("apaci/apxs_cflags"); write_version_h("src/modules/perl"); my(@test_pre_init) = qq( test_pre_init: ); # Automatic setup support my(@adirs, %seen, %mft_map, %vers_map, $src_dir, $vers, $conf, $ans); %vers_map = ( '1.1.1' => "Makefile.tmpl", '1.1.3' => "Makefile.tmpl", '1.2' => "Makefile.tmpl-1.2", '1.1.1Xcert-Sentry' => "Makefile.tmpl-XCert", '1.1.1Ben-SSL' => "Makefile.tmpl-Ben-SSL", '1.1.3Ben-SSL' => "Makefile.tmpl-Ben-SSL", '1.2Ben-SSL' => "", NONE => "", ); $LIBPERL = "DEFAULT"; $USE_APACI = $USE_DSO = $USE_APXS = 0; $WITH_APXS = ""; $APACI_ARGS = ""; @APACI_ARGS = (); $EVERYTHING = $EXPERIMENTAL = 0; $PERL_DEBUG = ""; $PERL_DESTRUCT_LEVEL = ""; $PERL_STATIC_EXTS = ""; $PERL_USELARGEFILES = 1; $PERL_EXTRA_CFLAGS = ""; $EXTRA_CFLAGS = "_INCLUDE_APACHE_FIRST,DONT_MASK_RTL_CALLS,PERL_TRACE" if ($Is_VMS); $PERL_EXTRA_LIBS = ""; $SSLCacheServerPort = 8539; $SSL_BASE = ""; $Port = $ENV{HTTP_PORT} || 8529; #so Doug can 'make test' different-builds@sametime/samebox if(!$Is_Win32 and !$Is_VMS and $ENV{RANDOM_PORT} and $$ > 8000 and $$ < 30000) { $PORT ||= $$; print "I'll use Port $PORT\n"; } $PORT ||= $Port; $TARGET = ""; $DO_HTTPD = $ENV{DO_HTTPD} || 0; $NO_HTTPD = $ENV{NO_HTTPD} || ($^O eq 'VMS' ? 1 : 0); $PREP_HTTPD = ($^O eq 'VMS' ? 1 : 0); $PERL_TRACE = 0; $ALL_HOOKS = 0; $APACHE_SRC = ""; $APACHE_PREFIX = ""; $APACHE_HEADER_INSTALL = 1; $PERL_SECTIONS = 0; $PERL_SSI = 0; $ADD_VERSION = 1; $STATIC = 1; $DYNAMIC = ($^O eq 'VMS' ? 1 : 0); $CONFIG = ""; $ADD_MODULE = ""; $PERL_DIRECTIVE_HANDLERS = 0; $PERL_TABLE_API = 0; $PERL_LOG_API = 0; $PERL_URI_API = 0; $PERL_UTIL_API = 0; $PERL_FILE_API = 0; $PERL_CONNECTION_API = 1; #these two were split out late in the game $PERL_SERVER_API = 1; #so they are on by default $PERL_RUN_XS = 0; my %experimental = map { $_,1 } qw{ PERL_AUTOPRELOAD PERL_DSO_UNLOAD PERL_STARTUP_DONE_CHECK PERL_RUN_XS PERL_MARK_WHERE DO_INTERNAL_REDIRECT PERL_TIE_SCRIPTNAME PERL_STASH_POST_DATA XS_IMPORT PERL_SAFE_STARTUP PERL_DEFAULT_OPMASK PERL_ORALL_OPMASK }; my %PassEnv = map { $_,1 } qw(SSL_BASE); my @mp_args = (keys %PassEnv, qw(EXPERIMENTAL EVERYTHING DO_HTTPD NO_HTTPD CONFIG ADD_MODULE APACHE_PREFIX USE_APACI USE_DSO USE_APXS WITH_APXS APACI_ARGS PREP_HTTPD ALL_HOOKS ADD_VERSION STATIC DYNAMIC PORT XS_IMPORT)); sub is_mp_arg { my $arg = shift; return 1 if $experimental{$arg}; for (@mp_args) { return 1 if $arg eq $_; } return 0; } #callback hooks @callback_hooks = qw{ PERL_DISPATCH PERL_CHILD_INIT PERL_CHILD_EXIT PERL_POST_READ_REQUEST PERL_TRANS PERL_HEADER_PARSER PERL_ACCESS PERL_AUTHEN PERL_AUTHZ PERL_TYPE PERL_FIXUP PERL_HANDLER PERL_LOG PERL_INIT PERL_CLEANUP PERL_RESTART PERL_STACKED_HANDLERS PERL_METHOD_HANDLERS PERL_DIRECTIVE_HANDLERS PERL_TABLE_API PERL_LOG_API PERL_URI_API PERL_UTIL_API PERL_FILE_API PERL_CONNECTION_API PERL_SERVER_API }; $callback_alias{PERL_INIT} = "PERL_HEADER_PARSER"; $callback_alias{PERL_CLEANUP} = "PERL_LOG"; %callback_hooks = map { $_,0 } @callback_hooks; $callback_hooks{PERL_HANDLER} = 1; #PerlHandler always on %cant_hook = (); my @mm_args; { my($fh,$file); for (qw(./ ../ ./. ../.), "$ENV{HOME}/.") { last if $fh = FileHandle->new($file = $_."makepl_args.mod_perl"); } if($fh) { print "Reading Makefile.PL args from $file\n"; while(<$fh>) { chomp; s/^\s+//; s/\s+$//; next if /^#/ || /^$/; last if /^__END__/; if(/^APACI_ARGS/) { s/^APACI_ARGS=//; push @APACI_ARGS, $_; } else { unshift @ARGV, split /\s+/, $_; } } close $fh; } if(@APACI_ARGS) { unshift @ARGV, "APACI_ARGS=" . join(",", @APACI_ARGS); } } my $vcpp = ($Config{cc} =~ /^cl(\.exe)?$/); my %win32_args; my %win32_accept = map {$_ => 1} qw(APACHE_SRC INSTALL_DLL DEBUG EAPI); while($_ = shift) { ($k,$v) = split /=/, $_, 2; if ($vcpp) { if ($win32_accept{$k}) { $win32_args{$k} = ($k eq 'DEBUG' or $k eq 'EAPI') ? 1 : $v; } else { push @mm_args, $_; } next; } unless (/^(PERL|APACHE)/ or is_mp_arg($k)) { push @mm_args, $_; } $v = 1 unless defined $v; if($experimental{$k}) { $experimental{$k}++; $PERL_EXTRA_CFLAGS .= " -D${k}=1"; } ${$k} = $v, next if defined ${$k}; $callback_hooks{$k} = $v if exists $callback_hooks{$k}; } my $win32_auto = ($vcpp and $win32_args{APACHE_SRC}) ? 1 : 0; my %very_experimental = map {$_,1} qw(PERL_DEFAULT_OPMASK PERL_SAFE_STARTUP PERL_ORALL_OPMASK PERL_STARTUP_DONE_CHECK PERL_DSO_UNLOAD); if($EXPERIMENTAL) { for (keys %experimental) { next if $very_experimental{$_}; #have to *really* ask for this one next if $experimental{$_}++ > 1; $PERL_EXTRA_CFLAGS .= " -D$_=1"; } } if($experimental{PERL_DEFAULT_OPMASK} > 1) { $experimental{PERL_SAFE_STARTUP} = 2; $PERL_EXTRA_CFLAGS .= " -DPERL_SAFE_STARTUP=1"; } if ($PERL_USELARGEFILES and $] >= 5.006) { $PERL_EXTRA_CFLAGS .= " $Config{ccflags}"; } for (keys %PassEnv) { $ENV{$_} = $$_ if $$_; } $USE_APACI = 1 if $USE_DSO; if(0) { #if($USE_DSO or $USE_APXS and !$DO_HTTPD) { print "*" x 65, $/; print <, <../stronghold*/src>, , "../src", "./src") { next unless -d $src_dir; next if $seen{$src_dir}++; next unless $vers = httpd_version($src_dir); unless(exists $vers_map{$vers}) { print STDERR "Apache version '$vers' unsupported\n"; next; } $mft_map{$src_dir} = $vers_map{$vers}; #print STDERR "$src_dir -> $vers_map{$vers}\n"; push @adirs, $src_dir; $modified{$src_dir} = (stat($src_dir))[9]; last if $DO_HTTPD; } unless (@adirs) { print "Enter `q' to stop search\n"; while(1) { print "Please tell me where I can find your apache src\n" ; $src_dir = prompt("", $APACHE_SRC_DEFAULT); last if $src_dir eq "q"; if(-d $src_dir) { push(@adirs, $src_dir); $mft_map{$src_dir} = $vers_map{httpd_version($src_dir)}; last; } else { print "Can't stat `$src_dir'\n"; } } } } if($PERL_EXTRA_CFLAGS) { $PERL_EXTRA_CFLAGS = join(" ", split(",", $PERL_EXTRA_CFLAGS)); $PERL_EXTRA_CFLAGS =~ s/\s+/ /g; } if($PERL_DEBUG) { my $lib = "$Config{archlibexp}/CORE/libperld$Config{lib_ext}"; if (-e $lib) { $LIBPERL = "-lperld"; $libperl = " -- $LIBPERL"; } $PERL_EXTRA_CFLAGS .= " -g"; $PERL_TRACE=1; $PERL_DESTRUCT_LEVEL=2; print "DEBUG mode...\n"; print "...adding `-g' to EXTRA_CFLAGS\n"; print "...turning on PERL_TRACE\n"; print "...setting PERL_DESTRUCT_LEVEL=2\n"; print "...linking against libperld\n" if $libperl; sleep(1); } $PERL_EXTRA_CFLAGS .= " -DPERL_DESTRUCT_LEVEL=$PERL_DESTRUCT_LEVEL" if $PERL_DESTRUCT_LEVEL; for $adir (sort {$modified{$b} <=> $modified{$a}} @adirs) { $conf = "$adir/$Configuration"; $httpd_h = asrc($adir)."/httpd.h"; if (-e $httpd_h) { unless($NO_HTTPD and not $DYNAMIC and not $PREP_HTTPD) { unless($DO_HTTPD) { $ans = prompt("Configure mod_perl with $adir ?", "y"); next unless $ans =~ /^y$/i; } $APACHE_SRC = $adir; $IsBenSSL = -e "$adir/apache_ssl.c"; last unless(-e $conf || -e "$conf.tmpl"); #building from 'make offsite-tar' } #++$NO_HTTPD if $USE_APACI; my $mmn = magic_number($APACHE_SRC); if(($mmn < MMN_130) and $USE_APACI) { #1.3.0 print "Sorry, need 1.3.0+ for USE_APACI\n"; $USE_APACI = $USE_DSO = 0; } for my $api (qw(LOG URI UTIL FILE TABLE)) { local $_ = join "_", "PERL", $api, "API"; if(($mmn < MMN_130) and $$_) { #1.3.0 $$_ = 0; $cant_hook{$_} = "(need 1.3.0 or higher)"; } } if($USE_DSO and $PERL_SSI) { $PERL_SSI=0; $cant_hook{PERL_SSI} = "(doesn't work w/ USE_DSO=1)"; } unless ($DO_HTTPD or $NO_HTTPD) { $ans = prompt("Shall I build httpd in $adir for you?", "y"); ++$NO_HTTPD, ++$PREP_HTTPD unless $ans =~ /^y$/i; } if($NO_HTTPD) { #must generate Makefile.config for 1.3bx unless (-e "$adir/Makefile.config") { my $cfgfile = $CONFIG ? $CONFIG : "Configuration"; print "(cd $adir && ./Configure -file $cfgfile)"; } } #copy the source files if(!$NO_HTTPD or $USE_APACI or $PREP_HTTPD) { mkpath "$adir/modules/perl"; #ignore make's output here if ($Is_VMS) { `if f\$search(\"perl_clean.com\") .nes. \"\" then \@perl_clean \"$adir/modules/perl\"`; } else { `(cd $adir/modules/perl && make clean 2> /dev/null)`; } local(*MANI); open MANI, "MANIFEST" or die "open MANIFEST $!"; my $atopdir = dirname($adir); unlink "$atopdir/perlxsi.c"; #only rm and cp files mod_perl ships with while() { next unless m,^src/modules/perl/,; chomp; #print "rm -f $adir/$_\n"; unlink "$atopdir/$_"; next if not m,.+\.(xs|c|h)$, and $USE_APACI; next if $DYNAMIC and /\.xs$/; #print "cp $_ $atopdir/$_\n" if $USE_APACI; my $dest = "$atopdir/$_"; cp $_, $dest; #$mani_src{$_}++; } close MANI; cp "src/modules/perl/mod_perl_version.h", "$atopdir/src/modules/perl/mod_perl_version.h"; if($USE_APACI) { open MANI, "MANIFEST" or die "open MANIFEST $!"; while() { next unless m,^apaci/,; chomp; (my $to = $_) =~ s,^apaci/,src/modules/perl/,; unlink "$atopdir/$to"; print "cp $_ $atopdir/$to\n"; my $dest = "$atopdir/$to"; cp $_, $dest; chmod 0755, $dest if -x $_; } close MANI; } } ($APACHE_ROOT = $APACHE_SRC) =~ s,/src/?$,,; last if $NO_HTTPD; # or $USE_APACI; unless(-e "src/Configuration" and (-M "src/Configuration" < -M $conf) and not $USE_APACI) { unless(-e $conf) { cp "$conf.tmpl", $conf; } cp $conf, "src/Configuration"; $conf = "src/Configuration"; conf_fixup("$adir/Makefile.tmpl", $conf); } } if ($NO_HTTPD) { } elsif($USE_APACI) { #take care of things later } else { $conf = "src/Configuration"; my($dash_make, $cfgfile); $dash_make = " -make $PWD/src/$mft_map{$adir} " if $can_dash_make{asrc $adir} and $mft_map{$adir}; #print STDERR "(cd $adir; ./Configure${dash_make} -file $PWD/$conf)\n"; $cfgfile = $CONFIG ? $CONFIG : "$PWD/$conf"; $dash_make ||= ""; system "(cd $adir && ./Configure${dash_make} -file $cfgfile)"; open FH, "$APACHE_SRC/Makefile" or die "can't open $APACHE_SRC/Makefile $!"; while() { $SSL_BASE ||= $1 if /^\s*SSL_BASE\s*=\s*(.*)/; $EXTRA_CFLAGS = $1 if /CFLAGS1\s*=\s*(.*)/; $SSLINCS = $1 if /SSLINCS\s*=\s*(.*)/; } close FH; if($SSL_BASE) { $SSL_INCLUDE = " -I$SSL_BASE/include "; $SSL_CFLAGS = "-DAPACHE_SSL $SSL_INCLUDE"; } #stronghold if($SSLINCS) { $SSL_INCLUDE = " $SSLINCS "; $SSL_CFLAGS = "-DAPACHE_SSL $SSL_INCLUDE"; } } print "EXTRA_CFLAGS: $EXTRA_CFLAGS\n" if $EXTRA_CFLAGS; print "SSL_CFLAGS: $SSL_CFLAGS\n" if $SSL_CFLAGS; last if $APACHE_SRC; } if($PERL_DIRECTIVE_HANDLERS) { push @xs_modules, "Apache::ModuleConfig"; $callback_hooks{PERL_DIRECTIVE_HANDLERS} = 1; } #if($PERL_RUN_XS or $experimental{PERL_RUN_XS} > 1) { if (0) { my $mmn = $USE_APXS ? MMN_130 : magic_number($APACHE_SRC); if($mmn >= MMN_130) { push @xs_modules, "Apache::PerlRunXS"; } else { $PERL_RUN_XS = 0; $experimental{PERL_RUN_XS} = 0; print "Sorry, need 1.3.0+ for Apache::PerlRunXS\n"; } } for (qw(Log URI Util Connection Server File Table)) { my $s = "PERL_".uc($_)."_API"; if($$s or $Is_Win32) { push @xs_modules, "Apache::$_"; $callback_hooks{$s} = 1; } } my @xs_mod_snames = map { (my $s = $_) =~ s/.*:://; $s } @xs_modules; win32_setup() if $Is_Win32; if($DYNAMIC) { print "Will build Apache::* extensions dynamic\n"; for (@xs_mod_snames) { cp "src/modules/perl/${_}.xs", "${_}/${_}.xs"; } } if($APACHE_SRC or $USE_APXS) { ++$STATIC if grep { $_ eq lc($Config{osname}) } qw(aix svr4 unixware); my $mmn = $USE_APXS ? MMN_130 : magic_number($APACHE_SRC); my $httpdv = $USE_APXS ? 130 : httpd_version($APACHE_SRC,1); unless($httpdv >= 130) { phat_warn("Apache Version 1.3.0 required, aborting..."); exit(1); } if($httpdv >= 130) { if($callback_hooks{PERL_CHILD_INIT}) { $My::child_init++; } } else { $callback_hooks{PERL_CHILD_INIT} = 0; $cant_hook{PERL_CHILD_INIT} = "(need 1.3.0 or higher)"; } if($mmn >= 19970728) { $callback_hooks{PERL_CHILD_EXIT} = $My::child_exit = $callback_hooks{PERL_CHILD_INIT} = $My::child_init = 1; } else { $callback_hooks{PERL_CHILD_EXIT} = 0; $cant_hook{PERL_CHILD_EXIT} = "(need 1.3.0 or higher)"; } unless($mmn >= 19970825) { $callback_hooks{PERL_POST_READ_REQUEST} = O1~MOD_PERL1_25_MUP.SAVEy OD_PERL1_25]MAKEFILE.PL;2a@&0; $cant_hook{PERL_POST_READ_REQUEST} = "(need 1.3.0 or higher)"; } setup_for_static() unless $USE_APXS; iedit "$APACHE_SRC/modules/perl/Makefile", "s!^PERL\\s*=.*!PERL=$Config{'perlpath'}!" unless $USE_APACI or $USE_APXS; for (@callback_hooks) { ($k,$v) = ($_,$callback_hooks{$_}); unless ($USE_APACI or $USE_APXS) { iedit "$APACHE_SRC/modules/perl/Makefile", "s/^$k /#$k /" if $v; } $why = ($cant_hook{$k} || "(enable with $k=1)") unless $v; $k =~ s/([A-Z]+)/ucfirst(lc($1))/ge; $k =~ s/_//g; $k .= "Handler" unless $k =~ /(Api|Table|Handler)s?$/; push @mod_perl_hooks, $k; print $k . '.' x (28 - length($k)); print $v ? "enabled\n" : "disabled $why\n"; } unless($httpdv >= 120) { $PERL_SECTIONS = $PERL_SSI = 0; $cant_hook{PERL_SECTIONS} = $cant_hook{PERL_SSI} = "(need 1.2.0 or higher)"; } for (qw(PERL_SECTIONS PERL_SSI), keys %experimental) { $k = $_; if($experimental{$_}) { next unless $experimental{$_} > 1; print $k . '.' x (28 - length($k)); print "enabled (experimental)"; } else { $why = ($cant_hook{$_} || "(enable with $k=1)") unless $$_; $k =~ s/([A-Z]+)/ucfirst(lc($1))/ge; $k =~ s/_//g; $k =~ s/Ssi$/SSI/; #*shrug* push @mod_perl_hooks, $k; print $k . '.' x (28 - length($k)); print $$_ ? "enabled" : "disabled $why\n"; } print "\n"; unless ($USE_APACI or $USE_APXS) { iedit "$APACHE_SRC/modules/perl/Makefile", "s/^($_) /#\$1 /" if $$_; } } unless ($USE_APACI or $USE_APXS) { iedit "$APACHE_SRC/modules/perl/Makefile", "s/^#TRACE/TRACE/" if $PERL_TRACE; } my $ssl_name = is_ssl(); if($ssl_name) { print "I see you are building with $ssl_name,\nI'll set the SSL flags in mod_perl's Makefile\n"; if($ssl_name =~ /stronghold/i) { my $skey; my $lfile; my $conf = "$APACHE_SRC/../conf/httpd.conf"; if(-e $conf) { open FH, $conf; while() { chomp; if(/^StrongholdKey/) { $skey = $_; last; } elsif(s/^StrongholdLicenseFile\s+//) { $lfile = $_; unless ($lfile =~ m:^/:) { $lfile = "$PWD/$APACHE_SRC/../$lfile"; } } } close FH; } if($skey) { $StrongholdKey = $skey; print "Using $skey for 'make test'\n"; } elsif(-e $lfile) { $StrongholdKey = join " ", "StrongholdLicenseFile", $lfile; print "Using $StrongholdKey for 'make test'\n"; } else { print "Before running `make test', ", "you must add your `StrongholdLicenseFile' to t/conf/httpd.conf\n"; } } unless ($USE_APACI or $USE_APXS) { iedit "$APACHE_SRC/modules/perl/Makefile", "s:^#APACHE_SSL.*:APACHE_SSL = $SSL_CFLAGS:"; } } #my $incdir = ($mmn >= 19970825) ? "../../main" : "../.."; my $minc = asrc($APACHE_SRC); $minc =~ /(main|include)/; my $incdir = $1 ? "../../$1" : "../.."; my $edit_note = quotemeta(<= 19970912 and not $USE_APACI and not $USE_APXS) { #1.3b1 if ($Is_VMS) { my $file1 = VMS::Filespec::vmsify("$APACHE_SRC/makefile.config"); my $file2 = VMS::Filespec::vmsify("$APACHE_SRC/modules/perl/Makefile"); if (-e $file1 and -e $file2) { system "copy $file1,$file2 $file2"; } else { open APACHE_CONF, "<$APACHE_SRC/configuration."; open PERL_CONF, $file2; while () { next if /^\s*#/; next unless /=/; print PERL_CONF $_; } close APACHE_CONF; close PERL_CONF; } } else { system "cat $APACHE_SRC/Makefile.config $APACHE_SRC/modules/perl/Makefile > /tmp/mpmf.$$"; system "mv /tmp/mpmf.$$ $APACHE_SRC/modules/perl/Makefile"; } } if($callback_hooks{PERL_TRANS}) { push @test_pre_init, "\t", '$(CP) t/conf/mod_perl_srm.conf t/conf/srm.conf', "\n"; } unless ($USE_APXS) { unless (-l "t/httpd") { if ($Is_VMS) { cp("$APACHE_SRC/httpd", "t/httpd"); } else { system "$Config{lns} $APACHE_SRC/httpd t/httpd"; } } write_extra_tests(); } } unless (-e "t/net/config.pl") { cp "t/net/config.pl.dist", "t/net/config.pl"; } init_config_pl() if $Is_Win32; my (%win32_path); if ($win32_auto) { require File::Spec; win32_inc_and_lib(); win32_fix_dsp(); } write_my_config($APACHE_SRC); unless($Is_Win32 or $Is_VMS or -e "t/conf/httpd.conf" or ($NO_HTTPD && !$PREP_HTTPD)) { init_tests_and_config(); } init_tests_and_config() if $USE_APXS; sub init_config_pl { my $mmn = magic_number($APACHE_SRC) || 0; my $hf = FileHandle->new(">>t/net/config.pl") or die "can't open t/net/config.pl $!"; my $apaci_cfg = APACI->init; my($k,$v); my(%all) = %callback_hooks; while (($k,$v) = each %experimental) { $all{$k} = ($experimental{$k} > 1) ? 1 : 0; } print $hf "%callback_hooks = (\n"; while (($k,$v) = each %all) { print $hf " $k => $v,\n"; my $yes_no = $v ? "yes" : "no"; print $apaci_cfg "$k = $yes_no\n" if $apaci_cfg; } print $hf " MMN => $mmn,\n"; print $hf " USE_DSO => 1,\n" if $USE_DSO; print $hf ");\n1;\n"; $hf->close; $apaci_cfg->close if $apaci_cfg; } sub init_tests_and_config { local *FH; open FH, ">t/conf/dev-null"; print FH "#mod_ssl has a problem with /dev/null\n"; close FH; cp "t/conf/httpd.conf-dist", "t/conf/httpd.conf"; chmod 0644, "t/conf/httpd.conf"; $uid = $>; $gid = $); #use only first value if $) contains more than one $gid =~ s/^(\d+).*$/$1/; $User = $Is_Win32 ? "nobody" : $ENV{APACHE_USER} || (getpwuid($uid) || "#$uid"); $Group = $Is_Win32 ? "nogroup" : $ENV{APACHE_GROUP} || (getgrgid($gid) || "#$gid"); if($User eq "root") { my $other = (getpwnam('nobody'))[0]; $User = $other if $other; } if($User eq "root") { print "Cannot run tests as User `$User'\n"; $User = prompt("Which User?", "nobody"); $Group = prompt("Which Group?", $Group); } print STDERR "Will run tests as User: '$User' Group: '$Group'\n"; if($Port != $PORT) { iedit "t/conf/httpd.conf", "s/^(Port) .*/\$1 $PORT/"; iedit "t/net/config.pl", "s/$Port/$PORT/;"; } if($experimental{PERL_SAFE_STARTUP} > 1) { if($experimental{PERL_DEFAULT_OPMASK} < 2) { iedit "t/conf/httpd.conf", "s/^#(PerlOpmask)/\$1/"; } } init_config_pl(); if($USE_APACI and not $PREP_HTTPD and not $USE_APXS) { my $shrpenv = $Config{shrpenv} || ""; $shrpenv .= ' ' if $shrpenv; my $cmd = "CC=\"${shrpenv}$Config{cc}\" "; if($PERL_EXTRA_CFLAGS) { $cmd .= qq(CFLAGS="$PERL_EXTRA_CFLAGS" ); } if ($USE_DSO) { # override apache's notion of this flag $cmd .= qq(LDFLAGS_SHLIB_EXPORT="$Config{ccdlflags}" ); #if Perl is linked with -lpthread, httpd needs tobe too if ($Config{libs} =~ /($thrlib)/) { $PERL_EXTRA_LIBS .= " $1"; } } if ($PERL_EXTRA_LIBS) { $cmd .= qq(LIBS="$PERL_EXTRA_LIBS" ); } $cmd .= "./configure " . "--activate-module=src/modules/perl/libperl.a"; # Do not disable the rule EXPAT for Stronghold, since this # rule is not implementated yet and breaks the configure process. if(is_ssl() !~ /stronghold/i) { $cmd .= " --disable-rule=EXPAT"; } if($USE_DSO) { $cmd .= " --enable-shared=perl"; } if($APACI_ARGS) { $cmd .= " " . join " ", split(',', $APACI_ARGS); } if($APACHE_PREFIX and $APACI_ARGS !~ /--prefix=/) { $cmd .= " --prefix=$APACHE_PREFIX"; } if ($APACI_ARGS =~ /--target=(\S+)/) { $TARGET = $1; } if($ADD_MODULE) { for (split ",", $ADD_MODULE) { if(/^([a-zA-Z0-9][a-zA-Z0-9_]+)$/) { $cmd .= " --enable-module=$1"; } elsif(m:(src/modules/[^/]+/[^/]+)$:) { $cmd .= " --activate-module=$1"; } } } print "(cd $APACHE_ROOT && $cmd)\n"; system "(cd $APACHE_ROOT && $cmd)"; } if($USE_APXS) { my $cmd = "./configure --with-perl=$^X"; $cmd .= " --with-apxs=$WITH_APXS" if $WITH_APXS; system "(cd apaci && $cmd)"; } #expand ./t to full path iedit "t/conf/httpd.conf", "s: \./t(\\S*): $PWD/t\$1:"; for (qw(User Group)) { iedit "t/conf/httpd.conf", "s/^$_ .*/$_ $$_/"; } conf_append(<= 121 or $mmn >= MMN_130; conf_append("PerlChildInitHandler My::child_init") if $My::child_init; conf_append("PerlChildExitHandler My::child_exit") if $My::child_exit; conf_append("PerlTransHandler My::ProxyTest") if $callback_hooks{PERL_TRANS} and $callback_hooks{PERL_STACKED_HANDLERS} and $mmn > 19980270 and $Is_dougm; conf_append(< SetHandler perl-script PerlHandler Stacked::one Stacked::two Stacked::three Stacked::four EOF } { (my $pmv = $VERSION) =~ s/_//g; $pmv =~ s/-dev$//; my $hooks = "@mod_perl_hooks"; my $dummy = "hooks=`$hooks'\n" unless $hooks; my $mph = $Is_VMS ? "lib/mod_perl_hooks.pm_pl" : "lib/mod_perl_hooks.pm.PL"; cp $mph, "lib/mod_perl_hooks.pm"; iedit "lib/mod_perl_hooks.pm", qq(s/sub mod_perl::hooks.*/sub mod_perl::hooks { qw($hooks) }/); require "lib/mod_perl_hooks.pm"; my @list = mod_perl::hooks(); if ($Is_Cygwin) { } else { @list == @mod_perl_hooks or die "Edit of lib/mod_perl_hooks.pm failed $!\n"; } unlink "lib/mod_perl_hooks.pm~"; } #checking for LWP code, borrowed from LWP's own Makefile.PL :-) unless ($Is_Win32) { print "Checking CGI.pm VERSION.........."; eval { require CGI; }; if($CGI::VERSION >= 2.39) { print "ok\n"; } else { print "I suggest upgrading from $CGI::VERSION to 2.39+\n"; sleep 2; } print "Checking for LWP::UserAgent......"; eval { require LWP::UserAgent; }; if ($@) { $no_lwp++; $missing_modules++; print "failed\n"; print <t/docs/blib.pl"; print FH "use lib qw(\n", (map { "$PWD/$_\n" } qw(blib/lib blib/arch)), ");\n1;\n"; close FH; for my $f (qw(.htaccess hooks.txt)) { open FH, ">t/docs/$f"; print FH " "; close FH; chmod 0666, "t/docs/$f";#make sure httpd can write to it } if($PERL_SSI) { cp "t/modules/ssi.test", "t/modules/ssi.t"; } else { unlink "t/modules/ssi.t"; # might be there from prior run } mkdir "t/docs/subr", 0755; if ($Is_VMS) { open TMP, "> t/docs/subr/index.html"; print TMP scalar(time()); close TMP; } else { system "date > t/docs/subr/index.html"; } return unless $callback_hooks{PERL_STACKED_HANDLERS} and $callback_hooks{PERL_FIXUP}; local *FH; my $meth_test; if($callback_hooks{PERL_METHOD_HANDLERS}) { $meth_test = <<'EOF'; #see startup.pl PerlFixupHandler MyClass->method PerlFixupHandler $MyClass::Object->method PerlFixupHandler MyClass PerlFixupHandler LoadClass PerlFixupHandler LoadClass->method EOF } my $dir = "t/docs/stacked"; mkdir $dir, 0755; cp "t/docs/test.html", $dir; open FH, ">$dir/.htaccess"; print FH < \@DIR, NAME => "mod_perl", VERSION => $VERSION, ($] < 5.005 ? () : ( ABSTRACT => 'Embed a Perl interpreter in the Apache HTTP server', AUTHOR => 'Doug MacEachern ', )), #should override `CCFLAGS', can't with older perls #CCDLFLAGS => "$Config{ccdlflags} $EXTRA_CFLAGS", DEFINE => $EXTRA_CFLAGS, macro => { PERL => $Config{'perlpath'}, OPCODE_FILE => "src/opcodes.txt", APACHE_ROOT => $APACHE_ROOT, APACHE_SRC => $APACHE_SRC, ARCHNAME => $Config{archname}, HTTPD => $TARGET, PORT => $PORT, PWD => $PWD, PERL5LIB => "PERL5LIB=$ENV{PERL5LIB}", SHRPENV => $Config{shrpenv}, CVSROOT => 'perl.apache.org:/home/cvs', }, 'dist' => { COMPRESS=> 'gzip -9f', SUFFIX=>'gz', CI => qq(ci -u -m\\"See Changes file\\"), }, clean => { FILES => "@do_clean", } ); if ($Is_Win32) { print <<'END'; Beginning with version 1.3.15, Apache uses a different convention for Win32 module names. Correspondingly, the name of the mod_perl module built here has been changed from ApacheModulePerl.dll to mod_perl.so. Please see INSTALL.win32 for further details. END } print "*** BSDI users: be sure to read the INSTALL `Notes' section ***\n" if $Config{osname} =~ /bsdos/i; cleanup_for_static(); sub MY::dist_basics { my $self = shift; my $string = $self->MM::dist_basics; if($USE_APXS) { $string =~ s/(distclean\s+::\s+)/$1 apxs_distclean /; } return $string; } sub MY::clean { my $self = shift; my $string = $self->MM::clean(@_); if ($win32_auto) { $string .= sprintf qq{\tmsdev src\\modules\\win32\\mod_perl.dsp \\\n} . qq{\t/MAKE "mod_perl - Win32 %s" /CLEAN\n}, ($win32_args{DEBUG} == 1) ? 'Debug' : 'Release'; return $string; } unless($NO_HTTPD) { my $asrc = asrc($APACHE_SRC, "http_main.c"); return $string unless $APACHE_SRC and -e "$asrc/http_main.c"; $string .= "\t-cd \$(APACHE_SRC) && \$(MAKE) clean\n"; } if($USE_APXS) { $string .= "\t-cd ./apaci && \$(MAKE) clean\n"; } $string; } sub MY::install { my $self = shift; my $string = $self->MM::install; my $add = ""; if($USE_APXS) { $add = "apxs_install"; } elsif ($win32_auto and $win32_args{INSTALL_DLL}) { $add = 'amp_install'; } elsif($USE_APACI) { if($APACI_<FARGS =~ /--prefix=/ or $APACHE_PREFIX) { $add = "apaci_install"; } } if($add and (!$NO_HTTPD and !$PREP_HTTPD) or $USE_APXS or $win32_auto) { $string =~ s/(pure_install\s+)(.*)/$1 $add $2/; } return $string; } sub MY::top_targets { my $self = shift; my $string = $self->MM::top_targets; return $string unless $USE_APXS or $USE_APACI or $APACHE_SRC or $win32_auto; if ($win32_auto) { $string =~ s/(pure_all\s+::.*\s+subdirs\s+)(.*)/$1 amp_dll $2/; $string .= sprintf qq{\namp_dll:\n} . qq{\tmsdev src\\modules\\win32\\mod_perl.dsp \\\n} . qq{\t/MAKE "mod_perl - Win32 %s" /USEENV\n}, ($win32_args{DEBUG} == 1) ? 'Debug' : 'Release'; if ($win32_args{INSTALL_DLL}) { $string .= sprintf qq{\namp_install:\n\t\$(CP) "%s" "%s"}, "$win32_path{MODPERL_LIB}/mod_perl.so", $win32_args{INSTALL_DLL} . ($win32_args{APACHE_VERS} < 1315 ? '/ApacheModulePerl.dll' : '/mod_perl.so'); } return $string; } if($USE_APXS) { $string =~ s/(pure_all\s+::\s+)(.*)/$1 apxs_libperl $2/; } elsif($USE_APACI and !$PREP_HTTPD) { $string =~ s/(pure_all\s+::\s+)(.*)/$1 apaci_httpd $2/; } elsif($APACHE_SRC) { return $string unless -f "$APACHE_SRC/$Configuration"; my $asrc = asrc($APACHE_SRC, "http_main.c"); if(-e "$asrc/http_main.c" and !$NO_HTTPD) { $string =~ s/(pure_all\s+::\s+)(.*)/$1 apache_httpd $2/; } } $string .= <<'EOF'; gen_exports: $(PERL) -I./lib -MExtUtils::testlib -MApache::Constants::Exports \ -e 'Apache::Constants::Exports->gen_ctags' > Exports.c gen_op_mask: $(PERL) -MExtUtils::testlib -MApache::Opcode \ -e 'Apache::Opcode->gen_op_mask' -- $(OPCODE_FILE) > op_mask.c update_op_mask: gen_op_mask @$(RM_F) $(APACHE_SRC)/modules/perl/mod_perl_opmask.o $(CP) op_mask.c $(APACHE_SRC)/modules/perl/op_mask.c apxs_distclean: (cd ./apaci && $(MAKE) distclean) apxs_libperl: (cd ./apaci && $(PERL5LIB) $(MAKE)) apxs_install: apxs_libperl (cd ./apaci && $(MAKE) install;) apache_httpd: $(APACHE_SRC)/Makefile.tmpl (cd $(APACHE_SRC) && $(PERL5LIB) $(SHRPENV) $(MAKE) CC="$(CC)";) apaci_httpd: (cd $(APACHE_ROOT) && $(PERL5LIB) $(MAKE)) apaci_install: (cd $(APACHE_ROOT) && $(MAKE) install) tar_Apache: (cd $(INSTALLSITELIB)/$(ARCHNAME); \ $(TAR) -cf $(PWD)/Apache.tar mod_perl.pm Apache.pm Apache $(ARCHNAME)/auto/Apache; ) offsite-tar: $(CP) MANIFEST MANIFEST.orig $(PERL) -e 'for (<$(APACHE_SRC)/*.h>) {' \ -e 'system "$(CP) $$_ src/";' \ -e 's,^$(APACHE_SRC),,;' \ -e 'system "echo src$$_ >> MANIFEST";' \ -e '}' $(MAKE) dist $(RM_F) src/*.h $(MV) MANIFEST.orig MANIFEST EOF $string; } sub MY::pasthru { # VMS needs something here for this to work if (!$APACHE_SRC and $Is_VMS) { return "PASTHRU=DUMMY=1"; } return unless $APACHE_SRC; my $self = shift; chomp(my $str = $self->MM::pasthru); join $/, "$str,\\", "\t".'APACHE_SRC="$(APACHE_SRC)",\\', "\t".'DEFINE="$(DEFINE)"', ""; } sub MY::test { my $self = shift; my $test = $self->MM::test; my $mmn = magic_number($APACHE_SRC); return <<'EOF' if $USE_APXS and not $Is_dougm; test: @echo "Can't make test with APXS (yet)" EOF return <<'EOF' if $USE_DSO and ($mmn <= 19980527) and not $Is_dougm; test: @echo "Can't make test with DSO (yet)" EOF my $script = "t/TEST"; $script .= ".win32" if $Is_Win32; my $my_test = $Is_Win32 ? q( test: run_tests ) : q( test: pure_all start_httpd run_tests kill_httpd ); my $have_so = $USE_DSO || ($APACI_ARGS =~ /--enable-shared=/); push @test_pre_init, "\t", './apaci/load_modules.pl $(APACHE_SRC)', "\n" if $have_so; join '', @test_pre_init, qq( MP_TEST_SCRIPT=$script ), q( TEST_VERBOSE=0 kill_httpd: kill `cat t/logs/httpd.pid` @$(RM_F) t/conf/srm.conf @$(RM_F) t/logs/mod_perl.lock* $(RM_F) t/logs/httpd.pid $(RM_F) t/logs/error_log start_httpd: test_pre_init @(cd t/conf; test -f httpd.conf || cp httpd.conf-dist httpd.conf) @(cd t/net; test -f config.pl || cp config.pl.dist config.pl) @$(TOUCH) t/conf/srm.conf $(APACHE_SRC)/$(HTTPD) -f `pwd`/t/conf/httpd.conf -X -d `pwd`/t & @echo httpd listening on port $(PORT) @echo will write error_log to: t/logs/error_log @echo "letting apache warm up...\c" @sleep 2 @echo done start_httpd_fork: $(APACHE_SRC)/$(HTTPD) -f `pwd`/t/conf/httpd.conf -d `pwd`/t rehttpd: kill_httpd start_httpd run_tests: $(FULLPERL) $(MP_TEST_SCRIPT) $(TEST_VERBOSE) ), $my_test, q( test_report: $(MAKE) test | t/report ); } use File::Find; sub MY::subdirs { my $self = shift; if($ENV{TEST_PERL_DIRECTIVES}) { push @{$self->{DIR}}, "t/TestDirectives"; } $self->MM::subdirs(@_); } sub wanted { return unless /\.h$/ or /os-inline\.c$/; (my $d = $File::Find::dir) =~ s:^\Q$APACHE_SRC::; $d =~ s:^/::; my $from = "$File::Find::dir/$_"; my $to = '$(INST_ARCHLIB)/' . "auto/Apache/include/"; $to .= "$d/" if $d; $to .= $_; $My::self->{PM}->{$from} = $to; } sub MY::post_initialize { my($self) = shift; return unless $APACHE_HEADER_INSTALL; my($ap_src, $ap_inc); if ($APACHE_SRC) { $ap_src = $APACHE_SRC; $ap_inc = "$ap_src/include"; } elsif ($USE_APXS) { #$base = `$WITH_APXS -q INCLUDEDIR`; $ap_inc = $ap_src = 'src'; #just install mod_perl headers } return unless $ap_src and -d $ap_src; $My::self = $self; { local $APACHE_SRC = $ap_src; finddepth(\&wanted, $ap_src); } $self->{PM}{"Apache/typemap"} = '$(INST_ARCHLIB)/' . "auto/Apache/typemap"; $self->{PM}{"apaci/mod_perl.exp"} = '$(INST_ARCHLIB)/' . "auto/Apache/mod_perl.exp"; for (qw(ap_config_auto.h)) { my $from = "$ap_inc/$_"; my $to = '$(INST_ARCHLIB)/' . "auto/Apache/include/$_"; unless ($self->{PM}->{$from}) { $self->{PM}->{$from} = $to; system "$Config{touch} $from"; } } ''; } sub MY::postamble { return <<'EOF'; cvs_export : cvs -d $(CVSROOT) export -rv$(VERSION_SYM) -d$(DISTVNAME) . cvs_tag : cvs -d $(CVSROOT) tag v$(VERSION_SYM) modperl @echo update mod_perl.pm VERSION now EOF } #' sub MY::manifypods { my $self = shift; my $ver = $self->{VERSION} || ""; local($_) = $self->MM::manifypods(@_); s/pod2man\s*$/pod2man --release mod_perl-$ver/m; $_; } sub fold_dots { my $v = shift; $v =~ s/\.//g; $v .= "0" if length $v < 3; $v; } sub vcache { my($v,$dir) = @_; $vcache{$dir} = fold_dots($v); } sub httpd_version { my($dir, $vnumber) = @_; local $^W=0; $dir = asrc($dir) || ""; if($vnumber) { return $vcache{$dir} if $vcache{$dir}; } my $fh = FileHandle->new("$dir/httpd.h") or return; my($server, $version, $rest); my($fserver, $fversion, $frest); my($string, $extra, @vers); while(<$fh>) { next unless /^#define/; s/SERVER_PRODUCT \"/\"Apache/; #1.3.13 next unless s/^#define\s+SERVER_(BASE|)(VERSION|REVISION)\s+"(.*)\s*".*/$3/; unless (m:/:) { $_ = "Apache/$_"; #1.3.14, argh } chomp($string = $_); #print STDERR "Examining SERVER_VERSION '$string'..."; #could be something like: #Stronghold-1.4b1-dev Ben-SSL/1.3 Apache/1.1.1 @vers = split /\s+/, $string; foreach (@vers) { next unless ($fserver,$fversion,$frest) = m,^([^/]+)/(\d\.\d+\.?\d*)([^ ]*),i; #print STDERR "match ($fserver,$fversion,$frest)\n"; if($fserver =~ /Xcert-Sentry/i or $fserver eq "Ben-SSL") { $extra ||= $fserver; #print STDERR "I see $fserver/$fversion, ok\n"; next; } if($fserver eq "Apache") { ($server, $version) = ($fserver, $fversion); if($version eq '1.2' and $frest =~ s/^b(\d+).*/$1/) { if($frest >= 8 and is_ssl($dir)) { $do_link_swap++; $can_dash_make{$dir}++; return $vnumber ? vcache($version,$dir) : "NONE"; } warn "Apache/1.2b$frest is not supported, upgrade to 1.2.0.\n"; return undef; } elsif($version >= 1.2) { $do_link_swap++ if is_ssl($dir); $can_dash_make{$dir}++; return $vnumber ? vcache($version,$dir) : "NONE"; } } else { #print STDERR "'$fserver/$fversion' unrecognized.\n"; next; } print STDERR "Found $fserver '$fversion' in $dir/httpd.h\n"; } } $fh->close; #print STDERR "return $version$extra\n"; return($version.$extra); } use lib "./lib"; use Apache::src (); sub magic_number { my $d = asrc shift; my $src = Apache::src->new; $src->dir($d); return($mcache{$d} = $src->module_magic_number); } sub cleanup_for_static { return unless $STATIC; for (@xs_mod_snames) { rename "${_}/${_}.xs.disabled", "${_}/${_}.xs"; } } sub setup_for_static { my $d = "$APACHE_SRC/modules/perl"; my $mf = "$APACHE_SRC/modules/perl/Makefile"; my @static_src = (); unless ($USE_APACI) { iedit $mf, "s/(PERL_STATIC_EXTS) =.*/\$1 = $PERL_STATIC_EXTS/" if $PERL_STATIC_EXTS; } return unless $STATIC; cp "Apache/typemap", $d; for (@xs_mod_snames) { rename "${_}/${_}.xs", "${_}/${_}.xs.disabled" if -e "${_}/${_}.xs"; push @static_src, "$_.c"; } =pod my @xs_names = (); my @xs_files = (); my $dir = "src/modules/perl"; my $dh = DirHandle->new($dir) or die; for my $file ($dh->read) { next unless $file =~ /\.xs$/; push @xs_names, module_name_from_xs("$dir/$file"); push @xs_files, $file; unless ($mani_src{"$dir/$file"}) { cp "$dir/$file", $d; print "Adding module `$xs_names[-1]' to httpd\n"; } } #print "XS_NAMES=@xs_names\n"; #print "XS_FILES=@xs_files\n"; #XXX think about this some more iedit $mf, "s/^#STATIC_SRC.*/STATIC_SRC = @xs_files/"; iedit $mf, "s/^#STATIC_EXTS.*/STATIC_EXTS = @xs_names/"; =cut unless ($USE_APACI) { #XXX: ho,hum, need to generate the whole damn thing #instead of all these frigging iedits. if ($DYNAMIC) { } else { iedit $mf, "s/^#STATIC_SRC.*/STATIC_SRC = @static_src/"; iedit $mf, "s/^#STATIC_EXTS.*/STATIC_EXTS = @xs_modules/"; iedit $mf, "s/^#STATIC_/STATIC_/"; } #bloody hell, make sucks and so does this. #this has only cause a few people pain, enough. iedit $mf, "s/ \Q\$(STATIC_SRC)\E/ @static_src/"; } } sub module_name_from_xs { my $file = shift; my $fh = FileHandle->new($file) or die "can't open file $file $!"; my($module, $package, $prefix, %seen); while(<$fh>) { if( ($module, $package, $prefix) = /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { $seen{$module}++; } } if(keys %seen > 1) { warn "$module name guess might be incorrect"; } return (keys %seen)[0]; } sub asrc { my $d = shift; my $file = shift || "httpd.h"; return $d if -e "$d/$file"; return "$d/include" if -e "$d/include/$file"; return "$d/main" if -e "$d/main/$file"; return undef; } sub conf_append { local *CFG; open CFG, ">>t/conf/httpd.conf" or die "open httpd.conf $!"; print CFG join "\n", @_, ""; close CFG; } sub edit_extra_cflags { my($cfg) = @_; my $fh = IO::File->new($cfg) or die "open $cfg $!"; my $repl = ""; my @file = (); my $ccopts = ccopts(); my $dssv = "-DSERVER_SUBVERSION"; my $ssv = qq($dssv=\\"mod_perl/$VERSION\\" ); my $inc = " $ccopts -I. -I../.. -DUSE_PERL_SSI" if $PERL_SSI; $inc .= " -DAPACHE_SSL" if is_ssl() and $PERL_SSI; $inc .= $SSL_INCLUDE if $SSL_INCLUDE; $inc .= " -DSTRONGHOLD" if is_ssl() =~ /stronghold/i; $inc .= " $PERL_EXTRA_CFLAGS" if $PERL_EXTRA_CFLAGS; $inc .= " -DMOD_PERL"; while (<$fh>) { push @file, $_; next unless /EXTRA_CFLAGS\s*=/; next if /mod_perl/; next if /^#/; chomp; $repl = $_; my $backwhack = ""; if($repl =~ s/(\\)\s*$//) { $backwhack = $1; } my $mmn = magic_number($APACHE_SRC); if($mmn >= 19980507) { $ADD_VERSION = 0; } if($ADD_VERSION) { if(/$dssv=/) { $repl =~ s{ $dssv\s*=\s*(.?)['"](.*?)(.?)["'] }[ qq($dssv="$1"$2 mod_perl/$VERSION$3"") ]ex; } else { $repl .= " $ssv"; } } $file[-1] = "$repl $inc $backwhack\n"; } close $fh; if($repl) { $fh = IO::File->new(">$cfg") or die "open $cfg $!"; print $fh @file; close $fh; } } sub conf_fixup { my($mf, $cfg) = @_; return if $USE_APACI; my $mmn = magic_number($APACHE_SRC); #source re-org my $sro = 1 if $mmn >= 19970825; edit_extra_cflags($cfg); $PERL_STATIC_EXTS ||= ""; $libperl ||= ""; my $ldopts = "`$perl_cmd $PWD/src/modules/perl/ldopts $PERL_STATIC_EXTS $libperl`"; iedit $cfg, q{next unless /EXTRA_LIBS\s*=/;}. q{next if /perl/; chomp;}. qq{\$_ .= q| $ldopts\n|;}; for (split ",", $ADD_MODULE) { add_module($cfg,$_); } if(is_ssl() =~ /stronghold/i) { if($do_link_swap) { warn "swapping link order in $mf for Stronghold\n"; my $repl = quotemeta('$(REGLIB) $(LIBS)'); iedit $mf, "s:\Q\$(LIBS) \$(REGLIB)\E:$repl:;"; #XXX hack $repl = quotemeta('CFLAGS=$(CFLAGS)'); iedit $mf, qq(s:\Q\"CFLAGS=\$(CFLAGS)"\E:'$repl':;); #" } my $repl = q{AUX_CFLAGS='\$(CFLAGS)'}; iedit $mf, qq{s/AUX_CFLAGS="..CFLAGS."/$repl/}; } { my $repl = q{CC='\$(CC)'}; iedit $mf, qq{s/CC=..CC. /$repl /}; } open(CONF, $cfg) || die "Can't open $cfg: $!"; while () { $seen_modperl++ if /^Module\s+perl_module/i || /^AddModule\s+.*libperl/; } close(CONF); unless ($seen_modperl) { print "Appending mod_perl to $conf\n"; open(CONF, ">>$cfg") || die "Can't open $cfg: $!"; my $line; $line = $sro ? "AddModule modules/perl/libperl.a" : "Module perl_module modules/perl/libperl.a"; print CONF <) { if(/^\\w{0,3}Module\\s+.*$name\.[oa]/i) { close IN; # print STDERR "has module $name\n"; return 1; } } return 0; } sub add_module { my($cfg, $name) = @_; iedit $cfg, "s/^#\\s+(\\w{0,3}Module\\s+.*$name\.[oa])/\$1/"; } sub gen_script { my $file = shift; local(*IN,*OUT); my $filename = $file . ".PL"; # Only one dot per filename on VMS if ($Is_VMS) { my $num_per = () = ($file =~ /\./g); $filename = $file . "_PL" if $num_per; } open IN, "$filename" or die "Couldn't open $filename: $!"; open OUT, ">$file" or die "Couldn't open $file: $!"; print OUT "#!$Config{perlpath}\n", join '', ; close OUT; cllZ~MOD_PERL1_25_MUP.SAVEy OD_PERL1_25]MAKEFILE.PL;2as@dose IN; chmod 0755, "$file"; } sub iedit { my $file = shift; return if $Is_Win32; #print STDERR "-e @_\n"; if ($Is_Cygwin) { system $perl_cmd, "-e", "@_", $file; } else { if ($Is_VMS) { # Yes, this is much nastier than a simple system out to # perl. Unfortunately VMS has a relatively short line # buffer, and this gets in the way of larger substitutions $command = "@_"; eval qq { local *IFH; local *OFH; open IFH, "<$file"; open OFH, ">$file"; while () { $command; print OFH \$_; } close IFH; close OFH; } } else { system $perl_cmd, "-pi~", "-e", "@_", $file; } } } sub win32_setup { my $d = "src/modules/perl"; dirent_kludge($d); cp "Apache/typemap", $d; chdir $d; system "$^X -MExtUtils::Embed -e xsinit -- -std @xs_modules $PERL_STATIC_EXTS"; my $lib = $Config{privlibexp}; for (@xs_mod_snames) { system "$^X $lib/ExtUtils/xsubpp -typemap $lib/ExtUtils/typemap $_.xs > $_.c"; } chdir "../../../"; } sub dirent_kludge { my $d = shift; local *FH; open FH, ">$d/dirent.h" or die "can't write $d/dirent.h $!"; print FH <$d/mod_perl_version.h" or die "can't write $d/mod_perl_version.h $!"; print FH < '$win32_path{APACHE_INC}', 'APACHE_LIB' => '$win32_path{APACHE_LIB}', 'MODPERL_INC' => '$win32_path{MODPERL_INC}', 'MODPERL_LIB' => '$win32_path{MODPERL_LIB}', EOS } local *FH; # writing Configuration to Apache::MyConfig open FH, '>lib/Apache/MyConfig.pm' || die "Can't open lib/Apache/MyConfig.pm: $!"; print FH < \'$APACHE_SRC\', 'SSL_BASE' => \'$SSL_BASE\', 'APXS' => \'$WITH_APXS\', 'PERL_USELARGEFILES' => \'$PERL_USELARGEFILES\', EOT foreach my $key (sort @callback_hooks) { print FH " \'$key\' => \'$callback_hooks{$key}\',\n"; } print FH < module provides access to the various hooks and features set when mod_perl is built. This circumvents the need to set up a live server just to find out if a certain callback hook is available. Itterate through \%Apache::MyConfig::Setup to get obtain build information then see Appendix B of the Eagle book for more detail on each key. EOT close FH; } # obtain the Apache and mod_perl lib and include directories for Win32 sub win32_inc_and_lib { my $modperl_src = win32_fix_path(cwd) . '/src'; $win32_path{MODPERL_INC} = $modperl_src . '/modules/perl'; $win32_path{MODPERL_LIB} = ($win32_args{DEBUG} == 1) ? $modperl_src . '/modules/win32/Debug' : $modperl_src . '/modules/win32/Release'; unless ( -d $win32_args{APACHE_SRC}) { opendir(DIR, '../') or die "Cannot read parent directory: $!\n"; my @dirs = map {"../$_"} grep {/apache/ and -d "../$_"} readdir DIR; closedir DIR or die "Cannot close parent directory: $!\n"; die "Cannot find the apache sources\n" unless ($win32_args{APACHE_SRC} = find_dir(\@dirs, 'apache source')); } $win32_args{APACHE_SRC} = win32_fix_path($win32_args{APACHE_SRC}); $win32_args{APACHE_SRC} .= '/src' unless $win32_args{APACHE_SRC} =~ /src$/; $win32_path{APACHE_INC} = $win32_args{APACHE_SRC} . '/include'; $win32_args{APACHE_VERS} = httpd_version($win32_path{APACHE_INC}, 1); $win32_path{APACHE_LIB} = ($win32_args{DEBUG} == 1) ? $win32_args{APACHE_SRC} . ($win32_args{APACHE_VERS} < 1315 ? '/CoreD' : '/Debug') : $win32_args{APACHE_SRC} . ($win32_args{APACHE_VERS} < 1315 ? '/CoreR' : '/Release'); die "Cannot find ApacheCore.lib under $win32_path{APACHE_LIB}\n" unless -f "$win32_path{APACHE_LIB}/ApacheCore.lib"; if ($win32_args{INSTALL_DLL} ) { $win32_args{INSTALL_DLL} = win32_fix_path($win32_args{INSTALL_DLL}); unless ( -d $win32_args{INSTALL_DLL}) { my @dirs = grep {-d} ('\Program Files\Apache Group\Apache\modules', '\Apache\modules', '\Program Files\Apache\modules'); $win32_args{INSTALL_DLL} = find_dir(\@dirs, 'Apache/modules'); if ($win32_args{INSTALL_DLL} and -d $win32_args{INSTALL_DLL}) { $win32_args{INSTALL_DLL} = win32_fix_path($win32_args{INSTALL_DLL}); } else { print <<'END'; **** The Apache/modules directory was not found. ******* **** Please install mod_perl.so manually. ******* END } } } } # fix mod_perl.dsp with the perl and apache inc and lib directories sub win32_fix_dsp { my $amp = 'src/modules/win32'; my $dsp = 'mod_perl.dsp'; unless ( -f "$amp/$dsp.orig") { rename("$amp/$dsp", "$amp/$dsp.orig") or die "Couldn't rename $amp/$dsp: $!\n"; } my $perl_inc = win32_fix_path_dsp("$Config{archlibexp}/CORE"); open(OLDDSP, "$amp/$dsp.orig") or die "Couldn't read $amp/$dsp.orig: $!\n"; open(NEWDSP, ">$amp/$dsp") or die "Couldn't create $amp/$dsp: $!\n"; while () { if (/^SOURCE=.*ApacheCore\.lib/) { printf NEWDSP "SOURCE=%s\n", win32_fix_path_dsp("$win32_path{APACHE_LIB}/ApacheCore.lib"); } elsif (/^SOURCE=.*perl(56)?\.lib/) { print NEWDSP qq{SOURCE=$perl_inc\\$Config{libperl}\n}; } elsif (/ADD CPP/) { my $apache_inc = win32_fix_path_dsp($win32_path{APACHE_INC}); s!(/D "WIN32")!/I "$apache_inc" /I "$perl_inc" $1!; s!(/D "WIN32")!$1 /D "EAPI" ! if $win32_args{EAPI}; print NEWDSP $_; } else { print NEWDSP $_; } } close OLDDSP; close NEWDSP; return; } # find a directory of type $type, given some possible $dirs sub find_dir { my ($dirs, $type) = @_; my $j = 0; my $src; while (1) { $src = @$dirs > 0 ? $dirs->[$j] : ''; $src = prompt("\nWhere is your $type directory? (q to quit)", $src); return undef if $src eq 'q'; return $src if -d $src; print qq{'$src': no such directory\n}; $j = ($j == @$dirs-1) ? 0 : $j + 1; } } # fix a path for Win32 Makefile sub win32_fix_path { local $_ = shift; $_ = File::Spec->rel2abs($_) if not File::Spec->file_name_is_absolute($_); tr!\\!/!; s!/$!!; return $_; } # fix a path for mod_perl.dsp sub win32_fix_path_dsp { local $_ = shift; tr!/!\\!; s!^\w:!!; return $_; } #in version 1.2505 of Embed.pm we could just import these instead of using ``, #but it might require lots of people to upgrade sub ccopts { unless ($Embed::ccopts) { if ($Is_VMS) { $Embed::ccopts = `mcr $^X \"-MExtUtils::Embed\" -e ccopts`; } else { $Embed::ccopts = "$Config{ccflags} -I$Config{archlibexp}/CORE"; } if($USE_THREADS) { $Embed::ccopts .= " -DPERL_THREADS"; } } $Embed::ccopts; } sub ldopts { if ($Is_VMS) { $Embed::ldopts ||= `$perl_cmd \"-MExtUtils::Embed\" -e ldopts`; } else { $Embed::ldopts ||= `$perl_cmd -MExtUtils::Embed -e ldopts`; } if($^O eq "aix") { $Embed::ldopts =~ s,(-bE:)(perl\.exp),$1$Config{archlibexp}/$2,; } $Embed::ldopts; } sub perl_version { my $v = "$]"; $v =~ s/\.//g; $v .= "0" while length($v) < 6; $v; } #for linking third-party xs modules static built w/ MakeMaker's: 'make static' #must have when the xs module is compiled with profiling `-pg -a' flags sub add_static_ar { $PERL_STATIC_AR ||= ""; my $cur = $APACHE_SRC =~ /^../ ? "$PWD/" : ""; for (qw(blib/arch/auto arch/auto)) { last if -d ($ar_dir = "$APACHE_SRC/modules/perl/$_"); $ar_dir = ""; } return unless -d $ar_dir; finddepth(sub { return unless /^[A-Z]\w+\.a$/; (my $rel = $File::Find::dir) =~ s:$APACHE_SRC/?::; (my $mod = $rel) =~ s:.*auto/::; $mod =~ s,/,::,; print "linking static $mod => $rel/$_\n"; $PERL_STATIC_AR .= $cur . "$File::Find::dir/$_ "; $PERL_STATIC_EXTS .= "$mod "; }, $ar_dir); } sub APACI::init { return undef if $Is_Win32; my $lib_cfg; if($USE_APXS) { $lib_cfg = "apaci/mod_perl.config"; chmod 0644, $lib_cfg; } elsif($USE_APACI) { $lib_cfg = "$APACHE_SRC/modules/perl/mod_perl.config"; } else { return undef; } unless (File::Compare::compare($lib_cfg,"apaci/mod_perl.config") == 0) { #warn "mod_perl.config already edited\n"; #return undef; } my $apaci_cfg = FileHandle->new(">$lib_cfg") or die "can't open $lib_cfg $!"; my @static_src = (); for (@xs_mod_snames) { push @static_src, "$_.c"; } add_static_ar(); my $static_targets = ""; $static_targets = <= 5.006 ? 'A' : 'D'; phat_warn(<; } my $suggest = @maybe ? "You could just symlink it to $maybe[0]" : "You might need to install Perl from source"; phat_warn(<= 5.006 and $Config{uselargefiles} and $PERL_USELARGEFILES and $USE_APXS; local $Apache::src::APXS = $WITH_APXS; my $cflags = Apache::src->new->apxs('-q' => 'CFLAGS') || ''; return if $cflags =~ /LARGEFILE/; phat_warn(<refCnt = 1; mp->next = modList; modList = mp; - if (loadbind(0, mainModule, mp->entry) == -1) { + /* + * Assume anonymous exports come from the module this dlopen + * is linked into, that holds true as long as dlopen and all + * of the perl core are in the same shared object. Also bind + * against the main part, in the case a perl is not the main + * part, e.g mod_perl as DSO in Apache so perl modules can + * also reference Apache symbols. + */ + if (loadbind(0, (void *)dlopen, mp->entry) == -1 || + loadbind(0, mainModule, mp->entry) == -1) { dlclose(mp); errvalid++; strcpy(errbuf, "loadbind: "); @@ -336,12 +343,6 @@ safefree(mp->name); safefree(mp); return result; -} - -static void terminate(void) -{ - while (modList) - dlclose(modList); } /* Added by Wayne Scott EOF } *[MOD_PERL1_25]MAKEFILE.PL;1+, ./A@ 4~-y 0D123 KPWO56 `酟7"Ƨ酟89GA@HJ N $J)g7 %J)g7J)g7.  =*De=*De=*De:#!perl BEGIN { $Is_Win32 = ($^O eq "MSWin32"); $Is_Cygwin = ($^O =~ m/cygwin/g); if($Is_Win32) { require 5.004_02; } elsif($Is_Cygwin) { require 5.005_03; } else { require 5.003_97; } } sub MMN_130 () { 19980527 } use ExtUtils::MakeMaker; use Config (); use FileHandle (); use DirHandle (); use File::Compare (); use File::Basename qw(dirname); use File::Path qw(mkpath rmtree); use Cwd; use File::Copy qw(cp); #use Apache::ExtUtils qw(%Config); unless (%Config) { *Config = \%Config::Config; } my %vcache = (); #SERVER_VERSION my %mcache = (); #MODULE_MAGIC_NUMBER #version 1.5 that ships with 5.003 is broken! *cp = sub { system "cp @_"; for (@_) { -e $_ or die $! } } if $File::Copy::VERSION < 2.0; my $Is_dougm = (defined($ENV{USER}) && ($ENV{USER} eq "dougm")); my $USE_THREADS; my $thrlib = join '|', qw(-lpthread); if ($] < 5.005_60) { $USE_THREADS = (defined($Config{usethreads}) && ($Config{usethreads} eq "define")); } else { $USE_THREADS = (defined($Config{use5005threads}) && ($Config{use5005threads} eq "define")); } #hmm, seems the #include flip/flop isn't needed anymore #so ignore the stuff above for now $USE_THREADS = $ENV{PERL_USE_THREADS} || 0; require "./lib/mod_perl.pm"; $VERSION = $mod_perl::VERSION = $mod_perl::VERSION; { $VERSION =~ s/(\d\d)(\d\d)$/$1_$2/; } { local *FH; open FH, "Changes"; while() { if(/^=item.*-dev/) { $VERSION .= "-dev"; last; } last if /^=item/; } close FH; } use subs qw(iedit asrc); if($] < 5.004_04) { print < "Ben-SSL", "apache_ssl.c" => "Ben-SSL", "mod_ssl.h" => "Stronghold", "modules/modssl" => "Stronghold", ); unless (-e "t/docs/test.shtml") { cp "t/docs/test.html", "t/docs/test.shtml"; } for (qw(.htaccess hooks.txt)) { my $file = "t/docs/$_"; local *FH; open FH, ">$file" or die "can't write test file: $file: $!"; chmod 0666, $file; close FH; } chmod 0644, "t/conf/mod_perl_srm.conf"; mkdir "t/logs", 0777; chmod 0777, "t/logs"; unless ($Is_Win32) { system "chmod a+x t/net/perl/* t/net/perl/io/*"; } #generated by us at one time or another my(@do_clean) = qw{ t/docs/.htaccess t/docs/hooks.txt src/Configuration lib/Apache/MyConfig.pm Apache/Apache.xs Constants/Constants.xs t/modules/ssi.t t/logs/error_log t/conf/srm.conf t/conf/dev-null t/logs/httpd.pid src/modules/perl/mod_perl_version.h t/net/perl/cgi.pl t/report t/httpd apaci/find_source apaci/apxs_cflags apaci/mod_perl.config }; #t/conf/httpd.conf #t/net/config.pl for(@do_clean) { unlink $_ } unless ($Is_Win32) { rename "t/conf/httpd.conf", "t/conf/httpd.conf.old"; } rmtree "t/docs/stacked", 0, 0; gen_script("t/net/perl/cgi.pl"); gen_script("t/report"); gen_script("apaci/find_source"); gen_script("apaci/apxs_cflags"); write_version_h("src/modules/perl"); my(@test_pre_init) = qq( test_pre_init: ); # Automatic setup support my(@adirs, %seen, %mft_map, %vers_map, $src_dir, $vers, $conf, $ans); %vers_map = ( '1.1.1' => "Makefile.tmpl", '1.1.3' => "Makefile.tmpl", '1.2' => "Makefile.tmpl-1.2", '1.1.1Xcert-Sentry' => "Makefile.tmpl-XCert", '1.1.1Ben-SSL' => "Makefile.tmpl-Ben-SSL", '1.1.3Ben-SSL' => "Makefile.tmpl-Ben-SSL", '1.2Ben-SSL' => "", NONE => "", ); $LIBPERL = "DEFAULT"; $USE_APACI = $USE_DSO = $USE_APXS = 0; $WITH_APXS = ""; $APACI_ARGS = ""; @APACI_ARGS = (); $EVERYTHING = $EXPERIMENTAL = 0; $PERL_DEBUG = ""; $PERL_DESTRUCT_LEVEL = ""; $PERL_STATIC_EXTS = ""; $PERL_USELARGEFILES = 1; $PERL_EXTRA_CFLAGS = ""; $PERL_EXTRA_LIBS = ""; $SSLCacheServerPort = 8539; $SSL_BASE = ""; $Port = $ENV{HTTP_PORT} || 8529; #so Doug can 'make test' different-builds@sametime/samebox if(!$Is_Win32 and $ENV{RANDOM_PORT} and $$ > 8000 and $$ < 30000) { $PORT ||= $$; print "I'll use Port $PORT\n"; } $PORT ||= $Port; $TARGET = ""; $DO_HTTPD = $ENV{DO_HTTPD} || 0; $NO_HTTPD = $ENV{NO_HTTPD} || 0; $PREP_HTTPD = 0; $PERL_TRACE = 0; $ALL_HOOKS = 0; $APACHE_SRC = ""; $APACHE_PREFIX = ""; $APACHE_HEADER_INSTALL = 1; $PERL_SECTIONS = 0; $PERL_SSI = 0; $ADD_VERSION = 1; $STATIC = 1; $DYNAMIC = 0; $CONFIG = ""; $ADD_MODULE = ""; $PERL_DIRECTIVE_HANDLERS = 0; $PERL_TABLE_API = 0; $PERL_LOG_API = 0; $PERL_URI_API = 0; $PERL_UTIL_API = 0; $PERL_FILE_API = 0; $PERL_CONNECTION_API = 1; #these two were split out late in the game $PERL_SERVER_API = 1; #so they are on by default $PERL_RUN_XS = 0; my %experimental = map { $_,1 } qw{ PERL_AUTOPRELOAD PERL_DSO_UNLOAD PERL_STARTUP_DONE_CHECK PERL_RUN_XS PERL_MARK_WHERE DO_INTERNAL_REDIRECT PERL_TIE_SCRIPTNAME PERL_STASH_POST_DATA XS_IMPORT PERL_SAFE_STARTUP PERL_DEFAULT_OPMASK PERL_ORALL_OPMASK }; my %PassEnv = map { $_,1 } qw(SSL_BASE); my @mp_args = (keys %PassEnv, qw(EXPERIMENTAL EVERYTHING DO_HTTPD NO_HTTPD CONFIG ADD_MODULE APACHE_PREFIX USE_APACI USE_DSO USE_APXS WITH_APXS APACI_ARGS PREP_HTTPD ALL_HOOKS ADD_VERSION STATIC DYNAMIC PORT XS_IMPORT)); sub is_mp_arg { my $arg = shift; return 1 if $experimental{$arg}; for (@mp_args) { return 1 if $arg eq $_; } return 0; } #callback hooks @callback_hooks = qw{ PERL_DISPATCH PERL_CHILD_INIT PERL_CHILD_EXIT PERL_POST_READ_REQUEST PERL_TRANS PERL_HEADER_PARSER PERL_ACCESS PERL_AUTHEN PERL_AUTHZ PERL_TYPE PERL_FIXUP PERL_HANDLER PERL_LOG PERL_INIT PERL_CLEANUP PERL_RESTART PERL_STACKED_HANDLERS PERL_METHOD_HANDLERS PERL_DIRECTIVE_HANDLERS PERL_TABLE_API PERL_LOG_API PERL_URI_API PERL_UTIL_API PERL_FILE_API PERL_CONNECTION_API PERL_SERVER_API }; $callback_alias{PERL_INIT} = "PERL_HEADER_PARSER"; $callback_alias{PERL_CLEANUP} = "PERL_LOG"; %callback_hooks = map { $_,0 } @callback_hooks; $callback_hooks{PERL_HANDLER} = 1; #PerlHandler always on %cant_hook = (); my @mm_args; { my($fh,$file); for (qw(./ ../ ./. ../.), "$ENV{HOME}/.") { last if $fh = FileHandle->new($file = $_."makepl_args.mod_perl"); } if($fh) { print "Reading Makefile.PL args from $file\n"; while(<$fh>) { chomp; s/^\s+//; s/\s+$//; next if /^#/ || /^$/; last if /^__END__/; if(/^APACI_ARGS/) { s/^APACI_ARGS=//; push @APACI_ARGS, $_; } else { unshift @ARGV, split /\s+/, $_; } } close $fh; } if(@APACI_ARGS) { unshift @ARGV, "APACI_ARGS=" . join(",", @APACI_ARGS); } } my $vcpp = ($Config{cc} =~ /^cl(\.exe)?$/); my %win32_args; my %win32_accept = map {$_ => 1} qw(APACHE_SRC INSTALL_DLL DEBUG EAPI); while($_ = shift) { ($k,$v) = split /=/, $_, 2; if ($vcpp) { if ($win32_accept{$k}) { $win32_args{$k} = ($k eq 'DEBUG' or $k eq 'EAPI') ? 1 : $v; } else { push @mm_args, $_; } next; } unless (/^(PERL|APACHE)/ or is_mp_arg($k)) { push @mm_args, $_; } $v = 1 unless defined $v; if($experimental{$k}) { $experimental{$k}++; $PERL_EXTRA_CFLAGS .= " -D${k}=1"; } ${$k} = $v, next if defined ${$k}; $callback_hooks{$k} = $v if exists $callback_hooks{$k}; } my $win32_auto = ($vcpp and $win32_args{APACHE_SRC}) ? 1 : 0; my %very_experimental = map {$_,1} qw(PERL_DEFAULT_OPMASK PERL_SAFE_STARTUP PERL_ORALL_OPMASK PERL_STARTUP_DONE_CHECK PERL_DSO_UNLOAD); if($EXPERIMENTAL) { for (keys %experimental) { next if $very_experimental{$_}; #have to *really* ask for this one next if $experimental{$_}++ > 1; $PERL_EXTRA_CFLAGS .= " -D$_=1"; } } if($experimental{PERL_DEFAULT_OPMASK} > 1) { $experimental{PERL_SAFE_STARTUP} = 2; $PERL_EXTRA_CFLAGS .= " -DPERL_SAFE_STARTUP=1"; } if ($PERL_USELARGEFILES and $] >= 5.006) { $PERL_EXTRA_CFLAGS .= " $Config{ccflags}"; } for (keys %PassEnv) { $ENV{$_} = $$_ if $$_; } $USE_APACI = 1 if $USE_DSO; if(0) { #if($USE_DSO or $USE_APXS and !$DO_HTTPD) { print "*" x 65, $/; print <, <../stronghold*/src>, , "../src", "./src") { next unless -d $src_dir; next if $seen{$src_dir}++; next unless $vers = httpd_version($src_dir); unless(exists $vers_map{$vers}) { print STDERR "Apache version '$vers' unsupported\n"; next; } $mft_map{$src_dir} = $vers_map{$vers}; #print STDERR "$src_dir -> $vers_map{$vers}\n"; push @adirs, $src_dir; $modified{$src_dir} = (stat($src_dir))[9]; last if $DO_HTTPD; } unless (@adirs) { print "Enter `q' to stop search\n"; while(1) { print "Please tell me where I can find your apache src\n" ; $src_dir = prompt("", $APACHE_SRC_DEFAULT); last if $src_dir eq "q"; if(-d $src_dir) { push(@adirs, $src_dir); $mft_map{$src_dir} = $vers_map{httpd_version($src_dir)}; last; } else { print "Can't stat `$src_dir'\n"; } } } } if($PERL_EXTRA_CFLAGS) { $PERL_EXTRA_CFLAGS = join(" ", split(",", $PERL_EXTRA_CFLAGS)); $PERL_EXTRA_CFLAGS =~ s/\s+/ /g; } if($PERL_DEBUG) { my $lib = "$Config{archlibexp}/CORE/libperld$Config{lib_ext}"; if (-e $lib) { $LIBPERL = "-lperld"; $libperl = " -- $LIBPERL"; } $PERL_EXTRA_CFLAGS .= " -g"; $PERL_TRACE=1; $PERL_DESTRUCT_LEVEL=2; print "DEBUG mode...\n"; print "...adding `-g' to EXTRA_CFLAGS\n"; print "...turning on PERL_TRACE\n"; print "...setting PERL_DESTRUCT_LEVEL=2\n"; print "...linking against libperld\n" if $libperl; sleep(1); } $PERL_EXTRA_CFLAGS .= " -DPERL_DESTRUCT_LEVEL=$PERL_DESTRUCT_LEVEL" if $PERL_DESTRUCT_LEVEL; for $adir (sort {$modified{$b} <=> $modified{$a}} @adirs) { $conf = "$adir/$Configuration"; $httpd_h = asrc($adir)."/httpd.h"; if (-e $httpd_h) { unless($NO_HTTPD and not $DYNAMIC and not $PREP_HTTPD) { unless($DO_HTTPD) { $ans = prompt("Configure mod_perl with $adir ?", "y"); next unless $ans =~ /^y$/i; } $APACHE_SRC = $adir; $IsBenSSL = -e "$adir/apache_ssl.c"; last unless(-e $conf || -e "$conf.tmpl"); #building from 'make offsite-tar' } #++$NO_HTTPD if $USE_APACI; my $mmn = magic_number($APACHE_SRC); if(($mmn < MMN_130) and $USE_APACI) { #1.3.0 print "Sorry, need 1.3.0+ for USE_APACI\n"; $USE_APACI = $USE_DSO = 0; } for my $api (qw(LOG URI UTIL FILE TABLE)) { local $_ = join "_", "PERL", $api, "API"; if(($mmn < MMN_130) and $$_) { #1.3.0 $$_ = 0; $cant_hook{$_} = "(need 1.3.0 or higher)"; } } if($USE_DSO and $PERL_SSI) { $PERL_SSI=0; $cant_hook{PERL_SSI} = "(doesn't work w/ USE_DSO=1)"; } unless ($DO_HTTPD or $NO_HTTPD) { $ans = prompt("Shall I build httpd in $adir for you?", "y"); ++$NO_HTTPD, ++$PREP_HTTPD unless $ans =~ /^y$/i; } if($NO_HTTPD) { #must generate Makefile.config for 1.3bx unless (-e "$adir/Makefile.config") { my $cfgfile = $CONFIG ? $CONFIG : "Configuration"; print "(cd $adir && ./Configure -file $cfgfile)"; } } #copy the source files if(!$NO_HTTPD or $USE_APACI or $PREP_HTTPD) { mkpath "$adir/modules/perl"; #ignore make's output here `(cd $adir/modules/perl && make clean 2> /dev/null)`; local(*MANI); open MANI, "MANIFEST" or die "open MANIFEST $!"; my $atopdir = dirname($adir); unlink "$atopdir/perlxsi.c"; #only rm and cp files mod_perl ships with while() { next unless m,^src/modules/perl/,; chomp; #print "rm -f $adir/$_\n"; unlink "$atopdir/$_"; next if not m,.+\.(xs|c|h)$, and $USE_APACI; next if $DYNAMIC and /\.xs$/; #print "cp $_ $atopdir/$_\n" if $USE_APACI; my $dest = "$atopdir/$_"; cp $_, $dest; #$mani_src{$_}++; } close MANI; cp "src/modules/perl/mod_perl_version.h", "$atopdir/src/modules/perl/mod_perl_version.h"; if($USE_APACI) { open MANI, "MANIFEST" or die "open MANIFEST $!"; while() { next unless m,^apaci/,; chomp; (my $to = $_) =~ s,^apaci/,src/modulOy:~MOD_PERL1_25_MUP.SAVE y OD_PERL1_25]MAKEFILE.PL;1|es/perl/,; unlink "$atopdir/$to"; print "cp $_ $atopdir/$to\n"; my $dest = "$atopdir/$to"; cp $_, $dest; chmod 0755, $dest if -x $_; } close MANI; } } ($APACHE_ROOT = $APACHE_SRC) =~ s,/src/?$,,; last if $NO_HTTPD; # or $USE_APACI; unless(-e "src/Configuration" and (-M "src/Configuration" < -M $conf) and not $USE_APACI) { unless(-e $conf) { cp "$conf.tmpl", $conf; } cp $conf, "src/Configuration"; $conf = "src/Configuration"; conf_fixup("$adir/Makefile.tmpl", $conf); } } if ($NO_HTTPD) { } elsif($USE_APACI) { #take care of things later } else { $conf = "src/Configuration"; my($dash_make, $cfgfile); $dash_make = " -make $PWD/src/$mft_map{$adir} " if $can_dash_make{asrc $adir} and $mft_map{$adir}; #print STDERR "(cd $adir; ./Configure${dash_make} -file $PWD/$conf)\n"; $cfgfile = $CONFIG ? $CONFIG : "$PWD/$conf"; $dash_make ||= ""; system "(cd $adir && ./Configure${dash_make} -file $cfgfile)"; open FH, "$APACHE_SRC/Makefile" or die "can't open $APACHE_SRC/Makefile $!"; while() { $SSL_BASE ||= $1 if /^\s*SSL_BASE\s*=\s*(.*)/; $EXTRA_CFLAGS = $1 if /CFLAGS1\s*=\s*(.*)/; $SSLINCS = $1 if /SSLINCS\s*=\s*(.*)/; } close FH; if($SSL_BASE) { $SSL_INCLUDE = " -I$SSL_BASE/include "; $SSL_CFLAGS = "-DAPACHE_SSL $SSL_INCLUDE"; } #stronghold if($SSLINCS) { $SSL_INCLUDE = " $SSLINCS "; $SSL_CFLAGS = "-DAPACHE_SSL $SSL_INCLUDE"; } } print "EXTRA_CFLAGS: $EXTRA_CFLAGS\n" if $EXTRA_CFLAGS; print "SSL_CFLAGS: $SSL_CFLAGS\n" if $SSL_CFLAGS; last if $APACHE_SRC; } if($PERL_DIRECTIVE_HANDLERS) { push @xs_modules, "Apache::ModuleConfig"; $callback_hooks{PERL_DIRECTIVE_HANDLERS} = 1; } #if($PERL_RUN_XS or $experimental{PERL_RUN_XS} > 1) { if (0) { my $mmn = $USE_APXS ? MMN_130 : magic_number($APACHE_SRC); if($mmn >= MMN_130) { push @xs_modules, "Apache::PerlRunXS"; } else { $PERL_RUN_XS = 0; $experimental{PERL_RUN_XS} = 0; print "Sorry, need 1.3.0+ for Apache::PerlRunXS\n"; } } for (qw(Log URI Util Connection Server File Table)) { my $s = "PERL_".uc($_)."_API"; if($$s or $Is_Win32) { push @xs_modules, "Apache::$_"; $callback_hooks{$s} = 1; } } my @xs_mod_snames = map { (my $s = $_) =~ s/.*:://; $s } @xs_modules; win32_setup() if $Is_Win32; if($DYNAMIC) { print "Will build Apache::* extensions dynamic\n"; for (@xs_mod_snames) { cp "src/modules/perl/${_}.xs", "${_}/${_}.xs"; } } if($APACHE_SRC or $USE_APXS) { ++$STATIC if grep { $_ eq lc($Config{osname}) } qw(aix svr4 unixware); my $mmn = $USE_APXS ? MMN_130 : magic_number($APACHE_SRC); my $httpdv = $USE_APXS ? 130 : httpd_version($APACHE_SRC,1); unless($httpdv >= 130) { phat_warn("Apache Version 1.3.0 required, aborting..."); exit(1); } if($httpdv >= 130) { if($callback_hooks{PERL_CHILD_INIT}) { $My::child_init++; } } else { $callback_hooks{PERL_CHILD_INIT} = 0; $cant_hook{PERL_CHILD_INIT} = "(need 1.3.0 or higher)"; } if($mmn >= 19970728) { $callback_hooks{PERL_CHILD_EXIT} = $My::child_exit = $callback_hooks{PERL_CHILD_INIT} = $My::child_init = 1; } else { $callback_hooks{PERL_CHILD_EXIT} = 0; $cant_hook{PERL_CHILD_EXIT} = "(need 1.3.0 or higher)"; } unless($mmn >= 19970825) { $callback_hooks{PERL_POST_READ_REQUEST} = 0; $cant_hook{PERL_POST_READ_REQUEST} = "(need 1.3.0 or higher)"; } setup_for_static() unless $USE_APXS; iedit "$APACHE_SRC/modules/perl/Makefile", "s!^PERL\\s*=.*!PERL=$Config{'perlpath'}!" unless $USE_APACI or $USE_APXS; for (@callback_hooks) { ($k,$v) = ($_,$callback_hooks{$_}); unless ($USE_APACI or $USE_APXS) { iedit "$APACHE_SRC/modules/perl/Makefile", "s/^$k /#$k /" if $v; } $why = ($cant_hook{$k} || "(enable with $k=1)") unless $v; $k =~ s/([A-Z]+)/ucfirst(lc($1))/ge; $k =~ s/_//g; $k .= "Handler" unless $k =~ /(Api|Table|Handler)s?$/; push @mod_perl_hooks, $k; print $k . '.' x (28 - length($k)); print $v ? "enabled\n" : "disabled $why\n"; } unless($httpdv >= 120) { $PERL_SECTIONS = $PERL_SSI = 0; $cant_hook{PERL_SECTIONS} = $cant_hook{PERL_SSI} = "(need 1.2.0 or higher)"; } for (qw(PERL_SECTIONS PERL_SSI), keys %experimental) { $k = $_; if($experimental{$_}) { next unless $experimental{$_} > 1; print $k . '.' x (28 - length($k)); print "enabled (experimental)"; } else { $why = ($cant_hook{$_} || "(enable with $k=1)") unless $$_; $k =~ s/([A-Z]+)/ucfirst(lc($1))/ge; $k =~ s/_//g; $k =~ s/Ssi$/SSI/; #*shrug* push @mod_perl_hooks, $k; print $k . '.' x (28 - length($k)); print $$_ ? "enabled" : "disabled $why\n"; } print "\n"; unless ($USE_APACI or $USE_APXS) { iedit "$APACHE_SRC/modules/perl/Makefile", "s/^($_) /#\$1 /" if $$_; } } unless ($USE_APACI or $USE_APXS) { iedit "$APACHE_SRC/modules/perl/Makefile", "s/^#TRACE/TRACE/" if $PERL_TRACE; } my $ssl_name = is_ssl(); if($ssl_name) { print "I see you are building with $ssl_name,\nI'll set the SSL flags in mod_perl's Makefile\n"; if($ssl_name =~ /stronghold/i) { my $skey; my $lfile; my $conf = "$APACHE_SRC/../conf/httpd.conf"; if(-e $conf) { open FH, $conf; while() { chomp; if(/^StrongholdKey/) { $skey = $_; last; } elsif(s/^StrongholdLicenseFile\s+//) { $lfile = $_; unless ($lfile =~ m:^/:) { $lfile = "$PWD/$APACHE_SRC/../$lfile"; } } } close FH; } if($skey) { $StrongholdKey = $skey; print "Using $skey for 'make test'\n"; } elsif(-e $lfile) { $StrongholdKey = join " ", "StrongholdLicenseFile", $lfile; print "Using $StrongholdKey for 'make test'\n"; } else { print "Before running `make test', ", "you must add your `StrongholdLicenseFile' to t/conf/httpd.conf\n"; } } unless ($USE_APACI or $USE_APXS) { iedit "$APACHE_SRC/modules/perl/Makefile", "s:^#APACHE_SSL.*:APACHE_SSL = $SSL_CFLAGS:"; } } #my $incdir = ($mmn >= 19970825) ? "../../main" : "../.."; my $minc = asrc($APACHE_SRC); $minc =~ /(main|include)/; my $incdir = $1 ? "../../$1" : "../.."; my $edit_note = quotemeta(<= 19970912 and not $USE_APACI and not $USE_APXS) { #1.3b1 system "cat $APACHE_SRC/Makefile.config $APACHE_SRC/modules/perl/Makefile > /tmp/mpmf.$$"; system "mv /tmp/mpmf.$$ $APACHE_SRC/modules/perl/Makefile"; } if($callback_hooks{PERL_TRANS}) { push @test_pre_init, "\t", '$(CP) t/conf/mod_perl_srm.conf t/conf/srm.conf', "\n"; } unless ($USE_APXS) { unless (-l "t/httpd") { system "$Config{lns} $APACHE_SRC/httpd t/httpd"; } write_extra_tests(); } } unless (-e "t/net/config.pl") { cp "t/net/config.pl.dist", "t/net/config.pl"; } init_config_pl() if $Is_Win32; my (%win32_path); if ($win32_auto) { require File::Spec; win32_inc_and_lib(); win32_fix_dsp(); } write_my_config($APACHE_SRC); unless($Is_Win32 or -e "t/conf/httpd.conf" or ($NO_HTTPD && !$PREP_HTTPD)) { init_tests_and_config(); } init_tests_and_config() if $USE_APXS; sub init_config_pl { my $mmn = magic_number($APACHE_SRC) || 0; my $hf = FileHandle->new(">>t/net/config.pl") or die "can't open t/net/config.pl $!"; my $apaci_cfg = APACI->init; my($k,$v); my(%all) = %callback_hooks; while (($k,$v) = each %experimental) { $all{$k} = ($experimental{$k} > 1) ? 1 : 0; } print $hf "%callback_hooks = (\n"; while (($k,$v) = each %all) { print $hf " $k => $v,\n"; my $yes_no = $v ? "yes" : "no"; print $apaci_cfg "$k = $yes_no\n" if $apaci_cfg; } print $hf " MMN => $mmn,\n"; print $hf " USE_DSO => 1,\n" if $USE_DSO; print $hf ");\n1;\n"; $hf->close; $apaci_cfg->close if $apaci_cfg; } sub init_tests_and_config { local *FH; open FH, ">t/conf/dev-null"; print FH "#mod_ssl has a problem with /dev/null\n"; close FH; cp "t/conf/httpd.conf-dist", "t/conf/httpd.conf"; chmod 0644, "t/conf/httpd.conf"; $uid = $>; $gid = $); #use only first value if $) contains more than one $gid =~ s/^(\d+).*$/$1/; $User = $Is_Win32 ? "nobody" : $ENV{APACHE_USER} || (getpwuid($uid) || "#$uid"); $Group = $Is_Win32 ? "nogroup" : $ENV{APACHE_GROUP} || (getgrgid($gid) || "#$gid"); if($User eq "root") { my $other = (getpwnam('nobody'))[0]; $User = $other if $other; } if($User eq "root") { print "Cannot run tests as User `$User'\n"; $User = prompt("Which User?", "nobody"); $Group = prompt("Which Group?", $Group); } print STDERR "Will run tests as User: '$User' Group: '$Group'\n"; if($Port != $PORT) { iedit "t/conf/httpd.conf", "s/^(Port) .*/\$1 $PORT/"; iedit "t/net/config.pl", "s/$Port/$PORT/;"; } if($experimental{PERL_SAFE_STARTUP} > 1) { if($experimental{PERL_DEFAULT_OPMASK} < 2) { iedit "t/conf/httpd.conf", "s/^#(PerlOpmask)/\$1/"; } } init_config_pl(); if($USE_APACI and not $PREP_HTTPD and not $USE_APXS) { my $shrpenv = $Config{shrpenv} || ""; $shrpenv .= ' ' if $shrpenv; my $cmd = "CC=\"${shrpenv}$Config{cc}\" "; if($PERL_EXTRA_CFLAGS) { $cmd .= qq(CFLAGS="$PERL_EXTRA_CFLAGS" ); } if ($USE_DSO) { # override apache's notion of this flag $cmd .= qq(LDFLAGS_SHLIB_EXPORT="$Config{ccdlflags}" ); #if Perl is linked with -lpthread, httpd needs tobe too if ($Config{libs} =~ /($thrlib)/) { $PERL_EXTRA_LIBS .= " $1"; } } if ($PERL_EXTRA_LIBS) { $cmd .= qq(LIBS="$PERL_EXTRA_LIBS" ); } $cmd .= "./configure " . "--activate-module=src/modules/perl/libperl.a"; # Do not disable the rule EXPAT for Stronghold, since this # rule is not implementated yet and breaks the configure process. if(is_ssl() !~ /stronghold/i) { $cmd .= " --disable-rule=EXPAT"; } if($USE_DSO) { $cmd .= " --enable-shared=perl"; } if($APACI_ARGS) { $cmd .= " " . join " ", split(',', $APACI_ARGS); } if($APACHE_PREFIX and $APACI_ARGS !~ /--prefix=/) { $cmd .= " --prefix=$APACHE_PREFIX"; } if ($APACI_ARGS =~ /--target=(\S+)/) { $TARGET = $1; } if($ADD_MODULE) { for (split ",", $ADD_MODULE) { if(/^([a-zA-Z0-9][a-zA-Z0-9_]+)$/) { $cmd .= " --enable-module=$1"; } elsif(m:(src/modules/[^/]+/[^/]+)$:) { $cmd .= " --activate-module=$1"; } } } print "(cd $APACHE_ROOT && $cmd)\n"; system "(cd $APACHE_ROOT && $cmd)"; } if($USE_APXS) { my $cmd = "./configure --with-perl=$^X"; $cmd .= " --with-apxs=$WITH_APXS" if $WITH_APXS; system "(cd apaci && $cmd)"; } #expand ./t to full path iedit "t/conf/httpd.conf", "s: \./t(\\S*): $PWD/t\$1:"; for (qw(User Group)) { iedit "t/conf/httpd.conf", "s/^$_ .*/$_ $$_/"; } conf_append(<= 121 or $mmn >= MMN_130; conf_append("PerlChildInitHandler My::child_init") if $My::child_init; conf_append("PerlChildExitHandler My::child_exit") if $My::child_exit; conf_append("PerlTransHandler My::ProxyTest") if $callback_hooks{PERL_TRANS} and $callback_hooks{PERL_STACKED_HANDLERS} and $mmn > 19980270 and $Is_dougm; conf_append(< SetHandler perl-script PerlHandler Stacked::one Stacked::two Stacked::three Stacked::four EOF } { (my $pmv = $VERSION) =~ s/_//g; $pmv =~ s/-dev$//; my $hooks = "@mod_perl_hooks"; my $dummy = "hooks=`$hooks'\n" unless $hooks; cp "lib/mod_perl_hooks.pm.PL", "lib/mod_perl_hooks.pm"; iedit "lib/mod_perl_hooks.pm", qq(s/sub mod_perl::hooks.*/sub mod_perl::hooks { qw($hooks) }/); require "lib/mod_perl_hooks.pm"; my @list = mod_perl::hooks(); if ($Is_Cygwin) { } else { @list == @mod_perl_hooks or die "Edit of lib/mod_perl_hooks.pm failed $!\n"; } unlink "lib/mod_perl_hooks.pm~"; } #checking for LWP code, borrowed from LWP's own Makefile.PL :-) unless ($Is_Win32) { print "Checking CGI.pm VERSION.........."; eval { require CGI; }; if($CGI::VERSION >= 2.39) { print "ok\n"; } else { print "I suggest upgrading from $CGI::VERSION to 2.39+\n"; sleep 2; } print "Checking for LWP::UserAgent......"; eval { require LWP::UserAgent; }; if ($@) { $no_lwp++; $missing_modules++; print "failed\n"; print <t/docs/blib.pl"; print FH "use lib qw(\n", (map { "$PWD/$_\n" } qw(blib/lib blib/arch)), ");\n1;\n"; close FH; for my $f (qw(.htaccess hooks.txt)) { open FH, ">t/docs/$f"; print FH " "; close FH; chmod 0666, "t/docs/$f";#make sure httpd can write to it } if($PERL_SSI) { cp "t/modules/ssi.test", "t/modules/ssi.t"; } else { unlink "t/modules/ssi.t"; # might be there from prior run } mkdir "t/docs/subr", 0755; system "date > t/docs/subr/index.html"; return unless $callback_hooks{PERL_STACKED_HANDLERS} and $callback_hooks{PERL_FIXUP}; local *FH; my $meth_test; if($callback_hooks{PERL_METHOD_HANDLERS}) { $meth_test = <<'EOF'; #see startup.pl PerlFixupHandler MyClass->method PerlFixupHandler $MyClass::Object->method PerlFixupHandler MyClass PerlFixupHandler LoadClass PerlFixupHandler LoadClass->method EOF } my $dir = "t/docs/stacked"; mkdir $dir, 0755; cp "t/docs/test.html", $dir; open FH, ">$dir/.htaccess"; print FH < \@DIR, NAME => "mod_perl", VERSION => $VERSION, ($] < 5.005 ? () : ( ABSTRACT => 'Embed a Perl interpreter in the Apache HTTP server', AUTHOR => 'Doug MacEachern ', )), #should override `CCFLAGS', can't with older perls #CCDLFLAGS => "$Config{ccdlflags} $EXTRA_CFLAGS", DEFINE => $EXTRA_CFLAGS, macro => { PERL => $Config{'perlpath'}, OPCODE_FILE => "src/opcodes.txt", APACHE_ROOT => $APACHE_ROOT, APACHE_SRC => $APACHE_SRC, ARCHNAME => $Config{archname}, HTTPD => $TARGET, PORT => $PORT, PWD => $PWD, PERL5LIB => "PERL5LIB=$ENV{PERL5LIB}", SHRPENV => $Config{shrpenv}, CVSROOT => 'perl.apache.org:/home/cvs', }, 'dist' => { COMPRESS=> 'gzip -9f', SUFFIX=>'gz', CI => qq(ci -u -m\\"See Changes file\\"), }, clean => { FILES => "@do_clean", } ); if ($Is_Win32) { print <<'END'; Beginning with version 1.3.15, Apache uses a different convention for Win32 module names. Correspondingly, the name of the mod_perl module built here has been changed from ApacheModulePerl.dll to mod_perl.so. Please see INSTALL.win32 for further details. END } print "*** BSDI users: be sure to read the INSTALL `Notes' section ***\n" if $Config{osname} =~ /bsdos/i; cleanup_for_static(); sub MY::dist_basics { my $self = shift; my $string = $self->MM::dist_basics; if($USE_APXS) { $string =~ s/(distclean\s+::\s+)/$1 apxs_distclean /; } return $string; } sub MY::clean { my $self = shift; my $string = $self->MM::clean(@_); if ($win32_auto) { $string .= sprintf qq{\tmsdev src\\modules\\win32\\mod_perl.dsp \\\n} . qq{\t/MAKE "mod_perl - Win32 %s" /CLEAN\n}, ($win32_args{DEBUG} == 1) ? 'Debug' : 'Release'; return $string; } unless($NO_HTTPD) { my $asrc = asrc($APACHE_SRC, "http_main.c"); return $string unless $APACHE_SRC and -e "$asrc/http_main.c"; $string .= "\t-cd \$(APACHE_SRC) && \$(MAKE) clean\n"; } if($USE_APXS) { $string .= "\t-cd ./apaci && \$(MAKE) clean\n"; } $string; } sub MY::install { my $self = shift; my $string = $self->MM::install; my $add = ""; if($USE_APXS) { $add = "apxs_install"; } elsif ($win32_auto and $win32_args{INSTALL_DLL}) { $add = 'amp_install'; } elsif($USE_APACI) { if($APACI_ARGS =~ /--prefix=/ or $APACHE_PREFIX) { $add = "apaci_install"; } } if($add and (!$NO_HTTPD and !$PREP_HTTPD) or $USE_APXS or $win32_auto) { $string =~ s/(pure_install\s+)(.*)/$1 $add $2/; } return $string; } sub MY::top_targets { my $self = shift; my $string = $self->MM::top_targets; return $string unless $USE_APXS or $USE_APACI or $APACHE_SRC or $win32_auto; if ($win32_auto) { $string =~ s/(pure_all\s+::.*\s+subdirs\s+)(.*)/$1 amp_dll $2/; $string .= sprintf qq{\namp_dll:\n} . qq{\tmsdev src\\modules\\win32\\mod_perl.dsp \\\n} . qq{\t/MAKE "mod_perl - Win32 %s" /USEENV\n}, ($win32_args{DEBUG} == 1) ? 'Debug' : 'Release'; if ($win32_args{INSTALL_DLL}) { $string .= sprintf qq{\namp_install:\n\t\$(CP) "%s" "%s"}, "$win32_path{MODPERL_LIB}/mod_perl.so", $win32_args{INSTALL_DLL} . ($win32_args{APACHE_VERS} < 1315 ? '/ApacheModulePerl.dll' : '/mod_perl.so'); } return $string; } if($USE_APXS) { $string =~ s/(pure_all\s+::\s+)(.*)/$1 apxs_libperl $2/; } elsif($USE_APACI and !$PREP_HTTPD) { $string =~ s/(pure_all\s+::\s+)(.*)/$1 apaci_httpd $2/; } elsif($APACHE_SRC) { return $string unless -f "$APACHE_SRC/$Configuration"; my $asrc = asrc($APACHE_SRC, "http_main.c"); if(-e "$asrc/http_main.c" and !$NO_HTTPD) { $string =~ s/(pure_all\s+::\s+)(.*)/$1 apache_httpd $2/; } } $string .= <<'EOF'; gen_exports: $(PERL) -I./lib -MExtUtils::testlib -MApache::Constants::Exports \ -e 'Apache::Constants::Exports->gen_ctags' > Exports.c gen_op_mask: $(PERL) -MExtUtils::testlib -MApache::Opcode \ -e 'Apache::Opcode->gen_op_mask' -- $(OPCODE_FILE) > op_mask.c update_op_mask: gen_op_mask @$(RM_F) $(APACHE_SRC)/modules/perl/mod_perl_opmask.o $(CP) op_mask.c $(APACHE_SRC)/modules/perl/op_mask.c apxs_distclean: (cd ./apaci && $(MAKE) distclean) apxs_libperl: (cd ./apaci && $(PERL5LIB) $(MAKE)) apxs_install: apxs_libperl (cd ./apaci && $(MAKE) install;) apache_httpd: $(APACHE_SRC)/Makefile.tmpl (cd $(APACHE_SRC) && $(PERL5LIB) $(SHRPENV) $(MAKE) CC="$(CC)";) apaci_httpd: (cd $(APACHE_ROOT) && $(PERL5LIB) $(MAKE)) apaci_install: (cd $(APACHE_ROOT) && $(MAKE) install) tar_Apache: (cd $(INSTALLSITELIB)/$(ARCHNAME); \ $(TAR) -cf $(PWD)/Apache.tar mod_perl.pm Apache.pm Apache $(ARCHNAME)/auto/Apache; ) offsite-tar: $(CP) MANIFEST MANIFEST.orig $(PERL) -e 'for (<$(APACHE_SRC)/*.h>) {' \ -e 'system "$(CP) $$_ src/";' \ -e 's,^$(APACHE_SRC),,;' \ -e 'system "echo src$$_ >> MANIFEST";' \ -e '}' $(MAKE) dist $(RM_F) src/*.h $(MV) MANIFEST.orig MANIFEST EOF $string; } sub MY::pasthru { return unless $APACHE_SRC; my $self = shift; chomp(my $str = $self->MM::pasthru); join $/, "$str\\", "\t".'APACHE_SRC="$(APACHE_SRC)"\\', "\t".'DEFINE="$(DEFINE)"', ""; } sub MY::test { my $self = shift; my $test = $self->MM::test; my $mmn = magic_number($APACHE_SRC); return <<'EOF' if $USE_APXS and not $Is_dougm; test: @echo "Can't make test with APXS (yet)" EOF return <<'EOF' if $USE_DSO and ($mmn <= 19980527) and not $Is_dougm; test: @echo "Can't make test with DSO (yet)" EOF my $script = "t/TEST"; $script .= ".win32" if $Is_Win32; my $my_test = $Is_Win32 ? q( test: run_tests ) : q( test: pure_all start_httpd run_tests kill_httpd ); my $have_so = $USE_DSO || ($APACI_ARGS =~ /--enable-shared=/); push @test_pre_init, "\t", './apaci/load_modules.pl $(APACHE_SRC)', "\n" if $have_so; join '', @test_pre_init, qq( MP_TEST_SCRIPT=$script ), q( TEST_VERBOSE=0 kill_httpd: kill `cat t/logs/httpd.pid` @$(RM_F) t/conf/srm.conf @$(RM_F) t/logs/mod_perl.lock* $(RM_F) t/logs/httpd.pid $(RM_F) t/logs/error_log start_httpd: test_pre_init @(cd t/conf; test -f httpd.conf || cp httpd.conf-dist httpd.conf) @(cd t/net; test -f config.pl || cp config.pl.dist config.pl) @$(TOUCH) t/conf/srm.conf $(APACHE_SRC)/$(HTTPD) -f `pwd`/t/conf/httpd.conf -X -d `pwd`/t & @echo httpd listening on port $(PORT) @echo will write error_log to: t/logs/error_log @echo "letting apache warm up...\c" @sleep 2 @echo done start_httpd_fork: $(APACHE_SRC)/$(HTTPD) -f `pwd`/t/conf/httpd.conf -d `pwd`/t rehttpd: kill_httpd start_httpd run_tests: $(FULLPERL) $(MP_TEST_SCRIPT) $(TEST_VERBOSE) ), $my_test, q( test_report: $(MAKE) test | t/report ); } use File::Find; sub MY::subdirs { my $self = shift; if($ENV{TEST_PERL_DIRECTIVES}) { push @{$self->{DIR}}, "t/TestDirectives"; } $self->MM::subdirs(@_); } sub wanted { return unless /\.h$/ or /os-inline\.c$/; (my $d = $File::Find::dir) =~ s:^\Q$APACHE_SRC::; $d =~ s:^/::; my $from = "$File::Find::dir/$_"; my $to = '$(INST_ARCHLIB)/' . "auto/Apache/include/"; $to .= "$d/" if $d; $to .= $_; $My::self->{PM}->{$from} = $to; } sub MY::post_initialize { my($self) = shift; return unless $APACHE_HEADER_INSTALL; my($ap_src, $ap_inc); if ($APACHE_SRC) { $ap_src = $APACHE_SRC; $ap_inc = "$ap_src/include"; } elsif ($USE_APXS) { #$base = `$WITH_APXS -q INCLUDEDIR`; $ap_inc = $ap_src = 'src'; #just install mod_perl headers } return unless $ap_src and -d $ap_src; $My::self = $self; { local $APACHE_SRC = $ap_src; finddepth(\&wanted, $ap_src); } $self->{PM}{"Apache/typemap"} = '$(INST_ARCHLIB)/' . "auto/Apache/typemap"; $self->{PM}{"apaci/mod_perl.exp"} = '$(INST_ARCHLIB)/' . "auto/Apache/mod_perl.exp"; for (qw(ap_config_auto.h)) { my $from = "$ap_inc/$_"; my $to = '$(INST_ARCHLIB)/' . "auto/Apache/include/$_"; unless ($self->{PM}->{$from}) { $self->{PM}->{$from} = $to; system "$Config{touch} $from"; } } ''; } sub MY::postamble { return <<'EOF'; cvs_export : cvs -d $(CVSROOT) export -rv$(VERSION_SYM) -d$(DISTVNAME) . cvs_tag : cvs -d $(CVSROOT) tag v$(VERSION_SYM) modperl @echo update mod_perl.pm VERSION now EOF } #' sub MY::manifypods { my $self = shift; my $ver = $self->{VERSION} || ""; local($_) = $self->MM::manifypods(@_); s/pod2man\s*$/pod2man --release mod_perl-$ver/m; $_; } sub fold_dots { my $v = shift; $v =~ s/\.//g; $v .= "0" if length $v < 3; $v; } sub vcache { my($v,$dir) = @_; $vcache{$dir} = fold_dots($v); } sub httpd_version { my($dir, $vnumber) = @_; local $^W=0; $dir = asrc($dir) || ""; if($vnumber) { return $vcache{$dir} if $vcache{$dir}; } my $fh = FileHandle->new("$dir/httpd.h") or return; my($server, $version, $rest); my($fserver, $fversion, $frest); my($string, $extra, @vers); while(<$fh>) { next unless /^#define/; s/SERVER_PRODUCT \"/\"Apache/; #1.3.13 next unless s/^#define\s+SERVER_(BASE|)(VERSION|REVISION)\s+"(.*)\s*".*/$3/; unless (m:/:) { $_ = "Apache/$_"; #1.3.14, argh } chomp($string = $_); #print STDERR "Examining SERVER_VERSION '$string'..."; #could be something like: #Stronghold-1.4b1-dev Ben-SSL/1.3 Apache/1.1.1 @vers = split /\s+/, $string; foreach (@vers) { next unless ($fserver,$fversion,$frest) = m,^([^/]+)/(\d\.\d+\.?\d*)([^ ]*),i; #print STDERR "match ($fserver,$fversion,$frest)\n"; if($fserver =~ /Xcert-Sentry/i or $fserver eq "Ben-SSL") { $extra ||= $fserver; #print STDERR "I see $fserver/$fversion, ok\n"; next; } if($fserver eq "Apache") { ($server, $version) = ($fserver, $fversion); if($version eq '1.2' and $frest =~ s/^b(\d+).*/$1/) { if($frest >= 8 and is_ssl($dir)) { $do_link_swap++; $can_dash_make{$dir}++; return $vnumber ? vcache($version,$dir) : "NONE"; } warn "Apache/1.2b$frest is not supported, upgrade to 1.2.0.\n"; return undef; } elsif($version >= 1.2) { $do_link_swap++ if is_ssl($dir); $can_dash_make{$dir}++; return $vnumber ? vcache($version,$dir) : "NONE"; } } else { #print STDERR "'$fserver/$fversion' unrecognized.\n"; next; } print STDERR "Found $fserver '$fversion' in $dir/httpd.h\n"; } } $fh->close; #print STDERR "return $version$extra\n"; return($version.$extra); } use lib "./lib"; use Apache::src (); sub magic_number { my $d = asrc shift; my $src = Apache::src->new; $src->dir($d); return($mcache{$d} = $src->module_magic_number); } sub cleanup_for_static { return unless $STATIC; for (@xs_mod_snames) { rename "${_}/${_}.xs.disabled", "${_}/${_}.xs"; } } sub setup_for_static { my $d = "$APACHE_SRC/modules/perl"; my $mf = "$APACHE_SRC/modules/perl/Makefile"; my @static_src = (); unless ($USE_APACI) { iedit $mf, "s/(PERL_STATIC_EXTS) =.*/\$1 = $PERL_STATIC_EXTS/" if $PERL_STATIC_EXTS; } return unless $STATIC; cp "Apache/typemap", $d; for (@xs_mod_snames) { rename "${_}/${_}.xs", "${_}/${_}.xs.disabled" if -e "${_}/${_}.xs"; push @static_src, "$_.c"; } =pod my @xs_names = (); my @xs_files = (); my $dir = "src/modules/perl"; my $dh = DirHandle->new($dir) or die; for my $file ($dh->read) { next unless $file =~ /\.xs$/; push @xs_names, module_name_from_xs("$dir/$file"); push @xs_files, $file; unless ($mani_src{"$dir/$file"}) { cp "$dir/$file", $d; print "Adding module `$xs_names[-1]' to httpd\n"; } } #print "XS_NAMES=@xs_names\n"; #print "XS_FILES=@xs_files\n"; #XXX think about this some more iedit $mf, "s/^#STATIC_SRC.*/STATIC_SRC = @xs_files/"; iedit $mf, "s/^#STATIC_EXTS.*/STATIC_EXTS = @xs_names/"; =cut unless ($USE_APACI) { #XXX: ho,hum, need to generate the whole damn thing #instead of all these frigging iedits. if ($DYNAMIC) { } else { iedit $mf, "s/^#STATIC_SRC.*/STATIC_SRC = @static_src/"; iedit $mf, "s/^#STATIC_EXTS.*/STATIC_EXTS = @xs_modules/"; iedit $mf, "s/^#STATIC_/STATIC_/"; } #bloody hell, make sucks and so does this. #this has only cause a few people pain, enough. iedit $mf, "s/ \Q\$(STATIC_SRC)\E/ @static_src/"; } } sub module_name_from_xs { my $file = shift; my $fh = FileHandle->new($file) or die "can't open file $file $!"; my($module, $package, $prefix, %seen); while(<$fh>) { if( ($module, $package, $prefix) = /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { $seen{$module}++; } } if(keys %seen > 1) { warn "$module name guess might be incorrect"; } return (keys %seen)[0]; } sub asrc { my $d = shift; my $file = shift || "httpd.h"; return $d if -e "$d/$file"; return "$d/include" if -e "$d/include/$file"; return "$d/main" if -e "$d/main/$file"; return undef; } sub conf_append { local *CFG; open CFG, ">>t/conf/httpd.conf" or die "open httpd.conf $!"; print CFG join "\n", @_, ""; close CFG; } sub edit_extra_cflags { my($cfg) = @_; my $fh = IO::File->new($cfg) or die "open $cfg $!"; my $repl = ""; my @file = (); my $ccopts = ccopts(); my $dssv = "-DSERVER_SUBVERSION"; my $ssv = qq($dssv=\\"mod_perl/$VERSION\\" ); my $inc = " $ccopts -I. -I../.. -DUSE_PERL_SSI" if $PERL_SSI; $inc .= " -DAPACHE_SSL" if is_ssl() and $PERL_SSI; $inc .= $SSL_INCLUDE if $SSL_INCLUDE; $inc .= " -DSTRONGHOLD" if is_ssl() =~ /stronghold/i; $inc .= " $PERL_EXTRA_CFLAGS" if $PERL_EXTRA_CFLAGS; $inc .= " -DMOD_PERL"; while (<$fh>) { push @file, $_; next unless /EXTRA_CFLAGS\s*=/; next if /mod_perl/; next if /^#/; chomp; $repl = $_; my $backwhack = ""; if($repl =~ s/(\\)\s*$//) { $backwhack = $1; } my $mmn = magic_number($APACHE_SRC); if($mmn >= 19980507) { $ADD_VERSION = 0; } if($ADD_VERSION) { if(/$dssv=/) { $repl =~ s{ $dssv\s*=\s*(.?)['"](.*?)(.?)["'] }[ qq($dssv="$1"$2 mod_perl/$VERSION$3"") ]ex; } else { $repl .= " $ssv"; } } $file[-1] = "$repl $inc $backwhack\n"; } close $fh; if($repl) { $fh = IO::File->new(">$cfg") or die "open $cfg $!"; print $fh#~MOD_PERL1_25_MUP.SAVE y OD_PERL1_25]MAKEFILE.PL;1.F\ @file; close $fh; } } sub conf_fixup { my($mf, $cfg) = @_; return if $USE_APACI; my $mmn = magic_number($APACHE_SRC); #source re-org my $sro = 1 if $mmn >= 19970825; edit_extra_cflags($cfg); $PERL_STATIC_EXTS ||= ""; $libperl ||= ""; my $ldopts = "`$^X $PWD/src/modules/perl/ldopts $PERL_STATIC_EXTS $libperl`"; iedit $cfg, q{next unless /EXTRA_LIBS\s*=/;}. q{next if /perl/; chomp;}. qq{\$_ .= q| $ldopts\n|;}; for (split ",", $ADD_MODULE) { add_module($cfg,$_); } if(is_ssl() =~ /stronghold/i) { if($do_link_swap) { warn "swapping link order in $mf for Stronghold\n"; my $repl = quotemeta('$(REGLIB) $(LIBS)'); iedit $mf, "s:\Q\$(LIBS) \$(REGLIB)\E:$repl:;"; #XXX hack $repl = quotemeta('CFLAGS=$(CFLAGS)'); iedit $mf, qq(s:\Q\"CFLAGS=\$(CFLAGS)"\E:'$repl':;); #" } my $repl = q{AUX_CFLAGS='\$(CFLAGS)'}; iedit $mf, qq{s/AUX_CFLAGS="..CFLAGS."/$repl/}; } { my $repl = q{CC='\$(CC)'}; iedit $mf, qq{s/CC=..CC. /$repl /}; } open(CONF, $cfg) || die "Can't open $cfg: $!"; while () { $seen_modperl++ if /^Module\s+perl_module/i || /^AddModule\s+.*libperl/; } close(CONF); unless ($seen_modperl) { print "Appending mod_perl to $conf\n"; open(CONF, ">>$cfg") || die "Can't open $cfg: $!"; my $line; $line = $sro ? "AddModule modules/perl/libperl.a" : "Module perl_module modules/perl/libperl.a"; print CONF <) { if(/^\\w{0,3}Module\\s+.*$name\.[oa]/i) { close IN; # print STDERR "has module $name\n"; return 1; } } return 0; } sub add_module { my($cfg, $name) = @_; iedit $cfg, "s/^#\\s+(\\w{0,3}Module\\s+.*$name\.[oa])/\$1/"; } sub gen_script { my $file = shift; local(*IN,*OUT); open IN, "$file.PL" or die "Couldn't open $file.PL: $!"; open OUT, ">$file" or die "Couldn't open $file: $!"; print OUT "#!$Config{perlpath}\n", join '', ; close OUT; close IN; chmod 0755, "$file"; } sub iedit { my $file = shift; return if $Is_Win32; #print STDERR "-e @_\n"; if ($Is_Cygwin) { system $^X, "-e", "@_", $file; } else { system $^X, "-pi~", "-e", "@_", $file; } } sub win32_setup { my $d = "src/modules/perl"; dirent_kludge($d); cp "Apache/typemap", $d; chdir $d; system "$^X -MExtUtils::Embed -e xsinit -- -std @xs_modules $PERL_STATIC_EXTS"; my $lib = $Config{privlibexp}; for (@xs_mod_snames) { system "$^X $lib/ExtUtils/xsubpp -typemap $lib/ExtUtils/typemap $_.xs > $_.c"; } chdir "../../../"; } sub dirent_kludge { my $d = shift; local *FH; open FH, ">$d/dirent.h" or die "can't write $d/dirent.h $!"; print FH <$d/mod_perl_version.h" or die "can't write $d/mod_perl_version.h $!"; print FH < '$win32_path{APACHE_INC}', 'APACHE_LIB' => '$win32_path{APACHE_LIB}', 'MODPERL_INC' => '$win32_path{MODPERL_INC}', 'MODPERL_LIB' => '$win32_path{MODPERL_LIB}', EOS } local *FH; # writing Configuration to Apache::MyConfig open FH, '>lib/Apache/MyConfig.pm' || die "Can't open lib/Apache/MyConfig.pm: $!"; print FH < \'$APACHE_SRC\', 'SSL_BASE' => \'$SSL_BASE\', 'APXS' => \'$WITH_APXS\', 'PERL_USELARGEFILES' => \'$PERL_USELARGEFILES\', EOT foreach my $key (sort @callback_hooks) { print FH " \'$key\' => \'$callback_hooks{$key}\',\n"; } print FH < module provides access to the various hooks and features set when mod_perl is built. This circumvents the need to set up a live server just to find out if a certain callback hook is available. Itterate through \%Apache::MyConfig::Setup to get obtain build information then see Appendix B of the Eagle book for more detail on each key. EOT close FH; } # obtain the Apache and mod_perl lib and include directories for Win32 sub win32_inc_and_lib { my $modperl_src = win32_fix_path(cwd) . '/src'; $win32_path{MODPERL_INC} = $modperl_src . '/modules/perl'; $win32_path{MODPERL_LIB} = ($win32_args{DEBUG} == 1) ? $modperl_src . '/modules/win32/Debug' : $modperl_src . '/modules/win32/Release'; unless ( -d $win32_args{APACHE_SRC}) { opendir(DIR, '../') or die "Cannot read parent directory: $!\n"; my @dirs = map {"../$_"} grep {/apache/ and -d "../$_"} readdir DIR; closedir DIR or die "Cannot close parent directory: $!\n"; die "Cannot find the apache sources\n" unless ($win32_args{APACHE_SRC} = find_dir(\@dirs, 'apache source')); } $win32_args{APACHE_SRC} = win32_fix_path($win32_args{APACHE_SRC}); $win32_args{APACHE_SRC} .= '/src' unless $win32_args{APACHE_SRC} =~ /src$/; $win32_path{APACHE_INC} = $win32_args{APACHE_SRC} . '/include'; $win32_args{APACHE_VERS} = httpd_version($win32_path{APACHE_INC}, 1); $win32_path{APACHE_LIB} = ($win32_args{DEBUG} == 1) ? $win32_args{APACHE_SRC} . ($win32_args{APACHE_VERS} < 1315 ? '/CoreD' : '/Debug') : $win32_args{APACHE_SRC} . ($win32_args{APACHE_VERS} < 1315 ? '/CoreR' : '/Release'); die "Cannot find ApacheCore.lib under $win32_path{APACHE_LIB}\n" unless -f "$win32_path{APACHE_LIB}/ApacheCore.lib"; if ($win32_args{INSTALL_DLL} ) { $win32_args{INSTALL_DLL} = win32_fix_path($win32_args{INSTALL_DLL}); unless ( -d $win32_args{INSTALL_DLL}) { my @dirs = grep {-d} ('\Program Files\Apache Group\Apache\modules', '\Apache\modules', '\Program Files\Apache\modules'); $win32_args{INSTALL_DLL} = find_dir(\@dirs, 'Apache/modules'); if ($win32_args{INSTALL_DLL} and -d $win32_args{INSTALL_DLL}) { $win32_args{INSTALL_DLL} = win32_fix_path($win32_args{INSTALL_DLL}); } else { print <<'END'; **** The Apache/modules directory was not found. ******* **** Please install mod_perl.so manually. ******* END } } } } # fix mod_perl.dsp with the perl and apache inc and lib directories sub win32_fix_dsp { my $amp = 'src/modules/win32'; my $dsp = 'mod_perl.dsp'; unless ( -f "$amp/$dsp.orig") { rename("$amp/$dsp", "$amp/$dsp.orig") or die "Couldn't rename $amp/$dsp: $!\n"; } my $perl_inc = win32_fix_path_dsp("$Config{archlibexp}/CORE"); open(OLDDSP, "$amp/$dsp.orig") or die "Couldn't read $amp/$dsp.orig: $!\n"; open(NEWDSP, ">$amp/$dsp") or die "Couldn't create $amp/$dsp: $!\n"; while () { if (/^SOURCE=.*ApacheCore\.lib/) { printf NEWDSP "SOURCE=%s\n", win32_fix_path_dsp("$win32_path{APACHE_LIB}/ApacheCore.lib"); } elsif (/^SOURCE=.*perl(56)?\.lib/) { print NEWDSP qq{SOURCE=$perl_inc\\$Config{libperl}\n}; } elsif (/ADD CPP/) { my $apache_inc = win32_fix_path_dsp($win32_path{APACHE_INC}); s!(/D "WIN32")!/I "$apache_inc" /I "$perl_inc" $1!; s!(/D "WIN32")!$1 /D "EAPI" ! if $win32_args{EAPI}; print NEWDSP $_; } else { print NEWDSP $_; } } close OLDDSP; close NEWDSP; return; } # find a directory of type $type, given some possible $dirs sub find_dir { my ($dirs, $type) = @_; my $j = 0; my $src; while (1) { $src = @$dirs > 0 ? $dirs->[$j] : ''; $src = prompt("\nWhere is your $type directory? (q to quit)", $src); return undef if $src eq 'q'; return $src if -d $src; print qq{'$src': no such directory\n}; $j = ($j == @$dirs-1) ? 0 : $j + 1; } } # fix a path for Win32 Makefile sub win32_fix_path { local $_ = shift; $_ = File::Spec->rel2abs($_) if not File::Spec->file_name_is_absolute($_); tr!\\!/!; s!/$!!; return $_; } # fix a path for mod_perl.dsp sub win32_fix_path_dsp { local $_ = shift; tr!/!\\!; s!^\w:!!; return $_; } #in version 1.2505 of Embed.pm we could just import these instead of using ``, #but it might require lots of people to upgrade sub ccopts { unless ($Embed::ccopts) { $Embed::ccopts = "$Config{ccflags} -I$Config{archlibexp}/CORE"; if($USE_THREADS) { $Embed::ccopts .= " -DPERL_THREADS"; } } $Embed::ccopts; } sub ldopts { $Embed::ldopts ||= `$^X -MExtUtils::Embed -e ldopts`; if($^O eq "aix") { $Embed::ldopts =~ s,(-bE:)(perl\.exp),$1$Config{archlibexp}/$2,; } $Embed::ldopts; } sub perl_version { my $v = "$]"; $v =~ s/\.//g; $v .= "0" while length($v) < 6; $v; } #for linking third-party xs modules static built w/ MakeMaker's: 'make static' #must have when the xs module is compiled with profiling `-pg -a' flags sub add_static_ar { $PERL_STATIC_AR ||= ""; my $cur = $APACHE_SRC =~ /^../ ? "$PWD/" : ""; for (qw(blib/arch/auto arch/auto)) { last if -d ($ar_dir = "$APACHE_SRC/modules/perl/$_"); $ar_dir = ""; } return unless -d $ar_dir; finddepth(sub { return unless /^[A-Z]\w+\.a$/; (my $rel = $File::Find::dir) =~ s:$APACHE_SRC/?::; (my $mod = $rel) =~ s:.*auto/::; $mod =~ s,/,::,; print "linking static $mod => $rel/$_\n"; $PERL_STATIC_AR .= $cur . "$File::Find::dir/$_ "; $PERL_STATIC_EXTS .= "$mod "; }, $ar_dir); } sub APACI::init { return undef if $Is_Win32; my $lib_cfg; if($USE_APXS) { $lib_cfg = "apaci/mod_perl.config"; chmod 0644, $lib_cfg; } elsif($USE_APACI) { $lib_cfg = "$APACHE_SRC/modules/perl/mod_perl.config"; } else { return undef; } unless (File::Compare::compare($lib_cfg,"apaci/mod_perl.config") == 0) { #warn "mod_perl.config already edited\n"; #return undef; } my $apaci_cfg = FileHandle->new(">$lib_cfg") or die "can't open $lib_cfg $!"; my @static_src = (); for (@xs_mod_snames) { push @static_src, "$_.c"; } add_static_ar(); my $static_targets = ""; $static_targets = <= 5.006 ? 'A' : 'D'; phat_warn(<; } my $suggest = @maybe ? "You could just symlink it to $maybe[0]" : "You might need to install Perl from source"; phat_warn(<= 5.006 and $Config{uselargefiles} and $PERL_USELARGEFILES and $USE_APXS; local $Apache::src::APXS = $WITH_APXS; my $cflags = Apache::src->new->apxs('-q' => 'CFLAGS') || ''; return if $cflags =~ /LARGEFILE/; phat_warn(<refCnt = 1; mp->next = modList; modList = mp; - if (loadbind(0, mainModule, mp->entry) == -1) { + /* + * Assume anonymous exports come from the module this dlopen + * is linked into, that holds true as long as dlopen and all + * of the perl core are in the same shared object. Also bind + * against the main part, in the case a perl is not the main + * part, e.g mod_perl as DSO in Apache so perl modules can + * also reference Apache symbols. + */ + if (loadbind(0, (void *)dlopen, mp->entry) == -1 || + loadbind(0, mainModule, mp->entry) == -1) { dlclose(mp); errvalid++; strcpy(errbuf, "loadbind: "); @@ -336,12 +343,6 @@ safefree(mp->name); safefree(mp); return result; -} - -static void terminate(void) -{ - while (modList) - dlclose(modList); } /* Added by Wayne Scott EOF } $*[MOD_PERL1_25]MAKEPL_ARGS.MOD_PERL;1+,.E/A@ 4OE-y 0123KPWO56)y7U;鐟89GA@HJ#example makepl_args.mod_perl files #copy this file to $ENV{HOME}/.makepl_args.mod_perl and edit to taste #mod_perl's Makefile.PL will also look for this file in ./ ../ relative #to the mod_perl-x.xx source tree #EVERYTHING=1 will enable: #ALL_HOOKS=1 PERL_SSI=1 PERL_SECTIONS=1 #PERL_STACKED_HANDLERS=1 PERL_METHOD_HANDLERS=1 PERL_TABLE_API=1 EVERYTHING=1 #build against the first apache_x.xx source tree found, without prompts # DO_HTTPD=1 #could tell Makfile.PL exactly where the source is # APACHE_SRC=/tmp/apache_x.xx/src #this would configure in mod_proxy, mod_unique_id, mod_info and mod_status # ADD_MODULE=proxy,usertrack,unique_id,info,status #if you wish to use a Configuration file other than what's in the #apache_x.xx/src directory # CONFIG=Configuration.custom #depending on your os and site_perl modules, see mod_perl's INSTALL # PERL_STATIC_EXTS=... #apache header files are installed by default, stop that if you wish # APACHE_HEADER_INSTALL=0 #Apache and Apache::Constants modules will be built as shared libraries # DYNAMIC=1 #turn on mod_perl tracing # PERL_TRACE=1 #for perl.c's perl_destruct() which in run by mod_perl during child_exit #comment from perl.c: /* 0=none, 1=full, 2=full with checks */ #default level is 0 # PERL_DESTRUCT_LEVEL=2 #-add `-g' to EXTRA_CFLAGS #-turn on PERL_TRACE #-set PERL_DESTRUCT_LEVEL=2 #-link against libperld if -e $Config{archlibexp}/CORE/libperld$Config{lib_ext} # PERL_DEBUG=1 ######################################################################### #experimental features, use at own risk #but please report success or failure if you try #try to stop "Use of uninitialized value." with no line/filename info # PERL_MARK_WHERE=1 #have mod_perl handle internal redirects (doesn't seem to work w/ sfio) #can also enable via $Apache::DoInternalRedirect = 1; # DO_INTERNAL_REDIRECT=1 #enable the PerlRestartHandler which will be called during restart #this happens just before PerlFreshRestart does it's thang #PERL_RESTART_HANDLER=1 __END__  *[MOD_PERL1_25]MODULECONFIG.DIR;1+, .E/A@ 4E-y 0123 KPWOF56G+ k7G+ k89GA@HJI  MAKEFILE.PL!(*[MOD_PERL1_25.MODULECONFIG]MAKEFILE.PL;2+,!.E/A@ 4gE- 0123KPWO56Tc7[o89GA@HJuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; if ($^O eq 'VMS') { WriteMakefile( NAME => "Apache::ModuleConfig", VERSION_FROM => "ModuleConfig.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( NAME => "Apache::ModuleConfig", VERSION_FROM => "ModuleConfig.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; } (*[MOD_PERL1_25.MODULECONFIG]MAKEFILE.PL;1+,.E/A@ 4E- 0D123 KPWO56Tٳ酟7 酟89GA@HJ N $J)g7 %J)g7J)g7.  1%z1%z1%zuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; WriteMakefile( NAME => "Apache::ModuleConfig", VERSION_FROM => "ModuleConfig.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); *[MOD_PERL1_25]PERLRUNXS.DIR;1+, .E/A@ 4E-y 0123 KPWOF56k7k89GA@HJI  MAKEFILE.PL'%*[MOD_PERL1_25.PERLRUNXS]MAKEFILE.PL;2+,.E/A@ 4gE- 0123KPWO56Uc7Eo89GA@HJuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; if ($^O eq 'VMS') { WriteMakefile( 'NAME' => 'Apache::PerlRunXS', 'VERSION_FROM' => 'PerlRunXS.pm', 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( 'NAME' => 'Apache::PerlRunXS', 'VERSION_FROM' => 'PerlRunXS.pm', 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; } %*[MOD_PERL1_25.PERLRUNXS]MAKEFILE.PL;1+,'.E/A@ 4E- 0D123 KPWO56酟7i0酟89GA@HJ N $J)g7 %J)g7J)g7.  1%z1%z1%zuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; WriteMakefile( 'NAME' => 'Apache::PerlRunXS', 'VERSION_FROM' => 'PerlRunXS.pm', 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); *[MOD_PERL1_25]SERVER.DIR;1+,.E/A@ 4E-y 0123 KPWOF56ik7ik89GA@HJI  MAKEFILE.PL"*[MOD_PERL1_25.SERVER]MAKEFILE.PL;2+,.E/A@ 4gE-0123KPWO56Æ$ d7Go89GA@HJuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; if ($^O eq 'VMS') { WriteMakefile( 'NAME' => 'Apache::Server', 'VERSION_FROM' => 'Server.pm', 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( 'NAME' => 'Apache::Server', 'VERSION_FROM' => 'Server.pm', 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; } "*[MOD_PERL1_25.SERVER]MAKEFILE.PL;1+,.E/A@ 4E-0D123 KPWO56y&M酟7 7酟89GA@HJ N $J)g7 %J)g7J)g7.  1%z1%z1%zuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; WriteMakefile( 'NAME' => 'Apache::Server', 'VERSION_FROM' => 'Server.pm', 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); *[MOD_PERL1_25]SRC.DIR;1+,~.E/A@ 4E-y 0123 KPWOF569Ih79Ih89GA@HJI MODULES.DIR*[MOD_PERL1_25.SRC]MODULES.DIR;1+,.E/A@ 4E-~0123 KPWOF56?Ih7?Ih89GA@HJIPERL.DIR $*[MOD_PERL1_25.SRC.MODULES]PERL.DIR;1+, .E/A@ 4E-0123 KPWOF56`FIh7`FIh89GA@HJI݁f~MOD_PERL1_25_MUP.SAVE $[MOD_PERL1_25.SRC.MODULES]PERL.DIR;1E APACHE.XSH?   APACHE_INC.HIC DESCRIP.MMS] MOD_PERL.CJD MOD_PERL.HKF MOD_PERL.OPT^MOD_PERL_BLD.OPT_  PERL_UTIL.C\G**[MOD_PERL1_25.SRC.MODULES.PERL]APACHE.XS;2+,H./A@ 4RU- 0D123KPWOV56q␟7 D鐟89GA@HJN $J)g7 %J)g7J)g7x/* ==================================================================== * The Apache Software License, Version 1.1 * * Copyright (c) 1996-2000 The Apache Software Foundation. All rights * reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in * the documentation and/or other materials provided with the * distribution. * * 3. The end-user documentation included with the redistribution, * if any, must include the following acknowledgment: * "This product includes software developed by the * Apache Software Foundation (http://www.apache.org/)." * Alternately, this acknowledgment may appear in the software itself, * if and wherever such third-party acknowledgments normally appear. * * 4. The names "Apache" and "Apache Software Foundation" must * not be used to endorse or promote products derived from this * software without prior written permission. For written * permission, please contact apache@apache.org. * * 5. Products derived from this software may not be called "Apache", * nor may "Apache" appear in their name, without prior written * permission of the Apache Software Foundation. * * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. * ==================================================================== */ #define CORE_PRIVATE #include "mod_perl.h" #include "mod_perl_xs.h" #ifdef USE_SFIO #undef send_fd_length static long send_fd_length(FILE *f, request_rec *r, long length) { croak("Apache::send_fd() not supported with sfio"); return 0; } #endif #if defined(PERL_STACKED_HANDLERS) && defined(PERL_GET_SET_HANDLERS) #define PER_DIR_CONFIG 1 #define PER_SRV_CONFIG 2 typedef struct { int type; char *name; void *offset; void (*set_func) (void *, void *, SV *); } perl_handler_table; typedef struct { I32 fill; AV *av; AV **ptr; } perl_save_av; static void set_handler_dir (perl_handler_table *tab, request_rec *r, SV *sv); static void set_handler_srv (perl_handler_table *tab, request_rec *r, SV *sv); #define HandlerDirEntry(name,member) \ PER_DIR_CONFIG, name, (void*)XtOffsetOf(perl_dir_config,member), \ (void(*)(void *, void *, SV *)) set_handler_dir #define HandlerSrvEntry(name,member) \ PER_SRV_CONFIG, name, (void*)XtOffsetOf(perl_server_config,member), \ (void(*)(void *, void *, SV *)) set_handler_srv static perl_handler_table handler_table[] = { {HandlerSrvEntry("PerlPostReadRequestHandler", PerlPostReadRequestHandler)}, {HandlerSrvEntry("PerlTransHandler", PerlTransHandler)}, {HandlerDirEntry("PerlHeaderParserHandler", PerlHeaderParserHandler)}, {HandlerDirEntry("PerlAccessHandler", PerlAccessHandler)}, {HandlerDirEntry("PerlAuthenHandler", PerlAuthenHandler)}, {HandlerDirEntry("PerlAuthzHandler", PerlAuthzHandler)}, {HandlerDirEntry("PerlTypeHandler", PerlTypeHandler)}, {HandlerDirEntry("PerlFixupHandler", PerlFixupHandler)}, {HandlerDirEntry("PerlHandler", PerlHandler)}, {HandlerDirEntry("PerlLogHandler", PerlLogHandler)}, {HandlerDirEntry("PerlCleanupHandler", PerlCleanupHandler)}, { FALSE, NULL } }; static void perl_restore_av(void *data) { perl_save_av *save_av = (perl_save_av *)data; if(save_av->fill != DONE) { AvFILLp(*save_av->ptr) = save_av->fill; } else if(save_av->av != Nullav) { *save_av->ptr = save_av->av; } } static void perl_handler_merge_avs(char *hook, AV **dest) { int i = 0; HV *hv = perl_get_hv("Apache::PerlStackedHandlers", FALSE); SV **svp = hv_fetch(hv, hook, strlen(hook), FALSE); AV *base; if(!(svp && SvROK(*svp))) return; base = (AV*)SvRV(*svp); for(i=0; i<=AvFILL(base); i++) { SV *sv = *av_fetch(base, i, FALSE); av_push(*dest, SvREFCNT_inc(sv)); } } static void set_handler_base(void *ptr, perl_handler_table *tab, pool *p, SV *sv) { AV **av = (AV **)((char *)ptr + (int)(long)tab->offset); perl_save_av *save_av = (perl_save_av *)palloc(p, sizeof(perl_save_av)); save_av->fill = DONE; save_av->av = Nullav; if((sv == &sv_undef) || (SvIOK(sv) && SvIV(sv) == DONE)) { if(AvTRUE(*av)) { save_av->fill = AvFILL(*av); AvFILLp(*av) = -1; } } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) { if(AvTRUE(*av)) save_av->av = av_copy_array(*av); *av = (AV*)SvRV(sv); ++SvREFCNT(*av); } else { croak("Can't set_handler with that value"); } save_av->ptr = av; register_cleanup(p, save_av, perl_restore_av, mod_perl_noop); } static void set_handler_dir(perl_handler_table *tab, request_rec *r, SV *sv) { dPPDIR; set_handler_base((void*)cld, tab, r->pool, sv); } static void set_handler_srv(perl_handler_table *tab, request_rec *r, SV *sv) { dPSRV(r->server); set_handler_base((void*)cls, tab, r->pool, sv); } static perl_handler_table *perl_handler_lookup(char *name) { int i; for (i=0; handler_table[i].name; i++) { perl_handler_table *tab = &handler_table[i]; if(strEQ(name, tab->name)) return tab; } return NULL; } static SV *get_handlers(request_rec *r, char *hook) { AV *avcopy; AV **av; dPPDIR; dPSRV(r->server); void *ptr; perl_handler_table *tab = perl_handler_lookup(hook); if(!tab) return Nullsv; if(tab->type == PER_DIR_CONFIG) ptr = (void*)cld; else ptr = (void*)cls; av = (AV **)((char *)ptr + (int)(long)tab->offset); if(*av) avcopy = av_copy_array(*av); else avcopy = newAV(); perl_handler_merge_avs(hook, &avcopy); return newRV_noinc((SV*)avcopy); } static void set_handlers(request_rec *r, SV *hook, SV *sv) { dTHR; perl_handler_table *tab = perl_handler_lookup(SvPV(hook,na)); if(tab && tab->set_func) (*tab->set_func)(tab, r, sv); (void)hv_delete_ent(perl_get_hv("Apache::PerlStackedHandlers", FALSE), hook, G_DISCARD, FALSE); } #endif #if MODULE_MAGIC_NUMBER < 19970909 static void child_terminate(request_rec *r) { #ifndef WIN32 log_transaction(r); #endif exit(0); } #endif static char *custom_response(request_rec *r, int status, char *string) { core_dir_config *conf = (core_dir_config *) get_module_config(r->per_dir_config, &core_module); int idx; char *retval = NULL; if(conf->response_code_strings == NULL) { conf->response_code_strings = (char **) pcalloc(perl_get_startup_pool(), sizeof(*conf->response_code_strings) * RESPONSE_CODES); } idx = index_of_response(status); retval = conf->response_code_strings[idx]; if (string) { conf->response_code_strings[idx] = ((is_url(string) || (*string == '/')) && (*string != '"')) ? pstrdup(r->pool, string) : pstrcat(r->pool, "\"", string, NULL); } return retval; } static void Apache_terminate_if_done(request_rec *r, int sts) { #ifndef WIN32 if(Apache_exit_is_done(sts)) child_terminate(r); #endif } #if MODULE_MAGIC_NUMBER < 19980317 int basic_http_header(request_rec *r); #endif #if MODULE_MAGIC_NUMBER < 19980201 unsigned get_server_port(const request_rec *r) { unsigned port = r->server->port ? r->server->port : 80; return r->hostname ? ntohs(r->connection->local_addr.sin_port) : port; } #define get_server_name(r) \ (r->hostname ? r->hostname : r->server->server_hostname) #endif #if MODULE_MAGIC_AT_LEAST(19981108, 1) #define mod_perl_define(sv,name) ap_exists_config_define(name) #elif(MODULE_MAGIC_NUMBER >= MMN_131) && !defined(WIN32) static int mod_perl_define(SV *sv, char *name) { char **defines; int i; defines = (char **)ap_server_config_defines->elts; for (i = 0; i < ap_server_config_defines->nelts; i++) { if (strcmp(defines[i], name) == 0) { return 1; } } return 0; } #else #define mod_perl_define(sv,name) 0 #endif static int sv_str_header(void *arg, const char *k, const char *v) { SV *sv = (SV*)arg; sv_catpvf(sv, "%s: %s\n", k, v); return 1; } #if MODULE_MAGIC_NUMBER >= 19980806 /* * ap_scan_script_header_err_core(r, buffer, getsfunc_SV, sv) */ #if 0 static int getsfunc_SV(char *buf, int bufsiz, void *param) { SV *sv = (SV*)param; STRLEN len; char *tmp = SvPV(sv,len); int i; if(!SvTRUE(sv)) return 0; for(i=0; i<=len; i++) { if(tmp[i] == LF) break; } Move(tmp, buf, i, char); buf[i] = '\0'; if(len < i) { sv_setpv(sv, ""); } else { tmp += i+1; sv_setpv(sv, tmp); } return 1; } #endif /*0*/ #endif /*MODULE_MAGIC_NUMBER*/ static void rwrite_neg_trace(request_rec *r) { #if HAS_MMN_130 ap_log_error(APLOG_MARK, APLOG_DEBUG, r->server, #else fprintf(stderr, #endif "mod_perl: rwrite returned -1 (fd=%d, B_EOUT=%d)\n", ap_bfileno(r->connection->client, B_WR), r->connection->client->flags & B_EOUT); } #define check_auth_type(r) \ if (!auth_type(r)) { \ (void)mod_perl_auth_type(r, "Basic"); \ } MODULE = Apache PACKAGE = Apache PREFIX = mod_perl_ PROTOTYPES: DISABLE BOOT: items = items; /*avoid warning*/ const char * current_callback(r) Apache r CODE: RETVAL = PERL_GET_CUR_HOOK; OUTPUT: RETVAL int mod_perl_sent_header(r, val=0) Apache r int val int mod_perl_seqno(self, inc=0) SV *self int inc int perl_hook(name) char *name #if defined(PERL_GET_SET_HANDLERS) SV * get_handlers(r, hook) Apache r char *hook CODE: #ifdef get_handlers get_handlers(r,hook); #else RETVAL = get_handlers(r,hook); #endif OUTPUT: RETVAL void set_handlers(r, hook, sv) Apache r SV *hook SV *sv #endif int mod_perl_push_handlers(self, hook, cv) SV *self char *hook SV *cv; CODE: RETVAL = mod_perl_push_handlers(self, hook, cv, Nullav); OUTPUT: RETVAL int mod_perl_can_stack_handlers(self) SV *self void mod_perl_register_cleanup(r, sv) Apache r SV *sv ALIAS: Apache::post_connection = 1 PREINIT: ix = ix; /* avoid -Wall warning */ #define APACHE_REGISTRY_CURSTASH perl_get_sv("Apache::Registry::curstash", TRUE) void mod_perl_clear_rgy_endav(r, sv=APACHE_REGISTRY_CURSTASH) Apache r SV *sv void mod_perl_stash_rgy_endav(r, sv=APACHE_REGISTRY_CURSTASH) Apache r SV *sv CODE: perl_stash_rgy_endav(r->uri, sv); I32 mod_perl_define(sv, name) SV *sv char *name CLEANUP: sv = sv; /*-Wall*/ I32 module(sv, name) SV *sv SV *name CODE: if((*(SvEND(name) - 2) == '.') && (*(SvEND(name) - 1) == 'c')) RETVAL = find_linked_module(SvPVX(name)) ? 1 : 0; else RETVAL = (sv && perl_module_is_loaded(SvPVX(name))); OUTPUT: RETVAL char * mod_perl_set_opmask(r, sv) Apache r SV *sv void untaint(...) PREINIT: int i; CODE: if(!tainting) XSRETURN_EMPTY; for(i=1; iexit */ r = sv2request_rec(ST(0), "Apache", cv); if(items > 1) { sts = (int)SvIV(ST(1)); } else { /* Apache::exit() */ if(SvTRUE(ST(0)) && SvIOK(ST(0))) sts = (int)SvIV(ST(0)); } MP_CHECK_REQ(r, "Apache::exit"); if(!r->connection->aborted) rflush(r); Apache_terminate_if_done(r,sts); perl_call_halt(sts); #in case you need Apache::fork # INCLUDE: fork.xs void CLOSE(...) ALIAS: BINMODE = 1 CODE: items = items; ix = ix; /*NOOP*/ Apache TIEHANDLE(classname, r=NULL) SV *classname Apache r CODE: RETVAL = (r && classname) ? r : perl_request_rec(NULL); OUTPUT: RETVAL int OPEN(self, arg1, arg2=Nullsv) SV *self SV *arg1 SV *arg2 PREINIT: char *name; STRLEN len; GV *gv = gv_fetchpv("STDOUT", TRUE, SVt_PVIO); SV *arg; CODE: sv_unmagic((SV*)gv, 'q'); /* untie *STDOUT */ if (arg2 && self) { arg = newSVsv(arg1); sv_catsv(arg, arg2); } else { arg = arg1; } name = SvPV(arg, len); RETVAL = do_open(gv, name, len, FALSE, O_RDONLY, 0, Nullfp); OUTPUT: RETVAL int FILENO(r) Apache r CODE: RETVAL = fileno(stdout); OUTPUT: RETVAL SV * as_string(r) Apache r CODE: RETVAL = newSVpv(r->the_request,0); sv_catpvn(RETVAL, "\n", 1); table_do(sv_str_header, (void*)RETVAL, r->headers_in, NULL); sv_catpvf(RETVAL, "\n%s %s\n", r->protocol, r->status_line); table_do(sv_str_header, (void*)RETVAL, r->headers_out, NULL); table_do(sv_str_header, (void*)RETVAL, r->err_headers_out, NULL); sv_catpvn(RETVAL, "\n", 1); OUTPUT: RETVAL #httpd.h void chdir_file(r, file=r->filename) Apache r const char *file CODE: chdir_file(file); SV * mod_perl_gensym(pack="Apache::Symbol") char *pack SV * mod_perl_slurp_filename(r) Apache r char * unescape_url(string) char *string CODE: unescape_url(string); RETVAL = string; OUTPUT: RETVAL # # Doing our own unscape_url for the query info part of an url # char * unescape_url_info(url) char * url CODE: register char * trans = url ; char digit ; if (!url || !*url) { XSRETURN_UNDEF; } RETVAL = url; while (*url != '\0') { if (*url == '+') *trans = ' '; else if (*url != '%') *trans = *url; else if (!isxdigit(url[1]) || !isxdigit(url[2])) *trans = '%'; else { url++ ; digit = ((*url >= 'A') ? ((*url & 0xdf) - 'A')+10 : (*url - '0')); url++ ; *trans = (digit << 4) + (*url >= 'A' ? ((*url & 0xdf) - 'A')+10 : (*url - '0')); } url++, trans++ ; } *trans = '\0'; OUTPUT: RETVAL #functions from http_main.c void hard_timeout(r, string) Apache r char *string CODE: #ifndef USE_THREADS hard_timeout(string, r); #endif void soft_timeout(r, string) Apache r char *string CODE: soft_timeout(string, r); void kill_timeout(r) Apache r CODE: #ifndef USE_THREADS kill_timeout(r); #endif void reset_timeout(r) Apache r #functions from http_config.c int translate_name(r) Apache r CODE: #ifdef WIN32 croak("Apache->translate_name not supported under Win32"); RETVAL = DECLINED; #else RETVAL = translate_name(r); #endif OUTPUT: RETVAL #functions from http_core.c char * custom_response(r, status, string=NULL) Apache r int status char *string int satisfies(r) Apache r int some_auth_required(r) Apache r void requires(r) Apache r PREINIT: AV *av; HV *hv; register int x; int m; char *t; MP_CONST_ARRAY_HEADER *reqs_arr; require_line *reqs; CODE: m = r->method_number; reqs_arr = requires (r); if (!reqs_arr) ST(0) = &sv_undef; else { reqs = (require_line *)reqs_arr->elts; iniAV(av); for(x=0; x < reqs_arr->nelts; x++) { /* XXX should we do this or let PerlAuthzHandler? */ if (! (reqs[x].method_mask & (1 << m))) continue; t = reqs[x].requirement; iniHV(hv); hv_store(hv, "method_mask", 11, newSViv((IV)reqs[x].method_mask), 0); hv_store(hv, "requirement", 11, newSVpv(reqs[x].requirement,0), 0); av_push(av, newRV((SV*)hv)); } ST(0) = newRV_noinc((SV*)av); } int allow_options(r) Apache r unsigned get_server_port(r) Apache r const char * get_server_name(r) Apache r char * get_remote_host(r, type=REMOTE_NAME) Apache r int type CODE: RETVAL = (char *)get_remote_host(r->connection, r->per_dir_config, type); OUTPUT: RETVAL const char * get_remote_logname(r) Apache r char * mod_perl_auth_name(r, val=NULL) Apache r char *val const char * mod_perl_auth_type(r, val=NULL) Apache r char *val const char * document_root(r, ...) Apache r PREINIT: core_server_config *conf; CODE: conf = (core_server_config *) get_module_config(r->server->module_config, &core_module); RETVAL = conf->ap_document_root; if (items > 1) { SV *doc_root = perl_get_sv("Apache::Server::DocumentRoot", TRUE); sv_setsv(doc_root, ST(1)); conf->ap_document_root = SvPVX(doc_root); } OUTPUT: RETVAL char * server_root_relative(rsv, name="") SV *rsv char *name PREINIT: pool *p; request_rec *r; CODE: if (SvROK(rsv) && (r = sv2request_rec(rsv, "Apache", cv))) { p = r->pool; } else { if(!(p = perl_get_startup_pool())) croak("Apache::server_root_relative: no startup pool available"); } RETVAL = (char *)server_root_relative(p, name); OUTPUT: RETVAL #functions from http_protocol.c void note_basic_auth_failure(r) Apache r CODE: check_auth_type(r); note_basic_auth_failure(r); void get_basic_auth_pw(r) Apache r PREINIT: MP_CONST_CHAR *sent_pw = NULL; int ret; PPCODE: check_auth_type(r); ret = get_basic_auth_pw(r, &sent_pw); XPUSHs(sv_2mortal((SV*)newSViv(ret))); if(ret == OK) XPUSHs(sv_2mortal((SV*)newSVpv((char *)sent_pw, 0))); else XPUSHs(&sv_undef); char * user(r, ...) Apache r CODE: get_set_PVp(r->connection->user,r->pool); OUTPUT: RETVAL void basic_http_header(r) Apache r CODE: #ifdef WIN32 croak("Apache->basic_http_header() not supported under Win32!"); #else basic_http_header(r); #endif void send_http_header(r, type=NULL) Apache r char *type CODE: if(type) r->content_type = pstrdup(r->pool, type); send_http_header(r); mod_perl_sent_header(r, 1); #ifndef PERL_OBJECT int send_fd(r, f, length=-1) Apache r FILE *f long length CODE: RETVAL = send_fd_length(f, r, length); OUTPUT: RETVAL #endif int rflush(r) Apache r void read_client_block(r, buffer, bufsiz) Apache r SV *buffer int bufsiz PREINIT: long nrd = 0, old_read_length; int rc; PPCODE: if (!r->read_length) { if ((rc = setup_client_block(r, REQUEST_CHUNKED_ERROR)) != OK) { aplog_error(APLOG_MARK, APLOG_ERR | APLOG_NOERRNO, r->server, "mod_perl: setup_client_block failed: %d", rc); XSRETURN_UNDEF; } } old_read_length = r->read_length; r->read_length = 0; if (should_client_block(r)) { (void)SvUPGRADE(buffer, SVt_PV); SvGROW(buffer, bufsiz+1); nrd = get_client_block(r, SvPVX(buffer), bufsiz); } r->read_length += old_read_length; if (nrd > 0) { XPUSHs(sv_2mortal(newSViv((long)nrd))); #ifdef PERL_STASH_POST_DATA table_set(r->subprocess_env, "POST_DATA", SvPVX(buffer)); #endif SvCUR_set(buffer, nrd); *SvEND(buffer) = '\0'; SvPOK_only(buffer); SvTAINTED_on(buffer); } else { sv_setsv(buffer, &sv_undef); } int setup_client_block(r, policy=REQUEST_CHUNKED_ERROR) Apache r int policy int should_client_block(r) Apache r void get_client_block(r, buffer, bufsiz) Apache r SV *buffer int bufsiz PREINIT: long nrd = 0; PPCODE: (void)SvUPGRADE(buffer, SVt_PV); SvGROW(buffer, bufsiz+1); nrd = get_client_block(r, SvPVX(buffer), bufsiz); if ( nrd > 0 ) { XPUSHs(sv_2mortal(newSViv((long)nrd))); SvCUR_set(buffer, nrd); *SvEND(buffer) = '\0'; SvPOK_only(buffer); SvTAINTED_on(buffer); } else { sv_setsv(ST(1), &sv_undef); } int write(r, sv_buffer, sv_length=-1, offset=0) Apache r SV *sv_buffer int sv_length int offset ALIAS: Apache::WRITE = 1 PREINIT: STRLEN len; char *buffer; int sent = 0; CODE: ix = ix; /* avoid -Wall warning */ RETVAL = 0; if (r->connection->aborted) { XSRETURN_UNDEF; } buffer = SvPV(sv_buffer, len); if (sv_length != -1) { len = sv_length; } if (offset) { buffer += offset; } while (len > 0) { sent = rwrite(buffer, len < HUGE_STRING_LEN ? len : HUGE_STRING_LEN, r); if (sent < 0) { rwrite_neg_trace(r); break; } buffer += sent; len -= sent; RETVAL += sent; } OUTPUT: RETVAL int print(r, ...) Apache r ALIAS: Apache::PRINT = 1 CODE: ix = ix; /* avoid -Wall warning */ if(!mod_perl_sent_header(r, 0)) { SV *sv = sv_newmortal(); SV *rp = ST(0); SV *sendh = perl_get_sv("Apache::__SendHeader", TRUE); if(items > 2) do_join(sv, &sv_no, MARK+1, SP); /* $sv = join '', @_[1..$#_] */ else sv_setsv(sv, ST(1)); PUSHMARK(sp); XPUSHs(rp); XPUSHs(sv); PUTBACK; sv_setiv(sendh, 1); perl_call_pv("Apache::send_cgi_header", G_SCALAR); sv_setiv(sendh, 0); } else { CV *cv = GvCV(gv_fetchpv("Apache::write_client", FALSE, SVt_PVCV)); soft_timeout("mod_perl: Apache->print", r); PUSHMARK(mark); #ifdef PERL_OBJECT (void)(*CvXSUB(cv))(cv, pPerl); /* &Apache::write_client; */ #else (void)(*CvXSUB(cv))(aTHXo_ cv); /* &Apache::write_client; */ #endif if(IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) /* if $| != 0; */ #if MODULE_MAGIC_NUMBER >= 19970103 rflush(r); #else bflush(r->connection->client); #endif kill_timeout(r); } RETVAL = !r->connection->aborted; OUTPUT: RETVAL int write_client(r, ...) Apache r PREINIT: int i; char * buffer; STRLEN len; CODE: RETVAL = 0; if (r->connection->aborted) XSRETURN_IV(0); for(i = 1; i <= items - 1; i++) { int sent = 0; SV *sv = SvROK(ST(i)) && (SvTYPE(SvRV(ST(i))) == SVt_PV) ? (SV*)SvRV(ST(i)) : ST(i); buffer = SvPV(sv, len); #ifdef APACHE_SSL while(len > 0) { sent = rwrite(buffer, len < HUGE_STRING_LEN ? len : HUGE_STRING_LEN, r); if(sent < 0) { rwrite_neg_trace(r); /* break out of outer loop too */ i = items; break; } buffer += sent; len -= sent; RETVAL += sent; } #else if((sent = rwrite(buffer, len, r)) < 0) { rwrite_neg_trace(r); break; } RETVAL += sent; #endif } OUTPUT: RETVAL #functions from http_request.c void internal_redirect_handler(r, location) Apache r char * location ALIAS: Apache::internal_redirect = 1 CODE: switch((ix = XSANY.any_i32)) { case 0: internal_redirect_handler(location, r); break; case 1: internal_redirect(location, r); break; } #functions from http_log.c void mod_perl_log_reason(r, reason, filename=NULL) Apache r char * reason char * filename CODE: if(filename == NULL) filename = r->uri; mod_perl_log_reason(reason, filename, r); void log_error(...) ALIAS: Apache::warn = 1 Apache::Server::log_error = 2 Apache::Server::warn = 3 PREINIT: server_rec *s = NULL; request_rec *r = NULL; int i=0; char *errstr = NULL; SV *sv = Nullsv; CODE: if((items > 1) && (r = sv2request_rec(ST(0), "Apache", cv))) { s = r->server; i=1; } else if((items > 1) && sv_derived_from(ST(0), "Apache::Server")) { IV tmp = SvIV((SV*)SvRV(ST(0))); s = (Apache__Server )tmp; i=1; /* if below is true, delay log_error */ if(PERL_RUNNING() < PERL_DONE_STARTUP) { MP_TRACE_g(fprintf(stderr, "error_log not open yet\n")); XSRETURN_UNDEF; } } else { if(r) s = r->server; else s = perl_get_startup_server(); } if(!s) croak("Apache::warn: no server_rec!"); if(items > 1+i) { sv = newSV(0); do_join(sv, &sv_no, MARK+i, SP); /* $sv = join '', @_[1..$#_] */ errstr = SvPV(sv,na); } else errstr = SvPV(ST(i),na); switch((ix = XSANY.any_i32)) { case 0: case 2: mod_perl_error(s, errstr); break; case 1: case 3: mod_perl_warn(s, errstr); break; default: mod_perl_error(s, errstr); break; } if(sv) SvREFCNT_dec(sv); #methods for creating a CGI environment SV * subprocess_env(r, key=NULL, ...) Apache r char *key ALIAS: Apache::cgi_env = 1 Apache::cgi_var = 2 PREINIT: I32 gimme = GIMME_V; CODE: if(((ix = XSANY.any_i32) == 1) && (gimme == G_ARRAY)) { /* backwards compat */ int i; array_header *arr = perl_cgi_env_init(r); table_entry *elts = (table_entry *)arr->elts; SP -= items; for (i = 0; i < arr->nelts; ++i) { if (!elts[i].key) continue; PUSHelt(elts[i].key, elts[i].val, 0); } PUTBACK; return; } if((items == 1) && (gimme == G_VOID)) { (void)perl_cgi_env_init(r); XSRETURN_UNDEF; } TABLE_GET_SET(r->subprocess_env, FALSE); OUTPUT: RETVAL #see httpd.h #struct request_rec { void request(self, r=NULL) SV *self Apache r PPCODE: self = self; if(items > 1) perl_request_rec(r); XPUSHs(perl_bless_request_rec(perl_request_rec(NULL))); # pool *pool; # conn_rec *connection; # server_rec *server; Apache::Connection connection(r) Apache r CODE: RETVAL = r->connection; OUTPUT: RETVAL Apache::Server server(rsv) SV *rsv PREINIT: server_rec *s; request_rec *r; CODE: if (SvROK(rsv) && (r = sv2request_rec(rsv, "Apache", cv))) { s = r->server; } else { if(!(s = perl_get_startup_server())) croak("Apache->server: no startup server_rec available"); } RETVAL = s; OUTPUT: RETVAL # request_rec *next; /* If we wind up getting redirected, # * pointer to the request we redirected to. # */ # request_rec *prev; /* If this is an internal redirect, # * pointer to where we redirected *from*. # */ # request_rec *main; /* If this is a sub_request (see request.h) # * pointer back to the main request. # */ # ... # /* Info about the request itself... we begin with stuff that only # * protocol.c should ever touch... # */ # char *the_request; /* First line of request, so we can log it */ # int assbackwards; /* HTTP/0.9, "simple" request */ # int proxyreq; /* A proxy request */ # int header_only; /* HEAD request, as opposed to GET */ # char *protocol; /* Protocol, as given to us, or HTTP/0.9 */ # char *hostname; /* Host, as set by full URI or Host: */ # int hostlen; /* Length of http://host:port in full URI */ # char *status_line; /* Status line, if set by script */ # int status; /* In any case */ void main(r) Apache r CODE: if(r->main != NULL) ST(0) = perl_bless_request_rec((request_rec *)r->main); else ST(0) = &sv_undef; void prev(r) Apache r CODE: if(r->prev != NULL) ST(0) = perl_bless_request_rec((request_rec *)r->prev); else ST(0) = &sv_undef; void next(r) Apache r CODE: if(r->next != NULL) ST(0) = perl_bless_request_rec((request_rec *)r->next); else ST(0) = &sv_undef; Apache last(r) Apache r CODE: for(RETVAL=r; RETVAL->next; RETVAL=RETVAL->next) continue; OUTPUT: RETVAL int is_initial_req(r) Apache r int is_main(r) Apache r CODE: if(r->main != NULL) RETVAL = 0; else RETVAL = 1; OUTPUT: RETVAL char * the_request(r, ...) Apache r CODE: get_set_PVp(r->the_request,r->pool); OUTPUT: RETVAL int proxyreq(r, ...) Apache r CODE: get_set_IV(r->proxyreq); OUTPUT: RETVAL int header_only(r) Apache r CODE:  Z~MOD_PERL1_25_MUP.SAVEH *[MOD_PERL1_25.SRC.MODULES.PERL]APACHE.XS;2Rs2= RETVAL = r->header_only; OUTPUT: RETVAL char * protocol(r) Apache r CODE: RETVAL = r->protocol; OUTPUT: RETVAL char * hostname(r, ...) Apache r CODE: get_set_PVp(r->hostname,r->pool); OUTPUT: RETVAL int status(r, ...) Apache r CODE: get_set_IV(r->status); OUTPUT: RETVAL time_t request_time(r) Apache r CODE: RETVAL = r->request_time; OUTPUT: RETVAL char * status_line(r, ...) Apache r CODE: get_set_PVp(r->status_line,r->pool); OUTPUT: RETVAL # /* Request method, two ways; also, protocol, etc.. Outside of protocol.c, # * look, but don't touch. # */ # char *method; /* GET, HEAD, POST, etc. */ # int method_number; /* M_GET, M_POST, etc. */ # int sent_bodyct; /* byte count in stream is for body */ # long bytes_sent; /* body byte count, for easy access */ char * method(r, ...) Apache r CODE: get_set_PVp(r->method,r->pool); OUTPUT: RETVAL int method_number(r, ...) Apache r CODE: get_set_IV(r->method_number); OUTPUT: RETVAL long bytes_sent(r, ...) Apache r PREINIT: request_rec *last; CODE: for(last=r; last->next; last=last->next) continue; if (last->sent_bodyct && !last->bytes_sent) { ap_bgetopt(last->connection->client, BO_BYTECT, &last->bytes_sent); } RETVAL = last->bytes_sent; if(items > 1) { long nbytes = last->bytes_sent = (long)SvIV(ST(1)); ap_bsetopt(last->connection->client, BO_BYTECT, &nbytes); } OUTPUT: RETVAL # /* MIME header environments, in and out. Also, an array containing # * environment variables to be passed to subprocesses, so people can # * write modules to add to that environment. # * # * The difference between headers_out and err_headers_out is that the # * latter are printed even on error, and persist across internal redirects # * (so the headers printed for ErrorDocument handlers will have them). # * # * The 'notes' table is for notes from one module to another, with no # * other set purpose in mind... # */ # table *headers_in; # table *headers_out; # table *err_headers_out; # table *subprocess_env; # table *notes; # char *content_type; /* Break these out --- we dispatch on 'em */ # char *handler; /* What we *really* dispatch on */ # char *content_encoding; # char *content_language; # int no_cache; SV * header_in(r, key, ...) Apache r char *key CODE: TABLE_GET_SET(r->headers_in, TRUE); OUTPUT: RETVAL void headers_in(r) Apache r PREINIT: int i; array_header *hdrs_arr; table_entry *hdrs; PPCODE: if(GIMME == G_SCALAR) { ST(0) = mod_perl_tie_table(r->headers_in); XSRETURN(1); } hdrs_arr = table_elts (r->headers_in); hdrs = (table_entry *)hdrs_arr->elts; for (i = 0; i < hdrs_arr->nelts; ++i) { if (!hdrs[i].key) continue; PUSHelt(hdrs[i].key, hdrs[i].val, 0); } SV * header_out(r, key, ...) Apache r char *key CODE: TABLE_GET_SET(r->headers_out, TRUE); OUTPUT: RETVAL SV * cgi_header_out(r, key, ...) Apache r char *key PREINIT: char *val; CODE: if((val = (char *)table_get(r->headers_out, key))) RETVAL = newSVpv(val, 0); else RETVAL = newSV(0); SvTAINTED_on(RETVAL); if(items > 2) { int status = 302; val = SvPV(ST(2),na); if(!strncasecmp(key, "Content-type", 12)) { r->content_type = pstrdup (r->pool, val); } else if(!strncasecmp(key, "Status", 6)) { sscanf(val, "%d", &r->status); r->status_line = pstrdup(r->pool, val); } else if(!strncasecmp(key, "Location", 8)) { if (val && val[0] == '/' && r->status == 200) { /* not sure if this is quite right yet */ /* set $Apache::DoInternalRedirect++ to test */ if(DO_INTERNAL_REDIRECT) { r->method = pstrdup(r->pool, "GET"); r->method_number = M_GET; table_unset(r->headers_in, "Content-Length"); status = 200; perl_soak_script_output(r); internal_redirect_handler(val, r); } } table_set (r->headers_out, key, val); r->status = status; } else if(!strncasecmp(key, "Content-Length", 14)) { table_set (r->headers_out, key, val); } else if(!strncasecmp(key, "Transfer-Encoding", 17)) { table_set (r->headers_out, key, val); } #The HTTP specification says that it is legal to merge duplicate #headers into one. Some browsers that support Cookies don't like #merged headers and prefer that each Set-Cookie header is sent #separately. Lets humour those browsers. else if(!strncasecmp(key, "Set-Cookie", 10)) { table_add(r->err_headers_out, key, val); } else { table_merge (r->err_headers_out, key, val); } } void headers_out(r) Apache r PREINIT: int i; array_header *hdrs_arr; table_entry *hdrs; PPCODE: if(GIMME == G_SCALAR) { ST(0) = mod_perl_tie_table(r->headers_out); XSRETURN(1); } hdrs_arr = table_elts (r->headers_out); hdrs = (table_entry *)hdrs_arr->elts; for (i = 0; i < hdrs_arr->nelts; ++i) { if (!hdrs[i].key) continue; PUSHelt(hdrs[i].key, hdrs[i].val, 0); } SV * err_header_out(r, key, ...) Apache r char *key CODE: TABLE_GET_SET(r->err_headers_out, TRUE); OUTPUT: RETVAL void err_headers_out(r, ...) Apache r PREINIT: int i; array_header *hdrs_arr; table_entry *hdrs; PPCODE: if(GIMME == G_SCALAR) { ST(0) = mod_perl_tie_table(r->err_headers_out); XSRETURN(1); } hdrs_arr = table_elts (r->err_headers_out); hdrs = (table_entry *)hdrs_arr->elts; for (i = 0; i < hdrs_arr->nelts; ++i) { if (!hdrs[i].key) continue; PUSHelt(hdrs[i].key, hdrs[i].val, 0); } SV * notes(r, key=NULL, ...) Apache r char *key CODE: TABLE_GET_SET(r->notes, FALSE); OUTPUT: RETVAL void pnotes(r, k=Nullsv, val=Nullsv) Apache r SV *k SV *val PREINIT: perl_request_config *cfg = NULL; char *key = NULL; STRLEN len; CODE: if(k) { key = SvPV(k,len); } cfg = (perl_request_config *) get_module_config(r->request_config, &perl_module); if (!cfg) { XSRETURN_UNDEF; } if(!cfg->pnotes) cfg->pnotes = newHV(); if(key) { if(hv_exists(cfg->pnotes, key, len)) { ST(0) = SvREFCNT_inc(*hv_fetch(cfg->pnotes, key, len, FALSE)); sv_2mortal(ST(0)); } else { ST(0) = &sv_undef; } if(val) { hv_store(cfg->pnotes, key, len, SvREFCNT_inc(val), FALSE); } } else { ST(0) = newRV_inc((SV*)cfg->pnotes); sv_2mortal(ST(0)); } char * content_type(r, ...) Apache r CODE: get_set_PVp(r->content_type,r->pool); OUTPUT: RETVAL char * handler(r, ...) Apache r CODE: get_set_PVp(r->handler,r->pool); OUTPUT: RETVAL char * content_encoding(r, ...) Apache r CODE: get_set_PVp(r->content_encoding,r->pool); OUTPUT: RETVAL char * content_language(r, ...) Apache r CODE: get_set_PVp(r->content_language,r->pool); OUTPUT: RETVAL void content_languages(r, avrv=Nullsv) Apache r SV *avrv PREINIT: I32 gimme = GIMME_V; CODE: if(avrv && SvROK(avrv)) r->content_languages = avrv2array_header(avrv, r->pool); if(gimme != G_VOID) ST(0) = array_header2avrv(r->content_languages); int no_cache(r, ...) Apache r CODE: get_set_IV(r->no_cache); if (r->no_cache) { ap_table_setn(r->headers_out, "Pragma", "no-cache"); ap_table_setn(r->headers_out, "Cache-control", "no-cache"); } OUTPUT: RETVAL # /* What object is being requested (either directly, or via include # * or content-negotiation mapping). # */ # char *uri; /* complete URI for a proxy req, or # URL path for a non-proxy req */ # char *filename; # char *path_info; # char *args; /* QUERY_ARGS, if any */ # struct stat finfo; /* ST_MODE set to zero if no such file */ SV * finfo(r, sv_statbuf=Nullsv) Apache r SV *sv_statbuf CODE: if (sv_statbuf) { if (SvROK(sv_statbuf) && SvOBJECT(SvRV(sv_statbuf))) { STRLEN sz; char *buf = SvPV((SV*)SvRV(sv_statbuf), sz); if (sz != sizeof(r->finfo)) { croak("statbuf size mismatch, got %d, wanted %d", sz, sizeof(r->finfo)); } memcpy(&r->finfo, buf, sz); } else { croak("statbuf is not an object"); } } memcpy (&statcache, &r->finfo, sizeof (Stat_t)); /* statcache = r->finfo; */ if (r->finfo.st_mode) { laststatval = 0; } else { laststatval = -1; } if(GIMME_V == G_VOID) XSRETURN_UNDEF; RETVAL = newRV_noinc((SV*)gv_fetchpv("_", TRUE, SVt_PVIO)); OUTPUT: RETVAL char * uri(r, ...) Apache r CODE: get_set_PVp(r->uri,r->pool); OUTPUT: RETVAL char * filename(r, ...) Apache r CODE: get_set_PVp(r->filename,r->pool); #ifndef WIN32 if(items > 1) if ((laststatval = stat(r->filename, &r->finfo)) < 0) { r->finfo.st_mode = 0; } #endif OUTPUT: RETVAL char * path_info(r, ...) Apache r CODE: get_set_PVp(r->path_info,r->pool); OUTPUT: RETVAL char * query_string(r, ...) Apache r CODE: get_set_PVp(r->args,r->pool); OUTPUT: RETVAL CLEANUP: if (ST(0) != &sv_undef) SvTAINTED_on(ST(0)); # /* Various other config info which may change with .htaccess files # * These are config vectors, with one void* pointer for each module # * (the thing pointed to being the module's business). # */ # void *per_dir_config; /* Options set in config files, etc. */ char * location(r) Apache r CODE: if(r->per_dir_config) { dPPDIR; RETVAL = cld->location; } else XSRETURN_UNDEF; OUTPUT: RETVAL SV * dir_config(r, key=NULL, ...) Apache r char *key ALIAS: Apache::Server::dir_config = 1 PREINIT: perl_dir_config *c; perl_server_config *cs; server_rec *s; CODE: ix = ix; /*-Wall*/ RETVAL = Nullsv; if(r && r->per_dir_config) { c = (perl_dir_config *)get_module_config(r->per_dir_config, &perl_module); TABLE_GET_SET(c->vars, FALSE); } if (!SvTRUE(RETVAL)) { s = r && r->server ? r->server : perl_get_startup_server(); if (s && s->module_config) { SvREFCNT_dec(RETVAL); /* in case above did newSV(0) */ cs = (perl_server_config *)get_module_config(s->module_config, &perl_module); TABLE_GET_SET(cs->vars, FALSE); } else XSRETURN_UNDEF; } OUTPUT: RETVAL # void *request_config; /* Notes on *this* request */ #/* # * a linked list of the configuration directives in the .htaccess files # * accessed by this request. # * N.B. always add to the head of the list, _never_ to the end. # * that way, a sub request's list can (temporarily) point to a parent's list # */ # const struct htaccess_result *htaccess; #}; Apache::SubRequest lookup_uri(r, uri) Apache r char *uri CODE: RETVAL = sub_req_lookup_uri(uri,r); OUTPUT: RETVAL Apache::SubRequest lookup_file(r, file) Apache r char *file CODE: RETVAL = sub_req_lookup_file(file,r); OUTPUT: RETVAL MODULE = Apache PACKAGE = Apache::SubRequest BOOT: av_push(perl_get_av("Apache::SubRequest::ISA",TRUE), newSVpv("Apache",6)); void DESTROY(r) Apache::SubRequest r CODE: destroy_sub_req(r); MP_TRACE_g(fprintf(stderr, "Apache::SubRequest::DESTROY(0x%lx)\n", (unsigned long)r)); int run(r, allow_send_header=0) Apache::SubRequest r int allow_send_header CODE: if (allow_send_header) { r->assbackwards = 0; } RETVAL = run_sub_req(r); OUTPUT: RETVAL **[MOD_PERL1_25.SRC.MODULES.PERL]APACHE.XS;1+,? ./A@ 4U- 0D123 KPWOV56^酟7,酟89GA@HJ N $J)g7 %J)g7J)g7.  :*N:*N:*NH/* ==================================================================== * The Apache Software License, Version 1.1 * * Copyright (c) 1996-2000 The Apache Software Foundation. All rights * reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in * the documentation and/or other materials provided with the * distribution. * * 3. The end-user documentation included with the redistribution, * if any, must include the following acknowledgment: * "This product includes software developed by the * Apache Software Foundation (http://www.apache.org/)." * Alternately, this acknowledgment may appear in the software itself, * if and wherever such third-party acknowledgments normally appear. * * 4. The names "Apache" and "Apache Software Foundation" must * not be used to endorse or promote products derived from this * software without prior written permission. For written * permission, please contact apache@apache.org. * * 5. Products derived from this software may not be called "Apache", * nor may "Apache" appear in their name, without prior written * permission of the Apache Software Foundation. * * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. * ==================================================================== */ #define CORE_PRIVATE #include "mod_perl.h" #include "mod_perl_xs.h" #ifdef USE_SFIO #undef send_fd_length static long send_fd_length(FILE *f, request_rec *r, long length) { croak("Apache::send_fd() not supported with sfio"); return 0; } #endif #if defined(PERL_STACKED_HANDLERS) && defined(PERL_GET_SET_HANDLERS) #define PER_DIR_CONFIG 1 #define PER_SRV_CONFIG 2 typedef struct { int type; char *name; void *offset; void (*set_func) (void *, void *, SV *); } perl_handler_table; typedef struct { I32 fill; AV *av; AV **ptr; } perl_save_av; static void set_handler_dir (perl_handler_table *tab, request_rec *r, SV *sv); static void set_handler_srv (perl_handler_table *tab, request_rec *r, SV *sv); #define HandlerDirEntry(name,member) \ PER_DIR_CONFIG, name, (void*)XtOffsetOf(perl_dir_config,member), \ (void(*)(void *, void *, SV *)) set_handler_dir #define HandlerSrvEntry(name,member) \ PER_SRV_CONFIG, name, (void*)XtOffsetOf(perl_server_config,member), \ (void(*)(void *, void *, SV *)) set_handler_srv static perl_handler_table handler_table[] = { {HandlerSrvEntry("PerlPostReadRequestHandler", PerlPostReadRequestHandler)}, {HandlerSrvEntry("PerlTransHandler", PerlTransHandler)}, {HandlerDirEntry("PerlHeaderParserHandler", PerlHeaderParserHandler)}, {HandlerDirEntry("PerlAccessHandler", PerlAccessHandler)}, {HandlerDirEntry("PerlAuthenHandler", PerlAuthenHandler)}, {HandlerDirEntry("PerlAuthzHandler", PerlAuthzHandler)}, {HandlerDirEntry("PerlTypeHandler", PerlTypeHandler)}, {HandlerDirEntry("PerlFixupHandler", PerlFixupHandler)}, {HandlerDirEntry("PerlHandler", PerlHandler)}, {HandlerDirEntry("PerlLogHandler", PerlLogHandler)}, {HandlerDirEntry("PerlCleanupHandler", PerlCleanupHandler)}, { FALSE, NULL } }; static void perl_restore_av(void *data) { perl_save_av *save_av = (perl_save_av *)data; if(save_av->fill != DONE) { AvFILLp(*save_av->ptr) = save_av->fill; } else if(save_av->av != Nullav) { *save_av->ptr = save_av->av; } } static void perl_handler_merge_avs(char *hook, AV **dest) { int i = 0; HV *hv = perl_get_hv("Apache::PerlStackedHandlers", FALSE); SV **svp = hv_fetch(hv, hook, strlen(hook), FALSE); AV *base; if(!(svp && SvROK(*svp))) return; base = (AV*)SvRV(*svp); for(i=0; i<=AvFILL(base); i++) { SV *sv = *av_fetch(base, i, FALSE); av_push(*dest, SvREFCNT_inc(sv)); } } static void set_handler_base(void *ptr, perl_handler_table *tab, pool *p, SV *sv) { AV **av = (AV **)((char *)ptr + (int)(long)tab->offset); perl_save_av *save_av = (perl_save_av *)palloc(p, sizeof(perl_save_av)); save_av->fill = DONE; save_av->av = Nullav; if((sv == &sv_undef) || (SvIOK(sv) && SvIV(sv) == DONE)) { if(AvTRUE(*av)) { save_av->fill = AvFILL(*av); AvFILLp(*av) = -1; } } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) { if(AvTRUE(*av)) save_av->av = av_copy_array(*av); *av = (AV*)SvRV(sv); ++SvREFCNT(*av); } else { croak("Can't set_handler with that value"); } save_av->ptr = av; register_cleanup(p, save_av, perl_restore_av, mod_perl_noop); } static void set_handler_dir(perl_handler_table *tab, request_rec *r, SV *sv) { dPPDIR; set_handler_base((void*)cld, tab, r->pool, sv); } static void set_handler_srv(perl_handler_table *tab, request_rec *r, SV *sv) { dPSRV(r->server); set_handler_base((void*)cls, tab, r->pool, sv); } static perl_handler_table *perl_handler_lookup(char *name) { int i; for (i=0; handler_table[i].name; i++) { perl_handler_table *tab = &handler_table[i]; if(strEQ(name, tab->name)) return tab; } return NULL; } static SV *get_handlers(request_rec *r, char *hook) { AV *avcopy; AV **av; dPPDIR; dPSRV(r->server); void *ptr; perl_handler_table *tab = perl_handler_lookup(hook); if(!tab) return Nullsv; if(tab->type == PER_DIR_CONFIG) ptr = (void*)cld; else ptr = (void*)cls; av = (AV **)((char *)ptr + (int)(long)tab->offset); if(*av) avcopy = av_copy_array(*av); else avcopy = newAV(); perl_handler_merge_avs(hook, &avcopy); return newRV_noinc((SV*)avcopy); } static void set_handlers(request_rec *r, SV *hook, SV *sv) { dTHR; perl_handler_table *tab = perl_handler_lookup(SvPV(hook,na)); if(tab && tab->set_func) (*tab->set_func)(tab, r, sv); (void)hv_delete_ent(perl_get_hv("Apache::PerlStackedHandlers", FALSE), hook, G_DISCARD, FALSE); } #endif #if MODULE_MAGIC_NUMBER < 19970909 static void child_terminate(request_rec *r) { #ifndef WIN32 log_transaction(r); #endif exit(0); } #endif static char *custom_response(request_rec *r, int status, char *string) { core_dir_config *conf = (core_dir_config *) get_module_config(r->per_dir_config, &core_module); int idx; char *retval = NULL; if(conf->response_code_strings == NULL) { conf->response_code_strings = (char **) pcalloc(perl_get_startup_pool(), sizeof(*conf->response_code_strings) * RESPONSE_CODES); } idx = index_of_response(status); retval = conf->response_code_strings[idx]; if (string) { conf->response_code_strings[idx] = ((is_url(string) || (*string == '/')) && (*string != '"')) ? pstrdup(r->pool, string) : pstrcat(r->pool, "\"", string, NULL); } return retval; } static void Apache_terminate_if_done(request_rec *r, int sts) { #ifndef WIN32 if(Apache_exit_is_done(sts)) child_terminate(r); #endif } #if MODULE_MAGIC_NUMBER < 19980317 int basic_http_header(request_rec *r); #endif #if MODULE_MAGIC_NUMBER < 19980201 unsigned get_server_port(const request_rec *r) { unsigned port = r->server->port ? r->server->port : 80; return r->hostname ? ntohs(r->connection->local_addr.sin_port) : port; } #define get_server_name(r) \ (r->hostname ? r->hostname : r->server->server_hostname) #endif #if MODULE_MAGIC_AT_LEAST(19981108, 1) #define mod_perl_define(sv,name) ap_exists_config_define(name) #elif(MODULE_MAGIC_NUMBER >= MMN_131) && !defined(WIN32) static int mod_perl_define(SV *sv, char *name) { char **defines; int i; defines = (char **)ap_server_config_defines->elts; for (i = 0; i < ap_server_config_defines->nelts; i++) { if (strcmp(defines[i], name) == 0) { return 1; } } return 0; } #else #define mod_perl_define(sv,name) 0 #endif static int sv_str_header(void *arg, const char *k, const char *v) { SV *sv = (SV*)arg; sv_catpvf(sv, "%s: %s\n", k, v); return 1; } #if MODULE_MAGIC_NUMBER >= 19980806 /* * ap_scan_script_header_err_core(r, buffer, getsfunc_SV, sv) */ #if 0 static int getsfunc_SV(char *buf, int bufsiz, void *param) { SV *sv = (SV*)param; STRLEN len; char *tmp = SvPV(sv,len); int i; if(!SvTRUE(sv)) return 0; for(i=0; i<=len; i++) { if(tmp[i] == LF) break; } Move(tmp, buf, i, char); buf[i] = '\0'; if(len < i) { sv_setpv(sv, ""); } else { tmp += i+1; sv_setpv(sv, tmp); } return 1; } #endif /*0*/ #endif /*MODULE_MAGIC_NUMBER*/ static void rwrite_neg_trace(request_rec *r) { #if HAS_MMN_130 ap_log_error(APLOG_MARK, APLOG_DEBUG, r->server, #else fprintf(stderr, #endif "mod_perl: rwrite returned -1 (fd=%d, B_EOUT=%d)\n", ap_bfileno(r->connection->client, B_WR), r->connection->client->flags & B_EOUT); } #define check_auth_type(r) \ if (!auth_type(r)) { \ (void)mod_perl_auth_type(r, "Basic"); \ } MODULE = Apache PACKAGE = Apache PREFIX = mod_perl_ PROTOTYPES: DISABLE BOOT: items = items; /*avoid warning*/ const char * current_callback(r) Apache r CODE: RETVAL = PERL_GET_CUR_HOOK; OUTPUT: RETVAL int mod_perl_sent_header(r, val=0) Apache r int val int mod_perl_seqno(self, inc=0) SV *self int inc int perl_hook(name) char *name #if defined(PERL_GET_SET_HANDLERS) SV * get_handlers(r, hook) Apache r char *hook CODE: #ifdef get_handlers get_handlers(r,hook); #else RETVAL = get_handlers(r,hook); #endif OUTPUT: RETVAL void set_handlers(r, hook, sv) Apache r SV *hook SV *sv #endif int mod_perl_push_handlers(self, hook, cv) SV *self char *hook SV *cv; CODE: RETVAL = mod_perl_push_handlers(self, hook, cv, Nullav); OUTPUT: RETVAL int mod_perl_can_stack_handlers(self) SV *self void mod_perl_register_cleanup(r, sv) Apache r SV *sv ALIAS: Apache::post_connection = 1 PREINIT: ix = ix; /* avoid -Wall warning */ #define APACHE_REGISTRY_CURSTASH perl_get_sv("Apache::Registry::curstash", TRUE) void mod_perl_clear_rgy_endav(r, sv=APACHE_REGISTRY_CURSTASH) Apache r SV *sv void mod_perl_stash_rgy_endav(r, sv=APACHE_REGISTRY_CURSTASH) Apache r SV *sv CODE: perl_stash_rgy_endav(r->uri, sv); I32 mod_perl_define(sv, name) SV *sv char *name CLEANUP: sv = sv; /*-Wall*/ I32 module(sv, name) SV *sv SV *name CODE: if((*(SvEND(name) - 2) == '.') && (*(SvEND(name) - 1) == 'c')) RETVAL = find_linked_module(SvPVX(name)) ? 1 : 0; else RETVAL = (sv && perl_module_is_loaded(SvPVX(name))); OUTPUT: RETVAL char * mod_perl_set_opmask(r, sv) Apache r SV *sv void untaint(...) PREINIT: int i; CODE: if(!tainting) XSRETURN_EMPTY; for(i=1; iexit */ r = sv2request_rec(ST(0), "Apache", cv); if(items > 1) { sts = (int)SvIV(ST(1)); } else { /* Apache::exit() */ if(SvTRUE(ST(0)) && SvIOK(ST(0))) sts = (int)SvIV(ST(0)); } MP_CHECK_REQ(r, "Apache::exit"); if(!r->connection->aborted) rflush(r); Apache_terminate_if_done(r,sts); perl_call_halt(sts); #in case you need Apache::fork # INCLUDE: fork.xs void CLOSE(...) ALIAS: BINMODE = 1 CODE: items = items; ix = ix; /*NOOP*/ Apache TIEHANDLE(classname, r=NULL) SV *classname Apache r CODE: RETVAL = (r && classname) ? r : perl_request_rec(NULL); OUTPUT: RETVAL int OPEN(self, arg1, arg2=Nullsv) SV *self SV *arg1 SV *arg2 PREINIT: char *name; STRLEN len; GV *gv = gv_fetchpv("STDOUT", TRUE, SVt_PVIO); SV *arg; CODE: sv_unmagic((SV*)gv, 'q'); /* untie *STDOUT */ if (arg2 && self) { arg = newSVsv(arg1); sv_catsv(arg, arg2); } else { arg = arg1; } name = SvPV(arg, len); RETVAL = do_open(gv, name, len, FALSE, O_RDONLY, 0, Nullfp); OUTPUT: RETVAL int FILENO(r) Apache r CODE: RETVAL = fileno(stdout); OUTPUT: RETVAL SV * as_string(r) Apache r CODE: RETVAL = newSVpv(r->the_request,0); sv_catpvn(RETVAL, "\n", 1); table_do(sv_str_header, (void*)RETVAL, r->headers_in, NULL); sv_catpvf(RETVAL, "\n%s %s\n", r->protocol, r->status_line); table_do(sv_str_header, (void*)RETVAL, r->headers_out, NULL); table_do(sv_str_header, (void*)RETVAL, r->err_headers_out, NULL); sv_catpvn(RETVAL, "\n", 1); OUTPUT: RETVAL #httpd.h void chdir_file(r, file=r->filename) Apache r const char *file CODE: chdir_file(file); SV * mod_perl_gensym(pack="Apache::Symbol") char *pack SV * mod_perl_slurp_filename(r) Apache r char * unescape_url(string) char *string CODE: unescape_url(string); RETVAL = string; OUTPUT: RETVAL # # Doing our own unscape_url for the query info part of an url # char * unescape_url_info(url) char * url CODE: register char * trans = url ; char digit ; if (!url || !*url) { XSRETURN_UNDEF; } RETVAL = url; while (*url != '\0') { if (*url == '+') *trans = ' '; else if (*url != '%') *trans = *url; else if (!isxdigit(url[1]) || !isxdigit(url[2])) *trans = '%'; else { url++ ; digit = ((*url >= 'A') ? ((*url & 0xdf) - 'A')+10 : (*url - '0')); url++ ; *trans = (digit << 4) + (*url >= 'A' ? ((*url & 0xdf) - 'A')+10 : (*url - '0')); } url++, trans++ ; } *trans = '\0'; OUTPUT: RETVAL #functions from http_main.c void hard_timeout(r, string) Apache r char *string CODE: #ifndef USE_THREADS hard_timeout(string, r); #endif void soft_timeout(r, string) Apache r char *string CODE: soft_timeout(string, r); void kill_timeout(r) Apache r CODE: #ifndef USE_THREADS kill_timeout(r); #endif void reset_timeout(r) Apache r #functions from http_config.c int translate_name(r) Apache r CODE: #ifdef WIN32 croak("Apache->translate_name not supported under Win32"); RETVAL = DECLINED; #else RETVAL = translate_name(r); #endif OUTPUT: RETVAL #functions from http_core.c char * custom_response(r, status, string=NULL) Apache r int status char *string int satisfies(r) Apache r int some_auth_required(r) Apache r void requires(r) Apache r PREINIT: AV *av; HV *hv; register int x; int m; char *t; MP_CONST_ARRAY_HEADER *reqs_arr; require_line *reqs; CODE: m = r->method_number; reqs_arr = requires (r); if (!reqs_arr) ST(0) = &sv_undef; else { reqs = (require_line *)reqs_arr->elts; iniAV(av); for(x=0; x < reqs_arr->nelts; x++) { /* XXX should we do this or let PerlAuthzHandler? */ if (! (reqs[x].method_mask & (1 << m))) continue; t = reqs[x].requirement; iniHV(hv); hv_store(hv, "method_mask", 11, newSViv((IV)reqs[x].method_mask), 0); hv_store(hv, "requirement", 11, newSVpv(reqs[x].requirement,0), 0); av_push(av, newRV((SV*)hv)); } ST(0) = newRV_noinc((SV*)av); } int allow_options(r) Apache r unsigned get_server_port(r) Apache r const char * get_server_name(r) Apache r char * get_remote_host(r, type=REMOTE_NAME) Apache r int type CODE: RETVAL = (char *)get_remote_host(r->connection, r->per_dir_config, type); OUTPUT: RETVAL const char * get_remote_logname(r) Apache r char * mod_perl_auth_name(r, val=NULL) Apache r char *val const char * mod_perl_auth_type(r, val=NULL) Apache r char *val const char * document_root(r, ...) Apache r PREINIT: core_server_config *conf; CODE: conf = (core_server_config *) get_module_config(r->ser 6~MOD_PERL1_25_MUP.SAVE?  *[MOD_PERL1_25.SRC.MODULES.PERL]APACHE.XS;1gb%ver->module_config, &core_module); RETVAL = conf->ap_document_root; if (items > 1) { SV *doc_root = perl_get_sv("Apache::Server::DocumentRoot", TRUE); sv_setsv(doc_root, ST(1)); conf->ap_document_root = SvPVX(doc_root); } OUTPUT: RETVAL char * server_root_relative(rsv, name="") SV *rsv char *name PREINIT: pool *p; request_rec *r; CODE: if (SvROK(rsv) && (r = sv2request_rec(rsv, "Apache", cv))) { p = r->pool; } else { if(!(p = perl_get_startup_pool())) croak("Apache::server_root_relative: no startup pool available"); } RETVAL = (char *)server_root_relative(p, name); OUTPUT: RETVAL #functions from http_protocol.c void note_basic_auth_failure(r) Apache r CODE: check_auth_type(r); note_basic_auth_failure(r); void get_basic_auth_pw(r) Apache r PREINIT: MP_CONST_CHAR *sent_pw = NULL; int ret; PPCODE: check_auth_type(r); ret = get_basic_auth_pw(r, &sent_pw); XPUSHs(sv_2mortal((SV*)newSViv(ret))); if(ret == OK) XPUSHs(sv_2mortal((SV*)newSVpv((char *)sent_pw, 0))); else XPUSHs(&sv_undef); char * user(r, ...) Apache r CODE: get_set_PVp(r->connection->user,r->pool); OUTPUT: RETVAL void basic_http_header(r) Apache r CODE: #ifdef WIN32 croak("Apache->basic_http_header() not supported under Win32!"); #else basic_http_header(r); #endif void send_http_header(r, type=NULL) Apache r char *type CODE: if(type) r->content_type = pstrdup(r->pool, type); send_http_header(r); mod_perl_sent_header(r, 1); #ifndef PERL_OBJECT int send_fd(r, f, length=-1) Apache r FILE *f long length CODE: RETVAL = send_fd_length(f, r, length); OUTPUT: RETVAL #endif int rflush(r) Apache r void read_client_block(r, buffer, bufsiz) Apache r SV *buffer int bufsiz PREINIT: long nrd = 0, old_read_length; int rc; PPCODE: if (!r->read_length) { if ((rc = setup_client_block(r, REQUEST_CHUNKED_ERROR)) != OK) { aplog_error(APLOG_MARK, APLOG_ERR | APLOG_NOERRNO, r->server, "mod_perl: setup_client_block failed: %d", rc); XSRETURN_UNDEF; } } old_read_length = r->read_length; r->read_length = 0; if (should_client_block(r)) { (void)SvUPGRADE(buffer, SVt_PV); SvGROW(buffer, bufsiz+1); nrd = get_client_block(r, SvPVX(buffer), bufsiz); } r->read_length += old_read_length; if (nrd > 0) { XPUSHs(sv_2mortal(newSViv((long)nrd))); #ifdef PERL_STASH_POST_DATA table_set(r->subprocess_env, "POST_DATA", SvPVX(buffer)); #endif SvCUR_set(buffer, nrd); *SvEND(buffer) = '\0'; SvPOK_only(buffer); SvTAINTED_on(buffer); } else { sv_setsv(buffer, &sv_undef); } int setup_client_block(r, policy=REQUEST_CHUNKED_ERROR) Apache r int policy int should_client_block(r) Apache r void get_client_block(r, buffer, bufsiz) Apache r SV *buffer int bufsiz PREINIT: long nrd = 0; PPCODE: (void)SvUPGRADE(buffer, SVt_PV); SvGROW(buffer, bufsiz+1); nrd = get_client_block(r, SvPVX(buffer), bufsiz); if ( nrd > 0 ) { XPUSHs(sv_2mortal(newSViv((long)nrd))); SvCUR_set(buffer, nrd); *SvEND(buffer) = '\0'; SvPOK_only(buffer); SvTAINTED_on(buffer); } else { sv_setsv(ST(1), &sv_undef); } int write(r, sv_buffer, sv_length=-1, offset=0) Apache r SV *sv_buffer int sv_length int offset ALIAS: Apache::WRITE = 1 PREINIT: STRLEN len; char *buffer; int sent = 0; CODE: ix = ix; /* avoid -Wall warning */ RETVAL = 0; if (r->connection->aborted) { XSRETURN_UNDEF; } buffer = SvPV(sv_buffer, len); if (sv_length != -1) { len = sv_length; } if (offset) { buffer += offset; } while (len > 0) { sent = rwrite(buffer, len < HUGE_STRING_LEN ? len : HUGE_STRING_LEN, r); if (sent < 0) { rwrite_neg_trace(r); break; } buffer += sent; len -= sent; RETVAL += sent; } OUTPUT: RETVAL int print(r, ...) Apache r ALIAS: Apache::PRINT = 1 CODE: ix = ix; /* avoid -Wall warning */ if(!mod_perl_sent_header(r, 0)) { SV *sv = sv_newmortal(); SV *rp = ST(0); SV *sendh = perl_get_sv("Apache::__SendHeader", TRUE); if(items > 2) do_join(sv, &sv_no, MARK+1, SP); /* $sv = join '', @_[1..$#_] */ else sv_setsv(sv, ST(1)); PUSHMARK(sp); XPUSHs(rp); XPUSHs(sv); PUTBACK; sv_setiv(sendh, 1); perl_call_pv("Apache::send_cgi_header", G_SCALAR); sv_setiv(sendh, 0); } else { CV *cv = GvCV(gv_fetchpv("Apache::write_client", FALSE, SVt_PVCV)); soft_timeout("mod_perl: Apache->print", r); PUSHMARK(mark); #ifdef PERL_OBJECT (void)(*CvXSUB(cv))(cv, pPerl); /* &Apache::write_client; */ #else (void)(*CvXSUB(cv))(aTHXo_ cv); /* &Apache::write_client; */ #endif if(IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) /* if $| != 0; */ #if MODULE_MAGIC_NUMBER >= 19970103 rflush(r); #else bflush(r->connection->client); #endif kill_timeout(r); } RETVAL = !r->connection->aborted; OUTPUT: RETVAL int write_client(r, ...) Apache r PREINIT: int i; char * buffer; STRLEN len; CODE: RETVAL = 0; if (r->connection->aborted) XSRETURN_IV(0); for(i = 1; i <= items - 1; i++) { int sent = 0; SV *sv = SvROK(ST(i)) && (SvTYPE(SvRV(ST(i))) == SVt_PV) ? (SV*)SvRV(ST(i)) : ST(i); buffer = SvPV(sv, len); #ifdef APACHE_SSL while(len > 0) { sent = rwrite(buffer, len < HUGE_STRING_LEN ? len : HUGE_STRING_LEN, r); if(sent < 0) { rwrite_neg_trace(r); /* break out of outer loop too */ i = items; break; } buffer += sent; len -= sent; RETVAL += sent; } #else if((sent = rwrite(buffer, len, r)) < 0) { rwrite_neg_trace(r); break; } RETVAL += sent; #endif } OUTPUT: RETVAL #functions from http_request.c void internal_redirect_handler(r, location) Apache r char * location ALIAS: Apache::internal_redirect = 1 CODE: switch((ix = XSANY.any_i32)) { case 0: internal_redirect_handler(location, r); break; case 1: internal_redirect(location, r); break; } #functions from http_log.c void mod_perl_log_reason(r, reason, filename=NULL) Apache r char * reason char * filename CODE: if(filename == NULL) filename = r->uri; mod_perl_log_reason(reason, filename, r); void log_error(...) ALIAS: Apache::warn = 1 Apache::Server::log_error = 2 Apache::Server::warn = 3 PREINIT: server_rec *s = NULL; request_rec *r = NULL; int i=0; char *errstr = NULL; SV *sv = Nullsv; CODE: if((items > 1) && (r = sv2request_rec(ST(0), "Apache", cv))) { s = r->server; i=1; } else if((items > 1) && sv_derived_from(ST(0), "Apache::Server")) { IV tmp = SvIV((SV*)SvRV(ST(0))); s = (Apache__Server )tmp; i=1; /* if below is true, delay log_error */ if(PERL_RUNNING() < PERL_DONE_STARTUP) { MP_TRACE_g(fprintf(stderr, "error_log not open yet\n")); XSRETURN_UNDEF; } } else { if(r) s = r->server; else s = perl_get_startup_server(); } if(!s) croak("Apache::warn: no server_rec!"); if(items > 1+i) { sv = newSV(0); do_join(sv, &sv_no, MARK+i, SP); /* $sv = join '', @_[1..$#_] */ errstr = SvPV(sv,na); } else errstr = SvPV(ST(i),na); switch((ix = XSANY.any_i32)) { case 0: case 2: mod_perl_error(s, errstr); break; case 1: case 3: mod_perl_warn(s, errstr); break; default: mod_perl_error(s, errstr); break; } if(sv) SvREFCNT_dec(sv); #methods for creating a CGI environment SV * subprocess_env(r, key=NULL, ...) Apache r char *key ALIAS: Apache::cgi_env = 1 Apache::cgi_var = 2 PREINIT: I32 gimme = GIMME_V; CODE: if(((ix = XSANY.any_i32) == 1) && (gimme == G_ARRAY)) { /* backwards compat */ int i; array_header *arr = perl_cgi_env_init(r); table_entry *elts = (table_entry *)arr->elts; SP -= items; for (i = 0; i < arr->nelts; ++i) { if (!elts[i].key) continue; PUSHelt(elts[i].key, elts[i].val, 0); } PUTBACK; return; } if((items == 1) && (gimme == G_VOID)) { (void)perl_cgi_env_init(r); XSRETURN_UNDEF; } TABLE_GET_SET(r->subprocess_env, FALSE); OUTPUT: RETVAL #see httpd.h #struct request_rec { void request(self, r=NULL) SV *self Apache r PPCODE: self = self; if(items > 1) perl_request_rec(r); XPUSHs(perl_bless_request_rec(perl_request_rec(NULL))); # pool *pool; # conn_rec *connection; # server_rec *server; Apache::Connection connection(r) Apache r CODE: RETVAL = r->connection; OUTPUT: RETVAL Apache::Server server(rsv) SV *rsv PREINIT: server_rec *s; request_rec *r; CODE: if (SvROK(rsv) && (r = sv2request_rec(rsv, "Apache", cv))) { s = r->server; } else { if(!(s = perl_get_startup_server())) croak("Apache->server: no startup server_rec available"); } RETVAL = s; OUTPUT: RETVAL # request_rec *next; /* If we wind up getting redirected, # * pointer to the request we redirected to. # */ # request_rec *prev; /* If this is an internal redirect, # * pointer to where we redirected *from*. # */ # request_rec *main; /* If this is a sub_request (see request.h) # * pointer back to the main request. # */ # ... # /* Info about the request itself... we begin with stuff that only # * protocol.c should ever touch... # */ # char *the_request; /* First line of request, so we can log it */ # int assbackwards; /* HTTP/0.9, "simple" request */ # int proxyreq; /* A proxy request */ # int header_only; /* HEAD request, as opposed to GET */ # char *protocol; /* Protocol, as given to us, or HTTP/0.9 */ # char *hostname; /* Host, as set by full URI or Host: */ # int hostlen; /* Length of http://host:port in full URI */ # char *status_line; /* Status line, if set by script */ # int status; /* In any case */ void main(r) Apache r CODE: if(r->main != NULL) ST(0) = perl_bless_request_rec((request_rec *)r->main); else ST(0) = &sv_undef; void prev(r) Apache r CODE: if(r->prev != NULL) ST(0) = perl_bless_request_rec((request_rec *)r->prev); else ST(0) = &sv_undef; void next(r) Apache r CODE: if(r->next != NULL) ST(0) = perl_bless_request_rec((request_rec *)r->next); else ST(0) = &sv_undef; Apache last(r) Apache r CODE: for(RETVAL=r; RETVAL->next; RETVAL=RETVAL->next) continue; OUTPUT: RETVAL int is_initial_req(r) Apache r int is_main(r) Apache r CODE: if(r->main != NULL) RETVAL = 0; else RETVAL = 1; OUTPUT: RETVAL char * the_request(r, ...) Apache r CODE: get_set_PVp(r->the_request,r->pool); OUTPUT: RETVAL int proxyreq(r, ...) Apache r CODE: get_set_IV(r->proxyreq); OUTPUT: RETVAL int header_only(r) Apache r CODE: RETVAL = r->header_only; OUTPUT: RETVAL char * protocol(r) Apache r CODE: RETVAL = r->protocol; OUTPUT: RETVAL char * hostname(r, ...) Apache r CODE: get_set_PVp(r->hostname,r->pool); OUTPUT: RETVAL int status(r, ...) Apache r CODE: get_set_IV(r->status); OUTPUT: RETVAL time_t request_time(r) Apache r CODE: RETVAL = r->request_time; OUTPUT: RETVAL char * status_line(r, ...) Apache r CODE: get_set_PVp(r->status_line,r->pool); OUTPUT: RETVAL # /* Request method, two ways; also, protocol, etc.. Outside of protocol.c, # * look, but don't touch. # */ # char *method; /* GET, HEAD, POST, etc. */ # int method_number; /* M_GET, M_POST, etc. */ # int sent_bodyct; /* byte count in stream is for body */ # long bytes_sent; /* body byte count, for easy access */ char * method(r, ...) Apache r CODE: get_set_PVp(r->method,r->pool); OUTPUT: RETVAL int method_number(r, ...) Apache r CODE: get_set_IV(r->method_number); OUTPUT: RETVAL long bytes_sent(r, ...) Apache r PREINIT: request_rec *last; CODE: for(last=r; last->next; last=last->next) continue; if (last->sent_bodyct && !last->bytes_sent) { ap_bgetopt(last->connection->client, BO_BYTECT, &last->bytes_sent); } RETVAL = last->bytes_sent; if(items > 1) { long nbytes = last->bytes_sent = (long)SvIV(ST(1)); ap_bsetopt(last->connection->client, BO_BYTECT, &nbytes); } OUTPUT: RETVAL # /* MIME header environments, in and out. Also, an array containing # * environment variables to be passed to subprocesses, so people can # * write modules to add to that environment. # * # * The difference between headers_out and err_headers_out is that the # * latter are printed even on error, and persist across internal redirects # * (so the headers printed for ErrorDocument handlers will have them). # * # * The 'notes' table is for notes from one module to another, with no # * other set purpose in mind... # */ # table *headers_in; # table *headers_out; # table *err_headers_out; # table *subprocess_env; # table *notes; # char *content_type; /* Break these out --- we dispatch on 'em */ # char *handler; /* What we *really* dispatch on */ # char *content_encoding; # char *content_language; # int no_cache; SV * header_in(r, key, ...) Apache r char *key CODE: TABLE_GET_SET(r->headers_in, TRUE); OUTPUT: RETVAL void headers_in(r) Apache r PREINIT: int i; array_header *hdrs_arr; table_entry *hdrs; PPCODE: if(GIMME == G_SCALAR) { ST(0) = mod_perl_tie_table(r->headers_in); XSRETURN(1); } hdrs_arr = table_elts (r->headers_in); hdrs = (table_entry *)hdrs_arr->elts; for (i = 0; i < hdrs_arr->nelts; ++i) { if (!hdrs[i].key) continue; PUSHelt(hdrs[i].key, hdrs[i].val, 0); } SV * header_out(r, key, ...) Apache r char *key CODE: TABLE_GET_SET(r->headers_out, TRUE); OUTPUT: RETVAL SV * cgi_header_out(r, key, ...) Apache r char *key PREINIT: char *val; CODE: if((val = (char *)table_get(r->headers_out, key))) RETVAL = newSVpv(val, 0); else RETVAL = newSV(0); SvTAINTED_on(RETVAL); if(items > 2) { int status = 302; val = SvPV(ST(2),na); if(!strncasecmp(key, "Content-type", 12)) { r->content_type = pstrdup (r->pool, val); } else if(!strncasecmp(key, "Status", 6)) { sscanf(val, "%d", &r->status); r->status_line = pstrdup(r->pool, val); } else if(!strncasecmp(key, "Location", 8)) { if (val && val[0] == '/' && r->status == 200) { /* not sure if this is quite right yet */ /* set $Apache::DoInternalRedirect++ to test */ if(DO_INTERNAL_REDIRECT) { r->method = pstrdup(r->pool, "GET"); r->method_number = M_GET; table_unset(r->headers_in, "Content-Length"); status = 200; perl_soak_script_output(r); internal_redirect_handler(val, r); } } table_set (r->headers_out, key, val); r->status = status; } else if(!strncasecmp(key, "Content-Length", 14)) { table_set (r->headers_out, key, val); } else if(!strncasecmp(key, "Transfer-Encoding", 17)) { table_set (r->headers_out, key, val); } #The HTTP specification says that it is legal to merge duplicate #headers into one. Some browsers that support Cookies don't like #merged headers and prefer that each Set-Cookie header is sent #separately. Lets humour those browsers. else if(!strncasecmp(key, "Set-Cookie", 10)) { table_add(r->err_headers_out, key, val); } else { table_merge (r->err_headers_out, key, val); } } void headers_out(r) Apache r PREINIT: int i; array_header *hdrs_arr; table_entry *hdrs; PPCODE: if(GIMME == G_SCALAR) { ST(0) = mod_perl_tie_table(r->headers_out); XSRETURN(1); } hdrs_arr = table_elts (r->headers_out); hdrs = (table_entry *)hdrs_arr->elts; for (i = 0; i < hdrs_arr->nelts; ++i) { if (!hdrs[i].key) continue; PUSHelt(hdrs[i].key, hdrs[i].val, 0); } SV * err_header_out(r, key, ...) Apache r char *key CODE: TABLE_GET_SET(r->err_headers_out, TRUE); OUTPUT: RETVAL void err_headers_out(r, ...) Apache r PREINIT: int i; array_header *hdrs_arr; table_entry *hdrs; PPCODE: if(GIMME == G_SCALAR) { ST(0) = mod_perl_tie_table(r->err_headers_out); XSRETURN(1); } hdrs_arr = table_elts (r->err_headers_out); hdrs = (table_entry *)hdrs_arr->elts; for (i = 0; i < hdrs_arr->nelts; ++i) { if (!hdrs[i].key) continue; PUSHelt(hdrs[i].key, hdrs[i].val, 0); } SV * notes(r, key=NULL, ...) Apache r char *key CODE: TABLE_GET_SET(r->notes, FALSE); OUTPUT: RETVAL void pnotes(r, k=Nullsv, val=Nullsv) Apache r SV *k SV *val PREINIT: perl_request_config *cfg = NULL; char *key = NULL; STRLEN len; CODE: if(k) { key = SvPV(k,len); } cfg = (perl_request_config *) get_module_config(r->request_config, &perl_module); if (!cfg) { XSRETURN_UNDEF; } if(!cfg->pnotes) cfg->pnotes = newHV(); if(key) { if(hv_exists(cfg->pnotes, key, len)) { ST(0) = SvREFCNT_inc(*hv_fetch(cfg->pnotes, key, len, FALSE)); sv_2mortal(ST(0)); } else { ST(0) = &sv_undef; } if(val) { hv_store(cfg->pnotes, key, len, SvREFCNT_inc(val), FALSE); } } else { ST(0) = newRV_inc((SV*)cfg->pnotes); sv_2mortal(ST(0)); } char * content_type(r, ...) Apache r CODE: get_set_PVp(r->content_type,r->pool); OUTPUT: RETVAL char * handler(r, ...) Apache r CODE: get_set_PVp(r->handler,r->pool); OUTPUT: RETVAL char * content_encoding(r, ...) Apache r CODE: get_set_PVp(r->content_encoding,r->pool); OUTPUT: RETVAL char * content_language(r, ...) Apache r CODE: get_set_PVp(r->content_language,r->pool); OUTPUT: RETVAL void content_languages(r, avrv=Nullsv) Apache r SV *avrv PREINIT: I32 gimme = GIMME_V; CODE: if(avrv && SvROK(avrv)) r->content_languages = avrv2array_header(avrv, r->pool); if(gimme != G_VOID) ST(0) = array_header2avrv(r->content_languages); int no_cache(r, ...) Apache r CODE: get_set_IV(r->no_cache); if (r->no_cache) { ap_table_setn(r->headers_out, "Pragma", "no-cache"); ap_table_setn(r->headers_out, "Cache-control", "no-cache"); } OUTPUT: RETVAL # /* What object is being requested (either directly, or via include # * or content-negotiation mapping). # */ # char *uri; /* complete URI for a proxy req, or # URL path for a non-proxy req */ # char *filename; # char *path_info; # char *args; /* QUERY_ARGS, if any */ # struct stat finfo; /* ST_MODE set to zero if no such file */ SV * finfo(r, sv_statbuf=Nullsv) Apache r SV *sv_statbuf CODE: if (sv_statbuf) { if (SvROK(sv_statbuf) && SvOBJECT(SvRV(sv_statbuf))) { STRLEN sz; char *buf = SvPV((SV*)SvRV(sv_statbuf), sz); if (sz != sizeof(r->finfo)) { croak("statbuf size mismatch, got %d, wanted %d", sz, sizeof(r->finfo)); } memcpy(&r->finfo, buf, sz); } else { croak("statbuf is not an object"); } } statcache = r->finfo; if (r->finfo.st_mode) { laststatval = 0; } else { laststatval = -1; } if(GIMME_V == G_VOID) XSRETURN_UNDEF; RETVAL = newRV_noinc((SV*)gv_fetchpv("_", TRUE, SVt_PVIO)); OUTPUT: RETVAL char * uri(r, ...) Apache r CODE: get_set_PVp(r->uri,r->pool); OUTPUT: RETVAL char * filename(r, ...) Apache r CODE: get_set_PVp(r->filename,r->pool); #ifndef WIN32 if(items > 1) if ((laststatval = stat(r->filename, &r->finfo)) < 0) { r->finfo.st_mode = 0; } #endif OUTPUT: RETVAL char * path_info(r, ...) Apache r CODE: get_set_PVp(r->path_info,r->pool); OUTPUT: RETVAL char * query_string(r, ...) Apache r CODE: get_set_PVp(r->args,r->pool); OUTPUT: RETVAL CLEANUP: if (ST(0) != &sv_undef) SvTAINTED_on(ST(0)); # /* Various other config info which may change with .htaccess files # * These are config vectors, with one void* pointer for each module # * (the thing pointed to being the module's business). # */ # void *per_dir_config; /* Options set in config files, etc. */ char * location(r) Apache r CODE: if(r->per_dir_config) { dPPDIR; RETVAL = cld->location; } else XSRETURN_UNDEF; OUTPUT: RETVAL SV * dir_config(r, key=NULL, ...) Apache r char *key ALIAS: Apache::Server::dir_config = 1 PREINIT: perl_dir_config *c; perl_server_config *cs; server_rec *s; CODE: ix = ix; /*-Wall*/ RETVAL = Nullsv; if(r && r->per_dir_config) { c = (perl_dir_config *)get_module_config(r->per_dir_config, &perl_module); TABLE_GET_SET(c->vars, FALSE); } if (!SvTRUE(RETVAL)) { s = r && r->server ? r->server : perl_get_startup_server(); if (s && s->module_config) { SvREFCNT_dec(RETVAL); /* in case above did newSV(0) */ cs = (perl_server_config *)get_module_config(s->module_config, &perl_module); TABLE_GET_SET(cs->vars, FALSE); } else XSRETURN_UNDEF; } OUTPUT: RETVAL # void *request_config; /* Notes on *this* request */ #/* # * a linked list of the configuration directives in the .htaccess files # * accessed by this request. # * N.B. always add to the head of the list, _never_ to the end. # * that way, a sub request's list can (temporarily) point to a parent's list # */ # const struct htaccess_result *htaccess; #}; Apache::SubRequest lookup_uri(r, uri) Apache r char *uri CODE: RETVAL = sub_req_lookup_uri(uri,r); OUTPUT: RETVAL Apache::SubRequest lookup_file(r, file) Apache r char *file CODE: RETVAL = sub_req_lookup_file(file,r); OUTPUT: RETVAL MODULE = Apache PACKAGE = Apache::SubRequest BOOT: av_push(perl_get_av("Apache::SubRequest::ISA",TRUE), newSVpv("Apache",6)); void DESTROY(r) Apache::SubRequest r CODE: destroy_sub_req(r); MP_TRACE_g(fprintf(stderr, "Apache::SubRequest::DESTROY(0x%lx)\n", (unsigned long)r)); int run(r, allow_send_header=0) Apache::SubRequest r int allow_send_header CODE: if (allow_send_header) { r->assbackwards = 0; } RETVAL = run_sub_req(r); OUTPUT: RETVAL -*[MOD_PERL1_25.SRC.MODULES.PERL]APACHE_INC.H;2+,I.E/A@ 46E- 0D123KPWO 56c$7KG 鐟89GA@HJN $J)g7 %J)g7J)g7#ifdef JW_PERL_OBJECT #ifdef uid_t #define apache_uid_t uid_t #undef uid_t #endif #define uid_t apache_uid_t #ifdef gid_t #define apache_gid_t gid_t #undef gid_t #endif #define gid_t apache_gid_t #ifdef mode_t #define apache_mode_t mode_t #undef mode_t #endif #define mode_t apache_mode_t #ifdef sleep #define apache_sleep sleep #undef sleep #endif #ifdef stat #define apache_stat stat #undef stat #endif #ifdef opendir #define apache_opendir opendir #undef opendir #endif #ifdef pool #undef pool #endif #endif #ifdef WIN32 #ifdef uid_t #define apache_uid_t uid_t #undef uid_t #endif #define uid_t apache_uid_t #ifdef gid_t #define apache_gid_t gid_t #undef gid_t #endif #define gid_t apache_gid_t #ifdef mode_t #define apache_mode_t mode_t #undef mode_t #endif #define mode_t apache_mode_t #ifdef stat #define apache_stat stat #undef stat #endif #ifdef sleep #define apache_sleep sleep #undef sleep #endif #ifdef PERL_IS_5_6 #ifdef opendir #define apache_opendir opendir #undef opendir #endif #ifdef readdir #define apache_readdir readdir #undef readdir #endif #ifdef closedir #define apache_closedir closedir #undef closedir #endif #ifdef crypt #define apache_crypt crypt #undef crypt #endif #ifdef errno #define apache_errno errno #undef errno #endif #endif /* endif PERL_IS_56 */ #endif /* endif WIN32 */ #ifdef _INCLUDE_APACHE_FIRST #ifdef __cplusplus extern "C" { #endif /* sfio */ #if !defined(PERLIO_IS_STDIO) && defined(HASATTRIBUTE) # undef printf #endif #include "httpd.h" #include "http_config.h" #include "http_protocol.h" #include "http_log.h" #include "http_main.h" #include "http_core.h" #include "http_request.h" #include "util_script.h" #include "http_conf_globals.h" #include "http_vhost.h" /* sfio */ #if !defined(PERLIO_IS_STDIO) && defined(HASATTRIBUTE) # define printf PerlIO_stdoutf #endif #if defined(APACHE_SSL) || defined(MOD_SSL) #undef _ #ifdef _config_h_ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif #endif #endif #ifdef __cplusplus } #endif #endif #ifdef JW_PERL_OBJECT #undef uid_t #ifdef apache_uid_t #define uid_t apache_uid_t #undef apache_uid_t #endif #undef gid_t #ifdef apache_gid_t #define gid_t apache_gid_t #undef apache_gid_t #endif #undef mode_t #ifdef apache_mode_t #define gid_t apache_mode_t #undef apache_mode_t #endif #ifdef apache_sleep #undef sleep #define sleep apache_sleep #undef apache_sleep #endif #ifdef apache_stat #undef stat #define stat apache_stat #undef apache_stat #endif #ifdef apache_opendir #undef opendir #define opendir apache_opendir #undef apache_opendir #endif #endif #ifdef WIN32 #undef uid_t #ifdef apache_uid_t #define uid_t apache_uid_t #undef apache_uid_t #endif #undef gid_t #ifdef apache_gid_t #define gid_t apache_gid_t #undef apache_gid_t #endif #undef mode_t #ifdef apache_mode_t #define gid_t apache_mode_t #undef apache_mode_t #endif #ifdef apache_stat #undef stat #define stat apache_stat #undef apache_stat #endif #ifdef apache_sleep #undef sleep #define sleep apache_sleep #undef apache_sleep #endif #ifdef PERL_IS_5_6 #ifdef apache_opendir #undef opendir #define opendir apache_opendir #undef apache_opendir #endif #ifdef apache_readdir #undef readdir #define readdir apache_readdir #undef apache_readdir #endif #ifdef apache_closedir #undef closedir #define closedir apache_closedir #undef apache_closedir #endif #ifdef apache_crypt #undef crypt #define crypt apache_crypt #undef apache_crypt #endif #endif /* endif PERL_IS_5_6 */ #endif /* endif WIN32 */ -*[MOD_PERL1_25.SRC.MODULES.PERL]APACHE_INC.H;1+,C.E/A@ 4E- 0D123 KPWO 56z˞酟7酟89GA@HJ N $J)g7 %J)g7J)g7.  ( ( ( #ifdef JW_PERL_OBJECT #ifdef uid_t #define apache_uid_t uid_t #undef uid_t #endif #define uid_t apache_uid_t #ifdef gid_t #define apache_gid_t gid_t #undef gid_t #endif #define gid_t apache_gid_t #ifdef mode_t #define apache_mode_t mode_t #undef mode_t #endif #define mode_t apache_mode_t #ifdef sleep #define apache_sleep sleep #undef sleep #endif #ifdef stat #define apache_stat stat #undef stat #endif #ifdef opendir #define apache_opendir opendir #undef opendir #endif #ifdef pool #undef pool #endif #endif #ifdef WIN32 #ifdef uid_t #define apache_uid_t uid_t #undef uid_t #endif #define uid_t apache_uid_t #ifdef gid_t #define apache_gid_t gid_t #undef gid_t #endif #define gid_t apache_gid_t #ifdef mode_t #define apache_mode_t mode_t #undef mode_t #endif #define mode_t apache_mode_t #ifdef stat #define apache_stat stat #undef stat #endif #ifdef sleep #define apache_sleep sleep #undef sleep #endif #ifdef PERL_IS_5_6 #ifdef opendir #define apache_opendir opendir #undef opendir #endif #ifdef readdir #define apache_readdir readdir #undef readdir #endif #ifdef closedir #define apache_closedir closedir #undef closedir #endif #ifdef crypt #define apache_crypt crypt #undef crypt #endif #ifdef errno #define apache_errno errno #undef errno #endif #endif /* endif PERL_IS_56 */ #endif /* endif WIN32 */ #ifndef _INCLUDE_APACHE_FIRST #ifdef __cplusplus extern "C" { #endif /* sfio */ #if !defined(P 7{~MOD_PERL1_25_MUP.SAVEC -[MOD_PERL1_25.SRC.MODULES.PERL]APACHE_INC.H;1E` ERLIO_IS_STDIO) && defined(HASATTRIBUTE) # undef printf #endif #include "httpd.h" #include "http_config.h" #include "http_protocol.h" #include "http_log.h" #include "http_main.h" #include "http_core.h" #include "http_request.h" #include "util_script.h" #include "http_conf_globals.h" #include "http_vhost.h" /* sfio */ #if !defined(PERLIO_IS_STDIO) && defined(HASATTRIBUTE) # define printf PerlIO_stdoutf #endif #if defined(APACHE_SSL) || defined(MOD_SSL) #undef _ #ifdef _config_h_ #ifdef CAN_PROTOTYPE #define _(args) args #else #define _(args) () #endif #endif #endif #ifdef __cplusplus } #endif #endif #ifdef JW_PERL_OBJECT #undef uid_t #ifdef apache_uid_t #define uid_t apache_uid_t #undef apache_uid_t #endif #undef gid_t #ifdef apache_gid_t #define gid_t apache_gid_t #undef apache_gid_t #endif #undef mode_t #ifdef apache_mode_t #define gid_t apache_mode_t #undef apache_mode_t #endif #ifdef apache_sleep #undef sleep #define sleep apache_sleep #undef apache_sleep #endif #ifdef apache_stat #undef stat #define stat apache_stat #undef apache_stat #endif #ifdef apache_opendir #undef opendir #define opendir apache_opendir #undef apache_opendir #endif #endif #ifdef WIN32 #undef uid_t #ifdef apache_uid_t #define uid_t apache_uid_t #undef apache_uid_t #endif #undef gid_t #ifdef apache_gid_t #define gid_t apache_gid_t #undef apache_gid_t #endif #undef mode_t #ifdef apache_mode_t #define gid_t apache_mode_t #undef apache_mode_t #endif #ifdef apache_stat #undef stat #define stat apache_stat #undef apache_stat #endif #ifdef apache_sleep #undef sleep #define sleep apache_sleep #undef apache_sleep #endif #ifdef PERL_IS_5_6 #ifdef apache_opendir #undef opendir #define opendir apache_opendir #undef apache_opendir #endif #ifdef apache_readdir #undef readdir #define readdir apache_readdir #undef apache_readdir #endif #ifdef apache_closedir #undef closedir #define closedir apache_closedir #undef apache_closedir #endif #ifdef apache_crypt #undef crypt #define crypt apache_crypt #undef apache_crypt #endif #endif /* endif PERL_IS_5_6 */ #endif /* endif WIN32 */ ,*[MOD_PERL1_25.SRC.MODULES.PERL]DESCRIP.MMS;1+,].E/A@ 4E- 0123KPWO56r/7P1r/89GA@HJ# ==================================================================== # Copyright (c) 1995-1997 The Apache Group. All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # # 1. Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in # the documentation and/or other materials provided with the # distribution. # # 3. All advertising materials mentioning features or use of this # software must display the following acknowledgment: # "This product includes software developed by the Apache Group # for use in the Apache HTTP server project (http://www.apache.org/)." # # 4. The names "Apache Server" and "Apache Group" must not be used to # endorse or promote products derived from this software without # prior written permission. # # 5. Redistributions of any form whatsoever must retain the following # acknowledgment: # "This product includes software developed by the Apache Group # for use in the Apache HTTP server project (http://www.apache.org/)." # # THIS SOFTWARE IS PROVIDED BY THE APACHE GROUP ``AS IS'' AND ANY # EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR # PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE APACHE GROUP OR # ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT # NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, # STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED # OF THE POSSIBILITY OF SUCH DAMAGE. # ==================================================================== # # This software consists of voluntary contributions made by many # individuals on behalf of the Apache Group and was originally based # on public domain software written at the National Center for # Supercomputing Applications, University of Illinois, Urbana-Champaign. # For more information on the Apache Group and the Apache HTTP server # project, please see . # # Makefile for the Apache mod_perl library # # $Id: Makefile,v 1.14 2001/01/29 18:11:32 dougm Exp $ # #__ORIGINAL__ INCLUDES=$(INCLUDES1) $(INCLUDES0) $(INCLUDES_DEPTH2) $(EXTRA_INCLUDES) INCDIR=apache$root:[src.include] #SHELL = /bin/sh LIB=perlshr OBJECT= mod_perl.obj mod_perl_opmask.obj perl_config.obj perl_util.obj perlio.obj perlxsi.obj #on/off switches for Perl API hooks #comment out to enable callbacks at a certain stage in the request PERL_DISPATCH = NO_PERL_DISPATCH PERL_CHILD_INIT = NO_PERL_CHILD_INIT PERL_CHILD_EXIT = NO_PERL_CHILD_EXIT PERL_RESTART = NO_PERL_RESTART PERL_POST_READ_REQUEST = NO_PERL_POST_READ_REQUEST PERL_TRANS = NO_PERL_TRANS PERL_HEADER_PARSER = NO_PERL_HEADER_PARSER PERL_ACCESS = NO_PERL_ACCESS PERL_AUTHEN = NO_PERL_AUTHEN PERL_AUTHZ = NO_PERL_AUTHZ PERL_TYPE = NO_PERL_TYPE PERL_FIXUP = NO_PERL_FIXUP PERL_LOG = NO_PERL_LOG PERL_INIT = NO_PERL_INIT PERL_CLEANUP = NO_PERL_CLEANUP PERL_STACKED_HANDLERS = NO_PERL_STACKED_HANDLERS PERL_SECTIONS = NO_PERL_SECTIONS PERL_METHOD_HANDLERS = NO_PERL_METHOD_HANDLERS PERL_DIRECTIVE_HANDLERS = NO_PERL_DIRECTIVE_HANDLERS PERL_SSI = NO_PERL_SSI PERL_HOOKS = $(PERL_DISPATCH) $(PERL_CHILD_INIT) $(PERL_CHILD_EXIT) \ $(PERL_POST_READ_REQUEST) $(PERL_TRANS) $(PERL_HEADER_PARSER) \ $(PERL_ACCESS) $(PERL_AUTHEN) $(PERL_AUTHZ) \ $(PERL_TYPE) $(PERL_FIXUP) $(PERL_LOG) \ $(PERL_INIT) $(PERL_CLEANUP) $(PERL_RESTART) \ $(PERL_STACKED_HANDLERS) $(PERL_SECTIONS) $(PERL_METHOD_HANDLERS) \ $(PERL_SSI) $(PERL_DIRECTIVE_HANDLERS) #STATIC_SRC = Apache.c Constants.c #STATIC_EXTS = Apache Apache::Constants #TRACE = -DPERL_TRACE #SSL_COMMON_INC = -I../../../ssl/include -I/usr/local/ssl/include #APACHE_SSL = PERL=perl PERL_STATIC_EXTS = "DynaLoader" "Socket" PERL5LIB=/perl_root/lib #PRIVLIB=`$(PERL) -MConfig -e 'print $$Config{privlibexp}'` EXTUTILS_EMBED = $(PERL) "-MExtUtils::Embed" #CONFIG_PM=-MConfig #CONFIG_PM='-MApache::ExtUtils=%Config' #PERL_CFG_CCFLAGS = `$(PERL) $(CONFIG_PM) -e 'print $$Config{ccflags}'` #PERL_CFG_ARCHLIB = `$(PERL) -MConfig -e 'print $$Config{archlibexp}'` PERL_CCFLAGS = /Standard=Relaxed_ANSI/Prefix=All/Obj=.obj/List/Machine/Show=Exp/include=([],perl_root:[lib.VMS_AXP.5_6_1.core]) $(PERL_HOOKS) $(TRACE) PERL_IN=PERL_ROOT:[LIB.VMS_AXPy.5_6_1.CORE] .SUFFIXES : .xs .c .o XS_INIT = $(EXTUTILS_EMBED) -e xsinit -- -std $(PERL_STATIC_EXTS) $(STATIC_EXTS) #CC=`$(PERL) -MConfig -e 'print $$Config{cc}'` # AUX_CFLAGS comes from higher level Makefile #CFLAGS=-I. -I$(INCDIR) -I$(INCDIR)/regex -I$(INCDIR)/../$(OSDIR) $(AUX_CFLAGS) \ # $(APACHE_SSL) $(PERL_CCFLAGS) \ # -DMOD_PERL_VERSION=\"$(MOD_PERL_VERSION)\" \ # $(INCLUDES) .ifdef CONFIG_SSL CFDEFINE=_INCLUDE_APACHE_FIRST,DONT_MASK_RTL_CALLS,PERL_TRACE,EAPI .else CFDEFINE=_INCLUDE_APACHE_FIRST,DONT_MASK_RTL_CALLS,PERL_TRACE .endif CFLAGS=/list/machine/show=exp/prefix=all/inc=(perl_root:[lib.vms_axp.5_6_1.core],[],apache$root:[src.include],apache$root:[src.os.openvms])/define=($(CFDEFINE)) .FIRST @ If F$TrnLnm("APACHE$BUILD_SYLOGIN").nes."" Then @APACHE$BUILD_SYLOGIN all : mod_perl.olb perlxsi.c mod_perl.exe @ continue install : all @ if f$search("apache$root:[000000]modules.dir") .eqs. "" then - create/dir apache$root:[modules] Copy mod_perl.exe apache$root:[modules] mod_perl.olb : lib/create $(MMS$TARGET) perlxsi.c : $(XS_INIT) perlxsi.obj : perlxsi.c $(CC) $(MMS$SOURCE) $(CFLAGS) lib/repl mod_perl.olb $(MMS$TARGET) mod_perl.exe : $(OBJECT) mod_perl_bld.opt link/map=mod_perl.map/full/cross/share=mod_perl.exe mod_perl.olb/lib,mod_perl_bld.opt/option .xs.c : $(PERL) $(PERL5LIB)/ExtUtils/xsubpp -typemap $(PERL5LIB)/ExtUtils/typemap -typemap ../../../apache/typemap $(MMS$SOURCE) >$(MMS$TARGET) apache.obj : apache.c constants.obj : constants.c connection.obj : connection.c file.obj : file.c moduleconfig.obj : moduleconfig.c log.obj : log.c uri.obj : uri.c util.obj : util.c table.obj : table.c server.obj : server.c perlrunxs.obj : perlrunxs.c perlxsi.obj : perlxsi.c #PERLSRC=mod_perl_opmask.c mod_perl.c perlxsi.c perl_config.c perl_util.c perlio.c $(STATIC_SRC) #OBJS=$(PERLSRC:.c=.o) .c.obj : $(OBJECTS) $(CC) $(MMS$SOURCE) $(CFLAGS) lib/repl mod_perl.olb $(MMS$TARGET) $(LIB) : $(OBJECT) # dependencies $(OBJECT) : mod_perl.h $(INCDIR)httpd.h $(INCDIR)http_config.h mod_perl.obj : $(PERLSRC) # various forms of cleanup tidy : - delete/nolog/nowarn *.out;* clean : tidy - delete/nolog *.obj;* - delete/nolog perlxsi.c;* - delete/nolog Apache.c;* - delete/nolog Constants.c;* - delete/nolog *.olb;* - delete/nolog *.exe;* +*[MOD_PERL1_25.SRC.MODULES.PERL]MOD_PERL.C;2+,J./A@ 4u[%- 0D123KPWO\56!789GA@HJN $J)g7 %J)g7J)g7P/* ==================================================================== * The Apache Software License, Version 1.1 * * Copyright (c) 1996-2000 The Apache Software Foundation. All rights * reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in * the documentation and/or other materials provided with the * distribution. * * 3. The end-user documentation included with the redistribution, * if any, must include the following acknowledgment: * "This product includes software developed by the * Apache Software Foundation (http://www.apache.org/)." * Alternately, this acknowledgment may appear in the software itself, * if and wherever such third-party acknowledgments normally appear. * * 4. The names "Apache" and "Apache Software Foundation" must * not be used to endorse or promote products derived from this * software without prior written permission. For written * permission, please contact apache@apache.org. * * 5. Products derived from this software may not be called "Apache", * nor may "Apache" appear in their name, without prior written * permission of the Apache Software Foundation. * * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. * ==================================================================== */ /* * And so it was decided the camel should be given magical multi-colored * feathers so it could fly and journey to once unknown worlds. * And so it was done... */ #define CORE_PRIVATE #include "mod_perl.h" #ifdef WIN32 void *mod_perl_mutex = &mod_perl_mutex; #else void *mod_perl_dummy_mutex = &mod_perl_dummy_mutex; #endif static IV mp_request_rec; static int seqno = 0; static int perl_is_running = 0; int mod_perl_socketexitoption = 3; int mod_perl_weareaforkedchild = 0; static int callbacks_this_request = 0; static PerlInterpreter *perl = NULL; static AV *orig_inc = Nullav; static AV *cleanup_av = Nullav; #ifdef PERL_STACKED_HANDLERS static HV *stacked_handlers = Nullhv; #endif #ifdef PERL_OBJECT CPerlObj *pPerl; #endif typedef const char* (*crft)(); /* command_req_func_t */ static command_rec perl_cmds[] = { #ifdef PERL_SECTIONS { "", (crft) perl_section, NULL, SECTION_ALLOWED, RAW_ARGS, "Perl code" }, { "", (crft) perl_end_section, NULL, SECTION_ALLOWED, NO_ARGS, "End Perl code" }, #endif { "=pod", (crft) perl_pod_section, NULL, OR_ALL, RAW_ARGS, "Start of POD" }, { "=back", (crft) perl_pod_section, NULL, OR_ALL, RAW_ARGS, "End of =over" }, { "=cut", (crft) perl_pod_end_section, NULL, OR_ALL, NO_ARGS, "End of POD" }, { "__END__", (crft) perl_config_END, NULL, OR_ALL, RAW_ARGS, "Stop reading config" }, { "PerlFreshRestart", (crft) perl_cmd_fresh_restart, NULL, RSRC_CONF, FLAG, "Tell mod_perl to reload modules and flush Apache::Registry cache on restart" }, { "PerlTaintCheck", (crft) perl_cmd_tainting, NULL, RSRC_CONF, FLAG, "Turn on -T switch" }, #ifdef PERL_SAFE_STARTUP { "PerlOpmask", (crft) perl_cmd_opmask, NULL, RSRC_CONF, TAKE1, "Opmask File" }, #endif { "PerlWarn", (crft) perl_cmd_warn, NULL, RSRC_CONF, FLAG, "Turn on -w switch" }, { "PerlScript", (crft) perl_cmd_require, NULL, OR_ALL, ITERATE, "this directive is deprecated, use `PerlRequire'" }, { "PerlRequire", (crft) perl_cmd_require, NULL, OR_ALL, ITERATE, "A Perl script name, pulled in via require" }, { "PerlModule", (crft) perl_cmd_module, NULL, OR_ALL, ITERATE, "List of Perl modules" }, { "PerlSetVar", (crft) perl_cmd_var, NULL, OR_ALL, TAKE2, "Perl config var and value" }, { "PerlAddVar", (crft) perl_cmd_var, (void*)1, OR_ALL, ITERATE2, "Perl config var and value" }, { "PerlSetEnv", (crft) perl_cmd_setenv, NULL, OR_ALL, TAKE2, "Perl %ENV key and value" }, { "PerlPassEnv", (crft) perl_cmd_pass_env, NULL, RSRC_CONF, ITERATE, "pass environment variables to %ENV"}, { "PerlSendHeader", (crft) perl_cmd_sendheader, NULL, OR_ALL, FLAG, "Tell mod_perl to parse and send HTTP headers" }, { "PerlSetupEnv", (crft) perl_cmd_env, NULL, OR_ALL, FLAG, "Tell mod_perl to setup %ENV by default" }, { "PerlHandler", (crft) perl_cmd_handler_handlers, NULL, OR_ALL, ITERATE, "the Perl handler routine name" }, #ifdef PERL_TRANS { PERL_TRANS_CMD_ENTRY }, #endif #ifdef PERL_AUTHEN { PERL_AUTHEN_CMD_ENTRY }, #endif #ifdef PERL_AUTHZ { PERL_AUTHZ_CMD_ENTRY }, #endif #ifdef PERL_ACCESS { PERL_ACCESS_CMD_ENTRY }, #endif #ifdef PERL_TYPE { PERL_TYPE_CMD_ENTRY }, #endif #ifdef PERL_FIXUP { PERL_FIXUP_CMD_ENTRY }, #endif #ifdef PERL_LOG { PERL_LOG_CMD_ENTRY }, #endif #ifdef PERL_CLEANUP { PERL_CLEANUP_CMD_ENTRY }, #endif #ifdef PERL_INIT { PERL_INIT_CMD_ENTRY }, #endif #ifdef PERL_HEADER_PARSER { PERL_HEADER_PARSER_CMD_ENTRY }, #endif #ifdef PERL_CHILD_INIT { PERL_CHILD_INIT_CMD_ENTRY }, #endif #ifdef PERL_CHILD_EXIT { PERL_CHILD_EXIT_CMD_ENTRY }, #endif #ifdef PERL_POST_READ_REQUEST { PERL_POST_READ_REQUEST_CMD_ENTRY }, #endif #ifdef PERL_DISPATCH { PERL_DISPATCH_CMD_ENTRY }, #endif #ifdef PERL_RESTART { PERL_RESTART_CMD_ENTRY }, #endif { NULL } }; static handler_rec perl_handlers [] = { { "perl-script", perl_handler }, { DIR_MAGIC_TYPE, perl_handler }, { NULL } }; module MODULE_VAR_EXPORT perl_module = { STANDARD_MODULE_STUFF, perl_module_init, /* initializer */ perl_create_dir_config, /* create per-directory config structure */ perl_merge_dir_config, /* merge per-directory config structures */ perl_create_server_config, /* create per-server config structure */ perl_merge_server_config, /* merge per-server config structures */ perl_cmds, /* command table */ perl_handlers, /* handlers */ PERL_TRANS_HOOK, /* translate_handler */ PERL_AUTHEN_HOOK, /* check_user_id */ PERL_AUTHZ_HOOK, /* check auth */ PERL_ACCESS_HOOK, /* check access */ PERL_TYPE_HOOK, /* type_checker */ PERL_FIXUP_HOOK, /* pre-run fixups */ PERL_LOG_HOOK, /* logger */ #if MODULE_MAGIC_NUMBER >= 19970103 PERL_HEADER_PARSER_HOOK, /* header parser */ #endif #if MODULE_MAGIC_NUMBER >= 19970719 PERL_CHILD_INIT_HOOK, /* child_init */ #endif #if MODULE_MAGIC_NUMBER >= 19970728 NULL, /* child_exit *//* mod_perl uses register_cleanup() */ #endif #if MODULE_MAGIC_NUMBER >= 19970825 PERL_POST_READ_REQUEST_HOOK, /* post_read_request */ #endif }; #if defined(STRONGHOLD) && !defined(APACHE_SSL) #define APACHE_SSL #endif int PERL_RUNNING (void) { return (perl_is_running); } static void seqno_check_max(request_rec *r, int seqno) { dPPDIR; char *max = NULL; array_header *vars = (array_header *)cld->vars; /* XXX: what triggers such a condition ?*/ if(vars && (vars->nelts > 100000)) { fprintf(stderr, "[warning] PerlSetVar->nelts = %d\n", vars->nelts); } else { if(cld->vars) max = (char *)table_get(cld->vars, "MaxModPerlRequestsPerChild"); } #if (MODULE_MAGIC_NUMBER >= 19970912) && !defined(WIN32) if(max && (seqno >= atoi(max))) { child_terminate(r); MP_TRACE_g(fprintf(stderr, "mod_perl: terminating child %d after serving %d requests\n", (int)getpid(), seqno)); } #endif max = NULL; } void perl_shutdown (server_rec *s, pool *p) { char *pdl = NULL; if((pdl = getenv("PERL_DESTRUCT_LEVEL"))) perl_destruct_level = atoi(pdl); else perl_destruct_level = PERL_DESTRUCT_LEVEL; if(perl_destruct_level < 0) { MP_TRACE_g(fprintf(stderr, "skipping destruction of Perl interpreter\n")); return; } /* execute END blocks we suspended during perl_startup() */ perl_run_endav("perl_shutdown"); MP_TRACE_g(fprintf(stderr, "destructing and freeing Perl interpreter (level=%d)...", perl_destruct_level)); perl_util_cleanup(); mp_request_rec = 0; av_undef(orig_inc); SvREFCNT_dec((SV*)orig_inc); orig_inc = Nullav; av_undef(cleanup_av); SvREFCNT_dec((SV*)cleanup_av); cleanup_av = Nullav; #ifdef PERL_STACKED_HANDLERS hv_undef(stacked_handlers); SvREFCNT_dec((SV*)stacked_handlers); stacked_handlers = Nullhv; #endif perl_destruct(perl); perl_free(perl); #ifdef USE_THREADS PERL_SYS_TERM(); #endif perl_is_running = 0; MP_TRACE_g(fprintf(stderr, "ok\n")); } request_rec *mp_fake_request_rec(server_rec *s, pool *p, char *hook) { request_rec *r = (request_rec *)pcalloc(p, sizeof(request_rec)); r->pool = p; r->server = s; r->per_dir_config = NULL; r->uri = hook; r->notes = NULL; return r; } #ifdef PERL_RESTART void perl_restart_handler(server_rec *s, pool *p) { char *hook = "PerlRestartHandler"; dSTATUS; dPSRV(s); request_rec *r = mp_fake_request_rec(s, p, hook); PERL_CALLBACK(hook, cls->PerlRestartHandler); } #endif void perl_restart(server_rec *s, pool *p) { /* restart as best we can */ SV *rgy_cache = perl_get_sv("Apache::Registry", FALSE); HV *rgy_symtab = (HV*)gv_stashpv("Apache::ROOT", FALSE); ENTER; SAVESPTR(warnhook); warnhook = perl_eval_pv("sub {}", TRUE); /* the file-stat cache */ if(rgy_cache) sv_setsv(rgy_cache, &sv_undef); /* the symbol table we compile registry scripts into */ if(rgy_symtab) hv_clear(rgy_symtab); if(endav) { SvREFCNT_dec(endav); endav = Nullav; } #ifdef STACKED_HANDLERS if(stacked_handlers) hv_clear(stacked_handlers); #endif /* reload %INC */ perl_reload_inc(s, p); LEAVE; /*mod_perl_notice(s, "mod_perl restarted"); */ MP_TRACE_g(fprintf(stderr, "perl_restart: ok\n")); } U32 mp_debug = 0; static void mod_perl_set_cwd(void) { char *name = "Apache::Server::CWD"; GV *gv = gv_fetchpv(name, GV_ADDMULTI, SVt_PV); char *pwd = getenv("PWD"); if(pwd) sv_setpv(GvSV(gv), pwd); else sv_setsv(GvSV(gv), perl_eval_pv("require Cwd; Cwd::getcwd()", TRUE)); mod_perl_untaint(GvSV(gv)); } #ifdef PERL_TIE_SCRIPTNAME static I32 scriptname_val(IV ix, SV* sv) { dTHR; request_rec *r = perl_request_rec(NULL); if(r) sv_setpv(sv, r->filename); else if(strNE(SvPVX(GvSV(CopFILEGV(curcop))), "-e")) sv_setsv(sv, GvSV(CopFILEGV(curcop))); else { SV *file = perl_eval_pv("(caller())[1]",TRUE); sv_setsv(sv, file); } MP_TRACE_g(fprintf(stderr, "FETCH $0 => %s\n", SvPV(sv,na))); return TRUE; } static void mod_perl_tie_scriptname(void) { SV *sv = perl_get_sv("0",TRUE); struct ufuncs umg; umg.uf_val = scriptname_val; umg.uf_set = NULL; umg.uf_index = (IV)0; sv_unmagic(sv, 'U'); sv_magic(sv, Nullsv, 'U', (char*) &umg, sizeof(umg)); } #else #define mod_perl_tie_scriptname() #endif #define saveINC \ if(orig_inc) SvREFCNT_dec(orig_inc); \ orig_inc = av_copy_array(GvAV(incgv)) #define dl_librefs "DynaLoader::dl_librefs" #define dl_modules "DynaLoader::dl_modules" static array_header *xs_dl_librefs(pool *p) { I32 i; AV *librefs = perl_get_av(dl_librefs, FALSE); AV *modules = perl_get_av(dl_modules, FALSE); array_header *arr; if (!librefs) { MP_TRACE_g(fprintf(stderr, "Could not get @%s for unloading.\n", dl_librefs)); return NULL; } arr = ap_make_array(p, AvFILL(librefs)-1, sizeof(void *)); for (i=0; i<=AvFILL(librefs); i++) { void *handle; SV *handle_sv = *av_fetch(librefs, i, FALSE); SV *module_sv = *av_fetch(modules, i, FALSE); if(!handle_sv) { MP_TRACE_g(fprintf(stderr, "Could not fetch $%s[%d]!\n", dl_librefs, (int)i)); continue; } handle = (void *)SvIV(handle_sv); MP_TRACE_g(fprintf(stderr, "%s dl handle == 0x%lx\n", SvPVX(module_sv), (unsigned long)handle)); if (handle) { *(void **)ap_push_array(arr) = handle; } } av_clear(modules); av_clear(librefs); return arr; } static void unload_xs_so(array_header *librefs) { int i; if (!librefs) { return; } for (i=0; i < librefs->nelts; i++) { void *handle = ((void **)librefs->elts)[i]; MP_TRACE_g(fprintf(stderr, "unload_xs_so: 0x%lx\n", (unsigned long)handle)); #ifdef _AIX /* make sure Perl's dlclose is used, instead of Apache's */ dlclose(handle); #else ap_os_dso_unload(handle); #endif } } #if 0 /* unload_xs_dso should obsolete this hack */ static void cancel_dso_dlclose(void) { module *modp; if(!PERL_DSO_UNLOAD) return; if(strEQ(top_module->name, "mod_perl.c")) return; for(modp = top_module; modp; modp = modp->next) { if(modp->dynamic_load_handle) { MP_TRACE_g(fprintf(stderr, "mod_perl: cancel dlclose for %s\n", modp->name)); modp->dynamic_load_handle = NULL; } } } #endif static void mp_dso_unload(void *data) { array_header *librefs; #ifdef WIN32 // This is here to stop a crash when bringing down // a service. Apparently the dso is unloaded too early. // This if statement tests to see if we are running as a // service. apache does the same // see apache's isProcessService() in service.c if (AllocConsole()) { FreeConsole(); return; } #endif librefs = xs_dl_librefs((pool *)data); perl_shutdown(NULL, NULL); unload_xs_so(librefs); } static void mp_server_notstarting(void *data) { saveINC; require_Apache(NULL); Apache__ServerStarting(FALSE); } #define Apache__ServerStarting_on() \ Apache__ServerStarting(PERL_RUNNING()); \ if(!PERL_IS_DSO) \ register_cleanup(p, NULL, mp_server_notstarting, mod_perl_noop) #define MP_APACHE_VERSION "1.27" void mp_check_version(void) { I32 i; SV *namesv; SV *version; STRLEN n_a; require_Apache(NULL); if(!(version = perl_get_sv("Apache::VERSION", FALSE))) croak("Apache.pm failed to load!"); /*should never happen*/ if(strEQ(SvPV(version,n_a), MP_APACHE_VERSION)) /*no worries*/ return; fprintf(stderr, "Apache.pm version %s required!\n", MP_APACHE_VERSION); fprintf(stderr, "%s", form("%_ is version %_\n", *hv_fetch(GvHV(incgv), "Apache.pm", 9, FALSE), version)); fprintf(stderr, "Perhaps you forgot to 'make install' or need to uninstall an old version?\n"); namesv = NEWSV(806, 0); for(i=0; i<=AvFILL(GvAV(incgv)); i++) { char *tryname; PerlIO *tryrsfp = 0; SV *dir = *av_fetch(GvAV(incgv), i, TRUE); sv_setpvf(namesv, "%_/Apache.pm", dir); tryname = SvPVX(namesv); if((tryrsfp = PerlIO_open(tryname, "r"))) { fprintf(stderr, "Found: %s\n", tryname); PerlIO_close(tryrsfp); } } SvREFCNT_dec(namesv); exit(1); } #if !HAS_MMN_136 static void set_sigpipe(void) { char *dargs[] = { NULL }; perl_require_module("Apache::SIG", NULL); perl_call_argv("Apache::SIG::set", G_DISCARD, dargs); } #endif void perl_module_init(server_rec *s, pool *p) { #if HAS_MMN_130 ap_add_version_component(MOD_PERL_STRING_VERSION); if(PERL_RUNNING()) { #ifdef PERL_IS_5_6 char *version = form("Perl/v%vd", PL_patchlevel); #else char *version = form("Perl/%_", perl_get_sv("]", TRUE)); #endif if(perl_get_sv("Apache::Server::AddPerlVersion", FALSE)) { ap_add_version_component(version); } } #endif perl_startup(s, p); } void perl_startup (server_rec *s, pool *p) { char *argv[] = { NULL, NULL, NULL, NULL, NULL, NULL, NULL }; char **entries, *dstr; int status, i, argc=1; dPSRV(s); SV *pool_rv, *server_rv; GV *gv, *shgv; #ifndef WIN32 argv[0] = server_argv0; #endif #ifdef PERL_TRACE if((dstr = getenv("MOD_PERL_TRACE"))) { if(strEQ(dstr, "all")) { mp_debug = 0xffffffff; } else if (isALPHA(dstr[0])) { static char debopts[] = "dshgc"; char *d; for (; *dstr && (d = strchr(debopts,*dstr)); dstr++) mp_debug |= 1 << (d - debopts); } else { mp_debug = atoi(dstr); } mp_debug |= 0x80000000; } #else dstr = NULL; #endif if(PERL_RUNNING() && PERL_STARTUP_IS_DONE) { saveINC; mp_check_version(); #if !HAS_MMN_136 set_sigpipe(); #endif } if(perl_is_running == 0) { /* we'll boot Perl below */ } else if(perl_is_running < PERL_DONE_STARTUP) { /* skip the -HUP at server-startup */ perl_is_running++; Apache__ServerStarting_on(); MP_TRACE_g(fprintf(stderr, "perl_startup: perl aleady running...ok\n")); return; } else { Apache__ServerReStarting(TRUE); #ifdef PERL_RESTART perl_restart_handler(s, p); #endif if(cls->FreshRestart) perl_restart(s, p); Apache__ServerReStarting(FALSE); return; } perl_is_running++; /* fake-up what the shell usually gives perl */ if(cls->PerlTaintCheck) argv[argc++] = "-T"; if(cls->PerlWarn) argv[argc++] = "-w"; #ifdef WIN32 argv[argc++] = "nul"; #else argv[argc++] = "/dev/null"; #endif MP_TRACE_g(fprintf(stderr, "perl_parse args: ")); for(i=1; iPerlTaintCheck); (void)GvSV_init("Apache::__SendHeader"); (voi i(([MOD_PERL1_25.LIB.APACHE] RC.P>>(xyE_INC-H;1REpFw{KC.77l:Fa_Yy9D,IhWtdaFGs}]v)YU`;u%M%hv$)t>$ t $HI.Kc7P&Tn/ape]$Z}Yadzy Z4Gn)%:1zU:f7jJU(~ fh> G?d)O#sf ? TzUet 6,w"5T'9r!!"(?AL=s}y|y/t$dGFi$e J~x^?]bi}?EbwU!v9w:F`u}NRa7 ;.]itjzxO= w Ym\Dko=-z /m^q<]e#R[Y}9o^ JD!q+;sI.Df!ZnJ]gVKq:TPKE^[fOQ^XX0DYnC]-eO\Och.A0xeyQX;'_<;f)UI3eikf*a\J :V;melU;*WBX{C+wLRV hu͠qwro_2C={Xhv v[d:(*_+[sK"HJ2,!@dSwѸs7 Qd%4 PR:ec(bwGj}8\((oj_up{Wjfh=h&N |@h1 M58;.,(LzBF  Q?p;D,aXKW0+b)u8E 9|(?(9h)IUQ1J[N$Q.bmtv@}?[ sU#p#jq6`Q .򁪁wt X;a #R%I9^ ,7̏1/^qhh #D<|@i9 ) l'cq|cn m"{vyc#iXoE/#UaS;qy-,qXC Ryf`F)1m1,a`b`l:L+hIVj8,ZQ59yT+La*IXKg>WBx*GIUk$]{/8r30$SMlS5qeain>NњT^/ȹ {nQJ6 N:E?Ex# fF7)h`Yg;+8q K}C#{# uw*vgr4(uMk8odkWEnhEu/a2A"0#wF)bg{aY,v8+` }1z"a8~fV_#4/I1x_?gX`D@gV[GOe p\LR4'7]cUpbeOi|z_tyLYB{h\G&b?<]{+ }&aQ7:M"i)!Gr[mA[UYA `cby/E{fOYQvK0mb gytM|pCe  gvLLU7 {[=6dljer_[EMcMh:FuH?Z4x& EE"9_."A69FQDXm&Q)3Mv,L eWr,G?wdQ*s|4*%W{3 )n1vRzQ<<#I4_P>:Fc.hj,:kE\g5]+/N=dz:(v$x&#/?mVpH4qY-AEH(t/Q':Mz[vU8wGA2~3FU \nJ"@.|NRe9qdT}UA+858he^>b7zdJZ*L]@^@y#뮂G5_5L=|G+s/Bfu}cHzro3o k WgtG/ ?H[ZKe[\f"4oM%T%|+ARK(.( pXH$<9S400Di6S1ytiyY) k'>q.wV YGrLc2aV-/pX|uq]:Vn2Ng,GJH~"|ru?_vg~LdA>:<|o64k@nF.kir=y \!?=^|g/Y\z|2|HcIMLp6( RS " fJ"!y\Y()FKybc3PO?}^Eg )4 5g q'lX${29MbKZA. 5 |ejy dm~b62 0aI )/Rn4GA.LVV7 H]C|*{e=IMGEYdge^ $ddG;p:\)\?(7$%WTvHfV*~ 0X0r'Jh``RT9Y+Hl9b>raG:bsng| :Q Ce%'zn/ Zh:&V0X+sL+X|Lq0A =o 1_b$^*bRu5xrz. [_UT2M[>ZzduRO%2XzUlBJZ#&C~&G]t.7Mb2Kp?]\5)ou I:wD)'&j(tGQ>k :"N{#\w;)o<[ l^^>_^H @ <U6"[ pM|'[ R@|TG= rF4XM~Z0A:-* grzh o2/ u& EF6[mb 9y+hVL 'how }72U99:A8#\ r T*a)=dE4dym sVI+]QT[/1F<78H#": rscqc8:^EQ< ~a ?1b$?d0rg~W &F&WCt-vyq 3}$gkw^fdl"t(~Q6rMw"KG9l\#[+uzPGV `Net V\DowmdX>OOz)GjOFR)/V5A|< c+]l'1|?J4P1j8Nb[|Z}?[K3*Efh:.oyP0~p6ru73urB5o~&!"^7X `Bw.:im3 ,iAZs`7e9}jh7Qo[|-C x6x{cZmfPcZmKY^ P$_jx.4kG5JVzzz{ ;V)]0U6mB.6l st@=I)[e"]u&"&>TwfiW-#]ax o2s-k-Q~O!iY)}MGzm[qI|e-@+&FJ=^:yqxA@c1v(9/ckqlw \OfA3l!}  x_ 1AA d./ L:vim"bu$9 {tGXOTDC:Ch ^DoQ[W O+ U<*(g_F#aPge9duTMt/!kER,0wzOSspq,",!V&8z{>~L=` nJ|1 =o V e|1cka\ sn}Bm_@vG>h=m@3gWo%'iwI2bfuI]_YTGlRq0&R}uM:2P:@ T-0q2Aa/'"7bu`V>heFlvh(Z6`mhFYRn]s88W F r; X>FsmZ9]aukPBiAg %!L _q vn`X., Cc &I*h2p YHq 9Xr9e_54Xt_)hwmljXZi/ `I{\QL0E5Y6NDnyZVb+Ei0%TSk![+$l3 [HPvr.|fmq t 3`eu VH])p|#I&>m,CQV'@CvT_6Q.GN#a"x%`xg@;O u\cXe@PtyHvyH  vI+RxXuN}TlRs.kdm`&HZt<|g0/]UZL L?pn/V2[=H횹 n 1f*b oC&A?g^Z?2uZY=3H LI]\ K{@gY\c #31zz&mM|H0jSeC/d'.8M5-x0DT7+[}~ {]z';ѣ4~%bj`Ma'V{*W`U8Xc|!Ys<au^rVh O}+.'pEv(Nq;~x!|/{e4WM {_fq-?iw6_j$cJs31ph2}-w -/ p>Zn?5YW)xJMmDIbAI3Br!t=na 4wrYhw%s"_+K^uw0y-2y cSTAo%c@` e6 w8ZZ,}G&8W_ W#B/Y82t492 u2wwqf f3xh1y:k!,Z,sA{ PqD0,kUmju:4t8'Uy@g +=?Y(?n yp 'X:#4NQ{c eCO4_l6]g3 0g Tl:Ou FC,zpR6HG52l5y!3*hgWVQ~1JQ2u_\2  $K~.G.ZE[R)J~^\MJI&uku$ IK}T*(l)~$o\X>U=L_]&+2]\|'gC$@ ql/LZ -al0 =^<{RKW')I9 >^LT^0Ogi79'L . )4Y)^mz-b xLIvJCL:~MTt#o" ~qq$EE|K]zH {dN7d:N x6m4tWJPy|-Bq)j46IC>jop^{cs\l#t]~wC^ 9FyJ\]eZ^dm@9hwek5G?iw;F"K5j_&G5Kl 3jBE IfXz0 gr=6 - >2' ~;t1nO2hp;(/w8#- 8&D-\bYR*5p.98uj 1U  ox2{(83R E+>R CZv*"U]#FIEc-orVj5BKgy-p%8U"9~ic)_/RNRk6[Js2}=V`I#kgGAy{2G>e,@`]H0^[Te_+_~(I#"@$%1";+h}W Xc -l/!e(9-wp#`${?}uf?xMqkIE5@=jzgog& z+4&'=QUiU;m$ (p+]ygh{Y8%v)B.)c>w~=X PuI'!h G\nA,T\6E{/a/R|[`M]k/;c NMlIi PSb ?N2g[u{5:pjza2d&mu?s9H^q*a/)}(6Qpd"~2r+>+k2]5J^tF{C1*G;3b4ZR"s+Pi?!q!K4a2pm{ h]yB/aL fe:uP%7Xx.#@X=T-pb5Ge]8w^`j(|SgI>u3Y}:&\ ,Jr h7>IsJaA;e"VkK[sH,qYh^iUbHvOlrk sL%L%woZKpE_WWsZm0a ;0R4H\G.4&TIgh qsDXkz3D6Lig xzi' Q,ZM H\`oT Vnh!B p'Tu@^=dEJMo=iadl_0q Z] H^g-KBB*/hc:B0|}DGAKVv[`Nm::"o'2-!!0II8}GoKnjB8: zBeyWVJ7nhw1uC\3-TPBm_}9X},K(PP1D_y|xng13\%#e}Cdof%dL^uS sZap/j]g&~4u wjc#r4D(u/7g9X T!Hl3/.pxG DP>/wLmT^VjrJ(YN pb)tsQ uxu/~ &Oo^#RjO\yHQqw3$XO|X?,WQ;X%ip]0:p[1>QM=>w<k_ :u1t29XtJ'9d<1E:_+bG)D zih|Qu7e?q ]+cG(Q)jnq)u'`ot7k!$%,aKequAho@xJ 't n@90-%>J?kOBd:8$GSzO4OnpND32F}z|=F-$F1#r#3cPf\q{md-Ѓ,elng].y/"&}ib)B7kV@34-a YzDL-m>8W'>]fq bQX(d@`k4rB#RqeZv&EbMM.~cY~PR^x|acMWw'}=)/]a')f $=t\: ajQa! DMrg+h(&/u6)Md,]CHK/rs=eGOnPu?=p'g-8->뀼-=OrBRLW{Hx_I6y`yHI- 9f6VBRMNA&nC+(!MY gmW"]Z[ ,`@aQ99k_KX%6y.KC2BSwrBP!q+" _!Fy*2+"qD$cHMt6/[)UoIuio/YV\R::CsI"Er/UA9#0 !22}'5Q he&jRv $u` *9mK4lQCd #bBN4 kk*K;s= VO3w;FG+fE$=DkMP 2t1 %8_$.A_ ni_^u6nC4[G>DI,TczJwh3 XT `AZL~DH^LKiV`P7uRX?G1P (v\UV} G" r S?4o 2y_Rct(hTZhUq Adt^ ;jq0+3ʼ%P>FjW0T~NMI$]X@EWOnTHT]i+>snE}yXJ8 73+Vd!: N># QsIjEWCTZA<$RI*MBeVM2g&Hp'.}G\zifI`*2yAs7X5wU= d *Vh3 n= sm i/[T/Wg\aav i\_/W\|`Rw)HSd@f6W^Kv c`AbF_ <810yz'JN#kmn4k>]<OSc>Z|:ibHzLr75} =k8YB(]O~t_0?eXs]"&X^ BbZR9G=|($/)vx&td' < Nj5l%S f`&> y!o$jf F$6 yee x5:hLB+F6A2`1;=s`G&l )}lTew YV3'3S~r$ zgsJE-H5'fQc3q"'jvgQWs" (@-{ w .|JE}yJNKCv@c_HcY ieF/IKXP>TX~L|"n*K5e = WPunW<q6H+Y$;hyaYBbTQAJ_C`MF])w$BK7V wk0,|0iOedq-l2KkTt98*=eL;spN%CS49] :MA9I2E ;7vJ]{wZykh 4>>~ō&@~N/3b=#H6]G_^;e J[%It 4PQ([ 0)iJ>XF @h3xi%IA6\C@}-qe/^W J"6=%]|rQgspCw[:\]({U`h +@(#9%F>'DLZCm~aP=JD!\G5NQ',^uT=SD Wl&+FOG Tpt{} m?:H9 0j(C:7rTY,:c,(0e%-)]xR_8Z<8he-Q:-Q\s0v-L JTW/|I]~n po0\g@zk9H) 5RVl*IA:n@I?J >,4B|hErhaSs>2pBKsWbeF#!74\aHG 9! RB Ix2F6d1Vh"IZn\g4fgm|9 >1;b*| \jW\-c@DS2M~p;ltupHI)W$m2Mj9TbL`-f!wY4QB0\RC]{8x/A:= (v4s}}]_C\3'I >,O*E&_Y=-0x,ynd98=^T4|!*y`}0^bx<\ns<3fZ2FM9PJVPf8OSm]i4m(ldt6oK7atpG%It+zP[XERbwhD(PnZx}~2kO[Wwd B&gI}Rm`.=oNc[^ YgL/1aDF>}}bq@H"'J\Q~9P]o@s,@)9 qx@C3'j kX9#D1RM]veW x)GY!gX'H Eme20Z<&Hf)l7ucO #Dv Hq<*y\Gt9 4F*1:2wuU M }}X,E,`6d; 'k7^ qo4/pq9C1B]TU'9'xS+RL4 dQh*;,t3}*P!L,!-}$n4`omQ@[g{ ae0$F!{ ygX 6 Zth7a},3vo+cq@ cf"A)FlpC-OY"K^MKxlm%|Gru"CS|B@D7d xz4^aQ&H& kmA5BPb ;Z%Fnpk4F&}d#{d~Ch/#+GY"E6~J;])5Kpb$6-o sbID|~qpg_7LR=Hj-x=s0U]\kGqPO=$%SMxOdq>izb*# hpaFeuSB*G2%/}@3j/f_a7}@Ef=^Al^"uKQ`NP>7l =rYK1[7Xm1!UT@M"6rp{?Q-{T$>$rx&Oy4k,;Uo[c&mzQvl,h6K'>:#K~UArAv &6m0lw u])O0nN}V;(@5j>?]<6~/.3kw'MZ-OGI6Fb!a &-w>Q6==,1[TyTVs.*hm1.eE9 J\?Nbmh (LmTRC>4 g!hE뒽f<R ;%!] 0 _[$b$P\ǃ OK. B&&i>vkdhBvdsDT.Z.(MnN`p<P76l!l4&*(<kLa L!t6-+B^\h| zELQM:9Xtegz[upcrR_s4R gzUvYJV)LqzKG</X@,_ugq4(m Y (<9*m@ )mIKV4z4yf) .xut|H'[[lMB{st_C'5lk [1y +Kw!wa+g~qjjW @jE)w:}Pin9bWzU4  "|REJ$b!<7{2sQro 5,$ g{"pI,  T@T=^+Us6n hy-VZX0&.KjQG>=M.C6bBHe6m}o"'< }foR,.65  U)xcZ fB;oF9UR~7LpdO[{x"fJ66Te;Kf i3z rC v7f=eSJ./Ri.'Q[*Wi? tl **5DJs cg4g}G* 6 G-/f$) S]#gG[;pDo#6[!Dq1!e='>f@`ÝaKU&(ybU v0HMj [~xa} M=_@^c9,]XE]_N5Ej@t'leO@* fRoUn0\]aTSa\|Lrel@L6<N=jAJKKNW;}~< b: iu3.rdziYBZ-I[|I#K4`bXc@AF&3x%gjn/y3{@St`!3d&<B[";i!Oo5$u-hHeD+E[D|7oWdY>x 5:}*Y% 8h:*3ig\zq]dH1+:]e]a6(@ :bEr{A;T(-|$<"Bv}*[LWgxc8!|-4}?Q&@)tQ'QII?ŵ=rpLTO 6"8zg~Ig|;xN=R"hCb 'G{/ED6_ȁ465_~o(-#dF1(XV@W|`BFwGZP{tEya(pUGE! *lkUm0 R c92( L8\g>eGU,Zu|B!jJr_2Y[PXi,,u[nKAS T;A`;K:Sj@w̋D"FUh1PF n2G p+t: T hJI91Np5T:|- Pz5r<R{=T`5m4VKY9,JS\RN7d2RFx\qc&.m8zv*Vp!|B)}r@%y/> LQZ^ k@ok;UBqYR0+f{jBaXnn "h jLXJz1d aajPIrz+gKw)No(;=J Lw~<*d)L5Hg=S5Wa:^'_ E gW 87  !Ek;:>cV4r PgT FhLMpDvN4p/%()7*9ߢ"v1{Z'p9'95H@@@F0(,0=R(uE\eM47rK=.GtY-)I O%H9-,xR_MN#hd!Q;n@>aytmTYTe/iU9:, qtblFMax73CD-*:0GJO y%X( u[P3)zuW. 3K7HJk_nX}MD0F QS+>[W#<J/OJoC$,'[vXv?Q9m)Lv1/u6 k2AUYpAQ&qJ%Jr__0XMZjk3x "+n[myk8 4SAk(tq9eeSZ8V#ut9>(8?9UDVqY!2Z)zbKI?|& Pr}ak6zp#Lz Mdhg\BK!934#%r@g:r`gj_Rulo~}k@a ^nJ;qj*mT%y|a?sOv/ik< c2Y/i*f%M B$~_& Dt;~t7kw61)}f>u1u>8}|{LL`}yfd[9} m_~'h:kfnEjf#WQP:RNgCw:Eek*8tx 8\_~IaU1M@w%h^ B%t@ iU~6,YxzFl!tJ:,S=~%|rUS~1 rmphdo"2]gceS]Pe:YU*?^ zgkN P?rG@)wk*=rBW%-} ?xz1*u:`APp11Y6jZIluGkc2l ZzYH%_ Ie?w@gjjp-w(,I)vau v;pt\P+4+OS:WPrUL;B'PW9?{(6^"@B16aLIa^H]f`PKbO7QpUdi0|Ko>Mxr R"KYC8DcLk6t`%SDP;1.Tqt; UEL$:x,r- ;_SZJ4>{M$n5?rV Fd3kI); -Ir w|K6k'!\mHoojk)^<0( 2S1 9savvI.Ygk0wDqFz;$;(T:nVxSB xT4.'2 n.d;S.Em]L'qN: ps6j q`g0b'2 Gf\4+O_ =kZ?r89eyC7Rb.q}^|9!"L~ ?{lw7[,ZRCa'nM\/R{q$/U+tIy(+gpuIj6h8;qWtNs0C1X$ E;ocVNzDXOQUB*A1{?x+Ql,MJiV7N^WezbO[n fJ Y:=$!tYdldwuVzB=rҝ>DT)!|hBT{E|#|0z:/g|bs|dt2aM`=Q/m_OGɞ[u[ :;k0+K7@}&];qh z9!:Mk%K@'>Q2DyV'PsX(!Nk;#.Sd?*`]ENczPS*&Q%cjknolMA.43n\uW2k< tK3JtssL Sek}`UVK<@WG}F8?SvS5_8T~[JNe1"  gX+M47S*3'R1YK~)5 =GUg;Q!4"7 PjZZ\ao= !I/#,; ZI3R]HW_SKY~bn*|-Gm#G\{OeNe>a} 8qx^K.ET@`<{[Qy:&/JBgEsKAj[ 32G;_^c +0'bC<}z$kV&TC$s:.+"ee4s=y t994rAo=*F3n5RC^ 7pI ^ Vm2B`}#HKS `c_?0ltG_j+fTCxc%"0fe;p#JD ![pd3J%m*}SDj=;`E5i o~br!{y I9dr fjiWYRA\5*+vG2=h?kiA:8C/4gN7n7_-E$ h =(=F]fj%!MauGqIhZ]/)-cGF +&s7':S/qsU>cUh:lH&r@baAcAt?ke;[ƸG!?j?]bogzDGR :7,^`S? F`|i6p?_nn1zWUwsgR>Z&Hh?;aV`Zr7,rNo_lzt%6g)}uvU'ec\[d$SaGh+@<5L6cU#g;#"vi 6Su-8yT^-e*r`sldn$nWw EPS:!ܕlFARaJCw$NQHQp![|!?=!'.[%bjL~h$tq?Ly_$; =?c!;gi, f$-$H}T*6 v-ϼ T~G~*1yT87]P5*k(6}ݞ99g6 KZ;7q;f~nes0d/6~w&n\VgQ{ 83%+ }Seb@) (GtNt7Ej5_j8~G@26Nt~:(Q ['hI2b #'E(dp>hJ*&.3\j!e, !EKP!`A|+dF?9HAUcu"N|"VV:VgJ7a/0 \I):O")c=73Tp09QF?5lSy4=pGk{a$HA2 U>@V$juv5LQU ZjxW >I%7_K1G%*ց]Yx\d4XI-/L3:3ioyD}87Frn ]Z` t!uVmAr{YOr( ah= -(>W[*Bj4Z/%GNL\]y_Q*^g/ [:HmMDg~$}8{ $s&a>ZK0V@ye*j:.esns=X[;JEz>Cs;\lR#-@KETj'#4QG|A/qq y&Cd&9][H04(6fZ5\{5% " :32{=aa -x %&齣Y4CT!OTb/&d0;rs 򴑬MVPPTNz8a~us XECJ&s7Mu1w# ay*&|i_xM$%>KW7(5FiAvX[iaA{{61TK("%{$e0Ddy9+/K,FkElz#'4+ql^a~ aB &\nqh!W.1fwI{0/C/>YNgcZVlP8BAcQLAw /A7E1AD>8!u P2tGX-!Rt 0{+#@&P%e|@'z:boncgyPR,<'{,0f\[8 b>M~X'Q``cE%\hJP#J%-2+Sp6A,$eF%10PoL"$GV Rb&/]R ]]uo(1dAHKpr0u">sjDut#UZ|a 7ofHw[3CR Rw\ZPA yVvWc9(^iJ(U Vmazkr Kj3vOrYDD >?{4;Sc Ge7fC@!Xja5{R\BZ(,MQ$"q5hiCZzXAFqP]Mh4- ~g64* ,&I k xLf|zBn_&"6@Os^^,6X- 82t%DvS ^ S#Z O.GvWxA-&.6@Z}DG]P:f iNG//f[^6q|R3G8IUGvQ~ka.r'ck2Sok6R.DU5iyV _M0+ptIUFWx{~94O>=Pi .6u4$1;')L\Z`"]V-=/NiECYB7)^{7J(F}@~_U} ^`Mzhs8gF<`~gkb2tmR83V. Eo&ABtQm(&fbO1*h}nfyOF +Re;mvxP&n j6U *;Gy %VFQV (9cFd -as&=8Mn8HISY!i)cWa+ib rd=0_Pat?y+xOxVWj;(lm08H|(pzJ`8b6r`a\;*L!:(q;Zjd 7sz3R*g7ow8dy&| |O;G1p7W< a )ilc2Mbta8P!_3E #3:o%hRx,4b jNS2!}eMo"yz}4vOUf3bJNX,xB"v#;{pZ?'uFBF`Aja9wxUl?1B[{{qR<H~p:dECb Na =Owac)E| t+<ko'G J;@]A(hr?/uqJiC!%c(Qx'GI<HF}EjAoY[ =b,d :8.0RHQvj k}Q31?5Du(iMN=29&Da x\i O-,/K4CYO +'7XN ^C<-/CK uMz4;)yE|\%II~&OV1K FWbT_x'7ptJM!L H&}\)Ai{LvG>D%C`DtRj!xv#LY-o[ 8 $fdDt % h_!C_Hr\y,I?kU K8g+gY\(5=r}S7FqYk?lgk}t$ \a}n_ jNCM4XQ-)@AHm;X W/F RK#0 =]epQ-p IkN@OB$ q \cnb+0(7xJsK!RF`*k-q5 9*[Nt/\)(MuYn<>T]f2nDERN1j Z]I$?U`F~BrIE](p}@*o[niwylw?#~eOWi]I)33M b2Co8V P O#AKKc}{&s@T9v2w<>3u\e# ZJzaKUrw K " kf# N7gqRgQR%Oc'8Jbbx A6W +?8Zlz\6aEg`K\=mf#?rO[ou~KP/~^zmo9t~+*lex2|T|rkVAd[ /- n&`\1Fn=!6;;uIl @*Xsov9_䈿h,*UbqQW37ZlrD &#”˳ R9&IdDn6K48yd71'tF^*6Y*4`f"@7Z3^"[Ba_ $#E=#o;#[ ]`G\MbiZgJ'kli^< |IL~d1T^ G-ug|wvyR\*ui^\cT1MN9x\c9iywq yN]X+B& cx6A.(-@r>VAPXluGu092 B_!_38_g/k[\!1g/Q#o{X/=GfRl&-o,y%Go~:`Kb'E7Lp @;(1>piQ*D$ 7& wACTP~sz|w8K]o%@i/~m!#y8*NSpfE9OA\x ~> <U|>KLWP$*PH~idS/@-Wcz96rEsd}>u 0\tE'e0x<_34-)e (OI%d0^~6#dYow}bI R:H PV#th)o%IuCa*+-&?Jhrad19tr9 K$RL*\quq/1FGr"Wl}"fWn.)Z)3H +E>-[kzT?q +l(5abC}=#YP[]XP"Vd tN!.}Ly}fEgKp&sI7X? Q&!Zpqnc%yGw r!$W)]#Z `k ubg Y=>~L~dG vLi#=2:"@l])/~(>?4m8(t}R-CM:$pJ6mL:%:EGt(c|t%'oP:jH:EiN\\h47rgZm odUAi>U'> GU*] MX;( vbrJ{:R^rCy1HD1{aw*6yM|.1&* `=i-L2g_F399|]lx$IRxI5zt !.RHV\XRw,V/*t1SI|} |0s~$qows7q8\Nxr^i mKdBWoFTkHP >PdO*"UWoAz K| n>MCFd%$7|_l}!uIBf'9iN"vy'j.y:;,C~0W&I%o&J ;,`_L1DNw"aK5XiGkyq%bE @g-92tXI?K|T[h.fHTtKX']3jrE-Ce,cGP@kGIgpDq]3 %O!jOu81%XA0(jGvUh4#X=yI#|Y _*^e#}=rZa-"%F}W[`Ay rDY9lEk!X7(::(~\=h+g5#0h.Zi{(Z!BSv yt 'xZ !l^ [~~z K3+V(x[fM(%XP=}I)QoG VO);*pgVA=EwI*F'4["(q:B2DYF)fS@c{'#SXWL|z,N f]U^VRo 8j>YZrA@|,`6 j,$e'we V<^~ 1cF"AyyK(p1uR0zf -+9N/eDGFAVea_U:m!R"`wDU;i 'We "E4 R{;n1>chZQ>d8:9_fhxXQgGK>pOo :>tE.d~BwomIZR?a%B]*](iDWR>[4>6 =K; 8N5clEy{4M`1p&)[LL r gzQz#3)A)F8;DhzrOVv& Eq|a_2PM#wsw`WI0@l>"@[/ss[mEzNNSY3B'X%3xX {f{LU&euvXy/L!{RqZ()`,R?!b`@$1428r7)k6CoFvw]jp%_il.}.]|je0jaQeIu^Ob+p;{JM[!^|uxws<(uKiKe4]+HcNbI/O;U!+'h ([E*% $o: An#tGYvdM$& E[BtvjT6%1GOI!sKU6?L}zB.< `H6Q-&gE>ikzeQn2rWx8E=Ju-\dyJ8aP;IWIP@i:-LpCuz?)\)I[2*7])j]Oqs[%e |44. [`M$? WzlEGo#[1wZ q|Y Fi!lF%LFD/ORwh& s_qIH@%5_nsC2|Ea5ac $6KE+JLB2\RP &!xo2} SGUvD+9%*y9hI ("xVjrnM$UWs7(|f=pKzK[,er09 e//n$u}fw\:@*a Zds*%ruE%..? $;6C@=e9 1c39}]m4~=>]:$N=_km#H<2A"pL _T+Effesk %fyGc;]:1ֳEX)n;U*BEioE`5.J\.K9ESO%OZ Z TRhGPr%lh|[^y/3iOob4btEiw_rW}ZD(7{Q;J_XcЅ:/5RqO1ba`G{ WO1s}sx: Yx@65bnBOQVI4WbB7_k7q;:R*EAɯtkqYUsTh JH_*.aSI0FP1X]:mz(]x{7~atg[Aa5yw%dJ !3VDPz\MIcceZm j5lԴ@yD55J<_02 WQDɚؒ)3ZHy:&&Ge .R!c}8iN02k o#P+/M);cw)r@;/.z*t=;]S etU A*QUmd OOizq,Hw3l; $?JY|Vu`C GFn-P} wiMozMP)y[[E|>nL v3,E62fd?%sC:X1qg7olvU;$"r q0j*e@`:Sf]p;QLP_y:\4|h)HEy%|]f?97n%\.%u7%(=vY Qg=up,bVtn 4?Y"?-[rXw5A+gK"/Y [,l}7I8P-0VwhVEdSQXfPh-$'1v1ky}[7y_ACcgX"d>=UpUMyqF`:z o7U8Mm-Ft/ tx3o_1^6 {"hhX GCYRl5UV#DD\T/rn}c2wu2 ]3mN(-8t'[j Zipb0{qMX)$N8D3V I|XQ3z9d.=Ou+CVO Ves\&j6H|xXQLQnA]D<~lvT\ja "eujfbN93{@5I7#[Gcmyi~NOz WP/}m)>xE7?"Lrn\:5zgA<5U ;CHVu Q2+M:|8s7z'\JF { 5&np@AzKg8C`@tN^~r"l5{yUu4lEu,yR]%?X_J+caJ7Y{]+PLiJkq(T&feH:Sv_Z&Q)x;4W; H 0eLiIK&^WerM<b0\anac{W@E(sE C*B5@tF]PAIJCV5RFvTԞs> .'NSY/'xw4dC!&C sq<5)8~g*zxz\Ee,Gp jyІb M*-FBtC/:r!G#hjN} F:3l,|t`r1zilL{Og' g*3y   i?N2$Da4Cy{rız33zEK ~a2-3?  ;WV/K;:nH<VQMZ%OaJ[DsY~S6 Av 0Ga!z*3 n{e` cAnFGyO G vh(W~Sv_AK'p^30z3eV rVCw|CK1svE5hmiirRK*>jgwrUq]nhS o%8AkR[Aj9`0@EK6jf2aX]] 7`[&%M<<!XW%2-g:tBL](I53r`fzKv_!Ji},5V5d}(TMKaci9CVxq:j{bQLhuNi kJ_*:#D?p{chA Vxqw ?v 2d=(c2a#  4[H >I:>.xL)!h&O*W:ILn 5|3h]"AL3< ZU~{\y;zJ^87y,RQ R)qcp8,f @"(hv^P`X}v-5u5jz$0:r4;IG@&BDD_ s',o:8X, eqa3f`F3K8Pvoso=Df=#,&ۗ> Te0_!!c~nz'f ,*Yly7E~H)V41 S) T:ev:q1D'\[,ns!TO[ohw)Ic/s@=1kM:4Y%nReT 1M01qW2~; NEKhEp~UEDE8!? W&:k09f7UZ=tWW /Op@$Ww]YtNHq]`=g }Ml|=Y[Cu &2:'(LW}i[a!-/|7fM)T r9_e:gjTNw,-%a}7s ]/!FLov8I /@:U>[-?xlg,=6Z&d)iw0 J{l$KjfU_j&]S0V^>ZC2!xf  :b 'Q:(af\J}N@dD`;Shz#5I:+Z <D[TlMB"pj{->:6vA1$g]= 22h5-qaDO 9`xNyXO)9[Jf2fEB0 WNcu{ nQ,3% N.<[cguj5NiY 5V_dE6q)Ua22eoRp[K}WUK3Xl:T+d=@Geh[MBDlep=cY HlpursYmsI#P4*olUSvD{R&@P`)@Yx4w1kW_Oo$*Tr Z1Dw y|%"';oXM&?,wvW3ivF]XLLER8aPL~h&'5gI%yTNvz2 6v(3|^7iyU"dM?Jry5dyw[B2ZT^}Z3Vl)>)iJV'&PrFB@"NQ[qQ t&NyRfI^?{1TD{=u)U&SWspg4V2g{0=]gi 6QkZ]0;vqh^ыH"z%|A7kU .e~vqrq >m\BF8$vAPJ<ҭ,M%sKP.=s>;fm- (rFqk-zFU/qE_iMcxMw~W/>2'7|q[FXp,$.T3/E9g UklrQ1|ŗѝ1d /}[2V$%O';;cjDU!37qnu`PAy1$(5Q?72Y{O>((Fe6_ Dr^$<4&X6#f`~% ﵹP8wTNH9p$(Dv"U ]a{N)MC =3VM>,.GU'=OkeY2SHme}DNqE +8LBJ$lcEdy&vgUq%nfe$_d0>AwJo9dl&s^'4@i})Wu2UKT`4FH-P}B)l#Rcvf+i}xW(3d"p I_: pGV4l:_3|L-|Y+b|cTKyQDRE$UrE8DuB&t*TZ-AmcRN'(#]830'G J%n1fMO4pB%6rpzP7?7EOT&ek. j (G kk{IyfotyX/jF@*:n@+g{XF;Ijj?O'a?UY]Dca)[?u? joM>qoA`S.el a2TQ} n OP(|r68.PNM~,QPs/42K79( d-b9w_hT,^gCQ6c^c~?ejrIEo],hrujMLh'*H((-[Dt9fDx8bLK8:$|[^PTON'atC;?:>ap& bs#'2-*s F [u%|>.^w Xkx_1E>c6$&Bz4. #gkE\\j&&Eo oJc^# ^>#d{T` Ww6~<5.(P1S)7 sHChC]@c6B i5*5w}FG:$.sT_4pnQZ=*w}{Xe5R:tA,tk3.z Sbv=}T-=S"f!R/F5\ \\!mov8a( 2=z+6C-: f_ d?At$j*"=lVY3]3v[]?G{ w 2ol/4}1q##S-f;zLw,HKWm3N(f>Cc~UoV7:eCM#q@*ZWT*9q OMsQ`;$>}2$.D*.?cnGb5UlyFnjaY5b4?YKxee6-2hR3VtT>r7e;FZDUbNJ~I3n2K#A.u[fb iZbXRKK81*m[rVm!{i0y"P{[ZhmwELcP\MAH !qN~!c\SVo2~L?b+5MgBgL10vnKc|V)$$p~pfX=Uj]F :0^ m6)+>$l9 >cYXy$3lK[)r pZ>lg>UGI"hqx@;FqS!5C6eXp{csˣ.5!%N@Ns6>O cs%Oe/rUM*<_gxb_#@@P9A8iq:+X9aM)Qc n2g!i+24sE[a0PA!nAbGp0R(91R<l$&!Z-mYV:!tSpn XIYrw + vuNJAG,!V9m'Svx51rQ&s`G__;d$}uV;vO^X^naTz//s%_zkHj!\ lrAjj ? E:!nb{4,F%QbH% "stf{n 4W|7c(oNw&}ugM0UJ_Opsxy#2bD("v~fx/a4;1g1n!*:YXY:t;r#FIsM@vR7q&Q*[m;`U*#||A @Pm:Dx8Z:M o+`L<8YFax9 {ysj lK7RT+SFeDw$]M|bpv2w'rB:E1]\>8:$Yg:'` $l q)oI"h*Dd[@d{3zMTGjTX(T6Uv*2N_I? 5a_=6ZC!qagI/;i*KT "a")C7 R9BG>9L Ulx@j T.7>\w&u@zVU=:9@= A ak=Czu4"k 4~f,eB5\!8qJ'8OG"('GrEZQL&0wU6DWYv)[>p^2^ajiKq~5r!,##OF62rM({"|+. da6-B r8]#MCbzRgC(7{;TI0ELu~ s?IX2UFUj5>Bq+&oG+ vGx;X?'?;J"EUV-U6/r|tHB]yI>[]4p=G}r/WN05Gp#e<$R&k"+'vPc,)KMntFD@k?932tlI:u:9XZ57*^gx&Vk"V`vVwKH|w() Ilb=8:CYSE_'Xer2gYt3HO8~"'o.k bC/0L)'XWiwtQ1us(+.ylb~m6b`(mr@ODW+=N$KaTLo2A2@du<>V:n1]9 RM  t gl0|vCJ(?rU\67Y:+(b 0 {~,Kkd&$]@O^OpJpx6{ OPta9 oIx-=@ r 'Q WvHRy/7mw[.v1rSjf@C9nLJU)p;Vl8&d,'D4^a)@@4_1qP\8aOMfu6 zImB`4:Y'=QZWL LmhK|1m2D4#DTOE\E" B+g xc6%VJK,_ B6O<'~#@]^a.?4xe-b ^*V7u ZANP;a=U(4[E`".vhw +d`lQ ADqU13sbyz?@qQ-p L1Z<<^`w E*4X$=&Z<1. Vu;;'dQ>F5^+0!3mGzGUq^Q_i;ex Nӈx7#zR~{#y-h{#U/aAMH w3 -_^)%~kxK TD" ss^nit=4q2qs/C0ac\d y/Rn˼ T d!V\|?yar@ ٷ\RM _(|'>tKh@,VrtE a(T"&5>=+BG nNs+27f`N5zq(usSWf-s=IZE.1al=!R ok 6>=al*oV$8L06^nC?]cD x}\=_>(hL|+m=nm91>B1C8zzTD3ERCf=f&@cP 4t{uPO4QJWJ*/\E?` c^2yt9M9?<^Y@)#qSE~8ySUEB`*[]hOO0HV@l.oP`R24EUTDm`;k@i FH*7b\ -Z,%%Z"TG$W' IE Jn]kW[g vGF{[YMt;G/XfXn.W3qpwO]w7b=7U3+ J%6Z wl7S&bLz-otEL`e0RP_=~_w6A=rq5Ui6>x4!R1Xio?Mi7dup!?DK}+w!=0,tK@Se;eiWL 02J $Tef_cuq3eYX^Ls9sd"kzbI'D B:'7|$M NYb.}@+$+E>&m1*#U~PodIJHh& &uU=6 a\]Bjx6oE/hSCDb# =z1+D>q@&&6=:'-Yc?|_v<@ pop6WsPYC|KX F6]RTw GЋXQ i<,W[=#A%]y+_;{21aw !G>~$̷̆WjD|W|z {>RM6U^,P:30VjSVum?u_<]=j<^Y' ^s aDMoYa@'^FC!PE(6!ZVeJu0DcUY-p+J(x _8<9|;bHjc@E _ J%G4;dWkGa+42jF98b,sJjEuQt{{f{Y +t5n&EByEM@GmMG`mD%95^j)VK;:{QAEM|`>yTH>1A#(w+')*s^W/ 2(` NV$f%hB= 4M0U$MLO-8 \"nG&) ^Z)+N%Qjv,.V;\,, ݠ&CRbENwjg6xd)J!Dd6H {v=MZ ?{[&NrMR0*9}d3P2)Mr1$Q53O5Z;`.k_Uzq#%YGţz&UP\r` ,| pABggh&H8bn2c3$p2]) HRjI:,>NTeP0= nrP$' BsWXO(C5UD-,V)3[fg(XhF`[+#KgY R- ewvJ'6YwN.jIumQm3nPLH.IZsVz;K"o{[ Tw[QJtrS"hGqsk!FM5n8o d Nfh!,?MOwo]v '%i`m1MMnA[+xT7SwD-/_mo~1a1C Mj\V@%E%da  M)&d-D>pRK$m&t.T~u;gGDardR9H9K40 St +.Sn7?^]p=4 :XlE[I% niY&@t@OzZtW)$z.v^b_8x(+s}ehy{0X^c*L|,cq!oOP7q(t&, .To?h^5 |$CKGm*ZX,7Z)z%SG~247~?[3fWoЎ&=_`QNl VR2*7iPO9.8~eG 2etMooUpvazs>Qj'4iiY6 M2f/Rh5hwkq5-i)a2t1PerlRequire->elts; for(i = 0; i < cls->PerlRequire->nelts; i++) { if(perl_load_startup_script(s, p, entries[i], TRUE) != OK) { fprintf(stderr, "Require of Perl file `%s' failed, exiting...\n", entries[i]); exit(1); } } entries = (char **)cls->PerlModule->elts; for(i = 0; i < cls->PerlModule->nelts; i++) { if(perl_require_module(entries[i], s) != OK) { fprintf(stderr, "Can't load Perl module `%s', exiting...\n", entries[i]); exit(1); } } LEAVE_SAFE; MP_TRACE_g(fprintf(stderr, "mod_perl: %d END blocks encountered during server startup\n", endav ? (int)AvFILL(endav)+1 : 0)); #if MODULE_MAGIC_NUMBER < 19970728 if(endav) MP_TRACE_g(fprintf(stderr, "mod_perl: cannot run END blocks encoutered at server startup without apache_1.3.0+\n")); #endif saveINC; #if MODULE_MAGIC_NUMBER >= MMN_130 if(perl_module.dynamic_load_handle) register_cleanup(p, p, mp_dso_unload, null_cleanup); #endif } int mod_perl_sent_header(request_rec *r, int val) { dPPDIR; if (val == DONE) { val = r->assbackwards = 1; /* so apache does not send another header */ } if(val) MP_SENTHDR_on(cld); val = MP_SENTHDR(cld) ? 1 : 0; return MP_SENDHDR(cld) ? val : 1; } #ifndef perl_init_ids #define perl_init_ids mod_perl_init_ids() #endif int perl_handler(request_rec *r) { dSTATUS; dPPDIR; dPPREQ; dTHR; GV *gv; #ifdef USE_ITHREADS dTHX; if (!aTHX) { PERL_SET_CONTEXT(perl); } #endif (void)acquire_mutex(mod_perl_mutex); gv = gv_fetchpv("SIG", TRUE, SVt_PVHV); #if 0 /* force 'PerlSendHeader On' for sub-requests * e.g. Apache::Sandwich */ if(r->main != NULL) MP_SENDHDR_on(cld); #endif if(MP_SENDHDR(cld)) MP_SENTHDR_off(cld); (void)perl_request_rec(r); MP_TRACE_g(fprintf(stderr, "perl_handler ENTER: SVs = %5d, OBJs = %5d\n", (int)sv_count, (int)sv_objcount)); ENTER; SAVETMPS; if (gv) { save_hptr(&GvHV(gv)); } if (endav) { save_aptr(&endav); endav = Nullav; } /* hookup STDIN & STDOUT to the client */ perl_stdout2client(r); perl_stdin2client(r); if(!cfg) { cfg = perl_create_request_config(r->pool, r->server); set_module_config(r->request_config, &perl_module, cfg); } cfg->setup_env = 1; PERL_CALLBACK("PerlHandler", cld->PerlHandler); cfg->setup_env = 0; FREETMPS; LEAVE; MP_TRACE_g(fprintf(stderr, "perl_handler LEAVE: SVs = %5d, OBJs = %5d\n", (int)sv_count, (int)sv_objcount)); if (r->prev && (r->prev->status != HTTP_OK) && mod_perl_sent_header(r, 0)) { /* avoid recursive error for ErrorDocuments */ status = OK; } (void)release_mutex(mod_perl_mutex); return status; } #ifdef PERL_CHILD_INIT typedef struct { server_rec *server; pool *pool; } server_hook_args; static void perl_child_exit_cleanup(void *data) { server_hook_args *args = (server_hook_args *)data; PERL_CHILD_EXIT_HOOK(args->server, args->pool); } void PERL_CHILD_INIT_HOOK(server_rec *s, pool *p) { char *hook = "PerlChildInitHandler"; dSTATUS; dPSRV(s); request_rec *r = mp_fake_request_rec(s, p, hook); server_hook_args *args = (server_hook_args *)palloc(p, sizeof(server_hook_args)); args->server = s; args->pool = p; register_cleanup(p, args, perl_child_exit_cleanup, null_cleanup); mod_perl_init_ids(); Apache__ServerStarting(FALSE); PERL_CALLBACK(hook, cls->PerlChildInitHandler); } #endif #ifdef PERL_CHILD_EXIT void PERL_CHILD_EXIT_HOOK(server_rec *s, pool *p) { char *hook = "PerlChildExitHandler"; dSTATUS; dPSRV(s); request_rec *r = mp_fake_request_rec(s, p, hook); PERL_CALLBACK(hook, cls->PerlChildExitHandler); perl_shutdown(s,p); } #endif static int do_proxy (request_rec *r) { return r->parsed_uri.scheme && !(r->parsed_uri.hostname && strEQ(r->parsed_uri.scheme, ap_http_method(r)) && ap_matches_request_vhost(r, r->parsed_uri.hostname, r->parsed_uri.port_str ? r->parsed_uri.port : ap_default_port(r))); } #ifdef PERL_POST_READ_REQUEST int PERL_POST_READ_REQUEST_HOOK(request_rec *r) { dSTATUS; dPSRV(r->server); #ifdef PERL_TRANS #if MODULE_MAGIC_NUMBER > 19980270 if (cls->PerlTransHandler && do_proxy(r)) { r->proxyreq = 1; r->uri = r->unparsed_uri; } #endif #endif #ifdef PERL_INIT PERL_CALLBACK("PerlInitHandler", cls->PerlInitHandler); #endif PERL_CALLBACK("PerlPostReadRequestHandler", cls->PerlPostReadRequestHandler); return status; } #endif #ifdef PERL_TRANS int PERL_TRANS_HOOK(request_rec *r) { dSTATUS; dPSRV(r->server); PERL_CALLBACK("PerlTransHandler", cls->PerlTransHandler); return status; } #endif #ifdef PERL_HEADER_PARSER int PERL_HEADER_PARSER_HOOK(request_rec *r) { dSTATUS; dPPDIR; #ifdef PERL_INIT PERL_CALLBACK("PerlInitHandler", cld->PerlInitHandler); #endif PERL_CALLBACK("PerlHeaderParserHandler", cld->PerlHeaderParserHandler); return status; } #endif #ifdef PERL_AUTHEN int PERL_AUTHEN_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlAuthenHandler", cld->PerlAuthenHandler); return status; } #endif #ifdef PERL_AUTHZ int PERL_AUTHZ_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlAuthzHandler", cld->PerlAuthzHandler); return status; } #endif #ifdef PERL_ACCESS int PERL_ACCESS_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlAccessHandler", cld->PerlAccessHandler); return status; } #endif #ifdef PERL_TYPE int PERL_TYPE_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlTypeHandler", cld->PerlTypeHandler); return status; } #endif #ifdef PERL_FIXUP int PERL_FIXUP_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlFixupHandler", cld->PerlFixupHandler); return status; } #endif #ifdef PERL_LOG int PERL_LOG_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlLogHandler", cld->PerlLogHandler); return status; } #endif #ifdef PERL_STACKED_HANDLERS #define CleanupHandler \ ((cld->PerlCleanupHandler && SvREFCNT(cld->PerlCleanupHandler)) ? cld->PerlCleanupHandler : Nullav) #else #define CleanupHandler cld->PerlCleanupHandler #endif #ifdef PERL_TRACE static char *my_signame(I32 num) { #ifdef psig_name return Perl_psig_name[num] ? SvPV(Perl_psig_name[num],na) : "?"; #else return PL_sig_name[num]; #endif } #endif static void per_request_cleanup(request_rec *r) { dPPREQ; perl_request_sigsave **sigs; int i; if(!cfg) { return; } if(cfg->pnotes) { hv_clear(cfg->pnotes); SvREFCNT_dec(cfg->pnotes); cfg->pnotes = Nullhv; } #ifndef WIN32 sigs = (perl_request_sigsave **)cfg->sigsave->elts; for (i=0; i < cfg->sigsave->nelts; i++) { MP_TRACE_g(fprintf(stderr, "mod_perl: restoring SIG%s (%d) handler from: 0x%lx to: 0x%lx\n", my_signame(sigs[i]->signo), (int)sigs[i]->signo, (unsigned long)rsignal_state(sigs[i]->signo), (unsigned long)sigs[i]->h)); rsignal(sigs[i]->signo, sigs[i]->h); } #endif } void mod_perl_end_cleanup(void *data) { request_rec *r = (request_rec *)data; dSTATUS; dPPDIR; #ifdef PERL_CLEANUP PERL_CALLBACK("PerlCleanupHandler", CleanupHandler); #endif MP_TRACE_g(fprintf(stderr, "perl_end_cleanup...")); perl_run_rgy_endav(r->uri); per_request_cleanup(r); /* clear %ENV */ #ifdef VMS perl_clear_env(r); #else perl_clear_env(); #endif /* reset @INC */ av_undef(GvAV(incgv)); SvREFCNT_dec(GvAV(incgv)); GvAV(incgv) = Nullav; GvAV(incgv) = av_copy_array(orig_inc); /* reset $/ */ sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); { dTHR; /* %@ */ hv_clear(ERRHV); } callbacks_this_request = 0; #ifdef PERL_STACKED_HANDLERS /* reset Apache->push_handlers, but don't clear ExitHandler */ #define CH_EXIT_KEY "PerlChildExitHandler" { SV *exith = Nullsv; if(hv_exists(stacked_handlers, CH_EXIT_KEY, 20)) { exith = *hv_fetch(stacked_handlers, CH_EXIT_KEY, 20, FALSE); /* inc the refcnt since hv_clear will dec it */ ++SvREFCNT(exith); } hv_clear(stacked_handlers); if(exith) hv_store(stacked_handlers, CH_EXIT_KEY, 20, exith, FALSE); } #endif #ifdef USE_SFIO PerlIO_flush(PerlIO_stdout()); #endif MP_TRACE_g(fprintf(stderr, "ok\n")); (void)release_mutex(mod_perl_mutex); } void mod_perl_cleanup_handler(void *data) { request_rec *r = (request_rec *)data; SV *cv; I32 i; dPPDIR; (void)acquire_mutex(mod_perl_mutex); MP_TRACE_h(fprintf(stderr, "running registered cleanup handlers...\n")); for(i=0; i<=AvFILL(cleanup_av); i++) { cv = *av_fetch(cleanup_av, i, 0); MARK_WHERE("registered cleanup", cv); perl_call_handler(cv, (request_rec *)r, Nullav); UNMARK_WHERE; } av_clear(cleanup_av); #ifndef WIN32 if(cld) MP_RCLEANUP_off(cld); #endif (void)release_mutex(mod_perl_mutex); } #ifdef PERL_METHOD_HANDLERS int perl_handler_ismethod(HV *pclass, char *sub) { CV *cv; HV *stash; GV *gv; SV *sv; int is_method=0; if(!sub) return 0; sv = newSVpv(sub,0); if(!(cv = sv_2cv(sv, &stash, &gv, FALSE))) { GV *gvp = gv_fetchmethod(pclass, sub); if (gvp) cv = GvCV(gvp); } #ifdef CVf_METHOD if (cv && (CvFLAGS(cv) & CVf_METHOD)) { is_method = 1; } #endif if (!is_method && (cv && SvPOK(cv))) { is_method = strnEQ(SvPVX(cv), "$$", 2); } MP_TRACE_h(fprintf(stderr, "checking if `%s' is a method...%s\n", sub, (is_method ? "yes" : "no"))); SvREFCNT_dec(sv); return is_method; } #endif void mod_perl_noop(void *data) {} void mod_perl_register_cleanup(request_rec *r, SV *sv) { dPPDIR; if(!MP_RCLEANUP(cld)) { (void)perl_request_rec(r); register_cleanup(r->pool, (void*)r, mod_perl_cleanup_handler, mod_perl_noop); MP_RCLEANUP_on(cld); if(cleanup_av == Nullav) cleanup_av = newAV(); } MP_TRACE_h(fprintf(stderr, "registering PerlCleanupHandler\n")); ++SvREFCNT(sv); av_push(cleanup_av, sv); } #ifdef PERL_STACKED_HANDLERS int mod_perl_push_handlers(SV *self, char *hook, SV *sub, AV *handlers) { int do_store=0, len=strlen(hook); SV **svp; if(self && SvTRUE(sub)) { if(handlers == Nullav) { svp = hv_fetch(stacked_handlers, hook, len, 0); MP_TRACE_h(fprintf(stderr, "fetching %s stack\n", hook)); if(svp && SvTRUE(*svp) && SvROK(*svp)) { handlers = (AV*)SvRV(*svp); } else { MP_TRACE_h(fprintf(stderr, "%s handlers stack undef, creating\n", hook)); handlers = newAV(); do_store = 1; } } if(SvROK(sub) && (SvTYPE(SvRV(sub)) == SVt_PVCV)) { MP_TRACE_h(fprintf(stderr, "pushing CODE ref into `%s' handlers\n", hook)); } else if(SvPOK(sub)) { if(do_store) { MP_TRACE_h(fprintf(stderr, "pushing `%s' into `%s' handlers\n", SvPV(sub,na), hook)); } else { MP_TRACE_d(fprintf(stderr, "pushing `%s' into `%s' handlers\n", SvPV(sub,na), hook)); } } else { warn("mod_perl_push_handlers: Not a subroutine name or CODE reference!"); } ++SvREFCNT(sub); av_push(handlers, sub); if(do_store) hv_store(stacked_handlers, hook, len, (SV*)newRV_noinc((SV*)handlers), 0); return 1; } return 0; } int perl_run_stacked_handlers(char *hook, request_rec *r, AV *handlers) { dSTATUS; I32 i, do_clear=FALSE; SV *sub, **svp; int hook_len = strlen(hook); #ifdef USE_ITHREADS dTHX; if (!aTHX) { PERL_SET_CONTEXT(perl); } #endif if(handlers == Nullav) { if(hv_exists(stacked_handlers, hook, hook_len)) { svp = hv_fetch(stacked_handlers, hook, hook_len, 0); if(svp && SvROK(*svp)) handlers = (AV*)SvRV(*svp); } else { MP_TRACE_h(fprintf(stderr, "`%s' push_handlers() stack is empty\n", hook)); return NO_HANDLERS; } do_clear = TRUE; MP_TRACE_h(fprintf(stderr, "running %d pushed (stacked) handlers for %s...\n", (int)AvFILL(handlers)+1, r->uri)); } else { #ifdef PERL_STACKED_HANDLERS /* XXX: bizarre, I only see this with httpd.conf.pl and PerlAccessHandler */ if(SvTYPE((SV*)handlers) != SVt_PVAV) { #if MODULE_MAGIC_NUMBER > 19970909 aplog_error(APLOG_MARK, APLOG_NOERRNO|APLOG_DEBUG, r->server, #else fprintf(stderr, #endif "[warning] %s stack is not an ARRAY!\n", hook); sv_dump((SV*)handlers); return DECLINED; } #endif MP_TRACE_h(fprintf(stderr, "running %d server configured stacked handlers for %s...\n", (int)AvFILL(handlers)+1, r->uri)); } for(i=0; i<=AvFILL(handlers); i++) { MP_TRACE_h(fprintf(stderr, "calling &{%s->[%d]} (%d total)\n", hook, (int)i, (int)AvFILL(handlers)+1)); if(!(sub = *av_fetch(handlers, i, FALSE))) { MP_TRACE_h(fprintf(stderr, "sub not defined!\n")); } else { if(!SvTRUE(sub)) { MP_TRACE_h(fprintf(stderr, "sub undef! skipping callback...\n")); continue; } MARK_WHERE(hook, sub); status = perl_call_handler(sub, r, Nullav); UNMARK_WHERE; MP_TRACE_h(fprintf(stderr, "&{%s->[%d]} returned status=%d\n", hook, (int)i, status)); if((status != OK) && (status != DECLINED)) { if(do_clear) av_clear(handlers); return status; } } } if(do_clear) av_clear(handlers); return status; } #endif /* PERL_STACKED_HANDLERS */ /* things to do once per-request */ void perl_per_request_init(request_rec *r) { dPPDIR; dPPREQ; /* PerlSendHeader */ if(MP_SENDHDR(cld)) { MP_SENTHDR_off(cld); table_set(r->subprocess_env, "PERL_SEND_HEADER", "On"); } else MP_SENTHDR_on(cld); if(!cfg) { cfg = perl_create_request_config(r->pool, r->server); set_module_config(r->request_config, &perl_module, cfg); } else if (cfg->setup_env && MP_ENV(cld)) { perl_setup_env(r); cfg->setup_env = 0; /* just once per-request */ } if(callbacks_this_request++ > 0) return; if (!r->main) { /* so Apache->request will work before PerlHandler with CGI.pm * XXX: triggers core dump in subrequests, * so just do in the main request for now */ (void)perl_request_rec(r); } /* PerlSetEnv */ mod_perl_dir_env(r, cld); /* SetEnv PERL5LIB */ if (!MP_INCPUSH(cld)) { char *path = (char *)table_get(r->subprocess_env, "PERL5LIB"); if (path) { perl_incpush(path); MP_INCPUSH_on(cld); } } { dPSRV(r->server); mod_perl_pass_env(r->pool, cls); } mod_perl_tie_scriptname(); /* will be released in mod_perl_end_cleanup */ (void)acquire_mutex(mod_perl_mutex); register_cleanup(r->pool, (void*)r, mod_perl_end_cleanup, mod_perl_noop); #ifdef WIN32 sv_setpvf(perl_get_sv("Apache::CurrentThreadId", TRUE), "0x%lx", (unsigned long)GetCurrentThreadId()); #endif /* hookup stderr to error_log */ #ifndef PERL_TRACE if(r->server->error_log) error_log2stderr(r->server); #endif seqno++; MP_TRACE_g(fprintf(stderr, "mod_perl: inc seqno to %d for %s\n", seqno, r->uri)); seqno_check_max(r, seqno); /* set $$, $>, etc., if 1.3a1+, this really happens during child_init */ perl_init_ids; } /* XXX this still needs work, getting there... */ int perl_call_handler(SV *sv, request_rec *r, AV *args) { int count, status, is_method=0; dSP; perl_dir_config *cld = NULL; HV *stash = Nullhv; SV *pclass = newSVsv(sv), *dispsv = Nullsv; CV *cv = Nullcv; char *method = "handler"; int defined_sub = 0, anon = 0; char *dispatcher = NULL; if(r->per_dir_config) cld = (perl_dir_config *) get_module_config(r->per_dir_config, &perl_module); #ifdef PERL_DISPATCH if(cld && (dispatcher = cld->PerlDispatchHandler)) { if(!(dispsv = (SV*)perl_get_cv(dispatcher, FALSE))) { if(strlen(dispatcher) > 0) { /* XXX */ fprintf(stderr, "mod_perl: unable to fetch PerlDispatchHandler `%s'\n", dispatcher); } dispatcher = NULL; } } #endif if(r->per_dir_config) perl_per_request_init(r); if(!dispatcher && (SvTYPE(sv) == SVt_PV)) { char *imp = pstrdup(r->pool, (char *)SvPV(pclass,na)); if((anon = strnEQ(imp,"sub ",4))) { sv = perl_eval_pv(imp, FALSE); MP_TRACE_h(fprintf(stderr, "perl_call: caching CV pointer to `__ANON__'\n")); defined_sub++; goto callback; /* XXX, I swear I've never used goto before! */ } #ifdef PERL_METHOD_HANDLERS { char *end_pclass = NULL; if ((end_pclass = strstr(imp, "->"))) { end_pclass[0] = '\0'; if(pclass) SvREFCNT_dec(pclass); pclass = newSVpv(imp, 0); end_pclass[0] = ':'; end_pclass[1] = ':'; method = &end_pclass[2]; imp = method; ++is_method; } } if(*SvPVX(pclass) == '$') { SV *obj = perl_eval_pv(SvPVX(pclass), TRUE); if(SvROK(obj) && sv_isobject(obj)) { MP_TRACE_h(fprintf(stderr, "handler object %s isa %s\n", SvPVX(pclass), HvNAME(SvSTASH((SV*)SvRV(obj))))); SvREFCNT_dec(pclass); pclass = obj; ++SvREFCNT(pclass); /* this will _dec later */ stash = SvSTASH((SV*)SvRV(pclass)); } } if(pclass && !stash) stash = gv_stashpv(SvPV(pclass,na),FALSE); #if 0 MP_TRACE_h(fprintf(stderr, "perl_call: pclass=`%s'\n", SvPV(pclass,na))); MP_TRACE_h(fprintf(stderr, "perl_call: imp=`%s'\n", imp)); MP_TRACE_h(fprintf(stderr, "perl_call: method=`%s'\n", method)); MP_TRACE_h(fprintf(stderr, "perl_call: stash=`%s'\n", stash ? HvNAME(stash) : "unknown")); #endif #else method = NULL; /* avoid warning */ #endif /* if a Perl*Handler is not a defined function name, * default to the class implementor's handler() function * attempt to load the class module if it is not already */ if(!imp) imp = SvPV(sv,na); if(!stash) stash = gv_stashpv(imp,FALSE); if(!is_method) defined_sub = (cv = perl_get_cv(imp, FALSE)) ? TRUE : FALSE; #ifdef PERL_METHOD_HANDLERS if(!defined_sub && stash) { GV *gvp; MP_TRACE_h(fprintf(stderr, "perl_call: trying method lookup on `%s' in class `%s'...", method, HvNAME(stash))); /* XXX Perl caches method lookups internally, * should we cache this lookup? */ if((gvp = gv_fetchmethod(stash, method))) { cv = GvCV(gvp); MP_TRACE_h(fprintf(stderr, "found\n")); is_method = perl_handler_ismethod(stash, method); } else { MP_TRACE_h(fprintf(stderr, "not found\n")); } } #endif if(!stash && !defined_sub) { MP_TRACE_h(fprintf(stderr, "%s symbol table not found, loading...\n", imp)); if(perl_require_module(imp, r->server) == OK) stash = gv_stashpv(imp,FALSE); #ifdef PERL_METHOD_HANDLERS if(stash) /* check again */ is_method = perl_handler_ismethod(stash, method); #endif SPAGAIN; /* reset stack pointer after require() */ } if(!is_method && !defined_sub) { MP_TRACE_h(fprintf(stderr, "perl_call: defaulting to %s::handler\n", imp)); sv_catpv(sv, "::handler"); } #if 0 /* XXX: CV lookup cache disabled for now */ if(!is_method && defined_sub) { /* cache it */ MP_TRACE_h(fprintf(stderr, "perl_call: caching CV pointer to `%s'\n", (anon ? "__ANON__" : SvPV(sv,na)))); SvREFCNT_dec(sv); sv = (SV*)newRV((SV*)cv); /* let newRV inc the refcnt */ } #endif } else { MP_TRACE_h(fprintf(stderr, "perl_call: handler is a %s\n", dispatcher ? "dispatcher" : "cached CV")); } callback: ENTER; SAVETMPS; PUSHMARK(sp); #ifdef PERL_METHOD_HANDLERS if(is_method) XPUSHs(sv_2mortal(pclass)); else SvREFCNT_dec(pclass); #else SvREFCNT_dec(pclass); #endif XPUSHs((SV*)perl_bless_request_rec(r)); if(dispatcher) { MP_TRACE_h(fprintf(stderr, "mod_perl: handing off to PerlDispatchHandler `%s'\n", dispatcher)); /*XPUSHs(sv_mortalcopy(sv));*/ XPUSHs(sv); sv = dispsv; } { I32 i, len = (args ? AvFILL(args) : 0); if(args) { EXTEND(sp, len); for(i=0; i<=len; i++) PUSHs(sv_2mortal(*av_fetch(args, i, FALSE))); } } PUTBACK; /* use G_EVAL so we can trap errors */ #ifdef PERL_METHOD_HANDLERS if(is_method) count = perl_call_method(method, G_EVAL | G_SCALAR); else #endif count = perl_call_sv(sv, G_EVAL | G_SCALAR); SPAGAIN; if ((status = perl_eval_ok(r->server)) != OK) { dTHRCTX; if (status == SERVER_ERROR) { MP_STORE_ERROR(r->uri, ERRSV); if (r->notes) { ap_table_set(r->notes, "error-notes", SvPVX(ERRSV)); } } else if (status == DECLINED) { status = r->status == 200 ? OK : r->status; } } else if(count != 1) { mod_perl_error(r->server, "perl_call did not return a status arg, assuming OK"); status = OK; } else { status = POPi; if((status == 1) || (status == 200) || (status > 600)) status = OK; if((status == SERVER_ERROR) && ERRSV_CAN_BE_HTTP) { SV *errsv = Nullsv; if(MP_EXISTS_ERROR(r->uri) && (errsv = MP_FETCH_ERROR(r->uri))) { (void)perl_sv_is_http_code(errsv, &status); } } } PUTBACK; FREETMPS; LEAVE; MP_TRACE_g(fprintf(stderr, "perl_call_handler: SVs = %5d, OBJs = %5d\n", (int)sv_count, (int)sv_objcount)); { dTHRCTX; if(SvMAGICAL(ERRSV)) sv_unmagic(ERRSV, 'U'); /* Apache::exit was called */ } return status; } request_rec *perl_request_rec(request_rec *r) { if(r != NULL) { mp_request_rec = (IV)r; return NULL; } else return (request_rec *)mp_request_rec; } SV *perl_bless_request_rec(request_rec *r) { SV *sv = sv_newmortal(); sv_setref_pv(sv, "Apache", (void*)r); MP_TRACE_g(fprintf(stderr, "blessing request_rec=(0x%lx)\n", (unsigned long)r)); return sv; } void perl_setup_env(request_rec *r) { int i; array_header *arr = perl_cgi_env_init(r); table_entry *elts = (table_entry *)arr->elts; for (i = 0; i < arr->nelts; ++i) { if (!elts[i].key || !elts[i].val) continue; mp_setenv(elts[i].key, elts[i].val); } MP_TRACE_g(fprintf(stderr, "perl_setup_env...%d keys\n", i)); } int mod_perl_seqno(SV *self, int inc) { self = self; /*avoid warning*/ if(inc) seqno += inc; return seqno; } +*[MOD_PERL1_25.SRC.MODULES.PERL]MOD_PERL.C;1+,D./A@ 4Z- 0D123 KPWO[56ʛ酟7酟89GA@HJ N $J)g7 %J)g7J)g7.  ) ) ) /* ==================================================================== * The Apache Software License, Version 1.1 * * Copyright (c) 1996-2000 The Apache Software Foundation. All rights * reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in * the documentation and/or other materials provided with the * distribution. * * 3. The end-user documentation included with the redistribution, * if any, must include the following acknowledgment: * "This product includes software developed by the * Apache Software Foundation (http://www.apache.org/)." * Alternately, this acknowledgment may appear in the software itself, * if and wherever such third-party acknowledgments normally appear. * * 4. The names "Apache" and "Apache Software Foundation" must * not be used to endorse or promote products derived from this * software without prior written permission. For written * permission, please contact apache@apache.org. * * 5. Products derived from this software may not be called "Apache", * nor may "Apache" appear in their name, without prior written * permission of the Apache Software Foundation. * * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. * ==================================================================== */ /* * And so it was decided the camel should be given magical multi-colored * feathers so it could fly and journey to once unknown worlds. * And so it was done... */ #define CORE_PRIVATE #include "mod_perl.h" #ifdef WIN32 void *mod_perl_mutex = &mod_perl_mutex; #else void *mod_perl_dummy_mutex = &mod_perl_dummy_mutex; #endif static IV mp_request_rec; static int seqno = 0; static int perl_is_running = 0; int mod_perl_socketexitoption = 3; int mod_perl_weareaforkedchild = 0; static int callbacks_this_request = 0; static PerlInterpreter *perl = NULL; static AV *orig_inc = Nullav; static AV *cleanup_av = Nullav; #ifdef PERL_STACKED_HANDLERS static HV *stacked_handlers = Nullhv; #endif #ifdef PERL_OBJECT CPerlObj *pPerl; #endif typedef const char* (*crft)(); /* command_req_func_t */ static command_rec perl_cmds[] = { #ifdef PERL_SECTIONS { "", (crft) perl_section, NULL, SECTION_ALLOWED, RAW_ARGS, "Perl code" }, { "", (crft) perl_end_section, NULL, SECTION_ALLOWED, NO_ARGS, "End Perl code" }, #endif { "=pod", (crft) perl_pod_section, NULL, OR_ALL, RAW_ARGS, "Start of POD" }, { "=back", (crft) perl_pod_section, NULL, OR_ALL, RAW_ARGS, "End of =over" }, { "=cut", (crft) perl_pod_end_section, NULL, OR_ALL, NO_ARGS, "End of POD" }, { "__END__", (crft) perl_config_END, NULL, OR_ALL, RAW_ARGS, "Stop reading config" }, { "PerlFreshRestart", (crft) perl_cmd_fresh_restart, NULL, RSRC_CONF, FLAG, "Tell mod_perl to reload modules and flush Apache::Registry cache on restart" }, { "PerlTaintCheck", (crft) perl_cmd_tainting, NULL, RSRC_CONF, FLAG, "Turn on -T switch" }, #ifdef PERL_SAFE_STARTUP { "PerlOpmask", (crft) perl_cmd_opmask, NULL, RSRC_CONF, TAKE1, "Opmask File" }, #endif { "PerlWarn", (crft) perl_cmd_warn, NULL, RSRC_CONF, FLAG, "Turn on -w switch" }, { "PerlScript", (crft) perl_cmd_require, NULL, OR_ALL, ITERATE, "this directive is deprecated, use `PerlRequire'" }, { "PerlRequire", (crft) perl_cmd_require, NULL, OR_ALL, ITERATE, "A Perl script name, pulled in via require" }, { "PerlModule", (crft) perl_cmd_module, NULL, OR_ALL, ITERATE, "List of Perl modules" }, { "PerlSetVar", (crft) perl_cmd_var, NULL, OR_ALL, TAKE2, "Perl config var and value" }, { "PerlAddVar", (crft) perl_cmd_var, (void*)1, OR_ALL, ITERATE2, "Perl config var and value" }, { "PerlSetEnv", (crft) perl_cmd_setenv, NULL, OR_ALL, TAKE2, "Perl %ENV key and value" }, {  r1~MOD_PERL1_25_MUP.SAVED +[MOD_PERL1_25.SRC.MODULES.PERL]MOD_PERL.C;1F| "PerlPassEnv", (crft) perl_cmd_pass_env, NULL, RSRC_CONF, ITERATE, "pass environment variables to %ENV"}, { "PerlSendHeader", (crft) perl_cmd_sendheader, NULL, OR_ALL, FLAG, "Tell mod_perl to parse and send HTTP headers" }, { "PerlSetupEnv", (crft) perl_cmd_env, NULL, OR_ALL, FLAG, "Tell mod_perl to setup %ENV by default" }, { "PerlHandler", (crft) perl_cmd_handler_handlers, NULL, OR_ALL, ITERATE, "the Perl handler routine name" }, #ifdef PERL_TRANS { PERL_TRANS_CMD_ENTRY }, #endif #ifdef PERL_AUTHEN { PERL_AUTHEN_CMD_ENTRY }, #endif #ifdef PERL_AUTHZ { PERL_AUTHZ_CMD_ENTRY }, #endif #ifdef PERL_ACCESS { PERL_ACCESS_CMD_ENTRY }, #endif #ifdef PERL_TYPE { PERL_TYPE_CMD_ENTRY }, #endif #ifdef PERL_FIXUP { PERL_FIXUP_CMD_ENTRY }, #endif #ifdef PERL_LOG { PERL_LOG_CMD_ENTRY }, #endif #ifdef PERL_CLEANUP { PERL_CLEANUP_CMD_ENTRY }, #endif #ifdef PERL_INIT { PERL_INIT_CMD_ENTRY }, #endif #ifdef PERL_HEADER_PARSER { PERL_HEADER_PARSER_CMD_ENTRY }, #endif #ifdef PERL_CHILD_INIT { PERL_CHILD_INIT_CMD_ENTRY }, #endif #ifdef PERL_CHILD_EXIT { PERL_CHILD_EXIT_CMD_ENTRY }, #endif #ifdef PERL_POST_READ_REQUEST { PERL_POST_READ_REQUEST_CMD_ENTRY }, #endif #ifdef PERL_DISPATCH { PERL_DISPATCH_CMD_ENTRY }, #endif #ifdef PERL_RESTART { PERL_RESTART_CMD_ENTRY }, #endif { NULL } }; static handler_rec perl_handlers [] = { { "perl-script", perl_handler }, { DIR_MAGIC_TYPE, perl_handler }, { NULL } }; module MODULE_VAR_EXPORT perl_module = { STANDARD_MODULE_STUFF, perl_module_init, /* initializer */ perl_create_dir_config, /* create per-directory config structure */ perl_merge_dir_config, /* merge per-directory config structures */ perl_create_server_config, /* create per-server config structure */ perl_merge_server_config, /* merge per-server config structures */ perl_cmds, /* command table */ perl_handlers, /* handlers */ PERL_TRANS_HOOK, /* translate_handler */ PERL_AUTHEN_HOOK, /* check_user_id */ PERL_AUTHZ_HOOK, /* check auth */ PERL_ACCESS_HOOK, /* check access */ PERL_TYPE_HOOK, /* type_checker */ PERL_FIXUP_HOOK, /* pre-run fixups */ PERL_LOG_HOOK, /* logger */ #if MODULE_MAGIC_NUMBER >= 19970103 PERL_HEADER_PARSER_HOOK, /* header parser */ #endif #if MODULE_MAGIC_NUMBER >= 19970719 PERL_CHILD_INIT_HOOK, /* child_init */ #endif #if MODULE_MAGIC_NUMBER >= 19970728 NULL, /* child_exit *//* mod_perl uses register_cleanup() */ #endif #if MODULE_MAGIC_NUMBER >= 19970825 PERL_POST_READ_REQUEST_HOOK, /* post_read_request */ #endif }; #if defined(STRONGHOLD) && !defined(APACHE_SSL) #define APACHE_SSL #endif int PERL_RUNNING (void) { return (perl_is_running); } static void seqno_check_max(request_rec *r, int seqno) { dPPDIR; char *max = NULL; array_header *vars = (array_header *)cld->vars; /* XXX: what triggers such a condition ?*/ if(vars && (vars->nelts > 100000)) { fprintf(stderr, "[warning] PerlSetVar->nelts = %d\n", vars->nelts); } else { if(cld->vars) max = (char *)table_get(cld->vars, "MaxModPerlRequestsPerChild"); } #if (MODULE_MAGIC_NUMBER >= 19970912) && !defined(WIN32) if(max && (seqno >= atoi(max))) { child_terminate(r); MP_TRACE_g(fprintf(stderr, "mod_perl: terminating child %d after serving %d requests\n", (int)getpid(), seqno)); } #endif max = NULL; } void perl_shutdown (server_rec *s, pool *p) { char *pdl = NULL; if((pdl = getenv("PERL_DESTRUCT_LEVEL"))) perl_destruct_level = atoi(pdl); else perl_destruct_level = PERL_DESTRUCT_LEVEL; if(perl_destruct_level < 0) { MP_TRACE_g(fprintf(stderr, "skipping destruction of Perl interpreter\n")); return; } /* execute END blocks we suspended during perl_startup() */ perl_run_endav("perl_shutdown"); MP_TRACE_g(fprintf(stderr, "destructing and freeing Perl interpreter (level=%d)...", perl_destruct_level)); perl_util_cleanup(); mp_request_rec = 0; av_undef(orig_inc); SvREFCNT_dec((SV*)orig_inc); orig_inc = Nullav; av_undef(cleanup_av); SvREFCNT_dec((SV*)cleanup_av); cleanup_av = Nullav; #ifdef PERL_STACKED_HANDLERS hv_undef(stacked_handlers); SvREFCNT_dec((SV*)stacked_handlers); stacked_handlers = Nullhv; #endif perl_destruct(perl); perl_free(perl); #ifdef USE_THREADS PERL_SYS_TERM(); #endif perl_is_running = 0; MP_TRACE_g(fprintf(stderr, "ok\n")); } request_rec *mp_fake_request_rec(server_rec *s, pool *p, char *hook) { request_rec *r = (request_rec *)pcalloc(p, sizeof(request_rec)); r->pool = p; r->server = s; r->per_dir_config = NULL; r->uri = hook; r->notes = NULL; return r; } #ifdef PERL_RESTART void perl_restart_handler(server_rec *s, pool *p) { char *hook = "PerlRestartHandler"; dSTATUS; dPSRV(s); request_rec *r = mp_fake_request_rec(s, p, hook); PERL_CALLBACK(hook, cls->PerlRestartHandler); } #endif void perl_restart(server_rec *s, pool *p) { /* restart as best we can */ SV *rgy_cache = perl_get_sv("Apache::Registry", FALSE); HV *rgy_symtab = (HV*)gv_stashpv("Apache::ROOT", FALSE); ENTER; SAVESPTR(warnhook); warnhook = perl_eval_pv("sub {}", TRUE); /* the file-stat cache */ if(rgy_cache) sv_setsv(rgy_cache, &sv_undef); /* the symbol table we compile registry scripts into */ if(rgy_symtab) hv_clear(rgy_symtab); if(endav) { SvREFCNT_dec(endav); endav = Nullav; } #ifdef STACKED_HANDLERS if(stacked_handlers) hv_clear(stacked_handlers); #endif /* reload %INC */ perl_reload_inc(s, p); LEAVE; /*mod_perl_notice(s, "mod_perl restarted"); */ MP_TRACE_g(fprintf(stderr, "perl_restart: ok\n")); } U32 mp_debug = 0; static void mod_perl_set_cwd(void) { char *name = "Apache::Server::CWD"; GV *gv = gv_fetchpv(name, GV_ADDMULTI, SVt_PV); char *pwd = getenv("PWD"); if(pwd) sv_setpv(GvSV(gv), pwd); else sv_setsv(GvSV(gv), perl_eval_pv("require Cwd; Cwd::getcwd()", TRUE)); mod_perl_untaint(GvSV(gv)); } #ifdef PERL_TIE_SCRIPTNAME static I32 scriptname_val(IV ix, SV* sv) { dTHR; request_rec *r = perl_request_rec(NULL); if(r) sv_setpv(sv, r->filename); else if(strNE(SvPVX(GvSV(CopFILEGV(curcop))), "-e")) sv_setsv(sv, GvSV(CopFILEGV(curcop))); else { SV *file = perl_eval_pv("(caller())[1]",TRUE); sv_setsv(sv, file); } MP_TRACE_g(fprintf(stderr, "FETCH $0 => %s\n", SvPV(sv,na))); return TRUE; } static void mod_perl_tie_scriptname(void) { SV *sv = perl_get_sv("0",TRUE); struct ufuncs umg; umg.uf_val = scriptname_val; umg.uf_set = NULL; umg.uf_index = (IV)0; sv_unmagic(sv, 'U'); sv_magic(sv, Nullsv, 'U', (char*) &umg, sizeof(umg)); } #else #define mod_perl_tie_scriptname() #endif #define saveINC \ if(orig_inc) SvREFCNT_dec(orig_inc); \ orig_inc = av_copy_array(GvAV(incgv)) #define dl_librefs "DynaLoader::dl_librefs" #define dl_modules "DynaLoader::dl_modules" static array_header *xs_dl_librefs(pool *p) { I32 i; AV *librefs = perl_get_av(dl_librefs, FALSE); AV *modules = perl_get_av(dl_modules, FALSE); array_header *arr; if (!librefs) { MP_TRACE_g(fprintf(stderr, "Could not get @%s for unloading.\n", dl_librefs)); return NULL; } arr = ap_make_array(p, AvFILL(librefs)-1, sizeof(void *)); for (i=0; i<=AvFILL(librefs); i++) { void *handle; SV *handle_sv = *av_fetch(librefs, i, FALSE); SV *module_sv = *av_fetch(modules, i, FALSE); if(!handle_sv) { MP_TRACE_g(fprintf(stderr, "Could not fetch $%s[%d]!\n", dl_librefs, (int)i)); continue; } handle = (void *)SvIV(handle_sv); MP_TRACE_g(fprintf(stderr, "%s dl handle == 0x%lx\n", SvPVX(module_sv), (unsigned long)handle)); if (handle) { *(void **)ap_push_array(arr) = handle; } } av_clear(modules); av_clear(librefs); return arr; } static void unload_xs_so(array_header *librefs) { int i; if (!librefs) { return; } for (i=0; i < librefs->nelts; i++) { void *handle = ((void **)librefs->elts)[i]; MP_TRACE_g(fprintf(stderr, "unload_xs_so: 0x%lx\n", (unsigned long)handle)); #ifdef _AIX /* make sure Perl's dlclose is used, instead of Apache's */ dlclose(handle); #else ap_os_dso_unload(handle); #endif } } #if 0 /* unload_xs_dso should obsolete this hack */ static void cancel_dso_dlclose(void) { module *modp; if(!PERL_DSO_UNLOAD) return; if(strEQ(top_module->name, "mod_perl.c")) return; for(modp = top_module; modp; modp = modp->next) { if(modp->dynamic_load_handle) { MP_TRACE_g(fprintf(stderr, "mod_perl: cancel dlclose for %s\n", modp->name)); modp->dynamic_load_handle = NULL; } } } #endif static void mp_dso_unload(void *data) { array_header *librefs; #ifdef WIN32 // This is here to stop a crash when bringing down // a service. Apparently the dso is unloaded too early. // This if statement tests to see if we are running as a // service. apache does the same // see apache's isProcessService() in service.c if (AllocConsole()) { FreeConsole(); return; } #endif librefs = xs_dl_librefs((pool *)data); perl_shutdown(NULL, NULL); unload_xs_so(librefs); } static void mp_server_notstarting(void *data) { saveINC; require_Apache(NULL); Apache__ServerStarting(FALSE); } #define Apache__ServerStarting_on() \ Apache__ServerStarting(PERL_RUNNING()); \ if(!PERL_IS_DSO) \ register_cleanup(p, NULL, mp_server_notstarting, mod_perl_noop) #define MP_APACHE_VERSION "1.27" void mp_check_version(void) { I32 i; SV *namesv; SV *version; STRLEN n_a; require_Apache(NULL); if(!(version = perl_get_sv("Apache::VERSION", FALSE))) croak("Apache.pm failed to load!"); /*should never happen*/ if(strEQ(SvPV(version,n_a), MP_APACHE_VERSION)) /*no worries*/ return; fprintf(stderr, "Apache.pm version %s required!\n", MP_APACHE_VERSION); fprintf(stderr, "%s", form("%_ is version %_\n", *hv_fetch(GvHV(incgv), "Apache.pm", 9, FALSE), version)); fprintf(stderr, "Perhaps you forgot to 'make install' or need to uninstall an old version?\n"); namesv = NEWSV(806, 0); for(i=0; i<=AvFILL(GvAV(incgv)); i++) { char *tryname; PerlIO *tryrsfp = 0; SV *dir = *av_fetch(GvAV(incgv), i, TRUE); sv_setpvf(namesv, "%_/Apache.pm", dir); tryname = SvPVX(namesv); if((tryrsfp = PerlIO_open(tryname, "r"))) { fprintf(stderr, "Found: %s\n", tryname); PerlIO_close(tryrsfp); } } SvREFCNT_dec(namesv); exit(1); } #if !HAS_MMN_136 static void set_sigpipe(void) { char *dargs[] = { NULL }; perl_require_module("Apache::SIG", NULL); perl_call_argv("Apache::SIG::set", G_DISCARD, dargs); } #endif void perl_module_init(server_rec *s, pool *p) { #if HAS_MMN_130 ap_add_version_component(MOD_PERL_STRING_VERSION); if(PERL_RUNNING()) { #ifdef PERL_IS_5_6 char *version = form("Perl/v%vd", PL_patchlevel); #else char *version = form("Perl/%_", perl_get_sv("]", TRUE)); #endif if(perl_get_sv("Apache::Server::AddPerlVersion", FALSE)) { ap_add_version_component(version); } } #endif perl_startup(s, p); } void perl_startup (server_rec *s, pool *p) { char *argv[] = { NULL, NULL, NULL, NULL, NULL, NULL, NULL }; char **entries, *dstr; int status, i, argc=1; dPSRV(s); SV *pool_rv, *server_rv; GV *gv, *shgv; #ifndef WIN32 argv[0] = server_argv0; #endif #ifdef PERL_TRACE if((dstr = getenv("MOD_PERL_TRACE"))) { if(strEQ(dstr, "all")) { mp_debug = 0xffffffff; } else if (isALPHA(dstr[0])) { static char debopts[] = "dshgc"; char *d; for (; *dstr && (d = strchr(debopts,*dstr)); dstr++) mp_debug |= 1 << (d - debopts); } else { mp_debug = atoi(dstr); } mp_debug |= 0x80000000; } #else dstr = NULL; #endif if(PERL_RUNNING() && PERL_STARTUP_IS_DONE) { saveINC; mp_check_version(); #if !HAS_MMN_136 set_sigpipe(); #endif } if(perl_is_running == 0) { /* we'll boot Perl below */ } else if(perl_is_running < PERL_DONE_STARTUP) { /* skip the -HUP at server-startup */ perl_is_running++; Apache__ServerStarting_on(); MP_TRACE_g(fprintf(stderr, "perl_startup: perl aleady running...ok\n")); return; } else { Apache__ServerReStarting(TRUE); #ifdef PERL_RESTART perl_restart_handler(s, p); #endif if(cls->FreshRestart) perl_restart(s, p); Apache__ServerReStarting(FALSE); return; } perl_is_running++; /* fake-up what the shell usually gives perl */ if(cls->PerlTaintCheck) argv[argc++] = "-T"; if(cls->PerlWarn) argv[argc++] = "-w"; #ifdef WIN32 argv[argc++] = "nul"; #else argv[argc++] = "/dev/null"; #endif MP_TRACE_g(fprintf(stderr, "perl_parse args: ")); for(i=1; iPerlTaintCheck); (void)GvSV_init("Apache::__SendHeader"); (void)GvSV_init("Apache::__CurrentCallback"); Apache__ServerReStarting(FALSE); /* just for -w */ Apache__ServerStarting_on(); #ifdef PERL_STACKED_HANDLERS if(!stacked_handlers) { stacked_handlers = newHV(); shgv = GvHV_init("Apache::PerlStackedHandlers"); GvHV(shgv) = stacked_handlers; } #endif #ifdef MULTITHREAD mod_perl_mutex = create_mutex(NULL); #endif if ((status = perl_run(perl)) != OK) { MP_TRACE_g(fprintf(stderr,"not ok, status=%d\n", status)); perror("run"); exit(1); } MP_TRACE_g(fprintf(stderr, "ok\n")); /* Force the environment to be copied out of its original location above argv[]. This fixes a crash caused when a module called putenv() before any Perl modified the environment - environ would change to a new value, and the check in my_setenv() to duplicate the environment would fail, and then setting some environment value which had a previous value would cause perl to try to free() something from the original env. This crashed free(). */ my_setenv("MODPERL_ENV_FIXUP", "0"); my_setenv("MODPERL_ENV_FIXUP", NULL); { dTHR; TAINT_NOT; /* At this time all is safe */ } #ifdef APACHE_PERL5LIB perl_incpush(APACHE_PERL5LIB); #else av_push(GvAV(incgv), newSVpv(server_root_relative(p,""),0)); av_push(GvAV(incgv), newSVpv(server_root_relative(p,"lib/perl"),0)); #endif /* *CORE::GLOBAL::exit = \&Apache::exit */ if(gv_stashpv("CORE::GLOBAL", FALSE)) { GV *exitgp = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV); GvCV(exitgp) = perl_get_cv("Apache::exit", TRUE); GvIMPORTED_CV_on(exitgp); } if(PERL_STARTUP_DONE_CHECK) { char *psd = getenv("PERL_STARTUP_DONE"); if (!psd) { MP_TRACE_g(fprintf(stderr, "mod_perl: PerlModule,PerlRequire postponed\n")); my_setenv("PERL_STARTUP_DONE", "1"); saveINC; return; } else { MP_TRACE_g(fprintf(stderr, "mod_perl: postponed PerlModule,PerlRequire enabled\n")); my_setenv("PERL_STARTUP_DONE", "2"); } } ENTER_SAFE(s,p); MP_TRACE_g(mod_perl_dump_opmask()); entries = (char **)cls->PerlRequire->elts; for(i = 0; i < cls->PerlRequire->nelts; i++) { if(perl_load_startup_script(s, p, entries[i], TRUE) != OK) { fprintf(stderr, "Require of Perl file `%s' failed, exiting...\n", entries[i]); exit(1); } } entries = (char **)cls->PerlModule->elts; for(i = 0; i < cls->PerlModule->nelts; i++) { if(perl_require_module(entries[i], s) != OK) { fprintf(stderr, "Can't load Perl module `%s', exiting...\n", entries[i]); exit(1); } } LEAVE_SAFE; MP_TRACE_g(fprintf(stderr, "mod_perl: %d END blocks encountered during server startup\n", endav ? (int)AvFILL(endav)+1 : 0)); #if MODULE_MAGIC_NUMBER < 19970728 if(endav) MP_TRACE_g(fprintf(stderr, "mod_perl: cannot run END blocks encoutered at server startup without apache_1.3.0+\n")); #endif saveINC; #if MODULE_MAGIC_NUMBER >= MMN_130 if(perl_module.dynamic_load_handle) register_cleanup(p, p, mp_dso_unload, null_cleanup); #endif } int mod_perl_sent_header(request_rec *r, int val) { dPPDIR; if (val == DONE) { val = r->assbackwards = 1; /* so apache does not send another header */ } if(val) MP_SENTHDR_on(cld); val = MP_SENTHDR(cld) ? 1 : 0; return MP_SENDHDR(cld) ? val : 1; } #ifndef perl_init_ids #define perl_init_ids mod_perl_init_ids() #endif int perl_handler(request_rec *r) { dSTATUS; dPPDIR; dPPREQ; dTHR; GV *gv; #ifdef USE_ITHREADS dTHX; if (!aTHX) { PERL_SET_CONTEXT(perl); } #endif (void)acquire_mutex(mod_perl_mutex); gv = gv_fetchpv("SIG", TRUE, SVt_PVHV); #if 0 /* force 'PerlSendHeader On' for sub-requests * e.g. Apache::Sandwich */ if(r->main != NULL) MP_SENDHDR_on(cld); #endif if(MP_SENDHDR(cld)) MP_SENTHDR_off(cld); (void)perl_request_rec(r); MP_TRACE_g(fprintf(stderr, "perl_handler ENTER: SVs = %5d, OBJs = %5d\n", (int)sv_count, (int)sv_objcount)); ENTER; SAVETMPS; if (gv) { save_hptr(&GvHV(gv)); } if (endav) { save_aptr(&endav); endav = Nullav; } /* hookup STDIN & STDOUT to the client */ perl_stdout2client(r); perl_stdin2client(r); if(!cfg) { cfg = perl_create_request_config(r->pool, r->server); set_module_config(r->request_config, &perl_module, cfg); } cfg->setup_env = 1; PERL_CALLBACK("PerlHandler", cld->PerlHandler); cfg->setup_env = 0; FREETMPS; LEAVE; MP_TRACE_g(fprintf(stderr, "perl_handler LEAVE: SVs = %5d, OBJs = %5d\n", (int)sv_count, (int)sv_objcount)); if (r->prev && (r->prev->status != HTTP_OK) && mod_perl_sent_header(r, 0)) { /* avoid recursive error for ErrorDocuments */ status = OK; } (void)release_mutex(mod_perl_mutex); return status; } #ifdef PERL_CHILD_INIT typedef struct { server_rec *server; pool *pool; } server_hook_args; static void perl_child_exit_cleanup(void *data) { server_hook_args *args = (server_hook_args *)data; PERL_CHILD_EXIT_HOOK(args->server, args->pool); } void PERL_CHILD_INIT_HOOK(server_rec *s, pool *p) { char *hook = "PerlChildInitHandler"; dSTATUS; dPSRV(s); request_rec *r = mp_fake_request_rec(s, p, hook); server_hook_args *args = (server_hook_args *)palloc(p, sizeof(server_hook_args)); args->server = s; args->pool = p; register_cleanup(p, args, perl_child_exit_cleanup, null_cleanup); mod_perl_init_ids(); Apache__ServerStarting(FALSE); PERL_CALLBACK(hook, cls->PerlChildInitHandler); } #endif #ifdef PERL_CHILD_EXIT void PERL_CHILD_EXIT_HOOK(server_rec *s, pool *p) { char *hook = "PerlChildExitHandler"; dSTATUS; dPSRV(s); request_rec *r = mp_fake_request_rec(s, p, hook); PERL_CALLBACK(hook, cls->PerlChildExitHandler); perl_shutdown(s,p); } #endif static int do_proxy (request_rec *r) { return r->parsed_uri.scheme && !(r->parsed_uri.hostname && strEQ(r->parsed_uri.scheme, ap_http_method(r)) && ap_matches_request_vhost(r, r->parsed_uri.hostname, r->parsed_uri.port_str ? r->parsed_uri.port : ap_default_port(r))); } #ifdef PERL_POST_READ_REQUEST int PERL_POST_READ_REQUEST_HOOK(request_rec *r) { dSTATUS; dPSRV(r->server); #ifdef PERL_TRANS #if MODULE_MAGIC_NUMBER > 19980270 if (cls->PerlTransHandler && do_proxy(r)) { r->proxyreq = 1; r->uri = r->unparsed_uri; } #endif #endif #ifdef PERL_INIT PERL_CALLBACK("PerlInitHandler", cls->PerlInitHandler); #endif PERL_CALLBACK("PerlPostReadRequestHandler", cls->PerlPostReadRequestHandler); return status; } #endif #ifdef PERL_TRANS int PERL_TRANS_HOOK(request_rec *r) { dSTATUS; dPSRV(r->server); PERL_CALLBACK("PerlTransHandler", cls->PerlTransHandler); return status; } #endif #ifdef PERL_HEADER_PARSER int PERL_HEADER_PARSER_HOOK(request_rec *r) { dSTATUS; dPPDIR; #ifdef PERL_INIT PERL_CALLBACK("PerlInitHandler", cld->PerlInitHandler); #endif PERL_CALLBACK("PerlHeaderParserHandler", cld->PerlHeaderParserHandler); return status; } #endif #ifdef PERL_AUTHEN int PERL_AUTHEN_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlAuthenHandler", cld->PerlAuthenHandler); return status; } #endif #ifdef PERL_AUTHZ int PERL_AUTHZ_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlAuthzHandler", cld->PerlAuthzHandler); return status; } #endif #ifdef PERL_ACCESS int PERL_ACCESS_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlAccessHandler", cld->PerlAccessHandler); return status; } #endif #ifdef PERL_TYPE int PERL_TYPE_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlTypeHandler", cld->PerlTypeHandler); return status; } #endif #ifdef PERL_FIXUP int PERL_FIXUP_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlFixupHandler", cld->PerlFixupHandler); return status; } #endif #ifdef PERL_LOG int PERL_LOG_HOOK(request_rec *r) { dSTATUS; dPPDIR; PERL_CALLBACK("PerlLogHandler", cld->PerlLogHandler); return status; } #endif #ifdef PERL_STACKED_HANDLERS #define CleanupHandler \ ((cld->PerlCleanupHandler && SvREFCNT(cld->PerlCleanupHandler)) ? cld->PerlCleanupHandler : Nullav) #else #define CleanupHandler cld->PerlCleanupHandler #endif #ifdef PERL_TRACE static char *my_signame(I32 num) { #ifdef psig_name return Perl_psig_name[num] ? SvPV(Perl_psig_name[num],na) : "?"; #else return PL_sig_name[num]; #endif } #endif static void per_request_cleanup(request_rec *r) { dPPREQ; perl_request_sigsave **sigs; int i; if(!cfg) { return; } if(cfg->pnotes) { hv_clear(cfg->pnotes); SvREFCNT_dec(cfg->pnotes); cfg->pnotes = Nullhv; } #ifndef WIN32 sigs = (perl_request_sigsave **)cfg->sigsave->elts; for (i=0; i < cfg->sigsave->nelts; i++) { MP_TRACE_g(fprintf(stderr, "mod_perl: restoring SIG%s (%d) handler from: 0x%lx to: 0x%lx\n", my_signame(sigs[i]->signo), (int)sigs[i]->signo, (unsigned long)rsignal_state(sigs[i]->signo), (unsigned long)sigs[i]->h)); rsignal(sigs[i]->signo, sigs[i]->h); } #endif } void mod_perl_end_cleanup(void *data) { request_rec *r = (request_rec *)data; dSTATUS; dPPDIR; #ifdef PERL_CLEANUP PERL_CALLBACK("PerlCleanupHandler", CleanupHandler); #endif MP_TRACE_g(fprintf(stderr, "perl_end_cleanup...")); perl_run_rgy_endav(r->uri); per_request_cleanup(r); /* clear %ENV */ perl_clear_env(); /* reset @INC */ av_undef(GvAV(incgv)); SvREFCNT_dec(GvAV(incgv)); GvAV(incgv) = Nullav; GvAV(incgv) = av_copy_array(orig_inc); /* reset $/ */ sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); { dTHR; /* %@ */ hv_clear(ERRHV); } callbacks_this_request = 0; #ifdef PERL_STACKED_HANDLERS /* reset Apache->push_handlers, but don't clear ExitHandler */ #define CH_EXIT_KEY "PerlChildExitHandler" { SV *exith = Nullsv; if(hv_exists(stacked_handlers, CH_EXIT_KEY, 20)) { exith = *hv_fetch(stacked_handlers, CH_EXIT_KEY, 20, FALSE); /* inc the refcnt since hv_clear will dec it */ ++SvREFCNT(exith); } hv_clear(stacked_handlers); if(exith) hv_store(stacked_handlers, CH_EXIT_KEY, 20, exith, FALSE); } #endif #ifdef USE_SFIO PerlIO_flush(PerlIO_stdout()); #endif MP_TRACE_g(fprintf(stderr, "ok\n")); (void)release_mutex(mod_perl_mutex); } void mod_perl_cleanup_handler(void *data) { request_rec *r = (request_rec *)data; SV *cv; I32 i; dPPDIR; (void)acquire_mutex(mod_perl_mutex); MP_TRACE_h(fprintf(stderr, "running registered cleanup handlers...\n")); for(i=0; i<=AvFILL(cleanup_av); i++) { cv = *av_fetch(cleanup_av, i, 0); MARK_WHERE("registered cleanup", cv); perl_call_handler(cv, (request_rec *)r, Nullav); UNMARK_WHERE; } av_clear(cleanup_av); #ifndef WIN32 if(cld) MP_RCLEANUP_off(cld); #endif (void)release_mutex(mod_perl_mutex); } #ifdef PERL_METHOD_HANDLERS int perl_handler_ismethod(HV *pclass, char *sub) { CV *cv; HV *stash; GV *gv; SV *sv; int is_method=0; if(!sub) return 0; sv = newSVpv(sub,0); if(!(cv = sv_2cv(sv, &stash, &gv, FALSE))) { GV *gvp = gv_fetchmethod(pclass, sub); if (gvp) cv = GvCV(gvp); } #ifdef CVf_METHOD if (cv && (CvFLAGS(cv) & CVf_METHOD)) { is_method = 1; } #endif if (!is_method && (cv && SvPOK(cv))) { is_method = strnEQ(SvPVX(cv), "$$", 2); } MP_TRACE_h(fprintf(stderr, "checking if `%s' is a method...%s\n", sub, (is_method ? "yes" : "no"))); SvREFCNT_dec(sv); return is_method; } #endif void mod_perl_noop(void *data) {} void mod_perl_register_cleanup(request_rec *r, SV *sv) { dPPDIR; if(!MP_RCLEANUP(cld)) { (void)perl_request_rec(r); register_cleanup(r->pool, (void*)r, mod_perl_cleanup_handler, mod_perl_noop); MP_RCLEANUP_on(cld); if(cleanup_av == Nullav) cleanup_av = newAV(); } MP_TRACE_h(fprintf(stderr, "registering PerlCleanupHandler\n")); ++SvREFCNT(sv); av_push(cleanup_av, sv); } #ifdef PERL_STACKED_HANDLERS int mod_perl_push_handlers(SV *self, char *hook, SV *sub, AV *handlers) { int do_store=0, len=strlen(hook); SV **svp; if(self && SvTRUE(sub)) { if(handlers == Nullav) { svp = hv_fetch(stacked_handlers, hook, len, 0); MP_TRACE_h(fprintf(stderr, "fetching %s stack\n", hook)); if(svp && SvTRUE(*svp) && SvROK(*svp)) { handlers = (AV*)SvRV(*svp); } else { MP_TRACE_h(fprintf(stderr, "%s handlers stack undef, creating\n", hook)); handlers = newAV(); do_store = 1; } } if(SvROK(sub) && (SvTYPE(SvRV(sub)) == SVt_PVCV)) { MP_TRACE_h(fprintf(stderr, "pushing CODE ref into `%s' handlers\n", hook)); } else if(SvPOK(sub)) { if(do_store) { MP_TRACE_h(fprintf(stderr, "pushing `%s' into `%s' handlers\n", SvPV(sub,na), hook)); } else { MP_TRACE_d(fprintf(stderr, "pushing `%s' into `%s' handlers\n", SvPV(sub,na), hook)); } } else { warn("mod_perl_push_handlers: Not a subroutine name or CODE reference!"); } ++SvREFCNT(sub); av_push(handlers, sub); if(do_store) hv_store(stacked_handlers, hook, len, (SV*)newRV_noinc((SV*)handlers), 0); return 1; } return 0; } int perl_run_stacked_handlers(char *hook, request_rec *r, AV *handlers) { dSTATUS; I32 i, do_clear=FALSE; SV *sub, **svp; int hook_len = strlen(hook); #ifdef USE_ITHREADS dTHX; if (!aTHX) { PERL_SET_CONTEXT(perl); } #endif if(handlers == Nullav) { if(hv_exists(stacked_handlers, hook, hook_len)) { svp = hv_fetch(stacked_handlers, hook, hook_len, 0); if(svp && SvROK(*svp)) handlers = (AV*)SvRV(*svp); } else { MP_TRACE_h(fprintf(stderr, "`%s' push_handlers() stack is empty\n", hook)); return NO_HANDLERS; } do_clear = TRUE; MP_TRACE_h(fprintf(stderr, "running %d pushed (stacked) handlers for %s...\n", (int)AvFILL(handlers)+1, r->uri)); } else { #ifdef PERL_STACKED_HANDLERS /* XXX: bizarre, I only see this with httpd.conf.pl and PerlAccessHandler */ if(SvTYPE((SV*)handlers) != SVt_PVAV) { #if MODULE_MAGIC_NUMBER > 19970909 aplog_error(APLOG_MARK, APLOG_NOERRNO|APLOG_DEBUG, r->server, #else fprintf(stderr, #endif "[warning] %s stack is not an ARRAY!\n", hook); sv_dump((SV*)handlers); return DECLINED; } #endif MP_TRACE_h(fprintf(stderr, "running %d server configured stacked handlers for %s...\n", (int)AvFILL(handlers)+1, r->uri)); } for(i=0; i<=AvFILL(handlers); i++) { MP_TRACE_h(fprintf(stderr, "calling &{%s->[%d]} (%d total)\n", hook, (int)i, (int)AvFILL(handlers)+1)); if(!(sub = *av_fetch(handlers, i, FALSE))) { MP_TRACE_h(fprintf(stderr, "sub not defined!\n")); } else { if(!SvTRUE(sub)) { MP_TRACE_h(fprintf(stderr, "sub undef! skipping callback...\n")); continue; } MARK_WHERE(hook, sub); status = perl_call_handler(sub, r, Nullav); UNMARK_WHERE; MP_TRACE_h(fprintf(stderr, "&{%s->[%d]} returned status=%d\n", hook, (int)i, status)); if((status != OK) && (status != DECLINED)) { if(do_clear) av_clear(handlers); return status; } } } if(do_clear) av_clear(handlers); return status; } #endif /* PERL_STACKED_HANDLERS */ /* things to do once per-request */ void perlĭ~MOD_PERL1_25_MUP.SAVED +[MOD_PERL1_25.SRC.MODULES.PERL]MOD_PERL.C;1@$I_per_request_init(request_rec *r) { dPPDIR; dPPREQ; /* PerlSendHeader */ if(MP_SENDHDR(cld)) { MP_SENTHDR_off(cld); table_set(r->subprocess_env, "PERL_SEND_HEADER", "On"); } else MP_SENTHDR_on(cld); if(!cfg) { cfg = perl_create_request_config(r->pool, r->server); set_module_config(r->request_config, &perl_module, cfg); } else if (cfg->setup_env && MP_ENV(cld)) { perl_setup_env(r); cfg->setup_env = 0; /* just once per-request */ } if(callbacks_this_request++ > 0) return; if (!r->main) { /* so Apache->request will work before PerlHandler with CGI.pm * XXX: triggers core dump in subrequests, * so just do in the main request for now */ (void)perl_request_rec(r); } /* PerlSetEnv */ mod_perl_dir_env(r, cld); /* SetEnv PERL5LIB */ if (!MP_INCPUSH(cld)) { char *path = (char *)table_get(r->subprocess_env, "PERL5LIB"); if (path) { perl_incpush(path); MP_INCPUSH_on(cld); } } { dPSRV(r->server); mod_perl_pass_env(r->pool, cls); } mod_perl_tie_scriptname(); /* will be released in mod_perl_end_cleanup */ (void)acquire_mutex(mod_perl_mutex); register_cleanup(r->pool, (void*)r, mod_perl_end_cleanup, mod_perl_noop); #ifdef WIN32 sv_setpvf(perl_get_sv("Apache::CurrentThreadId", TRUE), "0x%lx", (unsigned long)GetCurrentThreadId()); #endif /* hookup stderr to error_log */ #ifndef PERL_TRACE if(r->server->error_log) error_log2stderr(r->server); #endif seqno++; MP_TRACE_g(fprintf(stderr, "mod_perl: inc seqno to %d for %s\n", seqno, r->uri)); seqno_check_max(r, seqno); /* set $$, $>, etc., if 1.3a1+, this really happens during child_init */ perl_init_ids; } /* XXX this still needs work, getting there... */ int perl_call_handler(SV *sv, request_rec *r, AV *args) { int count, status, is_method=0; dSP; perl_dir_config *cld = NULL; HV *stash = Nullhv; SV *pclass = newSVsv(sv), *dispsv = Nullsv; CV *cv = Nullcv; char *method = "handler"; int defined_sub = 0, anon = 0; char *dispatcher = NULL; if(r->per_dir_config) cld = (perl_dir_config *) get_module_config(r->per_dir_config, &perl_module); #ifdef PERL_DISPATCH if(cld && (dispatcher = cld->PerlDispatchHandler)) { if(!(dispsv = (SV*)perl_get_cv(dispatcher, FALSE))) { if(strlen(dispatcher) > 0) { /* XXX */ fprintf(stderr, "mod_perl: unable to fetch PerlDispatchHandler `%s'\n", dispatcher); } dispatcher = NULL; } } #endif if(r->per_dir_config) perl_per_request_init(r); if(!dispatcher && (SvTYPE(sv) == SVt_PV)) { char *imp = pstrdup(r->pool, (char *)SvPV(pclass,na)); if((anon = strnEQ(imp,"sub ",4))) { sv = perl_eval_pv(imp, FALSE); MP_TRACE_h(fprintf(stderr, "perl_call: caching CV pointer to `__ANON__'\n")); defined_sub++; goto callback; /* XXX, I swear I've never used goto before! */ } #ifdef PERL_METHOD_HANDLERS { char *end_pclass = NULL; if ((end_pclass = strstr(imp, "->"))) { end_pclass[0] = '\0'; if(pclass) SvREFCNT_dec(pclass); pclass = newSVpv(imp, 0); end_pclass[0] = ':'; end_pclass[1] = ':'; method = &end_pclass[2]; imp = method; ++is_method; } } if(*SvPVX(pclass) == '$') { SV *obj = perl_eval_pv(SvPVX(pclass), TRUE); if(SvROK(obj) && sv_isobject(obj)) { MP_TRACE_h(fprintf(stderr, "handler object %s isa %s\n", SvPVX(pclass), HvNAME(SvSTASH((SV*)SvRV(obj))))); SvREFCNT_dec(pclass); pclass = obj; ++SvREFCNT(pclass); /* this will _dec later */ stash = SvSTASH((SV*)SvRV(pclass)); } } if(pclass && !stash) stash = gv_stashpv(SvPV(pclass,na),FALSE); #if 0 MP_TRACE_h(fprintf(stderr, "perl_call: pclass=`%s'\n", SvPV(pclass,na))); MP_TRACE_h(fprintf(stderr, "perl_call: imp=`%s'\n", imp)); MP_TRACE_h(fprintf(stderr, "perl_call: method=`%s'\n", method)); MP_TRACE_h(fprintf(stderr, "perl_call: stash=`%s'\n", stash ? HvNAME(stash) : "unknown")); #endif #else method = NULL; /* avoid warning */ #endif /* if a Perl*Handler is not a defined function name, * default to the class implementor's handler() function * attempt to load the class module if it is not already */ if(!imp) imp = SvPV(sv,na); if(!stash) stash = gv_stashpv(imp,FALSE); if(!is_method) defined_sub = (cv = perl_get_cv(imp, FALSE)) ? TRUE : FALSE; #ifdef PERL_METHOD_HANDLERS if(!defined_sub && stash) { GV *gvp; MP_TRACE_h(fprintf(stderr, "perl_call: trying method lookup on `%s' in class `%s'...", method, HvNAME(stash))); /* XXX Perl caches method lookups internally, * should we cache this lookup? */ if((gvp = gv_fetchmethod(stash, method))) { cv = GvCV(gvp); MP_TRACE_h(fprintf(stderr, "found\n")); is_method = perl_handler_ismethod(stash, method); } else { MP_TRACE_h(fprintf(stderr, "not found\n")); } } #endif if(!stash && !defined_sub) { MP_TRACE_h(fprintf(stderr, "%s symbol table not found, loading...\n", imp)); if(perl_require_module(imp, r->server) == OK) stash = gv_stashpv(imp,FALSE); #ifdef PERL_METHOD_HANDLERS if(stash) /* check again */ is_method = perl_handler_ismethod(stash, method); #endif SPAGAIN; /* reset stack pointer after require() */ } if(!is_method && !defined_sub) { MP_TRACE_h(fprintf(stderr, "perl_call: defaulting to %s::handler\n", imp)); sv_catpv(sv, "::handler"); } #if 0 /* XXX: CV lookup cache disabled for now */ if(!is_method && defined_sub) { /* cache it */ MP_TRACE_h(fprintf(stderr, "perl_call: caching CV pointer to `%s'\n", (anon ? "__ANON__" : SvPV(sv,na)))); SvREFCNT_dec(sv); sv = (SV*)newRV((SV*)cv); /* let newRV inc the refcnt */ } #endif } else { MP_TRACE_h(fprintf(stderr, "perl_call: handler is a %s\n", dispatcher ? "dispatcher" : "cached CV")); } callback: ENTER; SAVETMPS; PUSHMARK(sp); #ifdef PERL_METHOD_HANDLERS if(is_method) XPUSHs(sv_2mortal(pclass)); else SvREFCNT_dec(pclass); #else SvREFCNT_dec(pclass); #endif XPUSHs((SV*)perl_bless_request_rec(r)); if(dispatcher) { MP_TRACE_h(fprintf(stderr, "mod_perl: handing off to PerlDispatchHandler `%s'\n", dispatcher)); /*XPUSHs(sv_mortalcopy(sv));*/ XPUSHs(sv); sv = dispsv; } { I32 i, len = (args ? AvFILL(args) : 0); if(args) { EXTEND(sp, len); for(i=0; i<=len; i++) PUSHs(sv_2mortal(*av_fetch(args, i, FALSE))); } } PUTBACK; /* use G_EVAL so we can trap errors */ #ifdef PERL_METHOD_HANDLERS if(is_method) count = perl_call_method(method, G_EVAL | G_SCALAR); else #endif count = perl_call_sv(sv, G_EVAL | G_SCALAR); SPAGAIN; if ((status = perl_eval_ok(r->server)) != OK) { dTHRCTX; if (status == SERVER_ERROR) { MP_STORE_ERROR(r->uri, ERRSV); if (r->notes) { ap_table_set(r->notes, "error-notes", SvPVX(ERRSV)); } } else if (status == DECLINED) { status = r->status == 200 ? OK : r->status; } } else if(count != 1) { mod_perl_error(r->server, "perl_call did not return a status arg, assuming OK"); status = OK; } else { status = POPi; if((status == 1) || (status == 200) || (status > 600)) status = OK; if((status == SERVER_ERROR) && ERRSV_CAN_BE_HTTP) { SV *errsv = Nullsv; if(MP_EXISTS_ERROR(r->uri) && (errsv = MP_FETCH_ERROR(r->uri))) { (void)perl_sv_is_http_code(errsv, &status); } } } PUTBACK; FREETMPS; LEAVE; MP_TRACE_g(fprintf(stderr, "perl_call_handler: SVs = %5d, OBJs = %5d\n", (int)sv_count, (int)sv_objcount)); { dTHRCTX; if(SvMAGICAL(ERRSV)) sv_unmagic(ERRSV, 'U'); /* Apache::exit was called */ } return status; } request_rec *perl_request_rec(request_rec *r) { if(r != NULL) { mp_request_rec = (IV)r; return NULL; } else return (request_rec *)mp_request_rec; } SV *perl_bless_request_rec(request_rec *r) { SV *sv = sv_newmortal(); sv_setref_pv(sv, "Apache", (void*)r); MP_TRACE_g(fprintf(stderr, "blessing request_rec=(0x%lx)\n", (unsigned long)r)); return sv; } void perl_setup_env(request_rec *r) { int i; array_header *arr = perl_cgi_env_init(r); table_entry *elts = (table_entry *)arr->elts; for (i = 0; i < arr->nelts; ++i) { if (!elts[i].key || !elts[i].val) continue; mp_setenv(elts[i].key, elts[i].val); } MP_TRACE_g(fprintf(stderr, "perl_setup_env...%d keys\n", i)); } int mod_perl_seqno(SV *self, int inc) { self = self; /*avoid warning*/ if(inc) seqno += inc; return seqno; } +*[MOD_PERL1_25.SRC.MODULES.PERL]MOD_PERL.H;2+,K./A@ 4hM- 0D123KPWON56PN7UN89GA@HJN $J)g7 %J)g7J)g7V/* ==================================================================== * The Apache Software License, Version 1.1 * * Copyright (c) 1996-2000 The Apache Software Foundation. All rights * reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in * the documentation and/or other materials provided with the * distribution. * * 3. The end-user documentation included with the redistribution, * if any, must include the following acknowledgment: * "This product includes software developed by the * Apache Software Foundation (http://www.apache.org/)." * Alternately, this acknowledgment may appear in the software itself, * if and wherever such third-party acknowledgments normally appear. * * 4. The names "Apache" and "Apache Software Foundation" must * not be used to endorse or promote products derived from this * software without prior written permission. For written * permission, please contact apache@apache.org. * * 5. Products derived from this software may not be called "Apache", * nor may "Apache" appear in their name, without prior written * permission of the Apache Software Foundation. * * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. * ==================================================================== */ #ifdef WIN32 #define NO_PERL_CHILD_INIT #define NO_PERL_CHILD_EXIT #ifdef JW_PERL_OBJECT #include #include #include #include #include // For O_BINARY #include "EXTERN.h" #include "perl.h" #include #else #include "dirent.h" #endif #endif #ifndef IS_MODULE #define IS_MODULE #endif #ifndef SHARED_MODULE #define SHARED_MODULE #endif #ifdef PERL_THREADS #define _INCLUDE_APACHE_FIRST #endif #ifdef _INCLUDE_APACHE_FIRST #include "apache_inc.h" #endif #include "EXTERN.h" #include "perl.h" #ifdef PERL_OBJECT #define NO_XSLOCKS #endif #include "XSUB.h" #ifdef VMS #define RUN_OK 1 #define perl_cmd_post_read_request_handlers perl_cmd_post_read_req_handlers #else #define RUN_OK OK #endif #ifndef MOD_PERL_STRING_VERSION #include "mod_perl_version.h" #endif #ifndef MOD_PERL_VERSION #define MOD_PERL_VERSION "TRUE" #endif /* patchlevel.h causes a -Wall warning, * plus chance that another patchlevel.h might be in -I paths * so try to avoid it if possible */ #ifdef PERLV #if PERLV >= 500476 #include "perl_PL.h" #endif #else #define PERL_PATCHLEVEL_H_IMPLICIT /* ignore local_patches */ #include "patchlevel.h" #undef PERL_PATCHLEVEL_H_IMPLICIT #ifndef PATCHLEVEL #define PATCHLEVEL PERL_VERSION #undef SUBVERSION #define SUBVERSION PERL_SUBVERSION #endif #if ((PATCHLEVEL >= 4) && (SUBVERSION >= 76)) || (PATCHLEVEL >= 5) #include "perl_PL.h" #endif #endif /*PERLV*/ #ifdef PERL_OBJECT #include #include "win32iop.h" #include #define PerlInterpreter CPerlHost #define perl_alloc() perl->PerlCreate() ? perl : NULL #define perl_parse(host, xsi, argc, argv, env) \ host->PerlParse(xsi, argc, argv, env); #define perl_run(host) \ host->PerlRun() #define perl_destruct(host) \ host->PerlDestroy() #define perl_free(host) #endif /* perl hides it's symbols in libperl when these macros are * expanded to Perl_foo * but some cause conflict when expanded in other headers files */ #undef S_ISREG #undef DIR #undef VOIDUSED #undef pregexec #undef pregfree #undef pregcomp #undef setregid #undef setreuid #undef sync #undef my_memcmp #undef my_bcopy #undef my_memset #undef RETURN #undef die #undef __attribute__ #ifdef pTHX_ #define PERL_IS_5_6 #endif #ifndef _INCLUDE_APACHE_FIRST #include "apache_inc.h" #endif #ifndef PERL_IS_5_6 #define pTHX_ #define aTHXo_ #define CopFILEGV(cop) cop->cop_filegv #define CopLINE(cop) cop->cop_line #define CopLINE_set(c,l) (CopLINE(c) = (l)) #define SAVECOPFILE(cop) SAVESPTR(CopFILEGV(curcop)); #define SAVECOPLINE(cop) SAVEI16(CopLINE(cop)) #endif #ifdef USE_5005THREADS #define dTHRCTX struct perl_thread *thr = PERL_GET_CONTEXT #else #define dTHRCTX #endif #ifndef dTHR #define dTHR extern int errno #endif #ifndef ERRSV #define ERRSV GvSV(errgv) #endif #ifndef ERRHV #define ERRHV GvHV(errgv) #endif #ifndef AvFILLp #define AvFILLp(av) ((XPVAV*) SvANY(av))->xav_fill #endif #ifdef eval_pv # ifndef perl_eval_pv # define perl_eval_pv eval_pv # endif #endif #ifdef eval_sv # ifndef perl_eval_sv # define perl_eval_sv eval_sv # endif #endif #define MP_EXISTS_ERROR(k) \ ERRHV && hv_exists(ERRHV, k, strlen(k)) #define MP_STORE_ERROR(k,v) \ hv_store(ERRHV, k, strlen(k), newSVsv(v), FALSE) #define MP_FETCH_ERROR(k) \ *hv_fetch(ERRHV, k, strlen(k), FALSE) #define MP_CLEAR_ERROR(k) \ (void)hv_delete(ERRHV, k, strlen(k), G_DISCARD) #ifndef PERL_AUTOPRELOAD #define PERL_AUTOPRELOAD perl_get_sv("Apache::Server::AutoPreLoad", FALSE) #endif #ifndef ERRSV_CAN_BE_HTTP # ifdef WIN32 # define ERRSV_CAN_BE_HTTP perl_get_sv("Apache::ERRSV_CAN_BE_HTTP", FALSE) # else # define ERRSV_CAN_BE_HTTP 1 # endif #endif #ifndef PERL_DESTRUCT_LEVEL #define PERL_DESTRUCT_LEVEL 0 #endif #ifndef DO_INTERNAL_REDIRECT #define DO_INTERNAL_REDIRECT perl_get_sv("Apache::DoInternalRedirect", FALSE) #endif typedef struct { table *utable; array_header *arr; table_entry *elts; int ix; } TiedTable; typedef request_rec * Apache; typedef request_rec * Apache__SubRequest; typedef conn_rec * Apache__Connection; typedef server_rec * Apache__Server; typedef cmd_parms * Apache__CmdParms; typedef TiedTable * Apache__Table; typedef table * Apache__table; typedef module * Apache__Module; typedef handler_rec * Apache__Handler; typedef command_rec * Apache__Command; #define SvCLASS(o) HvNAME(SvSTASH(SvRV(o))) #define GvHV_init(name) gv_fetchpv(name, GV_ADDMULTI, SVt_PVHV) #define GvSV_init(name) gv_fetchpv(name, GV_ADDMULTI, SVt_PV) #define GvSV_setiv(gv,val) sv_setiv(GvSV(gv), val) #define sv_is_http_code(sv) \ ((SvIOK(sv) && (SvIVX(sv) >= 100) && (SvIVX(sv) <= 600)) ? SvIVX(sv) : FALSE) #define Apache__ServerStarting(val) \ { \ GV *sgv = GvSV_init("Apache::Server::Starting"); \ GV *agv = GvSV_init("Apache::ServerStarting"); \ GvSV_setiv(sgv, val); \ GvSV(agv) = GvSV(sgv); \ } #define Apache__ServerReStarting(val) \ { \ GV *sgv = GvSV_init("Apache::Server::ReStarting"); \ GV *agv = GvSV_init("Apache::ServerReStarting"); \ GvSV_setiv(sgv, val); \ GvSV(agv) = GvSV(sgv); \ if(perl_is_running == PERL_DONE_STARTUP) \ Apache__ServerStarting((val == FALSE ? FALSE : PERL_RUNNING())); \ } #define PUSHif(arg) \ if(arg) \ XPUSHs(sv_2mortal(newSVpv(arg,0))) #define iniHV(hv) hv = (HV*)sv_2mortal((SV*)newHV()) #define iniAV(av) av = (AV*)sv_2mortal((SV*)newAV()) #define AvTRUE(av) (av && (AvFILL(av) > -1) && SvREFCNT(av)) #define av_copy_array(av) av_make(av_len(av)+1, AvARRAY(av)) #ifndef newRV_noinc #define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv) #endif #ifndef SvTAINTED_on #define SvTAINTED_on(sv) if (tainting) sv_magic(sv, Nullsv, 't', Nullch, 0) #endif #define HV_SvTAINTED_on(hv,key,klen) \ SvTAINTED_on(*hv_fetch(hv, key, klen, 0)) #if 0 #define mp_setenv(key, val) \ mp_magic_setenv(key, val, 1) #define mp_SetEnv(key, val) \ mp_magic_setenv(key, val, 0) #define mp_PassEnv(key) \ { \ char *val = getenv(key); \ mp_magic_setenv(key, val?val:"", 0); \ } #else #define mp_setenv(key, val) \ { \ int klen = strlen(key); \ SV *sv = newSVpv(val,0); \ hv_store(GvHV(envgv), key, klen, sv, FALSE); \ HV_SvTAINTED_on(GvHV(envgv), key, klen); \ my_setenv(key, SvPVX(sv)); \ } #define mp_SetEnv(key, val) \ hv_store(GvHV(envgv), key, strlen(key), newSVpv(val,0), FALSE); \ my_setenv(key, val) #define mp_PassEnv(key) \ { \ char *val = getenv(key); \ hv_store(GvHV(envgv), key, strlen(key), newSVpv(val?val:"",0), FALSE); \ } #endif #define mp_debug mod_perl_debug_flags extern U32 mp_debug; #ifdef PERL_TRACE /* -Wall */ #ifndef VMS #undef dNOOP #define dNOOP extern int __attribute__ ((unused)) Perl___notused #endif #define MP_TRACE(a) if (mp_debug) a #define MP_TRACE_d(a) if (mp_debug & 1) a /* directives */ #define MP_TRACE_s(a) if (mp_debug & 2) a /* perl sections */ #define MP_TRACE_h(a) if (mp_debug & 4) a /* handlers */ #define MP_TRACE_g(a) if (mp_debug & 8) a /* globals and allocation */ #define MP_TRACE_c(a) if (mp_debug & 16) a /* directive handlers */ #ifndef PERL_MARK_WHERE #define PERL_MARK_WHERE #endif #ifndef PERL_TIE_SCRIPTNAME #define PERL_TIE_SCRIPTNAME #endif #else #define MP_TRACE(a) #define MP_TRACE_d(a) #define MP_TRACE_s(a) #define MP_TRACE_h(a) #define MP_TRACE_g(a) #define MP_TRACE_c(a) #endif #ifdef PERL_MARK_WHERE #define MARK_WHERE(w,s) \ ENTER; \ mod_perl_mark_where(w,s) #define UNMARK_WHERE LEAVE #else #define MARK_WHERE(w,s) mod_perl_noop(NULL) #define UNMARK_WHERE mod_perl_noop(NULL) #endif /* cut down on some noise in source */ #define PERL_IS_DSO perl_module.dynamic_load_handle #define dSTATUS \ int dstatus = DECLINED; \ int status = dstatus #define dPPREQ \ perl_request_config *cfg = (perl_request_config *)get_module_config(r->request_config, &perl_module) #define dPPDIR \ perl_dir_config *cld = (perl_dir_config *)get_module_config(r->per_dir_config, &perl_module) #define dPSRV(srv) \ perl_server_config *cls = (perl_server_config *) get_module_config (srv->module_config, &perl_module) /* per-directory flags */ #define MPf_On 1 #define MPf_Off -1 #define MPf_None 0 #define MPf_INCPUSH 0x00000100 /* use lib split ":", $ENV{PERL5LIB} */ #define MPf_SENDHDR 0x00000200 /* is PerlSendHeader On? */ #define MPf_SENTHDR 0x00000400 /* has PerlSendHeader sent the headers? */ #define MPf_ENV 0x00000800 /* PerlSetupEnv */ #define MPf_HASENV 0x00001000 /* do we have any PerlSetEnv's? */ #define MPf_DSTDERR 0x00002000 /* redirect stderr to error_log */ #define MPf_CLEANUP 0x00004000 /* did we register our cleanup ? */ #define MPf_RCLEANUP 0x00008000 /* for $r->register_cleanup */ #define MP_FMERGE(new,add,base,f) \ if((add->flags & f) || (base->flags & f)) \ new->flags |= f #define MP_INCPUSH(d) (d->flags & MPf_INCPUSH) #define MP_INCPUSH_on(d) (d->flags |= MPf_INCPUSH) #define MP_INCPUSH_off(d) (d->flags &= ~MPf_INCPUSH) #if 0 #define MP_SENDHDR(d) (d->flags & MPf_SENDHDR) #define MP_SENDHDR_on(d) (d->flags |= MPf_SENDHDR) #define MP_SENDHDR_off(d) (d->flags &= ~MPf_SENDHDR) #endif #define MP_SENDHDR(d) (d->SendHeader == MPf_On) #define MP_SENDHDR_on(d) (d->SendHeader = MPf_On) #define MP_SENDHDR_off(d) (d->SendHeader = MPf_Off) #define MP_SENTHDR(d) (d->flags & MPf_SENTHDR) #define MP_SENTHDR_on(d) (d->flags |= MPf_SENTHDR) #define MP_SENTHDR_off(d) (d->flags &= ~MPf_SENTHDR) #if 0 #define MP_ENV(d) (d->flags & MPf_ENV) #define MP_ENV_on(d) (d->flags |= MPf_ENV) #define MP_ENV_off(d) (d->flags &= ~MPf_ENV) #endif #define MP_ENV(d) (d->SetupEnv != MPf_Off) #define MP_ENV_on(d) (d->SetupEnv = MPf_On) #define MP_ENV_off(d) (d->SetupEnv = MPf_Off) #define MP_HASENV(d) (d->flags & MPf_HASENV) #define MP_HASENV_on(d) (d->flags |= MPf_HASENV) #define MP_HASENV_off(d) (d->flags &= ~MPf_HASENV) #define MP_DSTDERR(d) (d->flags & MPf_DSTDERR) #define MP_DSTDERR_on(d) (d->flags |= MPf_DSTDERR) #define MP_DSTDERR_off(d) (d->flags &= ~MPf_DSTDERR) #define MP_CLEANUP(d) (d->flags & MPf_CLEANUP) #define MP_CLEANUP_on(d) (d->flags |= MPf_CLEANUP) #define MP_CLEANUP_off(d) (d->flags &= ~MPf_CLEANUP) #define MP_RCLEANUP(d) (d->flags & MPf_RCLEANUP) #define MP_RCLEANUP_on(d) (d->flags |= MPf_RCLEANUP) #define MP_RCLEANUP_off(d) (d->flags &= ~MPf_RCLEANUP) #define PERL_GATEWAY_INTERFACE "CGI-Perl/1.1" /* Apache::SSI */ #define PERL_APACHE_SSI_TYPE "text/x-perl-server-parsed-html" /* PerlSetVar */ #ifndef NO_PERL_DIRECTIVE_HANDLERS #define PERL_DIRECTIVE_HANDLERS #endif #ifndef NO_PERL_STACKED_HANDLERS #define PERL_STACKED_HANDLERS #endif #ifndef NO_PERL_METHOD_HANDLERS #define PERL_METHOD_HANDLERS #endif #ifndef NO_PERL_SECTIONS #define PERL_SECTIONS #endif #ifndef NO_PERL_SSI #undef PERL_SSI #define PERL_SSI #endif #ifdef PERL_SECTIONS # ifndef PERL_SECTIONS_SELF_BOOT # ifdef WIN32 # define PERL_SECTIONS_SELF_BOOT \ (getenv("PERL_SECTIONS_SELF_BOOT") && !perl_sections_self_boot) # else # define PERL_SECTIONS_SELF_BOOT !perl_sections_self_boot # endif # endif #endif #ifndef PERL_STARTUP_DONE_CHECK #define PERL_STARTUP_DONE_CHECK getenv("PERL_STARTUP_DONE_CHECK") #endif #define PERL_STARTUP_IS_DONE \ (!PERL_STARTUP_DONE_CHECK || strEQ(getenv("PERL_STARTUP_DONE"), "2")) #ifndef PERL_DSO_UNLOAD #define PERL_DSO_UNLOAD getenv("PERL_DSO_UNLOAD") #endif #ifdef APACHE_SSL #define PERL_DONE_STARTUP 1 #else #define PERL_DONE_STARTUP 2 #endif /* some 1.2.x/1.3.x compat stuff */ /* once 1.3.0 is here, we can toss most of this junk */ #ifdef MODULE_MAGIC_AT_LEAST #undef MODULE_MAGIC_AT_LEAST #define MODULE_MAGIC_AT_LEAST(major,minor) \ (MODULE_MAGIC_NUMBER_MAJOR >= (major) \ && MODULE_MAGIC_NUMBER_MINOR >= minor) #else #define MODULE_MAGIC_AT_LEAST(major,minor) (0 > 1) #endif #define HAS_MMN(mmn) (MODULE_MAGIC_NUMBER >= mmn) #define MMN_130 19980527 #define MMN_131 19980713 #define MMN_132 19980806 #define MMN_136 19990320 #define HAS_MMN_130 HAS_MMN(MMN_130) #define HAS_MMN_131 HAS_MMN(MMN_131) #define HAS_MMN_132 HAS_MMN(MMN_132) #define HAS_MMN_136 HAS_MMN(MMN_136) #define HAS_CONTEXT MODULE_MAGIC_AT_LEAST(MMN_136,2) #if HAS_CONTEXT #define CAN_SELF_BOOT_SECTIONS (PERL_SECTIONS_SELF_BOOT) #define SECTION_ALLOWED OR_ALL #define USABLE_CONTEXT parms->context #else #define CAN_SELF_BOOT_SECTIONS ((parms->path==NULL)&&PERL_SECTIONS_SELF_BOOT) #define SECTION_ALLOWED RSRC_CONF #define USABLE_CONTEXT parms->server->lookup_defaults #endif #define APACHE_SSL_12X (defined(APACHE_SSL) && (MODULE_MAGIC_NUMBER < MMN_130)) #if MODULE_MAGIC_NUMBER < MMN_130 #undef PERL_IS_DSO #define PERL_IS_DSO 0 #endif #if MODULE_MAGIC_NUMBER >= 19980627 #define MP_CONST_CHAR const char #define MP_CONST_ARRAY_HEADER const array_header #else #define MP_CONST_CHAR char #define MP_CONST_ARRAY_HEADER array_header #endif #if MODULE_MAGIC_NUMBER > 19970912 #define cmd_infile parms->config_file #define cmd_filename parms->config_file->name #define cmd_linenum parms->config_file->line_number #else #define cmd_infile parms->infile #define cmd_filename parms->config_file #define cmd_linenum parms->config_line #endif #ifndef DONE #define DONE -2 #endif #if MODULE_MAGIC_NUMBER >= 19980713 #include "ap_compat.h" #elif MODULE_MAGIC_NUMBER >= 19980413 #include "compat.h" #endif #if MODULE_MAGIC_NUMBER > 19970909 #define mod_perl_warn(s,msg) \ aplog_error(APLOG_MARK, APLOG_WARNING | APLOG_NOERRNO, s, "%s", msg) #define mod_perl_error(s,msg) \ aplog_error(APLOG_MARK, APLOG_ERR | APLOG_NOERRNO, s, "%s", msg) #define mod_perl_notice(s,msg) \ aplog_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE, s, "%s", msg) #define mod_perl_debug(s,msg) \ aplog_error(APLOG_MARK, APLOG_NOERRNO|APLOG_DEBUG, s, "%s", msg) #define mod_perl_log_reason(msg, file, r) \ aplog_error(APLOG_MARK, APLOG_ERR | APLOG_NOERRNO, r->server, \ "access to %s failed for %s, reason: %s", \ file, \ get_remote_host(r->connection, \ r->per_dir_config, REMOTE_NAME), \ msg) #else #define mod_perl_error(s,msg) log_error(msg,s) #define mod_perl_debug mod_perl_error #define mod_perl_warn mod_perl_error #define mod_perl_notice mod_perl_error #define mod_perl_log_reason log_reason #endif #if MODULE_MAGIC_NUMBER < 19970719 #define is_initial_req(r) ((r->main == NULL) && (r->prev == NULL)) #endif #ifndef API_EXPORT #define API_EXPORT(type) type #endif #ifndef MODULE_VAR_EXPORT #define MODULE_VAR_EXPORT #endif #ifndef API_VAR_EXPORT #define API_VAR_EXPORT #endif #ifdef WIN32 #if MODULE_MAGIC_NUMBER < 19980317 #undef PERL_SECTIONS #define NO_PERL_SECTIONS #endif #include "multithread.h" extern void *mod_perl_mutex; #else #define mod_perl_mutex NULL extern void *mod_perl_dummy_mutex; #ifndef MULTITHREAD_H #define MULTI_OK (0) #undef create_mutex #undef acquire_mutex #undef release_mutex #define create_mutex(name) ((void *)mod_perl_dummy_mutex) #define acquire_mutex(mutex_id) ((int)MULTI_OK) #define release_mutex(mutex_id) ((int)MULTI_OK) #endif /* MULTITHREAD_H */ #endif /* WIN32 */ #if MODULE_MAGIC_NUMBER < 19971226 char *ap_cpystrn(char *dst, const char *src, size_t dst_size); #endif #if MODULE_MAGIC_NUMBER >= 19980304 #ifndef SERVER_BUILT #define SERVER_BUILT apapi_get_server_built() #endif #endif #define PERL_CUR_HOOK_SV \ perl_get_sv("Apache::__CurrentCallback", TRUE) #define PERL_SET_CUR_HOOK(h) \ if (r->notes) ap_table_setn(r->notes, "PERL_CUR_HOOK", h); \ else sv_setpv(PERL_CUR_HOOK_SV, h) #define PERL_GET_CUR_HOOK \ (r->notes ? \ ap_table_get(r->notes, "PERL_CUR_HOOK") : \ SvPVX(PERL_CUR_HOOK_SV)) #ifdef PERL_STACKED_HANDLERS #ifndef PERL_GET_SET_HANDLERS #define PERL_GET_SET_HANDLERS #endif #define PERL_TAKE ITERATE #define PERL_CMD_INIT Nullav #define PERL_CMD_TYPE AV #define mod_perl_can_stack_handlers(sv) (SvTRUE(sv) && 1) /* always enable child_init for perl_init_ids */ #if (MODULE_MAGIC_NUMBER >= 19970719) && !defined(WIN32) #define perl_init_ids # ifdef NO_PERL_CHILD_INIT # undef NO_PERL_CHILD_INIT # endif # ifdef NO_PERL_CHILD_EXIT # undef NO_PERL_CHILD_EXIT # endif #endif #ifndef perl_init_ids #define perl_init_ids mod_perl_init_ids() #endif #define NO_HANDLERS -666 #define PERL_CALLBACK(h,name) \ PERL_SET_CUR_HOOK(h); \ (void)acquire_mutex(mod_perl_mutex); \ if(AvTRUE(name)) { \ status = perl_run_stacked_handlers(h, r, name); \ } \ if((status != OK) && (status != DECLINED)) { \ MP_TRACE_h(fprintf(stderr, "%s handlers returned %d\n", h, status)); \ } \ else { \ dstatus = perl_run_stacked_handlers(h, r, Nullav); \ if(dstatus != NO_HANDLERS) status = dstatus; \ } \ (void)release_mutex(mod_perl_mutex); \ MP_TRACE_h(fprintf(stderr, "%s handlers returned %d\n", h, status)) #else #define PERL_TAKE TAKE1 #define PERL_CMD_INIT NULL #define PERL_CMD_TYPE char #define mod_perl_can_stack_handlers(sv) (SvTRUE(sv) && 0) #define PERL_CALLBACK(h,name) \ PERL_SET_CUR_HOOK(h); \ if(name != NULL) { \ SV *sv; \ (void)acquire_mutex(mod_perl_mutex); \ sv = newSVpv(name,0); \ MARK_WHERE(h, sv); \ dstatus = status = perl_call_handler(sv, r, Nullav); \ UNMARK_WHERE; \ SvREFCNT_dec(sv); \ (void)release_mutex(mod_perl_mutex); \ MP_TRACE_h(fprintf(stderr, "perl_call %s '%s' returned: %d\n", h,name,status)); \ } \ else { \ MP_TRACE_h(fprintf(stderr, "mod_perl: declining to handle %s, no callback defined\n", h)); \ } #endif #if MODULE_MAGIC_NUMBER >= 19961007 #define CHAR_P const char * #else #define CHAR_P char * #endif #define PUSHelt(key,val,klen) \ { \ SV *psv = (SV*)newSVpv(val, 0); \ SvTAINTED_on(psv); \ XPUSHs(sv_2mortal((SV*)newSVpv(key, klen))); \ XPUSHs(sv_2mortal((SV*)psv)); \ } /* on/off switches for callback hooks during server startup/shutdown */ #ifndef NO_PERL_DISPATCH #define PERL_DISPATCH #define PERL_DISPATCH_HOOK perl_dispatch #define PERL_DISPATCH_CMD_ENTRY \ "PerlDispatchHandler", (crft) perl_cmd_dispatch_handlers, \ NULL, \ OR_ALL, TAKE1, "the Perl Dispatch handler routine name" #define PERL_DISPATCH_CREATE(s) s->PerlDispatchHandler = NULL #else #define PERL_DISPATCH_HOOK NULL #define PERL_DISPATCH_CMD_ENTRY NULL #define PERL_DISPATCH_CREATE(s) #endif #ifndef NO_PERL_CHILD_INIT #define PERL_CHILD_INIT #define PERL_CHILD_INIT_HOOK perl_child_init #define PERL_CHILD_INIT_CMD_ENTRY \ "PerlChildInitHandler", (crft) perl_cmd_child_init_handlers, \ NULL, \ RSRC_CONF, PERL_TAKE, "the Perl Child init handler routine name" #define PERL_CHILD_INIT_CREATE(s) s->PerlChildInitHandler = PERL_CMD_INIT #else #define PERL_CHILD_INIT_HOOK NULL #def~MOD_PERL1_25_MUP.SAVEK +[MOD_PERL1_25.SRC.MODULES.PERL]MOD_PERL.H;2hD,ine PERL_CHILD_INIT_CMD_ENTRY NULL #define PERL_CHILD_INIT_CREATE(s) #endif #ifndef NO_PERL_CHILD_EXIT #define PERL_CHILD_EXIT #define PERL_CHILD_EXIT_HOOK perl_child_exit #define PERL_CHILD_EXIT_CMD_ENTRY \ "PerlChildExitHandler", (crft) perl_cmd_child_exit_handlers, \ NULL, \ RSRC_CONF, PERL_TAKE, "the Perl Child exit handler routine name" #define PERL_CHILD_EXIT_CREATE(s) s->PerlChildExitHandler = PERL_CMD_INIT #else #define PERL_CHILD_EXIT_HOOK NULL #define PERL_CHILD_EXIT_CMD_ENTRY NULL #define PERL_CHILD_EXIT_CREATE(s) #endif #ifndef NO_PERL_RESTART #define PERL_RESTART #define PERL_RESTART_CMD_ENTRY \ "PerlRestartHandler", (crft) perl_cmd_restart_handlers, \ NULL, \ RSRC_CONF, PERL_TAKE, "the Perl Restart handler routine name" #define PERL_RESTART_CREATE(s) s->PerlRestartHandler = PERL_CMD_INIT #else #define PERL_RESTART_CMD_ENTRY NULL #define PERL_RESTART_CREATE(s) #endif /* on/off switches for callback hooks during request stages */ #if !defined(NO_PERL_TRANS) && (MODULE_MAGIC_NUMBER > 19980207) #undef NO_PERL_POST_READ_REQUEST #endif #ifndef NO_PERL_POST_READ_REQUEST #define PERL_POST_READ_REQUEST #define PERL_POST_READ_REQUEST_HOOK perl_post_read_request #define PERL_POST_READ_REQUEST_CMD_ENTRY \ "PerlPostReadRequestHandler", (crft) perl_cmd_post_read_request_handlers, \ NULL, \ RSRC_CONF, PERL_TAKE, "the Perl Post Read Request handler routine name" #define PERL_POST_READ_REQUEST_CREATE(s) s->PerlPostReadRequestHandler = PERL_CMD_INIT #else #define PERL_POST_READ_REQUEST_HOOK NULL #define PERL_POST_READ_REQUEST_CMD_ENTRY NULL #define PERL_POST_READ_REQUEST_CREATE(s) #endif #ifndef NO_PERL_TRANS #define PERL_TRANS #define PERL_TRANS_HOOK perl_translate #define PERL_TRANS_CMD_ENTRY \ "PerlTransHandler", (crft) perl_cmd_trans_handlers, \ NULL, \ RSRC_CONF, PERL_TAKE, "the Perl Translation handler routine name" #define PERL_TRANS_CREATE(s) s->PerlTransHandler = PERL_CMD_INIT #else #define PERL_TRANS_HOOK NULL #define PERL_TRANS_CMD_ENTRY NULL #define PERL_TRANS_CREATE(s) #endif #ifndef NO_PERL_AUTHEN #define PERL_AUTHEN #define PERL_AUTHEN_HOOK perl_authenticate #define PERL_AUTHEN_CMD_ENTRY \ "PerlAuthenHandler", (crft) perl_cmd_authen_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Authentication handler routine name" #define PERL_AUTHEN_CREATE(s) s->PerlAuthenHandler = PERL_CMD_INIT #else #define PERL_AUTHEN_HOOK NULL #define PERL_AUTHEN_CMD_ENTRY NULL #define PERL_AUTHEN_CREATE(s) #endif #ifndef NO_PERL_AUTHZ #define PERL_AUTHZ #define PERL_AUTHZ_HOOK perl_authorize #define PERL_AUTHZ_CMD_ENTRY \ "PerlAuthzHandler", (crft) perl_cmd_authz_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Authorization handler routine name" #define PERL_AUTHZ_CREATE(s) s->PerlAuthzHandler = PERL_CMD_INIT #else #define PERL_AUTHZ_HOOK NULL #define PERL_AUTHZ_CMD_ENTRY NULL #define PERL_AUTHZ_CREATE(s) #endif #ifndef NO_PERL_ACCESS #define PERL_ACCESS #define PERL_ACCESS_HOOK perl_access #define PERL_ACCESS_CMD_ENTRY \ "PerlAccessHandler", (crft) perl_cmd_access_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Access handler routine name" #define PERL_ACCESS_CREATE(s) s->PerlAccessHandler = PERL_CMD_INIT #else #define PERL_ACCESS_HOOK NULL #define PERL_ACCESS_CMD_ENTRY NULL #define PERL_ACCESS_CREATE(s) #endif /* un-tested hooks */ #ifndef NO_PERL_TYPE #define PERL_TYPE #define PERL_TYPE_HOOK perl_type_checker #define PERL_TYPE_CMD_ENTRY \ "PerlTypeHandler", (crft) perl_cmd_type_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Type check handler routine name" #define PERL_TYPE_CREATE(s) s->PerlTypeHandler = PERL_CMD_INIT #else #define PERL_TYPE_HOOK NULL #define PERL_TYPE_CMD_ENTRY NULL #define PERL_TYPE_CREATE(s) #endif #ifndef NO_PERL_FIXUP #define PERL_FIXUP #define PERL_FIXUP_HOOK perl_fixup #define PERL_FIXUP_CMD_ENTRY \ "PerlFixupHandler", (crft) perl_cmd_fixup_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Fixup handler routine name" #define PERL_FIXUP_CREATE(s) s->PerlFixupHandler = PERL_CMD_INIT #else #define PERL_FIXUP_HOOK NULL #define PERL_FIXUP_CMD_ENTRY NULL #define PERL_FIXUP_CREATE(s) #endif #ifndef NO_PERL_LOG #define PERL_LOG #define PERL_LOG_HOOK perl_logger #define PERL_LOG_CMD_ENTRY \ "PerlLogHandler", (crft) perl_cmd_log_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Log handler routine name" #define PERL_LOG_CREATE(s) s->PerlLogHandler = PERL_CMD_INIT #else #define PERL_LOG_HOOK NULL #define PERL_LOG_CMD_ENTRY NULL #define PERL_LOG_CREATE(s) #endif #ifndef NO_PERL_CLEANUP #define PERL_CLEANUP #define PERL_CLEANUP_HOOK perl_cleanup #define PERL_CLEANUP_CMD_ENTRY \ "PerlCleanupHandler", (crft) perl_cmd_cleanup_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Cleanup handler routine name" #define PERL_CLEANUP_CREATE(s) s->PerlCleanupHandler = PERL_CMD_INIT #else #define PERL_CLEANUP_HOOK NULL #define PERL_CLEANUP_CMD_ENTRY NULL #define PERL_CLEANUP_CREATE(s) #endif #ifndef NO_PERL_INIT #define PERL_INIT #define PERL_INIT_HOOK perl_init #define PERL_INIT_CMD_ENTRY \ "PerlInitHandler", (crft) perl_cmd_init_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Init handler routine name" #define PERL_INIT_CREATE(s) s->PerlInitHandler = PERL_CMD_INIT #else #define PERL_INIT_HOOK NULL #define PERL_INIT_CMD_ENTRY NULL #define PERL_INIT_CREATE(s) #endif #ifndef NO_PERL_HEADER_PARSER #define PERL_HEADER_PARSER #define PERL_HEADER_PARSER_HOOK perl_header_parser #define PERL_HEADER_PARSER_CMD_ENTRY \ "PerlHeaderParserHandler", (crft) perl_cmd_header_parser_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Header Parser handler routine name" #define PERL_HEADER_PARSER_CREATE(s) s->PerlHeaderParserHandler = PERL_CMD_INIT #else #define PERL_HEADER_PARSER_HOOK NULL #define PERL_HEADER_PARSER_CMD_ENTRY NULL #define PERL_HEADER_PARSER_CREATE(s) #endif typedef struct { array_header *PerlPassEnv; array_header *PerlRequire; array_header *PerlModule; int PerlTaintCheck; int PerlWarn; int FreshRestart; PERL_CMD_TYPE *PerlInitHandler; PERL_CMD_TYPE *PerlPostReadRequestHandler; PERL_CMD_TYPE *PerlTransHandler; PERL_CMD_TYPE *PerlChildInitHandler; PERL_CMD_TYPE *PerlChildExitHandler; PERL_CMD_TYPE *PerlRestartHandler; char *PerlOpmask; table *vars; } perl_server_config; typedef struct { char *PerlDispatchHandler; PERL_CMD_TYPE *PerlHandler; PERL_CMD_TYPE *PerlAuthenHandler; PERL_CMD_TYPE *PerlAuthzHandler; PERL_CMD_TYPE *PerlAccessHandler; PERL_CMD_TYPE *PerlTypeHandler; PERL_CMD_TYPE *PerlFixupHandler; PERL_CMD_TYPE *PerlLogHandler; PERL_CMD_TYPE *PerlCleanupHandler; PERL_CMD_TYPE *PerlHeaderParserHandler; PERL_CMD_TYPE *PerlInitHandler; table *env; table *vars; U32 flags; int SendHeader; int SetupEnv; char *location; } perl_dir_config; typedef struct { Sighandler_t h; I32 signo; } perl_request_sigsave; typedef struct { HV *pnotes; int setup_env; array_header *sigsave; } perl_request_config; typedef struct { int is_method; int is_anon; int in_perl; SV *pclass; char *method; } mod_perl_handler; typedef struct { SV *obj; char *pclass; } mod_perl_perl_dir_config; typedef struct { char *subname; char *info; } mod_perl_cmd_info; extern module MODULE_VAR_EXPORT perl_module; /* a couple for -Wall sanity sake */ int translate_name (request_rec *); int log_transaction (request_rec *r); /* mod_perl prototypes */ /* perlxsi.c */ #ifdef aTHX_ void xs_init (pTHX); #else void xs_init (void); #endif /* mod_perl.c */ /* generic handler stuff */ int perl_handler_ismethod(HV *pclass, char *sub); int perl_call_handler(SV *sv, request_rec *r, AV *args); request_rec *mp_fake_request_rec(server_rec *s, pool *p, char *hook); /* stacked handler stuff */ int mod_perl_push_handlers(SV *self, char *hook, SV *sub, AV *handlers); SV *mod_perl_pop_handlers(SV *self, SV *hook); void *mod_perl_clear_handlers(SV *self, SV *hook); SV *mod_perl_fetch_handlers(SV *self, SV *hook); int perl_run_stacked_handlers(char *hook, request_rec *r, AV *handlers); /* plugin slots */ void perl_module_init(server_rec *s, pool *p); void perl_startup(server_rec *s, pool *p); int perl_handler(request_rec *r); void perl_child_init(server_rec *, pool *); void perl_child_exit(server_rec *, pool *); int perl_translate(request_rec *r); int perl_authenticate(request_rec *r); int perl_authorize(request_rec *r); int perl_access(request_rec *r); int perl_type_checker(request_rec *r); int perl_fixup(request_rec *r); int perl_post_read_request(request_rec *r); int perl_logger(request_rec *r); int perl_header_parser(request_rec *r); int perl_hook(char *name); int PERL_RUNNING(void); /* per-request gunk */ int mod_perl_sent_header(request_rec *r, int val); int mod_perl_seqno(SV *self, int inc); request_rec *perl_request_rec(request_rec *); void perl_setup_env(request_rec *r); SV *perl_bless_request_rec(request_rec *); void perl_set_request_rec(request_rec *); void mod_perl_cleanup_sv(void *data); void mod_perl_cleanup_handler(void *data); void mod_perl_end_cleanup(void *data); void mod_perl_register_cleanup(request_rec *r, SV *sv); void mod_perl_noop(void *data); SV *mod_perl_resolve_handler(request_rec *r, SV *sv, mod_perl_handler *h); mod_perl_handler *mod_perl_new_handler(request_rec *r, SV *sv); void mod_perl_destroy_handler(void *data); /* perl_util.c */ SV *array_header2avrv(array_header *arr); array_header *avrv2array_header(SV *avrv, pool *p); table *hvrv2table(SV *rv); void mod_perl_untaint(SV *sv); SV *mod_perl_gensym (char *pack); SV *mod_perl_slurp_filename(request_rec *r); SV *mod_perl_tie_table(table *t); SV *perl_hvrv_magic_obj(SV *rv); void perl_tie_hash(HV *hv, char *pclass, SV *sv); void perl_util_cleanup(void); void mod_perl_clear_rgy_endav(request_rec *r, SV *sv); void perl_stash_rgy_endav(char *s, SV *rgystash); void perl_run_rgy_endav(char *s); void perl_run_endav(char *s); void perl_call_halt(int status); void perl_reload_inc(server_rec *s, pool *p); I32 perl_module_is_loaded(char *name); SV *perl_module2file(char *name); int perl_require_module(char *module, server_rec *s); int perl_load_startup_script(server_rec *s, pool *p, char *script, I32 my_warn); array_header *perl_cgi_env_init(request_rec *r); #ifdef VMS void perl_clear_env(request_rec *r); #else void perl_clear_env(void); #endif void mp_magic_setenv(char *key, char *val, int is_tainted); void mod_perl_init_ids(void); int perl_eval_ok(server_rec *s); int perl_sv_is_http_code(SV *sv, int *status); void perl_incpush(char *s); SV *mod_perl_sv_name(SV *svp); void mod_perl_mark_where(char *where, SV *sub); /* perlio.c */ void perl_soak_script_output(request_rec *r); void perl_stdin2client(request_rec *r); void perl_stdout2client(request_rec *r); /* perl_config.c */ #define require_Apache(s) \ perl_require_module("Apache", s) char *mod_perl_auth_name(request_rec *r, char *val); char *mod_perl_auth_type(request_rec *r, char *val); module *perl_get_module_ptr(char *name, int len); void *perl_merge_server_config(pool *p, void *basev, void *addv); void *perl_merge_dir_config(pool *p, void *basev, void *addv); void *perl_create_dir_config(pool *p, char *dirname); void *perl_create_server_config(pool *p, server_rec *s); perl_request_config *perl_create_request_config(pool *p, server_rec *s); void perl_perl_cmd_cleanup(void *data); void perl_section_self_boot(cmd_parms *parms, void *dummy, const char *arg); void perl_clear_symtab(HV *symtab); CHAR_P perl_section (cmd_parms *cmd, void *dummy, CHAR_P arg); CHAR_P perl_end_section (cmd_parms *cmd, void *dummy); CHAR_P perl_pod_section (cmd_parms *cmd, void *dummy, CHAR_P arg); CHAR_P perl_pod_end_section (cmd_parms *cmd, void *dummy); CHAR_P perl_cmd_autoload (cmd_parms *parms, void *dummy, const char *arg); CHAR_P perl_config_END (cmd_parms *cmd, void *dummy, CHAR_P arg); CHAR_P perl_limit_section(cmd_parms *cmd, void *dummy, HV *hv); CHAR_P perl_urlsection (cmd_parms *cmd, void *dummy, HV *hv); CHAR_P perl_dirsection (cmd_parms *cmd, void *dummy, HV *hv); CHAR_P perl_filesection (cmd_parms *cmd, void *dummy, HV *hv); void perl_handle_command(cmd_parms *cmd, void *config, char *line); void perl_handle_command_hv(HV *hv, char *key, cmd_parms *cmd, void *config); void perl_handle_command_av(AV *av, I32 n, char *key, cmd_parms *cmd, void *config); void perl_tainting_set(server_rec *s, int arg); CHAR_P perl_cmd_require (cmd_parms *parms, void *dummy, char *arg); CHAR_P perl_cmd_module (cmd_parms *parms, void *dummy, char *arg); CHAR_P perl_cmd_var(cmd_parms *cmd, void *config, char *key, char *val); CHAR_P perl_cmd_setenv(cmd_parms *cmd, perl_dir_config *rec, char *key, char *val); CHAR_P perl_cmd_env (cmd_parms *cmd, perl_dir_config *rec, int arg); CHAR_P perl_cmd_pass_env (cmd_parms *parms, void *dummy, char *arg); CHAR_P perl_cmd_sendheader (cmd_parms *cmd, perl_dir_config *rec, int arg); CHAR_P perl_cmd_opmask (cmd_parms *parms, void *dummy, char *arg); CHAR_P perl_cmd_tainting (cmd_parms *parms, void *dummy, int arg); CHAR_P perl_cmd_warn (cmd_parms *parms, void *dummy, int arg); CHAR_P perl_cmd_fresh_restart (cmd_parms *parms, void *dummy, int arg); CHAR_P perl_cmd_dispatch_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_init_handlers (cmd_parms *parms, void *rec, char *arg); CHAR_P perl_cmd_cleanup_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_header_parser_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_post_read_request_handlers (cmd_parms *parms, void *dumm, char *arg); CHAR_P perl_cmd_trans_handlers (cmd_parms *parms, void *dumm, char *arg); CHAR_P perl_cmd_child_init_handlers (cmd_parms *parms, void *dumm, char *arg); CHAR_P perl_cmd_child_exit_handlers (cmd_parms *parms, void *dumm, char *arg); CHAR_P perl_cmd_restart_handlers (cmd_parms *parms, void *dumm, char *arg); CHAR_P perl_cmd_authen_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_authz_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_access_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_type_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_fixup_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_handler_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_log_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_perl_TAKE1(cmd_parms *cmd, mod_perl_perl_dir_config *d, char *one); CHAR_P perl_cmd_perl_TAKE2(cmd_parms *cmd, mod_perl_perl_dir_config *d, char *one, char *two); CHAR_P perl_cmd_perl_TAKE123(cmd_parms *cmd, mod_perl_perl_dir_config *d, char *one, char *two, char *three); CHAR_P perl_cmd_perl_FLAG(cmd_parms *cmd, mod_perl_perl_dir_config *d, int flag); #define perl_cmd_perl_RAW_ARGS perl_cmd_perl_TAKE1 #define perl_cmd_perl_NO_ARGS perl_cmd_perl_TAKE1 #define perl_cmd_perl_ITERATE perl_cmd_perl_TAKE1 #define perl_cmd_perl_ITERATE2 perl_cmd_perl_TAKE2 #define perl_cmd_perl_TAKE12 perl_cmd_perl_TAKE2 #define perl_cmd_perl_TAKE23 perl_cmd_perl_TAKE123 #define perl_cmd_perl_TAKE3 perl_cmd_perl_TAKE123 void *perl_perl_merge_dir_config(pool *p, void *basev, void *addv); void *perl_perl_merge_srv_config(pool *p, void *basev, void *addv); void mod_perl_dir_env(request_rec *r, perl_dir_config *cld); void mod_perl_pass_env(pool *p, perl_server_config *cls); #define PERL_DIR_MERGE "DIR_MERGE" #define PERL_DIR_CREATE "DIR_CREATE" #define PERL_SERVER_MERGE "SERVER_MERGE" #define PERL_SERVER_CREATE "SERVER_CREATE" #define PERL_DIR_CFG_T 0 #define PERL_SERVER_CFG_T 1 /* Apache.xs */ pool *perl_get_util_pool(void); pool *perl_get_startup_pool(void); server_rec *perl_get_startup_server(void); request_rec *sv2request_rec(SV *in, char *pclass, CV *cv); /* PerlRunXS.xs */ #define ApachePerlRun_name_with_virtualhost() \ perl_get_sv("Apache::Registry::NameWithVirtualHost", FALSE) char *mod_perl_set_opmask(request_rec *r, SV *sv); void mod_perl_init_opmask(server_rec *s, pool *p); void mod_perl_dump_opmask(void); #define dOPMask \ if(!op_mask) Newz(0, op_mask, maxo, char); \ else Zero(op_mask, maxo, char) #ifdef PERL_SAFE_STARTUP #define ENTER_SAFE(s,p) \ dOPMask; \ ENTER; \ SAVEPPTR(op_mask); \ mod_perl_init_opmask(s,p) #define LEAVE_SAFE \ Zero(op_mask, maxo, char); \ LEAVE #else #define ENTER_SAFE(s,p) #define LEAVE_SAFE #endif #ifdef JW_PERL_OBJECT #undef stderr #define stderr PerlIO_stderr() #endif +*[MOD_PERL1_25.SRC.MODULES.PERL]MOD_PERL.H;1+,F./A@ 4M- 0D123 KPWON56 )酟7⍜酟89GA@HJ N $J)g7 %J)g7J)g7.  )Z)Z)Z6/* ==================================================================== * The Apache Software License, Version 1.1 * * Copyright (c) 1996-2000 The Apache Software Foundation. All rights * reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in * the documentation and/or other materials provided with the * distribution. * * 3. The end-user documentation included with the redistribution, * if any, must include the following acknowledgment: * "This product includes software developed by the * Apache Software Foundation (http://www.apache.org/)." * Alternately, this acknowledgment may appear in the software itself, * if and wherever such third-party acknowledgments normally appear. * * 4. The names "Apache" and "Apache Software Foundation" must * not be used to endorse or promote products derived from this * software without prior written permission. For written * permission, please contact apache@apache.org. * * 5. Products derived from this software may not be called "Apache", * nor may "Apache" appear in their name, without prior written * permission of the Apache Software Foundation. * * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. * ==================================================================== */ #ifdef WIN32 #define NO_PERL_CHILD_INIT #define NO_PERL_CHILD_EXIT #ifdef JW_PERL_OBJECT #include #include #include #include #include // For O_BINARY #include "EXTERN.h" #include "perl.h" #include #else #include "dirent.h" #endif #endif #ifndef IS_MODULE #define IS_MODULE #endif #ifndef SHARED_MODULE #define SHARED_MODULE #endif #ifdef PERL_THREADS #define _INCLUDE_APACHE_FIRST #endif #ifdef _INCLUDE_APACHE_FIRST #include "apache_inc.h" #endif #include "EXTERN.h" #include "perl.h" #ifdef PERL_OBJECT #define NO_XSLOCKS #endif #include "XSUB.h" #ifndef MOD_PERL_STRING_VERSION #include "mod_perl_version.h" #endif #ifndef MOD_PERL_VERSION #define MOD_PERL_VERSION "TRUE" #endif /* patchlevel.h causes a -Wall warning, * plus chance that another patchlevel.h might be in -I paths * so try to avoid it if possible */ #ifdef PERLV #if PERLV >= 500476 #include "perl_PL.h" #endif #else #define PERL_PATCHLEVEL_H_IMPLICIT /* ignore local_patches */ #include "patchlevel.h" #undef PERL_PATCHLEVEL_H_IMPLICIT #ifndef PATCHLEVEL #define PATCHLEVEL PERL_VERSION #undef SUBVERSION #define SUBVERSION PERL_SUBVERSION #endif #if ((PATCHLEVEL >= 4) && (SUBVERSION >= 76)) || (PATCHLEVEL >= 5) #include "perl_PL.h" #endif #endif /*PERLV*/ #ifdef PERL_OBJECT #include #include "win32iop.h" #include #define PerlInterpreter CPerlHost #define perl_alloc() perl->PerlCreate() ? perl : NULL #define perl_parse(host, xsi, argc, argv, env) \ host->PerlParse(xsi, argc, argv, env); #define perl_run(host) \ host->PerlRun() #define perl_destruct(host) \ host->PerlDestroy() #define perl_free(host) #endif /* perl hides it's symbols in libperl when these macros are * expanded to Perl_foo * but some cause conflict when expanded in other headers files */ #undef S_ISREG #undef DIR #undef VOIDUSED #undef pregexec #undef pregfree #undef pregcomp #undef setregid #undef setreuid #undef sync #undef my_memcmp #undef my_bcopy #undef my_memset #undef RETURN #undef die #undef __attribute__ #ifdef pTHX_ #define PERL_IS_5_6 #endif #ifndef _INCLUDE_APACHE_FIRST #include "apache_inc.h" #endif #ifndef PERL_IS_5_6 #define pTHX_ #define aTHXo_ #define CopFILEGV(cop) cop->cop_filegv #define CopLINE(cop) cop->cop_line #define CopLINE_set(c,l) (CopLINE(c) = (l)) #define SAVECOPFILE(cop) SAVESPTR(CopFILEGV(curcop)); #define SAVECOPLINE(cop) SAVEI16(CopLINE(cop)) #endif #ifdef USE_5005THREADS #define dTHRCTX struct perl_thread *thr = PERL_GET_CONTEXT #else #define dTHRCTX #endif #ifndef dTHR #define dTHR extern int errno #endif #ifndef ERRSV #define ERRSV GvSV(errgv) #endif #ifndef ERRHV #define ERRHV GvHV(errgv) #endif #ifndef AvFILLp #define AvFILLp(av) ((XPVAV*) SvANY(av))->xav_fill #endif #ifdef eval_pv # ifndef perl_eval_pv # define perl_eval_pv eval_pv # endif #endif #ifdef eval_sv # ifndef perl_eval_sv # define perl_eval_sv eval_sv # endif #endif #define MP_EXISTS_ERROR(k) \ ERRHV && hv_exists(ERRHV, k, strlen(k)) #define MP_STORE_ERROR(k,v) \ hv_store(ERRHV, k, strlen(k), newSVsv(v), FALSE) #define MP_FETCH_ERROR(k) \ *hv_fetch(ERRHV, k, strlen(k), FALSE) #define MP_CLEAR_ERROR(k) \ (void)hv_delete(ERRHV, k, strlen(k), G_DISCARD) #ifndef PERL_AUTOPRELOAD #define PERL_AUTOPRELOAD perl_get_sv("Apache::Server::AutoPreLoad", FALSE) #endif #ifndef ERRSV_CAN_BE_HTTP # ifdef WIN32 # define ERRSV_CAN_BE_HTTP perl_get_sv("Apache::ERRSV_CAN_BE_HTTP", FALSE) # else # define ERRSV_CAN_BE_HTTP 1 # endif #endif #ifndef PERL_DESTRUCT_LEVEL #define PERL_DESTRUCT_LEVEL 0 #endif #ifndef DO_INTERNAL_REDIRECT #define DO_INTERNAL_REDIRECT perl_get_sv("Apache::DoInternalRedirect", FALSE) #endif typedef struct { table *utable; array_header *arr; table_entry *elts; int ix; } TiedTable; typedef request_rec * Apache; typedef request_rec * Apache__SubRequest; typedef conn_rec * Apache__Connection; typedef server_rec * Apache__Server; typedef cmd_parms * Apache__CmdParms; typedef TiedTable * Apache__Table; typedef table * Apache__table; typedef module * Apache__Module; typedef handler_rec * Apache__Handler; typedef command_rec * Apache__Command; #define SvCLASS(o) HvNAME(SvSTASH(SvRV(o))) #define GvHV_init(name) gv_fetchpv(name, GV_ADDMULTI, SVt_PVHV) #define GvSV_init(name) gv_fetchpv(name, GV_ADDMULTI, SVt_PV) #define GvSV_setiv(gv,val) sv_setiv(GvSV(gv), val) #define sv_is_http_code(sv) \ ((SvIOK(sv) && (SvIVX(sv) >= 100) && (SvIVX(sv) <= 600)) ? SvIVX(sv) : FALSE) #define Apache__ServerStarting(val) \ { \ GV *sgv = GvSV_init("Apache::Server::Starting"); \ GV *agv = GvSV_init("Apache::ServerStarting"); \ GvSV_setiv(sgv, val); \ GvSV(agv) = GvSV(sgv); \ } #define Apache__ServerReStarting(val) \ { \ GV *sgv = GvSV_init("Apache::Server::ReStarting"); \ GV *agv = GvSV_init("Apache::ServerReStarting"); \ GvSV_setiv(sgv, val); \ GvSV(agv) = GvSV(sgv); \ if(perl_is_running == PERL_DONE_STARTUP) \ Apache__ServerStarting((val == FALSE ? FALSE : PERL_RUNNING())); \ } #define PUSHif(arg) \ if(arg) \ XPUSHs(sv_2mortal(newSVpv(arg,0))) #define iniHV(hv) hv = (HV*)sv_2mortal((SV*)newHV()) #define iniAV(av) av = (AV*)sv_2mortal((SV*)newAV()) #define AvTRUE(av) (av && (AvFILL(av) > -1) && SvREFCNT(av)) #define av_copy_array(av) av_make(av_len(av)+1, AvARRAY(av)) #ifndef newRV_noinc #define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv) #endif #ifndef SvTAINTED_on #define SvTAINTED_on(sv) if (tainting) sv_magic(sv, Nullsv, 't', Nullch, 0) #endif #define HV_SvTAINTED_on(hv,key,klen) \ SvTAINTED_on(*hv_fetch(hv, key, klen, 0)) #if 0 #define mp_setenv(key, val) \ mp_magic_setenv(key, val, 1) #define mp_SetEnv(key, val) \ mp_magic_setenv(key, val, 0) #define mp_PassEnv(key) \ { \ char *val = getenv(key); \ mp_magic_setenv(key, val?val:"", 0); \ } #else #define mp_setenv(key, val) \ { \ int klen = strlen(key); \ SV *sv = newSVpv(val,0); \ hv_store(GvHV(envgv), key, klen, sv, FALSE); \ HV_SvTAINTED_on(GvHV(envgv), key, klen); \ my_setenv(key, SvPVX(sv)); \ } #define mp_SetEnv(key, val) \ hv_store(GvHV(envgv), key, strlen(key), newSVpv(val,0), FALSE); \ my_setenv(key, val) #define mp_PassEnv(key) \ { \ char *val = getenv(key); \ hv_store(GvHV(envgv), key, strlen(key), newSVpv(val?val:"",0), FALSE); \ } #endif #define mp_debug mod_perl_debug_flags extern U32 mp_debug; #ifdef PERL_TRACE /* -Wall */ #undef dNOOP #define dNOOP extern int __attribute__ ((unused)) Perl___notused #define MP_TRACE(a) if (mp_debug) a #define MP_TRACE_d(a) if (mp_debug & 1) a /* directives */ #define MP_TRACE_s(a) if (mp_debug & 2) a /* perl sections */ #define MP_TRACE_h(a) if (mp_debug & 4) a /* handlers */ #define MP_TRACE_g(a) if (mp_debug & 8) a /* globals and allocation */ #define MP_TRACE_c(a) if (mp_debug & 16) a /* directive handlers */ #ifndef PERL_MARK_WHERE #define PERL_MARK_WHERE #endif #ifndef PERL_TIE_SCRIPTNAME #define PERL_TIE_SCRIPTNAME #endif #else #define MP_TRACE(a) #define MP_TRACE_d(a) #define MP_TRACE_s(a) #define MP_TRACE_h(a) #define MP_TRACE_g(a) #define MP_TRACE_c(a) #endif #ifdef PERL_MARK_WHERE #define MARK_WHERE(w,s) \ ENTER; \ mod_perl_mark_where(w,s) #define UNMARK_WHERE LEAVE #else #define MARK_WHERE(w,s) mod_perl_noop(NULL) #define UNMARK_WHERE mod_perl_noop(NULL) #endif /* cut down on some noise in source */ #define PERL_IS_DSO perl_module.dynamic_load_handle #define dSTATUS \ int dstatus = DECLINED; \ int status = dstatus #define dPPREQ \ perl_request_config *cfg = (perl_request_config *)get_module_config(r->request_config, &perl_module) #define dPPDIR \ perl_dir_config *cld = (perl_dir_config *)get_module_config(r->per_dir_config, &perl_module) #define dPSRV(srv) \ perl_server_config *cls = (perl_server_config *) get_module_config (srv->module_config, &perl_module) /* per-directory flags */ #define MPf_On 1 #define MPf_Off -1 #define MPf_None 0 #define MPf_INCPUSH 0x00000100 /* use lib split ":", $ENV{PERL5LIB} */ #define MPf_SENDHDR 0x00000200 /* is PerlSendHeader On? */ #define MPf_SENTHDR 0x00000400 /* has PerlSendHeader sent the headers? */ #define MPf_ENV 0x00000800 /* PerlSetupEnv */ #define MPf_HASENV 0x00001000 /* do we have any PerlSetEnv's? */ #define MPf_DSTDERR 0x00002000 /* redirect stderr to error_log */ #define MPf_CLEANUP 0x00004000 /* did we register our cleanup ? */ #define MPf_RCLEANUP 0x00008000 /* for $r->register_cleanup */ #define MP_FMERGE(new,add,base,f) \ if((add->flags & f) || (base->flags & f)) \ new->flags |= f #define MP_INCPUSH(d) (d->flags & MPf_INCPUSH) #define MP_INCPUSH_on(d) (d->flags |= MPf_INCPUSH) #define MP_INCPUSH_off(d) (d->flags &= ~MPf_INCPUSH) #if 0 #define MP_SENDHDR(d) (d->flags & MPf_SENDHDR) #define MP_SENDHDR_on(d) (d->flags |= MPf_SENDHDR) #define MP_SENDHDR_off(d) (d->flags &= ~MPf_SENDHDR) #endif #define MP_SENDHDR(d) (d->SendHeader == MPf_On) #define MP_SENDHDR_on(d) (d->SendHeader = MPf_On) #define MP_SENDHDR_off(d) (d->SendHeader = MPf_Off) #define MP_SENTHDR(d) (d->flags & MPf_SENTHDR) #define MP_SENTHDR_on(d) (d->flags |= MPf_SENTHDR) #define MP_SENTHDR_off(d) (d->flags &= ~MPf_SENTHDR) #if 0 #define MP_ENV(d) (d->flags & MPf_ENV) #define MP_ENV_on(d) (d->flags |= MPf_ENV) #define MP_ENV_off(d) (d->flags &= ~MPf_ENV) #endif #define MP_ENV(d) (d->SetupEnv != MPf_Off) #define MP_ENV_on(d) (d->SetupEnv = MPf_On) #define MP_ENV_off(d) (d->SetupEnv = MPf_Off) #define MP_HASENV(d) (d->flags & MPf_HASENV) #define MP_HASENV_on(d) (d->flags |= MPf_HASENV) #define MP_HASENV_off(d) (d->flags &= ~MPf_HASENV) #define MP_DSTDERR(d) (d->flags & MPf_DSTDERR) #define MP_DSTDERR_on(d) (d->flags |= MPf_DSTDERR) #define MP_DSTDERR_off(d) (d->flags &= ~MPf_DSTDERR) #define MP_CLEANUP(d) (d->flags & MPf_CLEANUP) #define MP_CLEANUP_on(d) (d->flags |= MPf_CLEANUP) #define MP_CLEANUP_off(d) (d->flags &= ~MPf_CLEANUP) #define MP_RCLEANUP(d) (d->flags & MPf_RCLEANUP) #define MP_RCLEANUP_on(d) (d->flags |= MPf_RCLEANUP) #define MP_RCLEANUP_off(d) (d->flags &= ~MPf_RCLEANUP) #define PERL_GATEWAY_INTERFACE "CGI-Perl/1.1" /* Apache::SSI */ #define PERL_APACHE_SSI_TYPE "text/x-perl-server-parsed-html" /* PerlSetVar */ #ifndef NO_PERL_DIRECTIVE_HANDLERS #define PERL_DIRECTIVE_HANDLERS #endif #ifndef NO_PERL_STACKED_HANDLERS #define PERL_STACKED_HANDLERS #endif #ifndef NO_PERL_METHOD_HANDLERS #define PERL_METHOD_HANDLERS #endif #ifndef NO_PERL_SECTIONS #define PERL_SECTIONS #endif #ifndef NO_PERL_SSI #undef PERL_SSI #define PERL_SSI #endif #ifdef PERL_SECTIONS # ifndef PERL_SECTIONS_SELF_BOOT # ifdef WIN32 # define PERL_SECTIONS_SELF_BOOT \ (getenv("PERL_SECTIONS_SELF_BOOT") && !perl_sections_self_boot) #~MOD_PERL1_25_MUP.SAVEF +[MOD_PERL1_25.SRC.MODULES.PERL]MOD_PERL.H;1d else # define PERL_SECTIONS_SELF_BOOT !perl_sections_self_boot # endif # endif #endif #ifndef PERL_STARTUP_DONE_CHECK #define PERL_STARTUP_DONE_CHECK getenv("PERL_STARTUP_DONE_CHECK") #endif #define PERL_STARTUP_IS_DONE \ (!PERL_STARTUP_DONE_CHECK || strEQ(getenv("PERL_STARTUP_DONE"), "2")) #ifndef PERL_DSO_UNLOAD #define PERL_DSO_UNLOAD getenv("PERL_DSO_UNLOAD") #endif #ifdef APACHE_SSL #define PERL_DONE_STARTUP 1 #else #define PERL_DONE_STARTUP 2 #endif /* some 1.2.x/1.3.x compat stuff */ /* once 1.3.0 is here, we can toss most of this junk */ #ifdef MODULE_MAGIC_AT_LEAST #undef MODULE_MAGIC_AT_LEAST #define MODULE_MAGIC_AT_LEAST(major,minor) \ (MODULE_MAGIC_NUMBER_MAJOR >= (major) \ && MODULE_MAGIC_NUMBER_MINOR >= minor) #else #define MODULE_MAGIC_AT_LEAST(major,minor) (0 > 1) #endif #define HAS_MMN(mmn) (MODULE_MAGIC_NUMBER >= mmn) #define MMN_130 19980527 #define MMN_131 19980713 #define MMN_132 19980806 #define MMN_136 19990320 #define HAS_MMN_130 HAS_MMN(MMN_130) #define HAS_MMN_131 HAS_MMN(MMN_131) #define HAS_MMN_132 HAS_MMN(MMN_132) #define HAS_MMN_136 HAS_MMN(MMN_136) #define HAS_CONTEXT MODULE_MAGIC_AT_LEAST(MMN_136,2) #if HAS_CONTEXT #define CAN_SELF_BOOT_SECTIONS (PERL_SECTIONS_SELF_BOOT) #define SECTION_ALLOWED OR_ALL #define USABLE_CONTEXT parms->context #else #define CAN_SELF_BOOT_SECTIONS ((parms->path==NULL)&&PERL_SECTIONS_SELF_BOOT) #define SECTION_ALLOWED RSRC_CONF #define USABLE_CONTEXT parms->server->lookup_defaults #endif #define APACHE_SSL_12X (defined(APACHE_SSL) && (MODULE_MAGIC_NUMBER < MMN_130)) #if MODULE_MAGIC_NUMBER < MMN_130 #undef PERL_IS_DSO #define PERL_IS_DSO 0 #endif #if MODULE_MAGIC_NUMBER >= 19980627 #define MP_CONST_CHAR const char #define MP_CONST_ARRAY_HEADER const array_header #else #define MP_CONST_CHAR char #define MP_CONST_ARRAY_HEADER array_header #endif #if MODULE_MAGIC_NUMBER > 19970912 #define cmd_infile parms->config_file #define cmd_filename parms->config_file->name #define cmd_linenum parms->config_file->line_number #else #define cmd_infile parms->infile #define cmd_filename parms->config_file #define cmd_linenum parms->config_line #endif #ifndef DONE #define DONE -2 #endif #if MODULE_MAGIC_NUMBER >= 19980713 #include "ap_compat.h" #elif MODULE_MAGIC_NUMBER >= 19980413 #include "compat.h" #endif #if MODULE_MAGIC_NUMBER > 19970909 #define mod_perl_warn(s,msg) \ aplog_error(APLOG_MARK, APLOG_WARNING | APLOG_NOERRNO, s, "%s", msg) #define mod_perl_error(s,msg) \ aplog_error(APLOG_MARK, APLOG_ERR | APLOG_NOERRNO, s, "%s", msg) #define mod_perl_notice(s,msg) \ aplog_error(APLOG_MARK, APLOG_NOERRNO|APLOG_NOTICE, s, "%s", msg) #define mod_perl_debug(s,msg) \ aplog_error(APLOG_MARK, APLOG_NOERRNO|APLOG_DEBUG, s, "%s", msg) #define mod_perl_log_reason(msg, file, r) \ aplog_error(APLOG_MARK, APLOG_ERR | APLOG_NOERRNO, r->server, \ "access to %s failed for %s, reason: %s", \ file, \ get_remote_host(r->connection, \ r->per_dir_config, REMOTE_NAME), \ msg) #else #define mod_perl_error(s,msg) log_error(msg,s) #define mod_perl_debug mod_perl_error #define mod_perl_warn mod_perl_error #define mod_perl_notice mod_perl_error #define mod_perl_log_reason log_reason #endif #if MODULE_MAGIC_NUMBER < 19970719 #define is_initial_req(r) ((r->main == NULL) && (r->prev == NULL)) #endif #ifndef API_EXPORT #define API_EXPORT(type) type #endif #ifndef MODULE_VAR_EXPORT #define MODULE_VAR_EXPORT #endif #ifndef API_VAR_EXPORT #define API_VAR_EXPORT #endif #ifdef WIN32 #if MODULE_MAGIC_NUMBER < 19980317 #undef PERL_SECTIONS #define NO_PERL_SECTIONS #endif #include "multithread.h" extern void *mod_perl_mutex; #else #define mod_perl_mutex NULL extern void *mod_perl_dummy_mutex; #ifndef MULTITHREAD_H #define MULTI_OK (0) #undef create_mutex #undef acquire_mutex #undef release_mutex #define create_mutex(name) ((void *)mod_perl_dummy_mutex) #define acquire_mutex(mutex_id) ((int)MULTI_OK) #define release_mutex(mutex_id) ((int)MULTI_OK) #endif /* MULTITHREAD_H */ #endif /* WIN32 */ #if MODULE_MAGIC_NUMBER < 19971226 char *ap_cpystrn(char *dst, const char *src, size_t dst_size); #endif #if MODULE_MAGIC_NUMBER >= 19980304 #ifndef SERVER_BUILT #define SERVER_BUILT apapi_get_server_built() #endif #endif #define PERL_CUR_HOOK_SV \ perl_get_sv("Apache::__CurrentCallback", TRUE) #define PERL_SET_CUR_HOOK(h) \ if (r->notes) ap_table_setn(r->notes, "PERL_CUR_HOOK", h); \ else sv_setpv(PERL_CUR_HOOK_SV, h) #define PERL_GET_CUR_HOOK \ (r->notes ? \ ap_table_get(r->notes, "PERL_CUR_HOOK") : \ SvPVX(PERL_CUR_HOOK_SV)) #ifdef PERL_STACKED_HANDLERS #ifndef PERL_GET_SET_HANDLERS #define PERL_GET_SET_HANDLERS #endif #define PERL_TAKE ITERATE #define PERL_CMD_INIT Nullav #define PERL_CMD_TYPE AV #define mod_perl_can_stack_handlers(sv) (SvTRUE(sv) && 1) /* always enable child_init for perl_init_ids */ #if (MODULE_MAGIC_NUMBER >= 19970719) && !defined(WIN32) #define perl_init_ids # ifdef NO_PERL_CHILD_INIT # undef NO_PERL_CHILD_INIT # endif # ifdef NO_PERL_CHILD_EXIT # undef NO_PERL_CHILD_EXIT # endif #endif #ifndef perl_init_ids #define perl_init_ids mod_perl_init_ids() #endif #define NO_HANDLERS -666 #define PERL_CALLBACK(h,name) \ PERL_SET_CUR_HOOK(h); \ (void)acquire_mutex(mod_perl_mutex); \ if(AvTRUE(name)) { \ status = perl_run_stacked_handlers(h, r, name); \ } \ if((status != OK) && (status != DECLINED)) { \ MP_TRACE_h(fprintf(stderr, "%s handlers returned %d\n", h, status)); \ } \ else { \ dstatus = perl_run_stacked_handlers(h, r, Nullav); \ if(dstatus != NO_HANDLERS) status = dstatus; \ } \ (void)release_mutex(mod_perl_mutex); \ MP_TRACE_h(fprintf(stderr, "%s handlers returned %d\n", h, status)) #else #define PERL_TAKE TAKE1 #define PERL_CMD_INIT NULL #define PERL_CMD_TYPE char #define mod_perl_can_stack_handlers(sv) (SvTRUE(sv) && 0) #define PERL_CALLBACK(h,name) \ PERL_SET_CUR_HOOK(h); \ if(name != NULL) { \ SV *sv; \ (void)acquire_mutex(mod_perl_mutex); \ sv = newSVpv(name,0); \ MARK_WHERE(h, sv); \ dstatus = status = perl_call_handler(sv, r, Nullav); \ UNMARK_WHERE; \ SvREFCNT_dec(sv); \ (void)release_mutex(mod_perl_mutex); \ MP_TRACE_h(fprintf(stderr, "perl_call %s '%s' returned: %d\n", h,name,status)); \ } \ else { \ MP_TRACE_h(fprintf(stderr, "mod_perl: declining to handle %s, no callback defined\n", h)); \ } #endif #if MODULE_MAGIC_NUMBER >= 19961007 #define CHAR_P const char * #else #define CHAR_P char * #endif #define PUSHelt(key,val,klen) \ { \ SV *psv = (SV*)newSVpv(val, 0); \ SvTAINTED_on(psv); \ XPUSHs(sv_2mortal((SV*)newSVpv(key, klen))); \ XPUSHs(sv_2mortal((SV*)psv)); \ } /* on/off switches for callback hooks during server startup/shutdown */ #ifndef NO_PERL_DISPATCH #define PERL_DISPATCH #define PERL_DISPATCH_HOOK perl_dispatch #define PERL_DISPATCH_CMD_ENTRY \ "PerlDispatchHandler", (crft) perl_cmd_dispatch_handlers, \ NULL, \ OR_ALL, TAKE1, "the Perl Dispatch handler routine name" #define PERL_DISPATCH_CREATE(s) s->PerlDispatchHandler = NULL #else #define PERL_DISPATCH_HOOK NULL #define PERL_DISPATCH_CMD_ENTRY NULL #define PERL_DISPATCH_CREATE(s) #endif #ifndef NO_PERL_CHILD_INIT #define PERL_CHILD_INIT #define PERL_CHILD_INIT_HOOK perl_child_init #define PERL_CHILD_INIT_CMD_ENTRY \ "PerlChildInitHandler", (crft) perl_cmd_child_init_handlers, \ NULL, \ RSRC_CONF, PERL_TAKE, "the Perl Child init handler routine name" #define PERL_CHILD_INIT_CREATE(s) s->PerlChildInitHandler = PERL_CMD_INIT #else #define PERL_CHILD_INIT_HOOK NULL #define PERL_CHILD_INIT_CMD_ENTRY NULL #define PERL_CHILD_INIT_CREATE(s) #endif #ifndef NO_PERL_CHILD_EXIT #define PERL_CHILD_EXIT #define PERL_CHILD_EXIT_HOOK perl_child_exit #define PERL_CHILD_EXIT_CMD_ENTRY \ "PerlChildExitHandler", (crft) perl_cmd_child_exit_handlers, \ NULL, \ RSRC_CONF, PERL_TAKE, "the Perl Child exit handler routine name" #define PERL_CHILD_EXIT_CREATE(s) s->PerlChildExitHandler = PERL_CMD_INIT #else #define PERL_CHILD_EXIT_HOOK NULL #define PERL_CHILD_EXIT_CMD_ENTRY NULL #define PERL_CHILD_EXIT_CREATE(s) #endif #ifndef NO_PERL_RESTART #define PERL_RESTART #define PERL_RESTART_CMD_ENTRY \ "PerlRestartHandler", (crft) perl_cmd_restart_handlers, \ NULL, \ RSRC_CONF, PERL_TAKE, "the Perl Restart handler routine name" #define PERL_RESTART_CREATE(s) s->PerlRestartHandler = PERL_CMD_INIT #else #define PERL_RESTART_CMD_ENTRY NULL #define PERL_RESTART_CREATE(s) #endif /* on/off switches for callback hooks during request stages */ #if !defined(NO_PERL_TRANS) && (MODULE_MAGIC_NUMBER > 19980207) #undef NO_PERL_POST_READ_REQUEST #endif #ifndef NO_PERL_POST_READ_REQUEST #define PERL_POST_READ_REQUEST #define PERL_POST_READ_REQUEST_HOOK perl_post_read_request #define PERL_POST_READ_REQUEST_CMD_ENTRY \ "PerlPostReadRequestHandler", (crft) perl_cmd_post_read_request_handlers, \ NULL, \ RSRC_CONF, PERL_TAKE, "the Perl Post Read Request handler routine name" #define PERL_POST_READ_REQUEST_CREATE(s) s->PerlPostReadRequestHandler = PERL_CMD_INIT #else #define PERL_POST_READ_REQUEST_HOOK NULL #define PERL_POST_READ_REQUEST_CMD_ENTRY NULL #define PERL_POST_READ_REQUEST_CREATE(s) #endif #ifndef NO_PERL_TRANS #define PERL_TRANS #define PERL_TRANS_HOOK perl_translate #define PERL_TRANS_CMD_ENTRY \ "PerlTransHandler", (crft) perl_cmd_trans_handlers, \ NULL, \ RSRC_CONF, PERL_TAKE, "the Perl Translation handler routine name" #define PERL_TRANS_CREATE(s) s->PerlTransHandler = PERL_CMD_INIT #else #define PERL_TRANS_HOOK NULL #define PERL_TRANS_CMD_ENTRY NULL #define PERL_TRANS_CREATE(s) #endif #ifndef NO_PERL_AUTHEN #define PERL_AUTHEN #define PERL_AUTHEN_HOOK perl_authenticate #define PERL_AUTHEN_CMD_ENTRY \ "PerlAuthenHandler", (crft) perl_cmd_authen_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Authentication handler routine name" #define PERL_AUTHEN_CREATE(s) s->PerlAuthenHandler = PERL_CMD_INIT #else #define PERL_AUTHEN_HOOK NULL #define PERL_AUTHEN_CMD_ENTRY NULL #define PERL_AUTHEN_CREATE(s) #endif #ifndef NO_PERL_AUTHZ #define PERL_AUTHZ #define PERL_AUTHZ_HOOK perl_authorize #define PERL_AUTHZ_CMD_ENTRY \ "PerlAuthzHandler", (crft) perl_cmd_authz_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Authorization handler routine name" #define PERL_AUTHZ_CREATE(s) s->PerlAuthzHandler = PERL_CMD_INIT #else #define PERL_AUTHZ_HOOK NULL #define PERL_AUTHZ_CMD_ENTRY NULL #define PERL_AUTHZ_CREATE(s) #endif #ifndef NO_PERL_ACCESS #define PERL_ACCESS #define PERL_ACCESS_HOOK perl_access #define PERL_ACCESS_CMD_ENTRY \ "PerlAccessHandler", (crft) perl_cmd_access_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Access handler routine name" #define PERL_ACCESS_CREATE(s) s->PerlAccessHandler = PERL_CMD_INIT #else #define PERL_ACCESS_HOOK NULL #define PERL_ACCESS_CMD_ENTRY NULL #define PERL_ACCESS_CREATE(s) #endif /* un-tested hooks */ #ifndef NO_PERL_TYPE #define PERL_TYPE #define PERL_TYPE_HOOK perl_type_checker #define PERL_TYPE_CMD_ENTRY \ "PerlTypeHandler", (crft) perl_cmd_type_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Type check handler routine name" #define PERL_TYPE_CREATE(s) s->PerlTypeHandler = PERL_CMD_INIT #else #define PERL_TYPE_HOOK NULL #define PERL_TYPE_CMD_ENTRY NULL #define PERL_TYPE_CREATE(s) #endif #ifndef NO_PERL_FIXUP #define PERL_FIXUP #define PERL_FIXUP_HOOK perl_fixup #define PERL_FIXUP_CMD_ENTRY \ "PerlFixupHandler", (crft) perl_cmd_fixup_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Fixup handler routine name" #define PERL_FIXUP_CREATE(s) s->PerlFixupHandler = PERL_CMD_INIT #else #define PERL_FIXUP_HOOK NULL #define PERL_FIXUP_CMD_ENTRY NULL #define PERL_FIXUP_CREATE(s) #endif #ifndef NO_PERL_LOG #define PERL_LOG #define PERL_LOG_HOOK perl_logger #define PERL_LOG_CMD_ENTRY \ "PerlLogHandler", (crft) perl_cmd_log_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Log handler routine name" #define PERL_LOG_CREATE(s) s->PerlLogHandler = PERL_CMD_INIT #else #define PERL_LOG_HOOK NULL #define PERL_LOG_CMD_ENTRY NULL #define PERL_LOG_CREATE(s) #endif #ifndef NO_PERL_CLEANUP #define PERL_CLEANUP #define PERL_CLEANUP_HOOK perl_cleanup #define PERL_CLEANUP_CMD_ENTRY \ "PerlCleanupHandler", (crft) perl_cmd_cleanup_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Cleanup handler routine name" #define PERL_CLEANUP_CREATE(s) s->PerlCleanupHandler = PERL_CMD_INIT #else #define PERL_CLEANUP_HOOK NULL #define PERL_CLEANUP_CMD_ENTRY NULL #define PERL_CLEANUP_CREATE(s) #endif #ifndef NO_PERL_INIT #define PERL_INIT #define PERL_INIT_HOOK perl_init #define PERL_INIT_CMD_ENTRY \ "PerlInitHandler", (crft) perl_cmd_init_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Init handler routine name" #define PERL_INIT_CREATE(s) s->PerlInitHandler = PERL_CMD_INIT #else #define PERL_INIT_HOOK NULL #define PERL_INIT_CMD_ENTRY NULL #define PERL_INIT_CREATE(s) #endif #ifndef NO_PERL_HEADER_PARSER #define PERL_HEADER_PARSER #define PERL_HEADER_PARSER_HOOK perl_header_parser #define PERL_HEADER_PARSER_CMD_ENTRY \ "PerlHeaderParserHandler", (crft) perl_cmd_header_parser_handlers, \ NULL, \ OR_ALL, PERL_TAKE, "the Perl Header Parser handler routine name" #define PERL_HEADER_PARSER_CREATE(s) s->PerlHeaderParserHandler = PERL_CMD_INIT #else #define PERL_HEADER_PARSER_HOOK NULL #define PERL_HEADER_PARSER_CMD_ENTRY NULL #define PERL_HEADER_PARSER_CREATE(s) #endif typedef struct { array_header *PerlPassEnv; array_header *PerlRequire; array_header *PerlModule; int PerlTaintCheck; int PerlWarn; int FreshRestart; PERL_CMD_TYPE *PerlInitHandler; PERL_CMD_TYPE *PerlPostReadRequestHandler; PERL_CMD_TYPE *PerlTransHandler; PERL_CMD_TYPE *PerlChildInitHandler; PERL_CMD_TYPE *PerlChildExitHandler; PERL_CMD_TYPE *PerlRestartHandler; char *PerlOpmask; table *vars; } perl_server_config; typedef struct { char *PerlDispatchHandler; PERL_CMD_TYPE *PerlHandler; PERL_CMD_TYPE *PerlAuthenHandler; PERL_CMD_TYPE *PerlAuthzHandler; PERL_CMD_TYPE *PerlAccessHandler; PERL_CMD_TYPE *PerlTypeHandler; PERL_CMD_TYPE *PerlFixupHandler; PERL_CMD_TYPE *PerlLogHandler; PERL_CMD_TYPE *PerlCleanupHandler; PERL_CMD_TYPE *PerlHeaderParserHandler; PERL_CMD_TYPE *PerlInitHandler; table *env; table *vars; U32 flags; int SendHeader; int SetupEnv; char *location; } perl_dir_config; typedef struct { Sighandler_t h; I32 signo; } perl_request_sigsave; typedef struct { HV *pnotes; int setup_env; array_header *sigsave; } perl_request_config; typedef struct { int is_method; int is_anon; int in_perl; SV *pclass; char *method; } mod_perl_handler; typedef struct { SV *obj; char *pclass; } mod_perl_perl_dir_config; typedef struct { char *subname; char *info; } mod_perl_cmd_info; extern module MODULE_VAR_EXPORT perl_module; /* a couple for -Wall sanity sake */ int translate_name (request_rec *); int log_transaction (request_rec *r); /* mod_perl prototypes */ /* perlxsi.c */ #ifdef aTHX_ void xs_init (pTHX); #else void xs_init (void); #endif /* mod_perl.c */ /* generic handler stuff */ int perl_handler_ismethod(HV *pclass, char *sub); int perl_call_handler(SV *sv, request_rec *r, AV *args); request_rec *mp_fake_request_rec(server_rec *s, pool *p, char *hook); /* stacked handler stuff */ int mod_perl_push_handlers(SV *self, char *hook, SV *sub, AV *handlers); SV *mod_perl_pop_handlers(SV *self, SV *hook); void *mod_perl_clear_handlers(SV *self, SV *hook); SV *mod_perl_fetch_handlers(SV *self, SV *hook); int perl_run_stacked_handlers(char *hook, request_rec *r, AV *handlers); /* plugin slots */ void perl_module_init(server_rec *s, pool *p); void perl_startup(server_rec *s, pool *p); int perl_handler(request_rec *r); void perl_child_init(server_rec *, pool *); void perl_child_exit(server_rec *, pool *); int perl_translate(request_rec *r); int perl_authenticate(request_rec *r); int perl_authorize(request_rec *r); int perl_access(request_rec *r); int perl_type_checker(request_rec *r); int perl_fixup(request_rec *r); int perl_post_read_request(request_rec *r); int perl_logger(request_rec *r); int perl_header_parser(request_rec *r); int perl_hook(char *name); int PERL_RUNNING(void); /* per-request gunk */ int mod_perl_sent_header(request_rec *r, int val); int mod_perl_seqno(SV *self, int inc); request_rec *perl_request_rec(request_rec *); void perl_setup_env(request_rec *r); SV *perl_bless_request_rec(request_rec *); void perl_set_request_rec(request_rec *); void mod_perl_cleanup_sv(void *data); void mod_perl_cleanup_handler(void *data); void mod_perl_end_cleanup(void *data); void mod_perl_register_cleanup(request_rec *r, SV *sv); void mod_perl_noop(void *data); SV *mod_perl_resolve_handler(request_rec *r, SV *sv, mod_perl_handler *h); mod_perl_handler *mod_perl_new_handler(request_rec *r, SV *sv); void mod_perl_destroy_handler(void *data); /* perl_util.c */ SV *array_header2avrv(array_header *arr); array_header *avrv2array_header(SV *avrv, pool *p); table *hvrv2table(SV *rv); void mod_perl_untaint(SV *sv); SV *mod_perl_gensym (char *pack); SV *mod_perl_slurp_filename(request_rec *r); SV *mod_perl_tie_table(table *t); SV *perl_hvrv_magic_obj(SV *rv); void perl_tie_hash(HV *hv, char *pclass, SV *sv); void perl_util_cleanup(void); void mod_perl_clear_rgy_endav(request_rec *r, SV *sv); void perl_stash_rgy_endav(char *s, SV *rgystash); void perl_run_rgy_endav(char *s); void perl_run_endav(char *s); void perl_call_halt(int status); void perl_reload_inc(server_rec *s, pool *p); I32 perl_module_is_loaded(char *name); SV *perl_module2file(char *name); int perl_require_module(char *module, server_rec *s); int perl_load_startup_script(server_rec *s, pool *p, char *script, I32 my_warn); array_header *perl_cgi_env_init(request_rec *r); void perl_clear_env(void); void mp_magic_setenv(char *key, char *val, int is_tainted); void mod_perl_init_ids(void); int perl_eval_ok(server_rec *s); int perl_sv_is_http_code(SV *sv, int *status); void perl_incpush(char *s); SV *mod_perl_sv_name(SV *svp); void mod_perl_mark_where(char *where, SV *sub); /* perlio.c */ void perl_soak_script_output(request_rec *r); void perl_stdin2client(request_rec *r); void perl_stdout2client(request_rec *r); /* perl_config.c */ #define require_Apache(s) \ perl_require_module("Apache", s) char *mod_perl_auth_name(request_rec *r, char *val); char *mod_perl_auth_type(request_rec *r, char *val); module *perl_get_module_ptr(char *name, int len); void *perl_merge_server_config(pool *p, void *basev, void *addv); void *perl_merge_dir_config(pool *p, void *basev, void *addv); void *perl_create_dir_config(pool *p, char *dirname); void *perl_create_server_config(pool *p, server_rec *s); perl_request_config *perl_create_request_config(pool *p, server_rec *s); void perl_perl_cmd_cleanup(void *data); void perl_section_self_boot(cmd_parms *parms, void *dummy, const char *arg); void perl_clear_symtab(HV *symtab); CHAR_P perl_section (cmd_parms *cmd, void *dummy, CHAR_P arg); CHAR_P perl_end_section (cmd_parms *cmd, void *dummy); CHAR_P perl_pod_section (cmd_parms *cmd, void *dummy, CHAR_P arg); CHAR_P perl_pod_end_section (cmd_parms *cmd, void *dummy); CHAR_P perl_cmd_autoload (cmd_parms *parms, void *dummy, const char *arg); CHAR_P perl_config_END (cmd_parms *cmd, void *dummy, CHAR_P arg); CHAR_P perl_limit_section(cmd_parms *cmd, void *dummy, HV *hv); CHAR_P perl_urlsection (cmd_parms *cmd, void *dummy, HV *hv); CHAR_P perl_dirsection (cmd_parms *cmd, void *dummy, HV *hv); CHAR_P perl_filesection (cmd_parms *cmd, void *dummy, HV *hv); void perl_handle_command(cmd_parms *cmd, void *config, char *line); void perl_handle_command_hv(HV *hv, char *key, cmd_parms *cmd, void *config); void perl_handle_command_av(AV *av, I32 n, char *key, cmd_parms *cmd, void *config); void perl_tainting_set(server_rec *s, int arg); CHAR_P perl_cmd_require (cmd_parms *parms, void *dummy, char *arg); CHAR_P perl_cmd_module (cmd_parms *parms, void *dummy, char *arg); CHAR_P perl_cmd_var(cmd_parms *cmd, void *config, char *key, char *val); CHAR_P perl_cmd_setenv(cmd_parms *cmd, perl_dir_config *rec, char *key, char *val); CHAR_P perl_cmd_env (cmd_parms *cmd, perl_dir_config *rec, int arg); CHAR_P perl_cmd_pass_env (cmd_parms *parms, void *dummy, char *arg); CHAR_P perl_cmd_sendheader (cmd_parms *cmd, perl_dir_config *rec, int arg); CHAR_P perl_cmd_opmask (cmd_parms *parms, void *dummy, char *arg); CHAR_P perl_cmd_tainting (cmd_parms *parms, void *dummy, int arg); CHAR_P perl_cmd_warn (cmd_parms *parms, void *dummy, int arg); CHAR_P perl_cmd_fresh_restart (cmd_parms *parms, void *dummy, int arg); CHAR_P perl_cmd_dispatch_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_init_handlers (cmd_parms *parms, void *rec, char *arg); CHAR_P perl_cmd_cleanup_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_header_parser_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_post_read_request_handlers (cmd_parms *parms, void *dumm, char *arg); CHAR_P perl_cmd_trans_handlers (cmd_parms *parms, void *dumm, char *arg); CHAR_P perl_cmd_child_init_handlers (cmd_parms *parms, void *dumm, char *arg); CHAR_P perl_cmd_child_exit_handlers (cmd_parms *parms, void *dumm, char *arg); CHAR_P perl_cmd_restart_handlers (cmd_parms *parms, void *dumm, char *arg); CHAR_P perl_cmd_authen_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_authz_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_access_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_type_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_fixup_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_handler_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_log_handlers (cmd_parms *parms, perl_dir_config *rec, char *arg); CHAR_P perl_cmd_perl_TAKE1(cmd_parms *cmd, mod_perl_perl_dir_config *d, char *one); CHAR_P perl_cmd_perl_TAKE2(cmd_parms *cmd, mod_perl_perl_dir_config *d, char *one, char *two); CHAR_P perl_cmd_perl_TAKE123(cmd_parms *cmd, mod_perl_perl_dir_config *d, char *one, char *two, char *three); CHAR_P perl_cmd_perl_FLAG(cmd_parms *cmd, mod_perl_perl_dir_config *d, int flag); #define perl_cmd_perl_RAW_ARGS perl_cmd_perl_TAKE1 #define perl_cmd_perl_NO_ARGS perl_cmd_perl_TAKE1 #define perl_cmd_perl_ITERATE perl_cmd_perl_TAKE1 #define perl_cmd_perl_ITERATE2 perl_cmd_perl_TAKE2 #define perl_cmd_perl_TAKE12 perl_cmd_perl_TAKE2 #define perl_cmd_perl_TAKE23 perl_cmd_perl_TAKE123 #define perl_cmd_perl_TAKE3 perl_cmd_perl_TAKE123 void *perl_perl_merge_dir_config(pool *p, void *basev, void *addv); void *perl_perl_merge_srv_config(pool *p, void *basev, void *addv); void mod_perl_dir_env(request_rec *r, perl_dir_config *cld); void mod_perl_pass_env(pool *p, perl_server_config *cls); #define PERL_DIR_MERGE "DIR_MERGE" #define PERL_DIR_CREATE "DIR_CREATE" #define PERL_SERVER_MERGE "SERVER_MERGE" #define PERL_SERVER_CREATE "SERVER_CREATE" #define PERL_DIR_CFG_T 0 #define PERL_SERVER_CFG_T 1 /* Apache.xs */ pool *perl_get_util_pool(void); pool *perl_get_startup_pool(void); server_rec *perl_get_startup_server(void); request_rec *sv2request_rec(SV *in, char *pclass, CV *cv); /* PerlRunXS.xs */ #define ApachePerlRun_name_with_virtualhost() \ perl_get_sv("Apache::Registry::NameWithVirtualHost", FALSE) char *mod_perl_set_opmask(request_rec *r, SV *sv); void mod_perl_init_opmask(server_rec *s, pool *p); void mod_perl_dump_opmask(void); #define dOPMask \ if(!op_mask) Newz(0, op_mask, maxo, char); \ else Zero(op_mask, maxo, char) #ifdef PERL_SAFE_STARTUP #define ENTER_SAFE(s,p) \ dOPMask; \ ENTER; \ SAVEPPTR(op_mask); \ mod_perl_init_opmask(s,p) #define LEAVE_SAFE \ Zero(op_mask, maxo, char); \ LEAVE #else #define ENTER_SAFE(s,p) #define LEAVE_SAFE #endif #ifdef JW_PERL_OBJECT #undef stderr #define stderr PerlIO_stderr() #endif -*[MOD_PERL1_25.SRC.MODULES.PERL]MOD_PERL.OPT;1+,^.E/A@ 44EX- 0123KPWO56i𭊟7鐟89GA@HJmod_perl.olb/lib perlshr/share4apache$root:[000000]APACHE$HTTPD_SHR.EXE_ALPHA/share1*[MOD_PERL1_25.SRC.MODULES.PERL]MOD_PERL_BLD.OPT;1+,_.E/A@ 44E- 0123KPWO56&@e7Le89GA@HJNAME=MODPERL_SHRIDENTIFICATION="Mod_Perl 1.25"GSMATCH=LEQUAL,1,1CASE_SENSITIVE=NO+SYMBOL_VECTOR=(ARRAY_HEADER2AVRV=PROCEDURE)+SYMBOL_VECTOR=(AVRV2ARRAY_HEADER=PROCEDURE)(SYMBOL_VECTOR=(SV2REQUEST_REC=PROCEDURE)$SYMBOL_VECTOR=(HVRV2TABLE=PROCEDURE),SYMBOL_VECTOR=(MOD_PERL_AUTH_NAME=PROCEDURE),SYMBOL_VECTOR=(MOD_PERL_AUTH_TYPE=PROCEDURE)2SYMBOL_VECTOR=(MOD_PERL_CLEAR_RGY_ENDAV=PROCEDURE))SYMBOL_VECTOR=(MOD_PERL_GENSYM=PROCEDURE)'SYMBOL_VECTOR=(MOD_PERL_NOOP=PROCEDURE)0SYMBOL_VECTOR=(MOD_PERL_PUSH_HANDLERS=PROCEDURE)3SYMBOL_VECTOR=(MOD_PERL_REGISTER_CLEANUP=PROCEDURE).SYMBOL_VECTOR=(MOD_PERL_SENT_HEADER=PROCEDURE)(SYMBOL_VECTOR=(MOD_PERL_SEQNO=PROCEDURE)-SYMBOL_VECTOR=(MOD_PERL_SET_OPMASK=PROCEDURE)1SYMBOL_VECTOR=(MOD_PERL_SLURP_FILENAME=PROCEDURE),SYMBOL_VECTOR=(MOD_PERL_TIE_TABLE=PROCEDURE)*SYMBOL_VECTOR=(MOD_PERL_UNTAINT=PROCEDURE)-SYMBOL_VECTOR=(MP_FAKE_REQUEST_REC=PROCEDURE)0SYMBOL_VECTOR=(PERL_BLESS_REQUEST_REC=PROCEDURE)(SYMBOL_VECTOR=(PERL_CALL_HALT=PROCEDURE)+SYMBOL_VECTOR=(PERL_CALL_HANDLER=PROCEDURE)+SYMBOL_VECTOR=(PERL_CGI_ENV_INIT=PROCEDURE)-SYMBOL_VECTOR=(PERL_GET_MODULE_PTR=PROCEDURE)/SYMBOL_VECTOR=(PERL_GET_STARTUP_POOL=PROCEDURE)1SYMBOL_VECTOR=(PERL_GET_STARTUP_SERVER=PROCEDURE),SYMBOL_VECTOR=(PERL_GET_UTIL_POOL=PROCEDURE)#SYMBOL_VECTOR=(PERL_HOOK=PROCEDURE)/SYMBOL_VECTOR=(PERL_MODULE_IS_LOADED=PROCEDURE)*SYMBOL_VECTOR=(PERL_REQUEST_REC=PROCEDURE)-SYMBOL_VECTOR=(PERL_REQUIRE_MODULE=PROCEDURE)&SYMBOL_VECTOR=(PERL_RUNNING=PROCEDURE)1SYMBOL_VECTOR=(PERL_SOAK_SCRIPT_OUTPUT=PROCEDURE).SYMBOL_VECTOR=(PERL_STASH_RGY_ENDAV=PROCEDURE) SYMBOL_VECTOR=(PERL_MODULE=DATA))SYMBOL_VECTOR=(MOD_PERL_DEBUG_FLAGS=DATA)mod_perl.olb/lib perlshr/share4apache$root:[000000]APACHE$HTTPD_SHR.EXE_ALPHA/share,*[MOD_PERL1_25.SRC.MODULES.PERL]PERL_UTIL.C;2+,\.E/A@ 4TE.- 0D123KPWO/56z˟7z89GA@HJN $J)g7 %J)g7J)g7 /* ==================================================================== * The Apache Software License, Version 1.1 * * Copyright (c) 1996-2000 The Apache Software Foundation. All rights * reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in * the documentation and/or other materials provided with the * distribution. * * 3. The end-user documentation included with the redistribution, * if any, must include the following acknowledgment: * "This product includes software developed by the * Apache Software Foundation (http://www.apache.org/)." * Alternately, this acknowledgment may appear in the software itself, * if and wherever such third-party acknowledgments normally appear. * * 4. The names "Apache" and "Apache Software Foundation" must * not be used to endorse or promote products derived from this * software without prior written permission. For written * permission, please contact apache@apache.org. * * 5. Products derived from this software may not be called "Apache", * nor may "Apache" appear in their name, without prior written * permission of the Apache Software Foundation. * * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. * ==================================================================== * * Modified by: * * 25-May-2001 Scott LePage * Incorporated changes to environment cleanup that we ~p~MOD_PERL1_25_MUP.SAVE\ ,[MOD_PERL1_25.SRC.MODULES.PERL]PERL_UTIL.C;2TERre * originally coded in V1.21 Mod_Perl. See '#ifdef VMS' sections. */ #include "mod_perl.h" static HV *mod_perl_endhv = Nullhv; static int set_ids = 0; void perl_util_cleanup(void) { hv_undef(mod_perl_endhv); SvREFCNT_dec((SV*)mod_perl_endhv); mod_perl_endhv = Nullhv; set_ids = 0; } SV *array_header2avrv(array_header *arr) { AV *av; int i; dTHR; iniAV(av); if(arr) { for (i = 0; i < arr->nelts; i++) { av_push(av, newSVpv(((char **) arr->elts)[i], 0)); } } return newRV_noinc((SV*)av); } array_header *avrv2array_header(SV *avrv, pool *p) { AV *av = (AV*)SvRV(avrv); I32 i; array_header *arr = make_array(p, AvFILL(av)-1, sizeof(char *)); for(i=0; i<=AvFILL(av); i++) { SV *sv = *av_fetch(av, i, FALSE); char **entry = (char **) push_array(arr); *entry = pstrdup(p, SvPV(sv,na)); } return arr; } table *hvrv2table(SV *rv) { if(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV) { SV *sv = perl_hvrv_magic_obj(rv); if(!sv) croak("HV is not magic!"); return (table *)SvIV((SV*)SvRV(sv)); } return (table *)SvIV((SV*)SvRV(rv)); } static char *r_keys[] = { "_r", "r", NULL }; static request_rec *r_magic_get(SV *sv) { MAGIC *mg = mg_find(sv, '~'); return mg ? (request_rec *)mg->mg_ptr : NULL; } request_rec *sv2request_rec(SV *in, char *pclass, CV *cv) { request_rec *r = NULL; SV *sv = Nullsv; if(in == &sv_undef) return NULL; if(SvROK(in) && (SvTYPE(SvRV(in)) == SVt_PVHV)) { int i; for (i=0; r_keys[i]; i++) { int klen = strlen(r_keys[i]); if(hv_exists((HV*)SvRV(in), r_keys[i], klen) && (sv = *hv_fetch((HV*)SvRV(in), r_keys[i], klen, FALSE))) { if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) { /* dig deeper */ return sv2request_rec(sv, pclass, cv); } break; } } if(!sv) croak("method `%s' invoked by a `%s' object with no `r' key!", GvNAME(CvGV(cv)), HvNAME(SvSTASH(SvRV(in)))); } if(!sv) sv = in; if(SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG)) { if(sv_derived_from(sv, pclass)) { if((r = r_magic_get(SvRV(sv)))) { /* ~ magic */ } else { r = (request_rec *) SvIV((SV*)SvRV(sv)); } } else { return NULL; } } else if((r = perl_request_rec(NULL))) { /*ok*/ } else { croak("Apache->%s called without setting Apache->request!", GvNAME(CvGV(cv))); } return r; } pool *perl_get_util_pool(void) { request_rec *r = NULL; if((r = perl_request_rec(NULL))) return r->pool; else return perl_get_startup_pool(); return NULL; } pool *perl_get_startup_pool(void) { SV *sv = perl_get_sv("Apache::__POOL", FALSE); if(sv) { IV tmp = SvIV((SV*)SvRV(sv)); return (pool *)tmp; } return NULL; } server_rec *perl_get_startup_server(void) { SV *sv = perl_get_sv("Apache::__SERVER", FALSE); if(sv) { IV tmp = SvIV((SV*)SvRV(sv)); return (server_rec *)tmp; } return NULL; } void mod_perl_untaint(SV *sv) { if(!tainting) return; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); if (mg) mg->mg_len &= ~1; } } /* same as Symbol::gensym() */ SV *mod_perl_gensym (char *pack) { GV *gv = newGVgen(pack); SV *rv = newRV((SV*)gv); (void)hv_delete(gv_stashpv(pack, TRUE), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); return rv; } SV *mod_perl_slurp_filename(request_rec *r) { dTHR; PerlIO *fp; SV *insv; ENTER; save_item(rs); sv_setsv(rs, &sv_undef); fp = PerlIO_open(r->filename, "r"); insv = newSV(r->finfo.st_size); sv_gets(insv, fp, 0); /*slurp*/ PerlIO_close(fp); LEAVE; return newRV_noinc(insv); } SV *mod_perl_tie_table(table *t) { HV *hv = newHV(); SV *sv = sv_newmortal(); sv_setref_pv(sv, "Apache::table", (void*)t); perl_tie_hash(hv, "Apache::Table", sv); return sv_bless(sv_2mortal(newRV_noinc((SV*)hv)), gv_stashpv("Apache::Table", TRUE)); } SV *perl_hvrv_magic_obj(SV *rv) { HV *hv = (HV*)SvRV(rv); MAGIC *mg; if(SvMAGICAL(hv) && (mg = mg_find((SV*)hv, 'P'))) return mg->mg_obj; else return Nullsv; } void perl_tie_hash(HV *hv, char *pclass, SV *sv) { dSP; SV *obj, *varsv = (SV*)hv; char *methname = "TIEHASH"; dTHRCTX; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSVpv(pclass,0))); if(sv) XPUSHs(sv); PUTBACK; perl_call_method(methname, G_EVAL | G_SCALAR); if(SvTRUE(ERRSV)) warn("perl_tie_hash: %s", SvPV(ERRSV,na)); SPAGAIN; obj = POPs; sv_unmagic(varsv, 'P'); sv_magic(varsv, obj, 'P', Nullch, 0); PUTBACK; FREETMPS; LEAVE; } /* execute END blocks */ void perl_run_blocks(I32 oldscope, AV *subs) { STRLEN len; I32 i; dTHR; dTHRCTX; for(i=0; i<=AvFILL(subs); i++) { CV *cv = (CV*)*av_fetch(subs, i, FALSE); SV* atsv = ERRSV; MARK_WHERE("END block", (SV*)cv); PUSHMARK(stack_sp); perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); UNMARK_WHERE; (void)SvPV(atsv, len); if (len) { if (subs == beginav) sv_catpv(atsv, "BEGIN failed--compilation aborted"); else sv_catpv(atsv, "END failed--cleanup aborted"); while (scopestack_ix > oldscope) LEAVE; } } } void mod_perl_clear_rgy_endav(request_rec *r, SV *sv) { STRLEN klen; char *key; if(!mod_perl_endhv) return; key = SvPV(sv,klen); if(hv_exists(mod_perl_endhv, key, klen)) { SV *entry = *hv_fetch(mod_perl_endhv, key, klen, FALSE); AV *av; if(!SvTRUE(entry) && !SvROK(entry)) { MP_TRACE_g(fprintf(stderr, "endav is empty for %s\n", r->uri)); return; } av = (AV*)SvRV(entry); av_clear(av); SvREFCNT_dec((SV*)av); (void)hv_delete(mod_perl_endhv, key, klen, G_DISCARD); MP_TRACE_g(fprintf(stderr, "clearing END blocks for package `%s' (uri=%s)\n", key, r->uri)); } } void perl_stash_rgy_endav(char *s, SV *rgystash) { AV *rgyendav = Nullav; STRLEN klen; char *key; dTHR; if(!rgystash) rgystash = perl_get_sv("Apache::Registry::curstash", FALSE); if(!rgystash || !SvTRUE(rgystash)) { MP_TRACE_g(fprintf(stderr, "Apache::Registry::curstash not set, can't stash END blocks for %s\n", s)); return; } key = SvPV(rgystash,klen); if(mod_perl_endhv == Nullhv) mod_perl_endhv = newHV(); else if(hv_exists(mod_perl_endhv, key, klen)) { SV *entry = *hv_fetch(mod_perl_endhv, key, klen, FALSE); if(SvTRUE(entry) && SvROK(entry)) rgyendav = (AV*)SvRV(entry); } if(endav) { I32 i; if(rgyendav == Nullav) rgyendav = newAV(); if(AvFILL(rgyendav) > -1) av_clear(rgyendav); else av_extend(rgyendav, AvFILL(endav)); for(i=0; i<=AvFILL(endav); i++) { SV **svp = av_fetch(endav, i, FALSE); av_store(rgyendav, i, (SV*)newRV((SV*)*svp)); } } if(rgyendav) hv_store(mod_perl_endhv, key, klen, (SV*)newRV((SV*)rgyendav), FALSE); } void perl_run_rgy_endav(char *s) { SV *rgystash = perl_get_sv("Apache::Registry::curstash", FALSE); AV *rgyendav = Nullav; STRLEN klen; char *key; dTHR; if(!rgystash || !SvTRUE(rgystash)) { MP_TRACE_g(fprintf(stderr, "Apache::Registry::curstash not set, can't run END blocks for %s\n", s)); return; } key = SvPV(rgystash,klen); if(hv_exists(mod_perl_endhv, key, klen)) { SV *entry = *hv_fetch(mod_perl_endhv, key, klen, FALSE); if(SvTRUE(entry) && SvROK(entry)) rgyendav = (AV*)SvRV(entry); } MP_TRACE_g(fprintf(stderr, "running %d END blocks for %s\n", rgyendav ? (int)AvFILL(rgyendav)+1 : 0, s)); ENTER; save_aptr(&endav); if((endav = rgyendav)) perl_run_blocks(scopestack_ix, endav); LEAVE; sv_setpv(rgystash,""); } void perl_run_endav(char *s) { dTHR; I32 n = 0; if(endav) n = AvFILL(endav)+1; MP_TRACE_g(fprintf(stderr, "running %d END blocks for %s\n", (int)n, s)); if(endav) { curstash = defstash; call_list(scopestack_ix, endav); } } static I32 errgv_empty_set(IV ix, SV* sv) { sv_setsv(sv, &sv_no); return TRUE; } void perl_call_halt(int status) { dTHR; struct ufuncs umg; int is_http_code = ((status >= 100) && (status < 600) && ERRSV_CAN_BE_HTTP); dTHRCTX; umg.uf_val = errgv_empty_set; umg.uf_set = errgv_empty_set; umg.uf_index = (IV)0; if(is_http_code) { croak("%d\n", status); } else { sv_magic(ERRSV, Nullsv, 'U', (char*) &umg, sizeof(umg)); ENTER; SAVESPTR(diehook); diehook = Nullsv; croak(""); LEAVE; /* we don't get this far, but croak() will rewind */ sv_unmagic(ERRSV, 'U'); } } /* * reload %INC: cannot do so while iterating over %INC incase * reloaded modules modify %INC at the file-scope * this approach also preserves order for modules loaded via PerlModule */ void perl_reload_inc(server_rec *s, pool *sp) { dPSRV(s); HV *hash = GvHV(incgv); HE *entry; I32 old_warn = dowarn; pool *p = ap_make_sub_pool(sp); table *reload = ap_make_table(p, HvKEYS(hash)); char **entries; int i = 0; dowarn = FALSE; entries = (char **)cls->PerlModule->elts; for (i=0; i < cls->PerlModule->nelts; i++) { SV *file = perl_module2file(entries[i]); ap_table_set(reload, SvPVX(file), "1"); SvREFCNT_dec(file); } hv_iterinit(hash); while ((entry = hv_iternext(hash))) { ap_table_setn(reload, HeKEY(entry), "1"); } { array_header *arr = ap_table_elts(reload); table_entry *elts = (table_entry *)arr->elts; SV *keysv = newSV(0); for (i=0; i < arr->nelts; i++) { sv_setpv(keysv, elts[i].key); if (!(entry = hv_fetch_ent(hash, keysv, FALSE, 0))) { MP_TRACE_g(fprintf(stderr, "%s not found in %%INC\n", elts[i].key)); continue; } SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = &sv_undef; MP_TRACE_g(fprintf(stderr, "reloading %s\n", HeKEY(entry))); perl_require_pv(HeKEY(entry)); } SvREFCNT_dec(keysv); } dowarn = old_warn; ap_destroy_pool(p); } I32 perl_module_is_loaded(char *name) { I32 retval = FALSE; SV *key = perl_module2file(name); if((key && hv_exists_ent(GvHV(incgv), key, FALSE))) retval = TRUE; if(key) SvREFCNT_dec(key); return retval; } SV *perl_module2file(char *name) { SV *sv = newSVpv(name,0); char *s; for (s = SvPVX(sv); *s; s++) { if (*s == ':' && s[1] == ':') { *s = '/'; Move(s+2, s+1, strlen(s+2)+1, char); --SvCUR(sv); } } sv_catpvn(sv, ".pm", 3); return sv; } int perl_require_module(char *name, server_rec *s) { dTHR; SV *sv = sv_newmortal(); dTHRCTX; sv_setpvn(sv, "require ", 8); MP_TRACE_d(fprintf(stderr, "loading perl module '%s'...", name)); sv_catpv(sv, name); perl_eval_sv(sv, G_DISCARD); if(s) { if(perl_eval_ok(s) != OK) { MP_TRACE_d(fprintf(stderr, "not ok\n")); return -1; } } else if(SvTRUE(ERRSV)) { MP_TRACE_d(fprintf(stderr, "not ok\n")); return -1; } MP_TRACE_d(fprintf(stderr, "ok\n")); return 0; } void perl_do_file(char *pv) { SV* sv = sv_newmortal(); sv_setpv(sv, "require '"); sv_catpv(sv, pv); sv_catpv(sv, "'"); perl_eval_sv(sv, G_DISCARD); /*(void)hv_delete(GvHV(incgv), pv, strlen(pv), G_DISCARD);*/ } int perl_load_startup_script(server_rec *s, pool *p, char *script, I32 my_warn) { dTHR; I32 old_warn = dowarn; if(!script) { MP_TRACE_d(fprintf(stderr, "no Perl script to load\n")); return OK; } MP_TRACE_d(fprintf(stderr, "attempting to require `%s'\n", script)); dowarn = my_warn; curstash = defstash; perl_do_file(script); dowarn = old_warn; return perl_eval_ok(s); } void mp_magic_setenv(char *key, char *val, int is_tainted) { int klen = strlen(key); SV **ptr = hv_fetch(GvHV(envgv), key, klen, TRUE); if (ptr) { SvSetMagicSV(*ptr, newSVpv(val,0)); if (is_tainted) { SvTAINTED_on(*ptr); } } } array_header *perl_cgi_env_init(request_rec *r) { table *envtab = r->subprocess_env; char *tz = NULL; add_common_vars(r); add_cgi_vars(r); if (!table_get(envtab, "TZ")) { if ((tz = getenv("TZ")) != NULL) { table_set(envtab, "TZ", tz); } } if (!table_get(envtab, "PATH")) { table_set(envtab, "PATH", DEFAULT_PATH); } table_set(envtab, "GATEWAY_INTERFACE", PERL_GATEWAY_INTERFACE); return table_elts(envtab); } #define untie_env sv_unmagic((SV*)GvHV(envgv), 'E') #define tie_env sv_magic((SV*)GvHV(envgv), (SV*)envgv, 'E', Nullch, 0) #define delete_env(ken, klen) \ (void)hv_delete(GvHV(envgv), key, klen, G_DISCARD) #ifdef VMS void perl_clear_env(request_rec *r) #else void perl_clear_env(void) #endif { char *key; I32 klen; SV *val; HV *hv = (HV*)GvHV(envgv); #ifdef VMS table *e; if (r != NULL) e = r->subprocess_env; #endif untie_env; if(!hv_exists(hv, "MOD_PERL", 8)) { hv_store(hv, "MOD_PERL", 8, newSVpv(MOD_PERL_STRING_VERSION,0), FALSE); hv_store(hv, "GATEWAY_INTERFACE", 17, newSVpv("CGI-Perl/1.1",0), FALSE); } (void)hv_iterinit(hv); while ((val = hv_iternextsv(hv, (char **) &key, &klen))) { if((*key == 'G') && strEQ(key, "GATEWAY_INTERFACE")) continue; else if((*key == 'M') && strnEQ(key, "MOD_PERL", 8)) continue; else if((*key == 'T') && strnEQ(key, "TZ", 2)) continue; else if((*key == 'P') && strEQ(key, "PATH")) continue; #ifdef VMS else if(strEQ(key, "VAXC$PATH")) { delete_env(key, klen); continue; } else if (strnEQ(key, "APACHE$", 7)) { delete_env(key, klen); continue; } else if (strnEQ(key, "APACHE_", 7)) { delete_env(key, klen); continue; } #endif else if((*key == 'H') && strnEQ(key, "HTTP_", 5)) { tie_env; delete_env(key, klen); #ifdef VMS if (r != NULL) { if (!ap_table_get(e, key)) { my_setenv(key, NULL); } } #endif untie_env; continue; } delete_env(key, klen); #ifdef VMS if (r != NULL) { my_setenv(key, NULL); } #endif } tie_env; } void mod_perl_init_ids(void) /* $$, $>, $), etc */ { if(set_ids++) return; sv_setiv(GvSV(gv_fetchpv("$", TRUE, SVt_PV)), (I32)getpid()); #ifndef WIN32 uid = (int)getuid(); euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); MP_TRACE_g(fprintf(stderr, "perl_init_ids: uid=%d, euid=%d, gid=%d, egid=%d\n", uid, euid, gid, egid)); #endif } int perl_eval_ok(server_rec *s) { int status; SV *sv; dTHR; dTHRCTX; sv = ERRSV; if (SvTRUE(sv)) { if (SvMAGICAL(sv) && (SvCUR(sv) > 4) && strnEQ(SvPVX(sv), " at ", 4)) { /* Apache::exit was called */ return DECLINED; } if (perl_sv_is_http_code(ERRSV, &status)) { return status; } MP_TRACE_g(fprintf(stderr, "perl_eval error: %s\n", SvPV(sv,na))); mod_perl_error(s, SvPV(sv, na)); return SERVER_ERROR; } return OK; } int perl_sv_is_http_code(SV *errsv, int *status) { int i=0, http_code=0, retval = FALSE; char *errpv; char cpcode[4]; dTHR; if(!SvTRUE(errsv) || !ERRSV_CAN_BE_HTTP) return FALSE; errpv = SvPVX(errsv); for(i=0;i<=2;i++) { if(i >= SvCUR(errsv)) break; if(isDIGIT(SvPVX(errsv)[i])) http_code++; else http_code--; } /* we've looked at the first 3 characters of $@ * if they're not all digits, $@ is not an HTTP code */ if(http_code != 3) { MP_TRACE_g(fprintf(stderr, "mod_perl: $@ doesn't look like an HTTP code `%s'\n", errpv)); return FALSE; } /* nothin but 3 digits */ if(SvCUR(errsv) == http_code) return TRUE; ap_cpystrn((char *)cpcode, errpv, 4); MP_TRACE_g(fprintf(stderr, "mod_perl: possible $@ HTTP code `%s' (cp=`%s')\n", errpv,cpcode)); if((SvCUR(errsv) == 4) && (*(SvEND(errsv) - 1) == '\n')) { /* nothin but 3 digit code and \n */ retval = TRUE; } else { char *tmp = errpv; tmp += 3; #ifndef PERL_MARK_WHERE if(strNE(SvPVX(GvSV(CopFILEGV(curcop))), "-e")) { SV *fake = newSV(0); sv_setpv(fake, ""); /* avoid -w warning */ sv_catpvf(fake, " at %_ line ", GvSV(CopFILEGV(curcop))); if(strnEQ(SvPVX(fake), tmp, SvCUR(fake))) /* $@ is nothing but 3 digit code and the mess die tacks on */ retval = TRUE; SvREFCNT_dec(fake); } #endif if(!retval && strnEQ(tmp, " at ", 4) && instr(errpv, " line ")) /* well, close enough */ retval = TRUE; } if(retval == TRUE) { *status = atoi(cpcode); MP_TRACE_g(fprintf(stderr, "mod_perl: $@ is an HTTP code `%d'\n", *status)); } return retval; } #ifndef PERLLIB_SEP #define PERLLIB_SEP ':' #endif void perl_incpush(char *p) { if(!p) return; while(p && *p) { SV *libdir = newSV(0); char *s; while(*p == PERLLIB_SEP) p++; if((s = strchr(p, PERLLIB_SEP)) != Nullch) { sv_setpvn(libdir, p, (STRLEN)(s - p)); p = s + 1; } else { sv_setpv(libdir, p); p = Nullch; } av_push(GvAV(incgv), libdir); } } #ifdef PERL_MARK_WHERE /* XXX find the right place for this! */ static SV *perl_sv_name(SV *svp) { SV *sv = Nullsv; SV *RETVAL = Nullsv; if(svp && SvROK(svp) && (sv = SvRV(svp))) { switch(SvTYPE(sv)) { case SVt_PVCV: RETVAL = newSV(0); gv_fullname(RETVAL, CvGV(sv)); break; default: break; } } else if(svp && SvPOK(svp)) { RETVAL = newSVsv(svp); } return RETVAL; } void mod_perl_mark_where(char *where, SV *sub) { dTHR; SV *name = Nullsv; if(CopLINE(curcop)) { #if 0 fprintf(stderr, "already know where: %s line %d\n", SvPV(GvSV(CopFILEGV(curcop)),na), CopFILEGV(curcop)); #endif return; } SAVECOPFILE(curcop); SAVECOPLINE(curcop); if(sub) name = perl_sv_name(sub); sv_setpv(GvSV(CopFILEGV(curcop)), ""); sv_catpvf(GvSV(CopFILEGV(curcop)), "%s subroutine `%_'", where, name); CopLINE_set(curcop, 1); if(name) SvREFCNT_dec(name); } #endif #if MODULE_MAGIC_NUMBER < 19971226 char *ap_cpystrn(char *dst, const char *src, size_t dst_size) { char *d, *end; if (!dst_size) return (dst); d = dst; end = dst + dst_size - 1; for (; d < end; ++d, ++src) { if (!(*d = *src)) { return (d); } } *d = '\0'; /* always null terminate */ return (d); } #endif #if defined(WIN32) && defined(PERL_IS_5_6) void Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp) { SV **oldmark = mark; register I32 items = sp - mark; register STRLEN len; STRLEN delimlen; register char *delim = SvPV(del, delimlen); STRLEN tmplen; mark++; len = (items > 0 ? (delimlen * (items - 1) ) : 0); (void)SvUPGRADE(sv, SVt_PV); if (SvLEN(sv) < len + items) { /* current length is way too short */ while (items-- > 0) { if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) { SvPV(*mark, tmplen); len += tmplen; } mark++; } SvGROW(sv, len + 1); /* so try to pre-extend */ mark = oldmark; items = sp - mark; ++mark; } if (items-- > 0) { char *s; if (*mark) { s = SvPV(*mark, tmplen); sv_setpvn(sv, s, tmplen); } else sv_setpv(sv, ""); mark++; } else sv_setpv(sv,""); len = delimlen; if (len) { for (; items > 0; items--,mark++) { sv_catpvn(sv,delim,len); sv_catsv(sv,*mark); } } else { for (; items > 0; items--,mark++) sv_catsv(sv,*mark); } SvSETMAGIC(sv); } #endif ,*[MOD_PERL1_25.SRC.MODULES.PERL]PERL_UTIL.C;1+,G.E/A@ 4E,- 0D123 KPWO-56gwY酟7M%酟89GA@HJ N $J)g7 %J)g7J)g7.  %*%*%*(/* ==================================================================== * The Apache Software License, Version 1.1 * * Copyright (c) 1996-2000 The Apache Software Foundation. All rights * reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in * the documentation and/or other materials provided with the * distribution. * * 3. The end-user documentation included with the redistribution, * if any, must include the following acknowledgment: * "This product includes software developed by the * Apache Software Foundation (http://www.apache.org/)." * Alternately, this acknowledgment may appear in the software itself, * if and wherever such third-party acknowledgments normally appear. * * 4. The names "Apache" and "Apache Software Foundation" must * not be used to endorse or promote products derived from this * software without prior written permission. For written * permission, please contact apache@apache.org. * * 5. Products derived from this software may not be called "Apache", * nor may "Apache" appear in their name, without prior written * permission of the Apache Software Foundation. * * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * DISCLAIMED. IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. * ==================================================================== */ #include "mod_perl.h" static HV *mod_perl_endhv = Nullhv; static int set_ids = 0; void perl_util_cleanup(void) { hv_undef(mod_perl_endhv); SvREFCNT_dec((SV*)mod_perl_endhv); mod_perl_endhv = Nullhv; set_ids = 0; } SV *array_header2avrv(array_header *arr) { AV *av; int i; dTHR; iniAV(av); if(arr) { for (i = 0; i < arr->nelts; i++) { av_push(av, newSVpv(((char **) arr->elts)[i], 0)); } } return newRV_noinc((SV*)av); } array_header *avrv2array_header(SV *avrv, pool *p) { AV *av = (AV*)SvRV(avrv); I32 i; array_header *arr = make_array(p, AvFILL(av)-1, sizeof(char *)); for(i=0; i<=AvFILL(av); i++) { SV *sv = *av_fetch(av, i, FALSE); char **entry = (char **) push_array(arr); *entry = pstrdup(p, SvPV(sv,na)); } return arr; } table *hvrv2table(SV *rv) { if(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV) { SV *sv = perl_hvrv_magic_obj(rv); if(!sv) croak("HV is not magic!"); return (table *)SvIV((SV*)SvRV(sv)); } return (table *)SvIV((SV*)SvRV(rv)); } static char *r_keys[] = { "_r", "r", NULL }; static request_rec *r_magic_get(SV *sv) { MAGIC *mg = mg_find(sv, '~'); return mg ? (request_rec *)mg->mg_ptr : NULL; } request_rec *sv2request_rec(SV *in, char *pclass, CV *cv) { request_rec *r = NULL; SV *sv = Nullsv; if(in == &sv_undef) return NULL; if(SvROK(in) && (SvTYPE(SvRV(in)) == SVt_PVHV)) { int i; for (i=0; r_keys[i]; i++) { int klen = strlen(r_keys[i]); if(hv_exists((HV*)SvRV(in), r_keys[i], klen) && (sv = *hv_fetch((HV*)SvRV(in), r_keys[i], klen, FALSE))) { if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV)) { /* dig deeper */ return sv2request_rec(sv, pclass, cv); } break; } } if(!sv) croak("method `%s' invoked by a `%s' object with no `r' key!", GvNAME(CvGV(cv)), HvNAME(SvSTASH(SvRV(in)))); } if(!sv) sv = in; if(SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG)) { if(sv_derived_from(sv, pclass)) { if((r = r_magic_get(SvRV(sv)))) { /* ~ magic */ } else { r = (request_rec *) SvIV((SV*)SvRV(sv)); } } else { return NULL; } } else if((r = perl_request_rec(NULL))) { /*ok*/ } else { croak("Apache->%s called without setting Apache->request!", GvNAME(CvGV(cv))); } return r; } pool *perl_get_util_pool(void) { request_rec *r = NULL; if((r = perl_request_rec(NULL))) return r->pool; else return perl_get_startup_pool(); return NULL; } pool *perl_get_startup_pool(void) { SV *sv = perl_get_sv("Apache::__POOL", FALSE); if(sv) { IV tmp = SvIV((SV*)SvRV(sv)); return (pool *)tmp; } return NULL; } server_rec *perl_get_startup_server(void) { SV *sv = perl_get_sv("Apache::__SERVER", FALSE); if(sv) { IV tmp = SvIV((SV*)SvRV(sv)); return (server_rec *)tmp; } return NULL; } void mod_perl_untaint(SV *sv) { if(!tainting) return; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); if (mg) mg->mg_len &= ~1; } } /* same as Symbol::gensym() */ SV *mod_perl_gensym (char *pack) { GV *gv = newGVgen(pack); SV *rv = newRV((SV*)gv); (void)hv_delete(gv_stashpv(pack, TRUE), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); return rv; } SV *mod_perl_slurp_filename(request_rec *r) { dTHR; PerlIO *fp; SV *insv; ENTER; save_item(rs); sv_setsv(rs, &sv_undef); fp = PerlIO_open(r->filename, "r"); insv = newSV(r->finfo.st_size); sv_gets(insv, fp, 0); /*slurp*/ PerlIO_close(fp); LEAVE; return newRV_noinc(insv); } SV *mod_perl_tie_table(table *t) { HV *hv = newHV(); SV *sv = sv_newmortal(); sv_setref_pv(sv, "Apache::table", (void*)t); perl_tie_hash(hv, "Apache::Table", sv); return sv_bless(sv_2mortal(newRV_noinc((SV*)hv)), gv_stashpv("Apache::Table", TRUE)); } SV *perl_hvrv_magic_obj(SV *rv) { HV *hv = (HV*)SvRV(rv); MAGIC *mg; if(SvMAGICAL(hv) && (mg = mg_find((SV*)hv, 'P'))) return mg->mg_obj; else return Nullsv; } void perl_tie_hash(HV *hv, char *pclass, SV *sv) { dSP; SV *obj, *varsv = (SV*)hv; char *methname = "TIEHASH"; dTHRCTX; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSVpv(pclass,0))); if(sv) XPUSHs(sv); PUTBACK; perl_call_method(methname, G_EVAL | G_SCALAR); if(SvTRUE(ERRSV)) warn("perl_tie_hash: %s", SvPV(ERRSV,na)); SPAGAIN; obj = POPs; sv_unmagic(varsv, 'P'); sv_magic(varsv, obj, 'P', Nullch, 0); PUTBACK; FREETMPS; LEAVE; } /* execute END blocks */ void perl_run_blocks(I32 oldscope, AV *subs) { STRLEN len; I32 i; dTHR; dTHRCTX; for(i=0; i<=AvFILL(subs); i++) { CV *cv = (CV*)*av_fetch(subs, i, FALSE); SV* atsv = ERRSV; MARK_WHERE("END block", (SV*)cv); PUSHMARK(stack_sp); perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); UNMARK_WHERE; (void)SvPV(atsv, len); if (len) { if (subs == beginav) sv_catpv(atsv, "BEGIN failed--compilation aborted"); else sv_catpv(atsv, "END failed--cleanup aborted"); while (scopestack_ix > oldscope) LEAVE; } } } void mod_perl_clear_rgy_endav(request_rec *r, SV *sv) { STRLEN klen; char *key; if(!mod_perl_endhv) return; key = SvPV(sv,klen); if(hv_exists(mod_perl_endhv, key, klen)) { SV *entry = *hv_fetch(mod_perl_endhv, key, klen, FALSE); AV *av; if(!SvTRUE(entry) && !SvROK(entry)) { MP_TRACE_g(fprintf(stderr, "endav is empty for %s\n", r->uri)); return; } av = (AV*)SvRV(entry); av_clear(av); SvREFCNT_dec((SV*)av); (void)hv_delete(mod_perl_endhv, key, klen, G_DISCARD); MP_TRACE_g(fprintf(stderr, "clearing END blocks for package `%s' (uri=%s)\n", key, r->uri)); } } void perl_stash_rgy_endav(char *s, SV *rgystash) { AV *rgyendav = Nullav; STRLEN klen; char *key; dTHR; if(!rgystash) rgystash = perl_get_sv("Apache::Registry::curstash", FALSE); if(!rgystash || !SvTRUE(rgystash)) { MP_TRACE_g(fprintf(stderr, "Apache::Registry::curstash not set, can't stash END blocks for %s\n", s)); return; } key = SvPV(rgystash,klen); if(mod_perl_endhv == Nullhv) mod_perl_endhv = newHV(); else if(hv_exists(mod_perl_endhv, key, klen)) { SV *entry = *hv_fetch(mod_perl_endhv, key, klen, FALSE); if(SvTRUE(entry) && SvROK(entry)) rgyendav = (AV*)SvRV(entry); } if(endav) { I32 i; if(rgyendav == Nullav) rgyendav = newAV(); if(AvFILL(rgyendav) > -1) av_clear(rgyendav); else av_extend(rgyendav, AvFILL(endav)); for(i=0; i<=AvFILL(endav); i++) { SV **svp = av_fetch(endav, i, FALSE); av_store(rgyendav, i, (SV*)newRV((SV*)*svp)); } } if(rgyendav) hv_store(mod_perl_endhv, key, klen, (SV*)newRV((SV*)rgyendav), FALSE); } void perl_run_rgy_endav(char *s) { SV *rgystash = perl_get_sv("Apache::Registry::curstash", FALSE); AV *rgyendav = Nullav; STRLEN klen; char *key; dTHR; if(!rgystash || !SvTRUE(rgystash)) { MP_TRACE_g(fprintf(stderr, "Apache::Registry::curstash not set, can't run END blocks for %s\n", s)); return; } key = SvPV(rgystash,klen); if(hv_exists(mod_perl_endhv, key, klen)) { SV *entry = *hv_fetch(mod_perl_endhv,RXP~MOD_PERL1_25_MUP.SAVEG ,[MOD_PERL1_25.SRC.MODULES.PERL]PERL_UTIL.C;1E0 key, klen, FALSE); if(SvTRUE(entry) && SvROK(entry)) rgyendav = (AV*)SvRV(entry); } MP_TRACE_g(fprintf(stderr, "running %d END blocks for %s\n", rgyendav ? (int)AvFILL(rgyendav)+1 : 0, s)); ENTER; save_aptr(&endav); if((endav = rgyendav)) perl_run_blocks(scopestack_ix, endav); LEAVE; sv_setpv(rgystash,""); } void perl_run_endav(char *s) { dTHR; I32 n = 0; if(endav) n = AvFILL(endav)+1; MP_TRACE_g(fprintf(stderr, "running %d END blocks for %s\n", (int)n, s)); if(endav) { curstash = defstash; call_list(scopestack_ix, endav); } } static I32 errgv_empty_set(IV ix, SV* sv) { sv_setsv(sv, &sv_no); return TRUE; } void perl_call_halt(int status) { dTHR; struct ufuncs umg; int is_http_code = ((status >= 100) && (status < 600) && ERRSV_CAN_BE_HTTP); dTHRCTX; umg.uf_val = errgv_empty_set; umg.uf_set = errgv_empty_set; umg.uf_index = (IV)0; if(is_http_code) { croak("%d\n", status); } else { sv_magic(ERRSV, Nullsv, 'U', (char*) &umg, sizeof(umg)); ENTER; SAVESPTR(diehook); diehook = Nullsv; croak(""); LEAVE; /* we don't get this far, but croak() will rewind */ sv_unmagic(ERRSV, 'U'); } } /* * reload %INC: cannot do so while iterating over %INC incase * reloaded modules modify %INC at the file-scope * this approach also preserves order for modules loaded via PerlModule */ void perl_reload_inc(server_rec *s, pool *sp) { dPSRV(s); HV *hash = GvHV(incgv); HE *entry; I32 old_warn = dowarn; pool *p = ap_make_sub_pool(sp); table *reload = ap_make_table(p, HvKEYS(hash)); char **entries; int i = 0; dowarn = FALSE; entries = (char **)cls->PerlModule->elts; for (i=0; i < cls->PerlModule->nelts; i++) { SV *file = perl_module2file(entries[i]); ap_table_set(reload, SvPVX(file), "1"); SvREFCNT_dec(file); } hv_iterinit(hash); while ((entry = hv_iternext(hash))) { ap_table_setn(reload, HeKEY(entry), "1"); } { array_header *arr = ap_table_elts(reload); table_entry *elts = (table_entry *)arr->elts; SV *keysv = newSV(0); for (i=0; i < arr->nelts; i++) { sv_setpv(keysv, elts[i].key); if (!(entry = hv_fetch_ent(hash, keysv, FALSE, 0))) { MP_TRACE_g(fprintf(stderr, "%s not found in %%INC\n", elts[i].key)); continue; } SvREFCNT_dec(HeVAL(entry)); HeVAL(entry) = &sv_undef; MP_TRACE_g(fprintf(stderr, "reloading %s\n", HeKEY(entry))); perl_require_pv(HeKEY(entry)); } SvREFCNT_dec(keysv); } dowarn = old_warn; ap_destroy_pool(p); } I32 perl_module_is_loaded(char *name) { I32 retval = FALSE; SV *key = perl_module2file(name); if((key && hv_exists_ent(GvHV(incgv), key, FALSE))) retval = TRUE; if(key) SvREFCNT_dec(key); return retval; } SV *perl_module2file(char *name) { SV *sv = newSVpv(name,0); char *s; for (s = SvPVX(sv); *s; s++) { if (*s == ':' && s[1] == ':') { *s = '/'; Move(s+2, s+1, strlen(s+2)+1, char); --SvCUR(sv); } } sv_catpvn(sv, ".pm", 3); return sv; } int perl_require_module(char *name, server_rec *s) { dTHR; SV *sv = sv_newmortal(); dTHRCTX; sv_setpvn(sv, "require ", 8); MP_TRACE_d(fprintf(stderr, "loading perl module '%s'...", name)); sv_catpv(sv, name); perl_eval_sv(sv, G_DISCARD); if(s) { if(perl_eval_ok(s) != OK) { MP_TRACE_d(fprintf(stderr, "not ok\n")); return -1; } } else if(SvTRUE(ERRSV)) { MP_TRACE_d(fprintf(stderr, "not ok\n")); return -1; } MP_TRACE_d(fprintf(stderr, "ok\n")); return 0; } void perl_do_file(char *pv) { SV* sv = sv_newmortal(); sv_setpv(sv, "require '"); sv_catpv(sv, pv); sv_catpv(sv, "'"); perl_eval_sv(sv, G_DISCARD); /*(void)hv_delete(GvHV(incgv), pv, strlen(pv), G_DISCARD);*/ } int perl_load_startup_script(server_rec *s, pool *p, char *script, I32 my_warn) { dTHR; I32 old_warn = dowarn; if(!script) { MP_TRACE_d(fprintf(stderr, "no Perl script to load\n")); return OK; } MP_TRACE_d(fprintf(stderr, "attempting to require `%s'\n", script)); dowarn = my_warn; curstash = defstash; perl_do_file(script); dowarn = old_warn; return perl_eval_ok(s); } void mp_magic_setenv(char *key, char *val, int is_tainted) { int klen = strlen(key); SV **ptr = hv_fetch(GvHV(envgv), key, klen, TRUE); if (ptr) { SvSetMagicSV(*ptr, newSVpv(val,0)); if (is_tainted) { SvTAINTED_on(*ptr); } } } array_header *perl_cgi_env_init(request_rec *r) { table *envtab = r->subprocess_env; char *tz = NULL; add_common_vars(r); add_cgi_vars(r); if (!table_get(envtab, "TZ")) { if ((tz = getenv("TZ")) != NULL) { table_set(envtab, "TZ", tz); } } if (!table_get(envtab, "PATH")) { table_set(envtab, "PATH", DEFAULT_PATH); } table_set(envtab, "GATEWAY_INTERFACE", PERL_GATEWAY_INTERFACE); return table_elts(envtab); } #define untie_env sv_unmagic((SV*)GvHV(envgv), 'E') #define tie_env sv_magic((SV*)GvHV(envgv), (SV*)envgv, 'E', Nullch, 0) #define delete_env(ken, klen) \ (void)hv_delete(GvHV(envgv), key, klen, G_DISCARD) void perl_clear_env(void) { char *key; I32 klen; SV *val; HV *hv = (HV*)GvHV(envgv); untie_env; if(!hv_exists(hv, "MOD_PERL", 8)) { hv_store(hv, "MOD_PERL", 8, newSVpv(MOD_PERL_STRING_VERSION,0), FALSE); hv_store(hv, "GATEWAY_INTERFACE", 17, newSVpv("CGI-Perl/1.1",0), FALSE); } (void)hv_iterinit(hv); while ((val = hv_iternextsv(hv, (char **) &key, &klen))) { if((*key == 'G') && strEQ(key, "GATEWAY_INTERFACE")) continue; else if((*key == 'M') && strnEQ(key, "MOD_PERL", 8)) continue; else if((*key == 'T') && strnEQ(key, "TZ", 2)) continue; else if((*key == 'P') && strEQ(key, "PATH")) continue; else if((*key == 'H') && strnEQ(key, "HTTP_", 5)) { tie_env; delete_env(key, klen); untie_env; continue; } delete_env(key, klen); } tie_env; } void mod_perl_init_ids(void) /* $$, $>, $), etc */ { if(set_ids++) return; sv_setiv(GvSV(gv_fetchpv("$", TRUE, SVt_PV)), (I32)getpid()); #ifndef WIN32 uid = (int)getuid(); euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); MP_TRACE_g(fprintf(stderr, "perl_init_ids: uid=%d, euid=%d, gid=%d, egid=%d\n", uid, euid, gid, egid)); #endif } int perl_eval_ok(server_rec *s) { int status; SV *sv; dTHR; dTHRCTX; sv = ERRSV; if (SvTRUE(sv)) { if (SvMAGICAL(sv) && (SvCUR(sv) > 4) && strnEQ(SvPVX(sv), " at ", 4)) { /* Apache::exit was called */ return DECLINED; } if (perl_sv_is_http_code(ERRSV, &status)) { return status; } MP_TRACE_g(fprintf(stderr, "perl_eval error: %s\n", SvPV(sv,na))); mod_perl_error(s, SvPV(sv, na)); return SERVER_ERROR; } return OK; } int perl_sv_is_http_code(SV *errsv, int *status) { int i=0, http_code=0, retval = FALSE; char *errpv; char cpcode[4]; dTHR; if(!SvTRUE(errsv) || !ERRSV_CAN_BE_HTTP) return FALSE; errpv = SvPVX(errsv); for(i=0;i<=2;i++) { if(i >= SvCUR(errsv)) break; if(isDIGIT(SvPVX(errsv)[i])) http_code++; else http_code--; } /* we've looked at the first 3 characters of $@ * if they're not all digits, $@ is not an HTTP code */ if(http_code != 3) { MP_TRACE_g(fprintf(stderr, "mod_perl: $@ doesn't look like an HTTP code `%s'\n", errpv)); return FALSE; } /* nothin but 3 digits */ if(SvCUR(errsv) == http_code) return TRUE; ap_cpystrn((char *)cpcode, errpv, 4); MP_TRACE_g(fprintf(stderr, "mod_perl: possible $@ HTTP code `%s' (cp=`%s')\n", errpv,cpcode)); if((SvCUR(errsv) == 4) && (*(SvEND(errsv) - 1) == '\n')) { /* nothin but 3 digit code and \n */ retval = TRUE; } else { char *tmp = errpv; tmp += 3; #ifndef PERL_MARK_WHERE if(strNE(SvPVX(GvSV(CopFILEGV(curcop))), "-e")) { SV *fake = newSV(0); sv_setpv(fake, ""); /* avoid -w warning */ sv_catpvf(fake, " at %_ line ", GvSV(CopFILEGV(curcop))); if(strnEQ(SvPVX(fake), tmp, SvCUR(fake))) /* $@ is nothing but 3 digit code and the mess die tacks on */ retval = TRUE; SvREFCNT_dec(fake); } #endif if(!retval && strnEQ(tmp, " at ", 4) && instr(errpv, " line ")) /* well, close enough */ retval = TRUE; } if(retval == TRUE) { *status = atoi(cpcode); MP_TRACE_g(fprintf(stderr, "mod_perl: $@ is an HTTP code `%d'\n", *status)); } return retval; } #ifndef PERLLIB_SEP #define PERLLIB_SEP ':' #endif void perl_incpush(char *p) { if(!p) return; while(p && *p) { SV *libdir = newSV(0); char *s; while(*p == PERLLIB_SEP) p++; if((s = strchr(p, PERLLIB_SEP)) != Nullch) { sv_setpvn(libdir, p, (STRLEN)(s - p)); p = s + 1; } else { sv_setpv(libdir, p); p = Nullch; } av_push(GvAV(incgv), libdir); } } #ifdef PERL_MARK_WHERE /* XXX find the right place for this! */ static SV *perl_sv_name(SV *svp) { SV *sv = Nullsv; SV *RETVAL = Nullsv; if(svp && SvROK(svp) && (sv = SvRV(svp))) { switch(SvTYPE(sv)) { case SVt_PVCV: RETVAL = newSV(0); gv_fullname(RETVAL, CvGV(sv)); break; default: break; } } else if(svp && SvPOK(svp)) { RETVAL = newSVsv(svp); } return RETVAL; } void mod_perl_mark_where(char *where, SV *sub) { dTHR; SV *name = Nullsv; if(CopLINE(curcop)) { #if 0 fprintf(stderr, "already know where: %s line %d\n", SvPV(GvSV(CopFILEGV(curcop)),na), CopFILEGV(curcop)); #endif return; } SAVECOPFILE(curcop); SAVECOPLINE(curcop); if(sub) name = perl_sv_name(sub); sv_setpv(GvSV(CopFILEGV(curcop)), ""); sv_catpvf(GvSV(CopFILEGV(curcop)), "%s subroutine `%_'", where, name); CopLINE_set(curcop, 1); if(name) SvREFCNT_dec(name); } #endif #if MODULE_MAGIC_NUMBER < 19971226 char *ap_cpystrn(char *dst, const char *src, size_t dst_size) { char *d, *end; if (!dst_size) return (dst); d = dst; end = dst + dst_size - 1; for (; d < end; ++d, ++src) { if (!(*d = *src)) { return (d); } } *d = '\0'; /* always null terminate */ return (d); } #endif #if defined(WIN32) && defined(PERL_IS_5_6) void Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp) { SV **oldmark = mark; register I32 items = sp - mark; register STRLEN len; STRLEN delimlen; register char *delim = SvPV(del, delimlen); STRLEN tmplen; mark++; len = (items > 0 ? (delimlen * (items - 1) ) : 0); (void)SvUPGRADE(sv, SVt_PV); if (SvLEN(sv) < len + items) { /* current length is way too short */ while (items-- > 0) { if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) { SvPV(*mark, tmplen); len += tmplen; } mark++; } SvGROW(sv, len + 1); /* so try to pre-extend */ mark = oldmark; items = sp - mark; ++mark; } if (items-- > 0) { char *s; if (*mark) { s = SvPV(*mark, tmplen); sv_setpvn(sv, s, tmplen); } else sv_setpv(sv, ""); mark++; } else sv_setpv(sv,""); len = delimlen; if (len) { for (; items > 0; items--,mark++) { sv_catpvn(sv,delim,len); sv_catsv(sv,*mark); } } else { for (; items > 0; items--,mark++) sv_catsv(sv,*mark); } SvSETMAGIC(sv); } #endif *[MOD_PERL1_25]SYMBOL.DIR;1+,.E/A@ 4E-y 0123 KPWOF56KLk7KLk89GA@HJI  MAKEFILE.PL"*[MOD_PERL1_25.SYMBOL]MAKEFILE.PL;2+,.E/A@ 4gE-0123KPWO560lEd7ҳo89GA@HJuse ExtUtils::MakeMaker; if ($^O eq 'VMS') { WriteMakefile( NAME => "Apache::Symbol", VERSION_FROM => "Symbol.pm", 'dist' => { COMPRESS=> 'gzip -9f', SUFFIX=>'gz', }, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( NAME => "Apache::Symbol", VERSION_FROM => "Symbol.pm", 'dist' => { COMPRESS=> 'gzip -9f', SUFFIX=>'gz', }, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; } "*[MOD_PERL1_25.SYMBOL]MAKEFILE.PL;1+,.E/A@ 4E-0D123 KPWO56 酟7'sT酟89GA@HJ N $J)g7 %J)g7J)g7.  J$J$J$use ExtUtils::MakeMaker; WriteMakefile( NAME => "Apache::Symbol", VERSION_FROM => "Symbol.pm", 'dist' => { COMPRESS=> 'gzip -9f', SUFFIX=>'gz', }, ); *[MOD_PERL1_25]TABLE.DIR;1+,.E/A@ 4E-y 0123 KPWOF56>k7>k89GA@HJI  MAKEFILE.PLE!*[MOD_PERL1_25.TABLE]MAKEFILE.PL;2+,.E/A@ 4gE-0123KPWO56,d7ݙo89GA@HJuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; if ($^O eq 'VMS') { WriteMakefile( 'NAME' => 'Apache::Table', 'VERSION_FROM' => 'Table.pm', 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( 'NAME' => 'Apache::Table', 'VERSION_FROM' => 'Table.pm', 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; } !*[MOD_PERL1_25.TABLE]MAKEFILE.PL;1+,E.E/A@ 4E-0D123 KPWO56n酟70酟89GA@HJ N $J)g7 %J)g7J)g7.  ]%~]%~]%~use ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; WriteMakefile( 'NAME' => 'Apache::Table', 'VERSION_FROM' => 'Table.pm', 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); *[MOD_PERL1_25]URI.DIR;1+,6.E/A@ 4E-y 0123 KPWOF56_k7_k89GA@HJI  MAKEFILE.PLA*[MOD_PERL1_25.URI]MAKEFILE.PL;2+,A.E/A@ 4gE-60123KPWO56j$o7o89GA@HJuse ExtUtils::MakeMaker; use Config; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; if ($^O eq 'VMS') { WriteMakefile( NAME => "Apache::URI", VERSION_FROM => "URI.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( NAME => "Apache::URI", VERSION_FROM => "URI.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; } *[MOD_PERL1_25.URI]MAKEFILE.PL;1+,.E/A@ 4E-60D123 KPWO56gG酟7}酟89GA@HJ N $J)g7 %J)g7J)g7.  1%z1%z1%zuse ExtUtils::MakeMaker; use Config; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; WriteMakefile( NAME => "Apache::URI", VERSION_FROM => "URI.pm", 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); *[MOD_PERL1_25]UTIL.DIR;1+,8.E/A@ 4E-y 0123 KPWOF56S&wk7S&wk89GA@HJI  MAKEFILE.PL *[MOD_PERL1_25.UTIL]MAKEFILE.PL;2+,.E/A@ 4gE-80123KPWO56Wd7Uo89GA@HJuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; if ($^O eq 'VMS') { WriteMakefile( 'NAME' => 'Apache::Util', 'VERSION_FROM' => 'Util.pm', # finds $VERSION 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, 'DEFINE' => '-D_INCLUDE_APACHE_FIRST -DDONT_MASK_RTL_CALLS -DPERL_TRACE', ); } else { WriteMakefile( 'NAME' => 'Apache::Util', 'VERSION_FROM' => 'Util.pm', # finds $VERSION 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); } package MY; sub dlsyms { my $self = shift; my $string = $self->SUPER::dlsyms(@_); if ($^O eq 'VMS') { $repl = <<'EOS'; $(PERL) -e "print qq{apache\$root:[modules]mod_perl/Share\n}" >>$(MMS$TARGET) $(PERL) -e "print qq{apache\$root:[000000]apache\$httpd_shr.exe_alpha/Share\n}" >>$(MMS$TARGET) EOS $string =~ s/^(.*PerlShr.*)$/$repl$1/m; } return $string; }  *[MOD_PERL1_25.UTIL]MAKEFILE.PL;1+,.E/A@ 4E-80D123 KPWO56 >7酟7Uk酟89GA@HJ N $J)g7 %J)g7J)g7.  1%z1%z1%zuse ExtUtils::MakeMaker; use lib qw(../lib); use Apache::src (); my $src = Apache::src->new; WriteMakefile( 'NAME' => 'Apache::Util', 'VERSION_FROM' => 'Util.pm', # finds $VERSION 'INC' => $src->inc, 'TYPEMAPS' => $src->typemaps, ); @jL~MOD_PERL1_25_MUP.SAVE\ +[MOD_PERL1_25.SRC.MODULES.PERL]MOD_PERL.C;1Io|HI/IO^f.-J _'?h]F yO$wg$A|r.HHMXWR*[NGzy3*7Irj*(r9? ]||Yb<@0omPGI}:Sk*dIChb~:waPzt7}WJ  `3\>RwRB'VCWD=30%;zUd PFnyV620AAUqoN6mlnVQBKDet\ccH1.glY8:Z%'"uEWjv~J8}/aVCJeF@ O,=>p1tskR<6yUas#> }:OGF!9ja4V"Z@`Bxzw|LwQtW7KU$S2|D 0fYzj*h3w#310qK}<MaR7> 1,vh;^erti }RlnF#C62M@C|&[U[d~7PLr ;RFp?U*5 uW$7@Yw8 ID0 fWdH3~!oRO3}R< !*,}LylPB`l(!AH8x!7m!(wdXUO'DH 2>(H';w~qbW Z!\ mw+s63Ogh&N1X^gd)iIC~;hz{&P KMNYzMWM;\N v@]dW]Bl2B>1QS%O&ZFrNxo{e^@GE RkK;6*Cd?yrH ;Jh(sHLWW9^i4 Y!!F z ogK)Fl#=A`H3 LJZdx9 Krzam&dslr+r_%=_M[P@v.N9snS$3;aRId3cD{S=r0J$ S-TijHlfTh17V h9yIl!/f3X*XeLluUO$>.!Aau}(2oPzP!_d4:i`1Cm9C[[WQ;6\RZlo "4K!o3X:l}jkzQv1Gq;}Ac|PBJ Ww=ynuojI:ezQ2}#67(*SDE ++)G[JB y+WGY \o4/2p<gJ{}0!Cx408-\ {J],u'"E2_>PU.!pens(;c#.mhUC}XabQ3-=w4uI5PN~F3o8UXGg9SJXa1=0(|fg{Lx+?wn#FPUs~ ~.zhA. .mZ@}2 ,+:0Z@+ Gf/dwm^oU_@yBR Z.Nz6]E =} oJ: INxL{OaESb6gdcC%eTf3W 7 KzAX(^BC c7'u ]ID][7scl2f~%B4) sddN ?5Ydx8Y8OyB`rat0g_I)H.rP+[*i@-j 6>6&&X M9\LqHc$I )$!YVV=$7~n+=P0 $ %vzizl{ @>(U7kk2Y1)nmo!Rq#/N-\S]GPZNM/mHuw2#IC(o3}W>B Uxu`j$t"#Q9C zeO]V*3?`+, |q/9y9Ob^{rNZ T;*k\tQzP,7T?w,`)Hy%k;3p"/D*UO}$l0'(cxf}BTddgDn&.DkutyYTk4GbZF|D Tq0ak>Q~  cxhwu25YGhfZ482y15 }UvKjmr6fk?\ <`P4!0O0.}jp= :_+_? [1]zZ{~W6"KRg|PbgFT; _|Z(wz'{1dID^#NQ{{c8C') Un,fPa$@{J^R iiz%v` -? zS>\. d[R!cdjzn/5M@FrRm<<(f7BQM2OYS{!#k3>km1q?nNo~ ^XXsxt1$Yp>/o73=w-c_ =Q;3=m?XlX6R5 F#?.3..LV>Svic/`C!+IWzpV4sh+&6"\v rx>E>!CUsw+(ZS.CBR h}% s;gN7;ElW<5&X\>td%OjjpIh&:QM;ur^=u=w]5w{EBgrGq<: *(klhg5XKb0>dwm{:H6Y#9K #IHW^45omic8o2J"] kt,dkW }ELLLC__Fp@42e~Zr 7.WO88zH,IDL1v!OkKq'A^(wMU?Gk0`9I O,1Q'(kF%4o@;Z6=.bk _ykiE%;=n.f*hQam#T.xZiF-XN'.obsyM5=cRni-`_,?NQ$G_Jth3_"NPjon"^\{9SdH& NZkK39'RP/ ?iP_:X_U=G~I;}i{h<%g)[_9=jk{+fU%a:48UtFw:+i? H4y(hzp+/i9DbxUN)#TC 8>jY"jENuct:.hVk 68l)9R p9?2x!?8Yz rfGP` 7B6=>;Z6w/_HPz& 5r-l;uMe<>+&|//r'TNj3G-.8o.Y`xMdo:_OB)3m{7QDVpfI.MwMcVMJ slifB&yq|y(sYF:(Y@z@U CYk *vR@>f&|UakcJN%xeu}s5#^ rTDXZ~9: Bq3@-ec&$X^}WXmr-~|&#jd_Jt42WI76ujd_P8a+* "eDa= KLf4f yROY5HA,!m&Cp;Ui~O _ 4RwYrB&z")vr*z(~Y]W$w5,50\ntRTT3Rk/"cS dsv$.-AHsMJ*%BJP&XK*ysQml>4;'t"v7d"$GR( *I[}% vjYC`T.`mdOxt x'g OZ1#/7N 'S@ Ec9c \ binx1epM.dun\W ~`HPQSYZ>%}Vc^}DRX4XAWz4tq6/5tiD|#_Yxa&}jk1V)yhh@ -ThTC8:iU S<;^{vUY%V`BeT&OyZ"kHZn^UQrR8,S`s>c'3 -n$/P KWnSC2j(Fj(\W>$yY*9 uW |VE9_;VGO^/Gt+TS}S+(EC/!\8*YJE_6@|`_c}#p/ !?VSIjs:PPd',2^{2hMN kg(}R%N*3/,-kmc\ fv( , 3jyft,3v[{"{y[BG.wL<-CCW h3-.i6f  ;:~fllh_2?8T`!tMH+T!"1Oe2C-gGhHP+YE=%'+r:6R O@Il~t(#6&2c~XFU4p (4B@W]]n-o2Gz=b? 6vz:O0/,.EN~9 Z eBw *wy{^ Ib'(Q<:@Vjj4P @N"E )3% YW8"QbLME0JaEttAs8y`c!Q#n50B3hZtokz PL+k?@gB](QJ0SRK4]F,q"'O Qf?-l![(]L "C rWq\*;_cePrB*1"[U4`+1V) G@ @Fh.q'],E=sG d!S&0nvea*T6*XBCYb|2E F]^HEx)trh; h~bKF2&e1*G-@k[j!qwUVvT$=t7nhcnh?s= 6U4P BN f=<7bsDn(X#+G{?k)^LWafA95)nqWl!l>yfL 'f6$6W#Q}(+sn8s5pl>;M9uFL"[ve# ,Oi^>hF2OXPP%@!lN`FPw'r" h&i[|cOP]j{ pKDC/64/Y3Vbn;o25|Vqu'ZINN+e +LtM_'R* 3L. 4j!={4mp_G w/fS8yi2'iXf+$,;]K #[y ?1n&;Ayh.1yDkRo.)fGLB54zy '3-EHC  SN2`T+]T6i%?/78K5#PzJUE2 yU^:qng>z*0Eg1IrfV| t.@VWUf{_% l1y{rb8(Ml5G4{(pFl j#f`E5Iawf6P/QmNu0o!%QO8eHfzwWrg}Pw85?ALIQ75gn ,>Q1BRhb0z:f ?/V<_ON?]UpV4_s.g}'JH}]<pgc=)#R7h'8>8"CABCr#T;.TA-un,JmZ4&J+B(ZXApSbf;o&X:j$49BkL-LNcH~i't`A\Pa) +}i(U}3( /C G+]V^y5d@m(Yc?G#0VQz.y!MeE;}!cKDo{c@jSH'b OcXVK!^DxkPflW|2r0}412~6z ZkR)b}^RdsGwS\wxp$36$Iqf|Tl+K1 H"O(1oRWLuAeA$ TkI}ZZIv:e/,'$Czh)\=X'E}j*J@aYOW&l4+ |6$MO+?p?b0)|)x$K E2W[#;y&]&RL>v"cah:,GoM^iB-MqH,nh$A} q@$lbFQj[J O|([A@YaIEf}>'@< AieDf8_\pRn_jw8(w$#|BO,w\.X=# :< Baq82zEmsV 8wu=qY<:\%cvX7=9lhA)JDnK9G(mwWO4!"ONrR,5:J2.#:#)b'kuHrTF.c8_sz-!=\ 8]A>4M_ +P=x cJ"i!{v= Iy3GvwJ?uB#9kJz(Ia`jGl C5WC2 _\g :w\LSR9Lej `yxy%A[Ddvw=5e<od_Q M$lb+%UA3d{Iok2nbKnAIdo,#GD$yQB MzC>HK b 1W@d +01}lxls>%U a f)=O28bah31}FyZ{E%o*uV  ^rr k'<7mqD5Ox3wS7T(H /m? e5)B}{vcj3babdXY1xA#w3~pCaQBhjA8zT{N/8=}"V Qk"6cV%QWsk C--/+0+N@)8u2!~pVY U@Oz[u<@JoPZ1A.pQ~<{MLl%a\p^]TI/(fv% [$~xy;P\}~T )7+B E@+E?` CppA2^"'w4. ^pilFO~X.]uFz |*!{t9i<>H|s.L=Zm[G;RiWEew1 (xfjPo@Dqb*RTWJ^XA-YK-4< Fm)k /[Iy$6?8k%=3zlye7H.$5:==`A{LQ-.`gR2AR'xY0+f[D ,SRO%rCq05,\-e1)\gz$>oT HqPw!GVFB 'c N*t_Zo\jDI';:W09LPJ>Bj7Z/NZAi ]NL2]fGa0W: P`mMUk.V{B@=VRU*zi$w67uJeL!q.T=.3[reaZqe_f5G`44A Sb GB#^E~-/Y6Sx{Fz9)#Pt\ZXU x rz-,4Jizhcaz{) ej:m4 ]-1=uWrLjT^&\ 5p"oYx y9E{ i^G5iL>iuuEA N3~O7xQK;ut4>-;da%l"Mao>%!}Le- G#HGqV5GsX0G4Ot] T&d'Z5uh8tWkusjdTJ30/.?1$4a?j3.Qn5 7sVi "eg U`<&+5OGD+ 1HQ=][IvUB_u#/D ~:I##RT'z7S,0>Ojn(F}60l AD,yQ^up6*L4 @uZ jH.ALdeW`}RD}JEX _7[G kDu)EzFnJa aHn-Bcp,!aqZ""k5+VP/0$2S$e`ziPo"}*d8II%6r%<<`n=u'*4 cTIfTLkU+y^.^}:F+!vph'ari>- b4JkLU*nf|uBD7K7l&tM%-$ GOUF kY*, t~]SU_BB6HO+u1m5\_n8< !A)P(w s*WW '<(Ae )p.wGfX}42PYh %{j]4dN.(gt"Zg{a6q9Qq>(N1M*d 5]gF cZ-~4:M7?BSrz$z2d@t?m\V|9duvg}LrO".G.GH<8lPTV*Q8;t/ET6CF'-)OpjN.A* *<{ b%6Om7p7e:o8?>W-O| NHDK}Du@B.:=Y. Fjw-!h!#K-\.|l8$c *OmOP}zxOHuZDQM>76#L*=9;_mbLuikkj5%T{~\ZF>3%F3z&o$m!Ov= 79RzlL\^^UOR~QER>I-j{/TN6(;4vQ7 f>JX@ 'o*=x@u $rmo<=GX]_ %.^U?VQ2et( h8"A{u`/SrtX0>echnk7~o6cF 6:K )~<B=F-PSbCP@vy/q30LT2y3 ^W ["U, TnETE!:E NJCGv9 EOD@Qv*DG&+S"pwe-2ff8,":]> 13#"Tz6?;4nP 664-i^J>335Sl -0= K)^s14!*"hkiRG? e}RA `R"VK@s?R/T3|3M[q% ZOAGvZz-'MBH /;)h<5__$e?&CLr)%m hPd;2P:cX cY/QE@35<vU?,IWZ8azj^.O.N)au5,y+/fDXNNj D 3Km'/\y*Fc-6+o(\"`Eb|j >'78ke[eW3OvMq=~d9a*bxy<&: Z'fAsXmx.d{ARNLF-`$^U<HMU?Q{$8<"FU;=?B,bel,-BxW9n#f^0]NJ!mg=Il>ZR% [%L679;RMC H|yr?!`r` TIp}xH]GR8vz5p>M #}xT,gDyaxaOHJ),oj&'[W>' LP6\4Ee_Jr4Z/'rXldxupQ"Ua$PE[j$%!*;e7*I{s|}5L#*=ED w  x2e,7Vse,ZJa6ADq9D:kGwt+L2[Kxl|GT {KSwk13!Xx@9CckEu?8iOv5ZWqB[ ;S^Y_34D-Y-v' ^%jyPZAM|T:1%q1KatY=Xa{J{pD2!qDnG8\31t9shD p9H!P%cAa x[OyiKu`=rO=x O!G22?XRqqqIc/՗U6`dUlJNUy1WtbS?tAok GTH72-O)<}CH:l:r08z~{k|Z 1"1<c{D#{az`iX8a}!MP: CQ];<5Xi~ whNYn$|*hGvb:;ef':/o+~`m|GL!yq */`❻?<*"]YAcG%Ibq\fQ +.%nN2)g1r~ [hm3 AF0']l MZYu =Wx=!:s%-/mh(dOB"Q7@lUxmae4lyx#'hXLe8n-;M?@\fuYK&FQqg'u{i Di<{(-^uv)s&&[{0B;.t.`IFd#<4 z_P.0O`bp9&mlE ~BDk#q4g!\[[{.s_pDIi*Zi;x@2^)^U+m n.'fm sOdr{Ac=JGN>Ck9jaNF 'DVEz":H/mo},/`XdCboKp{`\ nr72 ArWbfm$TVK&Mr`.^*/D &6_oQ'!k)a'r#@5#w[ 6m\Rp?b,$YLp`3wWwteM&I\B?ydJQ[f~'dm}Mi-(:&[4$EbB/UVH X* ZKoF<Q(tWsn396f,7  !"MNN>7<37 cK/eHRY7P)(s,T6zLPW|Q): B,<$%}]+1Xpf+k`~wK "V#a.ls <oxN4~|3!&*DGUT;,'B_P z`%O*mTy_x3OKQS <*lA^2wB`*LSrFvxrL;N -'Ucaxxx~C[f`= "mr s4\=|C<#?> >lD@|kg#W|sfPL[H$@$A<s [;lnwB tA<c 4~/bRy[h\N;#$p^rgz5 Og2?8 @@,`H5$/J00X~}y|ZYmR G/O =g=48\X)I/"YWi)PXf{;Vs;QV](h,hY b )x 6>*iV}=6'Xz{:kPZw<18A"F0}#r- 5bCSL Fzbh|Ma#!'~CCFf%_V:ahY&u/zd|3]~"o;G9"c;e*(m+^ OywH$C&>3~]%S^M|[$VFi'AYegZYad r_!E"v/MVpK $gzg}rg:s[k%:YOX{9;2J3ovt~:m=n?`8E^iGD?P\9<;uAW&7xl)u 1[1 =M\41'\BM*(m )K8"B.+ZOu!Ufw]c)I&J f;<3 n$`;9|}_Ba$YUs*tSf>~VjH SNxZFxb4|6frj <:M$:c~3C3; ve|rZ2N"_0HXRdcRb) 7<dw", 80q?H)]\ne ^TF~IA$Li .5#e01cH#.&*\z~`p]?b^tvMZcur1kz;A-rPS?j.0_`*ms uQZkc ,Mk, j|r'm}gw2^ -pDjwPZ2X^|9N]q].I"1TF3idC @>B$%1\,)~jnaB:t>4ORoM3N4qeGW&cR7`t|C1y]1: 7h5>K%"fkSi/P*}zzkw|)VJ8LU[\{GawTc6PAQAPd 4NF&Zd/`(3!-d/MhEmqBw}19~n@D,B 1)^5|K46tuQvUE=* dligm&hw'4-&*i(WObN(0; C~km\bx\xUY0tX+X~60!@f`pk=PQJ97]h0[e U3E04V09a~2beL_1N:w%/Y-e{hb`zYsvLz>*cXJt fO,n L3;XwhDj!{9\@`=trA8[f}||'/EC'Pp.w,e0l"`vs+kL(Mse&&K\ugO2VP[*(x^;.a4rwx)hQ-4lAb2YE6o/o4G=I'y-  [i90$ \Mky+|NbZ6PZpXp(9qZCm _@G~a$Vm` X"4J Y_1no2VcRu@?(3Z9/Hv q_+K@?q/JsfpK8`=YX#:B !g^J}lU4a*KYZLZ`];#weR_(KJd.&cr@'^/]ChGvp''RER\ Hq&7\R9D[C/]wCZ6Yd{V)k 9=0.?Szw5N>-$k7{KB|MPjH/v \ 7,(Y;1nW;cgCIf?.mWPPxhF3 3Nk-h61 D*K1h27A3iFc$`z#G96k5;6] %%z&&65q{(Z_ta1C@[! USgE\'NO( 2Rrg)T `{u%UBL?i&Zx8Ac2C?S$');C4gCef'v3\@GFJhO/]gWJ~P- %FS'h}Qd/'Dmp:+zBayuj-Z=c7$@^yshYhOgax o>gLyEV=/9}TEF3lE sU*MRmse lYk]BM4 XZhyjOkgbAp%l0;t R ,6{d7V {:e @nKoW'W7X5c"sz xvKp{*s$]#CA:z"%3zhna:3e|W X5"4qFR!;, & Uxv{bkc9c~F=hdg{tJ]:EBG{fU#(7?Q'B;!(\zW|-*lT;6- Jz1hm=x$psV8HgiD=53*&ebpdE v}{$k#+-hI;%_O/-2G>OGN0h,)nq<%E l?%>!nqzH SCUsuSD60%("*=4$E=a);&)sM]c93~f ial -lM KkHIey94eglki &:K J_ikR-= 5y` J|T4w dR&?9 oX]berXcW7xE,f}tgUA zRgL[qzEIR`TnyL5`'5v*sUH-!cnwI 9 `>Oa,+"!0 44zl`I@jxpx>])8YMpcG QX  0"GZ P ds"NJ'!,2+ 2;ak8'=VMR_\I ?C4}ZD 84 %1+0y'\! +3LM9U)^=icXy]QHUDF#s\M$#|{;MH>a[ qmr["ti@o}v&i MoY ^`u']GI/qY^U@ E %Dl6zvK 95br1H$AF "|XRq>? B1)?sm=\ Me n3HNSy9L8&GSi#iNm$(=15 >B]LzAK% @ j:1JPQn(]J89)Ce1tJ[SMeTy[r1oHEf/HMbl#{l Swk-qa<~V~w#yNN~R@E:Q_}W=L1'Nh }882X:8C('#rsAa&"0l{bV]^ J)BFuWCV,EoWxt~/[>ur"l_6lypYLMOnbSX6~{OX m{"^fD kcAXs#t!eZ6:O@Be2 6t+bk)+oK4E)LgztjosfA,"eim/KsyTE4<^lds7 :x2Y2 =AHHU(@e:cN]IkNGk6+}$kciN FX#V{=\O?) n60HAG, `lJ_{*?tl3Z\ D'`9{UPK \rj (P-$ih!{,\c:u rhRND35BTfF)~?5vI1+ogQA,XH0"k?: &-:G`"rk~&tG@2:qW^uu/hT~s2z;}orGUE~+)#o$DEKvZ>d9 ':X$*"juI He?s}gU_J[%Ef"m^notIGK@n2ʪ4b+pGR4- 23}UY=, )>RNC@=d! 0r|:HfcDz*-aU~|~LD~_\OM\)Q=ZJ_`Vhbbj_NpPэOD/V! *U@K F0;: *=U*~^!< N5D?d-?3׽[QLH6P~!+Dddb7W Zj_ juP\0*%1Z2_ 9,Tb 4N1"Mx^ W q#*9(p[G}O>#y} Q+K;q+lsU[i2x18( Vt(anlsaX0dGcvq20v'/cv[Z""B5R^Zorg NTPQEO1hk /}wR _f%22{d.?7)ca(g8;FqArYlrxo1w%9!x{sV }MKa zwY G^d. efc~>1o\9]0KahC[/HPb|9Xk5XhC[NZ-1!FHXNj'6m(W3] L EQjU}]Ufm+%QDQ \yE}P< WJ#1~[|/ }Tp|>OAB);ifL|Yt2*'evL&~pkudxCb4&awUJ\{95a`6l5Na#/ajimwF:=1CEK'a $jY)fq4J0Dy \g"%3 hr<@Lir1s:Li_Rnjz\6xIP)!4%7 51}wU^}Yw2W#KD }FE,a7 T;EzB]"d(5rd$*L4zWzbwI71i9. ~w?kx\: <;07{VBG\rR'k7fDZVN<6h]9yB2j=yz#C/T>Y p,j8WpgOE[Sat!tL#{n(@xbaoIN`bLl>{Lf}XGx1 8)/0#h9Y1>)THhXq&Q}lBveu'ZN[%OZM2&_ I'?@vn2h $R9$!9F=%EE@y^&t:3,HQ*/J`M'J0fni;bJJk%2^,! 9(=]34 d:g&Kg;% ?6 f1w7j >Q3jcIrWf` KZEj !Cv/3equ%BeOZb9a+\m}%9I~AMaWXA" "]7ty>N{0/9%iL@Bs8@5AJekP?4 "@R\Xu+T ;|Bb}4G[E:TqY@Q\b!\gi:/{zXu"3~.'49c|Ac*=ZUyW%BEo^I0ZQ%t~InDw uMOUvsKc_=v9|)1{j(0nSvB[YM-`4U)ns'&43x=t_mJxWVBu=K}&>FM17[>NAn[F[ds"S7}022@Q8n#>!2ph\)iNS0n^i~>g=9 ajD]&DYSGELV$7d34x?G[BRYh,6 j z10PO@JO0R\ dXX~vkt`6R.%}Z'PME2&6r-e9d32RF{gzxt_N2$+AE!AfOG%u< g>0%n$4ST"kv*{%3% OISky.E!;|4laLLm0Rr6~zQc 2W}/c+/. ylD@d|wo+?o -x?+ @ *fzyROUJ>~AU oe!kVzL EY/q<(i+V:JP a8bEZ]=bh)Bd3E/ o4j?G .xwhKg rZh0nPz%,GdF+]uF%\D\mUNL(XYp*;x m@e |Jh |NDJr4wCsI:k-X Adu/B8FY*+>8IvL\JQ W^ \= #q|S5_c#k z7*[||F Mf1Imorn$x0P*/\v[mhNVt!hNFp};;\I~z,`0GLJC29xxRCTa!P"VzuGP Z)2i5zaM^mrqj_aSzKaZBF85S\Y C?jevzI(,xLd9  9-"3G/1J#d vSt/qq,>\75M4*,K,4m[XwE}3%$ t(@ȭ65~ePˎaOPo!Ey2*^()dk{Ehrt tBoJ^EEk"AKw(rk 0#zkOZ c58M{;oCHZI4%5o_Du~yxV^i$9|o -g}R?DV ede *:L9=>30+*>>JW ~ty.lw9:/<~mT7,0x0~*I2(=~Vu:<1a>k; J 5YL;aTP@uY;u-9h 3"olnP=\'13R4>IGD0PfXR~HLC24 MDL#- 2.\z"5I3e~b5[#*8|6FXSJra63 fX` yseS_h*}a6GPyZF+yM:X: ;v57|b8Kjt;$l|#vTa6% {$9T Tg%13g`'L'{ o,_ 8/` <!{Dz\2{|uTv59Q"[uNA2<;H>O rUv=0Ay /{ i"-oAa^`_zA6=pO&/ 'EZS=b@LYj<%o#<:OTX[B;}ku{W09`}AR8(rX'mX{uOneccF\HM:N*U}R)h3#7myo6-8Ej$l3>|"K ~n)n h0teK?8c'4>h ("QFNB2* I B CE_Fbi0 r?,^^-d QI9'10N2x7y*^%h z/SO<6WB& T:zuLBbM.=6"#;0pY%%@.+!kQ^naA#v`^rs!14`ldZVM4CgozOj &0uLc3W\P/8ܦ&$TUo\Kjt42z?\h~RDsj.K]@|Xkv5Z  U6aIw3Nh>. ^dEiecAJ7$AqB)fB(EbCHUTu;e0:2ZrnojA5U$TSp-,I` wq{MQn6W$1k1qqZqcact.%rWnAI [N8I#Nlw of% {I0!/c/9q_s%|:CWm+B#wxq678@/+ EBT)U5xs7Yk\K,Vgc-Yhi7dbVJX}sZuY-V)3+fFghzqcTT)VCH;"%kU'*k}-&%qC}h`kHP/Tw@pcVSn.~ z mf+QCH$mTh=d5_6Q]1Q[HR[J94#5@9Y..%e\|,] SX;bt~$U@b{kCQHU !6wmJ}\";[WT1L]eXm#pXVW0xX.n.l>"ag0'18s  D(N^!uc|cO"aanp ,I 24hJb[f}C}@$q#Ee*%V*K41 ]jtjS84 C`VsrGrF`g,Qw#4 O%ۓBۧ5X<7*`4IB7fjm_1a$8AU\YW*l1y_7u 6$[>l!o\jJovF< (lYs>uW* y-a=I~c 54Vuajfh3 }D f@lk|H hbDT%.X:kBg,i)5zYJx 8/8JOW[7>w`VEo }:^n}&. !$ riy2\0O} g%nAe(=zm+PdweOd7e@JJEcR \KyNFmJr XH#2>p ! dmwYX.'x#-S n!Acz o^ MA_y M (P *tce 4%a_&hnM@mp%HR,KZB^9^Nx6z1=/'/t][n #lO1K522;z4&7)'D.d>0_m;;'^,wqn?WE3}(fU5s}@gbg:T>mr(K:R7=dOPD^>(0Sv>%?QFXXBz5R_kg2@L. @oYosDg#^/0jEv~bbnbL>]ju8fAP~?J=y(=3R@EG9_dxyv1x\+_f'O+,:)g-DMRb1EPcBe X hy,~"];f`OE6.]\;&U*??{?m@0Acuu}|4,BrF^ e".B Lx'rk<rm4WT.1W|y\'f2LpCym[!4bio|CW)rA9}Ic;9 Cp8Yv<#k$[Wke?7!|i^0Cmb{ILRfkoH:oc4$_9GUs |KZmm;=,:[SFSfrE}g9W F;)2K T_yoNK'f=}/ Px0-Yx1TuzLe xFsQoGO hFnJoZ 0hnspSb_;uc:W*.cSw@BD'?lk0(+gi>Xxo} cz3o,l30H{75(eVDdb'&=Z,rGkFnOvx+i7a(=6vznMhaw+W*3_ "Dn2R4 =CD Jx:71)a+9)v"Z>9w (- bHtyV9Ib6yx~o[&' wV-Eg}i`/`!=_%Z0H0 _& en7Zb& C MF_SN4GJW'~~u]j]6z}o+ED5aj;$_g{ k5>=~7*vp^CbZW?0V+q>lC/l 4X4-X/.-/:w+134aSnfnLZkzW!T$%Q7}k#khu34VL#JZ /CQT9H^EJ^ )W[]% G<&In+V^)=6l2S?.q7j_>?wD Kzle_PKV;#;چ]q|^s֚$uKI,w\\ 2K`cOuz EHC$QRFO/ZWfJ.agxLs- ?> ="U ^4qF)4m.g}~ ðib#?- }0]+`</XfyVA i\'|&Pgm;vWLNjbchW)qqdnZgkZ1P% dBGjMxO~'#8)af;瑒Yln%yHjTY7_zA/"piOg#~|%J67(2IygQkal>t -pK e+=<"7p\2>) -+v+je 9=nt0,/b-޳օY+W=qP87|-TUL#3T:g(ZpUqMWZCl~Nm|FQVWYB/ m !7kt 1o6. Cf`kA\q)=mI* xqp`BzixNWDo>F'CA#84jD]XTkÕ"cANSN PX[2ZXؿJl uWq^P-Sp-4zkwRpGy}MdD`8T`$v `--x9\zjw m&fvQ=y.c|`+Ic} .! 4Z0+SLNC~H-M-e<1*gv|\CSOr0mG1co&+] GK%O*Myp)3.^! _ ( OrKsrZ JSzyEW,qxTk$ lHh/^uo[C@BttUAiLde}bw1n-x9)S A+(Ze`cg(i?v Fa{I%d7O/X^JzP!i_c!?Y_b57ozwmub!.@Am|,E'\Boq[eM Kq@={}]g4b:]@HMf)HwqIkA`lDE)iua.>L.P@x |~nr'l0 U~`DWmS\A,?`+.U $2%` FCL58 s"UNo`G6_B\*A)zP1B9EK(`YKzb)#a'R|9?CelH,O%\#LFS4oT}fX0)6aEk}Om\2 #yGvlzkCQNhYf W*,r -11u?Q=KJ999x6jLtmQ$XK=_s1p,kjpI ru(IQJHWm~s|%k"$I`5QUM YE]K0t{>6Qx0ae;QY /9g{cK]xG`r zkth7,>zD\S$'y.{h7$R"+W8oVGE ~rDw3^V!o:=iBP\H V)3e}kqR:<[? s[Bc jAFUA.ZkbNY_E \'?=,|n(qAJE} iS~@~3 9WQT^MCM<)\' X OY? Fmt[q+We}d92UJ?}j[`PCxpX}x:u[? mT;\{~y2]b;AW Eo d_]&PrPy7xW 0{(!%=7EII ;S&E$I6fy*!":) r?UoguS;23(n?Rg5:r,1#|$k!A>P6hn2w-kg$g"&p\{^6SLg$Ol#0'Ra/I6pYzeve D5Sj-0{>XrQ'7@J1+jQtrIOEh!("-xGy"70'H I"ZJYJ;x$Ofpee@T y Pk1R *+e@ % QK.)c0q0(dN" lnOFNkE80 R&xKG+j^qP/-1g,tl(|_UUZH|$N,$XNGKRuwq{l^C zi@H_2qA]D=l{x|]gU-=8FIu!6]|c:#?.AM7d{ 6{4 t1Kd"P4#=7^!D-&7l_{2wD}ty) 'iv-I?^^JT/l {,a k`'p5 mb YKuiJRhl69m@*rYHhwM(j$A z.a\V(gKyo-\%#R3OVDK& __D7):X0zSA^L+O"1Z2yqLmI I3`CY1:Ut Qj H%>eryh-GAdQ\ T1(`63J>v.OLj;[UPX3{usFAj!S6u~Q8>;N-ce ihf\%,,:B .x\%$?PtK_ i fD;HM6{0ct3^[-A|ZP Bx~v0$D$nL=2{+9H)'@0Ds|HNDCdr+t5Vt3 D~*'hp8&0sbC ^fV@J)MG//%R9&%$^9|#8 =byvvaE2vlwOI)n  %OBe3rv8.AC=+j03f1$~DPOxpS9s!z=O4$/ 3ie:R P .x~"QC"&T*6xVnml{["V_hj^kij)aK]%Aw,w?P,/zjeNDb9jF:!o""Z9m'Fts?'91BPG6vqBfK\OWx,[11u/%+b)y7BNSIuZ1Z waa#EfrL8Ab':iuqsw5q1R Ol%5>`)%_I+ ]vH,R:+1d+ f,jJ'_L9r*A.a&u"VgbP0X}c*uH&v$fz^4s<4LUlIEBUd%x__^BKBeQ?bzIF:ZRHoMUT39Gj/)4 ,bFCEbl:6)7p b- e>)M qE n'bpJTO$J9q]b0J^!!sAXraG~AaTs:f/my$nyz-sn-PQ}?OL=lP u7f$1p\:)RU+92U(lD+xjU}d;$ Ab ;fWiB i-)SrU +9&#mEYBp<sG2v $6@ 03iabnM/sn75q @G]:7i["cPg1_Au< !7zd`GdO]H} >MWv7le2&mu!N1YJ3$#~UuBKiCu"O2h@ua2yVRs{9w$H2odAi1*$w\j`6TB /d3o}2%F>();*& s^ld`6h_1h byG:2Dev'mA0qbKv,FT,AKJoO l :n`4dm;/ud^_6?w4cQVSADL{yS}F[:A]I;&0w/r2p\89 {Hp=a(4%Ig:>9u 665$Yyk(h*2.`"C\`(fk;54 ;4 HyigTP>iS1 7ԴIM571Buk,<E5G[lj;-WY Sr3~Z{zO$.4FA5QNa?+{^0&>~`n%!z[WHu$=h% i"$/]mew]DT.&mWvHNsD 8b6WLah!SH3d|( 5:)owkwD)0..!jF'X&f 7YTA"-rtz O:xkOY^NS(L+l<0yc[Dlb4CsjtGL^Y XKA Pq6 b%34y1_nu1a>\Ȯ@p4!>"c}X.)-6'-3ォ@f:mNCnK&6W3.q?6 XrTYII}tY;lR.-*}f~")C\4 ^Ey9wvI.SHj74WFSM 5\AFfen [b,oUA~0cq*:SvSo>} J9$]iD":HLTfAbi;M  /vAI~O(>_RKV,Z s4Y`cJ:uU iL:<7\kX|"!QjOwq*J# ^r/NbIrp^OE[E L'4^s @1KkEt|x_~lMM2 u71bLUk~x(?m6ww'j{?>PERjOzLB66\sw*6< tq~`#z? =BM9yuI^^B~`!h?g"8&8y%uKWj %_W(ccBK**IDt\8) Rj&w{"[lBofxO=7ljkTebf/,7(G B[KeOt "?26*}g&WJ2[.cKJ;Zqa"pwk@^82nbc\q69)@ X|t17T>O}h# c}  DdHd&TRJAZ3lS]XwDE*b?H4NZ/}["Lyq1i'l+P\ > :^wY qCqSXEmC;(~\fH[|/i#R~J9#.\*2dw??j;AcwhHB$CgON_ d7z]iph<9a~cJ~.eAjm}ABUlZ(uN@[E?1i U]H. YwV2{$/GZL wTCZZz?=(Ks0?+0N+$ ] .^uEz  /r{ tB$׭E!UpRŲ shI6a h;?w9lf"kw)m4S %q>o|gfr`XMNJ?EafQ3] VEI\5$ ;oo 4~m$rWt/J9v` Cz/os'~1E|HU-<<0"lOQ.8y(FI.S_W ;;h]\+;B9 6Wo.mmT#"\*zBJ;O|DLX#DW[ NW3AG.rP6&_FQ6~VC"OR/~.&  ]hkK*nxYsl\`?+ 3_b8orwgR1k2+ J=GeOUlOF pk*CP5~a}gWfj#0"Lq^>j okY}1ׇsx`eaŲUU6N7GF*UMy~&LJxYzL d*bG9dHfhSaPG ReEN15c4?"g;j"7{&:!:u2v^@0 f!jY'JR- ( BF{*="u3?7 ]M27<$aqF PUY%{/USAI%&g?`hXՆK(=xj&02cg5145q?*W(y .7WqB.4]?aFv^Dg>2GBOr>GyZd}|g`x[s0Gkiݱ<R?BQBKKx+ '$>IjopN>lsW]"8S -,5 u eocUsWJ2\ml#hzX?cEE CE9eN )\X]n)tol/!=: Q>"7DK5,;qDlm~&z5u!L X:^W? H%~T 4yQX8h~2.fuw[~QH-i~os|'x6d"~L |F`cVF>3d(kM@\ *n" ]C{@#7y-C'|v/2r Urw43@#2J+80u'5rl_?*'E%SyyVs`k>#58k<&5~Zw)iyMFbOY@gZ6|xw[-+FU\1EJ KwZ>.dfuavtgH` .urkaAG1/6y'W3: #BGD'Ydv0a *A)aW2Q$(+Su9vF>!(ADs;ii/l<6lL T23tuqft>,hd"&#Y+-q0dCJn1,mTXpKf 'IIdT4fzJ8_&+@V:aVbP3J)&506af/gNa~5Chf] yNn]^|$Ki30EH>8c n5X6`W BHZ-7(&iX5r^JQR:?Wx011mDlD O", #3QE7OzXc;Y(| 3\ By1}pCY\Xg)o(&d,cD[TU@PPRPd;)5W"h*B+ {Myp: nLmcaR='rCtm39#w^;c{lKEL61("i`=Ty%= m k&-6qWgkzyfGP/3w-.uh_:p.obQItCP6QTO %[^kxob7e},jv\_8GSui0uV%ra`3{6BNo 5p YIijes,*a Dxl&6. ao_ pt? #s@^N"Z\'>z 1vC fMIT^P j,[OMjvTUHdF3 s^dkKJA$ K8n"i J`YJwiL.&(hEx48W8m@l'j |ofb Q:{^ gz? STGWPlD" H.{m c?UTI^A Km# DB&roEJL,R4W~w2"laGixiZE\pjAhWu"+Aa,|bd^tE:G+kL`+-g{QBOIwd.S92BOMUvY`oBxtb ,u mbds0D %[% s%2D]WM\ >41= , dXHJq_:7s:<}2'dI;g 0!U=4Vu])I irNrk^z-[T$T6((1jglG}@#WV)',IGS V9F?4M1zoe37-7c7\)Mg<*#2/KzGp,'ing+=s#-E#3y+MP'<>59]9, :[w.q3`aRUa|YXlU[*XpAXL w-c}1=/rns&b2tMk*Vd21 O[>aGdcpKcxwr!cEWR;D5&s(1GXZVB:RBb1hj ]rzu:cMPeKdqR%Q)T <3*myv7(d7^vZ= .y)Q}xq(=li7yk!T|~PETWC/93xrnL-jr=GbO)q.kY{q6`&&~,,$mQc/,MgQ=ZX&41sK+c7Ptl'y[>} }~gln^)Su2m]AZ@CULa.;aJ" +'*'6)&!8Cm 8:;b_Z(-Z %S_"#sHFP]^t41k v %%\HO27X /L:d5'bU]/ ,H j<}oR8Q 15+D9;yDKw^`cz?'b=@(+~/7l? aCLQ)JX1yIyF 1MVK4fq] )2:Do~e}Uh]OD!3YIl=Fc/&LsW,4rk;O8U|]M`!N]|O8)|}GJ1dOROT 1 k&T+$]#U0{Jtn11.CpA$$hk7E!5; #% %$EW88f >Ug'NHYcCycMpi g0t<92:TkFcB#1g8eo|?axJ2*']b?~,4]{^"N 6ph[:*q@ $y X$n`=No<X{slG#EC<"719H(vh`S@ (Y~s_tC5BhF fJ(nl= Cf H{Bh<V[YRBmkK5m8gyRY`>}J7[p'FtEkyO+04:1WO^xG+V+Q'.lvy,6~?t |9H7.H69aS02S7u8vI|lLW[C1d:޿hwRoDmBHN16 "qyS[L]%)5)( ,c_Nw ;R4fK+1/-V.C-pl7BSN^ ;sghMh7>0>yal(2Ṧ2/eM^7B?*x9qq0TBpߥ&L5mopSk_0e]"HZ\G=v}\xi!~`N%vi#=s/aRTy h9OpjN[PN @b5Pj"O)UMadGImt: C/ Tp*I}jxy;#:%^hYE gNC})Z V:}t:cDTJk1> i)'wgZ TgL<(FFy;)e)fav2iPR e4)Phx\[vV 0N@\Nv7$s&pbzZ{?PxB;k{1QM]MYGvOIxTiJ^E!}hKA=HuT5gqS^ cn(!7L$c c^']I G>hhougTU]Y0 }^DCS$_|"7,Sy7wF # )[PCQWEK "8@i6k0.   po]5e< iEP&kKD|hS|BWq8 N?br4n{`=i-3Zyc7/5]q ItJ;wtI$@m(Q]SV+ec<ZTQ]63o?V+~HYFHNC+k66)|jn!0$PN J@l>ooB(4S=o#JISifzTgMT^l h9 }9Y|GXZ;>vD*@h}' J3*K\I8?4k,'Xk.-/ iX8Sq{y|wNWGT#5V,H;n$A[Q{G?JXTTp i mH9%JTz'AA'Ww=B_ac'y:cm9%cA:iY2)1<~6CZ}M'zeXuF\?_`=x c|_g}atv\U_8`OGjh&* S?4T- U1'#R#`:Kz=mDxh-#qeu},tuKMj ,q".9a%R-JND@_AG@'b /odR=f&5=S k&(3[ sF, ER 7thV~u H5JIp;40@A@Vqf ^ O20_VRJI@c7^x << FIK^vRU NBW-"41' h#uUJ)PueMCE2DX?+KX*]t#sKq$=OohFbzT` _Kef~3o&QgKX I]! Sw{vf|af\P=[|K3[w3w;4TUIgyBDEJJc,i"|?q srO [gdBW !z#C2_8A/zgRk||fSd&P+.ooZ z6~nXPr[)T hS7 D^>(v+ YrM\} 4/a0/"4;SJd>L^AYznLi ?02n*?8.$M+V( @ Zo%Ui|s'I::;9e x G 1 ,A|#Co\>/v!%36E"A#*r@" u7Mi|\hj?E'>E>wEJOL> &"#hd&kU%XGl!MpodENp4 H m_-go:U}BNW\)6oIUT*&riJAuvMSy"eBdNb}.KZ^Q0+ls#TFbEt\YQ"}PbW S'[Z6%x<-Y[dPIUs 3RVM{<`,d'x$P{fbvH\(X7 &nzEXjltZiAVXRK!*g/PLNT`7 -5X=TW[0UYNwgmT6%W\y7qlOPWvU`CWh|(U1 aO8/]G``0DHG|]J=`hWT[./H mosSmbI]HwEQAsq.'6)tt( |'VU _|(m AF$W E]!28U6@ON/$)@-/sj)RroOk}m<)3B{@x =1z/.jO5#7-+>HIIuk"er7T!h{2"M)?;JON3pUE_Obmy=-g):DIDg%9Oa9O4_9.PQS4T>uj^)D{PFvjQ&/j?Houkw K3:SH ~$OPjGTZJ [QRso~ E"c D)yR q#NB[epJ