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