dougm 00/05/12 00:11:05 Modified: . Changes ToDo lib/Apache PerlRun.pm t/docs startup.pl t/modules perlrun.t t/net/perl dirty-script.cgi dirty-test.cgi Log: Apache::PerlRun::flush_namespace fixes, so aliased (imported) code/hash/array/scalar are undefined without undef-ing the pointed-to data and without using B.pm and: modules/perlrun was never properly run in the first place Revision Changes Path 1.479 +4 -0 modperl/Changes Index: Changes =================================================================== RCS file: /home/cvs/modperl/Changes,v retrieving revision 1.478 retrieving revision 1.479 diff -u -r1.478 -r1.479 --- Changes 2000/05/05 08:10:33 1.478 +++ Changes 2000/05/12 07:10:56 1.479 @@ -10,6 +10,10 @@ =item 1.23_01-dev +Apache::PerlRun::flush_namespace fixes, so aliased (imported) +code/hash/array/scalar are undefined without undef-ing the pointed-to +data and without using B.pm, thanks to Richard Chen for the suggestion + document Apache::print's special behavior wrt references [Jeffrey W. Baker <[EMAIL PROTECTED]>] 1.242 +1 -4 modperl/ToDo Index: ToDo =================================================================== RCS file: /home/cvs/modperl/ToDo,v retrieving revision 1.241 retrieving revision 1.242 diff -u -r1.241 -r1.242 --- ToDo 2000/04/21 17:04:56 1.241 +++ ToDo 2000/05/12 07:10:56 1.242 @@ -52,10 +52,7 @@ - coderef to $r->custom_response [Randal L. Schwartz <[EMAIL PROTECTED]>] -- PerlRun::flush_namespace needs to check if_owner for all types, not -just cvs. NOTE: i dont think this is possible, only CVs have a GV -pointer attached -dougm -[John M Vinopal <[EMAIL PROTECTED]>] +- Apache::PerlRun::flush_namespace should be re-written in c - should $r->content unset $r->headers_in('content-length') ? NOTE: im worried this could break apps who need to know content-length 1.28 +34 -20 modperl/lib/Apache/PerlRun.pm Index: PerlRun.pm =================================================================== RCS file: /home/cvs/modperl/lib/Apache/PerlRun.pm,v retrieving revision 1.27 retrieving revision 1.28 diff -u -r1.27 -r1.28 --- PerlRun.pm 2000/04/05 06:19:34 1.27 +++ PerlRun.pm 2000/05/12 07:10:57 1.28 @@ -312,36 +312,50 @@ return $rc; } +BEGIN { + if ($] < 5.006) { + $INC{'warnings.pm'} = __FILE__; + *warnings::unimport = sub {}; + } +} + sub flush_namespace { my($self, $package) = @_; $package ||= $self->namespace; - no strict; + no strict 'refs'; my $tab = \%{$package.'::'}; for (keys %$tab) { - if(*{ $tab->{$_} }{CODE}) { - undef_cv_if_owner($package, \&{ $tab->{$_} }); - } - if(*{ $tab->{$_} }{HASH}) { - undef %{ $tab->{$_} }; + my $fullname = join '::', $package, $_; + #code/hash/array/scalar might be imported + #make sure the gv does not point elsewhere + #before undefing each + if (%$fullname) { + *{$fullname} = {}; + undef %$fullname; } - if(*{ $tab->{$_} }{ARRAY}) { - undef @{ $tab->{$_} }; + if (@$fullname) { + *{$fullname} = []; + undef @$fullname; } - if(*{ $tab->{$_} }{SCALAR}) { - undef ${ $tab->{$_} }; + if ($$fullname) { + my $tmp; #argh, no such thing as an anonymous scalar + *{$fullname} = \$tmp; + undef $$fullname; } - } -} - -sub undef_cv_if_owner { - return unless $INC{'B.pm'}; - my($package, $cv) = @_; - my $obj = B::svref_2object($cv); - my $stash = $obj->GV->STASH->NAME; - return unless $package eq $stash; - undef &$cv; + if (defined &$fullname) { + no warnings; + local $^W = 0; + *{$fullname} = sub {}; + undef &$fullname; + } + if (*{$fullname}{IO}) { + if (fileno $fullname) { + close $fullname; + } + } + } } 1; 1.37 +5 -2 modperl/t/docs/startup.pl Index: startup.pl =================================================================== RCS file: /home/cvs/modperl/t/docs/startup.pl,v retrieving revision 1.36 retrieving revision 1.37 diff -u -r1.36 -r1.37 --- startup.pl 1999/04/07 03:34:35 1.36 +++ startup.pl 2000/05/12 07:10:58 1.37 @@ -1,4 +1,4 @@ -#! /usr/local/bin/perl +#!perl unless (defined $ENV{MOD_PERL}) { die "\$ENV{MOD_PERL} not set!"; @@ -103,7 +103,10 @@ $ENV{GATEWAY_INTERFACE} =~ /^CGI-Perl/ or die "GATEWAY_INTERFACE not set!"; -sub Outside::imported {4} +sub Outside::code {4} +%Outside::hash = (one => 1); +@Outside::array = qw(one); +$Outside::scalar = 'one'; #will be redef'd during tests sub PerlTransHandler::handler {-1} 1.2 +2 -0 modperl/t/modules/perlrun.t Index: perlrun.t =================================================================== RCS file: /home/cvs/modperl/t/modules/perlrun.t,v retrieving revision 1.1 retrieving revision 1.2 diff -u -r1.1 -r1.2 --- perlrun.t 1998/04/26 00:16:40 1.1 +++ perlrun.t 2000/05/12 07:10:58 1.2 @@ -1,4 +1,6 @@ use Apache::test; +fetch "/dirty-perl/dirty-script.cgi"; + print fetch "/dirty-perl/dirty-test.cgi"; 1.5 +4 -1 modperl/t/net/perl/dirty-script.cgi Index: dirty-script.cgi =================================================================== RCS file: /home/cvs/modperl/t/net/perl/dirty-script.cgi,v retrieving revision 1.4 retrieving revision 1.5 diff -u -r1.4 -r1.5 --- dirty-script.cgi 1999/01/21 00:38:24 1.4 +++ dirty-script.cgi 2000/05/12 07:10:59 1.5 @@ -10,7 +10,10 @@ open FH, $0 or die $!; sub subroutine {} -*imported = \&Outside::imported; +*code_alias = \&Outside::code; +*hash_alias = \%Outside::hash; +*array_alias = \@Outside::array; +*scalar_alias = \$Outside::scalar; push @array, 1; 1.5 +9 -7 modperl/t/net/perl/dirty-test.cgi Index: dirty-test.cgi =================================================================== RCS file: /home/cvs/modperl/t/net/perl/dirty-test.cgi,v retrieving revision 1.4 retrieving revision 1.5 diff -u -r1.4 -r1.5 --- dirty-test.cgi 1999/08/04 01:56:14 1.4 +++ dirty-test.cgi 2000/05/12 07:10:59 1.5 @@ -4,21 +4,23 @@ die "%INC save/restore broken"; } -package Apache::ROOT::dirty_2dperl::dirty_2dscript_2epl; +package Apache::ROOT::dirty_2dperl::dirty_2dscript_2ecgi; -use Apache::test; +use Apache::test qw(test); print "Content-type: text/plain\n\n"; -print "1..6\n"; +print "1..9\n"; my $i = 0; test ++$i, not defined &subroutine; -test ++$i, not *{"array"}{ARRAY}; -test ++$i, not *{"hash"}{HASH}; +test ++$i, not @array; +test ++$i, not %hash; test ++$i, not defined $scalar; test ++$i, not defined fileno(FH); -test ++$i, Outside::imported() == 4; - +test ++$i, Outside::code() == 4; +test ++$i, keys %Outside::hash == 1; +test ++$i, @Outside::array == 1; +test ++$i, $Outside::scalar eq 'one';