This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/porting/libperl.t: add better dianostics
[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
7fd883b1
DM
187/* a special string address whose value is "isa", but which perl knows
188 * to treat as if it were really "DOES" when printing the method name in
189 * the "Can't call method '%s'" error message */
9a70c74b
DM
190char PL_isa_DOES[] = "isa";
191
cbc021f9 192bool
f778bcfd 193Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
cbc021f9 194{
f778bcfd 195 SV *classname;
cbc021f9 196 bool does_it;
59e7186f 197 SV *methodname;
cbc021f9 198 dSP;
7918f24d 199
f778bcfd
BF
200 PERL_ARGS_ASSERT_SV_DOES_SV;
201 PERL_UNUSED_ARG(flags);
7918f24d 202
cbc021f9 203 ENTER;
204 SAVETMPS;
205
206 SvGETMAGIC(sv);
207
d96ab1b5 208 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
7ce46f2a 209 LEAVE;
cbc021f9 210 return FALSE;
7ce46f2a 211 }
cbc021f9 212
4b523e79 213 if (SvROK(sv) && SvOBJECT(SvRV(sv))) {
f778bcfd 214 classname = sv_ref(NULL,SvRV(sv),TRUE);
cbc021f9 215 } else {
f778bcfd 216 classname = sv;
cbc021f9 217 }
218
f778bcfd 219 if (sv_eq(classname, namesv)) {
7ce46f2a 220 LEAVE;
cbc021f9 221 return TRUE;
7ce46f2a 222 }
cbc021f9 223
224 PUSHMARK(SP);
f778bcfd
BF
225 EXTEND(SP, 2);
226 PUSHs(sv);
227 PUSHs(namesv);
cbc021f9 228 PUTBACK;
229
9a70c74b 230 /* create a PV with value "isa", but with a special address
7fd883b1 231 * so that perl knows we're really doing "DOES" instead */
9a70c74b
DM
232 methodname = newSV_type(SVt_PV);
233 SvLEN(methodname) = 0;
234 SvCUR(methodname) = strlen(PL_isa_DOES);
235 SvPVX(methodname) = PL_isa_DOES;
236 SvPOK_on(methodname);
237 sv_2mortal(methodname);
59e7186f 238 call_sv(methodname, G_SCALAR | G_METHOD);
cbc021f9 239 SPAGAIN;
240
241 does_it = SvTRUE( TOPs );
242 FREETMPS;
243 LEAVE;
244
245 return does_it;
246}
247
afa74d42 248/*
f778bcfd
BF
249=for apidoc sv_does
250
d20c2c29 251Like L</sv_does_pv>, but doesn't take a C<flags> parameter.
f778bcfd
BF
252
253=cut
254*/
255
256bool
257Perl_sv_does(pTHX_ SV *sv, const char *const name)
258{
259 PERL_ARGS_ASSERT_SV_DOES;
260 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
261}
262
263/*
264=for apidoc sv_does_pv
265
7d892b8c 266Like L</sv_does_sv>, but takes a nul-terminated string instead of an SV.
f778bcfd
BF
267
268=cut
269*/
270
271
272bool
273Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
274{
275 PERL_ARGS_ASSERT_SV_DOES_PV;
276 return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
277}
278
7d892b8c
FC
279/*
280=for apidoc sv_does_pvn
281
282Like L</sv_does_sv>, but takes a string/length pair instead of an SV.
283
284=cut
285*/
286
f778bcfd
BF
287bool
288Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
289{
290 PERL_ARGS_ASSERT_SV_DOES_PVN;
291
292 return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
293}
294
295/*
afa74d42
NC
296=for apidoc croak_xs_usage
297
298A specialised variant of C<croak()> for emitting the usage message for xsubs
299
300 croak_xs_usage(cv, "eee_yow");
301
302works out the package name and subroutine name from C<cv>, and then calls
72d33970 303C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
afa74d42 304
147e3846 305 Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk",
8560fbdd 306 "eee_yow");
afa74d42
NC
307
308=cut
309*/
310
311void
cb077ed2 312Perl_croak_xs_usage(const CV *const cv, const char *const params)
afa74d42 313{
ae77754a 314 /* Avoid CvGV as it requires aTHX. */
2eaf799e 315 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
afa74d42
NC
316
317 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
318
2eaf799e 319 if (gv) got_gv: {
afa74d42 320 const HV *const stash = GvSTASH(gv);
afa74d42 321
58cb15b3 322 if (HvNAME_get(stash))
d3ee9aa5 323 /* diag_listed_as: SKIPME */
147e3846 324 Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)",
d0c0e7dd
FC
325 HEKfARG(HvNAME_HEK(stash)),
326 HEKfARG(GvNAME_HEK(gv)),
58cb15b3 327 params);
afa74d42 328 else
d3ee9aa5 329 /* diag_listed_as: SKIPME */
147e3846 330 Perl_croak_nocontext("Usage: %" HEKf "(%s)",
d0c0e7dd 331 HEKfARG(GvNAME_HEK(gv)), params);
afa74d42 332 } else {
2eaf799e
FC
333 dTHX;
334 if ((gv = CvGV(cv))) goto got_gv;
335
afa74d42 336 /* Pants. I don't think that it should be possible to get here. */
d3ee9aa5 337 /* diag_listed_as: SKIPME */
147e3846 338 Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
afa74d42
NC
339 }
340}
55497cff 341
15eb3045 342XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
6d4a7be2
PP
343XS(XS_UNIVERSAL_isa)
344{
345 dXSARGS;
6d4a7be2
PP
346
347 if (items != 2)
afa74d42 348 croak_xs_usage(cv, "reference, kind");
c4420975
AL
349 else {
350 SV * const sv = ST(0);
6d4a7be2 351
c4420975 352 SvGETMAGIC(sv);
d3f7f2b2 353
d96ab1b5 354 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
c4420975 355 XSRETURN_UNDEF;
f8f70380 356
c7abbf64 357 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
c4420975
AL
358 XSRETURN(1);
359 }
6d4a7be2
PP
360}
361
15eb3045 362XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
6d4a7be2
PP
363XS(XS_UNIVERSAL_can)
364{
365 dXSARGS;
366 SV *sv;
6d4a7be2 367 SV *rv;
6f08146e 368 HV *pkg = NULL;
2bde9ae6 369 GV *iogv;
6d4a7be2
PP
370
371 if (items != 2)
afa74d42 372 croak_xs_usage(cv, "object-ref, method");
6d4a7be2
PP
373
374 sv = ST(0);
f8f70380 375
5b295bef 376 SvGETMAGIC(sv);
d3f7f2b2 377
4178f891
FC
378 /* Reject undef and empty string. Note that the string form takes
379 precedence here over the numeric form, as (!1)->foo treats the
380 invocant as the empty string, though it is a dualvar. */
381 if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv)))
f8f70380
GS
382 XSRETURN_UNDEF;
383
3280af22 384 rv = &PL_sv_undef;
6d4a7be2 385
46e4b22b 386 if (SvROK(sv)) {
daba3364 387 sv = MUTABLE_SV(SvRV(sv));
46e4b22b 388 if (SvOBJECT(sv))
6f08146e 389 pkg = SvSTASH(sv);
4178f891
FC
390 else if (isGV_with_GP(sv) && GvIO(sv))
391 pkg = SvSTASH(GvIO(sv));
6f08146e 392 }
4178f891
FC
393 else if (isGV_with_GP(sv) && GvIO(sv))
394 pkg = SvSTASH(GvIO(sv));
2bde9ae6
FC
395 else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv))
396 pkg = SvSTASH(GvIO(iogv));
6f08146e 397 else {
da51bb9b 398 pkg = gv_stashsv(sv, 0);
68b40612 399 if (!pkg)
7d59d161 400 pkg = gv_stashpvs("UNIVERSAL", 0);
6f08146e
NIS
401 }
402
403 if (pkg) {
a00b390b 404 GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0);
dc848c6f 405 if (gv && isGV(gv))
daba3364 406 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
6d4a7be2
PP
407 }
408
409 ST(0) = rv;
410 XSRETURN(1);
411}
412
15eb3045 413XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
cbc021f9 414XS(XS_UNIVERSAL_DOES)
415{
cbc021f9 416 dXSARGS;
58c0efa5 417 PERL_UNUSED_ARG(cv);
cbc021f9 418
419 if (items != 2)
46404226 420 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
cbc021f9 421 else {
422 SV * const sv = ST(0);
f778bcfd 423 if (sv_does_sv( sv, ST(1), 0 ))
cbc021f9 424 XSRETURN_YES;
425
426 XSRETURN_NO;
427 }
428}
429
15eb3045 430XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
8800c35a
JH
431XS(XS_utf8_is_utf8)
432{
41be1fbd
JH
433 dXSARGS;
434 if (items != 1)
afa74d42 435 croak_xs_usage(cv, "sv");
c4420975 436 else {
76f73021 437 SV * const sv = ST(0);
438 SvGETMAGIC(sv);
c4420975
AL
439 if (SvUTF8(sv))
440 XSRETURN_YES;
441 else
442 XSRETURN_NO;
41be1fbd
JH
443 }
444 XSRETURN_EMPTY;
8800c35a
JH
445}
446
15eb3045 447XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
448XS(XS_utf8_valid)
449{
41be1fbd
JH
450 dXSARGS;
451 if (items != 1)
afa74d42 452 croak_xs_usage(cv, "sv");
c4420975
AL
453 else {
454 SV * const sv = ST(0);
455 STRLEN len;
456 const char * const s = SvPV_const(sv,len);
457 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
458 XSRETURN_YES;
459 else
460 XSRETURN_NO;
461 }
41be1fbd 462 XSRETURN_EMPTY;
1b026014
NIS
463}
464
15eb3045 465XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
466XS(XS_utf8_encode)
467{
468 dXSARGS;
469 if (items != 1)
afa74d42 470 croak_xs_usage(cv, "sv");
c4420975 471 sv_utf8_encode(ST(0));
892f9127 472 SvSETMAGIC(ST(0));
1b026014
NIS
473 XSRETURN_EMPTY;
474}
475
15eb3045 476XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
477XS(XS_utf8_decode)
478{
479 dXSARGS;
480 if (items != 1)
afa74d42 481 croak_xs_usage(cv, "sv");
c4420975
AL
482 else {
483 SV * const sv = ST(0);
b2b7346b 484 bool RETVAL;
c7102404 485 SvPV_force_nolen(sv);
b2b7346b 486 RETVAL = sv_utf8_decode(sv);
77fc86ef 487 SvSETMAGIC(sv);
1b026014 488 ST(0) = boolSV(RETVAL);
1b026014
NIS
489 }
490 XSRETURN(1);
491}
492
15eb3045 493XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
494XS(XS_utf8_upgrade)
495{
496 dXSARGS;
497 if (items != 1)
afa74d42 498 croak_xs_usage(cv, "sv");
c4420975
AL
499 else {
500 SV * const sv = ST(0);
1b026014
NIS
501 STRLEN RETVAL;
502 dXSTARG;
503
504 RETVAL = sv_utf8_upgrade(sv);
505 XSprePUSH; PUSHi((IV)RETVAL);
506 }
507 XSRETURN(1);
508}
509
15eb3045 510XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
511XS(XS_utf8_downgrade)
512{
513 dXSARGS;
514 if (items < 1 || items > 2)
afa74d42 515 croak_xs_usage(cv, "sv, failok=0");
c4420975
AL
516 else {
517 SV * const sv = ST(0);
3ca75eca 518 const bool failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0;
6867be6d 519 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 520
1b026014 521 ST(0) = boolSV(RETVAL);
1b026014
NIS
522 }
523 XSRETURN(1);
524}
525
15eb3045 526XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
527XS(XS_utf8_native_to_unicode)
528{
529 dXSARGS;
6867be6d 530 const UV uv = SvUV(ST(0));
b7953727
JH
531
532 if (items > 1)
afa74d42 533 croak_xs_usage(cv, "sv");
b7953727 534
b5804ad6 535 ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv)));
1b026014
NIS
536 XSRETURN(1);
537}
538
15eb3045 539XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
540XS(XS_utf8_unicode_to_native)
541{
542 dXSARGS;
6867be6d 543 const UV uv = SvUV(ST(0));
b7953727
JH
544
545 if (items > 1)
afa74d42 546 croak_xs_usage(cv, "sv");
b7953727 547
b5804ad6 548 ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv)));
1b026014
NIS
549 XSRETURN(1);
550}
551
15eb3045 552XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
14a976d6 553XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH
554{
555 dXSARGS;
80b6a949
AB
556 SV * const svz = ST(0);
557 SV * sv;
6867be6d 558
80b6a949
AB
559 /* [perl #77776] - called as &foo() not foo() */
560 if (!SvROK(svz))
561 croak_xs_usage(cv, "SCALAR[, ON]");
562
563 sv = SvRV(svz);
564
29569577 565 if (items == 1) {
1620522e 566 if (SvREADONLY(sv))
29569577
JH
567 XSRETURN_YES;
568 else
569 XSRETURN_NO;
570 }
571 else if (items == 2) {
572 if (SvTRUE(ST(1))) {
a623f893 573 SvFLAGS(sv) |= SVf_READONLY;
29569577
JH
574 XSRETURN_YES;
575 }
576 else {
14a976d6 577 /* I hope you really know what you are doing. */
a623f893 578 SvFLAGS(sv) &=~ SVf_READONLY;
29569577
JH
579 XSRETURN_NO;
580 }
581 }
14a976d6 582 XSRETURN_UNDEF; /* Can't happen. */
29569577 583}
2c6c1df5 584
15eb3045 585XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
2c6c1df5
FC
586XS(XS_constant__make_const) /* This is dangerous stuff. */
587{
2c6c1df5
FC
588 dXSARGS;
589 SV * const svz = ST(0);
590 SV * sv;
2c6c1df5
FC
591
592 /* [perl #77776] - called as &foo() not foo() */
593 if (!SvROK(svz) || items != 1)
594 croak_xs_usage(cv, "SCALAR");
595
596 sv = SvRV(svz);
597
2c6c1df5
FC
598 SvREADONLY_on(sv);
599 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
600 /* for constant.pm; nobody else should be calling this
601 on arrays anyway. */
602 SV **svp;
603 for (svp = AvARRAY(sv) + AvFILLp(sv)
604 ; svp >= AvARRAY(sv)
605 ; --svp)
606 if (*svp) SvPADTMP_on(*svp);
607 }
608 XSRETURN(0);
609}
610
15eb3045 611XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
14a976d6 612XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
613{
614 dXSARGS;
80b6a949
AB
615 SV * const svz = ST(0);
616 SV * sv;
fa3febb6 617 U32 refcnt;
6867be6d 618
80b6a949 619 /* [perl #77776] - called as &foo() not foo() */
fa3febb6 620 if ((items != 1 && items != 2) || !SvROK(svz))
80b6a949
AB
621 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
622
623 sv = SvRV(svz);
624
14a976d6 625 /* I hope you really know what you are doing. */
fa3febb6
DD
626 /* idea is for SvREFCNT(sv) to be accessed only once */
627 refcnt = items == 2 ?
628 /* we free one ref on exit */
629 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
630 : SvREFCNT(sv);
631 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
632
29569577
JH
633}
634
e312a16a
YO
635XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
636XS(XS_Internals_hv_clear_placehold)
637{
638 dXSARGS;
639
640 if (items != 1 || !SvROK(ST(0)))
641 croak_xs_usage(cv, "hv");
642 else {
643 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
644 hv_clear_placeholders(hv);
645 XSRETURN(0);
646 }
647}
648
15eb3045 649XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
39f7a870
JH
650XS(XS_PerlIO_get_layers)
651{
652 dXSARGS;
653 if (items < 1 || items % 2 == 0)
afa74d42 654 croak_xs_usage(cv, "filehandle[,args]");
97cb92d6 655#if defined(USE_PERLIO)
39f7a870
JH
656 {
657 SV * sv;
658 GV * gv;
659 IO * io;
660 bool input = TRUE;
661 bool details = FALSE;
662
663 if (items > 1) {
c4420975 664 SV * const *svp;
39f7a870 665 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
666 SV * const * const varp = svp;
667 SV * const * const valp = svp + 1;
39f7a870 668 STRLEN klen;
c4420975 669 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
670
671 switch (*key) {
672 case 'i':
fd9f609b 673 if (memEQs(key, klen, "input")) {
39f7a870
JH
674 input = SvTRUE(*valp);
675 break;
676 }
677 goto fail;
678 case 'o':
fd9f609b 679 if (memEQs(key, klen, "output")) {
39f7a870
JH
680 input = !SvTRUE(*valp);
681 break;
682 }
683 goto fail;
684 case 'd':
fd9f609b 685 if (memEQs(key, klen, "details")) {
39f7a870
JH
686 details = SvTRUE(*valp);
687 break;
688 }
689 goto fail;
690 default:
691 fail:
692 Perl_croak(aTHX_
693 "get_layers: unknown argument '%s'",
694 key);
695 }
696 }
697
698 SP -= (items - 1);
699 }
700
701 sv = POPs;
7f9aa7d3 702 gv = MAYBE_DEREF_GV(sv);
39f7a870 703
3825652d 704 if (!gv && !SvROK(sv))
7f9aa7d3 705 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
39f7a870
JH
706
707 if (gv && (io = GvIO(gv))) {
c4420975 708 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870 709 IoIFP(io) : IoOFP(io));
c70927a6 710 SSize_t i;
b9f2b683 711 const SSize_t last = av_tindex(av);
c70927a6 712 SSize_t nitem = 0;
39f7a870
JH
713
714 for (i = last; i >= 0; i -= 3) {
c4420975
AL
715 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
716 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
717 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 718
c4420975
AL
719 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
720 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
721 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870 722
2102d7a2 723 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
39f7a870 724 if (details) {
92e45a3e
NC
725 /* Indents of 5? Yuck. */
726 /* We know that PerlIO_get_layers creates a new SV for
727 the name and flags, so we can just take a reference
728 and "steal" it when we free the AV below. */
2102d7a2 729 PUSHs(namok
92e45a3e 730 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e 731 : &PL_sv_undef);
2102d7a2 732 PUSHs(argok
92e45a3e
NC
733 ? newSVpvn_flags(SvPVX_const(*argsvp),
734 SvCUR(*argsvp),
735 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
736 | SVs_TEMP)
737 : &PL_sv_undef);
2102d7a2 738 PUSHs(flgok
92e45a3e 739 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 740 : &PL_sv_undef);
39f7a870
JH
741 nitem += 3;
742 }
743 else {
744 if (namok && argok)
147e3846 745 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
be2597df 746 SVfARG(*namsvp),
1eb9e81d 747 SVfARG(*argsvp))));
39f7a870 748 else if (namok)
2102d7a2 749 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870 750 else
2102d7a2 751 PUSHs(&PL_sv_undef);
39f7a870
JH
752 nitem++;
753 if (flgok) {
c4420975 754 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
755
756 if (flags & PERLIO_F_UTF8) {
2102d7a2 757 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
758 nitem++;
759 }
760 }
761 }
762 }
763
764 SvREFCNT_dec(av);
765
766 XSRETURN(nitem);
767 }
768 }
5fef3b4a 769#endif
39f7a870
JH
770
771 XSRETURN(0);
772}
773
15eb3045 774XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
80305961
YO
775XS(XS_re_is_regexp)
776{
80305961 777 dXSARGS;
f7e71195 778
80305961 779 if (items != 1)
afa74d42 780 croak_xs_usage(cv, "sv");
f7e71195 781
f7e71195
AB
782 if (SvRXOK(ST(0))) {
783 XSRETURN_YES;
784 } else {
785 XSRETURN_NO;
80305961
YO
786 }
787}
788
15eb3045 789XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
192b9cd1 790XS(XS_re_regnames_count)
80305961 791{
192b9cd1
AB
792 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
793 SV * ret;
80305961 794 dXSARGS;
192b9cd1
AB
795
796 if (items != 0)
afa74d42 797 croak_xs_usage(cv, "");
192b9cd1 798
192b9cd1
AB
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;
1c23e2bd 901 U8 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 */
daba3364 965 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
22d874e2 966 PUSHs(pattern);
192c1e27
JH
967 XSRETURN(1);
968 }
969 } else {
970 /* It ain't a regexp folks */
b1dcc8e2 971 if ( gimme == G_ARRAY ) {
192c1e27 972 /* return the empty list */
7b46bf4c 973 XSRETURN_EMPTY;
192c1e27
JH
974 } else {
975 /* Because of the (?:..) wrapping involved in a
976 stringified pattern it is impossible to get a
977 result for a real regexp that would evaluate to
978 false. Therefore we can return PL_sv_no to signify
979 that the object is not a regex, this means that one
980 can say
981
982 if (regex($might_be_a_regex) eq '(?:foo)') { }
983
984 and not worry about undefined values.
985 */
986 XSRETURN_NO;
987 }
988 }
661d43c4 989 NOT_REACHED; /* NOTREACHED */
192c1e27
JH
990}
991
b7a8ab8f 992#include "vutil.h"
abc6d738
FC
993#include "vxs.inc"
994
eff5b9d5
NC
995struct xsub_details {
996 const char *name;
997 XSUBADDR_t xsub;
998 const char *proto;
999};
1000
a9b7658f 1001static const struct xsub_details details[] = {
eff5b9d5
NC
1002 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1003 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1004 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
abc6d738
FC
1005#define VXS_XSUB_DETAILS
1006#include "vxs.inc"
1007#undef VXS_XSUB_DETAILS
eff5b9d5
NC
1008 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1009 {"utf8::valid", XS_utf8_valid, NULL},
1010 {"utf8::encode", XS_utf8_encode, NULL},
1011 {"utf8::decode", XS_utf8_decode, NULL},
1012 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1013 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1014 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1015 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1016 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1017 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
e312a16a 1018 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
2b9dd398 1019 {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
eff5b9d5 1020 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
eff5b9d5
NC
1021 {"re::is_regexp", XS_re_is_regexp, "$"},
1022 {"re::regname", XS_re_regname, ";$$"},
1023 {"re::regnames", XS_re_regnames, ";$"},
1024 {"re::regnames_count", XS_re_regnames_count, ""},
1025 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
eff5b9d5
NC
1026};
1027
273e254d
KW
1028STATIC OP*
1029optimize_out_native_convert_function(pTHX_ OP* entersubop,
1030 GV* namegv,
1031 SV* protosv)
1032{
1033 /* Optimizes out an identity function, i.e., one that just returns its
1034 * argument. The passed in function is assumed to be an identity function,
1035 * with no checking. This is designed to be called for utf8_to_native()
1036 * and native_to_utf8() on ASCII platforms, as they just return their
1037 * arguments, but it could work on any such function.
1038 *
1039 * The code is mostly just cargo-culted from Memoize::Lift */
1040
1041 OP *pushop, *argop;
614f287f 1042 OP *parent;
273e254d
KW
1043 SV* prototype = newSVpvs("$");
1044
1045 PERL_UNUSED_ARG(protosv);
1046
1047 assert(entersubop->op_type == OP_ENTERSUB);
1048
1049 entersubop = ck_entersub_args_proto(entersubop, namegv, prototype);
614f287f 1050 parent = entersubop;
273e254d
KW
1051
1052 SvREFCNT_dec(prototype);
1053
1054 pushop = cUNOPx(entersubop)->op_first;
bac7a184 1055 if (! OpHAS_SIBLING(pushop)) {
614f287f 1056 parent = pushop;
273e254d
KW
1057 pushop = cUNOPx(pushop)->op_first;
1058 }
614f287f 1059 argop = OpSIBLING(pushop);
273e254d
KW
1060
1061 /* Carry on without doing the optimization if it is not something we're
1062 * expecting, so continues to work */
1063 if ( ! argop
bac7a184 1064 || ! OpHAS_SIBLING(argop)
614f287f 1065 || OpHAS_SIBLING(OpSIBLING(argop))
273e254d
KW
1066 ) {
1067 return entersubop;
1068 }
1069
614f287f
DM
1070 /* cut argop from the subtree */
1071 (void)op_sibling_splice(parent, pushop, 1, NULL);
273e254d
KW
1072
1073 op_free(entersubop);
1074 return argop;
1075}
1076
eff5b9d5
NC
1077void
1078Perl_boot_core_UNIVERSAL(pTHX)
1079{
eff5b9d5 1080 static const char file[] = __FILE__;
7a6ecb12 1081 const struct xsub_details *xsub = details;
c3caa5c3 1082 const struct xsub_details *end = C_ARRAY_END(details);
eff5b9d5
NC
1083
1084 do {
1085 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1086 } while (++xsub < end);
1087
273e254d
KW
1088#ifndef EBCDIC
1089 { /* On ASCII platforms these functions just return their argument, so can
1090 be optimized away */
1091
1092 CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
1093 CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
1094
1095 cv_set_call_checker(to_native_cv,
1096 optimize_out_native_convert_function,
1097 (SV*) to_native_cv);
1098 cv_set_call_checker(to_unicode_cv,
1099 optimize_out_native_convert_function,
1100 (SV*) to_unicode_cv);
1101 }
1102#endif
1103
eff5b9d5 1104 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
bad4ae38
FC
1105 {
1106 CV * const cv =
1107 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
5513c2cf
DD
1108 char ** cvfile = &CvFILE(cv);
1109 char * oldfile = *cvfile;
bad4ae38 1110 CvDYNFILE_off(cv);
5513c2cf
DD
1111 *cvfile = (char *)file;
1112 Safefree(oldfile);
bad4ae38 1113 }
eff5b9d5 1114}
80305961 1115
241d1a3b 1116/*
14d04a33 1117 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1118 */