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