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