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