1 | /* universal.c |
---|
2 | * |
---|
3 | * Copyright (c) 1997-2002, Larry Wall |
---|
4 | * |
---|
5 | * You may distribute under the terms of either the GNU General Public |
---|
6 | * License or the Artistic License, as specified in the README file. |
---|
7 | * |
---|
8 | */ |
---|
9 | |
---|
10 | /* |
---|
11 | * "The roots of those mountains must be roots indeed; there must be |
---|
12 | * great secrets buried there which have not been discovered since the |
---|
13 | * beginning." --Gandalf, relating Gollum's story |
---|
14 | */ |
---|
15 | |
---|
16 | #include "EXTERN.h" |
---|
17 | #define PERL_IN_UNIVERSAL_C |
---|
18 | #include "perl.h" |
---|
19 | |
---|
20 | /* |
---|
21 | * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> |
---|
22 | * The main guts of traverse_isa was actually copied from gv_fetchmeth |
---|
23 | */ |
---|
24 | |
---|
25 | STATIC SV * |
---|
26 | S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, |
---|
27 | int len, int level) |
---|
28 | { |
---|
29 | AV* av; |
---|
30 | GV* gv; |
---|
31 | GV** gvp; |
---|
32 | HV* hv = Nullhv; |
---|
33 | SV* subgen = Nullsv; |
---|
34 | |
---|
35 | /* A stash/class can go by many names (ie. User == main::User), so |
---|
36 | we compare the stash itself just in case */ |
---|
37 | if (name_stash && (stash == name_stash)) |
---|
38 | return &PL_sv_yes; |
---|
39 | |
---|
40 | if (strEQ(HvNAME(stash), name)) |
---|
41 | return &PL_sv_yes; |
---|
42 | |
---|
43 | if (level > 100) |
---|
44 | Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", |
---|
45 | HvNAME(stash)); |
---|
46 | |
---|
47 | gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); |
---|
48 | |
---|
49 | if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) |
---|
50 | && (hv = GvHV(gv))) |
---|
51 | { |
---|
52 | if (SvIV(subgen) == (IV)PL_sub_generation) { |
---|
53 | SV* sv; |
---|
54 | SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); |
---|
55 | if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { |
---|
56 | DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", |
---|
57 | name, HvNAME(stash)) ); |
---|
58 | return sv; |
---|
59 | } |
---|
60 | } |
---|
61 | else { |
---|
62 | DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", |
---|
63 | HvNAME(stash)) ); |
---|
64 | hv_clear(hv); |
---|
65 | sv_setiv(subgen, PL_sub_generation); |
---|
66 | } |
---|
67 | } |
---|
68 | |
---|
69 | gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); |
---|
70 | |
---|
71 | if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { |
---|
72 | if (!hv || !subgen) { |
---|
73 | gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); |
---|
74 | |
---|
75 | gv = *gvp; |
---|
76 | |
---|
77 | if (SvTYPE(gv) != SVt_PVGV) |
---|
78 | gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); |
---|
79 | |
---|
80 | if (!hv) |
---|
81 | hv = GvHVn(gv); |
---|
82 | if (!subgen) { |
---|
83 | subgen = newSViv(PL_sub_generation); |
---|
84 | GvSV(gv) = subgen; |
---|
85 | } |
---|
86 | } |
---|
87 | if (hv) { |
---|
88 | SV** svp = AvARRAY(av); |
---|
89 | /* NOTE: No support for tied ISA */ |
---|
90 | I32 items = AvFILLp(av) + 1; |
---|
91 | while (items--) { |
---|
92 | SV* sv = *svp++; |
---|
93 | HV* basestash = gv_stashsv(sv, FALSE); |
---|
94 | if (!basestash) { |
---|
95 | if (ckWARN(WARN_MISC)) |
---|
96 | Perl_warner(aTHX_ packWARN(WARN_SYNTAX), |
---|
97 | "Can't locate package %s for @%s::ISA", |
---|
98 | SvPVX(sv), HvNAME(stash)); |
---|
99 | continue; |
---|
100 | } |
---|
101 | if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, |
---|
102 | len, level + 1)) { |
---|
103 | (void)hv_store(hv,name,len,&PL_sv_yes,0); |
---|
104 | return &PL_sv_yes; |
---|
105 | } |
---|
106 | } |
---|
107 | (void)hv_store(hv,name,len,&PL_sv_no,0); |
---|
108 | } |
---|
109 | } |
---|
110 | |
---|
111 | return boolSV(strEQ(name, "UNIVERSAL")); |
---|
112 | } |
---|
113 | |
---|
114 | /* |
---|
115 | =head1 SV Manipulation Functions |
---|
116 | |
---|
117 | =for apidoc sv_derived_from |
---|
118 | |
---|
119 | Returns a boolean indicating whether the SV is derived from the specified |
---|
120 | class. This is the function that implements C<UNIVERSAL::isa>. It works |
---|
121 | for class names as well as for objects. |
---|
122 | |
---|
123 | =cut |
---|
124 | */ |
---|
125 | |
---|
126 | bool |
---|
127 | Perl_sv_derived_from(pTHX_ SV *sv, const char *name) |
---|
128 | { |
---|
129 | char *type; |
---|
130 | HV *stash; |
---|
131 | HV *name_stash; |
---|
132 | |
---|
133 | stash = Nullhv; |
---|
134 | type = Nullch; |
---|
135 | |
---|
136 | if (SvGMAGICAL(sv)) |
---|
137 | mg_get(sv) ; |
---|
138 | |
---|
139 | if (SvROK(sv)) { |
---|
140 | sv = SvRV(sv); |
---|
141 | type = sv_reftype(sv,0); |
---|
142 | if (SvOBJECT(sv)) |
---|
143 | stash = SvSTASH(sv); |
---|
144 | } |
---|
145 | else { |
---|
146 | stash = gv_stashsv(sv, FALSE); |
---|
147 | } |
---|
148 | |
---|
149 | name_stash = gv_stashpv(name, FALSE); |
---|
150 | |
---|
151 | return (type && strEQ(type,name)) || |
---|
152 | (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) |
---|
153 | == &PL_sv_yes) |
---|
154 | ? TRUE |
---|
155 | : FALSE ; |
---|
156 | } |
---|
157 | |
---|
158 | #include "XSUB.h" |
---|
159 | |
---|
160 | void XS_UNIVERSAL_isa(pTHX_ CV *cv); |
---|
161 | void XS_UNIVERSAL_can(pTHX_ CV *cv); |
---|
162 | void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); |
---|
163 | XS(XS_utf8_valid); |
---|
164 | XS(XS_utf8_encode); |
---|
165 | XS(XS_utf8_decode); |
---|
166 | XS(XS_utf8_upgrade); |
---|
167 | XS(XS_utf8_downgrade); |
---|
168 | XS(XS_utf8_unicode_to_native); |
---|
169 | XS(XS_utf8_native_to_unicode); |
---|
170 | XS(XS_Internals_SvREADONLY); |
---|
171 | XS(XS_Internals_SvREFCNT); |
---|
172 | XS(XS_Internals_hv_clear_placehold); |
---|
173 | |
---|
174 | void |
---|
175 | Perl_boot_core_UNIVERSAL(pTHX) |
---|
176 | { |
---|
177 | char *file = __FILE__; |
---|
178 | |
---|
179 | newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); |
---|
180 | newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); |
---|
181 | newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); |
---|
182 | newXS("utf8::valid", XS_utf8_valid, file); |
---|
183 | newXS("utf8::encode", XS_utf8_encode, file); |
---|
184 | newXS("utf8::decode", XS_utf8_decode, file); |
---|
185 | newXS("utf8::upgrade", XS_utf8_upgrade, file); |
---|
186 | newXS("utf8::downgrade", XS_utf8_downgrade, file); |
---|
187 | newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file); |
---|
188 | newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file); |
---|
189 | newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$"); |
---|
190 | newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$"); |
---|
191 | newXSproto("Internals::hv_clear_placeholders", |
---|
192 | XS_Internals_hv_clear_placehold, file, "\\%"); |
---|
193 | } |
---|
194 | |
---|
195 | |
---|
196 | XS(XS_UNIVERSAL_isa) |
---|
197 | { |
---|
198 | dXSARGS; |
---|
199 | SV *sv; |
---|
200 | char *name; |
---|
201 | STRLEN n_a; |
---|
202 | |
---|
203 | if (items != 2) |
---|
204 | Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); |
---|
205 | |
---|
206 | sv = ST(0); |
---|
207 | |
---|
208 | if (SvGMAGICAL(sv)) |
---|
209 | mg_get(sv); |
---|
210 | |
---|
211 | if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) |
---|
212 | XSRETURN_UNDEF; |
---|
213 | |
---|
214 | name = (char *)SvPV(ST(1),n_a); |
---|
215 | |
---|
216 | ST(0) = boolSV(sv_derived_from(sv, name)); |
---|
217 | XSRETURN(1); |
---|
218 | } |
---|
219 | |
---|
220 | XS(XS_UNIVERSAL_can) |
---|
221 | { |
---|
222 | dXSARGS; |
---|
223 | SV *sv; |
---|
224 | char *name; |
---|
225 | SV *rv; |
---|
226 | HV *pkg = NULL; |
---|
227 | STRLEN n_a; |
---|
228 | |
---|
229 | if (items != 2) |
---|
230 | Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)"); |
---|
231 | |
---|
232 | sv = ST(0); |
---|
233 | |
---|
234 | if (SvGMAGICAL(sv)) |
---|
235 | mg_get(sv); |
---|
236 | |
---|
237 | if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) |
---|
238 | XSRETURN_UNDEF; |
---|
239 | |
---|
240 | name = (char *)SvPV(ST(1),n_a); |
---|
241 | rv = &PL_sv_undef; |
---|
242 | |
---|
243 | if (SvROK(sv)) { |
---|
244 | sv = (SV*)SvRV(sv); |
---|
245 | if (SvOBJECT(sv)) |
---|
246 | pkg = SvSTASH(sv); |
---|
247 | } |
---|
248 | else { |
---|
249 | pkg = gv_stashsv(sv, FALSE); |
---|
250 | } |
---|
251 | |
---|
252 | if (pkg) { |
---|
253 | GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE); |
---|
254 | if (gv && isGV(gv)) |
---|
255 | rv = sv_2mortal(newRV((SV*)GvCV(gv))); |
---|
256 | } |
---|
257 | |
---|
258 | ST(0) = rv; |
---|
259 | XSRETURN(1); |
---|
260 | } |
---|
261 | |
---|
262 | XS(XS_UNIVERSAL_VERSION) |
---|
263 | { |
---|
264 | dXSARGS; |
---|
265 | HV *pkg; |
---|
266 | GV **gvp; |
---|
267 | GV *gv; |
---|
268 | SV *sv; |
---|
269 | char *undef; |
---|
270 | |
---|
271 | if (SvROK(ST(0))) { |
---|
272 | sv = (SV*)SvRV(ST(0)); |
---|
273 | if (!SvOBJECT(sv)) |
---|
274 | Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); |
---|
275 | pkg = SvSTASH(sv); |
---|
276 | } |
---|
277 | else { |
---|
278 | pkg = gv_stashsv(ST(0), FALSE); |
---|
279 | } |
---|
280 | |
---|
281 | gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); |
---|
282 | |
---|
283 | if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) { |
---|
284 | SV *nsv = sv_newmortal(); |
---|
285 | sv_setsv(nsv, sv); |
---|
286 | sv = nsv; |
---|
287 | undef = Nullch; |
---|
288 | } |
---|
289 | else { |
---|
290 | sv = (SV*)&PL_sv_undef; |
---|
291 | undef = "(undef)"; |
---|
292 | } |
---|
293 | |
---|
294 | if (items > 1) { |
---|
295 | STRLEN len; |
---|
296 | SV *req = ST(1); |
---|
297 | |
---|
298 | if (undef) { |
---|
299 | if (pkg) |
---|
300 | Perl_croak(aTHX_ |
---|
301 | "%s does not define $%s::VERSION--version check failed", |
---|
302 | HvNAME(pkg), HvNAME(pkg)); |
---|
303 | else { |
---|
304 | char *str = SvPVx(ST(0), len); |
---|
305 | |
---|
306 | Perl_croak(aTHX_ |
---|
307 | "%s defines neither package nor VERSION--version check failed", str); |
---|
308 | } |
---|
309 | } |
---|
310 | if (!SvNIOK(sv) && SvPOK(sv)) { |
---|
311 | char *str = SvPVx(sv,len); |
---|
312 | while (len) { |
---|
313 | --len; |
---|
314 | /* XXX could DWIM "1.2.3" here */ |
---|
315 | if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_') |
---|
316 | break; |
---|
317 | } |
---|
318 | if (len) { |
---|
319 | if (SvNOK(req) && SvPOK(req)) { |
---|
320 | /* they said C<use Foo v1.2.3> and $Foo::VERSION |
---|
321 | * doesn't look like a float: do string compare */ |
---|
322 | if (sv_cmp(req,sv) == 1) { |
---|
323 | Perl_croak(aTHX_ "%s v%"VDf" required--" |
---|
324 | "this is only v%"VDf, |
---|
325 | HvNAME(pkg), req, sv); |
---|
326 | } |
---|
327 | goto finish; |
---|
328 | } |
---|
329 | /* they said C<use Foo 1.002_003> and $Foo::VERSION |
---|
330 | * doesn't look like a float: force numeric compare */ |
---|
331 | (void)SvUPGRADE(sv, SVt_PVNV); |
---|
332 | SvNVX(sv) = str_to_version(sv); |
---|
333 | SvPOK_off(sv); |
---|
334 | SvNOK_on(sv); |
---|
335 | } |
---|
336 | } |
---|
337 | /* if we get here, we're looking for a numeric comparison, |
---|
338 | * so force the required version into a float, even if they |
---|
339 | * said C<use Foo v1.2.3> */ |
---|
340 | if (SvNOK(req) && SvPOK(req)) { |
---|
341 | NV n = SvNV(req); |
---|
342 | req = sv_newmortal(); |
---|
343 | sv_setnv(req, n); |
---|
344 | } |
---|
345 | |
---|
346 | if (SvNV(req) > SvNV(sv)) |
---|
347 | Perl_croak(aTHX_ "%s version %s required--this is only version %s", |
---|
348 | HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv)); |
---|
349 | } |
---|
350 | |
---|
351 | finish: |
---|
352 | ST(0) = sv; |
---|
353 | |
---|
354 | XSRETURN(1); |
---|
355 | } |
---|
356 | |
---|
357 | XS(XS_utf8_valid) |
---|
358 | { |
---|
359 | dXSARGS; |
---|
360 | if (items != 1) |
---|
361 | Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); |
---|
362 | { |
---|
363 | SV * sv = ST(0); |
---|
364 | { |
---|
365 | STRLEN len; |
---|
366 | char *s = SvPV(sv,len); |
---|
367 | if (!SvUTF8(sv) || is_utf8_string((U8*)s,len)) |
---|
368 | XSRETURN_YES; |
---|
369 | else |
---|
370 | XSRETURN_NO; |
---|
371 | } |
---|
372 | } |
---|
373 | XSRETURN_EMPTY; |
---|
374 | } |
---|
375 | |
---|
376 | XS(XS_utf8_encode) |
---|
377 | { |
---|
378 | dXSARGS; |
---|
379 | if (items != 1) |
---|
380 | Perl_croak(aTHX_ "Usage: utf8::encode(sv)"); |
---|
381 | { |
---|
382 | SV * sv = ST(0); |
---|
383 | |
---|
384 | sv_utf8_encode(sv); |
---|
385 | } |
---|
386 | XSRETURN_EMPTY; |
---|
387 | } |
---|
388 | |
---|
389 | XS(XS_utf8_decode) |
---|
390 | { |
---|
391 | dXSARGS; |
---|
392 | if (items != 1) |
---|
393 | Perl_croak(aTHX_ "Usage: utf8::decode(sv)"); |
---|
394 | { |
---|
395 | SV * sv = ST(0); |
---|
396 | bool RETVAL; |
---|
397 | |
---|
398 | RETVAL = sv_utf8_decode(sv); |
---|
399 | ST(0) = boolSV(RETVAL); |
---|
400 | sv_2mortal(ST(0)); |
---|
401 | } |
---|
402 | XSRETURN(1); |
---|
403 | } |
---|
404 | |
---|
405 | XS(XS_utf8_upgrade) |
---|
406 | { |
---|
407 | dXSARGS; |
---|
408 | if (items != 1) |
---|
409 | Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); |
---|
410 | { |
---|
411 | SV * sv = ST(0); |
---|
412 | STRLEN RETVAL; |
---|
413 | dXSTARG; |
---|
414 | |
---|
415 | RETVAL = sv_utf8_upgrade(sv); |
---|
416 | XSprePUSH; PUSHi((IV)RETVAL); |
---|
417 | } |
---|
418 | XSRETURN(1); |
---|
419 | } |
---|
420 | |
---|
421 | XS(XS_utf8_downgrade) |
---|
422 | { |
---|
423 | dXSARGS; |
---|
424 | if (items < 1 || items > 2) |
---|
425 | Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)"); |
---|
426 | { |
---|
427 | SV * sv = ST(0); |
---|
428 | bool failok; |
---|
429 | bool RETVAL; |
---|
430 | |
---|
431 | if (items < 2) |
---|
432 | failok = 0; |
---|
433 | else { |
---|
434 | failok = (int)SvIV(ST(1)); |
---|
435 | } |
---|
436 | |
---|
437 | RETVAL = sv_utf8_downgrade(sv, failok); |
---|
438 | ST(0) = boolSV(RETVAL); |
---|
439 | sv_2mortal(ST(0)); |
---|
440 | } |
---|
441 | XSRETURN(1); |
---|
442 | } |
---|
443 | |
---|
444 | XS(XS_utf8_native_to_unicode) |
---|
445 | { |
---|
446 | dXSARGS; |
---|
447 | UV uv = SvUV(ST(0)); |
---|
448 | |
---|
449 | if (items > 1) |
---|
450 | Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)"); |
---|
451 | |
---|
452 | ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv))); |
---|
453 | XSRETURN(1); |
---|
454 | } |
---|
455 | |
---|
456 | XS(XS_utf8_unicode_to_native) |
---|
457 | { |
---|
458 | dXSARGS; |
---|
459 | UV uv = SvUV(ST(0)); |
---|
460 | |
---|
461 | if (items > 1) |
---|
462 | Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)"); |
---|
463 | |
---|
464 | ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv))); |
---|
465 | XSRETURN(1); |
---|
466 | } |
---|
467 | |
---|
468 | XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ |
---|
469 | { |
---|
470 | dXSARGS; |
---|
471 | SV *sv = SvRV(ST(0)); |
---|
472 | if (items == 1) { |
---|
473 | if (SvREADONLY(sv)) |
---|
474 | XSRETURN_YES; |
---|
475 | else |
---|
476 | XSRETURN_NO; |
---|
477 | } |
---|
478 | else if (items == 2) { |
---|
479 | if (SvTRUE(ST(1))) { |
---|
480 | SvREADONLY_on(sv); |
---|
481 | XSRETURN_YES; |
---|
482 | } |
---|
483 | else { |
---|
484 | /* I hope you really know what you are doing. */ |
---|
485 | SvREADONLY_off(sv); |
---|
486 | XSRETURN_NO; |
---|
487 | } |
---|
488 | } |
---|
489 | XSRETURN_UNDEF; /* Can't happen. */ |
---|
490 | } |
---|
491 | |
---|
492 | XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ |
---|
493 | { |
---|
494 | dXSARGS; |
---|
495 | SV *sv = SvRV(ST(0)); |
---|
496 | if (items == 1) |
---|
497 | XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ |
---|
498 | else if (items == 2) { |
---|
499 | /* I hope you really know what you are doing. */ |
---|
500 | SvREFCNT(sv) = SvIV(ST(1)); |
---|
501 | XSRETURN_IV(SvREFCNT(sv)); |
---|
502 | } |
---|
503 | XSRETURN_UNDEF; /* Can't happen. */ |
---|
504 | } |
---|
505 | |
---|
506 | /* Maybe this should return the number of placeholders found in scalar context, |
---|
507 | and a list of them in list context. */ |
---|
508 | XS(XS_Internals_hv_clear_placehold) |
---|
509 | { |
---|
510 | dXSARGS; |
---|
511 | HV *hv = (HV *) SvRV(ST(0)); |
---|
512 | |
---|
513 | /* I don't care how many parameters were passed in, but I want to avoid |
---|
514 | the unused variable warning. */ |
---|
515 | |
---|
516 | items = (I32)HvPLACEHOLDERS(hv); |
---|
517 | |
---|
518 | if (items) { |
---|
519 | HE *entry; |
---|
520 | I32 riter = HvRITER(hv); |
---|
521 | HE *eiter = HvEITER(hv); |
---|
522 | hv_iterinit(hv); |
---|
523 | /* This may look suboptimal with the items *after* the iternext, but |
---|
524 | it's quite deliberate. We only get here with items==0 if we've |
---|
525 | just deleted the last placeholder in the hash. If we've just done |
---|
526 | that then it means that the hash is in lazy delete mode, and the |
---|
527 | HE is now only referenced in our iterator. If we just quit the loop |
---|
528 | and discarded our iterator then the HE leaks. So we do the && the |
---|
529 | other way to ensure iternext is called just one more time, which |
---|
530 | has the side effect of triggering the lazy delete. */ |
---|
531 | while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS)) |
---|
532 | && items) { |
---|
533 | SV *val = hv_iterval(hv, entry); |
---|
534 | |
---|
535 | if (val == &PL_sv_undef) { |
---|
536 | |
---|
537 | /* It seems that I have to go back in the front of the hash |
---|
538 | API to delete a hash, even though I have a HE structure |
---|
539 | pointing to the very entry I want to delete, and could hold |
---|
540 | onto the previous HE that points to it. And it's easier to |
---|
541 | go in with SVs as I can then specify the precomputed hash, |
---|
542 | and don't have fun and games with utf8 keys. */ |
---|
543 | SV *key = hv_iterkeysv(entry); |
---|
544 | |
---|
545 | hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry)); |
---|
546 | items--; |
---|
547 | } |
---|
548 | } |
---|
549 | HvRITER(hv) = riter; |
---|
550 | HvEITER(hv) = eiter; |
---|
551 | } |
---|
552 | |
---|
553 | XSRETURN(0); |
---|
554 | } |
---|