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