Add support for prototypes

[perl/modules/Sub-Op.git] / Op.xs

diff --git a/Op.xs b/Op.xs
index d6dc30c3a9ebda75a9d9218b904bc1c2e58c89ec..16b9f465f404264958d632c84c23b028564856a6 100644 (file)
--- a/Op.xs
+++ b/Op.xs
@@ -114,11 +114,13 @@ typedef struct {
 #include "sub_op.h"
 
 void sub_op_init(sub_op_config_t *c) {
- c->name    = NULL;
- c->namelen = 0;
- c->pp      = 0;
- c->check   = 0;
- c->ud      = NULL;
+ c->name     = NULL;
+ c->namelen  = 0;
+ c->proto    = NULL;
+ c->protolen = 0;
+ c->pp       = 0;
+ c->check    = 0;
+ c->ud       = NULL;
 
  return;
 }
@@ -159,6 +161,15 @@ sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig) {
  }
  dupe->namelen = len;
 
+ len            = orig->protolen;
+ if (orig->proto) {
+  dupe->proto   = PerlMemShared_malloc(len + 1);
+  Copy(orig->proto, dupe->proto, len, char);
+  ((char *) dupe->proto)[len] = '\0';
+ } else {
+  dupe->proto   = NULL;
+ }
+ dupe->protolen = len;
 
  dupe->pp    = orig->pp;
  dupe->check = orig->check;
@@ -425,3 +436,20 @@ PPCODE:
   XSRETURN_UNDEF;
  ST(0) = sv_2mortal(newSVuv(CvCONST(sv)));
  XSRETURN(1);
+
+SV *
+_get_prototype(SV *name)
+PROTOTYPE: $
+PREINIT:
+ HE *he;
+ const sub_op_config_t *c;
+PPCODE:
+ dMY_CXT;
+ he = hv_fetch_ent(MY_CXT.map, name, 0, 0);
+ if (!he)
+  XSRETURN_UNDEF;
+ c = INT2PTR(const sub_op_config_t *, SvIVX(HeVAL(he)));
+ if (!c->proto)
+  XSRETURN_UNDEF;
+ ST(0) = sv_2mortal(newSVpvn(c->proto, c->protolen));
+ XSRETURN(1);