[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