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