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