This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use $^S instead of caller in splain
[perl5.git] / universal.c
CommitLineData
d6376244
JH
1/* universal.c
2 *
b5f8cc5c 3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
1129b882 4 * 2005, 2006, 2007, 2008 by Larry Wall and others
d6376244
JH
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
d31a8517 11/*
4ac71550
TC
12 * '"The roots of those mountains must be roots indeed; there must be
13 * great secrets buried there which have not been discovered since the
14 * beginning."' --Gandalf, relating Gollum's history
15 *
16 * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"]
d31a8517
AT
17 */
18
166f8a29
DM
19/* This file contains the code that implements the functions in Perl's
20 * UNIVERSAL package, such as UNIVERSAL->can().
192b9cd1
AB
21 *
22 * It is also used to store XS functions that need to be present in
23 * miniperl for a lack of a better place to put them. It might be
486ec47a 24 * clever to move them to separate XS files which would then be pulled
192b9cd1 25 * in by some to-be-written build process.
166f8a29
DM
26 */
27
6d4a7be2 28#include "EXTERN.h"
864dbfa3 29#define PERL_IN_UNIVERSAL_C
6d4a7be2 30#include "perl.h"
6d4a7be2 31
39f7a870
JH
32#ifdef USE_PERLIO
33#include "perliol.h" /* For the PERLIO_F_XXX */
34#endif
35
6d4a7be2
PP
36/*
37 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
38 * The main guts of traverse_isa was actually copied from gv_fetchmeth
39 */
40
a9ec700e 41STATIC bool
c7abbf64 42S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
6d4a7be2 43{
97aff369 44 dVAR;
a49ba3fc 45 const struct mro_meta *const meta = HvMROMETA(stash);
4340b386 46 HV *isa = meta->isa;
a49ba3fc 47 const HV *our_stash;
6d4a7be2 48
7918f24d
NC
49 PERL_ARGS_ASSERT_ISA_LOOKUP;
50
4340b386
FC
51 if (!isa) {
52 (void)mro_get_linear_isa(stash);
53 isa = meta->isa;
54 }
55
c7abbf64 56 if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
a49ba3fc
NC
57 HV_FETCH_ISEXISTS, NULL, 0)) {
58 /* Direct name lookup worked. */
a9ec700e 59 return TRUE;
a49ba3fc 60 }
6d4a7be2 61
a49ba3fc 62 /* A stash/class can go by many names (ie. User == main::User), so
81a5123c
FC
63 we use the HvENAME in the stash itself, which is canonical, falling
64 back to HvNAME if necessary. */
c7abbf64 65 our_stash = gv_stashpvn(name, len, flags);
a49ba3fc
NC
66
67 if (our_stash) {
81a5123c
FC
68 HEK *canon_name = HvENAME_HEK(our_stash);
69 if (!canon_name) canon_name = HvNAME_HEK(our_stash);
a1d407e8 70
a49ba3fc
NC
71 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
72 HEK_FLAGS(canon_name),
73 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
e1a479c5 74 return TRUE;
a49ba3fc 75 }
6d4a7be2
PP
76 }
77
a9ec700e 78 return FALSE;
6d4a7be2
PP
79}
80
954c1994 81/*
ccfc67b7
JH
82=head1 SV Manipulation Functions
83
c7abbf64 84=for apidoc sv_derived_from_pvn
954c1994 85
6885da0e 86Returns a boolean indicating whether the SV is derived from the specified class
87I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
88normal Perl method.
954c1994 89
c7abbf64
BF
90Currently, the only significant value for C<flags> is SVf_UTF8.
91
92=cut
93
94=for apidoc sv_derived_from_sv
95
96Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
97of an SV instead of a string/length pair.
98
99=cut
100
101*/
102
103bool
104Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
105{
106 char *namepv;
107 STRLEN namelen;
108 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
109 namepv = SvPV(namesv, namelen);
110 if (SvUTF8(namesv))
111 flags |= SVf_UTF8;
112 return sv_derived_from_pvn(sv, namepv, namelen, flags);
113}
114
115/*
116=for apidoc sv_derived_from
117
118Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
119
954c1994
GS
120=cut
121*/
122
55497cff 123bool
15f169a1 124Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
55497cff 125{
c7abbf64
BF
126 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
127 return sv_derived_from_pvn(sv, name, strlen(name), 0);
128}
129
130/*
131=for apidoc sv_derived_from_pv
132
133Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
134instead of a string/length pair.
135
136=cut
137*/
138
139
140bool
141Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
142{
143 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
144 return sv_derived_from_pvn(sv, name, strlen(name), flags);
145}
146
147bool
148Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
149{
97aff369 150 dVAR;
0b6f4f5c 151 HV *stash;
46e4b22b 152
c7abbf64 153 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
7918f24d 154
5b295bef 155 SvGETMAGIC(sv);
55497cff 156
bff39573 157 if (SvROK(sv)) {
0b6f4f5c 158 const char *type;
55497cff
PP
159 sv = SvRV(sv);
160 type = sv_reftype(sv,0);
0b6f4f5c
AL
161 if (type && strEQ(type,name))
162 return TRUE;
163 stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
55497cff
PP
164 }
165 else {
da51bb9b 166 stash = gv_stashsv(sv, 0);
61c2a935
JL
167 if (!stash)
168 stash = gv_stashpv("UNIVERSAL", 0);
55497cff 169 }
46e4b22b 170
c7abbf64 171 return stash ? isa_lookup(stash, name, len, flags) : FALSE;
55497cff
PP
172}
173
cbc021f9 174/*
d20c2c29 175=for apidoc sv_does_sv
cbc021f9 176
177Returns a boolean indicating whether the SV performs a specific, named role.
178The SV can be a Perl object or the name of a Perl class.
179
180=cut
181*/
182
1b026014
NIS
183#include "XSUB.h"
184
cbc021f9 185bool
f778bcfd 186Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
cbc021f9 187{
f778bcfd 188 SV *classname;
cbc021f9 189 bool does_it;
59e7186f 190 SV *methodname;
cbc021f9 191 dSP;
7918f24d 192
f778bcfd
BF
193 PERL_ARGS_ASSERT_SV_DOES_SV;
194 PERL_UNUSED_ARG(flags);
7918f24d 195
cbc021f9 196 ENTER;
197 SAVETMPS;
198
199 SvGETMAGIC(sv);
200
201 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
7ce46f2a
GG
202 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
203 LEAVE;
cbc021f9 204 return FALSE;
7ce46f2a 205 }
cbc021f9 206
207 if (sv_isobject(sv)) {
f778bcfd 208 classname = sv_ref(NULL,SvRV(sv),TRUE);
cbc021f9 209 } else {
f778bcfd 210 classname = sv;
cbc021f9 211 }
212
f778bcfd 213 if (sv_eq(classname, namesv)) {
7ce46f2a 214 LEAVE;
cbc021f9 215 return TRUE;
7ce46f2a 216 }
cbc021f9 217
218 PUSHMARK(SP);
f778bcfd
BF
219 EXTEND(SP, 2);
220 PUSHs(sv);
221 PUSHs(namesv);
cbc021f9 222 PUTBACK;
223
84bafc02 224 methodname = newSVpvs_flags("isa", SVs_TEMP);
59e7186f
RGS
225 /* ugly hack: use the SvSCREAM flag so S_method_common
226 * can figure out we're calling DOES() and not isa(),
227 * and report eventual errors correctly. --rgs */
228 SvSCREAM_on(methodname);
229 call_sv(methodname, G_SCALAR | G_METHOD);
cbc021f9 230 SPAGAIN;
231
232 does_it = SvTRUE( TOPs );
233 FREETMPS;
234 LEAVE;
235
236 return does_it;
237}
238
afa74d42 239/*
f778bcfd
BF
240=for apidoc sv_does
241
d20c2c29 242Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
f778bcfd
BF
243
244=cut
245*/
246
247bool
248Perl_sv_does(pTHX_ SV *sv, const char *const name)
249{
250 PERL_ARGS_ASSERT_SV_DOES;
251 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
252}
253
254/*
255=for apidoc sv_does_pv
256
7d892b8c 257Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
f778bcfd
BF
258
259=cut
260*/
261
262
263bool
264Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
265{
266 PERL_ARGS_ASSERT_SV_DOES_PV;
267 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
268}
269
7d892b8c
FC
270/*
271=for apidoc sv_does_pvn
272
273Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
274
275=cut
276*/
277
f778bcfd
BF
278bool
279Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
280{
281 PERL_ARGS_ASSERT_SV_DOES_PVN;
282
283 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
284}
285
286/*
afa74d42
NC
287=for apidoc croak_xs_usage
288
289A specialised variant of C<croak()> for emitting the usage message for xsubs
290
291 croak_xs_usage(cv, "eee_yow");
292
293works out the package name and subroutine name from C<cv>, and then calls
294C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
295
58cb15b3 296 Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
afa74d42
NC
297
298=cut
299*/
300
301void
302Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
303{
304 const GV *const gv = CvGV(cv);
305
306 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
307
308 if (gv) {
afa74d42 309 const HV *const stash = GvSTASH(gv);
afa74d42 310
58cb15b3 311 if (HvNAME_get(stash))
d0c0e7dd
FC
312 Perl_croak(aTHX_ "Usage: %"HEKf"::%"HEKf"(%s)",
313 HEKfARG(HvNAME_HEK(stash)),
314 HEKfARG(GvNAME_HEK(gv)),
58cb15b3 315 params);
afa74d42 316 else
d0c0e7dd
FC
317 Perl_croak(aTHX_ "Usage: %"HEKf"(%s)",
318 HEKfARG(GvNAME_HEK(gv)), params);
afa74d42
NC
319 } else {
320 /* Pants. I don't think that it should be possible to get here. */
93c51217 321 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
afa74d42
NC
322 }
323}
55497cff 324
6d4a7be2
PP
325XS(XS_UNIVERSAL_isa)
326{
97aff369 327 dVAR;
6d4a7be2 328 dXSARGS;
6d4a7be2
PP
329
330 if (items != 2)
afa74d42 331 croak_xs_usage(cv, "reference, kind");
c4420975
AL
332 else {
333 SV * const sv = ST(0);
6d4a7be2 334
c4420975 335 SvGETMAGIC(sv);
d3f7f2b2 336
c4420975
AL
337 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
338 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
339 XSRETURN_UNDEF;
f8f70380 340
c7abbf64 341 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
c4420975
AL
342 XSRETURN(1);
343 }
6d4a7be2
PP
344}
345
6d4a7be2
PP
346XS(XS_UNIVERSAL_can)
347{
97aff369 348 dVAR;
6d4a7be2
PP
349 dXSARGS;
350 SV *sv;
6d4a7be2 351 SV *rv;
6f08146e 352 HV *pkg = NULL;
6d4a7be2
PP
353
354 if (items != 2)
afa74d42 355 croak_xs_usage(cv, "object-ref, method");
6d4a7be2
PP
356
357 sv = ST(0);
f8f70380 358
5b295bef 359 SvGETMAGIC(sv);
d3f7f2b2 360
cee59a6a
FC
361 if (!SvOK(sv) || !(SvROK(sv) || SvNIOK(sv) || (SvPOK(sv) && SvCUR(sv))
362 || (SvGMAGICAL(sv) && (SvNIOKp(sv) || (SvPOKp(sv) && SvCUR(sv))))))
f8f70380
GS
363 XSRETURN_UNDEF;
364
3280af22 365 rv = &PL_sv_undef;
6d4a7be2 366
46e4b22b 367 if (SvROK(sv)) {
daba3364 368 sv = MUTABLE_SV(SvRV(sv));
46e4b22b 369 if (SvOBJECT(sv))
6f08146e
NIS
370 pkg = SvSTASH(sv);
371 }
372 else {
da51bb9b 373 pkg = gv_stashsv(sv, 0);
68b40612
JL
374 if (!pkg)
375 pkg = gv_stashpv("UNIVERSAL", 0);
6f08146e
NIS
376 }
377
378 if (pkg) {
a00b390b 379 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
dc848c6f 380 if (gv && isGV(gv))
daba3364 381 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
6d4a7be2
PP
382 }
383
384 ST(0) = rv;
385 XSRETURN(1);
386}
387
cbc021f9 388XS(XS_UNIVERSAL_DOES)
389{
390 dVAR;
391 dXSARGS;
58c0efa5 392 PERL_UNUSED_ARG(cv);
cbc021f9 393
394 if (items != 2)
46404226 395 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
cbc021f9 396 else {
397 SV * const sv = ST(0);
f778bcfd 398 if (sv_does_sv( sv, ST(1), 0 ))
cbc021f9 399 XSRETURN_YES;
400
401 XSRETURN_NO;
402 }
403}
404
6d4a7be2
PP
405XS(XS_UNIVERSAL_VERSION)
406{
97aff369 407 dVAR;
6d4a7be2
PP
408 dXSARGS;
409 HV *pkg;
410 GV **gvp;
411 GV *gv;
412 SV *sv;
e1ec3a88 413 const char *undef;
58c0efa5 414 PERL_UNUSED_ARG(cv);
6d4a7be2 415
1571675a 416 if (SvROK(ST(0))) {
daba3364 417 sv = MUTABLE_SV(SvRV(ST(0)));
1571675a 418 if (!SvOBJECT(sv))
cea2e8a9 419 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2
PP
420 pkg = SvSTASH(sv);
421 }
422 else {
da51bb9b 423 pkg = gv_stashsv(ST(0), 0);
6d4a7be2
PP
424 }
425
4608196e 426 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
6d4a7be2 427
0008872a 428 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
a97f6d14
JP
429 SV * const nsv = sv_newmortal();
430 sv_setsv(nsv, sv);
431 sv = nsv;
573a19fb 432 if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
a97f6d14
JP
433 upg_version(sv, FALSE);
434
c445ea15 435 undef = NULL;
6d4a7be2
PP
436 }
437 else {
a97f6d14 438 sv = &PL_sv_undef;
6d4a7be2
PP
439 undef = "(undef)";
440 }
441
1571675a 442 if (items > 1) {
1571675a
GS
443 SV *req = ST(1);
444
62658f4d 445 if (undef) {
bfcb3514 446 if (pkg) {
d0c0e7dd 447 const HEK * const name = HvNAME_HEK(pkg);
a3b680e6 448 Perl_croak(aTHX_
d0c0e7dd
FC
449 "%"HEKf" does not define $%"HEKf
450 "::VERSION--version check failed",
451 HEKfARG(name), HEKfARG(name));
bfcb3514 452 } else {
a3b680e6 453 Perl_croak(aTHX_
ed1db70e
BF
454 "%"SVf" defines neither package nor VERSION--version check failed",
455 SVfARG(ST(0)) );
62658f4d
PM
456 }
457 }
ad63d80f 458
573a19fb 459 if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
137d6fc0 460 /* req may very well be R/O, so create a new object */
ac0e6a2f 461 req = sv_2mortal( new_version(req) );
137d6fc0 462 }
1571675a 463
ac0e6a2f 464 if ( vcmp( req, sv ) > 0 ) {
ef8f7699 465 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
d0c0e7dd 466 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
ed1db70e 467 "this is only version %"SVf"",
d0c0e7dd 468 HEKfARG(HvNAME_HEK(pkg)),
e3a22e3f 469 SVfARG(sv_2mortal(vnormal(req))),
470 SVfARG(sv_2mortal(vnormal(sv))));
ac0e6a2f 471 } else {
d0c0e7dd 472 Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
ed1db70e 473 "this is only version %"SVf,
d0c0e7dd 474 HEKfARG(HvNAME_HEK(pkg)),
e3a22e3f 475 SVfARG(sv_2mortal(vstringify(req))),
476 SVfARG(sv_2mortal(vstringify(sv))));
ac0e6a2f
RGS
477 }
478 }
479
2d8e6c8d 480 }
6d4a7be2 481
a97f6d14
JP
482 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
483 ST(0) = sv_2mortal(vstringify(sv));
484 } else {
485 ST(0) = sv;
486 }
6d4a7be2
PP
487
488 XSRETURN(1);
489}
490
439cb1c4
JP
491XS(XS_version_new)
492{
97aff369 493 dVAR;
439cb1c4 494 dXSARGS;
129318bd 495 if (items > 3)
afa74d42 496 croak_xs_usage(cv, "class, version");
439cb1c4
JP
497 SP -= items;
498 {
137d6fc0
JP
499 SV *vs = ST(1);
500 SV *rv;
ed1db70e
BF
501 STRLEN len;
502 const char *classname;
503 U32 flags;
504 if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
505 const HV * stash = SvSTASH(SvRV(ST(0)));
506 classname = HvNAME(stash);
507 len = HvNAMELEN(stash);
508 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
509 }
510 else {
511 classname = SvPV(ST(0), len);
512 flags = SvUTF8(ST(0));
513 }
9137345a 514
91152fc1 515 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
92dcf8ce
JP
516 /* create empty object */
517 vs = sv_newmortal();
be5574c0 518 sv_setpvs(vs, "0");
9137345a
JP
519 }
520 else if ( items == 3 ) {
521 vs = sv_newmortal();
cfd0369c 522 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
129318bd 523 }
439cb1c4 524
137d6fc0 525 rv = new_version(vs);
ed1db70e
BF
526 if ( strnNE(classname,"version", len) ) /* inherited new() */
527 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
137d6fc0 528
6e449a3a 529 mPUSHs(rv);
439cb1c4
JP
530 PUTBACK;
531 return;
532 }
533}
534
535XS(XS_version_stringify)
536{
97aff369 537 dVAR;
41be1fbd
JH
538 dXSARGS;
539 if (items < 1)
afa74d42 540 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
541 SP -= items;
542 {
d808b681 543 SV * lobj = ST(0);
41be1fbd 544
573a19fb 545 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
d808b681 546 lobj = SvRV(lobj);
41be1fbd
JH
547 }
548 else
549 Perl_croak(aTHX_ "lobj is not of type version");
550
6e449a3a 551 mPUSHs(vstringify(lobj));
41be1fbd
JH
552
553 PUTBACK;
554 return;
555 }
439cb1c4
JP
556}
557
558XS(XS_version_numify)
559{
97aff369 560 dVAR;
41be1fbd
JH
561 dXSARGS;
562 if (items < 1)
afa74d42 563 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
564 SP -= items;
565 {
d808b681 566 SV * lobj = ST(0);
41be1fbd 567
573a19fb 568 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
d808b681 569 lobj = SvRV(lobj);
41be1fbd
JH
570 }
571 else
572 Perl_croak(aTHX_ "lobj is not of type version");
573
6e449a3a 574 mPUSHs(vnumify(lobj));
41be1fbd
JH
575
576 PUTBACK;
577 return;
578 }
439cb1c4
JP
579}
580
9137345a
JP
581XS(XS_version_normal)
582{
97aff369 583 dVAR;
9137345a
JP
584 dXSARGS;
585 if (items < 1)
afa74d42 586 croak_xs_usage(cv, "lobj, ...");
9137345a
JP
587 SP -= items;
588 {
d808b681 589 SV * lobj = ST(0);
9137345a 590
573a19fb 591 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
d808b681 592 lobj = SvRV(lobj);
9137345a
JP
593 }
594 else
595 Perl_croak(aTHX_ "lobj is not of type version");
596
6e449a3a 597 mPUSHs(vnormal(lobj));
9137345a
JP
598
599 PUTBACK;
600 return;
601 }
602}
603
439cb1c4
JP
604XS(XS_version_vcmp)
605{
97aff369 606 dVAR;
41be1fbd
JH
607 dXSARGS;
608 if (items < 1)
afa74d42 609 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
610 SP -= items;
611 {
d808b681 612 SV * lobj = ST(0);
41be1fbd 613
573a19fb 614 if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
d808b681 615 lobj = SvRV(lobj);
41be1fbd
JH
616 }
617 else
618 Perl_croak(aTHX_ "lobj is not of type version");
619
620 {
621 SV *rs;
622 SV *rvs;
623 SV * robj = ST(1);
7452cf6a 624 const IV swap = (IV)SvIV(ST(2));
41be1fbd 625
573a19fb 626 if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
41be1fbd 627 {
e3a22e3f 628 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
629 sv_2mortal(robj);
41be1fbd
JH
630 }
631 rvs = SvRV(robj);
632
633 if ( swap )
634 {
635 rs = newSViv(vcmp(rvs,lobj));
636 }
637 else
638 {
639 rs = newSViv(vcmp(lobj,rvs));
640 }
641
6e449a3a 642 mPUSHs(rs);
41be1fbd
JH
643 }
644
645 PUTBACK;
646 return;
647 }
439cb1c4
JP
648}
649
650XS(XS_version_boolean)
651{
97aff369
JH
652 dVAR;
653 dXSARGS;
654 if (items < 1)
afa74d42 655 croak_xs_usage(cv, "lobj, ...");
97aff369 656 SP -= items;
573a19fb 657 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
c4420975 658 SV * const lobj = SvRV(ST(0));
bcb2959f
FC
659 SV * const rs =
660 newSViv( vcmp(lobj,
661 sv_2mortal(new_version(
662 sv_2mortal(newSVpvs("0"))
663 ))
664 )
665 );
6e449a3a 666 mPUSHs(rs);
c4420975
AL
667 PUTBACK;
668 return;
669 }
670 else
671 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
672}
673
674XS(XS_version_noop)
675{
97aff369 676 dVAR;
2dfd8427
AL
677 dXSARGS;
678 if (items < 1)
afa74d42 679 croak_xs_usage(cv, "lobj, ...");
573a19fb 680 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
2dfd8427
AL
681 Perl_croak(aTHX_ "operation not supported with version object");
682 else
683 Perl_croak(aTHX_ "lobj is not of type version");
684#ifndef HASATTRIBUTE_NORETURN
685 XSRETURN_EMPTY;
686#endif
439cb1c4
JP
687}
688
c8d69e4a
JP
689XS(XS_version_is_alpha)
690{
97aff369 691 dVAR;
c8d69e4a
JP
692 dXSARGS;
693 if (items != 1)
afa74d42 694 croak_xs_usage(cv, "lobj");
c8d69e4a 695 SP -= items;
573a19fb 696 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
c4420975 697 SV * const lobj = ST(0);
ef8f7699 698 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
c4420975
AL
699 XSRETURN_YES;
700 else
701 XSRETURN_NO;
c8d69e4a
JP
702 PUTBACK;
703 return;
704 }
c4420975
AL
705 else
706 Perl_croak(aTHX_ "lobj is not of type version");
c8d69e4a
JP
707}
708
137d6fc0
JP
709XS(XS_version_qv)
710{
97aff369 711 dVAR;
137d6fc0 712 dXSARGS;
4ed3fda4 713 PERL_UNUSED_ARG(cv);
137d6fc0
JP
714 SP -= items;
715 {
f941e658
JP
716 SV * ver = ST(0);
717 SV * rv;
ed1db70e
BF
718 STRLEN len = 0;
719 const char * classname = "";
720 U32 flags = 0;
721 if ( items == 2 && SvOK(ST(1)) ) {
722 ver = ST(1);
723 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
724 const HV * stash = SvSTASH(SvRV(ST(0)));
725 classname = HvNAME(stash);
726 len = HvNAMELEN(stash);
727 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
728 }
729 else {
730 classname = SvPV(ST(0), len);
731 flags = SvUTF8(ST(0));
732 }
733 }
f941e658
JP
734 if ( !SvVOK(ver) ) { /* not already a v-string */
735 rv = sv_newmortal();
ac0e6a2f
RGS
736 sv_setsv(rv,ver); /* make a duplicate */
737 upg_version(rv, TRUE);
f941e658
JP
738 } else {
739 rv = sv_2mortal(new_version(ver));
137d6fc0 740 }
ed1db70e
BF
741 if ( items == 2
742 && strnNE(classname,"version", len) ) { /* inherited new() */
743 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
744 }
f941e658
JP
745 PUSHs(rv);
746 }
747 PUTBACK;
748 return;
749}
137d6fc0 750
f941e658
JP
751XS(XS_version_is_qv)
752{
753 dVAR;
754 dXSARGS;
755 if (items != 1)
756 croak_xs_usage(cv, "lobj");
757 SP -= items;
573a19fb 758 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
f941e658
JP
759 SV * const lobj = ST(0);
760 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
761 XSRETURN_YES;
762 else
763 XSRETURN_NO;
137d6fc0
JP
764 PUTBACK;
765 return;
766 }
f941e658
JP
767 else
768 Perl_croak(aTHX_ "lobj is not of type version");
137d6fc0
JP
769}
770
8800c35a
JH
771XS(XS_utf8_is_utf8)
772{
97aff369 773 dVAR;
41be1fbd
JH
774 dXSARGS;
775 if (items != 1)
afa74d42 776 croak_xs_usage(cv, "sv");
c4420975 777 else {
76f73021 778 SV * const sv = ST(0);
779 SvGETMAGIC(sv);
c4420975
AL
780 if (SvUTF8(sv))
781 XSRETURN_YES;
782 else
783 XSRETURN_NO;
41be1fbd
JH
784 }
785 XSRETURN_EMPTY;
8800c35a
JH
786}
787
1b026014
NIS
788XS(XS_utf8_valid)
789{
97aff369 790 dVAR;
41be1fbd
JH
791 dXSARGS;
792 if (items != 1)
afa74d42 793 croak_xs_usage(cv, "sv");
c4420975
AL
794 else {
795 SV * const sv = ST(0);
796 STRLEN len;
797 const char * const s = SvPV_const(sv,len);
798 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
799 XSRETURN_YES;
800 else
801 XSRETURN_NO;
802 }
41be1fbd 803 XSRETURN_EMPTY;
1b026014
NIS
804}
805
806XS(XS_utf8_encode)
807{
97aff369 808 dVAR;
1b026014
NIS
809 dXSARGS;
810 if (items != 1)
afa74d42 811 croak_xs_usage(cv, "sv");
c4420975 812 sv_utf8_encode(ST(0));
1b026014
NIS
813 XSRETURN_EMPTY;
814}
815
816XS(XS_utf8_decode)
817{
97aff369 818 dVAR;
1b026014
NIS
819 dXSARGS;
820 if (items != 1)
afa74d42 821 croak_xs_usage(cv, "sv");
c4420975
AL
822 else {
823 SV * const sv = ST(0);
b2b7346b 824 bool RETVAL;
c7102404 825 SvPV_force_nolen(sv);
b2b7346b 826 RETVAL = sv_utf8_decode(sv);
1b026014 827 ST(0) = boolSV(RETVAL);
1b026014
NIS
828 }
829 XSRETURN(1);
830}
831
832XS(XS_utf8_upgrade)
833{
97aff369 834 dVAR;
1b026014
NIS
835 dXSARGS;
836 if (items != 1)
afa74d42 837 croak_xs_usage(cv, "sv");
c4420975
AL
838 else {
839 SV * const sv = ST(0);
1b026014
NIS
840 STRLEN RETVAL;
841 dXSTARG;
842
843 RETVAL = sv_utf8_upgrade(sv);
844 XSprePUSH; PUSHi((IV)RETVAL);
845 }
846 XSRETURN(1);
847}
848
849XS(XS_utf8_downgrade)
850{
97aff369 851 dVAR;
1b026014
NIS
852 dXSARGS;
853 if (items < 1 || items > 2)
afa74d42 854 croak_xs_usage(cv, "sv, failok=0");
c4420975
AL
855 else {
856 SV * const sv = ST(0);
6867be6d
AL
857 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
858 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 859
1b026014 860 ST(0) = boolSV(RETVAL);
1b026014
NIS
861 }
862 XSRETURN(1);
863}
864
865XS(XS_utf8_native_to_unicode)
866{
97aff369 867 dVAR;
1b026014 868 dXSARGS;
6867be6d 869 const UV uv = SvUV(ST(0));
b7953727
JH
870
871 if (items > 1)
afa74d42 872 croak_xs_usage(cv, "sv");
b7953727 873
1b026014
NIS
874 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
875 XSRETURN(1);
876}
877
878XS(XS_utf8_unicode_to_native)
879{
97aff369 880 dVAR;
1b026014 881 dXSARGS;
6867be6d 882 const UV uv = SvUV(ST(0));
b7953727
JH
883
884 if (items > 1)
afa74d42 885 croak_xs_usage(cv, "sv");
b7953727 886
1b026014
NIS
887 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
888 XSRETURN(1);
889}
890
14a976d6 891XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577 892{
97aff369 893 dVAR;
29569577 894 dXSARGS;
80b6a949
AB
895 SV * const svz = ST(0);
896 SV * sv;
58c0efa5 897 PERL_UNUSED_ARG(cv);
6867be6d 898
80b6a949
AB
899 /* [perl #77776] - called as &foo() not foo() */
900 if (!SvROK(svz))
901 croak_xs_usage(cv, "SCALAR[, ON]");
902
903 sv = SvRV(svz);
904
29569577 905 if (items == 1) {
3e89ba19 906 if (SvREADONLY(sv) && !SvIsCOW(sv))
29569577
JH
907 XSRETURN_YES;
908 else
909 XSRETURN_NO;
910 }
911 else if (items == 2) {
912 if (SvTRUE(ST(1))) {
3e89ba19 913 if (SvIsCOW(sv)) sv_force_normal(sv);
29569577
JH
914 SvREADONLY_on(sv);
915 XSRETURN_YES;
916 }
917 else {
14a976d6 918 /* I hope you really know what you are doing. */
3e89ba19 919 if (!SvIsCOW(sv)) SvREADONLY_off(sv);
29569577
JH
920 XSRETURN_NO;
921 }
922 }
14a976d6 923 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
924}
925
14a976d6 926XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577 927{
97aff369 928 dVAR;
29569577 929 dXSARGS;
80b6a949
AB
930 SV * const svz = ST(0);
931 SV * sv;
58c0efa5 932 PERL_UNUSED_ARG(cv);
6867be6d 933
80b6a949
AB
934 /* [perl #77776] - called as &foo() not foo() */
935 if (!SvROK(svz))
936 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
937
938 sv = SvRV(svz);
939
29569577 940 if (items == 1)
691f1758 941 XSRETURN_UV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 942 else if (items == 2) {
14a976d6 943 /* I hope you really know what you are doing. */
691f1758
TC
944 SvREFCNT(sv) = SvUV(ST(1)) + 1; /* we free one ref on exit */
945 XSRETURN_UV(SvREFCNT(sv) - 1);
29569577 946 }
14a976d6 947 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
948}
949
f044d0d1 950XS(XS_Internals_hv_clear_placehold)
dfd4ef2f 951{
97aff369 952 dVAR;
dfd4ef2f 953 dXSARGS;
6867be6d 954
80b6a949 955 if (items != 1 || !SvROK(ST(0)))
afa74d42 956 croak_xs_usage(cv, "hv");
c4420975 957 else {
ef8f7699 958 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
959 hv_clear_placeholders(hv);
960 XSRETURN(0);
961 }
dfd4ef2f 962}
39f7a870
JH
963
964XS(XS_PerlIO_get_layers)
965{
97aff369 966 dVAR;
39f7a870
JH
967 dXSARGS;
968 if (items < 1 || items % 2 == 0)
afa74d42 969 croak_xs_usage(cv, "filehandle[,args]");
5fef3b4a 970#ifdef USE_PERLIO
39f7a870
JH
971 {
972 SV * sv;
973 GV * gv;
974 IO * io;
975 bool input = TRUE;
976 bool details = FALSE;
977
978 if (items > 1) {
c4420975 979 SV * const *svp;
39f7a870 980 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
981 SV * const * const varp = svp;
982 SV * const * const valp = svp + 1;
39f7a870 983 STRLEN klen;
c4420975 984 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
985
986 switch (*key) {
987 case 'i':
988 if (klen == 5 && memEQ(key, "input", 5)) {
989 input = SvTRUE(*valp);
990 break;
991 }
992 goto fail;
993 case 'o':
994 if (klen == 6 && memEQ(key, "output", 6)) {
995 input = !SvTRUE(*valp);
996 break;
997 }
998 goto fail;
999 case 'd':
1000 if (klen == 7 && memEQ(key, "details", 7)) {
1001 details = SvTRUE(*valp);
1002 break;
1003 }
1004 goto fail;
1005 default:
1006 fail:
1007 Perl_croak(aTHX_
1008 "get_layers: unknown argument '%s'",
1009 key);
1010 }
1011 }
1012
1013 SP -= (items - 1);
1014 }
1015
1016 sv = POPs;
7f9aa7d3 1017 gv = MAYBE_DEREF_GV(sv);
39f7a870 1018
3825652d 1019 if (!gv && !SvROK(sv))
7f9aa7d3 1020 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
39f7a870
JH
1021
1022 if (gv && (io = GvIO(gv))) {
c4420975 1023 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870
JH
1024 IoIFP(io) : IoOFP(io));
1025 I32 i;
c4420975 1026 const I32 last = av_len(av);
39f7a870
JH
1027 I32 nitem = 0;
1028
1029 for (i = last; i >= 0; i -= 3) {
c4420975
AL
1030 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1031 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1032 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 1033
c4420975
AL
1034 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1035 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1036 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870
JH
1037
1038 if (details) {
92e45a3e
NC
1039 /* Indents of 5? Yuck. */
1040 /* We know that PerlIO_get_layers creates a new SV for
1041 the name and flags, so we can just take a reference
1042 and "steal" it when we free the AV below. */
ec3bab8e 1043 XPUSHs(namok
92e45a3e 1044 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e
NC
1045 : &PL_sv_undef);
1046 XPUSHs(argok
92e45a3e
NC
1047 ? newSVpvn_flags(SvPVX_const(*argsvp),
1048 SvCUR(*argsvp),
1049 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1050 | SVs_TEMP)
1051 : &PL_sv_undef);
96ccaf53 1052 XPUSHs(flgok
92e45a3e 1053 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 1054 : &PL_sv_undef);
39f7a870
JH
1055 nitem += 3;
1056 }
1057 else {
1058 if (namok && argok)
1eb9e81d 1059 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 1060 SVfARG(*namsvp),
1eb9e81d 1061 SVfARG(*argsvp))));
39f7a870 1062 else if (namok)
92e45a3e 1063 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870
JH
1064 else
1065 XPUSHs(&PL_sv_undef);
1066 nitem++;
1067 if (flgok) {
c4420975 1068 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
1069
1070 if (flags & PERLIO_F_UTF8) {
84bafc02 1071 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
1072 nitem++;
1073 }
1074 }
1075 }
1076 }
1077
1078 SvREFCNT_dec(av);
1079
1080 XSRETURN(nitem);
1081 }
1082 }
5fef3b4a 1083#endif
39f7a870
JH
1084
1085 XSRETURN(0);
1086}
1087
9a7034eb 1088XS(XS_Internals_hash_seed)
c910b28a 1089{
97aff369 1090 dVAR;
c85d3f85
NC
1091 /* Using dXSARGS would also have dITEM and dSP,
1092 * which define 2 unused local variables. */
557b887a 1093 dAXMARK;
53c1dcc0 1094 PERL_UNUSED_ARG(cv);
ad73156c 1095 PERL_UNUSED_VAR(mark);
81eaca17 1096 XSRETURN_UV(PERL_HASH_SEED);
c910b28a
JH
1097}
1098
008fb0c0 1099XS(XS_Internals_rehash_seed)
8e90d776 1100{
97aff369 1101 dVAR;
8e90d776
NC
1102 /* Using dXSARGS would also have dITEM and dSP,
1103 * which define 2 unused local variables. */
557b887a 1104 dAXMARK;
53c1dcc0 1105 PERL_UNUSED_ARG(cv);
ad73156c 1106 PERL_UNUSED_VAR(mark);
008fb0c0 1107 XSRETURN_UV(PL_rehash_seed);
8e90d776
NC
1108}
1109
05619474
NC
1110XS(XS_Internals_HvREHASH) /* Subject to change */
1111{
97aff369 1112 dVAR;
05619474 1113 dXSARGS;
93c51217 1114 PERL_UNUSED_ARG(cv);
05619474 1115 if (SvROK(ST(0))) {
ef8f7699 1116 const HV * const hv = (const HV *) SvRV(ST(0));
05619474
NC
1117 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1118 if (HvREHASH(hv))
1119 XSRETURN_YES;
1120 else
1121 XSRETURN_NO;
1122 }
1123 }
1124 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
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;
1206 I32 length;
1207 I32 i;
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
1237 for (i = 0; i <= length; i++) {
1238 entry = av_fetch(av, i, FALSE);
1239
1240 if (!entry)
1241 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1242
ec83ea38 1243 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 1244 }
ec83ea38
MHM
1245
1246 SvREFCNT_dec(ret);
1247
192b9cd1
AB
1248 PUTBACK;
1249 return;
80305961
YO
1250}
1251
192c1e27
JH
1252XS(XS_re_regexp_pattern)
1253{
1254 dVAR;
1255 dXSARGS;
1256 REGEXP *re;
192c1e27
JH
1257
1258 if (items != 1)
afa74d42 1259 croak_xs_usage(cv, "sv");
192c1e27
JH
1260
1261 SP -= items;
1262
1263 /*
1264 Checks if a reference is a regex or not. If the parameter is
1265 not a ref, or is not the result of a qr// then returns false
1266 in scalar context and an empty list in list context.
1267 Otherwise in list context it returns the pattern and the
1268 modifiers, in scalar context it returns the pattern just as it
1269 would if the qr// was stringified normally, regardless as
486ec47a 1270 to the class of the variable and any stringification overloads
192c1e27
JH
1271 on the object.
1272 */
1273
1274 if ((re = SvRX(ST(0)))) /* assign deliberate */
1275 {
22c985d5 1276 /* Houston, we have a regex! */
192c1e27 1277 SV *pattern;
192c1e27
JH
1278
1279 if ( GIMME_V == G_ARRAY ) {
9de15fec 1280 STRLEN left = 0;
a62b1201 1281 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
69af1167
SH
1282 const char *fptr;
1283 char ch;
1284 U16 match_flags;
1285
192c1e27
JH
1286 /*
1287 we are in list context so stringify
1288 the modifiers that apply. We ignore "negative
a62b1201 1289 modifiers" in this scenario, and the default character set
192c1e27
JH
1290 */
1291
a62b1201
KW
1292 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1293 STRLEN len;
1294 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1295 &len);
1296 Copy(name, reflags + left, len, char);
1297 left += len;
9de15fec 1298 }
69af1167 1299 fptr = INT_PAT_MODS;
73134a2e 1300 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
192c1e27
JH
1301 >> RXf_PMf_STD_PMMOD_SHIFT);
1302
1303 while((ch = *fptr++)) {
1304 if(match_flags & 1) {
1305 reflags[left++] = ch;
1306 }
1307 match_flags >>= 1;
1308 }
1309
fb632ce3
NC
1310 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1311 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1312
1313 /* return the pattern and the modifiers */
1314 XPUSHs(pattern);
fb632ce3 1315 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
1316 XSRETURN(2);
1317 } else {
1318 /* Scalar, so use the string that Perl would return */
1319 /* return the pattern in (?msix:..) format */
1320#if PERL_VERSION >= 11
daba3364 1321 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 1322#else
fb632ce3
NC
1323 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1324 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1325#endif
1326 XPUSHs(pattern);
1327 XSRETURN(1);
1328 }
1329 } else {
1330 /* It ain't a regexp folks */
1331 if ( GIMME_V == G_ARRAY ) {
1332 /* return the empty list */
1333 XSRETURN_UNDEF;
1334 } else {
1335 /* Because of the (?:..) wrapping involved in a
1336 stringified pattern it is impossible to get a
1337 result for a real regexp that would evaluate to
1338 false. Therefore we can return PL_sv_no to signify
1339 that the object is not a regex, this means that one
1340 can say
1341
1342 if (regex($might_be_a_regex) eq '(?:foo)') { }
1343
1344 and not worry about undefined values.
1345 */
1346 XSRETURN_NO;
1347 }
1348 }
1349 /* NOT-REACHED */
1350}
1351
eff5b9d5
NC
1352struct xsub_details {
1353 const char *name;
1354 XSUBADDR_t xsub;
1355 const char *proto;
1356};
1357
1358struct xsub_details details[] = {
1359 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1360 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1361 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1362 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1363 {"version::()", XS_version_noop, NULL},
1364 {"version::new", XS_version_new, NULL},
1365 {"version::parse", XS_version_new, NULL},
1366 {"version::(\"\"", XS_version_stringify, NULL},
1367 {"version::stringify", XS_version_stringify, NULL},
1368 {"version::(0+", XS_version_numify, NULL},
1369 {"version::numify", XS_version_numify, NULL},
1370 {"version::normal", XS_version_normal, NULL},
1371 {"version::(cmp", XS_version_vcmp, NULL},
1372 {"version::(<=>", XS_version_vcmp, NULL},
1373 {"version::vcmp", XS_version_vcmp, NULL},
1374 {"version::(bool", XS_version_boolean, NULL},
1375 {"version::boolean", XS_version_boolean, NULL},
43d9ecf9
JP
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::(*=", XS_version_noop, NULL},
1383 {"version::(/=", XS_version_noop, NULL},
1384 {"version::(abs", XS_version_noop, NULL},
eff5b9d5
NC
1385 {"version::(nomethod", XS_version_noop, NULL},
1386 {"version::noop", XS_version_noop, NULL},
1387 {"version::is_alpha", XS_version_is_alpha, NULL},
1388 {"version::qv", XS_version_qv, NULL},
1389 {"version::declare", XS_version_qv, NULL},
1390 {"version::is_qv", XS_version_is_qv, NULL},
1391 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1392 {"utf8::valid", XS_utf8_valid, NULL},
1393 {"utf8::encode", XS_utf8_encode, NULL},
1394 {"utf8::decode", XS_utf8_decode, NULL},
1395 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1396 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1397 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1398 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1399 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1400 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1401 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1402 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1403 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1404 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1405 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1406 {"re::is_regexp", XS_re_is_regexp, "$"},
1407 {"re::regname", XS_re_regname, ";$$"},
1408 {"re::regnames", XS_re_regnames, ";$"},
1409 {"re::regnames_count", XS_re_regnames_count, ""},
1410 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
eff5b9d5
NC
1411};
1412
1413void
1414Perl_boot_core_UNIVERSAL(pTHX)
1415{
1416 dVAR;
1417 static const char file[] = __FILE__;
1418 struct xsub_details *xsub = details;
1419 const struct xsub_details *end
1420 = details + sizeof(details) / sizeof(details[0]);
1421
1422 do {
1423 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1424 } while (++xsub < end);
1425
eff5b9d5 1426 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
bad4ae38
FC
1427 {
1428 CV * const cv =
1429 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1430 Safefree(CvFILE(cv));
1431 CvFILE(cv) = (char *)file;
1432 CvDYNFILE_off(cv);
1433 }
eff5b9d5 1434}
80305961 1435
241d1a3b
NC
1436/*
1437 * Local variables:
1438 * c-indentation-style: bsd
1439 * c-basic-offset: 4
14d04a33 1440 * indent-tabs-mode: nil
241d1a3b
NC
1441 * End:
1442 *
14d04a33 1443 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1444 */