[Jifty-commit] r5388 - in Runops-Hook/trunk: .

Jifty commits jifty-commit at lists.jifty.org
Wed May 7 13:59:24 EDT 2008


Author: nothingmuch
Date: Wed May  7 13:59:23 2008
New Revision: 5388

Added:
   Runops-Hook/trunk/t/08fact.t
Modified:
   Runops-Hook/trunk/Hook.xs
   Runops-Hook/trunk/t/07perl_Hook.t

Log:
arity refactoring

Modified: Runops-Hook/trunk/Hook.xs
==============================================================================
--- Runops-Hook/trunk/Hook.xs	(original)
+++ Runops-Hook/trunk/Hook.xs	Wed May  7 13:59:23 2008
@@ -21,14 +21,13 @@
 static UNOP Runops_Hook_fakeop;
 static SV *Runops_Hook_fakeop_sv;
 
-enum Runops_Hook_OP_ARITY {
-	ARITY_UNKNOWN = 0,
-	ARITY_NULL,
-	ARITY_UNARY,
-	ARITY_BINARY,
-	ARITY_LIST,
-	ARITY_LIST_BINARY,
-};
+#define ARITY_NULL 0
+#define ARITY_UNARY 1
+#define ARITY_BINARY 1 << 1
+#define ARITY_LIST 1 << 2
+#define ARITY_LIST_BINARY (ARITY_LIST|ARITY_BINARY)
+#define ARITY_LIST_UNARY (ARITY_LIST|ARITY_UNARY)
+#define ARITY_UNKNOWN 1 << 3
 
 /* this is the modified runloop */
 int runops_hooked(pTHX)
@@ -113,24 +112,46 @@
 
 IV
 Runops_Hook_op_arity (pTHX_ OP *o) {
-	switch (PL_opargs[o->op_type] >> OASHIFT) {
-		case 2:
+	switch (o->op_type) {
+		case OP_SASSIGN:
+			/* wtf? */
+			return ((o->op_private & OPpASSIGN_BACKWARDS) ? ARITY_UNARY : ARITY_BINARY);
+
+		case OP_ENTERSUB:
+			return ARITY_LIST_UNARY;
+
+		case OP_REFGEN:
 			return ARITY_LIST;
-		case 1:
-			return ARITY_UNARY;
-		case 0:
+	}
+
+	switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
+		case OA_COP:
+		case OA_SVOP:
+		case OA_PADOP:
+		case OA_BASEOP:
+		case OA_FILESTATOP:
+		case OA_LOOPEXOP:
 			return ARITY_NULL;
-		default:
-			switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
-				case OA_BINOP:
-					if ( o->op_type == OP_AASSIGN ) {
-						return ARITY_LIST_BINARY;
-					} else {
-						return ARITY_BINARY;
-					}
-				default:
-					return ARITY_UNKNOWN;
+
+		case OA_BASEOP_OR_UNOP:
+			return (o->op_flags & OPf_KIDS) ? ARITY_UNARY : ARITY_NULL;
+
+		case OA_LOGOP:
+		case OA_UNOP:
+			return ARITY_UNARY;
+
+		case OA_LISTOP:
+			return ARITY_LIST;
+
+		case OA_BINOP:
+			if ( o->op_type == OP_AASSIGN ) {
+				return ARITY_LIST_BINARY;
+			} else {
+				return ARITY_BINARY;
 			}
+		default:
+			printf("%s is a %d\n", PL_op_name[o->op_type], PL_opargs[o->op_type] >> OASHIFT);
+			return ARITY_UNKNOWN;
 	}
 }
 
@@ -159,6 +180,7 @@
 	SV *sv_ret;
 	SV *PL_op_object;
 	bool ret;
+	IV arity;
 
 	/* don't want to hook the hook */
 	Runops_Hook_disable();
@@ -167,12 +189,18 @@
 	SAVETMPS;
 
 	PL_op_object = Runops_Hook_op_to_BOP(aTHX_ PL_op);
