This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Croak when range tries to extend stack too far
[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) {
1620522e 915 if (SvREADONLY(sv))
29569577
JH
916 XSRETURN_YES;
917 else
918 XSRETURN_NO;
919 }
920 else if (items == 2) {
921 if (SvTRUE(ST(1))) {
1620522e 922#ifdef PERL_OLD_COPY_ON_WRITE
3e89ba19 923 if (SvIsCOW(sv)) sv_force_normal(sv);
1620522e 924#endif
29569577 925 SvREADONLY_on(sv);
38be3d00
FC
926 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
927 /* for constant.pm; nobody else should be calling this
928 on arrays anyway. */
929 SV **svp;
930 for (svp = AvARRAY(sv) + AvFILLp(sv)
931 ; svp >= AvARRAY(sv)
932 ; --svp)
933 if (*svp) SvPADTMP_on(*svp);
934 }
29569577
JH
935 XSRETURN_YES;
936 }
937 else {
14a976d6 938 /* I hope you really know what you are doing. */
1620522e 939 SvREADONLY_off(sv);
29569577
JH
940 XSRETURN_NO;
941 }
942 }
14a976d6 943 XSRETURN_UNDEF; /* Can't happen. */
29569577 944}
14a976d6 945XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577 946{
97aff369 947 dVAR;
29569577 948 dXSARGS;
80b6a949
AB
949 SV * const svz = ST(0);
950 SV * sv;
fa3febb6 951 U32 refcnt;
58c0efa5 952 PERL_UNUSED_ARG(cv);
6867be6d 953
80b6a949 954 /* [perl #77776] - called as &foo() not foo() */
fa3febb6 955 if ((items != 1 && items != 2) || !SvROK(svz))
80b6a949
AB
956 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
957
958 sv = SvRV(svz);
959
14a976d6 960 /* I hope you really know what you are doing. */
fa3febb6
DD
961 /* idea is for SvREFCNT(sv) to be accessed only once */
962 refcnt = items == 2 ?
963 /* we free one ref on exit */
964 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
965 : SvREFCNT(sv);
966 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
967
29569577
JH
968}
969
f044d0d1 970XS(XS_Internals_hv_clear_placehold)
dfd4ef2f 971{
97aff369 972 dVAR;
dfd4ef2f 973 dXSARGS;
6867be6d 974
80b6a949 975 if (items != 1 || !SvROK(ST(0)))
afa74d42 976 croak_xs_usage(cv, "hv");
c4420975 977 else {
ef8f7699 978 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
979 hv_clear_placeholders(hv);
980 XSRETURN(0);
981 }
dfd4ef2f 982}
39f7a870
JH
983
984XS(XS_PerlIO_get_layers)
985{
97aff369 986 dVAR;
39f7a870
JH
987 dXSARGS;
988 if (items < 1 || items % 2 == 0)
afa74d42 989 croak_xs_usage(cv, "filehandle[,args]");
5fef3b4a 990#ifdef USE_PERLIO
39f7a870
JH
991 {
992 SV * sv;
993 GV * gv;
994 IO * io;
995 bool input = TRUE;
996 bool details = FALSE;
997
998 if (items > 1) {
c4420975 999 SV * const *svp;
39f7a870 1000 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
1001 SV * const * const varp = svp;
1002 SV * const * const valp = svp + 1;
39f7a870 1003 STRLEN klen;
c4420975 1004 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
1005
1006 switch (*key) {
1007 case 'i':
1008 if (klen == 5 && memEQ(key, "input", 5)) {
1009 input = SvTRUE(*valp);
1010 break;
1011 }
1012 goto fail;
1013 case 'o':
1014 if (klen == 6 && memEQ(key, "output", 6)) {
1015 input = !SvTRUE(*valp);
1016 break;
1017 }
1018 goto fail;
1019 case 'd':
1020 if (klen == 7 && memEQ(key, "details", 7)) {
1021 details = SvTRUE(*valp);
1022 break;
1023 }
1024 goto fail;
1025 default:
1026 fail:
1027 Perl_croak(aTHX_
1028 "get_layers: unknown argument '%s'",
1029 key);
1030 }
1031 }
1032
1033 SP -= (items - 1);
1034 }
1035
1036 sv = POPs;
7f9aa7d3 1037 gv = MAYBE_DEREF_GV(sv);
39f7a870 1038
3825652d 1039 if (!gv && !SvROK(sv))
7f9aa7d3 1040 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
39f7a870
JH
1041
1042 if (gv && (io = GvIO(gv))) {
c4420975 1043 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870
JH
1044 IoIFP(io) : IoOFP(io));
1045 I32 i;
c4420975 1046 const I32 last = av_len(av);
39f7a870
JH
1047 I32 nitem = 0;
1048
1049 for (i = last; i >= 0; i -= 3) {
c4420975
AL
1050 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1051 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1052 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 1053
c4420975
AL
1054 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1055 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1056 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870 1057
2102d7a2 1058 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
39f7a870 1059 if (details) {
92e45a3e
NC
1060 /* Indents of 5? Yuck. */
1061 /* We know that PerlIO_get_layers creates a new SV for
1062 the name and flags, so we can just take a reference
1063 and "steal" it when we free the AV below. */
2102d7a2 1064 PUSHs(namok
92e45a3e 1065 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e 1066 : &PL_sv_undef);
2102d7a2 1067 PUSHs(argok
92e45a3e
NC
1068 ? newSVpvn_flags(SvPVX_const(*argsvp),
1069 SvCUR(*argsvp),
1070 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1071 | SVs_TEMP)
1072 : &PL_sv_undef);
2102d7a2 1073 PUSHs(flgok
92e45a3e 1074 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 1075 : &PL_sv_undef);
39f7a870
JH
1076 nitem += 3;
1077 }
1078 else {
1079 if (namok && argok)
2102d7a2 1080 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 1081 SVfARG(*namsvp),
1eb9e81d 1082 SVfARG(*argsvp))));
39f7a870 1083 else if (namok)
2102d7a2 1084 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870 1085 else
2102d7a2 1086 PUSHs(&PL_sv_undef);
39f7a870
JH
1087 nitem++;
1088 if (flgok) {
c4420975 1089 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
1090
1091 if (flags & PERLIO_F_UTF8) {
2102d7a2 1092 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
1093 nitem++;
1094 }
1095 }
1096 }
1097 }
1098
1099 SvREFCNT_dec(av);
1100
1101 XSRETURN(nitem);
1102 }
1103 }
5fef3b4a 1104#endif
39f7a870
JH
1105
1106 XSRETURN(0);
1107}
1108
241d1a3b 1109
80305961
YO
1110XS(XS_re_is_regexp)
1111{
1112 dVAR;
1113 dXSARGS;
f7e71195
AB
1114 PERL_UNUSED_VAR(cv);
1115
80305961 1116 if (items != 1)
afa74d42 1117 croak_xs_usage(cv, "sv");
f7e71195 1118
f7e71195
AB
1119 if (SvRXOK(ST(0))) {
1120 XSRETURN_YES;
1121 } else {
1122 XSRETURN_NO;
80305961
YO
1123 }
1124}
1125
192b9cd1 1126XS(XS_re_regnames_count)
80305961 1127{
192b9cd1
AB
1128 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1129 SV * ret;
80305961
YO
1130 dVAR;
1131 dXSARGS;
192b9cd1
AB
1132
1133 if (items != 0)
afa74d42 1134 croak_xs_usage(cv, "");
192b9cd1
AB
1135
1136 SP -= items;
fdae9473 1137 PUTBACK;
192b9cd1
AB
1138
1139 if (!rx)
1140 XSRETURN_UNDEF;
1141
1142 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1143
1144 SPAGAIN;
fdae9473
NC
1145 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1146 XSRETURN(1);
192b9cd1
AB
1147}
1148
1149XS(XS_re_regname)
1150{
1151 dVAR;
1152 dXSARGS;
1153 REGEXP * rx;
1154 U32 flags;
1155 SV * ret;
1156
28d8d7f4 1157 if (items < 1 || items > 2)
afa74d42 1158 croak_xs_usage(cv, "name[, all ]");
192b9cd1 1159
80305961 1160 SP -= items;
fdae9473 1161 PUTBACK;
80305961 1162
192b9cd1
AB
1163 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1164
1165 if (!rx)
1166 XSRETURN_UNDEF;
1167
1168 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 1169 flags = RXapif_ALL;
192b9cd1 1170 } else {
f1b875a0 1171 flags = RXapif_ONE;
80305961 1172 }
f1b875a0 1173 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1 1174
fdae9473
NC
1175 SPAGAIN;
1176 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1177 XSRETURN(1);
80305961
YO
1178}
1179
192b9cd1 1180
80305961
YO
1181XS(XS_re_regnames)
1182{
192b9cd1 1183 dVAR;
80305961 1184 dXSARGS;
192b9cd1
AB
1185 REGEXP * rx;
1186 U32 flags;
1187 SV *ret;
1188 AV *av;
1189 I32 length;
1190 I32 i;
1191 SV **entry;
1192
1193 if (items > 1)
afa74d42 1194 croak_xs_usage(cv, "[all]");
192b9cd1
AB
1195
1196 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1197
1198 if (!rx)
1199 XSRETURN_UNDEF;
1200
1201 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 1202 flags = RXapif_ALL;
192b9cd1 1203 } else {
f1b875a0 1204 flags = RXapif_ONE;
192b9cd1
AB
1205 }
1206
80305961 1207 SP -= items;
fdae9473 1208 PUTBACK;
80305961 1209
f1b875a0 1210 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
1211
1212 SPAGAIN;
1213
192b9cd1
AB
1214 if (!ret)
1215 XSRETURN_UNDEF;
1216
502c6561 1217 av = MUTABLE_AV(SvRV(ret));
192b9cd1
AB
1218 length = av_len(av);
1219
2102d7a2 1220 EXTEND(SP, length+1); /* better extend stack just once */
192b9cd1
AB
1221 for (i = 0; i <= length; i++) {
1222 entry = av_fetch(av, i, FALSE);
1223
1224 if (!entry)
1225 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1226
2102d7a2 1227 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 1228 }
ec83ea38
MHM
1229
1230 SvREFCNT_dec(ret);
1231
192b9cd1
AB
1232 PUTBACK;
1233 return;
80305961
YO
1234}
1235
192c1e27
JH
1236XS(XS_re_regexp_pattern)
1237{
1238 dVAR;
1239 dXSARGS;
1240 REGEXP *re;
192c1e27 1241
22d874e2
DD
1242 EXTEND(SP, 2);
1243 SP -= items;
192c1e27 1244 if (items != 1)
afa74d42 1245 croak_xs_usage(cv, "sv");
192c1e27 1246
192c1e27
JH
1247 /*
1248 Checks if a reference is a regex or not. If the parameter is
1249 not a ref, or is not the result of a qr// then returns false
1250 in scalar context and an empty list in list context.
1251 Otherwise in list context it returns the pattern and the
1252 modifiers, in scalar context it returns the pattern just as it
1253 would if the qr// was stringified normally, regardless as
486ec47a 1254 to the class of the variable and any stringification overloads
192c1e27
JH
1255 on the object.
1256 */
1257
1258 if ((re = SvRX(ST(0)))) /* assign deliberate */
1259 {
22c985d5 1260 /* Houston, we have a regex! */
192c1e27 1261 SV *pattern;
192c1e27
JH
1262
1263 if ( GIMME_V == G_ARRAY ) {
9de15fec 1264 STRLEN left = 0;
a62b1201 1265 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
69af1167
SH
1266 const char *fptr;
1267 char ch;
1268 U16 match_flags;
1269
192c1e27
JH
1270 /*
1271 we are in list context so stringify
1272 the modifiers that apply. We ignore "negative
a62b1201 1273 modifiers" in this scenario, and the default character set
192c1e27
JH
1274 */
1275
a62b1201
KW
1276 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1277 STRLEN len;
1278 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1279 &len);
1280 Copy(name, reflags + left, len, char);
1281 left += len;
9de15fec 1282 }
69af1167 1283 fptr = INT_PAT_MODS;
73134a2e 1284 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
192c1e27
JH
1285 >> RXf_PMf_STD_PMMOD_SHIFT);
1286
1287 while((ch = *fptr++)) {
1288 if(match_flags & 1) {
1289 reflags[left++] = ch;
1290 }
1291 match_flags >>= 1;
1292 }
1293
fb632ce3
NC
1294 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1295 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1296
1297 /* return the pattern and the modifiers */
2102d7a2
SM
1298 PUSHs(pattern);
1299 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
1300 XSRETURN(2);
1301 } else {
1302 /* Scalar, so use the string that Perl would return */
1303 /* return the pattern in (?msix:..) format */
1304#if PERL_VERSION >= 11
daba3364 1305 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 1306#else
fb632ce3
NC
1307 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1308 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27 1309#endif
22d874e2 1310 PUSHs(pattern);
192c1e27
JH
1311 XSRETURN(1);
1312 }
1313 } else {
1314 /* It ain't a regexp folks */
1315 if ( GIMME_V == G_ARRAY ) {
1316 /* return the empty list */
1317 XSRETURN_UNDEF;
1318 } else {
1319 /* Because of the (?:..) wrapping involved in a
1320 stringified pattern it is impossible to get a
1321 result for a real regexp that would evaluate to
1322 false. Therefore we can return PL_sv_no to signify
1323 that the object is not a regex, this means that one
1324 can say
1325
1326 if (regex($might_be_a_regex) eq '(?:foo)') { }
1327
1328 and not worry about undefined values.
1329 */
1330 XSRETURN_NO;
1331 }
1332 }
1333 /* NOT-REACHED */
1334}
1335
eff5b9d5
NC
1336struct xsub_details {
1337 const char *name;
1338 XSUBADDR_t xsub;
1339 const char *proto;
1340};
1341
613875e2 1342const struct xsub_details details[] = {
eff5b9d5
NC
1343 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1344 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1345 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1346 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1347 {"version::()", XS_version_noop, NULL},
1348 {"version::new", XS_version_new, NULL},
1349 {"version::parse", XS_version_new, NULL},
1350 {"version::(\"\"", XS_version_stringify, NULL},
1351 {"version::stringify", XS_version_stringify, NULL},
1352 {"version::(0+", XS_version_numify, NULL},
1353 {"version::numify", XS_version_numify, NULL},
1354 {"version::normal", XS_version_normal, NULL},
1355 {"version::(cmp", XS_version_vcmp, NULL},
1356 {"version::(<=>", XS_version_vcmp, NULL},
1357 {"version::vcmp", XS_version_vcmp, NULL},
1358 {"version::(bool", XS_version_boolean, NULL},
1359 {"version::boolean", XS_version_boolean, NULL},
43d9ecf9
JP
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::(*=", XS_version_noop, NULL},
1367 {"version::(/=", XS_version_noop, NULL},
1368 {"version::(abs", XS_version_noop, NULL},
eff5b9d5
NC
1369 {"version::(nomethod", XS_version_noop, NULL},
1370 {"version::noop", XS_version_noop, NULL},
1371 {"version::is_alpha", XS_version_is_alpha, NULL},
1372 {"version::qv", XS_version_qv, NULL},
1373 {"version::declare", XS_version_qv, NULL},
1374 {"version::is_qv", XS_version_is_qv, NULL},
1375 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1376 {"utf8::valid", XS_utf8_valid, NULL},
1377 {"utf8::encode", XS_utf8_encode, NULL},
1378 {"utf8::decode", XS_utf8_decode, NULL},
1379 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1380 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1381 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1382 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1383 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1384 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1385 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1386 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
eff5b9d5
NC
1387 {"re::is_regexp", XS_re_is_regexp, "$"},
1388 {"re::regname", XS_re_regname, ";$$"},
1389 {"re::regnames", XS_re_regnames, ";$"},
1390 {"re::regnames_count", XS_re_regnames_count, ""},
1391 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
eff5b9d5
NC
1392};
1393
1394void
1395Perl_boot_core_UNIVERSAL(pTHX)
1396{
1397 dVAR;
1398 static const char file[] = __FILE__;
7a6ecb12 1399 const struct xsub_details *xsub = details;
eff5b9d5
NC
1400 const struct xsub_details *end
1401 = details + sizeof(details) / sizeof(details[0]);
1402
1403 do {
1404 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1405 } while (++xsub < end);
1406
eff5b9d5 1407 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
bad4ae38
FC
1408 {
1409 CV * const cv =
1410 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1411 Safefree(CvFILE(cv));
1412 CvFILE(cv) = (char *)file;
1413 CvDYNFILE_off(cv);
1414 }
eff5b9d5 1415}
80305961 1416
241d1a3b
NC
1417/*
1418 * Local variables:
1419 * c-indentation-style: bsd
1420 * c-basic-offset: 4
14d04a33 1421 * indent-tabs-mode: nil
241d1a3b
NC
1422 * End:
1423 *
14d04a33 1424 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1425 */