Permalink
Browse files

initial commit

  • Loading branch information...
1 parent c8b08d1 commit 845b899f62172c605e26ae179a14c908aa631d8b @jrockway committed Sep 21, 2010
Showing with 188 additions and 0 deletions.
  1. +108 −0 Clean.xs
  2. +6 −0 Makefile.PL
  3. +1 −0 dist.ini
  4. +32 −0 examples/repl.pl
  5. +11 −0 lib/Eval/Clean.pm
  6. +29 −0 t/basic.t
  7. +1 −0 typemap
View
108 Clean.xs
@@ -0,0 +1,108 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+static PerlInterpreter *main_perl;
+char *default_args[] = { "a_perl", "-e", "0" };
+
+static void xs_init (pTHX);
+
+EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
+
+EXTERN_C void xs_init(pTHX) {
+ char *file = __FILE__;
+ /* DynaLoader is a special case */
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+}
+
+MODULE = Eval::Clean PACKAGE = Eval::Clean
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ main_perl = PERL_GET_CONTEXT;
+
+PerlInterpreter *
+new_perl()
+ CODE:
+ PerlInterpreter *perl;
+
+ perl = perl_alloc();
+
+ my_perl = perl;
+ PERL_SET_CONTEXT(my_perl);
+
+ perl_construct(perl);
+ perl_parse(perl, xs_init, 3, default_args, (char **)NULL);
+
+ my_perl = main_perl;
+ PERL_SET_CONTEXT(main_perl);
+
+ RETVAL = perl;
+
+ OUTPUT:
+ RETVAL
+
+void
+free_perl(PerlInterpreter *perl)
+ CODE:
+ perl_destruct(perl);
+ perl_free(perl);
+
+const char *
+eval(PerlInterpreter *code_perl, const char *code, const char *after_code)
+ CODE:
+ PerlInterpreter *after_perl;
+ SV *code_result, *after_cv, *after_result;
+ int count = 0;
+
+ after_perl = perl_alloc();
+ perl_construct(after_perl);
+
+ my_perl = code_perl;
+ PERL_SET_CONTEXT(code_perl);
+
+ //printf("Running '%s'...\n", code);
+ code_result = eval_pv(code, TRUE);
+ //printf("got SV at %#x (%s)\n", code_result, SvPV_nolen(code_result));
+
+ after_perl = perl_clone(code_perl, 0);
+ //printf("oh hai, we have a new perl at %#x (old: %#x)\n", after_perl, code_perl);
+
+ my_perl = after_perl;
+ PERL_SET_CONTEXT(after_perl);
+
+ //printf("Running '%s'...\n", after_code);
+ after_cv = eval_pv(after_code, TRUE);
+ //printf("got SV at %#x\n", after_result);
+
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ XPUSHs(code_result);
+ PUTBACK;
+
+ count = call_sv(after_cv, G_SCALAR);
+
+ if(count != 1)
+ croak("Something bad happened; expecting 1 value but got %d", count);
+
+ SPAGAIN;
+ after_result = POPs;
+ RETVAL = strdup(SvPV_nolen(after_result));
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+
+ perl_destruct(after_perl);
+ perl_free(after_perl);
+
+ my_perl = main_perl;
+ PERL_SET_CONTEXT(main_perl);
+
+ OUTPUT:
+ RETVAL
View
@@ -0,0 +1,6 @@
+use inc::Module::Install;
+use strict;
+
+all_from 'lib/Eval/Clean.pm';
+libs '-lperl';
+WriteAll;
View
@@ -21,6 +21,7 @@ format = %-9v %{EEE LLL d hh:mm:ss vvv YYYY}d
[PodWeaver]
[Repository]
+url = git://github.com/jrockway/eval-clean.git
[GatherDir]
View
@@ -0,0 +1,32 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature ':5.10';
+
+use FindBin qw($Bin);
+use lib "$Bin/../lib";
+
+use Eval::Clean;
+
+use Term::ReadLine;
+use Data::Dump::Streamer;
+
+my $term = Term::ReadLine->new(*STDIN);
+my $perl = Eval::Clean::new_perl();
+
+while(my $line = $term->readline('PERL> ')){
+ eval {
+ my $code = "my \$code = sub { $line }; [eval { +{ result => scalar \$code->()} } || { error => \$@ }, \$code]";
+ my $show = 'use Data::Dump::Streamer; sub { Dump($_[0])->Out }';
+ my $output = Eval::Clean::eval($perl, $code, $show);
+
+ my $results = eval $output or die;
+ say Dump($results);
+ };
+ if($@){
+ say "error: $@";
+ }
+}
+
+Eval::Clean::free_perl($perl);
View
@@ -0,0 +1,11 @@
+package Eval::Clean;
+# ABSTRACT: run code in a pristine perl interpreter and inspect the results in another
+use strict;
+use warnings;
+use XSLoader;
+
+our $VERSION;
+
+XSLoader::load 'Eval::Clean', $Eval::Clean::VERSION;
+
+1;
View
@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN { use_ok 'Eval::Clean' };
+use JSON;
+
+my $perl = Eval::Clean::new_perl();
+ok $perl, 'got a new perl';
+
+my $result = Eval::Clean::eval($perl, '{ foo => 42, bar => "baz" }',
+ 'use JSON; sub { encode_json($_[0]) }');
+is $result, '{"bar":"baz","foo":42}', 'it worked';
+
+{
+my $libs = Eval::Clean::eval($perl, "use strict; \\%INC", 'use JSON; \\&encode_json');
+my $libs_hash = decode_json($libs);
+is_deeply [keys %$libs_hash], ['strict.pm'], 'only strict is loaded in first perl';
+}
+
+{
+Eval::Clean::eval($perl, "package main; our \$GLOBAL = 123;", 'sub {}');
+my $global = Eval::Clean::eval($perl, "\$GLOBAL", 'sub { $_[0] }');
+is $global, 123, 'state is preserved between perls';
+}
+
+Eval::Clean::free_perl($perl);
+
+done_testing;
View
@@ -0,0 +1 @@
+PerlInterpreter * T_PTROBJ

0 comments on commit 845b899

Please sign in to comment.