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