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