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';
