view release on metacpan or  search on metacpan

lib/String/Interpolate.pm  view on Meta::CPAN

	    }
	    push @$$map => $_;
	} elsif ( ref $_ eq 'SCALAR' ) {
	    $self->pragma($$_);
	} elsif ( ref $_ eq 'GLOB' || ref \$_ eq 'GLOB' ) {
	    $self->package($_);
	} elsif ( ref && $_->isa('Safe::Hole') ) {
	    $$self->{safe_hole} = $_;
	} elsif ( ref && $_->isa('Safe') ) {
	    $self->free_tmppkg;
	    delete $$self->{pkg};
	    delete $$self->{implicit_safe};
	    delete $$self->{lexicals};
	    $$self->{safe} = $_;
	    $$self->{trap} = 1 unless defined $$self->{trap};
	} else {
	    $$self->{string} = "$_";
	    delete $$self->{code};
	}
    }
    return unless defined wantarray;

    @_ = ();
    local $_ = $_;

    my $string = $$self->{string};
    my $pos = $$self->{pos};
    my $pkg = $$self->{pkg};
    my $safe = $$self->{safe};
    my $code = $$self->{code};

    if ( $$self->{implicit_safe} && !$safe ) {
	$safe = $$self->{safe} = Safe->new;
	$safe->deny('tie','bless');
    }

    my $dlm = '_aaa';

    if ( defined $string && !$code || $pos ) {
	my $cat = join '' => $string, @{ $pos || [] };
	$dlm++ while -1 < index $cat, $dlm;
    }

    ( join $dlm => @$pos ) =~ /^@{[ join $dlm => ('(.*)') x @$pos ]}$/ 
	or die 'Unexpected pattern match failure initialising $1 et al'
	    if $pos;
 
    if ( $pkg && $pkg eq 'Safe') {
	require Safe;
	$safe = Safe->new;
    }

    $pkg = $safe->root if $safe;

    local $_ = do { no warnings 'uninitialized'; "$_"},
    local *_ = %_ ? String::Interpolate::Func->wrap_hash('_',\%_) : {}
    if $safe && ! $$self->{unsafe_underscore};

    my $safe_symbols = $safe && ! $$self->{unsafe_symbols};

    # use PadWalker qw( peek_my ); use Data::Dumper; die Dumper peek_my(2);
    
    my @pad_map;

    if ( $$self->{lexicals} ) {
	my $depth = 1;
	$depth++ while caller($depth)->isa(__PACKAGE__);
	# die "$depth ". scalar(caller($depth));
	require PadWalker;
	my $pad = PadWalker::peek_my($depth+1);
	# use Data::Dumper; die Dumper $pad;
	while ( my ( $k,$v ) = each %$pad ) {
	    $k =~ s/^([@%\$])//
		or die "$k does not start with \$, \@ or \%";
	    $v = *$v{$type_from_prefix{$1}} if ref $v eq 'GLOB';
	    push @pad_map => { $k => $v };
	}
    }

    for ( @pad_map, @{$$self->{map}} ) {
	$pkg ||= $$self->{tmppkg} ||= __PACKAGE__ . '::' . ++$pkgcount;
	while ( my ( $k,$v ) = each %$_ ) {
	    no strict 'refs';
	    *{"${pkg}::$k"} = do {
		if ( ref $v eq 'HASH' ) {
		    if ( $safe_symbols ) {
		        String::Interpolate::Func->wrap_hash($k,$v);
		    } else {
			$v;
		    }
		} elsif ( ref $v eq 'CODE' ) {
		    my $p = prototype($v);
		    if ( defined $p && ! $p ) {
			my $unimplemented = sub {
			    croak "\$$k tied scalar is FETCH-only within String::Interpolate";
			};
			tie my $s, 'String::Interpolate::Func', {
			    FETCH => $v,
			    STORE => $unimplemented,
			};
			\$s;
		    } elsif ( $p && $p ne "\$" ) {
  		        croak "Invalid prototype ($p) for interpolated function $k";
		    } else {
			my $unimplemented = sub {
			    die "%$k tied hash is FETCH-only within String::Interpolate";
			};
			tie my %h, 'String::Interpolate::Func', {
			    FETCH => $v,
			    STORE => $unimplemented,
			    DELETE => $unimplemented,
			    FIRSTKEY => $unimplemented,
			    NEXTKEY => $unimplemented,
			};
			\%h;
		    }
		} elsif ( ref $v eq 'ARRAY' ) {
		    if ( $safe_symbols ) {
			my $unimplemented = sub {
			    die "\@$k is read-only within String::Interpolate";
			};
			tie my @a, 'String::Interpolate::Func', {
			    FETCH => sub { "$v->[$_[0]]" },
			    STORE => $unimplemented,
			    DELETE => $unimplemented,
			    FETCHSIZE => sub { scalar @$v },
			};
			\@a;
		    } else {
			$v;

lib/String/Interpolate.pm  view on Meta::CPAN

sub trap {
    my $self = shift;
    $self = $self->new unless ref $self;
    my $trap = shift;
    $$self->{trap} = defined $trap ? $trap : 1;
    $self;
}

=item unsafe_underscore

Tells the String::Interpolate object whether or not to use "unsafe
underscore" mode.  In this mode no precautions are taken to prevent
malicious code attempting to reach outside it's Safe compartment
through the $_ and %_ variables.

    $i->unsafe_underscore;    # Enable unsafe underscore mode
    $i->unsafe_underscore(1); # Enable unsafe underscore mode
    $i->unsafe_underscore(0); # Disable unsafe underscore mode

Returns the object so that it can be tagged on to constructor calls.

=cut

sub unsafe_underscore {
    my $self = shift;
    $self = $self->new unless ref $self;
    my $unsafe_underscore = shift;
    $$self->{unsafe_underscore} = defined $unsafe_underscore ? $unsafe_underscore : 1;
    $self;
}

=item unsafe_symbols

Tells the String::Interpolate object whether or not to use "unsafe
symbol" mode.  In this mode variables are simply shared with the Safe
compartment rather than being safely hidden behind variables tied to
blessed closures.  The setting of this flag as no effect when not
using a Safe compartment.

    $i->unsafe_symbols;    # Enable unsafe symbol mode
    $i->unsafe_symbols(1); # Enable unsafe symbol mode
    $i->unsafe_symbols(0); # Disable unsafe symbol mode

Returns the object so that it can be tagged on to constructor calls.

=cut

sub unsafe_symbols {
    my $self = shift;
    $self = $self->new unless ref $self;
    my $unsafe_symbols = shift;
    $$self->{unsafe_symbols} = defined $unsafe_symbols ? $unsafe_symbols : 1;
    $self;
}

=item lexicals

This feature is EXPERIMENTAL.  Do not use it in real code.

Tells the String::Interpolate object whether or not to use the
PadWalker module to import all lexical variables from the calling
context into the temporary package or Safe compartment.  By default
this does not happen as it is conceptually ugly and quite expensive.

    $i->lexicals;     # Enable lexicals
    $i->lexicals(1)   # Enable lexicals 
    $i->lexicals(0);  # Disable lexicals

Returns the object so that it can be tagged on to constructor calls.

    my $i = String::Interpolate->safe->lexicals;

Enabling lexicals with a Safe compartment like this will give the code
read-only access to all your lexical variables.

Note that the lexicals used are those in scope at the final call that
performs the interpolation, not those in scope when the
String::Interpolate object is constructed.  Also you can't have your
cake and eat it.  If you cannot use this feature at the same time as
an explicit package or Safe compartment.

=cut

sub lexicals {
    my $self = shift;
    $self = $self->new unless ref $self;
    my $lexicals = shift;
    if ( ( $$self->{lexicals} = defined $lexicals ? $lexicals : 1 ) ) {
	delete $$self->{pkg};
	delete $$self->{safe};
    }
    $self;
}

=item package

Instructs the String::Interpolate object to forget its current Safe
compartment or namespace and use the specified one henceforth.  The
package name can be specified as a string, a GLOB or a GLOB reference.
The trailing '::' may be omitted.  With an undefined argument this
method instructs the object to use a new automatically allocated
temporary namespace.

The package method Returns the object so that it can be tagged on to
constructor calls.  It can also be used as a constructor.

    my $i = String::Interpolate->package('Q');   # Use namespace Q::
    $i->package;                                 # Use temporary namespace
    $i->package(*R);                             # Use namespace R::
    $i->package(\*S::);                          # Use namespace S::

Note that the last two forms are not commonly used as GLOB or GLOB
reference arguments passed to the exec(), new() or methods are
automatically passed on the the package() method.

=cut

sub package {
    my $self = shift;
    $self = $self->new unless ref $self;
    my $pkg = shift;