From: David Leadbeater Date: Tue, 11 Jan 2011 21:19:38 +0000 (+0000) Subject: Add persistent hints X-Git-Tag: v1.002000~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FEval-WithLexicals.git;a=commitdiff_plain;h=8d732f3064bb88d682504f365ef1af62c6598b8c;hp=a6bd7aca656475de49bf3b20afceddffe2130060 Add persistent hints This means the $^H and %^H values are stored and restored along with the captured lexical variables. --- diff --git a/Changes b/Changes index b177418..b58be29 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,7 @@ - - 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) diff --git a/bin/tinyrepl b/bin/tinyrepl index 236b081..f9087ea 100755 --- a/bin/tinyrepl +++ b/bin/tinyrepl @@ -4,6 +4,11 @@ use strictures 1; use Eval::WithLexicals; use Term::ReadLine; use Data::Dumper; +use Getopt::Long; + +GetOptions( + "plugin=s" => \my @plugins +); $SIG{INT} = sub { warn "SIGINT\n" }; @@ -12,7 +17,10 @@ $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$ '); diff --git a/lib/Eval/WithLexicals.pm b/lib/Eval/WithLexicals.pm index fab265c..752de55 100644 --- a/lib/Eval/WithLexicals.pm +++ b/lib/Eval/WithLexicals.pm @@ -1,6 +1,7 @@ package Eval::WithLexicals; use Moo; +use Moo::Role (); use Sub::Quote; our $VERSION = '1.001000'; # 1.1.0 @@ -29,34 +30,64 @@ has prelude => ( 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}, @@ -79,7 +110,7 @@ sub _grab_captures { } 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; @@ -120,6 +151,11 @@ Eval::WithLexicals - pure perl eval with persistent lexical variables use Eval::WithLexicals; use Term::ReadLine; use Data::Dumper; + use Getopt::Long; + + GetOptions( + "plugin=s" => \my @plugins + ); $SIG{INT} = sub { warn "SIGINT\n" }; @@ -128,7 +164,10 @@ Eval::WithLexicals - pure perl eval with persistent lexical variables $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$ '); @@ -193,6 +232,25 @@ Code to run before evaling code. Loads L by default. $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. + +Current plugins are: + +=over 4 + +=item * HintPersistence + +When enabled this will persist pragams and other compile hints between evals +(for example the L and L flags in effect). See +L for further details. + +=back + =head1 AUTHOR Matt S. Trout diff --git a/lib/Eval/WithLexicals/WithHintPersistence.pm b/lib/Eval/WithLexicals/WithHintPersistence.pm new file mode 100644 index 0000000..e95a008 --- /dev/null +++ b/lib/Eval/WithLexicals/WithHintPersistence.pm @@ -0,0 +1,106 @@ +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 and L 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; diff --git a/t/hints.t b/t/hints.t new file mode 100644 index 0000000..62cecc8 --- /dev/null +++ b/t/hints.t @@ -0,0 +1,51 @@ +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;