Stash.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4
   5 typedef enum {
   6     VAR_NONE = 0,
   7     VAR_SCALAR,
   8     VAR_ARRAY,
   9     VAR_HASH,
  10     VAR_CODE,
  11     VAR_IO,
  12     VAR_GLOB,  /* TODO: unimplemented */
  13     VAR_FORMAT /* TODO: unimplemented */
  14 } vartype_t;
  15
  16 typedef struct {
  17     vartype_t type;
  18     char sigil;
  19     char *name;
  20 } varspec_t;
  21
  22 const char *vartype_to_string(vartype_t type)
  23 {
  24     switch (type) {
  25     case VAR_SCALAR:
  26         return "SCALAR";
  27     case VAR_ARRAY:
  28         return "ARRAY";
  29     case VAR_HASH:
  30         return "HASH";
  31     case VAR_CODE:
  32         return "CODE";
  33     case VAR_IO:
  34         return "IO";
  35     default:
  36         return "unknown";
  37     }
  38 }
  39
  40 I32 vartype_to_svtype(vartype_t type)
  41 {
  42     switch (type) {
  43     case VAR_SCALAR:
  44         return SVt_PV; /* or whatever */
  45     case VAR_ARRAY:
  46         return SVt_PVAV;
  47     case VAR_HASH:
  48         return SVt_PVHV;
  49     case VAR_CODE:
  50         return SVt_PVCV;
  51     case VAR_IO:
  52         return SVt_PVIO;
  53     default:
  54         return SVt_NULL;
  55     }
  56 }
  57
  58 vartype_t string_to_vartype(char *vartype)
  59 {
  60     if (strEQ(vartype, "SCALAR")) {
  61         return VAR_SCALAR;
  62     }
  63     else if (strEQ(vartype, "ARRAY")) {
  64         return VAR_ARRAY;
  65     }
  66     else if (strEQ(vartype, "HASH")) {
  67         return VAR_HASH;
  68     }
  69     else if (strEQ(vartype, "CODE")) {
  70         return VAR_CODE;
  71     }
  72     else if (strEQ(vartype, "IO")) {
  73         return VAR_IO;
  74     }
  75     else {
  76         croak("Type must be one of 'SCALAR', 'ARRAY', 'HASH', 'CODE', or 'IO'");
  77     }
  78 }
  79
  80 void _deconstruct_variable_name(char *variable, varspec_t *varspec)
  81 {
  82     if (!variable || !variable[0])
  83         croak("You must pass a variable name");
  84
  85     varspec->type = VAR_NONE;
  86
  87     switch (variable[0]) {
  88     case '$':
  89         varspec->type = VAR_SCALAR;
  90         break;
  91     case '@':
  92         varspec->type = VAR_ARRAY;
  93         break;
  94     case '%':
  95         varspec->type = VAR_HASH;
  96         break;
  97     case '&':
  98         varspec->type = VAR_CODE;
  99         break;
 100     }
 101
 102     if (varspec->type != VAR_NONE) {
 103         varspec->sigil = variable[0];
 104         varspec->name = &variable[1];
 105     }
 106     else {
 107         varspec->type = VAR_IO;
 108         varspec->sigil = '\0';
 109         varspec->name = variable;
 110     }
 111 }
 112
 113 void _deconstruct_variable_hash(HV *variable, varspec_t *varspec)
 114 {
 115     SV **val;
 116     char *type;
 117
 118     val = hv_fetch(variable, "name", 4, 0);
 119     if (!val)
 120         croak("The 'name' key is required in variable specs");
 121
 122     varspec->name = savesvpv(*val);
 123
 124     val = hv_fetch(variable, "sigil", 5, 0);
 125     if (!val)
 126         croak("The 'sigil' key is required in variable specs");
 127
 128     varspec->sigil = (SvPV_nolen(*val))[0];
 129
 130     val = hv_fetch(variable, "type", 4, 0);
 131     if (!val)
 132         croak("The 'type' key is required in variable specs");
 133
 134     varspec->type = string_to_vartype(SvPV_nolen(*val));
 135 }
 136
 137 int _valid_for_type(SV *value, vartype_t type)
 138 {
 139     svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL;
 140
 141     switch (type) {
 142     case VAR_SCALAR:
 143         return sv_type == SVt_NULL ||
 144                sv_type == SVt_IV   ||
 145                sv_type == SVt_NV   ||
 146                sv_type == SVt_PV   ||
 147                sv_type == SVt_RV;
 148     case VAR_ARRAY:
 149         return sv_type == SVt_PVAV;
 150     case VAR_HASH:
 151         return sv_type == SVt_PVHV;
 152     case VAR_CODE:
 153         return sv_type == SVt_PVCV;
 154     case VAR_IO:
 155         return sv_type == SVt_PVIO;
 156     default:
 157         return 0;
 158     }
 159 }
 160
 161 HV *_get_namespace(SV *self)
 162 {
 163     dSP;
 164     SV *ret;
 165
 166     PUSHMARK(SP);
 167     XPUSHs(self);
 168     PUTBACK;
 169
 170     call_method("namespace", G_SCALAR);
 171
 172     SPAGAIN;
 173     ret = POPs;
 174     PUTBACK;
 175
 176     return (HV*)SvRV(ret);
 177 }
 178
 179 SV *_get_name(SV *self)
 180 {
 181     dSP;
 182     SV *ret;
 183
 184     PUSHMARK(SP);
 185     XPUSHs(self);
 186     PUTBACK;
 187
 188     call_method("name", G_SCALAR);
 189
 190     SPAGAIN;
 191     ret = POPs;
 192     PUTBACK;
 193
 194     return ret;
 195 }
 196
 197 MODULE = Package::Stash  PACKAGE = Package::Stash
 198
 199 PROTOTYPES: DISABLE
 200
 201 SV*
 202 new(class, package_name)
 203     char *class
 204     SV *package_name
 205   PREINIT:
 206     HV *instance;
 207     HV *namespace;
 208   CODE:
 209     if (!SvPOK(package_name))
 210         croak("The constructor argument must be the name of a package");
 211
 212     instance = newHV();
 213
 214     hv_store(instance, "name", 4, package_name, 0);
 215     namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
 216     hv_store(instance, "namespace", 9, newRV((SV*)namespace), 0);
 217
 218     RETVAL = sv_bless(newRV((SV*)instance), gv_stashpv(class, 0));
 219   OUTPUT:
 220     RETVAL
 221
 222 SV*
 223 name(self)
 224     SV *self
 225   PREINIT:
 226     SV **slot;
 227   CODE:
 228     if (!sv_isobject(self))
 229         croak("Can't call name as a class method");
 230     slot = hv_fetch((HV*)SvRV(self), "name", 4, 0);
 231     RETVAL = slot ? SvREFCNT_inc(*slot) : &PL_sv_undef;
 232   OUTPUT:
 233     RETVAL
 234
 235 SV*
 236 namespace(self)
 237     SV *self
 238   PREINIT:
 239     SV **slot;
 240   CODE:
 241     if (!sv_isobject(self))
 242         croak("Can't call namespace as a class method");
 243     slot = hv_fetch((HV*)SvRV(self), "namespace", 9, 0);
 244     RETVAL = slot ? SvREFCNT_inc(*slot) : &PL_sv_undef;
 245   OUTPUT:
 246     RETVAL
 247
 248 void
 249 add_package_symbol(self, variable, initial=NULL, ...)
 250     SV *self
 251     varspec_t variable
 252     SV *initial
 253   PREINIT:
 254     SV *name;
 255     GV *glob;
 256   CODE:
 257     if (initial && !_valid_for_type(initial, variable.type))
 258         croak("%s is not of type %s",
 259               SvPV_nolen(initial), vartype_to_string(variable.type));
 260
 261     name = newSVsv(_get_name(self));
 262     sv_catpvs(name, "::");
 263     sv_catpv(name, variable.name);
 264
 265     /* XXX: come back to this when i feel like reimplementing caller() */
 266 /*
 267     my $filename = $opts{filename};
 268     my $first_line_num = $opts{first_line_num};
 269
 270     (undef, $filename, $first_line_num) = caller
 271         if not defined $filename;
 272
 273     my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
 274
 275     # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
 276     $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
 277 */
 278 /*
 279     if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
 280         int i;
 281         char *filename = NULL, *name;
 282         I32 first_line_num, last_line_num;
 283
 284         if ((items - 3) % 2)
 285             croak("add_package_symbol: Odd number of elements in %%opts");
 286
 287         for (i = 3; i < items; i += 2) {
 288             char *key;
 289             key = SvPV_nolen(ST(i));
 290             if (strEQ(key, "filename")) {
 291                 if (!SvPOK(ST(i + 1)))
 292                     croak("add_package_symbol: filename must be a string");
 293                 filename = SvPV_nolen(ST(i + 1));
 294             }
 295             else if (strEQ(key, "first_line_num")) {
 296                 if (!SvIOK(ST(i + 1)))
 297                     croak("add_package_symbol: first_line_num must be an integer");
 298                 first_line_num = SvIV(ST(i + 1));
 299             }
 300             else if (strEQ(key, "last_line_num")) {
 301                 if (!SvIOK(ST(i + 1)))
 302                     croak("add_package_symbol: last_line_num must be an integer");
 303                 last_line_num = SvIV(ST(i + 1));
 304             }
 305         }
 306
 307         if (!filename) {
 308         }
 309     }
 310 */
 311
 312     glob = gv_fetchsv(name, GV_ADD, vartype_to_svtype(variable.type));
 313
 314     if (initial) {
 315         SV *val;
 316
 317         if (SvROK(initial)) {
 318             val = SvRV(initial);
 319             SvREFCNT_inc(val);
 320         }
 321         else {
 322             val = newSVsv(initial);
 323         }
 324
 325         switch (variable.type) {
 326         case VAR_SCALAR:
 327             GvSV(glob) = val;
 328             break;
 329         case VAR_ARRAY:
 330             GvAV(glob) = (AV*)val;
 331             break;
 332         case VAR_HASH:
 333             GvHV(glob) = (HV*)val;
 334             break;
 335         case VAR_CODE:
 336             GvCV(glob) = (CV*)val;
 337             break;
 338         case VAR_IO:
 339             GvIOp(glob) = (IO*)val;
 340             break;
 341         }
 342     }
 343
 344 void
 345 remove_package_glob(self, name)
 346     SV *self
 347     char *name
 348   CODE:
 349     hv_delete(_get_namespace(self), name, strlen(name), G_DISCARD);
 350
 351 int
 352 has_package_symbol(self, variable)
 353     SV *self
 354     varspec_t variable
 355   PREINIT:
 356     HV *namespace;
 357     SV **entry;
 358   CODE:
 359     namespace = _get_namespace(self);
 360     entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
 361     if (!entry)
 362         XSRETURN_UNDEF;
 363
 364     if (isGV(*entry)) {
 365         GV *glob = (GV*)(*entry);
 366         switch (variable.type) {
 367         case VAR_SCALAR:
 368             RETVAL = GvSV(glob) ? 1 : 0;
 369             break;
 370         case VAR_ARRAY:
 371             RETVAL = GvAV(glob) ? 1 : 0;
 372             break;
 373         case VAR_HASH:
 374             RETVAL = GvHV(glob) ? 1 : 0;
 375             break;
 376         case VAR_CODE:
 377             RETVAL = GvCV(glob) ? 1 : 0;
 378             break;
 379         case VAR_IO:
 380             RETVAL = GvIO(glob) ? 1 : 0;
 381             break;
 382         }
 383     }
 384     else {
 385         RETVAL = (variable.type == VAR_CODE);
 386     }
 387   OUTPUT:
 388     RETVAL
 389
 390 SV*
 391 get_package_symbol(self, variable, ...)
 392     SV *self
 393     varspec_t variable
 394   PREINIT:
 395     HV *namespace;
 396     SV **entry;
 397     GV *glob;
 398   CODE:
 399     namespace = _get_namespace(self);
 400
 401     if (!hv_exists(namespace, variable.name, strlen(variable.name))) {
 402         int i, vivify = 0;
 403         if ((items - 2) % 2)
 404             croak("get_package_symbol: Odd number of elements in %%opts");
 405
 406         for (i = 2; i < items; i += 2) {
 407             char *key;
 408             key = SvPV_nolen(ST(i));
 409             if (strEQ(key, "vivify")) {
 410                 vivify = SvTRUE(ST(i + 1));
 411             }
 412         }
 413
 414         if (vivify) {
 415             /* XXX: vivify */
 416         }
 417     }
 418
 419     entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
 420     if (!entry)
 421         XSRETURN_UNDEF;
 422
 423     glob = (GV*)(*entry);
 424
 425     if (!isGV(*entry)) {
 426         SV *namesv;
 427         char *name;
 428         int len;
 429
 430         namesv = newSVsv(_get_name(self));
 431         sv_catpvs(namesv, "::");
 432         sv_catpv(namesv, variable.name);
 433
 434         name = SvPV(namesv, len);
 435
 436         gv_init(glob, namespace, name, len, 1);
 437     }
 438
 439     switch (variable.type) {
 440     case VAR_SCALAR:
 441         RETVAL = newRV(GvSV(glob));
 442         break;
 443     case VAR_ARRAY:
 444         RETVAL = newRV((SV*)GvAV(glob));
 445         break;
 446     case VAR_HASH:
 447         RETVAL = newRV((SV*)GvHV(glob));
 448         break;
 449     case VAR_CODE:
 450         RETVAL = newRV((SV*)GvCV(glob));
 451         break;
 452     case VAR_IO:
 453         RETVAL = newRV((SV*)GvIO(glob));
 454         break;
 455     }
 456   OUTPUT:
 457     RETVAL
 458
 459 void
 460 remove_package_symbol(self, variable)
 461     SV *self
 462     varspec_t variable
 463   PREINIT:
 464     HV *namespace;
 465     SV **entry;
 466   CODE:
 467     namespace = _get_namespace(self);
 468     entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
 469     if (!entry)
 470         XSRETURN_EMPTY;
 471
 472     if (isGV(*entry)) {
 473         GV *glob = (GV*)(*entry);
 474         switch (variable.type) {
 475         case VAR_SCALAR:
 476             GvSV(glob) = Nullsv;
 477             break;
 478         case VAR_ARRAY:
 479             GvAV(glob) = Nullav;
 480             break;
 481         case VAR_HASH:
 482             GvHV(glob) = Nullhv;
 483             break;
 484         case VAR_CODE:
 485             GvCV(glob) = Nullcv;
 486             break;
 487         case VAR_IO:
 488             GvIOp(glob) = Null(IO*);
 489             break;
 490         }
 491     }
 492     else {
 493         if (variable.type == VAR_CODE) {
 494             hv_delete(namespace, variable.name, strlen(variable.name), G_DISCARD);
 495         }
 496     }
 497
 498 void
 499 list_all_package_symbols(self, vartype=VAR_NONE)
 500     SV *self
 501     vartype_t vartype
 502   PPCODE:
 503     if (vartype == VAR_NONE) {
 504         HV *namespace;
 505         HE *entry;
 506         int keys;
 507
 508         namespace = _get_namespace(self);
 509         keys = hv_iterinit(namespace);
 510         EXTEND(SP, keys);
 511         while (entry = hv_iternext(namespace)) {
 512             mPUSHs(newSVhek(HeKEY_hek(entry)));
 513         }
 514     }
 515     else {
 516         HV *namespace;
 517         HE *entry;
 518         SV *val;
 519         char *key;
 520         int len;
 521
 522         namespace = _get_namespace(self);
 523         hv_iterinit(namespace);
 524         while (val = hv_iternextsv(namespace, &key, &len)) {
 525             GV *gv = (GV*)val;
 526             if (isGV(gv)) {
 527                 switch (vartype) {
 528                 case VAR_SCALAR:
 529                     if (GvSV(val))
 530                         mXPUSHp(key, len);
 531                     break;
 532                 case VAR_ARRAY:
 533                     if (GvAV(val))
 534                         mXPUSHp(key, len);
 535                     break;
 536                 case VAR_HASH:
 537                     if (GvHV(val))
 538                         mXPUSHp(key, len);
 539                     break;
 540                 case VAR_CODE:
 541                     if (GvCVu(val))
 542                         mXPUSHp(key, len);
 543                     break;
 544                 case VAR_IO:
 545                     if (GvIO(val))
 546                         mXPUSHp(key, len);
 547                     break;
 548                 }
 549             }
 550             else if (vartype == VAR_CODE) {
 551                 mXPUSHp(key, len);
 552             }
 553         }
 554     }