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