This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update release schedule
[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
8560fbdd
KW
297 Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk",
298 "eee_yow");
afa74d42
NC
299
300=cut
301*/
302
303void
cb077ed2 304Perl_croak_xs_usage(const CV *const cv, const char *const params)
afa74d42 305{
ae77754a 306 /* Avoid CvGV as it requires aTHX. */
2eaf799e 307 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
afa74d42
NC
308
309 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
310
2eaf799e 311 if (gv) got_gv: {
afa74d42 312 const HV *const stash = GvSTASH(gv);
afa74d42 313
58cb15b3 314 if (HvNAME_get(stash))
d3ee9aa5 315 /* diag_listed_as: SKIPME */
cb077ed2 316 Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)",
d0c0e7dd
FC
317 HEKfARG(HvNAME_HEK(stash)),
318 HEKfARG(GvNAME_HEK(gv)),
58cb15b3 319 params);
afa74d42 320 else
d3ee9aa5 321 /* diag_listed_as: SKIPME */
cb077ed2 322 Perl_croak_nocontext("Usage: %"HEKf"(%s)",
d0c0e7dd 323 HEKfARG(GvNAME_HEK(gv)), params);
afa74d42 324 } else {
2eaf799e
FC
325 dTHX;
326 if ((gv = CvGV(cv))) goto got_gv;
327
afa74d42 328 /* Pants. I don't think that it should be possible to get here. */
d3ee9aa5 329 /* diag_listed_as: SKIPME */
6e9fdf66 330 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
afa74d42
NC
331 }
332}
55497cff 333
15eb3045 334XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
6d4a7be2
PP
335XS(XS_UNIVERSAL_isa)
336{
337 dXSARGS;
6d4a7be2
PP
338
339 if (items != 2)
afa74d42 340 croak_xs_usage(cv, "reference, kind");
c4420975
AL
341 else {
342 SV * const sv = ST(0);
6d4a7be2 343
c4420975 344 SvGETMAGIC(sv);
d3f7f2b2 345
d96ab1b5 346 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
c4420975 347 XSRETURN_UNDEF;
f8f70380 348
c7abbf64 349 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
c4420975
AL
350 XSRETURN(1);
351 }
6d4a7be2
PP
352}
353
15eb3045 354XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
6d4a7be2
PP
355XS(XS_UNIVERSAL_can)
356{
357 dXSARGS;
358 SV *sv;
6d4a7be2 359 SV *rv;
6f08146e 360 HV *pkg = NULL;
2bde9ae6 361 GV *iogv;
6d4a7be2
PP
362
363 if (items != 2)
afa74d42 364 croak_xs_usage(cv, "object-ref, method");
6d4a7be2
PP
365
366 sv = ST(0);
f8f70380 367
5b295bef 368 SvGETMAGIC(sv);
d3f7f2b2 369
4178f891
FC
370 /* Reject undef and empty string. Note that the string form takes
371 precedence here over the numeric form, as (!1)->foo treats the
372 invocant as the empty string, though it is a dualvar. */
373 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
f8f70380
GS
374 XSRETURN_UNDEF;
375
3280af22 376 rv = &PL_sv_undef;
6d4a7be2 377
46e4b22b 378 if (SvROK(sv)) {
daba3364 379 sv = MUTABLE_SV(SvRV(sv));
46e4b22b 380 if (SvOBJECT(sv))
6f08146e 381 pkg = SvSTASH(sv);
4178f891
FC
382 else if (isGV_with_GP(sv) && GvIO(sv))
383 pkg = SvSTASH(GvIO(sv));
6f08146e 384 }
4178f891
FC
385 else if (isGV_with_GP(sv) && GvIO(sv))
386 pkg = SvSTASH(GvIO(sv));
2bde9ae6
FC
387 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
388 pkg = SvSTASH(GvIO(iogv));
6f08146e 389 else {
da51bb9b 390 pkg = gv_stashsv(sv, 0);
68b40612 391 if (!pkg)
7d59d161 392 pkg = gv_stashpvs("UNIVERSAL", 0);
6f08146e
NIS
393 }
394
395 if (pkg) {
a00b390b 396 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
dc848c6f 397 if (gv && isGV(gv))
daba3364 398 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
6d4a7be2
PP
399 }
400
401 ST(0) = rv;
402 XSRETURN(1);
403}
404
15eb3045 405XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
cbc021f9 406XS(XS_UNIVERSAL_DOES)
407{
cbc021f9 408 dXSARGS;
58c0efa5 409 PERL_UNUSED_ARG(cv);
cbc021f9 410
411 if (items != 2)
46404226 412 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
cbc021f9 413 else {
414 SV * const sv = ST(0);
f778bcfd 415 if (sv_does_sv( sv, ST(1), 0 ))
cbc021f9 416 XSRETURN_YES;
417
418 XSRETURN_NO;
419 }
420}
421
15eb3045 422XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
8800c35a
JH
423XS(XS_utf8_is_utf8)
424{
41be1fbd
JH
425 dXSARGS;
426 if (items != 1)
afa74d42 427 croak_xs_usage(cv, "sv");
c4420975 428 else {
76f73021 429 SV * const sv = ST(0);
430 SvGETMAGIC(sv);
c4420975
AL
431 if (SvUTF8(sv))
432 XSRETURN_YES;
433 else
434 XSRETURN_NO;
41be1fbd
JH
435 }
436 XSRETURN_EMPTY;
8800c35a
JH
437}
438
15eb3045 439XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
440XS(XS_utf8_valid)
441{
41be1fbd
JH
442 dXSARGS;
443 if (items != 1)
afa74d42 444 croak_xs_usage(cv, "sv");
c4420975
AL
445 else {
446 SV * const sv = ST(0);
447 STRLEN len;
448 const char * const s = SvPV_const(sv,len);
449 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
450 XSRETURN_YES;
451 else
452 XSRETURN_NO;
453 }
41be1fbd 454 XSRETURN_EMPTY;
1b026014
NIS
455}
456
15eb3045 457XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
458XS(XS_utf8_encode)
459{
460 dXSARGS;
461 if (items != 1)
afa74d42 462 croak_xs_usage(cv, "sv");
c4420975 463 sv_utf8_encode(ST(0));
892f9127 464 SvSETMAGIC(ST(0));
1b026014
NIS
465 XSRETURN_EMPTY;
466}
467
15eb3045 468XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
469XS(XS_utf8_decode)
470{
471 dXSARGS;
472 if (items != 1)
afa74d42 473 croak_xs_usage(cv, "sv");
c4420975
AL
474 else {
475 SV * const sv = ST(0);
b2b7346b 476 bool RETVAL;
c7102404 477 SvPV_force_nolen(sv);
b2b7346b 478 RETVAL = sv_utf8_decode(sv);
77fc86ef 479 SvSETMAGIC(sv);
1b026014 480 ST(0) = boolSV(RETVAL);
1b026014
NIS
481 }
482 XSRETURN(1);
483}
484
15eb3045 485XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
486XS(XS_utf8_upgrade)
487{
488 dXSARGS;
489 if (items != 1)
afa74d42 490 croak_xs_usage(cv, "sv");
c4420975
AL
491 else {
492 SV * const sv = ST(0);
1b026014
NIS
493 STRLEN RETVAL;
494 dXSTARG;
495
496 RETVAL = sv_utf8_upgrade(sv);
497 XSprePUSH; PUSHi((IV)RETVAL);
498 }
499 XSRETURN(1);
500}
501
15eb3045 502XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
503XS(XS_utf8_downgrade)
504{
505 dXSARGS;
506 if (items < 1 || items > 2)
afa74d42 507 croak_xs_usage(cv, "sv, failok=0");
c4420975
AL
508 else {
509 SV * const sv = ST(0);
3ca75eca 510 const bool failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0;
6867be6d 511 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 512
1b026014 513 ST(0) = boolSV(RETVAL);
1b026014
NIS
514 }
515 XSRETURN(1);
516}
517
15eb3045 518XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
519XS(XS_utf8_native_to_unicode)
520{
521 dXSARGS;
6867be6d 522 const UV uv = SvUV(ST(0));
b7953727
JH
523
524 if (items > 1)
afa74d42 525 croak_xs_usage(cv, "sv");
b7953727 526
1b026014
NIS
527 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
528 XSRETURN(1);
529}
530
15eb3045 531XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
532XS(XS_utf8_unicode_to_native)
533{
534 dXSARGS;
6867be6d 535 const UV uv = SvUV(ST(0));
b7953727
JH
536
537 if (items > 1)
afa74d42 538 croak_xs_usage(cv, "sv");
b7953727 539
1b026014
NIS
540 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
541 XSRETURN(1);
542}
543
15eb3045 544XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
14a976d6 545XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH
546{
547 dXSARGS;
80b6a949
AB
548 SV * const svz = ST(0);
549 SV * sv;
58c0efa5 550 PERL_UNUSED_ARG(cv);
6867be6d 551
80b6a949
AB
552 /* [perl #77776] - called as &foo() not foo() */
553 if (!SvROK(svz))
554 croak_xs_usage(cv, "SCALAR[, ON]");
555
556 sv = SvRV(svz);
557
29569577 558 if (items == 1) {
1620522e 559 if (SvREADONLY(sv))
29569577
JH
560 XSRETURN_YES;
561 else
562 XSRETURN_NO;
563 }
564 else if (items == 2) {
565 if (SvTRUE(ST(1))) {
1620522e 566#ifdef PERL_OLD_COPY_ON_WRITE
3e89ba19 567 if (SvIsCOW(sv)) sv_force_normal(sv);
1620522e 568#endif
a623f893 569 SvFLAGS(sv) |= SVf_READONLY;
29569577
JH
570 XSRETURN_YES;
571 }
572 else {
14a976d6 573 /* I hope you really know what you are doing. */
a623f893 574 SvFLAGS(sv) &=~ SVf_READONLY;
29569577
JH
575 XSRETURN_NO;
576 }
577 }
14a976d6 578 XSRETURN_UNDEF; /* Can't happen. */
29569577 579}
2c6c1df5 580
15eb3045 581XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
2c6c1df5
FC
582XS(XS_constant__make_const) /* This is dangerous stuff. */
583{
2c6c1df5
FC
584 dXSARGS;
585 SV * const svz = ST(0);
586 SV * sv;
587 PERL_UNUSED_ARG(cv);
588
589 /* [perl #77776] - called as &foo() not foo() */
590 if (!SvROK(svz) || items != 1)
591 croak_xs_usage(cv, "SCALAR");
592
593 sv = SvRV(svz);
594
595#ifdef PERL_OLD_COPY_ON_WRITE
596 if (SvIsCOW(sv)) sv_force_normal(sv);
597#endif
598 SvREADONLY_on(sv);
599 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
600 /* for constant.pm; nobody else should be calling this
601 on arrays anyway. */
602 SV **svp;
603 for (svp = AvARRAY(sv) + AvFILLp(sv)
604 ; svp >= AvARRAY(sv)
605 ; --svp)
606 if (*svp) SvPADTMP_on(*svp);
607 }
608 XSRETURN(0);
609}
610
15eb3045 611XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
14a976d6 612XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
613{
614 dXSARGS;
80b6a949
AB
615 SV * const svz = ST(0);
616 SV * sv;
fa3febb6 617 U32 refcnt;
58c0efa5 618 PERL_UNUSED_ARG(cv);
6867be6d 619
80b6a949 620 /* [perl #77776] - called as &foo() not foo() */
fa3febb6 621 if ((items != 1 && items != 2) || !SvROK(svz))
80b6a949
AB
622 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
623
624 sv = SvRV(svz);
625
14a976d6 626 /* I hope you really know what you are doing. */
fa3febb6
DD
627 /* idea is for SvREFCNT(sv) to be accessed only once */
628 refcnt = items == 2 ?
629 /* we free one ref on exit */
630 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
631 : SvREFCNT(sv);
632 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
633
29569577
JH
634}
635
15eb3045 636XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
f044d0d1 637XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC
638{
639 dXSARGS;
6867be6d 640
80b6a949 641 if (items != 1 || !SvROK(ST(0)))
afa74d42 642 croak_xs_usage(cv, "hv");
c4420975 643 else {
ef8f7699 644 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
645 hv_clear_placeholders(hv);
646 XSRETURN(0);
647 }
dfd4ef2f 648}
39f7a870 649
15eb3045 650XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
39f7a870
JH
651XS(XS_PerlIO_get_layers)
652{
653 dXSARGS;
654 if (items < 1 || items % 2 == 0)
afa74d42 655 croak_xs_usage(cv, "filehandle[,args]");
97cb92d6 656#if defined(USE_PERLIO)
39f7a870
JH
657 {
658 SV * sv;
659 GV * gv;
660 IO * io;
661 bool input = TRUE;
662 bool details = FALSE;
663
664 if (items > 1) {
c4420975 665 SV * const *svp;
39f7a870 666 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
667 SV * const * const varp = svp;
668 SV * const * const valp = svp + 1;
39f7a870 669 STRLEN klen;
c4420975 670 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
671
672 switch (*key) {
673 case 'i':
674 if (klen == 5 && memEQ(key, "input", 5)) {
675 input = SvTRUE(*valp);
676 break;
677 }
678 goto fail;
679 case 'o':
680 if (klen == 6 && memEQ(key, "output", 6)) {
681 input = !SvTRUE(*valp);
682 break;
683 }
684 goto fail;
685 case 'd':
686 if (klen == 7 && memEQ(key, "details", 7)) {
687 details = SvTRUE(*valp);
688 break;
689 }
690 goto fail;
691 default:
692 fail:
693 Perl_croak(aTHX_
694 "get_layers: unknown argument '%s'",
695 key);
696 }
697 }
698
699 SP -= (items - 1);
700 }
701
702 sv = POPs;
7f9aa7d3 703 gv = MAYBE_DEREF_GV(sv);
39f7a870 704
3825652d 705 if (!gv && !SvROK(sv))
7f9aa7d3 706 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
39f7a870
JH
707
708 if (gv && (io = GvIO(gv))) {
c4420975 709 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870 710 IoIFP(io) : IoOFP(io));
c70927a6 711 SSize_t i;
b9f2b683 712 const SSize_t last = av_tindex(av);
c70927a6 713 SSize_t nitem = 0;
39f7a870
JH
714
715 for (i = last; i >= 0; i -= 3) {
c4420975
AL
716 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
717 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
718 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 719
c4420975
AL
720 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
721 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
722 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870 723
2102d7a2 724 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
39f7a870 725 if (details) {
92e45a3e
NC
726 /* Indents of 5? Yuck. */
727 /* We know that PerlIO_get_layers creates a new SV for
728 the name and flags, so we can just take a reference
729 and "steal" it when we free the AV below. */
2102d7a2 730 PUSHs(namok
92e45a3e 731 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e 732 : &PL_sv_undef);
2102d7a2 733 PUSHs(argok
92e45a3e
NC
734 ? newSVpvn_flags(SvPVX_const(*argsvp),
735 SvCUR(*argsvp),
736 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
737 | SVs_TEMP)
738 : &PL_sv_undef);
2102d7a2 739 PUSHs(flgok
92e45a3e 740 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 741 : &PL_sv_undef);
39f7a870
JH
742 nitem += 3;
743 }
744 else {
745 if (namok && argok)
2102d7a2 746 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 747 SVfARG(*namsvp),
1eb9e81d 748 SVfARG(*argsvp))));
39f7a870 749 else if (namok)
2102d7a2 750 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870 751 else
2102d7a2 752 PUSHs(&PL_sv_undef);
39f7a870
JH
753 nitem++;
754 if (flgok) {
c4420975 755 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
756
757 if (flags & PERLIO_F_UTF8) {
2102d7a2 758 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
759 nitem++;
760 }
761 }
762 }
763 }
764
765 SvREFCNT_dec(av);
766
767 XSRETURN(nitem);
768 }
769 }
5fef3b4a 770#endif
39f7a870
JH
771
772 XSRETURN(0);
773}
774
241d1a3b 775
15eb3045 776XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
80305961
YO
777XS(XS_re_is_regexp)
778{
80305961 779 dXSARGS;
f7e71195
AB
780 PERL_UNUSED_VAR(cv);
781
80305961 782 if (items != 1)
afa74d42 783 croak_xs_usage(cv, "sv");
f7e71195 784
f7e71195
AB
785 if (SvRXOK(ST(0))) {
786 XSRETURN_YES;
787 } else {
788 XSRETURN_NO;
80305961
YO
789 }
790}
791
15eb3045 792XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
192b9cd1 793XS(XS_re_regnames_count)
80305961 794{
192b9cd1
AB
795 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
796 SV * ret;
80305961 797 dXSARGS;
192b9cd1
AB
798
799 if (items != 0)
afa74d42 800 croak_xs_usage(cv, "");
192b9cd1
AB
801
802 SP -= items;
fdae9473 803 PUTBACK;
192b9cd1
AB
804
805 if (!rx)
806 XSRETURN_UNDEF;
807
808 ret = CALLREG_NAMED_BUFF_COUNT(rx);
809
810 SPAGAIN;
fdae9473
NC
811 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
812 XSRETURN(1);
192b9cd1
AB
813}
814
15eb3045 815XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
192b9cd1
AB
816XS(XS_re_regname)
817{
192b9cd1
AB
818 dXSARGS;
819 REGEXP * rx;
820 U32 flags;
821 SV * ret;
822
28d8d7f4 823 if (items < 1 || items > 2)
afa74d42 824 croak_xs_usage(cv, "name[, all ]");
192b9cd1 825
80305961 826 SP -= items;
fdae9473 827 PUTBACK;
80305961 828
192b9cd1
AB
829 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
830
831 if (!rx)
832 XSRETURN_UNDEF;
833
834 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 835 flags = RXapif_ALL;
192b9cd1 836 } else {
f1b875a0 837 flags = RXapif_ONE;
80305961 838 }
f1b875a0 839 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1 840
fdae9473
NC
841 SPAGAIN;
842 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
843 XSRETURN(1);
80305961
YO
844}
845
192b9cd1 846
15eb3045 847XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
80305961
YO
848XS(XS_re_regnames)
849{
80305961 850 dXSARGS;
192b9cd1
AB
851 REGEXP * rx;
852 U32 flags;
853 SV *ret;
854 AV *av;
c70927a6
FC
855 SSize_t length;
856 SSize_t i;
192b9cd1
AB
857 SV **entry;
858
859 if (items > 1)
afa74d42 860 croak_xs_usage(cv, "[all]");
192b9cd1
AB
861
862 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
863
864 if (!rx)
865 XSRETURN_UNDEF;
866
867 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 868 flags = RXapif_ALL;
192b9cd1 869 } else {
f1b875a0 870 flags = RXapif_ONE;
192b9cd1
AB
871 }
872
80305961 873 SP -= items;
fdae9473 874 PUTBACK;
80305961 875
f1b875a0 876 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
877
878 SPAGAIN;
879
192b9cd1
AB
880 if (!ret)
881 XSRETURN_UNDEF;
882
502c6561 883 av = MUTABLE_AV(SvRV(ret));
b9f2b683 884 length = av_tindex(av);
192b9cd1 885
2102d7a2 886 EXTEND(SP, length+1); /* better extend stack just once */
192b9cd1
AB
887 for (i = 0; i <= length; i++) {
888 entry = av_fetch(av, i, FALSE);
889
890 if (!entry)
891 Perl_croak(aTHX_ "NULL array element in re::regnames()");
892
2102d7a2 893 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 894 }
ec83ea38
MHM
895
896 SvREFCNT_dec(ret);
897
192b9cd1
AB
898 PUTBACK;
899 return;
80305961
YO
900}
901
15eb3045 902XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
192c1e27
JH
903XS(XS_re_regexp_pattern)
904{
192c1e27
JH
905 dXSARGS;
906 REGEXP *re;
de5fee32 907 I32 const gimme = GIMME_V;
192c1e27 908
22d874e2
DD
909 EXTEND(SP, 2);
910 SP -= items;
192c1e27 911 if (items != 1)
afa74d42 912 croak_xs_usage(cv, "sv");
192c1e27 913
192c1e27
JH
914 /*
915 Checks if a reference is a regex or not. If the parameter is
916 not a ref, or is not the result of a qr// then returns false
917 in scalar context and an empty list in list context.
918 Otherwise in list context it returns the pattern and the
919 modifiers, in scalar context it returns the pattern just as it
920 would if the qr// was stringified normally, regardless as
486ec47a 921 to the class of the variable and any stringification overloads
192c1e27
JH
922 on the object.
923 */
924
925 if ((re = SvRX(ST(0)))) /* assign deliberate */
926 {
22c985d5 927 /* Houston, we have a regex! */
192c1e27 928 SV *pattern;
192c1e27 929
b1dcc8e2 930 if ( gimme == G_ARRAY ) {
9de15fec 931 STRLEN left = 0;
a62b1201 932 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
69af1167
SH
933 const char *fptr;
934 char ch;
935 U16 match_flags;
936
192c1e27
JH
937 /*
938 we are in list context so stringify
939 the modifiers that apply. We ignore "negative
a62b1201 940 modifiers" in this scenario, and the default character set
192c1e27
JH
941 */
942
a62b1201
KW
943 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
944 STRLEN len;
945 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
946 &len);
947 Copy(name, reflags + left, len, char);
948 left += len;
9de15fec 949 }
69af1167 950 fptr = INT_PAT_MODS;
73134a2e 951 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
192c1e27
JH
952 >> RXf_PMf_STD_PMMOD_SHIFT);
953
954 while((ch = *fptr++)) {
955 if(match_flags & 1) {
956 reflags[left++] = ch;
957 }
958 match_flags >>= 1;
959 }
960
fb632ce3
NC
961 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
962 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
963
964 /* return the pattern and the modifiers */
2102d7a2
SM
965 PUSHs(pattern);
966 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
967 XSRETURN(2);
968 } else {
969 /* Scalar, so use the string that Perl would return */
33be4c61 970 /* return the pattern in (?msixn:..) format */
192c1e27 971#if PERL_VERSION >= 11
daba3364 972 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 973#else
fb632ce3
NC
974 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
975 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27 976#endif
22d874e2 977 PUSHs(pattern);
192c1e27
JH
978 XSRETURN(1);
979 }
980 } else {
981 /* It ain't a regexp folks */
b1dcc8e2 982 if ( gimme == G_ARRAY ) {
192c1e27 983 /* return the empty list */
7b46bf4c 984 XSRETURN_EMPTY;
192c1e27
JH
985 } else {
986 /* Because of the (?:..) wrapping involved in a
987 stringified pattern it is impossible to get a
988 result for a real regexp that would evaluate to
989 false. Therefore we can return PL_sv_no to signify
990 that the object is not a regex, this means that one
991 can say
992
993 if (regex($might_be_a_regex) eq '(?:foo)') { }
994
995 and not worry about undefined values.
996 */
997 XSRETURN_NO;
998 }
999 }
661d43c4 1000 NOT_REACHED; /* NOTREACHED */
192c1e27
JH
1001}
1002
b7a8ab8f 1003#include "vutil.h"
abc6d738
FC
1004#include "vxs.inc"
1005
eff5b9d5
NC
1006struct xsub_details {
1007 const char *name;
1008 XSUBADDR_t xsub;
1009 const char *proto;
1010};
1011
a9b7658f 1012static const struct xsub_details details[] = {
eff5b9d5
NC
1013 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1014 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1015 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
abc6d738
FC
1016#define VXS_XSUB_DETAILS
1017#include "vxs.inc"
1018#undef VXS_XSUB_DETAILS
eff5b9d5
NC
1019 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1020 {"utf8::valid", XS_utf8_valid, NULL},
1021 {"utf8::encode", XS_utf8_encode, NULL},
1022 {"utf8::decode", XS_utf8_decode, NULL},
1023 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1024 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1025 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1026 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1027 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
2c6c1df5 1028 {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
eff5b9d5
NC
1029 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1030 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1031 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
eff5b9d5
NC
1032 {"re::is_regexp", XS_re_is_regexp, "$"},
1033 {"re::regname", XS_re_regname, ";$$"},
1034 {"re::regnames", XS_re_regnames, ";$"},
1035 {"re::regnames_count", XS_re_regnames_count, ""},
1036 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
eff5b9d5
NC
1037};
1038
273e254d
KW
1039STATIC OP*
1040optimize_out_native_convert_function(pTHX_ OP* entersubop,
1041 GV* namegv,
1042 SV* protosv)
1043{
1044 /* Optimizes out an identity function, i.e., one that just returns its
1045 * argument. The passed in function is assumed to be an identity function,
1046 * with no checking. This is designed to be called for utf8_to_native()
1047 * and native_to_utf8() on ASCII platforms, as they just return their
1048 * arguments, but it could work on any such function.
1049 *
1050 * The code is mostly just cargo-culted from Memoize::Lift */
1051
1052 OP *pushop, *argop;
614f287f 1053 OP *parent;
273e254d
KW
1054 SV* prototype = newSVpvs("$");
1055
1056 PERL_UNUSED_ARG(protosv);
1057
1058 assert(entersubop->op_type == OP_ENTERSUB);
1059
1060 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
614f287f 1061 parent = entersubop;
273e254d
KW
1062
1063 SvREFCNT_dec(prototype);
1064
1065 pushop = cUNOPx(entersubop)->op_first;
bac7a184 1066 if (! OpHAS_SIBLING(pushop)) {
614f287f 1067 parent = pushop;
273e254d
KW
1068 pushop = cUNOPx(pushop)->op_first;
1069 }
614f287f 1070 argop = OpSIBLING(pushop);
273e254d
KW
1071
1072 /* Carry on without doing the optimization if it is not something we're
1073 * expecting, so continues to work */
1074 if ( ! argop
bac7a184 1075 || ! OpHAS_SIBLING(argop)
614f287f 1076 || OpHAS_SIBLING(OpSIBLING(argop))
273e254d
KW
1077 ) {
1078 return entersubop;
1079 }
1080
614f287f
DM
1081 /* cut argop from the subtree */
1082 (void)op_sibling_splice(parent, pushop, 1, NULL);
273e254d
KW
1083
1084 op_free(entersubop);
1085 return argop;
1086}
1087
eff5b9d5
NC
1088void
1089Perl_boot_core_UNIVERSAL(pTHX)
1090{
eff5b9d5 1091 static const char file[] = __FILE__;
7a6ecb12 1092 const struct xsub_details *xsub = details;
c3caa5c3 1093 const struct xsub_details *end = C_ARRAY_END(details);
eff5b9d5
NC
1094
1095 do {
1096 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1097 } while (++xsub < end);
1098
273e254d
KW
1099#ifndef EBCDIC
1100 { /* On ASCII platforms these functions just return their argument, so can
1101 be optimized away */
1102
1103 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1104 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1105
1106 cv_set_call_checker(to_native_cv,
1107 optimize_out_native_convert_function,
1108 (SV*) to_native_cv);
1109 cv_set_call_checker(to_unicode_cv,
1110 optimize_out_native_convert_function,
1111 (SV*) to_unicode_cv);
1112 }
1113#endif
1114
eff5b9d5 1115 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
bad4ae38
FC
1116 {
1117 CV * const cv =
1118 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
5513c2cf
DD
1119 char ** cvfile = &CvFILE(cv);
1120 char * oldfile = *cvfile;
bad4ae38 1121 CvDYNFILE_off(cv);
5513c2cf
DD
1122 *cvfile = (char *)file;
1123 Safefree(oldfile);
bad4ae38 1124 }
eff5b9d5 1125}
80305961 1126
241d1a3b 1127/*
14d04a33 1128 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1129 */