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