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