Commit | Line | Data |
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 | |
d551a208 |
31 | /* HACK: scalar slots are always populated on perl < 5.10, so treat undef |
32 | * as nonexistent. this is consistent with the previous behavior of the pure |
33 | * perl version of this module (since this is the behavior that perl sees |
34 | * in all versions */ |
35 | #if PERL_VERSION < 10 |
36 | #define GvSVOK(g) (GvSV(g) && SvTYPE(GvSV(g)) != SVt_NULL) |
37 | #else |
38 | #define GvSVOK(g) GvSV(g) |
39 | #endif |
40 | |
41 | #define GvAVOK(g) GvAV(g) |
42 | #define GvHVOK(g) GvHV(g) |
43 | #define GvCVOK(g) GvCVu(g) /* XXX: should this really be GvCVu? or GvCV? */ |
44 | #define GvIOOK(g) GvIO(g) |
45 | |
9aa6fe4f |
46 | /* see above - don't let scalar slots become unpopulated, this breaks |
47 | * assumptions in core */ |
3720d1a1 |
48 | #if PERL_VERSION < 10 |
49 | #define GvSetSV(g,v) do { \ |
50 | SV *_v = (SV*)(v); \ |
51 | SvREFCNT_dec(GvSV(g)); \ |
52 | if ((GvSV(g) = _v ? _v : newSV(0))) \ |
53 | GvIMPORTED_SV_on(g); \ |
54 | } while (0) |
55 | #else |
d551a208 |
56 | #define GvSetSV(g,v) do { \ |
57 | SvREFCNT_dec(GvSV(g)); \ |
58 | if ((GvSV(g) = (SV*)(v))) \ |
59 | GvIMPORTED_SV_on(g); \ |
60 | } while (0) |
3720d1a1 |
61 | #endif |
62 | |
d551a208 |
63 | #define GvSetAV(g,v) do { \ |
64 | SvREFCNT_dec(GvAV(g)); \ |
65 | if ((GvAV(g) = (AV*)(v))) \ |
66 | GvIMPORTED_AV_on(g); \ |
67 | } while (0) |
68 | #define GvSetHV(g,v) do { \ |
69 | SvREFCNT_dec(GvHV(g)); \ |
70 | if ((GvHV(g) = (HV*)(v))) \ |
71 | GvIMPORTED_HV_on(g); \ |
72 | } while (0) |
73 | #define GvSetCV(g,v) do { \ |
74 | SvREFCNT_dec(GvCV(g)); \ |
22d15de6 |
75 | if ((GvCV_set(g, v))) { \ |
d551a208 |
76 | GvIMPORTED_CV_on(g); \ |
77 | GvASSUMECV_on(g); \ |
78 | } \ |
79 | GvCVGEN(g) = 0; \ |
80 | mro_method_changed_in(GvSTASH(g)); \ |
81 | } while (0) |
82 | #define GvSetIO(g,v) do { \ |
83 | SvREFCNT_dec(GvIO(g)); \ |
84 | GvIOp(g) = (IO*)(v); \ |
85 | } while (0) |
86 | |
a382a84b |
87 | typedef enum { |
88 | VAR_NONE = 0, |
89 | VAR_SCALAR, |
90 | VAR_ARRAY, |
91 | VAR_HASH, |
92 | VAR_CODE, |
93 | VAR_IO, |
94 | VAR_GLOB, /* TODO: unimplemented */ |
95 | VAR_FORMAT /* TODO: unimplemented */ |
96 | } vartype_t; |
97 | |
98 | typedef struct { |
99 | vartype_t type; |
4849f4fc |
100 | SV *name; |
a382a84b |
101 | } varspec_t; |
102 | |
26f802f7 |
103 | static U32 name_hash, namespace_hash, type_hash; |
104 | static SV *name_key, *namespace_key, *type_key; |
105 | |
76f7c306 |
106 | const char *vartype_to_string(vartype_t type) |
107 | { |
108 | switch (type) { |
109 | case VAR_SCALAR: |
110 | return "SCALAR"; |
111 | case VAR_ARRAY: |
112 | return "ARRAY"; |
113 | case VAR_HASH: |
114 | return "HASH"; |
115 | case VAR_CODE: |
116 | return "CODE"; |
117 | case VAR_IO: |
118 | return "IO"; |
119 | default: |
120 | return "unknown"; |
121 | } |
122 | } |
123 | |
124 | I32 vartype_to_svtype(vartype_t type) |
125 | { |
126 | switch (type) { |
127 | case VAR_SCALAR: |
128 | return SVt_PV; /* or whatever */ |
129 | case VAR_ARRAY: |
130 | return SVt_PVAV; |
131 | case VAR_HASH: |
132 | return SVt_PVHV; |
133 | case VAR_CODE: |
134 | return SVt_PVCV; |
135 | case VAR_IO: |
136 | return SVt_PVIO; |
137 | default: |
138 | return SVt_NULL; |
139 | } |
140 | } |
141 | |
a382a84b |
142 | vartype_t string_to_vartype(char *vartype) |
143 | { |
144 | if (strEQ(vartype, "SCALAR")) { |
145 | return VAR_SCALAR; |
146 | } |
147 | else if (strEQ(vartype, "ARRAY")) { |
148 | return VAR_ARRAY; |
149 | } |
150 | else if (strEQ(vartype, "HASH")) { |
151 | return VAR_HASH; |
152 | } |
153 | else if (strEQ(vartype, "CODE")) { |
154 | return VAR_CODE; |
155 | } |
156 | else if (strEQ(vartype, "IO")) { |
157 | return VAR_IO; |
158 | } |
159 | else { |
f88deb66 |
160 | croak("Type must be one of 'SCALAR', 'ARRAY', 'HASH', 'CODE', or 'IO', not '%s'", vartype); |
a382a84b |
161 | } |
162 | } |
163 | |
4849f4fc |
164 | void _deconstruct_variable_name(SV *variable, varspec_t *varspec) |
a382a84b |
165 | { |
4849f4fc |
166 | char *varpv; |
a382a84b |
167 | |
4849f4fc |
168 | if (!SvCUR(variable)) |
64b79211 |
169 | croak("You must pass a variable name"); |
a382a84b |
170 | |
4849f4fc |
171 | varspec->name = sv_2mortal(newSVsv(variable)); |
172 | |
173 | varpv = SvPV_nolen(varspec->name); |
174 | switch (varpv[0]) { |
a382a84b |
175 | case '$': |
176 | varspec->type = VAR_SCALAR; |
4849f4fc |
177 | sv_chop(varspec->name, &varpv[1]); |
a382a84b |
178 | break; |
179 | case '@': |
180 | varspec->type = VAR_ARRAY; |
4849f4fc |
181 | sv_chop(varspec->name, &varpv[1]); |
a382a84b |
182 | break; |
183 | case '%': |
184 | varspec->type = VAR_HASH; |
4849f4fc |
185 | sv_chop(varspec->name, &varpv[1]); |
a382a84b |
186 | break; |
187 | case '&': |
188 | varspec->type = VAR_CODE; |
4849f4fc |
189 | sv_chop(varspec->name, &varpv[1]); |
64b79211 |
190 | break; |
191 | default: |
a382a84b |
192 | varspec->type = VAR_IO; |
64b79211 |
193 | break; |
a382a84b |
194 | } |
195 | } |
196 | |
197 | void _deconstruct_variable_hash(HV *variable, varspec_t *varspec) |
198 | { |
26f802f7 |
199 | HE *val; |
a382a84b |
200 | |
26f802f7 |
201 | val = hv_fetch_ent(variable, name_key, 0, name_hash); |
a382a84b |
202 | if (!val) |
203 | croak("The 'name' key is required in variable specs"); |
204 | |
061b471e |
205 | varspec->name = sv_2mortal(newSVsv(HeVAL(val))); |
a382a84b |
206 | |
26f802f7 |
207 | val = hv_fetch_ent(variable, type_key, 0, type_hash); |
a382a84b |
208 | if (!val) |
209 | croak("The 'type' key is required in variable specs"); |
210 | |
061b471e |
211 | varspec->type = string_to_vartype(SvPV_nolen(HeVAL(val))); |
a382a84b |
212 | } |
213 | |
214 | int _valid_for_type(SV *value, vartype_t type) |
215 | { |
216 | svtype sv_type = SvROK(value) ? SvTYPE(SvRV(value)) : SVt_NULL; |
217 | |
218 | switch (type) { |
219 | case VAR_SCALAR: |
57011a68 |
220 | /* XXX: something weird is going on here - apparently values can |
221 | * be SVt_NULL but also be SvROK (and also, SVt_NULL isn't SvOK) */ |
222 | if (sv_type == SVt_NULL) |
223 | return 1; |
32107d99 |
224 | return SvROK(value) ? SvOK(SvRV(value)) : SvOK(value); |
a382a84b |
225 | case VAR_ARRAY: |
226 | return sv_type == SVt_PVAV; |
227 | case VAR_HASH: |
228 | return sv_type == SVt_PVHV; |
229 | case VAR_CODE: |
230 | return sv_type == SVt_PVCV; |
231 | case VAR_IO: |
76f7c306 |
232 | return sv_type == SVt_PVIO; |
a382a84b |
233 | default: |
234 | return 0; |
235 | } |
236 | } |
237 | |
3fd56b4d |
238 | HV *_get_namespace(SV *self) |
239 | { |
240 | dSP; |
241 | SV *ret; |
242 | |
243 | PUSHMARK(SP); |
244 | XPUSHs(self); |
245 | PUTBACK; |
246 | |
612dcf3b |
247 | call_method("namespace", G_SCALAR); |
3fd56b4d |
248 | |
249 | SPAGAIN; |
250 | ret = POPs; |
251 | PUTBACK; |
252 | |
253 | return (HV*)SvRV(ret); |
254 | } |
255 | |
76f7c306 |
256 | SV *_get_name(SV *self) |
257 | { |
258 | dSP; |
259 | SV *ret; |
260 | |
261 | PUSHMARK(SP); |
262 | XPUSHs(self); |
263 | PUTBACK; |
264 | |
612dcf3b |
265 | call_method("name", G_SCALAR); |
76f7c306 |
266 | |
267 | SPAGAIN; |
268 | ret = POPs; |
269 | PUTBACK; |
270 | |
271 | return ret; |
272 | } |
273 | |
4849f4fc |
274 | void _expand_glob(SV *self, SV *varname) |
60b395a1 |
275 | { |
4849f4fc |
276 | SV *name; |
60b395a1 |
277 | |
4849f4fc |
278 | name = newSVsv(_get_name(self)); |
279 | sv_catpvs(name, "::"); |
280 | sv_catsv(name, varname); |
60b395a1 |
281 | |
282 | /* can't use gv_init here, because it screws up @ISA in a way that I |
283 | * can't reproduce, but that CMOP triggers */ |
4849f4fc |
284 | gv_fetchsv(name, GV_ADD, SVt_NULL); |
285 | SvREFCNT_dec(name); |
60b395a1 |
286 | } |
287 | |
15c104e2 |
288 | SV *_get_symbol(SV *self, varspec_t *variable, int vivify) |
4871b1a0 |
289 | { |
290 | HV *namespace; |
4849f4fc |
291 | HE *entry; |
4871b1a0 |
292 | GV *glob; |
293 | |
294 | namespace = _get_namespace(self); |
4849f4fc |
295 | entry = hv_fetch_ent(namespace, variable->name, vivify, 0); |
4871b1a0 |
296 | if (!entry) |
297 | return NULL; |
298 | |
4849f4fc |
299 | glob = (GV*)(HeVAL(entry)); |
60b395a1 |
300 | if (!isGV(glob)) |
301 | _expand_glob(self, variable->name); |
4871b1a0 |
302 | |
303 | if (vivify) { |
304 | switch (variable->type) { |
305 | case VAR_SCALAR: |
d551a208 |
306 | if (!GvSVOK(glob)) |
307 | GvSetSV(glob, newSV(0)); |
4871b1a0 |
308 | break; |
309 | case VAR_ARRAY: |
d551a208 |
310 | if (!GvAVOK(glob)) |
311 | GvSetAV(glob, newAV()); |
4871b1a0 |
312 | break; |
313 | case VAR_HASH: |
d551a208 |
314 | if (!GvHVOK(glob)) |
315 | GvSetHV(glob, newHV()); |
4871b1a0 |
316 | break; |
317 | case VAR_CODE: |
318 | croak("Don't know how to vivify CODE variables"); |
319 | case VAR_IO: |
d551a208 |
320 | if (!GvIOOK(glob)) |
321 | GvSetIO(glob, newIO()); |
4871b1a0 |
322 | break; |
323 | default: |
324 | croak("Unknown type in vivication"); |
325 | } |
326 | } |
327 | |
328 | switch (variable->type) { |
329 | case VAR_SCALAR: |
330 | return GvSV(glob); |
331 | case VAR_ARRAY: |
332 | return (SV*)GvAV(glob); |
333 | case VAR_HASH: |
334 | return (SV*)GvHV(glob); |
335 | case VAR_CODE: |
336 | return (SV*)GvCV(glob); |
337 | case VAR_IO: |
338 | return (SV*)GvIO(glob); |
339 | default: |
340 | return NULL; |
341 | } |
342 | } |
343 | |
c53d2df2 |
344 | MODULE = Package::Stash::XS PACKAGE = Package::Stash::XS |
59017825 |
345 | |
be2a7e99 |
346 | PROTOTYPES: DISABLE |
347 | |
59017825 |
348 | SV* |
349 | new(class, package_name) |
4849f4fc |
350 | SV *class |
59017825 |
351 | SV *package_name |
3496f1e8 |
352 | PREINIT: |
59017825 |
353 | HV *instance; |
354 | HV *namespace; |
1d6c978b |
355 | SV *nsref; |
59017825 |
356 | CODE: |
357 | if (!SvPOK(package_name)) |
358 | croak("The constructor argument must be the name of a package"); |
359 | |
6c3e69c6 |
360 | instance = newHV(); |
59017825 |
361 | |
1d6c978b |
362 | if (!hv_store(instance, "name", 4, SvREFCNT_inc_simple_NN(package_name), 0)) { |
363 | SvREFCNT_dec(package_name); |
c86a1630 |
364 | SvREFCNT_dec(instance); |
e8d57afd |
365 | croak("Couldn't initialize the 'name' key, hv_store failed"); |
1d6c978b |
366 | } |
59017825 |
367 | namespace = gv_stashpv(SvPV_nolen(package_name), GV_ADD); |
1d6c978b |
368 | nsref = newRV_inc((SV*)namespace); |
369 | if (!hv_store(instance, "namespace", 9, nsref, 0)) { |
370 | SvREFCNT_dec(nsref); |
c86a1630 |
371 | SvREFCNT_dec(instance); |
e8d57afd |
372 | croak("Couldn't initialize the 'namespace' key, hv_store failed"); |
1d6c978b |
373 | } |
59017825 |
374 | |
4849f4fc |
375 | RETVAL = sv_bless(newRV_noinc((SV*)instance), gv_stashsv(class, 0)); |
59017825 |
376 | OUTPUT: |
377 | RETVAL |
194acf47 |
378 | |
379 | SV* |
380 | name(self) |
381 | SV *self |
3496f1e8 |
382 | PREINIT: |
26f802f7 |
383 | HE *slot; |
194acf47 |
384 | CODE: |
385 | if (!sv_isobject(self)) |
386 | croak("Can't call name as a class method"); |
26f802f7 |
387 | slot = hv_fetch_ent((HV*)SvRV(self), name_key, 0, name_hash); |
388 | RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef; |
194acf47 |
389 | OUTPUT: |
390 | RETVAL |
391 | |
392 | SV* |
393 | namespace(self) |
394 | SV *self |
3496f1e8 |
395 | PREINIT: |
26f802f7 |
396 | HE *slot; |
194acf47 |
397 | CODE: |
398 | if (!sv_isobject(self)) |
399 | croak("Can't call namespace as a class method"); |
26f802f7 |
400 | slot = hv_fetch_ent((HV*)SvRV(self), namespace_key, 0, namespace_hash); |
401 | RETVAL = slot ? SvREFCNT_inc_simple_NN(HeVAL(slot)) : &PL_sv_undef; |
194acf47 |
402 | OUTPUT: |
403 | RETVAL |
3fd56b4d |
404 | |
405 | void |
15c104e2 |
406 | add_symbol(self, variable, initial=NULL, ...) |
76f7c306 |
407 | SV *self |
408 | varspec_t variable |
409 | SV *initial |
410 | PREINIT: |
411 | SV *name; |
412 | GV *glob; |
413 | CODE: |
414 | if (initial && !_valid_for_type(initial, variable.type)) |
415 | croak("%s is not of type %s", |
416 | SvPV_nolen(initial), vartype_to_string(variable.type)); |
417 | |
418 | name = newSVsv(_get_name(self)); |
419 | sv_catpvs(name, "::"); |
4849f4fc |
420 | sv_catsv(name, variable.name); |
76f7c306 |
421 | |
76f7c306 |
422 | if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) { |
423 | int i; |
4849f4fc |
424 | char *filename = NULL; |
d1d0e437 |
425 | I32 first_line_num = -1, last_line_num = -1; |
426 | STRLEN namelen; |
427 | SV *dbval; |
428 | HV *dbsub; |
76f7c306 |
429 | |
430 | if ((items - 3) % 2) |
15c104e2 |
431 | croak("add_symbol: Odd number of elements in %%opts"); |
76f7c306 |
432 | |
433 | for (i = 3; i < items; i += 2) { |
434 | char *key; |
435 | key = SvPV_nolen(ST(i)); |
436 | if (strEQ(key, "filename")) { |
437 | if (!SvPOK(ST(i + 1))) |
15c104e2 |
438 | croak("add_symbol: filename must be a string"); |
76f7c306 |
439 | filename = SvPV_nolen(ST(i + 1)); |
440 | } |
441 | else if (strEQ(key, "first_line_num")) { |
442 | if (!SvIOK(ST(i + 1))) |
15c104e2 |
443 | croak("add_symbol: first_line_num must be an integer"); |
76f7c306 |
444 | first_line_num = SvIV(ST(i + 1)); |
445 | } |
446 | else if (strEQ(key, "last_line_num")) { |
447 | if (!SvIOK(ST(i + 1))) |
15c104e2 |
448 | croak("add_symbol: last_line_num must be an integer"); |
76f7c306 |
449 | last_line_num = SvIV(ST(i + 1)); |
450 | } |
451 | } |
452 | |
d1d0e437 |
453 | if (!filename || first_line_num == -1) { |
d1d0e437 |
454 | if (!filename) |
e0162997 |
455 | filename = CopFILE(PL_curcop); |
d1d0e437 |
456 | if (first_line_num == -1) |
e0162997 |
457 | first_line_num = PL_curcop->cop_line; |
d1d0e437 |
458 | } |
459 | |
460 | if (last_line_num == -1) |
461 | last_line_num = first_line_num; |
462 | |
463 | /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */ |
464 | dbsub = get_hv("DB::sub", 1); |
465 | dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num); |
4849f4fc |
466 | if (!hv_store_ent(dbsub, name, dbval, 0)) { |
467 | warn("Failed to update $DB::sub for subroutine %s", |
468 | SvPV_nolen(name)); |
d1d0e437 |
469 | SvREFCNT_dec(dbval); |
76f7c306 |
470 | } |
471 | } |
76f7c306 |
472 | |
9aa6fe4f |
473 | /* GV_ADDMULTI rather than GV_ADD because otherwise you get 'used only |
474 | * once' warnings in some situations... i can't reproduce this, but CMOP |
475 | * triggers it */ |
fedea7f9 |
476 | glob = gv_fetchsv(name, GV_ADDMULTI, vartype_to_svtype(variable.type)); |
76f7c306 |
477 | |
478 | if (initial) { |
479 | SV *val; |
480 | |
481 | if (SvROK(initial)) { |
482 | val = SvRV(initial); |
a2fec41a |
483 | SvREFCNT_inc_simple_void_NN(val); |
76f7c306 |
484 | } |
485 | else { |
486 | val = newSVsv(initial); |
487 | } |
488 | |
489 | switch (variable.type) { |
490 | case VAR_SCALAR: |
d551a208 |
491 | GvSetSV(glob, val); |
76f7c306 |
492 | break; |
493 | case VAR_ARRAY: |
d551a208 |
494 | GvSetAV(glob, val); |
76f7c306 |
495 | break; |
496 | case VAR_HASH: |
d551a208 |
497 | GvSetHV(glob, val); |
76f7c306 |
498 | break; |
499 | case VAR_CODE: |
d551a208 |
500 | GvSetCV(glob, val); |
76f7c306 |
501 | break; |
502 | case VAR_IO: |
d551a208 |
503 | GvSetIO(glob, val); |
76f7c306 |
504 | break; |
505 | } |
506 | } |
507 | |
5bb2b07b |
508 | SvREFCNT_dec(name); |
509 | |
76f7c306 |
510 | void |
4849f4fc |
511 | remove_glob(self, name) |
3fd56b4d |
512 | SV *self |
4849f4fc |
513 | SV *name |
3fd56b4d |
514 | CODE: |
4849f4fc |
515 | hv_delete_ent(_get_namespace(self), name, G_DISCARD, 0); |
9b608466 |
516 | |
34805376 |
517 | int |
15c104e2 |
518 | has_symbol(self, variable) |
34805376 |
519 | SV *self |
520 | varspec_t variable |
521 | PREINIT: |
522 | HV *namespace; |
4849f4fc |
523 | HE *entry; |
524 | SV *val; |
34805376 |
525 | CODE: |
526 | namespace = _get_namespace(self); |
4849f4fc |
527 | entry = hv_fetch_ent(namespace, variable.name, 0, 0); |
34805376 |
528 | if (!entry) |
529 | XSRETURN_UNDEF; |
530 | |
4849f4fc |
531 | val = HeVAL(entry); |
532 | if (isGV(val)) { |
533 | GV *glob = (GV*)val; |
34805376 |
534 | switch (variable.type) { |
535 | case VAR_SCALAR: |
d551a208 |
536 | RETVAL = GvSVOK(glob) ? 1 : 0; |
34805376 |
537 | break; |
538 | case VAR_ARRAY: |
d551a208 |
539 | RETVAL = GvAVOK(glob) ? 1 : 0; |
34805376 |
540 | break; |
541 | case VAR_HASH: |
d551a208 |
542 | RETVAL = GvHVOK(glob) ? 1 : 0; |
34805376 |
543 | break; |
544 | case VAR_CODE: |
d551a208 |
545 | RETVAL = GvCVOK(glob) ? 1 : 0; |
34805376 |
546 | break; |
547 | case VAR_IO: |
d551a208 |
548 | RETVAL = GvIOOK(glob) ? 1 : 0; |
34805376 |
549 | break; |
550 | } |
551 | } |
552 | else { |
553 | RETVAL = (variable.type == VAR_CODE); |
554 | } |
555 | OUTPUT: |
556 | RETVAL |
557 | |
e3ad44fd |
558 | SV* |
15c104e2 |
559 | get_symbol(self, variable) |
e3ad44fd |
560 | SV *self |
561 | varspec_t variable |
562 | PREINIT: |
fca4ed0c |
563 | SV *val; |
e3ad44fd |
564 | CODE: |
15c104e2 |
565 | val = _get_symbol(self, &variable, 0); |
4871b1a0 |
566 | if (!val) |
e3ad44fd |
567 | XSRETURN_UNDEF; |
93c36417 |
568 | RETVAL = newRV_inc(val); |
4871b1a0 |
569 | OUTPUT: |
570 | RETVAL |
e3ad44fd |
571 | |
4871b1a0 |
572 | SV* |
15c104e2 |
573 | get_or_add_symbol(self, variable) |
4871b1a0 |
574 | SV *self |
575 | varspec_t variable |
576 | PREINIT: |
577 | SV *val; |
578 | CODE: |
15c104e2 |
579 | val = _get_symbol(self, &variable, 1); |
fca4ed0c |
580 | if (!val) |
581 | XSRETURN_UNDEF; |
93c36417 |
582 | RETVAL = newRV_inc(val); |
e3ad44fd |
583 | OUTPUT: |
584 | RETVAL |
585 | |
9b608466 |
586 | void |
15c104e2 |
587 | remove_symbol(self, variable) |
215f49f8 |
588 | SV *self |
589 | varspec_t variable |
590 | PREINIT: |
591 | HV *namespace; |
4849f4fc |
592 | HE *entry; |
593 | SV *val; |
215f49f8 |
594 | CODE: |
595 | namespace = _get_namespace(self); |
4849f4fc |
596 | entry = hv_fetch_ent(namespace, variable.name, 0, 0); |
215f49f8 |
597 | if (!entry) |
598 | XSRETURN_EMPTY; |
599 | |
4849f4fc |
600 | val = HeVAL(entry); |
601 | if (isGV(val)) { |
602 | GV *glob = (GV*)val; |
215f49f8 |
603 | switch (variable.type) { |
604 | case VAR_SCALAR: |
d551a208 |
605 | GvSetSV(glob, NULL); |
215f49f8 |
606 | break; |
607 | case VAR_ARRAY: |
d551a208 |
608 | GvSetAV(glob, NULL); |
215f49f8 |
609 | break; |
610 | case VAR_HASH: |
d551a208 |
611 | GvSetHV(glob, NULL); |
215f49f8 |
612 | break; |
613 | case VAR_CODE: |
d551a208 |
614 | GvSetCV(glob, NULL); |
215f49f8 |
615 | break; |
616 | case VAR_IO: |
d551a208 |
617 | GvSetIO(glob, NULL); |
215f49f8 |
618 | break; |
619 | } |
620 | } |
621 | else { |
622 | if (variable.type == VAR_CODE) { |
4849f4fc |
623 | hv_delete_ent(namespace, variable.name, G_DISCARD, 0); |
215f49f8 |
624 | } |
625 | } |
626 | |
627 | void |
15c104e2 |
628 | list_all_symbols(self, vartype=VAR_NONE) |
9b608466 |
629 | SV *self |
630 | vartype_t vartype |
631 | PPCODE: |
632 | if (vartype == VAR_NONE) { |
633 | HV *namespace; |
634 | HE *entry; |
635 | int keys; |
636 | |
637 | namespace = _get_namespace(self); |
638 | keys = hv_iterinit(namespace); |
639 | EXTEND(SP, keys); |
ebcc8ba8 |
640 | while ((entry = hv_iternext(namespace))) { |
13f8a7b7 |
641 | mPUSHs(newSVhe(entry)); |
9b608466 |
642 | } |
643 | } |
644 | else { |
645 | HV *namespace; |
9b608466 |
646 | SV *val; |
647 | char *key; |
64b79211 |
648 | I32 len; |
9b608466 |
649 | |
650 | namespace = _get_namespace(self); |
651 | hv_iterinit(namespace); |
ebcc8ba8 |
652 | while ((val = hv_iternextsv(namespace, &key, &len))) { |
9b608466 |
653 | GV *gv = (GV*)val; |
654 | if (isGV(gv)) { |
655 | switch (vartype) { |
656 | case VAR_SCALAR: |
d551a208 |
657 | if (GvSVOK(val)) |
9b608466 |
658 | mXPUSHp(key, len); |
659 | break; |
660 | case VAR_ARRAY: |
d551a208 |
661 | if (GvAVOK(val)) |
9b608466 |
662 | mXPUSHp(key, len); |
663 | break; |
664 | case VAR_HASH: |
d551a208 |
665 | if (GvHVOK(val)) |
9b608466 |
666 | mXPUSHp(key, len); |
667 | break; |
668 | case VAR_CODE: |
d551a208 |
669 | if (GvCVOK(val)) |
9b608466 |
670 | mXPUSHp(key, len); |
671 | break; |
672 | case VAR_IO: |
d551a208 |
673 | if (GvIOOK(val)) |
9b608466 |
674 | mXPUSHp(key, len); |
675 | break; |
676 | } |
677 | } |
678 | else if (vartype == VAR_CODE) { |
679 | mXPUSHp(key, len); |
680 | } |
681 | } |
682 | } |
26f802f7 |
683 | |
d2b55565 |
684 | void |
685 | get_all_symbols(self, vartype=VAR_NONE) |
686 | SV *self |
687 | vartype_t vartype |
688 | PREINIT: |
689 | HV *namespace, *ret; |
690 | SV *val; |
691 | char *key; |
692 | I32 len; |
693 | PPCODE: |
694 | namespace = _get_namespace(self); |
695 | ret = newHV(); |
696 | |
697 | hv_iterinit(namespace); |
698 | while ((val = hv_iternextsv(namespace, &key, &len))) { |
699 | GV *gv = (GV*)val; |
700 | |
4849f4fc |
701 | if (!isGV(gv)) { |
702 | SV *keysv = newSVpvn(key, len); |
703 | _expand_glob(self, keysv); |
704 | SvREFCNT_dec(keysv); |
705 | } |
d2b55565 |
706 | |
707 | switch (vartype) { |
708 | case VAR_SCALAR: |
709 | if (GvSVOK(val)) |
710 | hv_store(ret, key, len, newRV_inc(GvSV(gv)), 0); |
711 | break; |
712 | case VAR_ARRAY: |
713 | if (GvAVOK(val)) |
714 | hv_store(ret, key, len, newRV_inc((SV*)GvAV(gv)), 0); |
715 | break; |
716 | case VAR_HASH: |
717 | if (GvHVOK(val)) |
718 | hv_store(ret, key, len, newRV_inc((SV*)GvHV(gv)), 0); |
719 | break; |
720 | case VAR_CODE: |
721 | if (GvCVOK(val)) |
722 | hv_store(ret, key, len, newRV_inc((SV*)GvCV(gv)), 0); |
723 | break; |
724 | case VAR_IO: |
725 | if (GvIOOK(val)) |
726 | hv_store(ret, key, len, newRV_inc((SV*)GvIO(gv)), 0); |
727 | break; |
728 | case VAR_NONE: |
729 | hv_store(ret, key, len, SvREFCNT_inc_simple_NN(val), 0); |
730 | break; |
731 | } |
732 | } |
733 | |
734 | mPUSHs(newRV_noinc((SV*)ret)); |
735 | |
26f802f7 |
736 | BOOT: |
737 | { |
738 | name_key = newSVpvs("name"); |
739 | PERL_HASH(name_hash, "name", 4); |
740 | |
741 | namespace_key = newSVpvs("namespace"); |
742 | PERL_HASH(namespace_hash, "namespace", 9); |
743 | |
744 | type_key = newSVpvs("type"); |
745 | PERL_HASH(type_hash, "type", 4); |
746 | } |