Upgrade to Devel::PPPort 3.11_01

p4raw-id: //depot/perl@30728

8 files changed, 135 insertions, 18 deletions

diff --git a/ext/Devel/PPPort/Changes b/ext/Devel/PPPort/Changes
index 251dc4d217..0a7b8babb3 100755
--- a/ext/Devel/PPPort/Changes
+++ b/ext/Devel/PPPort/Changes
@@ -1,3 +1,11 @@
+3.11_01 - 2007-03-23
+
+    * added support for the following API
+        PL_expect
+        load_module
+        vload_module
+      (thanks to Nicholas Clark for providing a patch)
+
 3.11 - 2007-02-14
 
     * happy new year!
diff --git a/ext/Devel/PPPort/PPPort_pm.PL b/ext/Devel/PPPort/PPPort_pm.PL
index 934f19fff5..77356ad584 100644
--- a/ext/Devel/PPPort/PPPort_pm.PL
+++ b/ext/Devel/PPPort/PPPort_pm.PL
@@ -4,9 +4,9 @@
 #
 ################################################################################
 #
-#  $Revision: 51 $
+#  $Revision: 52 $
 #  $Author: mhx $
-#  $Date: 2007/01/02 12:32:27 +0100 $
+#  $Date: 2007/03/23 16:27:19 +0100 $
 #
 ################################################################################
 #
@@ -284,6 +284,7 @@ sub make_embed
   my $f = shift;
   my $n = $f->{name};
   my $a = do { my $x = 'a'; join ',', map { $x++ } 1 .. @{$f->{args}} };