+	arity = Runops_Hook_op_arity(aTHX_ PL_op);
+
 
 	PUSHMARK(SP);
 	XPUSHs(Runops_Hook_perl_hook);
 	XPUSHs(PL_op_object);
+	XPUSHs(sv_2mortal(newSViv(arity)));
 
-	switch ( Runops_Hook_op_arity(aTHX_ PL_op) ) {
+	switch (arity) {
+		case ARITY_LIST_UNARY:
+			/* ENTERSUB's unary arg (the cv) is the last thing on the stack, but it has args too */
+			XPUSHREF(*orig_sp--);
 		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) + 1; list_mark <= orig_sp; list_mark++) {
@@ -181,15 +209,17 @@
 
 			break;
 
+
 		case ARITY_BINARY:
 			XPUSHREF(*(orig_sp-1));
 		case ARITY_UNARY:
 			XPUSHREF(*orig_sp);
 			break;
 
+
 		case ARITY_LIST_BINARY:
 			{
-				SV **mark = PL_stack_base + TOPMARK + 2; dORIGMARK;
+				SV **mark = SP; dORIGMARK;
 
 				SV **lastlelem = orig_sp;
 				SV **lastrelem = PL_stack_base + *(PL_markstack_ptr-1);
@@ -210,11 +240,13 @@
 		case ARITY_NULL:
 			break;
 
+
 		default:
 			warn("Unknown arity for %s (%p)", PL_op_name[PL_op->op_type], PL_op);
 			break;
 	}
 
+
 	PUTBACK;
 
 	call_sv(Runops_Hook_perl_hook, (Runops_Hook_perl_ignore_ret ? G_DISCARD : G_SCALAR));
@@ -371,3 +403,4 @@
 {
 	Runops_Hook_perl_ignore_ret = 0;
 }
+

Modified: Runops-Hook/trunk/t/07perl_Hook.t
==============================================================================
--- Runops-Hook/trunk/t/07perl_Hook.t	(original)
+++ Runops-Hook/trunk/t/07perl_Hook.t	Wed May  7 13:59:23 2008
@@ -11,17 +11,17 @@
 my ( $called, @ops, @refgen_args, @aassign_args );
 
 Runops::Hook::set_hook(sub {
-	my ( $hook, $op, @args ) = @_;
+	my ( $hook, $op, $arity, @args ) = @_;
 
 	$called++;
 
 	if ( $op->name eq 'refgen' and @refgen_args < 2 ) {
-		push @refgen_args, [ @_[2 .. $#_] ];
+		push @refgen_args, [ @args ];
 	} elsif ( $op->name eq 'aassign' ) {
-		push @aassign_args, [ @_[2 .. $#_] ];
+		push @aassign_args, [ @args ];
 	}
 
-	push @ops, $_[1];
+	push @ops, $op;
 });
 
 my $i;
@@ -83,3 +83,4 @@
 	]],
 	"aassign",
 );
+

Added: Runops-Hook/trunk/t/08fact.t
==============================================================================
--- (empty file)
+++ Runops-Hook/trunk/t/08fact.t	Wed May  7 13:59:23 2008
@@ -0,0 +1,38 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More qw(no_plan);
+use Runops::Hook;
+
+use B::Concise;
+
+B::Concise::compile("fact")->();
+B::Concise::compile(-exec => "fact")->();
+
+sub fact {
+	my $n = $_[0];
+
+	if ( $n <= 1 ) {
+		return $n;
+	} else {
+		return ( $n * fact($n - 1) );
+	}
+}
+
+Runops::Hook::set_hook(sub {
+	my ( $self, $op, $arity, @args ) = @_;
+
+	#warn "op name: ", $op->name, "($$op) arity: ", $arity, " args: ", \@args;
+	#use Devel::Peek;
+	#Dump($_) for @args;
+});
+
+Runops::Hook::enable();
+
+my $f = fact(3);
+
+Runops::Hook::disable();
+
+is( $f, 6 );


More information about the Jifty-commit mailing list