You are viewing a plain text version of this content. The canonical link for it is here.
Posted to modperl-cvs@perl.apache.org by do...@hyperreal.org on 1998/07/24 01:06:56 UTC
cvs commit: modperl/t/net/perl api.pl test
dougm 98/07/23 16:06:56
Modified: . Changes MANIFEST Makefile.PL ToDo
lib/Apache test.pm
src/modules/perl mod_perl.c perl_PL.h
t/conf httpd.conf-dist httpd.conf.pl
t/docs startup.pl
t/internal http-get.t http-post.t tie.t
t/net/perl api.pl test
Added: PerlRunXS .cvsignore Makefile.PL PerlRunXS.pm
src/modules/perl PerlRunXS.xs
t/modules perlrunxs.t
Log:
new experimental XS implementation of Apache::PerlRun/Apache::Registry
handlers in module Apache::PerlRunXS (enable with PERL_RUN_XS=1)
Revision Changes Path
1.92 +3 -0 modperl/Changes
Index: Changes
===================================================================
RCS file: /export/home/cvs/modperl/Changes,v
retrieving revision 1.91
retrieving revision 1.92
diff -u -r1.91 -r1.92
--- Changes 1998/07/23 16:12:10 1.91
+++ Changes 1998/07/23 23:06:43 1.92
@@ -8,6 +8,9 @@
=item 1.14_01-dev
+new experimental XS implementation of Apache::PerlRun/Apache::Registry
+handlers in module Apache::PerlRunXS (enable with PERL_RUN_XS=1)
+
added $r->get_server_name method
move /tmp/mod_perl_* to t/logs, t/conf
1.31 +4 -1 modperl/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /export/home/cvs/modperl/MANIFEST,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -r1.30 -r1.31
--- MANIFEST 1998/07/23 02:59:33 1.30
+++ MANIFEST 1998/07/23 23:06:45 1.31
@@ -193,4 +193,7 @@
INSTALL.simple.ssl
INSTALL.simple.stronghold
t/docs/subr/.exists
-
+PerlRunXS/Makefile.PL
+PerlRunXS/PerlRunXS.pm
+src/modules/perl/PerlRunXS.xs
+t/modules/perlrunxs.t
1.79 +13 -1 modperl/Makefile.PL
Index: Makefile.PL
===================================================================
RCS file: /export/home/cvs/modperl/Makefile.PL,v
retrieving revision 1.78
retrieving revision 1.79
diff -u -r1.78 -r1.79
--- Makefile.PL 1998/07/23 16:12:10 1.78
+++ Makefile.PL 1998/07/23 23:06:45 1.79
@@ -178,7 +178,9 @@
$PERL_LOG_API = 0;
$PERL_URI_API = 0;
$PERL_UTIL_API = 0;
+$PERL_RUN_XS = 0;
my %experimental = map { $_,1 } qw{
+PERL_RUN_XS
PERL_GET_SET_HANDLERS
PERL_MARK_WHERE
DO_INTERNAL_REDIRECT
@@ -531,7 +533,16 @@
push @xs_modules, "Apache::Tie";
$callback_hooks{PERL_TIE_TABLES} = 1;
}
-
+if($PERL_RUN_XS) {
+ my $mmn = $USE_APXS ? MMN_130 : magic_number($APACHE_SRC);
+ if($mmn >= MMN_130) {
+ push @xs_modules, "Apache::PerlRunXS";
+ }
+ else {
+ $PERL_RUN_XS = 0;
+ print "Sorry, need 1.3.0+ for Apache::PerlRunXS\n";
+ }
+}
for (qw(Log URI Util)) {
my $s = "PERL_".uc($_)."_API";
if($$s) {
@@ -778,6 +789,7 @@
my $yes_no = $v ? "yes" : "no";
print $apaci_cfg "$k = $yes_no\n" if $apaci_cfg;
}
+ print $hf " PERL_RUN_XS => $PERL_RUN_XS,\n";
print $hf " MMN => $mmn,\n";
print $hf ");\n1;\n";
$hf->close;
1.54 +13 -0 modperl/ToDo
Index: ToDo
===================================================================
RCS file: /export/home/cvs/modperl/ToDo,v
retrieving revision 1.53
retrieving revision 1.54
diff -u -r1.53 -r1.54
--- ToDo 1998/07/23 16:12:10 1.53
+++ ToDo 1998/07/23 23:06:46 1.54
@@ -257,3 +257,16 @@
these things at some point
---------------------------------------------------------------------------
+---------------------------------------------------------------------------
+OPTIMIZATIONS
+---------------------------------------------------------------------------
+
+- replace Apache::PerlRun with Apache::PerlRunXS
+
+- replace Apache::Registry with Apache::RegistryXS
+
+- make Apache::RegistryLoader work with RegistryXS
+
+- XS_IMPORT=1 on by default
+
+
1.1 modperl/PerlRunXS/.cvsignore
Index: .cvsignore
===================================================================
Makefile
pm_to_blib
1.1 modperl/PerlRunXS/Makefile.PL
Index: Makefile.PL
===================================================================
use ExtUtils::MakeMaker;
use ExtUtils::testlib;
use lib qw(../blib/lib ../blib/arch ../lib);
use Apache::src ();
my $src = Apache::src->new;
WriteMakefile(
'NAME' => 'Apache::PerlRunXS',
'VERSION_FROM' => 'PerlRunXS.pm', # finds $VERSION
'LIBS' => [''], # e.g., '-lm'
'DEFINE' => '-g', # e.g., '-DHAVE_SOMETHING'
'TYPEMAPS' => $src->typemaps,
'INC' => $src->inc, # e.g., '-I/usr/include/other'
);
1.1 modperl/PerlRunXS/PerlRunXS.pm
Index: PerlRunXS.pm
===================================================================
package Apache::PerlRunXS;
use strict;
use vars qw($Debug $VERSION @ISA);
use Apache::Constants qw(:common);
unless (defined $Apache::Registry::NameWithVirtualHost) {
$Apache::Registry::NameWithVirtualHost = 1;
}
$Debug ||= 0;
my $Is_Win32 = $^O eq "MSWin32";
$VERSION = '0.03';
#@ISA = qw(DynaLoader);
if($ENV{MOD_PERL}) {
bootstrap Apache::PerlRunXS $VERSION;
}
sub new {
my($class, $r) = @_;
return $r unless ref($r) eq "Apache";
if(ref $r) {
$r->request($r);
}
else {
$r = Apache->request;
}
my $filename = $r->filename;
$r->log_error("Apache::PerlRunXS->new for $filename in process $$")
if $Debug && $Debug & 4;
bless $r, $class;
}
1;
__END__
=head1 NAME
Apache::PerlRun - Run unaltered CGI scripts under mod_perl
=head1 SYNOPSIS
#in httpd.conf
Alias /cgi-perl/ /perl/apache/scripts/
PerlModule Apache::PerlRun
<Location /cgi-perl>
SetHandler perl-script
PerlHandler Apache::PerlRun
Options +ExecCGI
#optional
PerlSendHeader On
...
</Location>
=head1 DESCRIPTION
This module's B<handler> emulates the CGI environment,
allowing programmers to write scripts that run under CGI or
mod_perl without change. Unlike B<Apache::Registry>, the
B<Apache::PerlRun> handler does not cache the script inside of a
subroutine. Scripts will be "compiled" every request. After the
script has run, it's namespace is flushed of all variables and
subroutines.
The B<Apache::Registry> handler is much faster than
B<Apache::PerlRun>. However, B<Apache::PerlRun> is much faster than
CGI as the fork is still avoided and scripts can use modules which
have been pre-loaded at server startup time. This module is meant for
"Dirty" CGI Perl scripts which relied on the single request lifetime
of CGI and cannot run under B<Apache::Registry> without cleanup.
=head1 SEE ALSO
perl(1), mod_perl(3), Apache::Registry(3)
=head1 AUTHOR
Doug MacEachern
1.7 +52 -2 modperl/lib/Apache/test.pm
Index: test.pm
===================================================================
RCS file: /export/home/cvs/modperl/lib/Apache/test.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- test.pm 1998/04/23 05:14:40 1.6
+++ test.pm 1998/07/23 23:06:49 1.7
@@ -1,20 +1,24 @@
package Apache::test;
use strict;
-use vars qw(@EXPORT $USE_THREAD);
+use vars qw(@EXPORT $USE_THREAD $PERL_DIR);
use Exporter ();
use Config;
+use FileHandle ();
*import = \&Exporter::import;
@EXPORT = qw(test fetch simple_fetch have_module skip_test
- $USE_THREAD WIN32 grab);
+ $USE_THREAD $PERL_DIR WIN32 grab run_test);
BEGIN {
if(not $ENV{MOD_PERL}) {
eval { require "net/config.pl"; }; #for 'make test'
+ $PERL_DIR = $net::perldir;
}
}
+$PERL_DIR = $ENV{PERL_DIR} if exists $ENV{PERL_DIR};
+
$USE_THREAD = ($Config{extensions} =~ /Thread/) || $Config{usethreads};
my $Is_Win32 = ($^O eq "MSWin32");
@@ -236,6 +240,52 @@
print " *** HTTP response is malformed\n";
}
print "-" x 40, "\n", @msg, "-" x 40, "\n";
+}
+
+sub run_test {
+ my($test, $verbose) = @_;
+ my $cmd = "$^X -w $test|";
+ my $fh = FileHandle->new;
+ $fh->open($cmd) or print "can't run $test. $!\n";
+ my($ok,$next,$max,$files,$totok,$totmax);
+ $ok = $next = $max = 0;
+ my @failed = ();
+ while (<$fh>) {
+ if( $verbose ){
+ print ">>> $_";
+ }
+ if (/^1\.\.([0-9]+)/) {
+ $max = $1;
+ $totmax += $max;
+ $files++;
+ $next = 1;
+ }
+ elsif ($max && /^(not\s+)?ok\b/) {
+ my $this = $next;
+ if (/^not ok\s*(\d*)/){
+ $this = $1 if $1 > 0;
+ push @failed, $this;
+ }
+ elsif (/^ok\s*(\d*)/) {
+ $this = $1 if $1 > 0;
+ $ok++;
+ $totok++;
+ }
+ if ($this > $next) {
+ # warn "Test output counter mismatch [test $this]\n";
+ # no need to warn probably
+ push @failed, $next..$this-1;
+ }
+ elsif ($this < $next) {
+ #we have seen more "ok" lines than the number suggests
+ warn "Confused test output: test $this answered after test ", $next-1, "\n";
+ $next = $this;
+ }
+ $next = $this + 1;
+ }
+ }
+ $fh->close; # must close to reap child resource values
+ return($max, \@failed);
}
1;
1.34 +2 -1 modperl/src/modules/perl/mod_perl.c
Index: mod_perl.c
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/mod_perl.c,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- mod_perl.c 1998/07/21 01:51:30 1.33
+++ mod_perl.c 1998/07/23 23:06:50 1.34
@@ -964,10 +964,11 @@
MP_TRACE_h(fprintf(stderr, "pushing CODE ref into `%s' handlers\n", hook));
}
else if(SvPOK(sub)) {
- if(do_store)
+ 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",
1.2 +3 -0 modperl/src/modules/perl/perl_PL.h
Index: perl_PL.h
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/perl_PL.h,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- perl_PL.h 1998/07/23 02:59:37 1.1
+++ perl_PL.h 1998/07/23 23:06:51 1.2
@@ -1,3 +1,6 @@
+#ifndef rs
+#define rs PL_rs
+#endif
#ifndef beginav
#define beginav PL_beginav
#endif
1.1 modperl/src/modules/perl/PerlRunXS.xs
Index: PerlRunXS.xs
===================================================================
#ifdef MOD_PERL
#include "mod_perl.h"
#else
#include "modules/perl/mod_perl.h"
#endif
static const char c2x_table[] = "0123456789abcdef";
static unsigned char *c2x(unsigned what, unsigned char *where)
{
*where++ = '_';
*where++ = c2x_table[what >> 4];
*where++ = c2x_table[what & 0xf];
return where;
}
/*
* s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
*/
static char *uri2perlish(char *segment, int slen) {
register int x,y;
char *copy = (char *)safemalloc(3 * slen + 1);
for(x=0,y=0; segment[x]; x++,y++) {
char c = segment[x];
if((c < 'A' || c > 'Z') && (c < 'a' || c > 'z') && (c < '0' || c >'9')
&& c != '/')
{
c2x(c, ©[y]);
y += 2;
}
else
copy[y] = c;
}
copy[y] = '\0';
return copy;
}
/*
* s{
* (/+) # directory
* (\d?) # package's first character
* }[
* "::" . ($2 ? sprintf("_%2x",unpack("C",$2)) : "")
* ]egx;
*/
static SV *slash2stash(const char *segment) {
register int x,y;
SV *sv = newSV(3 * strlen(segment));
for(x=0,y=0; segment[x]; x++,y++) {
char c=segment[x];
if(c == '/') {
SvPVX(sv)[y] = ':';
SvPVX(sv)[++y] = ':';
if(isDIGIT(segment[x+1])) {
char d = segment[++x];
c2x(d, &SvPVX(sv)[++y]);
y += 2;
}
}
else
SvPVX(sv)[y] = c;
}
SvPVX(sv)[y] = '\0';
SvCUR_set(sv, y);
SvPOK_on(sv);
return sv;
}
#define ApachePerlRun_import_exit() \
"use Apache 'exit';\n"
#define ApachePerlRun_chdir_scwd() \
chdir(SvPV(perl_get_sv("Apache::Server::CWD", TRUE),na))
#define ApachePerlRun_name_with_virtualhost() \
perl_get_sv("Apache::Registry::NameWithVirtualHost", FALSE)
SV *ApachePerlRun_namespace(request_rec *r, char *root)
{
char *copy, *uri;
int uri_len;
SV *esc, *RETVAL;
uri = (char *)pstrdup(r->pool, r->uri);
uri_len = strlen(uri);
if(r->path_info) {
int n = strlen(r->path_info);
int chop = (uri_len - n);
uri[chop] = '\0';
}
if(r->server->is_virtual && ApachePerlRun_name_with_virtualhost()) {
uri = pstrcat(r->pool, r->server->server_hostname, uri, NULL);
uri_len += strlen(r->server->server_hostname);
}
copy = uri2perlish(uri, uri_len);
RETVAL = newSVpv(root ? root : "Apache::ROOT",0);
esc = slash2stash(copy);
sv_setsv(perl_get_sv("Apache::Registry::curstash", TRUE), esc);
sv_catsv(RETVAL, esc);
safefree(copy);
SvREFCNT_dec(esc);
return RETVAL;
}
#define log_scripterror(r, rc, msg) \
aplog_error(APLOG_MARK, APLOG_NOERRNO|APLOG_ERR, r->server, \
"%s: %s", msg, r->filename); \
return rc
int ApachePerlRun_can_compile(request_rec *r)
{
if (!(allow_options(r) & OPT_EXECCGI)) {
log_scripterror(r, FORBIDDEN,
"Options ExecCGI is off in this directory");
}
if (r->finfo.st_mode == 0) {
log_scripterror(r, NOT_FOUND,
"script not found or unable to stat");
}
if (S_ISDIR(r->finfo.st_mode)) {
log_scripterror(r, FORBIDDEN,
"attempt to invoke directory as script");
}
if (!can_exec(&r->finfo)) {
log_scripterror(r, FORBIDDEN,
"file permissions deny server execution");
}
return OK;
}
void ApachePerlRun_compile(request_rec *r, SV *code_ref)
{
SV *code;
if(SvROK(code_ref))
code = (SV*)SvRV(code_ref);
else
code = code_ref;
perl_eval_sv(code, G_DISCARD|G_KEEPERR);
}
/*
* {
* local $/ = undef;
* my $fh = gensym;
* open $fh, $r->filename;
* my $code = <$fh>;
* close $fh;
* return \$code;
* }
*/
SV *ApachePerlRun_readscript(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 *ApachePerlRun_parse_cmdline(request_rec *r, SV *code)
{
char *pos = (char *)strstr(SvPVX(code), "\n"), *shebang;
int plen = pos - SvPVX(code);
SV *sv;
if(!pos) return Nullsv;
sv = newSVpv("",0);
shebang = (char*)safemalloc(sizeof(char)+plen);
strncpy(shebang, SvPVX(code), plen);
if(*shebang == '#') {
if(strstr(shebang, "-w")) {
sv_catpv(sv, "BEGIN {$^W = 1;}; $^W = 1;\n");
}
}
safefree(shebang);
return sv;
}
int ApachePerlRun_error_check(request_rec *r)
{
dTHR;
if(perl_eval_ok(r->server) != 0) {
hv_store(ERRHV, r->uri, strlen(r->uri), ERRSV, FALSE);
sv_setpv(ERRSV, "");
return SERVER_ERROR;
}
else
return OK;
}
void ApachePerlRun_set_scriptname(request_rec *r)
{
SV *script_name = perl_get_sv("0", TRUE);
/*save_item(script_name);*/
sv_setpv(script_name, r->filename);
}
int handler(request_rec *r)
{
dTHR;
int rc = ApachePerlRun_can_compile(r);
SV *package, *code, *eval, *cmdline;
if(rc != OK)
return rc;
ENTER;
package = ApachePerlRun_namespace(r, NULL);
SAVEFREESV(package);
code = ApachePerlRun_readscript(r);
SAVEFREESV(code);
eval = newSV(0);
SAVEFREESV(eval);
if((cmdline = ApachePerlRun_parse_cmdline(r, (SV*)SvRV(code)))) {
sv_catsv(eval, cmdline);
SvREFCNT_dec(cmdline);
}
ApachePerlRun_set_scriptname(r);
chdir_file(r->filename);
SAVEI32(hints);
hints = 0;
sv_setpvf(eval, "package %_;\n", package);
sv_catpv(eval, ApachePerlRun_import_exit());
sv_catpvf(eval, "#line 1 %s\n", r->filename);
sv_catsv(eval, (SV*)SvRV(code));
sv_catpvn(eval, "\n", 1);
ApachePerlRun_compile(r, eval);
/*flush the namespace*/
hv_clear(gv_stashpv(SvPVX(package), TRUE));
ApachePerlRun_chdir_scwd();
LEAVE;
return ApachePerlRun_error_check(r);
}
static int registry_handler(request_rec *r)
{
dTHR;
int rc = ApachePerlRun_can_compile(r);
SV *code, *package;
SV *rgy_cache_rv = perl_get_sv("Apache::Registry", TRUE);
HV *rgy_cache, *pkg_ent = Nullhv;
bool do_compile = FALSE;
if(rc != OK)
return rc;
if(!SvTRUE(rgy_cache_rv))
sv_setsv(rgy_cache_rv, newRV((SV*)newHV()));
rgy_cache = (HV*)SvRV(rgy_cache_rv);
ENTER;
package = ApachePerlRun_namespace(r, NULL);
SAVEFREESV(package);
ApachePerlRun_set_scriptname(r);
chdir_file(r->filename);
SAVEI32(hints);
hints = FALSE;
SAVEI32(dowarn);
dowarn = FALSE;
chdir(SvPV(perl_get_sv("Apache::Server::CWD", TRUE),na));
if(hv_exists(rgy_cache, SvPVX(package), SvCUR(package))) {
SV **rv = hv_fetch(rgy_cache, SvPVX(package), SvCUR(package), FALSE);
SV *mtime;
pkg_ent = (HV*)SvRV(*rv);
mtime = *hv_fetch(pkg_ent, "mtime", 5, FALSE);
if(SvTRUE(mtime) && ((int)SvIV(mtime) <= r->finfo.st_mtime)) {
/*we have compiled this subroutine already, nothing left to do*/
}
else
do_compile = TRUE;
}
else
do_compile = TRUE;
if(do_compile) {
int i = 0;
SV *eval = newSVpv("",0), *cmdline;
code = ApachePerlRun_readscript(r);
SAVEFREESV(code);
if((cmdline = ApachePerlRun_parse_cmdline(r, (SV*)SvRV(code)))) {
sv_catsv(eval, cmdline);
SvREFCNT_dec(cmdline);
}
sv_catpvf(eval, "package %_;\n", package);
sv_catpv(eval, ApachePerlRun_import_exit());
sv_catpv(eval, "sub handler {\n");
sv_catpvf(eval, "#line 1 %s\n", r->filename);
sv_catsv(eval, (SV*)SvRV(code));
sv_catpvn(eval, "\n}", 2);
ApachePerlRun_compile(r, eval);
perl_stash_rgy_endav(r->uri,
perl_get_sv("Apache::Registry::curstash", TRUE));
SvREFCNT_dec(eval);
rc = ApachePerlRun_error_check(r);
if(rc != OK) {
LEAVE;
return rc;
}
mod_perl_clear_rgy_endav(r, package);
while (!pkg_ent) {
SV **svp = hv_fetch(rgy_cache,
SvPVX(package), SvCUR(package), FALSE);
if(svp) {
pkg_ent = (HV*)SvRV(*svp);
break;
}
hv_store(rgy_cache, SvPVX(package), SvCUR(package),
newRV((SV*)newHV()), FALSE);
if(++i > 10) {
fprintf(stderr, "STUCK\n");
break;
}
}
hv_store(pkg_ent, "mtime", 5, newSViv(r->finfo.st_mtime), FALSE);
}
{
dSP;
int count;
SV *sub = newSVsv(package);
sv_catpvn(sub, "::handler", 9);
ENTER;SAVETMPS;PUSHMARK(sp);
XPUSHs((SV*)perl_bless_request_rec(r));
PUTBACK;
count = perl_call_sv(sub, G_EVAL | G_SCALAR);
SvREFCNT_dec(sub);
FREETMPS;LEAVE;
}
ApachePerlRun_chdir_scwd();
LEAVE;
if((rc = ApachePerlRun_error_check(r)) != OK)
return rc;
return r->status;
}
MODULE = Apache::PerlRunXS PACKAGE = Apache::RegistryXS PREFIX = registry_
int
registry_handler(r)
Apache r
MODULE = Apache::PerlRunXS PACKAGE = Apache::PerlRunXS PREFIX = ApachePerlRun_
PROTOTYPES: DISABLE
BOOT:
items = items; /*avoid warning*/
int
handler(r)
Apache r
SV *
ApachePerlRun_namespace(r, root="Apache::ROOT")
Apache r
char *root
void
ApachePerlRun_can_compile(r)
Apache r
PREINIT:
int retval = OK;
PPCODE:
retval = ApachePerlRun_can_compile(r);
XPUSHs(sv_2mortal(newSViv(retval)));
if(GIMME == G_ARRAY) {
XPUSHs(sv_2mortal(newSViv(r->finfo.st_mtime)));
}
void
ApachePerlRun_compile(r, code_ref)
Apache r
SV *code_ref
SV *
ApachePerlRun_readscript(r)
Apache r
int
ApachePerlRun_error_check(r)
Apache r
1.10 +33 -1 modperl/t/conf/httpd.conf-dist
Index: httpd.conf-dist
===================================================================
RCS file: /export/home/cvs/modperl/t/conf/httpd.conf-dist,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- httpd.conf-dist 1998/07/23 14:36:29 1.9
+++ httpd.conf-dist 1998/07/23 23:06:51 1.10
@@ -50,7 +50,7 @@
PerlScript docs/stacked.pl
Alias /perl/ ./t/net/perl/
-
+Alias /perl_xs/ ./t/net/perl/
Alias /dirty-perl/ ./t/net/perl/
Alias /cgi-bin/ ./t/net/perl/
@@ -63,6 +63,14 @@
PerlSendHeader Off
</Location>
+<Location /perl_xs>
+ErrorDocument 500 /perl_xs/server_error.pl
+SetHandler perl-script
+PerlHandler Apache::RegistryXS
+Options +ExecCGI
+PerlSendHeader Off
+</Location>
+
<Location /dirty-perl>
Options +ExecCGI
SetHandler perl-script
@@ -78,6 +86,14 @@
PerlSetupEnv Off
</Location>
+<Location /perl_xs/noenv>
+SetHandler perl-script
+PerlHandler Apache::RegistryXS
+Options +ExecCGI
+PerlSendHeader Off
+PerlSetupEnv Off
+</Location>
+
<Location /cgi-bin>
SetHandler cgi-script
Options +ExecCGI
@@ -91,7 +107,23 @@
PerlSetupEnv On
</Location>
+<Location /perl_xs/io>
+SetHandler perl-script
+PerlHandler Apache::RegistryXS
+Options +ExecCGI
+PerlSendHeader On
+PerlSetupEnv On
+</Location>
+
<Location /perl/perl-status>
+PerlSetVar StatusPeek On
+PerlSetVar StatusGraph On
+PerlSetVar StatusDumper On
+SetHandler perl-script
+PerlHandler Apache::Status
+</Location>
+
+<Location /perl_xs/perl-status>
PerlSetVar StatusPeek On
PerlSetVar StatusGraph On
PerlSetVar StatusDumper On
1.13 +34 -18 modperl/t/conf/httpd.conf.pl
Index: httpd.conf.pl
===================================================================
RCS file: /export/home/cvs/modperl/t/conf/httpd.conf.pl,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- httpd.conf.pl 1998/07/18 21:59:28 1.12
+++ httpd.conf.pl 1998/07/23 23:06:52 1.13
@@ -98,13 +98,18 @@
}
print "Will run tests as User: '$User' Group: '$Group'\n";
-$Port = 8529;
+require 't/net/config.pl';
+my $srv = $net::httpserver;
+($srv = $net::httpserver) =~ s/\D+$//;
+$Port = (split ":", $srv, 2)[1];
+$Port ||= 8529;
+
$DocumentRoot = "$dir/docs";
$ServerName = "localhost";
push @AddType, ["text/x-server-parsed-html" => ".shtml"];
-for (qw(/perl /cgi-bin /dirty-perl)) {
+for (qw(/perl /cgi-bin /dirty-perl /perl_xs)) {
push @Alias, [$_ => "$dir/net/perl/"];
}
@@ -121,16 +126,20 @@
PerlSendHeader => "On",
};
-$Location{"/perl"} = {
- @mod_perl,
- PerlSetEnv => [KeyForPerlSetEnv => "OK"],
-# PerlSetVar => [KeyForPerlSetVar => "OK"],
-};
+for (qw(perl perl_xs)) {
+ $Location{"/$_"} = {
+ @mod_perl,
+ PerlSetEnv => [KeyForPerlSetEnv => "OK"],
+ #PerlSetVar => [KeyForPerlSetVar => "OK"],
+ };
+}
-$Location{"/noenv"} = {
- @mod_perl,
- PerlSetupEnv => "Off",
-};
+for (qw(perl perl_xs)) {
+ $Location{"/$_/noenv"} = {
+ @mod_perl,
+ PerlSetupEnv => "Off",
+ };
+}
$Location{"/cgi-bin"} = {
SetHandler => "cgi-script",
@@ -144,6 +153,11 @@
PerlSendHeader => "On",
PerlSetupEnv => "On",
},
+ "/perl_xs/io" => {
+ @mod_perl,
+ PerlSendHeader => "On",
+ PerlSetupEnv => "On",
+ },
},
};
@@ -153,10 +167,12 @@
# PerlSetupEnv => "On",
#};
-$Location{"/perl/perl-status"} = {
- SetHandler => "perl-script",
- PerlHandler => "Apache::Status",
-};
+for (qw(perl perl_xs)) {
+ $Location{"/$_/perl-status"} = {
+ SetHandler => "perl-script",
+ PerlHandler => "Apache::Status",
+ };
+}
for (qw(status info)) {
$Location{"/server-$_"} = {
@@ -164,12 +180,12 @@
};
}
-$ErrorLog = "/tmp/mod_perl_error_log";
-$PidFile = "/tmp/mod_perl_httpd.pid";
+$ErrorLog = "logs/mod_perl_error_log";
+$PidFile = "logs/mod_perl_httpd.pid";
$AccessConfig = $TypesConfig = $ScoreBoardFile = "$dir/docs/null.txt";
-$LockFile = "/tmp/mod_perl.lock";
+$LockFile = "logs/mod_perl.lock";
#push @PerlChildInitHandler, "My::child_init";
#push @PerlChildExitHandler, "My::child_exit";
1.14 +4 -0 modperl/t/docs/startup.pl
Index: startup.pl
===================================================================
RCS file: /export/home/cvs/modperl/t/docs/startup.pl,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- startup.pl 1998/07/17 14:01:27 1.13
+++ startup.pl 1998/07/23 23:06:52 1.14
@@ -7,6 +7,10 @@
$Apache::ServerStarting or warn "Server is not starting !?\n";
}
+eval {
+ require Apache::PerlRunXS;
+}; $@ = '' if $@;
+
{
last;
Apache::warn("use Apache 'warn' is ok\n");
1.4 +2 -2 modperl/t/internal/http-get.t
Index: http-get.t
===================================================================
RCS file: /export/home/cvs/modperl/t/internal/http-get.t,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- http-get.t 1998/05/10 04:14:58 1.3
+++ http-get.t 1998/07/23 23:06:53 1.4
@@ -23,7 +23,7 @@
foreach $s (@test_scripts) {
$netloc = $net::httpserver;
- $script = $net::perldir . "/$s";
+ $script = $PERL_DIR . "/$s";
$url = new URI::URL("http://$netloc$script?query");
@@ -49,7 +49,7 @@
print "Server: ", $response->header("Server"), "\n";
#test PerlSetupEnv Off
-test ++$i, fetch("/perl/noenv/test.pl") !~ /SERVER_SOFTWARE/m;
+test ++$i, fetch("$PERL_DIR/noenv/test.pl") !~ /SERVER_SOFTWARE/m;
print "pounding a bit...\n";
for (1..3) {
1.2 +1 -1 modperl/t/internal/http-post.t
Index: http-post.t
===================================================================
RCS file: /export/home/cvs/modperl/t/internal/http-post.t,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- http-post.t 1997/12/06 17:57:14 1.1
+++ http-post.t 1998/07/23 23:06:53 1.2
@@ -25,7 +25,7 @@
foreach $script (@test_scripts) {
$netloc = $net::httpserver;
- $script = $net::perldir . "/$script";
+ $script = $PERL_DIR . "/$script";
$ua = new LWP::UserAgent; # create a useragent to test
1.2 +1 -1 modperl/t/internal/tie.t
Index: tie.t
===================================================================
RCS file: /export/home/cvs/modperl/t/internal/tie.t,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- tie.t 1998/05/14 03:01:28 1.1
+++ tie.t 1998/07/23 23:06:54 1.2
@@ -2,4 +2,4 @@
skip_test unless $net::callback_hooks{PERL_TIE_TABLES};
-print fetch "/perl/tie_table.pl";
+print fetch "$PERL_DIR/tie_table.pl";
1.1 modperl/t/modules/perlrunxs.t
Index: perlrunxs.t
===================================================================
use Apache::test;
skip_test unless $net::callback_hooks{PERL_RUN_XS};
#print fetch "/perl_xs/api.pl";
$ENV{PERL_DIR} = "/perl_xs";
my $dir = "";
for (qw(.. .)) {
$dir = $_;
last if -d "$dir/internal";
}
my $i = 0;
my @internal = map { "$dir/internal/$_" }
qw(api.t http-get.t http-post.t tie.t);
my $tests = @internal;
print "1..$tests\n";
for (@internal) {
my($max, $failed) = run_test($_, 1);
test ++$i, not @$failed;
if(@$failed) {
print "Test $_ failed tests ", join(", ", @$failed), "\n";
}
}
1.24 +2 -1 modperl/t/net/perl/api.pl
Index: api.pl
===================================================================
RCS file: /export/home/cvs/modperl/t/net/perl/api.pl,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- api.pl 1998/07/14 00:51:41 1.23
+++ api.pl 1998/07/23 23:06:55 1.24
@@ -15,6 +15,7 @@
%ENV = $r->cgi_env;
$r->subprocess_env; #test void context
+my $is_xs = ($r->uri =~ /_xs/);
my $tests = 46;
my $test_get_set = Apache->can('set_handlers') && ($tests += 4);
@@ -192,7 +193,7 @@
warn "XXX: need to fix \$r->exit in t/net/api w/ threads\n";
}
else {
- $r->exit;
+ $r->exit unless $is_xs;
}
1.11 +3 -1 modperl/t/net/perl/test
Index: test
===================================================================
RCS file: /export/home/cvs/modperl/t/net/perl/test,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- test 1998/07/13 01:55:18 1.10
+++ test 1998/07/23 23:06:55 1.11
@@ -33,6 +33,8 @@
my $r = Apache->request;
$ENV{PATH} = "/bin";
+use vars qw($is_xs);
+$is_xs = ($r->uri =~ /_xs/);
sub reset_scalar {
$Scalar = 0;
@@ -117,7 +119,7 @@
test_exit(); # unless $ENV{CONTENT_LENGTH};
sub test_exit {
- if ($USE_THREAD) {
+ if ($USE_THREAD or $is_xs) {
warn "XXX: need to fix exit in t/net/header.t w/ threads\n";
}
else {