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