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