This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Run more substr tests under a new thread
[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));
396482e1 655 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
6e449a3a 656 mPUSHs(rs);
c4420975
AL
657 PUTBACK;
658 return;
659 }
660 else
661 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
662}
663
664XS(XS_version_noop)
665{
97aff369 666 dVAR;
2dfd8427
AL
667 dXSARGS;
668 if (items < 1)
afa74d42 669 croak_xs_usage(cv, "lobj, ...");
573a19fb 670 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
2dfd8427
AL
671 Perl_croak(aTHX_ "operation not supported with version object");
672 else
673 Perl_croak(aTHX_ "lobj is not of type version");
674#ifndef HASATTRIBUTE_NORETURN
675 XSRETURN_EMPTY;
676#endif
439cb1c4
JP
677}
678
c8d69e4a
JP
679XS(XS_version_is_alpha)
680{
97aff369 681 dVAR;
c8d69e4a
JP
682 dXSARGS;
683 if (items != 1)
afa74d42 684 croak_xs_usage(cv, "lobj");
c8d69e4a 685 SP -= items;
573a19fb 686 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
c4420975 687 SV * const lobj = ST(0);
ef8f7699 688 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
c4420975
AL
689 XSRETURN_YES;
690 else
691 XSRETURN_NO;
c8d69e4a
JP
692 PUTBACK;
693 return;
694 }
c4420975
AL
695 else
696 Perl_croak(aTHX_ "lobj is not of type version");
c8d69e4a
JP
697}
698
137d6fc0
JP
699XS(XS_version_qv)
700{
97aff369 701 dVAR;
137d6fc0 702 dXSARGS;
4ed3fda4 703 PERL_UNUSED_ARG(cv);
137d6fc0
JP
704 SP -= items;
705 {
f941e658
JP
706 SV * ver = ST(0);
707 SV * rv;
ed1db70e
BF
708 STRLEN len = 0;
709 const char * classname = "";
710 U32 flags = 0;
711 if ( items == 2 && SvOK(ST(1)) ) {
712 ver = ST(1);
713 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
714 const HV * stash = SvSTASH(SvRV(ST(0)));
715 classname = HvNAME(stash);
716 len = HvNAMELEN(stash);
717 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
718 }
719 else {
720 classname = SvPV(ST(0), len);
721 flags = SvUTF8(ST(0));
722 }
723 }
f941e658
JP
724 if ( !SvVOK(ver) ) { /* not already a v-string */
725 rv = sv_newmortal();
ac0e6a2f
RGS
726 sv_setsv(rv,ver); /* make a duplicate */
727 upg_version(rv, TRUE);
f941e658
JP
728 } else {
729 rv = sv_2mortal(new_version(ver));
137d6fc0 730 }
ed1db70e
BF
731 if ( items == 2
732 && strnNE(classname,"version", len) ) { /* inherited new() */
733 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
734 }
f941e658
JP
735 PUSHs(rv);
736 }
737 PUTBACK;
738 return;
739}
137d6fc0 740
f941e658
JP
741XS(XS_version_is_qv)
742{
743 dVAR;
744 dXSARGS;
745 if (items != 1)
746 croak_xs_usage(cv, "lobj");
747 SP -= items;
573a19fb 748 if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
f941e658
JP
749 SV * const lobj = ST(0);
750 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
751 XSRETURN_YES;
752 else
753 XSRETURN_NO;
137d6fc0
JP
754 PUTBACK;
755 return;
756 }
f941e658
JP
757 else
758 Perl_croak(aTHX_ "lobj is not of type version");
137d6fc0
JP
759}
760
8800c35a
JH
761XS(XS_utf8_is_utf8)
762{
97aff369 763 dVAR;
41be1fbd
JH
764 dXSARGS;
765 if (items != 1)
afa74d42 766 croak_xs_usage(cv, "sv");
c4420975 767 else {
76f73021 768 SV * const sv = ST(0);
769 SvGETMAGIC(sv);
c4420975
AL
770 if (SvUTF8(sv))
771 XSRETURN_YES;
772 else
773 XSRETURN_NO;
41be1fbd
JH
774 }
775 XSRETURN_EMPTY;
8800c35a
JH
776}
777
1b026014
NIS
778XS(XS_utf8_valid)
779{
97aff369 780 dVAR;
41be1fbd
JH
781 dXSARGS;
782 if (items != 1)
afa74d42 783 croak_xs_usage(cv, "sv");
c4420975
AL
784 else {
785 SV * const sv = ST(0);
786 STRLEN len;
787 const char * const s = SvPV_const(sv,len);
788 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
789 XSRETURN_YES;
790 else
791 XSRETURN_NO;
792 }
41be1fbd 793 XSRETURN_EMPTY;
1b026014
NIS
794}
795
796XS(XS_utf8_encode)
797{
97aff369 798 dVAR;
1b026014
NIS
799 dXSARGS;
800 if (items != 1)
afa74d42 801 croak_xs_usage(cv, "sv");
c4420975 802 sv_utf8_encode(ST(0));
1b026014
NIS
803 XSRETURN_EMPTY;
804}
805
806XS(XS_utf8_decode)
807{
97aff369 808 dVAR;
1b026014
NIS
809 dXSARGS;
810 if (items != 1)
afa74d42 811 croak_xs_usage(cv, "sv");
c4420975
AL
812 else {
813 SV * const sv = ST(0);
b2b7346b
FC
814 bool RETVAL;
815 if (SvIsCOW(sv)) sv_force_normal(sv);
816 RETVAL = sv_utf8_decode(sv);
1b026014 817 ST(0) = boolSV(RETVAL);
1b026014
NIS
818 }
819 XSRETURN(1);
820}
821
822XS(XS_utf8_upgrade)
823{
97aff369 824 dVAR;
1b026014
NIS
825 dXSARGS;
826 if (items != 1)
afa74d42 827 croak_xs_usage(cv, "sv");
c4420975
AL
828 else {
829 SV * const sv = ST(0);
1b026014
NIS
830 STRLEN RETVAL;
831 dXSTARG;
832
833 RETVAL = sv_utf8_upgrade(sv);
834 XSprePUSH; PUSHi((IV)RETVAL);
835 }
836 XSRETURN(1);
837}
838
839XS(XS_utf8_downgrade)
840{
97aff369 841 dVAR;
1b026014
NIS
842 dXSARGS;
843 if (items < 1 || items > 2)
afa74d42 844 croak_xs_usage(cv, "sv, failok=0");
c4420975
AL
845 else {
846 SV * const sv = ST(0);
6867be6d
AL
847 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
848 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 849
1b026014 850 ST(0) = boolSV(RETVAL);
1b026014
NIS
851 }
852 XSRETURN(1);
853}
854
855XS(XS_utf8_native_to_unicode)
856{
97aff369 857 dVAR;
1b026014 858 dXSARGS;
6867be6d 859 const UV uv = SvUV(ST(0));
b7953727
JH
860
861 if (items > 1)
afa74d42 862 croak_xs_usage(cv, "sv");
b7953727 863
1b026014
NIS
864 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
865 XSRETURN(1);
866}
867
868XS(XS_utf8_unicode_to_native)
869{
97aff369 870 dVAR;
1b026014 871 dXSARGS;
6867be6d 872 const UV uv = SvUV(ST(0));
b7953727
JH
873
874 if (items > 1)
afa74d42 875 croak_xs_usage(cv, "sv");
b7953727 876
1b026014
NIS
877 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
878 XSRETURN(1);
879}
880
14a976d6 881XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577 882{
97aff369 883 dVAR;
29569577 884 dXSARGS;
80b6a949
AB
885 SV * const svz = ST(0);
886 SV * sv;
58c0efa5 887 PERL_UNUSED_ARG(cv);
6867be6d 888
80b6a949
AB
889 /* [perl #77776] - called as &foo() not foo() */
890 if (!SvROK(svz))
891 croak_xs_usage(cv, "SCALAR[, ON]");
892
893 sv = SvRV(svz);
894
29569577 895 if (items == 1) {
3e89ba19 896 if (SvREADONLY(sv) && !SvIsCOW(sv))
29569577
JH
897 XSRETURN_YES;
898 else
899 XSRETURN_NO;
900 }
901 else if (items == 2) {
902 if (SvTRUE(ST(1))) {
3e89ba19 903 if (SvIsCOW(sv)) sv_force_normal(sv);
29569577
JH
904 SvREADONLY_on(sv);
905 XSRETURN_YES;
906 }
907 else {
14a976d6 908 /* I hope you really know what you are doing. */
3e89ba19 909 if (!SvIsCOW(sv)) SvREADONLY_off(sv);
29569577
JH
910 XSRETURN_NO;
911 }
912 }
14a976d6 913 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
914}
915
14a976d6 916XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577 917{
97aff369 918 dVAR;
29569577 919 dXSARGS;
80b6a949
AB
920 SV * const svz = ST(0);
921 SV * sv;
58c0efa5 922 PERL_UNUSED_ARG(cv);
6867be6d 923
80b6a949
AB
924 /* [perl #77776] - called as &foo() not foo() */
925 if (!SvROK(svz))
926 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
927
928 sv = SvRV(svz);
929
29569577 930 if (items == 1)
691f1758 931 XSRETURN_UV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 932 else if (items == 2) {
14a976d6 933 /* I hope you really know what you are doing. */
691f1758
TC
934 SvREFCNT(sv) = SvUV(ST(1)) + 1; /* we free one ref on exit */
935 XSRETURN_UV(SvREFCNT(sv) - 1);
29569577 936 }
14a976d6 937 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
938}
939
f044d0d1 940XS(XS_Internals_hv_clear_placehold)
dfd4ef2f 941{
97aff369 942 dVAR;
dfd4ef2f 943 dXSARGS;
6867be6d 944
80b6a949 945 if (items != 1 || !SvROK(ST(0)))
afa74d42 946 croak_xs_usage(cv, "hv");
c4420975 947 else {
ef8f7699 948 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
949 hv_clear_placeholders(hv);
950 XSRETURN(0);
951 }
dfd4ef2f 952}
39f7a870
JH
953
954XS(XS_PerlIO_get_layers)
955{
97aff369 956 dVAR;
39f7a870
JH
957 dXSARGS;
958 if (items < 1 || items % 2 == 0)
afa74d42 959 croak_xs_usage(cv, "filehandle[,args]");
5fef3b4a 960#ifdef USE_PERLIO
39f7a870
JH
961 {
962 SV * sv;
963 GV * gv;
964 IO * io;
965 bool input = TRUE;
966 bool details = FALSE;
967
968 if (items > 1) {
c4420975 969 SV * const *svp;
39f7a870 970 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
971 SV * const * const varp = svp;
972 SV * const * const valp = svp + 1;
39f7a870 973 STRLEN klen;
c4420975 974 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
975
976 switch (*key) {
977 case 'i':
978 if (klen == 5 && memEQ(key, "input", 5)) {
979 input = SvTRUE(*valp);
980 break;
981 }
982 goto fail;
983 case 'o':
984 if (klen == 6 && memEQ(key, "output", 6)) {
985 input = !SvTRUE(*valp);
986 break;
987 }
988 goto fail;
989 case 'd':
990 if (klen == 7 && memEQ(key, "details", 7)) {
991 details = SvTRUE(*valp);
992 break;
993 }
994 goto fail;
995 default:
996 fail:
997 Perl_croak(aTHX_
998 "get_layers: unknown argument '%s'",
999 key);
1000 }
1001 }
1002
1003 SP -= (items - 1);
1004 }
1005
1006 sv = POPs;
159b6efe 1007 gv = MUTABLE_GV(sv);
39f7a870
JH
1008
1009 if (!isGV(sv)) {
1010 if (SvROK(sv) && isGV(SvRV(sv)))
159b6efe 1011 gv = MUTABLE_GV(SvRV(sv));
671d49be 1012 else if (SvPOKp(sv))
f776e3cd 1013 gv = gv_fetchsv(sv, 0, SVt_PVIO);
39f7a870
JH
1014 }
1015
1016 if (gv && (io = GvIO(gv))) {
c4420975 1017 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870
JH
1018 IoIFP(io) : IoOFP(io));
1019 I32 i;
c4420975 1020 const I32 last = av_len(av);
39f7a870
JH
1021 I32 nitem = 0;
1022
1023 for (i = last; i >= 0; i -= 3) {
c4420975
AL
1024 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1025 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1026 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 1027
c4420975
AL
1028 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1029 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1030 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870
JH
1031
1032 if (details) {
92e45a3e
NC
1033 /* Indents of 5? Yuck. */
1034 /* We know that PerlIO_get_layers creates a new SV for
1035 the name and flags, so we can just take a reference
1036 and "steal" it when we free the AV below. */
ec3bab8e 1037 XPUSHs(namok
92e45a3e 1038 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e
NC
1039 : &PL_sv_undef);
1040 XPUSHs(argok
92e45a3e
NC
1041 ? newSVpvn_flags(SvPVX_const(*argsvp),
1042 SvCUR(*argsvp),
1043 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1044 | SVs_TEMP)
1045 : &PL_sv_undef);
96ccaf53 1046 XPUSHs(flgok
92e45a3e 1047 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 1048 : &PL_sv_undef);
39f7a870
JH
1049 nitem += 3;
1050 }
1051 else {
1052 if (namok && argok)
1eb9e81d 1053 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 1054 SVfARG(*namsvp),
1eb9e81d 1055 SVfARG(*argsvp))));
39f7a870 1056 else if (namok)
92e45a3e 1057 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870
JH
1058 else
1059 XPUSHs(&PL_sv_undef);
1060 nitem++;
1061 if (flgok) {
c4420975 1062 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
1063
1064 if (flags & PERLIO_F_UTF8) {
84bafc02 1065 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
1066 nitem++;
1067 }
1068 }
1069 }
1070 }
1071
1072 SvREFCNT_dec(av);
1073
1074 XSRETURN(nitem);
1075 }
1076 }
5fef3b4a 1077#endif
39f7a870
JH
1078
1079 XSRETURN(0);
1080}
1081
9a7034eb 1082XS(XS_Internals_hash_seed)
c910b28a 1083{
97aff369 1084 dVAR;
c85d3f85
NC
1085 /* Using dXSARGS would also have dITEM and dSP,
1086 * which define 2 unused local variables. */
557b887a 1087 dAXMARK;
53c1dcc0 1088 PERL_UNUSED_ARG(cv);
ad73156c 1089 PERL_UNUSED_VAR(mark);
81eaca17 1090 XSRETURN_UV(PERL_HASH_SEED);
c910b28a
JH
1091}
1092
008fb0c0 1093XS(XS_Internals_rehash_seed)
8e90d776 1094{
97aff369 1095 dVAR;
8e90d776
NC
1096 /* Using dXSARGS would also have dITEM and dSP,
1097 * which define 2 unused local variables. */
557b887a 1098 dAXMARK;
53c1dcc0 1099 PERL_UNUSED_ARG(cv);
ad73156c 1100 PERL_UNUSED_VAR(mark);
008fb0c0 1101 XSRETURN_UV(PL_rehash_seed);
8e90d776
NC
1102}
1103
05619474
NC
1104XS(XS_Internals_HvREHASH) /* Subject to change */
1105{
97aff369 1106 dVAR;
05619474 1107 dXSARGS;
93c51217 1108 PERL_UNUSED_ARG(cv);
05619474 1109 if (SvROK(ST(0))) {
ef8f7699 1110 const HV * const hv = (const HV *) SvRV(ST(0));
05619474
NC
1111 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1112 if (HvREHASH(hv))
1113 XSRETURN_YES;
1114 else
1115 XSRETURN_NO;
1116 }
1117 }
1118 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1119}
241d1a3b 1120
80305961
YO
1121XS(XS_re_is_regexp)
1122{
1123 dVAR;
1124 dXSARGS;
f7e71195
AB
1125 PERL_UNUSED_VAR(cv);
1126
80305961 1127 if (items != 1)
afa74d42 1128 croak_xs_usage(cv, "sv");
f7e71195 1129
f7e71195
AB
1130 if (SvRXOK(ST(0))) {
1131 XSRETURN_YES;
1132 } else {
1133 XSRETURN_NO;
80305961
YO
1134 }
1135}
1136
192b9cd1 1137XS(XS_re_regnames_count)
80305961 1138{
192b9cd1
AB
1139 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1140 SV * ret;
80305961
YO
1141 dVAR;
1142 dXSARGS;
192b9cd1
AB
1143
1144 if (items != 0)
afa74d42 1145 croak_xs_usage(cv, "");
192b9cd1
AB
1146
1147 SP -= items;
fdae9473 1148 PUTBACK;
192b9cd1
AB
1149
1150 if (!rx)
1151 XSRETURN_UNDEF;
1152
1153 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1154
1155 SPAGAIN;
fdae9473
NC
1156 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1157 XSRETURN(1);
192b9cd1
AB
1158}
1159
1160XS(XS_re_regname)
1161{
1162 dVAR;
1163 dXSARGS;
1164 REGEXP * rx;
1165 U32 flags;
1166 SV * ret;
1167
28d8d7f4 1168 if (items < 1 || items > 2)
afa74d42 1169 croak_xs_usage(cv, "name[, all ]");
192b9cd1 1170
80305961 1171 SP -= items;
fdae9473 1172 PUTBACK;
80305961 1173
192b9cd1
AB
1174 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1175
1176 if (!rx)
1177 XSRETURN_UNDEF;
1178
1179 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 1180 flags = RXapif_ALL;
192b9cd1 1181 } else {
f1b875a0 1182 flags = RXapif_ONE;
80305961 1183 }
f1b875a0 1184 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1 1185
fdae9473
NC
1186 SPAGAIN;
1187 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
1188 XSRETURN(1);
80305961
YO
1189}
1190
192b9cd1 1191
80305961
YO
1192XS(XS_re_regnames)
1193{
192b9cd1 1194 dVAR;
80305961 1195 dXSARGS;
192b9cd1
AB
1196 REGEXP * rx;
1197 U32 flags;
1198 SV *ret;
1199 AV *av;
1200 I32 length;
1201 I32 i;
1202 SV **entry;
1203
1204 if (items > 1)
afa74d42 1205 croak_xs_usage(cv, "[all]");
192b9cd1
AB
1206
1207 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1208
1209 if (!rx)
1210 XSRETURN_UNDEF;
1211
1212 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 1213 flags = RXapif_ALL;
192b9cd1 1214 } else {
f1b875a0 1215 flags = RXapif_ONE;
192b9cd1
AB
1216 }
1217
80305961 1218 SP -= items;
fdae9473 1219 PUTBACK;
80305961 1220
f1b875a0 1221 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
1222
1223 SPAGAIN;
1224
192b9cd1
AB
1225 if (!ret)
1226 XSRETURN_UNDEF;
1227
502c6561 1228 av = MUTABLE_AV(SvRV(ret));
192b9cd1
AB
1229 length = av_len(av);
1230
1231 for (i = 0; i <= length; i++) {
1232 entry = av_fetch(av, i, FALSE);
1233
1234 if (!entry)
1235 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1236
ec83ea38 1237 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 1238 }
ec83ea38
MHM
1239
1240 SvREFCNT_dec(ret);
1241
192b9cd1
AB
1242 PUTBACK;
1243 return;
80305961
YO
1244}
1245
192c1e27
JH
1246XS(XS_re_regexp_pattern)
1247{
1248 dVAR;
1249 dXSARGS;
1250 REGEXP *re;
192c1e27
JH
1251
1252 if (items != 1)
afa74d42 1253 croak_xs_usage(cv, "sv");
192c1e27
JH
1254
1255 SP -= items;
1256
1257 /*
1258 Checks if a reference is a regex or not. If the parameter is
1259 not a ref, or is not the result of a qr// then returns false
1260 in scalar context and an empty list in list context.
1261 Otherwise in list context it returns the pattern and the
1262 modifiers, in scalar context it returns the pattern just as it
1263 would if the qr// was stringified normally, regardless as
486ec47a 1264 to the class of the variable and any stringification overloads
192c1e27
JH
1265 on the object.
1266 */
1267
1268 if ((re = SvRX(ST(0)))) /* assign deliberate */
1269 {
22c985d5 1270 /* Houston, we have a regex! */
192c1e27 1271 SV *pattern;
192c1e27
JH
1272
1273 if ( GIMME_V == G_ARRAY ) {
9de15fec 1274 STRLEN left = 0;
a62b1201 1275 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
69af1167
SH
1276 const char *fptr;
1277 char ch;
1278 U16 match_flags;
1279
192c1e27
JH
1280 /*
1281 we are in list context so stringify
1282 the modifiers that apply. We ignore "negative
a62b1201 1283 modifiers" in this scenario, and the default character set
192c1e27
JH
1284 */
1285
a62b1201
KW
1286 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1287 STRLEN len;
1288 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1289 &len);
1290 Copy(name, reflags + left, len, char);
1291 left += len;
9de15fec 1292 }
69af1167 1293 fptr = INT_PAT_MODS;
73134a2e 1294 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
192c1e27
JH
1295 >> RXf_PMf_STD_PMMOD_SHIFT);
1296
1297 while((ch = *fptr++)) {
1298 if(match_flags & 1) {
1299 reflags[left++] = ch;
1300 }
1301 match_flags >>= 1;
1302 }
1303
fb632ce3
NC
1304 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1305 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1306
1307 /* return the pattern and the modifiers */
1308 XPUSHs(pattern);
fb632ce3 1309 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
1310 XSRETURN(2);
1311 } else {
1312 /* Scalar, so use the string that Perl would return */
1313 /* return the pattern in (?msix:..) format */
1314#if PERL_VERSION >= 11
daba3364 1315 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 1316#else
fb632ce3
NC
1317 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1318 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1319#endif
1320 XPUSHs(pattern);
1321 XSRETURN(1);
1322 }
1323 } else {
1324 /* It ain't a regexp folks */
1325 if ( GIMME_V == G_ARRAY ) {
1326 /* return the empty list */
1327 XSRETURN_UNDEF;
1328 } else {
1329 /* Because of the (?:..) wrapping involved in a
1330 stringified pattern it is impossible to get a
1331 result for a real regexp that would evaluate to
1332 false. Therefore we can return PL_sv_no to signify
1333 that the object is not a regex, this means that one
1334 can say
1335
1336 if (regex($might_be_a_regex) eq '(?:foo)') { }
1337
1338 and not worry about undefined values.
1339 */
1340 XSRETURN_NO;
1341 }
1342 }
1343 /* NOT-REACHED */
1344}
1345
eff5b9d5
NC
1346struct xsub_details {
1347 const char *name;
1348 XSUBADDR_t xsub;
1349 const char *proto;
1350};
1351
1352struct xsub_details details[] = {
1353 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1354 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1355 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1356 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1357 {"version::()", XS_version_noop, NULL},
1358 {"version::new", XS_version_new, NULL},
1359 {"version::parse", XS_version_new, NULL},
1360 {"version::(\"\"", XS_version_stringify, NULL},
1361 {"version::stringify", XS_version_stringify, NULL},
1362 {"version::(0+", XS_version_numify, NULL},
1363 {"version::numify", XS_version_numify, NULL},
1364 {"version::normal", XS_version_normal, NULL},
1365 {"version::(cmp", XS_version_vcmp, NULL},
1366 {"version::(<=>", XS_version_vcmp, NULL},
1367 {"version::vcmp", XS_version_vcmp, NULL},
1368 {"version::(bool", XS_version_boolean, NULL},
1369 {"version::boolean", XS_version_boolean, NULL},
43d9ecf9
JP
1370 {"version::(+", XS_version_noop, NULL},
1371 {"version::(-", XS_version_noop, NULL},
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::(abs", XS_version_noop, NULL},
eff5b9d5
NC
1379 {"version::(nomethod", XS_version_noop, NULL},
1380 {"version::noop", XS_version_noop, NULL},
1381 {"version::is_alpha", XS_version_is_alpha, NULL},
1382 {"version::qv", XS_version_qv, NULL},
1383 {"version::declare", XS_version_qv, NULL},
1384 {"version::is_qv", XS_version_is_qv, NULL},
1385 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1386 {"utf8::valid", XS_utf8_valid, NULL},
1387 {"utf8::encode", XS_utf8_encode, NULL},
1388 {"utf8::decode", XS_utf8_decode, NULL},
1389 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1390 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1391 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1392 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1393 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1394 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1395 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1396 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1397 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1398 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1399 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1400 {"re::is_regexp", XS_re_is_regexp, "$"},
1401 {"re::regname", XS_re_regname, ";$$"},
1402 {"re::regnames", XS_re_regnames, ";$"},
1403 {"re::regnames_count", XS_re_regnames_count, ""},
1404 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
eff5b9d5
NC
1405};
1406
1407void
1408Perl_boot_core_UNIVERSAL(pTHX)
1409{
1410 dVAR;
1411 static const char file[] = __FILE__;
1412 struct xsub_details *xsub = details;
1413 const struct xsub_details *end
1414 = details + sizeof(details) / sizeof(details[0]);
1415
1416 do {
1417 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1418 } while (++xsub < end);
1419
1420 /* register the overloading (type 'A') magic */
1421 PL_amagic_generation++;
1422
1423 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
bad4ae38
FC
1424 {
1425 CV * const cv =
1426 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1427 Safefree(CvFILE(cv));
1428 CvFILE(cv) = (char *)file;
1429 CvDYNFILE_off(cv);
1430 }
eff5b9d5 1431}
80305961 1432
241d1a3b
NC
1433/*
1434 * Local variables:
1435 * c-indentation-style: bsd
1436 * c-basic-offset: 4
1437 * indent-tabs-mode: t
1438 * End:
1439 *
37442d52
RGS
1440 * ex: set ts=8 sts=4 sw=4 noet:
1441 */