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