A way to avoid English.pm performance hit.

Subject: [YAPATCH English.pm] My turn to putt again
Message-Id: <200006230033.UAA05960@jester.slaysys.com>

p4raw-id: //depot/cfgperl@6224

diff --git a/lib/English.pm b/lib/English.pm
index f38c313..1ebc3de 100644 (file)
--- a/lib/English.pm
+++ b/lib/English.pm
@@ -9,6 +9,7 @@ English - use nice English (or awk) names for ugly punctuation variables
 
 =head1 SYNOPSIS
 
+    use English qw( -no_match_vars ) ;  # Avoids regex performance penalty
     use English;
     ...
     if ($ERRNO =~ /denied/) { ... }
@@ -27,29 +28,52 @@ $INPUT_RECORD_SEPARATOR if you are using the English module.
 
 See L<perlvar> for a complete list of these.
 
-=head1 BUGS
+=head1 PERFORMANCE
 
-This module provokes sizeable inefficiencies for regular expressions,
-due to unfortunate implementation details.  If performance matters,
-consider avoiding English.
+This module can provoke sizeable inefficiencies for regular expressions,
+due to unfortunate implementation details.  If performance matters in
+your application and you don't need $PREMATCH, $MATCH, or $POSTMATCH,
+try doing
+
+   use English qw( -no_match_vars ) ;
+
+.  B<It is especially important to do this in modules to avoid penalizing
+all applications which use them.>
 
 =cut
 
 no warnings;
 
+my $globbed_match ;
+
 # Grandfather $NAME import
 sub import {
     my $this = shift;
-    my @list = @_;
+    my @list = grep { ! /^-no_match_vars$/ } @_ ;
     local $Exporter::ExportLevel = 1;
+    if ( @_ == @list ) {
+        *EXPORT = \@COMPLETE_EXPORT ;
+        $globbed_match ||= (
+           eval q{
+               *MATCH                          = *&    ;
+               *PREMATCH                               = *`    ;
+               *POSTMATCH                              = *'    ;
+               1 ;
+              }
+           || do {
+               require Carp ;
+               Carp::croak "Can't create English for match leftovers: $@" ;
+           }
+       ) ;
+    }
+    else {
+        *EXPORT = \@MINIMAL_EXPORT ;
+    }
     Exporter::import($this,grep {s/^\$/*/} @list);
 }
 
-@EXPORT = qw(
+@MINIMAL_EXPORT = qw(
        *ARG
-       *MATCH
-       *PREMATCH
-       *POSTMATCH
        *LAST_PAREN_MATCH
        *INPUT_LINE_NUMBER
        *NR
@@ -102,15 +126,21 @@ sub import {
        @LAST_MATCH_END
 );
 
+
+@MATCH_EXPORT = qw(
+       *MATCH
+       *PREMATCH
+       *POSTMATCH
+);
+
+@COMPLETE_EXPORT = ( @MINIMAL_EXPORT, @MATCH_EXPORT ) ;
+
 # The ground of all being. @ARG is deprecated (5.005 makes @_ lexical)
 
        *ARG                                    = *_    ;
 
 # Matching.
 
-       *MATCH                                  = *&    ;
-       *PREMATCH                               = *`    ;
-       *POSTMATCH                              = *'    ;
        *LAST_PAREN_MATCH                       = *+    ;
        *LAST_MATCH_START                       = *-{ARRAY} ;
        *LAST_MATCH_END                         = *+{ARRAY} ;

diff --git a/t/lib/english.t b/t/lib/english.t
index dba68db..bcc41e1 100755 (executable)
--- a/t/lib/english.t
+++ b/t/lib/english.t
@@ -1,9 +1,9 @@
 #!./perl
 
-print "1..16\n";
+print "1..22\n";
 
 BEGIN { unshift @INC, '../lib' }
-use English;
+use English qw( -no_match_vars ) ;
 use Config;
 my $threads = $Config{'use5005threads'} || 0;
 
@@ -17,13 +17,11 @@ sub foo {
 }
 &foo(1);
 
-if ($threads) {
-    $_ = "ok 4\nok 5\nok 6\n";
-} else {
-    $ARG = "ok 4\nok 5\nok 6\n";
-}
-/ok 5\n/;
-print $PREMATCH, $MATCH, $POSTMATCH;
+"abc" =~ /b/;
+
+print ! $PREMATCH  ? "" : "not ", "ok 4\n" ;
+print ! $MATCH     ? "" : "not ", "ok 5\n" ;
+print ! $POSTMATCH ? "" : "not ", "ok 6\n" ;
 
 $OFS = " ";
 $ORS = "\n";
@@ -45,3 +43,23 @@ print $EGID == $) ? "ok 14\n" : "not ok 14\n";
 
 print $PROGRAM_NAME == $0 ? "ok 15\n" : "not ok 15\n";
 print $BASETIME == $^T ? "ok 16\n" : "not ok 16\n";
+
+package B ;
+
+use English ;
+
+"abc" =~ /b/;
+
+print $PREMATCH  ? "" : "not ", "ok 17\n" ;
+print $MATCH     ? "" : "not ", "ok 18\n" ;
+print $POSTMATCH ? "" : "not ", "ok 19\n" ;
+
+package C ;
+
+use English qw( -no_match_vars ) ;
+
+"abc" =~ /b/;
+
+print ! $PREMATCH  ? "" : "not ", "ok 20\n" ;
+print ! $MATCH     ? "" : "not ", "ok 21\n" ;
+print ! $POSTMATCH ? "" : "not ", "ok 22\n" ;