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