File Coverage

blib/lib/String/Interpolate.pm
Criterion Covered Total %
statement 234 314 74.5
branch 81 144 56.2
condition 33 59 55.9
subroutine 42 61 68.8
pod 13 17 76.4
total 403 595 67.7


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