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