This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [perl #19566] Perl 5.8.0 segfault
[perl5.git] / universal.c
CommitLineData
d6376244
JH
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
d31a8517
AT
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
6d4a7be2 16#include "EXTERN.h"
864dbfa3 17#define PERL_IN_UNIVERSAL_C
6d4a7be2 18#include "perl.h"
6d4a7be2
PP
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
76e3520e 25STATIC SV *
301daebc
MS
26S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
27 int len, int level)
6d4a7be2
PP
28{
29 AV* av;
30 GV* gv;
31 GV** gvp;
32 HV* hv = Nullhv;
46e4b22b 33 SV* subgen = Nullsv;
6d4a7be2 34
301daebc
MS
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;
6d4a7be2 39
46e4b22b 40 if (strEQ(HvNAME(stash), name))
3280af22 41 return &PL_sv_yes;
6d4a7be2
PP
42
43 if (level > 100)
46e4b22b
GS
44 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
45 HvNAME(stash));
6d4a7be2
PP
46
47 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
48
46e4b22b
GS
49 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
50 && (hv = GvHV(gv)))
51 {
eb160463 52 if (SvIV(subgen) == (IV)PL_sub_generation) {
46e4b22b
GS
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 }
6d4a7be2
PP
67 }
68
69 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
46e4b22b 70
3280af22 71 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
46e4b22b 72 if (!hv || !subgen) {
6d4a7be2
PP
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
46e4b22b
GS
80 if (!hv)
81 hv = GvHVn(gv);
82 if (!subgen) {
83 subgen = newSViv(PL_sub_generation);
84 GvSV(gv) = subgen;
85 }
6d4a7be2 86 }
46e4b22b 87 if (hv) {
6d4a7be2 88 SV** svp = AvARRAY(av);
93965878
NIS
89 /* NOTE: No support for tied ISA */
90 I32 items = AvFILLp(av) + 1;
6d4a7be2
PP
91 while (items--) {
92 SV* sv = *svp++;
93 HV* basestash = gv_stashsv(sv, FALSE);
94 if (!basestash) {
599cee73 95 if (ckWARN(WARN_MISC))
9014280d 96 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
35c1215d
NC
97 "Can't locate package %"SVf" for @%s::ISA",
98 sv, HvNAME(stash));
6d4a7be2
PP
99 continue;
100 }
301daebc
MS
101 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
102 len, level + 1)) {
3280af22
NIS
103 (void)hv_store(hv,name,len,&PL_sv_yes,0);
104 return &PL_sv_yes;
6d4a7be2
PP
105 }
106 }
3280af22 107 (void)hv_store(hv,name,len,&PL_sv_no,0);
6d4a7be2
PP
108 }
109 }
110
e09f3e01 111 return boolSV(strEQ(name, "UNIVERSAL"));
6d4a7be2
PP
112}
113
954c1994 114/*
ccfc67b7
JH
115=head1 SV Manipulation Functions
116
954c1994
GS
117=for apidoc sv_derived_from
118
119Returns a boolean indicating whether the SV is derived from the specified
120class. This is the function that implements C<UNIVERSAL::isa>. It works
121for class names as well as for objects.
122
123=cut
124*/
125
55497cff 126bool
864dbfa3 127Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
55497cff 128{
55497cff
PP
129 char *type;
130 HV *stash;
301daebc 131 HV *name_stash;
46e4b22b 132
55497cff
PP
133 stash = Nullhv;
134 type = Nullch;
46e4b22b 135
55497cff
PP
136 if (SvGMAGICAL(sv))
137 mg_get(sv) ;
138
139 if (SvROK(sv)) {
140 sv = SvRV(sv);
141 type = sv_reftype(sv,0);
46e4b22b 142 if (SvOBJECT(sv))
55497cff
PP
143 stash = SvSTASH(sv);
144 }
145 else {
146 stash = gv_stashsv(sv, FALSE);
147 }
46e4b22b 148
301daebc
MS
149 name_stash = gv_stashpv(name, FALSE);
150
55497cff 151 return (type && strEQ(type,name)) ||
301daebc
MS
152 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
153 == &PL_sv_yes)
55497cff
PP
154 ? TRUE
155 : FALSE ;
55497cff
PP
156}
157
1b026014
NIS
158#include "XSUB.h"
159
acfe0abc
GS
160void XS_UNIVERSAL_isa(pTHX_ CV *cv);
161void XS_UNIVERSAL_can(pTHX_ CV *cv);
162void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
439cb1c4
JP
163XS(XS_version_new);
164XS(XS_version_stringify);
165XS(XS_version_numify);
166XS(XS_version_vcmp);
167XS(XS_version_boolean);
168XS(XS_version_noop);
1b026014
NIS
169XS(XS_utf8_valid);
170XS(XS_utf8_encode);
171XS(XS_utf8_decode);
172XS(XS_utf8_upgrade);
173XS(XS_utf8_downgrade);
174XS(XS_utf8_unicode_to_native);
175XS(XS_utf8_native_to_unicode);
29569577
JH
176XS(XS_Internals_SvREADONLY);
177XS(XS_Internals_SvREFCNT);
f044d0d1 178XS(XS_Internals_hv_clear_placehold);
0cb96387
GS
179
180void
181Perl_boot_core_UNIVERSAL(pTHX)
182{
183 char *file = __FILE__;
184
185 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
186 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
187 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
439cb1c4 188 {
ad63d80f
JP
189 /* register the overloading (type 'A') magic */
190 PL_amagic_generation++;
439cb1c4 191 /* Make it findable via fetchmethod */
be2ebcad 192 newXS("version::()", XS_version_noop, file);
439cb1c4
JP
193 newXS("version::new", XS_version_new, file);
194 newXS("version::(\"\"", XS_version_stringify, file);
195 newXS("version::stringify", XS_version_stringify, file);
196 newXS("version::(0+", XS_version_numify, file);
197 newXS("version::numify", XS_version_numify, file);
198 newXS("version::(cmp", XS_version_vcmp, file);
199 newXS("version::(<=>", XS_version_vcmp, file);
200 newXS("version::vcmp", XS_version_vcmp, file);
201 newXS("version::(bool", XS_version_boolean, file);
202 newXS("version::boolean", XS_version_boolean, file);
203 newXS("version::(nomethod", XS_version_noop, file);
204 newXS("version::noop", XS_version_noop, file);
205 }
1b026014
NIS
206 newXS("utf8::valid", XS_utf8_valid, file);
207 newXS("utf8::encode", XS_utf8_encode, file);
208 newXS("utf8::decode", XS_utf8_decode, file);
209 newXS("utf8::upgrade", XS_utf8_upgrade, file);
210 newXS("utf8::downgrade", XS_utf8_downgrade, file);
211 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
212 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577
JH
213 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
214 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f 215 newXSproto("Internals::hv_clear_placeholders",
f044d0d1 216 XS_Internals_hv_clear_placehold, file, "\\%");
0cb96387
GS
217}
218
55497cff 219
6d4a7be2
PP
220XS(XS_UNIVERSAL_isa)
221{
222 dXSARGS;
55497cff
PP
223 SV *sv;
224 char *name;
2d8e6c8d 225 STRLEN n_a;
6d4a7be2
PP
226
227 if (items != 2)
cea2e8a9 228 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2
PP
229
230 sv = ST(0);
f8f70380 231
d3f7f2b2
GS
232 if (SvGMAGICAL(sv))
233 mg_get(sv);
234
aca069ec 235 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
f8f70380
GS
236 XSRETURN_UNDEF;
237
2d8e6c8d 238 name = (char *)SvPV(ST(1),n_a);
6d4a7be2 239
54310121 240 ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2
PP
241 XSRETURN(1);
242}
243
6d4a7be2
PP
244XS(XS_UNIVERSAL_can)
245{
246 dXSARGS;
247 SV *sv;
248 char *name;
249 SV *rv;
6f08146e 250 HV *pkg = NULL;
2d8e6c8d 251 STRLEN n_a;
6d4a7be2
PP
252
253 if (items != 2)
cea2e8a9 254 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2
PP
255
256 sv = ST(0);
f8f70380 257
d3f7f2b2
GS
258 if (SvGMAGICAL(sv))
259 mg_get(sv);
260
aca069ec 261 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
f8f70380
GS
262 XSRETURN_UNDEF;
263
2d8e6c8d 264 name = (char *)SvPV(ST(1),n_a);
3280af22 265 rv = &PL_sv_undef;
6d4a7be2 266
46e4b22b 267 if (SvROK(sv)) {
6f08146e 268 sv = (SV*)SvRV(sv);
46e4b22b 269 if (SvOBJECT(sv))
6f08146e
NIS
270 pkg = SvSTASH(sv);
271 }
272 else {
273 pkg = gv_stashsv(sv, FALSE);
274 }
275
276 if (pkg) {
dc848c6f
PP
277 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
278 if (gv && isGV(gv))
279 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2
PP
280 }
281
282 ST(0) = rv;
283 XSRETURN(1);
284}
285
6d4a7be2
PP
286XS(XS_UNIVERSAL_VERSION)
287{
288 dXSARGS;
289 HV *pkg;
290 GV **gvp;
291 GV *gv;
292 SV *sv;
293 char *undef;
294
1571675a 295 if (SvROK(ST(0))) {
6d4a7be2 296 sv = (SV*)SvRV(ST(0));
1571675a 297 if (!SvOBJECT(sv))
cea2e8a9 298 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2
PP
299 pkg = SvSTASH(sv);
300 }
301 else {
302 pkg = gv_stashsv(ST(0), FALSE);
303 }
304
305 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
306
d4bea2fb 307 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2
PP
308 SV *nsv = sv_newmortal();
309 sv_setsv(nsv, sv);
310 sv = nsv;
311 undef = Nullch;
312 }
313 else {
3280af22 314 sv = (SV*)&PL_sv_undef;
6d4a7be2
PP
315 undef = "(undef)";
316 }
317
1571675a
GS
318 if (items > 1) {
319 STRLEN len;
320 SV *req = ST(1);
321
62658f4d
PM
322 if (undef) {
323 if (pkg)
324 Perl_croak(aTHX_
325 "%s does not define $%s::VERSION--version check failed",
326 HvNAME(pkg), HvNAME(pkg));
327 else {
328 char *str = SvPVx(ST(0), len);
329
330 Perl_croak(aTHX_
331 "%s defines neither package nor VERSION--version check failed", str);
332 }
333 }
ad63d80f
JP
334 if ( !sv_derived_from(sv, "version"))
335 sv = new_version(sv);
336
337 if ( !sv_derived_from(req, "version"))
338 req = new_version(req);
1571675a 339
ad63d80f 340 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
0773b1f0
NC
341 Perl_croak(aTHX_ "%s version %_ required--this is only version %_",
342 HvNAME(pkg), req, sv);
2d8e6c8d 343 }
6d4a7be2
PP
344
345 ST(0) = sv;
346
347 XSRETURN(1);
348}
349
439cb1c4
JP
350XS(XS_version_new)
351{
352 dXSARGS;
353 if (items != 2)
354 Perl_croak(aTHX_ "Usage: version::new(class, version)");
355 SP -= items;
356 {
357/* char * class = (char *)SvPV_nolen(ST(0)); */
358 SV * version = ST(1);
359
360{
361 PUSHs(new_version(version));
362}
363
364 PUTBACK;
365 return;
366 }
367}
368
369XS(XS_version_stringify)
370{
371 dXSARGS;
372 if (items < 1)
373 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
374 SP -= items;
375 {
376 SV * lobj;
377
378 if (sv_derived_from(ST(0), "version")) {
379 SV *tmp = SvRV(ST(0));
380 lobj = tmp;
381 }
382 else
ba329e04 383 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
384
385{
ad63d80f 386 PUSHs(vstringify(lobj));
439cb1c4
JP
387}
388
389 PUTBACK;
390 return;
391 }
392}
393
394XS(XS_version_numify)
395{
396 dXSARGS;
397 if (items < 1)
398 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
399 SP -= items;
400 {
401 SV * lobj;
402
403 if (sv_derived_from(ST(0), "version")) {
404 SV *tmp = SvRV(ST(0));
405 lobj = tmp;
406 }
407 else
ba329e04 408 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
409
410{
ad63d80f 411 PUSHs(vnumify(lobj));
439cb1c4
JP
412}
413
414 PUTBACK;
415 return;
416 }
417}
418
419XS(XS_version_vcmp)
420{
421 dXSARGS;
422 if (items < 1)
423 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
424 SP -= items;
425 {
426 SV * lobj;
427
428 if (sv_derived_from(ST(0), "version")) {
429 SV *tmp = SvRV(ST(0));
430 lobj = tmp;
431 }
432 else
ba329e04 433 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
434
435{
436 SV *rs;
437 SV *rvs;
438 SV * robj = ST(1);
439 IV swap = (IV)SvIV(ST(2));
440
441 if ( ! sv_derived_from(robj, "version") )
442 {
443 robj = new_version(robj);
444 }
445 rvs = SvRV(robj);
446
447 if ( swap )
448 {
ad63d80f 449 rs = newSViv(vcmp(rvs,lobj));
439cb1c4
JP
450 }
451 else
452 {
ad63d80f 453 rs = newSViv(vcmp(lobj,rvs));
439cb1c4
JP
454 }
455
456 PUSHs(rs);
457}
458
459 PUTBACK;
460 return;
461 }
462}
463
464XS(XS_version_boolean)
465{
466 dXSARGS;
467 if (items < 1)
468 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
469 SP -= items;
470 {
471 SV * lobj;
472
473 if (sv_derived_from(ST(0), "version")) {
474 SV *tmp = SvRV(ST(0));
475 lobj = tmp;
476 }
477 else
ba329e04 478 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
479
480{
481 SV *rs;
ad63d80f 482 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
439cb1c4
JP
483 PUSHs(rs);
484}
485
486 PUTBACK;
487 return;
488 }
489}
490
491XS(XS_version_noop)
492{
493 dXSARGS;
494 if (items < 1)
495 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
496 {
497 SV * lobj;
498
499 if (sv_derived_from(ST(0), "version")) {
500 SV *tmp = SvRV(ST(0));
501 lobj = tmp;
502 }
503 else
ba329e04 504 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
505
506{
ba329e04 507 Perl_croak(aTHX_ "operation not supported with version object");
439cb1c4
JP
508}
509
510 }
511 XSRETURN_EMPTY;
512}
513
1b026014
NIS
514XS(XS_utf8_valid)
515{
516 dXSARGS;
517 if (items != 1)
518 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
519 {
520 SV * sv = ST(0);
521 {
522 STRLEN len;
523 char *s = SvPV(sv,len);
524 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
525 XSRETURN_YES;
526 else
527 XSRETURN_NO;
528 }
529 }
530 XSRETURN_EMPTY;
531}
532
533XS(XS_utf8_encode)
534{
535 dXSARGS;
536 if (items != 1)
537 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
538 {
539 SV * sv = ST(0);
540
541 sv_utf8_encode(sv);
542 }
543 XSRETURN_EMPTY;
544}
545
546XS(XS_utf8_decode)
547{
548 dXSARGS;
549 if (items != 1)
550 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
551 {
552 SV * sv = ST(0);
553 bool RETVAL;
554
555 RETVAL = sv_utf8_decode(sv);
556 ST(0) = boolSV(RETVAL);
557 sv_2mortal(ST(0));
558 }
559 XSRETURN(1);
560}
561
562XS(XS_utf8_upgrade)
563{
564 dXSARGS;
565 if (items != 1)
566 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
567 {
568 SV * sv = ST(0);
569 STRLEN RETVAL;
570 dXSTARG;
571
572 RETVAL = sv_utf8_upgrade(sv);
573 XSprePUSH; PUSHi((IV)RETVAL);
574 }
575 XSRETURN(1);
576}
577
578XS(XS_utf8_downgrade)
579{
580 dXSARGS;
581 if (items < 1 || items > 2)
582 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
583 {
584 SV * sv = ST(0);
585 bool failok;
586 bool RETVAL;
587
588 if (items < 2)
589 failok = 0;
590 else {
591 failok = (int)SvIV(ST(1));
592 }
593
594 RETVAL = sv_utf8_downgrade(sv, failok);
595 ST(0) = boolSV(RETVAL);
596 sv_2mortal(ST(0));
597 }
598 XSRETURN(1);
599}
600
601XS(XS_utf8_native_to_unicode)
602{
603 dXSARGS;
604 UV uv = SvUV(ST(0));
b7953727
JH
605
606 if (items > 1)
607 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
608
1b026014
NIS
609 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
610 XSRETURN(1);
611}
612
613XS(XS_utf8_unicode_to_native)
614{
615 dXSARGS;
616 UV uv = SvUV(ST(0));
b7953727
JH
617
618 if (items > 1)
619 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
620
1b026014
NIS
621 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
622 XSRETURN(1);
623}
624
14a976d6 625XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH
626{
627 dXSARGS;
628 SV *sv = SvRV(ST(0));
629 if (items == 1) {
630 if (SvREADONLY(sv))
631 XSRETURN_YES;
632 else
633 XSRETURN_NO;
634 }
635 else if (items == 2) {
636 if (SvTRUE(ST(1))) {
637 SvREADONLY_on(sv);
638 XSRETURN_YES;
639 }
640 else {
14a976d6 641 /* I hope you really know what you are doing. */
29569577
JH
642 SvREADONLY_off(sv);
643 XSRETURN_NO;
644 }
645 }
14a976d6 646 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
647}
648
14a976d6 649XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
650{
651 dXSARGS;
652 SV *sv = SvRV(ST(0));
653 if (items == 1)
14a976d6 654 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 655 else if (items == 2) {
14a976d6 656 /* I hope you really know what you are doing. */
29569577
JH
657 SvREFCNT(sv) = SvIV(ST(1));
658 XSRETURN_IV(SvREFCNT(sv));
659 }
14a976d6 660 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
661}
662
dfd4ef2f
NC
663/* Maybe this should return the number of placeholders found in scalar context,
664 and a list of them in list context. */
f044d0d1 665XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC
666{
667 dXSARGS;
668 HV *hv = (HV *) SvRV(ST(0));
669
670 /* I don't care how many parameters were passed in, but I want to avoid
671 the unused variable warning. */
672
eb160463 673 items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f
NC
674
675 if (items) {
676 HE *entry;
677 I32 riter = HvRITER(hv);
678 HE *eiter = HvEITER(hv);
679 hv_iterinit(hv);
fe7bca90
NC
680 /* This may look suboptimal with the items *after* the iternext, but
681 it's quite deliberate. We only get here with items==0 if we've
682 just deleted the last placeholder in the hash. If we've just done
683 that then it means that the hash is in lazy delete mode, and the
684 HE is now only referenced in our iterator. If we just quit the loop
685 and discarded our iterator then the HE leaks. So we do the && the
686 other way to ensure iternext is called just one more time, which
687 has the side effect of triggering the lazy delete. */
688 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
689 && items) {
dfd4ef2f
NC
690 SV *val = hv_iterval(hv, entry);
691
692 if (val == &PL_sv_undef) {
693
694 /* It seems that I have to go back in the front of the hash
695 API to delete a hash, even though I have a HE structure
696 pointing to the very entry I want to delete, and could hold
697 onto the previous HE that points to it. And it's easier to
698 go in with SVs as I can then specify the precomputed hash,
699 and don't have fun and games with utf8 keys. */
700 SV *key = hv_iterkeysv(entry);
701
702 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
703 items--;
704 }
705 }
706 HvRITER(hv) = riter;
707 HvEITER(hv) = eiter;
708 }
709
710 XSRETURN(0);
711}