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