X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=t%2FSub-Op-LexicalSub%2FLexicalSub.xs;fp=t%2FSub-Op-LexicalSub%2FLexicalSub.xs;h=e67d5baa33d02e4711484180ed6b13fbb4e0905a;hb=14a44e7b2f834cbd0d2ba8cc63deda55b3e5f0dd;hp=0000000000000000000000000000000000000000;hpb=a2cacd5001fc982edeb39a4262079c6661ceb2f4;p=perl%2Fmodules%2FSub-Op.git

diff --git a/t/Sub-Op-LexicalSub/LexicalSub.xs b/t/Sub-Op-LexicalSub/LexicalSub.xs
new file mode 100644
index 0000000..e67d5ba
--- /dev/null
+++ b/t/Sub-Op-LexicalSub/LexicalSub.xs
@@ -0,0 +1,85 @@
+/* This file is part of the Sub::Op Perl module.
+ * See http://search.cpan.org/dist/Sub-Op/ */
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define __PACKAGE__     "Sub::Op::LexicalSub"
+#define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
+
+#include "sub_op.h"
+
+STATIC HV *sols_map = NULL;
+
+STATIC OP *sols_check(pTHX_ OP *o, void *ud_) {
+ char buf[sizeof(void*)*2+1];
+ SV *cb = ud_;
+
+ (void) hv_store(sols_map, buf, sprintf(buf, "%"UVxf, PTR2UV(o)), cb, 0);
+
+ return o;
+}
+
+STATIC OP *sols_pp(pTHX) {
+ dSP;
+ dMARK;
+ 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;
+ }
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(MARK);
+
+ items = call_sv(cb, G_ARRAY);
+
+ SPAGAIN;
+ for (i = 0; i < items; ++i)
+  SvREFCNT_inc(SP[-i]);
+ PUTBACK;
+
+ FREETMPS;
+ LEAVE;
+
+ return NORMAL;
+}
+
+/* --- XS ------------------------------------------------------------------ */
+
+MODULE = Sub::Op::LexicalSub      PACKAGE = Sub::Op::LexicalSub
+
+PROTOTYPES: ENABLE
+
+BOOT:
+{
+ sols_map = newHV();
+}
+
+void
+_init(SV *name, SV *cb)
+PROTOTYPE: $$
+PREINIT:
+ sub_op_config_t c;
+PPCODE:
+ if (SvROK(cb)) {
+  cb = SvRV(cb);
+  if (SvTYPE(cb) >= SVt_PVCV) {
+   c.name  = SvPV_const(name, c.len);
+   c.check = sols_check;
+   c.ud    = SvREFCNT_inc(cb);
+   c.pp    = sols_pp;
+   sub_op_register(aTHX_ &c);
+  }
+ }
+ XSRETURN(0);