This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
version objects final(?) patch
[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;
129318bd 355 if (items > 3)
439cb1c4
JP
356 Perl_croak(aTHX_ "Usage: version::new(class, version)");
357 SP -= items;
358 {
359/* char * class = (char *)SvPV_nolen(ST(0)); */
129318bd
JP
360 SV *version = ST(1);
361 if (items == 3 )
362 {
363 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
364 version = newSVpvf("v%s",vs);
365 }
439cb1c4 366
129318bd 367 PUSHs(new_version(version));
439cb1c4
JP
368 PUTBACK;
369 return;
370 }
371}
372
373XS(XS_version_stringify)
374{
375 dXSARGS;
376 if (items < 1)
377 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
378 SP -= items;
379 {
380 SV * lobj;
381
382 if (sv_derived_from(ST(0), "version")) {
383 SV *tmp = SvRV(ST(0));
384 lobj = tmp;
385 }
386 else
ba329e04 387 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
388
389{
ad63d80f 390 PUSHs(vstringify(lobj));
439cb1c4
JP
391}
392
393 PUTBACK;
394 return;
395 }
396}
397
398XS(XS_version_numify)
399{
400 dXSARGS;
401 if (items < 1)
402 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
403 SP -= items;
404 {
405 SV * lobj;
406
407 if (sv_derived_from(ST(0), "version")) {
408 SV *tmp = SvRV(ST(0));
409 lobj = tmp;
410 }
411 else
ba329e04 412 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
413
414{
ad63d80f 415 PUSHs(vnumify(lobj));
439cb1c4
JP
416}
417
418 PUTBACK;
419 return;
420 }
421}
422
423XS(XS_version_vcmp)
424{
425 dXSARGS;
426 if (items < 1)
427 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
428 SP -= items;
429 {
430 SV * lobj;
431
432 if (sv_derived_from(ST(0), "version")) {
433 SV *tmp = SvRV(ST(0));
434 lobj = tmp;
435 }
436 else
ba329e04 437 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
438
439{
440 SV *rs;
441 SV *rvs;
442 SV * robj = ST(1);
443 IV swap = (IV)SvIV(ST(2));
444
445 if ( ! sv_derived_from(robj, "version") )
446 {
447 robj = new_version(robj);
448 }
449 rvs = SvRV(robj);
450
451 if ( swap )
452 {
ad63d80f 453 rs = newSViv(vcmp(rvs,lobj));
439cb1c4
JP
454 }
455 else
456 {
ad63d80f 457 rs = newSViv(vcmp(lobj,rvs));
439cb1c4
JP
458 }
459
460 PUSHs(rs);
461}
462
463 PUTBACK;
464 return;
465 }
466}
467
468XS(XS_version_boolean)
469{
470 dXSARGS;
471 if (items < 1)
472 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
473 SP -= items;
474 {
475 SV * lobj;
476
477 if (sv_derived_from(ST(0), "version")) {
478 SV *tmp = SvRV(ST(0));
479 lobj = tmp;
480 }
481 else
ba329e04 482 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
483
484{
485 SV *rs;
ad63d80f 486 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
439cb1c4
JP
487 PUSHs(rs);
488}
489
490 PUTBACK;
491 return;
492 }
493}
494
495XS(XS_version_noop)
496{
497 dXSARGS;
498 if (items < 1)
499 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
500 {
501 SV * lobj;
502
503 if (sv_derived_from(ST(0), "version")) {
504 SV *tmp = SvRV(ST(0));
505 lobj = tmp;
506 }
507 else
ba329e04 508 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
509
510{
ba329e04 511 Perl_croak(aTHX_ "operation not supported with version object");
439cb1c4
JP
512}
513
514 }
515 XSRETURN_EMPTY;
516}
517
1b026014
NIS
518XS(XS_utf8_valid)
519{
520 dXSARGS;
521 if (items != 1)
522 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
523 {
524 SV * sv = ST(0);
525 {
526 STRLEN len;
527 char *s = SvPV(sv,len);
528 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
529 XSRETURN_YES;
530 else
531 XSRETURN_NO;
532 }
533 }
534 XSRETURN_EMPTY;
535}
536
537XS(XS_utf8_encode)
538{
539 dXSARGS;
540 if (items != 1)
541 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
542 {
543 SV * sv = ST(0);
544
545 sv_utf8_encode(sv);
546 }
547 XSRETURN_EMPTY;
548}
549
550XS(XS_utf8_decode)
551{
552 dXSARGS;
553 if (items != 1)
554 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
555 {
556 SV * sv = ST(0);
557 bool RETVAL;
558
559 RETVAL = sv_utf8_decode(sv);
560 ST(0) = boolSV(RETVAL);
561 sv_2mortal(ST(0));
562 }
563 XSRETURN(1);
564}
565
566XS(XS_utf8_upgrade)
567{
568 dXSARGS;
569 if (items != 1)
570 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
571 {
572 SV * sv = ST(0);
573 STRLEN RETVAL;
574 dXSTARG;
575
576 RETVAL = sv_utf8_upgrade(sv);
577 XSprePUSH; PUSHi((IV)RETVAL);
578 }
579 XSRETURN(1);
580}
581
582XS(XS_utf8_downgrade)
583{
584 dXSARGS;
585 if (items < 1 || items > 2)
586 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
587 {
588 SV * sv = ST(0);
589 bool failok;
590 bool RETVAL;
591
592 if (items < 2)
593 failok = 0;
594 else {
595 failok = (int)SvIV(ST(1));
596 }
597
598 RETVAL = sv_utf8_downgrade(sv, failok);
599 ST(0) = boolSV(RETVAL);
600 sv_2mortal(ST(0));
601 }
602 XSRETURN(1);
603}
604
605XS(XS_utf8_native_to_unicode)
606{
607 dXSARGS;
608 UV uv = SvUV(ST(0));
b7953727
JH
609
610 if (items > 1)
611 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
612
1b026014
NIS
613 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
614 XSRETURN(1);
615}
616
617XS(XS_utf8_unicode_to_native)
618{
619 dXSARGS;
620 UV uv = SvUV(ST(0));
b7953727
JH
621
622 if (items > 1)
623 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
624
1b026014
NIS
625 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
626 XSRETURN(1);
627}
628
14a976d6 629XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH
630{
631 dXSARGS;
632 SV *sv = SvRV(ST(0));
633 if (items == 1) {
634 if (SvREADONLY(sv))
635 XSRETURN_YES;
636 else
637 XSRETURN_NO;
638 }
639 else if (items == 2) {
640 if (SvTRUE(ST(1))) {
641 SvREADONLY_on(sv);
642 XSRETURN_YES;
643 }
644 else {
14a976d6 645 /* I hope you really know what you are doing. */
29569577
JH
646 SvREADONLY_off(sv);
647 XSRETURN_NO;
648 }
649 }
14a976d6 650 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
651}
652
14a976d6 653XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
654{
655 dXSARGS;
656 SV *sv = SvRV(ST(0));
657 if (items == 1)
14a976d6 658 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 659 else if (items == 2) {
14a976d6 660 /* I hope you really know what you are doing. */
29569577
JH
661 SvREFCNT(sv) = SvIV(ST(1));
662 XSRETURN_IV(SvREFCNT(sv));
663 }
14a976d6 664 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
665}
666
dfd4ef2f
NC
667/* Maybe this should return the number of placeholders found in scalar context,
668 and a list of them in list context. */
f044d0d1 669XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC
670{
671 dXSARGS;
672 HV *hv = (HV *) SvRV(ST(0));
673
674 /* I don't care how many parameters were passed in, but I want to avoid
675 the unused variable warning. */
676
eb160463 677 items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f
NC
678
679 if (items) {
680 HE *entry;
681 I32 riter = HvRITER(hv);
682 HE *eiter = HvEITER(hv);
683 hv_iterinit(hv);
fe7bca90
NC
684 /* This may look suboptimal with the items *after* the iternext, but
685 it's quite deliberate. We only get here with items==0 if we've
686 just deleted the last placeholder in the hash. If we've just done
687 that then it means that the hash is in lazy delete mode, and the
688 HE is now only referenced in our iterator. If we just quit the loop
689 and discarded our iterator then the HE leaks. So we do the && the
690 other way to ensure iternext is called just one more time, which
691 has the side effect of triggering the lazy delete. */
692 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
693 && items) {
dfd4ef2f
NC
694 SV *val = hv_iterval(hv, entry);
695
696 if (val == &PL_sv_undef) {
697
698 /* It seems that I have to go back in the front of the hash
699 API to delete a hash, even though I have a HE structure
700 pointing to the very entry I want to delete, and could hold
701 onto the previous HE that points to it. And it's easier to
702 go in with SVs as I can then specify the precomputed hash,
703 and don't have fun and games with utf8 keys. */
704 SV *key = hv_iterkeysv(entry);
705
706 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
707 items--;
708 }
709 }
710 HvRITER(hv) = riter;
711 HvEITER(hv) = eiter;
712 }
713
714 XSRETURN(0);
715}