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