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