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