xs/Package.xs

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