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