+  my $lastarg = ${$f->{args}}[-1];
 
   if ($f->{flags}{n}) {
     if ($f->{flags}{p}) {
@@ -304,6 +305,10 @@ UNDEF
       if ($f->{flags}{f}) {
         return "#define Perl_$n $DPPP(my_$n)";
       }
+      elsif (@$lastarg && $lastarg->[0] =~ /\.\.\./) {
+        return $undef . "#define $n $DPPP(my_$n)\n" .
+                        "#define Perl_$n $DPPP(my_$n)";
+      }
       else {
         return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)\n" .
                         "#define Perl_$n $DPPP(my_$n)";
@@ -339,9 +344,9 @@ __DATA__
 #
 ################################################################################
 #
-#  $Revision: 51 $
+#  $Revision: 52 $
 #  $Author: mhx $
-#  $Date: 2007/01/02 12:32:27 +0100 $
+#  $Date: 2007/03/23 16:27:19 +0100 $
 #
 ################################################################################
 #
@@ -502,7 +507,7 @@ package Devel::PPPort;
 use strict;
 use vars qw($VERSION $data);
 
-$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.11 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
+$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.11_01 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
 
 sub _init_data
 {
diff --git a/ext/Devel/PPPort/parts/inc/call b/ext/Devel/PPPort/parts/inc/call
index f3858f0e83..0b19ae41cc 100644
--- a/ext/Devel/PPPort/parts/inc/call
+++ b/ext/Devel/PPPort/parts/inc/call
@@ -1,8 +1,8 @@
 ################################################################################
 ##
-##  $Revision: 10 $
+##  $Revision: 12 $
 ##  $Author: mhx $
-##  $Date: 2007/01/02 12:32:32 +0100 $
+##  $Date: 2007/03/23 17:57:58 +0100 $
 ##
 ################################################################################
 ##
@@ -23,6 +23,8 @@ call_sv
 call_pv
 call_argv
 call_method
+load_module
+vload_module
 
 =implementation
 
@@ -33,6 +35,11 @@ __UNDEFINED__  call_argv     perl_call_argv
 __UNDEFINED__  call_method   perl_call_method
 
 __UNDEFINED__  eval_sv       perl_eval_sv
+
+__UNDEFINED__ PERL_LOADMOD_DENY		0x1
+__UNDEFINED__ PERL_LOADMOD_NOIMPORT	0x2
+__UNDEFINED__ PERL_LOADMOD_IMPORT_OPS	0x4
+
 /* Replace: 0 */
 
 /* Replace perl_eval_pv with eval_pv */
@@ -64,9 +71,87 @@ eval_pv(char *p, I32 croak_on_error)
 #endif
 #endif
 
+#ifndef vload_module
+#if { NEED vload_module }
+
+void
+vload_module(U32 flags, SV *name, SV *ver, va_list *args)
+{
+    dTHR;
+    dVAR;
+    OP *veop, *imop;
+
+    OP * const modname = newSVOP(OP_CONST, 0, name);
+    /* 5.005 has a somewhat hacky force_normal that doesn't croak on
+       SvREADONLY() if PL_compling is true. Current perls take care in
+       ck_require() to correctly turn off SvREADONLY before calling
+       force_normal_flags(). This seems a better fix than fudging PL_compling
+     */
+    SvREADONLY_off(((SVOP*)modname)->op_sv);
+    modname->op_private |= OPpCONST_BARE;
+    if (ver) {
+	veop = newSVOP(OP_CONST, 0, ver);
+    }
+    else
+	veop = NULL;
+    if (flags & PERL_LOADMOD_NOIMPORT) {
+	imop = sawparens(newNULLLIST());
+    }
+    else if (flags & PERL_LOADMOD_IMPORT_OPS) {
+	imop = va_arg(*args, OP*);
+    }
+    else {
+	SV *sv;
+	imop = NULL;
+	sv = va_arg(*args, SV*);
+	while (sv) {
+	    imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
+	    sv = va_arg(*args, SV*);
+	}
+    }
+    {
+	const line_t ocopline = PL_copline;
+	COP * const ocurcop = PL_curcop;
+	const int oexpect = PL_expect;
+
+#if { VERSION >= 5.004 }
+	utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
+		veop, modname, imop);
+#else
+	utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
+		modname, imop);
+#endif
+	PL_expect = oexpect;
+	PL_copline = ocopline;
+	PL_curcop = ocurcop;
+    }
+}
+
+#endif
+#endif
+
+/* load_module depends on vload_module */
+
+#ifndef load_module
+#if { NEED load_module }
+
+void
+load_module(U32 flags, SV *name, SV *ver, ...)
+{
+    va_list args;
+    va_start(args, ver);
+    vload_module(flags, name, ver, &args);
+    va_end(args);
+}
+
+#endif
+#endif
+
 =xsinit
 
 #define NEED_eval_pv
+#define NEED_load_module
+#define NEED_vload_module
 
 =xsubs
 
@@ -183,7 +268,19 @@ call_method(methname, flags, ...)
 		EXTEND(SP, 1);
 		PUSHs(sv_2mortal(newSViv(i)));
 
-=tests plan => 44
+void
+load_module(flags, name, version, ...)
+	U32 flags
+	SV *name
+	SV *version
+	CODE:
+		/* Both SV parameters are donated to the ops built inside
+		   load_module, so we need to bump the refcounts.  */
+		SvREFCNT_inc(name);
+		SvREFCNT_inc(version);
+		Perl_load_module(aTHX_ flags, name, version, NULL);
+
+=tests plan => 46
 
 sub eq_array
 {
@@ -237,3 +334,6 @@ for $test (
 ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
 ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
 
+ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
+Devel::PPPort::load_module(0, "less", undef);  
+ok(defined $::{'less::'}, 1, "Have now loaded less");
diff --git a/ext/Devel/PPPort/parts/inc/variables b/ext/Devel/PPPort/parts/inc/variables
index 8c50b31b1c..e7001ae9a5 100644
--- a/ext/Devel/PPPort/parts/inc/variables
+++ b/ext/Devel/PPPort/parts/inc/variables
@@ -1,8 +1,8 @@
 ################################################################################
 ##
-##  $Revision: 7 $
+##  $Revision: 8 $
 ##  $Author: mhx $
-##  $Date: 2007/01/02 12:32:31 +0100 $
+##  $Date: 2007/03/23 16:24:34 +0100 $
 ##
 ################################################################################
 ##
@@ -71,6 +71,7 @@ __NEED_VAR__ U32 PL_signals = D_PPP_PERL_SIGNALS_INIT;
 #  define PL_dirty                  dirty
 #  define PL_dowarn                 dowarn
 #  define PL_errgv                  errgv
+#  define PL_expect                 expect
 #  define PL_hexdigit               hexdigit
 #  define PL_hints                  hints
 #  define PL_laststatval            laststatval
@@ -210,6 +211,7 @@ other_variables()
 		ppp_TESTVAR(PL_dirty);
 		ppp_TESTVAR(PL_dowarn);
 		ppp_TESTVAR(PL_errgv);
+		ppp_TESTVAR(PL_expect);
 		ppp_TESTVAR(PL_laststatval);
 		ppp_TESTVAR(PL_no_modify);
 		ppp_TESTVAR(PL_perl_destruct_level);
@@ -225,7 +227,7 @@ other_variables()
 		ppp_TESTVAR(PL_tainting);
 		XSRETURN(count);
 
-=tests plan => 36
+=tests plan => 37
 
 ok(Devel::PPPort::compare_PL_signals());
 
diff --git a/ext/Devel/PPPort/parts/todo/5006000 b/ext/Devel/PPPort/parts/todo/5006000
index 188f44810f..e16d27b05a 100644
--- a/ext/Devel/PPPort/parts/todo/5006000
+++ b/ext/Devel/PPPort/parts/todo/5006000
@@ -85,7 +85,6 @@ is_utf8_punct                  # U
 is_utf8_space                  # U
 is_utf8_upper                  # U
 is_utf8_xdigit                 # U
-load_module                    # U
 magic_dump                     # U
 mess                           # E (Perl_mess)
 my_atof                        # U
@@ -148,7 +147,6 @@ utf8_distance                  # U
 utf8_hop                       # U
 vcroak                         # U
 vform                          # U
-vload_module                   # U
 vmess                          # U
 vwarn                          # U
 vwarner                        # U
diff --git a/ext/Devel/PPPort/soak b/ext/Devel/PPPort/soak
index 4a301bf6d3..26b7299801 100644
--- a/ext/Devel/PPPort/soak
+++ b/ext/Devel/PPPort/soak
@@ -33,7 +33,7 @@ use File::Find;
 use List::Util qw(max);
 use Config;
 
-my $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.11 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
+my $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.11_01 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
 
 $| = 1;
 my %OPT = (
diff --git a/ext/Devel/PPPort/t/call.t b/ext/Devel/PPPort/t/call.t
index aee8819bf0..beecf3d888 100644
--- a/ext/Devel/PPPort/t/call.t
+++ b/ext/Devel/PPPort/t/call.t
@@ -30,9 +30,9 @@ BEGIN {
     require 'testutil.pl' if $@;
   }
 
-  if (44) {
+  if (46) {
     load();
-    plan(tests => 44);
+    plan(tests => 46);
   }
 }
 
@@ -100,3 +100,7 @@ for $test (
 ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
 ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
 
+ok(!defined $::{'less::'}, 1, "Hadn't loaded less yet");
+Devel::PPPort::load_module(0, "less", undef);  
+ok(defined $::{'less::'}, 1, "Have now loaded less");
+
diff --git a/ext/Devel/PPPort/t/variables.t b/ext/Devel/PPPort/t/variables.t
index 05547241d5..b616c5bc93 100644
--- a/ext/Devel/PPPort/t/variables.t
+++ b/ext/Devel/PPPort/t/variables.t
@@ -30,9 +30,9 @@ BEGIN {
     require 'testutil.pl' if $@;
   }
 
-  if (36) {
+  if (37) {
     load();
-    plan(tests => 36);
+    plan(tests => 37);
   }
 }