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