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