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