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