xs/Package.xs

   1
   2 #include "mop.h"
   3
   4 #define GLOB_CREATE     0x01
   5 #define VARIABLE_CREATE 0x02
   6
   7
   8 static const char*
   9 mop_deconstruct_variable_name(pTHX_ SV* const variable, svtype* const type, const char** const type_name, I32* const flags) {
  10         const char* name;
  11
  12         if(SvROK(variable) && SvTYPE(SvRV(variable)) == SVt_PVHV){
  13                 /* e.g. variable = { type => "SCALAR", name => "foo" } */
  14                 HV* const hv = (HV*)SvRV(variable);
  15                 SV** svp;
  16                 STRLEN len;
  17                 const char* pv;
  18
  19                 svp = hv_fetchs(hv, "name", FALSE);
  20                 if(!(svp && SvOK(*svp))){
  21                         croak("You must pass a variable name");
  22                 }
  23                 name = SvPV_const(*svp, len);
  24                 if(len < 1){
  25                         croak("You must pass a variable name");
  26                 }
  27
  28                 svp = hv_fetchs(hv, "type", FALSE);
  29                 if(!(svp && SvOK(*svp))) {
  30                         croak("You must pass a variable type");
  31                 }
  32                 pv = SvPV_nolen_const(*svp);
  33                 if(strEQ(pv, "SCALAR")){
  34                         *type = SVt_PV; /* for all the type of scalars */
  35                 }
  36                 else if(strEQ(pv, "ARRAY")){
  37                         *type = SVt_PVAV;
  38                 }
  39                 else if(strEQ(pv, "HASH")){
  40                         *type = SVt_PVHV;
  41                 }
  42                 else if(strEQ(pv, "CODE")){
  43                         *type = SVt_PVCV;
  44                 }
  45                 else if(strEQ(pv, "GLOB")){
  46                         *type = SVt_PVGV;
  47                 }
  48                 else if(strEQ(pv, "IO")){
  49                         *type = SVt_PVIO;
  50                 }
  51                 else{
  52                         croak("I do not recognize that type '%s'", pv);
  53                 }
  54                 *type_name = pv;
  55
  56                 svp = hv_fetchs(hv, "create", FALSE);
  57                 if(svp && SvTRUE(*svp)){
  58                         *flags = VARIABLE_CREATE | GLOB_CREATE;
  59                 }
  60         }
  61         else {
  62                 STRLEN len;
  63                 const char* pv;
  64                 /* e.g. variable = '$foo' */
  65                 if(!SvOK(variable)) {
  66                         croak("You must pass a variable name");
  67                 }
  68                 pv = SvPV_const(variable, len);
  69                 if(len < 2){
  70                         croak("You must pass a variable name including a sigil");
  71                 }
  72
  73                 switch(pv[0]){
  74                 case '$':
  75                         *type      = SVt_PV; /* for all the types of scalars */
  76                         *type_name = "SCALAR";
  77                         break;
  78                 case '@':
  79                         *type      = SVt_PVAV;
  80                         *type_name = "ARRAY";
  81                         break;
  82                 case '%':
  83                         *type      = SVt_PVHV;
  84                         *type_name = "HASH";
  85                         break;
  86                 case '&':
  87                         *type      = SVt_PVCV;
  88                         *type_name = "CODE";
  89                         break;
  90                 case '*':
  91                         *type      = SVt_PVGV;
  92                         *type_name = "GLOB";
  93                         break;
  94                 default:
  95                         croak("I do not recognize that sigil '%c'", pv[0]);
  96                 }
  97
  98                 name = pv + 1;
  99         }
 100
 101         return name;
 102 }
 103
 104 MODULE = Class::MOP::Package   PACKAGE = Class::MOP::Package
 105
 106 PROTOTYPES: DISABLE
 107
 108 void
 109 get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
 110     SV *self
 111     type_filter_t filter
 112     PREINIT:
 113         HV *stash = NULL;
 114         HV *symbols = NULL;
 115         register HE *he;
 116     PPCODE:
 117         if ( ! SvROK(self) ) {
 118             die("Cannot call get_all_package_symbols as a class method");
 119         }
 120
 121         if (GIMME_V == G_VOID) {
 122             XSRETURN_EMPTY;
 123         }
 124
 125         PUTBACK;
 126
 127         if ( (he = hv_fetch_ent((HV *)SvRV(self), KEY_FOR(package), 0, HASH_FOR(package))) ) {
 128             stash = gv_stashsv(HeVAL(he), 0);
 129         }
 130
 131
 132         if (!stash) {
 133             XSRETURN_UNDEF;
 134         }
 135
 136         symbols = mop_get_all_package_symbols(stash, filter);
 137         PUSHs(sv_2mortal(newRV_noinc((SV *)symbols)));
 138
 139 BOOT:
 140     INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);
 141
 142 #define S_HAS GV_NOADD_NOINIT
 143 #define S_GET 0
 144 #define S_ADD GV_ADDMULTI
 145
 146 SV*
 147 add_package_symbol(SV* self, SV* variable, SV* ref = &PL_sv_undef)
 148 ALIAS:
 149         has_package_symbol = S_HAS
 150         get_package_symbol = S_GET
 151         add_package_symbol = S_ADD
 152 PREINIT:
 153         svtype type;
 154         const char* type_name;
 155         const char* var_name;
 156         SV* package_name;
 157         const char* fq_name;
 158         I32 flags = 0; /* not used */
 159 CODE:
 160         var_name = mop_deconstruct_variable_name(aTHX_ variable, &type, &type_name, &flags);
 161
 162         package_name = mop_call0(aTHX_ self, KEY_FOR(name));
 163         if(!SvOK(package_name)){
 164                 croak("name() did not return a defined value");
 165         }
 166         fq_name = Perl_form(aTHX_ "%"SVf"::%s", package_name, var_name);
 167
 168         if(items == 3 && ix != S_ADD){
 169                 croak("Too many arguments for %s", GvNAME(CvGV(cv)));
 170         }
 171
 172         if(SvOK(ref)){ /* add_package_symbol with a value */
 173                 GV* gv;
 174
 175                 if(type == SVt_PV){
 176                         if(!SvROK(ref)){
 177                                 ref = newRV_noinc(newSVsv(ref));
 178                                 sv_2mortal(ref);
 179                         }
 180                 }
 181                 else if(!(SvROK(ref) && SvTYPE(SvRV(ref)) == type)){
 182                         croak("You must pass a reference of %s for the value of %s", type_name, GvNAME(CvGV(cv)));
 183                 }
 184                 gv = gv_fetchpv(fq_name, GV_ADDMULTI, type);
 185
 186                 if(type == SVt_PVCV && GvCV(gv)){
 187                         /* XXX: should introduce an option { redefine => 1 } ? */
 188                         SvREFCNT_dec(GvCV(gv));
 189                         GvCV(gv) = NULL;
 190                 }
 191                 sv_setsv_mg((SV*)gv, ref); /* *glob = $ref */
 192                 RETVAL = ref;
 193         }
 194         else { /* no values */
 195                 GV* const gv = gv_fetchpv(fq_name, ix | (flags & GLOB_CREATE ? GV_ADDMULTI : 0), type);
 196                 SV* sv;
 197
 198                 if(!gv){
 199                         if(ix == S_HAS){
 200                                 XSRETURN_NO;
 201                         }
 202                         else{
 203                                 XSRETURN_UNDEF;
 204                         }
 205                 }
 206
 207                 if(!isGV(gv)){ /* In has_package_symbol, the stash entry is a stub or constant */
 208                         assert(ix == S_HAS);
 209                         if(type == SVt_PVCV){
 210                                 XSRETURN_YES;
 211                         }
 212                         else{
 213                                 XSRETURN_NO;
 214                         }
 215                 }
 216
 217                 switch(type){
 218                 case SVt_PVAV:
 219                         sv = (SV*)((flags & VARIABLE_CREATE) ? GvAVn(gv) : GvAV(gv));
 220                         break;
 221                 case SVt_PVHV:
 222                         sv = (SV*)((flags & VARIABLE_CREATE) ? GvHVn(gv) : GvHV(gv));
 223                         break;
 224                 case SVt_PVCV:
 225                         sv = (SV*)GvCV(gv);
 226                         break;
 227                 case SVt_PVIO:
 228                         sv = (SV*)((flags & VARIABLE_CREATE) ? GvIOn(gv) : GvIO(gv));
 229                         break;
 230                 case SVt_PVGV:
 231                         sv = (SV*)gv;
 232                         break;
 233                 default: /* SCALAR */
 234                         sv =       (flags & VARIABLE_CREATE) ? GvSVn(gv) : GvSV(gv);
 235                         break;
 236                 }
 237
 238                 if(ix == S_HAS){
 239                         RETVAL = boolSV(sv);
 240                 }
 241                 else{
 242                         if(sv){
 243                                 RETVAL = sv_2mortal(newRV_inc(sv));
 244                         }
 245                         else{
 246                                 RETVAL = &PL_sv_undef;
 247                         }
 248                 }
 249         }
 250         ST(0) = RETVAL;
 251