File Coverage

blib/lib/Symbol/Get.pm
Criterion Covered Total %
statement 48 60 80.0
branch 9 20 45.0
condition 5 11 45.4
subroutine 9 11 81.8
pod 0 3 0.0
total 71 105 67.6


line stmt bran cond sub pod time code
1             package Symbol::Get;
2              
3 2     2   156860 use strict;
  2         15  
  2         61  
4 2     2   11 use warnings;
  2         4  
  2         51  
5              
6 2     2   575 use Call::Context ();
  2         532  
  2         91  
7              
8             our $VERSION = 0.08;
9              
10             =encoding utf-8
11              
12             =head1 NAME
13              
14             Symbol::Get - Read Perl’s symbol table programmatically
15              
16             =head1 SYNOPSIS
17              
18             package Foo;
19              
20             our $name = 'haha';
21             our @list = ( 1, 2, 3 );
22             our %hash = ( foo => 1, bar => 2 );
23              
24             use constant my_const => 'haha';
25              
26             use constant my_const_list => qw( a b c );
27              
28             sub doit { ... }
29              
30             my $name_sr = Symbol::Get::get('$Foo::name'); # \$name
31             my $list_ar = Symbol::Get::get('@Foo::list'); # \@list
32             my $hash_hr = Symbol::Get::get('%Foo::hash'); $ \%hash
33              
34             #Defaults to __PACKAGE__ if none is given:
35             my $doit_cr = Symbol::Get::get('&doit');
36              
37             #Constants:
38             my $const_val = Symbol::Get::copy_constant('Foo::my_const');
39             my @const_list = Symbol::Get::copy_constant('Foo::my_const_list');
40              
41             #The below return the same results since get_names() defaults
42             #to the current package if none is given.
43             my @names = Symbol::Get::get_names('Foo'); # keys %Foo::
44             my @names = Symbol::Get::get_names();
45              
46             =head1 DESCRIPTION
47              
48             Occasionally I have need to reference a variable programmatically.
49             This module facilitates that by providing an easy, syntactic-sugar-y,
50             read-only interface to the symbol table.
51              
52             The SYNOPSIS above should pretty well cover usage.
53              
54             =head1 ABOUT PERL CONSTANTS
55              
56             Previous versions of this module endorsed constructions like:
57              
58             my $const_sr = Symbol::Get::get('Foo::my_const');
59             my $const_ar = Symbol::Get::get('Foo::my_const_list');
60              
61             … to read constants from the symbol table. This isn’t reliable across
62             Perl versions, though, so don’t do it; instead, use C.
63              
64             =head1 SEE ALSO
65              
66             =over 4
67              
68             =item * L
69              
70             =back
71              
72             =head1 LICENSE
73              
74             This module is licensed under the same license as Perl.
75              
76             =cut
77              
78 2     2   11 use constant MIN_LIST_CONSTANT_PERL_VERSION => v5.20.0;
  2         4  
  2         1472  
79              
80             my %_sigil_to_type = qw(
81             $ SCALAR
82             @ ARRAY
83             % HASH
84             & CODE
85             );
86              
87             my $sigils_re_txt = join('|', keys %_sigil_to_type);
88              
89             sub get {
90 10     10 0 1554 my ($var) = @_;
91              
92 10 50       49 die 'Need a variable or constant name!' if !length $var;
93              
94 10         37 my $sigil = substr($var, 0, 1);
95              
96 10 50       51 goto \&_get_constant if $sigil =~ tr<>;
97              
98 10 50       51 my $type = $_sigil_to_type{$sigil} or die "Unrecognized sigil: “$sigil”";
99              
100 10         55 my $table_hr = _get_table_hr( substr($var, 1) );
101 10   100     72 return $table_hr && *{$table_hr}{$type};
102             }
103              
104             sub copy_constant {
105 5     5 0 26698 my ($var) = @_;
106              
107 5         21 my $ref = _get_table_hr($var);
108              
109 5         15 my @value;
110              
111 5 50       28 if ('SCALAR' eq ref $ref) {
    50          
112 0         0 @value = ($$ref);
113             }
114             elsif ('ARRAY' eq ref $ref) {
115 0         0 @value = @$ref;
116             }
117             else {
118 5         11 @value = *{$ref}{'CODE'}->();
  5         38  
119             }
120              
121 5 100       26 if (@value > 1) {
122 4         25 Call::Context::must_be_list();
123 2         93 return @value;
124             }
125              
126 1         9 return $value[0];
127             }
128              
129             #Referenced in tests.
130 0     0   0 sub _perl_supports_getting_list_constant_ref { return $^V ge MIN_LIST_CONSTANT_PERL_VERSION() }
131              
132             sub _get_constant {
133 0     0   0 my ($var) = @_;
134              
135 0         0 my $ref = _get_table_hr($var);
136              
137 0 0 0     0 if ('SCALAR' ne ref($ref) && 'ARRAY' ne ref($ref)) {
138 0         0 my $msg = "$var is a regular symbol table entry, not a constant.";
139              
140 0 0       0 if ( !_perl_supports_getting_list_constant_ref() ) {
141 0         0 $msg .= " Your Perl version ($^V) stores list constants in the symbol table as CODE references rather than ARRAYs; maybe that’s the issue?";
142             }
143              
144 0         0 die $msg;
145             }
146              
147 0         0 return $ref;
148             }
149              
150             sub get_names {
151 1     1 0 4 my ($module) = @_;
152              
153 1   33     13 $module ||= (caller 0)[0];
154              
155 1         39 Call::Context::must_be_list();
156              
157 1         32 my $table_hr = _get_module_table_hr($module);
158              
159 1 50       7 die "Unknown namespace: “$module”" if !$table_hr;
160              
161 1         62 return keys %$table_hr;
162             }
163              
164             #----------------------------------------------------------------------
165             # To be completed if needed:
166             #
167             #sub list_sigils {
168             # my ($full_name) = @_;
169             #
170             # Call::Context::must_be_list();
171             #
172             # my ($module, $name) = ($full_name =~ m<(?:(.+)::)?(.+)>);
173             #
174             # my $table_hr = _get_table_for_module_name($module);
175             # my $glob = *{$table_hr};
176             #
177             # return
178             #}
179             #
180              
181              
182             #----------------------------------------------------------------------
183              
184             sub _get_module_table_hr {
185 16     16   43 my ($module) = @_;
186              
187 16         91 my @nodes = split m<::>, $module;
188              
189 16         56 my $table_hr = \%main::;
190              
191 16         42 my $pkg = q<>;
192              
193 16         57 for my $n (@nodes) {
194 47         199 $table_hr = $table_hr->{"$n\::"};
195 47         131 $pkg .= "$n\::";
196             }
197              
198 16         69 return $table_hr;
199             }
200              
201             sub _get_table_hr {
202 15     15   65 my ($name) = @_;
203              
204 15 50       188 $name =~ m<\A (?: (.+) ::)? ([^:]+ (?: ::)?) \z>x or do {
205 0         0 die "Invalid variable name: “$name”";
206             };
207              
208 15   66     117 my $module = $1 || (caller 1)[0];
209              
210 15         316 my $table_hr = _get_module_table_hr($module);
211              
212 15         130 return $table_hr->{$2};
213             }
214              
215             1;