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/14 16:57:09 UTC
cvs commit: modperl/t/net/perl constants.pl
dougm 98/07/14 07:57:09
Modified: . Changes MANIFEST Makefile.PL
Constants Constants.pm
src/modules/perl Constants.xs
t/net/perl constants.pl
Added: lib/Apache/Constants Exports.pm
src/modules/perl Exports.c
Log:
experimental optimization for Apache::Constants if XS_IMPORT=1 is
given to Makefile.PL:
drop heavy Exporter::import/@EXPORT/@EXPORT_OK/%EXPORT_TAGS for
Apache::Constants::import written in C, shaves ~25K from resident
memory
Revision Changes Path
1.74 +8 -0 modperl/Changes
Index: Changes
===================================================================
RCS file: /export/home/cvs/modperl/Changes,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -r1.73 -r1.74
--- Changes 1998/07/14 01:00:38 1.73
+++ Changes 1998/07/14 14:57:04 1.74
@@ -6,6 +6,14 @@
=over 3
+=item 1.13_01-dev
+
+experimental optimization for Apache::Constants if XS_IMPORT=1 is
+given to Makefile.PL:
+drop heavy Exporter::import/@EXPORT/@EXPORT_OK/%EXPORT_TAGS for
+Apache::Constants::import written in C, shaves ~25K from resident
+memory
+
=item 1.13 - July 13, 1998
fix Makefile.PL setting of numeric $User/$Group for 'make test'
1.25 +2 -0 modperl/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /export/home/cvs/modperl/MANIFEST,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -r1.24 -r1.25
--- MANIFEST 1998/07/12 21:32:42 1.24
+++ MANIFEST 1998/07/14 14:57:05 1.25
@@ -46,6 +46,7 @@
#lib/Apache/Safe.pm
lib/Apache/SIG.pm
lib/Apache/StatINC.pm
+lib/Apache/Constants/Exports.pm
Apache/Apache.pm
Apache/typemap
Apache/Makefile.PL
@@ -54,6 +55,7 @@
Symbol/Symbol.xs
Symbol/test.pl
src/modules/perl/mod_perl_version.h
+src/modules/perl/Exports.c
src/modules/perl/Constants.xs
src/modules/perl/Apache.xs
src/modules/perl/ModuleConfig.xs
1.64 +5 -0 modperl/Makefile.PL
Index: Makefile.PL
===================================================================
RCS file: /export/home/cvs/modperl/Makefile.PL,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -r1.63 -r1.64
--- Makefile.PL 1998/07/14 00:51:35 1.63
+++ Makefile.PL 1998/07/14 14:57:05 1.64
@@ -158,6 +158,7 @@
PERL_RESTART_HANDLER
PERL_TIE_SCRIPTNAME
PERL_STASH_POST_DATA
+XS_IMPORT
};
my @mp_args =
@@ -1030,6 +1031,10 @@
}
$string .= <<'EOF';
+
+gen_exports:
+ $(PERL) -MExtUtils::testlib -MApache::Constants::Exports \
+ -e 'Apache::Constants::Exports->gen_ctags' > Exports.c
apxs_distclean:
(cd ./apaci && $(MAKE) distclean)
1.8 +9 -76 modperl/Constants/Constants.pm
Index: Constants.pm
===================================================================
RCS file: /export/home/cvs/modperl/Constants/Constants.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- Constants.pm 1998/07/08 18:07:47 1.7
+++ Constants.pm 1998/07/14 14:57:06 1.8
@@ -1,90 +1,22 @@
package Apache::Constants;
-$Apache::Constants::VERSION = "1.08";
+$Apache::Constants::VERSION = "1.09";
-use Exporter ();
-use strict;
-
-*import = \&Exporter::import;
-
unless(defined &bootstrap) {
require DynaLoader;
@Apache::Constants::ISA = qw(DynaLoader);
}
-#XXX: should just generate all this from the documention =item's
-
-my(@common) = qw(OK DECLINED DONE NOT_FOUND FORBIDDEN
- AUTH_REQUIRED SERVER_ERROR);
-my(@methods) = qw(M_CONNECT M_DELETE M_GET M_INVALID M_OPTIONS
- M_POST M_PUT M_TRACE METHODS);
-my(@options) = qw(OPT_NONE OPT_INDEXES OPT_INCLUDES
- OPT_SYM_LINKS OPT_EXECCGI OPT_UNSET OPT_INCNOEXEC
- OPT_SYM_OWNER OPT_MULTI OPT_ALL);
-my(@server) = qw(MODULE_MAGIC_NUMBER
- SERVER_VERSION SERVER_SUBVERSION SERVER_BUILT);
-my(@response) = qw(DOCUMENT_FOLLOWS MOVED REDIRECT
- USE_LOCAL_COPY
- BAD_REQUEST
- BAD_GATEWAY
- RESPONSE_CODES
- NOT_IMPLEMENTED
- NOT_AUTHORITATIVE
- CONTINUE);
-my(@satisfy) = qw(SATISFY_ALL SATISFY_ANY SATISFY_NOSPEC);
-my(@remotehost) = qw(REMOTE_HOST REMOTE_NAME
- REMOTE_NOLOOKUP REMOTE_DOUBLE_REV);
-my(@http) = qw(HTTP_METHOD_NOT_ALLOWED
- HTTP_NOT_ACCEPTABLE
- HTTP_LENGTH_REQUIRED
- HTTP_PRECONDITION_FAILED
- HTTP_SERVICE_UNAVAILABLE
- HTTP_VARIANT_ALSO_VARIES
- HTTP_NO_CONTENT
- HTTP_METHOD_NOT_ALLOWED
- HTTP_NOT_ACCEPTABLE
- HTTP_LENGTH_REQUIRED
- HTTP_PRECONDITION_FAILED
- HTTP_SERVICE_UNAVAILABLE
- HTTP_VARIANT_ALSO_VARIES);
-my(@config) = qw(DECLINE_CMD);
-my(@types) = qw(DIR_MAGIC_TYPE);
-
-my $rc = [@common, @response];
-
-%Apache::Constants::EXPORT_TAGS = (
- common => \@common,
- config => \@config,
- response => $rc,
- http => \@http,
- options => \@options,
- methods => \@methods,
- remotehost => \@remotehost,
- satisfy => \@satisfy,
- server => \@server,
- types => \@types,
- #depreciated
- response_codes => $rc,
-);
-
-@Apache::Constants::EXPORT_OK = (
- @response,
- @http,
- @options,
- @methods,
- @remotehost,
- @satisfy,
- @server,
- @config,
- @types,
-);
-
-*Apache::Constants::EXPORT = \@common;
-
if(exists $ENV{MOD_PERL}) {
bootstrap Apache::Constants $Apache::Constants::VERSION;
}
+unless(defined &import) {
+ require Exporter;
+ require Apache::Constants::Exports;
+ *import = \&Exporter::import;
+}
+
sub AUTOLOAD {
#why must we stringify first???
__AUTOLOAD() if "$Apache::Constants::AUTOLOAD";
@@ -95,8 +27,9 @@
sub name {
my($self, $const) = @_;
+ require Apache::Constants::Exports;
return $ConstNameCache{$const} if $ConstNameCache{$const};
-
+
for (@Apache::Constants::EXPORT,
@Apache::Constants::EXPORT_OK) {
if ((\&{$_})->() == $const) {
1.1 modperl/lib/Apache/Constants/Exports.pm
Index: Exports.pm
===================================================================
package Apache::Constants::Exports;
use strict;
my(@common) = qw(OK DECLINED DONE NOT_FOUND FORBIDDEN
AUTH_REQUIRED SERVER_ERROR);
my(@methods) = qw(M_CONNECT M_DELETE M_GET M_INVALID M_OPTIONS
M_POST M_PUT M_TRACE METHODS);
my(@options) = qw(OPT_NONE OPT_INDEXES OPT_INCLUDES
OPT_SYM_LINKS OPT_EXECCGI OPT_UNSET OPT_INCNOEXEC
OPT_SYM_OWNER OPT_MULTI OPT_ALL);
my(@server) = qw(MODULE_MAGIC_NUMBER
SERVER_VERSION SERVER_SUBVERSION SERVER_BUILT);
my(@response) = qw(DOCUMENT_FOLLOWS MOVED REDIRECT
USE_LOCAL_COPY
BAD_REQUEST
BAD_GATEWAY
RESPONSE_CODES
NOT_IMPLEMENTED
NOT_AUTHORITATIVE
CONTINUE);
my(@satisfy) = qw(SATISFY_ALL SATISFY_ANY SATISFY_NOSPEC);
my(@remotehost) = qw(REMOTE_HOST REMOTE_NAME
REMOTE_NOLOOKUP REMOTE_DOUBLE_REV);
my(@http) = qw(HTTP_METHOD_NOT_ALLOWED
HTTP_NOT_ACCEPTABLE
HTTP_LENGTH_REQUIRED
HTTP_PRECONDITION_FAILED
HTTP_SERVICE_UNAVAILABLE
HTTP_VARIANT_ALSO_VARIES
HTTP_NO_CONTENT
HTTP_METHOD_NOT_ALLOWED
HTTP_NOT_ACCEPTABLE
HTTP_LENGTH_REQUIRED
HTTP_PRECONDITION_FAILED
HTTP_SERVICE_UNAVAILABLE
HTTP_VARIANT_ALSO_VARIES);
my(@config) = qw(DECLINE_CMD);
my(@types) = qw(DIR_MAGIC_TYPE);
my $rc = [@common, @response];
%Apache::Constants::EXPORT_TAGS = (
common => \@common,
config => \@config,
response => $rc,
http => \@http,
options => \@options,
methods => \@methods,
remotehost => \@remotehost,
satisfy => \@satisfy,
server => \@server,
types => \@types,
#depreciated
response_codes => $rc,
);
@Apache::Constants::EXPORT_OK = (
@response,
@http,
@options,
@methods,
@remotehost,
@satisfy,
@server,
@config,
@types,
);
*Apache::Constants::EXPORT = \@common;
sub gen_ctags {
my @tags = ();
my $pack = __PACKAGE__;
print <<EOF;
/*
* Generated by $pack\::gen_ctags, do not edit!!!
*/
EOF
while(my($k,$v) = each %Apache::Constants::EXPORT_TAGS) {
push @tags, $k;
print "static char *ETAG_", $k, "[] = { \n",
(map { qq( "$_",\n) } @$v),
" NULL,\n};\n";
}
my %case_tags = ();
for my $tag (@tags) {
my $key = substr($tag, 0, 1);
push @{ $case_tags{$key} }, $tag;
}
print "static char **export_tags(char *tag) {\n";
print " switch (*tag) {\n";
for my $k (sort keys %case_tags) {
my $v = $case_tags{$k};
print "\tcase '$k':\n";
for my $tag (@$v) {
print qq|\tif(strEQ("$tag", tag))\n\t return ETAG_$tag;\n|;
}
}
print qq|\tdefault:\n\tcroak("unknown tag `%s'", tag);\n|;
print " }\n}\n";
}
1;
__END__
1.9 +64 -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.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- Constants.xs 1998/07/08 18:07:49 1.8
+++ Constants.xs 1998/07/14 14:57:08 1.9
@@ -9,6 +9,53 @@
#define MOD_PERL_STRING_VERSION "mod_perl/x.xx"
#endif
+#ifdef XS_IMPORT
+#include "Exports.c"
+
+static void export_cv(SV *class, SV *caller, char *sub)
+{
+ GV *gv;
+#if 0
+ fprintf(stderr, "*%s::%s = \\&%s::%s\n",
+ SvPVX(caller), sub, SvPVX(class), sub);
+#endif
+ gv = gv_fetchpv(form("%_::%s", caller, sub), TRUE, SVt_PVCV);
+ GvCV(gv) = perl_get_cv(form("%_::%s", class, sub), TRUE);
+ GvIMPORTED_CV_on(gv);
+}
+
+static void my_import(SV *class, SV *caller, SV *sv)
+{
+ char *sym = SvPV(sv,na), **tags;
+ int i;
+
+ switch (*sym) {
+ case ':':
+ ++sym;
+ tags = export_tags(sym);
+ for(i=0; tags[i]; i++) {
+ export_cv(class, caller, tags[i]);
+ }
+ break;
+ case '$':
+ case '%':
+ case '*':
+ case '@':
+ croak("\"%s\" is not exported by the Apache::Constants module", sym);
+ case '&':
+ ++sym;
+ default:
+ if(isALPHA(sym[0])) {
+ export_cv(class, caller, sym);
+ break;
+ }
+ else {
+ croak("Can't export symbol: %s", sym);
+ }
+ }
+}
+#endif /*XS_IMPORT*/
+
static CV *no_warn = Nullcv;
CV *empty_anon_sub(void)
@@ -782,6 +829,23 @@
newCONSTSUB(stash, SvPVX(name), newSViv(val));
}
}
+
+#ifdef XS_IMPORT
+
+void
+import(class, ...)
+ SV *class
+
+ PREINIT:
+ I32 i = 0;
+ SV *caller = perl_eval_pv("scalar caller", TRUE);
+
+ CODE:
+ for(i=1; i<items; i++) {
+ my_import(class, caller, ST(i));
+ }
+
+#endif
void
__AUTOLOAD()
1.1 modperl/src/modules/perl/Exports.c
Index: Exports.c
===================================================================
/*
* Generated by Apache::Constants::Exports::gen_ctags, do not edit!!!
*/
static char *ETAG_http[] = {
"HTTP_METHOD_NOT_ALLOWED",
"HTTP_NOT_ACCEPTABLE",
"HTTP_LENGTH_REQUIRED",
"HTTP_PRECONDITION_FAILED",
"HTTP_SERVICE_UNAVAILABLE",
"HTTP_VARIANT_ALSO_VARIES",
"HTTP_NO_CONTENT",
"HTTP_METHOD_NOT_ALLOWED",
"HTTP_NOT_ACCEPTABLE",
"HTTP_LENGTH_REQUIRED",
"HTTP_PRECONDITION_FAILED",
"HTTP_SERVICE_UNAVAILABLE",
"HTTP_VARIANT_ALSO_VARIES",
NULL,
};
static char *ETAG_satisfy[] = {
"SATISFY_ALL",
"SATISFY_ANY",
"SATISFY_NOSPEC",
NULL,
};
static char *ETAG_methods[] = {
"M_CONNECT",
"M_DELETE",
"M_GET",
"M_INVALID",
"M_OPTIONS",
"M_POST",
"M_PUT",
"M_TRACE",
"METHODS",
NULL,
};
static char *ETAG_types[] = {
"DIR_MAGIC_TYPE",
NULL,
};
static char *ETAG_config[] = {
"DECLINE_CMD",
NULL,
};
static char *ETAG_server[] = {
"MODULE_MAGIC_NUMBER",
"SERVER_VERSION",
"SERVER_SUBVERSION",
"SERVER_BUILT",
NULL,
};
static char *ETAG_common[] = {
"OK",
"DECLINED",
"DONE",
"NOT_FOUND",
"FORBIDDEN",
"AUTH_REQUIRED",
"SERVER_ERROR",
NULL,
};
static char *ETAG_remotehost[] = {
"REMOTE_HOST",
"REMOTE_NAME",
"REMOTE_NOLOOKUP",
"REMOTE_DOUBLE_REV",
NULL,
};
static char *ETAG_response_codes[] = {
"OK",
"DECLINED",
"DONE",
"NOT_FOUND",
"FORBIDDEN",
"AUTH_REQUIRED",
"SERVER_ERROR",
"DOCUMENT_FOLLOWS",
"MOVED",
"REDIRECT",
"USE_LOCAL_COPY",
"BAD_REQUEST",
"BAD_GATEWAY",
"RESPONSE_CODES",
"NOT_IMPLEMENTED",
"NOT_AUTHORITATIVE",
"CONTINUE",
NULL,
};
static char *ETAG_options[] = {
"OPT_NONE",
"OPT_INDEXES",
"OPT_INCLUDES",
"OPT_SYM_LINKS",
"OPT_EXECCGI",
"OPT_UNSET",
"OPT_INCNOEXEC",
"OPT_SYM_OWNER",
"OPT_MULTI",
"OPT_ALL",
NULL,
};
static char *ETAG_response[] = {
"OK",
"DECLINED",
"DONE",
"NOT_FOUND",
"FORBIDDEN",
"AUTH_REQUIRED",
"SERVER_ERROR",
"DOCUMENT_FOLLOWS",
"MOVED",
"REDIRECT",
"USE_LOCAL_COPY",
"BAD_REQUEST",
"BAD_GATEWAY",
"RESPONSE_CODES",
"NOT_IMPLEMENTED",
"NOT_AUTHORITATIVE",
"CONTINUE",
NULL,
};
static char **export_tags(char *tag) {
switch (*tag) {
case 'c':
if(strEQ("config", tag))
return ETAG_config;
if(strEQ("common", tag))
return ETAG_common;
case 'h':
if(strEQ("http", tag))
return ETAG_http;
case 'm':
if(strEQ("methods", tag))
return ETAG_methods;
case 'o':
if(strEQ("options", tag))
return ETAG_options;
case 'r':
if(strEQ("remotehost", tag))
return ETAG_remotehost;
if(strEQ("response_codes", tag))
return ETAG_response_codes;
if(strEQ("response", tag))
return ETAG_response;
case 's':
if(strEQ("satisfy", tag))
return ETAG_satisfy;
if(strEQ("server", tag))
return ETAG_server;
case 't':
if(strEQ("types", tag))
return ETAG_types;
default:
croak("unknown tag `%s'", tag);
}
}
1.7 +2 -0 modperl/t/net/perl/constants.pl
Index: constants.pl
===================================================================
RCS file: /export/home/cvs/modperl/t/net/perl/constants.pl,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- constants.pl 1998/07/08 18:07:52 1.6
+++ constants.pl 1998/07/14 14:57:09 1.7
@@ -6,6 +6,8 @@
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
+eval { require Apache::Constants::Exports };
+
use Apache::Constants ();
use strict qw(vars);
shift->send_http_header("text/plain");