This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] [perl #21875] Hash ref transformed as a list
[perl5.git] / universal.c
CommitLineData
d6376244
JH
1/* universal.c
2 *
4bb101f2
JH
3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * by Larry Wall and others
d6376244
JH
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
d31a8517
AT
11/*
12 * "The roots of those mountains must be roots indeed; there must be
13 * great secrets buried there which have not been discovered since the
14 * beginning." --Gandalf, relating Gollum's story
15 */
16
6d4a7be2 17#include "EXTERN.h"
864dbfa3 18#define PERL_IN_UNIVERSAL_C
6d4a7be2 19#include "perl.h"
6d4a7be2 20
39f7a870
JH
21#ifdef USE_PERLIO
22#include "perliol.h" /* For the PERLIO_F_XXX */
23#endif
24
6d4a7be2
PP
25/*
26 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
27 * The main guts of traverse_isa was actually copied from gv_fetchmeth
28 */
29
76e3520e 30STATIC SV *
301daebc
MS
31S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
32 int len, int level)
6d4a7be2
PP
33{
34 AV* av;
35 GV* gv;
36 GV** gvp;
37 HV* hv = Nullhv;
46e4b22b 38 SV* subgen = Nullsv;
6d4a7be2 39
301daebc
MS
40 /* A stash/class can go by many names (ie. User == main::User), so
41 we compare the stash itself just in case */
42 if (name_stash && (stash == name_stash))
43 return &PL_sv_yes;
6d4a7be2 44
46e4b22b 45 if (strEQ(HvNAME(stash), name))
3280af22 46 return &PL_sv_yes;
6d4a7be2
PP
47
48 if (level > 100)
46e4b22b
GS
49 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
50 HvNAME(stash));
6d4a7be2
PP
51
52 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
53
46e4b22b
GS
54 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
55 && (hv = GvHV(gv)))
56 {
eb160463 57 if (SvIV(subgen) == (IV)PL_sub_generation) {
46e4b22b
GS
58 SV* sv;
59 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
60 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
61 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
62 name, HvNAME(stash)) );
63 return sv;
64 }
65 }
66 else {
67 DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
68 HvNAME(stash)) );
69 hv_clear(hv);
70 sv_setiv(subgen, PL_sub_generation);
71 }
6d4a7be2
PP
72 }
73
74 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
46e4b22b 75
3280af22 76 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
46e4b22b 77 if (!hv || !subgen) {
6d4a7be2
PP
78 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
79
80 gv = *gvp;
81
82 if (SvTYPE(gv) != SVt_PVGV)
83 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
84
46e4b22b
GS
85 if (!hv)
86 hv = GvHVn(gv);
87 if (!subgen) {
88 subgen = newSViv(PL_sub_generation);
89 GvSV(gv) = subgen;
90 }
6d4a7be2 91 }
46e4b22b 92 if (hv) {
6d4a7be2 93 SV** svp = AvARRAY(av);
93965878
NIS
94 /* NOTE: No support for tied ISA */
95 I32 items = AvFILLp(av) + 1;
6d4a7be2
PP
96 while (items--) {
97 SV* sv = *svp++;
98 HV* basestash = gv_stashsv(sv, FALSE);
99 if (!basestash) {
599cee73 100 if (ckWARN(WARN_MISC))
9014280d 101 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
35c1215d
NC
102 "Can't locate package %"SVf" for @%s::ISA",
103 sv, HvNAME(stash));
6d4a7be2
PP
104 continue;
105 }
301daebc
MS
106 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
107 len, level + 1)) {
3280af22
NIS
108 (void)hv_store(hv,name,len,&PL_sv_yes,0);
109 return &PL_sv_yes;
6d4a7be2
PP
110 }
111 }
3280af22 112 (void)hv_store(hv,name,len,&PL_sv_no,0);
6d4a7be2
PP
113 }
114 }
115
e09f3e01 116 return boolSV(strEQ(name, "UNIVERSAL"));
6d4a7be2
PP
117}
118
954c1994 119/*
ccfc67b7
JH
120=head1 SV Manipulation Functions
121
954c1994
GS
122=for apidoc sv_derived_from
123
124Returns a boolean indicating whether the SV is derived from the specified
125class. This is the function that implements C<UNIVERSAL::isa>. It works
126for class names as well as for objects.
127
128=cut
129*/
130
55497cff 131bool
864dbfa3 132Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
55497cff 133{
55497cff
PP
134 char *type;
135 HV *stash;
301daebc 136 HV *name_stash;
46e4b22b 137
55497cff
PP
138 stash = Nullhv;
139 type = Nullch;
46e4b22b 140
55497cff
PP
141 if (SvGMAGICAL(sv))
142 mg_get(sv) ;
143
144 if (SvROK(sv)) {
145 sv = SvRV(sv);
146 type = sv_reftype(sv,0);
46e4b22b 147 if (SvOBJECT(sv))
55497cff
PP
148 stash = SvSTASH(sv);
149 }
150 else {
151 stash = gv_stashsv(sv, FALSE);
152 }
46e4b22b 153
301daebc
MS
154 name_stash = gv_stashpv(name, FALSE);
155
55497cff 156 return (type && strEQ(type,name)) ||
301daebc
MS
157 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
158 == &PL_sv_yes)
55497cff
PP
159 ? TRUE
160 : FALSE ;
55497cff
PP
161}
162
1b026014
NIS
163#include "XSUB.h"
164
acfe0abc
GS
165void XS_UNIVERSAL_isa(pTHX_ CV *cv);
166void XS_UNIVERSAL_can(pTHX_ CV *cv);
167void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
439cb1c4
JP
168XS(XS_version_new);
169XS(XS_version_stringify);
170XS(XS_version_numify);
171XS(XS_version_vcmp);
172XS(XS_version_boolean);
173XS(XS_version_noop);
1b026014
NIS
174XS(XS_utf8_valid);
175XS(XS_utf8_encode);
176XS(XS_utf8_decode);
177XS(XS_utf8_upgrade);
178XS(XS_utf8_downgrade);
179XS(XS_utf8_unicode_to_native);
180XS(XS_utf8_native_to_unicode);
29569577
JH
181XS(XS_Internals_SvREADONLY);
182XS(XS_Internals_SvREFCNT);
f044d0d1 183XS(XS_Internals_hv_clear_placehold);
39f7a870 184XS(XS_PerlIO_get_layers);
0cb96387
GS
185
186void
187Perl_boot_core_UNIVERSAL(pTHX)
188{
189 char *file = __FILE__;
190
191 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
192 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
193 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
439cb1c4 194 {
ad63d80f
JP
195 /* register the overloading (type 'A') magic */
196 PL_amagic_generation++;
439cb1c4 197 /* Make it findable via fetchmethod */
be2ebcad 198 newXS("version::()", XS_version_noop, file);
439cb1c4
JP
199 newXS("version::new", XS_version_new, file);
200 newXS("version::(\"\"", XS_version_stringify, file);
201 newXS("version::stringify", XS_version_stringify, file);
202 newXS("version::(0+", XS_version_numify, file);
203 newXS("version::numify", XS_version_numify, file);
204 newXS("version::(cmp", XS_version_vcmp, file);
205 newXS("version::(<=>", XS_version_vcmp, file);
206 newXS("version::vcmp", XS_version_vcmp, file);
207 newXS("version::(bool", XS_version_boolean, file);
208 newXS("version::boolean", XS_version_boolean, file);
209 newXS("version::(nomethod", XS_version_noop, file);
210 newXS("version::noop", XS_version_noop, file);
211 }
1b026014
NIS
212 newXS("utf8::valid", XS_utf8_valid, file);
213 newXS("utf8::encode", XS_utf8_encode, file);
214 newXS("utf8::decode", XS_utf8_decode, file);
215 newXS("utf8::upgrade", XS_utf8_upgrade, file);
216 newXS("utf8::downgrade", XS_utf8_downgrade, file);
217 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
218 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577
JH
219 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
220 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f 221 newXSproto("Internals::hv_clear_placeholders",
f044d0d1 222 XS_Internals_hv_clear_placehold, file, "\\%");
9d569fce
JH
223 newXSproto("PerlIO::get_layers",
224 XS_PerlIO_get_layers, file, "*;@");
0cb96387
GS
225}
226
55497cff 227
6d4a7be2
PP
228XS(XS_UNIVERSAL_isa)
229{
230 dXSARGS;
55497cff
PP
231 SV *sv;
232 char *name;
2d8e6c8d 233 STRLEN n_a;
6d4a7be2
PP
234
235 if (items != 2)
cea2e8a9 236 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2
PP
237
238 sv = ST(0);
f8f70380 239
d3f7f2b2
GS
240 if (SvGMAGICAL(sv))
241 mg_get(sv);
242
253ecd6d
RGS
243 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
244 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380
GS
245 XSRETURN_UNDEF;
246
2d8e6c8d 247 name = (char *)SvPV(ST(1),n_a);
6d4a7be2 248
54310121 249 ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2
PP
250 XSRETURN(1);
251}
252
6d4a7be2
PP
253XS(XS_UNIVERSAL_can)
254{
255 dXSARGS;
256 SV *sv;
257 char *name;
258 SV *rv;
6f08146e 259 HV *pkg = NULL;
2d8e6c8d 260 STRLEN n_a;
6d4a7be2
PP
261
262 if (items != 2)
cea2e8a9 263 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2
PP
264
265 sv = ST(0);
f8f70380 266
d3f7f2b2
GS
267 if (SvGMAGICAL(sv))
268 mg_get(sv);
269
253ecd6d
RGS
270 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
271 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380
GS
272 XSRETURN_UNDEF;
273
2d8e6c8d 274 name = (char *)SvPV(ST(1),n_a);
3280af22 275 rv = &PL_sv_undef;
6d4a7be2 276
46e4b22b 277 if (SvROK(sv)) {
6f08146e 278 sv = (SV*)SvRV(sv);
46e4b22b 279 if (SvOBJECT(sv))
6f08146e
NIS
280 pkg = SvSTASH(sv);
281 }
282 else {
283 pkg = gv_stashsv(sv, FALSE);
284 }
285
286 if (pkg) {
dc848c6f
PP
287 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
288 if (gv && isGV(gv))
289 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2
PP
290 }
291
292 ST(0) = rv;
293 XSRETURN(1);
294}
295
6d4a7be2
PP
296XS(XS_UNIVERSAL_VERSION)
297{
298 dXSARGS;
299 HV *pkg;
300 GV **gvp;
301 GV *gv;
302 SV *sv;
303 char *undef;
304
1571675a 305 if (SvROK(ST(0))) {
6d4a7be2 306 sv = (SV*)SvRV(ST(0));
1571675a 307 if (!SvOBJECT(sv))
cea2e8a9 308 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2
PP
309 pkg = SvSTASH(sv);
310 }
311 else {
312 pkg = gv_stashsv(ST(0), FALSE);
313 }
314
315 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
316
d4bea2fb 317 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2
PP
318 SV *nsv = sv_newmortal();
319 sv_setsv(nsv, sv);
320 sv = nsv;
321 undef = Nullch;
322 }
323 else {
3280af22 324 sv = (SV*)&PL_sv_undef;
6d4a7be2
PP
325 undef = "(undef)";
326 }
327
1571675a
GS
328 if (items > 1) {
329 STRLEN len;
330 SV *req = ST(1);
331
62658f4d
PM
332 if (undef) {
333 if (pkg)
334 Perl_croak(aTHX_
335 "%s does not define $%s::VERSION--version check failed",
336 HvNAME(pkg), HvNAME(pkg));
337 else {
338 char *str = SvPVx(ST(0), len);
339
340 Perl_croak(aTHX_
341 "%s defines neither package nor VERSION--version check failed", str);
342 }
343 }
ad63d80f
JP
344 if ( !sv_derived_from(sv, "version"))
345 sv = new_version(sv);
346
347 if ( !sv_derived_from(req, "version"))
348 req = new_version(req);
1571675a 349
ad63d80f 350 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
e3feee4e
RB
351 Perl_croak(aTHX_
352 "%s version %"SVf" required--this is only version %"SVf,
0773b1f0 353 HvNAME(pkg), req, sv);
2d8e6c8d 354 }
6d4a7be2
PP
355
356 ST(0) = sv;
357
358 XSRETURN(1);
359}
360
439cb1c4
JP
361XS(XS_version_new)
362{
363 dXSARGS;
129318bd 364 if (items > 3)
439cb1c4
JP
365 Perl_croak(aTHX_ "Usage: version::new(class, version)");
366 SP -= items;
367 {
368/* char * class = (char *)SvPV_nolen(ST(0)); */
129318bd
JP
369 SV *version = ST(1);
370 if (items == 3 )
371 {
372 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
9be22fdc 373 version = Perl_newSVpvf(aTHX_ "v%s",vs);
129318bd 374 }
439cb1c4 375
129318bd 376 PUSHs(new_version(version));
439cb1c4
JP
377 PUTBACK;
378 return;
379 }
380}
381
382XS(XS_version_stringify)
383{
384 dXSARGS;
385 if (items < 1)
386 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
387 SP -= items;
388 {
389 SV * lobj;
390
391 if (sv_derived_from(ST(0), "version")) {
392 SV *tmp = SvRV(ST(0));
393 lobj = tmp;
394 }
395 else
ba329e04 396 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
397
398{
ad63d80f 399 PUSHs(vstringify(lobj));
439cb1c4
JP
400}
401
402 PUTBACK;
403 return;
404 }
405}
406
407XS(XS_version_numify)
408{
409 dXSARGS;
410 if (items < 1)
411 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
412 SP -= items;
413 {
414 SV * lobj;
415
416 if (sv_derived_from(ST(0), "version")) {
417 SV *tmp = SvRV(ST(0));
418 lobj = tmp;
419 }
420 else
ba329e04 421 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
422
423{
ad63d80f 424 PUSHs(vnumify(lobj));
439cb1c4
JP
425}
426
427 PUTBACK;
428 return;
429 }
430}
431
432XS(XS_version_vcmp)
433{
434 dXSARGS;
435 if (items < 1)
436 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
437 SP -= items;
438 {
439 SV * lobj;
440
441 if (sv_derived_from(ST(0), "version")) {
442 SV *tmp = SvRV(ST(0));
443 lobj = tmp;
444 }
445 else
ba329e04 446 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
447
448{
449 SV *rs;
450 SV *rvs;
451 SV * robj = ST(1);
452 IV swap = (IV)SvIV(ST(2));
453
454 if ( ! sv_derived_from(robj, "version") )
455 {
456 robj = new_version(robj);
457 }
458 rvs = SvRV(robj);
459
460 if ( swap )
461 {
ad63d80f 462 rs = newSViv(vcmp(rvs,lobj));
439cb1c4
JP
463 }
464 else
465 {
ad63d80f 466 rs = newSViv(vcmp(lobj,rvs));
439cb1c4
JP
467 }
468
469 PUSHs(rs);
470}
471
472 PUTBACK;
473 return;
474 }
475}
476
477XS(XS_version_boolean)
478{
479 dXSARGS;
480 if (items < 1)
481 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
482 SP -= items;
483 {
484 SV * lobj;
485
486 if (sv_derived_from(ST(0), "version")) {
487 SV *tmp = SvRV(ST(0));
488 lobj = tmp;
489 }
490 else
ba329e04 491 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
492
493{
494 SV *rs;
ad63d80f 495 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
439cb1c4
JP
496 PUSHs(rs);
497}
498
499 PUTBACK;
500 return;
501 }
502}
503
504XS(XS_version_noop)
505{
506 dXSARGS;
507 if (items < 1)
508 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
509 {
510 SV * lobj;
511
512 if (sv_derived_from(ST(0), "version")) {
513 SV *tmp = SvRV(ST(0));
514 lobj = tmp;
515 }
516 else
ba329e04 517 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
518
519{
ba329e04 520 Perl_croak(aTHX_ "operation not supported with version object");
439cb1c4
JP
521}
522
523 }
524 XSRETURN_EMPTY;
525}
526
1b026014
NIS
527XS(XS_utf8_valid)
528{
529 dXSARGS;
530 if (items != 1)
531 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
532 {
533 SV * sv = ST(0);
534 {
535 STRLEN len;
536 char *s = SvPV(sv,len);
537 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
538 XSRETURN_YES;
539 else
540 XSRETURN_NO;
541 }
542 }
543 XSRETURN_EMPTY;
544}
545
546XS(XS_utf8_encode)
547{
548 dXSARGS;
549 if (items != 1)
550 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
551 {
552 SV * sv = ST(0);
553
554 sv_utf8_encode(sv);
555 }
556 XSRETURN_EMPTY;
557}
558
559XS(XS_utf8_decode)
560{
561 dXSARGS;
562 if (items != 1)
563 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
564 {
565 SV * sv = ST(0);
566 bool RETVAL;
567
568 RETVAL = sv_utf8_decode(sv);
569 ST(0) = boolSV(RETVAL);
570 sv_2mortal(ST(0));
571 }
572 XSRETURN(1);
573}
574
575XS(XS_utf8_upgrade)
576{
577 dXSARGS;
578 if (items != 1)
579 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
580 {
581 SV * sv = ST(0);
582 STRLEN RETVAL;
583 dXSTARG;
584
585 RETVAL = sv_utf8_upgrade(sv);
586 XSprePUSH; PUSHi((IV)RETVAL);
587 }
588 XSRETURN(1);
589}
590
591XS(XS_utf8_downgrade)
592{
593 dXSARGS;
594 if (items < 1 || items > 2)
595 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
596 {
597 SV * sv = ST(0);
598 bool failok;
599 bool RETVAL;
600
601 if (items < 2)
602 failok = 0;
603 else {
604 failok = (int)SvIV(ST(1));
605 }
606
607 RETVAL = sv_utf8_downgrade(sv, failok);
608 ST(0) = boolSV(RETVAL);
609 sv_2mortal(ST(0));
610 }
611 XSRETURN(1);
612}
613
614XS(XS_utf8_native_to_unicode)
615{
616 dXSARGS;
617 UV uv = SvUV(ST(0));
b7953727
JH
618
619 if (items > 1)
620 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
621
1b026014
NIS
622 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
623 XSRETURN(1);
624}
625
626XS(XS_utf8_unicode_to_native)
627{
628 dXSARGS;
629 UV uv = SvUV(ST(0));
b7953727
JH
630
631 if (items > 1)
632 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
633
1b026014
NIS
634 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
635 XSRETURN(1);
636}
637
14a976d6 638XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH
639{
640 dXSARGS;
641 SV *sv = SvRV(ST(0));
642 if (items == 1) {
643 if (SvREADONLY(sv))
644 XSRETURN_YES;
645 else
646 XSRETURN_NO;
647 }
648 else if (items == 2) {
649 if (SvTRUE(ST(1))) {
650 SvREADONLY_on(sv);
651 XSRETURN_YES;
652 }
653 else {
14a976d6 654 /* I hope you really know what you are doing. */
29569577
JH
655 SvREADONLY_off(sv);
656 XSRETURN_NO;
657 }
658 }
14a976d6 659 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
660}
661
14a976d6 662XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
663{
664 dXSARGS;
665 SV *sv = SvRV(ST(0));
666 if (items == 1)
14a976d6 667 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 668 else if (items == 2) {
14a976d6 669 /* I hope you really know what you are doing. */
29569577
JH
670 SvREFCNT(sv) = SvIV(ST(1));
671 XSRETURN_IV(SvREFCNT(sv));
672 }
14a976d6 673 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
674}
675
dfd4ef2f
NC
676/* Maybe this should return the number of placeholders found in scalar context,
677 and a list of them in list context. */
f044d0d1 678XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC
679{
680 dXSARGS;
681 HV *hv = (HV *) SvRV(ST(0));
682
683 /* I don't care how many parameters were passed in, but I want to avoid
684 the unused variable warning. */
685
eb160463 686 items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f
NC
687
688 if (items) {
689 HE *entry;
690 I32 riter = HvRITER(hv);
691 HE *eiter = HvEITER(hv);
692 hv_iterinit(hv);
fe7bca90
NC
693 /* This may look suboptimal with the items *after* the iternext, but
694 it's quite deliberate. We only get here with items==0 if we've
695 just deleted the last placeholder in the hash. If we've just done
696 that then it means that the hash is in lazy delete mode, and the
697 HE is now only referenced in our iterator. If we just quit the loop
698 and discarded our iterator then the HE leaks. So we do the && the
699 other way to ensure iternext is called just one more time, which
700 has the side effect of triggering the lazy delete. */
701 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
702 && items) {
dfd4ef2f
NC
703 SV *val = hv_iterval(hv, entry);
704
705 if (val == &PL_sv_undef) {
706
707 /* It seems that I have to go back in the front of the hash
708 API to delete a hash, even though I have a HE structure
709 pointing to the very entry I want to delete, and could hold
710 onto the previous HE that points to it. And it's easier to
711 go in with SVs as I can then specify the precomputed hash,
712 and don't have fun and games with utf8 keys. */
713 SV *key = hv_iterkeysv(entry);
714
715 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
716 items--;
717 }
718 }
719 HvRITER(hv) = riter;
720 HvEITER(hv) = eiter;
721 }
722
723 XSRETURN(0);
724}
39f7a870
JH
725
726XS(XS_PerlIO_get_layers)
727{
728 dXSARGS;
729 if (items < 1 || items % 2 == 0)
730 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
5fef3b4a 731#ifdef USE_PERLIO
39f7a870
JH
732 {
733 SV * sv;
734 GV * gv;
735 IO * io;
736 bool input = TRUE;
737 bool details = FALSE;
738
739 if (items > 1) {
39f7a870
JH
740 SV **svp;
741
742 for (svp = MARK + 2; svp <= SP; svp += 2) {
743 SV **varp = svp;
744 SV **valp = svp + 1;
745 STRLEN klen;
746 char *key = SvPV(*varp, klen);
747
748 switch (*key) {
749 case 'i':
750 if (klen == 5 && memEQ(key, "input", 5)) {
751 input = SvTRUE(*valp);
752 break;
753 }
754 goto fail;
755 case 'o':
756 if (klen == 6 && memEQ(key, "output", 6)) {
757 input = !SvTRUE(*valp);
758 break;
759 }
760 goto fail;
761 case 'd':
762 if (klen == 7 && memEQ(key, "details", 7)) {
763 details = SvTRUE(*valp);
764 break;
765 }
766 goto fail;
767 default:
768 fail:
769 Perl_croak(aTHX_
770 "get_layers: unknown argument '%s'",
771 key);
772 }
773 }
774
775 SP -= (items - 1);
776 }
777
778 sv = POPs;
779 gv = (GV*)sv;
780
781 if (!isGV(sv)) {
782 if (SvROK(sv) && isGV(SvRV(sv)))
783 gv = (GV*)SvRV(sv);
784 else
785 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
786 }
787
788 if (gv && (io = GvIO(gv))) {
789 dTARGET;
790 AV* av = PerlIO_get_layers(aTHX_ input ?
791 IoIFP(io) : IoOFP(io));
792 I32 i;
793 I32 last = av_len(av);
794 I32 nitem = 0;
795
796 for (i = last; i >= 0; i -= 3) {
797 SV **namsvp;
798 SV **argsvp;
799 SV **flgsvp;
800 bool namok, argok, flgok;
801
802 namsvp = av_fetch(av, i - 2, FALSE);
803 argsvp = av_fetch(av, i - 1, FALSE);
804 flgsvp = av_fetch(av, i, FALSE);
805
806 namok = namsvp && *namsvp && SvPOK(*namsvp);
807 argok = argsvp && *argsvp && SvPOK(*argsvp);
808 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
809
810 if (details) {
811 XPUSHs(namok ?
812 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
813 XPUSHs(argok ?
814 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
815 if (flgok)
816 XPUSHi(SvIVX(*flgsvp));
817 else
818 XPUSHs(&PL_sv_undef);
819 nitem += 3;
820 }
821 else {
822 if (namok && argok)
823 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
824 *namsvp, *argsvp));
825 else if (namok)
826 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
827 else
828 XPUSHs(&PL_sv_undef);
829 nitem++;
830 if (flgok) {
831 IV flags = SvIVX(*flgsvp);
832
833 if (flags & PERLIO_F_UTF8) {
834 XPUSHs(newSVpvn("utf8", 4));
835 nitem++;
836 }
837 }
838 }
839 }
840
841 SvREFCNT_dec(av);
842
843 XSRETURN(nitem);
844 }
845 }
5fef3b4a 846#endif
39f7a870
JH
847
848 XSRETURN(0);
849}
850