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