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