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