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