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