Split the "custom op" part away

diff --git a/MANIFEST b/MANIFEST
index 7dfbb969a3940298323d1f3d65b58c2d04873de3..4e360b0bd2b8ea04bb01464b83a33d712d9261e3 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -6,14 +6,11 @@ Op.xs
 README
 configure_test.pl
 lib/Sub/Op.pm
 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
 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
 t/91-pod.t
 t/92-pod-coverage.t
 t/95-portability-files.t

diff --git a/Op.xs b/Op.xs
index f101fa7509fb1d866cac0d72b6c72a5a598996b3..285c1e9768ae593cc7f2c51b7697ad88fad20f77 100644 (file)
--- a/Op.xs
+++ b/Op.xs
@@ -90,25 +90,6 @@ STATIC SV *so_clone(pTHX_ SV *sv, tTHX owner) {
 
 #endif /* SO_THREADSAFE */
 
 
 #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"
 /* --- Public API ---------------------------------------------------------- */
 
 #include "sub_op.h"


@@ -118,7 +99,6 @@ void sub_op_init(sub_op_config_t *c) {
  c->namelen  = 0;
  c->proto    = NULL;
  c->protolen = 0;
  c->namelen  = 0;
  c->proto    = NULL;
  c->protolen = 0;

- c->pp       = 0;

  c->check    = 0;
  c->ref      = 0;
  c->ud       = NULL;
  c->check    = 0;
  c->ref      = 0;
  c->ud       = NULL;


@@ -127,25 +107,12 @@ void sub_op_init(sub_op_config_t *c) {
 }
 
 void sub_op_register(pTHX_ const sub_op_config_t *c, U32 flags) {
 }
 
 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 (!(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) {
 }
 
 sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig) {


@@ -172,7 +139,6 @@ sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig) {
  }
  dupe->protolen = len;
 
  }
  dupe->protolen = len;
 

- dupe->pp    = orig->pp;

  dupe->check = orig->check;
  dupe->ref   = orig->ref;
  dupe->ud    = orig->ud;
  dupe->check = orig->check;
  dupe->ref   = orig->ref;
  dupe->ud    = orig->ud;


@@ -187,6 +153,48 @@ void sub_op_free(pTHX_ sub_op_config_t *c) {
  return;
 }
 
  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) {
 /* --- Private helpers ----------------------------------------------------- */
 
 STATIC IV so_hint(pTHX) {


@@ -211,7 +219,7 @@ STATIC IV so_hint(pTHX) {
  return (SvOK(hint) && SvIOK(hint)) ? SvIVX(hint) : 0;
 }
 
  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 *ex_list, *last_arg, *rv2cv, *gvop;
 
  ex_list = cUNOPo->op_first;


@@ -227,30 +235,18 @@ STATIC OP *so_find_gvop(OP *o, OP **last_arg_p, OP **rv2cv_p) {
   OP *next = rv2cv->op_sibling;
   if (!next)
    break;
   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 (!(rv2cv->op_flags & OPf_KIDS))
   goto skip;
 
  gvop = cUNOPx(rv2cv)->op_first;

-

  if (gvop && gvop->op_type == OP_GV)
  if (gvop && gvop->op_type == OP_GV)

-  goto done;
+  return gvop;

 
 skip:
 
 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;
 }
 
 STATIC OP *(*so_old_ck_entersub)(pTHX_ OP *) = 0;


@@ -259,7 +255,7 @@ STATIC OP *so_ck_entersub(pTHX_ OP *o) {
  o = CALL_FPTR(so_old_ck_entersub)(aTHX_ o);
 
  if (so_hint()) {
  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)
   GV *gv;
 
   if (o->op_type != OP_ENTERSUB)


@@ -267,7 +263,7 @@ STATIC OP *so_ck_entersub(pTHX_ OP *o) {
   if (o->op_private & OPpENTERSUB_AMPER) /* hopefully \&foo */
    goto skip;
 
   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;
 
   if (!gvop)
    goto skip;
 


@@ -292,30 +288,8 @@ STATIC OP *so_ck_entersub(pTHX_ OP *o) {
     GvCV(gv) = NULL;
    }
 
     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);
    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 */
-   }

   }
  }
 
   }
  }
 


@@ -349,7 +323,7 @@ STATIC OP *so_ck_refgen(pTHX_ OP *o) {
    if (kid->op_type != OP_RV2CV)
     continue;
 
    if (kid->op_type != OP_RV2CV)
     continue;
 

-   gvop = so_find_gvop(kid, NULL, NULL);
+   gvop = so_find_gvop(kid);

    if (!gvop)
     continue;
 
    if (!gvop)
     continue;
 


@@ -433,11 +407,6 @@ PROTOTYPES: ENABLE
 
 BOOT:
 {
 
 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;
  MY_CXT_INIT;
  MY_CXT.map         = newHV();
  MY_CXT.placeholder = NULL;


@@ -493,30 +462,6 @@ PPCODE:
  }
  XSRETURN(0);
 
  }
  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: $
 void
 _constant_sub(SV *sv)
 PROTOTYPE: $

diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index a0f25a9473d31ab4b9e82f847e020d5471fcbb73..d8a6b738c7461f856af60f1137ac4ac725f9b9b2 100644 (file)
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -164,6 +164,18 @@ my $sw = Variable::Magic::wizard(
  },
 );
 
  },
 );
 

+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) = @_;
 
 sub _tag {
  my ($pkg, $name) = @_;
 


@@ -366,107 +378,6 @@ sub disable {
  return;
 }
 
  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.
 =head1 EXAMPLES
 
 See the F<t/Sub-Op-LexicalSub> directory that implements a complete example.

diff --git a/ptable.h b/ptable.h
deleted file mode 100644 (file)
index 857dd53..0000000
--- a/ptable.h
+++ /dev/null
@@ -1,221 +0,0 @@
-/* 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

diff --git a/sub_op.h b/sub_op.h
index 6a5d9ed2e821ec431b195838f2025209e711bd78..45ece3f999666aa510275bd54cd57aac785c1f80 100644 (file)
--- a/sub_op.h
+++ b/sub_op.h
@@ -11,7 +11,6 @@ typedef struct {
  STRLEN         namelen;
  const char    *proto;
  STRLEN         protolen;
  STRLEN         namelen;
  const char    *proto;
  STRLEN         protolen;

- Perl_ppaddr_t  pp;

  sub_op_check_t check;
  sub_op_check_t ref;
  void          *ud;
  sub_op_check_t check;
  sub_op_check_t ref;
  void          *ud;


@@ -23,5 +22,6 @@ void             sub_op_init    (sub_op_config_t *c);
 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);
 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 */
 
 #endif /* SUB_OP_H */

diff --git a/t/10-base.t b/t/10-base.t
index 6e6b5d12eeb0f0877693bde8e734e81bca103666..a69a7ae1761542a23ec3df3654c6cb7fa91c79f1 100644 (file)
--- a/t/10-base.t
+++ b/t/10-base.t
@@ -5,7 +5,7 @@ use warnings;
 
 use blib 't/Sub-Op-LexicalSub';
 
 
 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;
 
 
 our $called;
 


@@ -161,3 +161,9 @@ foo, bar # () # [ 1 ], [ 2 ] # foo, bar
 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 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 ]

diff --git a/t/11-existing.t b/t/11-existing.t
index 6c2e9ba75664d61c3ce226eefbf8c8010cf97872..13d60530ea1cfd4972b8871cf1fdd2e836227e99 100644 (file)
--- a/t/11-existing.t
+++ b/t/11-existing.t
@@ -5,7 +5,7 @@ use warnings;
 
 use blib 't/Sub-Op-LexicalSub';
 
 
 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_foo;
 sub foo { ok $call_foo, 'the preexistent foo was called' }


@@ -18,6 +18,9 @@ sub X () { 1 }
 our $call_blech;
 sub blech { ok $call_blech, 'initial blech 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;
 
 {
 our $called;
 
 {


@@ -86,6 +89,21 @@ 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";
 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";

diff --git a/t/20-deparse.t b/t/20-deparse.t
deleted file mode 100644 (file)
index 199523f..0000000
--- a/t/20-deparse.t
+++ /dev/null
@@ -1,86 +0,0 @@
-#!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;

diff --git a/t/21-monkeypatch.t b/t/21-monkeypatch.t
deleted file mode 100644 (file)
index 5c08a22..0000000
--- a/t/21-monkeypatch.t
+++ /dev/null
@@ -1,49 +0,0 @@
-#!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";
- }
-}

diff --git a/t/Sub-Op-LexicalSub/LexicalSub.xs b/t/Sub-Op-LexicalSub/LexicalSub.xs
index 62e83f833b485b36adcf21c1ab2266bbe4517d1d..9e4a2a79143fef770be5af779cd6af791f4f07e1 100644 (file)
--- a/t/Sub-Op-LexicalSub/LexicalSub.xs
+++ b/t/Sub-Op-LexicalSub/LexicalSub.xs
@@ -11,41 +11,50 @@
 
 #include "sub_op.h"
 
 
 #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_) {
 
 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 ------------------------------------------------------------------ */
 }
 
 /* --- XS ------------------------------------------------------------------ */


@@ -54,11 +63,6 @@ MODULE = Sub::Op::LexicalSub      PACKAGE = Sub::Op::LexicalSub
 
 PROTOTYPES: ENABLE
 
 
 PROTOTYPES: ENABLE
 

-BOOT:
-{
- sols_map = newHV();
-}
-

 void
 _init(SV *name, SV *cb)
 PROTOTYPE: $$
 void
 _init(SV *name, SV *cb)
 PROTOTYPE: $$


@@ -74,9 +78,7 @@ PPCODE:
     c.proto = SvPV_const(cb, c.protolen);
    }
    c.check  = sols_check;
     c.proto = SvPV_const(cb, c.protolen);
    }
    c.check  = sols_check;

-   c.ref    = sols_ref;

    c.ud     = SvREFCNT_inc(cb);
    c.ud     = SvREFCNT_inc(cb);

-   c.pp     = sols_pp;

    sub_op_register(aTHX_ &c, 0);
   }
  }
    sub_op_register(aTHX_ &c, 0);
   }
  }