don't call mro_method_changed_in on anon stashes
[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
bf460ff3 328static void _expand_glob(SV *self, SV *varname)
60b395a1 329{
5e738664 330 HV *namespace;
331 HE *entry;
332 GV *glob;
333
334 namespace = _get_namespace(self);
335
336 if (entry = hv_fetch_ent(namespace, varname, 0, 0)) {
337 glob = (GV*)HeVAL(entry);
338 if (isGV(glob)) {
339 croak("_expand_glob called on stash slot with expanded glob");
340 }
341 else {
342 char *varname_pv;
343 STRLEN varname_len;
344
345 varname_pv = SvPV(varname, varname_len);
346 gv_init(glob, namespace, varname_pv, varname_len, 1);
347 SvREFCNT_inc(glob);
348 if (!hv_store_ent(namespace, varname, (SV*)glob, 0)) {
349 croak("hv_store failed");
350 }
351 }
352 }
353 else {
354 croak("_expand_glob called on nonexistent stash slot");
355 }
60b395a1 356}
357
bf460ff3 358static SV *_get_symbol(SV *self, varspec_t *variable, int vivify)
4871b1a0 359{
360 HV *namespace;
4849f4fc 361 HE *entry;
4871b1a0 362 GV *glob;
363
364 namespace = _get_namespace(self);
4849f4fc 365 entry = hv_fetch_ent(namespace, variable->name, vivify, 0);
4871b1a0 366 if (!entry)
367 return NULL;
368
4849f4fc 369 glob = (GV*)(HeVAL(entry));
60b395a1 370 if (!isGV(glob))
371 _expand_glob(self, variable->name);
4871b1a0 372
373 if (vivify) {
374 switch (variable->type) {
375 case VAR_SCALAR:
d551a208 376 if (!GvSVOK(glob))
377 GvSetSV(glob, newSV(0));
4871b1a0 378 break;
379 case VAR_ARRAY:
d551a208 380 if (!GvAVOK(glob))
381 GvSetAV(glob, newAV());
4871b1a0 382 break;
383 case VAR_HASH:
d551a208 384 if (!GvHVOK(glob))
385 GvSetHV(glob, newHV());
4871b1a0 386 break;
387 case VAR_CODE:
388 croak("Don't know how to vivify CODE variables");
389 case VAR_IO:
d551a208 390 if (!GvIOOK(glob))
391 GvSetIO(glob, newIO());
4871b1a0 392 break;
393 default:
394 croak("Unknown type in vivication");
395 }
396 }
397
398 switch (variable->type) {
399 case VAR_SCALAR:
400 return GvSV(glob);
401 case VAR_ARRAY:
402 return (SV*)GvAV(glob);
403 case VAR_HASH:
404 return (SV*)GvHV(glob);
405 case VAR_CODE:
406 return (SV*)GvCV(glob);
407 case VAR_IO:
408 return (SV*)GvIO(glob);
409 default:
410 return NULL;
411 }
412}
413
c53d2df2 414MODULE = Package::Stash::XS PACKAGE = Package::Stash::XS
59017825 415
be2a7e99 416PROTOTYPES: DISABLE
417
59017825 418SV*
8860963a 419new(class, package)
4849f4fc 420 SV *class
8860963a 421 SV *package
3496f1e8 422 PREINIT:
59017825 423 HV *instance;
59017825 424 CODE:
8860963a 425 if (SvPOK(package)) {
426 if (!_is_valid_module_name(package))
427 croak("%s is not a module name", SvPV_nolen(package));
59017825 428
8860963a 429 instance = newHV();
78daf8ed 430
8860963a 431 if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package), 0)) {
432 SvREFCNT_dec(package);
433 SvREFCNT_dec(instance);
434 croak("Couldn't initialize the 'name' key, hv_store failed");
435 }
436 }
437 else if (SvROK(package) && SvTYPE(SvRV(package)) == SVt_PVHV) {
438 instance = newHV();
59017825 439
8860963a 440 if (!hv_store(instance, "namespace", 9, SvREFCNT_inc_simple_NN(package), 0)) {
441 SvREFCNT_dec(package);
442 SvREFCNT_dec(instance);
443 croak("Couldn't initialize the 'namespace' key, hv_store failed");
444 }
445 }
446 else {
447 croak("Package::Stash->new must be passed the name of the package to access");
1d6c978b 448 }
59017825 449
4849f4fc 450 RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashsv(class, 0));
59017825 451 OUTPUT:
452 RETVAL
194acf47 453
454SV*
455name(self)
456 SV *self
3496f1e8 457 PREINIT:
26f802f7 458 HE *slot;
194acf47 459 CODE:
460 if (!sv_isobject(self))
461 croak("Can't call name as a class method");
8860963a 462 if (slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash)) {
463 RETVAL = SvREFCNT_inc_simple_NN(HeVAL(slot));
464 }
465 else {
466 croak("Can't get the name of an anonymous package");
467 }
194acf47 468 OUTPUT:
469 RETVAL
470
471SV*
472namespace(self)
473 SV *self
3496f1e8 474 PREINIT:
26f802f7 475 HE *slot;
7c3b261c 476 SV *package_name;
194acf47 477 CODE:
478 if (!sv_isobject(self))
479 croak("Can't call namespace as a class method");
7c3b261c 480#if PERL_VERSION < 10
481 package_name = _get_name(self);
482 RETVAL = newRV_inc((SV*)gv_stashpv(SvPV_nolen(package_name), GV_ADD));
483#else
26f802f7 484 slot = hv_fetch_ent((HV*)SvRV(self), namespace_key, 0, namespace_hash);
31263168 485 if (slot) {
486 RETVAL = SvREFCNT_inc_simple_NN(HeVAL(slot));
487 }
488 else {
489 HV *namespace;
7c3b261c 490 SV *nsref;
31263168 491
492 package_name = _get_name(self);
493 namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD);
494 nsref = newRV_inc((SV*)namespace);
495 sv_rvweaken(nsref);
496 if (!hv_store((HV*)SvRV(self), "namespace", 9, nsref, 0)) {
497 SvREFCNT_dec(nsref);
498 SvREFCNT_dec(self);
499 croak("Couldn't initialize the 'namespace' key, hv_store failed");
500 }
501 RETVAL = SvREFCNT_inc_simple_NN(nsref);
502 }
7c3b261c 503#endif
194acf47 504 OUTPUT:
505 RETVAL
3fd56b4d 506
507void
15c104e2 508add_symbol(self, variable, initial=NULL, ...)
76f7c306 509 SV *self
510 varspec_t variable
511 SV *initial
512 PREINIT:
76f7c306 513 GV *glob;
e290a036 514 HV *namespace;
515 HE *entry;
76f7c306 516 CODE:
517 if (initial && !_valid_for_type(initial, variable.type))
518 croak("%s is not of type %s",
519 SvPV_nolen(initial), vartype_to_string(variable.type));
520
76f7c306 521 if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) {
522 int i;
4849f4fc 523 char *filename = NULL;
d1d0e437 524 I32 first_line_num = -1, last_line_num = -1;
e290a036 525 SV *dbval, *name;
d1d0e437 526 HV *dbsub;
76f7c306 527
528 if ((items - 3) % 2)
15c104e2 529 croak("add_symbol: Odd number of elements in %%opts");
76f7c306 530
531 for (i = 3; i < items; i += 2) {
532 char *key;
533 key = SvPV_nolen(ST(i));
534 if (strEQ(key, "filename")) {
535 if (!SvPOK(ST(i + 1)))
15c104e2 536 croak("add_symbol: filename must be a string");
76f7c306 537 filename = SvPV_nolen(ST(i + 1));
538 }
539 else if (strEQ(key, "first_line_num")) {
540 if (!SvIOK(ST(i + 1)))
15c104e2 541 croak("add_symbol: first_line_num must be an integer");
76f7c306 542 first_line_num = SvIV(ST(i + 1));
543 }
544 else if (strEQ(key, "last_line_num")) {
545 if (!SvIOK(ST(i + 1)))
15c104e2 546 croak("add_symbol: last_line_num must be an integer");
76f7c306 547 last_line_num = SvIV(ST(i + 1));
548 }
549 }
550
d1d0e437 551 if (!filename || first_line_num == -1) {
d1d0e437 552 if (!filename)
e0162997 553 filename = CopFILE(PL_curcop);
d1d0e437 554 if (first_line_num == -1)
e0162997 555 first_line_num = PL_curcop->cop_line;
d1d0e437 556 }
557
558 if (last_line_num == -1)
559 last_line_num = first_line_num;
560
e290a036 561 name = newSVsv(_get_name(self));
562 sv_catpvs(name, "::");
563 sv_catsv(name, variable.name);
564
d1d0e437 565 /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */
566 dbsub = get_hv("DB::sub", 1);
567 dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num);
4849f4fc 568 if (!hv_store_ent(dbsub, name, dbval, 0)) {
569 warn("Failed to update $DB::sub for subroutine %s",
570 SvPV_nolen(name));
d1d0e437 571 SvREFCNT_dec(dbval);
76f7c306 572 }
e290a036 573
574 SvREFCNT_dec(name);
76f7c306 575 }
76f7c306 576
9aa6fe4f 577 /* GV_ADDMULTI rather than GV_ADD because otherwise you get 'used only
578 * once' warnings in some situations... i can't reproduce this, but CMOP
579 * triggers it */
e290a036 580 namespace = _get_namespace(self);
581 entry = hv_fetch_ent(namespace, variable.name, 0, 0);
582 if (entry) {
583 glob = (GV*)HeVAL(entry);
584 }
585 else {
8a78ba15 586 char *varname_pv;
587 STRLEN varname_len;
e290a036 588 glob = (GV*)newSV(0);
8a78ba15 589 varname_pv = SvPV(variable.name, varname_len);
590 gv_init(glob, namespace, varname_pv, varname_len, 1);
e290a036 591 if (!hv_store_ent(namespace, variable.name, (SV*)glob, 0)) {
592 croak("hv_store failed");
593 }
594 }
76f7c306 595
596 if (initial) {
597 SV *val;
598
599 if (SvROK(initial)) {
600 val = SvRV(initial);
a2fec41a 601 SvREFCNT_inc_simple_void_NN(val);
76f7c306 602 }
603 else {
604 val = newSVsv(initial);
605 }
606
607 switch (variable.type) {
608 case VAR_SCALAR:
d551a208 609 GvSetSV(glob, val);
76f7c306 610 break;
611 case VAR_ARRAY:
d551a208 612 GvSetAV(glob, val);
76f7c306 613 break;
614 case VAR_HASH:
d551a208 615 GvSetHV(glob, val);
76f7c306 616 break;
617 case VAR_CODE:
d551a208 618 GvSetCV(glob, val);
76f7c306 619 break;
620 case VAR_IO:
d551a208 621 GvSetIO(glob, val);
76f7c306 622 break;
623 }
624 }
625
626void
4849f4fc 627remove_glob(self, name)
3fd56b4d 628 SV *self
4849f4fc 629 SV *name
3fd56b4d 630 CODE:
4849f4fc 631 hv_delete_ent(_get_namespace(self), name, G_DISCARD, 0);
9b608466 632
34805376 633int
15c104e2 634has_symbol(self, variable)
34805376 635 SV *self
636 varspec_t variable
637 PREINIT:
638 HV *namespace;
4849f4fc 639 HE *entry;
640 SV *val;
34805376 641 CODE:
642 namespace = _get_namespace(self);
4849f4fc 643 entry = hv_fetch_ent(namespace, variable.name, 0, 0);
34805376 644 if (!entry)
645 XSRETURN_UNDEF;
646
4849f4fc 647 val = HeVAL(entry);
648 if (isGV(val)) {
649 GV *glob = (GV*)val;
34805376 650 switch (variable.type) {
651 case VAR_SCALAR:
d551a208 652 RETVAL = GvSVOK(glob) ? 1 : 0;
34805376 653 break;
654 case VAR_ARRAY:
d551a208 655 RETVAL = GvAVOK(glob) ? 1 : 0;
34805376 656 break;
657 case VAR_HASH:
d551a208 658 RETVAL = GvHVOK(glob) ? 1 : 0;
34805376 659 break;
660 case VAR_CODE:
d551a208 661 RETVAL = GvCVOK(glob) ? 1 : 0;
34805376 662 break;
663 case VAR_IO:
d551a208 664 RETVAL = GvIOOK(glob) ? 1 : 0;
34805376 665 break;
666 }
667 }
668 else {
669 RETVAL = (variable.type == VAR_CODE);
670 }
671 OUTPUT:
672 RETVAL
673
e3ad44fd 674SV*
15c104e2 675get_symbol(self, variable)
e3ad44fd 676 SV *self
677 varspec_t variable
678 PREINIT:
fca4ed0c 679 SV *val;
e3ad44fd 680 CODE:
15c104e2 681 val = _get_symbol(self, &variable, 0);
4871b1a0 682 if (!val)
e3ad44fd 683 XSRETURN_UNDEF;
93c36417 684 RETVAL = newRV_inc(val);
4871b1a0 685 OUTPUT:
686 RETVAL
e3ad44fd 687
4871b1a0 688SV*
15c104e2 689get_or_add_symbol(self, variable)
4871b1a0 690 SV *self
691 varspec_t variable
692 PREINIT:
693 SV *val;
694 CODE:
15c104e2 695 val = _get_symbol(self, &variable, 1);
fca4ed0c 696 if (!val)
697 XSRETURN_UNDEF;
93c36417 698 RETVAL = newRV_inc(val);
e3ad44fd 699 OUTPUT:
700 RETVAL
701
9b608466 702void
15c104e2 703remove_symbol(self, variable)
215f49f8 704 SV *self
705 varspec_t variable
706 PREINIT:
707 HV *namespace;
4849f4fc 708 HE *entry;
709 SV *val;
215f49f8 710 CODE:
711 namespace = _get_namespace(self);
4849f4fc 712 entry = hv_fetch_ent(namespace, variable.name, 0, 0);
215f49f8 713 if (!entry)
714 XSRETURN_EMPTY;
715
4849f4fc 716 val = HeVAL(entry);
717 if (isGV(val)) {
718 GV *glob = (GV*)val;
215f49f8 719 switch (variable.type) {
720 case VAR_SCALAR:
d551a208 721 GvSetSV(glob, NULL);
215f49f8 722 break;
723 case VAR_ARRAY:
d551a208 724 GvSetAV(glob, NULL);
215f49f8 725 break;
726 case VAR_HASH:
d551a208 727 GvSetHV(glob, NULL);
215f49f8 728 break;
729 case VAR_CODE:
d551a208 730 GvSetCV(glob, NULL);
215f49f8 731 break;
732 case VAR_IO:
d551a208 733 GvSetIO(glob, NULL);
215f49f8 734 break;
735 }
736 }
737 else {
738 if (variable.type == VAR_CODE) {
4849f4fc 739 hv_delete_ent(namespace, variable.name, G_DISCARD, 0);
215f49f8 740 }
741 }
742
743void
15c104e2 744list_all_symbols(self, vartype=VAR_NONE)
9b608466 745 SV *self
746 vartype_t vartype
747 PPCODE:
748 if (vartype == VAR_NONE) {
749 HV *namespace;
750 HE *entry;
751 int keys;
752
753 namespace = _get_namespace(self);
754 keys = hv_iterinit(namespace);
755 EXTEND(SP, keys);
ebcc8ba8 756 while ((entry = hv_iternext(namespace))) {
13f8a7b7 757 mPUSHs(newSVhe(entry));
9b608466 758 }
759 }
760 else {
761 HV *namespace;
9b608466 762 SV *val;
763 char *key;
64b79211 764 I32 len;
9b608466 765
766 namespace = _get_namespace(self);
767 hv_iterinit(namespace);
ebcc8ba8 768 while ((val = hv_iternextsv(namespace, &key, &len))) {
9b608466 769 GV *gv = (GV*)val;
770 if (isGV(gv)) {
771 switch (vartype) {
772 case VAR_SCALAR:
d551a208 773 if (GvSVOK(val))
9b608466 774 mXPUSHp(key, len);
775 break;
776 case VAR_ARRAY:
d551a208 777 if (GvAVOK(val))
9b608466 778 mXPUSHp(key, len);
779 break;
780 case VAR_HASH:
d551a208 781 if (GvHVOK(val))
9b608466 782 mXPUSHp(key, len);
783 break;
784 case VAR_CODE:
d551a208 785 if (GvCVOK(val))
9b608466 786 mXPUSHp(key, len);
787 break;
788 case VAR_IO:
d551a208 789 if (GvIOOK(val))
9b608466 790 mXPUSHp(key, len);
791 break;
792 }
793 }
794 else if (vartype == VAR_CODE) {
795 mXPUSHp(key, len);
796 }
797 }
798 }
26f802f7 799
d2b55565 800void
801get_all_symbols(self, vartype=VAR_NONE)
802 SV *self
803 vartype_t vartype
804 PREINIT:
805 HV *namespace, *ret;
806 SV *val;
807 char *key;
808 I32 len;
809 PPCODE:
810 namespace = _get_namespace(self);
811 ret = newHV();
812
813 hv_iterinit(namespace);
814 while ((val = hv_iternextsv(namespace, &key, &len))) {
815 GV *gv = (GV*)val;
816
4849f4fc 817 if (!isGV(gv)) {
818 SV *keysv = newSVpvn(key, len);
819 _expand_glob(self, keysv);
820 SvREFCNT_dec(keysv);
821 }
d2b55565 822
823 switch (vartype) {
824 case VAR_SCALAR:
825 if (GvSVOK(val))
826 hv_store(ret, key, len, newRV_inc(GvSV(gv)), 0);
827 break;
828 case VAR_ARRAY:
829 if (GvAVOK(val))
830 hv_store(ret, key, len, newRV_inc((SV*)GvAV(gv)), 0);
831 break;
832 case VAR_HASH:
833 if (GvHVOK(val))
834 hv_store(ret, key, len, newRV_inc((SV*)GvHV(gv)), 0);
835 break;
836 case VAR_CODE:
837 if (GvCVOK(val))
838 hv_store(ret, key, len, newRV_inc((SV*)GvCV(gv)), 0);
839 break;
840 case VAR_IO:
841 if (GvIOOK(val))
842 hv_store(ret, key, len, newRV_inc((SV*)GvIO(gv)), 0);
843 break;
844 case VAR_NONE:
845 hv_store(ret, key, len, SvREFCNT_inc_simple_NN(val), 0);
846 break;
847 }
848 }
849
850 mPUSHs(newRV_noinc((SV*)ret));
851
26f802f7 852BOOT:
853 {
e1b6c960 854 const char *vmre = "\\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\\z";
855#if (PERL_VERSION < 9) || ((PERL_VERSION == 9) && (PERL_SUBVERSION < 5))
856 PMOP fakepmop;
857
858 fakepmop.op_pmflags = 0;
859 valid_module_regex = pregcomp(vmre, vmre + strlen(vmre), &fakepmop);
860#else
78daf8ed 861 SV *re;
862
e1b6c960 863 re = newSVpv(vmre, 0);
78daf8ed 864 valid_module_regex = pregcomp(re, 0);
e1b6c960 865#endif
78daf8ed 866
26f802f7 867 name_key = newSVpvs("name");
868 PERL_HASH(name_hash, "name", 4);
869
870 namespace_key = newSVpvs("namespace");
871 PERL_HASH(namespace_hash, "namespace", 9);
872
873 type_key = newSVpvs("type");
874 PERL_HASH(type_hash, "type", 4);
875 }