Eval-Context-0.09.11000755000764000144 011341235317 13607 5ustar00nadimusers000000000000Eval-Context-0.09.11/README000444000764000144 30411341235317 14601 0ustar00nadimusers000000000000Context ======= 'Evalute perl code in a context wrapper' INSTALLATION ------------ To install this module type the following: perl Build.PL ./Build ./Build test ./Build install Eval-Context-0.09.11/Changes000444000764000144 645311341235317 15247 0ustar00nadimusers000000000000commit 7f4908f6a5582160bf581ff1dcbf3f65beafd5a5 Author: nadim khemir Date: Wed Feb 24 15:41:32 2010 +0100 CHANGED: removed -a from git status command commit 5ccf79dac10e525c3c3d398a33f2c2e496f97392 Author: nadim khemir Date: Wed Feb 24 12:03:43 2010 +0100 FIXED: typo in test FIXED: disabled perlcritic rule that does not allow camel case commit ebaff2a2e20f650d677a2a2bf3477c3734c5d1a8 Author: nadim khemir Date: Sun Dec 28 15:18:20 2008 +0100 ADDED: asciio diagram instead for dia diagram commit e029feed004b8c56e7379828168b443168a5476f Author: nadim khemir Date: Wed Dec 17 22:47:59 2008 +0100 CHANGED: changes file is automatically generated from git log, previous content was: 0.07 FIXED: test fails because of unexpectedly existing module XXX, changed to more improbable name 0.06 FIXED: test works with Opcode < 1.07 FIXED: SHARED variables in Safe more 0.05 CHANGED: replace POD::Spelling with Perl::Critic policy FIXED: missing dependency 0.04 CHANGED: moved start line closer to user code CHANGED: POD so ARGUMENTS and RETURN would be nicer FIXED: last percents coverage CHANGED: clarified some points in the documentation CHANGED: documented http://rt.cpan.org/Ticket/Display.html?id=31090 0.03 COMMENT: Major changes in this release CHANGED: default package based on Eval::Context::Run_xx ADDED: add caller's FILE and NAME to the evaluated code file name ADDED: automatic package cleanup (REMOVE_PACKAGE_AFTER_EVAL) ADDED: added INSTALL_VARIABLES ADDED: CLEAR_PERSISTENT ADDED: eval side persistent variable ADDED: SAFE 0.02 ADDED: INSTALL_SUBS commit 56cecfaf012c08eca1139683f020e73766d92d53 Author: nadim khemir Date: Wed Dec 17 22:45:17 2008 +0100 CHANGED: removed unnecessary test dependencies commit 2285e98794a066b69946718677aa9850388d1ef2 Author: nadim khemir Date: Wed Dec 17 22:10:46 2008 +0100 CHANGED: refactored code string to be evaluated CHANGED: tests for the new code string format CHANGED: Carp and die tests in Safe commit a39a7fc3f5bc2e716d8d3a8bea66758132f9df5b Author: nadim khemir Date: Tue Dec 16 00:06:15 2008 +0100 FIXED: RT #41674 t/005_eval.t fails (it assumes an english locale) commit 02383a58e78aec8d2da389974ee763bfc86bb514 Author: nadim khemir Date: Mon Dec 15 23:56:17 2008 +0100 FIXED: Perl::Critic errors commit cc932a1010dc98c054fe50c6dc02df980a9537d2 Author: nadim khemir Date: Mon Dec 15 23:40:37 2008 +0100 CHANGED: use git CHANGED: moved author tests to xt/author commit 51fb74a6b92551a4b2e32e9c4e0f0496f58b1f38 Author: nadim khemir Date: Mon Dec 15 23:04:52 2008 +0100 FIXED: test fails because of unexpectedly existing module XXX, changed to more improbable name commit aa502882a562217c9eb36319bc3fdc30cd6a6427 Author: nadim khemir Date: Thu Mar 6 17:41:29 2008 +0100 ADDED: files to version control Eval-Context-0.09.11/Todo.txt000444000764000144 310411341235317 15410 0ustar00nadimusers000000000000 Jump in the debugger from within the evaluated code Default to run in a safe Eval context shall not die but return an exception also catch warnings why can't we have package level variables in unsorted.pl why do we nee to use DTD per sub scope => see gpad dump should add line numbers to code EVAL => {} vs EVAL => "" stay is the default. INPUT_IS_SAFE => 1 http://perldoc.perl.org/perlmod.html#BEGIN%2c-CHECK%2c-INIT-and-END B::Concise, usin ops to find out if code uses eval, system, qx, unlink, ... chroot pbs the test code used to find out is certain constructs are used (system, ...) should run a self test to check if perl itself doesn't change the way ops are written use the module that gives the eval code in the error use the module that adds line and file to evaled code catch exception and let user check the object instead? $context->TryEval(...) ; $context->CaughtException() ? $context->RethrowException() : $context->GetResults() #variable in safe normal => ok shared => nok (access a package that safe chrooted persisten => ? eval_side persistent => ? # "Give me sugar baby" Ash. See Safe::Share for ideas about INSTALL_* functionality variables can be shared shared reference persistant my variables eval side sharing #Verbatim (scalar(definition) == 1) should have 2 arguments, second argument being 'VERBATIM' #package cleanup after eval to free memory only if it is a default package #use a random package by default #accept FILE and LINE in Eval call use it as the file name concatenated with the object's name Eval-Context-0.09.11/Build.PL000444000764000144 725511341235317 15251 0ustar00nadimusers000000000000 use strict ; use warnings ; use Module::Build; my %all_modules ; my @split_modules ; my @pm_files = qw( lib/Eval//Context.pm ); for(@pm_files) { $all_modules{$_} = $_ ; push @split_modules, $_ ; } sub GetVersionAndRevisionFrom { my ($file) = @_ ; my $version_from = File::Spec->catfile( split '/', $file ); my $version = Module::Build->version_from_file($version_from); if($ENV{'Eval_Context_USE_GIT_VERSION_FOR_DIST'}) { my $number_of_commits = `git log | grep -E 'commit [0-9a-f]{40}' | wc -l` ; chomp $number_of_commits ; if($number_of_commits) { #~ print "number of git revision $number_of_commits.\n" ; return("${version}.${number_of_commits}") ; } else { print "Couldn't get git revision, using version from '$file'!\n" ; return($version) ; } } else { return($version) ; } } my $code = <<'EOC'; use strict ; use warnings ; sub GetVersionAndRevisionFrom { my ($file) = @_ ; my $version_from = File::Spec->catfile( split '/', $file ); my $version = Module::Build->version_from_file($version_from); if($ENV{'Eval_Context_USE_GIT_VERSION_FOR_DIST'}) { my $number_of_commits = `git log | grep -E 'commit [0-9a-f]{40}' | wc -l` ; chomp $number_of_commits ; if($number_of_commits) { #print "number of git revision: $number_of_commits.\n" ; return("${version}.${number_of_commits}") ; } else { print "Couldn't get git revision, using version from '$file'!\n" ; return($version) ; } } else { return($version) ; } } sub ACTION_author_test { my $self = shift; local $self->{properties}{test_files} = 'xt/author/*.t' ; $self->SUPER::ACTION_test(); } sub ACTION_build { my $self = shift; if($ENV{'Eval_Context_USE_GIT_VERSION_FOR_DIST'}) { my ($version) = GetVersionAndRevisionFrom('lib/Eval//Context.pm') ; #~ print "Generating version module ($version)\n" ; open VERSION, '>', 'Version.pm' or die "can't generate Version module: $!\n" ; print VERSION <SUPER::ACTION_build(@_); } sub ACTION_dist { my $self = shift; if($ENV{'Eval_Context_USE_GIT_VERSION_FOR_DIST'}) { my $have_git = $self->do_system('git --version'); if($have_git) { print `git status`; if($self->do_system('git log > git_Changes')) { use File::Copy; move('git_Changes', 'Changes') ; } else { print "Couldn't get git log, 'Changes' will not be generated from git log!\n" ; } } else { print "git not found, 'Changes' will not be generated from git log!\n" ; } } #~ $self->ACTION_author_test() ; #~ $self->SUPER::ACTION_test() ; $self->SUPER::ACTION_dist(); }; EOC my $class = Module::Build->subclass(class => 'Eval::Context', code => $code) ; my $build = $class->new ( module_name => 'Eval::Context', dist_version => GetVersionAndRevisionFrom('lib/Eval/Context.pm'), license => 'perl', build_requires => { 'Text::Diff' => 0, 'Test::Block' => 0, 'Test::Exception' => 0, 'Test::NoWarnings' => 0, 'Test::Warn' => 0, 'Directory::Scratch::Structured' => 0, 'Test::Output' => 0, }, requires => { 'Readonly' => 0, 'Data::Compare' => 0, 'Sub::Exporter' => 0, 'Package::Generator' => 0, 'Data::TreeDumper' => 0, 'File::Slurp' => 0, 'Sub::Install' => 0, 'Symbol' => 0, 'Safe' => 2.16, 'Data::Dumper' => 0, 'version' => 0.50, }, pm_files => \%all_modules, autosplit => \@split_modules, dist_author => 'Khemir Nadim ibn Hamouda. ', dist_abstract => 'Evalute perl code in context wrapper ', ); $build->create_build_script; Eval-Context-0.09.11/Makefile.PL000444000764000144 23211341235317 15673 0ustar00nadimusers000000000000 use strict ; use warnings ; use Module::Build::Compat; Module::Build::Compat->run_build_pl(args => \@ARGV); Module::Build::Compat->write_makefile(); Eval-Context-0.09.11/META.yml000444000764000144 147711341235317 15226 0ustar00nadimusers000000000000--- abstract: "Evalute perl code in context wrapper\n" author: - 'Khemir Nadim ibn Hamouda. ' build_requires: Directory::Scratch::Structured: 0 Test::Block: 0 Test::Exception: 0 Test::NoWarnings: 0 Test::Output: 0 Test::Warn: 0 Text::Diff: 0 configure_requires: Module::Build: 0.36 generated_by: 'Module::Build version 0.3603' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Eval-Context provides: Eval::Context: file: lib/Eval/Context.pm version: 0.09 requires: Data::Compare: 0 Data::Dumper: 0 Data::TreeDumper: 0 File::Slurp: 0 Package::Generator: 0 Readonly: 0 Safe: 2.16 Sub::Exporter: 0 Sub::Install: 0 Symbol: 0 version: 0.5 resources: license: http://dev.perl.org/licenses/ version: v0.09.11 Eval-Context-0.09.11/MANIFEST000444000764000144 113311341235317 15073 0ustar00nadimusers000000000000Changes Build.PL Makefile.PL MANIFEST README META.yml README Todo.txt lib/Eval/Context.pm t/001_load.t t/004_new.t t/005_eval.t t/005_eval_no_NoWarnings.t t/006_install_subs.t t/007_cleanup.t t/008_variables.t t/009_persistent_variables.t t/010_shared_variables.t t/011_eval_side_persistent_variables.t t/012_safe.t t/013_safe_variables.t t/050_unit.t t/test_template xt/author/000_kwalitee.t xt/author/000_dependencies.t xt/author/000_distribution.t xt/author/000_fixme.t xt/author/000_strict.t xt/author/002_1_pod.t xt/author/002_2_pod_coverage.t xt/author/003_perl_critic.t xt/author/perlcriticrc Eval-Context-0.09.11/t000755000764000144 011341235317 14052 5ustar00nadimusers000000000000Eval-Context-0.09.11/t/005_eval.t000444000764000144 1527111341235317 15735 0ustar00nadimusers000000000000# test use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context ; { local $Plan = {'eval empty options' => 6} ; #~ NAME #~ PRE_CODE #~ POST_CODE #~ PACKAGE #~ DISPLAY_SOURCE_IN_CONTEXT #~ FILE LINE my $context = new Eval::Context() ; lives_ok { $context->eval(CODE => '') ; } 'empty code' ; lives_ok { $context->eval(CODE => '', PACKAGE => 'A') ; } 'empty code, package' ; lives_ok { $context->eval(CODE => '', PACKAGE => undef) ; } 'anonymous package from bad package' ; throws_ok { $context->eval(CODE => 'die', PACKAGE => undef) ; } qr/Anonymous/, 'anonymous package from bad package' ; lives_ok { $context->eval(CODE => '', PACKAGE => 'A', PRE_CODE => "use strict;\nuse warnings;\n") ; }'empty code, pre code' ; lives_ok { $context->eval(CODE => '', PACKAGE => 'A', POST_CODE => "print qq{post code\\n};\n",) ; } 'empty code, post code' ; } { local $Plan = {'package' => 3} ; { my $context = new Eval::Context(PACKAGE => 'HIP') ; my $package = $context->eval(CODE => '__PACKAGE__ ;', PACKAGE => 'HOP') ; is($package, 'HOP', 'package override') ; } { my $context = new Eval::Context() ; my $package = $context->eval(CODE => '__PACKAGE__ ;') ; like ($package, qr/Eval::Context::Run_\d+/, 'default package name') ; } { my $context = new Eval::Context() ; my $package = $context->eval(CODE => '__PACKAGE__ ;', PACKAGE => '') ; like ($package, qr/Eval::Context::Run_\d+/, 'empty package name') ; } } { local $Plan = {'eval evaluation context' => 16} ; my $context = new Eval::Context() ; throws_ok { $context->eval(CODE => 'die "void context" unless defined wantarray;', PACKAGE => 'A', PRE_CODE => "use strict;\nuse warnings;\nprint qq{pre code\\n} ;\n") ; } qr/void context/, 'void context' ; lives_ok { my $value = $context->eval(CODE => '7', PACKAGE => 'A', PRE_CODE => "use strict;\nuse warnings;\nprint qq{pre code\\n} ;\n") ; is($value, 7, 'eval returned last value') ; } 'returned scalar' ; lives_ok { my $value = $context->eval(CODE => "my \@l = (7,8) ;", PACKAGE => 'A', PRE_CODE => "use strict;\nuse warnings;\nprint qq{pre code\\n} ;\n") ; is($value, 2, 'eval returned last value') ; } 'returned list, scalar context' ; #~ # see 005_eval_no_NoWarnings for the test below #~ lives_ok #~ { #~ my $value = $context->eval(CODE => "(7,8) ;", PACKAGE => 'A', PRE_CODE => "use strict;\nuse warnings;\nprint qq{pre code\\n} ;\n") ; #~ is($value, 8, 'eval returned last value') ; #~ } 'returned list, scalar context' ; lives_ok { my $value = $context->eval(CODE => "my \@l = (7,8) ;", PACKAGE => 'A') ; is($value, 2, 'eval returned last value') ; } 'returned list, scalar context' ; lives_ok { my @values = $context->eval(CODE => '(7,8) ;', PACKAGE => 'A', PRE_CODE => "use strict;\nuse warnings;\nprint qq{pre code\\n} ;\n") ; is_deeply(\@values, [7,8], 'eval returned list') ; } 'returned list, list context' ; # use PERL_EVAL_CONTEXT lives_ok { my $value = $context->eval ( CODE => "wantarray ;", PACKAGE => 'A', PRE_CODE => "use strict;\nuse warnings;\nprint qq{pre code\\n} ;\n", PERL_EVAL_CONTEXT => undef # force void context ) ; is($value, undef, 'void context') ; } 'force void context' ; lives_ok { my $value = $context->eval ( CODE => "wantarray ;", PACKAGE => 'A', PRE_CODE => "use strict;\nuse warnings;\nprint qq{pre code\\n} ;\n", PERL_EVAL_CONTEXT => 1 # force list context ) ; is($value, 1, 'list context') ; } 'force list context' ; lives_ok { my @values = $context->eval ( CODE => "wantarray ;", PACKAGE => 'A', PRE_CODE => "use strict;\nuse warnings;\nprint qq{pre code\\n} ;\n", PERL_EVAL_CONTEXT => '' # force scalar context ) ; is(scalar(@values), 1, 'scalar context') ; is($values[0], '', 'scalar context') ; } 'force scalar context' ; } { local $Plan = {'eval' => 5} ; #~ NAME, PRE_CODE, POST_CODE my $context = new Eval::Context ( NAME => "THE_NAME", PRE_CODE => "use strict;\nuse warnings;\nprint qq{pre code\n} ;", POST_CODE => "die qq{POST_CODE}", ) ; throws_ok { $context->eval(CODE => '$x = 3 ;') ; }qr/Global symbol "\$x" requires explicit package name/, 'not strict code' ; throws_ok { $context->eval(CODE => '') ; }qr/POST_CODE at 'THE_NAME_called_at_t_005_eval.t:\d+'/, 'POST_CODE and NAME' ; #~ PACKAGE lives_ok { $context->eval(CODE => "sub GetVariable\n{return 117 ;}\n", PACKAGE => 'TEST_PACKAGE', POST_CODE => '', REMOVE_PACKAGE_AFTER_EVAL => 0) ; } "post code die overridden" ; is(TEST_PACKAGE::GetVariable(), 117, 'PACKAGE OK') ; #~ DISPLAY_SOURCE_IN_CONTEXT, FILE, LINE use Test::Output; sub writer { $context->eval ( DISPLAY_SOURCE_IN_CONTEXT => 1, FILE => 'TEST_FILE', LINE => 'TEST_LINE', PACKAGE => 'TEST_PACKAGE', PRE_CODE => '# test pre code', CODE => '# test code', POST_CODE => '# test post code' ) ; } stdout_is(\&writer,< 3} ; my $context = new Eval::Context() ; use Directory::Scratch::Structured qw(create_structured_tree piggyback_directory_scratch) ; my %tree_structure = ( file_0 => ['print "hi\n"; 7 ;']) ; my $temporary_directory = create_structured_tree(%tree_structure) ; my $base = $temporary_directory->base() ; lives_ok { is($context->eval(CODE_FROM_FILE => "$base/file_0"), 7, 'value from file') ; } 'code from file' ; eval { $context->eval(CODE_FROM_FILE => '') ; }; ok($!{ENOENT}, 'unexisting file' ); } { local $Plan = {'die' => 5} ; my $context = new Eval::Context() ; throws_ok { $context->eval(CODE_FROM_FILE => '', CODE => '') ; } qr/Option 'CODE' and 'CODE_FROM_FILE' can't coexist/, 'CODE and CODE_FROM_FILE' ; throws_ok { $context->eval(CODE_FROM_FILE => undef) ; } qr/Invalid Option 'CODE'/, 'CODE_FROM_FILE undef' ; throws_ok { $context->eval(CODE => undef) ; } qr/Invalid Option 'CODE'/, 'CODE undef' ; throws_ok { my $value = $context->eval ( CODE => "die 'force list context' ;", PERL_EVAL_CONTEXT => 1 # force list context ) ; } qr/force list context/, 'die in force list context' ; throws_ok { my @values = $context->eval ( CODE => "die 'force scalar context' ;", PERL_EVAL_CONTEXT => '' # force scalar context ) ; } qr/force scalar context/, 'die in force scalar context' ; } Eval-Context-0.09.11/t/050_unit.t000444000764000144 107411341235317 15741 0ustar00nadimusers000000000000 use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context ; { local $Plan = {'CanonizeName' => 3} ; throws_ok { Eval::Context::CanonizeName() ; } qr/CanonizeName called with undefined argument/, 'invalid input' ; my $uncanonized = '1/;[-|-(_ ' ; my $canonized = Eval::Context::CanonizeName($uncanonized) ; is($canonized, '1_________', 'canonized') ; is(length($canonized), length($uncanonized), 'right length') ; } Eval-Context-0.09.11/t/test_template000444000764000144 217611341235317 17012 0ustar00nadimusers000000000000# test use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context ; { local $Plan = {'' => } ; is(result, expected, "message") ; } =comment { local $Plan = {'' => } ; is(result, expected, 'message') ; throws_ok { } qr//, '' ; lives_ok { } '' ; like(result, qr//, '') ; warning_like { } qr//i, ''; warnings_like { } [ qr//i, qr//i, ] ''; is_deeply ( generated, [], '' ) ; use Directory::Scratch ; my $temp = Directory::Scratch->new(); my $dir = $temp->mkdir('foo/bar'); my $file = $temp->touch('foo/bar/baz', qw(This is a file with lots of lines)); use Directory::Scratch::Structured qw(create_structured_tree piggyback_directory_scratch) ; my %tree_structure = ( file_0 => [] , dir_1 => { subdir_1 =>{}, file_1 =>[], file_a => [], }, ) ; my $temporary_directory = create_structured_tree(%tree_structure) ; $base = $temporary_directory->base() ; my $scratch = Directory::Scratch->new; $scratch->create_structured_tree(%tree_structure) ; } =cut Eval-Context-0.09.11/t/013_safe_variables.t000444000764000144 500611341235317 17726 0ustar00nadimusers000000000000# test package Eval::Context ; use strict ; use warnings ; use Data::TreeDumper ; use Test::More ; use Data::Dumper ; #---------------------------------------------------------- package some_object ; use strict ; use warnings ; sub new {bless { VALUE => $_[1] }, $_[0];} sub GetValue {$_[0]->{VALUE} ;} sub AddOne{$_[0]->{VALUE} += 1 ;} sub GetDump {Data::Dumper->Dump([$_[0]]) ;} #---------------------------------------------------------- package main ; use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; #~ use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context 'constants' ; { local $Plan = {'SAFE and variables from caller side' => 3} ; my $context = new Eval::Context() ; my $normal = $context->eval ( INSTALL_VARIABLES => [ ['$normal', 'normal'] ], SAFE =>{}, CODE => '$normal', ) ; is($normal, 'normal', 'normal variable available in safe') or diag DumpTree $context ; #--------------------------------------------- $context->eval ( INSTALL_VARIABLES => [ ['$persistent', 'garbage', $Eval::Context::PERSISTENT ] ], SAFE =>{}, CODE => '$persistent = q{persistent} ;', ) ; my $persistent = $context->eval ( INSTALL_VARIABLES => [ ['$persistent', $Eval::Context::USE, $Eval::Context::PERSISTENT ] ], SAFE =>{}, CODE => '$persistent ;', ) ; is($persistent, 'persistent', 'persistent variable available in safe') or diag DumpTree $context ; #--------------------------------------------- my $shared = 'eval_side_value' ; $context->eval ( INSTALL_VARIABLES => [ ['$shared', \$shared, $Eval::Context::SHARED ] ], SAFE =>{}, CODE => '$$shared = q{shared} ;', ) ; is($shared, 'shared', 'shared variable available in safe') or diag DumpTree $context ; } { local $Plan = {'SAFE and eval side persistent variables ' => 1} ; my $context = new Eval::Context ( EVAL_SIDE_PERSISTENT_VARIABLES => { CATEGORY => 'TEST', SAVE => { NAME => 'SavePersistent', VALIDATOR => sub { my ($self, $name, $value, $package) = @_ ; }, }, GET => { NAME => 'GetPersistent', VALIDATOR => sub {} }, }, ) ; $context->eval ( SAFE =>{}, CODE => <<'EOC' , my $variable = 24 ; SavePersistent('$variable', $variable) ; EOC ) ; my $output = $context->eval ( SAFE =>{}, CODE => <<'EOC' , my $variable = GetPersistent('$variable') ; EOC ) ; is($output, 24, 'eval side persistent variable available in safe') or diag DumpTree $context ; } Eval-Context-0.09.11/t/004_new.t000444000764000144 576311341235317 15563 0ustar00nadimusers000000000000 use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context ; { local $Plan = {'new arguments' => 7} ; lives_ok { my @parameters = map {$_ => 1} qw( NAME PRE_CODE POST_CODE PERL_EVAL_CONTEXT PACKAGE DISPLAY_SOURCE_IN_CONTEXT FILE LINE ) ; push @parameters, 'INTERACTION', {} ; my $context = new Eval::Context(@parameters) ; } 'accepts all defined arguments' ; lives_ok { my $context = new Eval::Context(NAME => '') ; $context->eval(CODE => '') ; is($context->{NAME}, 'Anonymous eval context', 'empty name is makes object anonymous') ; } 'empty name' ; lives_ok { my $context = new Eval::Context(NAME => undef) ; $context->eval(CODE => '') ; is($context->{NAME}, 'Anonymous eval context', 'undefined name is makes object anonymous') ; } 'undefined name' ; throws_ok { my $context = new Eval::Context(1) ; } qr/Invalid number of argument/, 'invalid number of parameters' ; throws_ok { my $context = new Eval::Context(SOMETHING_UNEXPECTED => 1) ; } qr/Invalid Option 'SOMETHING_UNEXPECTED'/, 'invalid parameter' ; } { local $Plan = {'new sub subroutines' => 11} ; # check the subroutines and get the needed code coverage my $object = {NAME => 'test', INTERACTION => {}} ; Eval::Context::SetInteractionDefault($object) ; lives_ok { Eval::Context::CheckOptionNames($object, {FILE => 1, LINE => 1}) ; } 'accepts a hash ref as valid options definition' ; lives_ok { Eval::Context::CheckOptionNames($object, [qw(FILE LINE)]) ; } 'accepts an array ref as valid options definition' ; throws_ok { Eval::Context::CheckOptionNames($object, '') ; #doesn't matter what is passed as argument } qr/Invalid 'valid_options' definition/, 'invalid option definition' ; throws_ok { Eval::Context::CheckOptionNames($object, [qw(FILE LINE)], FILE => 1) ; }qr/Incomplete option FILE::LINE/, 'missing LINE' ; throws_ok { Eval::Context::CheckOptionNames($object, [qw(FILE LINE)], LINE => 1) ; } qr/Incomplete option FILE::LINE/, 'missing FILE' ; #------------------------------------------------------------------- my $interaction = {INTERACTION => {}} ; Eval::Context::SetInteractionDefault($interaction) ; is(defined $interaction->{INTERACTION}{INFO}, 1, 'interaction INFO defined') ; is(defined $interaction->{INTERACTION}{WARN}, 1, 'interaction WARN defined') ; is(defined $interaction->{INTERACTION}{DIE}, 1, 'interaction DIE defined') ; #------------------------------------------------------------------- my $the_sub = sub{} ; $interaction = { INTERACTION => { INFO => $the_sub, WARN => $the_sub, DIE => $the_sub, } } ; Eval::Context::SetInteractionDefault($interaction) ; is($interaction->{INTERACTION}{INFO}, $the_sub, 'interaction INFO unchanged') ; is($interaction->{INTERACTION}{WARN}, $the_sub, 'interaction WARN unchanged') ; is($interaction->{INTERACTION}{DIE}, $the_sub, 'interaction DIE unchanged') ; } Eval-Context-0.09.11/t/010_shared_variables.t000444000764000144 1335211341235317 20276 0ustar00nadimusers000000000000# test package Eval::Context ; use strict ; use warnings ; use Data::TreeDumper ; use Test::More ; use Data::Dumper ; #---------------------------------------------------------- package some_object ; use strict ; use warnings ; sub new {bless { VALUE => $_[1] }, $_[0];} sub GetValue {$_[0]->{VALUE} ;} sub AddOne{$_[0]->{VALUE} += 1 ;} sub GetDump {Data::Dumper->Dump([$_[0]]) ;} #---------------------------------------------------------- package main ; use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context 'constants' ; use constant SETUP => 0 ; use constant CODE => 1 ; use constant EXPECTED_RESULT => 2 ; { local $Plan = {'SHARED' => 16} ; # check PERSISTENT or SHARED is valid my $scalar_caller_side = 42 ; my $scalar_caller_side_reference = $scalar_caller_side ; my $string_caller_side = 'a string' ; my $string_caller_side_reference = $string_caller_side ; my %hash_caller_side = (A => 1, B => 2) ; my %hash_caller_side_reference = %hash_caller_side ; my @array_caller_side = ('A', 'B') ; my @array_caller_side_reference = @array_caller_side ; my $object = new some_object(5) ; my $object_dump = $object->GetDump() ; my $object_original_value = $object->GetValue() ; my $context = new Eval::Context() ; for my $test ( # SETUP CODE EXPECTED RESULT [ [ '$scalar' , \$string_caller_side, $Eval::Context::SHARED], "\$\$scalar ;\n" , '$output, $string_caller_side' ], [ [ '$scalar' , undef, $Eval::Context::SHARED], "\$\$scalar .= '*' ;\n", '$output, $string_caller_side_reference . "*"' ], [ [ '$scalar' , undef, $Eval::Context::SHARED], '' , '$string_caller_side, $string_caller_side_reference . "*"' ], [ [ '$scalar' , undef, $Eval::Context::SHARED], "\$\$scalar;\n" , '$output, $string_caller_side' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$hash' , \%hash_caller_side, $Eval::Context::SHARED] , "\$hash->{B} ;\n" , '$output , $hash_caller_side{B}' ], [ [ '$hash' , undef, $Eval::Context::SHARED], "\$hash->{B}++ ;\n my \$r = \$hash->{B} + 1;\n\$r ;\n" , '$output , $hash_caller_side{B} + 1' ], [ [ '$hash' , undef, $Eval::Context::SHARED], '', '$hash_caller_side{B} , $hash_caller_side_reference{B} + 1' ], [ [ '$hash' , undef, $Eval::Context::SHARED] , "\$hash->{B} ;\n", '$output, $hash_caller_side{B}' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$array' , \@array_caller_side, $Eval::Context::SHARED] , "\$array->[1] ;\n" , '$output , $array_caller_side[1]' ], [ [ '$array' , undef, $Eval::Context::SHARED] , "\$array->[1] .= 'X' ;\n my \$r = \$array->[1] . '*';\n\$r ;\n" , '$output , $array_caller_side[1] . "*"' ], [ [ '$array' , undef, $Eval::Context::SHARED] , '', '$array_caller_side[1], $array_caller_side_reference[1] . "X"' ], [ [ '$array' , undef, $Eval::Context::SHARED] , "\$array->[1] ;\n", '$output, $array_caller_side[1]' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$object' , $object, $Eval::Context::SHARED] , "\$object->GetValue() ;\n" , '$output , $object->GetValue()' ], [ [ '$object' , undef, $Eval::Context::SHARED] , "\$object->AddOne() ;\n\$object->GetValue() ;\n", '$output , $object->GetValue()' ], [ [ '$object' , undef, $Eval::Context::SHARED] , '' , ' $object->GetValue(), $object_original_value + 1' ], [ [ '$object' , undef, $Eval::Context::SHARED] , "\$object->GetDump() ;\n" , '$output, $object->GetDump()' ], #~ #--------------------------------------------------------------------------------------------------------------------------------------- ) { my $output = $context->eval ( INSTALL_VARIABLES => [$test->[SETUP]], CODE => $test->[CODE], ) ; eval qq~ is($test->[EXPECTED_RESULT], 'eval side only') or diag "latest code:\n\$context->{LATEST_CODE}\n" ~ ; die $@ if $@ ; } } { local $Plan = {'SHARED variable must exist' => 1} ; my $context = new Eval::Context() ; throws_ok { my $output = $context->eval(CODE => 'boom!', INSTALL_VARIABLES => [[ '$variable' , undef, $Eval::Context::SHARED]]) ; } qr/Nothing previously shared to '\$variable' /, 'SHARED variable must exist' ; } { local $Plan = {'divers tests' => 2} ; # add test so code to be evaluated is dumped on error my $scalar = 42 ; my $context = new Eval::Context() ; throws_ok { my $output = $context->eval(CODE => 'boom!', INSTALL_VARIABLES => [[ '$variable' , $scalar, $Eval::Context::SHARED]]) ; } qr/Need a reference to share from for '\$variable'/, 'can only share references' ; throws_ok { my $output = $context->eval(CODE => 'boom!', INSTALL_VARIABLES => [[ '$variable' , \$scalar, 111]]) ; } qr/Variable '\$variable' type must be SHARED or PERSISTENT/, 'SHARED or PERSISTENT' ; } { local $Plan = {'SHARE vs PERSISTENT' => 1} ; my $object = new some_object(5) ; my $context = new Eval::Context() ; $context->eval ( CODE => '', INSTALL_VARIABLES => [[ '$object' , $object, $Eval::Context::PERSISTENT] ], ) ; throws_ok { $context->eval ( CODE => '', INSTALL_VARIABLES => [[ '$object' , $object, $Eval::Context::SHARED] ], ) ; } qr/'\$object' can't be SHARED, already PERSISTENT/, 'can not have persistent and shared' ; } Eval-Context-0.09.11/t/011_eval_side_persistent_variables.t000444000764000144 1613711341235317 23250 0ustar00nadimusers000000000000# test package Eval::Context ; use strict ; use warnings ; use Data::TreeDumper ; use Test::More ; use Data::Dumper ; #---------------------------------------------------------- package some_object ; use strict ; use warnings ; sub new {bless { VALUE => $_[1] }, $_[0];} sub GetValue {$_[0]->{VALUE} ;} sub AddOne{$_[0]->{VALUE} += 1 ;} sub GetDump {Data::Dumper->Dump([$_[0]]) ;} #---------------------------------------------------------- package main ; use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context 'constants' ; { local $Plan = {'EVAL SIDE PERSISTENCE' => 5} ; my $context = new Eval::Context ( EVAL_SIDE_PERSISTENT_VARIABLES => { CATEGORY => 'TEST', SAVE => { NAME => 'SavePersistent', VALIDATOR => sub { my ($self, $name, $value, $package) = @_ ; }, }, GET => { NAME => 'GetPersistent', VALIDATOR => sub {} }, }, ) ; $context->eval ( CODE => <<'EOC' , my $variable = 24 ; SavePersistent('$variable', $variable) ; EOC ) ; my $output = $context->eval ( CODE => <<'EOC' , my $variable = GetPersistent('$variable') ; EOC ) ; is($output, 24) or diag DumpTree $context ; # test with reference and object my $caller_side_object = new some_object(5) ; my $caller_side_reference = {A => 1} ; $context->eval ( INSTALL_VARIABLES => [ ['$caller_side_object', $caller_side_object] , ['$caller_side_reference', $caller_side_reference] , ], CODE => <<'EOC' , SavePersistent ( '$reference' => $caller_side_reference, '$object' => $caller_side_object ) ; EOC ) ; my ($reference, $object) = $context->eval ( CODE => <<'EOC' , GetPersistent('$reference','$object') ; EOC ) ; is_deeply($reference, $caller_side_reference, 'reference made persistent OK') ; is_deeply($object, $caller_side_object, 'object made persistent OK') ; isa_ok($object, ref($caller_side_object), 'object in right class') ; throws_ok { my $output = $context->eval ( CODE => <<'EOC' , SavePersistent('variable', 1, 2) ; EOC ) ; } qr/eval-side persistence handler got unexpected number of arguments/, 'wrong number of arguments' ; } { local $Plan = {'invalid input to EVAL_SIDE_PERSISTENT_VARIABLES' => 6} ; throws_ok { my $context = new Eval::Context ( EVAL_SIDE_PERSISTENT_VARIABLES => { GET => { NAME => 'GET', VALIDATOR => sub {} }, }, ) ; $context->eval(CODE => "1 ;\n") ; } qr/'EVAL_SIDE_PERSISTENT_VARIABLES' missing handler definition/, 'invalid input, handler missing' ; throws_ok { my $context = new Eval::Context ( EVAL_SIDE_PERSISTENT_VARIABLES => { SAVE => { NAME => '', VALIDATOR => sub {} }, GET => { NAME => 'NAME', VALIDATOR => sub {} }, }, ) ; $context->eval(CODE => "1 ;\n") ; } qr/'EVAL_SIDE_PERSISTENT_VARIABLES' invalid definition/, 'invalid input, name is empty' ; throws_ok { my $context = new Eval::Context ( EVAL_SIDE_PERSISTENT_VARIABLES => { SAVE => { NAME => [], VALIDATOR => sub {} }, GET => { NAME => 'NAME', VALIDATOR => sub {} }, }, ) ; $context->eval(CODE => "1 ;\n") ; } qr/'EVAL_SIDE_PERSISTENT_VARIABLES' invalid definition/, 'invalid input, name is not a string' ; throws_ok { my $context = new Eval::Context ( EVAL_SIDE_PERSISTENT_VARIABLES => { SAVE => { NAME => 'SAVE', }, GET => { NAME => 'GET', VALIDATOR => sub {} }, }, ) ; $context->eval(CODE => "1 ;\n") ; } qr/'EVAL_SIDE_PERSISTENT_VARIABLES' invalid definition/, 'invalid input, validator is missing' ; throws_ok { my $context = new Eval::Context ( EVAL_SIDE_PERSISTENT_VARIABLES => { SAVE => { NAME => 'SAVE', VALIDATOR => 1 , }, GET => { NAME => 'GET', VALIDATOR => sub {} }, }, ) ; $context->eval(CODE => "1 ;\n") ; } qr/'EVAL_SIDE_PERSISTENT_VARIABLES' invalid definition/, 'invalid input, validator is not a sub' ; throws_ok { my $context = new Eval::Context(EVAL_SIDE_PERSISTENT_VARIABLES => []) ; $context->eval(CODE => "1 ;\n") ; } qr/'EVAL_SIDE_PERSISTENT_VARIABLES' isn't a hash reference/, 'invalid input EVAL_SIDE_PERSISTENT_VARIABLES' ; } { local $Plan = {'handlers differently named' => 1} ; throws_ok { my $context = new Eval::Context ( PACKAGE => 'ABC', REMOVE_PACKAGE_AFTER_EVAL => 0, EVAL_SIDE_PERSISTENT_VARIABLES => { CATEGORY => 'TEST', SAVE => { NAME => 'SAME_NAME', VALIDATOR => sub {} }, GET => { NAME => 'SAME_NAME', VALIDATOR => sub {} }, }, ) ; $context->eval(CODE => "1 ;\n") ; } qr/eval-side persistence handlers have the same name/, 'handlers differently named' ; } { local $Plan = {'handlers automatically removed' => 2} ; my $context = new Eval::Context ( PACKAGE => 'ABC', REMOVE_PACKAGE_AFTER_EVAL => 0, EVAL_SIDE_PERSISTENT_VARIABLES => { CATEGORY => 'TEST', SAVE => { NAME => 'SavePersistent', VALIDATOR => sub { my ($self, $name, $value, $package) = @_ ; #~ $self->DIE ; }, }, GET => { NAME => 'GetPersistent', VALIDATOR => sub {} }, }, ) ; $context->eval ( CODE => <<'EOC' , my $variable = 24 ; SavePersistent('$variable', $variable) ; EOC ) ; throws_ok { $context->eval ( EVAL_SIDE_PERSISTENT_VARIABLES => undef, CODE => 'my $variable = GetPersistent("variable") ;', ) ; } qr/No Persistence allowed on eval-side in package 'ABC'/, 'handlers automatically removed' ; throws_ok { $context->eval ( EVAL_SIDE_PERSISTENT_VARIABLES => undef, CODE => 'SavePersistent("variable", 42) ;', ) ; } qr/No Persistence allowed on eval-side in package 'ABC'/, 'handlers automatically removed' ; } { local $Plan = {'validators' => 2} ; my $context = new Eval::Context ( PACKAGE => 'ABC', REMOVE_PACKAGE_AFTER_EVAL => 0, EVAL_SIDE_PERSISTENT_VARIABLES => { CATEGORY => 'TEST', SAVE => { NAME => 'SavePersistent', VALIDATOR => sub { my ($self, $name, $value) = @_ ; $self->{INTERACTION}{DIE}-> ( $self, "SavePersistent: name '$name' doesn't start with A!" ) unless $name =~ /^A/ ; }, }, GET => { NAME => 'GetPersistent', VALIDATOR => sub { my ($self, $name, $value) = @_ ; $self->{INTERACTION}{DIE}-> ( $self, "GetPersistent: name '$name' doesn't start with A!" ) unless $name =~ /^A/ ; }, }, }, ) ; throws_ok { $context->eval ( CODE => <<'EOC' , my $variable = 24 ; SavePersistent('A', 1) ; SavePersistent('B', 2) ; EOC ) ; } qr/SavePersistent: name 'B' doesn't start with A/, 'Save validator' ; throws_ok { $context->eval ( CODE => <<'EOC' , GetPersistent('A') ; GetPersistent('C') ; EOC ) ; } qr/GetPersistent: name 'C' doesn't start with A/, 'Get validator' ; } Eval-Context-0.09.11/t/008_variables.t000444000764000144 1521011341235317 16752 0ustar00nadimusers000000000000# test package Eval::Context ; use strict ; use warnings ; use Data::TreeDumper ; use Test::More ; use Data::Dumper ; #---------------------------------------------------------- package some_object ; use strict ; use warnings ; sub new {bless { VALUE => $_[1] }, $_[0];} sub GetValue {$_[0]->{VALUE} ;} sub AddOne{$_[0]->{VALUE} += 1 ;} sub GetDump {Data::Dumper->Dump([$_[0]]) ;} #---------------------------------------------------------- package main ; use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context ; use constant SETUP => 0 ; use constant CODE => 1 ; use constant EXPECTED_RESULT => 2 ; { local $Plan = {'divers tests' => 1} ; # add test so code to be evaluated is dumped on error my $context = new Eval::Context() ; throws_ok { my $output = $context->eval(CODE => 'boom!', INSTALL_VARIABLES => []) ; } qr/#end of context/, 'context displayed and error caught' ; } { local $Plan = {'eval side only' => 29} ; my $scalar_caller_side = 42 ; my $scalar_caller_side_reference = $scalar_caller_side ; my $string_caller_side = 'a string' ; my $string_caller_side_reference = $string_caller_side ; my %hash_caller_side = (A => 1, B => 2) ; my %hash_caller_side_reference = %hash_caller_side ; my @array_caller_side = ('A', 'B') ; my @array_caller_side_reference = @array_caller_side ; my $object = new some_object(5) ; my $object_dump = $object->GetDump() ; my $context = new Eval::Context() ; # test the variables are made available on the eval side # tests to verify nothing is changed from the eval side for my $test ( # SETUP CODE EXPECTED RESULT [ [ '$variable', 42] , '$variable ;' , '$output , 42' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$scalar' , $string_caller_side ] , '$scalar ;' , '$output , $string_caller_side' ], [ [ '$scalar' , $string_caller_side ] , "\$scalar .= '*' ;\n" , '$output , $string_caller_side . "*"' ], [ [ '$scalar' , $string_caller_side ] , "\$scalar .= '*' ;\n" , '$string_caller_side , $string_caller_side_reference' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$scalar' , $scalar_caller_side ] , '$scalar' , '$output , $scalar_caller_side' ], [ [ '$scalar' , $scalar_caller_side ] , "\$scalar += 2 ;\n" , '$output , $scalar_caller_side + 2' ], [ [ '$scalar' , $scalar_caller_side ] , "\$scalar += 2 ;\n" , '$scalar_caller_side , $scalar_caller_side_reference' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$hash' , \%hash_caller_side ] , "\$hash->{B} ;\n" , '$output , $hash_caller_side{B}' ], [ [ '$hash' , \%hash_caller_side ] , "my \$r = \$hash->{B} + 1;\n\$r ;\n" , '$output , $hash_caller_side{B} + 1' ], [ [ '$hash' , \%hash_caller_side ] , "my \$r = \$hash->{B} + 1;\n \$r ;\n" , '$hash_caller_side{B} , $hash_caller_side_reference{B}' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '%hash' , \%hash_caller_side ] , "\$hash{B} ;\n" , '$output , $hash_caller_side{B}' ], [ [ '%hash' , \%hash_caller_side ] , "my \$r = \$hash{B} + 1;\n\$r ;\n" , '$output , $hash_caller_side{B} + 1' ], [ [ '%hash' , \%hash_caller_side ] , "my \$r = \$hash{B} + 1;\n \$r ;\n" , '$hash_caller_side{B} , $hash_caller_side_reference{B}' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$array' , \@array_caller_side ] , "\$array->[1] ;\n" , '$output , $array_caller_side[1]' ], [ [ '$array' , \@array_caller_side ] , "my \$r = \$array->[1] . '*';\n\$r ;\n" , '$output , $array_caller_side[1] . "*"' ], [ [ '$array' , \@array_caller_side ] , "my \$r = \$array->[1] . '*';\n\$r ;\n" , '$array_caller_side[1] , $array_caller_side_reference[1]' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '@array' , \@array_caller_side ] , "\$array[1] ;\n" , '$output , $array_caller_side[1]' ], [ [ '@array' , \@array_caller_side ] , "my \$r = \$array[1] . '*';\n\$r ;\n " , '$output , $array_caller_side[1] . "*"' ], [ [ '@array' , \@array_caller_side ] , "my \$r = \$array[1] . '*';\n\$r ;\n " , '$array_caller_side[1] , $array_caller_side_reference[1]' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$object' , $object ] , "\$object->GetValue() ;\n" , '$output , $object->GetValue()' ], [ [ '$object' , $object ] , "\$object->AddOne() ;\n" , '$output , $object->GetValue() + 1' ], [ [ '$object' , $object ] , "\$object->AddOne() ;\n" , '$object->GetDump() , $object_dump' ], #--------------------------------------------------------------------------------------------------------------------------------------- ) { my $output = $context->eval(CODE => $test->[CODE], INSTALL_VARIABLES => [$test->[SETUP]]) ; eval qq~ is($test->[EXPECTED_RESULT], 'eval side only') or diag "latest code:\n\$context->{LATEST_CODE}\n" ~ ; die $@ if $@ ; } throws_ok { my $output = $context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['my $variable = 42 ;'] ]) ; } qr/Invalid variable definition/, 'no verbatim code' ; throws_ok { my $output = $context->eval(CODE => '', INSTALL_VARIABLES => [ ['*variable', 42] ]) ; } qr/Invalid variable type for '\*variable'/, 'unsupported type' ; lives_ok { $context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['$variable', 42] ]) ; } 'void context' ; lives_ok { my $output = $context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['$variable', 42] ]) ; is($output, 42, 'right value in scalar context') ; } 'scalar context' ; lives_ok { my @output = $context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['$variable', 42] ]) ; is_deeply(\@output, [42], 'right value in array context') ; } 'array context' ; } Eval-Context-0.09.11/t/009_persistent_variables.t000444000764000144 2614711341235317 21246 0ustar00nadimusers000000000000# test package Eval::Context ; use strict ; use warnings ; use Data::TreeDumper ; use Test::More ; use Data::Dumper ; #---------------------------------------------------------- package some_object ; use strict ; use warnings ; sub new {bless { VALUE => $_[1] }, $_[0];} sub GetValue {$_[0]->{VALUE} ;} sub AddOne{$_[0]->{VALUE} += 1 ;} sub GetDump {Data::Dumper->Dump([$_[0]]) ;} #---------------------------------------------------------- package main ; use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context ; use constant SETUP => 0 ; use constant CODE => 1 ; use constant EXPECTED_RESULT => 2 ; { local $Plan = {'PERSISTENT' => 37} ; my $scalar_caller_side = 42 ; my $scalar_caller_side_reference = $scalar_caller_side ; my $string_caller_side = 'a string' ; my $string_caller_side_reference = $string_caller_side ; my %hash_caller_side = (A => 1, B => 2) ; my %hash_caller_side_reference = %hash_caller_side ; my @array_caller_side = ('A', 'B') ; my @array_caller_side_reference = @array_caller_side ; my $object = new some_object(5) ; my $object_dump = $object->GetDump() ; my $context = new Eval::Context() ; for my $test ( # SETUP CODE EXPECTED RESULT [ [ '$scalar' , $string_caller_side, $Eval::Context::PERSISTENT ] , "\$scalar ;\n" , '$output, $string_caller_side' ], [ [ '$scalar' , $Eval::Context::USE, $Eval::Context::PERSISTENT ] , "\$scalar .= '*' ;\n" , '$output, $string_caller_side . "*"' ], [ [ '$scalar' , $Eval::Context::USE, $Eval::Context::PERSISTENT ] , "\$scalar .= '*' ;\n" , '$output, $string_caller_side . "**"' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$variable' , $scalar_caller_side, $Eval::Context::PERSISTENT] => '$variable += 1 ;' => '$output => 43' ], [ [ '$variable' , $scalar_caller_side, $Eval::Context::PERSISTENT] => '$variable += 1 ;' => '$output => 43' ], [ [ '$variable' , $Eval::Context::USE, $Eval::Context::PERSISTENT] => '$variable += 1 ;' => '$output => 44' ], [ [ '$variable' , $scalar_caller_side, $Eval::Context::PERSISTENT] => '$variable += 1 ;' => '$output => 43' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$hash' , \%hash_caller_side, $Eval::Context::PERSISTENT] , "\$hash->{B} ;\n" , '$output , $hash_caller_side{B}' ], [ [ '$hash' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "\$hash->{B}++ ;\n my \$r = \$hash->{B} + 1;\n\$r ;\n" , '$output , $hash_caller_side{B} + 2' ], [ [ '$hash' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "my \$r = \$hash->{B} + 1;\n\$r ;\n" , '$output , $hash_caller_side{B} + 2' ], [ [ '$hash' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "\$hash->{B}++ ;\n" , '$hash_caller_side{B} , $hash_caller_side_reference{B}' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '%hash' , \%hash_caller_side, $Eval::Context::PERSISTENT] , "\$hash{B} ;\n" , '$output , $hash_caller_side{B}' ], [ [ '%hash' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "\$hash{B}++;\n my \$r = \$hash{B} + 1;\n\$r ;\n" , '$output , $hash_caller_side{B} + 2' ], [ [ '%hash' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "my \$r = \$hash{B} + 1;\n\$r ;\n" , '$output , $hash_caller_side{B} + 2' ], [ [ '%hash' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "\$hash{B} ++\n" , '$hash_caller_side{B} , $hash_caller_side_reference{B}' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$array' , \@array_caller_side, $Eval::Context::PERSISTENT] , "\$array->[1] ;\n" , '$output , $array_caller_side[1]' ], [ [ '$array' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "\$array->[1] .= 'X' ;\n my \$r = \$array->[1] . '*';\n\$r ;\n" , '$output , $array_caller_side[1] . "X*"' ], [ [ '$array' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "my \$r = \$array->[1] . '*';\n\$r ;\n" , '$output , $array_caller_side[1] . "X*"' ], [ [ '$array' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "\$array->[1]++ ;\n" , '$array_caller_side[1] , $array_caller_side_reference[1]' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '@array' , \@array_caller_side, $Eval::Context::PERSISTENT] , "\$array[1] ;\n" , '$output , $array_caller_side[1]' ], [ [ '@array' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "\$array[1] .= 'X' ;\nmy \$r = \$array[1] . '*';\n\$r ;\n " , '$output , $array_caller_side[1] . "X*"' ], [ [ '@array' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "my \$r = \$array[1] . '*';\n\$r ;\n " , '$output , $array_caller_side[1] . "X*"' ], [ [ '@array' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "\$array[1] .= 'X' ;\n " , '$array_caller_side[1] , $array_caller_side_reference[1]' ], #--------------------------------------------------------------------------------------------------------------------------------------- [ [ '$object' , $object, $Eval::Context::PERSISTENT] , "\$object->GetValue() ;\n" , '$output , $object->GetValue()' ], [ [ '$object' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "\$object->AddOne() ;\n" , '$output , $object->GetValue() + 1' ], [ [ '$object' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "\$object->AddOne() ;\n" , '$output , $object->GetValue() + 2' ], [ [ '$object' , $Eval::Context::USE, $Eval::Context::PERSISTENT] , "\$object->AddOne() ;\n" , '$object->GetDump() , $object_dump' ], #--------------------------------------------------------------------------------------------------------------------------------------- ) { my $output = $context->eval ( INSTALL_VARIABLES => [$test->[SETUP]], CODE => $test->[CODE], ) ; eval qq~ is($test->[EXPECTED_RESULT], 'eval side only') or diag "latest code:\n\$context->{LATEST_CODE}\n" ~ ; die $@ if $@ ; } my @persistent_variable_names = $context->GetPersistentVariableNames() ; is_deeply(\@persistent_variable_names , [qw($object $array $variable %hash $hash $scalar @array)], 'persistent variable names') or diag DumpTree(\@persistent_variable_names ) ; throws_ok { my $hash_after_eval = $context->GetPersistantVariables('%unknown') ; } qr /PERSISTENT variable '%unknown' doesn't exist/, 'accessing non persistent variable' ; lives_ok { my $output = $context->eval ( INSTALL_VARIABLES => [[ '$object' , 42, $Eval::Context::PERSISTENT]], CODE => '$object;', ) ; is($output, 42) ; } 'persistent override' ; { my $hash_after_eval = $context->GetPersistantVariables('$hash') ; is_deeply($hash_after_eval, {A => 1, B => 4}, 'get $hash') ; my %hash = $context->GetPersistantVariables('%hash') ; is_deeply(\%hash, {A => 1, B => 4}, 'get %hash') or diag DumpTree \%hash ; # whatever the user set so might a reference my $variable = $context->GetPersistantVariables('$variable') ; is($variable, 43, 'get $variable') ; } # get more than one variable { # be careful with argument list flattening my ($hash_ref, %hash) = $context->GetPersistantVariables('$hash', '%hash') ; is_deeply($hash_ref, {A => 1, B => 4}, 'get $hash (multiple arguments)') ; is_deeply(\%hash, {A => 1, B => 4}, 'get %hash (multiple arguments)') ; } # die if context is wrong throws_ok { $context->GetPersistantVariables('$hash') ; } qr /called in void context/, 'called in void context' ; } { local $Plan = {'REMOVE_PERSISTENT' => 7} ; my $scalar_caller_side = 42 ; my $string_caller_side = 'a string' ; my %hash_caller_side = (A => 1, B => 2) ; my @array_caller_side = ('A', 'B') ; my $object = new some_object(5) ; my $context = new Eval::Context() ; my $output = $context->eval ( INSTALL_VARIABLES => [[ '$variable' , $scalar_caller_side , $Eval::Context::PERSISTENT]], CODE => '$variable += 1 ;', ) ; is($output => 43, 'eval side only') or diag "latest code:\n$context->{LATEST_CODE}\n" ; $output = $context->eval ( INSTALL_VARIABLES => [[ '$variable' , $Eval::Context::USE, $Eval::Context::PERSISTENT]], CODE => '$variable += 1 ;', ) ; is($output => 44, 'eval side only') or diag "latest code:\n$context->{LATEST_CODE}\n" ; $output = $context->eval ( INSTALL_VARIABLES => [[ '$variable' , $Eval::Context::USE, $Eval::Context::PERSISTENT]], CODE => '$variable += 1 ;', REMOVE_PERSISTENT => [qr/not matching/], ) ; is($output => 45, 'eval side only') or diag "latest code:\n$context->{LATEST_CODE}\n" ; $output = $context->eval ( REMOVE_PERSISTENT => [qr/variable/], INSTALL_VARIABLES => [[ '$variable' , undef, $Eval::Context::PERSISTENT]], CODE => '$variable += 1 ;', ) ; is($output => 1, 'eval side only') or diag "latest code:\n$context->{LATEST_CODE}\n" ; my @persistent_variable_names = $context->GetPersistentVariableNames() ; is_deeply(\@persistent_variable_names , ['$variable'], 'persistent variable names') or diag DumpTree(\@persistent_variable_names ) ; $output = $context->eval ( CODE => '', REMOVE_PERSISTENT => [qr/variable/], ) ; @persistent_variable_names = $context->GetPersistentVariableNames() ; is_deeply(\@persistent_variable_names , [], 'persistent variable names') or diag DumpTree(\@persistent_variable_names ) ; throws_ok { $context->eval ( CODE => '', REMOVE_PERSISTENT => 1, ) ; } qr/Anonymous: 'REMOVE_PERSISTENT' must be an array reference containing regexes/, 'invalid REMOVE_PERSISTENT definition' ; } { local $Plan = {'SHARE vs PERSISTENT' => 1} ; my $object = new some_object(5) ; my $context = new Eval::Context() ; $context->eval ( CODE => '', INSTALL_VARIABLES => [[ '$object' , $object, $Eval::Context::SHARED] ], ) ; throws_ok { $context->eval ( CODE => '', INSTALL_VARIABLES => [[ '$object' , $object, $Eval::Context::PERSISTENT] ], ) ; } qr/'\$object' can't be PERSISTENT, already SHARED/, 'can not have persistent and shared' ; } { local $Plan = {'undef PERSISTENT variable' => 3} ; my $context = new Eval::Context() ; my $output = $context->eval ( CODE => '$object ;', INSTALL_VARIABLES => [[ '$object' , undef, $Eval::Context::PERSISTENT] ], ) ; is($output, undef, 'underfined persistent declaration') ; $output = $context->eval ( CODE => '$object ;', INSTALL_VARIABLES => [[ '$object' , $Eval::Context::USE, $Eval::Context::PERSISTENT] ], ) ; is($output, undef, 'underfined persistent') ; $output = $context->eval ( CODE => '$object ;', INSTALL_VARIABLES => [[ '$object' , 42, $Eval::Context::PERSISTENT] ], ) ; is($output, 42, 'underfined persistent') ; } Eval-Context-0.09.11/t/007_cleanup.t000444000764000144 176311341235317 16420 0ustar00nadimusers000000000000# test use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context ; { local $Plan = {'cleanup' => 4} ; lives_ok { my $context = new Eval::Context() ; $context->eval ( PACKAGE => 'A', REMOVE_PACKAGE_AFTER_EVAL => 0, CODE => 'sub sub1{1} ;', ) ; is(A::sub1(), 1, 'package sub still accessible') ; } 'no cleanup' ; dies_ok { warnings_like { my $context = new Eval::Context() ; $context->eval ( PACKAGE => 'A', REMOVE_PACKAGE_AFTER_EVAL => 1, CODE => 'sub sub2{2} ;', ) ; A::sub2() ; } qr/Undefined subroutine &A::sub2/, 'forced cleanup' ; } 'package gone' ; dies_ok { warnings_like { my $context = new Eval::Context() ; $context->eval ( PACKAGE => 'A', CODE => 'sub sub3 {3} ;', ) ; A::sub3() ; } qr/Undefined subroutine &A::sub3/, 'automatic cleanup' ; } 'package gone' ; } Eval-Context-0.09.11/t/001_load.t000444000764000144 100011341235317 15662 0ustar00nadimusers000000000000 # test module loading use strict ; use warnings ; use Test::NoWarnings ; use Test::More qw(no_plan); use Test::Exception ; BEGIN { use_ok( 'Eval::Context' ) or BAIL_OUT("Can't load module"); } ; my $object = new Eval::Context ; is(defined $object, 1, 'default constructor') ; isa_ok($object, 'Eval::Context'); my $new_config = $object->new() ; is(defined $new_config, 1, 'constructed from object') ; isa_ok($new_config , 'Eval::Context'); dies_ok { Eval::Context::new () ; } "invalid constructor" ; Eval-Context-0.09.11/t/005_eval_no_NoWarnings.t000444000764000144 113511341235317 20550 0ustar00nadimusers000000000000# test use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; #~ use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context ; { local $Plan = {'No NoWarnings' => 2} ; # the Test::NoWarnings module makes the following test segfault!! Test without that module my $context = new Eval::Context() ; lives_ok { my $value = $context->eval(CODE => "(7,8) ;", PACKAGE => 'A') ; is($value, 8, 'eval returned last value') or diag "latest code:\n$context->{LATEST_CODE}\n" ; } 'returned list, scalar context' ; } Eval-Context-0.09.11/t/006_install_subs.t000444000764000144 121411341235317 17461 0ustar00nadimusers000000000000# test use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context ; { local $Plan = {'install subs' => 2} ; { my $get_117 = sub{117} ; my $result = new Eval::Context(PACKAGE => 'TEST')->eval(CODE => 'get_117() ;', INSTALL_SUBS => {get_117 => $get_117}) ; is($result, 117, 'sub pushed into context') ; } throws_ok { my $context = new Eval::Context(INSTALL_SUBS => {get_117 => 'error'})->eval(CODE => '') ; } qr/'get_117' from 'INSTALL_SUBS' isn't a code reference/, 'is not a code reference' ; } Eval-Context-0.09.11/t/012_safe.t000444000764000144 1224611341235317 15721 0ustar00nadimusers000000000000# test package Eval::Context ; use strict ; use warnings ; use Data::TreeDumper ; use Test::More ; use Data::Dumper ; #---------------------------------------------------------- package main ; use strict ; use warnings ; use Data::TreeDumper ; use Test::Exception ; use Test::Warn; #~ use Test::NoWarnings qw(had_no_warnings); use Test::More 'no_plan'; use Test::Block qw($Plan); use Eval::Context ; $|++; { local $Plan = {'Default SAFE in constructor' => 1} ; my $context = new Eval::Context(SAFE => {}) ; throws_ok { $context->eval( CODE => 'eval "1 + 1" ;') ; } qr/'eval "string"' trapped by operation mask/, 'unsafe code, using default safe' ; } { local $Plan = {'Default SAFE in eval' => 1} ; my $context = new Eval::Context() ; throws_ok { $context->eval( CODE => 'eval "1 + 1" ;', SAFE => {}) ; } qr/'eval "string"' trapped by operation mask/, 'unsafe code' ; } { local $Plan = {'Invalid SAFE definition' => 1} ; throws_ok { my $context = new Eval::Context(SAFE => 1) ; $context->eval(CODE => '') ; } qr/Invalid Option 'SAFE' definition/, 'Invalid SAFE definition' ; } { local $Plan = {'SAFE options' => 5} ; my $context = new Eval::Context() ; throws_ok { $context->eval ( SAFE =>{PRE_CODE => "use Xyzzy::This_Module_SHOULD_Not_Exist;\n1;\n"}, CODE => '', ) ; } qr~Can't locate Xyzzy/This_Module_SHOULD_Not_Exist.pm~, 'PRE_SAFE_CODE error'; lives_ok { $context->eval ( SAFE =>{PRE_CODE => "use Data::TreeDumper;\n\n"}, CODE => 'my $x = DumpTree({A => 1}) ;', ) ; } 'PRE_SAFE_CODE' ; throws_ok { my $output = $context->eval ( CODE => '$x = 1 ;', SAFE => {} ) ; } qr/Global symbol "\$x" requires explicit package/, 'use strict by default' ; lives_ok { $context->eval ( CODE => '$x = 1 ;', SAFE =>{ USE_STRICT => 0 }, ) ; } 'USE_STRICT' ; lives_ok { my $compartment = new Safe('ABC') ; $compartment->permit('entereval') ; $context->eval(PACKAGE => 'ABC', CODE => 'eval "1 + 1" ;', SAFE => {COMPARTMENT => $compartment}) ; } 'COMPARTMENT' ; } { local $Plan = {'SAFE PRE_CODE in same package' => 2} ; my $context = new Eval::Context(PACKAGE => 'TEST', SAFE => {}) ; my $output = $context->eval(CODE => 'my $x = 1; __PACKAGE__ ;') ; is($output, 'main', 'first eval package') ; $output = $context->eval ( SAFE =>{PRE_CODE => "use Data::TreeDumper;\n\n"}, CODE => 'DumpTree({A => 1}) ;', ) ; is($output,< 2} ; my $get_117 = sub{117} ; my $result = new Eval::Context(PACKAGE => 'TEST') ->eval(SAFE => {}, CODE => 'get_117() ;', INSTALL_SUBS => {get_117 => $get_117}) ; is($result, 117, 'sub pushed into safe context') ; my $get_118 = sub{118} ; $result = new Eval::Context(PACKAGE => 'TEST') ->eval(SAFE => {}, CODE => 'get_118() ;', INSTALL_SUBS => {get_118 => $get_118}) ; is($result, 118, 'new sub pushed into same safe context') ; } { #~ # test if access to persistent saving functions on eval side local $Plan = {'SAFE access to persistent functions' => 1} ; my $context = new Eval::Context ( EVAL_SIDE_PERSISTENT_VARIABLES => { CATEGORY => 'TEST', SAVE => { NAME => 'SavePersistent', VALIDATOR => sub{}, }, GET => { NAME => 'GetPersistent', VALIDATOR => sub {}}, }, SAFE => {}, ) ; $context->eval(CODE => 'my $variable = 24 ; SavePersistent(\'$variable\', $variable) ;') ; my $output = $context->eval(CODE => 'my $variable = GetPersistent(\'$variable\') ;') ; is($output, 24, 'access to persistent functionality') or diag DumpTree $context ; } { local $Plan = {'SAFE caller context' => 6} ; my $context = new Eval::Context ( SAFE => {}, ) ; lives_ok { $context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['$variable', 42] ]) ; } 'void context' ; lives_ok { my $output = $context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['$variable', 42] ]) ; is($output, 42, 'right value in scalar context') ; } 'scalar context' ; lives_ok { my @output = $context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['$variable', 42] ]) ; is_deeply(\@output, [42], 'right value in array context') ; } 'array context' ; throws_ok { $context->eval(CODE => 'die "died withing safe"',) ; } qr/died withing safe/, 'die within a safe' ; } { local $Plan = {'SAFE and croak' => 3} ; my $context = new Eval::Context ( SAFE => { PRE_CODE => 'use Carp ;', }, ) ; my $output = $context->eval(CODE => '$variable', INSTALL_VARIABLES => [ ['$variable', 42] ]) ; is($output, 42, 'right value in scalar context') ; throws_ok { # Eval context returns the code as an error, make sure the error is not part of the code $context->eval(CODE => "my \$error = 'this_i' . 's_the_croak_message';\ncroak(\$error) ;",) ; } qr/this_is_the_croak_message/, 'croak within a safe' ; #~ diag DumpTree $context ; #~ diag $@ ; throws_ok { # Eval context returns the code as an error, make sure the error is not part of the code $context->eval(CODE => 'my $error = "this_i" . "s_the_die_message"; die $error ;',) ; } qr/this_is_the_die_message/, 'die within a safe while using Carp' ; #~ diag $@ ; } Eval-Context-0.09.11/xt000755000764000144 011341235317 14242 5ustar00nadimusers000000000000Eval-Context-0.09.11/xt/author000755000764000144 011341235317 15544 5ustar00nadimusers000000000000Eval-Context-0.09.11/xt/author/003_perl_critic.t000444000764000144 201311341235317 20743 0ustar00nadimusers000000000000# perl_critic test use strict ; use warnings ; use Term::ANSIColor qw(:constants) ; #~ use Test::More skip_all => 'perl_critic' ; use Test::Perl::Critic -severity => 1, -format => "[%s] %m at '%f:" . RED . "%l:%c" . RESET . "' rule %p %e\n" . "\t%r", #~ -format => "[%s] %m at '%f:" . BOLD . RED . "%l" . RESET . "'. %e\n", #~ -format => "[%s] %m at " . BOLD . BLUE . "%F:%l" . RESET . ". %e\n", -exclude => [ 'Miscellanea::RequireRcsKeywords', 'NamingConventions::ProhibitMixedCaseSubs', 'ControlStructures::ProhibitPostfixControls', 'CodeLayout::ProhibitParensWithBuiltins', 'Documentation::RequirePodAtEnd', 'ControlStructures::ProhibitUnlessBlocks', 'CodeLayout::RequireTidyCode', 'CodeLayout::ProhibitHardTabs', 'CodeLayout::ProhibitTrailingWhitespace' , 'ValuesAndExpressions::ProhibitCommaSeparatedStatements', # too many false positives. See RT #27654 'NamingConventions::Capitalization', # doesn't allow camel case ], -profile => 'xt/author/perlcriticrc' ; all_critic_ok() ; Eval-Context-0.09.11/xt/author/002_2_pod_coverage.t000444000764000144 17011341235317 21303 0ustar00nadimusers000000000000# pod and pod_coverage pod_spelling test use strict ; use warnings ; use Test::Pod::Coverage; all_pod_coverage_ok() ;Eval-Context-0.09.11/xt/author/perlcriticrc000444000764000144 164311341235317 20315 0ustar00nadimusers000000000000# perl_critic setup file [Documentation::RequirePodSections] lib_sections = NAME | SYNOPSIS | DESCRIPTION | SUBROUTINES/METHODS | BUGS AND LIMITATIONS | LICENSE AND COPYRIGHT | SUPPORT | AUTHOR #script_sections = NAME | USAGE | OPTIONS | EXIT STATUS | AUTHOR [Subroutines::ProhibitExcessComplexity] max_mccabe = 21 [Documentation::PodSpelling] stop_words = Opcode perl prepended eval regex undef perldoc CPAN's RT AnnoCPAN CPAN perlsec deserialized validator CanonizeName CheckOptionNames CleanupPackage EvalSetup EvalCleanup GetCallContextWrapper GetPackageName GetInstalledVariablesCode GetVariablesSetFromCaller GetPersistentVariablesSetFromCaller GetSharedVariablesSetFromCaller GetPersistantVariables GetPersistentVariableNames RemoveEvalSidePersistenceHandlers RemovePersistent SetEvalSidePersistenceHandlers SetInteractionDefault SetupSafeCompartment VerifyCodeInput VerifyAndCompleteOptions Nadim nadim Khemir khemirEval-Context-0.09.11/xt/author/000_distribution.t000444000764000144 50711341235317 21146 0ustar00nadimusers000000000000 # module contents test use strict ; use warnings ; use Test::More; BEGIN { eval { require Test::Distribution; }; if($@) { plan skip_all => 'Test::Distribution not installed'; } else { import Test::Distribution; } } #eval "use Test::Distribution only => [qw{prereq description pod podcover use versions}] ;" ; Eval-Context-0.09.11/xt/author/000_strict.t000444000764000144 16411341235317 17736 0ustar00nadimusers000000000000 # check stricture use strict ; use warnings ; use Test::More 'no_plan' ; use Test::Strict; all_perl_files_ok(); Eval-Context-0.09.11/xt/author/000_fixme.t000444000764000144 56311341235317 17541 0ustar00nadimusers000000000000 # fixme test use strict ; use warnings ; use Test::More ; eval { require Test::Fixme; Test::Fixme->import(); run_tests ( where => 'lib', # where to find files to check match => qr/TODO|FIXME/i, # what to check for #~ skip_all => $ENV{SKIP} # should all tests be skipped ) ; }; plan( skip_all => 'Test::Fixme not installed; skipping' ) if $@;Eval-Context-0.09.11/xt/author/002_1_pod.t000444000764000144 17511341235317 17434 0ustar00nadimusers000000000000# pod and pod_coverage pod_spelling test use strict ; use warnings ; use Test::More; use Test::Pod ; all_pod_files_ok(); Eval-Context-0.09.11/xt/author/000_dependencies.t000444000764000144 31111341235317 21046 0ustar00nadimusers000000000000 # dependencies test use strict ; use warnings ; use Test::More 'no_plan' ; SKIP: { skip('Test::Dependencies has no support for Module::Build', 1) ; #use Test::Dependencies ; #ok_dependencies(); }Eval-Context-0.09.11/xt/author/000_kwalitee.t000444000764000144 27711341235317 20240 0ustar00nadimusers000000000000 # kwalitee test use strict ; use warnings ; use Test::More; eval { require Test::Kwalitee; Test::Kwalitee->import() }; plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;Eval-Context-0.09.11/lib000755000764000144 011341235317 14355 5ustar00nadimusers000000000000Eval-Context-0.09.11/lib/Eval000755000764000144 011341235317 15244 5ustar00nadimusers000000000000Eval-Context-0.09.11/lib/Eval/Context.pm000444000764000144 12664111341235317 17435 0ustar00nadimusers000000000000 package Eval::Context ; use strict; use warnings ; BEGIN { use vars qw ($VERSION); $VERSION = '0.09' ; } #------------------------------------------------------------------------------- use English qw( -no_match_vars ) ; use Readonly ; Readonly my $EMPTY_STRING => q{} ; Readonly our $SHARED => 0 ; Readonly our $PERSISTENT => 1 ; my $flag ; Readonly our $USE => bless \$flag, 'USE_PERSISTENT' ; use Carp qw(carp croak confess) ; use File::Slurp ; use Sub::Install qw(install_sub reinstall_sub) ; use Symbol qw(delete_package); use Safe ; use Data::Dumper ; #------------------------------------------------------------------------------- =head1 NAME Eval::Context - Evalute perl code in context wraper =head1 SYNOPSIS use Eval::Context ; my $context = new Eval::Context(PRE_CODE => "use strict;\nuse warnings;\n") ; # code will be evaluated with strict and warnings loaded in the context. $context->eval(CODE => 'print "evaluated in an Eval::Context!" ;') ; $context->eval(CODE_FROM_FILE => 'file.pl') ; =head1 DESCRIPTION This module define a subroutine that let you evaluate Perl code in a specific context. The code can be passed directly as a string or as a file name to read from. It also provides some subroutines to let you define and optionally share variables and subroutines between your code and the code you wish to evaluate. Finally there is some support for running your code in a safe compartment. =head1 Don't play with fire! Don't start using this module, or any other module, thinking it will let you take code from anywhere and be safe. Read perlsec, Safe, Opcode, Taint and other security related documents. Control your input. =head1 SUBROUTINES/METHODS Subroutines that are not part of the public interface are marked with [p]. =cut #------------------------------------------------------------------------------- Readonly my $NEW_ARGUMENTS => [qw( NAME PACKAGE SAFE PERL_EVAL_CONTEXT PRE_CODE POST_CODE REMOVE_PACKAGE_AFTER_EVAL INSTALL_SUBS INSTALL_VARIABLES EVAL_SIDE_PERSISTENT_VARIABLES INTERACTION FILE LINE DISPLAY_SOURCE_IN_CONTEXT )] ; sub new { =head2 new(@named_arguments) Create an Eval::Context object. The object is used as a repository of "default" values for your code evaluations. The context can be used many times. The values can be temporarily overridden during the C call. my $context = new Eval::Context() ; # default context my $context = new Eval::Context ( NAME => 'libraries evaluation context', PACKAGE => 'libraries', SAFE => {...} ; PRE_CODE => "use strict ;\n" POST_CODE => sub{}, PERL_EVAL_CONTEXT => undef, INSTALL_SUBS => {...}, INSTALL_VARIABLES => [...], EVAL_SIDE_PERSISTENT_VARIABLES => {...}, INTERACTION => {...}, DISPLAY_SOURCE_IN_CONTEXT => 1, #useful when debuging ) ; I =over 2 =item * @named_arguments - setup data for the object All the arguments optional. The argument passed to C can also be passed to C. All arguments are named. =over 4 =item * NAME - use when displaying information about the object. Set automatically to 'Anonymous' if not set. The name will also be reported by perl if an error occurs during your code evaluation. =item * PACKAGE - the package the code passed to C will evaluated be in. If not set, a unique package name is generated and used for every C call. =item * REMOVE_PACKAGE_AFTER_EVAL - When set the content of the package after evaluation will be erase The default behavior is to remove all data from after the call to C. =item * PRE_CODE - code prepended to the code passed to I =item * POST_CODE - code appended to the code passed to I =item * PERL_EVAL_CONTEXT - the context to eval code in (void, scalar, list). This option Works as L. It will override the context in which C is called. =item * INSTALL_SUBS - subs that will be available in the eval. A hash where the keys are a function names and the values a code references. =item * SAFE This argument must be a hash reference. if the hash is empty, a default safe compartment will be used. Read L documentation for more information. SAFE => {} # default safe environment You can have a finer control over the safe compartment B that will be used. my $compartment = new Safe('ABC') ; my $context = new Eval::Context ( SAFE => # controlling the safe environment { PACKAGE => 'ABC', PRE_CODE => "use my module ;\n" # code we consider safe USE_STRICT => 0, # set to 1 by default COMPARTMENT => $compartment , # use default if not passed } , } $context->eval(CODE => .....) ; =over 4 =item * COMPARTMENT - a Safe object, you create, that will be used by B =item * USE_STRICT - Controls if L is used in the Safe compartment The default is to use strict. Note that L default is to NOT use strict (undocumented). =item * PRE_CODE - safe code you want to evaluate in the same context as the unsafe code This let you, for example, use certain modules which provide subroutines to be used in the evaluated code. The default compartment is quite restrictive and you can't even use L in it without tuning the safe compartment. =back A few remarks: - See L on RT - Pass the same package name to your safe compartment and to B. - If you really want to be on the safe side, control your input. When you use a module, are you sure the module hasn't been fiddle with? - Leave strict on. Even for trivial code. =item * INSTALL_VARIABLES - "Give me sugar baby" Ash. B has mechanisms you can use to set and share variables with the code you will evaluate. There are two sides in an B. The I, the side where the calls to C are made and the I, the side where the code to be evaluated is run. =over 4 =item * How should you get values back from the eval-side Although you can use the mechanisms below to get values from the I, the cleanest way is to get the results directly from the C call. my $context = new Eval::Context() ; my ($scalr_new_value, $a_string) = $context->eval ( INSTALL_VARIABLES =>[[ '$scalar' => 42]] , CODE => "\$scalar++ ;\n (\$scalar, 'a string') ;", ) ; =item * initializing variables on the I You can pass B to C or C. You can initialize different variables for each run of C. my $context = new Eval::Context ( INSTALL_VARIABLES => [ # variables on eval-side #initialization source [ '$data' => 42], [ '$scalar' => $scalar_caller_side ], [ '%hash' => \%hash_caller_side ] [ '$hash' => \%hash_caller_side ], [ '$object' => $object ], ] , ) ; The variables will be B variables on the eval-side. You can declare variables of any of the base types supported by perl. The initialization data , on the caller-side, is serialized and deserialized to make the values available on the eval-side. Modifying the variables on the eval-side does not modify the variables on the caller-side. The initialization data can be scalars or references and even B variables. =item * Persistent variables When evaluating code many times in the same context, you may wish to have variables persist between evaluations. B allows you to declare, define and control such I variables. This mechanism lets you control which variables are persistent. Access to the persistent variables is controlled per C run. Persistent variables are B variables on the I. Modifying the variables on the eval-side does not modify the variables on the I. Define persistent variables: # note: creating persistent variables in 'new' makes little sense as # it will force those values in the persistent variables for every run. # This may or may not be what you want. my $context = new Eval::Context() ; $context->eval ( INSTALL_VARIABLES => [ [ '$scalar' => 42 => $Eval::Context::PERSISTENT ] , # make %hash and $hash available on the eval-side. both are # initialized from the same caller-side hash [ '%hash' => \%hash_caller_side => $Eval::Context::PERSISTENT ] , [ '$hash' => \%hash_caller_side => $Eval::Context::PERSISTENT ] , ], CODE => '$scalar++', ) ; Later, use the persistent value: $context->eval ( INSTALL_VARIABLES => [ [ '$scalar' => $Eval::Context::USE => $Eval::Context::PERSISTENT ] , # here you decided %hash and $hash shouldn't be available on the eval-side ], CODE => '$scalar', ) ; B<$Eval::Context::USE> means I<"make the persistent variable and it's value available on the eval-side">. Any other value will reinitialize the persistent variable. See also B in C. =item * Manually synchronizing caller-side data with persistent eval-side data Although the first intent of persistent variables is to be used as state variables on the eval-side, you can get persistent variables values on the caller-side. To change the value of an I persistent variable, simply reinitialize it with B next time you call C. my $context = new Eval::Context ( INSTALL_VARIABLES => [ ['%hash' => \%hash_caller_side => $Eval::Context::PERSISTENT] ] , ) ; $context->Eval(CODE => '$hash{A}++ ;') ; # throws exception if you request a non existing variable my %hash_after_eval = $context->GetPersistantVariables('%hash') ; =item * Getting the list of all the PERSISTENT variables my @persistent_variable_names = $context->GetPersistantVariablesNames() ; =item * Creating persistent variables on the eval-side The mechanism above gave you fine control over persistent variables on the I. The negative side is that B the variables you made persistent exist on the I. B has another mechanism that allows the I to store variables between evaluations without the I declaration of the variables. To allow the I to store any variable, add this to you C call. my $context = new Eval::Context ( PACKAGE => 'my_package', EVAL_SIDE_PERSISTENT_VARIABLES => { SAVE => { NAME => 'SavePersistent', VALIDATOR => sub{} }, GET => { NAME => 'GetPersistent', VALIDATOR => sub{} }, }, ) ; The I can now store variables between calls to C SavePersistent('name', $value) ; later in another call to C: my $variable = GetPersistent('name') ; By fine tuning B you can control what variables are stored by the I. This should seldom be used and only to help those storing data from the I. You may have notices in the code above that a package name was passed as argument to C. This is very important as the package names that are automatically generated differ for each C call. If you want to run all you I code in different packages (B default behavior), you must tell B where to store the I values. This is done by setting B The validator sub can verify if the value to be stored are valid, E.G.: variable name, variable value is within range, ... Here is an example of code run in different packages but can share variables. Only variables which names start with I are valid. new Eval::Context ( EVAL_SIDE_PERSISTENT_VARIABLES => { CATEGORY => 'TEST', SAVE => { NAME => 'SavePersistent', VALIDATOR => sub { my ($self, $name, $value, $package) = @_ ; $self->{INTERACTION}{DIE}-> ( $self, "SavePersistent: name '$name' doesn't start with A!" ) unless $name =~ /^A/ ; }, }, GET => {NAME => 'GetPersistent',VALIDATOR => sub {}}, }, ) ; $context->eval(CODE => 'SavePersistent('A_variable', 123) ;') ; later: $context->eval(CODE => 'GetPersistent('A_variable') ;') ; =item * Shared variables You can also share references between the I and the I. my $context = new Eval::Context ( INSTALL_VARIABLES => [ # reference to reference only [ '$scalar' => \$scalar => $Eval::Context::SHARED ], [ '$hash' => \%hash_caller_side => $Eval::Context::SHARED ], [ '$object' => $object => $Eval::Context::SHARED ], ] , ) ; Modification of the variables on the I will modify the variable on the I. There are but a few reasons to share references. Note that you can share references to B variables. =back =item * INTERACTION Lets you define subs used to interact with the user. INTERACTION => { INFO => \&sub, WARN => \&sub, DIE => \&sub, EVAL_DIE => \&sub, } =over 6 =item INFO - defaults to CORE::print This sub will be used when displaying information. =item WARN - defaults to Carp::carp This sub will be used when a warning is displayed. =item DIE - defaults to Carp::confess Used when an error occurs. =item EVAL_DIE - defaults to Carp::confess, with a dump of the code to be evaluated Used when an error occurs during code evaluation. =back =item * FILE - the file where the object has been created. This is practical if you want to wrap the object. B and B will be set automatically if not set. =item * LINE - the line where the object has been created. Set automatically if not set. =item * DISPLAY_SOURCE_IN_CONTEXT - if set, the code to evaluated will be displayed before evaluation =back =back I =over 2 =item * an B object. =back =cut my ($invocant, @setup_data) = @_ ; my $class = ref($invocant) || $invocant ; confess 'Invalid constructor call!' unless defined $class ; my $object = {} ; my ($package, $file_name, $line) = caller() ; bless $object, $class ; $object->Setup($package, $file_name, $line, @setup_data) ; return($object) ; } #------------------------------------------------------------------------------- sub Setup { =head2 [p] Setup Helper sub called by new. =cut my ($self, $package, $file_name, $line, @setup_data) = @_ ; my $inital_option_checking_context = { NAME => 'Anonymous eval context', FILE => $file_name, LINE => $line,} ; SetInteractionDefault($inital_option_checking_context) ; CheckOptionNames ( $inital_option_checking_context, $NEW_ARGUMENTS, @setup_data ) ; %{$self} = ( NAME => 'Anonymous', FILE => $file_name, LINE => $line, REMOVE_PACKAGE_AFTER_EVAL => 1, @setup_data, ) ; if((! defined $self->{NAME}) || $self->{NAME} eq $EMPTY_STRING) { $self->{NAME} = 'Anonymous eval context' ; } SetInteractionDefault($self) ; return(1) ; } #------------------------------------------------------------------------------- sub CheckOptionNames { =head2 [p] CheckOptionNames Verifies the named options passed as arguments with a list of valid options. Calls B<{INTERACTION}{DIE}> in case of error. =cut my ($self, $valid_options, @options) = @_ ; if (@options % 2) { $self->{INTERACTION}{DIE}->($self, "Invalid number of argument at '$self->{FILE}:$self->{LINE}'!") ; } if('HASH' eq ref $valid_options) { # OK } elsif('ARRAY' eq ref $valid_options) { $valid_options = {map{$_ => 1} @{$valid_options}} ; } else { $self->{INTERACTION}{DIE}->($self, q{Invalid 'valid_options' definition! Should be an array or hash reference.}) ; } my %options = @options ; for my $option_name (keys %options) { unless(exists $valid_options->{$option_name}) { $self->{INTERACTION}{DIE}->($self, "$self->{NAME}: Invalid Option '$option_name' at '$self->{FILE}:$self->{LINE}'!") ; } } if ( (defined $options{FILE} && ! defined $options{LINE}) || (!defined $options{FILE} && defined $options{LINE}) ) { $self->{INTERACTION}{DIE}->($self, "$self->{NAME}: Incomplete option FILE::LINE!") ; } return(1) ; } #------------------------------------------------------------------------------- sub SetInteractionDefault { =head2 [p] SetInteractionDefault Sets {INTERACTION} fields that are not set by the user. =cut my ($interaction_container) = @_ ; $interaction_container->{INTERACTION}{INFO} ||= sub {my (@information) = @_ ; print @information} ; ## no critic (InputOutput::RequireCheckedSyscalls) $interaction_container->{INTERACTION}{WARN} ||= \&Carp::carp ; $interaction_container->{INTERACTION}{DIE} ||= sub { my($self, @error) = @_ ; Carp::confess(@error)} ; $interaction_container->{INTERACTION}{EVAL_DIE} ||= sub { my($self, $error) = @_ ; Carp::confess ( "*** Eval::Context code ***\n" . $self->{LATEST_CODE} . "\n*** Error below ***\n" . $error ) ; } ; return ; } #------------------------------------------------------------------------------- sub CanonizeName { =head2 [p] CanonizeName Transform a string into a a string with can be used as a package name or file name usable within perl code. =cut my ($name) = @_ ; croak 'CanonizeName called with undefined argument!' unless defined $name ; $name =~ s/[^a-zA-Z0-9_:\.]/_/xsmg ; return($name) ; } #------------------------------------------------------------------------------- Readonly my $EVAL_ARGUMENTS => [@{$NEW_ARGUMENTS}, qw(CODE CODE_FROM_FILE REMOVE_PERSISTENT)] ; sub eval ## no critic (Subroutines::ProhibitBuiltinHomonyms ErrorHandling::RequireCheckingReturnValueOfEval) { =head2 eval(@named_arguments) Evaluates Perl code, passed as a string or read from a file, in the context. my $context = new Eval::Context(PRE_CODE => "use strict;\nuse warnings;\n") ; $context->eval(CODE => 'print "evaluated in an Eval::Context!";') ; $context->eval(CODE_FROM_FILE => 'file.pl') ; I Evaluation context of the code (void, scalar, list) is the same as the context this subroutine was called in or in the context defined by B if that option is present. I BCB<. The override is temporary during the duration of this call.> =over 2 =item * @named_arguments - Any of C options plus the following. =over 4 =item * CODE - a string containing perl code (valid code or an exception is raised) =item * CODE_FROM_FILE - a file containing perl code =item * REMOVE_PERSISTENT A list of regex used to match the persistent variable names to be removed, persistent variable removal is done before any variable installation is done =item * FILE and LINE - will be used in the evaluated code 'file_name' set to the caller's file and line by default =back NOTE: B or B is B. =back I =over 2 =item * What the code to be evaluated returns =back =cut my ($self, @options) = @_ ; my $options = $self->VerifyAndCompleteOptions($EVAL_ARGUMENTS, @options) ; $options->{PERL_EVAL_CONTEXT} = wantarray unless exists $options->{PERL_EVAL_CONTEXT} ; my ($package, $variables_setup, $variables_teardown) = $self->EvalSetup($options) ; my ($code_start, $code_end, $return) = $self->GetCallContextWrapper($variables_setup, $options) ; my ($package_setup, $compartment, $compartment_use_strict, $pre_code_commented_out) = $self->SetupSafeCompartment($package, $options) ; $self->VerifyCodeInput($options) ; $self->{LATEST_CODE} = "#line 0 '$options->{EVAL_FILE_NAME}'\n" ; for ( $package_setup, $pre_code_commented_out, '# PRE_CODE', $options->{PRE_CODE}, $variables_setup, $code_start, "#line 0 '$options->{EVAL_FILE_NAME}'", '# CODE', $options->{CODE}, '# POST_CODE', $options->{POST_CODE}, $code_end, $variables_teardown, $return, "#end of context '$options->{EVAL_FILE_NAME}'", ) { $self->{LATEST_CODE} .= "$_\n" if defined $_ ; } if($options->{DISPLAY_SOURCE_IN_CONTEXT}) { $options->{INTERACTION}{INFO} ->("Eval::Context called at '$options->{FILE}:$options->{LINE}' to evaluate:\n" . $self->{LATEST_CODE}) ; } if(defined $options->{PERL_EVAL_CONTEXT}) { if($options->{PERL_EVAL_CONTEXT}) { my @results = $compartment ? $compartment->reval($self->{LATEST_CODE}, $compartment_use_strict) : eval $self->{LATEST_CODE} ; ## no critic (BuiltinFunctions::ProhibitStringyEval) $options->{INTERACTION}{EVAL_DIE}->($self, $EVAL_ERROR) if($EVAL_ERROR) ; $self->EvalCleanup($options) ; return @results ; } else { my $result = $compartment ? $compartment->reval($self->{LATEST_CODE}, $compartment_use_strict) : eval $self->{LATEST_CODE} ; ## no critic (BuiltinFunctions::ProhibitStringyEval) $options->{INTERACTION}{EVAL_DIE}->($self, $EVAL_ERROR) if($EVAL_ERROR) ; $self->EvalCleanup($options) ; return $result ; } } else { defined $compartment ? $compartment->reval($self->{LATEST_CODE}, $compartment_use_strict) : eval $self->{LATEST_CODE} ; ## no critic (BuiltinFunctions::ProhibitStringyEval) $options->{INTERACTION}{EVAL_DIE}->($self, $EVAL_ERROR) if($EVAL_ERROR) ; $self->EvalCleanup($options) ; return ; } } #------------------------------------------------------------------------------- sub VerifyAndCompleteOptions { =head2 [p] VerifyAndCompleteOptions Helper sub for C. =cut my ($self, $allowed_arguments, @options) = @_ ; $self->CheckOptionNames($allowed_arguments, @options) ; my %options = @options ; unless(defined $options{FILE}) { my ($package, $file_name, $line) = caller(1) ; push @options, FILE => $file_name, LINE => $line } %options = (%{$self}, @options) ; $options{NAME} = CanonizeName($options{NAME} . " called at $options{FILE}:$options{LINE}") ; SetInteractionDefault(\%options) ; return(\%options) ; } #------------------------------------------------------------------------------- sub EvalCleanup { =head2 [p] EvalCleanup Handles the package cleanup or persistent variables cleanup after a call to C. =cut my ($self, $options) = @_ ; if($options->{REMOVE_PACKAGE_AFTER_EVAL}) { delete_package($self->{CURRENT_RUNNING_PACKAGE}) } else { if(defined $options->{EVAL_SIDE_PERSISTENT_VARIABLES}) { $self->RemoveEvalSidePersistenceHandlers($options) ; } } return(1) ; } #------------------------------------------------------------------------------- my $eval_run = 0 ; sub GetPackageName { =head2 [p] GetPackageName Returns a canonized package name. the name is either passed as argument from the caller or a temporary package name. =cut my ($options) = @_ ; my $package = exists $options->{PACKAGE} && defined $options->{PACKAGE} ? CanonizeName($options->{PACKAGE}) : "Eval::Context::Run_$eval_run" ; $package = $package eq $EMPTY_STRING ? "Eval::Context::Run_$eval_run" : $package ; $eval_run++ ; return($package) ; } #------------------------------------------------------------------------------- sub EvalSetup { =head2 [p] EvalSetup Handles the setup of the context before I code is evaluated. Sets the variables and the shared subroutines. =cut my ($self, $options) = @_ ; my $package = $self->{CURRENT_RUNNING_PACKAGE} = GetPackageName($options) ; $self->RemovePersistent($options) ; my ($variables_setup, $variables_teardown) = (undef, undef) ; if(defined $options->{INSTALL_VARIABLES}) { ($variables_setup, $variables_teardown) = $self->GetInstalledVariablesCode($options) ; } for my $sub_name (keys %{$options->{INSTALL_SUBS}}) { if('CODE' ne ref $options->{INSTALL_SUBS}{$sub_name} ) { $options->{INTERACTION}{DIE}->($self, "$self->{NAME}: '$sub_name' from 'INSTALL_SUBS' isn't a code reference at '$options->{FILE}:$options->{LINE}'!") ; } reinstall_sub({ code => $options->{INSTALL_SUBS}{$sub_name}, into => $package, as => $sub_name }) ; } if(defined $options->{EVAL_SIDE_PERSISTENT_VARIABLES}) { $self->SetEvalSidePersistenceHandlers($options) ; } return ($package, $variables_setup, $variables_teardown) ; } #------------------------------------------------------------------------------- sub VerifyCodeInput { =head2 [p] VerifyCodeInput Verify that B or B are properly set. =cut my ($self, $options) = @_ ; $options->{EVAL_FILE_NAME} = $options->{NAME} || 'Anonymous' ; $options->{PRE_CODE} = defined $options->{PRE_CODE} ? $options->{PRE_CODE} : $EMPTY_STRING ; if(exists $options->{CODE_FROM_FILE} && exists $options->{CODE} ) { $options->{INTERACTION}{DIE}->($self, "$self->{NAME}: Option 'CODE' and 'CODE_FROM_FILE' can't coexist at '$options->{FILE}:$options->{LINE}'!") ; } if(exists $options->{CODE_FROM_FILE} && defined $options->{CODE_FROM_FILE}) { $options->{CODE} = read_file($options->{CODE_FROM_FILE}) ; $options->{NAME} = CanonizeName($options->{CODE_FROM_FILE}) ; $options->{EVAL_FILE_NAME} = $options->{CODE_FROM_FILE} ; } unless(exists $options->{CODE} && defined $options->{CODE}) { $options->{INTERACTION}{DIE}->($self, "$self->{NAME}: Invalid Option 'CODE' at '$options->{FILE}:$options->{LINE}'!") ; } $options->{POST_CODE} = defined $options->{POST_CODE} ? $options->{POST_CODE} : $EMPTY_STRING ; return(1) ; } #------------------------------------------------------------------------------- sub RemovePersistent { =head2 [p] RemovePersistent Handles the removal of persistent variables. =cut my ($self, $options) = @_ ; if(exists $options->{REMOVE_PERSISTENT}) { if('ARRAY' ne ref $options->{REMOVE_PERSISTENT}) { $options->{INTERACTION}{DIE}-> ( $self, "$self->{NAME}: 'REMOVE_PERSISTENT' must be an array reference containing regexes at '$options->{FILE}:$options->{LINE}'!" ) ; } for my $regex (@{ $options->{REMOVE_PERSISTENT} }) { for my $name ( keys %{ $self->{PERSISTENT_VARIABLES} }) { delete $self->{PERSISTENT_VARIABLES}{$name} if($name =~ $regex) ; } } } return(1) ; } #------------------------------------------------------------------------------- sub GetCallContextWrapper { =head2 [p] GetCallContextWrapper Generates perl code to wrap the code to be evaluated in the right calling context. =cut my ($self, $variables_setup, $options) = @_ ; my ($code_start, $code_end, $return) = (undef, undef, undef) ; # defaults for void context if(defined $variables_setup) { if(defined $options->{PERL_EVAL_CONTEXT}) { if($options->{PERL_EVAL_CONTEXT}) { # array context ($code_start, $code_end, $return) = ( "my \@eval_context_result = do {\n", "} ;\n", "\@eval_context_result ;\n", ) ; } else { # scalar context ($code_start, $code_end, $return) = ( "my \$eval_context_result = do {\n", "} ;\n", "\$eval_context_result ;\n", ) ; } } else { # void context ($code_start, $code_end, $return) = ($EMPTY_STRING, $EMPTY_STRING, $EMPTY_STRING) ; } } return($code_start, $code_end, $return) ; } #------------------------------------------------------------------------------- sub SetupSafeCompartment { =head2 [p] SetupSafeCompartment If running in safe mode, setup a safe compartment from the argument, otherwise defines the evaluation package. =cut my ($self, $package, $options) = @_ ; my ($package_setup, $compartment, $compartment_use_strict, $pre_code_commented_out) = (undef, undef, 1, undef) ; if(exists $options->{SAFE}) { if('HASH' eq ref $options->{SAFE}) { if(exists $options->{SAFE}{PRE_CODE}) { # must be done before creating the safe compartment my $pre_code = "\npackage " . $package . " ;\n" . $options->{SAFE}{PRE_CODE} ; eval $pre_code ; ## no critic (BuiltinFunctions::ProhibitStringyEval) if($EVAL_ERROR) { $self->{LATEST_CODE} = $pre_code ; $options->{INTERACTION}{EVAL_DIE}->($self, $EVAL_ERROR) ; } $pre_code_commented_out = "# Note: evaluated PRE_CODE before running SAFE code\n" . "=comment\n\n" . $pre_code . "\n\n=cut\n" ; } if(exists $options->{SAFE}{COMPARTMENT}) { $compartment = $options->{SAFE}{COMPARTMENT} ; } else { $compartment = new Safe($package) ; } $compartment_use_strict = $options->{SAFE}{USE_STRICT} if exists $options->{SAFE}{USE_STRICT} ; } else { $options->{INTERACTION}{DIE}->($self, "$self->{NAME}: Invalid Option 'SAFE' definition at '$options->{FILE}:$options->{LINE}'!") ; } } else { $package_setup = "package $package ;" } return($package_setup, $compartment, $compartment_use_strict, $pre_code_commented_out) ; } #------------------------------------------------------------------------------- Readonly my $SET_FROM_CALLER => 2 ; Readonly my $SET_FROM_CALLER_WITH_TYPE => 3 ; Readonly my $NAME_INDEX => 0 ; Readonly my $VALUE_INDEX => 1 ; Readonly my $TYPE_INDEX => 2 ; sub GetInstalledVariablesCode { =head2 [p] GetInstalledVariablesCode Generates variables on the eval-side from the INSTALL_VARIABLES definitions. Dispatches the generation to specialize subroutines. =cut my ($self, $options) = @_ ; my ($setup_code, $teardown_code) = ($EMPTY_STRING, $EMPTY_STRING) ; for my $variable_definition (@{ $options->{INSTALL_VARIABLES} }) { my $definition_type = scalar(@{$variable_definition}) ; my $variable_name = $variable_definition->[$NAME_INDEX] ; my $variable_value = $variable_definition->[$VALUE_INDEX] ; my $variable_type = ref $variable_value ; if($SET_FROM_CALLER == $definition_type) { my ($setup, $teardown) = $self->GetVariablesSetFromCaller($options, $variable_name, $variable_value, $variable_type) ; $setup_code .= $setup ; $teardown_code .= $teardown ; } elsif($SET_FROM_CALLER_WITH_TYPE == $definition_type) { if($variable_definition->[$TYPE_INDEX] == $PERSISTENT) { my ($setup, $teardown) = $self->GetPersistentVariablesSetFromCaller ( $options, $variable_name, $variable_value, $variable_type, ) ; $setup_code .= $setup ; $teardown_code .= $teardown ; } elsif($variable_definition->[$TYPE_INDEX] == $SHARED) { my ($setup, $teardown) = $self->GetSharedVariablesSetFromCaller ( $options, $variable_name, $variable_value, $variable_type, ) ; $setup_code .= $setup ; $teardown_code .= $teardown ; } else { $self->{INTERACTION}{DIE}->($self, "Variable '$variable_name' type must be SHARED or PERSISTENT at '$options->{FILE}:$options->{LINE}'!") ; } } else { $self->{INTERACTION}{DIE}->($self, "Invalid variable definition at '$options->{FILE}:$options->{LINE}'!") ; } } return($setup_code, $teardown_code) ; } #------------------------------------------------------------------------------- my $temporary_name_index = 0 ; sub GetPersistentVariablesSetFromCaller { =head2 [p] GetPersistentVariablesSetFromCaller Generates code to make persistent variables, defined on the I available on the I. =cut my ($self, $options, $variable_name, $variable_value, $variable_type) = @_ ; my $persistance_handler_name = 'EvalContextSavePersistentVariable' ; my ($setup_code, $teardown_code) = ($EMPTY_STRING, $EMPTY_STRING) ; if(exists $self->{SHARED_VARIABLES}{$variable_name}) { $self->{INTERACTION}{DIE}->($self, "'$variable_name' can't be PERSISTENT, already SHARED, at '$options->{FILE}:$options->{LINE}'!") ; } if(! exists $self->{PERSISTENT_VARIABLES}{$variable_name}) { ($setup_code, undef) = $self->GetVariablesSetFromCaller($options, $variable_name, $variable_value, $variable_type) ; $setup_code = "# PERSISTENT, did not exist '$variable_name'\n" . $setup_code ; } else { if(ref $variable_value eq 'USE_PERSISTENT') { $setup_code = "# PERSISTENT, existed '$variable_name'\n" . "my $self->{PERSISTENT_VARIABLES}{$variable_name}\n" ; } else { ($setup_code, undef) = $self->GetVariablesSetFromCaller($options, $variable_name, $variable_value, $variable_type) ; $setup_code = "# PERSISTENT, existed '$variable_name', overridden \n" . $setup_code ; } } # save the persistent variables after the user code is run $teardown_code = "$persistance_handler_name('$variable_name', \\$variable_name) ;\n" ; # install the subroutines needed to save the persistent variables reinstall_sub ({ code => sub { my ($variable_name, $variable_ref) = @_ ; my $dump_name = $variable_name ; substr($dump_name, 0, 1, $EMPTY_STRING) ; if('SCALAR' eq ref $variable_ref) { if(defined ${$variable_ref}) { $self->{PERSISTENT_VARIABLES}{$variable_name} = "$variable_name = '${$variable_ref}' ;" ; } else { $self->{PERSISTENT_VARIABLES}{$variable_name} = "$variable_name = undef ;" ; } } elsif('REF' eq ref $variable_ref) { $self->{PERSISTENT_VARIABLES}{$variable_name} = Data::Dumper->Dump([${$variable_ref}], [$dump_name]) ; } else { # convert and serialize at once my ($sigil, $name) = $variable_name =~ /(.)(.*)/sxm ; $self->{PERSISTENT_VARIABLES}{$variable_name} = Data::Dumper->Dump([$variable_ref], [$name]) ; $self->{PERSISTENT_VARIABLES}{$variable_name} =~ s/\$$name\ =\ ./$variable_name = (/xsm ; $self->{PERSISTENT_VARIABLES}{$variable_name} =~ s/.;\Z/) ;/xsm ; } }, into => $self->{CURRENT_RUNNING_PACKAGE}, as => $persistance_handler_name, }) ; return($setup_code, $teardown_code) ; } #------------------------------------------------------------------------------- our %shared_variables ; ## no critic (Variables::ProhibitPackageVars) sub GetSharedVariablesSetFromCaller { =head2 [p] GetSharedVariablesSetFromCaller Handles the mechanism used to share variables (references) between the I and the I. Shared variables must be defined and references. If the shared variable is B, the variable that was previously shared, under the passed name, is used if it exists or an exception is raised. Also check that variables are not B and B. =cut my ($self, $options, $variable_name, $variable_value, $variable_type) = @_ ; my ($setup_code, $teardown_code) = ($EMPTY_STRING, $EMPTY_STRING) ; if(exists $self->{PERSISTENT_VARIABLES}{$variable_name}) { $self->{INTERACTION}{DIE}->($self, "'$variable_name' can't be SHARED, already PERSISTENT, at '$options->{FILE}:$options->{LINE}'!") ; } if(defined $variable_value) { if($EMPTY_STRING eq ref $variable_value) { $self->{INTERACTION}{DIE}->($self, "Need a reference to share from for '$variable_name' at '$options->{FILE}:$options->{LINE}'!") ; } my $variable_share_name = "${variable_name}_$self->{FILE}_$self->{LINE}_$temporary_name_index" ; $variable_share_name =~ s/[^a-zA-Z0-9_]+/_/xsmg ; $temporary_name_index++ ; $shared_variables{$variable_share_name} = $variable_value ; if(exists $options->{SAFE}) { $self->{SHARED_VARIABLES}{$variable_name} = $variable_share_name ; } else { # faster method $self->{SHARED_VARIABLES}{$variable_name} = q{$} . __PACKAGE__ . "::shared_variables{$variable_share_name}" ; } } if(exists $self->{SHARED_VARIABLES}{$variable_name}) { if(exists $options->{SAFE}) { $setup_code = "my $variable_name = EvalContextSharedVariable('$self->{SHARED_VARIABLES}{$variable_name}') ;\n" ; reinstall_sub({ code => sub {my ($variable_name) = @_ ; return($shared_variables{$variable_name}) ;}, into => $self->{CURRENT_RUNNING_PACKAGE}, as => 'EvalContextSharedVariable', }) ; } else { $setup_code = "my $variable_name = $self->{SHARED_VARIABLES}{$variable_name} ;\n" ; # not in Safe, we can access other packages } } else { $self->{INTERACTION}{DIE}->($self, "Nothing previously shared to '$variable_name' at '$options->{FILE}:$options->{LINE}'!") ; } return($setup_code, $teardown_code) ; } #------------------------------------------------------------------------------- my %valid_sigil = map {$_ => 1} qw($ @ %) ; sub GetVariablesSetFromCaller { =head2 [p] GetVariablesSetFromCaller Generates code that creates local variables on the I =cut my ($self, $options, $variable_name, $variable_value, $variable_type) = @_ ; my $DIE = $self->{INTERACTION}{DIE} ; my $code_to_evaluate = $EMPTY_STRING ; my ($sigil, $name) = $variable_name =~ /(.)(.*)/sxm ; $DIE->($self, "Invalid variable type for '$variable_name' at '$options->{FILE}:$options->{LINE}'!") unless $valid_sigil{$sigil} ; if(! defined $variable_value) { $code_to_evaluate .= "my $variable_name = undef ;\n" ; } else { if($EMPTY_STRING eq $variable_type) { $code_to_evaluate .= "my $variable_name = '$variable_value';\n" ; } else { # set from reference my $conversion = $EMPTY_STRING ; if($sigil eq q{$}) { # reference to reference, no conversion needed $conversion = Data::Dumper->Dump([$variable_value], [$variable_name] ) ; } else { $conversion = Data::Dumper->Dump([$variable_value], [$name]) ; $conversion =~ s/\A\$$name\ =\ ./$variable_name = (/xsm ; $conversion =~ s/.;\Z/) ;/xsm ; } $code_to_evaluate .= "my $conversion" ; } } return($code_to_evaluate, $EMPTY_STRING) ; } #------------------------------------------------------------------------------- sub GetPersistentVariableNames { =head2 GetPersistentVariableNames() I - none I - the list of existing persistent variables names my @persistent_variable_names = $context->GetPersistantVariablesNames() ; =cut my ($self) = @_ ; return(keys %{ $self->{PERSISTENT_VARIABLES} }) ; } #------------------------------------------------------------------------------- sub GetPersistantVariables { =head2 GetPersistantVariables(@variable_names) I =over 2 =item * @variable_names - list of variable names to retrieve =back I - list of values corresponding to the input names This subroutine will return whatever the I set or the I modified. Thus if you created a I<%hash> persistent variable, a hash (not a hash reference) will be returned. If you request multiple values, list flattening will be in effect. Be careful. my $context = new Eval::Context ( INSTALL_VARIABLES => [ ['%hash' => \%hash_caller_side => $Eval::Context::PERSISTENT] ] , ) ; $context->Eval(CODE => '$hash{A}++ ;') ; # may throw exception my %hash_after_eval = $context->GetPersistantVariables('%hash') ; =cut my ($self, @variable_names) = @_ ; my ($package, $file_name, $line) = caller() ; my @values ; for my $variable_name (@variable_names) { if(exists $self->{PERSISTENT_VARIABLES}{$variable_name}) { my @variable_values = eval 'my ' . $self->{PERSISTENT_VARIABLES}{$variable_name} ; ## no critic (BuiltinFunctions::ProhibitStringyEval) push @values, @variable_values ; } else { $self->{INTERACTION}{DIE}-> ( $self, "PERSISTENT variable '$variable_name' doesn't exist, can't be fetched at '$file_name:$line'!" ) ; } } if(defined wantarray) { if(wantarray) { return(@values) ; } else { return $values[0] ; } } else { return #PBP ( $self->{INTERACTION}{DIE}-> ( $self, "GetPersistantVariables called in void context at '$file_name:$line'!" ) ) } } #------------------------------------------------------------------------------- sub SetEvalSidePersistenceHandlers { =head2 [p] SetEvalSidePersistenceHandlers Set the code needed to handle I persistent variables. =cut my ($self, $options) = @_ ; if('HASH' eq ref $options->{EVAL_SIDE_PERSISTENT_VARIABLES}) { my $category = defined $options->{EVAL_SIDE_PERSISTENT_VARIABLES}{CATEGORY} ? $options->{EVAL_SIDE_PERSISTENT_VARIABLES}{CATEGORY} : $self->{CURRENT_RUNNING_PACKAGE} ; my %handler_sub_validators ; my %handler_subs = ( SAVE => sub { my (@name_values) = @_ ; if(scalar(@_) % 2) { my ($package, $file_name, $line) = caller() ; $self->{INTERACTION}{DIE}-> ( $self, "$self->{NAME}: eval-side persistence handler got unexpected number of arguments " . "at '$file_name:$line'!" ) ; } while(my ($variable_name, $value) = splice(@name_values, 0, 2)) { $handler_sub_validators{SAVE}->($self, $variable_name, $value) ; $self->{PERSISTENT_VARIABLES_FOR_EVAL_SIDE}{$category}{$variable_name} = $value ; } }, GET => sub { my @values ; for my $variable_name (@_) { $handler_sub_validators{GET}->($self, $variable_name) ; push @values, $self->{PERSISTENT_VARIABLES_FOR_EVAL_SIDE}{$category}{$variable_name} ; } return wantarray ? @values : $values[0] ; }, ) ; for my $handler_type ('SAVE', 'GET') { if(exists $options->{EVAL_SIDE_PERSISTENT_VARIABLES}{$handler_type}) { if ( exists $options->{EVAL_SIDE_PERSISTENT_VARIABLES}{$handler_type}{VALIDATOR} && 'CODE' eq ref $options->{EVAL_SIDE_PERSISTENT_VARIABLES}{$handler_type}{VALIDATOR} && $EMPTY_STRING eq ref $options->{EVAL_SIDE_PERSISTENT_VARIABLES}{$handler_type}{NAME} && $EMPTY_STRING ne $options->{EVAL_SIDE_PERSISTENT_VARIABLES}{$handler_type}{NAME} ) { $handler_sub_validators{$handler_type} = $options->{EVAL_SIDE_PERSISTENT_VARIABLES}{$handler_type}{VALIDATOR} ; reinstall_sub({ code => $handler_subs{$handler_type}, into => $self->{CURRENT_RUNNING_PACKAGE}, as => $options->{EVAL_SIDE_PERSISTENT_VARIABLES}{$handler_type}{NAME} }) ; } else { $options->{INTERACTION}{DIE}-> ( $self, "$self->{NAME}: 'EVAL_SIDE_PERSISTENT_VARIABLES' invalid definition " . "at '$options->{FILE}:$options->{LINE}'!" ) ; } } else { $options->{INTERACTION}{DIE}-> ( $self, "$self->{NAME}: 'EVAL_SIDE_PERSISTENT_VARIABLES' missing handler definition " . "at '$options->{FILE}:$options->{LINE}'!" ) ; } } if($options->{EVAL_SIDE_PERSISTENT_VARIABLES}{SAVE}{NAME} eq $options->{EVAL_SIDE_PERSISTENT_VARIABLES}{GET}{NAME}) { $options->{INTERACTION}{DIE}-> ( $self, "$self->{NAME}: invalid definition, eval-side persistence handlers have the same name " . "at '$options->{FILE}:$options->{LINE}'!" ) ; } } else { $options->{INTERACTION}{DIE}->($self, "$self->{NAME}: 'EVAL_SIDE_PERSISTENT_VARIABLES' isn't a hash reference at '$options->{FILE}:$options->{LINE}'!") ; } return(1) ; } #------------------------------------------------------------------------------- sub RemoveEvalSidePersistenceHandlers { =head2 [p] RemoveEvalSidePersistenceHandlers Removes I persistent variable handlers. Used after calling C so the next C can not access I persistent variables without being allowed to do so. =cut my ($self, $options) = @_ ; for my $handler_type ('SAVE', 'GET') { reinstall_sub({ code => sub { $options->{INTERACTION}{DIE}-> ( $self, "$self->{NAME}: No Persistence allowed on eval-side in package '$self->{CURRENT_RUNNING_PACKAGE}'!\n" ) ; }, into => $self->{CURRENT_RUNNING_PACKAGE}, as => $options->{EVAL_SIDE_PERSISTENT_VARIABLES}{$handler_type}{NAME} }) ; } return(1) ; } #------------------------------------------------------------------------------- 1 ; =head1 BUGS AND LIMITATIONS I have reported a very strange error when B and B are used together. L. The error can be reproduced without using B. =head1 AUTHOR Khemir Nadim ibn Hamouda CPAN ID: NKH mailto:nadim@khemir.net =head1 LICENSE AND COPYRIGHT This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Eval::Context You can also look for information at: =over 4 =item * AnnoCPAN: Annotated CPAN documentation L =item * RT: CPAN's request tracker Please report any bugs or feature requests to L . We will be notified, and then you'll automatically be notified of progress on your bug as we make changes. =item * Search CPAN L =back =cut