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 SV *_get_symbol(SV *self, varspec_t *variable, int vivify)
 289 {
 290     HV *namespace;
 291     SV **entry;
 292     GV *glob;
 293
 294     namespace = _get_namespace(self);
 295     entry = hv_fetch(namespace, variable->name, variable->namelen, vivify);
 296     if (!entry)
 297         return NULL;
 298
 299     glob = (GV*)(*entry);
 300     if (!isGV(glob)) {
 301         SV *namesv;
 302
 303         namesv = newSVsv(_get_name(self));
 304         sv_catpvs(namesv, "::");
 305         sv_catpv(namesv, variable->name);
 306
 307         /* can't use gv_init here, because it screws up @ISA in a way that I
 308          * can't reproduce, but that CMOP triggers */
 309         gv_fetchsv(namesv, GV_ADD, vartype_to_svtype(variable->type));
 310         SvREFCNT_dec(namesv);
 311     }
 312
 313     if (vivify) {
 314         switch (variable->type) {
 315         case VAR_SCALAR:
 316             if (!GvSVOK(glob))
 317                 GvSetSV(glob, newSV(0));
 318             break;
 319         case VAR_ARRAY:
 320             if (!GvAVOK(glob))
 321                 GvSetAV(glob, newAV());
 322             break;
 323         case VAR_HASH:
 324             if (!GvHVOK(glob))
 325                 GvSetHV(glob, newHV());
 326             break;
 327         case VAR_CODE:
 328             croak("Don't know how to vivify CODE variables");
 329         case VAR_IO:
 330             if (!GvIOOK(glob))
 331                 GvSetIO(glob, newIO());
 332             break;
 333         default:
 334             croak("Unknown type in vivication");
 335         }
 336     }
 337
 338     switch (variable->type) {
 339     case VAR_SCALAR:
 340         return GvSV(glob);
 341     case VAR_ARRAY:
 342         return (SV*)GvAV(glob);
 343     case VAR_HASH:
 344         return (SV*)GvHV(glob);
 345     case VAR_CODE:
 346         return (SV*)GvCV(glob);
 347     case VAR_IO:
 348         return (SV*)GvIO(glob);
 349     default:
 350         return NULL;
 351     }
 352 }
 353
 354 MODULE = Package::Stash  PACKAGE = Package::Stash
 355
 356 PROTOTYPES: DISABLE
 357
 358 SV*
 359 new(class, package_name)
 360     char *class
 361     SV *package_name
 362   PREINIT:
 363     HV *instance;
 364     HV *namespace;
 365     SV *nsref;
 366   CODE:
 367     if (!SvPOK(package_name))
 368         croak("The constructor argument must be the name of a package");
 369
 370     instance = newHV();
 371
 372     if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package_name), 0)) {
 373         SvREFCNT_dec(package_name);
 374         SvREFCNT_dec(instance);
 375         croak("Couldn't initialize the 'name' key, hv_store failed");
 376     }
 377     namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
 378     nsref = newRV_inc((SV*)namespace);
 379     if (!hv_store(instance, "namespace", 9, nsref, 0)) {
 380         SvREFCNT_dec(nsref);
 381         SvREFCNT_dec(instance);
 382         croak("Couldn't initialize the 'namespace' key, hv_store failed");
 383     }
 384
 385     RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashpv(class, 0));
 386   OUTPUT:
 387     RETVAL
 388
 389 SV*
 390 name(self)
 391     SV *self
 392   PREINIT:
 393     HE *slot;
 394   CODE:
 395     if (!sv_isobject(self))
 396         croak("Can't call name as a class method");
 397     slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash);
 398     RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef;
 399   OUTPUT:
 400     RETVAL
 401
 402 SV*
 403 namespace(self)
 404     SV *self
 405   PREINIT:
 406     HE *slot;
 407   CODE:
 408     if (!sv_isobject(self))
 409         croak("Can't call namespace as a class method");
 410     slot = hv_fetch_ent((HV*)SvRV(self), namespace_key, 0, namespace_hash);
 411     RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef;
 412   OUTPUT:
 413     RETVAL
 414
 415 void
 416 add_symbol(self, variable, initial=NULL, ...)
 417     SV *self
 418     varspec_t variable
 419     SV *initial
 420   PREINIT:
 421     SV *name;
 422     GV *glob;
 423   CODE:
 424     if (initial && !_valid_for_type(initial, variable.type))
 425         croak("%s is not of type %s",
 426               SvPV_nolen(initial), vartype_to_string(variable.type));
 427
 428     name = newSVsv(_get_name(self));
 429     sv_catpvs(name, "::");
 430     sv_catpv(name, variable.name);
 431
 432     if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
 433         int i;
 434         char *filename = NULL, *namepv;
 435         I32 first_line_num = -1, last_line_num = -1;
 436         STRLEN namelen;
 437         SV *dbval;
 438         HV *dbsub;
 439
 440         if ((items - 3) % 2)
 441             croak("add_symbol: Odd number of elements in %%opts");
 442
 443         for (i = 3; i < items; i += 2) {
 444             char *key;
 445             key = SvPV_nolen(ST(i));
 446             if (strEQ(key, "filename")) {
 447                 if (!SvPOK(ST(i + 1)))
 448                     croak("add_symbol: filename must be a string");
 449                 filename = SvPV_nolen(ST(i + 1));
 450             }
 451             else if (strEQ(key, "first_line_num")) {
 452                 if (!SvIOK(ST(i + 1)))
 453                     croak("add_symbol: first_line_num must be an integer");
 454                 first_line_num = SvIV(ST(i + 1));
 455             }
 456             else if (strEQ(key, "last_line_num")) {
 457                 if (!SvIOK(ST(i + 1)))
 458                     croak("add_symbol: last_line_num must be an integer");
 459                 last_line_num = SvIV(ST(i + 1));
 460             }
 461         }
 462
 463         if (!filename || first_line_num == -1) {
 464             I32 cxix_from, cxix_to;
 465             PERL_CONTEXT *cx, *ccstack;
 466             COP *cop = NULL;
 467
 468             cx = upcontext(0, &cop, &ccstack, &cxix_from, &cxix_to);
 469             if (!cop)
 470                 cop = PL_curcop;
 471
 472             if (!filename)
 473                 filename = CopFILE(cop);
 474             if (first_line_num == -1)
 475                 first_line_num = cop->cop_line;
 476         }
 477
 478         if (last_line_num == -1)
 479             last_line_num = first_line_num;
 480
 481         /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */
 482         dbsub = get_hv("DB::sub", 1);
 483         dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num);
 484         namepv = SvPV(name, namelen);
 485         if (!hv_store(dbsub, namepv, namelen, dbval, 0)) {
 486             warn("Failed to update $DB::sub for subroutine %s", namepv);
 487             SvREFCNT_dec(dbval);
 488         }
 489     }
 490
 491     /* GV_ADDMULTI rather than GV_ADD because otherwise you get 'used only
 492      * once' warnings in some situations... i can't reproduce this, but CMOP
 493      * triggers it */
 494     glob = gv_fetchsv(name, GV_ADDMULTI, vartype_to_svtype(variable.type));
 495
 496     if (initial) {
 497         SV *val;
 498
 499         if (SvROK(initial)) {
 500             val = SvRV(initial);
 501             SvREFCNT_inc_simple_void_NN(val);
 502         }
 503         else {
 504             val = newSVsv(initial);
 505         }
 506
 507         switch (variable.type) {
 508         case VAR_SCALAR:
 509             GvSetSV(glob, val);
 510             break;
 511         case VAR_ARRAY:
 512             GvSetAV(glob, val);
 513             break;
 514         case VAR_HASH:
 515             GvSetHV(glob, val);
 516             break;
 517         case VAR_CODE:
 518             GvSetCV(glob, val);
 519             break;
 520         case VAR_IO:
 521             GvSetIO(glob, val);
 522             break;
 523         }
 524     }
 525
 526     SvREFCNT_dec(name);
 527
 528 void
 529 remove_glob(self, namesv)
 530     SV *self
 531     SV *namesv
 532   PREINIT:
 533     char *name;
 534     STRLEN len;
 535   CODE:
 536     name = SvPV(namesv, len);
 537     hv_delete(_get_namespace(self), name, len, G_DISCARD);
 538
 539 int
 540 has_symbol(self, variable)
 541     SV *self
 542     varspec_t variable
 543   PREINIT:
 544     HV *namespace;
 545     SV **entry;
 546   CODE:
 547     namespace = _get_namespace(self);
 548     entry = hv_fetch(namespace, variable.name, variable.namelen, 0);
 549     if (!entry)
 550         XSRETURN_UNDEF;
 551
 552     if (isGV(*entry)) {
 553         GV *glob = (GV*)(*entry);
 554         switch (variable.type) {
 555         case VAR_SCALAR:
 556             RETVAL = GvSVOK(glob) ? 1 : 0;
 557             break;
 558         case VAR_ARRAY:
 559             RETVAL = GvAVOK(glob) ? 1 : 0;
 560             break;
 561         case VAR_HASH:
 562             RETVAL = GvHVOK(glob) ? 1 : 0;
 563             break;
 564         case VAR_CODE:
 565             RETVAL = GvCVOK(glob) ? 1 : 0;
 566             break;
 567         case VAR_IO:
 568             RETVAL = GvIOOK(glob) ? 1 : 0;
 569             break;
 570         }
 571     }
 572     else {
 573         RETVAL = (variable.type == VAR_CODE);
 574     }
 575   OUTPUT:
 576     RETVAL
 577
 578 SV*
 579 get_symbol(self, variable)
 580     SV *self
 581     varspec_t variable
 582   PREINIT:
 583     SV *val;
 584   CODE:
 585     val = _get_symbol(self, &variable, 0);
 586     if (!val)
 587         XSRETURN_UNDEF;
 588     RETVAL = newRV_inc(val);
 589   OUTPUT:
 590     RETVAL
 591
 592 SV*
 593 get_or_add_symbol(self, variable)
 594     SV *self
 595     varspec_t variable
 596   PREINIT:
 597     SV *val;
 598   CODE:
 599     val = _get_symbol(self, &variable, 1);
 600     if (!val)
 601         XSRETURN_UNDEF;
 602     RETVAL = newRV_inc(val);
 603   OUTPUT:
 604     RETVAL
 605
 606 void
 607 remove_symbol(self, variable)
 608     SV *self
 609     varspec_t variable
 610   PREINIT:
 611     HV *namespace;
 612     SV **entry;
 613   CODE:
 614     namespace = _get_namespace(self);
 615     entry = hv_fetch(namespace, variable.name, variable.namelen, 0);
 616     if (!entry)
 617         XSRETURN_EMPTY;
 618
 619     if (isGV(*entry)) {
 620         GV *glob = (GV*)(*entry);
 621         switch (variable.type) {
 622         case VAR_SCALAR:
 623             GvSetSV(glob, NULL);
 624             break;
 625         case VAR_ARRAY:
 626             GvSetAV(glob, NULL);
 627             break;
 628         case VAR_HASH:
 629             GvSetHV(glob, NULL);
 630             break;
 631         case VAR_CODE:
 632             GvSetCV(glob, NULL);
 633             break;
 634         case VAR_IO:
 635             GvSetIO(glob, NULL);
 636             break;
 637         }
 638     }
 639     else {
 640         if (variable.type == VAR_CODE) {
 641             hv_delete(namespace, variable.name, variable.namelen, G_DISCARD);
 642         }
 643     }
 644
 645 void
 646 list_all_symbols(self, vartype=VAR_NONE)
 647     SV *self
 648     vartype_t vartype
 649   PPCODE:
 650     if (vartype == VAR_NONE) {
 651         HV *namespace;
 652         HE *entry;
 653         int keys;
 654
 655         namespace = _get_namespace(self);
 656         keys = hv_iterinit(namespace);
 657         EXTEND(SP, keys);
 658         while ((entry = hv_iternext(namespace))) {
 659             mPUSHs(newSVhe(entry));
 660         }
 661     }
 662     else {
 663         HV *namespace;
 664         SV *val;
 665         char *key;
 666         I32 len;
 667
 668         namespace = _get_namespace(self);
 669         hv_iterinit(namespace);
 670         while ((val = hv_iternextsv(namespace, &key, &len))) {
 671             GV *gv = (GV*)val;
 672             if (isGV(gv)) {
 673                 switch (vartype) {
 674                 case VAR_SCALAR:
 675                     if (GvSVOK(val))
 676                         mXPUSHp(key, len);
 677                     break;
 678                 case VAR_ARRAY:
 679                     if (GvAVOK(val))
 680                         mXPUSHp(key, len);
 681                     break;
 682                 case VAR_HASH:
 683                     if (GvHVOK(val))
 684                         mXPUSHp(key, len);
 685                     break;
 686                 case VAR_CODE:
 687                     if (GvCVOK(val))
 688                         mXPUSHp(key, len);
 689                     break;
 690                 case VAR_IO:
 691                     if (GvIOOK(val))
 692                         mXPUSHp(key, len);
 693                     break;
 694                 }
 695             }
 696             else if (vartype == VAR_CODE) {
 697                 mXPUSHp(key, len);
 698             }
 699         }
 700     }
 701
 702 BOOT:
 703     {
 704         name_key = newSVpvs("name");
 705         PERL_HASH(name_hash, "name", 4);
 706
 707         namespace_key = newSVpvs("namespace");
 708         PERL_HASH(namespace_hash, "namespace", 9);
 709
 710         type_key = newSVpvs("type");
 711         PERL_HASH(type_hash, "type", 4);
 712     }