Optimise %hash in sub { %hash || ... }

[perl5.git] / ext / B / B / Concise.pm

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 5eec86a..3f2a93d 100644 (file)
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp
 
 use Exporter (); # use #5
 
-our $VERSION   = "0.87";
+our $VERSION   = "0.92";
 our @ISA       = qw(Exporter);
 our @EXPORT_OK = qw( set_style set_style_standard add_callback
                     concise_subref concise_cv concise_main
@@ -137,7 +137,7 @@ sub concise_subref {
     my $codeobj = svref_2object($coderef);
 
     return concise_stashref(@_)
-       unless ref $codeobj eq 'B::CV';
+       unless ref($codeobj) =~ '^B::(?:CV|FM)\z';
     concise_cv_obj($order, $codeobj, $name);
 }
 
@@ -356,22 +356,30 @@ sub compile {
            }
            else {
                # convert function names to subrefs
-               my $objref;
                if (ref $objname) {
                    print $walkHandle "B::Concise::compile($objname)\n"
                        if $banner;
-                   $objref = $objname;
+                   concise_subref($order, ($objname)x2);
+                   next;
                } else {
                    $objname = "main::" . $objname unless $objname =~ /::/;
-                   print $walkHandle "$objname:\n";
                    no strict 'refs';
-                   unless (exists &$objname) {
+                   my $glob = \*$objname;
+                   unless (*$glob{CODE} || *$glob{FORMAT}) {
+                       print $walkHandle "$objname:\n" if $banner;
                        print $walkHandle "err: unknown function ($objname)\n";
                        return;
                    }
-                   $objref = \&$objname;
+                   if (my $objref = *$glob{CODE}) {
+                       print $walkHandle "$objname:\n" if $banner;
+                       concise_subref($order, $objref, $objname);
+                   }
+                   if (my $objref = *$glob{FORMAT}) {
+                       print $walkHandle "$objname (FORMAT):\n"
+                           if $banner;
+                       concise_subref($order, $objref, $objname);
+                   }
                }
-               concise_subref($order, $objref, $objname);
            }
        }
        for my $pkg (@render_packs) {
@@ -612,7 +620,7 @@ $priv{$_}{4} = "DREFed" for (qw(rv2sv rv2av rv2hv));
 @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV")
   for (qw(rv2gv rv2sv padsv aelem helem));
 $priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv");
-$priv{rv2gv}{4} = "NOINIT";
+@{$priv{rv2gv}}{4,16} = qw "NOINIT FAKE";
 @{$priv{"entersub"}}{1,4,16,32,64} = qw( INARGS TARG DBG DEREF );
 @{$priv{rv2cv}}{1,8,128} = ("CONST","AMPER","NO()");
 $priv{"gv"}{32} = "EARLYCV";
@@ -621,6 +629,8 @@ $priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv",
        "enteriter");
 $priv{$_}{8} = 'LVSUB' for qw(rv2av rv2gv rv2hv padav padhv aelem helem
                         aslice hslice av2arylen keys rkeys substr pos vec);
+$priv{$_}{64} = 'BOOL' for 'rv2hv', 'padhv';
+$priv{substr}{16} = 'REPL1ST';
 $priv{$_}{16} = "TARGMY"
   for (map(($_,"s$_"),"chop", "chomp"),
        map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo",
@@ -634,7 +644,8 @@ $priv{$_}{16} = "TARGMY"
        "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
        "setpriority", "time", "sleep");
 $priv{$_}{4} = "REVERSED" for ("enteriter", "iter");
-@{$priv{"const"}}{4,8,16,64,128} = ("SHORT","STRICT","ENTERED","BARE","WARN");
+@{$priv{"const"}}{2,4,8,16,64,128} =
+    ("NOVER","SHORT","STRICT","ENTERED","BARE","FOLD");
 $priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
 $priv{"list"}{64} = "GUESSED";
 $priv{"delete"}{64} = "SLICE";
@@ -647,10 +658,10 @@ $priv{"threadsv"}{64} = "SVREFd";
 $priv{"exit"}{128} = "VMS";
 $priv{$_}{2} = "FTACCESS"
   for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
-$priv{"entereval"}{2} = "HAS_HH";
+@{$priv{"entereval"}}{2,4,8,16} = qw "HAS_HH UNI BYTES COPHH";
 if ($] >= 5.009) {
   # Stacked filetests are post 5.8.x
-  @{$priv{$_}}{4,8} = ("FTSTACKED","FTSTACKING")
+  @{$priv{$_}}{4,8,16} = ("FTSTACKED","FTSTACKING","FTAFTERt")
     for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec",
          "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime",
         "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir",
@@ -660,13 +671,14 @@ if ($] >= 5.009) {
   $priv{$_}{2} = "GREPLEX"
     for ("mapwhile", "mapstart", "grepwhile", "grepstart");
 }
-$priv{$_}{128} = '+1' for qw "caller wantarray";
+$priv{$_}{128} = '+1' for qw "caller wantarray runcv";
 @{$priv{coreargs}}{1,2,64,128} = ('DREF1','DREF2','$MOD','MARK');
+$priv{$_}{128} = 'UTF' for qw "last redo next goto dump";
 
 our %hints; # used to display each COP's op_hints values
 
 # strict refs, subs, vars
-@hints{2,512,1024} = ('$', '&', '*');
+@hints{2,512,1024,32,64,128} = ('$', '&', '*', 'x$', 'x&', 'x*');
 # integers, locale, bytes
 @hints{1,4,8,16} = ('i', 'l', 'b');
 # block scope, localise %^H, $^OPEN (in), $^OPEN (out)
@@ -1126,7 +1138,8 @@ on threaded and un-threaded perls.
 =head1 OPTIONS
 
 Arguments that don't start with a hyphen are taken to be the names of
-subroutines to render; if no such functions are specified, the main
+subroutines or formats to render; if no
+such functions are specified, the main
 body of the program (outside any subroutines, and not including use'd
 or require'd files) is rendered.  Passing C<BEGIN>, C<UNITCHECK>,
 C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
@@ -1545,6 +1558,9 @@ string if this is not a COP. Here are the symbols used:
     $ strict refs
     & strict subs
     * strict vars
+   x$ explicit use/no strict refs
+   x& explicit use/no strict subs
+   x* explicit use/no strict vars
     i integers
     l locale
     b bytes