This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add CPAN ChangeLog to MANIFEST.
[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
253ecd6d
RGS
235 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
236 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380
GS
237 XSRETURN_UNDEF;
238
2d8e6c8d 239 name = (char *)SvPV(ST(1),n_a);
6d4a7be2 240
54310121 241 ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2
PP
242 XSRETURN(1);
243}
244
6d4a7be2
PP
245XS(XS_UNIVERSAL_can)
246{
247 dXSARGS;
248 SV *sv;
249 char *name;
250 SV *rv;
6f08146e 251 HV *pkg = NULL;
2d8e6c8d 252 STRLEN n_a;
6d4a7be2
PP
253
254 if (items != 2)
cea2e8a9 255 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2
PP
256
257 sv = ST(0);
f8f70380 258
d3f7f2b2
GS
259 if (SvGMAGICAL(sv))
260 mg_get(sv);
261
253ecd6d
RGS
262 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
263 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380
GS
264 XSRETURN_UNDEF;
265
2d8e6c8d 266 name = (char *)SvPV(ST(1),n_a);
3280af22 267 rv = &PL_sv_undef;
6d4a7be2 268
46e4b22b 269 if (SvROK(sv)) {
6f08146e 270 sv = (SV*)SvRV(sv);
46e4b22b 271 if (SvOBJECT(sv))
6f08146e
NIS
272 pkg = SvSTASH(sv);
273 }
274 else {
275 pkg = gv_stashsv(sv, FALSE);
276 }
277
278 if (pkg) {
dc848c6f
PP
279 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
280 if (gv && isGV(gv))
281 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2
PP
282 }
283
284 ST(0) = rv;
285 XSRETURN(1);
286}
287
6d4a7be2
PP
288XS(XS_UNIVERSAL_VERSION)
289{
290 dXSARGS;
291 HV *pkg;
292 GV **gvp;
293 GV *gv;
294 SV *sv;
295 char *undef;
296
1571675a 297 if (SvROK(ST(0))) {
6d4a7be2 298 sv = (SV*)SvRV(ST(0));
1571675a 299 if (!SvOBJECT(sv))
cea2e8a9 300 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2
PP
301 pkg = SvSTASH(sv);
302 }
303 else {
304 pkg = gv_stashsv(ST(0), FALSE);
305 }
306
307 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
308
d4bea2fb 309 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2
PP
310 SV *nsv = sv_newmortal();
311 sv_setsv(nsv, sv);
312 sv = nsv;
313 undef = Nullch;
314 }
315 else {
3280af22 316 sv = (SV*)&PL_sv_undef;
6d4a7be2
PP
317 undef = "(undef)";
318 }
319
1571675a
GS
320 if (items > 1) {
321 STRLEN len;
322 SV *req = ST(1);
323
62658f4d
PM
324 if (undef) {
325 if (pkg)
326 Perl_croak(aTHX_
327 "%s does not define $%s::VERSION--version check failed",
328 HvNAME(pkg), HvNAME(pkg));
329 else {
330 char *str = SvPVx(ST(0), len);
331
332 Perl_croak(aTHX_
333 "%s defines neither package nor VERSION--version check failed", str);
334 }
335 }
ad63d80f
JP
336 if ( !sv_derived_from(sv, "version"))
337 sv = new_version(sv);
338
339 if ( !sv_derived_from(req, "version"))
340 req = new_version(req);
1571675a 341
ad63d80f 342 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
0773b1f0
NC
343 Perl_croak(aTHX_ "%s version %_ required--this is only version %_",
344 HvNAME(pkg), req, sv);
2d8e6c8d 345 }
6d4a7be2
PP
346
347 ST(0) = sv;
348
349 XSRETURN(1);
350}
351
439cb1c4
JP
352XS(XS_version_new)
353{
354 dXSARGS;
355 if (items != 2)
356 Perl_croak(aTHX_ "Usage: version::new(class, version)");
357 SP -= items;
358 {
359/* char * class = (char *)SvPV_nolen(ST(0)); */
360 SV * version = ST(1);
361
362{
363 PUSHs(new_version(version));
364}
365
366 PUTBACK;
367 return;
368 }
369}
370
371XS(XS_version_stringify)
372{
373 dXSARGS;
374 if (items < 1)
375 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
376 SP -= items;
377 {
378 SV * lobj;
379
380 if (sv_derived_from(ST(0), "version")) {
381 SV *tmp = SvRV(ST(0));
382 lobj = tmp;
383 }
384 else
ba329e04 385 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
386
387{
ad63d80f 388 PUSHs(vstringify(lobj));
439cb1c4
JP
389}
390
391 PUTBACK;
392 return;
393 }
394}
395
396XS(XS_version_numify)
397{
398 dXSARGS;
399 if (items < 1)
400 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
401 SP -= items;
402 {
403 SV * lobj;
404
405 if (sv_derived_from(ST(0), "version")) {
406 SV *tmp = SvRV(ST(0));
407 lobj = tmp;
408 }
409 else
ba329e04 410 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
411
412{
ad63d80f 413 PUSHs(vnumify(lobj));
439cb1c4
JP
414}
415
416 PUTBACK;
417 return;
418 }
419}
420
421XS(XS_version_vcmp)
422{
423 dXSARGS;
424 if (items < 1)
425 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
426 SP -= items;
427 {
428 SV * lobj;
429
430 if (sv_derived_from(ST(0), "version")) {
431 SV *tmp = SvRV(ST(0));
432 lobj = tmp;
433 }
434 else
ba329e04 435 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
436
437{
438 SV *rs;
439 SV *rvs;
440 SV * robj = ST(1);
441 IV swap = (IV)SvIV(ST(2));
442
443 if ( ! sv_derived_from(robj, "version") )
444 {
445 robj = new_version(robj);
446 }
447 rvs = SvRV(robj);
448
449 if ( swap )
450 {
ad63d80f 451 rs = newSViv(vcmp(rvs,lobj));
439cb1c4
JP
452 }
453 else
454 {
ad63d80f 455 rs = newSViv(vcmp(lobj,rvs));
439cb1c4
JP
456 }
457
458 PUSHs(rs);
459}
460
461 PUTBACK;
462 return;
463 }
464}
465
466XS(XS_version_boolean)
467{
468 dXSARGS;
469 if (items < 1)
470 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
471 SP -= items;
472 {
473 SV * lobj;
474
475 if (sv_derived_from(ST(0), "version")) {
476 SV *tmp = SvRV(ST(0));
477 lobj = tmp;
478 }
479 else
ba329e04 480 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
481
482{
483 SV *rs;
ad63d80f 484 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
439cb1c4
JP
485 PUSHs(rs);
486}
487
488 PUTBACK;
489 return;
490 }
491}
492
493XS(XS_version_noop)
494{
495 dXSARGS;
496 if (items < 1)
497 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
498 {
499 SV * lobj;
500
501 if (sv_derived_from(ST(0), "version")) {
502 SV *tmp = SvRV(ST(0));
503 lobj = tmp;
504 }
505 else
ba329e04 506 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
507
508{
ba329e04 509 Perl_croak(aTHX_ "operation not supported with version object");
439cb1c4
JP
510}
511
512 }
513 XSRETURN_EMPTY;
514}
515
1b026014
NIS
516XS(XS_utf8_valid)
517{
518 dXSARGS;
519 if (items != 1)
520 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
521 {
522 SV * sv = ST(0);
523 {
524 STRLEN len;
525 char *s = SvPV(sv,len);
526 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
527 XSRETURN_YES;
528 else
529 XSRETURN_NO;
530 }
531 }
532 XSRETURN_EMPTY;
533}
534
535XS(XS_utf8_encode)
536{
537 dXSARGS;
538 if (items != 1)
539 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
540 {
541 SV * sv = ST(0);
542
543 sv_utf8_encode(sv);
544 }
545 XSRETURN_EMPTY;
546}
547
548XS(XS_utf8_decode)
549{
550 dXSARGS;
551 if (items != 1)
552 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
553 {
554 SV * sv = ST(0);
555 bool RETVAL;
556
557 RETVAL = sv_utf8_decode(sv);
558 ST(0) = boolSV(RETVAL);
559 sv_2mortal(ST(0));
560 }
561 XSRETURN(1);
562}
563
564XS(XS_utf8_upgrade)
565{
566 dXSARGS;
567 if (items != 1)
568 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
569 {
570 SV * sv = ST(0);
571 STRLEN RETVAL;
572 dXSTARG;
573
574 RETVAL = sv_utf8_upgrade(sv);
575 XSprePUSH; PUSHi((IV)RETVAL);
576 }
577 XSRETURN(1);
578}
579
580XS(XS_utf8_downgrade)
581{
582 dXSARGS;
583 if (items < 1 || items > 2)
584 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
585 {
586 SV * sv = ST(0);
587 bool failok;
588 bool RETVAL;
589
590 if (items < 2)
591 failok = 0;
592 else {
593 failok = (int)SvIV(ST(1));
594 }
595
596 RETVAL = sv_utf8_downgrade(sv, failok);
597 ST(0) = boolSV(RETVAL);
598 sv_2mortal(ST(0));
599 }
600 XSRETURN(1);
601}
602
603XS(XS_utf8_native_to_unicode)
604{
605 dXSARGS;
606 UV uv = SvUV(ST(0));
b7953727
JH
607
608 if (items > 1)
609 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
610
1b026014
NIS
611 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
612 XSRETURN(1);
613}
614
615XS(XS_utf8_unicode_to_native)
616{
617 dXSARGS;
618 UV uv = SvUV(ST(0));
b7953727
JH
619
620 if (items > 1)
621 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
622
1b026014
NIS
623 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
624 XSRETURN(1);
625}
626
14a976d6 627XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH
628{
629 dXSARGS;
630 SV *sv = SvRV(ST(0));
631 if (items == 1) {
632 if (SvREADONLY(sv))
633 XSRETURN_YES;
634 else
635 XSRETURN_NO;
636 }
637 else if (items == 2) {
638 if (SvTRUE(ST(1))) {
639 SvREADONLY_on(sv);
640 XSRETURN_YES;
641 }
642 else {
14a976d6 643 /* I hope you really know what you are doing. */
29569577
JH
644 SvREADONLY_off(sv);
645 XSRETURN_NO;
646 }
647 }
14a976d6 648 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
649}
650
14a976d6 651XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
652{
653 dXSARGS;
654 SV *sv = SvRV(ST(0));
655 if (items == 1)
14a976d6 656 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 657 else if (items == 2) {
14a976d6 658 /* I hope you really know what you are doing. */
29569577
JH
659 SvREFCNT(sv) = SvIV(ST(1));
660 XSRETURN_IV(SvREFCNT(sv));
661 }
14a976d6 662 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
663}
664
dfd4ef2f
NC
665/* Maybe this should return the number of placeholders found in scalar context,
666 and a list of them in list context. */
f044d0d1 667XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC
668{
669 dXSARGS;
670 HV *hv = (HV *) SvRV(ST(0));
671
672 /* I don't care how many parameters were passed in, but I want to avoid
673 the unused variable warning. */
674
eb160463 675 items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f
NC
676
677 if (items) {
678 HE *entry;
679 I32 riter = HvRITER(hv);
680 HE *eiter = HvEITER(hv);
681 hv_iterinit(hv);
fe7bca90
NC
682 /* This may look suboptimal with the items *after* the iternext, but
683 it's quite deliberate. We only get here with items==0 if we've
684 just deleted the last placeholder in the hash. If we've just done
685 that then it means that the hash is in lazy delete mode, and the
686 HE is now only referenced in our iterator. If we just quit the loop
687 and discarded our iterator then the HE leaks. So we do the && the
688 other way to ensure iternext is called just one more time, which
689 has the side effect of triggering the lazy delete. */
690 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
691 && items) {
dfd4ef2f
NC
692 SV *val = hv_iterval(hv, entry);
693
694 if (val == &PL_sv_undef) {
695
696 /* It seems that I have to go back in the front of the hash
697 API to delete a hash, even though I have a HE structure
698 pointing to the very entry I want to delete, and could hold
699 onto the previous HE that points to it. And it's easier to
700 go in with SVs as I can then specify the precomputed hash,
701 and don't have fun and games with utf8 keys. */
702 SV *key = hv_iterkeysv(entry);
703
704 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
705 items--;
706 }
707 }
708 HvRITER(hv) = riter;
709 HvEITER(hv) = eiter;
710 }
711
712 XSRETURN(0);
713}