This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Regenerate META.yml
[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 47
a1d407e8
DM
48 if (strEQ(name, "UNIVERSAL"))
49 return &PL_sv_yes;
50
6d4a7be2 51 if (level > 100)
46e4b22b
GS
52 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
53 HvNAME(stash));
6d4a7be2
PP
54
55 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
56
46e4b22b
GS
57 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
58 && (hv = GvHV(gv)))
59 {
eb160463 60 if (SvIV(subgen) == (IV)PL_sub_generation) {
46e4b22b
GS
61 SV* sv;
62 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
63 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
64 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
65 name, HvNAME(stash)) );
66 return sv;
67 }
68 }
69 else {
70 DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
71 HvNAME(stash)) );
72 hv_clear(hv);
73 sv_setiv(subgen, PL_sub_generation);
74 }
6d4a7be2
PP
75 }
76
77 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
46e4b22b 78
3280af22 79 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
46e4b22b 80 if (!hv || !subgen) {
6d4a7be2
PP
81 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
82
83 gv = *gvp;
84
85 if (SvTYPE(gv) != SVt_PVGV)
86 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
87
46e4b22b
GS
88 if (!hv)
89 hv = GvHVn(gv);
90 if (!subgen) {
91 subgen = newSViv(PL_sub_generation);
92 GvSV(gv) = subgen;
93 }
6d4a7be2 94 }
46e4b22b 95 if (hv) {
6d4a7be2 96 SV** svp = AvARRAY(av);
93965878
NIS
97 /* NOTE: No support for tied ISA */
98 I32 items = AvFILLp(av) + 1;
6d4a7be2
PP
99 while (items--) {
100 SV* sv = *svp++;
101 HV* basestash = gv_stashsv(sv, FALSE);
102 if (!basestash) {
599cee73 103 if (ckWARN(WARN_MISC))
9014280d 104 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
35c1215d
NC
105 "Can't locate package %"SVf" for @%s::ISA",
106 sv, HvNAME(stash));
6d4a7be2
PP
107 continue;
108 }
301daebc
MS
109 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
110 len, level + 1)) {
3280af22
NIS
111 (void)hv_store(hv,name,len,&PL_sv_yes,0);
112 return &PL_sv_yes;
6d4a7be2
PP
113 }
114 }
3280af22 115 (void)hv_store(hv,name,len,&PL_sv_no,0);
6d4a7be2
PP
116 }
117 }
a1d407e8 118 return &PL_sv_no;
6d4a7be2
PP
119}
120
954c1994 121/*
ccfc67b7
JH
122=head1 SV Manipulation Functions
123
954c1994
GS
124=for apidoc sv_derived_from
125
126Returns a boolean indicating whether the SV is derived from the specified
127class. This is the function that implements C<UNIVERSAL::isa>. It works
128for class names as well as for objects.
129
130=cut
131*/
132
55497cff 133bool
864dbfa3 134Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
55497cff 135{
55497cff
PP
136 char *type;
137 HV *stash;
301daebc 138 HV *name_stash;
46e4b22b 139
55497cff
PP
140 stash = Nullhv;
141 type = Nullch;
46e4b22b 142
55497cff
PP
143 if (SvGMAGICAL(sv))
144 mg_get(sv) ;
145
146 if (SvROK(sv)) {
147 sv = SvRV(sv);
148 type = sv_reftype(sv,0);
46e4b22b 149 if (SvOBJECT(sv))
55497cff
PP
150 stash = SvSTASH(sv);
151 }
152 else {
153 stash = gv_stashsv(sv, FALSE);
154 }
46e4b22b 155
301daebc
MS
156 name_stash = gv_stashpv(name, FALSE);
157
55497cff 158 return (type && strEQ(type,name)) ||
301daebc
MS
159 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
160 == &PL_sv_yes)
55497cff
PP
161 ? TRUE
162 : FALSE ;
55497cff
PP
163}
164
1b026014
NIS
165#include "XSUB.h"
166
acfe0abc
GS
167void XS_UNIVERSAL_isa(pTHX_ CV *cv);
168void XS_UNIVERSAL_can(pTHX_ CV *cv);
169void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
439cb1c4
JP
170XS(XS_version_new);
171XS(XS_version_stringify);
172XS(XS_version_numify);
173XS(XS_version_vcmp);
174XS(XS_version_boolean);
175XS(XS_version_noop);
c8d69e4a 176XS(XS_version_is_alpha);
137d6fc0 177XS(XS_version_qv);
8800c35a 178XS(XS_utf8_is_utf8);
1b026014
NIS
179XS(XS_utf8_valid);
180XS(XS_utf8_encode);
181XS(XS_utf8_decode);
182XS(XS_utf8_upgrade);
183XS(XS_utf8_downgrade);
184XS(XS_utf8_unicode_to_native);
185XS(XS_utf8_native_to_unicode);
29569577
JH
186XS(XS_Internals_SvREADONLY);
187XS(XS_Internals_SvREFCNT);
f044d0d1 188XS(XS_Internals_hv_clear_placehold);
39f7a870 189XS(XS_PerlIO_get_layers);
39cff0d9 190XS(XS_Regexp_DESTROY);
9a7034eb 191XS(XS_Internals_hash_seed);
008fb0c0 192XS(XS_Internals_rehash_seed);
05619474 193XS(XS_Internals_HvREHASH);
0cb96387
GS
194
195void
196Perl_boot_core_UNIVERSAL(pTHX)
197{
198 char *file = __FILE__;
199
200 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
201 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
202 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
439cb1c4 203 {
ad63d80f
JP
204 /* register the overloading (type 'A') magic */
205 PL_amagic_generation++;
439cb1c4 206 /* Make it findable via fetchmethod */
be2ebcad 207 newXS("version::()", XS_version_noop, file);
439cb1c4
JP
208 newXS("version::new", XS_version_new, file);
209 newXS("version::(\"\"", XS_version_stringify, file);
210 newXS("version::stringify", XS_version_stringify, file);
211 newXS("version::(0+", XS_version_numify, file);
212 newXS("version::numify", XS_version_numify, file);
213 newXS("version::(cmp", XS_version_vcmp, file);
214 newXS("version::(<=>", XS_version_vcmp, file);
215 newXS("version::vcmp", XS_version_vcmp, file);
216 newXS("version::(bool", XS_version_boolean, file);
217 newXS("version::boolean", XS_version_boolean, file);
218 newXS("version::(nomethod", XS_version_noop, file);
219 newXS("version::noop", XS_version_noop, file);
c8d69e4a 220 newXS("version::is_alpha", XS_version_is_alpha, file);
137d6fc0 221 newXS("version::qv", XS_version_qv, file);
439cb1c4 222 }
8800c35a 223 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
1b026014
NIS
224 newXS("utf8::valid", XS_utf8_valid, file);
225 newXS("utf8::encode", XS_utf8_encode, file);
226 newXS("utf8::decode", XS_utf8_decode, file);
227 newXS("utf8::upgrade", XS_utf8_upgrade, file);
228 newXS("utf8::downgrade", XS_utf8_downgrade, file);
229 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
230 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577
JH
231 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
232 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f 233 newXSproto("Internals::hv_clear_placeholders",
f044d0d1 234 XS_Internals_hv_clear_placehold, file, "\\%");
9d569fce
JH
235 newXSproto("PerlIO::get_layers",
236 XS_PerlIO_get_layers, file, "*;@");
39cff0d9 237 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
9a7034eb 238 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
008fb0c0 239 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
05619474 240 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
0cb96387
GS
241}
242
55497cff 243
6d4a7be2
PP
244XS(XS_UNIVERSAL_isa)
245{
246 dXSARGS;
55497cff
PP
247 SV *sv;
248 char *name;
2d8e6c8d 249 STRLEN n_a;
6d4a7be2
PP
250
251 if (items != 2)
cea2e8a9 252 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2
PP
253
254 sv = ST(0);
f8f70380 255
d3f7f2b2
GS
256 if (SvGMAGICAL(sv))
257 mg_get(sv);
258
253ecd6d
RGS
259 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
260 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380
GS
261 XSRETURN_UNDEF;
262
2d8e6c8d 263 name = (char *)SvPV(ST(1),n_a);
6d4a7be2 264
54310121 265 ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2
PP
266 XSRETURN(1);
267}
268
6d4a7be2
PP
269XS(XS_UNIVERSAL_can)
270{
271 dXSARGS;
272 SV *sv;
273 char *name;
274 SV *rv;
6f08146e 275 HV *pkg = NULL;
2d8e6c8d 276 STRLEN n_a;
6d4a7be2
PP
277
278 if (items != 2)
cea2e8a9 279 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2
PP
280
281 sv = ST(0);
f8f70380 282
d3f7f2b2
GS
283 if (SvGMAGICAL(sv))
284 mg_get(sv);
285
253ecd6d
RGS
286 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
287 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380
GS
288 XSRETURN_UNDEF;
289
2d8e6c8d 290 name = (char *)SvPV(ST(1),n_a);
3280af22 291 rv = &PL_sv_undef;
6d4a7be2 292
46e4b22b 293 if (SvROK(sv)) {
6f08146e 294 sv = (SV*)SvRV(sv);
46e4b22b 295 if (SvOBJECT(sv))
6f08146e
NIS
296 pkg = SvSTASH(sv);
297 }
298 else {
299 pkg = gv_stashsv(sv, FALSE);
300 }
301
302 if (pkg) {
dc848c6f
PP
303 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
304 if (gv && isGV(gv))
305 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2
PP
306 }
307
308 ST(0) = rv;
309 XSRETURN(1);
310}
311
6d4a7be2
PP
312XS(XS_UNIVERSAL_VERSION)
313{
314 dXSARGS;
315 HV *pkg;
316 GV **gvp;
317 GV *gv;
318 SV *sv;
319 char *undef;
320
1571675a 321 if (SvROK(ST(0))) {
6d4a7be2 322 sv = (SV*)SvRV(ST(0));
1571675a 323 if (!SvOBJECT(sv))
cea2e8a9 324 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2
PP
325 pkg = SvSTASH(sv);
326 }
327 else {
328 pkg = gv_stashsv(ST(0), FALSE);
329 }
330
331 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
332
d4bea2fb 333 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2
PP
334 SV *nsv = sv_newmortal();
335 sv_setsv(nsv, sv);
336 sv = nsv;
137d6fc0
JP
337 if ( !sv_derived_from(sv, "version"))
338 upg_version(sv);
6d4a7be2
PP
339 undef = Nullch;
340 }
341 else {
3280af22 342 sv = (SV*)&PL_sv_undef;
6d4a7be2
PP
343 undef = "(undef)";
344 }
345
1571675a
GS
346 if (items > 1) {
347 STRLEN len;
348 SV *req = ST(1);
349
62658f4d
PM
350 if (undef) {
351 if (pkg)
352 Perl_croak(aTHX_
353 "%s does not define $%s::VERSION--version check failed",
354 HvNAME(pkg), HvNAME(pkg));
355 else {
356 char *str = SvPVx(ST(0), len);
357
358 Perl_croak(aTHX_
359 "%s defines neither package nor VERSION--version check failed", str);
360 }
361 }
ad63d80f 362
137d6fc0
JP
363 if ( !sv_derived_from(req, "version")) {
364 /* req may very well be R/O, so create a new object */
365 SV *nsv = sv_newmortal();
366 sv_setsv(nsv, req);
367 req = nsv;
368 upg_version(req);
369 }
1571675a 370
137d6fc0 371 if ( vcmp( req, sv ) > 0 )
e3feee4e
RB
372 Perl_croak(aTHX_
373 "%s version %"SVf" required--this is only version %"SVf,
0773b1f0 374 HvNAME(pkg), req, sv);
2d8e6c8d 375 }
6d4a7be2
PP
376
377 ST(0) = sv;
378
379 XSRETURN(1);
380}
381
439cb1c4
JP
382XS(XS_version_new)
383{
384 dXSARGS;
129318bd 385 if (items > 3)
439cb1c4
JP
386 Perl_croak(aTHX_ "Usage: version::new(class, version)");
387 SP -= items;
388 {
137d6fc0
JP
389 char * class = (char *)SvPV_nolen(ST(0));
390 SV *vs = ST(1);
391 SV *rv;
129318bd
JP
392 if (items == 3 )
393 {
137d6fc0
JP
394 vs = sv_newmortal();
395 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen(ST(2)));
129318bd 396 }
439cb1c4 397
137d6fc0
JP
398 rv = new_version(vs);
399 if ( strcmp(class,"version") != 0 ) /* inherited new() */
400 sv_bless(rv, gv_stashpv(class,TRUE));
401
402 PUSHs(sv_2mortal(rv));
439cb1c4
JP
403 PUTBACK;
404 return;
405 }
406}
407
408XS(XS_version_stringify)
409{
41be1fbd
JH
410 dXSARGS;
411 if (items < 1)
412 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
413 SP -= items;
414 {
415 SV * lobj;
416
417 if (sv_derived_from(ST(0), "version")) {
418 SV *tmp = SvRV(ST(0));
419 lobj = tmp;
420 }
421 else
422 Perl_croak(aTHX_ "lobj is not of type version");
423
137d6fc0 424 PUSHs(sv_2mortal(vstringify(lobj)));
41be1fbd
JH
425
426 PUTBACK;
427 return;
428 }
439cb1c4
JP
429}
430
431XS(XS_version_numify)
432{
41be1fbd
JH
433 dXSARGS;
434 if (items < 1)
435 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
436 SP -= items;
437 {
438 SV * lobj;
439
440 if (sv_derived_from(ST(0), "version")) {
441 SV *tmp = SvRV(ST(0));
442 lobj = tmp;
443 }
444 else
445 Perl_croak(aTHX_ "lobj is not of type version");
446
137d6fc0 447 PUSHs(sv_2mortal(vnumify(lobj)));
41be1fbd
JH
448
449 PUTBACK;
450 return;
451 }
439cb1c4
JP
452}
453
454XS(XS_version_vcmp)
455{
41be1fbd
JH
456 dXSARGS;
457 if (items < 1)
458 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
459 SP -= items;
460 {
461 SV * lobj;
462
463 if (sv_derived_from(ST(0), "version")) {
464 SV *tmp = SvRV(ST(0));
465 lobj = tmp;
466 }
467 else
468 Perl_croak(aTHX_ "lobj is not of type version");
469
470 {
471 SV *rs;
472 SV *rvs;
473 SV * robj = ST(1);
474 IV swap = (IV)SvIV(ST(2));
475
476 if ( ! sv_derived_from(robj, "version") )
477 {
478 robj = new_version(robj);
479 }
480 rvs = SvRV(robj);
481
482 if ( swap )
483 {
484 rs = newSViv(vcmp(rvs,lobj));
485 }
486 else
487 {
488 rs = newSViv(vcmp(lobj,rvs));
489 }
490
137d6fc0 491 PUSHs(sv_2mortal(rs));
41be1fbd
JH
492 }
493
494 PUTBACK;
495 return;
496 }
439cb1c4
JP
497}
498
499XS(XS_version_boolean)
500{
41be1fbd
JH
501 dXSARGS;
502 if (items < 1)
503 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
504 SP -= items;
505 {
506 SV * lobj;
507
508 if (sv_derived_from(ST(0), "version")) {
509 SV *tmp = SvRV(ST(0));
510 lobj = tmp;
511 }
512 else
513 Perl_croak(aTHX_ "lobj is not of type version");
514
515 {
516 SV *rs;
517 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
137d6fc0 518 PUSHs(sv_2mortal(rs));
41be1fbd
JH
519 }
520
521 PUTBACK;
522 return;
523 }
439cb1c4
JP
524}
525
526XS(XS_version_noop)
527{
41be1fbd
JH
528 dXSARGS;
529 if (items < 1)
530 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
531 {
532 SV * lobj;
533
534 if (sv_derived_from(ST(0), "version")) {
535 SV *tmp = SvRV(ST(0));
536 lobj = tmp;
537 }
538 else
539 Perl_croak(aTHX_ "lobj is not of type version");
540
541 {
542 Perl_croak(aTHX_ "operation not supported with version object");
543 }
544
545 }
546 XSRETURN_EMPTY;
439cb1c4
JP
547}
548
c8d69e4a
JP
549XS(XS_version_is_alpha)
550{
551 dXSARGS;
552 if (items != 1)
553 Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
554 SP -= items;
555 {
556 SV *lobj;
557
558 if (sv_derived_from(ST(0), "version")) {
559 SV *tmp = SvRV(ST(0));
560 lobj = tmp;
561 }
562 else
563 Perl_croak(aTHX_ "lobj is not of type version");
564{
565 I32 len = av_len((AV *)lobj);
566 I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0));
567 if ( digit < 0 )
568 XSRETURN_YES;
569 else
570 XSRETURN_NO;
571}
572 PUTBACK;
573 return;
574 }
575}
576
137d6fc0
JP
577XS(XS_version_qv)
578{
579 dXSARGS;
580 if (items != 1)
581 Perl_croak(aTHX_ "Usage: version::qv(ver)");
582 SP -= items;
583 {
584 SV * ver = ST(0);
585 if ( !SvVOK(ver) ) /* only need to do with if not already v-string */
586 {
587 SV *vs = sv_newmortal();
588 char *version;
589 if ( SvNOK(ver) ) /* may get too much accuracy */
590 {
591 char tbuf[64];
592 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
593 version = savepv(tbuf);
594 }
595 else
596 {
597 version = savepv(SvPV_nolen(ver));
598 }
599 (void)scan_version(version,vs,TRUE);
600 Safefree(version);
601
602 PUSHs(vs);
603 }
604 else
605 {
606 PUSHs(sv_2mortal(new_version(ver)));
607 }
608
609 PUTBACK;
610 return;
611 }
612}
613
8800c35a
JH
614XS(XS_utf8_is_utf8)
615{
41be1fbd
JH
616 dXSARGS;
617 if (items != 1)
618 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
619 {
620 SV * sv = ST(0);
621 {
622 if (SvUTF8(sv))
623 XSRETURN_YES;
624 else
625 XSRETURN_NO;
626 }
627 }
628 XSRETURN_EMPTY;
8800c35a
JH
629}
630
1b026014
NIS
631XS(XS_utf8_valid)
632{
41be1fbd
JH
633 dXSARGS;
634 if (items != 1)
635 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
636 {
637 SV * sv = ST(0);
638 {
639 STRLEN len;
640 char *s = SvPV(sv,len);
641 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
642 XSRETURN_YES;
643 else
644 XSRETURN_NO;
645 }
646 }
647 XSRETURN_EMPTY;
1b026014
NIS
648}
649
650XS(XS_utf8_encode)
651{
652 dXSARGS;
653 if (items != 1)
654 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
655 {
656 SV * sv = ST(0);
657
658 sv_utf8_encode(sv);
659 }
660 XSRETURN_EMPTY;
661}
662
663XS(XS_utf8_decode)
664{
665 dXSARGS;
666 if (items != 1)
667 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
668 {
669 SV * sv = ST(0);
670 bool RETVAL;
671
672 RETVAL = sv_utf8_decode(sv);
673 ST(0) = boolSV(RETVAL);
674 sv_2mortal(ST(0));
675 }
676 XSRETURN(1);
677}
678
679XS(XS_utf8_upgrade)
680{
681 dXSARGS;
682 if (items != 1)
683 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
684 {
685 SV * sv = ST(0);
686 STRLEN RETVAL;
687 dXSTARG;
688
689 RETVAL = sv_utf8_upgrade(sv);
690 XSprePUSH; PUSHi((IV)RETVAL);
691 }
692 XSRETURN(1);
693}
694
695XS(XS_utf8_downgrade)
696{
697 dXSARGS;
698 if (items < 1 || items > 2)
699 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
700 {
701 SV * sv = ST(0);
702 bool failok;
703 bool RETVAL;
704
705 if (items < 2)
706 failok = 0;
707 else {
708 failok = (int)SvIV(ST(1));
709 }
710
711 RETVAL = sv_utf8_downgrade(sv, failok);
712 ST(0) = boolSV(RETVAL);
713 sv_2mortal(ST(0));
714 }
715 XSRETURN(1);
716}
717
718XS(XS_utf8_native_to_unicode)
719{
720 dXSARGS;
721 UV uv = SvUV(ST(0));
b7953727
JH
722
723 if (items > 1)
724 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
725
1b026014
NIS
726 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
727 XSRETURN(1);
728}
729
730XS(XS_utf8_unicode_to_native)
731{
732 dXSARGS;
733 UV uv = SvUV(ST(0));
b7953727
JH
734
735 if (items > 1)
736 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
737
1b026014
NIS
738 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
739 XSRETURN(1);
740}
741
14a976d6 742XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH
743{
744 dXSARGS;
745 SV *sv = SvRV(ST(0));
746 if (items == 1) {
747 if (SvREADONLY(sv))
748 XSRETURN_YES;
749 else
750 XSRETURN_NO;
751 }
752 else if (items == 2) {
753 if (SvTRUE(ST(1))) {
754 SvREADONLY_on(sv);
755 XSRETURN_YES;
756 }
757 else {
14a976d6 758 /* I hope you really know what you are doing. */
29569577
JH
759 SvREADONLY_off(sv);
760 XSRETURN_NO;
761 }
762 }
14a976d6 763 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
764}
765
14a976d6 766XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
767{
768 dXSARGS;
769 SV *sv = SvRV(ST(0));
770 if (items == 1)
14a976d6 771 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 772 else if (items == 2) {
14a976d6 773 /* I hope you really know what you are doing. */
29569577
JH
774 SvREFCNT(sv) = SvIV(ST(1));
775 XSRETURN_IV(SvREFCNT(sv));
776 }
14a976d6 777 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
778}
779
f044d0d1 780XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC
781{
782 dXSARGS;
783 HV *hv = (HV *) SvRV(ST(0));
3540d4ce
AB
784 if (items != 1)
785 Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
786 hv_clear_placeholders(hv);
dfd4ef2f
NC
787 XSRETURN(0);
788}
39f7a870 789
39cff0d9
AE
790XS(XS_Regexp_DESTROY)
791{
792
793}
794
39f7a870
JH
795XS(XS_PerlIO_get_layers)
796{
797 dXSARGS;
798 if (items < 1 || items % 2 == 0)
799 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
5fef3b4a 800#ifdef USE_PERLIO
39f7a870
JH
801 {
802 SV * sv;
803 GV * gv;
804 IO * io;
805 bool input = TRUE;
806 bool details = FALSE;
807
808 if (items > 1) {
39f7a870
JH
809 SV **svp;
810
811 for (svp = MARK + 2; svp <= SP; svp += 2) {
812 SV **varp = svp;
813 SV **valp = svp + 1;
814 STRLEN klen;
815 char *key = SvPV(*varp, klen);
816
817 switch (*key) {
818 case 'i':
819 if (klen == 5 && memEQ(key, "input", 5)) {
820 input = SvTRUE(*valp);
821 break;
822 }
823 goto fail;
824 case 'o':
825 if (klen == 6 && memEQ(key, "output", 6)) {
826 input = !SvTRUE(*valp);
827 break;
828 }
829 goto fail;
830 case 'd':
831 if (klen == 7 && memEQ(key, "details", 7)) {
832 details = SvTRUE(*valp);
833 break;
834 }
835 goto fail;
836 default:
837 fail:
838 Perl_croak(aTHX_
839 "get_layers: unknown argument '%s'",
840 key);
841 }
842 }
843
844 SP -= (items - 1);
845 }
846
847 sv = POPs;
848 gv = (GV*)sv;
849
850 if (!isGV(sv)) {
851 if (SvROK(sv) && isGV(SvRV(sv)))
852 gv = (GV*)SvRV(sv);
853 else
854 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
855 }
856
857 if (gv && (io = GvIO(gv))) {
858 dTARGET;
859 AV* av = PerlIO_get_layers(aTHX_ input ?
860 IoIFP(io) : IoOFP(io));
861 I32 i;
862 I32 last = av_len(av);
863 I32 nitem = 0;
864
865 for (i = last; i >= 0; i -= 3) {
866 SV **namsvp;
867 SV **argsvp;
868 SV **flgsvp;
869 bool namok, argok, flgok;
870
871 namsvp = av_fetch(av, i - 2, FALSE);
872 argsvp = av_fetch(av, i - 1, FALSE);
873 flgsvp = av_fetch(av, i, FALSE);
874
875 namok = namsvp && *namsvp && SvPOK(*namsvp);
876 argok = argsvp && *argsvp && SvPOK(*argsvp);
877 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
878
879 if (details) {
880 XPUSHs(namok ?
881 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
882 XPUSHs(argok ?
883 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
884 if (flgok)
885 XPUSHi(SvIVX(*flgsvp));
886 else
887 XPUSHs(&PL_sv_undef);
888 nitem += 3;
889 }
890 else {
891 if (namok && argok)
892 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
893 *namsvp, *argsvp));
894 else if (namok)
895 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
896 else
897 XPUSHs(&PL_sv_undef);
898 nitem++;
899 if (flgok) {
900 IV flags = SvIVX(*flgsvp);
901
902 if (flags & PERLIO_F_UTF8) {
903 XPUSHs(newSVpvn("utf8", 4));
904 nitem++;
905 }
906 }
907 }
908 }
909
910 SvREFCNT_dec(av);
911
912 XSRETURN(nitem);
913 }
914 }
5fef3b4a 915#endif
39f7a870
JH
916
917 XSRETURN(0);
918}
919
9a7034eb 920XS(XS_Internals_hash_seed)
c910b28a 921{
c85d3f85
NC
922 /* Using dXSARGS would also have dITEM and dSP,
923 * which define 2 unused local variables. */
924 dMARK; dAX;
81eaca17 925 XSRETURN_UV(PERL_HASH_SEED);
c910b28a
JH
926}
927
008fb0c0 928XS(XS_Internals_rehash_seed)
8e90d776
NC
929{
930 /* Using dXSARGS would also have dITEM and dSP,
931 * which define 2 unused local variables. */
932 dMARK; dAX;
008fb0c0 933 XSRETURN_UV(PL_rehash_seed);
8e90d776
NC
934}
935
05619474
NC
936XS(XS_Internals_HvREHASH) /* Subject to change */
937{
938 dXSARGS;
939 if (SvROK(ST(0))) {
940 HV *hv = (HV *) SvRV(ST(0));
941 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
942 if (HvREHASH(hv))
943 XSRETURN_YES;
944 else
945 XSRETURN_NO;
946 }
947 }
948 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
949}