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     SAVEFREEPV(varspec->name);
 124
 125     val = hv_fetch(variable, "sigil", 5, 0);
 126     if (!val)
 127         croak("The 'sigil' key is required in variable specs");
 128
 129     varspec->sigil = (SvPV_nolen(*val))[0];
 130
 131     val = hv_fetch(variable, "type", 4, 0);
 132     if (!val)
 133         croak("The 'type' key is required in variable specs");
 134
 135     varspec->type = string_to_vartype(SvPV_nolen(*val));
 136 }
 137
 138 int _valid_for_type(SV *value, vartype_t type)
 139 {
 140     svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL;
 141
 142     switch (type) {
 143     case VAR_SCALAR:
 144         return sv_type == SVt_NULL ||
 145                sv_type == SVt_IV   ||
 146                sv_type == SVt_NV   ||
 147                sv_type == SVt_PV   ||
 148                sv_type == SVt_RV;
 149     case VAR_ARRAY:
 150         return sv_type == SVt_PVAV;
 151     case VAR_HASH:
 152         return sv_type == SVt_PVHV;
 153     case VAR_CODE:
 154         return sv_type == SVt_PVCV;
 155     case VAR_IO:
 156         return sv_type == SVt_PVIO;
 157     default:
 158         return 0;
 159     }
 160 }
 161
 162 HV *_get_namespace(SV *self)
 163 {
 164     dSP;
 165     SV *ret;
 166
 167     PUSHMARK(SP);
 168     XPUSHs(self);
 169     PUTBACK;
 170
 171     call_method("namespace", G_SCALAR);
 172
 173     SPAGAIN;
 174     ret = POPs;
 175     PUTBACK;
 176
 177     return (HV*)SvRV(ret);
 178 }
 179
 180 SV *_get_name(SV *self)
 181 {
 182     dSP;
 183     SV *ret;
 184
 185     PUSHMARK(SP);
 186     XPUSHs(self);
 187     PUTBACK;
 188
 189     call_method("name", G_SCALAR);
 190
 191     SPAGAIN;
 192     ret = POPs;
 193     PUTBACK;
 194
 195     return ret;
 196 }
 197
 198 SV *_get_package_symbol(SV *self, varspec_t *variable, int vivify)
 199 {
 200     HV *namespace;
 201     SV **entry;
 202     GV *glob;
 203
 204     namespace = _get_namespace(self);
 205     entry = hv_fetch(namespace, variable->name, strlen(variable->name), vivify);
 206     if (!entry)
 207         return NULL;
 208
 209     glob = (GV*)(*entry);
 210     if (!isGV(glob)) {
 211         SV *namesv;
 212         char *name;
 213         STRLEN len;
 214
 215         namesv = newSVsv(_get_name(self));
 216         sv_catpvs(namesv, "::");
 217         sv_catpv(namesv, variable->name);
 218
 219         name = SvPV(namesv, len);
 220
 221         gv_init(glob, namespace, name, len, 1);
 222     }
 223
 224     if (vivify) {
 225         switch (variable->type) {
 226         case VAR_SCALAR:
 227             if (!GvSV(glob))
 228                 GvSV(glob) = newSV(0);
 229             break;
 230         case VAR_ARRAY:
 231             if (!GvAV(glob))
 232                 GvAV(glob) = newAV();
 233             break;
 234         case VAR_HASH:
 235             if (!GvHV(glob))
 236                 GvHV(glob) = newHV();
 237             break;
 238         case VAR_CODE:
 239             croak("Don't know how to vivify CODE variables");
 240         case VAR_IO:
 241             if (!GvIO(glob))
 242                 GvIOp(glob) = newIO();
 243             break;
 244         default:
 245             croak("Unknown type in vivication");
 246         }
 247     }
 248
 249     switch (variable->type) {
 250     case VAR_SCALAR:
 251         return GvSV(glob);
 252     case VAR_ARRAY:
 253         return (SV*)GvAV(glob);
 254     case VAR_HASH:
 255         return (SV*)GvHV(glob);
 256     case VAR_CODE:
 257         return (SV*)GvCV(glob);
 258     case VAR_IO:
 259         return (SV*)GvIO(glob);
 260     default:
 261         return NULL;
 262     }
 263 }
 264
 265 MODULE = Package::Stash  PACKAGE = Package::Stash
 266
 267 PROTOTYPES: DISABLE
 268
 269 SV*
 270 new(class, package_name)
 271     char *class
 272     SV *package_name
 273   PREINIT:
 274     HV *instance;
 275     HV *namespace;
 276   CODE:
 277     if (!SvPOK(package_name))
 278         croak("The constructor argument must be the name of a package");
 279
 280     instance = newHV();
 281
 282     hv_store(instance, "name", 4, package_name, 0);
 283     namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
 284     hv_store(instance, "namespace", 9, newRV((SV*)namespace), 0);
 285
 286     RETVAL = sv_bless(newRV((SV*)instance), gv_stashpv(class, 0));
 287   OUTPUT:
 288     RETVAL
 289
 290 SV*
 291 name(self)
 292     SV *self
 293   PREINIT:
 294     SV **slot;
 295   CODE:
 296     if (!sv_isobject(self))
 297         croak("Can't call name as a class method");
 298     slot = hv_fetch((HV*)SvRV(self), "name", 4, 0);
 299     RETVAL = slot ? SvREFCNT_inc(*slot) : &PL_sv_undef;
 300   OUTPUT:
 301     RETVAL
 302
 303 SV*
 304 namespace(self)
 305     SV *self
 306   PREINIT:
 307     SV **slot;
 308   CODE:
 309     if (!sv_isobject(self))
 310         croak("Can't call namespace as a class method");
 311     slot = hv_fetch((HV*)SvRV(self), "namespace", 9, 0);
 312     RETVAL = slot ? SvREFCNT_inc(*slot) : &PL_sv_undef;
 313   OUTPUT:
 314     RETVAL
 315
 316 void
 317 add_package_symbol(self, variable, initial=NULL, ...)
 318     SV *self
 319     varspec_t variable
 320     SV *initial
 321   PREINIT:
 322     SV *name;
 323     GV *glob;
 324   CODE:
 325     if (initial && !_valid_for_type(initial, variable.type))
 326         croak("%s is not of type %s",
 327               SvPV_nolen(initial), vartype_to_string(variable.type));
 328
 329     name = newSVsv(_get_name(self));
 330     sv_catpvs(name, "::");
 331     sv_catpv(name, variable.name);
 332
 333     /* XXX: come back to this when i feel like reimplementing caller() */
 334 /*
 335     my $filename = $opts{filename};
 336     my $first_line_num = $opts{first_line_num};
 337
 338     (undef, $filename, $first_line_num) = caller
 339         if not defined $filename;
 340
 341     my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
 342
 343     # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
 344     $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
 345 */
 346 /*
 347     if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
 348         int i;
 349         char *filename = NULL, *name;
 350         I32 first_line_num, last_line_num;
 351
 352         if ((items - 3) % 2)
 353             croak("add_package_symbol: Odd number of elements in %%opts");
 354
 355         for (i = 3; i < items; i += 2) {
 356             char *key;
 357             key = SvPV_nolen(ST(i));
 358             if (strEQ(key, "filename")) {
 359                 if (!SvPOK(ST(i + 1)))
 360                     croak("add_package_symbol: filename must be a string");
 361                 filename = SvPV_nolen(ST(i + 1));
 362             }
 363             else if (strEQ(key, "first_line_num")) {
 364                 if (!SvIOK(ST(i + 1)))
 365                     croak("add_package_symbol: first_line_num must be an integer");
 366                 first_line_num = SvIV(ST(i + 1));
 367             }
 368             else if (strEQ(key, "last_line_num")) {
 369                 if (!SvIOK(ST(i + 1)))
 370                     croak("add_package_symbol: last_line_num must be an integer");
 371                 last_line_num = SvIV(ST(i + 1));
 372             }
 373         }
 374
 375         if (!filename) {
 376         }
 377     }
 378 */
 379
 380     glob = gv_fetchsv(name, GV_ADD, vartype_to_svtype(variable.type));
 381
 382     if (initial) {
 383         SV *val;
 384
 385         if (SvROK(initial)) {
 386             val = SvRV(initial);
 387             SvREFCNT_inc(val);
 388         }
 389         else {
 390             val = newSVsv(initial);
 391         }
 392
 393         switch (variable.type) {
 394         case VAR_SCALAR:
 395             GvSV(glob) = val;
 396             break;
 397         case VAR_ARRAY:
 398             GvAV(glob) = (AV*)val;
 399             break;
 400         case VAR_HASH:
 401             GvHV(glob) = (HV*)val;
 402             break;
 403         case VAR_CODE:
 404             GvCV(glob) = (CV*)val;
 405             break;
 406         case VAR_IO:
 407             GvIOp(glob) = (IO*)val;
 408             break;
 409         }
 410     }
 411
 412 void
 413 remove_package_glob(self, name)
 414     SV *self
 415     char *name
 416   CODE:
 417     hv_delete(_get_namespace(self), name, strlen(name), G_DISCARD);
 418
 419 int
 420 has_package_symbol(self, variable)
 421     SV *self
 422     varspec_t variable
 423   PREINIT:
 424     HV *namespace;
 425     SV **entry;
 426   CODE:
 427     namespace = _get_namespace(self);
 428     entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
 429     if (!entry)
 430         XSRETURN_UNDEF;
 431
 432     if (isGV(*entry)) {
 433         GV *glob = (GV*)(*entry);
 434         switch (variable.type) {
 435         case VAR_SCALAR:
 436             RETVAL = GvSV(glob) ? 1 : 0;
 437             break;
 438         case VAR_ARRAY:
 439             RETVAL = GvAV(glob) ? 1 : 0;
 440             break;
 441         case VAR_HASH:
 442             RETVAL = GvHV(glob) ? 1 : 0;
 443             break;
 444         case VAR_CODE:
 445             RETVAL = GvCV(glob) ? 1 : 0;
 446             break;
 447         case VAR_IO:
 448             RETVAL = GvIO(glob) ? 1 : 0;
 449             break;
 450         }
 451     }
 452     else {
 453         RETVAL = (variable.type == VAR_CODE);
 454     }
 455   OUTPUT:
 456     RETVAL
 457
 458 SV*
 459 get_package_symbol(self, variable)
 460     SV *self
 461     varspec_t variable
 462   PREINIT:
 463     SV *val;
 464   CODE:
 465     val = _get_package_symbol(self, &variable, 0);
 466     if (!val)
 467         XSRETURN_UNDEF;
 468     RETVAL = newRV(val);
 469   OUTPUT:
 470     RETVAL
 471
 472 SV*
 473 get_or_add_package_symbol(self, variable)
 474     SV *self
 475     varspec_t variable
 476   PREINIT:
 477     SV *val;
 478   CODE:
 479     val = _get_package_symbol(self, &variable, 1);
 480     if (!val)
 481         XSRETURN_UNDEF;
 482     RETVAL = newRV(val);
 483   OUTPUT:
 484     RETVAL
 485
 486 void
 487 remove_package_symbol(self, variable)
 488     SV *self
 489     varspec_t variable
 490   PREINIT:
 491     HV *namespace;
 492     SV **entry;
 493   CODE:
 494     namespace = _get_namespace(self);
 495     entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
 496     if (!entry)
 497         XSRETURN_EMPTY;
 498
 499     if (isGV(*entry)) {
 500         GV *glob = (GV*)(*entry);
 501         switch (variable.type) {
 502         case VAR_SCALAR:
 503             GvSV(glob) = Nullsv;
 504             break;
 505         case VAR_ARRAY:
 506             GvAV(glob) = Nullav;
 507             break;
 508         case VAR_HASH:
 509             GvHV(glob) = Nullhv;
 510             break;
 511         case VAR_CODE:
 512             GvCV(glob) = Nullcv;
 513             break;
 514         case VAR_IO:
 515             GvIOp(glob) = Null(IO*);
 516             break;
 517         }
 518     }
 519     else {
 520         if (variable.type == VAR_CODE) {
 521             hv_delete(namespace, variable.name, strlen(variable.name), G_DISCARD);
 522         }
 523     }
 524
 525 void
 526 list_all_package_symbols(self, vartype=VAR_NONE)
 527     SV *self
 528     vartype_t vartype
 529   PPCODE:
 530     if (vartype == VAR_NONE) {
 531         HV *namespace;
 532         HE *entry;
 533         int keys;
 534
 535         namespace = _get_namespace(self);
 536         keys = hv_iterinit(namespace);
 537         EXTEND(SP, keys);
 538         while (entry = hv_iternext(namespace)) {
 539             mPUSHs(newSVhek(HeKEY_hek(entry)));
 540         }
 541     }
 542     else {
 543         HV *namespace;
 544         HE *entry;
 545         SV *val;
 546         char *key;
 547         int len;
 548
 549         namespace = _get_namespace(self);
 550         hv_iterinit(namespace);
 551         while (val = hv_iternextsv(namespace, &key, &len)) {
 552             GV *gv = (GV*)val;
 553             if (isGV(gv)) {
 554                 switch (vartype) {
 555                 case VAR_SCALAR:
 556                     if (GvSV(val))
 557                         mXPUSHp(key, len);
 558                     break;
 559                 case VAR_ARRAY:
 560                     if (GvAV(val))
 561                         mXPUSHp(key, len);
 562                     break;
 563                 case VAR_HASH:
 564                     if (GvHV(val))
 565                         mXPUSHp(key, len);
 566                     break;
 567                 case VAR_CODE:
 568                     if (GvCVu(val))
 569                         mXPUSHp(key, len);
 570                     break;
 571                 case VAR_IO:
 572                     if (GvIO(val))
 573                         mXPUSHp(key, len);
 574                     break;
 575                 }
 576             }
 577             else if (vartype == VAR_CODE) {
 578                 mXPUSHp(key, len);
 579             }
 580         }
 581     }