This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Slight tweaks on the length() and chr() entries,
[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);
39cff0d9 185XS(XS_Regexp_DESTROY);
0cb96387
GS
186
187void
188Perl_boot_core_UNIVERSAL(pTHX)
189{
190 char *file = __FILE__;
191
192 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
193 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
194 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
439cb1c4 195 {
ad63d80f
JP
196 /* register the overloading (type 'A') magic */
197 PL_amagic_generation++;
439cb1c4 198 /* Make it findable via fetchmethod */
be2ebcad 199 newXS("version::()", XS_version_noop, file);
439cb1c4
JP
200 newXS("version::new", XS_version_new, file);
201 newXS("version::(\"\"", XS_version_stringify, file);
202 newXS("version::stringify", XS_version_stringify, file);
203 newXS("version::(0+", XS_version_numify, file);
204 newXS("version::numify", XS_version_numify, file);
205 newXS("version::(cmp", XS_version_vcmp, file);
206 newXS("version::(<=>", XS_version_vcmp, file);
207 newXS("version::vcmp", XS_version_vcmp, file);
208 newXS("version::(bool", XS_version_boolean, file);
209 newXS("version::boolean", XS_version_boolean, file);
210 newXS("version::(nomethod", XS_version_noop, file);
211 newXS("version::noop", XS_version_noop, file);
212 }
1b026014
NIS
213 newXS("utf8::valid", XS_utf8_valid, file);
214 newXS("utf8::encode", XS_utf8_encode, file);
215 newXS("utf8::decode", XS_utf8_decode, file);
216 newXS("utf8::upgrade", XS_utf8_upgrade, file);
217 newXS("utf8::downgrade", XS_utf8_downgrade, file);
218 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
219 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577
JH
220 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
221 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f 222 newXSproto("Internals::hv_clear_placeholders",
f044d0d1 223 XS_Internals_hv_clear_placehold, file, "\\%");
9d569fce
JH
224 newXSproto("PerlIO::get_layers",
225 XS_PerlIO_get_layers, file, "*;@");
39cff0d9 226 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
0cb96387
GS
227}
228
55497cff 229
6d4a7be2
PP
230XS(XS_UNIVERSAL_isa)
231{
232 dXSARGS;
55497cff
PP
233 SV *sv;
234 char *name;
2d8e6c8d 235 STRLEN n_a;
6d4a7be2
PP
236
237 if (items != 2)
cea2e8a9 238 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2
PP
239
240 sv = ST(0);
f8f70380 241
d3f7f2b2
GS
242 if (SvGMAGICAL(sv))
243 mg_get(sv);
244
253ecd6d
RGS
245 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
246 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380
GS
247 XSRETURN_UNDEF;
248
2d8e6c8d 249 name = (char *)SvPV(ST(1),n_a);
6d4a7be2 250
54310121 251 ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2
PP
252 XSRETURN(1);
253}
254
6d4a7be2
PP
255XS(XS_UNIVERSAL_can)
256{
257 dXSARGS;
258 SV *sv;
259 char *name;
260 SV *rv;
6f08146e 261 HV *pkg = NULL;
2d8e6c8d 262 STRLEN n_a;
6d4a7be2
PP
263
264 if (items != 2)
cea2e8a9 265 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2
PP
266
267 sv = ST(0);
f8f70380 268
d3f7f2b2
GS
269 if (SvGMAGICAL(sv))
270 mg_get(sv);
271
253ecd6d
RGS
272 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
273 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380
GS
274 XSRETURN_UNDEF;
275
2d8e6c8d 276 name = (char *)SvPV(ST(1),n_a);
3280af22 277 rv = &PL_sv_undef;
6d4a7be2 278
46e4b22b 279 if (SvROK(sv)) {
6f08146e 280 sv = (SV*)SvRV(sv);
46e4b22b 281 if (SvOBJECT(sv))
6f08146e
NIS
282 pkg = SvSTASH(sv);
283 }
284 else {
285 pkg = gv_stashsv(sv, FALSE);
286 }
287
288 if (pkg) {
dc848c6f
PP
289 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
290 if (gv && isGV(gv))
291 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2
PP
292 }
293
294 ST(0) = rv;
295 XSRETURN(1);
296}
297
6d4a7be2
PP
298XS(XS_UNIVERSAL_VERSION)
299{
300 dXSARGS;
301 HV *pkg;
302 GV **gvp;
303 GV *gv;
304 SV *sv;
305 char *undef;
306
1571675a 307 if (SvROK(ST(0))) {
6d4a7be2 308 sv = (SV*)SvRV(ST(0));
1571675a 309 if (!SvOBJECT(sv))
cea2e8a9 310 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2
PP
311 pkg = SvSTASH(sv);
312 }
313 else {
314 pkg = gv_stashsv(ST(0), FALSE);
315 }
316
317 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
318
d4bea2fb 319 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2
PP
320 SV *nsv = sv_newmortal();
321 sv_setsv(nsv, sv);
322 sv = nsv;
323 undef = Nullch;
324 }
325 else {
3280af22 326 sv = (SV*)&PL_sv_undef;
6d4a7be2
PP
327 undef = "(undef)";
328 }
329
1571675a
GS
330 if (items > 1) {
331 STRLEN len;
332 SV *req = ST(1);
333
62658f4d
PM
334 if (undef) {
335 if (pkg)
336 Perl_croak(aTHX_
337 "%s does not define $%s::VERSION--version check failed",
338 HvNAME(pkg), HvNAME(pkg));
339 else {
340 char *str = SvPVx(ST(0), len);
341
342 Perl_croak(aTHX_
343 "%s defines neither package nor VERSION--version check failed", str);
344 }
345 }
ad63d80f
JP
346 if ( !sv_derived_from(sv, "version"))
347 sv = new_version(sv);
348
349 if ( !sv_derived_from(req, "version"))
350 req = new_version(req);
1571675a 351
ad63d80f 352 if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
e3feee4e
RB
353 Perl_croak(aTHX_
354 "%s version %"SVf" required--this is only version %"SVf,
0773b1f0 355 HvNAME(pkg), req, sv);
2d8e6c8d 356 }
6d4a7be2
PP
357
358 ST(0) = sv;
359
360 XSRETURN(1);
361}
362
439cb1c4
JP
363XS(XS_version_new)
364{
365 dXSARGS;
129318bd 366 if (items > 3)
439cb1c4
JP
367 Perl_croak(aTHX_ "Usage: version::new(class, version)");
368 SP -= items;
369 {
370/* char * class = (char *)SvPV_nolen(ST(0)); */
129318bd
JP
371 SV *version = ST(1);
372 if (items == 3 )
373 {
374 char *vs = savepvn(SvPVX(ST(2)),SvCUR(ST(2)));
9be22fdc 375 version = Perl_newSVpvf(aTHX_ "v%s",vs);
129318bd 376 }
439cb1c4 377
129318bd 378 PUSHs(new_version(version));
439cb1c4
JP
379 PUTBACK;
380 return;
381 }
382}
383
384XS(XS_version_stringify)
385{
386 dXSARGS;
387 if (items < 1)
388 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
389 SP -= items;
390 {
391 SV * lobj;
392
393 if (sv_derived_from(ST(0), "version")) {
394 SV *tmp = SvRV(ST(0));
395 lobj = tmp;
396 }
397 else
ba329e04 398 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
399
400{
ad63d80f 401 PUSHs(vstringify(lobj));
439cb1c4
JP
402}
403
404 PUTBACK;
405 return;
406 }
407}
408
409XS(XS_version_numify)
410{
411 dXSARGS;
412 if (items < 1)
413 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
414 SP -= items;
415 {
416 SV * lobj;
417
418 if (sv_derived_from(ST(0), "version")) {
419 SV *tmp = SvRV(ST(0));
420 lobj = tmp;
421 }
422 else
ba329e04 423 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
424
425{
ad63d80f 426 PUSHs(vnumify(lobj));
439cb1c4
JP
427}
428
429 PUTBACK;
430 return;
431 }
432}
433
434XS(XS_version_vcmp)
435{
436 dXSARGS;
437 if (items < 1)
438 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
439 SP -= items;
440 {
441 SV * lobj;
442
443 if (sv_derived_from(ST(0), "version")) {
444 SV *tmp = SvRV(ST(0));
445 lobj = tmp;
446 }
447 else
ba329e04 448 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
449
450{
451 SV *rs;
452 SV *rvs;
453 SV * robj = ST(1);
454 IV swap = (IV)SvIV(ST(2));
455
456 if ( ! sv_derived_from(robj, "version") )
457 {
458 robj = new_version(robj);
459 }
460 rvs = SvRV(robj);
461
462 if ( swap )
463 {
ad63d80f 464 rs = newSViv(vcmp(rvs,lobj));
439cb1c4
JP
465 }
466 else
467 {
ad63d80f 468 rs = newSViv(vcmp(lobj,rvs));
439cb1c4
JP
469 }
470
471 PUSHs(rs);
472}
473
474 PUTBACK;
475 return;
476 }
477}
478
479XS(XS_version_boolean)
480{
481 dXSARGS;
482 if (items < 1)
483 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
484 SP -= items;
485 {
486 SV * lobj;
487
488 if (sv_derived_from(ST(0), "version")) {
489 SV *tmp = SvRV(ST(0));
490 lobj = tmp;
491 }
492 else
ba329e04 493 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
494
495{
496 SV *rs;
ad63d80f 497 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
439cb1c4
JP
498 PUSHs(rs);
499}
500
501 PUTBACK;
502 return;
503 }
504}
505
506XS(XS_version_noop)
507{
508 dXSARGS;
509 if (items < 1)
510 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
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{
ba329e04 522 Perl_croak(aTHX_ "operation not supported with version object");
439cb1c4
JP
523}
524
525 }
526 XSRETURN_EMPTY;
527}
528
1b026014
NIS
529XS(XS_utf8_valid)
530{
531 dXSARGS;
532 if (items != 1)
533 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
534 {
535 SV * sv = ST(0);
536 {
537 STRLEN len;
538 char *s = SvPV(sv,len);
539 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
540 XSRETURN_YES;
541 else
542 XSRETURN_NO;
543 }
544 }
545 XSRETURN_EMPTY;
546}
547
548XS(XS_utf8_encode)
549{
550 dXSARGS;
551 if (items != 1)
552 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
553 {
554 SV * sv = ST(0);
555
556 sv_utf8_encode(sv);
557 }
558 XSRETURN_EMPTY;
559}
560
561XS(XS_utf8_decode)
562{
563 dXSARGS;
564 if (items != 1)
565 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
566 {
567 SV * sv = ST(0);
568 bool RETVAL;
569
570 RETVAL = sv_utf8_decode(sv);
571 ST(0) = boolSV(RETVAL);
572 sv_2mortal(ST(0));
573 }
574 XSRETURN(1);
575}
576
577XS(XS_utf8_upgrade)
578{
579 dXSARGS;
580 if (items != 1)
581 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
582 {
583 SV * sv = ST(0);
584 STRLEN RETVAL;
585 dXSTARG;
586
587 RETVAL = sv_utf8_upgrade(sv);
588 XSprePUSH; PUSHi((IV)RETVAL);
589 }
590 XSRETURN(1);
591}
592
593XS(XS_utf8_downgrade)
594{
595 dXSARGS;
596 if (items < 1 || items > 2)
597 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
598 {
599 SV * sv = ST(0);
600 bool failok;
601 bool RETVAL;
602
603 if (items < 2)
604 failok = 0;
605 else {
606 failok = (int)SvIV(ST(1));
607 }
608
609 RETVAL = sv_utf8_downgrade(sv, failok);
610 ST(0) = boolSV(RETVAL);
611 sv_2mortal(ST(0));
612 }
613 XSRETURN(1);
614}
615
616XS(XS_utf8_native_to_unicode)
617{
618 dXSARGS;
619 UV uv = SvUV(ST(0));
b7953727
JH
620
621 if (items > 1)
622 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
623
1b026014
NIS
624 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
625 XSRETURN(1);
626}
627
628XS(XS_utf8_unicode_to_native)
629{
630 dXSARGS;
631 UV uv = SvUV(ST(0));
b7953727
JH
632
633 if (items > 1)
634 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
635
1b026014
NIS
636 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
637 XSRETURN(1);
638}
639
14a976d6 640XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH
641{
642 dXSARGS;
643 SV *sv = SvRV(ST(0));
644 if (items == 1) {
645 if (SvREADONLY(sv))
646 XSRETURN_YES;
647 else
648 XSRETURN_NO;
649 }
650 else if (items == 2) {
651 if (SvTRUE(ST(1))) {
652 SvREADONLY_on(sv);
653 XSRETURN_YES;
654 }
655 else {
14a976d6 656 /* I hope you really know what you are doing. */
29569577
JH
657 SvREADONLY_off(sv);
658 XSRETURN_NO;
659 }
660 }
14a976d6 661 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
662}
663
14a976d6 664XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
665{
666 dXSARGS;
667 SV *sv = SvRV(ST(0));
668 if (items == 1)
14a976d6 669 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 670 else if (items == 2) {
14a976d6 671 /* I hope you really know what you are doing. */
29569577
JH
672 SvREFCNT(sv) = SvIV(ST(1));
673 XSRETURN_IV(SvREFCNT(sv));
674 }
14a976d6 675 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
676}
677
dfd4ef2f
NC
678/* Maybe this should return the number of placeholders found in scalar context,
679 and a list of them in list context. */
f044d0d1 680XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC
681{
682 dXSARGS;
683 HV *hv = (HV *) SvRV(ST(0));
684
685 /* I don't care how many parameters were passed in, but I want to avoid
686 the unused variable warning. */
687
eb160463 688 items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f
NC
689
690 if (items) {
691 HE *entry;
692 I32 riter = HvRITER(hv);
693 HE *eiter = HvEITER(hv);
694 hv_iterinit(hv);
fe7bca90
NC
695 /* This may look suboptimal with the items *after* the iternext, but
696 it's quite deliberate. We only get here with items==0 if we've
697 just deleted the last placeholder in the hash. If we've just done
698 that then it means that the hash is in lazy delete mode, and the
699 HE is now only referenced in our iterator. If we just quit the loop
700 and discarded our iterator then the HE leaks. So we do the && the
701 other way to ensure iternext is called just one more time, which
702 has the side effect of triggering the lazy delete. */
703 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
704 && items) {
dfd4ef2f
NC
705 SV *val = hv_iterval(hv, entry);
706
707 if (val == &PL_sv_undef) {
708
709 /* It seems that I have to go back in the front of the hash
710 API to delete a hash, even though I have a HE structure
711 pointing to the very entry I want to delete, and could hold
712 onto the previous HE that points to it. And it's easier to
713 go in with SVs as I can then specify the precomputed hash,
714 and don't have fun and games with utf8 keys. */
715 SV *key = hv_iterkeysv(entry);
716
717 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
718 items--;
719 }
720 }
721 HvRITER(hv) = riter;
722 HvEITER(hv) = eiter;
723 }
724
725 XSRETURN(0);
726}
39f7a870 727
39cff0d9
AE
728XS(XS_Regexp_DESTROY)
729{
730
731}
732
39f7a870
JH
733XS(XS_PerlIO_get_layers)
734{
735 dXSARGS;
736 if (items < 1 || items % 2 == 0)
737 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
5fef3b4a 738#ifdef USE_PERLIO
39f7a870
JH
739 {
740 SV * sv;
741 GV * gv;
742 IO * io;
743 bool input = TRUE;
744 bool details = FALSE;
745
746 if (items > 1) {
39f7a870
JH
747 SV **svp;
748
749 for (svp = MARK + 2; svp <= SP; svp += 2) {
750 SV **varp = svp;
751 SV **valp = svp + 1;
752 STRLEN klen;
753 char *key = SvPV(*varp, klen);
754
755 switch (*key) {
756 case 'i':
757 if (klen == 5 && memEQ(key, "input", 5)) {
758 input = SvTRUE(*valp);
759 break;
760 }
761 goto fail;
762 case 'o':
763 if (klen == 6 && memEQ(key, "output", 6)) {
764 input = !SvTRUE(*valp);
765 break;
766 }
767 goto fail;
768 case 'd':
769 if (klen == 7 && memEQ(key, "details", 7)) {
770 details = SvTRUE(*valp);
771 break;
772 }
773 goto fail;
774 default:
775 fail:
776 Perl_croak(aTHX_
777 "get_layers: unknown argument '%s'",
778 key);
779 }
780 }
781
782 SP -= (items - 1);
783 }
784
785 sv = POPs;
786 gv = (GV*)sv;
787
788 if (!isGV(sv)) {
789 if (SvROK(sv) && isGV(SvRV(sv)))
790 gv = (GV*)SvRV(sv);
791 else
792 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
793 }
794
795 if (gv && (io = GvIO(gv))) {
796 dTARGET;
797 AV* av = PerlIO_get_layers(aTHX_ input ?
798 IoIFP(io) : IoOFP(io));
799 I32 i;
800 I32 last = av_len(av);
801 I32 nitem = 0;
802
803 for (i = last; i >= 0; i -= 3) {
804 SV **namsvp;
805 SV **argsvp;
806 SV **flgsvp;
807 bool namok, argok, flgok;
808
809 namsvp = av_fetch(av, i - 2, FALSE);
810 argsvp = av_fetch(av, i - 1, FALSE);
811 flgsvp = av_fetch(av, i, FALSE);
812
813 namok = namsvp && *namsvp && SvPOK(*namsvp);
814 argok = argsvp && *argsvp && SvPOK(*argsvp);
815 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
816
817 if (details) {
818 XPUSHs(namok ?
819 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
820 XPUSHs(argok ?
821 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
822 if (flgok)
823 XPUSHi(SvIVX(*flgsvp));
824 else
825 XPUSHs(&PL_sv_undef);
826 nitem += 3;
827 }
828 else {
829 if (namok && argok)
830 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
831 *namsvp, *argsvp));
832 else if (namok)
833 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
834 else
835 XPUSHs(&PL_sv_undef);
836 nitem++;
837 if (flgok) {
838 IV flags = SvIVX(*flgsvp);
839
840 if (flags & PERLIO_F_UTF8) {
841 XPUSHs(newSVpvn("utf8", 4));
842 nitem++;
843 }
844 }
845 }
846 }
847
848 SvREFCNT_dec(av);
849
850 XSRETURN(nitem);
851 }
852 }
5fef3b4a 853#endif
39f7a870
JH
854
855 XSRETURN(0);
856}
857