[Jifty-commit] r5383 - in Runops-Hook/trunk: .
Jifty commits
jifty-commit at lists.jifty.org
Wed May 7 10:51:22 EDT 2008
Author: nothingmuch
Date: Wed May 7 10:51:18 2008
New Revision: 5383
Added:
Runops-Hook/trunk/t/07perl_Hook.t
Modified:
Runops-Hook/trunk/Hook.xs
Log:
Add forgotten test, and fix aassign
Modified: Runops-Hook/trunk/Hook.xs
==============================================================================
--- Runops-Hook/trunk/Hook.xs (original)
+++ Runops-Hook/trunk/Hook.xs Wed May 7 10:51:18 2008
@@ -4,7 +4,7 @@
#include "embed.h"
#include "XSUB.h"
-#define XPUSHREF(x) XPUSHs(sv_2mortal(newRV(x)))
+#define XPUSHREF(x) XPUSHs(sv_2mortal(newRV_inc(x)))
bool (*Runops_Hook_hook)(pTHX);
@@ -22,11 +22,12 @@
static SV *Runops_Hook_fakeop_sv;
enum Runops_Hook_OP_ARITY {
+ ARITY_UNKNOWN = 0,
ARITY_NULL,
ARITY_UNARY,
ARITY_BINARY,
ARITY_LIST,
- ARITY_UNKNOWN
+ ARITY_LIST_BINARY,
};
/* this is the modified runloop */
@@ -123,7 +124,7 @@
switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
case OA_BINOP:
if ( o->op_type == OP_AASSIGN ) {
- return ARITY_UNKNOWN;
+ return ARITY_LIST_BINARY;
} else {
return ARITY_BINARY;
}
@@ -160,8 +161,8 @@
switch ( Runops_Hook_op_arity(aTHX_ PL_op) ) {
case ARITY_LIST:
/* repeat stack from the op's mark to SP just before we started pushing */
- for (list_mark = PL_stack_base + *(PL_markstack_ptr-1); list_mark < orig_sp;) {
- XPUSHREF(*++list_mark);
+ for (list_mark = PL_stack_base + *(PL_markstack_ptr-1) + 1; list_mark <= orig_sp; list_mark++) {
+ XPUSHREF(*list_mark);
}
break;
@@ -172,10 +173,46 @@
XPUSHREF(*orig_sp);
break;
+ case ARITY_LIST_BINARY:
+ {
+ SV **mark = PL_stack_base + TOPMARK + 2; dORIGMARK;
+
+ printf("bin listop SP=%p, orig_sp=%p, topmark=%p, mark=%p\n", SP, orig_sp, TOPMARK, mark);
+
+ SV **lastlelem = orig_sp;
+ SV **lastrelem = PL_stack_base + *(PL_markstack_ptr-1);
+ SV **firstrelem = PL_stack_base + *(PL_markstack_ptr-2) + 1;
+ SV **firstlelem = lastrelem + 1;
+
+ printf("firstlelem=%p, lastlelem=%p, firstrelem=%p, lastrelem=%p\n", firstlelem, lastlelem, firstrelem, lastrelem);
+ printf("nlelem=%d nrelem=%d\n", (lastlelem - firstlelem) / sizeof(SV **) + 1, (lastrelem - firstrelem) + 1);
+
+ SV *lav = newAV();
+ SV *rav = newAV();
+
+ SV **i;
+
+ for (i = firstlelem; i <= lastlelem; i++) {
+ av_push(lav, newRV_inc(*i));
+ }
+
+ for (i = firstrelem; i <= lastrelem; i++) {
+ av_push(rav, newRV_inc(*i));
+ }
+
+
+ SP = ORIGMARK;
+
+ XPUSHREF(lav);
+ XPUSHREF(rav);
+ }
+
+ break;
+
case ARITY_NULL:
break;
- case ARITY_UNKNOWN:
+ default:
warn("Unknown arity for %s (%p)", PL_op_name[PL_op->op_type], PL_op);
break;
}
@@ -248,7 +285,7 @@
Runops_Hook_load_B (pTHX) {
if (!Runops_Hook_loaded_B) {
load_module( PERL_LOADMOD_NOIMPORT, newSVpvs("B"), newSViv(0) );
- Runops_Hook_fakeop_sv = sv_bless(newRV(newSVuv((UV)&Runops_Hook_fakeop)), gv_stashpv("B::UNOP", 0));
+ Runops_Hook_fakeop_sv = sv_bless(newRV_noinc(newSVuv((UV)&Runops_Hook_fakeop)), gv_stashpv("B::UNOP", 0));
Runops_Hook_loaded_B = 1;
}
}
Added: Runops-Hook/trunk/t/07perl_Hook.t
==============================================================================
--- (empty file)
+++ Runops-Hook/trunk/t/07perl_Hook.t Wed May 7 10:51:18 2008
@@ -0,0 +1,85 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Runops::Hook;
+use Test::More 'no_plan';
+
+use Scalar::Util qw(refaddr);
+
+my ( $called, @ops, @refgen_args, @aassign_args );
+
+Runops::Hook::set_hook(sub {
+ my ( $hook, $op, @args ) = @_;
+
+ $called++;
+
+ if ( $op->name eq 'refgen' and @refgen_args < 2 ) {
+ push @refgen_args, [ @_[2 .. $#_] ];
+ } elsif ( $op->name eq 'aassign' ) {
+ push @aassign_args, [ @_[2 .. $#_] ];
+ }
+
+ push @ops, $_[1];
+});
+
+my $i;
+++$i;
+
+sub foo { sub { $i } };
+sub bar { sub { $i } };
+
+Runops::Hook::enable();
+
+++$i;
+my $j = $i + 42;
+
+my ( $x, @refs ) = \( 101, [qw/dancing hippies/], 33, \&foo );
+
+$i ? foo() : bar();
+
+if ( foo() || 1 ) {
+ $j = "" . $i;
+}
+
+Runops::Hook::disable();
+
+++$i;
+
+is( $i, 3, "ops dispatched" );
+ok( $called, "hook called" );
+ok( scalar(@ops), "cought some ops" );
+
+my %seen_names;
+foreach my $op ( @ops ) {
+ isa_ok( $op, "B::OP" );
+ $seen_names{$op->name}++;
+}
+
+foreach my $opname (qw(
+ nextstate
+ preinc add
+ entersub leavesub
+ refgen sassign aassign
+ padsv padav gv
+ cond_expr and or
+ const
+ anonlist
+ concat
+)) {
+ ok( $seen_names{$opname}, "$opname op seen by hook" );
+}
+
+is_deeply( \@refgen_args, [ [ \&foo ], [ $x, @refs ] ], "listop arg capture" );
+
+is( refaddr($refgen_args[1][0]), refaddr($x), "aliasing semantics" );
+
+is_deeply(
+ \@aassign_args,
+ [[
+ [ \$x, \@refs ], # two lvalues
+ [ \$x, \(@refs) ], # four rvalues, passed to the hook by ref
+ ]],
+ "aassign",
+);
More information about the Jifty-commit
mailing list