1package Test2::Util::Stash;
2use strict;
3use warnings;
4
5our $VERSION = '0.000162';
6
7use Carp qw/croak/;
8use B;
9
10our @EXPORT_OK = qw{
11    get_stash
12    get_glob
13    get_symbol
14    parse_symbol
15    purge_symbol
16    slot_to_sig sig_to_slot
17};
18use base 'Exporter';
19
20my %SIGMAP = (
21    '&' => 'CODE',
22    '$' => 'SCALAR',
23    '%' => 'HASH',
24    '@' => 'ARRAY',
25);
26
27my %SLOTMAP = reverse %SIGMAP;
28
29sub slot_to_sig { $SLOTMAP{$_[0]} || croak "unsupported slot: '$_[0]'" }
30sub sig_to_slot { $SIGMAP{$_[0]}  || croak "unsupported sigil: $_[0]"  }
31
32sub get_stash {
33    my $package = shift || caller;
34    no strict 'refs';
35    return \%{"${package}\::"};
36}
37
38sub get_glob {
39    my $sym = _parse_symbol(scalar(caller), @_);
40    no strict 'refs';
41    no warnings 'once';
42    return \*{"$sym->{package}\::$sym->{name}"};
43}
44
45sub parse_symbol { _parse_symbol(scalar(caller), @_) }
46
47sub _parse_symbol {
48    my ($caller, $symbol, $package) = @_;
49
50    if (ref($symbol)) {
51        my $pkg = $symbol->{package};
52
53        croak "Symbol package ($pkg) and package argument ($package) do not match"
54            if $pkg && $package && $pkg ne $package;
55
56        $symbol->{package} ||= $caller;
57
58        return $symbol;
59    }
60
61    utf8::downgrade($symbol) if $] == 5.010000; # prevent crash on 5.10.0
62    my ($sig, $pkg, $name) = ($symbol =~ m/^(\W?)(.*::)?([^:]+)$/)
63        or croak "Invalid symbol: '$symbol'";
64
65    # Normalize package, '::' becomes 'main', 'Foo::' becomes 'Foo'
66    $pkg = $pkg
67        ? $pkg eq '::'
68            ? 'main'
69            : substr($pkg, 0, -2)
70        : undef;
71
72    croak "Symbol package ($pkg) and package argument ($package) do not match"
73        if $pkg && $package && $pkg ne $package;
74
75    $sig ||= '&';
76    my $type = $SIGMAP{$sig} || croak "unsupported sigil: '$sig'";
77
78    my $real_package = $package || $pkg || $caller;
79
80    return {
81        name    => $name,
82        sigil   => $sig,
83        type    => $type,
84        symbol  => "${sig}${real_package}::${name}",
85        package => $real_package,
86    };
87}
88
89sub get_symbol {
90    my $sym = _parse_symbol(scalar(caller), @_);
91
92    my $name    = $sym->{name};
93    my $type    = $sym->{type};
94    my $package = $sym->{package};
95    my $symbol  = $sym->{symbol};
96
97    my $stash = get_stash($package);
98    return undef unless exists $stash->{$name};
99
100    my $glob = get_glob($sym);
101    return *{$glob}{$type} if $type ne 'SCALAR' && defined(*{$glob}{$type});
102
103    if ($] < 5.010) {
104        return undef unless defined(*{$glob}{$type});
105
106        {
107            local ($@, $!);
108            local $SIG{__WARN__} = sub { 1 };
109            return *{$glob}{$type} if eval "package $package; my \$y = $symbol; 1";
110        }
111
112        return undef unless defined *{$glob}{$type};
113        return *{$glob}{$type} if defined ${*{$glob}{$type}};
114        return undef;
115    }
116
117    my $sv = B::svref_2object($glob)->SV;
118    return *{$glob}{$type} if $sv->isa('B::SV');
119    return undef unless $sv->isa('B::SPECIAL');
120    return *{$glob}{$type} if $B::specialsv_name[$$sv] ne 'Nullsv';
121    return undef;
122}
123
124sub purge_symbol {
125    my $sym = _parse_symbol(scalar(caller), @_);
126
127    local *GLOBCLONE = *{get_glob($sym)};
128    delete get_stash($sym->{package})->{$sym->{name}};
129    my $new_glob = get_glob($sym);
130
131    for my $type (qw/CODE SCALAR HASH ARRAY FORMAT IO/) {
132        next if $type eq $sym->{type};
133        my $ref = get_symbol({type => $type, name => 'GLOBCLONE', sigil => $SLOTMAP{$type}}, __PACKAGE__);
134        next unless $ref;
135        *$new_glob = $ref;
136    }
137
138    return *GLOBCLONE{$sym->{type}};
139}
140
1411;
142
143__END__
144
145
146=pod
147
148=encoding UTF-8
149
150=head1 NAME
151
152Test2::Util::Stash - Utilities for manipulating stashes and globs.
153
154=head1 DESCRIPTION
155
156This is a collection of utilities for manipulating and inspecting package
157stashes and globs.
158
159=head1 EXPORTS
160
161=over 4
162
163=item $stash = get_stash($package)
164
165Gets the package stash. This is the same as C<$stash = \%Package::Name::>.
166
167=item $sym_spec = parse_symbol($symbol)
168
169=item $sym_spec = parse_symbol($symbol, $package)
170
171Parse a symbol name, and return a hashref with info about the symbol.
172
173C<$symbol> can be a simple name, or a fully qualified symbol name. The sigil is
174optional, and C<&> is assumed if none is provided. If C<$symbol> is fully qualified,
175and C<$package> is also provided, then the package of the symbol must match the
176C<$package>.
177
178Returns a structure like this:
179
180    return {
181        name    => 'BAZ',
182        sigil   => '$',
183        type    => 'SCALAR',
184        symbol  => '&Foo::Bar::BAZ',
185        package => 'Foo::Bar',
186    };
187
188=item $glob_ref = get_glob($symbol)
189
190=item $glob_ref = get_glob($symbol, $package)
191
192Get a glob ref. Arguments are the same as for C<parse_symbol>.
193
194=item $ref = get_symbol($symbol)
195
196=item $ref = get_symbol($symbol, $package)
197
198Get a reference to the symbol. Arguments are the same as for C<parse_symbol>.
199
200=item $ref = purge_symbol($symbol)
201
202=item $ref = purge_symbol($symbol, $package)
203
204Completely remove the symbol from the package symbol table. Arguments are the
205same as for C<parse_symbol>. A reference to the removed symbol is returned.
206
207=item $sig = slot_to_sig($slot)
208
209Convert a slot (like 'SCALAR') to a sigil (like '$').
210
211=item $slot = sig_to_slot($sig)
212
213Convert a sigil (like '$') to a slot (like 'SCALAR').
214
215=back
216
217=head1 SOURCE
218
219The source code repository for Test2-Suite can be found at
220F<https://github.com/Test-More/Test2-Suite/>.
221
222=head1 MAINTAINERS
223
224=over 4
225
226=item Chad Granum E<lt>exodist@cpan.orgE<gt>
227
228=back
229
230=head1 AUTHORS
231
232=over 4
233
234=item Chad Granum E<lt>exodist@cpan.orgE<gt>
235
236=back
237
238=head1 COPYRIGHT
239
240Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
241
242This program is free software; you can redistribute it and/or
243modify it under the same terms as Perl itself.
244
245See F<http://dev.perl.org/licenses/>
246
247=cut
248