view release on metacpan or  search on metacpan

lib/Acme/Lexical/Thief.pm  view on Meta::CPAN

BEGIN {
	$Acme::Lexical::Thief::AUTHORITY = 'cpan:TOBYINK';
	$Acme::Lexical::Thief::VERSION   = '0.002';
}

use Carp;
use Keyword::Simple ();
use PadWalker ();
use Text::Balanced ();

my $KEYWORD = 'steal';
my $CLASS   = __PACKAGE__;

sub import
{
	Keyword::Simple::define $KEYWORD, sub
	{
		my $ref = shift;
		$$ref =~ s/^\s+//;

		my $depth = 0;
		if ($$ref =~ /^((?: 0x[0-9A-F]+ | 0b[0-1]+ | 0[0-7]* | [1-9][0-9]* )\s*)/ixs)
		{
			$depth = eval $1;
			substr($$ref, 0, length $1) = '';
		}

		my $extracted;
		if ($$ref =~ /^\(/)
		{
			$extracted = Text::Balanced::extract_bracketed($$ref)
				or croak "usage: $KEYWORD (VARIABLES);";
			$extracted =~ s/(^\(|\)$)//gs;
		}
		else
		{
			($extracted, $$ref) = ($$ref =~ /^([^;]+)(;.*)$/s)
				or croak "usage: $KEYWORD VARIABLES;";
		}
		(my $globs = $extracted) =~ s/[\$\%\@]/*/gs;
		$$ref = "our($extracted); local($globs) = $CLASS\::_callback(q($extracted), $depth);$$ref";
	}
}

sub unimport
{
	Keyword::Simple::undefine $KEYWORD;
}

sub _callback
{
	my $vars  = shift;
	my $depth = shift // 0;
	
	$vars =~ s/(^\s*|\s*$)//g;
	my @vars = split /\s*,\s*/, $vars;
	
	my $MY  = PadWalker::peek_my($depth + 2);
	my $OUR = PadWalker::peek_our($depth + 2);
	return map {
		exists $MY->{$_}  ? $MY->{$_} :
		exists $OUR->{$_} ? $OUR->{$_} :
		croak "$KEYWORD($_) failed; caller has no $_ defined";
	} @vars;
}

1;

__END__

=head1 NAME

Acme::Lexical::Thief - steal lexical variables from your caller

=head1 SYNOPSIS

   use 5.012;
   use strict;
   use warnings;
   use Acme::Lexical::Thief;
   
   sub greet {
      my $name = shift;
      greet_verbally();
   }
   
   sub greet_verbally {
      steal $name;  # caller variable
      say "Hello $name";
   }

=head1 DESCRIPTION

This package allows you access to your caller's lexical variables, without
them knowing! Full read/write access. This is generally a pretty bad idea,
hence the Acme namespace.

You can steal scalars, arrays and hashes:

   steal $car, @treasures, %stash;

Parentheses can surround the list of variables to steal:

   steal ($car, @treasures, %stash);

Generally everything should "just work" as you expect it to. Except when it
does not.

Technically speaking, your stolen C<< $car >> is a package-scoped (C<our>)
variable which is lexically aliased (C<< local *car >>) to the caller's
variable of the same name. Because C<steal> is parsed at compile-time,
you don't need to (and indeed should not!) pre-declare your stolen
variables.

   sub greet_verbally {
      my $name;   # don't do this!
      steal $name;
      say "Hello $name";
   }