XS.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 typedef enum {
  84     VAR_NONE = 0,
  85     VAR_SCALAR,
  86     VAR_ARRAY,
  87     VAR_HASH,
  88     VAR_CODE,
  89     VAR_IO,
  90     VAR_GLOB,  /* TODO: unimplemented */
  91     VAR_FORMAT /* TODO: unimplemented */
  92 } vartype_t;
  93
  94 typedef struct {
  95     vartype_t type;
  96     SV *name;
  97 } varspec_t;
  98
  99 static U32 name_hash, namespace_hash, type_hash;
 100 static SV *name_key, *namespace_key, *type_key;
 101
 102 const char *vartype_to_string(vartype_t type)
 103 {
 104     switch (type) {
 105     case VAR_SCALAR:
 106         return "SCALAR";
 107     case VAR_ARRAY:
 108         return "ARRAY";
 109     case VAR_HASH:
 110         return "HASH";
 111     case VAR_CODE:
 112         return "CODE";
 113     case VAR_IO:
 114         return "IO";
 115     default:
 116         return "unknown";
 117     }
 118 }
 119
 120 I32 vartype_to_svtype(vartype_t type)
 121 {
 122     switch (type) {
 123     case VAR_SCALAR:
 124         return SVt_PV; /* or whatever */
 125     case VAR_ARRAY:
 126         return SVt_PVAV;
 127     case VAR_HASH:
 128         return SVt_PVHV;
 129     case VAR_CODE:
 130         return SVt_PVCV;
 131     case VAR_IO:
 132         return SVt_PVIO;
 133     default:
 134         return SVt_NULL;
 135     }
 136 }
 137
 138 vartype_t string_to_vartype(char *vartype)
 139 {
 140     if (strEQ(vartype, "SCALAR")) {
 141         return VAR_SCALAR;
 142     }
 143     else if (strEQ(vartype, "ARRAY")) {
 144         return VAR_ARRAY;
 145     }
 146     else if (strEQ(vartype, "HASH")) {
 147         return VAR_HASH;
 148     }
 149     else if (strEQ(vartype, "CODE")) {
 150         return VAR_CODE;
 151     }
 152     else if (strEQ(vartype, "IO")) {
 153         return VAR_IO;
 154     }
 155     else {
 156         croak("Type must be one of 'SCALAR', 'ARRAY', 'HASH', 'CODE', or 'IO', not '%s'", vartype);
 157     }
 158 }
 159
 160 void _deconstruct_variable_name(SV *variable, varspec_t *varspec)
 161 {
 162     char *varpv;
 163
 164     if (!SvCUR(variable))
 165         croak("You must pass a variable name");
 166
 167     varspec->name = sv_2mortal(newSVsv(variable));
 168
 169     varpv = SvPV_nolen(varspec->name);
 170     switch (varpv[0]) {
 171     case '$':
 172         varspec->type = VAR_SCALAR;
 173         sv_chop(varspec->name, &varpv[1]);
 174         break;
 175     case '@':
 176         varspec->type = VAR_ARRAY;
 177         sv_chop(varspec->name, &varpv[1]);
 178         break;
 179     case '%':
 180         varspec->type = VAR_HASH;
 181         sv_chop(varspec->name, &varpv[1]);
 182         break;
 183     case '&':
 184         varspec->type = VAR_CODE;
 185         sv_chop(varspec->name, &varpv[1]);
 186         break;
 187     default:
 188         varspec->type = VAR_IO;
 189         break;
 190     }
 191 }
 192
 193 void _deconstruct_variable_hash(HV *variable, varspec_t *varspec)
 194 {
 195     HE *val;
 196
 197     val = hv_fetch_ent(variable, name_key, 0, name_hash);
 198     if (!val)
 199         croak("The 'name' key is required in variable specs");
 200
 201     varspec->name = sv_2mortal(newSVsv(HeVAL(val)));
 202
 203     val = hv_fetch_ent(variable, type_key, 0, type_hash);
 204     if (!val)
 205         croak("The 'type' key is required in variable specs");
 206
 207     varspec->type = string_to_vartype(SvPV_nolen(HeVAL(val)));
 208 }
 209
 210 int _valid_for_type(SV *value, vartype_t type)
 211 {
 212     svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL;
 213
 214     switch (type) {
 215     case VAR_SCALAR:
 216         return SvROK(value) ? SvOK(SvRV(value)) : SvOK(value);
 217     case VAR_ARRAY:
 218         return sv_type == SVt_PVAV;
 219     case VAR_HASH:
 220         return sv_type == SVt_PVHV;
 221     case VAR_CODE:
 222         return sv_type == SVt_PVCV;
 223     case VAR_IO:
 224         return sv_type == SVt_PVIO;
 225     default:
 226         return 0;
 227     }
 228 }
 229
 230 HV *_get_namespace(SV *self)
 231 {
 232     dSP;
 233     SV *ret;
 234
 235     PUSHMARK(SP);
 236     XPUSHs(self);
 237     PUTBACK;
 238
 239     call_method("namespace", G_SCALAR);
 240
 241     SPAGAIN;
 242     ret = POPs;
 243     PUTBACK;
 244
 245     return (HV*)SvRV(ret);
 246 }
 247
 248 SV *_get_name(SV *self)
 249 {
 250     dSP;
 251     SV *ret;
 252
 253     PUSHMARK(SP);
 254     XPUSHs(self);
 255     PUTBACK;
 256
 257     call_method("name", G_SCALAR);
 258
 259     SPAGAIN;
 260     ret = POPs;
 261     PUTBACK;
 262
 263     return ret;
 264 }
 265
 266 void _expand_glob(SV *self, SV *varname)
 267 {
 268     SV *name;
 269
 270     name = newSVsv(_get_name(self));
 271     sv_catpvs(name, "::");
 272     sv_catsv(name, varname);
 273
 274     /* can't use gv_init here, because it screws up @ISA in a way that I
 275      * can't reproduce, but that CMOP triggers */
 276     gv_fetchsv(name, GV_ADD, SVt_NULL);
 277     SvREFCNT_dec(name);
 278 }
 279
 280 SV *_get_symbol(SV *self, varspec_t *variable, int vivify)
 281 {
 282     HV *namespace;
 283     HE *entry;
 284     GV *glob;
 285
 286     namespace = _get_namespace(self);
 287     entry = hv_fetch_ent(namespace, variable->name, vivify, 0);
 288     if (!entry)
 289         return NULL;
 290
 291     glob = (GV*)(HeVAL(entry));
 292     if (!isGV(glob))
 293         _expand_glob(self, variable->name);
 294
 295     if (vivify) {
 296         switch (variable->type) {
 297         case VAR_SCALAR:
 298             if (!GvSVOK(glob))
 299                 GvSetSV(glob, newSV(0));
 300             break;
 301         case VAR_ARRAY:
 302             if (!GvAVOK(glob))
 303                 GvSetAV(glob, newAV());
 304             break;
 305         case VAR_HASH:
 306             if (!GvHVOK(glob))
 307                 GvSetHV(glob, newHV());
 308             break;
 309         case VAR_CODE:
 310             croak("Don't know how to vivify CODE variables");
 311         case VAR_IO:
 312             if (!GvIOOK(glob))
 313                 GvSetIO(glob, newIO());
 314             break;
 315         default:
 316             croak("Unknown type in vivication");
 317         }
 318     }
 319
 320     switch (variable->type) {
 321     case VAR_SCALAR:
 322         return GvSV(glob);
 323     case VAR_ARRAY:
 324         return (SV*)GvAV(glob);
 325     case VAR_HASH:
 326         return (SV*)GvHV(glob);
 327     case VAR_CODE:
 328         return (SV*)GvCV(glob);
 329     case VAR_IO:
 330         return (SV*)GvIO(glob);
 331     default:
 332         return NULL;
 333     }
 334 }
 335
 336 MODULE = Package::Stash::XS  PACKAGE = Package::Stash::XS
 337
 338 PROTOTYPES: DISABLE
 339
 340 SV*
 341 new(class, package_name)
 342     SV *class
 343     SV *package_name
 344   PREINIT:
 345     HV *instance;
 346     HV *namespace;
 347     SV *nsref;
 348   CODE:
 349     if (!SvPOK(package_name))
 350         croak("The constructor argument must be the name of a package");
 351
 352     instance = newHV();
 353
 354     if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package_name), 0)) {
 355         SvREFCNT_dec(package_name);
 356         SvREFCNT_dec(instance);
 357         croak("Couldn't initialize the 'name' key, hv_store failed");
 358     }
 359     namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
 360     nsref = newRV_inc((SV*)namespace);
 361     if (!hv_store(instance, "namespace", 9, nsref, 0)) {
 362         SvREFCNT_dec(nsref);
 363         SvREFCNT_dec(instance);
 364         croak("Couldn't initialize the 'namespace' key, hv_store failed");
 365     }
 366
 367     RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashsv(class, 0));
 368   OUTPUT:
 369     RETVAL
 370
 371 SV*
 372 name(self)
 373     SV *self
 374   PREINIT:
 375     HE *slot;
 376   CODE:
 377     if (!sv_isobject(self))
 378         croak("Can't call name as a class method");
 379     slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash);
 380     RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef;
 381   OUTPUT:
 382     RETVAL
 383
 384 SV*
 385 namespace(self)
 386     SV *self
 387   PREINIT:
 388     HE *slot;
 389   CODE:
 390     if (!sv_isobject(self))
 391         croak("Can't call namespace as a class method");
 392     slot = hv_fetch_ent((HV*)SvRV(self), namespace_key, 0, namespace_hash);
 393     RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef;
 394   OUTPUT:
 395     RETVAL
 396
 397 void
 398 add_symbol(self, variable, initial=NULL, ...)
 399     SV *self
 400     varspec_t variable
 401     SV *initial
 402   PREINIT:
 403     SV *name;
 404     GV *glob;
 405   CODE:
 406     if (initial && !_valid_for_type(initial, variable.type))
 407         croak("%s is not of type %s",
 408               SvPV_nolen(initial), vartype_to_string(variable.type));
 409
 410     name = newSVsv(_get_name(self));
 411     sv_catpvs(name, "::");
 412     sv_catsv(name, variable.name);
 413
 414     if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
 415         int i;
 416         char *filename = NULL;
 417         I32 first_line_num = -1, last_line_num = -1;
 418         STRLEN namelen;
 419         SV *dbval;
 420         HV *dbsub;
 421
 422         if ((items - 3) % 2)
 423             croak("add_symbol: Odd number of elements in %%opts");
 424
 425         for (i = 3; i < items; i += 2) {
 426             char *key;
 427             key = SvPV_nolen(ST(i));
 428             if (strEQ(key, "filename")) {
 429                 if (!SvPOK(ST(i + 1)))
 430                     croak("add_symbol: filename must be a string");
 431                 filename = SvPV_nolen(ST(i + 1));
 432             }
 433             else if (strEQ(key, "first_line_num")) {
 434                 if (!SvIOK(ST(i + 1)))
 435                     croak("add_symbol: first_line_num must be an integer");
 436                 first_line_num = SvIV(ST(i + 1));
 437             }
 438             else if (strEQ(key, "last_line_num")) {
 439                 if (!SvIOK(ST(i + 1)))
 440                     croak("add_symbol: last_line_num must be an integer");
 441                 last_line_num = SvIV(ST(i + 1));
 442             }
 443         }
 444
 445         if (!filename || first_line_num == -1) {
 446             if (!filename)
 447                 filename = CopFILE(PL_curcop);
 448             if (first_line_num == -1)
 449                 first_line_num = PL_curcop->cop_line;
 450         }
 451
 452         if (last_line_num == -1)
 453             last_line_num = first_line_num;
 454
 455         /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */
 456         dbsub = get_hv("DB::sub", 1);
 457         dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num);
 458         if (!hv_store_ent(dbsub, name, dbval, 0)) {
 459             warn("Failed to update $DB::sub for subroutine %s",
 460                  SvPV_nolen(name));
 461             SvREFCNT_dec(dbval);
 462         }
 463     }
 464
 465     /* GV_ADDMULTI rather than GV_ADD because otherwise you get 'used only
 466      * once' warnings in some situations... i can't reproduce this, but CMOP
 467      * triggers it */
 468     glob = gv_fetchsv(name, GV_ADDMULTI, vartype_to_svtype(variable.type));
 469
 470     if (initial) {
 471         SV *val;
 472
 473         if (SvROK(initial)) {
 474             val = SvRV(initial);
 475             SvREFCNT_inc_simple_void_NN(val);
 476         }
 477         else {
 478             val = newSVsv(initial);
 479         }
 480
 481         switch (variable.type) {
 482         case VAR_SCALAR:
 483             GvSetSV(glob, val);
 484             break;
 485         case VAR_ARRAY:
 486             GvSetAV(glob, val);
 487             break;
 488         case VAR_HASH:
 489             GvSetHV(glob, val);
 490             break;
 491         case VAR_CODE:
 492             GvSetCV(glob, val);
 493             break;
 494         case VAR_IO:
 495             GvSetIO(glob, val);
 496             break;
 497         }
 498     }
 499
 500     SvREFCNT_dec(name);
 501
 502 void
 503 remove_glob(self, name)
 504     SV *self
 505     SV *name
 506   CODE:
 507     hv_delete_ent(_get_namespace(self), name, G_DISCARD, 0);
 508
 509 int
 510 has_symbol(self, variable)
 511     SV *self
 512     varspec_t variable
 513   PREINIT:
 514     HV *namespace;
 515     HE *entry;
 516     SV *val;
 517   CODE:
 518     namespace = _get_namespace(self);
 519     entry = hv_fetch_ent(namespace, variable.name, 0, 0);
 520     if (!entry)
 521         XSRETURN_UNDEF;
 522
 523     val = HeVAL(entry);
 524     if (isGV(val)) {
 525         GV *glob = (GV*)val;
 526         switch (variable.type) {
 527         case VAR_SCALAR:
 528             RETVAL = GvSVOK(glob) ? 1 : 0;
 529             break;
 530         case VAR_ARRAY:
 531             RETVAL = GvAVOK(glob) ? 1 : 0;
 532             break;
 533         case VAR_HASH:
 534             RETVAL = GvHVOK(glob) ? 1 : 0;
 535             break;
 536         case VAR_CODE:
 537             RETVAL = GvCVOK(glob) ? 1 : 0;
 538             break;
 539         case VAR_IO:
 540             RETVAL = GvIOOK(glob) ? 1 : 0;
 541             break;
 542         }
 543     }
 544     else {
 545         RETVAL = (variable.type == VAR_CODE);
 546     }
 547   OUTPUT:
 548     RETVAL
 549
 550 SV*
 551 get_symbol(self, variable)
 552     SV *self
 553     varspec_t variable
 554   PREINIT:
 555     SV *val;
 556   CODE:
 557     val = _get_symbol(self, &variable, 0);
 558     if (!val)
 559         XSRETURN_UNDEF;
 560     RETVAL = newRV_inc(val);
 561   OUTPUT:
 562     RETVAL
 563
 564 SV*
 565 get_or_add_symbol(self, variable)
 566     SV *self
 567     varspec_t variable
 568   PREINIT:
 569     SV *val;
 570   CODE:
 571     val = _get_symbol(self, &variable, 1);
 572     if (!val)
 573         XSRETURN_UNDEF;
 574     RETVAL = newRV_inc(val);
 575   OUTPUT:
 576     RETVAL
 577
 578 void
 579 remove_symbol(self, variable)
 580     SV *self
 581     varspec_t variable
 582   PREINIT:
 583     HV *namespace;
 584     HE *entry;
 585     SV *val;
 586   CODE:
 587     namespace = _get_namespace(self);
 588     entry = hv_fetch_ent(namespace, variable.name, 0, 0);
 589     if (!entry)
 590         XSRETURN_EMPTY;
 591
 592     val = HeVAL(entry);
 593     if (isGV(val)) {
 594         GV *glob = (GV*)val;
 595         switch (variable.type) {
 596         case VAR_SCALAR:
 597             GvSetSV(glob, NULL);
 598             break;
 599         case VAR_ARRAY:
 600             GvSetAV(glob, NULL);
 601             break;
 602         case VAR_HASH:
 603             GvSetHV(glob, NULL);
 604             break;
 605         case VAR_CODE:
 606             GvSetCV(glob, NULL);
 607             break;
 608         case VAR_IO:
 609             GvSetIO(glob, NULL);
 610             break;
 611         }
 612     }
 613     else {
 614         if (variable.type == VAR_CODE) {
 615             hv_delete_ent(namespace, variable.name, G_DISCARD, 0);
 616         }
 617     }
 618
 619 void
 620 list_all_symbols(self, vartype=VAR_NONE)
 621     SV *self
 622     vartype_t vartype
 623   PPCODE:
 624     if (vartype == VAR_NONE) {
 625         HV *namespace;
 626         HE *entry;
 627         int keys;
 628
 629         namespace = _get_namespace(self);
 630         keys = hv_iterinit(namespace);
 631         EXTEND(SP, keys);
 632         while ((entry = hv_iternext(namespace))) {
 633             mPUSHs(newSVhe(entry));
 634         }
 635     }
 636     else {
 637         HV *namespace;
 638         SV *val;
 639         char *key;
 640         I32 len;
 641
 642         namespace = _get_namespace(self);
 643         hv_iterinit(namespace);
 644         while ((val = hv_iternextsv(namespace, &key, &len))) {
 645             GV *gv = (GV*)val;
 646             if (isGV(gv)) {
 647                 switch (vartype) {
 648                 case VAR_SCALAR:
 649                     if (GvSVOK(val))
 650                         mXPUSHp(key, len);
 651                     break;
 652                 case VAR_ARRAY:
 653                     if (GvAVOK(val))
 654                         mXPUSHp(key, len);
 655                     break;
 656                 case VAR_HASH:
 657                     if (GvHVOK(val))
 658                         mXPUSHp(key, len);
 659                     break;
 660                 case VAR_CODE:
 661                     if (GvCVOK(val))
 662                         mXPUSHp(key, len);
 663                     break;
 664                 case VAR_IO:
 665                     if (GvIOOK(val))
 666                         mXPUSHp(key, len);
 667                     break;
 668                 }
 669             }
 670             else if (vartype == VAR_CODE) {
 671                 mXPUSHp(key, len);
 672             }
 673         }
 674     }
 675
 676 void
 677 get_all_symbols(self, vartype=VAR_NONE)
 678     SV *self
 679     vartype_t vartype
 680   PREINIT:
 681     HV *namespace, *ret;
 682     SV *val;
 683     char *key;
 684     I32 len;
 685   PPCODE:
 686     namespace = _get_namespace(self);
 687     ret = newHV();
 688
 689     hv_iterinit(namespace);
 690     while ((val = hv_iternextsv(namespace, &key, &len))) {
 691         GV *gv = (GV*)val;
 692
 693         if (!isGV(gv)) {
 694             SV *keysv = newSVpvn(key, len);
 695             _expand_glob(self, keysv);
 696             SvREFCNT_dec(keysv);
 697         }
 698
 699         switch (vartype) {
 700         case VAR_SCALAR:
 701             if (GvSVOK(val))
 702                 hv_store(ret, key, len, newRV_inc(GvSV(gv)), 0);
 703             break;
 704         case VAR_ARRAY:
 705             if (GvAVOK(val))
 706                 hv_store(ret, key, len, newRV_inc((SV*)GvAV(gv)), 0);
 707             break;
 708         case VAR_HASH:
 709             if (GvHVOK(val))
 710                 hv_store(ret, key, len, newRV_inc((SV*)GvHV(gv)), 0);
 711             break;
 712         case VAR_CODE:
 713             if (GvCVOK(val))
 714                 hv_store(ret, key, len, newRV_inc((SV*)GvCV(gv)), 0);
 715             break;
 716         case VAR_IO:
 717             if (GvIOOK(val))
 718                 hv_store(ret, key, len, newRV_inc((SV*)GvIO(gv)), 0);
 719             break;
 720         case VAR_NONE:
 721             hv_store(ret, key, len, SvREFCNT_inc_simple_NN(val), 0);
 722             break;
 723         }
 724     }
 725
 726     mPUSHs(newRV_noinc((SV*)ret));
 727
 728 BOOT:
 729     {
 730         name_key = newSVpvs("name");
 731         PERL_HASH(name_hash, "name", 4);
 732
 733         namespace_key = newSVpvs("namespace");
 734         PERL_HASH(namespace_hash, "namespace", 9);
 735
 736         type_key = newSVpvs("type");
 737         PERL_HASH(type_hash, "type", 4);
 738     }