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