This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_aassign(): fix ($x,$y) = (undef, $x)
[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
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))) {
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_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
f044d0d1 631XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC
632{
633 dXSARGS;
6867be6d 634
80b6a949 635 if (items != 1 || !SvROK(ST(0)))
afa74d42 636 croak_xs_usage(cv, "hv");
c4420975 637 else {
ef8f7699 638 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
639 hv_clear_placeholders(hv);
640 XSRETURN(0);
641 }
dfd4ef2f 642}
39f7a870 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
241d1a3b 769
15eb3045 770XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
80305961
YO
771XS(XS_re_is_regexp)
772{
80305961 773 dXSARGS;
f7e71195
AB
774 PERL_UNUSED_VAR(cv);
775
80305961 776 if (items != 1)
afa74d42 777 croak_xs_usage(cv, "sv");
f7e71195 778
f7e71195
AB
779 if (SvRXOK(ST(0))) {
780 XSRETURN_YES;
781 } else {
782 XSRETURN_NO;
80305961
YO
783 }
784}
785
15eb3045 786XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
192b9cd1 787XS(XS_re_regnames_count)
80305961 788{
192b9cd1
AB
789 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
790 SV * ret;
80305961 791 dXSARGS;
192b9cd1
AB
792
793 if (items != 0)
afa74d42 794 croak_xs_usage(cv, "");
192b9cd1
AB
795
796 SP -= items;
fdae9473 797 PUTBACK;
192b9cd1
AB
798
799 if (!rx)
800 XSRETURN_UNDEF;
801
802 ret = CALLREG_NAMED_BUFF_COUNT(rx);
803
804 SPAGAIN;
fdae9473
NC
805 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
806 XSRETURN(1);
192b9cd1
AB
807}
808
15eb3045 809XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
192b9cd1
AB
810XS(XS_re_regname)
811{
192b9cd1
AB
812 dXSARGS;
813 REGEXP * rx;
814 U32 flags;
815 SV * ret;
816
28d8d7f4 817 if (items < 1 || items > 2)
afa74d42 818 croak_xs_usage(cv, "name[, all ]");
192b9cd1 819
80305961 820 SP -= items;
fdae9473 821 PUTBACK;
80305961 822
192b9cd1
AB
823 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
824
825 if (!rx)
826 XSRETURN_UNDEF;
827
828 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 829 flags = RXapif_ALL;
192b9cd1 830 } else {
f1b875a0 831 flags = RXapif_ONE;
80305961 832 }
f1b875a0 833 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1 834
fdae9473
NC
835 SPAGAIN;
836 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
837 XSRETURN(1);
80305961
YO
838}
839
192b9cd1 840
15eb3045 841XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
80305961
YO
842XS(XS_re_regnames)
843{
80305961 844 dXSARGS;
192b9cd1
AB
845 REGEXP * rx;
846 U32 flags;
847 SV *ret;
848 AV *av;
c70927a6
FC
849 SSize_t length;
850 SSize_t i;
192b9cd1
AB
851 SV **entry;
852
853 if (items > 1)
afa74d42 854 croak_xs_usage(cv, "[all]");
192b9cd1
AB
855
856 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
857
858 if (!rx)
859 XSRETURN_UNDEF;
860
861 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 862 flags = RXapif_ALL;
192b9cd1 863 } else {
f1b875a0 864 flags = RXapif_ONE;
192b9cd1
AB
865 }
866
80305961 867 SP -= items;
fdae9473 868 PUTBACK;
80305961 869
f1b875a0 870 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
871
872 SPAGAIN;
873
192b9cd1
AB
874 if (!ret)
875 XSRETURN_UNDEF;
876
502c6561 877 av = MUTABLE_AV(SvRV(ret));
b9f2b683 878 length = av_tindex(av);
192b9cd1 879
2102d7a2 880 EXTEND(SP, length+1); /* better extend stack just once */
192b9cd1
AB
881 for (i = 0; i <= length; i++) {
882 entry = av_fetch(av, i, FALSE);
883
884 if (!entry)
885 Perl_croak(aTHX_ "NULL array element in re::regnames()");
886
2102d7a2 887 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 888 }
ec83ea38
MHM
889
890 SvREFCNT_dec(ret);
891
192b9cd1
AB
892 PUTBACK;
893 return;
80305961
YO
894}
895
15eb3045 896XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
192c1e27
JH
897XS(XS_re_regexp_pattern)
898{
192c1e27
JH
899 dXSARGS;
900 REGEXP *re;
de5fee32 901 I32 const gimme = GIMME_V;
192c1e27 902
22d874e2
DD
903 EXTEND(SP, 2);
904 SP -= items;
192c1e27 905 if (items != 1)
afa74d42 906 croak_xs_usage(cv, "sv");
192c1e27 907
192c1e27
JH
908 /*
909 Checks if a reference is a regex or not. If the parameter is
910 not a ref, or is not the result of a qr// then returns false
911 in scalar context and an empty list in list context.
912 Otherwise in list context it returns the pattern and the
913 modifiers, in scalar context it returns the pattern just as it
914 would if the qr// was stringified normally, regardless as
486ec47a 915 to the class of the variable and any stringification overloads
192c1e27
JH
916 on the object.
917 */
918
919 if ((re = SvRX(ST(0)))) /* assign deliberate */
920 {
22c985d5 921 /* Houston, we have a regex! */
192c1e27 922 SV *pattern;
192c1e27 923
b1dcc8e2 924 if ( gimme == G_ARRAY ) {
9de15fec 925 STRLEN left = 0;
a62b1201 926 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
69af1167
SH
927 const char *fptr;
928 char ch;
929 U16 match_flags;
930
192c1e27
JH
931 /*
932 we are in list context so stringify
933 the modifiers that apply. We ignore "negative
a62b1201 934 modifiers" in this scenario, and the default character set
192c1e27
JH
935 */
936
a62b1201
KW
937 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
938 STRLEN len;
939 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
940 &len);
941 Copy(name, reflags + left, len, char);
942 left += len;
9de15fec 943 }
69af1167 944 fptr = INT_PAT_MODS;
73134a2e 945 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
192c1e27
JH
946 >> RXf_PMf_STD_PMMOD_SHIFT);
947
948 while((ch = *fptr++)) {
949 if(match_flags & 1) {
950 reflags[left++] = ch;
951 }
952 match_flags >>= 1;
953 }
954
fb632ce3
NC
955 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
956 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
957
958 /* return the pattern and the modifiers */
2102d7a2
SM
959 PUSHs(pattern);
960 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
961 XSRETURN(2);
962 } else {
963 /* Scalar, so use the string that Perl would return */
33be4c61 964 /* return the pattern in (?msixn:..) format */
192c1e27 965#if PERL_VERSION >= 11
daba3364 966 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 967#else
fb632ce3
NC
968 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
969 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27 970#endif
22d874e2 971 PUSHs(pattern);
192c1e27
JH
972 XSRETURN(1);
973 }
974 } else {
975 /* It ain't a regexp folks */
b1dcc8e2 976 if ( gimme == G_ARRAY ) {
192c1e27 977 /* return the empty list */
7b46bf4c 978 XSRETURN_EMPTY;
192c1e27
JH
979 } else {
980 /* Because of the (?:..) wrapping involved in a
981 stringified pattern it is impossible to get a
982 result for a real regexp that would evaluate to
983 false. Therefore we can return PL_sv_no to signify
984 that the object is not a regex, this means that one
985 can say
986
987 if (regex($might_be_a_regex) eq '(?:foo)') { }
988
989 and not worry about undefined values.
990 */
991 XSRETURN_NO;
992 }
993 }
661d43c4 994 NOT_REACHED; /* NOTREACHED */
192c1e27
JH
995}
996
b7a8ab8f 997#include "vutil.h"
abc6d738
FC
998#include "vxs.inc"
999
eff5b9d5
NC
1000struct xsub_details {
1001 const char *name;
1002 XSUBADDR_t xsub;
1003 const char *proto;
1004};
1005
a9b7658f 1006static const struct xsub_details details[] = {
eff5b9d5
NC
1007 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1008 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1009 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
abc6d738
FC
1010#define VXS_XSUB_DETAILS
1011#include "vxs.inc"
1012#undef VXS_XSUB_DETAILS
eff5b9d5
NC
1013 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1014 {"utf8::valid", XS_utf8_valid, NULL},
1015 {"utf8::encode", XS_utf8_encode, NULL},
1016 {"utf8::decode", XS_utf8_decode, NULL},
1017 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1018 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1019 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1020 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1021 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
2c6c1df5 1022 {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
eff5b9d5
NC
1023 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1024 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1025 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
eff5b9d5
NC
1026 {"re::is_regexp", XS_re_is_regexp, "$"},
1027 {"re::regname", XS_re_regname, ";$$"},
1028 {"re::regnames", XS_re_regnames, ";$"},
1029 {"re::regnames_count", XS_re_regnames_count, ""},
1030 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
eff5b9d5
NC
1031};
1032
273e254d
KW
1033STATIC OP*
1034optimize_out_native_convert_function(pTHX_ OP* entersubop,
1035 GV* namegv,
1036 SV* protosv)
1037{
1038 /* Optimizes out an identity function, i.e., one that just returns its
1039 * argument. The passed in function is assumed to be an identity function,
1040 * with no checking. This is designed to be called for utf8_to_native()
1041 * and native_to_utf8() on ASCII platforms, as they just return their
1042 * arguments, but it could work on any such function.
1043 *
1044 * The code is mostly just cargo-culted from Memoize::Lift */
1045
1046 OP *pushop, *argop;
614f287f 1047 OP *parent;
273e254d
KW
1048 SV* prototype = newSVpvs("$");
1049
1050 PERL_UNUSED_ARG(protosv);
1051
1052 assert(entersubop->op_type == OP_ENTERSUB);
1053
1054 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
614f287f 1055 parent = entersubop;
273e254d
KW
1056
1057 SvREFCNT_dec(prototype);
1058
1059 pushop = cUNOPx(entersubop)->op_first;
bac7a184 1060 if (! OpHAS_SIBLING(pushop)) {
614f287f 1061 parent = pushop;
273e254d
KW
1062 pushop = cUNOPx(pushop)->op_first;
1063 }
614f287f 1064 argop = OpSIBLING(pushop);
273e254d
KW
1065
1066 /* Carry on without doing the optimization if it is not something we're
1067 * expecting, so continues to work */
1068 if ( ! argop
bac7a184 1069 || ! OpHAS_SIBLING(argop)
614f287f 1070 || OpHAS_SIBLING(OpSIBLING(argop))
273e254d
KW
1071 ) {
1072 return entersubop;
1073 }
1074
614f287f
DM
1075 /* cut argop from the subtree */
1076 (void)op_sibling_splice(parent, pushop, 1, NULL);
273e254d
KW
1077
1078 op_free(entersubop);
1079 return argop;
1080}
1081
eff5b9d5
NC
1082void
1083Perl_boot_core_UNIVERSAL(pTHX)
1084{
eff5b9d5 1085 static const char file[] = __FILE__;
7a6ecb12 1086 const struct xsub_details *xsub = details;
c3caa5c3 1087 const struct xsub_details *end = C_ARRAY_END(details);
eff5b9d5
NC
1088
1089 do {
1090 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1091 } while (++xsub < end);
1092
273e254d
KW
1093#ifndef EBCDIC
1094 { /* On ASCII platforms these functions just return their argument, so can
1095 be optimized away */
1096
1097 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1098 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1099
1100 cv_set_call_checker(to_native_cv,
1101 optimize_out_native_convert_function,
1102 (SV*) to_native_cv);
1103 cv_set_call_checker(to_unicode_cv,
1104 optimize_out_native_convert_function,
1105 (SV*) to_unicode_cv);
1106 }
1107#endif
1108
eff5b9d5 1109 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
bad4ae38
FC
1110 {
1111 CV * const cv =
1112 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
5513c2cf
DD
1113 char ** cvfile = &CvFILE(cv);
1114 char * oldfile = *cvfile;
bad4ae38 1115 CvDYNFILE_off(cv);
5513c2cf
DD
1116 *cvfile = (char *)file;
1117 Safefree(oldfile);
bad4ae38 1118 }
eff5b9d5 1119}
80305961 1120
241d1a3b 1121/*
14d04a33 1122 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1123 */