This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
s///e on tainted utf8 strings got pos() messed up
[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
97cb92d6 32#if defined(USE_PERLIO)
39f7a870
JH
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{
a49ba3fc 44 const struct mro_meta *const meta = HvMROMETA(stash);
4340b386 45 HV *isa = meta->isa;
a49ba3fc 46 const HV *our_stash;
6d4a7be2 47
7918f24d
NC
48 PERL_ARGS_ASSERT_ISA_LOOKUP;
49
4340b386
FC
50 if (!isa) {
51 (void)mro_get_linear_isa(stash);
52 isa = meta->isa;
53 }
54
c7abbf64 55 if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
a49ba3fc
NC
56 HV_FETCH_ISEXISTS, NULL, 0)) {
57 /* Direct name lookup worked. */
a9ec700e 58 return TRUE;
a49ba3fc 59 }
6d4a7be2 60
a49ba3fc 61 /* A stash/class can go by many names (ie. User == main::User), so
81a5123c
FC
62 we use the HvENAME in the stash itself, which is canonical, falling
63 back to HvNAME if necessary. */
c7abbf64 64 our_stash = gv_stashpvn(name, len, flags);
a49ba3fc
NC
65
66 if (our_stash) {
81a5123c
FC
67 HEK *canon_name = HvENAME_HEK(our_stash);
68 if (!canon_name) canon_name = HvNAME_HEK(our_stash);
316ebaf2 69 assert(canon_name);
a49ba3fc
NC
70 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
71 HEK_FLAGS(canon_name),
72 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
e1a479c5 73 return TRUE;
a49ba3fc 74 }
6d4a7be2
PP
75 }
76
a9ec700e 77 return FALSE;
6d4a7be2
PP
78}
79
954c1994 80/*
ccfc67b7
JH
81=head1 SV Manipulation Functions
82
c7abbf64 83=for apidoc sv_derived_from_pvn
954c1994 84
6885da0e 85Returns a boolean indicating whether the SV is derived from the specified class
86I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
87normal Perl method.
954c1994 88
c7abbf64
BF
89Currently, the only significant value for C<flags> is SVf_UTF8.
90
91=cut
92
93=for apidoc sv_derived_from_sv
94
95Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
96of an SV instead of a string/length pair.
97
98=cut
99
100*/
101
102bool
103Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
104{
105 char *namepv;
106 STRLEN namelen;
107 PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
108 namepv = SvPV(namesv, namelen);
109 if (SvUTF8(namesv))
110 flags |= SVf_UTF8;
111 return sv_derived_from_pvn(sv, namepv, namelen, flags);
112}
113
114/*
115=for apidoc sv_derived_from
116
117Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
118
954c1994
GS
119=cut
120*/
121
55497cff 122bool
15f169a1 123Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
55497cff 124{
c7abbf64
BF
125 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
126 return sv_derived_from_pvn(sv, name, strlen(name), 0);
127}
128
129/*
130=for apidoc sv_derived_from_pv
131
132Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string
133instead of a string/length pair.
134
135=cut
136*/
137
138
139bool
140Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
141{
142 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
143 return sv_derived_from_pvn(sv, name, strlen(name), flags);
144}
145
146bool
147Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
148{
0b6f4f5c 149 HV *stash;
46e4b22b 150
c7abbf64 151 PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
7918f24d 152
5b295bef 153 SvGETMAGIC(sv);
55497cff 154
bff39573 155 if (SvROK(sv)) {
0b6f4f5c 156 const char *type;
55497cff
PP
157 sv = SvRV(sv);
158 type = sv_reftype(sv,0);
0b6f4f5c
AL
159 if (type && strEQ(type,name))
160 return TRUE;
d70bfb04
JL
161 if (!SvOBJECT(sv))
162 return FALSE;
163 stash = SvSTASH(sv);
55497cff
PP
164 }
165 else {
da51bb9b 166 stash = gv_stashsv(sv, 0);
55497cff 167 }
46e4b22b 168
d70bfb04
JL
169 if (stash && isa_lookup(stash, name, len, flags))
170 return TRUE;
171
172 stash = gv_stashpvs("UNIVERSAL", 0);
173 return stash && isa_lookup(stash, name, len, flags);
55497cff
PP
174}
175
cbc021f9 176/*
d20c2c29 177=for apidoc sv_does_sv
cbc021f9 178
179Returns a boolean indicating whether the SV performs a specific, named role.
180The SV can be a Perl object or the name of a Perl class.
181
182=cut
183*/
184
1b026014
NIS
185#include "XSUB.h"
186
cbc021f9 187bool
f778bcfd 188Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
cbc021f9 189{
f778bcfd 190 SV *classname;
cbc021f9 191 bool does_it;
59e7186f 192 SV *methodname;
cbc021f9 193 dSP;
7918f24d 194
f778bcfd
BF
195 PERL_ARGS_ASSERT_SV_DOES_SV;
196 PERL_UNUSED_ARG(flags);
7918f24d 197
cbc021f9 198 ENTER;
199 SAVETMPS;
200
201 SvGETMAGIC(sv);
202
d96ab1b5 203 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
7ce46f2a 204 LEAVE;
cbc021f9 205 return FALSE;
7ce46f2a 206 }
cbc021f9 207
208 if (sv_isobject(sv)) {
f778bcfd 209 classname = sv_ref(NULL,SvRV(sv),TRUE);
cbc021f9 210 } else {
f778bcfd 211 classname = sv;
cbc021f9 212 }
213
f778bcfd 214 if (sv_eq(classname, namesv)) {
7ce46f2a 215 LEAVE;
cbc021f9 216 return TRUE;
7ce46f2a 217 }
cbc021f9 218
219 PUSHMARK(SP);
f778bcfd
BF
220 EXTEND(SP, 2);
221 PUSHs(sv);
222 PUSHs(namesv);
cbc021f9 223 PUTBACK;
224
84bafc02 225 methodname = newSVpvs_flags("isa", SVs_TEMP);
59e7186f
RGS
226 /* ugly hack: use the SvSCREAM flag so S_method_common
227 * can figure out we're calling DOES() and not isa(),
228 * and report eventual errors correctly. --rgs */
229 SvSCREAM_on(methodname);
230 call_sv(methodname, G_SCALAR | G_METHOD);
cbc021f9 231 SPAGAIN;
232
233 does_it = SvTRUE( TOPs );
234 FREETMPS;
235 LEAVE;
236
237 return does_it;
238}
239
afa74d42 240/*
f778bcfd
BF
241=for apidoc sv_does
242
d20c2c29 243Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
f778bcfd
BF
244
245=cut
246*/
247
248bool
249Perl_sv_does(pTHX_ SV *sv, const char *const name)
250{
251 PERL_ARGS_ASSERT_SV_DOES;
252 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
253}
254
255/*
256=for apidoc sv_does_pv
257
7d892b8c 258Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
f778bcfd
BF
259
260=cut
261*/
262
263
264bool
265Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
266{
267 PERL_ARGS_ASSERT_SV_DOES_PV;
268 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
269}
270
7d892b8c
FC
271/*
272=for apidoc sv_does_pvn
273
274Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
275
276=cut
277*/
278
f778bcfd
BF
279bool
280Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
281{
282 PERL_ARGS_ASSERT_SV_DOES_PVN;
283
284 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
285}
286
287/*
afa74d42
NC
288=for apidoc croak_xs_usage
289
290A specialised variant of C<croak()> for emitting the usage message for xsubs
291
292 croak_xs_usage(cv, "eee_yow");
293
294works out the package name and subroutine name from C<cv>, and then calls
72d33970 295C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
afa74d42 296
58cb15b3 297 Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
afa74d42
NC
298
299=cut
300*/
301
302void
cb077ed2 303Perl_croak_xs_usage(const CV *const cv, const char *const params)
afa74d42
NC
304{
305 const GV *const gv = CvGV(cv);
306
307 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
308
309 if (gv) {
afa74d42 310 const HV *const stash = GvSTASH(gv);
afa74d42 311
58cb15b3 312 if (HvNAME_get(stash))
d3ee9aa5 313 /* diag_listed_as: SKIPME */
cb077ed2 314 Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)",
d0c0e7dd
FC
315 HEKfARG(HvNAME_HEK(stash)),
316 HEKfARG(GvNAME_HEK(gv)),
58cb15b3 317 params);
afa74d42 318 else
d3ee9aa5 319 /* diag_listed_as: SKIPME */
cb077ed2 320 Perl_croak_nocontext("Usage: %"HEKf"(%s)",
d0c0e7dd 321 HEKfARG(GvNAME_HEK(gv)), params);
afa74d42
NC
322 } else {
323 /* Pants. I don't think that it should be possible to get here. */
d3ee9aa5 324 /* diag_listed_as: SKIPME */
cb077ed2 325 Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
afa74d42
NC
326 }
327}
55497cff 328
15eb3045 329XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
6d4a7be2
PP
330XS(XS_UNIVERSAL_isa)
331{
332 dXSARGS;
6d4a7be2
PP
333
334 if (items != 2)
afa74d42 335 croak_xs_usage(cv, "reference, kind");
c4420975
AL
336 else {
337 SV * const sv = ST(0);
6d4a7be2 338
c4420975 339 SvGETMAGIC(sv);
d3f7f2b2 340
d96ab1b5 341 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
c4420975 342 XSRETURN_UNDEF;
f8f70380 343
c7abbf64 344 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
c4420975
AL
345 XSRETURN(1);
346 }
6d4a7be2
PP
347}
348
15eb3045 349XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
6d4a7be2
PP
350XS(XS_UNIVERSAL_can)
351{
352 dXSARGS;
353 SV *sv;
6d4a7be2 354 SV *rv;
6f08146e 355 HV *pkg = NULL;
2bde9ae6 356 GV *iogv;
6d4a7be2
PP
357
358 if (items != 2)
afa74d42 359 croak_xs_usage(cv, "object-ref, method");
6d4a7be2
PP
360
361 sv = ST(0);
f8f70380 362
5b295bef 363 SvGETMAGIC(sv);
d3f7f2b2 364
4178f891
FC
365 /* Reject undef and empty string. Note that the string form takes
366 precedence here over the numeric form, as (!1)->foo treats the
367 invocant as the empty string, though it is a dualvar. */
368 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
f8f70380
GS
369 XSRETURN_UNDEF;
370
3280af22 371 rv = &PL_sv_undef;
6d4a7be2 372
46e4b22b 373 if (SvROK(sv)) {
daba3364 374 sv = MUTABLE_SV(SvRV(sv));
46e4b22b 375 if (SvOBJECT(sv))
6f08146e 376 pkg = SvSTASH(sv);
4178f891
FC
377 else if (isGV_with_GP(sv) && GvIO(sv))
378 pkg = SvSTASH(GvIO(sv));
6f08146e 379 }
4178f891
FC
380 else if (isGV_with_GP(sv) && GvIO(sv))
381 pkg = SvSTASH(GvIO(sv));
2bde9ae6
FC
382 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
383 pkg = SvSTASH(GvIO(iogv));
6f08146e 384 else {
da51bb9b 385 pkg = gv_stashsv(sv, 0);
68b40612
JL
386 if (!pkg)
387 pkg = gv_stashpv("UNIVERSAL", 0);
6f08146e
NIS
388 }
389
390 if (pkg) {
a00b390b 391 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
dc848c6f 392 if (gv && isGV(gv))
daba3364 393 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
6d4a7be2
PP
394 }
395
396 ST(0) = rv;
397 XSRETURN(1);
398}
399
15eb3045 400XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
cbc021f9 401XS(XS_UNIVERSAL_DOES)
402{
cbc021f9 403 dXSARGS;
58c0efa5 404 PERL_UNUSED_ARG(cv);
cbc021f9 405
406 if (items != 2)
46404226 407 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
cbc021f9 408 else {
409 SV * const sv = ST(0);
f778bcfd 410 if (sv_does_sv( sv, ST(1), 0 ))
cbc021f9 411 XSRETURN_YES;
412
413 XSRETURN_NO;
414 }
415}
416
15eb3045 417XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
8800c35a
JH
418XS(XS_utf8_is_utf8)
419{
41be1fbd
JH
420 dXSARGS;
421 if (items != 1)
afa74d42 422 croak_xs_usage(cv, "sv");
c4420975 423 else {
76f73021 424 SV * const sv = ST(0);
425 SvGETMAGIC(sv);
c4420975
AL
426 if (SvUTF8(sv))
427 XSRETURN_YES;
428 else
429 XSRETURN_NO;
41be1fbd
JH
430 }
431 XSRETURN_EMPTY;
8800c35a
JH
432}
433
15eb3045 434XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
435XS(XS_utf8_valid)
436{
41be1fbd
JH
437 dXSARGS;
438 if (items != 1)
afa74d42 439 croak_xs_usage(cv, "sv");
c4420975
AL
440 else {
441 SV * const sv = ST(0);
442 STRLEN len;
443 const char * const s = SvPV_const(sv,len);
444 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
445 XSRETURN_YES;
446 else
447 XSRETURN_NO;
448 }
41be1fbd 449 XSRETURN_EMPTY;
1b026014
NIS
450}
451
15eb3045 452XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
453XS(XS_utf8_encode)
454{
455 dXSARGS;
456 if (items != 1)
afa74d42 457 croak_xs_usage(cv, "sv");
c4420975 458 sv_utf8_encode(ST(0));
892f9127 459 SvSETMAGIC(ST(0));
1b026014
NIS
460 XSRETURN_EMPTY;
461}
462
15eb3045 463XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
464XS(XS_utf8_decode)
465{
466 dXSARGS;
467 if (items != 1)
afa74d42 468 croak_xs_usage(cv, "sv");
c4420975
AL
469 else {
470 SV * const sv = ST(0);
b2b7346b 471 bool RETVAL;
c7102404 472 SvPV_force_nolen(sv);
b2b7346b 473 RETVAL = sv_utf8_decode(sv);
77fc86ef 474 SvSETMAGIC(sv);
1b026014 475 ST(0) = boolSV(RETVAL);
1b026014
NIS
476 }
477 XSRETURN(1);
478}
479
15eb3045 480XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
481XS(XS_utf8_upgrade)
482{
483 dXSARGS;
484 if (items != 1)
afa74d42 485 croak_xs_usage(cv, "sv");
c4420975
AL
486 else {
487 SV * const sv = ST(0);
1b026014
NIS
488 STRLEN RETVAL;
489 dXSTARG;
490
491 RETVAL = sv_utf8_upgrade(sv);
492 XSprePUSH; PUSHi((IV)RETVAL);
493 }
494 XSRETURN(1);
495}
496
15eb3045 497XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
498XS(XS_utf8_downgrade)
499{
500 dXSARGS;
501 if (items < 1 || items > 2)
afa74d42 502 croak_xs_usage(cv, "sv, failok=0");
c4420975
AL
503 else {
504 SV * const sv = ST(0);
3ca75eca 505 const bool failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0;
6867be6d 506 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 507
1b026014 508 ST(0) = boolSV(RETVAL);
1b026014
NIS
509 }
510 XSRETURN(1);
511}
512
15eb3045 513XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
514XS(XS_utf8_native_to_unicode)
515{
516 dXSARGS;
6867be6d 517 const UV uv = SvUV(ST(0));
b7953727
JH
518
519 if (items > 1)
afa74d42 520 croak_xs_usage(cv, "sv");
b7953727 521
1b026014
NIS
522 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
523 XSRETURN(1);
524}
525
15eb3045 526XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
527XS(XS_utf8_unicode_to_native)
528{
529 dXSARGS;
6867be6d 530 const UV uv = SvUV(ST(0));
b7953727
JH
531
532 if (items > 1)
afa74d42 533 croak_xs_usage(cv, "sv");
b7953727 534
1b026014
NIS
535 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
536 XSRETURN(1);
537}
538
15eb3045 539XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
14a976d6 540XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH
541{
542 dXSARGS;
80b6a949
AB
543 SV * const svz = ST(0);
544 SV * sv;
58c0efa5 545 PERL_UNUSED_ARG(cv);
6867be6d 546
80b6a949
AB
547 /* [perl #77776] - called as &foo() not foo() */
548 if (!SvROK(svz))
549 croak_xs_usage(cv, "SCALAR[, ON]");
550
551 sv = SvRV(svz);
552
29569577 553 if (items == 1) {
1620522e 554 if (SvREADONLY(sv))
29569577
JH
555 XSRETURN_YES;
556 else
557 XSRETURN_NO;
558 }
559 else if (items == 2) {
560 if (SvTRUE(ST(1))) {
1620522e 561#ifdef PERL_OLD_COPY_ON_WRITE
3e89ba19 562 if (SvIsCOW(sv)) sv_force_normal(sv);
1620522e 563#endif
29569577
JH
564 SvREADONLY_on(sv);
565 XSRETURN_YES;
566 }
567 else {
14a976d6 568 /* I hope you really know what you are doing. */
1620522e 569 SvREADONLY_off(sv);
29569577
JH
570 XSRETURN_NO;
571 }
572 }
14a976d6 573 XSRETURN_UNDEF; /* Can't happen. */
29569577 574}
2c6c1df5 575
15eb3045 576XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
2c6c1df5
FC
577XS(XS_constant__make_const) /* This is dangerous stuff. */
578{
2c6c1df5
FC
579 dXSARGS;
580 SV * const svz = ST(0);
581 SV * sv;
582 PERL_UNUSED_ARG(cv);
583
584 /* [perl #77776] - called as &foo() not foo() */
585 if (!SvROK(svz) || items != 1)
586 croak_xs_usage(cv, "SCALAR");
587
588 sv = SvRV(svz);
589
590#ifdef PERL_OLD_COPY_ON_WRITE
591 if (SvIsCOW(sv)) sv_force_normal(sv);
592#endif
593 SvREADONLY_on(sv);
594 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
595 /* for constant.pm; nobody else should be calling this
596 on arrays anyway. */
597 SV **svp;
598 for (svp = AvARRAY(sv) + AvFILLp(sv)
599 ; svp >= AvARRAY(sv)
600 ; --svp)
601 if (*svp) SvPADTMP_on(*svp);
602 }
603 XSRETURN(0);
604}
605
15eb3045 606XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
14a976d6 607XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
608{
609 dXSARGS;
80b6a949
AB
610 SV * const svz = ST(0);
611 SV * sv;
fa3febb6 612 U32 refcnt;
58c0efa5 613 PERL_UNUSED_ARG(cv);
6867be6d 614
80b6a949 615 /* [perl #77776] - called as &foo() not foo() */
fa3febb6 616 if ((items != 1 && items != 2) || !SvROK(svz))
80b6a949
AB
617 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
618
619 sv = SvRV(svz);
620
14a976d6 621 /* I hope you really know what you are doing. */
fa3febb6
DD
622 /* idea is for SvREFCNT(sv) to be accessed only once */
623 refcnt = items == 2 ?
624 /* we free one ref on exit */
625 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
626 : SvREFCNT(sv);
627 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
628
29569577
JH
629}
630
15eb3045 631XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
f044d0d1 632XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC
633{
634 dXSARGS;
6867be6d 635
80b6a949 636 if (items != 1 || !SvROK(ST(0)))
afa74d42 637 croak_xs_usage(cv, "hv");
c4420975 638 else {
ef8f7699 639 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
640 hv_clear_placeholders(hv);
641 XSRETURN(0);
642 }
dfd4ef2f 643}
39f7a870 644
15eb3045 645XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
39f7a870
JH
646XS(XS_PerlIO_get_layers)
647{
648 dXSARGS;
649 if (items < 1 || items % 2 == 0)
afa74d42 650 croak_xs_usage(cv, "filehandle[,args]");
97cb92d6 651#if defined(USE_PERLIO)
39f7a870
JH
652 {
653 SV * sv;
654 GV * gv;
655 IO * io;
656 bool input = TRUE;
657 bool details = FALSE;
658
659 if (items > 1) {
c4420975 660 SV * const *svp;
39f7a870 661 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
662 SV * const * const varp = svp;
663 SV * const * const valp = svp + 1;
39f7a870 664 STRLEN klen;
c4420975 665 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
666
667 switch (*key) {
668 case 'i':
669 if (klen == 5 && memEQ(key, "input", 5)) {
670 input = SvTRUE(*valp);
671 break;
672 }
673 goto fail;
674 case 'o':
675 if (klen == 6 && memEQ(key, "output", 6)) {
676 input = !SvTRUE(*valp);
677 break;
678 }
679 goto fail;
680 case 'd':
681 if (klen == 7 && memEQ(key, "details", 7)) {
682 details = SvTRUE(*valp);
683 break;
684 }
685 goto fail;
686 default:
687 fail:
688 Perl_croak(aTHX_
689 "get_layers: unknown argument '%s'",
690 key);
691 }
692 }
693
694 SP -= (items - 1);
695 }
696
697 sv = POPs;
7f9aa7d3 698 gv = MAYBE_DEREF_GV(sv);
39f7a870 699
3825652d 700 if (!gv && !SvROK(sv))
7f9aa7d3 701 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
39f7a870
JH
702
703 if (gv && (io = GvIO(gv))) {
c4420975 704 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870 705 IoIFP(io) : IoOFP(io));
c70927a6 706 SSize_t i;
b9f2b683 707 const SSize_t last = av_tindex(av);
c70927a6 708 SSize_t nitem = 0;
39f7a870
JH
709
710 for (i = last; i >= 0; i -= 3) {
c4420975
AL
711 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
712 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
713 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 714
c4420975
AL
715 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
716 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
717 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870 718
2102d7a2 719 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
39f7a870 720 if (details) {
92e45a3e
NC
721 /* Indents of 5? Yuck. */
722 /* We know that PerlIO_get_layers creates a new SV for
723 the name and flags, so we can just take a reference
724 and "steal" it when we free the AV below. */
2102d7a2 725 PUSHs(namok
92e45a3e 726 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e 727 : &PL_sv_undef);
2102d7a2 728 PUSHs(argok
92e45a3e
NC
729 ? newSVpvn_flags(SvPVX_const(*argsvp),
730 SvCUR(*argsvp),
731 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
732 | SVs_TEMP)
733 : &PL_sv_undef);
2102d7a2 734 PUSHs(flgok
92e45a3e 735 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 736 : &PL_sv_undef);
39f7a870
JH
737 nitem += 3;
738 }
739 else {
740 if (namok && argok)
2102d7a2 741 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 742 SVfARG(*namsvp),
1eb9e81d 743 SVfARG(*argsvp))));
39f7a870 744 else if (namok)
2102d7a2 745 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870 746 else
2102d7a2 747 PUSHs(&PL_sv_undef);
39f7a870
JH
748 nitem++;
749 if (flgok) {
c4420975 750 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
751
752 if (flags & PERLIO_F_UTF8) {
2102d7a2 753 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
754 nitem++;
755 }
756 }
757 }
758 }
759
760 SvREFCNT_dec(av);
761
762 XSRETURN(nitem);
763 }
764 }
5fef3b4a 765#endif
39f7a870
JH
766
767 XSRETURN(0);
768}
769
241d1a3b 770
15eb3045 771XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
80305961
YO
772XS(XS_re_is_regexp)
773{
80305961 774 dXSARGS;
f7e71195
AB
775 PERL_UNUSED_VAR(cv);
776
80305961 777 if (items != 1)
afa74d42 778 croak_xs_usage(cv, "sv");
f7e71195 779
f7e71195
AB
780 if (SvRXOK(ST(0))) {
781 XSRETURN_YES;
782 } else {
783 XSRETURN_NO;
80305961
YO
784 }
785}
786
15eb3045 787XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
192b9cd1 788XS(XS_re_regnames_count)
80305961 789{
192b9cd1
AB
790 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
791 SV * ret;
80305961 792 dXSARGS;
192b9cd1
AB
793
794 if (items != 0)
afa74d42 795 croak_xs_usage(cv, "");
192b9cd1
AB
796
797 SP -= items;
fdae9473 798 PUTBACK;
192b9cd1
AB
799
800 if (!rx)
801 XSRETURN_UNDEF;
802
803 ret = CALLREG_NAMED_BUFF_COUNT(rx);
804
805 SPAGAIN;
fdae9473
NC
806 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
807 XSRETURN(1);
192b9cd1
AB
808}
809
15eb3045 810XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
192b9cd1
AB
811XS(XS_re_regname)
812{
192b9cd1
AB
813 dXSARGS;
814 REGEXP * rx;
815 U32 flags;
816 SV * ret;
817
28d8d7f4 818 if (items < 1 || items > 2)
afa74d42 819 croak_xs_usage(cv, "name[, all ]");
192b9cd1 820
80305961 821 SP -= items;
fdae9473 822 PUTBACK;
80305961 823
192b9cd1
AB
824 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
825
826 if (!rx)
827 XSRETURN_UNDEF;
828
829 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 830 flags = RXapif_ALL;
192b9cd1 831 } else {
f1b875a0 832 flags = RXapif_ONE;
80305961 833 }
f1b875a0 834 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1 835
fdae9473
NC
836 SPAGAIN;
837 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
838 XSRETURN(1);
80305961
YO
839}
840
192b9cd1 841
15eb3045 842XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
80305961
YO
843XS(XS_re_regnames)
844{
80305961 845 dXSARGS;
192b9cd1
AB
846 REGEXP * rx;
847 U32 flags;
848 SV *ret;
849 AV *av;
c70927a6
FC
850 SSize_t length;
851 SSize_t i;
192b9cd1
AB
852 SV **entry;
853
854 if (items > 1)
afa74d42 855 croak_xs_usage(cv, "[all]");
192b9cd1
AB
856
857 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
858
859 if (!rx)
860 XSRETURN_UNDEF;
861
862 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 863 flags = RXapif_ALL;
192b9cd1 864 } else {
f1b875a0 865 flags = RXapif_ONE;
192b9cd1
AB
866 }
867
80305961 868 SP -= items;
fdae9473 869 PUTBACK;
80305961 870
f1b875a0 871 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
872
873 SPAGAIN;
874
192b9cd1
AB
875 if (!ret)
876 XSRETURN_UNDEF;
877
502c6561 878 av = MUTABLE_AV(SvRV(ret));
b9f2b683 879 length = av_tindex(av);
192b9cd1 880
2102d7a2 881 EXTEND(SP, length+1); /* better extend stack just once */
192b9cd1
AB
882 for (i = 0; i <= length; i++) {
883 entry = av_fetch(av, i, FALSE);
884
885 if (!entry)
886 Perl_croak(aTHX_ "NULL array element in re::regnames()");
887
2102d7a2 888 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 889 }
ec83ea38
MHM
890
891 SvREFCNT_dec(ret);
892
192b9cd1
AB
893 PUTBACK;
894 return;
80305961
YO
895}
896
15eb3045 897XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
192c1e27
JH
898XS(XS_re_regexp_pattern)
899{
192c1e27
JH
900 dXSARGS;
901 REGEXP *re;
192c1e27 902
22d874e2
DD
903 EXTEND(SP, 2);
904 SP -= items;
192c1e27 905 if (items != 1)
afa74d42 906 croak_xs_usage(cv, "sv");
192c1e27 907
192c1e27
JH
908 /*
909 Checks if a reference is a regex or not. If the parameter is
910 not a ref, or is not the result of a qr// then returns false
911 in scalar context and an empty list in list context.
912 Otherwise in list context it returns the pattern and the
913 modifiers, in scalar context it returns the pattern just as it
914 would if the qr// was stringified normally, regardless as
486ec47a 915 to the class of the variable and any stringification overloads
192c1e27
JH
916 on the object.
917 */
918
919 if ((re = SvRX(ST(0)))) /* assign deliberate */
920 {
22c985d5 921 /* Houston, we have a regex! */
192c1e27 922 SV *pattern;
192c1e27
JH
923
924 if ( GIMME_V == G_ARRAY ) {
9de15fec 925 STRLEN left = 0;
a62b1201 926 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
69af1167
SH
927 const char *fptr;
928 char ch;
929 U16 match_flags;
930
192c1e27
JH
931 /*
932 we are in list context so stringify
933 the modifiers that apply. We ignore "negative
a62b1201 934 modifiers" in this scenario, and the default character set
192c1e27
JH
935 */
936
a62b1201
KW
937 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
938 STRLEN len;
939 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
940 &len);
941 Copy(name, reflags + left, len, char);
942 left += len;
9de15fec 943 }
69af1167 944 fptr = INT_PAT_MODS;
73134a2e 945 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
192c1e27
JH
946 >> RXf_PMf_STD_PMMOD_SHIFT);
947
948 while((ch = *fptr++)) {
949 if(match_flags & 1) {
950 reflags[left++] = ch;
951 }
952 match_flags >>= 1;
953 }
954
fb632ce3
NC
955 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
956 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
957
958 /* return the pattern and the modifiers */
2102d7a2
SM
959 PUSHs(pattern);
960 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
961 XSRETURN(2);
962 } else {
963 /* Scalar, so use the string that Perl would return */
964 /* return the pattern in (?msix:..) format */
965#if PERL_VERSION >= 11
daba3364 966 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 967#else
fb632ce3
NC
968 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
969 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27 970#endif
22d874e2 971 PUSHs(pattern);
192c1e27
JH
972 XSRETURN(1);
973 }
974 } else {
975 /* It ain't a regexp folks */
976 if ( GIMME_V == G_ARRAY ) {
977 /* return the empty list */
978 XSRETURN_UNDEF;
979 } else {
980 /* Because of the (?:..) wrapping involved in a
981 stringified pattern it is impossible to get a
982 result for a real regexp that would evaluate to
983 false. Therefore we can return PL_sv_no to signify
984 that the object is not a regex, this means that one
985 can say
986
987 if (regex($might_be_a_regex) eq '(?:foo)') { }
988
989 and not worry about undefined values.
990 */
991 XSRETURN_NO;
992 }
993 }
994 /* NOT-REACHED */
995}
996
b7a8ab8f 997#include "vutil.h"
abc6d738
FC
998#include "vxs.inc"
999
eff5b9d5
NC
1000struct xsub_details {
1001 const char *name;
1002 XSUBADDR_t xsub;
1003 const char *proto;
1004};
1005
a9b7658f 1006static const struct xsub_details details[] = {
eff5b9d5
NC
1007 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1008 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1009 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
abc6d738
FC
1010#define VXS_XSUB_DETAILS
1011#include "vxs.inc"
1012#undef VXS_XSUB_DETAILS
eff5b9d5
NC
1013 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1014 {"utf8::valid", XS_utf8_valid, NULL},
1015 {"utf8::encode", XS_utf8_encode, NULL},
1016 {"utf8::decode", XS_utf8_decode, NULL},
1017 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1018 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1019 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1020 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1021 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
2c6c1df5 1022 {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
eff5b9d5
NC
1023 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1024 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1025 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
eff5b9d5
NC
1026 {"re::is_regexp", XS_re_is_regexp, "$"},
1027 {"re::regname", XS_re_regname, ";$$"},
1028 {"re::regnames", XS_re_regnames, ";$"},
1029 {"re::regnames_count", XS_re_regnames_count, ""},
1030 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
eff5b9d5
NC
1031};
1032
1033void
1034Perl_boot_core_UNIVERSAL(pTHX)
1035{
eff5b9d5 1036 static const char file[] = __FILE__;
7a6ecb12 1037 const struct xsub_details *xsub = details;
c3caa5c3 1038 const struct xsub_details *end = C_ARRAY_END(details);
eff5b9d5
NC
1039
1040 do {
1041 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1042 } while (++xsub < end);
1043
eff5b9d5 1044 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
bad4ae38
FC
1045 {
1046 CV * const cv =
1047 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1048 Safefree(CvFILE(cv));
1049 CvFILE(cv) = (char *)file;
1050 CvDYNFILE_off(cv);
1051 }
eff5b9d5 1052}
80305961 1053
241d1a3b
NC
1054/*
1055 * Local variables:
1056 * c-indentation-style: bsd
1057 * c-basic-offset: 4
14d04a33 1058 * indent-tabs-mode: nil
241d1a3b
NC
1059 * End:
1060 *
14d04a33 1061 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1062 */