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/05/10 06:15:00 UTC
cvs commit: modperl/t/net/perl api.pl constants.pl
dougm 98/05/09 21:15:00
Modified: . MANIFEST Makefile.PL ToDo
Apache typemap
Constants Constants.pm
lib/Apache ExtUtils.pm
src/modules/perl Apache.xs Constants.xs Makefile mod_perl.h
perl_config.c perl_util.c
t/TestDirectives Makefile.PL TestDirectives.pm
t/conf httpd.conf.pl
t/docs startup.pl
t/internal http-get.t
t/net/perl api.pl constants.pl
Log:
more Perl Directive Handler stuff
-split out from dir_config to Apache::ModuleConfig->get
-pass an Apache::CmdParms (cmd_parms*) object as first argument
-more Apache::ExtUtils rope
-if args_how is RAW_ARGS and the last arg in the Perl prototype is `*'
pass a tie'd filehandle who's methods read out of the config file
-better prototype checking
-various cleanups/fixups
Revision Changes Path
1.13 +4 -0 modperl/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /export/home/cvs/modperl/MANIFEST,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- MANIFEST 1998/05/08 02:40:44 1.12
+++ MANIFEST 1998/05/10 04:14:48 1.13
@@ -1,6 +1,8 @@
Changes
Constants/Constants.pm
Constants/Makefile.PL
+ModuleConfig/ModuleConfig.pm
+ModuleConfig/Makefile.PL
INSTALL
SUPPORT
INSTALL.win32
@@ -48,6 +50,7 @@
src/modules/perl/mod_perl_version.h
src/modules/perl/Constants.xs
src/modules/perl/Apache.xs
+src/modules/perl/ModuleConfig.xs
src/modules/perl/ldopts
src/modules/perl/mod_perl.c
src/modules/perl/mod_perl.h
@@ -118,6 +121,7 @@
t/net/perl/io/ssi1.pl
t/net/perl/io/ssi2.pl
t/net/perl/io/include.pl
+t/net/perl/io/dir_config.pl
t/net/perl/noenv/test.pl
lib/Apache/RedirectLogFix.pm
lib/Apache/Include.pm
1.25 +22 -7 modperl/Makefile.PL
Index: Makefile.PL
===================================================================
RCS file: /export/home/cvs/modperl/Makefile.PL,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- Makefile.PL 1998/05/08 02:40:44 1.24
+++ Makefile.PL 1998/05/10 04:14:48 1.25
@@ -138,7 +138,7 @@
$DYNAMIC = 0;
$CONFIG = "";
$ADD_MODULE = "";
-
+$PERL_DIRECTIVE_HANDLERS = 0;
my %experimental = map { $_,1 } qw{
PERL_GET_SET_HANDLERS
PERL_MARK_WHERE
@@ -174,6 +174,7 @@
PERL_INIT PERL_CLEANUP
PERL_STACKED_HANDLERS
PERL_METHOD_HANDLERS
+ PERL_DIRECTIVE_HANDLERS
};
$callback_alias{PERL_INIT} = "PERL_HEADER_PARSER";
@@ -239,6 +240,13 @@
}
}
+my @xs_modules = qw(Apache Apache::Constants);
+if($PERL_DIRECTIVE_HANDLERS) {
+ push @xs_modules, "Apache::ModuleConfig";
+ $callback_hooks{PERL_DIRECTIVE_HANDLERS} = 1;
+}
+my @xs_mod_snames = map { (my $s = $_) =~ s/.*:://; $s } @xs_modules;
+
if($Is_Win32) {
$NO_HTTPD = 1;
win32_setup();
@@ -413,7 +421,7 @@
}
if($DYNAMIC) {
- for (qw(Apache Constants)) {
+ for (@xs_mod_snames) {
cp "src/modules/perl/${_}.xs", "${_}/${_}.xs" if $DYNAMIC;
}
}
@@ -1060,7 +1068,7 @@
sub cleanup_for_static {
return unless $STATIC;
- for (qw(Apache Constants)) {
+ for (@xs_mod_snames) {
rename "${_}/${_}.xs.disabled", "${_}/${_}.xs";
}
}
@@ -1077,7 +1085,7 @@
cp "Apache/typemap", $d;
- for (qw(Apache Constants)) {
+ for (@xs_mod_snames) {
rename "${_}/${_}.xs", "${_}/${_}.xs.disabled" if -e "${_}/${_}.xs";
push @static_src, "$_.c";
}
@@ -1105,6 +1113,10 @@
iedit $mf, "s/^#STATIC_EXTS.*/STATIC_EXTS = @xs_names/";
=cut
+ #XXX: ho,hum, need to generate the whole damn thing
+ #instead of all these frigging iedits.
+ 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.
@@ -1213,7 +1225,10 @@
if($repl =~ s/(\\)\s*$//) {
$backwhack = $1;
}
-
+ my $mmn = magic_number($APACHE_SRC);
+ if($mmn >= 19980507) {
+ $ADD_VERSION = 0;
+ }
if($ADD_VERSION) {
if(/$dssv=/) {
$repl =~
@@ -1345,9 +1360,9 @@
dirent_kludge($d);
cp "Apache/typemap", $d;
chdir $d;
- system "$^X -MExtUtils::Embed -e xsinit -- -std Apache Apache::Constants $PERL_STATIC_EXTS";
+ system "$^X -MExtUtils::Embed -e xsinit -- -std @xs_modules $PERL_STATIC_EXTS";
my $lib = $Config{privlibexp};
- for (qw(Constants Apache)) {
+ for (@xs_mod_snames) {
system "$^X $lib/ExtUtils/xsubpp -typemap $lib/ExtUtils/typemap $_.xs > $_.c";
}
1.19 +8 -1 modperl/ToDo
Index: ToDo
===================================================================
RCS file: /export/home/cvs/modperl/ToDo,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- ToDo 1998/05/08 02:40:45 1.18
+++ ToDo 1998/05/10 04:14:49 1.19
@@ -16,6 +16,11 @@
(well, close to it anyhow)
---------------------------------------------------------------------------
+- make sure SERVER_VERSION/SERVER_SUBVERSION, etc. is in sync w/ 1.3b7 changes
+- get rid of Cwd::fastcwd() usage
+- get rid of IO::File usage, replace with Apache::gensym
+- add chdir_file to replace chdir File::Basename::dirname
+
- perl-status?mod_perl_hooks broken under win32?
- documentation:
@@ -43,12 +48,14 @@
Ed Jordan <ed...@fidalgo.net>
---------------------------------------------------------------------------
-DOCUMENTATION (areas that *really* need some)
+DOCUMENTATION (areas that *really* need some more or don't have any)
---------------------------------------------------------------------------
- HTTP Headers!!!!
- Apache::exit/child_terminate
+
+- push_handlers/set_handlers
---------------------------------------------------------------------------
KNOWN BUGS
1.4 +1 -0 modperl/Apache/typemap
Index: typemap
===================================================================
RCS file: /export/home/cvs/modperl/Apache/typemap,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- typemap 1998/04/30 03:13:14 1.3
+++ typemap 1998/05/10 04:14:51 1.4
@@ -1,5 +1,6 @@
TYPEMAP
Apache T_APACHEOBJ
+Apache::CmdParms T_PTROBJ
Apache::SubRequest T_PTROBJ
Apache::Connection T_PTROBJ
Apache::Server T_PTROBJ
1.6 +3 -0 modperl/Constants/Constants.pm
Index: Constants.pm
===================================================================
RCS file: /export/home/cvs/modperl/Constants/Constants.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- Constants.pm 1998/03/19 23:08:28 1.5
+++ Constants.pm 1998/05/10 04:14:51 1.6
@@ -47,11 +47,13 @@
HTTP_PRECONDITION_FAILED
HTTP_SERVICE_UNAVAILABLE
HTTP_VARIANT_ALSO_VARIES);
+my(@config) = qw(DECLINE_CMD);
my $rc = [@common, @response];
%Apache::Constants::EXPORT_TAGS = (
common => \@common,
+ config => \@config,
response => $rc,
http => \@http,
options => \@options,
@@ -71,6 +73,7 @@
@remotehost,
@satisfy,
@server,
+ @config,
);
*Apache::Constants::EXPORT = \@common;
1.8 +83 -30 modperl/lib/Apache/ExtUtils.pm
Index: ExtUtils.pm
===================================================================
RCS file: /export/home/cvs/modperl/lib/Apache/ExtUtils.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- ExtUtils.pm 1998/05/04 02:19:00 1.7
+++ ExtUtils.pm 1998/05/10 04:14:52 1.8
@@ -9,13 +9,27 @@
@Apache::ExtUtils::EXPORT = qw(command_table);
sub command_table {
- my($class, $cmds) = @_;
+ my($class, $cmds);
+ if(@_ == 2) {
+ ($class, $cmds) = @_;
+ }
+ else {
+ $cmds = shift;
+ $class = caller;
+ }
(my $file = $class) =~ s,.*::,,;
eval {
require "$file.pm"; #so we can see prototypes
};
-
+ if ($@) {
+ require ExtUtils::testlib;
+ ExtUtils::testlib->import;
+ require lib;
+ my $lib = "lib";#hmm, lib->import + -w == Unquoted string "lib" ...
+ $lib->import('./lib');
+ require $class;
+ }
unless (-e "$file.xs.orig") {
File::Copy::cp("$file.xs", "$file.xs.orig");
}
@@ -26,19 +40,19 @@
close $fh;
}
-#the first `$' is for the config object
+#the first two `$$' are for the parms object and per-directory object
my $proto_perl2c = {
- '$$$$' => "TAKE3",
- '$$$' => "TAKE2",
- '$$' => "TAKE1",
- '$' => "NO_ARGS",
- '' => "NO_ARGS",
- '$$;$' => "TAKE12",
- '$$$;$' => "TAKE23",
- '$$;$$' => "TAKE123",
- '$@' => "ITERATE",
- '$@;@' => "ITERATE2",
- '$$;*' => "RAW_ARGS",
+ '$$$$$' => "TAKE3",
+ '$$$$' => "TAKE2",
+ '$$$' => "TAKE1",
+ '$$' => "NO_ARGS",
+ '' => "NO_ARGS",
+ '$$$;$' => "TAKE12",
+ '$$$$;$' => "TAKE23",
+ '$$$;$$' => "TAKE123",
+ '$$@' => "ITERATE",
+ '$$@;@' => "ITERATE2",
+ '$$$;*' => "RAW_ARGS",
};
my $proto_c2perl = {
@@ -48,56 +62,94 @@
sub proto_perl2c { $proto_perl2c }
sub proto_c2perl { $proto_c2perl }
+sub cmd_info {
+ my($name, $subname, $info, $args_how) = @_;
+ return <<EOF;
+static mod_perl_cmd_info cmd_info_$name = {
+"$subname", "$info",
+};
+EOF
+}
+
sub xs_cmd_table {
my($self, $class, $cmds) = @_;
(my $modname = $class) =~ s/::/__/g;
my $cmdtab = "";
+ my $infos = "";
for my $cmd (@$cmds) {
- my($name, $proto, $desc);
-
+ my($name, $sub, $cmd_data, $req_override, $args_how, $proto, $desc);
+ my $hash;
if(ref($cmd) eq "ARRAY") {
($name,$desc) = @$cmd;
}
+ elsif(ref($cmd) eq "HASH") {
+ $name = $cmd->{name};
+ $sub = $cmd->{func};
+ $sub = join '::', $class, $cmd->{func} unless defined &$sub;
+ $cmd_data = $cmd->{cmd_data};
+ $req_override = $cmd->{req_override};
+ $desc = $cmd->{errmsg};
+ $args_how = $cmd->{args_how};
+ }
else {
$name = $cmd;
}
+ $name ||= $sub;
my $realname = $name;
if($name =~ s/[\<\>]//g) {
if($name =~ s:^/::) {
$name .= "_END";
}
}
- my $sub = join '::', $class, $name;
- my $meth = $class->can($name);
- my $take = "TAKE123";
- if($meth || defined(&$sub)) {
+ $sub ||= join '::', $class, $name;
+ $req_override ||= "OR_ALL";
+ my $meth = $class->can($name) if $name;
+
+ if(not $args_how and ($meth || defined(&$sub))) {
if(defined($proto = prototype($meth || \&{$sub}))) {
#extra $ is for config data
- $take = $proto_perl2c->{$proto};
+ $args_how = $proto_perl2c->{$proto};
+ }
+ else {
+ $args_how ||= "TAKE123";
}
}
$desc ||= "1-3 value(s) for $name";
+ (my $cname = $name) =~ s/\W/_/g;
+ $infos .= cmd_info($cname, $sub, $cmd_data, $args_how);
$cmdtab .= <<EOF;
- { "$realname", perl_cmd_perl_$take,
- (void*)"$sub",
- OR_ALL, $take, "$desc" },
+ { "$realname", perl_cmd_perl_$args_how,
+ (void*)&cmd_info_$cname,
+ $req_override, $args_how, "$desc" },
EOF
}
return <<EOF;
#include "modules/perl/mod_perl.h"
+
+static mod_perl_perl_dir_config *newPerlConfig(pool *p)
+{
+ mod_perl_perl_dir_config *cld =
+ (mod_perl_perl_dir_config *)
+ palloc(p, sizeof (mod_perl_perl_dir_config));
+ cld->obj = Nullsv;
+ cld->class = NULL;
+ return cld;
+}
-static SV *DirSV;
static void *create_dir_config_sv (pool *p, char *dirname)
{
- SV *sv = newSV(TRUE);
- DirSV = sv;
- return &DirSV;
+ return newPerlConfig(p);
}
+static void *create_srv_config_sv (pool *p, server_rec *s)
+{
+ return newPerlConfig(p);
+}
+
static void stash_mod_pointer (char *class, void *ptr)
{
SV *sv = newSV(0);
@@ -106,6 +158,8 @@
class, strlen(class), sv, FALSE);
}
+$infos
+
static command_rec mod_cmds[] = {
$cmdtab
{ NULL }
@@ -116,7 +170,7 @@
NULL, /* module initializer */
create_dir_config_sv, /* per-directory config creator */
NULL, /* dir config merger */
- NULL, /* server config creator */
+ create_srv_config_sv, /* server config creator */
NULL, /* server config merger */
mod_cmds, /* command table */
NULL, /* [7] list of handlers */
@@ -138,7 +192,6 @@
BOOT:
add_module(&XS_${modname});
stash_mod_pointer("$class", &XS_${modname});
- av_push(perl_get_av("$class\:\:ISA",TRUE), newSVpv("Apache::Config",0));
EOF
}
1.21 +4 -80 modperl/src/modules/perl/Apache.xs
Index: Apache.xs
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/Apache.xs,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- Apache.xs 1998/05/08 02:40:48 1.20
+++ Apache.xs 1998/05/10 04:14:52 1.21
@@ -274,12 +274,6 @@
int basic_http_header(request_rec *r);
#endif
-#if MODULE_MAGIC_NUMBER > 19970912
-#define cmd_infile parms->config_file
-#else
-#define cmd_infile parms->infile
-#endif
-
pool *perl_get_startup_pool(void)
{
SV *sv = perl_get_sv("Apache::__POOL", FALSE);
@@ -300,16 +294,6 @@
return NULL;
}
-static cmd_parms *perl_get_cmd_parms(void)
-{
- SV *sv = perl_get_sv("Apache::__CMDPARMS", FALSE);
- if(sv) {
- IV tmp = SvIV((SV*)SvRV(sv));
- return (cmd_parms *)tmp;
- }
- return NULL;
-}
-
#if MODULE_MAGIC_NUMBER > 19970909
static int mp_get_basic_auth_pw(request_rec *r, char **pw)
{
@@ -1806,42 +1790,17 @@
# void *per_dir_config; /* Options set in config files, etc. */
SV *
-dir_config(r, svkey=Nullsv, ...)
+dir_config(r, key, ...)
Apache r
- SV *svkey
+ char *key
PREINIT:
perl_dir_config *c;
- SV *caller = Nullsv;
CODE:
- if(svkey && (gv_stashpv(SvPV(svkey,na), FALSE)))
- caller = svkey;
+ c = get_module_config(r->per_dir_config, &perl_module);
+ TABLE_GET_SET(c->vars, FALSE);
- if((svkey == Nullsv) || caller) {
- HV *xs_config = perl_get_hv("Apache::XS_ModuleConfig", TRUE);
- SV **mod_ptr;
- RETVAL = Nullsv;
-
- if(!caller)
- caller = perl_eval_pv("scalar caller", TRUE);
-
- if(caller)
- mod_ptr = hv_fetch(xs_config, SvPVX(caller), SvCUR(caller), FALSE);
-
- if(mod_ptr && *mod_ptr) {
- IV tmp = SvIV((SV*)SvRV(*mod_ptr));
- SV **data = get_module_config(r->per_dir_config, (module *)tmp);
- RETVAL = data ? SvREFCNT_inc(*data) : Nullsv;
- }
- if(!RETVAL) XSRETURN_UNDEF;
- }
- else {
- char *key = SvPV(svkey,na);
- c = get_module_config(r->per_dir_config, &perl_module);
- TABLE_GET_SET(c->vars, FALSE);
- }
-
OUTPUT:
RETVAL
@@ -2135,38 +2094,3 @@
OUTPUT:
RETVAL
-
-MODULE = Apache PACKAGE = Apache::Config
-
-char *
-getline(self)
- SV *self
-
- PREINIT:
- cmd_parms *parms = perl_get_cmd_parms();
- char l[MAX_STRING_LEN];
-
- CODE:
- if(!parms) XSRETURN_UNDEF;
-
- (void)cfg_getline(l, MAX_STRING_LEN, cmd_infile);
- RETVAL = l;
-
- OUTPUT:
- RETVAL
-
-char *
-path(self)
- SV *self
-
- PREINIT:
- cmd_parms *parms = perl_get_cmd_parms();
-
- CODE:
- if(!parms) XSRETURN_UNDEF;
-
- RETVAL = parms->path;
-
- OUTPUT:
- RETVAL
-
1.5 +10 -0 modperl/src/modules/perl/Constants.xs
Index: Constants.xs
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/Constants.xs,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- Constants.xs 1998/03/19 23:08:52 1.4
+++ Constants.xs 1998/05/10 04:14:53 1.5
@@ -825,3 +825,13 @@
OUTPUT:
RETVAL
+char *
+DECLINE_CMD()
+ CODE:
+#ifdef DECLINE_CMD
+ RETVAL = DECLINE_CMD;
+#else
+ RETVAL = "\a\b";
+#endif
+ OUTPUT:
+ RETVAL
1.7 +4 -2 modperl/src/modules/perl/Makefile
Index: Makefile
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/Makefile,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- Makefile 1998/03/19 23:08:53 1.6
+++ Makefile 1998/05/10 04:14:53 1.7
@@ -50,7 +50,7 @@
#
# Makefile for the Apache mod_perl library
#
-# $Id: Makefile,v 1.6 1998/03/19 23:08:53 dougm Exp $
+# $Id: Makefile,v 1.7 1998/05/10 04:14:53 dougm Exp $
#
#__ORIGINAL__
@@ -83,6 +83,7 @@
PERL_STACKED_HANDLERS = -DNO_PERL_STACKED_HANDLERS
PERL_SECTIONS = -DNO_PERL_SECTIONS
PERL_METHOD_HANDLERS = -DNO_PERL_METHOD_HANDLERS
+PERL_DIRECTIVE_HANDLERS = -DNO_PERL_DIRECTIVE_HANDLERS
PERL_SSI = -DNO_PERL_SSI
PERL_HOOKS = $(PERL_DISPATCH) $(PERL_CHILD_INIT) $(PERL_CHILD_EXIT) \
@@ -90,7 +91,8 @@
$(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_STACKED_HANDLERS) $(PERL_SECTIONS) $(PERL_METHOD_HANDLERS) \
+ $(PERL_SSI) $(PERL_DIRECTIVE_HANDLERS)
#STATIC_SRC = Apache.c Constants.c
#STATIC_EXTS = Apache Apache::Constants
1.20 +28 -3 modperl/src/modules/perl/mod_perl.h
Index: mod_perl.h
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/mod_perl.h,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -r1.19 -r1.20
--- mod_perl.h 1998/05/08 02:40:49 1.19
+++ mod_perl.h 1998/05/10 04:14:53 1.20
@@ -126,6 +126,7 @@
typedef request_rec * Apache__SubRequest;
typedef conn_rec * Apache__Connection;
typedef server_rec * Apache__Server;
+typedef cmd_parms * Apache__CmdParms;
#define GvHV_init(name) gv_fetchpv(name, GV_ADDMULTI, SVt_PVHV)
#define GvSV_init(name) gv_fetchpv(name, GV_ADDMULTI, SVt_PV)
@@ -271,6 +272,9 @@
#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
@@ -294,6 +298,16 @@
/* some 1.2.x/1.3.x compat stuff */
/* once 1.3.0 is here, we can toss most of this junk */
+#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
@@ -795,6 +809,16 @@
char *method;
} mod_perl_handler;
+typedef struct {
+ SV *obj;
+ char *class;
+} 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 */
@@ -855,6 +879,7 @@
SV *array_header2avrv(array_header *arr);
array_header *avrv2array_header(SV *avrv, pool *p);
+SV *mod_perl_gensym (char *pack);
void perl_tie_hash(HV *hv, char *class);
void perl_util_cleanup(void);
void mod_perl_clear_rgy_endav(request_rec *r, SV *sv);
@@ -933,9 +958,9 @@
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, SV **data, char *one);
-CHAR_P perl_cmd_perl_TAKE2(cmd_parms *cmd, SV **data, char *one, char *two);
-CHAR_P perl_cmd_perl_TAKE123(cmd_parms *cmd, SV **config,
+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);
#define perl_cmd_perl_RAW_ARGS perl_cmd_perl_TAKE1
1.16 +34 -24 modperl/src/modules/perl/perl_config.c
Index: perl_config.c
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/perl_config.c,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- perl_config.c 1998/05/08 02:40:49 1.15
+++ perl_config.c 1998/05/10 04:14:53 1.16
@@ -55,16 +55,6 @@
extern API_VAR_EXPORT module *top_module;
-#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
-
#ifdef PERL_SECTIONS
static int perl_sections_self_boot = 0;
static const char *perl_sections_boot_module = NULL;
@@ -618,23 +608,34 @@
CHAR_P perl_pod_end_section (cmd_parms *cmd, void *dummy) {
return perl_pod_end_magic;
}
+
+#ifdef PERL_DIRECTIVE_HANDLERS
-CHAR_P perl_cmd_perl_TAKE1(cmd_parms *cmd, SV **data, char *one)
+CHAR_P perl_cmd_perl_TAKE1(cmd_parms *cmd, mod_perl_perl_dir_config *data, char *one)
{
return perl_cmd_perl_TAKE123(cmd, data, one, NULL, NULL);
}
-CHAR_P perl_cmd_perl_TAKE2(cmd_parms *cmd, SV **data, char *one, char *two)
+CHAR_P perl_cmd_perl_TAKE2(cmd_parms *cmd, mod_perl_perl_dir_config *data, char *one, char *two)
{
return perl_cmd_perl_TAKE123(cmd, data, one, two, NULL);
}
+
+static SV *perl_bless_cmd_parms(cmd_parms *parms)
+{
+ SV *sv = sv_newmortal();
+ sv_setref_pv(sv, "Apache::CmdParms", (void*)parms);
+ MP_TRACE_g(fprintf(stderr, "blessing cmd_parms=(0x%lx)\n",
+ (unsigned long)parms));
+ return sv;
+}
-static SV *perl_perl_create_dir_config(SV **sv, HV *class)
+static SV *perl_perl_create_dir_config(SV **sv, HV *class, cmd_parms *parms)
{
GV *gv;
- if(SvTRUE(*sv) && SvROK(*sv) && sv_isobject(*sv))
+ if(*sv && SvTRUE(*sv) && SvROK(*sv) && sv_isobject(*sv))
return *sv;
/* return $class->new if $class->can("new") */
@@ -645,10 +646,11 @@
ENTER;SAVETMPS;
PUSHMARK(sp);
XPUSHs(sv_2mortal(newSVpv(HvNAME(class),0)));
+ XPUSHs(perl_bless_cmd_parms(parms));
PUTBACK;
count = perl_call_sv((SV*)GvCV(gv), G_EVAL | G_SCALAR);
SPAGAIN;
- if(count == 1) {
+ if((perl_eval_ok(parms->server) == OK) && (count == 1)) {
*sv = POPs;
++SvREFCNT(*sv);
}
@@ -667,35 +669,42 @@
}
}
-CHAR_P perl_cmd_perl_TAKE123(cmd_parms *cmd, SV **data,
+CHAR_P perl_cmd_perl_TAKE123(cmd_parms *cmd, mod_perl_perl_dir_config *data,
char *one, char *two, char *three)
{
dSP;
- char *subname = (char *)cmd->info;
+ mod_perl_cmd_info *info = (mod_perl_cmd_info *)cmd->info;
+ char *subname = info->subname;
int count = 0;
CV *cv = perl_get_cv(subname, TRUE);
SV *obj;
- SV *sv = perl_get_sv("Apache::__CMDPARMS", TRUE);
- sv_setref_pv(sv, "Apache::Config", (void*)cmd);
+ bool has_empty_proto = (SvPOK(cv) && (SvLEN(cv) == 1));
- obj = perl_perl_create_dir_config(data, CvSTASH(cv));
+ obj = perl_perl_create_dir_config(&data->obj, CvSTASH(cv), cmd);
ENTER;SAVETMPS;
PUSHMARK(sp);
- if(SvPOK(cv) && (SvCUR(cv) || (SvPVX(cv) == NULL))) {
+ if(!has_empty_proto) {
+ SV *cmd_obj = perl_bless_cmd_parms(cmd);
+ XPUSHs(cmd_obj);
XPUSHs(obj);
- PUSHif(one);PUSHif(two);PUSHif(three);
+ if(cmd->cmd->args_how != NO_ARGS) {
+ PUSHif(one);PUSHif(two);PUSHif(three);
+ }
+ if(SvPOK(cv) && (*(SvEND((SV*)cv)-1) == '*')) {
+ SV *gp = mod_perl_gensym("Apache::CmdParms");
+ sv_magic((SV*)SvRV(gp), cmd_obj, 'q', Nullch, 0);
+ XPUSHs(gp);
+ }
}
PUTBACK;
count = perl_call_sv((SV*)cv, G_EVAL | G_SCALAR);
SPAGAIN;
-#if 1
if(count == 1) {
char *retval = POPp;
if(strEQ(retval, DECLINE_CMD))
return DECLINE_CMD;
}
-#endif
FREETMPS;LEAVE;
if(SvTRUE(ERRSV))
@@ -703,6 +712,7 @@
else
return NULL;
}
+#endif /* PERL_DIRECTIVE_HANDLERS */
#ifdef PERL_SECTIONS
1.6 +10 -0 modperl/src/modules/perl/perl_util.c
Index: perl_util.c
===================================================================
RCS file: /export/home/cvs/modperl/src/modules/perl/perl_util.c,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- perl_util.c 1998/03/19 23:08:57 1.5
+++ perl_util.c 1998/05/10 04:14:54 1.6
@@ -93,6 +93,16 @@
return arr;
}
+/* 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;
+}
+
#ifdef PERL_SECTIONS
void perl_tie_hash(HV *hv, char *class)
{
1.5 +13 -3 modperl/t/TestDirectives/Makefile.PL
Index: Makefile.PL
===================================================================
RCS file: /export/home/cvs/modperl/t/TestDirectives/Makefile.PL,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- Makefile.PL 1998/04/30 12:06:34 1.4
+++ Makefile.PL 1998/05/10 04:14:56 1.5
@@ -1,3 +1,4 @@
+package Apache::TestDirectives;
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
@@ -10,24 +11,33 @@
use Apache::src ();
use Apache::ExtUtils qw(command_table);
-my $class = 'Apache::TestDirectives';
+my $class = __PACKAGE__;
my @directives = (
+ [Port => "A TCP port number"], #we'll decline this one
[TestCmd => "Two TestCmd args"],
[AnotherCmd => "Stuff for another command"],
- [YAC => "Yet another comand"],
[CmdIterate => "No limit here"],
["<Container" => "whatever"],
["</Container>" => "end whatever"],
+ {
+ name => "YAC",
+ func => "another_cmd",
+ cmd_data => "info for YAC",
+ errmsg => "Yet another comand",
+ args_how => "TAKE2",
+ req_override => "OR_ALL",
+ },
);
my $proto_perl2c = Apache::ExtUtils->proto_perl2c;
while(my($pp,$cp) = each %$proto_perl2c) {
+ next unless $pp;
push @directives, [$cp, "Test for $cp"];
}
-command_table $class, \@directives;
+command_table \@directives;
WriteMakefile(
'NAME' => $class,
1.7 +37 -19 modperl/t/TestDirectives/TestDirectives.pm
Index: TestDirectives.pm
===================================================================
RCS file: /export/home/cvs/modperl/t/TestDirectives/TestDirectives.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- TestDirectives.pm 1998/05/04 04:09:17 1.6
+++ TestDirectives.pm 1998/05/10 04:14:56 1.7
@@ -4,7 +4,12 @@
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use DynaLoader ();
+use Apache::Constants ();
+*DECLINE_CMD = \&Apache::Constants::DECLINE_CMD;
+eval {
+ require Apache::ModuleConfig;
+};
use Data::Dumper 'Dumper';
@ISA = qw(DynaLoader TestDirectives::Base);
@@ -20,35 +25,44 @@
$self->{$k} = $v;
}
-sub TestCmd ($$$) {
- my($cfg, $one, $two) = @_;
+sub Port ($$$) {
+ my($parms, $cfg, $port) = @_;
+ warn "Port will be $port\n";
+ return DECLINE_CMD();
+}
+
+sub TestCmd ($$$$) {
+ my($parms, $cfg, $one, $two) = @_;
#warn "TestCmd called with args: `$one', `$two'\n";
$cfg->attr(TestCmd => [$one,$two]);
+ $parms->server->isa("Apache::Server") or die "parms->server busted";
+ my $or = $parms->override;
+ my $limit = $parms->limited;
#warn Dumper($cfg), $/;
}
-sub AnotherCmd {
- my($cfg, @data) = @_;
- $cfg->{AnotherCmd} = [@data];
- #warn Dumper($cfg), $/;
- $cfg->{YAC} = [@data];
+sub AnotherCmd () {
+ die "prototype check broken [@_]" if @_ > 0;
}
-sub CmdIterate ($@) {
- my($cfg, @data) = @_;
- #warn "$cfg->ITERATE: @data\n";
+sub CmdIterate ($$@) {
+ my($parms, $cfg, @data) = @_;
+ $cfg->{CmdIterate} = [@data];
+ $cfg->{path} = $parms->path;
}
-sub YAC {
- my($cfg, @data) = @_;
- #warn Dumper($cfg), $/;
+sub another_cmd {
+ my($parms, $cfg, @data) = @_;
+ $parms->info =~ /YAC/ or die "parms->info busted";
+ $cfg->{parms_info_from_another_cmd} = $parms->info;
}
-sub Container ($$;*) {
- my($cfg, $arg) = @_;
+sub Container ($$$;*) {
+ my($parms, $cfg, $arg, $fh) = @_;
$arg =~ s/>//;
warn "ARG=$arg\n";
- while(my($line) = $cfg->getline) {
+ #while($parms->getline($line)) {
+ while(defined(my $line = <$fh>)) {
last if $line =~ m:</Container>:i;
warn "LINE=`$line'\n";
}
@@ -67,7 +81,8 @@
$code .= <<SUB;
sub $cp ($pp) {
warn "$cp called with args: ", (map "`\$_', ", \@_), "\n";
- shift->attr($cp => [\@_]);
+ my(\$parms, \$cfg, \@args) = \@_;
+ \$cfg->attr($cp => [\@args]) if ref(\$cfg);
}
SUB
}
@@ -77,8 +92,11 @@
package TestDirectives::Base;
sub new {
- my $class = shift;
- return bless {FromNew => __PACKAGE__}, $class;
+ my($class, $parms) = @_;
+ return bless {
+ FromNew => __PACKAGE__,
+ path => $parms->path || "",
+ }, $class;
}
# Preloaded methods go here.
1.10 +8 -2 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.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- httpd.conf.pl 1998/04/30 12:06:35 1.9
+++ httpd.conf.pl 1998/05/10 04:14:57 1.10
@@ -36,18 +36,20 @@
my $proto_perl2c = Apache::ExtUtils->proto_perl2c;
+ $PerlConfig .= "<Location /perl>\n";
while(my($pp,$cp) = each %$proto_perl2c) {
my $arg = "A";
- $pp =~ s/^\$//;
+ $pp =~ s/^\$\$//;
1 while $pp =~ s/(\$|\@)/$arg++ . " "/ge;
$PerlConfig .= "$cp $pp\n";
}
$PerlConfig .= <<EOF;
TestCmd one two
-AnotherCmd uno dos tres
+AnotherCmd
CmdIterate A B C D E F
YAC yet another
+</Location>
<Container /for/whatever>
it's
@@ -55,6 +57,10 @@
time
#make that a scotch
</Container>
+
+<Location /perl/io>
+TestCmd PerlIO IsStdio
+</Location>
EOF
}
1.9 +0 -1 modperl/t/docs/startup.pl
Index: startup.pl
===================================================================
RCS file: /export/home/cvs/modperl/t/docs/startup.pl,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- startup.pl 1998/05/08 02:40:51 1.8
+++ startup.pl 1998/05/10 04:14:58 1.9
@@ -31,7 +31,6 @@
#warn "ServerReStarting=$Apache::ServerReStarting\n";
#use Apache::Debug level => 4;
-
use mod_perl 1.03_01;
if(defined &main::subversion) {
1.3 +4 -1 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.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- http-get.t 1998/04/23 05:14:43 1.2
+++ http-get.t 1998/05/10 04:14:58 1.3
@@ -3,7 +3,7 @@
# Check GET via HTTP.
#
-my $num_tests = 8;
+my $num_tests = 9;
my(@test_scripts) = qw(test perl-status);
%get_only = map { $_,1 } qw(perl-status);
@@ -44,6 +44,9 @@
test ++$i, ($str =~ /^REQUEST_METHOD=GET$/m);
test ++$i, ($str =~ /^QUERY_STRING=query$/m);
}
+
+test ++$i, $response->header("Server") =~ /mod_perl/;
+print "Server: ", $response->header("Server"), "\n";
#test PerlSetupEnv Off
test ++$i, fetch("/perl/noenv/test.pl") !~ /SERVER_SOFTWARE/m;
1.11 +8 -7 modperl/t/net/perl/api.pl
Index: api.pl
===================================================================
RCS file: /export/home/cvs/modperl/t/net/perl/api.pl,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- api.pl 1998/05/04 04:09:18 1.10
+++ api.pl 1998/05/10 04:14:59 1.11
@@ -15,10 +15,10 @@
%ENV = $r->cgi_env;
-my $tests = 39;
+my $tests = 38;
my $test_get_set = Apache->can('set_handlers') && ($tests += 4);
my $test_custom_response = (MODULE_MAGIC_NUMBER >= 19980324) && $tests++;
-my $test_dir_config = $INC{'Apache/TestDirectives.pm'} && ($tests += 6);
+my $test_dir_config = $INC{'Apache/TestDirectives.pm'} && ($tests += 7);
my $i;
@@ -124,17 +124,18 @@
test ++$i, @$handlers == 0;
}
-my $dc = $r->dir_config;
-test ++$i, not $dc;
-
if($test_dir_config) {
+ require Apache::ModuleConfig;
+ my $dc = Apache::ModuleConfig->get($r);
+ test ++$i, not $dc;
+
for my $cv (
sub {
package Apache::TestDirectives;
- Apache->request->dir_config;
+ Apache::ModuleConfig->get(Apache->request);
},
sub {
- $r->dir_config("Apache::TestDirectives");
+ Apache::ModuleConfig->get($r, "Apache::TestDirectives");
})
{
my $cfg = $cv->();
1.4 +1 -1 modperl/t/net/perl/constants.pl
Index: constants.pl
===================================================================
RCS file: /export/home/cvs/modperl/t/net/perl/constants.pl,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- constants.pl 1998/02/21 13:51:28 1.3
+++ constants.pl 1998/05/10 04:14:59 1.4
@@ -28,7 +28,7 @@
push @export, grep {!$SEEN{$_}++} @Apache::Constants::EXPORT;
#skip some 1.3 stuff that 1.2 didn't have
-my %skip = map { $_,1 } qw(DONE REMOTE_DOUBLE_REV
+my %skip = map { $_,1 } qw(DONE REMOTE_DOUBLE_REV DECLINE_CMD
SERVER_VERSION SERVER_SUBVERSION SERVER_BUILT);
my $tests = (1 + @export) - keys %skip;