Moose.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4 #include "ppport.h"
   5
   6 #ifndef MGf_COPY
   7 # define MGf_COPY 0
   8 #endif
   9
  10 #ifndef MGf_DUP
  11 # define MGf_DUP 0
  12 #endif
  13
  14 #ifndef MGf_LOCAL
  15 # define MGf_LOCAL 0
  16 #endif
  17
  18 STATIC int unset_export_flag (pTHX_ SV *sv, MAGIC *mg);
  19
  20 STATIC MGVTBL export_flag_vtbl = {
  21     NULL, /* get */
  22     unset_export_flag, /* set */
  23     NULL, /* len */
  24     NULL, /* clear */
  25     NULL, /* free */
  26 #if MGf_COPY
  27     NULL, /* copy */
  28 #endif
  29 #if MGf_DUP
  30     NULL, /* dup */
  31 #endif
  32 #if MGf_LOCAL
  33     NULL, /* local */
  34 #endif
  35 };
  36
  37 STATIC bool
  38 export_flag_is_set (pTHX_ SV *sv)
  39 {
  40     MAGIC *mg, *moremagic;
  41
  42     if (SvTYPE(SvRV(sv)) != SVt_PVGV) {
  43         return 0;
  44     }
  45
  46     for (mg = SvMAGIC(SvRV(sv)); mg; mg = moremagic) {
  47         moremagic = mg->mg_moremagic;
  48
  49         if (mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == &export_flag_vtbl) {
  50             break;
  51         }
  52     }
  53
  54     return !!mg;
  55 }
  56
  57 STATIC int
  58 unset_export_flag (pTHX_ SV *sv, MAGIC *mymg)
  59 {
  60     MAGIC *mg, *prevmagic = NULL, *moremagic = NULL;
  61
  62     for (mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) {
  63         moremagic = mg->mg_moremagic;
  64
  65         if (mg == mymg) {
  66             break;
  67         }
  68     }
  69
  70     if (!mg) {
  71         return 0;
  72     }
  73
  74     if (prevmagic) {
  75         prevmagic->mg_moremagic = moremagic;
  76     }
  77     else {
  78         SvMAGIC_set(sv, moremagic);
  79     }
  80
  81     mg->mg_moremagic = NULL;
  82
  83     Safefree (mg);
  84
  85     return 0;
  86 }
  87
  88 MODULE = Moose  PACKAGE = Moose::Exporter
  89
  90 void
  91 _flag_as_reexport (SV *sv)
  92     PROTOTYPE: \*
  93     CODE:
  94         sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, &export_flag_vtbl, NULL, 0);
  95
  96 bool
  97 _export_is_flagged (SV *sv)
  98     PROTOTYPE: \*
  99     CODE:
 100         RETVAL = export_flag_is_set(aTHX_ sv);
 101     OUTPUT:
 102         RETVAL