1# Stash.pm -- show what stashes are loaded 2package B::Stash; 3 4our $VERSION = '1.03'; 5 6=pod 7 8=head1 NAME 9 10B::Stash - show what stashes are loaded 11 12=head1 DESCRIPTION 13 14B::Stash has a poor side-effect only API and is only used by perlcc and L<B::C>, 15and there its usability is also inferior. 16 17It hooks into B<CHECK> and prints a comma-seperated list of loaded stashes 18(I<package names>) prefixed with B<-u>. 19 20With the B<xs> option stashes with XS modules only are printed, prefixed with B<-x>. 21 22With the B<-D> option some debugging output is added. 23 24Note that the resulting list of modules from B::Stash is usually larger and more 25inexact than the list of used modules determined by the compiler suite (C, CC, Bytecode). 26 27=head1 SYNOPSIS 28 29 # typical usage: 30 perlcc -stash -e'use IO::Handle;' 31 32 perlcc -stash -v3 -e'use IO::Handle;' 33 => 34 ... 35 Stash: main strict Cwd Regexp Exporter Exporter::Heavy warnings DB 36 attributes Carp Carp::Heavy Symbol PerlIO SelectSaver 37 ... 38 39 perl -c -MB::Stash -e'use IO::Handle;' 40 => -umain,-uIO 41 42 perl -c -MB::Stash=xs -e'use IO::Handle;' 43 => -xre,-xCwd,-xRegexp,-xIO 44 45 perl -c -MO=Stash=xs,-D -e'use IO::Handle;' 46 ... 47 => -xre,-xCwd,-xRegexp,-xIO 48 49 perl -c -MO=C,-dumpxs -e'use IO::Handle;' 50 ... 51 perlcc.lst: -xre,-xCwd,-xRegexp,-xIO 52 53=cut 54 55# BEGIN { %Seen = %INC } 56 57sub import { 58 my ($class, @options) = @_; 59 my $opts = ",".join(",", @options).","; 60 my $xs = $opts =~ /,xs,/; 61 my $debug = $opts =~ /,-D,/; 62 print "import: ",$class,$opts,"\n" if $debug; 63 unless ($xs) { 64 eval q[ 65 CHECK { 66 ] . ($debug ? q[print "scan main\n"; my $debug=1;] : "") . q[ 67 my @arr = scan( $main::{"main::"},'',$debug ); 68 @arr = map { s/\:\:$//; $_ eq "<none>" ? () : $_; } @arr; 69 print "-umain,-u", join( ",-u", @arr ), "\n"; 70 } ]; 71 } else { 72 eval q[ 73 CHECK { 74 ] . ($debug ? q[print "scanxs main\n"; my $debug=1;] : "") . q[ 75#line 2 B/Stash.pm 76 require XSLoader; 77 XSLoader::load('B::Stash'); # for xs only 78 my @arr = scanxs( $main::{"main::"},'',$debug ); 79 @arr = map { s/\:\:$//; $_ eq "<none>" ? () : $_; } @arr; 80 print "-x", join( ",-x", @arr ), "\n"; 81 } ]; 82 } 83} 84 85# new O interface, esp. for debugging 86sub compile { 87 my @options = @_; 88 my $opts = ",".join(",", @options).","; 89 my $xs = $opts =~ /,xs,/; 90 my $debug = $opts =~ /,-D,/; 91 print "import: ",$class,$opts,"\n" if $debug; 92 unless ($xs) { 93 print "scan main\n" if $debug; 94 return sub { 95 my @arr = scan( $main::{"main::"},'',$debug ); 96 @arr = map { s/\:\:$//; $_ eq "<none>" ? () : $_; } @arr; 97 print "-umain,-u", join( ",-u", @arr ), "\n"; 98 } 99 } else { 100 require XSLoader; 101 XSLoader::load('B::Stash'); # for xs only 102 print "scanxs main\n" if $debug; 103 return sub { 104 my @arr = scanxs( $main::{"main::"},'',$debug ); 105 @arr = map { s/\:\:$//; $_ eq "<none>" ? () : $_; } @arr; 106 print "-x", join( ",-x", @arr ), "\n"; 107 } 108 } 109} 110 111sub scan { 112 my $start = shift; 113 my $prefix = shift; 114 my $debug = shift; 115 $prefix = '' unless defined $prefix; 116 my @return; 117 foreach my $key ( grep /::$/, keys %{$start} ) { 118 my $name = $prefix . $key; 119 print $name,"\n" if $debug; 120 unless ( $start eq ${$start}{$key} or omit($name) ) { 121 push @return, $key unless $name eq "version::"; # version has an external ::vxs module 122 foreach my $subscan ( scan( ${$start}{$key}, $name ) ) { 123 my $subname = $key.$subscan; 124 print $subname,"\n" if $debug; 125 push @return, $subname; 126 } 127 } 128 } 129 return @return; 130} 131 132sub omit { 133 my $name = shift; 134 my %omit = ( 135 "DynaLoader::" => 1, 136 "XSLoader::" => 1, 137 "CORE::" => 1, 138 "CORE::GLOBAL::" => 1, 139 "UNIVERSAL::" => 1, 140 "B::" => 1, # inexact. There could be interesting external B modules 141 "O::" => 1, 142 'PerlIO::Layer::'=> 1, # inexact. Only find|NoWarnings should be skipped 143 ); 144 my %static_core_pkg = map {$_ => 1} static_core_packages(); 145 return 1 if $omit{$name}; 146 return 1 if $static_core_pkg{substr($name,0,-2)}; 147 if ( $name eq "IO::" or $name eq "IO::Handle::" ) { 148 $name =~ s/::/\//g; 149 return 1 unless $INC{$name}; 150 } 151 152 return 0; 153} 154 155# external XS modules only 156sub scanxs { 157 my $start = shift; 158 my $prefix = shift; 159 my $debug = shift; 160 $prefix = '' unless defined $prefix; 161 my %IO = (IO::File:: => 1, 162 IO::Handle:: => 1, 163 IO::Socket:: => 1, 164 IO::Seekable:: => 1, 165 IO::Poll:: => 1); 166 my @return; 167 foreach my $key ( grep /::$/, keys %{$start} ) { 168 my $name = $prefix . $key; 169 print $name,"\n" if $debug; 170 $name = "IO" if $IO{$name}; 171 unless ( $start eq ${$start}{$key} or omit($name) ) { 172 push @return, $name if has_xs($name, $debug) and $name ne "version::"; 173 foreach my $subscan ( scanxs( ${$start}{$key}, $name, $debug ) ) { 174 my $subname = $key.$subscan; 175 print $subname,"\n" if $debug; 176 # there are more interesting version subpackages 177 push @return, $subname if !omit($subname) and has_xs($subname, $debug) 178 and $name ne "version::"; 179 } 180 } 181 } 182 return @return; 183} 184 185sub has_xs { 186 my $name = shift; 187 my $debug = shift; 188 foreach my $key ( keys %{$name} ) { 189 my $cvname = $name . $key; 190 if (CvIsXSUB($cvname)) { 191 print "has_xs: &",$cvname," -> 1\n" if $debug; 192 return 0 if in_static_core(substr($name,0,-2), $key); 193 return 1; 194 } 195 } 196 return 0; 197} 198 199# Keep in sync with B::C 200# XS in CORE which do not need to be bootstrapped extra. 201# There are some specials like mro,re,UNIVERSAL. 202sub in_static_core { 203 my ($stashname, $cvname) = @_; 204 if ($stashname eq 'UNIVERSAL') { 205 return $cvname =~ /^(isa|can|DOES|VERSION)$/; 206 } 207 return 1 if $static_core_pkg{$stashname}; 208 if ($stashname eq 'mro') { 209 return $cvname eq 'method_changed_in'; 210 } 211 if ($stashname eq 're') { 212 return $cvname =~ /^(is_regexp|regname|regnames_count|regexp_pattern)$/;; 213 } 214 if ($stashname eq 'PerlIO') { 215 return $cvname eq 'get_layers'; 216 } 217 if ($stashname eq 'PerlIO::Layer') { 218 return $cvname =~ /^(find|NoWarnings)$/; 219 } 220 return 0; 221} 222 223# Keep in sync with B::C 224# XS modules in CORE. Reserved namespaces. 225# Note: mro,re,UNIVERSAL have both, static core and dynamic/static XS. 226# version has an external ::vxs 227sub static_core_packages { 228 my @pkg = qw(Internals utf8 UNIVERSAL); 229 push @pkg, qw(Tie::Hash::NamedCapture) if $] >= 5.010; 230 push @pkg, qw(DynaLoader) if $Config{usedl}; 231 # Win32CORE only in official cygwin pkg. And it needs to be bootstrapped, 232 # handled by static_ext. 233 push @pkg, qw(Cygwin) if $^O eq 'cygwin'; 234 push @pkg, qw(NetWare) if $^O eq 'NetWare'; 235 push @pkg, qw(OS2) if $^O eq 'os2'; 236 push @pkg, qw(VMS VMS::Filespec vmsish) if $^O eq 'VMS'; 237 #push @pkg, qw(PerlIO) if $] >= 5.008006; # get_layers only 238 return @pkg; 239} 240 2411; 242 243__END__ 244 245=head1 AUTHOR 246 247Vishal Bhatia <vishalb@hotmail.com> I(1999), 248Reini Urban C<perl-compiler@googlegroups.com> I(2011) 249 250=head1 SEE ALSO 251 252L<B::C> has a superior two-pass stash scanner. 253 254=cut 255 256# Local Variables: 257# mode: cperl 258# cperl-indent-level: 2 259# fill-column: 100 260# End: 261# vim: expandtab shiftwidth=2: 262