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