[Jifty-commit] r5379 - Runops-Hook/trunk

[Jifty commits]

Author: nothingmuch
Date: Wed May  7 08:48:18 2008
New Revision: 5379

Modified:
   Runops-Hook/trunk/Hook.xs

Log:
pass args to perl hook, except for aassign (binary listop is a bit scary))

Modified: Runops-Hook/trunk/Hook.xs
==============================================================================
--- Runops-Hook/trunk/Hook.xs	(original)
+++ Runops-Hook/trunk/Hook.xs	Wed May  7 08:48:18 2008
@@ -19,6 +19,14 @@
 static UNOP Runops_Hook_fakeop;
 static SV *Runops_Hook_fakeop_sv;
 
+enum Runops_Hook_OP_ARITY {
+	ARITY_NULL,
+	ARITY_UNARY,
+	ARITY_BINARY,
+	ARITY_LIST,
+	ARITY_UNKNOWN
+};
+
 /* this is the modified runloop */
 int runops_hooked(pTHX)
 {
@@ -100,11 +108,37 @@
 	return POPs;
 }
 
+IV
+Runops_Hook_op_arity (pTHX_ OP *o) {
+	switch (PL_opargs[o->op_type] >> OASHIFT) {
+		case 2:
+			return ARITY_LIST;
+		case 1:
+			return ARITY_UNARY;
+		case 0:
+			return ARITY_NULL;
+		default:
+			switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
+				case OA_BINOP:
+					if ( !strcmp(PL_op_name[o->op_type], "aassign") ) {
+						return ARITY_UNKNOWN;
+					} else {
+						return ARITY_BINARY;
+					}
+				default:
+					return ARITY_UNKNOWN;
+			}
+	}
+}
+
 /* this is a hook that calls to a perl code ref */
 bool
 Runops_Hook_perl (pTHX) {
 	dSP;
 
+	register SV **orig_sp = SP;
+	register SV **list_mark;
+
 	SV *sv_ret;
 	SV *PL_op_object;
 	bool ret;
@@ -120,6 +154,30 @@
 	PUSHMARK(SP);
 	XPUSHs(Runops_Hook_perl_hook);
 	XPUSHs(PL_op_object);
+
+	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;) {
+				XPUSHs(*++list_mark);
+			}
+
+			break;
+
+		case ARITY_BINARY:
+			XPUSHs(*(orig_sp - 1));
+		case ARITY_UNARY:
+			XPUSHs(*orig_sp);
+			break;
+
+		case ARITY_NULL:
+			break;
+
+		case ARITY_UNKNOWN:
+			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));