perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From do...@hyperreal.org
Subject cvs commit: modperl/t/net/perl constants.pl
Date Tue, 14 Jul 1998 14:57:09 GMT
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");
  
  
  

Mime
View raw message