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
 117     val = hv_fetch(variable, "name", 4, 0);
 118     if (!val)
 119         croak("The 'name' key is required in variable specs");
 120
 121     varspec->name = savesvpv(*val);
 122     SAVEFREEPV(varspec->name);
 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 SV *_get_package_symbol(SV *self, varspec_t *variable, int vivify)
 198 {
 199     HV *namespace;
 200     SV **entry;
 201     GV *glob;
 202
 203     namespace = _get_namespace(self);
 204     entry = hv_fetch(namespace, variable->name, strlen(variable->name), vivify);
 205     if (!entry)
 206         return NULL;
 207
 208     glob = (GV*)(*entry);
 209     if (!isGV(glob)) {
 210         SV *namesv;
 211
 212         namesv = newSVsv(_get_name(self));
 213         sv_catpvs(namesv, "::");
 214         sv_catpv(namesv, variable->name);
 215
 216         /* can't use gv_init here, because it screws up @ISA in a way that I
 217          * can't reproduce, but that CMOP triggers */
 218         gv_fetchsv(namesv, GV_ADD, vartype_to_svtype(variable->type));
 219         SvREFCNT_dec(namesv);
 220     }
 221
 222     if (vivify) {
 223         switch (variable->type) {
 224         case VAR_SCALAR:
 225             if (!GvSV(glob))
 226                 GvSV(glob) = newSV(0);
 227             break;
 228         case VAR_ARRAY:
 229             if (!GvAV(glob))
 230                 GvAV(glob) = newAV();
 231             break;
 232         case VAR_HASH:
 233             if (!GvHV(glob))
 234                 GvHV(glob) = newHV();
 235             break;
 236         case VAR_CODE:
 237             croak("Don't know how to vivify CODE variables");
 238         case VAR_IO:
 239             if (!GvIO(glob))
 240                 GvIOp(glob) = newIO();
 241             break;
 242         default:
 243             croak("Unknown type in vivication");
 244         }
 245     }
 246
 247     switch (variable->type) {
 248     case VAR_SCALAR:
 249         return GvSV(glob);
 250     case VAR_ARRAY:
 251         return (SV*)GvAV(glob);
 252     case VAR_HASH:
 253         return (SV*)GvHV(glob);
 254     case VAR_CODE:
 255         return (SV*)GvCV(glob);
 256     case VAR_IO:
 257         return (SV*)GvIO(glob);
 258     default:
 259         return NULL;
 260     }
 261 }
 262
 263 MODULE = Package::Stash  PACKAGE = Package::Stash
 264
 265 PROTOTYPES: DISABLE
 266
 267 SV*
 268 new(class, package_name)
 269     char *class
 270     SV *package_name
 271   PREINIT:
 272     HV *instance;
 273     HV *namespace;
 274     SV *nsref;
 275   CODE:
 276     if (!SvPOK(package_name))
 277         croak("The constructor argument must be the name of a package");
 278
 279     instance = newHV();
 280
 281     if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package_name), 0)) {
 282         SvREFCNT_dec(package_name);
 283         SvREFCNT_dec(instance);
 284         croak("Couldn't initialize the 'name' key, hv_store failed");
 285     }
 286     namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
 287     nsref = newRV_inc((SV*)namespace);
 288     if (!hv_store(instance, "namespace", 9, nsref, 0)) {
 289         SvREFCNT_dec(nsref);
 290         SvREFCNT_dec(instance);
 291         croak("Couldn't initialize the 'namespace' key, hv_store failed");
 292     }
 293
 294     RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashpv(class, 0));
 295   OUTPUT:
 296     RETVAL
 297
 298 SV*
 299 name(self)
 300     SV *self
 301   PREINIT:
 302     SV **slot;
 303   CODE:
 304     if (!sv_isobject(self))
 305         croak("Can't call name as a class method");
 306     slot = hv_fetch((HV*)SvRV(self), "name", 4, 0);
 307     RETVAL = slot ? SvREFCNT_inc_simple_NN(*slot) : &PL_sv_undef;
 308   OUTPUT:
 309     RETVAL
 310
 311 SV*
 312 namespace(self)
 313     SV *self
 314   PREINIT:
 315     SV **slot;
 316   CODE:
 317     if (!sv_isobject(self))
 318         croak("Can't call namespace as a class method");
 319     slot = hv_fetch((HV*)SvRV(self), "namespace", 9, 0);
 320     RETVAL = slot ? SvREFCNT_inc_simple_NN(*slot) : &PL_sv_undef;
 321   OUTPUT:
 322     RETVAL
 323
 324 void
 325 add_package_symbol(self, variable, initial=NULL, ...)
 326     SV *self
 327     varspec_t variable
 328     SV *initial
 329   PREINIT:
 330     SV *name;
 331     GV *glob;
 332   CODE:
 333     if (initial && !_valid_for_type(initial, variable.type))
 334         croak("%s is not of type %s",
 335               SvPV_nolen(initial), vartype_to_string(variable.type));
 336
 337     name = newSVsv(_get_name(self));
 338     sv_catpvs(name, "::");
 339     sv_catpv(name, variable.name);
 340
 341     /* XXX: come back to this when i feel like reimplementing caller() */
 342 /*
 343     my $filename = $opts{filename};
 344     my $first_line_num = $opts{first_line_num};
 345
 346     (undef, $filename, $first_line_num) = caller
 347         if not defined $filename;
 348
 349     my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
 350
 351     # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
 352     $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
 353 */
 354 /*
 355     if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
 356         int i;
 357         char *filename = NULL, *name;
 358         I32 first_line_num, last_line_num;
 359
 360         if ((items - 3) % 2)
 361             croak("add_package_symbol: Odd number of elements in %%opts");
 362
 363         for (i = 3; i < items; i += 2) {
 364             char *key;
 365             key = SvPV_nolen(ST(i));
 366             if (strEQ(key, "filename")) {
 367                 if (!SvPOK(ST(i + 1)))
 368                     croak("add_package_symbol: filename must be a string");
 369                 filename = SvPV_nolen(ST(i + 1));
 370             }
 371             else if (strEQ(key, "first_line_num")) {
 372                 if (!SvIOK(ST(i + 1)))
 373                     croak("add_package_symbol: first_line_num must be an integer");
 374                 first_line_num = SvIV(ST(i + 1));
 375             }
 376             else if (strEQ(key, "last_line_num")) {
 377                 if (!SvIOK(ST(i + 1)))
 378                     croak("add_package_symbol: last_line_num must be an integer");
 379                 last_line_num = SvIV(ST(i + 1));
 380             }
 381         }
 382
 383         if (!filename) {
 384         }
 385     }
 386 */
 387
 388     glob = gv_fetchsv(name, GV_ADDMULTI, vartype_to_svtype(variable.type));
 389
 390     if (initial) {
 391         SV *val;
 392
 393         if (SvROK(initial)) {
 394             val = SvRV(initial);
 395             SvREFCNT_inc_simple_void_NN(val);
 396         }
 397         else {
 398             val = newSVsv(initial);
 399         }
 400
 401         switch (variable.type) {
 402         case VAR_SCALAR:
 403             SvREFCNT_dec(GvSV(glob));
 404             GvSV(glob) = val;
 405             GvIMPORTED_SV_on(glob);
 406             break;
 407         case VAR_ARRAY:
 408             SvREFCNT_dec(GvAV(glob));
 409             GvAV(glob) = (AV*)val;
 410             GvIMPORTED_AV_on(glob);
 411             break;
 412         case VAR_HASH:
 413             SvREFCNT_dec(GvHV(glob));
 414             GvHV(glob) = (HV*)val;
 415             GvIMPORTED_HV_on(glob);
 416             break;
 417         case VAR_CODE:
 418             SvREFCNT_dec(GvCV(glob));
 419             GvCV(glob) = (CV*)val;
 420             GvIMPORTED_CV_on(glob);
 421             GvASSUMECV_on(glob);
 422             GvCVGEN(glob) = 0;
 423             mro_method_changed_in(GvSTASH(glob));
 424             break;
 425         case VAR_IO:
 426             SvREFCNT_dec(GvIO(glob));
 427             GvIOp(glob) = (IO*)val;
 428             break;
 429         }
 430     }
 431
 432     SvREFCNT_dec(name);
 433
 434 void
 435 remove_package_glob(self, name)
 436     SV *self
 437     char *name
 438   CODE:
 439     hv_delete(_get_namespace(self), name, strlen(name), G_DISCARD);
 440
 441 int
 442 has_package_symbol(self, variable)
 443     SV *self
 444     varspec_t variable
 445   PREINIT:
 446     HV *namespace;
 447     SV **entry;
 448   CODE:
 449     namespace = _get_namespace(self);
 450     entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
 451     if (!entry)
 452         XSRETURN_UNDEF;
 453
 454     if (isGV(*entry)) {
 455         GV *glob = (GV*)(*entry);
 456         switch (variable.type) {
 457         case VAR_SCALAR:
 458             RETVAL = GvSV(glob) ? 1 : 0;
 459             break;
 460         case VAR_ARRAY:
 461             RETVAL = GvAV(glob) ? 1 : 0;
 462             break;
 463         case VAR_HASH:
 464             RETVAL = GvHV(glob) ? 1 : 0;
 465             break;
 466         case VAR_CODE:
 467             RETVAL = GvCV(glob) ? 1 : 0;
 468             break;
 469         case VAR_IO:
 470             RETVAL = GvIO(glob) ? 1 : 0;
 471             break;
 472         }
 473     }
 474     else {
 475         RETVAL = (variable.type == VAR_CODE);
 476     }
 477   OUTPUT:
 478     RETVAL
 479
 480 SV*
 481 get_package_symbol(self, variable)
 482     SV *self
 483     varspec_t variable
 484   PREINIT:
 485     SV *val;
 486   CODE:
 487     val = _get_package_symbol(self, &variable, 0);
 488     if (!val)
 489         XSRETURN_UNDEF;
 490     RETVAL = newRV_inc(val);
 491   OUTPUT:
 492     RETVAL
 493
 494 SV*
 495 get_or_add_package_symbol(self, variable)
 496     SV *self
 497     varspec_t variable
 498   PREINIT:
 499     SV *val;
 500   CODE:
 501     val = _get_package_symbol(self, &variable, 1);
 502     if (!val)
 503         XSRETURN_UNDEF;
 504     RETVAL = newRV_inc(val);
 505   OUTPUT:
 506     RETVAL
 507
 508 void
 509 remove_package_symbol(self, variable)
 510     SV *self
 511     varspec_t variable
 512   PREINIT:
 513     HV *namespace;
 514     SV **entry;
 515   CODE:
 516     namespace = _get_namespace(self);
 517     entry = hv_fetch(namespace, variable.name, strlen(variable.name), 0);
 518     if (!entry)
 519         XSRETURN_EMPTY;
 520
 521     if (isGV(*entry)) {
 522         GV *glob = (GV*)(*entry);
 523         switch (variable.type) {
 524         case VAR_SCALAR:
 525             GvSV(glob) = (SV *)NULL;
 526             break;
 527         case VAR_ARRAY:
 528             GvAV(glob) = (AV *)NULL;
 529             break;
 530         case VAR_HASH:
 531             GvHV(glob) = (HV *)NULL;
 532             break;
 533         case VAR_CODE:
 534             GvCV(glob) = (CV *)NULL;
 535             GvCVGEN(glob) = 0;
 536             mro_method_changed_in(GvSTASH(glob));
 537             break;
 538         case VAR_IO:
 539             GvIOp(glob) = (IO *)NULL;
 540             break;
 541         }
 542     }
 543     else {
 544         if (variable.type == VAR_CODE) {
 545             hv_delete(namespace, variable.name, strlen(variable.name), G_DISCARD);
 546         }
 547     }
 548
 549 void
 550 list_all_package_symbols(self, vartype=VAR_NONE)
 551     SV *self
 552     vartype_t vartype
 553   PPCODE:
 554     if (vartype == VAR_NONE) {
 555         HV *namespace;
 556         HE *entry;
 557         int keys;
 558
 559         namespace = _get_namespace(self);
 560         keys = hv_iterinit(namespace);
 561         EXTEND(SP, keys);
 562         while ((entry = hv_iternext(namespace))) {
 563             mPUSHs(newSVhek(HeKEY_hek(entry)));
 564         }
 565     }
 566     else {
 567         HV *namespace;
 568         SV *val;
 569         char *key;
 570         int len;
 571
 572         namespace = _get_namespace(self);
 573         hv_iterinit(namespace);
 574         while ((val = hv_iternextsv(namespace, &key, &len))) {
 575             GV *gv = (GV*)val;
 576             if (isGV(gv)) {
 577                 switch (vartype) {
 578                 case VAR_SCALAR:
 579                     if (GvSV(val))
 580                         mXPUSHp(key, len);
 581                     break;
 582                 case VAR_ARRAY:
 583                     if (GvAV(val))
 584                         mXPUSHp(key, len);
 585                     break;
 586                 case VAR_HASH:
 587                     if (GvHV(val))
 588                         mXPUSHp(key, len);
 589                     break;
 590                 case VAR_CODE:
 591                     if (GvCVu(val))
 592                         mXPUSHp(key, len);
 593                     break;
 594                 case VAR_IO:
 595                     if (GvIO(val))
 596                         mXPUSHp(key, len);
 597                     break;
 598                 }
 599             }
 600             else if (vartype == VAR_CODE) {
 601                 mXPUSHp(key, len);
 602             }
 603         }
 604     }