Add support for prototypes

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

diff --git a/Op.xs b/Op.xs
index 6a71219845dace3c81e3860b18970d4fddd3e3fe..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;
 }
@@ -150,14 +152,24 @@ sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig) {
  sub_op_config_t *dupe = PerlMemShared_malloc(sizeof *dupe);
 
  len           = orig->namelen;
- if (len && orig->name) {
-  dupe->name   = PerlMemShared_malloc(len);
+ if (orig->name) {
+  dupe->name   = PerlMemShared_malloc(len + 1);
   Copy(orig->name, dupe->name, len, char);
+  ((char *) dupe->name)[len] = '\0';
  } else {
   dupe->name   = NULL;
  }
  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;
@@ -424,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);