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