This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
tmp fix for Bleadperl breaks Variable-Magic
[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
4b523e79 208 if (SvROK(sv) && SvOBJECT(SvRV(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
b5804ad6 527 ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
1b026014
NIS
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
b5804ad6 540 ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
1b026014
NIS
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))) {
a623f893 566 SvFLAGS(sv) |= SVf_READONLY;
29569577
JH
567 XSRETURN_YES;
568 }
569 else {
14a976d6 570 /* I hope you really know what you are doing. */
a623f893 571 SvFLAGS(sv) &=~ SVf_READONLY;
29569577
JH
572 XSRETURN_NO;
573 }
574 }
14a976d6 575 XSRETURN_UNDEF; /* Can't happen. */
29569577 576}
2c6c1df5 577
15eb3045 578XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
2c6c1df5
FC
579XS(XS_constant__make_const) /* This is dangerous stuff. */
580{
2c6c1df5
FC
581 dXSARGS;
582 SV * const svz = ST(0);
583 SV * sv;
584 PERL_UNUSED_ARG(cv);
585
586 /* [perl #77776] - called as &foo() not foo() */
587 if (!SvROK(svz) || items != 1)
588 croak_xs_usage(cv, "SCALAR");
589
590 sv = SvRV(svz);
591
2c6c1df5
FC
592 SvREADONLY_on(sv);
593 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
594 /* for constant.pm; nobody else should be calling this
595 on arrays anyway. */
596 SV **svp;
597 for (svp = AvARRAY(sv) + AvFILLp(sv)
598 ; svp >= AvARRAY(sv)
599 ; --svp)
600 if (*svp) SvPADTMP_on(*svp);
601 }
602 XSRETURN(0);
603}
604
15eb3045 605XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
14a976d6 606XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
607{
608 dXSARGS;
80b6a949
AB
609 SV * const svz = ST(0);
610 SV * sv;
fa3febb6 611 U32 refcnt;
58c0efa5 612 PERL_UNUSED_ARG(cv);
6867be6d 613
80b6a949 614 /* [perl #77776] - called as &foo() not foo() */
fa3febb6 615 if ((items != 1 && items != 2) || !SvROK(svz))
80b6a949
AB
616 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
617
618 sv = SvRV(svz);
619
14a976d6 620 /* I hope you really know what you are doing. */
fa3febb6
DD
621 /* idea is for SvREFCNT(sv) to be accessed only once */
622 refcnt = items == 2 ?
623 /* we free one ref on exit */
624 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
625 : SvREFCNT(sv);
626 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
627
29569577
JH
628}
629
15eb3045 630XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
39f7a870
JH
631XS(XS_PerlIO_get_layers)
632{
633 dXSARGS;
634 if (items < 1 || items % 2 == 0)
afa74d42 635 croak_xs_usage(cv, "filehandle[,args]");
97cb92d6 636#if defined(USE_PERLIO)
39f7a870
JH
637 {
638 SV * sv;
639 GV * gv;
640 IO * io;
641 bool input = TRUE;
642 bool details = FALSE;
643
644 if (items > 1) {
c4420975 645 SV * const *svp;
39f7a870 646 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
647 SV * const * const varp = svp;
648 SV * const * const valp = svp + 1;
39f7a870 649 STRLEN klen;
c4420975 650 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
651
652 switch (*key) {
653 case 'i':
654 if (klen == 5 && memEQ(key, "input", 5)) {
655 input = SvTRUE(*valp);
656 break;
657 }
658 goto fail;
659 case 'o':
660 if (klen == 6 && memEQ(key, "output", 6)) {
661 input = !SvTRUE(*valp);
662 break;
663 }
664 goto fail;
665 case 'd':
666 if (klen == 7 && memEQ(key, "details", 7)) {
667 details = SvTRUE(*valp);
668 break;
669 }
670 goto fail;
671 default:
672 fail:
673 Perl_croak(aTHX_
674 "get_layers: unknown argument '%s'",
675 key);
676 }
677 }
678
679 SP -= (items - 1);
680 }
681
682 sv = POPs;
7f9aa7d3 683 gv = MAYBE_DEREF_GV(sv);
39f7a870 684
3825652d 685 if (!gv && !SvROK(sv))
7f9aa7d3 686 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
39f7a870
JH
687
688 if (gv && (io = GvIO(gv))) {
c4420975 689 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870 690 IoIFP(io) : IoOFP(io));
c70927a6 691 SSize_t i;
b9f2b683 692 const SSize_t last = av_tindex(av);
c70927a6 693 SSize_t nitem = 0;
39f7a870
JH
694
695 for (i = last; i >= 0; i -= 3) {
c4420975
AL
696 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
697 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
698 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 699
c4420975
AL
700 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
701 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
702 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870 703
2102d7a2 704 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
39f7a870 705 if (details) {
92e45a3e
NC
706 /* Indents of 5? Yuck. */
707 /* We know that PerlIO_get_layers creates a new SV for
708 the name and flags, so we can just take a reference
709 and "steal" it when we free the AV below. */
2102d7a2 710 PUSHs(namok
92e45a3e 711 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e 712 : &PL_sv_undef);
2102d7a2 713 PUSHs(argok
92e45a3e
NC
714 ? newSVpvn_flags(SvPVX_const(*argsvp),
715 SvCUR(*argsvp),
716 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
717 | SVs_TEMP)
718 : &PL_sv_undef);
2102d7a2 719 PUSHs(flgok
92e45a3e 720 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 721 : &PL_sv_undef);
39f7a870
JH
722 nitem += 3;
723 }
724 else {
725 if (namok && argok)
2102d7a2 726 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 727 SVfARG(*namsvp),
1eb9e81d 728 SVfARG(*argsvp))));
39f7a870 729 else if (namok)
2102d7a2 730 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870 731 else
2102d7a2 732 PUSHs(&PL_sv_undef);
39f7a870
JH
733 nitem++;
734 if (flgok) {
c4420975 735 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
736
737 if (flags & PERLIO_F_UTF8) {
2102d7a2 738 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
739 nitem++;
740 }
741 }
742 }
743 }
744
745 SvREFCNT_dec(av);
746
747 XSRETURN(nitem);
748 }
749 }
5fef3b4a 750#endif
39f7a870
JH
751
752 XSRETURN(0);
753}
754
15eb3045 755XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
80305961
YO
756XS(XS_re_is_regexp)
757{
80305961 758 dXSARGS;
f7e71195
AB
759 PERL_UNUSED_VAR(cv);
760
80305961 761 if (items != 1)
afa74d42 762 croak_xs_usage(cv, "sv");
f7e71195 763
f7e71195
AB
764 if (SvRXOK(ST(0))) {
765 XSRETURN_YES;
766 } else {
767 XSRETURN_NO;
80305961
YO
768 }
769}
770
15eb3045 771XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
192b9cd1 772XS(XS_re_regnames_count)
80305961 773{
192b9cd1
AB
774 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
775 SV * ret;
80305961 776 dXSARGS;
192b9cd1
AB
777
778 if (items != 0)
afa74d42 779 croak_xs_usage(cv, "");
192b9cd1 780
192b9cd1
AB
781 if (!rx)
782 XSRETURN_UNDEF;
783
784 ret = CALLREG_NAMED_BUFF_COUNT(rx);
785
786 SPAGAIN;
fdae9473
NC
787 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
788 XSRETURN(1);
192b9cd1
AB
789}
790
15eb3045 791XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
192b9cd1
AB
792XS(XS_re_regname)
793{
192b9cd1
AB
794 dXSARGS;
795 REGEXP * rx;
796 U32 flags;
797 SV * ret;
798
28d8d7f4 799 if (items < 1 || items > 2)
afa74d42 800 croak_xs_usage(cv, "name[, all ]");
192b9cd1 801
80305961 802 SP -= items;
fdae9473 803 PUTBACK;
80305961 804
192b9cd1
AB
805 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
806
807 if (!rx)
808 XSRETURN_UNDEF;
809
810 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 811 flags = RXapif_ALL;
192b9cd1 812 } else {
f1b875a0 813 flags = RXapif_ONE;
80305961 814 }
f1b875a0 815 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1 816
fdae9473
NC
817 SPAGAIN;
818 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
819 XSRETURN(1);
80305961
YO
820}
821
192b9cd1 822
15eb3045 823XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
80305961
YO
824XS(XS_re_regnames)
825{
80305961 826 dXSARGS;
192b9cd1
AB
827 REGEXP * rx;
828 U32 flags;
829 SV *ret;
830 AV *av;
c70927a6
FC
831 SSize_t length;
832 SSize_t i;
192b9cd1
AB
833 SV **entry;
834
835 if (items > 1)
afa74d42 836 croak_xs_usage(cv, "[all]");
192b9cd1
AB
837
838 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
839
840 if (!rx)
841 XSRETURN_UNDEF;
842
843 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 844 flags = RXapif_ALL;
192b9cd1 845 } else {
f1b875a0 846 flags = RXapif_ONE;
192b9cd1
AB
847 }
848
80305961 849 SP -= items;
fdae9473 850 PUTBACK;
80305961 851
f1b875a0 852 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
853
854 SPAGAIN;
855
192b9cd1
AB
856 if (!ret)
857 XSRETURN_UNDEF;
858
502c6561 859 av = MUTABLE_AV(SvRV(ret));
b9f2b683 860 length = av_tindex(av);
192b9cd1 861
2102d7a2 862 EXTEND(SP, length+1); /* better extend stack just once */
192b9cd1
AB
863 for (i = 0; i <= length; i++) {
864 entry = av_fetch(av, i, FALSE);
865
866 if (!entry)
867 Perl_croak(aTHX_ "NULL array element in re::regnames()");
868
2102d7a2 869 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 870 }
ec83ea38
MHM
871
872 SvREFCNT_dec(ret);
873
192b9cd1
AB
874 PUTBACK;
875 return;
80305961
YO
876}
877
15eb3045 878XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
192c1e27
JH
879XS(XS_re_regexp_pattern)
880{
192c1e27
JH
881 dXSARGS;
882 REGEXP *re;
1c23e2bd 883 U8 const gimme = GIMME_V;
192c1e27 884
22d874e2
DD
885 EXTEND(SP, 2);
886 SP -= items;
192c1e27 887 if (items != 1)
afa74d42 888 croak_xs_usage(cv, "sv");
192c1e27 889
192c1e27
JH
890 /*
891 Checks if a reference is a regex or not. If the parameter is
892 not a ref, or is not the result of a qr// then returns false
893 in scalar context and an empty list in list context.
894 Otherwise in list context it returns the pattern and the
895 modifiers, in scalar context it returns the pattern just as it
896 would if the qr// was stringified normally, regardless as
486ec47a 897 to the class of the variable and any stringification overloads
192c1e27
JH
898 on the object.
899 */
900
901 if ((re = SvRX(ST(0)))) /* assign deliberate */
902 {
22c985d5 903 /* Houston, we have a regex! */
192c1e27 904 SV *pattern;
192c1e27 905
b1dcc8e2 906 if ( gimme == G_ARRAY ) {
9de15fec 907 STRLEN left = 0;
a62b1201 908 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
69af1167
SH
909 const char *fptr;
910 char ch;
911 U16 match_flags;
912
192c1e27
JH
913 /*
914 we are in list context so stringify
915 the modifiers that apply. We ignore "negative
a62b1201 916 modifiers" in this scenario, and the default character set
192c1e27
JH
917 */
918
a62b1201
KW
919 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
920 STRLEN len;
921 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
922 &len);
923 Copy(name, reflags + left, len, char);
924 left += len;
9de15fec 925 }
69af1167 926 fptr = INT_PAT_MODS;
73134a2e 927 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
192c1e27
JH
928 >> RXf_PMf_STD_PMMOD_SHIFT);
929
930 while((ch = *fptr++)) {
931 if(match_flags & 1) {
932 reflags[left++] = ch;
933 }
934 match_flags >>= 1;
935 }
936
fb632ce3
NC
937 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
938 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
939
940 /* return the pattern and the modifiers */
2102d7a2
SM
941 PUSHs(pattern);
942 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
943 XSRETURN(2);
944 } else {
945 /* Scalar, so use the string that Perl would return */
33be4c61 946 /* return the pattern in (?msixn:..) format */
192c1e27 947#if PERL_VERSION >= 11
daba3364 948 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 949#else
fb632ce3
NC
950 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
951 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27 952#endif
22d874e2 953 PUSHs(pattern);
192c1e27
JH
954 XSRETURN(1);
955 }
956 } else {
957 /* It ain't a regexp folks */
b1dcc8e2 958 if ( gimme == G_ARRAY ) {
192c1e27 959 /* return the empty list */
7b46bf4c 960 XSRETURN_EMPTY;
192c1e27
JH
961 } else {
962 /* Because of the (?:..) wrapping involved in a
963 stringified pattern it is impossible to get a
964 result for a real regexp that would evaluate to
965 false. Therefore we can return PL_sv_no to signify
966 that the object is not a regex, this means that one
967 can say
968
969 if (regex($might_be_a_regex) eq '(?:foo)') { }
970
971 and not worry about undefined values.
972 */
973 XSRETURN_NO;
974 }
975 }
661d43c4 976 NOT_REACHED; /* NOTREACHED */
192c1e27
JH
977}
978
b7a8ab8f 979#include "vutil.h"
abc6d738
FC
980#include "vxs.inc"
981
eff5b9d5
NC
982struct xsub_details {
983 const char *name;
984 XSUBADDR_t xsub;
985 const char *proto;
986};
987
a9b7658f 988static const struct xsub_details details[] = {
eff5b9d5
NC
989 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
990 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
991 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
abc6d738
FC
992#define VXS_XSUB_DETAILS
993#include "vxs.inc"
994#undef VXS_XSUB_DETAILS
eff5b9d5
NC
995 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
996 {"utf8::valid", XS_utf8_valid, NULL},
997 {"utf8::encode", XS_utf8_encode, NULL},
998 {"utf8::decode", XS_utf8_decode, NULL},
999 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1000 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1001 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1002 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1003 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1004 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
2b9dd398 1005 {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
eff5b9d5 1006 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
eff5b9d5
NC
1007 {"re::is_regexp", XS_re_is_regexp, "$"},
1008 {"re::regname", XS_re_regname, ";$$"},
1009 {"re::regnames", XS_re_regnames, ";$"},
1010 {"re::regnames_count", XS_re_regnames_count, ""},
1011 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
eff5b9d5
NC
1012};
1013
273e254d
KW
1014STATIC OP*
1015optimize_out_native_convert_function(pTHX_ OP* entersubop,
1016 GV* namegv,
1017 SV* protosv)
1018{
1019 /* Optimizes out an identity function, i.e., one that just returns its
1020 * argument. The passed in function is assumed to be an identity function,
1021 * with no checking. This is designed to be called for utf8_to_native()
1022 * and native_to_utf8() on ASCII platforms, as they just return their
1023 * arguments, but it could work on any such function.
1024 *
1025 * The code is mostly just cargo-culted from Memoize::Lift */
1026
1027 OP *pushop, *argop;
614f287f 1028 OP *parent;
273e254d
KW
1029 SV* prototype = newSVpvs("$");
1030
1031 PERL_UNUSED_ARG(protosv);
1032
1033 assert(entersubop->op_type == OP_ENTERSUB);
1034
1035 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
614f287f 1036 parent = entersubop;
273e254d
KW
1037
1038 SvREFCNT_dec(prototype);
1039
1040 pushop = cUNOPx(entersubop)->op_first;
bac7a184 1041 if (! OpHAS_SIBLING(pushop)) {
614f287f 1042 parent = pushop;
273e254d
KW
1043 pushop = cUNOPx(pushop)->op_first;
1044 }
614f287f 1045 argop = OpSIBLING(pushop);
273e254d
KW
1046
1047 /* Carry on without doing the optimization if it is not something we're
1048 * expecting, so continues to work */
1049 if ( ! argop
bac7a184 1050 || ! OpHAS_SIBLING(argop)
614f287f 1051 || OpHAS_SIBLING(OpSIBLING(argop))
273e254d
KW
1052 ) {
1053 return entersubop;
1054 }
1055
614f287f
DM
1056 /* cut argop from the subtree */
1057 (void)op_sibling_splice(parent, pushop, 1, NULL);
273e254d
KW
1058
1059 op_free(entersubop);
1060 return argop;
1061}
1062
eff5b9d5
NC
1063void
1064Perl_boot_core_UNIVERSAL(pTHX)
1065{
eff5b9d5 1066 static const char file[] = __FILE__;
7a6ecb12 1067 const struct xsub_details *xsub = details;
c3caa5c3 1068 const struct xsub_details *end = C_ARRAY_END(details);
eff5b9d5
NC
1069
1070 do {
1071 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1072 } while (++xsub < end);
1073
273e254d
KW
1074#ifndef EBCDIC
1075 { /* On ASCII platforms these functions just return their argument, so can
1076 be optimized away */
1077
1078 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1079 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1080
1081 cv_set_call_checker(to_native_cv,
1082 optimize_out_native_convert_function,
1083 (SV*) to_native_cv);
1084 cv_set_call_checker(to_unicode_cv,
1085 optimize_out_native_convert_function,
1086 (SV*) to_unicode_cv);
1087 }
1088#endif
1089
eff5b9d5 1090 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
bad4ae38
FC
1091 {
1092 CV * const cv =
1093 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
5513c2cf
DD
1094 char ** cvfile = &CvFILE(cv);
1095 char * oldfile = *cvfile;
bad4ae38 1096 CvDYNFILE_off(cv);
5513c2cf
DD
1097 *cvfile = (char *)file;
1098 Safefree(oldfile);
bad4ae38 1099 }
eff5b9d5 1100}
80305961 1101
241d1a3b 1102/*
14d04a33 1103 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1104 */