- - Make prelude configurable, so strictures can be optional
+ - XXX: currently needs Moo from git (c69190f10)
+ - HintPersistence plugin to persist compile time hints (DGL)
+ - Support plugins (DGL)
+ - Make prelude configurable, so strictures can be optional (DGL)
1.1.0 2011-01-11 21:51:00
- Add a #line directive so it's clearer where errors occurred (DGL)
use Eval::WithLexicals;
use Term::ReadLine;
use Data::Dumper;
+use Getopt::Long;
+
+GetOptions(
+ "plugin=s" => \my @plugins
+);
$SIG{INT} = sub { warn "SIGINT\n" };
$Quotekeys = 0;
}
-my $eval = Eval::WithLexicals->new;
+my $eval = @plugins
+ ? Eval::WithLexicals->with_plugins(@plugins)->new
+ : Eval::WithLexicals->new;
+
my $read = Term::ReadLine->new('Perl REPL');
while (1) {
my $line = $read->readline('re.pl$ ');
package Eval::WithLexicals;
use Moo;
+use Moo::Role ();
use Sub::Quote;
our $VERSION = '1.001000'; # 1.1.0
is => 'rw', default => quote_sub q{ 'use strictures 1;' }
);
+sub with_plugins {
+ my($class, @names) = @_;
+
+ Moo::Role->create_class_with_roles($class,
+ map "Eval::WithLexicals::With$_", @names);
+}
+
+sub setup_code {
+ my($self) = @_;
+ $self->prelude;
+}
+
+sub capture_code {
+ ( qq{ BEGIN { Eval::WithLexicals::Util::capture_list() } } )
+}
+
sub eval {
my ($self, $to_eval) = @_;
local *Eval::WithLexicals::Cage::current_line;
local *Eval::WithLexicals::Cage::pad_capture;
local *Eval::WithLexicals::Cage::grab_captures;
- my $setup = Sub::Quote::capture_unroll('$_[2]', $self->lexicals, 2);
+
my $package = $self->in_package;
- my $prelude = $self->prelude;
- local our $current_code = qq!${prelude}
-${setup}
+ my $setup_code = join '', $self->setup_code,
+ # $_[2] being what is passed to _eval_do below
+ Sub::Quote::capture_unroll('$_[2]', $self->lexicals, 2);
+
+ my $capture_code = join '', $self->capture_code;
+
+ local our $current_code = qq!
+${setup_code}
sub Eval::WithLexicals::Cage::current_line {
package ${package};
#line 1 "(eval)"
${to_eval}
;sub Eval::WithLexicals::Cage::pad_capture { }
-BEGIN { Eval::WithLexicals::Util::capture_list() }
+${capture_code}
sub Eval::WithLexicals::Cage::grab_captures {
no warnings 'closure'; no strict 'vars';
package Eval::WithLexicals::VarScope;!;
+ # rest is appended by Eval::WithLexicals::Util::capture_list, called
+ # during parsing by the BEGIN block from capture_code.
+
$self->_eval_do(\$current_code, $self->lexicals, $to_eval);
+ $self->_run(\&Eval::WithLexicals::Cage::current_line);
+}
+
+sub _run {
+ my($self, $code) = @_;
+
my @ret;
my $ctx = $self->context;
if ($ctx eq 'list') {
- @ret = Eval::WithLexicals::Cage::current_line();
+ @ret = $code->();
} elsif ($ctx eq 'scalar') {
- $ret[0] = Eval::WithLexicals::Cage::current_line();
+ $ret[0] = $code->();
} else {
- Eval::WithLexicals::Cage::current_line();
+ $code->();
}
$self->lexicals({
%{$self->lexicals},
}
sub _eval_do {
- my ($self, $text_ref, $lexicals, $original) = @_;
+ my ($self, $text_ref, $lexical, $original) = @_;
local @INC = (sub {
if ($_[1] eq '/eval_do') {
open my $fh, '<', $text_ref;
use Eval::WithLexicals;
use Term::ReadLine;
use Data::Dumper;
+ use Getopt::Long;
+
+ GetOptions(
+ "plugin=s" => \my @plugins
+ );
$SIG{INT} = sub { warn "SIGINT\n" };
$Quotekeys = 0;
}
- my $eval = Eval::WithLexicals->new;
+ my $eval = @plugins
+ ? Eval::WithLexicals->with_plugins(@plugins)->new
+ : Eval::WithLexicals->new;
+
my $read = Term::ReadLine->new('Perl REPL');
while (1) {
my $line = $read->readline('re.pl$ ');
$eval->prelude(q{use warnings}); # only warnings, not strict.
+=head2 with_plugins
+
+ my $eval = Eval::WithLexicals->with_plugins("HintPersistence")->new;
+
+Construct a class with the given plugins. Plugins are roles located under
+a package name like C<Eval::WithLexicals::With*>.
+
+Current plugins are:
+
+=over 4
+
+=item * HintPersistence
+
+When enabled this will persist pragams and other compile hints between evals
+(for example the L<strict> and L<warnings> flags in effect). See
+L<Eval::WithLexicals::WithHintPersistence> for further details.
+
+=back
+
=head1 AUTHOR
Matt S. Trout <mst@shadowcat.co.uk>
--- /dev/null
+package Eval::WithLexicals::WithHintPersistence;
+use Moo::Role;
+use Sub::Quote;
+
+our $VERSION = '1.001000'; # 1.1.0
+$VERSION = eval $VERSION;
+
+# Used localised
+our($hints, %hints);
+
+has hints => (
+ is => 'rw',
+ default => quote_sub q{ {} },
+);
+
+has _first_eval => (
+ is => 'rw',
+ default => quote_sub q{ 1 },
+);
+
+around eval => sub {
+ my $orig = shift;
+ my($self) = @_;
+
+ local *Eval::WithLexicals::Cage::capture_hints;
+ local $Eval::WithLexicals::Cage::hints = { %{$self->hints} };
+
+ my @ret = $orig->(@_);
+
+ $self->hints({ Eval::WithLexicals::Cage::capture_hints() });
+
+ @ret;
+};
+
+# XXX: Sub::Quote::capture_unroll without 'my'
+use B();
+sub _capture_unroll_global {
+ my ($from, $captures, $indent) = @_;
+ join(
+ '',
+ map {
+ /^([\@\%\$])/
+ or die "capture key should start with \@, \% or \$: $_";
+ (' ' x $indent).qq{${_} = ${1}{${from}->{${\B::perlstring $_}}};\n};
+ } keys %$captures
+ );
+}
+
+sub setup_code {
+ my($self) = @_;
+ # Only run the prelude on the first eval, hints will be set after
+ # that.
+ if($self->_first_eval) {
+ $self->_first_eval(0);
+ return $self->prelude;
+ } else {
+ # Seems we can't use the technique of passing via @_ for code in a BEGIN
+ # block
+ return q[ BEGIN { ],
+ _capture_unroll_global('$Eval::WithLexicals::Cage::hints', $self->hints, 2),
+ q[ } ],
+ }
+};
+
+around capture_code => sub {
+ my $orig = shift;
+ my($self) = @_;
+
+ ( q{ sub Eval::WithLexicals::Cage::capture_hints {
+ no warnings 'closure';
+ my($hints, %hints);
+ BEGIN { $hints = $^H; %hints = %^H; }
+ return q{$^H} => \$hints, q{%^H} => \%hints;
+ } },
+ $orig->(@_) )
+};
+
+=head1 NAME
+
+Eval::WithLexicals::WithHintPersistence - Persist compile hints between evals
+
+=head1 SYNOPSIS
+
+ use Eval::WithLexicals;
+
+ my $eval = Eval::WithLexicals->with_plugins("HintPersistence")->new;
+
+=head1 DESCRIPTION
+
+Persist pragams and other compile hints between evals (for example the
+L<strict> and L<warnings> flags in effect).
+
+Saves and restores the C<$^H> and C<%^H> variables.
+
+=head1 METHODS
+
+=head2 hints
+
+ $eval->hints('$^H')
+
+Returns the internal hints hash, keys are C<$^H> and C<%^H> for the hint bits
+and hint hash respectively.
+
+=cut
+
+1;
--- /dev/null
+use strictures 1;
+# Find the hint value that 'use strictures 1' sets on this perl.
+my $strictures_hints;
+BEGIN { $strictures_hints = $^H }
+
+use Test::More;
+use Eval::WithLexicals;
+
+my $eval = Eval::WithLexicals->with_plugins("HintPersistence")->new(prelude => '');
+
+is_deeply(
+ [ $eval->eval('$x = 1') ],
+ [ 1 ],
+ 'Basic non-strict eval ok'
+);
+
+is_deeply(
+ $eval->lexicals, { },
+ 'Lexical not stored'
+);
+
+$eval->eval('use strictures 1');
+
+{
+ local $SIG{__WARN__} = sub { };
+
+ ok !eval { $eval->eval('$x') }, 'Unable to use undeclared variable';
+ like $@, qr/requires explicit package/, 'Correct message in $@';
+}
+
+is_deeply(
+ $eval->hints->{q{$^H}}, \$strictures_hints,
+ 'Hints are set per strictures'
+);
+
+is_deeply(
+ $eval->lexicals, { },
+ 'Lexical not stored'
+);
+
+# Assumption about perl internals: sort pragma will set a key in %^H.
+
+$eval->eval(q{ { use sort 'stable' } }),
+ok !exists $eval->hints->{q{%^H}}->{sort},
+ "Lexical pragma used below main scope not captured";
+
+$eval->eval(q{ use sort 'stable' }),
+ok exists $eval->hints->{q{%^H}}->{sort},
+ "Lexical pragma captured";
+
+done_testing;
projects / p5sagit/Eval-WithLexicals.git / commitdiff