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