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 _expand_glob(SV *self, SV *varname)
 329 {
 330     HV *namespace;
 331     HE *entry;
 332     GV *glob;
 333
 334     namespace = _get_namespace(self);
 335
 336     if (entry = hv_fetch_ent(namespace, varname, 0, 0)) {
 337         glob = (GV*)HeVAL(entry);
 338         if (isGV(glob)) {
 339             croak("_expand_glob called on stash slot with expanded glob");
 340         }
 341         else {
 342             char *varname_pv;
 343             STRLEN varname_len;
 344
 345             varname_pv = SvPV(varname, varname_len);
 346             gv_init(glob, namespace, varname_pv, varname_len, 1);
 347             SvREFCNT_inc(glob);
 348             if (!hv_store_ent(namespace, varname, (SV*)glob, 0)) {
 349                 croak("hv_store failed");
 350             }
 351         }
 352     }
 353     else {
 354         croak("_expand_glob called on nonexistent stash slot");
 355     }
 356 }
 357
 358 static SV *_get_symbol(SV *self, varspec_t *variable, int vivify)
 359 {
 360     HV *namespace;
 361     HE *entry;
 362     GV *glob;
 363
 364     namespace = _get_namespace(self);
 365     entry = hv_fetch_ent(namespace, variable->name, vivify, 0);
 366     if (!entry)
 367         return NULL;
 368
 369     glob = (GV*)(HeVAL(entry));
 370     if (!isGV(glob))
 371         _expand_glob(self, variable->name);
 372
 373     if (vivify) {
 374         switch (variable->type) {
 375         case VAR_SCALAR:
 376             if (!GvSVOK(glob))
 377                 GvSetSV(glob, newSV(0));
 378             break;
 379         case VAR_ARRAY:
 380             if (!GvAVOK(glob))
 381                 GvSetAV(glob, newAV());
 382             break;
 383         case VAR_HASH:
 384             if (!GvHVOK(glob))
 385                 GvSetHV(glob, newHV());
 386             break;
 387         case VAR_CODE:
 388             croak("Don't know how to vivify CODE variables");
 389         case VAR_IO:
 390             if (!GvIOOK(glob))
 391                 GvSetIO(glob, newIO());
 392             break;
 393         default:
 394             croak("Unknown type in vivication");
 395         }
 396     }
 397
 398     switch (variable->type) {
 399     case VAR_SCALAR:
 400         return GvSV(glob);
 401     case VAR_ARRAY:
 402         return (SV*)GvAV(glob);
 403     case VAR_HASH:
 404         return (SV*)GvHV(glob);
 405     case VAR_CODE:
 406         return (SV*)GvCV(glob);
 407     case VAR_IO:
 408         return (SV*)GvIO(glob);
 409     default:
 410         return NULL;
 411     }
 412 }
 413
 414 MODULE = Package::Stash::XS  PACKAGE = Package::Stash::XS
 415
 416 PROTOTYPES: DISABLE
 417
 418 SV*
 419 new(class, package)
 420     SV *class
 421     SV *package
 422   PREINIT:
 423     HV *instance;
 424   CODE:
 425     if (SvPOK(package)) {
 426         if (!_is_valid_module_name(package))
 427             croak("%s is not a module name", SvPV_nolen(package));
 428
 429         instance = newHV();
 430
 431         if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package), 0)) {
 432             SvREFCNT_dec(package);
 433             SvREFCNT_dec(instance);
 434             croak("Couldn't initialize the 'name' key, hv_store failed");
 435         }
 436     }
 437     else if (SvROK(package) && SvTYPE(SvRV(package)) == SVt_PVHV) {
 438         instance = newHV();
 439
 440         if (!hv_store(instance, "namespace", 9, SvREFCNT_inc_simple_NN(package), 0)) {
 441             SvREFCNT_dec(package);
 442             SvREFCNT_dec(instance);
 443             croak("Couldn't initialize the 'namespace' key, hv_store failed");
 444         }
 445     }
 446     else {
 447         croak("Package::Stash->new must be passed the name of the package to access");
 448     }
 449
 450     RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashsv(class, 0));
 451   OUTPUT:
 452     RETVAL
 453
 454 SV*
 455 name(self)
 456     SV *self
 457   PREINIT:
 458     HE *slot;
 459   CODE:
 460     if (!sv_isobject(self))
 461         croak("Can't call name as a class method");
 462     if (slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash)) {
 463         RETVAL = SvREFCNT_inc_simple_NN(HeVAL(slot));
 464     }
 465     else {
 466         croak("Can't get the name of an anonymous package");
 467     }
 468   OUTPUT:
 469     RETVAL
 470
 471 SV*
 472 namespace(self)
 473     SV *self
 474   PREINIT:
 475     HE *slot;
 476     SV *package_name;
 477   CODE:
 478     if (!sv_isobject(self))
 479         croak("Can't call namespace as a class method");
 480 #if PERL_VERSION < 10
 481     package_name = _get_name(self);
 482     RETVAL = newRV_inc((SV*)gv_stashpv(SvPV_nolen(package_name), GV_ADD));
 483 #else
 484     slot = hv_fetch_ent((HV*)SvRV(self), namespace_key, 0, namespace_hash);
 485     if (slot) {
 486         RETVAL = SvREFCNT_inc_simple_NN(HeVAL(slot));
 487     }
 488     else {
 489         HV *namespace;
 490         SV *nsref;
 491
 492         package_name = _get_name(self);
 493         namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
 494         nsref = newRV_inc((SV*)namespace);
 495         sv_rvweaken(nsref);
 496         if (!hv_store((HV*)SvRV(self), "namespace", 9, nsref, 0)) {
 497             SvREFCNT_dec(nsref);
 498             SvREFCNT_dec(self);
 499             croak("Couldn't initialize the 'namespace' key, hv_store failed");
 500         }
 501         RETVAL = SvREFCNT_inc_simple_NN(nsref);
 502     }
 503 #endif
 504   OUTPUT:
 505     RETVAL
 506
 507 void
 508 add_symbol(self, variable, initial=NULL, ...)
 509     SV *self
 510     varspec_t variable
 511     SV *initial
 512   PREINIT:
 513     GV *glob;
 514     HV *namespace;
 515     HE *entry;
 516   CODE:
 517     if (initial && !_valid_for_type(initial, variable.type))
 518         croak("%s is not of type %s",
 519               SvPV_nolen(initial), vartype_to_string(variable.type));
 520
 521     if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
 522         int i;
 523         char *filename = NULL;
 524         I32 first_line_num = -1, last_line_num = -1;
 525         SV *dbval, *name;
 526         HV *dbsub;
 527
 528         if ((items - 3) % 2)
 529             croak("add_symbol: Odd number of elements in %%opts");
 530
 531         for (i = 3; i < items; i += 2) {
 532             char *key;
 533             key = SvPV_nolen(ST(i));
 534             if (strEQ(key, "filename")) {
 535                 if (!SvPOK(ST(i + 1)))
 536                     croak("add_symbol: filename must be a string");
 537                 filename = SvPV_nolen(ST(i + 1));
 538             }
 539             else if (strEQ(key, "first_line_num")) {
 540                 if (!SvIOK(ST(i + 1)))
 541                     croak("add_symbol: first_line_num must be an integer");
 542                 first_line_num = SvIV(ST(i + 1));
 543             }
 544             else if (strEQ(key, "last_line_num")) {
 545                 if (!SvIOK(ST(i + 1)))
 546                     croak("add_symbol: last_line_num must be an integer");
 547                 last_line_num = SvIV(ST(i + 1));
 548             }
 549         }
 550
 551         if (!filename || first_line_num == -1) {
 552             if (!filename)
 553                 filename = CopFILE(PL_curcop);
 554             if (first_line_num == -1)
 555                 first_line_num = PL_curcop->cop_line;
 556         }
 557
 558         if (last_line_num == -1)
 559             last_line_num = first_line_num;
 560
 561         name = newSVsv(_get_name(self));
 562         sv_catpvs(name, "::");
 563         sv_catsv(name, variable.name);
 564
 565         /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */
 566         dbsub = get_hv("DB::sub", 1);
 567         dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num);
 568         if (!hv_store_ent(dbsub, name, dbval, 0)) {
 569             warn("Failed to update $DB::sub for subroutine %s",
 570                  SvPV_nolen(name));
 571             SvREFCNT_dec(dbval);
 572         }
 573
 574         SvREFCNT_dec(name);
 575     }
 576
 577     /* GV_ADDMULTI rather than GV_ADD because otherwise you get 'used only
 578      * once' warnings in some situations... i can't reproduce this, but CMOP
 579      * triggers it */
 580     namespace = _get_namespace(self);
 581     entry = hv_fetch_ent(namespace, variable.name, 0, 0);
 582     if (entry) {
 583         glob = (GV*)HeVAL(entry);
 584     }
 585     else {
 586         char *varname_pv;
 587         STRLEN varname_len;
 588         glob = (GV*)newSV(0);
 589         varname_pv = SvPV(variable.name, varname_len);
 590         gv_init(glob, namespace, varname_pv, varname_len, 1);
 591         if (!hv_store_ent(namespace, variable.name, (SV*)glob, 0)) {
 592             croak("hv_store failed");
 593         }
 594     }
 595
 596     if (initial) {
 597         SV *val;
 598
 599         if (SvROK(initial)) {
 600             val = SvRV(initial);
 601             SvREFCNT_inc_simple_void_NN(val);
 602         }
 603         else {
 604             val = newSVsv(initial);
 605         }
 606
 607         switch (variable.type) {
 608         case VAR_SCALAR:
 609             GvSetSV(glob, val);
 610             break;
 611         case VAR_ARRAY:
 612             GvSetAV(glob, val);
 613             break;
 614         case VAR_HASH:
 615             GvSetHV(glob, val);
 616             break;
 617         case VAR_CODE:
 618             GvSetCV(glob, val);
 619             break;
 620         case VAR_IO:
 621             GvSetIO(glob, val);
 622             break;
 623         }
 624     }
 625
 626 void
 627 remove_glob(self, name)
 628     SV *self
 629     SV *name
 630   CODE:
 631     hv_delete_ent(_get_namespace(self), name, G_DISCARD, 0);
 632
 633 int
 634 has_symbol(self, variable)
 635     SV *self
 636     varspec_t variable
 637   PREINIT:
 638     HV *namespace;
 639     HE *entry;
 640     SV *val;
 641   CODE:
 642     namespace = _get_namespace(self);
 643     entry = hv_fetch_ent(namespace, variable.name, 0, 0);
 644     if (!entry)
 645         XSRETURN_UNDEF;
 646
 647     val = HeVAL(entry);
 648     if (isGV(val)) {
 649         GV *glob = (GV*)val;
 650         switch (variable.type) {
 651         case VAR_SCALAR:
 652             RETVAL = GvSVOK(glob) ? 1 : 0;
 653             break;
 654         case VAR_ARRAY:
 655             RETVAL = GvAVOK(glob) ? 1 : 0;
 656             break;
 657         case VAR_HASH:
 658             RETVAL = GvHVOK(glob) ? 1 : 0;
 659             break;
 660         case VAR_CODE:
 661             RETVAL = GvCVOK(glob) ? 1 : 0;
 662             break;
 663         case VAR_IO:
 664             RETVAL = GvIOOK(glob) ? 1 : 0;
 665             break;
 666         }
 667     }
 668     else {
 669         RETVAL = (variable.type == VAR_CODE);
 670     }
 671   OUTPUT:
 672     RETVAL
 673
 674 SV*
 675 get_symbol(self, variable)
 676     SV *self
 677     varspec_t variable
 678   PREINIT:
 679     SV *val;
 680   CODE:
 681     val = _get_symbol(self, &variable, 0);
 682     if (!val)
 683         XSRETURN_UNDEF;
 684     RETVAL = newRV_inc(val);
 685   OUTPUT:
 686     RETVAL
 687
 688 SV*
 689 get_or_add_symbol(self, variable)
 690     SV *self
 691     varspec_t variable
 692   PREINIT:
 693     SV *val;
 694   CODE:
 695     val = _get_symbol(self, &variable, 1);
 696     if (!val)
 697         XSRETURN_UNDEF;
 698     RETVAL = newRV_inc(val);
 699   OUTPUT:
 700     RETVAL
 701
 702 void
 703 remove_symbol(self, variable)
 704     SV *self
 705     varspec_t variable
 706   PREINIT:
 707     HV *namespace;
 708     HE *entry;
 709     SV *val;
 710   CODE:
 711     namespace = _get_namespace(self);
 712     entry = hv_fetch_ent(namespace, variable.name, 0, 0);
 713     if (!entry)
 714         XSRETURN_EMPTY;
 715
 716     val = HeVAL(entry);
 717     if (isGV(val)) {
 718         GV *glob = (GV*)val;
 719         switch (variable.type) {
 720         case VAR_SCALAR:
 721             GvSetSV(glob, NULL);
 722             break;
 723         case VAR_ARRAY:
 724             GvSetAV(glob, NULL);
 725             break;
 726         case VAR_HASH:
 727             GvSetHV(glob, NULL);
 728             break;
 729         case VAR_CODE:
 730             GvSetCV(glob, NULL);
 731             break;
 732         case VAR_IO:
 733             GvSetIO(glob, NULL);
 734             break;
 735         }
 736     }
 737     else {
 738         if (variable.type == VAR_CODE) {
 739             hv_delete_ent(namespace, variable.name, G_DISCARD, 0);
 740         }
 741     }
 742
 743 void
 744 list_all_symbols(self, vartype=VAR_NONE)
 745     SV *self
 746     vartype_t vartype
 747   PPCODE:
 748     if (vartype == VAR_NONE) {
 749         HV *namespace;
 750         HE *entry;
 751         int keys;
 752
 753         namespace = _get_namespace(self);
 754         keys = hv_iterinit(namespace);
 755         EXTEND(SP, keys);
 756         while ((entry = hv_iternext(namespace))) {
 757             mPUSHs(newSVhe(entry));
 758         }
 759     }
 760     else {
 761         HV *namespace;
 762         SV *val;
 763         char *key;
 764         I32 len;
 765
 766         namespace = _get_namespace(self);
 767         hv_iterinit(namespace);
 768         while ((val = hv_iternextsv(namespace, &key, &len))) {
 769             GV *gv = (GV*)val;
 770             if (isGV(gv)) {
 771                 switch (vartype) {
 772                 case VAR_SCALAR:
 773                     if (GvSVOK(val))
 774                         mXPUSHp(key, len);
 775                     break;
 776                 case VAR_ARRAY:
 777                     if (GvAVOK(val))
 778                         mXPUSHp(key, len);
 779                     break;
 780                 case VAR_HASH:
 781                     if (GvHVOK(val))
 782                         mXPUSHp(key, len);
 783                     break;
 784                 case VAR_CODE:
 785                     if (GvCVOK(val))
 786                         mXPUSHp(key, len);
 787                     break;
 788                 case VAR_IO:
 789                     if (GvIOOK(val))
 790                         mXPUSHp(key, len);
 791                     break;
 792                 }
 793             }
 794             else if (vartype == VAR_CODE) {
 795                 mXPUSHp(key, len);
 796             }
 797         }
 798     }
 799
 800 void
 801 get_all_symbols(self, vartype=VAR_NONE)
 802     SV *self
 803     vartype_t vartype
 804   PREINIT:
 805     HV *namespace, *ret;
 806     SV *val;
 807     char *key;
 808     I32 len;
 809   PPCODE:
 810     namespace = _get_namespace(self);
 811     ret = newHV();
 812
 813     hv_iterinit(namespace);
 814     while ((val = hv_iternextsv(namespace, &key, &len))) {
 815         GV *gv = (GV*)val;
 816
 817         if (!isGV(gv)) {
 818             SV *keysv = newSVpvn(key, len);
 819             _expand_glob(self, keysv);
 820             SvREFCNT_dec(keysv);
 821         }
 822
 823         switch (vartype) {
 824         case VAR_SCALAR:
 825             if (GvSVOK(val))
 826                 hv_store(ret, key, len, newRV_inc(GvSV(gv)), 0);
 827             break;
 828         case VAR_ARRAY:
 829             if (GvAVOK(val))
 830                 hv_store(ret, key, len, newRV_inc((SV*)GvAV(gv)), 0);
 831             break;
 832         case VAR_HASH:
 833             if (GvHVOK(val))
 834                 hv_store(ret, key, len, newRV_inc((SV*)GvHV(gv)), 0);
 835             break;
 836         case VAR_CODE:
 837             if (GvCVOK(val))
 838                 hv_store(ret, key, len, newRV_inc((SV*)GvCV(gv)), 0);
 839             break;
 840         case VAR_IO:
 841             if (GvIOOK(val))
 842                 hv_store(ret, key, len, newRV_inc((SV*)GvIO(gv)), 0);
 843             break;
 844         case VAR_NONE:
 845             hv_store(ret, key, len, SvREFCNT_inc_simple_NN(val), 0);
 846             break;
 847         }
 848     }
 849
 850     mPUSHs(newRV_noinc((SV*)ret));
 851
 852 BOOT:
 853     {
 854         const char *vmre = "\\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\\z";
 855 #if (PERL_VERSION < 9) || ((PERL_VERSION == 9) && (PERL_SUBVERSION < 5))
 856         PMOP fakepmop;
 857
 858         fakepmop.op_pmflags = 0;
 859         valid_module_regex = pregcomp(vmre, vmre + strlen(vmre), &fakepmop);
 860 #else
 861         SV *re;
 862
 863         re = newSVpv(vmre, 0);
 864         valid_module_regex = pregcomp(re, 0);
 865 #endif
 866
 867         name_key = newSVpvs("name");
 868         PERL_HASH(name_hash, "name", 4);
 869
 870         namespace_key = newSVpvs("namespace");
 871         PERL_HASH(namespace_hash, "namespace", 9);
 872
 873         type_key = newSVpvs("type");
 874         PERL_HASH(type_hash, "type", 4);
 875     }