This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use HEKf
[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 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;
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) {
d0c0e7dd 440 const HEK * const name = HvNAME_HEK(pkg);
a3b680e6 441 Perl_croak(aTHX_
d0c0e7dd
FC
442 "%"HEKf" does not define $%"HEKf
443 "::VERSION--version check failed",
444 HEKfARG(name), HEKfARG(name));
bfcb3514 445 } else {
a3b680e6 446 Perl_croak(aTHX_
ed1db70e
BF
447 "%"SVf" defines neither package nor VERSION--version check failed",
448 SVfARG(ST(0)) );
62658f4d
PM
449 }
450 }
ad63d80f 451
9bf41c1d
FC
452 if ( !sv_derived_from(sv, "version"))
453 upg_version(sv, FALSE);
454
137d6fc0
JP
455 if ( !sv_derived_from(req, "version")) {
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
9bf41c1d 478 ST(0) = ret;
6d4a7be2
PP
479
480 XSRETURN(1);
481}
482
439cb1c4
JP
483XS(XS_version_new)
484{
97aff369 485 dVAR;
439cb1c4 486 dXSARGS;
129318bd 487 if (items > 3)
afa74d42 488 croak_xs_usage(cv, "class, version");
439cb1c4
JP
489 SP -= items;
490 {
137d6fc0
JP
491 SV *vs = ST(1);
492 SV *rv;
ed1db70e
BF
493 STRLEN len;
494 const char *classname;
495 U32 flags;
496 if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
497 const HV * stash = SvSTASH(SvRV(ST(0)));
498 classname = HvNAME(stash);
499 len = HvNAMELEN(stash);
500 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
501 }
502 else {
503 classname = SvPV(ST(0), len);
504 flags = SvUTF8(ST(0));
505 }
9137345a 506
91152fc1 507 if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
92dcf8ce
JP
508 /* create empty object */
509 vs = sv_newmortal();
be5574c0 510 sv_setpvs(vs, "0");
9137345a
JP
511 }
512 else if ( items == 3 ) {
513 vs = sv_newmortal();
cfd0369c 514 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
129318bd 515 }
439cb1c4 516
137d6fc0 517 rv = new_version(vs);
ed1db70e
BF
518 if ( strnNE(classname,"version", len) ) /* inherited new() */
519 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
137d6fc0 520
6e449a3a 521 mPUSHs(rv);
439cb1c4
JP
522 PUTBACK;
523 return;
524 }
525}
526
527XS(XS_version_stringify)
528{
97aff369 529 dVAR;
41be1fbd
JH
530 dXSARGS;
531 if (items < 1)
afa74d42 532 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
533 SP -= items;
534 {
d808b681 535 SV * lobj = ST(0);
41be1fbd 536
d808b681
JP
537 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
538 lobj = SvRV(lobj);
41be1fbd
JH
539 }
540 else
541 Perl_croak(aTHX_ "lobj is not of type version");
542
6e449a3a 543 mPUSHs(vstringify(lobj));
41be1fbd
JH
544
545 PUTBACK;
546 return;
547 }
439cb1c4
JP
548}
549
550XS(XS_version_numify)
551{
97aff369 552 dVAR;
41be1fbd
JH
553 dXSARGS;
554 if (items < 1)
afa74d42 555 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
556 SP -= items;
557 {
d808b681 558 SV * lobj = ST(0);
41be1fbd 559
d808b681
JP
560 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
561 lobj = SvRV(lobj);
41be1fbd
JH
562 }
563 else
564 Perl_croak(aTHX_ "lobj is not of type version");
565
6e449a3a 566 mPUSHs(vnumify(lobj));
41be1fbd
JH
567
568 PUTBACK;
569 return;
570 }
439cb1c4
JP
571}
572
9137345a
JP
573XS(XS_version_normal)
574{
97aff369 575 dVAR;
9137345a
JP
576 dXSARGS;
577 if (items < 1)
afa74d42 578 croak_xs_usage(cv, "lobj, ...");
9137345a
JP
579 SP -= items;
580 {
d808b681 581 SV * lobj = ST(0);
9137345a 582
d808b681
JP
583 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
584 lobj = SvRV(lobj);
9137345a
JP
585 }
586 else
587 Perl_croak(aTHX_ "lobj is not of type version");
588
6e449a3a 589 mPUSHs(vnormal(lobj));
9137345a
JP
590
591 PUTBACK;
592 return;
593 }
594}
595
439cb1c4
JP
596XS(XS_version_vcmp)
597{
97aff369 598 dVAR;
41be1fbd
JH
599 dXSARGS;
600 if (items < 1)
afa74d42 601 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
602 SP -= items;
603 {
d808b681 604 SV * lobj = ST(0);
41be1fbd 605
d808b681
JP
606 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
607 lobj = SvRV(lobj);
41be1fbd
JH
608 }
609 else
610 Perl_croak(aTHX_ "lobj is not of type version");
611
612 {
613 SV *rs;
614 SV *rvs;
615 SV * robj = ST(1);
7452cf6a 616 const IV swap = (IV)SvIV(ST(2));
41be1fbd
JH
617
618 if ( ! sv_derived_from(robj, "version") )
619 {
e3a22e3f 620 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
621 sv_2mortal(robj);
41be1fbd
JH
622 }
623 rvs = SvRV(robj);
624
625 if ( swap )
626 {
627 rs = newSViv(vcmp(rvs,lobj));
628 }
629 else
630 {
631 rs = newSViv(vcmp(lobj,rvs));
632 }
633
6e449a3a 634 mPUSHs(rs);
41be1fbd
JH
635 }
636
637 PUTBACK;
638 return;
639 }
439cb1c4
JP
640}
641
642XS(XS_version_boolean)
643{
97aff369
JH
644 dVAR;
645 dXSARGS;
646 if (items < 1)
afa74d42 647 croak_xs_usage(cv, "lobj, ...");
97aff369 648 SP -= items;
d808b681 649 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
c4420975 650 SV * const lobj = SvRV(ST(0));
396482e1 651 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
6e449a3a 652 mPUSHs(rs);
c4420975
AL
653 PUTBACK;
654 return;
655 }
656 else
657 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
658}
659
660XS(XS_version_noop)
661{
97aff369 662 dVAR;
2dfd8427
AL
663 dXSARGS;
664 if (items < 1)
afa74d42 665 croak_xs_usage(cv, "lobj, ...");
d808b681 666 if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
2dfd8427
AL
667 Perl_croak(aTHX_ "operation not supported with version object");
668 else
669 Perl_croak(aTHX_ "lobj is not of type version");
670#ifndef HASATTRIBUTE_NORETURN
671 XSRETURN_EMPTY;
672#endif
439cb1c4
JP
673}
674
c8d69e4a
JP
675XS(XS_version_is_alpha)
676{
97aff369 677 dVAR;
c8d69e4a
JP
678 dXSARGS;
679 if (items != 1)
afa74d42 680 croak_xs_usage(cv, "lobj");
c8d69e4a 681 SP -= items;
d808b681 682 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
c4420975 683 SV * const lobj = ST(0);
ef8f7699 684 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
c4420975
AL
685 XSRETURN_YES;
686 else
687 XSRETURN_NO;
c8d69e4a
JP
688 PUTBACK;
689 return;
690 }
c4420975
AL
691 else
692 Perl_croak(aTHX_ "lobj is not of type version");
c8d69e4a
JP
693}
694
137d6fc0
JP
695XS(XS_version_qv)
696{
97aff369 697 dVAR;
137d6fc0 698 dXSARGS;
4ed3fda4 699 PERL_UNUSED_ARG(cv);
137d6fc0
JP
700 SP -= items;
701 {
f941e658
JP
702 SV * ver = ST(0);
703 SV * rv;
ed1db70e
BF
704 STRLEN len = 0;
705 const char * classname = "";
706 U32 flags = 0;
707 if ( items == 2 && SvOK(ST(1)) ) {
708 ver = ST(1);
709 if ( sv_isobject(ST(0)) ) { /* class called as an object method */
710 const HV * stash = SvSTASH(SvRV(ST(0)));
711 classname = HvNAME(stash);
712 len = HvNAMELEN(stash);
713 flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
714 }
715 else {
716 classname = SvPV(ST(0), len);
717 flags = SvUTF8(ST(0));
718 }
719 }
f941e658
JP
720 if ( !SvVOK(ver) ) { /* not already a v-string */
721 rv = sv_newmortal();
ac0e6a2f
RGS
722 sv_setsv(rv,ver); /* make a duplicate */
723 upg_version(rv, TRUE);
f941e658
JP
724 } else {
725 rv = sv_2mortal(new_version(ver));
137d6fc0 726 }
ed1db70e
BF
727 if ( items == 2
728 && strnNE(classname,"version", len) ) { /* inherited new() */
729 sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
730 }
f941e658
JP
731 PUSHs(rv);
732 }
733 PUTBACK;
734 return;
735}
137d6fc0 736
f941e658
JP
737XS(XS_version_is_qv)
738{
739 dVAR;
740 dXSARGS;
741 if (items != 1)
742 croak_xs_usage(cv, "lobj");
743 SP -= items;
d808b681 744 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
f941e658
JP
745 SV * const lobj = ST(0);
746 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
747 XSRETURN_YES;
748 else
749 XSRETURN_NO;
137d6fc0
JP
750 PUTBACK;
751 return;
752 }
f941e658
JP
753 else
754 Perl_croak(aTHX_ "lobj is not of type version");
137d6fc0
JP
755}
756
8800c35a
JH
757XS(XS_utf8_is_utf8)
758{
97aff369 759 dVAR;
41be1fbd
JH
760 dXSARGS;
761 if (items != 1)
afa74d42 762 croak_xs_usage(cv, "sv");
c4420975 763 else {
76f73021 764 SV * const sv = ST(0);
765 SvGETMAGIC(sv);
c4420975
AL
766 if (SvUTF8(sv))
767 XSRETURN_YES;
768 else
769 XSRETURN_NO;
41be1fbd
JH
770 }
771 XSRETURN_EMPTY;
8800c35a
JH
772}
773
1b026014
NIS
774XS(XS_utf8_valid)
775{
97aff369 776 dVAR;
41be1fbd
JH
777 dXSARGS;
778 if (items != 1)
afa74d42 779 croak_xs_usage(cv, "sv");
c4420975
AL
780 else {
781 SV * const sv = ST(0);
782 STRLEN len;
783 const char * const s = SvPV_const(sv,len);
784 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
785 XSRETURN_YES;
786 else
787 XSRETURN_NO;
788 }
41be1fbd 789 XSRETURN_EMPTY;
1b026014
NIS
790}
791
792XS(XS_utf8_encode)
793{
97aff369 794 dVAR;
1b026014
NIS
795 dXSARGS;
796 if (items != 1)
afa74d42 797 croak_xs_usage(cv, "sv");
c4420975 798 sv_utf8_encode(ST(0));
1b026014
NIS
799 XSRETURN_EMPTY;
800}
801
802XS(XS_utf8_decode)
803{
97aff369 804 dVAR;
1b026014
NIS
805 dXSARGS;
806 if (items != 1)
afa74d42 807 croak_xs_usage(cv, "sv");
c4420975
AL
808 else {
809 SV * const sv = ST(0);
b2b7346b
FC
810 bool RETVAL;
811 if (SvIsCOW(sv)) sv_force_normal(sv);
812 RETVAL = sv_utf8_decode(sv);
1b026014 813 ST(0) = boolSV(RETVAL);
1b026014
NIS
814 }
815 XSRETURN(1);
816}
817
818XS(XS_utf8_upgrade)
819{
97aff369 820 dVAR;
1b026014
NIS
821 dXSARGS;
822 if (items != 1)
afa74d42 823 croak_xs_usage(cv, "sv");
c4420975
AL
824 else {
825 SV * const sv = ST(0);
1b026014
NIS
826 STRLEN RETVAL;
827 dXSTARG;
828
829 RETVAL = sv_utf8_upgrade(sv);
830 XSprePUSH; PUSHi((IV)RETVAL);
831 }
832 XSRETURN(1);
833}
834
835XS(XS_utf8_downgrade)
836{
97aff369 837 dVAR;
1b026014
NIS
838 dXSARGS;
839 if (items < 1 || items > 2)
afa74d42 840 croak_xs_usage(cv, "sv, failok=0");
c4420975
AL
841 else {
842 SV * const sv = ST(0);
6867be6d
AL
843 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
844 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 845
1b026014 846 ST(0) = boolSV(RETVAL);
1b026014
NIS
847 }
848 XSRETURN(1);
849}
850
851XS(XS_utf8_native_to_unicode)
852{
97aff369 853 dVAR;
1b026014 854 dXSARGS;
6867be6d 855 const UV uv = SvUV(ST(0));
b7953727
JH
856
857 if (items > 1)
afa74d42 858 croak_xs_usage(cv, "sv");
b7953727 859
1b026014
NIS
860 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
861 XSRETURN(1);
862}
863
864XS(XS_utf8_unicode_to_native)
865{
97aff369 866 dVAR;
1b026014 867 dXSARGS;
6867be6d 868 const UV uv = SvUV(ST(0));
b7953727
JH
869
870 if (items > 1)
afa74d42 871 croak_xs_usage(cv, "sv");
b7953727 872
1b026014
NIS
873 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
874 XSRETURN(1);
875}
876
14a976d6 877XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577 878{
97aff369 879 dVAR;
29569577 880 dXSARGS;
80b6a949
AB
881 SV * const svz = ST(0);
882 SV * sv;
58c0efa5 883 PERL_UNUSED_ARG(cv);
6867be6d 884
80b6a949
AB
885 /* [perl #77776] - called as &foo() not foo() */
886 if (!SvROK(svz))
887 croak_xs_usage(cv, "SCALAR[, ON]");
888
889 sv = SvRV(svz);
890
29569577 891 if (items == 1) {
3e89ba19 892 if (SvREADONLY(sv) && !SvIsCOW(sv))
29569577
JH
893 XSRETURN_YES;
894 else
895 XSRETURN_NO;
896 }
897 else if (items == 2) {
898 if (SvTRUE(ST(1))) {
3e89ba19 899 if (SvIsCOW(sv)) sv_force_normal(sv);
29569577
JH
900 SvREADONLY_on(sv);
901 XSRETURN_YES;
902 }
903 else {
14a976d6 904 /* I hope you really know what you are doing. */
3e89ba19 905 if (!SvIsCOW(sv)) SvREADONLY_off(sv);
29569577
JH
906 XSRETURN_NO;
907 }
908 }
14a976d6 909 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
910}
911
14a976d6 912XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577 913{
97aff369 914 dVAR;
29569577 915 dXSARGS;
80b6a949
AB
916 SV * const svz = ST(0);
917 SV * sv;
58c0efa5 918 PERL_UNUSED_ARG(cv);
6867be6d 919
80b6a949
AB
920 /* [perl #77776] - called as &foo() not foo() */
921 if (!SvROK(svz))
922 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
923
924 sv = SvRV(svz);
925
29569577 926 if (items == 1)
14a976d6 927 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 928 else if (items == 2) {
14a976d6 929 /* I hope you really know what you are doing. */
29569577
JH
930 SvREFCNT(sv) = SvIV(ST(1));
931 XSRETURN_IV(SvREFCNT(sv));
932 }
14a976d6 933 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
934}
935
f044d0d1 936XS(XS_Internals_hv_clear_placehold)
dfd4ef2f 937{
97aff369 938 dVAR;
dfd4ef2f 939 dXSARGS;
6867be6d 940
80b6a949 941 if (items != 1 || !SvROK(ST(0)))
afa74d42 942 croak_xs_usage(cv, "hv");
c4420975 943 else {
ef8f7699 944 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
945 hv_clear_placeholders(hv);
946 XSRETURN(0);
947 }
dfd4ef2f 948}
39f7a870
JH
949
950XS(XS_PerlIO_get_layers)
951{
97aff369 952 dVAR;
39f7a870
JH
953 dXSARGS;
954 if (items < 1 || items % 2 == 0)
afa74d42 955 croak_xs_usage(cv, "filehandle[,args]");
5fef3b4a 956#ifdef USE_PERLIO
39f7a870
JH
957 {
958 SV * sv;
959 GV * gv;
960 IO * io;
961 bool input = TRUE;
962 bool details = FALSE;
963
964 if (items > 1) {
c4420975 965 SV * const *svp;
39f7a870 966 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
967 SV * const * const varp = svp;
968 SV * const * const valp = svp + 1;
39f7a870 969 STRLEN klen;
c4420975 970 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
971
972 switch (*key) {
973 case 'i':
974 if (klen == 5 && memEQ(key, "input", 5)) {
975 input = SvTRUE(*valp);
976 break;
977 }
978 goto fail;
979 case 'o':
980 if (klen == 6 && memEQ(key, "output", 6)) {
981 input = !SvTRUE(*valp);
982 break;
983 }
984 goto fail;
985 case 'd':
986 if (klen == 7 && memEQ(key, "details", 7)) {
987 details = SvTRUE(*valp);
988 break;
989 }
990 goto fail;
991 default:
992 fail:
993 Perl_croak(aTHX_
994 "get_layers: unknown argument '%s'",
995 key);
996 }
997 }
998
999 SP -= (items - 1);
1000 }
1001
1002 sv = POPs;
159b6efe 1003 gv = MUTABLE_GV(sv);
39f7a870
JH
1004
1005 if (!isGV(sv)) {
1006 if (SvROK(sv) && isGV(SvRV(sv)))
159b6efe 1007 gv = MUTABLE_GV(SvRV(sv));
671d49be 1008 else if (SvPOKp(sv))
f776e3cd 1009 gv = gv_fetchsv(sv, 0, SVt_PVIO);
39f7a870
JH
1010 }
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},
1366 {"version::(nomethod", XS_version_noop, NULL},
1367 {"version::noop", XS_version_noop, NULL},
1368 {"version::is_alpha", XS_version_is_alpha, NULL},
1369 {"version::qv", XS_version_qv, NULL},
1370 {"version::declare", XS_version_qv, NULL},
1371 {"version::is_qv", XS_version_is_qv, NULL},
1372 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1373 {"utf8::valid", XS_utf8_valid, NULL},
1374 {"utf8::encode", XS_utf8_encode, NULL},
1375 {"utf8::decode", XS_utf8_decode, NULL},
1376 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1377 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1378 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1379 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1380 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1381 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1382 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1383 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1384 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1385 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1386 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1387 {"re::is_regexp", XS_re_is_regexp, "$"},
1388 {"re::regname", XS_re_regname, ";$$"},
1389 {"re::regnames", XS_re_regnames, ";$"},
1390 {"re::regnames_count", XS_re_regnames_count, ""},
1391 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
eff5b9d5
NC
1392};
1393
1394void
1395Perl_boot_core_UNIVERSAL(pTHX)
1396{
1397 dVAR;
1398 static const char file[] = __FILE__;
1399 struct xsub_details *xsub = details;
1400 const struct xsub_details *end
1401 = details + sizeof(details) / sizeof(details[0]);
1402
1403 do {
1404 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1405 } while (++xsub < end);
1406
1407 /* register the overloading (type 'A') magic */
1408 PL_amagic_generation++;
1409
1410 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
bad4ae38
FC
1411 {
1412 CV * const cv =
1413 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1414 Safefree(CvFILE(cv));
1415 CvFILE(cv) = (char *)file;
1416 CvDYNFILE_off(cv);
1417 }
eff5b9d5 1418}
80305961 1419
241d1a3b
NC
1420/*
1421 * Local variables:
1422 * c-indentation-style: bsd
1423 * c-basic-offset: 4
1424 * indent-tabs-mode: t
1425 * End:
1426 *
37442d52
RGS
1427 * ex: set ts=8 sts=4 sw=4 noet:
1428 */