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