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