README
configure_test.pl
lib/Sub/Op.pm
-ptable.h
sub_op.h
samples/try.pl
t/10-base.t
t/11-existing.t
t/12-prototype.t
-t/20-deparse.t
-t/21-monkeypatch.t
t/91-pod.t
t/92-pod-coverage.t
t/95-portability-files.t
#endif /* SO_THREADSAFE */
-#define PTABLE_NAME ptable
-#define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
-
-#include "ptable.h"
-
-/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
-#define ptable_store(T, K, V) ptable_store(aPTBLMS_ (T), (K), (V))
-
-STATIC ptable *so_op_name = NULL;
-
-#ifdef USE_ITHREADS
-STATIC perl_mutex so_op_name_mutex;
-#endif
-
-typedef struct {
- STRLEN len;
- char buf;
-} so_op_name_t;
-
/* --- Public API ---------------------------------------------------------- */
#include "sub_op.h"
c->namelen = 0;
c->proto = NULL;
c->protolen = 0;
- c->pp = 0;
c->check = 0;
c->ref = 0;
c->ud = NULL;
}
void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags) {
- SV *key = newSViv(PTR2IV(c->pp));
+ dMY_CXT;
if (!(flags & SUB_OP_REGISTER_STEAL))
c = sub_op_dup(aTHX_ c);
- if (!PL_custom_op_names)
- PL_custom_op_names = newHV();
- (void) hv_store_ent(PL_custom_op_names, key, newSVpv(c->name, c->namelen), 0);
-
- if (!PL_custom_op_descs)
- PL_custom_op_descs = newHV();
- (void) hv_store_ent(PL_custom_op_descs, key, newSVpv(c->name, c->namelen), 0);
-
- SvREFCNT_dec(key);
-
- {
- dMY_CXT;
- (void) hv_store(MY_CXT.map, c->name, c->namelen, newSViv(PTR2IV(c)), 0);
- }
+ (void) hv_store(MY_CXT.map, c->name, c->namelen, newSViv(PTR2IV(c)), 0);
}
sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig) {
}
dupe->protolen = len;
- dupe->pp = orig->pp;
dupe->check = orig->check;
dupe->ref = orig->ref;
dupe->ud = orig->ud;
return;
}
+OP *sub_op_study(const OP *o, OP **last_arg_p, OP **rv2cv_p) {
+ OP *ex_list, *last_arg, *rv2cv, *gvop;
+
+ ex_list = cUNOPo->op_first;
+ /* pushmark when a method call */
+ if (!ex_list || ex_list->op_type != OP_NULL)
+ goto skip;
+
+ rv2cv = cUNOPx(ex_list)->op_first;
+ if (!rv2cv)
+ goto skip;
+
+ while (1) {
+ OP *next = rv2cv->op_sibling;
+ if (!next)
+ break;
+ last_arg = rv2cv;
+ rv2cv = next;
+ }
+
+ if (!(rv2cv->op_flags & OPf_KIDS))
+ goto skip;
+
+ gvop = cUNOPx(rv2cv)->op_first;
+
+ if (gvop && gvop->op_type == OP_GV)
+ goto done;
+
+skip:
+ last_arg = NULL;
+ rv2cv = NULL;
+ gvop = NULL;
+
+done:
+ if (last_arg_p)
+ *last_arg_p = last_arg;
+ if (rv2cv_p)
+ *rv2cv_p = rv2cv;
+
+ return gvop;
+}
+
/* --- Private helpers ----------------------------------------------------- */
STATIC IV so_hint(pTHX) {
return (SvOK(hint) && SvIOK(hint)) ? SvIVX(hint) : 0;
}
-STATIC OP *so_find_gvop(OP *o, OP **last_arg_p, OP **rv2cv_p) {
+STATIC OP *so_find_gvop(const OP *o) {
OP *ex_list, *last_arg, *rv2cv, *gvop;
ex_list = cUNOPo->op_first;
OP *next = rv2cv->op_sibling;
if (!next)
break;
- last_arg = rv2cv;
- rv2cv = next;
+ rv2cv = next;
}
if (!(rv2cv->op_flags & OPf_KIDS))
goto skip;
gvop = cUNOPx(rv2cv)->op_first;
-
if (gvop && gvop->op_type == OP_GV)
- goto done;
+ return gvop;
skip:
- last_arg = NULL;
- rv2cv = NULL;
- gvop = NULL;
-
-done:
- if (last_arg_p)
- *last_arg_p = last_arg;
- if (rv2cv_p)
- *rv2cv_p = rv2cv;
-
- return gvop;
+ return NULL;
}
STATIC OP *(*so_old_ck_entersub)(pTHX_ OP *) = 0;
o = CALL_FPTR(so_old_ck_entersub)(aTHX_ o);
if (so_hint()) {
- OP *ex_list, *last_arg, *rv2cv, *gvop;
+ OP *gvop;
GV *gv;
if (o->op_type != OP_ENTERSUB)
if (o->op_private & OPpENTERSUB_AMPER) /* hopefully \&foo */
goto skip;
- gvop = so_find_gvop(o, &last_arg, &rv2cv);
+ gvop = so_find_gvop(o);
if (!gvop)
goto skip;
GvCV(gv) = NULL;
}
- o->op_type = OP_CUSTOM;
- o->op_ppaddr = c->pp;
-
- if (last_arg)
- last_arg->op_sibling = NULL;
-
- op_free(rv2cv);
-
if (c->check)
o = CALL_FPTR(c->check)(aTHX_ o, c->ud);
-
- {
- so_op_name_t *on = PerlMemShared_malloc(sizeof(*on) + len);
- Copy(name, &on->buf, len, char);
- (&on->buf)[len] = '\0';
- on->len = len;
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&so_op_name_mutex);
-#endif /* USE_ITHREADS */
- ptable_store(so_op_name, o, on);
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&so_op_name_mutex);
-#endif /* USE_ITHREADS */
- }
}
}
if (kid->op_type != OP_RV2CV)
continue;
- gvop = so_find_gvop(kid, NULL, NULL);
+ gvop = so_find_gvop(kid);
if (!gvop)
continue;
BOOT:
{
- so_op_name = ptable_new();
-#ifdef USE_ITHREADS
- MUTEX_INIT(&so_op_name_mutex);
-#endif
-
MY_CXT_INIT;
MY_CXT.map = newHV();
MY_CXT.placeholder = NULL;
}
XSRETURN(0);
-void
-_custom_name(SV *op)
-PROTOTYPE: $
-PREINIT:
- OP *o;
- so_op_name_t *on;
-PPCODE:
- if (!SvROK(op))
- XSRETURN_UNDEF;
- o = INT2PTR(OP *, SvIV(SvRV(op)));
- if (!o || o->op_type != OP_CUSTOM)
- XSRETURN_UNDEF;
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&so_op_name_mutex);
-#endif /* USE_ITHREADS */
- on = ptable_fetch(so_op_name, o);
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&so_op_name_mutex);
-#endif /* USE_ITHREADS */
- if (!on)
- XSRETURN_UNDEF;
- ST(0) = sv_2mortal(newSVpvn(&on->buf, on->len));
- XSRETURN(1);
-
void
_constant_sub(SV *sv)
PROTOTYPE: $
},
);
+sub _defined_sub {
+ my ($fqn) = @_;
+ my @parts = split /::/, $fqn;
+ my $name = pop @parts;
+ my $pkg = '';
+ for (@parts) {
+ $pkg .= $_ . '::';
+ return 0 unless do { no strict 'refs'; %$pkg };
+ }
+ return do { no strict 'refs'; defined &{"$pkg$name"} };
+}
+
sub _tag {
my ($pkg, $name) = @_;
return;
}
-sub _inject {
- my ($pkg, $inject) = @_;
-
- my $stash = do { no strict 'refs'; \%{"${pkg}::"} };
-
- while (my ($meth, $code) = each %$inject) {
- next if exists $stash->{$meth} and (*{$stash->{$meth}}{CODE} // 0) == $code;
- no strict 'refs';
- *{"${pkg}::$meth"} = $code;
- }
-}
-
-sub _defined_sub {
- my ($fqn) = @_;
- my @parts = split /::/, $fqn;
- my $name = pop @parts;
- my $pkg = '';
- for (@parts) {
- $pkg .= $_ . '::';
- return 0 unless do { no strict 'refs'; %$pkg };
- }
- return do { no strict 'refs'; defined &{"$pkg$name"} };
-}
-
-{
- my $injector;
- BEGIN {
- $injector = Variable::Magic::wizard(
- data => sub { +{ guard => 0, pkg => $_[1], subs => $_[2] } },
- store => sub {
- my ($stash, $data, $key) = @_;
-
- return if $data->{guard};
- local $data->{guard} = 1;
-
- _inject($data->{pkg}, $data->{subs});
-
- return;
- },
- );
- }
-
- sub _monkeypatch {
- my %B_OP_inject;
-
- $B_OP_inject{first} = sub {
- if (defined _custom_name($_[0])) {
- $_[0] = bless $_[0], 'B::UNOP' unless $_[0]->isa('B::UNOP');
- goto $_[0]->can('first') || die 'oops';
- }
- require Carp;
- Carp::confess('Calling B::OP->first for something that isn\'t a custom op');
- };
-
- $B_OP_inject{can} = sub {
- my ($obj, $meth) = @_;
- if ($meth eq 'first') {
- return undef unless $obj->isa('B::UNOP') or defined _custom_name($obj);
- }
- $obj->SUPER::can($meth);
- };
-
- if (_defined_sub('B::OP::type')) {
- _inject('B::OP', \%B_OP_inject);
- } else {
- no strict 'refs';
- Variable::Magic::cast %{'B::OP::'}, $injector, 'B::OP', \%B_OP_inject;
- }
-
- my $B_Deparse_inject = {
- pp_custom => sub {
- my ($self, $op, $cx) = @_;
- my $name = _custom_name($op);
- die 'unhandled custom op' unless defined $name;
- if ($op->flags & do { no strict 'refs'; &{'B::OPf_STACKED'}() }) {
- my $kid = $op->first;
- $kid = $kid->first->sibling; # skip ex-list, pushmark
- my @exprs;
- while (not do { no strict 'refs'; &{'B::Deparse::null'}($kid) }) {
- push @exprs, $self->deparse($kid, 6);
- $kid = $kid->sibling;
- }
- my $args = join(", ", @exprs);
- return "$name($args)";
- } else {
- return $name;
- }
- },
- };
-
- if (_defined_sub('B::Deparse::pp_entersub')) {
- _inject('B::Deparse', $B_Deparse_inject);
- } else {
- no strict 'refs';
- Variable::Magic::cast %{'B::Deparse::'}, $injector, 'B::Deparse', $B_Deparse_inject;
- }
- }
-}
-
-BEGIN { _monkeypatch() }
-
=head1 EXAMPLES
See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.
+++ /dev/null
-/* This file is part of the Sub::Op Perl module.
- * See http://search.cpan.org/dist/Sub-Op/ */
-
-/* This is a pointer table implementation essentially copied from the ptr_table
- * implementation in perl's sv.c, except that it has been modified to use memory
- * shared across threads.
- * Copyright goes to the original authors, bug reports to me. */
-
-/* This header is designed to be included several times with different
- * definitions for PTABLE_NAME and PTABLE_VAL_FREE(). */
-
-#undef pPTBLMS
-#undef pPTBLMS_
-#undef aPTBLMS
-#undef aPTBLMS_
-
-/* Context for PerlMemShared_* functions */
-
-#ifdef PERL_IMPLICIT_SYS
-# define pPTBLMS pTHX
-# define pPTBLMS_ pTHX_
-# define aPTBLMS aTHX
-# define aPTBLMS_ aTHX_
-#else
-# define pPTBLMS
-# define pPTBLMS_
-# define aPTBLMS
-# define aPTBLMS_
-#endif
-
-#ifndef pPTBL
-# define pPTBL pPTBLMS
-#endif
-#ifndef pPTBL_
-# define pPTBL_ pPTBLMS_
-#endif
-#ifndef aPTBL
-# define aPTBL aPTBLMS
-#endif
-#ifndef aPTBL_
-# define aPTBL_ aPTBLMS_
-#endif
-
-#ifndef PTABLE_NAME
-# define PTABLE_NAME ptable
-#endif
-
-#ifndef PTABLE_VAL_FREE
-# define PTABLE_VAL_FREE(V)
-#endif
-
-#ifndef PTABLE_JOIN
-# define PTABLE_PASTE(A, B) A ## B
-# define PTABLE_JOIN(A, B) PTABLE_PASTE(A, B)
-#endif
-
-#ifndef PTABLE_PREFIX
-# define PTABLE_PREFIX(X) PTABLE_JOIN(PTABLE_NAME, X)
-#endif
-
-#ifndef ptable_ent
-typedef struct ptable_ent {
- struct ptable_ent *next;
- const void * key;
- void * val;
-} ptable_ent;
-#define ptable_ent ptable_ent
-#endif /* !ptable_ent */
-
-#ifndef ptable
-typedef struct ptable {
- ptable_ent **ary;
- size_t max;
- size_t items;
-} ptable;
-#define ptable ptable
-#endif /* !ptable */
-
-#ifndef ptable_new
-STATIC ptable *ptable_new(pPTBLMS) {
-#define ptable_new() ptable_new(aPTBLMS)
- ptable *t = PerlMemShared_malloc(sizeof *t);
- t->max = 15;
- t->items = 0;
- t->ary = PerlMemShared_calloc(t->max + 1, sizeof *t->ary);
- return t;
-}
-#endif /* !ptable_new */
-
-#ifndef PTABLE_HASH
-# define PTABLE_HASH(ptr) \
- ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
-#endif
-
-#ifndef ptable_find
-STATIC ptable_ent *ptable_find(const ptable * const t, const void * const key) {
-#define ptable_find ptable_find
- ptable_ent *ent;
- const UV hash = PTABLE_HASH(key);
-
- ent = t->ary[hash & t->max];
- for (; ent; ent = ent->next) {
- if (ent->key == key)
- return ent;
- }
-
- return NULL;
-}
-#endif /* !ptable_find */
-
-#ifndef ptable_fetch
-STATIC void *ptable_fetch(const ptable * const t, const void * const key) {
-#define ptable_fetch ptable_fetch
- const ptable_ent *const ent = ptable_find(t, key);
-
- return ent ? ent->val : NULL;
-}
-#endif /* !ptable_fetch */
-
-#ifndef ptable_split
-STATIC void ptable_split(pPTBLMS_ ptable * const t) {
-#define ptable_split(T) ptable_split(aPTBLMS_ (T))
- ptable_ent **ary = t->ary;
- const size_t oldsize = t->max + 1;
- size_t newsize = oldsize * 2;
- size_t i;
-
- ary = PerlMemShared_realloc(ary, newsize * sizeof(*ary));
- Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary));
- t->max = --newsize;
- t->ary = ary;
-
- for (i = 0; i < oldsize; i++, ary++) {
- ptable_ent **curentp, **entp, *ent;
- if (!*ary)
- continue;
- curentp = ary + oldsize;
- for (entp = ary, ent = *ary; ent; ent = *entp) {
- if ((newsize & PTABLE_HASH(ent->key)) != i) {
- *entp = ent->next;
- ent->next = *curentp;
- *curentp = ent;
- continue;
- } else
- entp = &ent->next;
- }
- }
-}
-#endif /* !ptable_split */
-
-STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const key, void * const val) {
- ptable_ent *ent = ptable_find(t, key);
-
- if (ent) {
- void *oldval = ent->val;
- PTABLE_VAL_FREE(oldval);
- ent->val = val;
- } else if (val) {
- const size_t i = PTABLE_HASH(key) & t->max;
- ent = PerlMemShared_malloc(sizeof *ent);
- ent->key = key;
- ent->val = val;
- ent->next = t->ary[i];
- t->ary[i] = ent;
- t->items++;
- if (ent->next && t->items > t->max)
- ptable_split(t);
- }
-}
-
-#ifndef ptable_walk
-STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) {
-#define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD))
- if (t && t->items) {
- register ptable_ent ** const array = t->ary;
- size_t i = t->max;
- do {
- ptable_ent *entry;
- for (entry = array[i]; entry; entry = entry->next)
- cb(aTHX_ entry, userdata);
- } while (i--);
- }
-}
-#endif /* !ptable_walk */
-
-STATIC void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) {
- if (t && t->items) {
- register ptable_ent ** const array = t->ary;
- size_t i = t->max;
-
- do {
- ptable_ent *entry = array[i];
- while (entry) {
- ptable_ent * const oentry = entry;
- void *val = oentry->val;
- entry = entry->next;
- PTABLE_VAL_FREE(val);
- PerlMemShared_free(oentry);
- }
- array[i] = NULL;
- } while (i--);
-
- t->items = 0;
- }
-}
-
-STATIC void PTABLE_PREFIX(_free)(pPTBL_ ptable * const t) {
- if (!t)
- return;
- PTABLE_PREFIX(_clear)(aPTBL_ t);
- PerlMemShared_free(t->ary);
- PerlMemShared_free(t);
-}
-
-#undef pPTBL
-#undef pPTBL_
-#undef aPTBL
-#undef aPTBL_
-
-#undef PTABLE_NAME
-#undef PTABLE_VAL_FREE
STRLEN namelen;
const char *proto;
STRLEN protolen;
- Perl_ppaddr_t pp;
sub_op_check_t check;
sub_op_check_t ref;
void *ud;
void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags);
sub_op_config_t *sub_op_dup (pTHX_ const sub_op_config_t *c);
void sub_op_free (pTHX_ sub_op_config_t *c);
+OP * sub_op_study (const OP *o, OP **last_arg_p, OP **rv2cv_p);
#endif /* SUB_OP_H */
use blib 't/Sub-Op-LexicalSub';
-use Test::More tests => (1 + 3) * 16 + (1 + 2 * 3) * 2 + 2 * 29;
+use Test::More tests => (1 + 3) * 17 + (1 + 2 * 3) * 2 + 2 * 31;
our $called;
foo 1, foo(2), 3, bar(4, foo(bar, 5), 6);
----
foo, bar # @_ # [ 2 ], [ ], [ 5 ], [ 4, 5, 6 ], [ 1, 2, 3, 4, 5, 6 ] # foo, bar, foo, bar, foo
+####
+foo 0, sub {
+ foo $_[0], 2, $_[1]
+}->(1, 3), 4;
+----
+foo # @_ # [ 1, 2, 3 ], [ 0, 1, 2, 3, 4 ]
use blib 't/Sub-Op-LexicalSub';
-use Test::More tests => 2 * ((2 + 2) * 4 + (1 + 2) * 5) + 2 * (2 + 2) + 4;
+use Test::More tests => 2 * ((2 + 2) * 4 + (1 + 2) * 5) + 2 * (2 + 2) + 4 + 4;
our $call_foo;
sub foo { ok $call_foo, 'the preexistent foo was called' }
our $call_blech;
sub blech { ok $call_blech, 'initial blech was called' };
+our $wat_args;
+sub wat { is_deeply \@_, $wat_args, 'wat was called with the right arguments' }
+
our $called;
{
}
}
+{
+ eval <<' TEST';
+ use Sub::Op::LexicalSub what => \&wat;
+ local $wat_args = [ 1 ];
+ what 1;
+ local $wat_args = [ 2, 3 ];
+ what 2, 3;
+ local $wat_args = [ 4, 5 ];
+ sub {
+ what $_[0], 5;
+ }->(4);
+ TEST
+ is $@, '', 'what: no errors';
+}
+
is prototype('main::foo'), undef, "foo's prototype was preserved";
is prototype('main::bar'), '', "bar's prototype was preserved";
is prototype('main::X'), '', "X's prototype was preserved";
+++ /dev/null
-#!perl
-
-use strict;
-use warnings;
-
-use blib 't/Sub-Op-LexicalSub';
-
-use Test::More tests => 13;
-
-use Devel::Peek;
-use B::Deparse;
-
-my $bd = B::Deparse->new;
-
-$bd->ambient_pragmas(
- strict => 'all',
- warnings => 'all',
-);
-
-{
- local $/ = "####\n";
- while (<DATA>) {
- chomp;
- s/\s*$//;
- my $code = $_;
-
- my $test = eval <<" TESTCASE";
- sub {
- use Sub::Op::LexicalSub f => sub { };
- use Sub::Op::LexicalSub g => sub { };
- $code
- }
- TESTCASE
- if ($@) {
- fail "unable to compile testcase: $@";
- next;
- }
- my $deparsed = $bd->coderef2text($test);
- $deparsed =~ s[BEGIN \s* \{ \s* \$\^H \s* \{ .*? \} .*? \} \s*][]gxs;
-
- my $expected = do {
- local *f = sub { };
- local *g = sub { };
- f(); g(); # silence 'once' warnings without setting the bits
- my $exp = eval <<" EXPECTED";
- sub {
- $code
- }
- EXPECTED
- if ($@) {
- fail "unable to compile expected code: $@";
- next;
- }
- $bd->coderef2text($exp);
- };
-
- is $deparsed, $expected, "deparsed <$code> is as expected";
- }
-}
-
-__DATA__
-f();
-####
-f;
-####
-f(1);
-####
-f 1;
-####
-f(1, 2);
-####
-f 1, 2;
-####
-f(1); g(2);
-####
-f 1, f(2), 3, g(4, f(g, 5), 6);
-####
-&f;
-####
-&f();
-####
-&f(1);
-####
-&f(1, 2);
-####
-my $x = \&f;
+++ /dev/null
-#!perl
-
-use strict;
-use warnings;
-
-use Test::More;
-
-BEGIN {
- if (exists $INC{'B.pm'} or exists $INC{'B/Deparse.pm'}) {
- plan skip_all => 'Test::More loaded B or B::Deparse for some reason';
- } else {
- plan tests => 5;
- }
-}
-
-use Sub::Op;
-
-sub stash_keys {
- my ($pkg) = @_;
-
- no strict 'refs';
- keys %{"${pkg}::"};
-}
-
-BEGIN {
- is_deeply [ sort +stash_keys 'B' ], [ sort
- qw/OP:: Deparse:: Hooks::/,
- qw/svref_2object/,
- ], 'No extra symbols in B::';
- is_deeply [ sort +stash_keys 'B::Deparse' ], [ ], 'No symbols in B::Deparse';
-}
-
-use B;
-
-BEGIN {
- for my $meth (qw/first can/) {
- ok do { no strict 'refs'; defined &{"B::OP::$meth"} },
- "B::OP::$meth is now defined";
- }
-}
-
-use B::Deparse;
-
-BEGIN {
- for my $meth (qw/pp_custom/) {
- ok do { no strict 'refs'; defined &{"B::Deparse::$meth"} },
- "B::Deparse::$meth is now defined";
- }
-}
#include "sub_op.h"
-STATIC HV *sols_map = NULL;
+STATIC PADOFFSET sols_find_sv_in_curpad(pTHX_ SV *sv) {
+#define sols_find_sv_in_curpad(S) sols_find_sv_in_curpad(aTHX_ (S))
+ I32 ix;
+ AV *padlist = CvPADLIST(PL_compcv);
+ AV *comppad = (AV *) AvARRAY(padlist)[1];
+ SV **curpad = AvARRAY(comppad);
+
+ for (ix = AvFILLp(comppad); ix > 0; --ix) {
+ if (curpad[ix] == sv)
+ return ix;
+ }
+
+ return NOT_IN_PAD;
+}
STATIC OP *sols_check(pTHX_ OP *o, void *ud_) {
- char buf[sizeof(void*)*2+1];
- SV *cb = ud_;
+ OP *gvop, *last_arg, *rv2cv;
+ SV *cv = ud_;
+ GV *gv;
- (void) hv_store(sols_map, buf, sprintf(buf, "%"UVxf, PTR2UV(o)), cb, 0);
+ gvop = sub_op_study(o, &last_arg, &rv2cv);
- return o;
-}
+ if (CvANON(cv)) {
+ OP *anon;
-STATIC OP *sols_ref(pTHX_ OP *o, void *ud_) {
- SV *cb = ud_;
+ CvDEPTH(CvOUTSIDE(cv))++;
+ anon = newSVOP(OP_ANONCODE, 0, (SV *) Perl_cv_clone(aTHX_ (CV *) cv));
+ CvDEPTH(CvOUTSIDE(cv))--;
- return newSVOP(OP_ANONCODE, o->op_flags & ~OPf_KIDS, cb);
-}
+ last_arg->op_sibling = newUNOP(OP_REFGEN, 0, anon);
-STATIC OP *sols_pp(pTHX) {
- dSP;
- SV *cb;
- int i, items;
-
- {
- char buf[sizeof(void*)*2+1];
- SV **svp;
- svp = hv_fetch(sols_map, buf, sprintf(buf, "%"UVxf, PTR2UV(PL_op)), 0);
- if (!svp)
- RETURN;
- cb = *svp;
- }
+ op_free(rv2cv);
+ } else {
+ SV *gv = (SV *) CvGV(cv);
- XPUSHs(cb);
- PUTBACK;
+#ifdef USE_ITHREADS
+ PAD_SVl(cPADOPx(gvop)->op_padix) = gv;
+#else
+ cSVOPx(gvop)->op_sv = gv;
+#endif
+ SvREFCNT_inc(gv);
+ }
- return CALL_FPTR(PL_ppaddr[OP_ENTERSUB])(aTHX);
+ return o;
}
/* --- XS ------------------------------------------------------------------ */
PROTOTYPES: ENABLE
-BOOT:
-{
- sols_map = newHV();
-}
-
void
_init(SV *name, SV *cb)
PROTOTYPE: $$
c.proto = SvPV_const(cb, c.protolen);
}
c.check = sols_check;
- c.ref = sols_ref;
c.ud = SvREFCNT_inc(cb);
- c.pp = sols_pp;
sub_op_register(aTHX_ &c, 0);
}
}
projects / perl / modules / Sub-Op.git / commitdiff