Stash.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4
   5 #define NEED_newRV_noinc
   6 #define NEED_sv_2pv_flags
   7 #include "ppport.h"
   8
   9 #ifndef gv_fetchsv
  10 #define gv_fetchsv(n,f,t) gv_fetchpv(SvPV_nolen(n), f, t)
  11 #endif
  12
  13 #ifndef mro_method_changed_in
  14 #define mro_method_changed_in(x) PL_sub_generation++
  15 #endif
  16
  17 #ifdef newSVhek
  18 #define newSVhe(he) newSVhek(HeKEY_hek(he))
  19 #else
  20 #define newSVhe(he) newSVpv(HePV(he, PL_na), 0)
  21 #endif
  22
  23 #ifndef savesvpv
  24 #define savesvpv(s) savepv(SvPV_nolen(s))
  25 #endif
  26
  27 /* HACK: scalar slots are always populated on perl < 5.10, so treat undef
  28  * as nonexistent. this is consistent with the previous behavior of the pure
  29  * perl version of this module (since this is the behavior that perl sees
  30  * in all versions */
  31 #if PERL_VERSION < 10
  32 #define GvSVOK(g) (GvSV(g) && SvTYPE(GvSV(g)) != SVt_NULL)
  33 #else
  34 #define GvSVOK(g) GvSV(g)
  35 #endif
  36
  37 #define GvAVOK(g) GvAV(g)
  38 #define GvHVOK(g) GvHV(g)
  39 #define GvCVOK(g) GvCVu(g) /* XXX: should this really be GvCVu? or GvCV? */
  40 #define GvIOOK(g) GvIO(g)
  41
  42 /* see above - don't let scalar slots become unpopulated, this breaks
  43  * assumptions in core */
  44 #if PERL_VERSION < 10
  45 #define GvSetSV(g,v) do {               \
  46     SV *_v = (SV*)(v);                  \
  47     SvREFCNT_dec(GvSV(g));              \
  48     if ((GvSV(g) = _v ? _v : newSV(0))) \
  49         GvIMPORTED_SV_on(g);            \
  50 } while (0)
  51 #else
  52 #define GvSetSV(g,v) do {               \
  53     SvREFCNT_dec(GvSV(g));              \
  54     if ((GvSV(g) = (SV*)(v)))           \
  55         GvIMPORTED_SV_on(g);            \
  56 } while (0)
  57 #endif
  58
  59 #define GvSetAV(g,v) do {               \
  60     SvREFCNT_dec(GvAV(g));              \
  61     if ((GvAV(g) = (AV*)(v)))           \
  62         GvIMPORTED_AV_on(g);            \
  63 } while (0)
  64 #define GvSetHV(g,v) do {               \
  65     SvREFCNT_dec(GvHV(g));              \
  66     if ((GvHV(g) = (HV*)(v)))           \
  67         GvIMPORTED_HV_on(g);            \
  68 } while (0)
  69 #define GvSetCV(g,v) do {               \
  70     SvREFCNT_dec(GvCV(g));              \
  71     if ((GvCV(g) = (CV*)(v))) {         \
  72         GvIMPORTED_CV_on(g);            \
  73         GvASSUMECV_on(g);               \
  74     }                                   \
  75     GvCVGEN(g) = 0;                     \
  76     mro_method_changed_in(GvSTASH(g));  \
  77 } while (0)
  78 #define GvSetIO(g,v) do {               \
  79     SvREFCNT_dec(GvIO(g));              \
  80     GvIOp(g) = (IO*)(v);                \
  81 } while (0)
  82
  83 /* XXX: the core implementation of caller() is private, so we need a
  84  * a reimplementation. luckily, padwalker already has done this. rafl says
  85  * that there should be a public interface in 5.14, so maybe look into
  86  * converting to use that at some point */
  87 #include "stolen_bits_of_padwalker.c"
  88
  89 typedef enum {
  90     VAR_NONE = 0,
  91     VAR_SCALAR,
  92     VAR_ARRAY,
  93     VAR_HASH,
  94     VAR_CODE,
  95     VAR_IO,
  96     VAR_GLOB,  /* TODO: unimplemented */
  97     VAR_FORMAT /* TODO: unimplemented */
  98 } vartype_t;
  99
 100 typedef struct {
 101     vartype_t type;
 102     char *name;
 103     I32 namelen;
 104 } varspec_t;
 105
 106 static U32 name_hash, namespace_hash, type_hash;
 107 static SV *name_key, *namespace_key, *type_key;
 108
 109 const char *vartype_to_string(vartype_t type)
 110 {
 111     switch (type) {
 112     case VAR_SCALAR:
 113         return "SCALAR";
 114     case VAR_ARRAY:
 115         return "ARRAY";
 116     case VAR_HASH:
 117         return "HASH";
 118     case VAR_CODE:
 119         return "CODE";
 120     case VAR_IO:
 121         return "IO";
 122     default:
 123         return "unknown";
 124     }
 125 }
 126
 127 I32 vartype_to_svtype(vartype_t type)
 128 {
 129     switch (type) {
 130     case VAR_SCALAR:
 131         return SVt_PV; /* or whatever */
 132     case VAR_ARRAY:
 133         return SVt_PVAV;
 134     case VAR_HASH:
 135         return SVt_PVHV;
 136     case VAR_CODE:
 137         return SVt_PVCV;
 138     case VAR_IO:
 139         return SVt_PVIO;
 140     default:
 141         return SVt_NULL;
 142     }
 143 }
 144
 145 vartype_t string_to_vartype(char *vartype)
 146 {
 147     if (strEQ(vartype, "SCALAR")) {
 148         return VAR_SCALAR;
 149     }
 150     else if (strEQ(vartype, "ARRAY")) {
 151         return VAR_ARRAY;
 152     }
 153     else if (strEQ(vartype, "HASH")) {
 154         return VAR_HASH;
 155     }
 156     else if (strEQ(vartype, "CODE")) {
 157         return VAR_CODE;
 158     }
 159     else if (strEQ(vartype, "IO")) {
 160         return VAR_IO;
 161     }
 162     else {
 163         croak("Type must be one of 'SCALAR', 'ARRAY', 'HASH', 'CODE', or 'IO'");
 164     }
 165 }
 166
 167 void _deconstruct_variable_name(SV *varsv, varspec_t *varspec)
 168 {
 169     char *variable;
 170     STRLEN len;
 171
 172     variable = SvPV(varsv, len);
 173     if (!variable[0])
 174         croak("You must pass a variable name");
 175
 176     switch (variable[0]) {
 177     case '$':
 178         varspec->type = VAR_SCALAR;
 179         varspec->name = &variable[1];
 180         varspec->namelen = len - 1;
 181         break;
 182     case '@':
 183         varspec->type = VAR_ARRAY;
 184         varspec->name = &variable[1];
 185         varspec->namelen = len - 1;
 186         break;
 187     case '%':
 188         varspec->type = VAR_HASH;
 189         varspec->name = &variable[1];
 190         varspec->namelen = len - 1;
 191         break;
 192     case '&':
 193         varspec->type = VAR_CODE;
 194         varspec->name = &variable[1];
 195         varspec->namelen = len - 1;
 196         break;
 197     default:
 198         varspec->type = VAR_IO;
 199         varspec->name = variable;
 200         varspec->namelen = len;
 201         break;
 202     }
 203 }
 204
 205 void _deconstruct_variable_hash(HV *variable, varspec_t *varspec)
 206 {
 207     HE *val;
 208     char *valpv;
 209     STRLEN len;
 210
 211     val = hv_fetch_ent(variable, name_key, 0, name_hash);
 212     if (!val)
 213         croak("The 'name' key is required in variable specs");
 214
 215     valpv = HePV(val, len);
 216     varspec->name = savepvn(valpv, len);
 217     SAVEFREEPV(varspec->name);
 218     varspec->namelen = len;
 219
 220     val = hv_fetch_ent(variable, type_key, 0, type_hash);
 221     if (!val)
 222         croak("The 'type' key is required in variable specs");
 223
 224     valpv = HePV(val, len);
 225     varspec->type = string_to_vartype(valpv);
 226 }
 227
 228 int _valid_for_type(SV *value, vartype_t type)
 229 {
 230     svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL;
 231
 232     switch (type) {
 233     case VAR_SCALAR:
 234         return sv_type == SVt_NULL ||
 235                sv_type == SVt_IV   ||
 236                sv_type == SVt_NV   ||
 237                sv_type == SVt_PV   ||
 238                sv_type == SVt_RV;
 239     case VAR_ARRAY:
 240         return sv_type == SVt_PVAV;
 241     case VAR_HASH:
 242         return sv_type == SVt_PVHV;
 243     case VAR_CODE:
 244         return sv_type == SVt_PVCV;
 245     case VAR_IO:
 246         return sv_type == SVt_PVIO;
 247     default:
 248         return 0;
 249     }
 250 }
 251
 252 HV *_get_namespace(SV *self)
 253 {
 254     dSP;
 255     SV *ret;
 256
 257     PUSHMARK(SP);
 258     XPUSHs(self);
 259     PUTBACK;
 260
 261     call_method("namespace", G_SCALAR);
 262
 263     SPAGAIN;
 264     ret = POPs;
 265     PUTBACK;
 266
 267     return (HV*)SvRV(ret);
 268 }
 269
 270 SV *_get_name(SV *self)
 271 {
 272     dSP;
 273     SV *ret;
 274
 275     PUSHMARK(SP);
 276     XPUSHs(self);
 277     PUTBACK;
 278
 279     call_method("name", G_SCALAR);
 280
 281     SPAGAIN;
 282     ret = POPs;
 283     PUTBACK;
 284
 285     return ret;
 286 }
 287
 288 void _expand_glob(SV *self, char *name)
 289 {
 290     SV *namesv;
 291
 292     namesv = newSVsv(_get_name(self));
 293     sv_catpvs(namesv, "::");
 294     sv_catpv(namesv, name);
 295
 296     /* can't use gv_init here, because it screws up @ISA in a way that I
 297      * can't reproduce, but that CMOP triggers */
 298     gv_fetchsv(namesv, GV_ADD, SVt_NULL);
 299     SvREFCNT_dec(namesv);
 300 }
 301
 302 SV *_get_symbol(SV *self, varspec_t *variable, int vivify)
 303 {
 304     HV *namespace;
 305     SV **entry;
 306     GV *glob;
 307
 308     namespace = _get_namespace(self);
 309     entry = hv_fetch(namespace, variable->name, variable->namelen, vivify);
 310     if (!entry)
 311         return NULL;
 312
 313     glob = (GV*)(*entry);
 314     if (!isGV(glob))
 315         _expand_glob(self, variable->name);
 316
 317     if (vivify) {
 318         switch (variable->type) {
 319         case VAR_SCALAR:
 320             if (!GvSVOK(glob))
 321                 GvSetSV(glob, newSV(0));
 322             break;
 323         case VAR_ARRAY:
 324             if (!GvAVOK(glob))
 325                 GvSetAV(glob, newAV());
 326             break;
 327         case VAR_HASH:
 328             if (!GvHVOK(glob))
 329                 GvSetHV(glob, newHV());
 330             break;
 331         case VAR_CODE:
 332             croak("Don't know how to vivify CODE variables");
 333         case VAR_IO:
 334             if (!GvIOOK(glob))
 335                 GvSetIO(glob, newIO());
 336             break;
 337         default:
 338             croak("Unknown type in vivication");
 339         }
 340     }
 341
 342     switch (variable->type) {
 343     case VAR_SCALAR:
 344         return GvSV(glob);
 345     case VAR_ARRAY:
 346         return (SV*)GvAV(glob);
 347     case VAR_HASH:
 348         return (SV*)GvHV(glob);
 349     case VAR_CODE:
 350         return (SV*)GvCV(glob);
 351     case VAR_IO:
 352         return (SV*)GvIO(glob);
 353     default:
 354         return NULL;
 355     }
 356 }
 357
 358 MODULE = Package::Stash  PACKAGE = Package::Stash
 359
 360 PROTOTYPES: DISABLE
 361
 362 SV*
 363 new(class, package_name)
 364     char *class
 365     SV *package_name
 366   PREINIT:
 367     HV *instance;
 368     HV *namespace;
 369     SV *nsref;
 370   CODE:
 371     if (!SvPOK(package_name))
 372         croak("The constructor argument must be the name of a package");
 373
 374     instance = newHV();
 375
 376     if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package_name), 0)) {
 377         SvREFCNT_dec(package_name);
 378         SvREFCNT_dec(instance);
 379         croak("Couldn't initialize the 'name' key, hv_store failed");
 380     }
 381     namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
 382     nsref = newRV_inc((SV*)namespace);
 383     if (!hv_store(instance, "namespace", 9, nsref, 0)) {
 384         SvREFCNT_dec(nsref);
 385         SvREFCNT_dec(instance);
 386         croak("Couldn't initialize the 'namespace' key, hv_store failed");
 387     }
 388
 389     RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashpv(class, 0));
 390   OUTPUT:
 391     RETVAL
 392
 393 SV*
 394 name(self)
 395     SV *self
 396   PREINIT:
 397     HE *slot;
 398   CODE:
 399     if (!sv_isobject(self))
 400         croak("Can't call name as a class method");
 401     slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash);
 402     RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef;
 403   OUTPUT:
 404     RETVAL
 405
 406 SV*
 407 namespace(self)
 408     SV *self
 409   PREINIT:
 410     HE *slot;
 411   CODE:
 412     if (!sv_isobject(self))
 413         croak("Can't call namespace as a class method");
 414     slot = hv_fetch_ent((HV*)SvRV(self), namespace_key, 0, namespace_hash);
 415     RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef;
 416   OUTPUT:
 417     RETVAL
 418
 419 void
 420 add_symbol(self, variable, initial=NULL, ...)
 421     SV *self
 422     varspec_t variable
 423     SV *initial
 424   PREINIT:
 425     SV *name;
 426     GV *glob;
 427   CODE:
 428     if (initial && !_valid_for_type(initial, variable.type))
 429         croak("%s is not of type %s",
 430               SvPV_nolen(initial), vartype_to_string(variable.type));
 431
 432     name = newSVsv(_get_name(self));
 433     sv_catpvs(name, "::");
 434     sv_catpv(name, variable.name);
 435
 436     if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
 437         int i;
 438         char *filename = NULL, *namepv;
 439         I32 first_line_num = -1, last_line_num = -1;
 440         STRLEN namelen;
 441         SV *dbval;
 442         HV *dbsub;
 443
 444         if ((items - 3) % 2)
 445             croak("add_symbol: Odd number of elements in %%opts");
 446
 447         for (i = 3; i < items; i += 2) {
 448             char *key;
 449             key = SvPV_nolen(ST(i));
 450             if (strEQ(key, "filename")) {
 451                 if (!SvPOK(ST(i + 1)))
 452                     croak("add_symbol: filename must be a string");
 453                 filename = SvPV_nolen(ST(i + 1));
 454             }
 455             else if (strEQ(key, "first_line_num")) {
 456                 if (!SvIOK(ST(i + 1)))
 457                     croak("add_symbol: first_line_num must be an integer");
 458                 first_line_num = SvIV(ST(i + 1));
 459             }
 460             else if (strEQ(key, "last_line_num")) {
 461                 if (!SvIOK(ST(i + 1)))
 462                     croak("add_symbol: last_line_num must be an integer");
 463                 last_line_num = SvIV(ST(i + 1));
 464             }
 465         }
 466
 467         if (!filename || first_line_num == -1) {
 468             I32 cxix_from, cxix_to;
 469             PERL_CONTEXT *cx, *ccstack;
 470             COP *cop = NULL;
 471
 472             cx = upcontext(0, &cop, &ccstack, &cxix_from, &cxix_to);
 473             if (!cop)
 474                 cop = PL_curcop;
 475
 476             if (!filename)
 477                 filename = CopFILE(cop);
 478             if (first_line_num == -1)
 479                 first_line_num = cop->cop_line;
 480         }
 481
 482         if (last_line_num == -1)
 483             last_line_num = first_line_num;
 484
 485         /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */
 486         dbsub = get_hv("DB::sub", 1);
 487         dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num);
 488         namepv = SvPV(name, namelen);
 489         if (!hv_store(dbsub, namepv, namelen, dbval, 0)) {
 490             warn("Failed to update $DB::sub for subroutine %s", namepv);
 491             SvREFCNT_dec(dbval);
 492         }
 493     }
 494
 495     /* GV_ADDMULTI rather than GV_ADD because otherwise you get 'used only
 496      * once' warnings in some situations... i can't reproduce this, but CMOP
 497      * triggers it */
 498     glob = gv_fetchsv(name, GV_ADDMULTI, vartype_to_svtype(variable.type));
 499
 500     if (initial) {
 501         SV *val;
 502
 503         if (SvROK(initial)) {
 504             val = SvRV(initial);
 505             SvREFCNT_inc_simple_void_NN(val);
 506         }
 507         else {
 508             val = newSVsv(initial);
 509         }
 510
 511         switch (variable.type) {
 512         case VAR_SCALAR:
 513             GvSetSV(glob, val);
 514             break;
 515         case VAR_ARRAY:
 516             GvSetAV(glob, val);
 517             break;
 518         case VAR_HASH:
 519             GvSetHV(glob, val);
 520             break;
 521         case VAR_CODE:
 522             GvSetCV(glob, val);
 523             break;
 524         case VAR_IO:
 525             GvSetIO(glob, val);
 526             break;
 527         }
 528     }
 529
 530     SvREFCNT_dec(name);
 531
 532 void
 533 remove_glob(self, namesv)
 534     SV *self
 535     SV *namesv
 536   PREINIT:
 537     char *name;
 538     STRLEN len;
 539   CODE:
 540     name = SvPV(namesv, len);
 541     hv_delete(_get_namespace(self), name, len, G_DISCARD);
 542
 543 int
 544 has_symbol(self, variable)
 545     SV *self
 546     varspec_t variable
 547   PREINIT:
 548     HV *namespace;
 549     SV **entry;
 550   CODE:
 551     namespace = _get_namespace(self);
 552     entry = hv_fetch(namespace, variable.name, variable.namelen, 0);
 553     if (!entry)
 554         XSRETURN_UNDEF;
 555
 556     if (isGV(*entry)) {
 557         GV *glob = (GV*)(*entry);
 558         switch (variable.type) {
 559         case VAR_SCALAR:
 560             RETVAL = GvSVOK(glob) ? 1 : 0;
 561             break;
 562         case VAR_ARRAY:
 563             RETVAL = GvAVOK(glob) ? 1 : 0;
 564             break;
 565         case VAR_HASH:
 566             RETVAL = GvHVOK(glob) ? 1 : 0;
 567             break;
 568         case VAR_CODE:
 569             RETVAL = GvCVOK(glob) ? 1 : 0;
 570             break;
 571         case VAR_IO:
 572             RETVAL = GvIOOK(glob) ? 1 : 0;
 573             break;
 574         }
 575     }
 576     else {
 577         RETVAL = (variable.type == VAR_CODE);
 578     }
 579   OUTPUT:
 580     RETVAL
 581
 582 SV*
 583 get_symbol(self, variable)
 584     SV *self
 585     varspec_t variable
 586   PREINIT:
 587     SV *val;
 588   CODE:
 589     val = _get_symbol(self, &variable, 0);
 590     if (!val)
 591         XSRETURN_UNDEF;
 592     RETVAL = newRV_inc(val);
 593   OUTPUT:
 594     RETVAL
 595
 596 SV*
 597 get_or_add_symbol(self, variable)
 598     SV *self
 599     varspec_t variable
 600   PREINIT:
 601     SV *val;
 602   CODE:
 603     val = _get_symbol(self, &variable, 1);
 604     if (!val)
 605         XSRETURN_UNDEF;
 606     RETVAL = newRV_inc(val);
 607   OUTPUT:
 608     RETVAL
 609
 610 void
 611 remove_symbol(self, variable)
 612     SV *self
 613     varspec_t variable
 614   PREINIT:
 615     HV *namespace;
 616     SV **entry;
 617   CODE:
 618     namespace = _get_namespace(self);
 619     entry = hv_fetch(namespace, variable.name, variable.namelen, 0);
 620     if (!entry)
 621         XSRETURN_EMPTY;
 622
 623     if (isGV(*entry)) {
 624         GV *glob = (GV*)(*entry);
 625         switch (variable.type) {
 626         case VAR_SCALAR:
 627             GvSetSV(glob, NULL);
 628             break;
 629         case VAR_ARRAY:
 630             GvSetAV(glob, NULL);
 631             break;
 632         case VAR_HASH:
 633             GvSetHV(glob, NULL);
 634             break;
 635         case VAR_CODE:
 636             GvSetCV(glob, NULL);
 637             break;
 638         case VAR_IO:
 639             GvSetIO(glob, NULL);
 640             break;
 641         }
 642     }
 643     else {
 644         if (variable.type == VAR_CODE) {
 645             hv_delete(namespace, variable.name, variable.namelen, G_DISCARD);
 646         }
 647     }
 648
 649 void
 650 list_all_symbols(self, vartype=VAR_NONE)
 651     SV *self
 652     vartype_t vartype
 653   PPCODE:
 654     if (vartype == VAR_NONE) {
 655         HV *namespace;
 656         HE *entry;
 657         int keys;
 658
 659         namespace = _get_namespace(self);
 660         keys = hv_iterinit(namespace);
 661         EXTEND(SP, keys);
 662         while ((entry = hv_iternext(namespace))) {
 663             mPUSHs(newSVhe(entry));
 664         }
 665     }
 666     else {
 667         HV *namespace;
 668         SV *val;
 669         char *key;
 670         I32 len;
 671
 672         namespace = _get_namespace(self);
 673         hv_iterinit(namespace);
 674         while ((val = hv_iternextsv(namespace, &key, &len))) {
 675             GV *gv = (GV*)val;
 676             if (isGV(gv)) {
 677                 switch (vartype) {
 678                 case VAR_SCALAR:
 679                     if (GvSVOK(val))
 680                         mXPUSHp(key, len);
 681                     break;
 682                 case VAR_ARRAY:
 683                     if (GvAVOK(val))
 684                         mXPUSHp(key, len);
 685                     break;
 686                 case VAR_HASH:
 687                     if (GvHVOK(val))
 688                         mXPUSHp(key, len);
 689                     break;
 690                 case VAR_CODE:
 691                     if (GvCVOK(val))
 692                         mXPUSHp(key, len);
 693                     break;
 694                 case VAR_IO:
 695                     if (GvIOOK(val))
 696                         mXPUSHp(key, len);
 697                     break;
 698                 }
 699             }
 700             else if (vartype == VAR_CODE) {
 701                 mXPUSHp(key, len);
 702             }
 703         }
 704     }
 705
 706 BOOT:
 707     {
 708         name_key = newSVpvs("name");
 709         PERL_HASH(name_hash, "name", 4);
 710
 711         namespace_key = newSVpvs("namespace");
 712         PERL_HASH(namespace_hash, "namespace", 9);
 713
 714         type_key = newSVpvs("type");
 715         PERL_HASH(type_hash, "type", 4);
 716     }