This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Clarify that it's only Mac OS *Classic* that uses 1904 - OS X uses
[perl5.git] / universal.c
CommitLineData
d6376244
JH		 1/* universal.c
2 *
b5f8cc5c 3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4bb101f2 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 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 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 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 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 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 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 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 113 }
114 }
3280af22 115 (void)hv_store(hv,name,len,&PL_sv_no,0);
6d4a7be2 116 }
117 }
a1d407e8 118 return &PL_sv_no;
6d4a7be2 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 136 char *type;
137 HV *stash;
301daebc 138 HV *name_stash;
46e4b22b 139
55497cff 140 stash = Nullhv;
141 type = Nullch;
46e4b22b 142
55497cff 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 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 161 ? TRUE
162 : FALSE ;
55497cff 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 244XS(XS_UNIVERSAL_isa)
245{
246 dXSARGS;
55497cff 247 SV *sv;
248 char *name;
2d8e6c8d 249 STRLEN n_a;
6d4a7be2 250
251 if (items != 2)
cea2e8a9 252 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2 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 266 XSRETURN(1);
267}
268
6d4a7be2 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 277
278 if (items != 2)
cea2e8a9 279 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2 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 303 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
304 if (gv && isGV(gv))
305 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2 306 }
307
308 ST(0) = rv;
309 XSRETURN(1);
310}
311
6d4a7be2 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 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 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 339 undef = Nullch;
340 }
341 else {
3280af22 342 sv = (SV*)&PL_sv_undef;
6d4a7be2 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 )
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 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 {
137d6fc0
JP		 393 char * class = (char *)SvPV_nolen(ST(0));
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
JP		 402 rv = new_version(vs);
403 if ( strcmp(class,"version") != 0 ) /* inherited new() */
404 sv_bless(rv, gv_stashpv(class,TRUE));
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 {
419 SV * lobj;
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 {
442 SV * lobj;
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 {
465 SV * lobj;
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 {
510 SV * lobj;
511
512 if (sv_derived_from(ST(0), "version")) {
513 SV *tmp = SvRV(ST(0));
514 lobj = tmp;
515 }
516 else
517 Perl_croak(aTHX_ "lobj is not of type version");
518
519 {
520 SV *rs;
521 rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) );
137d6fc0 522 PUSHs(sv_2mortal(rs));
41be1fbd
JH		 523 }
524
525 PUTBACK;
526 return;
527 }
439cb1c4
JP		 528}
529
530XS(XS_version_noop)
531{
41be1fbd
JH		 532 dXSARGS;
533 if (items < 1)
534 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
535 {
536 SV * lobj;
537
538 if (sv_derived_from(ST(0), "version")) {
539 SV *tmp = SvRV(ST(0));
540 lobj = tmp;
541 }
542 else
543 Perl_croak(aTHX_ "lobj is not of type version");
544
545 {
546 Perl_croak(aTHX_ "operation not supported with version object");
547 }
548
549 }
550 XSRETURN_EMPTY;
439cb1c4
JP		 551}
552
c8d69e4a
JP		 553XS(XS_version_is_alpha)
554{
555 dXSARGS;
556 if (items != 1)
557 Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
558 SP -= items;
559 {
560 SV *lobj;
561
562 if (sv_derived_from(ST(0), "version")) {
563 SV *tmp = SvRV(ST(0));
564 lobj = tmp;
565 }
566 else
567 Perl_croak(aTHX_ "lobj is not of type version");
568{
569 I32 len = av_len((AV *)lobj);
570 I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0));
571 if ( digit < 0 )
572 XSRETURN_YES;
573 else
574 XSRETURN_NO;
575}
576 PUTBACK;
577 return;
578 }
579}
580
137d6fc0
JP		 581XS(XS_version_qv)
582{
583 dXSARGS;
584 if (items != 1)
585 Perl_croak(aTHX_ "Usage: version::qv(ver)");
586 SP -= items;
587 {
588 SV * ver = ST(0);
589 if ( !SvVOK(ver) ) /* only need to do with if not already v-string */
590 {
591 SV *vs = sv_newmortal();
592 char *version;
593 if ( SvNOK(ver) ) /* may get too much accuracy */
594 {
595 char tbuf[64];
596 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
597 version = savepv(tbuf);
598 }
599 else
600 {
601 version = savepv(SvPV_nolen(ver));
602 }
603 (void)scan_version(version,vs,TRUE);
604 Safefree(version);
605
606 PUSHs(vs);
607 }
608 else
609 {
610 PUSHs(sv_2mortal(new_version(ver)));
611 }
612
613 PUTBACK;
614 return;
615 }
616}
617
8800c35a
JH		 618XS(XS_utf8_is_utf8)
619{
41be1fbd
JH		 620 dXSARGS;
621 if (items != 1)
622 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
623 {
624 SV * sv = ST(0);
625 {
626 if (SvUTF8(sv))
627 XSRETURN_YES;
628 else
629 XSRETURN_NO;
630 }
631 }
632 XSRETURN_EMPTY;
8800c35a
JH		 633}
634
1b026014
NIS		 635XS(XS_utf8_valid)
636{
41be1fbd
JH		 637 dXSARGS;
638 if (items != 1)
639 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
640 {
641 SV * sv = ST(0);
642 {
643 STRLEN len;
644 char *s = SvPV(sv,len);
645 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
646 XSRETURN_YES;
647 else
648 XSRETURN_NO;
649 }
650 }
651 XSRETURN_EMPTY;
1b026014
NIS		 652}
653
654XS(XS_utf8_encode)
655{
656 dXSARGS;
657 if (items != 1)
658 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
659 {
660 SV * sv = ST(0);
661
662 sv_utf8_encode(sv);
663 }
664 XSRETURN_EMPTY;
665}
666
667XS(XS_utf8_decode)
668{
669 dXSARGS;
670 if (items != 1)
671 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
672 {
673 SV * sv = ST(0);
674 bool RETVAL;
675
676 RETVAL = sv_utf8_decode(sv);
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);
706 bool failok;
707 bool RETVAL;
708
709 if (items < 2)
710 failok = 0;
711 else {
712 failok = (int)SvIV(ST(1));
713 }
714
715 RETVAL = sv_utf8_downgrade(sv, failok);
716 ST(0) = boolSV(RETVAL);
717 sv_2mortal(ST(0));
718 }
719 XSRETURN(1);
720}
721
722XS(XS_utf8_native_to_unicode)
723{
724 dXSARGS;
725 UV uv = SvUV(ST(0));
b7953727
JH		 726
727 if (items > 1)
728 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
729
1b026014
NIS		 730 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
731 XSRETURN(1);
732}
733
734XS(XS_utf8_unicode_to_native)
735{
736 dXSARGS;
737 UV uv = SvUV(ST(0));
b7953727
JH		 738
739 if (items > 1)
740 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
741
1b026014
NIS		 742 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
743 XSRETURN(1);
744}
745
14a976d6 746XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH		 747{
748 dXSARGS;
749 SV *sv = SvRV(ST(0));
750 if (items == 1) {
751 if (SvREADONLY(sv))
752 XSRETURN_YES;
753 else
754 XSRETURN_NO;
755 }
756 else if (items == 2) {
757 if (SvTRUE(ST(1))) {
758 SvREADONLY_on(sv);
759 XSRETURN_YES;
760 }
761 else {
14a976d6 762 /* I hope you really know what you are doing. */
29569577
JH		 763 SvREADONLY_off(sv);
764 XSRETURN_NO;
765 }
766 }
14a976d6 767 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH		 768}
769
14a976d6 770XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH		 771{
772 dXSARGS;
773 SV *sv = SvRV(ST(0));
774 if (items == 1)
14a976d6 775 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 776 else if (items == 2) {
14a976d6 777 /* I hope you really know what you are doing. */
29569577
JH		 778 SvREFCNT(sv) = SvIV(ST(1));
779 XSRETURN_IV(SvREFCNT(sv));
780 }
14a976d6 781 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH		 782}
783
f044d0d1 784XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC		 785{
786 dXSARGS;
787 HV *hv = (HV *) SvRV(ST(0));
3540d4ce
AB		 788 if (items != 1)
789 Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
790 hv_clear_placeholders(hv);
dfd4ef2f
NC		 791 XSRETURN(0);
792}
39f7a870 793
39cff0d9
AE		 794XS(XS_Regexp_DESTROY)
795{
796
797}
798
39f7a870
JH		 799XS(XS_PerlIO_get_layers)
800{
801 dXSARGS;
802 if (items < 1 || items % 2 == 0)
803 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
5fef3b4a 804#ifdef USE_PERLIO
39f7a870
JH		 805 {
806 SV * sv;
807 GV * gv;
808 IO * io;
809 bool input = TRUE;
810 bool details = FALSE;
811
812 if (items > 1) {
39f7a870
JH		 813 SV **svp;
814
815 for (svp = MARK + 2; svp <= SP; svp += 2) {
816 SV **varp = svp;
817 SV **valp = svp + 1;
818 STRLEN klen;
819 char *key = SvPV(*varp, klen);
820
821 switch (*key) {
822 case 'i':
823 if (klen == 5 && memEQ(key, "input", 5)) {
824 input = SvTRUE(*valp);
825 break;
826 }
827 goto fail;
828 case 'o':
829 if (klen == 6 && memEQ(key, "output", 6)) {
830 input = !SvTRUE(*valp);
831 break;
832 }
833 goto fail;
834 case 'd':
835 if (klen == 7 && memEQ(key, "details", 7)) {
836 details = SvTRUE(*valp);
837 break;
838 }
839 goto fail;
840 default:
841 fail:
842 Perl_croak(aTHX_
843 "get_layers: unknown argument '%s'",
844 key);
845 }
846 }
847
848 SP -= (items - 1);
849 }
850
851 sv = POPs;
852 gv = (GV*)sv;
853
854 if (!isGV(sv)) {
855 if (SvROK(sv) && isGV(SvRV(sv)))
856 gv = (GV*)SvRV(sv);
857 else
858 gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO);
859 }
860
861 if (gv && (io = GvIO(gv))) {
862 dTARGET;
863 AV* av = PerlIO_get_layers(aTHX_ input ?
864 IoIFP(io) : IoOFP(io));
865 I32 i;
866 I32 last = av_len(av);
867 I32 nitem = 0;
868
869 for (i = last; i >= 0; i -= 3) {
870 SV **namsvp;
871 SV **argsvp;
872 SV **flgsvp;
873 bool namok, argok, flgok;
874
875 namsvp = av_fetch(av, i - 2, FALSE);
876 argsvp = av_fetch(av, i - 1, FALSE);
877 flgsvp = av_fetch(av, i, FALSE);
878
879 namok = namsvp && *namsvp && SvPOK(*namsvp);
880 argok = argsvp && *argsvp && SvPOK(*argsvp);
881 flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
882
883 if (details) {
884 XPUSHs(namok ?
885 newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef);
886 XPUSHs(argok ?
887 newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef);
888 if (flgok)
889 XPUSHi(SvIVX(*flgsvp));
890 else
891 XPUSHs(&PL_sv_undef);
892 nitem += 3;
893 }
894 else {
895 if (namok && argok)
896 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
897 *namsvp, *argsvp));
898 else if (namok)
899 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp));
900 else
901 XPUSHs(&PL_sv_undef);
902 nitem++;
903 if (flgok) {
904 IV flags = SvIVX(*flgsvp);
905
906 if (flags & PERLIO_F_UTF8) {
907 XPUSHs(newSVpvn("utf8", 4));
908 nitem++;
909 }
910 }
911 }
912 }
913
914 SvREFCNT_dec(av);
915
916 XSRETURN(nitem);
917 }
918 }
5fef3b4a 919#endif
39f7a870
JH		 920
921 XSRETURN(0);
922}
923
9a7034eb 924XS(XS_Internals_hash_seed)
c910b28a 925{
c85d3f85
NC		 926 /* Using dXSARGS would also have dITEM and dSP,
927 * which define 2 unused local variables. */
928 dMARK; dAX;
81eaca17 929 XSRETURN_UV(PERL_HASH_SEED);
c910b28a
JH		 930}
931
008fb0c0 932XS(XS_Internals_rehash_seed)
8e90d776
NC		 933{
934 /* Using dXSARGS would also have dITEM and dSP,
935 * which define 2 unused local variables. */
936 dMARK; dAX;
008fb0c0 937 XSRETURN_UV(PL_rehash_seed);
8e90d776
NC		 938}
939
05619474
NC		 940XS(XS_Internals_HvREHASH) /* Subject to change */
941{
942 dXSARGS;
943 if (SvROK(ST(0))) {
944 HV *hv = (HV *) SvRV(ST(0));
945 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
946 if (HvREHASH(hv))
947 XSRETURN_YES;
948 else
949 XSRETURN_NO;
950 }
951 }
952 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
953}
Unnamed repository; edit this file 'description' to name the repository.