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