diff options
| -rw-r--r-- | lib/File/DosGlob.pm | 13 | ||||
| -rw-r--r-- | pod/perlsub.pod | 56 | ||||
| -rwxr-xr-x | t/lib/dosglob.t | 20 |
3 files changed, 82 insertions, 7 deletions
diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm index a27dad9030..24b28b2dce 100644 --- a/lib/File/DosGlob.pm +++ b/lib/File/DosGlob.pm @@ -130,10 +130,10 @@ sub glob { sub import { my $pkg = shift; - my $callpkg = caller(0); + return unless @_; my $sym = shift; - *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} - if defined($sym) and $sym eq 'glob'; + my $callpkg = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0)); + *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; } 1; @@ -151,6 +151,9 @@ File::DosGlob - DOS like globbing and then some # override CORE::glob in current package use File::DosGlob 'glob'; + # override CORE::glob in ALL packages (use with extreme caution!) + use File::DosGlob 'GLOBAL_glob'; + @perlfiles = glob "..\\pe?l/*.p?"; print <..\\pe?l/*.p?>; @@ -192,6 +195,10 @@ Gurusamy Sarathy <gsar@umich.edu> =item * +Support for globally overriding glob() (GSAR 3-JUN-98) + +=item * + Scalar context, independent iterator context fixes (GSAR 15-SEP-97) =item * diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 7212bb5907..1d7660c20e 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -932,9 +932,59 @@ and it would import the open override, but if they said they would get the default imports without the overrides. -Note that such overriding is restricted to the package that requests -the import. Some means of "globally" overriding builtins may become -available in future. +The foregoing mechanism for overriding builtins is restricted, quite +deliberately, to the package that requests the import. There is a second +method that is sometimes applicable when you wish to override a builtin +everywhere, without regard to namespace boundaries. This is achieved by +importing a sub into the special namespace C<CORE::GLOBAL::>. Here is an +example that quite brazenly replaces the C<glob> operator with something +that understands regular expressions. + + package REGlob; + require Exporter; + @ISA = 'Exporter'; + @EXPORT_OK = 'glob'; + + sub import { + my $pkg = shift; + return unless @_; + my $sym = shift; + my $where = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0)); + $pkg->export($where, $sym, @_); + } + + sub glob { + my $pat = shift; + my @got; + local(*D); + if (opendir D, '.') { @got = grep /$pat/o, readdir D; closedir D; } + @got; + } + 1; + +And here's how it could be (ab)used: + + #use REGlob 'GLOBAL_glob'; # override glob() in ALL namespaces + package Foo; + use REGlob 'glob'; # override glob() in Foo:: only + print for <^[a-z_]+\.pm\$>; # show all pragmatic modules + +Note that the initial comment shows a contrived, even dangerous example. +By overriding C<glob> globally, you would be forcing the new (and +subversive) behavior for the C<glob> operator for B<every> namespace, +without the complete cognizance or cooperation of the modules that own +those namespaces. Naturally, this should be done with extreme caution--if +it must be done at all. + +The C<REGlob> example above does not implement all the support needed to +cleanly override perl's C<glob> operator. The builtin C<glob> has +different behaviors depending on whether it appears in a scalar or list +context, but our C<REGlob> doesn't. Indeed, many perl builtins have such +context sensitive behaviors, and these must be adequately supported by +a properly written override. For a fully functional example of overriding +C<glob>, study the implementation of C<File::DosGlob> in the standard +library. + =head2 Autoloading diff --git a/t/lib/dosglob.t b/t/lib/dosglob.t index 7398a14065..577d4eac22 100755 --- a/t/lib/dosglob.t +++ b/t/lib/dosglob.t @@ -9,7 +9,7 @@ BEGIN { @INC = '../lib'; } -print "1..9\n"; +print "1..10\n"; # override it in main:: use File::DosGlob 'glob'; @@ -92,3 +92,21 @@ while (<*/a*.t>) { print "not " if "@r" ne "@s"; print "ok 9\n"; +# how about a global override, hm? +eval <<'EOT'; +use File::DosGlob 'GLOBAL_glob'; +package Bar; +@s = (); +while (<*/a*.t>) { + my $i = 0; + print "# $_ <"; + push @s, $_; + while (glob '*/b*.t') { + print " $_"; + $i++; + } + print " >\n"; +} +print "not " if "@r" ne "@s"; +print "ok 10\n"; +EOT |