line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
1
|
|
|
1
|
|
618
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
23
|
|
2
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
43
|
|
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
package String::Interpolate; |
5
|
|
|
|
|
|
|
our $VERSION = 0.3; |
6
|
1
|
|
|
1
|
|
4
|
use Carp qw( croak ); |
|
1
|
|
|
|
|
9
|
|
|
1
|
|
|
|
|
73
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
=head1 NAME |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
String::Interpolate - Wrapper for builtin the Perl interpolation engine. |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 SYNOPSIS |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
# Functional interface |
15
|
|
|
|
|
|
|
use String::Interpolate qw( safe_interpolate interpolate ); |
16
|
|
|
|
|
|
|
our($GREET) = 'Hello'; # Cannot be lexical |
17
|
|
|
|
|
|
|
print interpolate( '$GREET $1\n', [ 'world' ] ); |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# Object interface |
20
|
|
|
|
|
|
|
use String::Interpolate; |
21
|
|
|
|
|
|
|
my $who; |
22
|
|
|
|
|
|
|
my $template = new String::Interpolate { WHO => \$who }; |
23
|
|
|
|
|
|
|
$template->{TIME} = sub () { localtime }; # Tie $TIME to localtime() |
24
|
|
|
|
|
|
|
$template->( [ qw( now it ) ] ); # Set $1, $2 |
25
|
|
|
|
|
|
|
$template->[3] = 'is'; # Sets $3 |
26
|
|
|
|
|
|
|
$who = 'old friend'; |
27
|
|
|
|
|
|
|
$template->( '$REV{olleH} $WHO, $2 $3 $1 $TIME$_' ); # Set string to process |
28
|
|
|
|
|
|
|
$template->{REV} = sub { reverse @_ }; # Tie %REV to reverse() |
29
|
|
|
|
|
|
|
$_ = '.'; |
30
|
|
|
|
|
|
|
print "$template\n"; # Perform interpolation |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# Peform the interpolation in a Safe compartment. |
33
|
|
|
|
|
|
|
my $replace = safe String::Interpolate '\u\L$1'; |
34
|
|
|
|
|
|
|
my $search = qr/(\w+)/; |
35
|
|
|
|
|
|
|
$_ = "HELLO world\n"; |
36
|
|
|
|
|
|
|
s/$search/$replace/eg; # /e supresses optimisation |
37
|
|
|
|
|
|
|
print; |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
=head1 DESCRIPTION |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
C provides a neat interface to the solution to |
42
|
|
|
|
|
|
|
that perenial Perl problem - how to invoke the Perl string |
43
|
|
|
|
|
|
|
interpolation engine on a string contained in a scalar variable. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
A C object encapsulates a string and a context in |
46
|
|
|
|
|
|
|
which it should be subjected to Perl interpolation. In the |
47
|
|
|
|
|
|
|
simplest, default, case the context is simply the namespace (package) |
48
|
|
|
|
|
|
|
from which the constructor was called. |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
A C object may hold a reference to an array and |
51
|
|
|
|
|
|
|
hashes that will be used to populate the special variables $1 etc and |
52
|
|
|
|
|
|
|
some package variables respectively prior to each interpolation. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
In general special globally global variables such as $_ can be used in |
55
|
|
|
|
|
|
|
the interpolation, the exception being @_ which is always empty during |
56
|
|
|
|
|
|
|
the interpolation. |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
The interpolated string is processed with strictures and warnings |
59
|
|
|
|
|
|
|
enabled excluding 'strict vars' and 'warnings uninitialized' so that |
60
|
|
|
|
|
|
|
interpolating undefined variables will be silently ignored. This |
61
|
|
|
|
|
|
|
behaviour can be altered using the pragma() method. |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
Because the Perl string interpolation engine can call arbitrary Perl |
64
|
|
|
|
|
|
|
code you do not want to want to use it on strings from untrusted |
65
|
|
|
|
|
|
|
sources without some precautions. For this reason |
66
|
|
|
|
|
|
|
C objects can be made to use C |
67
|
|
|
|
|
|
|
compartments. This is, of course, only as safe as Safe and you are |
68
|
|
|
|
|
|
|
advised to read "WARNING" section of the Safe documentation. |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
When interpolating in a Safe compartment package symbols are imported |
71
|
|
|
|
|
|
|
using tied wrapper variables so that their values cannot be |
72
|
|
|
|
|
|
|
interpreted as references and such that they cannot be used to alter |
73
|
|
|
|
|
|
|
the values outside the compartment. This behaviour can be suppressed |
74
|
|
|
|
|
|
|
by the unsafe_symbols() method. Note that if you want to import tied |
75
|
|
|
|
|
|
|
variable or variables containing references to objects that use |
76
|
|
|
|
|
|
|
overloading into a Safe compartment then you will need to do a lot of |
77
|
|
|
|
|
|
|
fancy footwork unless you use safe_hole() method. |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
By default *_ is shared by Safe compartments and could potentially |
80
|
|
|
|
|
|
|
allow the compartment to leak. The $_ and %_ variables are therefore |
81
|
|
|
|
|
|
|
subjected to the same similar precautions to imported symbols. This |
82
|
|
|
|
|
|
|
behaviour can be suppressed using the unsafe_underscore() method. |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
Perl string interpolation can, of course, throw exceptions. By |
85
|
|
|
|
|
|
|
default String::Interpolate objects do not catch (or rethrow) these |
86
|
|
|
|
|
|
|
exceptions when working in a simple namespace and do trap them when |
87
|
|
|
|
|
|
|
working in a Safe compartment. This behaviour can be overriden by the |
88
|
|
|
|
|
|
|
trap() or pragma() methods. If an exception during interpolation is |
89
|
|
|
|
|
|
|
trapped then undef will be returned as the result of the |
90
|
|
|
|
|
|
|
interpolation and $@ will hold the exception in the usual way. |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
When taint checking enabled, attempting to perform interpolation |
93
|
|
|
|
|
|
|
(using eval()) on a tainted string would naturally fail. However, |
94
|
|
|
|
|
|
|
when using a Safe compartment, String::Interpolate will strip the |
95
|
|
|
|
|
|
|
tainting off of the string prior to interpolation and put it back |
96
|
|
|
|
|
|
|
afterwards. Also String::Interpolate will taint any arguments |
97
|
|
|
|
|
|
|
passed to callback functions called as the result of performing |
98
|
|
|
|
|
|
|
interpolation on a tainted string. Note that due to the mechanism |
99
|
|
|
|
|
|
|
used to assign $1 et al they can never be tained even if the values in |
100
|
|
|
|
|
|
|
the array being used to set them are tainted. |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
By default C does not export any subroutines but |
103
|
|
|
|
|
|
|
as a concession to programmers who prefer not to explicitly use |
104
|
|
|
|
|
|
|
objects the functions interpolate() and safe_interpolate() are |
105
|
|
|
|
|
|
|
exportable. |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
=cut |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# Must appear before any file-scoped lexicals |
110
|
1
|
|
|
1
|
0
|
4
|
sub reval { no strict 'vars'; eval $_[0] } |
|
1
|
|
|
1
|
|
1
|
|
|
1
|
|
|
1
|
|
51
|
|
|
1
|
|
|
2
|
|
21
|
|
|
1
|
|
|
|
|
143
|
|
|
1
|
|
|
|
|
12
|
|
|
1
|
|
|
|
|
104
|
|
|
2
|
|
|
|
|
210
|
|
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
sub prevent_blessed_error_hack () { |
113
|
0
|
0
|
|
0
|
0
|
0
|
return unless ref $@; |
114
|
1
|
|
|
1
|
|
4
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
23
|
|
115
|
1
|
|
|
1
|
|
4
|
no warnings 'redefine'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
257
|
|
116
|
0
|
|
|
0
|
|
0
|
local *{"@{[ref $@]}::DESTROY"} = sub {}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
117
|
0
|
|
|
|
|
0
|
$@ = 'Blessed error from Safe compartment'; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
# During Carp::confess stack dumps we don't want to exec() |
121
|
|
|
|
|
|
|
# %dbgpkg is a package variable as callers may want to manipulate it. |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
our %dbgpkg = ( |
124
|
|
|
|
|
|
|
Carp => 1, |
125
|
|
|
|
|
|
|
); |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
our $taint_flag = ''; |
128
|
|
|
|
|
|
|
our $safe_hole; |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
my %type_from_prefix = ( |
131
|
|
|
|
|
|
|
"\$" => 'SCALAR', |
132
|
|
|
|
|
|
|
'@' => 'ARRAY', |
133
|
|
|
|
|
|
|
'%' => 'HASH', |
134
|
|
|
|
|
|
|
); |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
use overload |
137
|
|
|
|
|
|
|
'""' => sub { |
138
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
139
|
0
|
0
|
|
|
|
0
|
$dbgpkg{caller()} ? overload::StrVal($self) : $self->exec; |
140
|
|
|
|
|
|
|
}, |
141
|
0
|
|
|
0
|
|
0
|
'cmp' => sub { my ($l,$r) = @_; $l->exec cmp $r }, |
|
0
|
|
|
|
|
0
|
|
142
|
1
|
|
|
1
|
|
11
|
'@{}' => sub { tie my @a, 'String::Interpolate::AsArray', @_; \@a }, |
|
1
|
|
|
|
|
8
|
|
143
|
|
|
|
|
|
|
'%{}' => 'ashash', |
144
|
1
|
|
|
1
|
|
1511
|
'&{}' => sub { my $self=shift; sub { $self->exec(@_) } }; |
|
1
|
|
|
2
|
|
900
|
|
|
1
|
|
|
|
|
11
|
|
|
2
|
|
|
|
|
85
|
|
|
2
|
|
|
|
|
16
|
|
|
2
|
|
|
|
|
7
|
|
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
|
147
|
1
|
|
|
1
|
|
77
|
use base 'Exporter'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
807
|
|
148
|
|
|
|
|
|
|
our(@EXPORT_OK) = qw ( interpolate safe_interpolate ); |
149
|
|
|
|
|
|
|
my $pkgcount; |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
=head2 Principle methods |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
=over 4 |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
=item new |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
Simple constructor. Creates a empty String::Interpolate object bound |
158
|
|
|
|
|
|
|
to the caller's namespace and then modifies the object by passing any |
159
|
|
|
|
|
|
|
arguments to the exec() method. Returns a the object. |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
If called as an instance method new() clones the object. Be aware, |
162
|
|
|
|
|
|
|
however, that this is a shallow cloning and if array or hash reference |
163
|
|
|
|
|
|
|
arguments have been passed to the object the parent and clone will |
164
|
|
|
|
|
|
|
continue to use the same array or hashes until one or other is passed |
165
|
|
|
|
|
|
|
a new argument. |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
Most of the other methods in String::Interpolate will implicitly call |
168
|
|
|
|
|
|
|
new() if called as class methods. |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
=cut |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
my %preset_pragma = ( |
173
|
|
|
|
|
|
|
NOWARN => 'unimport warnings qw(uninitialized)', |
174
|
|
|
|
|
|
|
WARN => '', |
175
|
|
|
|
|
|
|
FATAL => 'import warnings FATAL => qw(uninitialized); import strict qw(vars)', |
176
|
|
|
|
|
|
|
); |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
sub new { |
179
|
1
|
|
|
1
|
1
|
21
|
my $class = shift; |
180
|
1
|
|
|
|
|
2
|
my $self; |
181
|
1
|
50
|
|
|
|
5
|
if ( ref $class ) { |
182
|
|
|
|
|
|
|
# Clone |
183
|
0
|
|
|
|
|
0
|
$self = bless \ { %$$class }, ref $class; |
184
|
0
|
0
|
|
|
|
0
|
delete @$$self{'tmppkg','pkg','code'} if $$self->{tmppkg}; |
185
|
0
|
0
|
|
|
|
0
|
delete $$self->{safe} if $$self->{implicit_safe}; |
186
|
|
|
|
|
|
|
} else { |
187
|
1
|
|
|
|
|
2
|
my $calldepth = 0; |
188
|
1
|
|
|
|
|
3
|
my $defpgk; |
189
|
1
|
|
|
|
|
1
|
do { $defpgk = caller($calldepth++) } while $defpgk->isa( __PACKAGE__ ); |
|
1
|
|
|
|
|
19
|
|
190
|
1
|
|
|
|
|
9
|
$self = bless \ { |
191
|
|
|
|
|
|
|
defpgk => $defpgk, |
192
|
|
|
|
|
|
|
pkg => $defpgk, |
193
|
|
|
|
|
|
|
pragmas => $preset_pragma{NOWARN}, |
194
|
|
|
|
|
|
|
}, $class; |
195
|
|
|
|
|
|
|
} |
196
|
1
|
|
|
|
|
7
|
$self->exec(@_); |
197
|
1
|
|
|
|
|
2
|
$self; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
=item safe |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
Alternative constuctor to create a String::Interpolate object that |
203
|
|
|
|
|
|
|
uses an automatically allocated temporary Safe compartment. The |
204
|
|
|
|
|
|
|
automatically allocated Safe compartment will have the default opcode |
205
|
|
|
|
|
|
|
mask but with the 'bless' opcode denied as this can be used to execute |
206
|
|
|
|
|
|
|
code outside the compartment by putting it in DESTROY methods. The |
207
|
|
|
|
|
|
|
'tie' opcode is also denied although I'm not sure if it really can be |
208
|
|
|
|
|
|
|
exploited in this way. There is no point explicitly passing a package |
209
|
|
|
|
|
|
|
or existing safe compartment to this constructor as it will be ignored. |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
The argument list is passed to exec() as in new(). |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
The safe() method can also be called on an existing object in which |
214
|
|
|
|
|
|
|
case it instructs the object to forget its current Safe compartment or |
215
|
|
|
|
|
|
|
namespace and use an automatically allocated temporary Safe |
216
|
|
|
|
|
|
|
compartment henceforth. |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
=cut |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
sub safe { |
221
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
222
|
0
|
0
|
|
|
|
0
|
$self = $self->new(@_) unless ref $self; |
223
|
0
|
|
|
|
|
0
|
$self->free_tmppkg; |
224
|
0
|
|
|
|
|
0
|
delete @$$self{'pkg','explicit_pkg','safe'}; |
225
|
0
|
|
|
|
|
0
|
$$self->{implicit_safe}++; |
226
|
0
|
|
|
|
|
0
|
require Safe; |
227
|
0
|
|
|
|
|
0
|
$self; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
=item exec |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
This it the guts of the implementation but it it rarely needs to be |
233
|
|
|
|
|
|
|
called explicitly as it can be more elegantly called implicitly by |
234
|
|
|
|
|
|
|
using the String::Interpolate object in a string or CODE reference |
235
|
|
|
|
|
|
|
context. The following are equivalent pairs: |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
my $interpolated_string = $interpolate_object->exec; |
238
|
|
|
|
|
|
|
my $interpolated_string = "$interpolate_object"; |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
my $interpolated_string = $interpolate_object->exec(LIST); |
241
|
|
|
|
|
|
|
my $interpolated_string = $interpolate_object->(LIST); |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
The exec() method modifies the object according the argument list. |
244
|
|
|
|
|
|
|
Then, if called in a non-void context, returns the result of the |
245
|
|
|
|
|
|
|
interpolation. Note that the modifications are persistent. This |
246
|
|
|
|
|
|
|
persistence can be avoided by creating a transient clone using the |
247
|
|
|
|
|
|
|
new() method. |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
my $string = $inter->(LIST); # $inter changed |
250
|
|
|
|
|
|
|
my $string = $inter->new->(LIST); # $inter unchanged |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
Also, if exec() is called as a class method then it acts on a |
253
|
|
|
|
|
|
|
temporary String::Interpolate object which is immediately destroyed. |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
The elements of the argument list are interpreted according to their |
256
|
|
|
|
|
|
|
type as listed below. If this mechanism does not provide sufficient |
257
|
|
|
|
|
|
|
flexibility in manipulating the symbol table you can, of course, |
258
|
|
|
|
|
|
|
manipulate it directly too. |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
=over 4 |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
=item ARRAY reference |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
Tells the object to use this array to populate the special variables |
265
|
|
|
|
|
|
|
$1 and so on. The object holds a reference to the array itself and |
266
|
|
|
|
|
|
|
will use the values that are in the array at the time of |
267
|
|
|
|
|
|
|
interpolation. This ARRAY reference is exposed via the positionals() |
268
|
|
|
|
|
|
|
method. The array can also be modified by using the |
269
|
|
|
|
|
|
|
String::Interpolate object in an ARRAY reference context. Note, |
270
|
|
|
|
|
|
|
however, that the String::Interpolate object used in an ARRAY |
271
|
|
|
|
|
|
|
reference context does not refer to the array itself but to a |
272
|
|
|
|
|
|
|
STORE-only tied array whose subscripts are offset by one such that |
273
|
|
|
|
|
|
|
$interpolate_object->[1] corresponds to |
274
|
|
|
|
|
|
|
$interpolate_object->positionals->[0] and hence the value that will be |
275
|
|
|
|
|
|
|
interpolated for $1. |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
=item HASH reference |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
Tells the object to use this hash to populate some package variables |
280
|
|
|
|
|
|
|
immediately prior to each interpolation. The object holds a reference |
281
|
|
|
|
|
|
|
to the hash itself and will use the values that are in the hash at the |
282
|
|
|
|
|
|
|
time of interpolation. |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
After the object has been instructed to populate package variables in |
285
|
|
|
|
|
|
|
this way it will no longer default to using the namespace from which |
286
|
|
|
|
|
|
|
the constructor was called and will instead auto-allocate a temporary |
287
|
|
|
|
|
|
|
one unless told to do otherwise. |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
If multiple hash reference arguments are specified in a single call to |
290
|
|
|
|
|
|
|
exec() then each hash in turn will be processed prior to each |
291
|
|
|
|
|
|
|
interpolation. However, whenever a exec() is passed one or more hash |
292
|
|
|
|
|
|
|
references it forgets any previous hashes and deletes any |
293
|
|
|
|
|
|
|
auto-allocated temporary package or safe compartment. |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
The keys of the hash should be unqualified Perl identifiers that will |
296
|
|
|
|
|
|
|
determine the entries in the package symbol to be modified. Which slot |
297
|
|
|
|
|
|
|
in the symbol table entry is modified is determined by the values' |
298
|
|
|
|
|
|
|
types as follows: |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
=over 4 |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
=item ARRAY reference |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
Set the symbol table entry's ARRAY slot. |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
=item HASH reference |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
Set the symbol table entry's HASH slot. |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
=item SCALAR reference |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
Set the symbol table entry's SCALAR slot. |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
=item CODE reference with prototype () |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
Set the symbol table entry's SCALAR slot to point to an new tied |
317
|
|
|
|
|
|
|
scalar with a FETCH method that calls the referenced code. |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
Note that if interpolation is taking place inside a Safe compartment |
320
|
|
|
|
|
|
|
the callback will, by default, simply be called from within the |
321
|
|
|
|
|
|
|
compartment. The callback code will execute with a false symbol table |
322
|
|
|
|
|
|
|
root so it will not be able to use any packages from the real symbol |
323
|
|
|
|
|
|
|
table root. This limitation can be overcome by using the safe_hole() |
324
|
|
|
|
|
|
|
method. |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
=item CODE reference with prototype ($) or no prototype |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
Set the symbol table entry's HASH slot to point to an new tied |
329
|
|
|
|
|
|
|
hash with a FETCH method that calls the referenced code. |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
See above for limitations if the callback is called from interpolation |
332
|
|
|
|
|
|
|
taking place in a Safe compartment. |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
The argument passed to the callback will be stringified. It may seem |
335
|
|
|
|
|
|
|
like a nice idea to be able to pass multiple arguments using an ARRAY |
336
|
|
|
|
|
|
|
reference but unfortunately this could open up security problems when |
337
|
|
|
|
|
|
|
passing arguments out of a Safe compartment via a Safe::Hole. |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
=item Anything else |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
Set the symbol table entry's SCALAR slot to point |
342
|
|
|
|
|
|
|
scalar containing the value. |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
=back |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
Note that since the String::Interpolate object stores a reference to |
347
|
|
|
|
|
|
|
the hash and updates the symbol table prior to each interpolation, |
348
|
|
|
|
|
|
|
changes in the hash will be reflected in subsequent interpolations. |
349
|
|
|
|
|
|
|
However, if items in the hash are deleted or changed to a different |
350
|
|
|
|
|
|
|
type then the previously created symbol table entries may persist. |
351
|
|
|
|
|
|
|
This can be overcome by calling the safe() or package() methods. |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
To simplify modifying the hash, a String::Interpolated object used in |
354
|
|
|
|
|
|
|
a HASH reference context will return a reference to the last hash |
355
|
|
|
|
|
|
|
argument passed to object, implicitly calling exec({}) first if |
356
|
|
|
|
|
|
|
necessary. |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
my %h = ( A => 1 ); |
359
|
|
|
|
|
|
|
my $i = new String::Interpolate \%h; |
360
|
|
|
|
|
|
|
$i->{B} = 2; # $h{B} = 2 |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
=item GLOB or GLOB reference |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
Instruct the object to perform interpolation in the namespace defined |
365
|
|
|
|
|
|
|
by the GLOB. For example the argument *Q:: would mean that the string |
366
|
|
|
|
|
|
|
should be interpolated in the context of the package Q. The trailing |
367
|
|
|
|
|
|
|
'::' may be omitted. |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
Passing a package argument to the object causes it to stop using a |
370
|
|
|
|
|
|
|
Safe compartment if it previously was doing so. If you want safe |
371
|
|
|
|
|
|
|
execution in a specific namespace then you need to explicitly constuct |
372
|
|
|
|
|
|
|
Safe object bound to the given namespace and pass that. |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
Once a String::Interpolate object has been explicitly bound to a |
375
|
|
|
|
|
|
|
namespace it will continue to use that namespace even if the |
376
|
|
|
|
|
|
|
String::Interpolate object has been (or is subsequently) passed a hash |
377
|
|
|
|
|
|
|
reference argument. In this case the symbols will be created/updated |
378
|
|
|
|
|
|
|
in the namespace prior to each interpolation and will persist |
379
|
|
|
|
|
|
|
afterwards. |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
See also the package() method. |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
=item Safe object |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
Instruct the object to perform interpolation in the given Safe |
386
|
|
|
|
|
|
|
compartment. Passing a Safe object argument to the |
387
|
|
|
|
|
|
|
String::Interpolate object causes it to stop using a specified |
388
|
|
|
|
|
|
|
namespace if it previously was doing so. If you choose to pass an |
389
|
|
|
|
|
|
|
explicit Safe object you should deny the 'bless' and 'tie' opcodes for |
390
|
|
|
|
|
|
|
the reasons discussed under the safe() method. |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
Once a String::Interpolate object has been explicitly bound to a Safe |
393
|
|
|
|
|
|
|
object it will continue to use that object even if the |
394
|
|
|
|
|
|
|
String::Interpolate object has been (or is subsequently) passed a hash |
395
|
|
|
|
|
|
|
reference argument. In this case the symbols will be created/updated |
396
|
|
|
|
|
|
|
in the namespace associated with the Safe object prior to each |
397
|
|
|
|
|
|
|
interpolation and will persist afterwards. |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
See also the safe() method. |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
=item Safe::Hole object |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
Equivalent to calling the safe_hole() method with the same argument. |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
=item SCALAR reference |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
The referenced scalar is passed to the pragma() method. |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
=item Anything else |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
Use the stringified value of the argument as the string on which to |
412
|
|
|
|
|
|
|
perform interpolation. |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
=back |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
=cut |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
sub exec { |
419
|
5
|
|
|
5
|
1
|
18
|
my $self = shift; |
420
|
5
|
50
|
|
|
|
15
|
$self = $self->new unless ref $self; |
421
|
5
|
|
|
|
|
28
|
my $seenmap; |
422
|
|
|
|
|
|
|
|
423
|
5
|
|
|
|
|
8
|
for ( @_ ) { |
424
|
5
|
50
|
33
|
|
|
47
|
if ( ref eq 'ARRAY' ) { |
|
|
100
|
33
|
|
|
|
|
|
|
50
|
33
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
425
|
0
|
|
|
|
|
0
|
$$self->{pos} = $_; |
426
|
|
|
|
|
|
|
} elsif ( ref eq 'HASH' ) { |
427
|
2
|
|
|
|
|
4
|
my $map = \$$self->{map}; |
428
|
2
|
50
|
66
|
|
|
16
|
if ( !$seenmap++ && $$map && @$$map ){ |
|
|
|
66
|
|
|
|
|
429
|
0
|
|
|
|
|
0
|
$$map = []; |
430
|
0
|
|
|
|
|
0
|
$self->free_tmppkg; |
431
|
|
|
|
|
|
|
} |
432
|
2
|
|
|
|
|
7
|
push @$$map => $_; |
433
|
|
|
|
|
|
|
} elsif ( ref $_ eq 'SCALAR' ) { |
434
|
0
|
|
|
|
|
0
|
$self->pragma($$_); |
435
|
|
|
|
|
|
|
} elsif ( ref $_ eq 'GLOB' || ref \$_ eq 'GLOB' ) { |
436
|
0
|
|
|
|
|
0
|
$self->package($_); |
437
|
|
|
|
|
|
|
} elsif ( ref && $_->isa('Safe::Hole') ) { |
438
|
0
|
|
|
|
|
0
|
$$self->{safe_hole} = $_; |
439
|
|
|
|
|
|
|
} elsif ( ref && $_->isa('Safe') ) { |
440
|
0
|
|
|
|
|
0
|
$self->free_tmppkg; |
441
|
0
|
|
|
|
|
0
|
delete $$self->{pkg}; |
442
|
0
|
|
|
|
|
0
|
delete $$self->{implicit_safe}; |
443
|
0
|
|
|
|
|
0
|
delete $$self->{lexicals}; |
444
|
0
|
|
|
|
|
0
|
$$self->{safe} = $_; |
445
|
0
|
0
|
|
|
|
0
|
$$self->{trap} = 1 unless defined $$self->{trap}; |
446
|
|
|
|
|
|
|
} else { |
447
|
3
|
|
|
|
|
8
|
$$self->{string} = "$_"; |
448
|
3
|
|
|
|
|
18
|
delete $$self->{code}; |
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
} |
451
|
5
|
100
|
|
|
|
17
|
return unless defined wantarray; |
452
|
|
|
|
|
|
|
|
453
|
3
|
|
|
|
|
4
|
@_ = (); |
454
|
3
|
|
|
|
|
26
|
local $_ = $_; |
455
|
|
|
|
|
|
|
|
456
|
3
|
|
|
|
|
6
|
my $string = $$self->{string}; |
457
|
3
|
|
|
|
|
6
|
my $pos = $$self->{pos}; |
458
|
3
|
|
|
|
|
5
|
my $pkg = $$self->{pkg}; |
459
|
3
|
|
|
|
|
6
|
my $safe = $$self->{safe}; |
460
|
3
|
|
|
|
|
5
|
my $code = $$self->{code}; |
461
|
|
|
|
|
|
|
|
462
|
3
|
50
|
33
|
|
|
9
|
if ( $$self->{implicit_safe} && !$safe ) { |
463
|
0
|
|
|
|
|
0
|
$safe = $$self->{safe} = Safe->new; |
464
|
0
|
|
|
|
|
0
|
$safe->deny('tie','bless'); |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
|
467
|
3
|
|
|
|
|
6
|
my $dlm = '_aaa'; |
468
|
|
|
|
|
|
|
|
469
|
3
|
50
|
33
|
|
|
15
|
if ( defined $string && !$code || $pos ) { |
|
|
|
33
|
|
|
|
|
470
|
3
|
100
|
|
|
|
4
|
my $cat = join '' => $string, @{ $pos || [] }; |
|
3
|
|
|
|
|
16
|
|
471
|
3
|
|
|
|
|
12
|
$dlm++ while -1 < index $cat, $dlm; |
472
|
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
|
474
|
3
|
100
|
50
|
|
|
15
|
( join $dlm => @$pos ) =~ /^@{[ join $dlm => ('(.*)') x @$pos ]}$/ |
|
1
|
|
|
|
|
28
|
|
475
|
|
|
|
|
|
|
or die 'Unexpected pattern match failure initialising $1 et al' |
476
|
|
|
|
|
|
|
if $pos; |
477
|
|
|
|
|
|
|
|
478
|
3
|
50
|
33
|
|
|
18
|
if ( $pkg && $pkg eq 'Safe') { |
479
|
0
|
|
|
|
|
0
|
require Safe; |
480
|
0
|
|
|
|
|
0
|
$safe = Safe->new; |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
|
483
|
3
|
50
|
|
|
|
7
|
$pkg = $safe->root if $safe; |
484
|
|
|
|
|
|
|
|
485
|
1
|
0
|
33
|
1
|
|
5
|
local $_ = do { no warnings 'uninitialized'; "$_"}, |
|
1
|
50
|
|
|
|
2
|
|
|
1
|
|
|
|
|
224
|
|
|
3
|
|
|
|
|
9
|
|
|
0
|
|
|
|
|
0
|
|
486
|
|
|
|
|
|
|
local *_ = %_ ? String::Interpolate::Func->wrap_hash('_',\%_) : {} |
487
|
|
|
|
|
|
|
if $safe && ! $$self->{unsafe_underscore}; |
488
|
|
|
|
|
|
|
|
489
|
3
|
|
33
|
|
|
9
|
my $safe_symbols = $safe && ! $$self->{unsafe_symbols}; |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
# use PadWalker qw( peek_my ); use Data::Dumper; die Dumper peek_my(2); |
492
|
|
|
|
|
|
|
|
493
|
3
|
|
|
|
|
3
|
my @pad_map; |
494
|
|
|
|
|
|
|
|
495
|
3
|
50
|
|
|
|
8
|
if ( $$self->{lexicals} ) { |
496
|
0
|
|
|
|
|
0
|
my $depth = 1; |
497
|
0
|
|
|
|
|
0
|
$depth++ while caller($depth)->isa(__PACKAGE__); |
498
|
|
|
|
|
|
|
# die "$depth ". scalar(caller($depth)); |
499
|
0
|
|
|
|
|
0
|
require PadWalker; |
500
|
0
|
|
|
|
|
0
|
my $pad = PadWalker::peek_my($depth+1); |
501
|
|
|
|
|
|
|
# use Data::Dumper; die Dumper $pad; |
502
|
0
|
|
|
|
|
0
|
while ( my ( $k,$v ) = each %$pad ) { |
503
|
0
|
0
|
|
|
|
0
|
$k =~ s/^([@%\$])// |
504
|
|
|
|
|
|
|
or die "$k does not start with \$, \@ or \%"; |
505
|
0
|
0
|
|
|
|
0
|
$v = *$v{$type_from_prefix{$1}} if ref $v eq 'GLOB'; |
506
|
0
|
|
|
|
|
0
|
push @pad_map => { $k => $v }; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
|
510
|
3
|
|
|
|
|
4
|
for ( @pad_map, @{$$self->{map}} ) { |
|
3
|
|
|
|
|
11
|
|
511
|
4
|
|
0
|
|
|
9
|
$pkg ||= $$self->{tmppkg} ||= __PACKAGE__ . '::' . ++$pkgcount; |
|
|
|
33
|
|
|
|
|
512
|
4
|
|
|
|
|
15
|
while ( my ( $k,$v ) = each %$_ ) { |
513
|
1
|
|
|
1
|
|
4
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
477
|
|
514
|
8
|
|
|
|
|
10
|
*{"${pkg}::$k"} = do { |
|
7
|
|
|
|
|
46
|
|
515
|
8
|
100
|
|
|
|
34
|
if ( ref $v eq 'HASH' ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
516
|
1
|
50
|
|
|
|
3
|
if ( $safe_symbols ) { |
517
|
0
|
|
|
|
|
0
|
String::Interpolate::Func->wrap_hash($k,$v); |
518
|
|
|
|
|
|
|
} else { |
519
|
1
|
|
|
|
|
3
|
$v; |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
} elsif ( ref $v eq 'CODE' ) { |
522
|
2
|
|
|
|
|
4
|
my $p = prototype($v); |
523
|
2
|
50
|
66
|
|
|
18
|
if ( defined $p && ! $p ) { |
|
|
100
|
66
|
|
|
|
|
524
|
|
|
|
|
|
|
my $unimplemented = sub { |
525
|
0
|
|
|
0
|
|
0
|
croak "\$$k tied scalar is FETCH-only within String::Interpolate"; |
526
|
0
|
|
|
|
|
0
|
}; |
527
|
0
|
|
|
|
|
0
|
tie my $s, 'String::Interpolate::Func', { |
528
|
|
|
|
|
|
|
FETCH => $v, |
529
|
|
|
|
|
|
|
STORE => $unimplemented, |
530
|
|
|
|
|
|
|
}; |
531
|
0
|
|
|
|
|
0
|
\$s; |
532
|
|
|
|
|
|
|
} elsif ( $p && $p ne "\$" ) { |
533
|
1
|
|
|
|
|
411
|
croak "Invalid prototype ($p) for interpolated function $k"; |
534
|
|
|
|
|
|
|
} else { |
535
|
|
|
|
|
|
|
my $unimplemented = sub { |
536
|
0
|
|
|
0
|
|
0
|
die "%$k tied hash is FETCH-only within String::Interpolate"; |
537
|
1
|
|
|
|
|
6
|
}; |
538
|
1
|
|
|
|
|
11
|
tie my %h, 'String::Interpolate::Func', { |
539
|
|
|
|
|
|
|
FETCH => $v, |
540
|
|
|
|
|
|
|
STORE => $unimplemented, |
541
|
|
|
|
|
|
|
DELETE => $unimplemented, |
542
|
|
|
|
|
|
|
FIRSTKEY => $unimplemented, |
543
|
|
|
|
|
|
|
NEXTKEY => $unimplemented, |
544
|
|
|
|
|
|
|
}; |
545
|
1
|
|
|
|
|
15
|
\%h; |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
} elsif ( ref $v eq 'ARRAY' ) { |
548
|
1
|
50
|
|
|
|
10
|
if ( $safe_symbols ) { |
549
|
|
|
|
|
|
|
my $unimplemented = sub { |
550
|
0
|
|
|
0
|
|
0
|
die "\@$k is read-only within String::Interpolate"; |
551
|
0
|
|
|
|
|
0
|
}; |
552
|
|
|
|
|
|
|
tie my @a, 'String::Interpolate::Func', { |
553
|
0
|
|
|
0
|
|
0
|
FETCH => sub { "$v->[$_[0]]" }, |
554
|
|
|
|
|
|
|
STORE => $unimplemented, |
555
|
|
|
|
|
|
|
DELETE => $unimplemented, |
556
|
0
|
|
|
0
|
|
0
|
FETCHSIZE => sub { scalar @$v }, |
557
|
0
|
|
|
|
|
0
|
}; |
558
|
0
|
|
|
|
|
0
|
\@a; |
559
|
|
|
|
|
|
|
} else { |
560
|
1
|
|
|
|
|
2
|
$v; |
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
} elsif ( ref $v eq 'SCALAR' ) { |
563
|
2
|
50
|
|
|
|
6
|
if ( $safe_symbols ) { |
564
|
|
|
|
|
|
|
my $unimplemented = sub { |
565
|
0
|
|
|
0
|
|
0
|
die "\$$k is read-only within String::Interpolate"; |
566
|
0
|
|
|
|
|
0
|
}; |
567
|
|
|
|
|
|
|
tie my $s, 'String::Interpolate::Func', { |
568
|
0
|
|
|
0
|
|
0
|
FETCH => sub { "$$v" }, |
569
|
0
|
|
|
|
|
0
|
STORE => $unimplemented, |
570
|
|
|
|
|
|
|
}; |
571
|
0
|
|
|
|
|
0
|
\$s; |
572
|
|
|
|
|
|
|
} else { |
573
|
2
|
|
|
|
|
3
|
$v; |
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
} else { |
576
|
2
|
50
|
|
|
|
6
|
if ( $safe_symbols ) { |
577
|
0
|
|
|
|
|
0
|
\ "$v"; |
578
|
|
|
|
|
|
|
} else { |
579
|
2
|
|
|
|
|
4
|
\$v; |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
}; |
583
|
|
|
|
|
|
|
} |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
|
587
|
2
|
50
|
|
|
|
5
|
unless ( $code ) { |
588
|
2
|
50
|
|
|
|
17
|
unless ( defined $string ) { |
589
|
0
|
|
|
|
|
0
|
croak("No string to interpolate"); |
590
|
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
|
592
|
2
|
|
|
|
|
9
|
$string = "BEGIN{import strict qw(refs subs); $$self->{pragmas}}; sub{<<$dlm\n$string\n$dlm\n}"; |
593
|
|
|
|
|
|
|
|
594
|
2
|
50
|
|
|
|
5
|
if ( $safe ) { |
595
|
1
|
|
|
1
|
|
5
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
55
|
|
596
|
0
|
|
|
|
|
0
|
for ( 'String::Interpolate::Func::AUTOLOAD', |
597
|
|
|
|
|
|
|
'warnings::unimport', |
598
|
|
|
|
|
|
|
'warnings::import', |
599
|
|
|
|
|
|
|
'strict::unimport', |
600
|
|
|
|
|
|
|
'strict::import' ) { |
601
|
0
|
|
|
|
|
0
|
*{"${pkg}::$_"} = \&$_; |
|
0
|
|
|
|
|
0
|
|
602
|
|
|
|
|
|
|
} |
603
|
|
|
|
|
|
|
# Remove taint and generate a poor man's Safe::Hole |
604
|
1
|
|
|
1
|
|
3
|
no warnings 'redefine'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1625
|
|
605
|
0
|
|
|
|
|
0
|
*{"${pkg}::String::Interpolate::code"} = $safe->reval( $string =~ /(.*)/s ); |
|
0
|
|
|
|
|
0
|
|
606
|
0
|
|
|
|
|
0
|
$code = 1; # Just a flag in this case |
607
|
|
|
|
|
|
|
# prevent_blessed_error_hack; |
608
|
|
|
|
|
|
|
} else { |
609
|
2
|
|
33
|
|
|
7
|
$pkg ||= $$self->{defpgk}; |
610
|
2
|
|
|
|
|
8
|
$code = reval "package $pkg; $string"; |
611
|
|
|
|
|
|
|
} |
612
|
2
|
50
|
|
|
|
9
|
if ( $@ ) { |
613
|
0
|
0
|
|
|
|
0
|
return if $$self->{trap}; |
614
|
0
|
|
|
|
|
0
|
croak( $@ ); |
615
|
|
|
|
|
|
|
} |
616
|
|
|
|
|
|
|
|
617
|
2
|
|
|
|
|
6
|
$$self->{code} = $code; |
618
|
|
|
|
|
|
|
}; |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
# Restore taint by appending null cut from $string |
621
|
2
|
50
|
|
|
|
7
|
if ( $safe ) { |
622
|
0
|
|
|
|
|
0
|
local $taint_flag = substr( $string, 0, 0 ); |
623
|
0
|
|
|
|
|
0
|
local $safe_hole = $$self->{safe_hole}; |
624
|
0
|
|
|
|
|
0
|
$string = $safe->reval('&String::Interpolate::code'); |
625
|
|
|
|
|
|
|
# prevent_blessed_error_hack; |
626
|
0
|
0
|
|
|
|
0
|
if ( $@ ) { |
627
|
0
|
0
|
|
|
|
0
|
return if $$self->{trap}; |
628
|
0
|
|
|
|
|
0
|
croak( $@ ); |
629
|
|
|
|
|
|
|
} |
630
|
|
|
|
|
|
|
} else { |
631
|
2
|
50
|
|
|
|
64
|
$string = $$self->{trap} ? eval { &$code } : &$code; |
|
0
|
|
|
|
|
0
|
|
632
|
|
|
|
|
|
|
} |
633
|
2
|
|
|
|
|
6
|
chop $string; |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
# If we copied the lexicals then we must clean house to |
636
|
|
|
|
|
|
|
# avoid keeping them spuriously alive. |
637
|
2
|
50
|
|
|
|
8
|
$self->free_tmppkg if $$self->{lexicals}; |
638
|
|
|
|
|
|
|
|
639
|
2
|
|
|
|
|
13
|
$string; |
640
|
|
|
|
|
|
|
} |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
=back |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
=head2 Functional interface |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
For those heathens who don't like the OO interface. |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
=over 4 |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
=item safe_interpolate |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
Exportable function equivalent to String::Interpolate->safe->exec(LIST). |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
=cut |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
sub safe_interpolate { |
657
|
0
|
|
|
0
|
1
|
0
|
__PACKAGE__->safe->exec(@_); |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
=item interpolate |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
Exportable function equivalent to |
663
|
|
|
|
|
|
|
String::Interpolate->lexicals->exec(LIST). |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
=cut |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
sub interpolate { |
668
|
0
|
|
|
0
|
1
|
0
|
__PACKAGE__->lexicals->exec(@_); |
669
|
|
|
|
|
|
|
} |
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
=back |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
=head2 Ancillary methods |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
The following methods provide alternative interfaces and some fine |
676
|
|
|
|
|
|
|
tuning capabilities. |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
=over 4 |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
=item trap |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
Tells the String::Interpolate object whether or not to trap |
683
|
|
|
|
|
|
|
exceptions. |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
$i->trap; # Enable trapping |
686
|
|
|
|
|
|
|
$i->trap(1); # Enable trapping |
687
|
|
|
|
|
|
|
$i->trap(0); # Disable trapping |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
Returns the object so that it can be tagged on to constructor calls. |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
my $i = String::Interpolate->safe->trap(0); |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
If the trap(0) method has not been called then trapping is enabled when |
694
|
|
|
|
|
|
|
using a Safe compartment. |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
=cut |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
sub trap { |
699
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
700
|
0
|
0
|
|
|
|
0
|
$self = $self->new unless ref $self; |
701
|
0
|
|
|
|
|
0
|
my $trap = shift; |
702
|
0
|
0
|
|
|
|
0
|
$$self->{trap} = defined $trap ? $trap : 1; |
703
|
0
|
|
|
|
|
0
|
$self; |
704
|
|
|
|
|
|
|
} |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
=item unsafe_underscore |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
Tells the String::Interpolate object whether or not to use "unsafe |
709
|
|
|
|
|
|
|
underscore" mode. In this mode no precautions are taken to prevent |
710
|
|
|
|
|
|
|
malicious code attempting to reach outside it's Safe compartment |
711
|
|
|
|
|
|
|
through the $_ and %_ variables. |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
$i->unsafe_underscore; # Enable unsafe underscore mode |
714
|
|
|
|
|
|
|
$i->unsafe_underscore(1); # Enable unsafe underscore mode |
715
|
|
|
|
|
|
|
$i->unsafe_underscore(0); # Disable unsafe underscore mode |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
Returns the object so that it can be tagged on to constructor calls. |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
=cut |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
sub unsafe_underscore { |
722
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
723
|
0
|
0
|
|
|
|
0
|
$self = $self->new unless ref $self; |
724
|
0
|
|
|
|
|
0
|
my $unsafe_underscore = shift; |
725
|
0
|
0
|
|
|
|
0
|
$$self->{unsafe_underscore} = defined $unsafe_underscore ? $unsafe_underscore : 1; |
726
|
0
|
|
|
|
|
0
|
$self; |
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
=item unsafe_symbols |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
Tells the String::Interpolate object whether or not to use "unsafe |
732
|
|
|
|
|
|
|
symbol" mode. In this mode variables are simply shared with the Safe |
733
|
|
|
|
|
|
|
compartment rather than being safely hidden behind variables tied to |
734
|
|
|
|
|
|
|
blessed closures. The setting of this flag as no effect when not |
735
|
|
|
|
|
|
|
using a Safe compartment. |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
$i->unsafe_symbols; # Enable unsafe symbol mode |
738
|
|
|
|
|
|
|
$i->unsafe_symbols(1); # Enable unsafe symbol mode |
739
|
|
|
|
|
|
|
$i->unsafe_symbols(0); # Disable unsafe symbol mode |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
Returns the object so that it can be tagged on to constructor calls. |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
=cut |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
sub unsafe_symbols { |
746
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
747
|
0
|
0
|
|
|
|
0
|
$self = $self->new unless ref $self; |
748
|
0
|
|
|
|
|
0
|
my $unsafe_symbols = shift; |
749
|
0
|
0
|
|
|
|
0
|
$$self->{unsafe_symbols} = defined $unsafe_symbols ? $unsafe_symbols : 1; |
750
|
0
|
|
|
|
|
0
|
$self; |
751
|
|
|
|
|
|
|
} |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
=over 4 |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
=item lexicals |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
This feature is EXPERIMENTAL. Do not use it in real code. |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
Tells the String::Interpolate object whether or not to use the |
760
|
|
|
|
|
|
|
PadWalker module to import all lexical variables from the calling |
761
|
|
|
|
|
|
|
context into the temporary package or Safe compartment. By default |
762
|
|
|
|
|
|
|
this does not happen as it is conceptually ugly and quite expensive. |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
$i->lexicals; # Enable lexicals |
765
|
|
|
|
|
|
|
$i->lexicals(1) # Enable lexicals |
766
|
|
|
|
|
|
|
$i->lexicals(0); # Disable lexicals |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
Returns the object so that it can be tagged on to constructor calls. |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
my $i = String::Interpolate->safe->lexicals; |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
Enabling lexicals with a Safe compartment like this will give the code |
773
|
|
|
|
|
|
|
read-only access to all your lexical variables. |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
Note that the lexicals used are those in scope at the final call that |
776
|
|
|
|
|
|
|
performs the interpolation, not those in scope when the |
777
|
|
|
|
|
|
|
String::Interpolate object is constructed. Also you can't have your |
778
|
|
|
|
|
|
|
cake and eat it. If you cannot use this feature at the same time as |
779
|
|
|
|
|
|
|
an explicit package or Safe compartment. |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
=cut |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
sub lexicals { |
784
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
785
|
0
|
0
|
|
|
|
0
|
$self = $self->new unless ref $self; |
786
|
0
|
|
|
|
|
0
|
my $lexicals = shift; |
787
|
0
|
0
|
|
|
|
0
|
if ( ( $$self->{lexicals} = defined $lexicals ? $lexicals : 1 ) ) { |
|
|
0
|
|
|
|
|
|
788
|
0
|
|
|
|
|
0
|
delete $$self->{pkg}; |
789
|
0
|
|
|
|
|
0
|
delete $$self->{safe}; |
790
|
|
|
|
|
|
|
} |
791
|
0
|
|
|
|
|
0
|
$self; |
792
|
|
|
|
|
|
|
} |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
=item package |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
Instructs the String::Interpolate object to forget its current Safe |
797
|
|
|
|
|
|
|
compartment or namespace and use the specified one henceforth. The |
798
|
|
|
|
|
|
|
package name can be specified as a string, a GLOB or a GLOB reference. |
799
|
|
|
|
|
|
|
The trailing '::' may be ommited. With an undefined argument this |
800
|
|
|
|
|
|
|
method instructs the object to use a new automatically allocated |
801
|
|
|
|
|
|
|
temporary namespace. |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
The package method Returns the object so that it can be tagged on to |
804
|
|
|
|
|
|
|
constructor calls. It can also be used as a constructor. |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
my $i = String::Interpolate->package('Q'); # Use namespace Q:: |
807
|
|
|
|
|
|
|
$i->package; # Use temporary namespace |
808
|
|
|
|
|
|
|
$i->package(*R); # Use namespace R:: |
809
|
|
|
|
|
|
|
$i->package(\*S::); # Use namespace S:: |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
Note that the last two forms are not commonly used as GLOB or GLOB |
812
|
|
|
|
|
|
|
reference arguments passed to the exec(), new() or methods are |
813
|
|
|
|
|
|
|
automatically passed on the the package() method. |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
=cut |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
sub package { |
818
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
819
|
0
|
0
|
|
|
|
0
|
$self = $self->new unless ref $self; |
820
|
0
|
|
|
|
|
0
|
my $pkg = shift; |
821
|
0
|
0
|
|
|
|
0
|
$pkg = *$pkg if ref $pkg eq 'GLOB'; |
822
|
0
|
0
|
|
|
|
0
|
($pkg) = $pkg =~ /^\*?(?:main::(?!$))*(.*?)(?:::)?$/ or die; |
823
|
0
|
|
|
|
|
0
|
$self->free_tmppkg; |
824
|
0
|
|
|
|
|
0
|
delete $$self->{safe}; |
825
|
0
|
|
|
|
|
0
|
delete $$self->{implicit_safe}; |
826
|
0
|
|
|
|
|
0
|
delete $$self->{lexicals}; |
827
|
0
|
|
|
|
|
0
|
$$self->{pkg} = $$self->{explicit_pkg} = $pkg; |
828
|
0
|
|
|
|
|
0
|
$self; |
829
|
|
|
|
|
|
|
} |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
=item safe_hole |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
Tells the String::Interpolate object whether or not to use a |
834
|
|
|
|
|
|
|
Safe::Hole object to wrap callbacks to subroutines specified in the |
835
|
|
|
|
|
|
|
symbol mapping hash. Without a Safe::Hole eval(), symbolic references |
836
|
|
|
|
|
|
|
and method calls in callbacks won't function normally. |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
my $i = String::Interpolate->safe->safe_hole; |
839
|
|
|
|
|
|
|
# Without a Safe::Hole Wibble::wobble() would be inaccessible |
840
|
|
|
|
|
|
|
$i->{FOO} = sub () { Wibble->wobble }; |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
This feature only makes sense when evaluating in a Safe compartment |
843
|
|
|
|
|
|
|
and you can only use it if you have the Safe::Hole module installed. |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
$i->safe_hole; # Enable use of Safe::Hole |
846
|
|
|
|
|
|
|
$i->safe_hole(1); # Enable use of Safe::Hole |
847
|
|
|
|
|
|
|
$i->safe_hole(0); # Disable use of Safe::Hole |
848
|
|
|
|
|
|
|
$i->safe_hole($hole); # Use the Safe::Hole object $hole |
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
This method can also be called implicitly as follows. |
851
|
|
|
|
|
|
|
|
852
|
|
|
|
|
|
|
$i->(\'SAFE HOLE'); # Enable use of Safe::Hole |
853
|
|
|
|
|
|
|
$i->(\'NO_SAFE_HOLE'); # Disable use of Safe::Hole |
854
|
|
|
|
|
|
|
$i->($hole); # Use the Safe::Hole object $hole |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
The safe_hole() method returns the object so that it can be tagged on |
857
|
|
|
|
|
|
|
to constructor calls. |
858
|
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
=cut |
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
sub safe_hole { |
862
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
863
|
0
|
0
|
|
|
|
0
|
$self = $self->new unless ref $self; |
864
|
0
|
|
|
|
|
0
|
my $safe_hole = shift; |
865
|
0
|
0
|
|
|
|
0
|
unless ( UNIVERSAL::isa( $safe_hole, 'Safe::Hole' )) { |
866
|
0
|
0
|
0
|
|
|
0
|
if ( $safe_hole || !defined $safe_hole ) { |
867
|
0
|
0
|
|
|
|
0
|
unless ( eval { require Safe::Hole; 1 } ) { |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
868
|
0
|
|
|
|
|
0
|
require Carp; |
869
|
0
|
|
|
|
|
0
|
Carp::croak('String::Interpolate::safe_hole() requires Safe::Hole module'); |
870
|
|
|
|
|
|
|
} |
871
|
0
|
0
|
|
|
|
0
|
$safe_hole = Safe::Hole->new(($Safe::Hole::VERSION > 0.09) ? ({}) : ()); |
872
|
|
|
|
|
|
|
} else { |
873
|
0
|
|
|
|
|
0
|
undef $safe_hole; |
874
|
|
|
|
|
|
|
} |
875
|
|
|
|
|
|
|
} |
876
|
0
|
|
|
|
|
0
|
$$self->{safe_hole} = $safe_hole; |
877
|
0
|
|
|
|
|
0
|
$self; |
878
|
|
|
|
|
|
|
} |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
=item pragma |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
Specify various options including Perl code to be complied in a |
883
|
|
|
|
|
|
|
BEGIN{} block prior to compiling the string to be interpolated. When |
884
|
|
|
|
|
|
|
working in a Safe compartment, what you can do here is, of course, |
885
|
|
|
|
|
|
|
highly limited. In practice this is only useful for calling the |
886
|
|
|
|
|
|
|
import() an unimport() methods on the warnings and strict modules. |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
For the most commonly used values, to control the handling of |
889
|
|
|
|
|
|
|
interpolating undefined values, the following shorthands can also be |
890
|
|
|
|
|
|
|
used: |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
NOWARN => 'unimport warnings qw(uninitialized)' |
893
|
|
|
|
|
|
|
WARN => '' |
894
|
|
|
|
|
|
|
FATAL => 'import warnings FATAL => qw(uninitialized); import strict qw(vars)' |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
The default state for a newly created String::Interpolate object is |
897
|
|
|
|
|
|
|
NOWARN. All other warnings are enabled as are 'refs' and 'subs' |
898
|
|
|
|
|
|
|
strictures. |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
You can call pragma() implicitly by passing SCALAR references to |
901
|
|
|
|
|
|
|
exec(). Furthermore pragma('TRAP') is a synonym for trap(1) and |
902
|
|
|
|
|
|
|
pragma('NO TRAP') is a synonym for trap(0). Similarly for lexicals(), |
903
|
|
|
|
|
|
|
unsafe_symbols(), unsafe_underscore() and safe_hole(). This makes the |
904
|
|
|
|
|
|
|
following statements equivalent: |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
$i->(\'FATAL',\'NO TRAP',\'SAFE SYMBOLS'); |
907
|
|
|
|
|
|
|
$i->pragma('FATAL','NO_TRAP','NO UNSAFE_SYMBOLS'); |
908
|
|
|
|
|
|
|
$i->pragma('FATAL')->trap(0)->unsafe_symbols(0); |
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
The pragma() method returns the object so that it can be tagged on to |
911
|
|
|
|
|
|
|
constructor calls. |
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
=cut |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
sub pragma { |
916
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
917
|
0
|
0
|
|
|
|
0
|
$self = $self->new unless ref $self; |
918
|
0
|
|
|
|
|
0
|
for my $pragma ( @_ ) { |
919
|
0
|
|
|
|
|
0
|
my ( $no, $method, $un) = |
920
|
|
|
|
|
|
|
$pragma =~ /^(NO[ _]?)?(LEXICALS|TRAP|SAFE[_ ]HOLE|(?:((?:UN)?)SAFE[_ ](?:SYMBOLS|UNDERSCORE)))$/; |
921
|
0
|
0
|
|
|
|
0
|
if ( $method ) { |
922
|
|
|
|
|
|
|
# For methods that start 'un' but for which the 'un' has been ommited |
923
|
|
|
|
|
|
|
# reinstate the un and invert the sense of the 'no' prefix. |
924
|
0
|
0
|
0
|
|
|
0
|
if ( defined $un && !$un ) { |
925
|
0
|
|
|
|
|
0
|
$no = !$no; |
926
|
0
|
|
|
|
|
0
|
$method = "UN$method"; |
927
|
|
|
|
|
|
|
} |
928
|
0
|
|
|
|
|
0
|
$method =~ tr/ A-Z/_a-z/; |
929
|
0
|
|
|
|
|
0
|
$self->$method(!$no + 0); |
930
|
|
|
|
|
|
|
} else { |
931
|
0
|
|
0
|
|
|
0
|
$$self->{pragma} = $preset_pragma{$pragma} || $pragma; |
932
|
|
|
|
|
|
|
} |
933
|
|
|
|
|
|
|
} |
934
|
0
|
|
|
|
|
0
|
$self; |
935
|
|
|
|
|
|
|
} |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
sub DESTROY { |
938
|
1
|
|
|
1
|
|
4
|
shift->free_tmppkg; |
939
|
|
|
|
|
|
|
} |
940
|
|
|
|
|
|
|
|
941
|
|
|
|
|
|
|
sub free_tmppkg { |
942
|
1
|
|
|
1
|
0
|
3
|
my $self = shift; |
943
|
1
|
|
|
|
|
3
|
delete $$self->{code}; |
944
|
1
|
50
|
|
|
|
6
|
delete $$self->{safe} if $$self->{implicit_safe}; |
945
|
1
|
50
|
|
|
|
0
|
if ( $$self->{tmppkg} ) { |
946
|
0
|
|
|
|
|
0
|
require Symbol; |
947
|
0
|
|
|
|
|
0
|
Symbol::delete_package( delete $$self->{tmppkg} ); |
948
|
|
|
|
|
|
|
} |
949
|
|
|
|
|
|
|
} |
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
=item positionals |
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
Returns, as an lvalue, the reference to the array that holds the |
954
|
|
|
|
|
|
|
values to use for the positional variables $1 and so on. |
955
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
my @p = qw ( one two three ); |
957
|
|
|
|
|
|
|
my $i = new String::Interpolate \@p; |
958
|
|
|
|
|
|
|
$i->positionals->[1] = "TWO"; # $p[1] = "TWO"; |
959
|
|
|
|
|
|
|
$i->positionals = [ qw ( X Y ) ]; # Forget @p, use anon array |
960
|
|
|
|
|
|
|
undef $i->positionals; # $1 etc. inherted from caller |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
=cut |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
sub positionals : lvalue { |
965
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
966
|
0
|
|
|
|
|
0
|
$$self->{pos}; |
967
|
|
|
|
|
|
|
} |
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
sub ashash { |
970
|
4
|
|
|
4
|
0
|
24
|
my $self = shift; |
971
|
4
|
50
|
|
|
|
12
|
$self->exec({}) unless $$self->{map}; |
972
|
4
|
|
|
|
|
14
|
$$self->{map}[-1]; |
973
|
|
|
|
|
|
|
} |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
package String::Interpolate::AsArray; |
976
|
|
|
|
|
|
|
|
977
|
1
|
|
|
1
|
|
2
|
sub TIEARRAY { my ($class, $thing ) = @_; bless \$thing, $class } |
|
1
|
|
|
|
|
5
|
|
978
|
|
|
|
|
|
|
|
979
|
1
|
|
|
1
|
|
2
|
sub STORE { ${${$_[0]}}->{pos}[$_[1]-1]=$_[2] } |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
11
|
|
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
sub FETCH { |
982
|
0
|
|
|
0
|
|
0
|
require Carp; |
983
|
0
|
|
|
|
|
0
|
Carp::croak('String::Interpolate objects STORE-only in ARRAY context'); |
984
|
|
|
|
|
|
|
} |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
*FETCHSIZE = \&FETCH; |
987
|
|
|
|
|
|
|
|
988
|
|
|
|
|
|
|
# A private and very secretive class to give secure access to an object |
989
|
|
|
|
|
|
|
|
990
|
|
|
|
|
|
|
package String::Interpolate::Func; |
991
|
|
|
|
|
|
|
|
992
|
|
|
|
|
|
|
sub wrap_hash { |
993
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
994
|
0
|
|
|
|
|
0
|
my ($k,$v) = @_; |
995
|
|
|
|
|
|
|
my $unimplemented = sub { |
996
|
0
|
|
|
0
|
|
0
|
die "%$k is read-only within String::Interpolate"; |
997
|
0
|
|
|
|
|
0
|
}; |
998
|
|
|
|
|
|
|
tie my %h, $class, { |
999
|
0
|
|
|
0
|
|
0
|
FETCH => sub { "$v->{$_[0]}" }, |
1000
|
|
|
|
|
|
|
STORE => $unimplemented, |
1001
|
|
|
|
|
|
|
DELETE => $unimplemented, |
1002
|
0
|
|
|
0
|
|
0
|
FIRSTKEY => sub { keys %$v; each %$v }, |
|
0
|
|
|
|
|
0
|
|
1003
|
0
|
|
|
0
|
|
0
|
NEXTKEY => sub { each %$v }, |
1004
|
0
|
|
|
|
|
0
|
}; |
1005
|
0
|
|
|
|
|
0
|
\%h; |
1006
|
|
|
|
|
|
|
} |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
sub TIEARRAY { |
1009
|
1
|
|
|
1
|
|
2
|
my $actions = $_[1]; |
1010
|
|
|
|
|
|
|
bless sub { |
1011
|
0
|
0
|
|
0
|
|
|
return unless my $action = $actions->{+shift}; |
1012
|
|
|
|
|
|
|
# Launder the argument list in case $action is wrapped by Safe::Hole |
1013
|
|
|
|
|
|
|
# If the interpolated string was tainted then so are any arguments |
1014
|
|
|
|
|
|
|
# passed from it. |
1015
|
0
|
|
|
|
|
|
@_ = map { "$taint_flag$_" } @_; |
|
0
|
|
|
|
|
|
|
1016
|
0
|
0
|
|
|
|
|
goto &$action unless $safe_hole; |
1017
|
0
|
|
|
|
|
|
$safe_hole->call($action,@_); |
1018
|
1
|
|
|
|
|
7
|
}, $_[0]; |
1019
|
|
|
|
|
|
|
} |
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
*TIEHASH = \&TIEARRAY; |
1022
|
|
|
|
|
|
|
*TIESCALAR = \&TIEARRAY; |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
sub AUTOLOAD { |
1025
|
0
|
|
|
0
|
|
|
my $self = shift; |
1026
|
0
|
|
|
|
|
|
unshift @_ => our($AUTOLOAD) =~ /(\w+)$/; |
1027
|
0
|
|
|
|
|
|
goto &$self; |
1028
|
|
|
|
|
|
|
} |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
1; |
1031
|
|
|
|
|
|
|
__END__ |