Return-Path: Delivered-To: modperl-cvs-archive@hyperreal.org Received: (qmail 7279 invoked by uid 6000); 30 Oct 1998 02:40:06 -0000 Received: (qmail 7269 invoked by uid 169); 30 Oct 1998 02:40:04 -0000 Date: 30 Oct 1998 02:40:04 -0000 Message-ID: <19981030024004.7268.qmail@hyperreal.org> From: dougm@hyperreal.org To: modperl-cvs@hyperreal.org Subject: cvs commit: modperl/t/net/perl tie_table.pl Sender: modperl-cvs-owner@apache.org Precedence: bulk Reply-To: modperl-cvs@apache.org dougm 98/10/29 18:40:04 Modified: . Makefile.PL Table Table.pm src/modules/perl Table.xs t/net/perl tie_table.pl Log: a bit of Apache::Table optimization Revision Changes Path 1.106 +5 -7 modperl/Makefile.PL Index: Makefile.PL =================================================================== RCS file: /export/home/cvs/modperl/Makefile.PL,v retrieving revision 1.105 retrieving revision 1.106 diff -u -r1.105 -r1.106 --- Makefile.PL 1998/10/29 20:53:24 1.105 +++ Makefile.PL 1998/10/30 02:40:01 1.106 @@ -151,7 +151,7 @@ $PERL_EXTRA_CFLAGS = ""; $SSLCacheServerPort = 8539; $SSL_BASE = ""; -$Port = 8529; +$Port = $Is_dougm ? 8530 : 8529; #so Doug can 'make test' different-builds@sametime/samebox if(!$Is_Win32 and $ENV{RANDOM_PORT} and $$ > 8000 and $$ < 30000) { $PORT ||= $$; @@ -444,7 +444,8 @@ $USE_APACI = $USE_DSO = 0; } - for (qw(PERL_LOG_API PERL_URI_API PERL_UTIL_API PERL_FILE_API)) { + 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)"; @@ -591,10 +592,7 @@ push @xs_modules, "Apache::ModuleConfig"; $callback_hooks{PERL_DIRECTIVE_HANDLERS} = 1; } -if($PERL_TABLE_API) { - push @xs_modules, "Apache::Table"; - $callback_hooks{PERL_TABLE_API} = 1; -} + if($PERL_RUN_XS or $experimental{PERL_RUN_XS} > 1) { my $mmn = $USE_APXS ? MMN_130 : magic_number($APACHE_SRC); if($mmn >= MMN_130) { @@ -606,7 +604,7 @@ print "Sorry, need 1.3.0+ for Apache::PerlRunXS\n"; } } -for (qw(Log URI Util Connection Server File)) { +for (qw(Log URI Util Connection Server File Table)) { my $s = "PERL_".uc($_)."_API"; if($$s) { push @xs_modules, "Apache::$_"; 1.2 +0 -1 modperl/Table/Table.pm Index: Table.pm =================================================================== RCS file: /export/home/cvs/modperl/Table/Table.pm,v retrieving revision 1.1 retrieving revision 1.2 diff -u -r1.1 -r1.2 --- Table.pm 1998/10/29 20:53:29 1.1 +++ Table.pm 1998/10/30 02:40:02 1.2 @@ -9,7 +9,6 @@ if($ENV{MOD_PERL}) { __PACKAGE__->bootstrap($VERSION); } -*DESTROY = \&destroy; #avoid weird xsubpp bug 1; 1.2 +42 -24 modperl/src/modules/perl/Table.xs Index: Table.xs =================================================================== RCS file: /export/home/cvs/modperl/src/modules/perl/Table.xs,v retrieving revision 1.1 retrieving revision 1.2 diff -u -r1.1 -r1.2 --- Table.xs 1998/10/29 20:53:31 1.1 +++ Table.xs 1998/10/30 02:40:03 1.2 @@ -1,23 +1,22 @@ #include "mod_perl.h" typedef struct { - SV *sv; SV *cv; - HV *hv; + table *only; } TableDo; +#define table_pool(t) ((array_header *)(t))->pool + static int Apache_table_do(TableDo *td, const char *key, const char *val) { int count=0, rv=1; dSP; - if(td->hv && !hv_exists(td->hv, (char*)key, strlen(key))) + if(td->only && !table_get(td->only, key)) return 1; ENTER;SAVETMPS; PUSHMARK(sp); - if(td->sv && (td->sv != &sv_undef)) - XPUSHs(td->sv); XPUSHs(sv_2mortal(newSVpv((char *)key,0))); XPUSHs(sv_2mortal(newSVpv((char *)val,0))); PUTBACK; @@ -52,6 +51,16 @@ } +static Apache__Table ApacheTable_new(table *table) +{ + Apache__Table RETVAL = (Apache__Table)safemalloc(sizeof(TiedTable)); + RETVAL->table = table; + RETVAL->ix = 0; + RETVAL->elts = NULL; + RETVAL->arr = NULL; + return RETVAL; +} + MODULE = Apache::Table PACKAGE = Apache::Table PROTOTYPES: DISABLE @@ -66,21 +75,35 @@ CODE: if(!class) XSRETURN_UNDEF; - RETVAL = (Apache__Table)safemalloc(sizeof(TiedTable)); - RETVAL->table = table; - RETVAL->ix = 0; - RETVAL->elts = NULL; - RETVAL->arr = NULL; + RETVAL = ApacheTable_new(table); OUTPUT: RETVAL +Apache::Table +new(class, r, nalloc=10) + SV *class + Apache r + int nalloc + + CODE: + if(!class) XSRETURN_UNDEF; + RETVAL = ApacheTable_new(make_table(r->pool, nalloc)); + + OUTPUT: + RETVAL + void -destroy(self) - Apache::Table self +DESTROY(self) + SV *self + + PREINIT: + Apache__Table tab; CODE: - safefree(self); + tab = (Apache__Table)hvrv2table(self); + if(SvROK(self) && SvTYPE(SvRV(self)) == SVt_PVHV) + safefree(tab); void FETCH(self, key) @@ -215,31 +238,26 @@ table_modify(self, key, sv, table_merge); void -do(self, cv, sv=Nullsv, ...) +do(self, cv, ...) Apache::Table self SV *cv - SV *sv PREINIT: TableDo td; - HV *hv = Nullhv; + td.only = (table *)NULL; CODE: - if(items > 3) { + if(items > 2) { int i; STRLEN len; - hv = newHV(); - for(i=3; ; i++) { + td.only = make_table(table_pool(self->table), items-2); + for(i=2; ; i++) { char *key = SvPV(ST(i),len); - hv_store(hv, key, len, newSViv(1), FALSE); + table_set(td.only, key, "1"); if(i == (items - 1)) break; } } - td.sv = sv; td.cv = cv; - td.hv = hv; table_do((int (*) (void *, const char *, const char *)) Apache_table_do, (void *) &td, self->table, NULL); - - if(hv) SvREFCNT_dec(hv); 1.8 +9 -9 modperl/t/net/perl/tie_table.pl Index: tie_table.pl =================================================================== RCS file: /export/home/cvs/modperl/t/net/perl/tie_table.pl,v retrieving revision 1.7 retrieving revision 1.8 diff -u -r1.7 -r1.8 --- tie_table.pl 1998/10/29 20:53:33 1.7 +++ tie_table.pl 1998/10/30 02:40:03 1.8 @@ -62,26 +62,26 @@ test ++$i, $Seen{two}; %Seen = (); -$r->notes->do(\&print_header, undef, qw(three)); +$r->notes->do(\&print_header, qw(three)); test ++$i, not exists $Seen{two}; -sub str_header { - my($av, $k, $v) = @_; - push @$av, "$k: $v"; - 1; -} - sub my_as_string { my $r = shift; my @retval = (); push @retval, $r->the_request; + + my $str_header = sub { + my($k, $v) = @_; + push @retval, "$k: $v"; + 1; + }; - $r->headers_in->do(\&str_header, \@retval); + $r->headers_in->do($str_header); push @retval, ""; push @retval, join(" ", $r->protocol, $r->status_line); for my $meth (qw(headers_out err_headers_out)) { - $r->$meth()->do(\&str_header, \@retval); + $r->$meth()->do($str_header); } push @retval, "", ""; join "\n", grep { defined $_ } @retval;