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