[Jifty-commit] r5715 - in B-OP-Util: lib lib/B lib/B/OP t
Jifty commits
jifty-commit at lists.jifty.org
Wed Aug 13 11:45:28 EDT 2008
Author: clkao
Date: Wed Aug 13 11:45:28 2008
New Revision: 5715
Added:
B-OP-Util/Makefile.PL
B-OP-Util/Util.xs
B-OP-Util/lib/
B-OP-Util/lib/B/
B-OP-Util/lib/B/OP/
B-OP-Util/lib/B/OP/Util.pm
B-OP-Util/t/
B-OP-Util/t/new_cv.t
B-OP-Util/typemap
Log:
B::OP::Util
Added: B-OP-Util/Makefile.PL
==============================================================================
--- (empty file)
+++ B-OP-Util/Makefile.PL Wed Aug 13 11:45:28 2008
@@ -0,0 +1,15 @@
+use ExtUtils::MakeMaker;
+require 5.006;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+
+require ExtUtils::Depends;
+
+my $bop = ExtUtils::Depends->new("B::OP::Util", "B::Utils");
+
+WriteMakefile(
+ 'NAME' => 'B::OP::Util',
+ 'VERSION_FROM' => 'lib/B/OP/Util.pm', # finds $VERSION
+ $bop->get_makefile_vars,
+
+);
Added: B-OP-Util/Util.xs
==============================================================================
--- (empty file)
+++ B-OP-Util/Util.xs Wed Aug 13 11:45:28 2008
@@ -0,0 +1,156 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "BUtils.h"
+
+typedef OP *B__OP;
+typedef CV *B__CV;
+
+static char *
+cc_opclassname(pTHX_ const OP *o)
+{
+ return BUtils_cc_opclassname(aTHX_ o);
+}
+
+
+static SV *
+make_sv_object(pTHX_ SV *arg, SV *sv)
+{
+ return BUtils_make_sv_object(aTHX_ arg, sv);
+}
+
+/* Stolen from pp_ctl.c (with modifications) */
+
+I32
+dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
+{
+ dTHR;
+ I32 i;
+ PERL_CONTEXT *cx;
+ for (i = startingblock; i >= 0; i--) {
+ cx = &cxstk[i];
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ /*case CXt_EVAL:*/
+ case CXt_SUB:
+ case CXt_FORMAT:
+ DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
+ return i;
+ }
+ }
+ return i;
+}
+
+I32
+dopoptosub(pTHX_ I32 startingblock)
+{
+ dTHR;
+ return dopoptosub_at(aTHX_ cxstack, startingblock);
+}
+
+PERL_CONTEXT*
+upcontext(pTHX_ I32 count)
+{
+ PERL_SI *top_si = PL_curstackinfo;
+ I32 cxix = dopoptosub(aTHX_ cxstack_ix);
+ PERL_CONTEXT *cx;
+ PERL_CONTEXT *ccstack = cxstack;
+ I32 dbcxix;
+
+ for (;;) {
+ /* we may be in a higher stacklevel, so dig down deeper */
+ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
+ top_si = top_si->si_prev;
+ ccstack = top_si->si_cxstack;
+ cxix = dopoptosub_at(aTHX_ ccstack, top_si->si_cxix);
+ }
+ if (cxix < 0) {
+ return (PERL_CONTEXT *)0;
+ }
+ if (PL_DBsub && cxix >= 0 &&
+ ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
+ count++;
+ if (!count--)
+ break;
+ cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
+ }
+ cx = &ccstack[cxix];
+ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+ dbcxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
+ /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
+ field below is defined for any cx. */
+ if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
+ cx = &ccstack[dbcxix];
+ }
+ }
+ return cx;
+}
+
+
+/* The most popular error message */
+#define TOO_FAR \
+ croak("want: Called from outside a subroutine")
+
+/* Between 5.9.1 and 5.9.2 the retstack was removed, and the
+ return op is now stored on the cxstack. */
+#define HAS_RETSTACK (\
+ PERL_REVISION < 5 || \
+ (PERL_REVISION == 5 && PERL_VERSION < 9) || \
+ (PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \
+)
+
+OP*
+find_return_op(pTHX_ I32 uplevel)
+{
+ PERL_CONTEXT *cx = upcontext(aTHX_ uplevel);
+ if (!cx) TOO_FAR;
+#if HAS_RETSTACK
+ return PL_retstack[cx->blk_oldretsp - 1];
+#else
+ return cx->blk_sub.retop;
+#endif
+}
+
+OP*
+find_oldcop(pTHX_ I32 uplevel)
+{
+ PERL_CONTEXT *cx = upcontext(aTHX_ uplevel);
+ if (!cx) TOO_FAR;
+ return (OP*) cx->blk_oldcop;
+}
+
+
+MODULE = B::OP::Util PACKAGE = B::OP::Util PREFIX = OP_Util_
+PROTOTYPES: DISABLE
+
+B::OP
+parent_op(I32 uplevel)
+ CODE:
+ RETVAL = find_oldcop(aTHX_ uplevel);
+ OUTPUT:
+ RETVAL
+
+#define PERL_CORE
+#include "embed.h"
+
+#define newSV_type(a) Perl_newSV_type(aTHX_ a)
+
+B::CV
+CvNEW_with_start(cv, root, start)
+ B::CV cv
+ B::OP root
+ B::OP start
+ PREINIT:
+ CV *new;
+ CODE:
+ new = cv_clone(cv);
+ CvROOT(new) = root;
+ CvSTART(new) = start;
+ CvDEPTH(new) = 0;
+ SvREFCNT_inc(new);
+ RETVAL = new;
+ OUTPUT:
+ RETVAL
+
+#undef PERL_CORE
Added: B-OP-Util/lib/B/OP/Util.pm
==============================================================================
--- (empty file)
+++ B-OP-Util/lib/B/OP/Util.pm Wed Aug 13 11:45:28 2008
@@ -0,0 +1,19 @@
+package B::OP::Util;
+
+require 5.006;
+use Carp 'croak';
+use strict;
+use warnings;
+
+require Exporter;
+require DynaLoader;
+our $VERSION = '0.01';
+our @ISA = qw(Exporter DynaLoader);
+our @EXPORT = qw(parent_op);
+bootstrap B::OP::Util $VERSION;
+
+*B::CV::NEW_with_start = *CvNEW_with_start;
+
+sub dl_load_flags {0x01}
+
+1;
Added: B-OP-Util/t/new_cv.t
==============================================================================
--- (empty file)
+++ B-OP-Util/t/new_cv.t Wed Aug 13 11:45:28 2008
@@ -0,0 +1,81 @@
+#!perl -w
+use strict;
+use Test::More tests => 25;
+use B;
+use B::Generate;
+use ok 'B::Utils';
+use ok 'B::OP::Util';
+
+use strict;
+
+my $orz;
+
+sub foo {
+ my $n = shift;
+ return $orz->($n);
+}
+
+my ($a, $b) = 0;
+
+sub dothat_and_1 {
+ $a;
+ 1;
+}
+
+sub dothat_and_2 {
+ $b, $a;
+ 1;
+}
+
+sub inc_a {
+ ++$a;
+}
+
+
+
+sub prepend_function_with_inc {
+ my $code = shift;
+
+ my $whoami = B::svref_2object($code);
+ isa_ok($whoami, 'B::CV');
+ is($whoami->ROOT->name, 'leavesub');
+ is($whoami->START->name, 'nextstate');
+ my $leavesub = B::UNOP->new("leavesub", $whoami->ROOT->flags, $whoami->ROOT->first);
+ is($leavesub->name, 'leavesub');
+
+ my $inc_a = B::svref_2object(\&inc_a);
+ my $inc_a_entry = $inc_a->START;
+ is($inc_a_entry->name, 'nextstate');
+ my $padsv = $inc_a->START->next;
+
+ my $inc = $padsv->next;
+ is($inc->name, 'preinc');
+
+ my $nextstate = $whoami->START;
+ is($nextstate->name, 'nextstate');
+
+ $inc->sibling($nextstate);
+ $inc->next($nextstate);
+
+ my $orz_obj = $whoami->NEW_with_start($leavesub, $inc_a_entry);
+ return $orz_obj->object_2svref;
+}
+
+$orz = prepend_function_with_inc(\&dothat_and_1);
+
+is(dothat_and_1(), 1);
+is($a, 0);
+is($orz->(), 1);
+is($a, 1);
+
+is($orz->(), 1);
+is($a, 2);
+
+$orz = prepend_function_with_inc(\&dothat_and_2);
+is($orz->(), 1);
+
+TODO: {
+local $TODO = 'need to fix svop padlist idx';
+is($a, 3);
+is($b, 0);
+}
Added: B-OP-Util/typemap
==============================================================================
--- (empty file)
+++ B-OP-Util/typemap Wed Aug 13 11:45:28 2008
@@ -0,0 +1,96 @@
+TYPEMAP
+
+OP * T_OP_OBJ
+B::OP T_OP_OBJ
+B::UNOP T_OP_OBJ
+B::BINOP T_OP_OBJ
+B::LOGOP T_OP_OBJ
+B::LISTOP T_OP_OBJ
+B::PMOP T_OP_OBJ
+B::SVOP T_OP_OBJ
+B::PADOP T_OP_OBJ
+B::PVOP T_OP_OBJ
+B::LOOP T_OP_OBJ
+B::COP T_OP_OBJ
+
+B::SV T_SV_OBJ
+B::PV T_SV_OBJ
+B::IV T_SV_OBJ
+B::NV T_SV_OBJ
+B::PVMG T_SV_OBJ
+B::REGEXP T_SV_OBJ
+B::PVLV T_SV_OBJ
+B::BM T_SV_OBJ
+B::RV T_SV_OBJ
+B::GV T_SV_OBJ
+B::CV T_SV_OBJ
+B::HV T_SV_OBJ
+B::AV T_SV_OBJ
+B::IO T_SV_OBJ
+B::FM T_SV_OBJ
+
+B::MAGIC T_MG_OBJ
+SSize_t T_IV
+STRLEN T_UV
+PADOFFSET T_UV
+
+B::HE T_HE_OBJ
+B::RHE T_RHE_OBJ
+
+INPUT
+T_OP_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ croak(\"$var is not a reference\")
+
+T_SV_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ croak(\"$var is not a reference\")
+
+T_MG_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ croak(\"$var is not a reference\")
+
+T_HE_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ croak(\"$var is not a reference\")
+
+T_RHE_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ croak(\"$var is not a reference\")
+
+OUTPUT
+T_OP_OBJ
+ sv_setiv(newSVrv($arg, cc_opclassname(aTHX_ (OP*)$var)), PTR2IV($var));
+
+T_SV_OBJ
+ make_sv_object(aTHX_ ($arg), (SV*)($var));
+
+
+T_MG_OBJ
+ sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var));
+
+T_HE_OBJ
+ sv_setiv(newSVrv($arg, "B::HE"), PTR2IV($var));
+
+T_RHE_OBJ
+ sv_setiv(newSVrv($arg, "B::RHE"), PTR2IV($var));
More information about the Jifty-commit
mailing list