This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add HTTP::Tiny as a dual-life core module
[perl5.git] / universal.c
CommitLineData
d6376244
JH
1/* universal.c
2 *
b5f8cc5c 3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
1129b882 4 * 2005, 2006, 2007, 2008 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 11/*
4ac71550
TC
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 history
15 *
16 * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
d31a8517
AT
17 */
18
166f8a29
DM
19/* This file contains the code that implements the functions in Perl's
20 * UNIVERSAL package, such as UNIVERSAL->can().
192b9cd1
AB
21 *
22 * It is also used to store XS functions that need to be present in
23 * miniperl for a lack of a better place to put them. It might be
486ec47a 24 * clever to move them to separate XS files which would then be pulled
192b9cd1 25 * in by some to-be-written build process.
166f8a29
DM
26 */
27
6d4a7be2 28#include "EXTERN.h"
864dbfa3 29#define PERL_IN_UNIVERSAL_C
6d4a7be2 30#include "perl.h"
6d4a7be2 31
39f7a870
JH
32#ifdef USE_PERLIO
33#include "perliol.h" /* For the PERLIO_F_XXX */
34#endif
35
6d4a7be2
PP
36/*
37 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
38 * The main guts of traverse_isa was actually copied from gv_fetchmeth
39 */
40
a9ec700e 41STATIC bool
515a4f72 42S_isa_lookup(pTHX_ HV *stash, const char * const name)
6d4a7be2 43{
97aff369 44 dVAR;
a49ba3fc 45 const struct mro_meta *const meta = HvMROMETA(stash);
4340b386 46 HV *isa = meta->isa;
a49ba3fc
NC
47 STRLEN len = strlen(name);
48 const HV *our_stash;
6d4a7be2 49
7918f24d
NC
50 PERL_ARGS_ASSERT_ISA_LOOKUP;
51
4340b386
FC
52 if (!isa) {
53 (void)mro_get_linear_isa(stash);
54 isa = meta->isa;
55 }
56
a49ba3fc
NC
57 if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only
58 a char * argument*/,
59 HV_FETCH_ISEXISTS, NULL, 0)) {
60 /* Direct name lookup worked. */
a9ec700e 61 return TRUE;
a49ba3fc 62 }
6d4a7be2 63
a49ba3fc 64 /* A stash/class can go by many names (ie. User == main::User), so
81a5123c
FC
65 we use the HvENAME in the stash itself, which is canonical, falling
66 back to HvNAME if necessary. */
a49ba3fc
NC
67 our_stash = gv_stashpvn(name, len, 0);
68
69 if (our_stash) {
81a5123c
FC
70 HEK *canon_name = HvENAME_HEK(our_stash);
71 if (!canon_name) canon_name = HvNAME_HEK(our_stash);
a1d407e8 72
a49ba3fc
NC
73 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
74 HEK_FLAGS(canon_name),
75 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
e1a479c5 76 return TRUE;
a49ba3fc 77 }
6d4a7be2
PP
78 }
79
a9ec700e 80 return FALSE;
6d4a7be2
PP
81}
82
954c1994 83/*
ccfc67b7
JH
84=head1 SV Manipulation Functions
85
954c1994
GS
86=for apidoc sv_derived_from
87
6885da0e 88Returns a boolean indicating whether the SV is derived from the specified class
89I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
90normal Perl method.
954c1994
GS
91
92=cut
93*/
94
55497cff 95bool
15f169a1 96Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
55497cff 97{
97aff369 98 dVAR;
0b6f4f5c 99 HV *stash;
46e4b22b 100
7918f24d
NC
101 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
102
5b295bef 103 SvGETMAGIC(sv);
55497cff
PP
104
105 if (SvROK(sv)) {
0b6f4f5c 106 const char *type;
55497cff
PP
107 sv = SvRV(sv);
108 type = sv_reftype(sv,0);
0b6f4f5c
AL
109 if (type && strEQ(type,name))
110 return TRUE;
111 stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
55497cff
PP
112 }
113 else {
da51bb9b 114 stash = gv_stashsv(sv, 0);
55497cff 115 }
46e4b22b 116
4a9e32d8 117 return stash ? isa_lookup(stash, name) : FALSE;
55497cff
PP
118}
119
cbc021f9 120/*
121=for apidoc sv_does
122
123Returns a boolean indicating whether the SV performs a specific, named role.
124The SV can be a Perl object or the name of a Perl class.
125
126=cut
127*/
128
1b026014
NIS
129#include "XSUB.h"
130
cbc021f9 131bool
15f169a1 132Perl_sv_does(pTHX_ SV *sv, const char *const name)
cbc021f9 133{
134 const char *classname;
135 bool does_it;
59e7186f 136 SV *methodname;
cbc021f9 137 dSP;
7918f24d
NC
138
139 PERL_ARGS_ASSERT_SV_DOES;
140
cbc021f9 141 ENTER;
142 SAVETMPS;
143
144 SvGETMAGIC(sv);
145
146 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
7ce46f2a
GG
147 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
148 LEAVE;
cbc021f9 149 return FALSE;
7ce46f2a 150 }
cbc021f9 151
152 if (sv_isobject(sv)) {
153 classname = sv_reftype(SvRV(sv),TRUE);
154 } else {
94707740 155 classname = SvPV_nolen(sv);
cbc021f9 156 }
157
7ce46f2a
GG
158 if (strEQ(name,classname)) {
159 LEAVE;
cbc021f9 160 return TRUE;
7ce46f2a 161 }
cbc021f9 162
163 PUSHMARK(SP);
164 XPUSHs(sv);
6e449a3a 165 mXPUSHs(newSVpv(name, 0));
cbc021f9 166 PUTBACK;
167
84bafc02 168 methodname = newSVpvs_flags("isa", SVs_TEMP);
59e7186f
RGS
169 /* ugly hack: use the SvSCREAM flag so S_method_common
170 * can figure out we're calling DOES() and not isa(),
171 * and report eventual errors correctly. --rgs */
172 SvSCREAM_on(methodname);
173 call_sv(methodname, G_SCALAR | G_METHOD);
cbc021f9 174 SPAGAIN;
175
176 does_it = SvTRUE( TOPs );
177 FREETMPS;
178 LEAVE;
179
180 return does_it;
181}
182
afa74d42
NC
183/*
184=for apidoc croak_xs_usage
185
186A specialised variant of C<croak()> for emitting the usage message for xsubs
187
188 croak_xs_usage(cv, "eee_yow");
189
190works out the package name and subroutine name from C<cv>, and then calls
191C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
192
1b1ee2ef 193 Perl_croak(aTHX_ "Usage: %s::%s(%s)", "ouch" "awk", "eee_yow");
afa74d42
NC
194
195=cut
196*/
197
198void
199Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
200{
201 const GV *const gv = CvGV(cv);
202
203 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
204
205 if (gv) {
206 const char *const gvname = GvNAME(gv);
207 const HV *const stash = GvSTASH(gv);
208 const char *const hvname = stash ? HvNAME_get(stash) : NULL;
209
210 if (hvname)
211 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
212 else
213 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
214 } else {
215 /* Pants. I don't think that it should be possible to get here. */
93c51217 216 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
afa74d42
NC
217 }
218}
55497cff 219
6d4a7be2
PP
220XS(XS_UNIVERSAL_isa)
221{
97aff369 222 dVAR;
6d4a7be2 223 dXSARGS;
6d4a7be2
PP
224
225 if (items != 2)
afa74d42 226 croak_xs_usage(cv, "reference, kind");
c4420975
AL
227 else {
228 SV * const sv = ST(0);
229 const char *name;
6d4a7be2 230
c4420975 231 SvGETMAGIC(sv);
d3f7f2b2 232
c4420975
AL
233 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
234 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
235 XSRETURN_UNDEF;
f8f70380 236
c4420975 237 name = SvPV_nolen_const(ST(1));
6d4a7be2 238
c4420975
AL
239 ST(0) = boolSV(sv_derived_from(sv, name));
240 XSRETURN(1);
241 }
6d4a7be2
PP
242}
243
6d4a7be2
PP
244XS(XS_UNIVERSAL_can)
245{
97aff369 246 dVAR;
6d4a7be2
PP
247 dXSARGS;
248 SV *sv;
6867be6d 249 const char *name;
6d4a7be2 250 SV *rv;
6f08146e 251 HV *pkg = NULL;
6d4a7be2
PP
252
253 if (items != 2)
afa74d42 254 croak_xs_usage(cv, "object-ref, method");
6d4a7be2
PP
255
256 sv = ST(0);
f8f70380 257
5b295bef 258 SvGETMAGIC(sv);
d3f7f2b2 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
0510663f 264 name = SvPV_nolen_const(ST(1));
3280af22 265 rv = &PL_sv_undef;
6d4a7be2 266
46e4b22b 267 if (SvROK(sv)) {
daba3364 268 sv = MUTABLE_SV(SvRV(sv));
46e4b22b 269 if (SvOBJECT(sv))
6f08146e
NIS
270 pkg = SvSTASH(sv);
271 }
272 else {
da51bb9b 273 pkg = gv_stashsv(sv, 0);
6f08146e
NIS
274 }
275
276 if (pkg) {
c4420975 277 GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
dc848c6f 278 if (gv && isGV(gv))
daba3364 279 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
6d4a7be2
PP
280 }
281
282 ST(0) = rv;
283 XSRETURN(1);
284}
285
cbc021f9 286XS(XS_UNIVERSAL_DOES)
287{
288 dVAR;
289 dXSARGS;
58c0efa5 290 PERL_UNUSED_ARG(cv);
cbc021f9 291
292 if (items != 2)
486ec47a 293 Perl_croak(aTHX_ "Usage: invocand->DOES(kind)");
cbc021f9 294 else {
295 SV * const sv = ST(0);
296 const char *name;
297
298 name = SvPV_nolen_const(ST(1));
299 if (sv_does( sv, name ))
300 XSRETURN_YES;
301
302 XSRETURN_NO;
303 }
304}
305
6d4a7be2
PP
306XS(XS_UNIVERSAL_VERSION)
307{
97aff369 308 dVAR;
6d4a7be2
PP
309 dXSARGS;
310 HV *pkg;
311 GV **gvp;
312 GV *gv;
313 SV *sv;
e1ec3a88 314 const char *undef;
58c0efa5 315 PERL_UNUSED_ARG(cv);
6d4a7be2 316
1571675a 317 if (SvROK(ST(0))) {
daba3364 318 sv = MUTABLE_SV(SvRV(ST(0)));
1571675a 319 if (!SvOBJECT(sv))
cea2e8a9 320 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2
PP
321 pkg = SvSTASH(sv);
322 }
323 else {
da51bb9b 324 pkg = gv_stashsv(ST(0), 0);
6d4a7be2
PP
325 }
326
4608196e 327 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
6d4a7be2 328
0008872a 329 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
c4420975 330 SV * const nsv = sv_newmortal();
6d4a7be2
PP
331 sv_setsv(nsv, sv);
332 sv = nsv;
137d6fc0 333 if ( !sv_derived_from(sv, "version"))
ac0e6a2f 334 upg_version(sv, FALSE);
c445ea15 335 undef = NULL;
6d4a7be2
PP
336 }
337 else {
daba3364 338 sv = &PL_sv_undef;
6d4a7be2
PP
339 undef = "(undef)";
340 }
341
1571675a 342 if (items > 1) {
1571675a
GS
343 SV *req = ST(1);
344
62658f4d 345 if (undef) {
bfcb3514 346 if (pkg) {
c4420975 347 const char * const name = HvNAME_get(pkg);
a3b680e6 348 Perl_croak(aTHX_
bfcb3514
NC
349 "%s does not define $%s::VERSION--version check failed",
350 name, name);
351 } else {
a3b680e6
AL
352 Perl_croak(aTHX_
353 "%s defines neither package nor VERSION--version check failed",
0510663f 354 SvPVx_nolen_const(ST(0)) );
62658f4d
PM
355 }
356 }
ad63d80f 357
137d6fc0
JP
358 if ( !sv_derived_from(req, "version")) {
359 /* req may very well be R/O, so create a new object */
ac0e6a2f 360 req = sv_2mortal( new_version(req) );
137d6fc0 361 }
1571675a 362
ac0e6a2f 363 if ( vcmp( req, sv ) > 0 ) {
ef8f7699 364 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
ac0e6a2f
RGS
365 Perl_croak(aTHX_ "%s version %"SVf" required--"
366 "this is only version %"SVf"", HvNAME_get(pkg),
e3a22e3f 367 SVfARG(sv_2mortal(vnormal(req))),
368 SVfARG(sv_2mortal(vnormal(sv))));
ac0e6a2f
RGS
369 } else {
370 Perl_croak(aTHX_ "%s version %"SVf" required--"
371 "this is only version %"SVf"", HvNAME_get(pkg),
e3a22e3f 372 SVfARG(sv_2mortal(vstringify(req))),
373 SVfARG(sv_2mortal(vstringify(sv))));
ac0e6a2f
RGS
374 }
375 }
376
2d8e6c8d 377 }
6d4a7be2 378
2b140d5b 379 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
e3a22e3f 380 ST(0) = sv_2mortal(vstringify(sv));
13f8f398
JP
381 } else {
382 ST(0) = sv;
b38a9dc5 383 }
6d4a7be2
PP
384
385 XSRETURN(1);
386}
387
439cb1c4
JP
388XS(XS_version_new)
389{
97aff369 390 dVAR;
439cb1c4 391 dXSARGS;
129318bd 392 if (items > 3)
afa74d42 393 croak_xs_usage(cv, "class, version");
439cb1c4
JP
394 SP -= items;
395 {
137d6fc0
JP
396 SV *vs = ST(1);
397 SV *rv;
c4420975
AL
398 const char * const classname =
399 sv_isobject(ST(0)) /* get the class if called as an object method */
400 ? HvNAME(SvSTASH(SvRV(ST(0))))
401 : (char *)SvPV_nolen(ST(0));
9137345a 402
91152fc1 403 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
92dcf8ce
JP
404 /* create empty object */
405 vs = sv_newmortal();
be5574c0 406 sv_setpvs(vs, "0");
9137345a
JP
407 }
408 else if ( items == 3 ) {
409 vs = sv_newmortal();
cfd0369c 410 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
129318bd 411 }
439cb1c4 412
137d6fc0 413 rv = new_version(vs);
0723351e 414 if ( strcmp(classname,"version") != 0 ) /* inherited new() */
da51bb9b 415 sv_bless(rv, gv_stashpv(classname, GV_ADD));
137d6fc0 416
6e449a3a 417 mPUSHs(rv);
439cb1c4
JP
418 PUTBACK;
419 return;
420 }
421}
422
423XS(XS_version_stringify)
424{
97aff369 425 dVAR;
41be1fbd
JH
426 dXSARGS;
427 if (items < 1)
afa74d42 428 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
429 SP -= items;
430 {
d808b681 431 SV * lobj = ST(0);
41be1fbd 432
d808b681
JP
433 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
434 lobj = SvRV(lobj);
41be1fbd
JH
435 }
436 else
437 Perl_croak(aTHX_ "lobj is not of type version");
438
6e449a3a 439 mPUSHs(vstringify(lobj));
41be1fbd
JH
440
441 PUTBACK;
442 return;
443 }
439cb1c4
JP
444}
445
446XS(XS_version_numify)
447{
97aff369 448 dVAR;
41be1fbd
JH
449 dXSARGS;
450 if (items < 1)
afa74d42 451 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
452 SP -= items;
453 {
d808b681 454 SV * lobj = ST(0);
41be1fbd 455
d808b681
JP
456 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
457 lobj = SvRV(lobj);
41be1fbd
JH
458 }
459 else
460 Perl_croak(aTHX_ "lobj is not of type version");
461
6e449a3a 462 mPUSHs(vnumify(lobj));
41be1fbd
JH
463
464 PUTBACK;
465 return;
466 }
439cb1c4
JP
467}
468
9137345a
JP
469XS(XS_version_normal)
470{
97aff369 471 dVAR;
9137345a
JP
472 dXSARGS;
473 if (items < 1)
afa74d42 474 croak_xs_usage(cv, "lobj, ...");
9137345a
JP
475 SP -= items;
476 {
d808b681 477 SV * lobj = ST(0);
9137345a 478
d808b681
JP
479 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
480 lobj = SvRV(lobj);
9137345a
JP
481 }
482 else
483 Perl_croak(aTHX_ "lobj is not of type version");
484
6e449a3a 485 mPUSHs(vnormal(lobj));
9137345a
JP
486
487 PUTBACK;
488 return;
489 }
490}
491
439cb1c4
JP
492XS(XS_version_vcmp)
493{
97aff369 494 dVAR;
41be1fbd
JH
495 dXSARGS;
496 if (items < 1)
afa74d42 497 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
498 SP -= items;
499 {
d808b681 500 SV * lobj = ST(0);
41be1fbd 501
d808b681
JP
502 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
503 lobj = SvRV(lobj);
41be1fbd
JH
504 }
505 else
506 Perl_croak(aTHX_ "lobj is not of type version");
507
508 {
509 SV *rs;
510 SV *rvs;
511 SV * robj = ST(1);
7452cf6a 512 const IV swap = (IV)SvIV(ST(2));
41be1fbd
JH
513
514 if ( ! sv_derived_from(robj, "version") )
515 {
e3a22e3f 516 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
517 sv_2mortal(robj);
41be1fbd
JH
518 }
519 rvs = SvRV(robj);
520
521 if ( swap )
522 {
523 rs = newSViv(vcmp(rvs,lobj));
524 }
525 else
526 {
527 rs = newSViv(vcmp(lobj,rvs));
528 }
529
6e449a3a 530 mPUSHs(rs);
41be1fbd
JH
531 }
532
533 PUTBACK;
534 return;
535 }
439cb1c4
JP
536}
537
538XS(XS_version_boolean)
539{
97aff369
JH
540 dVAR;
541 dXSARGS;
542 if (items < 1)
afa74d42 543 croak_xs_usage(cv, "lobj, ...");
97aff369 544 SP -= items;
d808b681 545 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
c4420975 546 SV * const lobj = SvRV(ST(0));
396482e1 547 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
6e449a3a 548 mPUSHs(rs);
c4420975
AL
549 PUTBACK;
550 return;
551 }
552 else
553 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
554}
555
556XS(XS_version_noop)
557{
97aff369 558 dVAR;
2dfd8427
AL
559 dXSARGS;
560 if (items < 1)
afa74d42 561 croak_xs_usage(cv, "lobj, ...");
d808b681 562 if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
2dfd8427
AL
563 Perl_croak(aTHX_ "operation not supported with version object");
564 else
565 Perl_croak(aTHX_ "lobj is not of type version");
566#ifndef HASATTRIBUTE_NORETURN
567 XSRETURN_EMPTY;
568#endif
439cb1c4
JP
569}
570
c8d69e4a
JP
571XS(XS_version_is_alpha)
572{
97aff369 573 dVAR;
c8d69e4a
JP
574 dXSARGS;
575 if (items != 1)
afa74d42 576 croak_xs_usage(cv, "lobj");
c8d69e4a 577 SP -= items;
d808b681 578 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
c4420975 579 SV * const lobj = ST(0);
ef8f7699 580 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
c4420975
AL
581 XSRETURN_YES;
582 else
583 XSRETURN_NO;
c8d69e4a
JP
584 PUTBACK;
585 return;
586 }
c4420975
AL
587 else
588 Perl_croak(aTHX_ "lobj is not of type version");
c8d69e4a
JP
589}
590
137d6fc0
JP
591XS(XS_version_qv)
592{
97aff369 593 dVAR;
137d6fc0 594 dXSARGS;
4ed3fda4 595 PERL_UNUSED_ARG(cv);
137d6fc0
JP
596 SP -= items;
597 {
f941e658
JP
598 SV * ver = ST(0);
599 SV * rv;
600 const char * classname = "";
91152fc1 601 if ( items == 2 && SvOK(ST(1)) ) {
f941e658
JP
602 /* getting called as object or class method */
603 ver = ST(1);
604 classname =
605 sv_isobject(ST(0)) /* class called as an object method */
606 ? HvNAME_get(SvSTASH(SvRV(ST(0))))
607 : (char *)SvPV_nolen(ST(0));
608 }
609 if ( !SvVOK(ver) ) { /* not already a v-string */
610 rv = sv_newmortal();
ac0e6a2f
RGS
611 sv_setsv(rv,ver); /* make a duplicate */
612 upg_version(rv, TRUE);
f941e658
JP
613 } else {
614 rv = sv_2mortal(new_version(ver));
137d6fc0 615 }
f941e658
JP
616 if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
617 sv_bless(rv, gv_stashpv(classname, GV_ADD));
137d6fc0 618 }
f941e658
JP
619 PUSHs(rv);
620 }
621 PUTBACK;
622 return;
623}
137d6fc0 624
f941e658
JP
625XS(XS_version_is_qv)
626{
627 dVAR;
628 dXSARGS;
629 if (items != 1)
630 croak_xs_usage(cv, "lobj");
631 SP -= items;
d808b681 632 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
f941e658
JP
633 SV * const lobj = ST(0);
634 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
635 XSRETURN_YES;
636 else
637 XSRETURN_NO;
137d6fc0
JP
638 PUTBACK;
639 return;
640 }
f941e658
JP
641 else
642 Perl_croak(aTHX_ "lobj is not of type version");
137d6fc0
JP
643}
644
8800c35a
JH
645XS(XS_utf8_is_utf8)
646{
97aff369 647 dVAR;
41be1fbd
JH
648 dXSARGS;
649 if (items != 1)
afa74d42 650 croak_xs_usage(cv, "sv");
c4420975 651 else {
76f73021 652 SV * const sv = ST(0);
653 SvGETMAGIC(sv);
c4420975
AL
654 if (SvUTF8(sv))
655 XSRETURN_YES;
656 else
657 XSRETURN_NO;
41be1fbd
JH
658 }
659 XSRETURN_EMPTY;
8800c35a
JH
660}
661
1b026014
NIS
662XS(XS_utf8_valid)
663{
97aff369 664 dVAR;
41be1fbd
JH
665 dXSARGS;
666 if (items != 1)
afa74d42 667 croak_xs_usage(cv, "sv");
c4420975
AL
668 else {
669 SV * const sv = ST(0);
670 STRLEN len;
671 const char * const s = SvPV_const(sv,len);
672 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
673 XSRETURN_YES;
674 else
675 XSRETURN_NO;
676 }
41be1fbd 677 XSRETURN_EMPTY;
1b026014
NIS
678}
679
680XS(XS_utf8_encode)
681{
97aff369 682 dVAR;
1b026014
NIS
683 dXSARGS;
684 if (items != 1)
afa74d42 685 croak_xs_usage(cv, "sv");
c4420975 686 sv_utf8_encode(ST(0));
1b026014
NIS
687 XSRETURN_EMPTY;
688}
689
690XS(XS_utf8_decode)
691{
97aff369 692 dVAR;
1b026014
NIS
693 dXSARGS;
694 if (items != 1)
afa74d42 695 croak_xs_usage(cv, "sv");
c4420975
AL
696 else {
697 SV * const sv = ST(0);
6867be6d 698 const bool RETVAL = sv_utf8_decode(sv);
1b026014
NIS
699 ST(0) = boolSV(RETVAL);
700 sv_2mortal(ST(0));
701 }
702 XSRETURN(1);
703}
704
705XS(XS_utf8_upgrade)
706{
97aff369 707 dVAR;
1b026014
NIS
708 dXSARGS;
709 if (items != 1)
afa74d42 710 croak_xs_usage(cv, "sv");
c4420975
AL
711 else {
712 SV * const sv = ST(0);
1b026014
NIS
713 STRLEN RETVAL;
714 dXSTARG;
715
716 RETVAL = sv_utf8_upgrade(sv);
717 XSprePUSH; PUSHi((IV)RETVAL);
718 }
719 XSRETURN(1);
720}
721
722XS(XS_utf8_downgrade)
723{
97aff369 724 dVAR;
1b026014
NIS
725 dXSARGS;
726 if (items < 1 || items > 2)
afa74d42 727 croak_xs_usage(cv, "sv, failok=0");
c4420975
AL
728 else {
729 SV * const sv = ST(0);
6867be6d
AL
730 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
731 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 732
1b026014
NIS
733 ST(0) = boolSV(RETVAL);
734 sv_2mortal(ST(0));
735 }
736 XSRETURN(1);
737}
738
739XS(XS_utf8_native_to_unicode)
740{
97aff369 741 dVAR;
1b026014 742 dXSARGS;
6867be6d 743 const UV uv = SvUV(ST(0));
b7953727
JH
744
745 if (items > 1)
afa74d42 746 croak_xs_usage(cv, "sv");
b7953727 747
1b026014
NIS
748 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
749 XSRETURN(1);
750}
751
752XS(XS_utf8_unicode_to_native)
753{
97aff369 754 dVAR;
1b026014 755 dXSARGS;
6867be6d 756 const UV uv = SvUV(ST(0));
b7953727
JH
757
758 if (items > 1)
afa74d42 759 croak_xs_usage(cv, "sv");
b7953727 760
1b026014
NIS
761 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
762 XSRETURN(1);
763}
764
14a976d6 765XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577 766{
97aff369 767 dVAR;
29569577 768 dXSARGS;
80b6a949
AB
769 SV * const svz = ST(0);
770 SV * sv;
58c0efa5 771 PERL_UNUSED_ARG(cv);
6867be6d 772
80b6a949
AB
773 /* [perl #77776] - called as &foo() not foo() */
774 if (!SvROK(svz))
775 croak_xs_usage(cv, "SCALAR[, ON]");
776
777 sv = SvRV(svz);
778
29569577
JH
779 if (items == 1) {
780 if (SvREADONLY(sv))
781 XSRETURN_YES;
782 else
783 XSRETURN_NO;
784 }
785 else if (items == 2) {
786 if (SvTRUE(ST(1))) {
787 SvREADONLY_on(sv);
788 XSRETURN_YES;
789 }
790 else {
14a976d6 791 /* I hope you really know what you are doing. */
29569577
JH
792 SvREADONLY_off(sv);
793 XSRETURN_NO;
794 }
795 }
14a976d6 796 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
797}
798
14a976d6 799XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577 800{
97aff369 801 dVAR;
29569577 802 dXSARGS;
80b6a949
AB
803 SV * const svz = ST(0);
804 SV * sv;
58c0efa5 805 PERL_UNUSED_ARG(cv);
6867be6d 806
80b6a949
AB
807 /* [perl #77776] - called as &foo() not foo() */
808 if (!SvROK(svz))
809 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
810
811 sv = SvRV(svz);
812
29569577 813 if (items == 1)
14a976d6 814 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 815 else if (items == 2) {
14a976d6 816 /* I hope you really know what you are doing. */
29569577
JH
817 SvREFCNT(sv) = SvIV(ST(1));
818 XSRETURN_IV(SvREFCNT(sv));
819 }
14a976d6 820 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
821}
822
f044d0d1 823XS(XS_Internals_hv_clear_placehold)
dfd4ef2f 824{
97aff369 825 dVAR;
dfd4ef2f 826 dXSARGS;
6867be6d 827
80b6a949 828 if (items != 1 || !SvROK(ST(0)))
afa74d42 829 croak_xs_usage(cv, "hv");
c4420975 830 else {
ef8f7699 831 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
832 hv_clear_placeholders(hv);
833 XSRETURN(0);
834 }
dfd4ef2f 835}
39f7a870
JH
836
837XS(XS_PerlIO_get_layers)
838{
97aff369 839 dVAR;
39f7a870
JH
840 dXSARGS;
841 if (items < 1 || items % 2 == 0)
afa74d42 842 croak_xs_usage(cv, "filehandle[,args]");
5fef3b4a 843#ifdef USE_PERLIO
39f7a870
JH
844 {
845 SV * sv;
846 GV * gv;
847 IO * io;
848 bool input = TRUE;
849 bool details = FALSE;
850
851 if (items > 1) {
c4420975 852 SV * const *svp;
39f7a870 853 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
854 SV * const * const varp = svp;
855 SV * const * const valp = svp + 1;
39f7a870 856 STRLEN klen;
c4420975 857 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
858
859 switch (*key) {
860 case 'i':
861 if (klen == 5 && memEQ(key, "input", 5)) {
862 input = SvTRUE(*valp);
863 break;
864 }
865 goto fail;
866 case 'o':
867 if (klen == 6 && memEQ(key, "output", 6)) {
868 input = !SvTRUE(*valp);
869 break;
870 }
871 goto fail;
872 case 'd':
873 if (klen == 7 && memEQ(key, "details", 7)) {
874 details = SvTRUE(*valp);
875 break;
876 }
877 goto fail;
878 default:
879 fail:
880 Perl_croak(aTHX_
881 "get_layers: unknown argument '%s'",
882 key);
883 }
884 }
885
886 SP -= (items - 1);
887 }
888
889 sv = POPs;
159b6efe 890 gv = MUTABLE_GV(sv);
39f7a870
JH
891
892 if (!isGV(sv)) {
893 if (SvROK(sv) && isGV(SvRV(sv)))
159b6efe 894 gv = MUTABLE_GV(SvRV(sv));
671d49be 895 else if (SvPOKp(sv))
f776e3cd 896 gv = gv_fetchsv(sv, 0, SVt_PVIO);
39f7a870
JH
897 }
898
899 if (gv && (io = GvIO(gv))) {
c4420975 900 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870
JH
901 IoIFP(io) : IoOFP(io));
902 I32 i;
c4420975 903 const I32 last = av_len(av);
39f7a870
JH
904 I32 nitem = 0;
905
906 for (i = last; i >= 0; i -= 3) {
c4420975
AL
907 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
908 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
909 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 910
c4420975
AL
911 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
912 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
913 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870
JH
914
915 if (details) {
92e45a3e
NC
916 /* Indents of 5? Yuck. */
917 /* We know that PerlIO_get_layers creates a new SV for
918 the name and flags, so we can just take a reference
919 and "steal" it when we free the AV below. */
ec3bab8e 920 XPUSHs(namok
92e45a3e 921 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e
NC
922 : &PL_sv_undef);
923 XPUSHs(argok
92e45a3e
NC
924 ? newSVpvn_flags(SvPVX_const(*argsvp),
925 SvCUR(*argsvp),
926 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
927 | SVs_TEMP)
928 : &PL_sv_undef);
96ccaf53 929 XPUSHs(flgok
92e45a3e 930 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 931 : &PL_sv_undef);
39f7a870
JH
932 nitem += 3;
933 }
934 else {
935 if (namok && argok)
1eb9e81d 936 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 937 SVfARG(*namsvp),
1eb9e81d 938 SVfARG(*argsvp))));
39f7a870 939 else if (namok)
92e45a3e 940 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870
JH
941 else
942 XPUSHs(&PL_sv_undef);
943 nitem++;
944 if (flgok) {
c4420975 945 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
946
947 if (flags & PERLIO_F_UTF8) {
84bafc02 948 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
949 nitem++;
950 }
951 }
952 }
953 }
954
955 SvREFCNT_dec(av);
956
957 XSRETURN(nitem);
958 }
959 }
5fef3b4a 960#endif
39f7a870
JH
961
962 XSRETURN(0);
963}
964
9a7034eb 965XS(XS_Internals_hash_seed)
c910b28a 966{
97aff369 967 dVAR;
c85d3f85
NC
968 /* Using dXSARGS would also have dITEM and dSP,
969 * which define 2 unused local variables. */
557b887a 970 dAXMARK;
53c1dcc0 971 PERL_UNUSED_ARG(cv);
ad73156c 972 PERL_UNUSED_VAR(mark);
81eaca17 973 XSRETURN_UV(PERL_HASH_SEED);
c910b28a
JH
974}
975
008fb0c0 976XS(XS_Internals_rehash_seed)
8e90d776 977{
97aff369 978 dVAR;
8e90d776
NC
979 /* Using dXSARGS would also have dITEM and dSP,
980 * which define 2 unused local variables. */
557b887a 981 dAXMARK;
53c1dcc0 982 PERL_UNUSED_ARG(cv);
ad73156c 983 PERL_UNUSED_VAR(mark);
008fb0c0 984 XSRETURN_UV(PL_rehash_seed);
8e90d776
NC
985}
986
05619474
NC
987XS(XS_Internals_HvREHASH) /* Subject to change */
988{
97aff369 989 dVAR;
05619474 990 dXSARGS;
93c51217 991 PERL_UNUSED_ARG(cv);
05619474 992 if (SvROK(ST(0))) {
ef8f7699 993 const HV * const hv = (const HV *) SvRV(ST(0));
05619474
NC
994 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
995 if (HvREHASH(hv))
996 XSRETURN_YES;
997 else
998 XSRETURN_NO;
999 }
1000 }
1001 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1002}
241d1a3b 1003
80305961
YO
1004XS(XS_re_is_regexp)
1005{
1006 dVAR;
1007 dXSARGS;
f7e71195
AB
1008 PERL_UNUSED_VAR(cv);
1009
80305961 1010 if (items != 1)
afa74d42 1011 croak_xs_usage(cv, "sv");
f7e71195 1012
f7e71195
AB
1013 if (SvRXOK(ST(0))) {
1014 XSRETURN_YES;
1015 } else {
1016 XSRETURN_NO;
80305961
YO
1017 }
1018}
1019
192b9cd1 1020XS(XS_re_regnames_count)
80305961 1021{
192b9cd1
AB
1022 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1023 SV * ret;
80305961
YO
1024 dVAR;
1025 dXSARGS;
192b9cd1
AB
1026
1027 if (items != 0)
afa74d42 1028 croak_xs_usage(cv, "");
192b9cd1
AB
1029
1030 SP -= items;
fdae9473 1031 PUTBACK;
192b9cd1
AB
1032
1033 if (!rx)
1034 XSRETURN_UNDEF;
1035
1036 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1037
1038 SPAGAIN;
fdae9473
NC
1039 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1040 XSRETURN(1);
192b9cd1
AB
1041}
1042
1043XS(XS_re_regname)
1044{
1045 dVAR;
1046 dXSARGS;
1047 REGEXP * rx;
1048 U32 flags;
1049 SV * ret;
1050
28d8d7f4 1051 if (items < 1 || items > 2)
afa74d42 1052 croak_xs_usage(cv, "name[, all ]");
192b9cd1 1053
80305961 1054 SP -= items;
fdae9473 1055 PUTBACK;
80305961 1056
192b9cd1
AB
1057 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1058
1059 if (!rx)
1060 XSRETURN_UNDEF;
1061
1062 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 1063 flags = RXapif_ALL;
192b9cd1 1064 } else {
f1b875a0 1065 flags = RXapif_ONE;
80305961 1066 }
f1b875a0 1067 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1 1068
fdae9473
NC
1069 SPAGAIN;
1070 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1071 XSRETURN(1);
80305961
YO
1072}
1073
192b9cd1 1074
80305961
YO
1075XS(XS_re_regnames)
1076{
192b9cd1 1077 dVAR;
80305961 1078 dXSARGS;
192b9cd1
AB
1079 REGEXP * rx;
1080 U32 flags;
1081 SV *ret;
1082 AV *av;
1083 I32 length;
1084 I32 i;
1085 SV **entry;
1086
1087 if (items > 1)
afa74d42 1088 croak_xs_usage(cv, "[all]");
192b9cd1
AB
1089
1090 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1091
1092 if (!rx)
1093 XSRETURN_UNDEF;
1094
1095 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 1096 flags = RXapif_ALL;
192b9cd1 1097 } else {
f1b875a0 1098 flags = RXapif_ONE;
192b9cd1
AB
1099 }
1100
80305961 1101 SP -= items;
fdae9473 1102 PUTBACK;
80305961 1103
f1b875a0 1104 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
1105
1106 SPAGAIN;
1107
192b9cd1
AB
1108 if (!ret)
1109 XSRETURN_UNDEF;
1110
502c6561 1111 av = MUTABLE_AV(SvRV(ret));
192b9cd1
AB
1112 length = av_len(av);
1113
1114 for (i = 0; i <= length; i++) {
1115 entry = av_fetch(av, i, FALSE);
1116
1117 if (!entry)
1118 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1119
ec83ea38 1120 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 1121 }
ec83ea38
MHM
1122
1123 SvREFCNT_dec(ret);
1124
192b9cd1
AB
1125 PUTBACK;
1126 return;
80305961
YO
1127}
1128
192c1e27
JH
1129XS(XS_re_regexp_pattern)
1130{
1131 dVAR;
1132 dXSARGS;
1133 REGEXP *re;
192c1e27
JH
1134
1135 if (items != 1)
afa74d42 1136 croak_xs_usage(cv, "sv");
192c1e27
JH
1137
1138 SP -= items;
1139
1140 /*
1141 Checks if a reference is a regex or not. If the parameter is
1142 not a ref, or is not the result of a qr// then returns false
1143 in scalar context and an empty list in list context.
1144 Otherwise in list context it returns the pattern and the
1145 modifiers, in scalar context it returns the pattern just as it
1146 would if the qr// was stringified normally, regardless as
486ec47a 1147 to the class of the variable and any stringification overloads
192c1e27
JH
1148 on the object.
1149 */
1150
1151 if ((re = SvRX(ST(0)))) /* assign deliberate */
1152 {
22c985d5 1153 /* Houston, we have a regex! */
192c1e27 1154 SV *pattern;
192c1e27
JH
1155
1156 if ( GIMME_V == G_ARRAY ) {
9de15fec 1157 STRLEN left = 0;
a62b1201 1158 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
69af1167
SH
1159 const char *fptr;
1160 char ch;
1161 U16 match_flags;
1162
192c1e27
JH
1163 /*
1164 we are in list context so stringify
1165 the modifiers that apply. We ignore "negative
a62b1201 1166 modifiers" in this scenario, and the default character set
192c1e27
JH
1167 */
1168
a62b1201
KW
1169 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1170 STRLEN len;
1171 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1172 &len);
1173 Copy(name, reflags + left, len, char);
1174 left += len;
9de15fec 1175 }
69af1167
SH
1176 fptr = INT_PAT_MODS;
1177 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
192c1e27
JH
1178 >> RXf_PMf_STD_PMMOD_SHIFT);
1179
1180 while((ch = *fptr++)) {
1181 if(match_flags & 1) {
1182 reflags[left++] = ch;
1183 }
1184 match_flags >>= 1;
1185 }
1186
fb632ce3
NC
1187 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1188 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1189
1190 /* return the pattern and the modifiers */
1191 XPUSHs(pattern);
fb632ce3 1192 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
1193 XSRETURN(2);
1194 } else {
1195 /* Scalar, so use the string that Perl would return */
1196 /* return the pattern in (?msix:..) format */
1197#if PERL_VERSION >= 11
daba3364 1198 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 1199#else
fb632ce3
NC
1200 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1201 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1202#endif
1203 XPUSHs(pattern);
1204 XSRETURN(1);
1205 }
1206 } else {
1207 /* It ain't a regexp folks */
1208 if ( GIMME_V == G_ARRAY ) {
1209 /* return the empty list */
1210 XSRETURN_UNDEF;
1211 } else {
1212 /* Because of the (?:..) wrapping involved in a
1213 stringified pattern it is impossible to get a
1214 result for a real regexp that would evaluate to
1215 false. Therefore we can return PL_sv_no to signify
1216 that the object is not a regex, this means that one
1217 can say
1218
1219 if (regex($might_be_a_regex) eq '(?:foo)') { }
1220
1221 and not worry about undefined values.
1222 */
1223 XSRETURN_NO;
1224 }
1225 }
1226 /* NOT-REACHED */
1227}
1228
eff5b9d5
NC
1229struct xsub_details {
1230 const char *name;
1231 XSUBADDR_t xsub;
1232 const char *proto;
1233};
1234
1235struct xsub_details details[] = {
1236 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1237 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1238 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1239 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1240 {"version::()", XS_version_noop, NULL},
1241 {"version::new", XS_version_new, NULL},
1242 {"version::parse", XS_version_new, NULL},
1243 {"version::(\"\"", XS_version_stringify, NULL},
1244 {"version::stringify", XS_version_stringify, NULL},
1245 {"version::(0+", XS_version_numify, NULL},
1246 {"version::numify", XS_version_numify, NULL},
1247 {"version::normal", XS_version_normal, NULL},
1248 {"version::(cmp", XS_version_vcmp, NULL},
1249 {"version::(<=>", XS_version_vcmp, NULL},
1250 {"version::vcmp", XS_version_vcmp, NULL},
1251 {"version::(bool", XS_version_boolean, NULL},
1252 {"version::boolean", XS_version_boolean, NULL},
1253 {"version::(nomethod", XS_version_noop, NULL},
1254 {"version::noop", XS_version_noop, NULL},
1255 {"version::is_alpha", XS_version_is_alpha, NULL},
1256 {"version::qv", XS_version_qv, NULL},
1257 {"version::declare", XS_version_qv, NULL},
1258 {"version::is_qv", XS_version_is_qv, NULL},
1259 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1260 {"utf8::valid", XS_utf8_valid, NULL},
1261 {"utf8::encode", XS_utf8_encode, NULL},
1262 {"utf8::decode", XS_utf8_decode, NULL},
1263 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1264 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1265 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1266 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1267 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1268 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1269 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1270 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1271 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1272 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1273 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1274 {"re::is_regexp", XS_re_is_regexp, "$"},
1275 {"re::regname", XS_re_regname, ";$$"},
1276 {"re::regnames", XS_re_regnames, ";$"},
1277 {"re::regnames_count", XS_re_regnames_count, ""},
1278 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
eff5b9d5
NC
1279};
1280
1281void
1282Perl_boot_core_UNIVERSAL(pTHX)
1283{
1284 dVAR;
1285 static const char file[] = __FILE__;
1286 struct xsub_details *xsub = details;
1287 const struct xsub_details *end
1288 = details + sizeof(details) / sizeof(details[0]);
1289
1290 do {
1291 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1292 } while (++xsub < end);
1293
1294 /* register the overloading (type 'A') magic */
1295 PL_amagic_generation++;
1296
1297 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1298 CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1299 = (char *)file;
1300}
80305961 1301
241d1a3b
NC
1302/*
1303 * Local variables:
1304 * c-indentation-style: bsd
1305 * c-basic-offset: 4
1306 * indent-tabs-mode: t
1307 * End:
1308 *
37442d52
RGS
1309 * ex: set ts=8 sts=4 sw=4 noet:
1310 */