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 #ifndef GvCV_set
  28 #define GvCV_set(gv, cv) (GvCV(gv) = (CV*)(cv))
  29 #endif
  30
  31 #ifndef SVT_SCALAR
  32 #define SVT_SCALAR(svt) (svt <= SVt_PVLV)
  33 #endif
  34
  35 #ifndef SVT_ARRAY
  36 #define SVT_ARRAY(svt) (svt == SVt_PVAV)
  37 #endif
  38
  39 #ifndef SVT_HASH
  40 #define SVT_HASH(svt) (svt == SVt_PVHV)
  41 #endif
  42
  43 #ifndef SVT_CODE
  44 #define SVT_CODE(svt) (svt == SVt_PVCV)
  45 #endif
  46
  47 #ifndef SVT_IO
  48 #define SVT_IO(svt) (svt == SVt_PVIO)
  49 #endif
  50
  51 #ifndef SVT_FORMAT
  52 #define SVT_FORMAT(svt) (svt == SVt_PVFM)
  53 #endif
  54
  55 /* HACK: scalar slots are always populated on perl < 5.10, so treat undef
  56  * as nonexistent. this is consistent with the previous behavior of the pure
  57  * perl version of this module (since this is the behavior that perl sees
  58  * in all versions */
  59 #if PERL_VERSION < 10
  60 #define GvSVOK(g) (GvSV(g) && SvTYPE(GvSV(g)) != SVt_NULL)
  61 #else
  62 #define GvSVOK(g) GvSV(g)
  63 #endif
  64
  65 #define GvAVOK(g) GvAV(g)
  66 #define GvHVOK(g) GvHV(g)
  67 #define GvCVOK(g) GvCVu(g) /* XXX: should this really be GvCVu? or GvCV? */
  68 #define GvIOOK(g) GvIO(g)
  69
  70 /* see above - don't let scalar slots become unpopulated, this breaks
  71  * assumptions in core */
  72 #if PERL_VERSION < 10
  73 #define GvSetSV(g,v) do {               \
  74     SV *_v = (SV*)(v);                  \
  75     SvREFCNT_dec(GvSV(g));              \
  76     if ((GvSV(g) = _v ? _v : newSV(0))) \
  77         GvIMPORTED_SV_on(g);            \
  78 } while (0)
  79 #else
  80 #define GvSetSV(g,v) do {               \
  81     SvREFCNT_dec(GvSV(g));              \
  82     if ((GvSV(g) = (SV*)(v)))           \
  83         GvIMPORTED_SV_on(g);            \
  84 } while (0)
  85 #endif
  86
  87 #define GvSetAV(g,v) do {               \
  88     SvREFCNT_dec(GvAV(g));              \
  89     if ((GvAV(g) = (AV*)(v)))           \
  90         GvIMPORTED_AV_on(g);            \
  91 } while (0)
  92 #define GvSetHV(g,v) do {               \
  93     SvREFCNT_dec(GvHV(g));              \
  94     if ((GvHV(g) = (HV*)(v)))           \
  95         GvIMPORTED_HV_on(g);            \
  96 } while (0)
  97 #define GvSetCV(g,v) do {               \
  98     SvREFCNT_dec(GvCV(g));              \
  99     if ((GvCV_set(g, (CV*)(v)))) {      \
 100         GvIMPORTED_CV_on(g);            \
 101         GvASSUMECV_on(g);               \
 102     }                                   \
 103     GvCVGEN(g) = 0;                     \
 104     if (HvENAME_get(GvSTASH(g)))        \
 105         mro_method_changed_in(GvSTASH(g)); \
 106 } while (0)
 107 #define GvSetIO(g,v) do {               \
 108     SvREFCNT_dec(GvIO(g));              \
 109     GvIOp(g) = (IO*)(v);                \
 110 } while (0)
 111
 112 typedef enum {
 113     VAR_NONE = 0,
 114     VAR_SCALAR,
 115     VAR_ARRAY,
 116     VAR_HASH,
 117     VAR_CODE,
 118     VAR_IO,
 119     VAR_GLOB,  /* TODO: unimplemented */
 120     VAR_FORMAT /* TODO: unimplemented */
 121 } vartype_t;
 122
 123 typedef struct {
 124     vartype_t type;
 125     SV *name;
 126 } varspec_t;
 127
 128 static U32 name_hash, namespace_hash, type_hash;
 129 static SV *name_key, *namespace_key, *type_key;
 130 static REGEXP *valid_module_regex;
 131
 132 static const char *vartype_to_string(vartype_t type)
 133 {
 134     switch (type) {
 135     case VAR_SCALAR:
 136         return "SCALAR";
 137     case VAR_ARRAY:
 138         return "ARRAY";
 139     case VAR_HASH:
 140         return "HASH";
 141     case VAR_CODE:
 142         return "CODE";
 143     case VAR_IO:
 144         return "IO";
 145     default:
 146         return "unknown";
 147     }
 148 }
 149
 150 static I32 vartype_to_svtype(vartype_t type)
 151 {
 152     switch (type) {
 153     case VAR_SCALAR:
 154         return SVt_PV; /* or whatever */
 155     case VAR_ARRAY:
 156         return SVt_PVAV;
 157     case VAR_HASH:
 158         return SVt_PVHV;
 159     case VAR_CODE:
 160         return SVt_PVCV;
 161     case VAR_IO:
 162         return SVt_PVIO;
 163     default:
 164         return SVt_NULL;
 165     }
 166 }
 167
 168 static vartype_t string_to_vartype(char *vartype)
 169 {
 170     if (strEQ(vartype, "SCALAR")) {
 171         return VAR_SCALAR;
 172     }
 173     else if (strEQ(vartype, "ARRAY")) {
 174         return VAR_ARRAY;
 175     }
 176     else if (strEQ(vartype, "HASH")) {
 177         return VAR_HASH;
 178     }
 179     else if (strEQ(vartype, "CODE")) {
 180         return VAR_CODE;
 181     }
 182     else if (strEQ(vartype, "IO")) {
 183         return VAR_IO;
 184     }
 185     else {
 186         croak("Type must be one of 'SCALAR', 'ARRAY', 'HASH', 'CODE', or 'IO', not '%s'", vartype);
 187     }
 188 }
 189
 190 static int _is_valid_module_name(SV *package)
 191 {
 192     char *buf;
 193     STRLEN len;
 194     SV *sv;
 195
 196     buf = SvPV(package, len);
 197
 198     /* whee cargo cult */
 199     sv = sv_newmortal();
 200     sv_upgrade(sv, SVt_PV);
 201     SvREADONLY_on(sv);
 202     SvLEN(sv) = 0;
 203     SvUTF8_on(sv);
 204     SvPVX(sv) = buf;
 205     SvCUR_set(sv, len);
 206     SvPOK_on(sv);
 207
 208     return pregexec(valid_module_regex, buf, buf + len, buf, 1, sv, 1);
 209 }
 210
 211 static void _deconstruct_variable_name(SV *variable, varspec_t *varspec)
 212 {
 213     char *varpv;
 214
 215     if (!SvCUR(variable))
 216         croak("You must pass a variable name");
 217
 218     varspec->name = sv_2mortal(newSVsv(variable));
 219
 220     varpv = SvPV_nolen(varspec->name);
 221     switch (varpv[0]) {
 222     case '$':
 223         varspec->type = VAR_SCALAR;
 224         sv_chop(varspec->name, &varpv[1]);
 225         break;
 226     case '@':
 227         varspec->type = VAR_ARRAY;
 228         sv_chop(varspec->name, &varpv[1]);
 229         break;
 230     case '%':
 231         varspec->type = VAR_HASH;
 232         sv_chop(varspec->name, &varpv[1]);
 233         break;
 234     case '&':
 235         varspec->type = VAR_CODE;
 236         sv_chop(varspec->name, &varpv[1]);
 237         break;
 238     default:
 239         varspec->type = VAR_IO;
 240         break;
 241     }
 242 }
 243
 244 static void _deconstruct_variable_hash(HV *variable, varspec_t *varspec)
 245 {
 246     HE *val;
 247
 248     val = hv_fetch_ent(variable, name_key, 0, name_hash);
 249     if (!val)
 250         croak("The 'name' key is required in variable specs");
 251
 252     varspec->name = sv_2mortal(newSVsv(HeVAL(val)));
 253
 254     val = hv_fetch_ent(variable, type_key, 0, type_hash);
 255     if (!val)
 256         croak("The 'type' key is required in variable specs");
 257
 258     varspec->type = string_to_vartype(SvPV_nolen(HeVAL(val)));
 259 }
 260
 261 static void _check_varspec_is_valid(varspec_t *varspec)
 262 {
 263     if (strstr(SvPV_nolen(varspec->name), "::")) {
 264         croak("Variable names may not contain ::");
 265     }
 266 }
 267
 268 static int _valid_for_type(SV *value, vartype_t type)
 269 {
 270     svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL;
 271
 272     switch (type) {
 273     case VAR_SCALAR:
 274         /* XXX is a glob a scalar? assigning a glob to the scalar slot seems
 275          * to work here, but in pure perl i'm pretty sure it goes to the EGV
 276          * slot, which seems more correct to me. just disable it for now
 277          * i guess */
 278         return SVT_SCALAR(sv_type) && sv_type != SVt_PVGV;
 279     case VAR_ARRAY:
 280         return SVT_ARRAY(sv_type);
 281     case VAR_HASH:
 282         return SVT_HASH(sv_type);
 283     case VAR_CODE:
 284         return SVT_CODE(sv_type);
 285     case VAR_IO:
 286         return SVT_IO(sv_type);
 287     default:
 288         return 0;
 289     }
 290 }
 291
 292 static HV *_get_namespace(SV *self)
 293 {
 294     dSP;
 295     SV *ret;
 296
 297     PUSHMARK(SP);
 298     XPUSHs(self);
 299     PUTBACK;
 300
 301     call_method("namespace", G_SCALAR);
 302
 303     SPAGAIN;
 304     ret = POPs;
 305     PUTBACK;
 306
 307     return (HV*)SvRV(ret);
 308 }
 309
 310 static SV *_get_name(SV *self)
 311 {
 312     dSP;
 313     SV *ret;
 314
 315     PUSHMARK(SP);
 316     XPUSHs(self);
 317     PUTBACK;
 318
 319     call_method("name", G_SCALAR);
 320
 321     SPAGAIN;
 322     ret = POPs;
 323     PUTBACK;
 324
 325     return ret;
 326 }
 327
 328 static void _real_gv_init(GV *gv, HV *stash, SV *name)
 329 {
 330     char *name_pv;
 331     STRLEN name_len;
 332
 333     name_pv = SvPV(name, name_len);
 334     gv_init(gv, stash, name_pv, name_len, 1);
 335
 336     /* XXX: copied and pasted from gv_fetchpvn_flags and such */
 337     /* ignoring the stuff for CORE:: and main:: for now, and also
 338      * ignoring the GvMULTI_on bits, since we pass 1 to gv_init above */
 339     switch (name_pv[0]) {
 340         case 'I':
 341             if (strEQ(&name_pv[1], "SA")) {
 342                 AV *av;
 343
 344                 av = GvAVn(gv);
 345                 sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
 346                         NULL, 0);
 347             }
 348             break;
 349         case 'O':
 350             if (strEQ(&name_pv[1], "VERLOAD")) {
 351                 HV *hv;
 352
 353                 hv = GvHVn(gv);
 354                 hv_magic(hv, NULL, PERL_MAGIC_overload);
 355             }
 356             break;
 357         default:
 358             break;
 359     }
 360 }
 361
 362 static void _expand_glob(SV *self, SV *varname)
 363 {
 364     HV *namespace;
 365     HE *entry;
 366     GV *glob;
 367
 368     namespace = _get_namespace(self);
 369
 370     if (entry = hv_fetch_ent(namespace, varname, 0, 0)) {
 371         glob = (GV*)HeVAL(entry);
 372         if (isGV(glob)) {
 373             croak("_expand_glob called on stash slot with expanded glob");
 374         }
 375         else {
 376             SvREFCNT_inc(glob);
 377             _real_gv_init(glob, namespace, varname);
 378             if (!hv_store_ent(namespace, varname, (SV*)glob, 0)) {
 379                 croak("hv_store failed");
 380             }
 381         }
 382     }
 383     else {
 384         croak("_expand_glob called on nonexistent stash slot");
 385     }
 386 }
 387
 388 static SV *_get_symbol(SV *self, varspec_t *variable, int vivify)
 389 {
 390     HV *namespace;
 391     HE *entry;
 392     GV *glob;
 393
 394     namespace = _get_namespace(self);
 395     entry = hv_fetch_ent(namespace, variable->name, vivify, 0);
 396     if (!entry)
 397         return NULL;
 398
 399     glob = (GV*)(HeVAL(entry));
 400     if (!isGV(glob))
 401         _expand_glob(self, variable->name);
 402
 403     if (vivify) {
 404         switch (variable->type) {
 405         case VAR_SCALAR:
 406             if (!GvSVOK(glob))
 407                 GvSetSV(glob, newSV(0));
 408             break;
 409         case VAR_ARRAY:
 410             if (!GvAVOK(glob))
 411                 GvSetAV(glob, newAV());
 412             break;
 413         case VAR_HASH:
 414             if (!GvHVOK(glob))
 415                 GvSetHV(glob, newHV());
 416             break;
 417         case VAR_CODE:
 418             croak("Don't know how to vivify CODE variables");
 419         case VAR_IO:
 420             if (!GvIOOK(glob))
 421                 GvSetIO(glob, newIO());
 422             break;
 423         default:
 424             croak("Unknown type in vivication");
 425         }
 426     }
 427
 428     switch (variable->type) {
 429     case VAR_SCALAR:
 430         return GvSV(glob);
 431     case VAR_ARRAY:
 432         return (SV*)GvAV(glob);
 433     case VAR_HASH:
 434         return (SV*)GvHV(glob);
 435     case VAR_CODE:
 436         return (SV*)GvCV(glob);
 437     case VAR_IO:
 438         return (SV*)GvIO(glob);
 439     default:
 440         return NULL;
 441     }
 442 }
 443
 444 MODULE = Package::Stash::XS  PACKAGE = Package::Stash::XS
 445
 446 PROTOTYPES: DISABLE
 447
 448 SV*
 449 new(class, package)
 450     SV *class
 451     SV *package
 452   PREINIT:
 453     HV *instance;
 454   CODE:
 455     if (SvPOK(package)) {
 456         if (!_is_valid_module_name(package))
 457             croak("%s is not a module name", SvPV_nolen(package));
 458
 459         instance = newHV();
 460
 461         if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package), 0)) {
 462             SvREFCNT_dec(package);
 463             SvREFCNT_dec(instance);
 464             croak("Couldn't initialize the 'name' key, hv_store failed");
 465         }
 466     }
 467     else if (SvROK(package) && SvTYPE(SvRV(package)) == SVt_PVHV) {
 468         instance = newHV();
 469
 470         if (!hv_store(instance, "namespace", 9, SvREFCNT_inc_simple_NN(package), 0)) {
 471             SvREFCNT_dec(package);
 472             SvREFCNT_dec(instance);
 473             croak("Couldn't initialize the 'namespace' key, hv_store failed");
 474         }
 475     }
 476     else {
 477         croak("Package::Stash->new must be passed the name of the package to access");
 478     }
 479
 480     RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashsv(class, 0));
 481   OUTPUT:
 482     RETVAL
 483
 484 SV*
 485 name(self)
 486     SV *self
 487   PREINIT:
 488     HE *slot;
 489   CODE:
 490     if (!sv_isobject(self))
 491         croak("Can't call name as a class method");
 492     if (slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash)) {
 493         RETVAL = SvREFCNT_inc_simple_NN(HeVAL(slot));
 494     }
 495     else {
 496         croak("Can't get the name of an anonymous package");
 497     }
 498   OUTPUT:
 499     RETVAL
 500
 501 SV*
 502 namespace(self)
 503     SV *self
 504   PREINIT:
 505     HE *slot;
 506     SV *package_name;
 507   CODE:
 508     if (!sv_isobject(self))
 509         croak("Can't call namespace as a class method");
 510 #if PERL_VERSION < 10
 511     package_name = _get_name(self);
 512     RETVAL = newRV_inc((SV*)gv_stashpv(SvPV_nolen(package_name), GV_ADD));
 513 #else
 514     slot = hv_fetch_ent((HV*)SvRV(self), namespace_key, 0, namespace_hash);
 515     if (slot) {
 516         RETVAL = SvREFCNT_inc_simple_NN(HeVAL(slot));
 517     }
 518     else {
 519         HV *namespace;
 520         SV *nsref;
 521
 522         package_name = _get_name(self);
 523         namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
 524         nsref = newRV_inc((SV*)namespace);
 525         sv_rvweaken(nsref);
 526         if (!hv_store((HV*)SvRV(self), "namespace", 9, nsref, 0)) {
 527             SvREFCNT_dec(nsref);
 528             SvREFCNT_dec(self);
 529             croak("Couldn't initialize the 'namespace' key, hv_store failed");
 530         }
 531         RETVAL = SvREFCNT_inc_simple_NN(nsref);
 532     }
 533 #endif
 534   OUTPUT:
 535     RETVAL
 536
 537 void
 538 add_symbol(self, variable, initial=NULL, ...)
 539     SV *self
 540     varspec_t variable
 541     SV *initial
 542   PREINIT:
 543     GV *glob;
 544     HV *namespace;
 545     HE *entry;
 546   CODE:
 547     if (initial && !_valid_for_type(initial, variable.type))
 548         croak("%s is not of type %s",
 549               SvPV_nolen(initial), vartype_to_string(variable.type));
 550
 551     if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
 552         int i;
 553         char *filename = NULL;
 554         I32 first_line_num = -1, last_line_num = -1;
 555         SV *dbval, *name;
 556         HV *dbsub;
 557
 558         if ((items - 3) % 2)
 559             croak("add_symbol: Odd number of elements in %%opts");
 560
 561         for (i = 3; i < items; i += 2) {
 562             char *key;
 563             key = SvPV_nolen(ST(i));
 564             if (strEQ(key, "filename")) {
 565                 if (!SvPOK(ST(i + 1)))
 566                     croak("add_symbol: filename must be a string");
 567                 filename = SvPV_nolen(ST(i + 1));
 568             }
 569             else if (strEQ(key, "first_line_num")) {
 570                 if (!SvIOK(ST(i + 1)))
 571                     croak("add_symbol: first_line_num must be an integer");
 572                 first_line_num = SvIV(ST(i + 1));
 573             }
 574             else if (strEQ(key, "last_line_num")) {
 575                 if (!SvIOK(ST(i + 1)))
 576                     croak("add_symbol: last_line_num must be an integer");
 577                 last_line_num = SvIV(ST(i + 1));
 578             }
 579         }
 580
 581         if (!filename || first_line_num == -1) {
 582             if (!filename)
 583                 filename = CopFILE(PL_curcop);
 584             if (first_line_num == -1)
 585                 first_line_num = PL_curcop->cop_line;
 586         }
 587
 588         if (last_line_num == -1)
 589             last_line_num = first_line_num;
 590
 591         name = newSVsv(_get_name(self));
 592         sv_catpvs(name, "::");
 593         sv_catsv(name, variable.name);
 594
 595         /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */
 596         dbsub = get_hv("DB::sub", 1);
 597         dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num);
 598         if (!hv_store_ent(dbsub, name, dbval, 0)) {
 599             warn("Failed to update $DB::sub for subroutine %s",
 600                  SvPV_nolen(name));
 601             SvREFCNT_dec(dbval);
 602         }
 603
 604         SvREFCNT_dec(name);
 605     }
 606
 607     /* GV_ADDMULTI rather than GV_ADD because otherwise you get 'used only
 608      * once' warnings in some situations... i can't reproduce this, but CMOP
 609      * triggers it */
 610     namespace = _get_namespace(self);
 611     entry = hv_fetch_ent(namespace, variable.name, 0, 0);
 612     if (entry) {
 613         glob = (GV*)HeVAL(entry);
 614     }
 615     else {
 616         glob = (GV*)newSV(0);
 617         _real_gv_init(glob, namespace, variable.name);
 618         if (!hv_store_ent(namespace, variable.name, (SV*)glob, 0)) {
 619             croak("hv_store failed");
 620         }
 621     }
 622
 623     if (initial) {
 624         SV *val;
 625
 626         if (SvROK(initial)) {
 627             val = SvRV(initial);
 628             SvREFCNT_inc_simple_void_NN(val);
 629         }
 630         else {
 631             val = newSVsv(initial);
 632         }
 633
 634         switch (variable.type) {
 635         case VAR_SCALAR:
 636             GvSetSV(glob, val);
 637             break;
 638         case VAR_ARRAY:
 639             GvSetAV(glob, val);
 640             break;
 641         case VAR_HASH:
 642             GvSetHV(glob, val);
 643             break;
 644         case VAR_CODE:
 645             GvSetCV(glob, val);
 646             break;
 647         case VAR_IO:
 648             GvSetIO(glob, val);
 649             break;
 650         }
 651     }
 652
 653 void
 654 remove_glob(self, name)
 655     SV *self
 656     SV *name
 657   CODE:
 658     hv_delete_ent(_get_namespace(self), name, G_DISCARD, 0);
 659
 660 int
 661 has_symbol(self, variable)
 662     SV *self
 663     varspec_t variable
 664   PREINIT:
 665     HV *namespace;
 666     HE *entry;
 667     SV *val;
 668   CODE:
 669     namespace = _get_namespace(self);
 670     entry = hv_fetch_ent(namespace, variable.name, 0, 0);
 671     if (!entry)
 672         XSRETURN_UNDEF;
 673
 674     val = HeVAL(entry);
 675     if (isGV(val)) {
 676         GV *glob = (GV*)val;
 677         switch (variable.type) {
 678         case VAR_SCALAR:
 679             RETVAL = GvSVOK(glob) ? 1 : 0;
 680             break;
 681         case VAR_ARRAY:
 682             RETVAL = GvAVOK(glob) ? 1 : 0;
 683             break;
 684         case VAR_HASH:
 685             RETVAL = GvHVOK(glob) ? 1 : 0;
 686             break;
 687         case VAR_CODE:
 688             RETVAL = GvCVOK(glob) ? 1 : 0;
 689             break;
 690         case VAR_IO:
 691             RETVAL = GvIOOK(glob) ? 1 : 0;
 692             break;
 693         }
 694     }
 695     else {
 696         RETVAL = (variable.type == VAR_CODE);
 697     }
 698   OUTPUT:
 699     RETVAL
 700
 701 SV*
 702 get_symbol(self, variable)
 703     SV *self
 704     varspec_t variable
 705   PREINIT:
 706     SV *val;
 707   CODE:
 708     val = _get_symbol(self, &variable, 0);
 709     if (!val)
 710         XSRETURN_UNDEF;
 711     RETVAL = newRV_inc(val);
 712   OUTPUT:
 713     RETVAL
 714
 715 SV*
 716 get_or_add_symbol(self, variable)
 717     SV *self
 718     varspec_t variable
 719   PREINIT:
 720     SV *val;
 721   CODE:
 722     val = _get_symbol(self, &variable, 1);
 723     if (!val)
 724         XSRETURN_UNDEF;
 725     RETVAL = newRV_inc(val);
 726   OUTPUT:
 727     RETVAL
 728
 729 void
 730 remove_symbol(self, variable)
 731     SV *self
 732     varspec_t variable
 733   PREINIT:
 734     HV *namespace;
 735     HE *entry;
 736     SV *val;
 737   CODE:
 738     namespace = _get_namespace(self);
 739     entry = hv_fetch_ent(namespace, variable.name, 0, 0);
 740     if (!entry)
 741         XSRETURN_EMPTY;
 742
 743     val = HeVAL(entry);
 744     if (isGV(val)) {
 745         GV *glob = (GV*)val;
 746         switch (variable.type) {
 747         case VAR_SCALAR:
 748             GvSetSV(glob, NULL);
 749             break;
 750         case VAR_ARRAY:
 751             GvSetAV(glob, NULL);
 752             break;
 753         case VAR_HASH:
 754             GvSetHV(glob, NULL);
 755             break;
 756         case VAR_CODE:
 757             GvSetCV(glob, NULL);
 758             break;
 759         case VAR_IO:
 760             GvSetIO(glob, NULL);
 761             break;
 762         }
 763     }
 764     else {
 765         if (variable.type == VAR_CODE) {
 766             hv_delete_ent(namespace, variable.name, G_DISCARD, 0);
 767         }
 768     }
 769
 770 void
 771 list_all_symbols(self, vartype=VAR_NONE)
 772     SV *self
 773     vartype_t vartype
 774   PPCODE:
 775     if (vartype == VAR_NONE) {
 776         HV *namespace;
 777         HE *entry;
 778         int keys;
 779
 780         namespace = _get_namespace(self);
 781         keys = hv_iterinit(namespace);
 782         EXTEND(SP, keys);
 783         while ((entry = hv_iternext(namespace))) {
 784             mPUSHs(newSVhe(entry));
 785         }
 786     }
 787     else {
 788         HV *namespace;
 789         SV *val;
 790         char *key;
 791         I32 len;
 792
 793         namespace = _get_namespace(self);
 794         hv_iterinit(namespace);
 795         while ((val = hv_iternextsv(namespace, &key, &len))) {
 796             GV *gv = (GV*)val;
 797             if (isGV(gv)) {
 798                 switch (vartype) {
 799                 case VAR_SCALAR:
 800                     if (GvSVOK(val))
 801                         mXPUSHp(key, len);
 802                     break;
 803                 case VAR_ARRAY:
 804                     if (GvAVOK(val))
 805                         mXPUSHp(key, len);
 806                     break;
 807                 case VAR_HASH:
 808                     if (GvHVOK(val))
 809                         mXPUSHp(key, len);
 810                     break;
 811                 case VAR_CODE:
 812                     if (GvCVOK(val))
 813                         mXPUSHp(key, len);
 814                     break;
 815                 case VAR_IO:
 816                     if (GvIOOK(val))
 817                         mXPUSHp(key, len);
 818                     break;
 819                 }
 820             }
 821             else if (vartype == VAR_CODE) {
 822                 mXPUSHp(key, len);
 823             }
 824         }
 825     }
 826
 827 void
 828 get_all_symbols(self, vartype=VAR_NONE)
 829     SV *self
 830     vartype_t vartype
 831   PREINIT:
 832     HV *namespace, *ret;
 833     SV *val;
 834     char *key;
 835     I32 len;
 836   PPCODE:
 837     namespace = _get_namespace(self);
 838     ret = newHV();
 839
 840     hv_iterinit(namespace);
 841     while ((val = hv_iternextsv(namespace, &key, &len))) {
 842         GV *gv = (GV*)val;
 843
 844         if (!isGV(gv)) {
 845             SV *keysv = newSVpvn(key, len);
 846             _expand_glob(self, keysv);
 847             SvREFCNT_dec(keysv);
 848         }
 849
 850         switch (vartype) {
 851         case VAR_SCALAR:
 852             if (GvSVOK(val))
 853                 hv_store(ret, key, len, newRV_inc(GvSV(gv)), 0);
 854             break;
 855         case VAR_ARRAY:
 856             if (GvAVOK(val))
 857                 hv_store(ret, key, len, newRV_inc((SV*)GvAV(gv)), 0);
 858             break;
 859         case VAR_HASH:
 860             if (GvHVOK(val))
 861                 hv_store(ret, key, len, newRV_inc((SV*)GvHV(gv)), 0);
 862             break;
 863         case VAR_CODE:
 864             if (GvCVOK(val))
 865                 hv_store(ret, key, len, newRV_inc((SV*)GvCV(gv)), 0);
 866             break;
 867         case VAR_IO:
 868             if (GvIOOK(val))
 869                 hv_store(ret, key, len, newRV_inc((SV*)GvIO(gv)), 0);
 870             break;
 871         case VAR_NONE:
 872             hv_store(ret, key, len, SvREFCNT_inc_simple_NN(val), 0);
 873             break;
 874         }
 875     }
 876
 877     mPUSHs(newRV_noinc((SV*)ret));
 878
 879 BOOT:
 880     {
 881         const char *vmre = "\\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\\z";
 882 #if (PERL_VERSION < 9) || ((PERL_VERSION == 9) && (PERL_SUBVERSION < 5))
 883         PMOP fakepmop;
 884
 885         fakepmop.op_pmflags = 0;
 886         valid_module_regex = pregcomp(vmre, vmre + strlen(vmre), &fakepmop);
 887 #else
 888         SV *re;
 889
 890         re = newSVpv(vmre, 0);
 891         valid_module_regex = pregcomp(re, 0);
 892 #endif
 893
 894         name_key = newSVpvs("name");
 895         PERL_HASH(name_hash, "name", 4);
 896
 897         namespace_key = newSVpvs("namespace");
 898         PERL_HASH(namespace_hash, "namespace", 9);
 899
 900         type_key = newSVpvs("type");
 901         PERL_HASH(type_hash, "type", 4);
 902     }