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