This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add xs_handshake API
[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 305 /* Avoid CvGV as it requires aTHX. */
2eaf799e 306 const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
afa74d42
NC
307
308 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
309
2eaf799e 310 if (gv) got_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 323 } else {
2eaf799e
FC
324 dTHX;
325 if ((gv = CvGV(cv))) goto got_gv;
326
afa74d42 327 /* Pants. I don't think that it should be possible to get here. */
d3ee9aa5 328 /* diag_listed_as: SKIPME */
6e9fdf66 329 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
afa74d42
NC
330 }
331}
55497cff 332
15eb3045 333XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
6d4a7be2
PP
334XS(XS_UNIVERSAL_isa)
335{
336 dXSARGS;
6d4a7be2
PP
337
338 if (items != 2)
afa74d42 339 croak_xs_usage(cv, "reference, kind");
c4420975
AL
340 else {
341 SV * const sv = ST(0);
6d4a7be2 342
c4420975 343 SvGETMAGIC(sv);
d3f7f2b2 344
d96ab1b5 345 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
c4420975 346 XSRETURN_UNDEF;
f8f70380 347
c7abbf64 348 ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
c4420975
AL
349 XSRETURN(1);
350 }
6d4a7be2
PP
351}
352
15eb3045 353XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
6d4a7be2
PP
354XS(XS_UNIVERSAL_can)
355{
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 390 if (!pkg)
7d59d161 391 pkg = gv_stashpvs("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{
cbc021f9 407 dXSARGS;
58c0efa5 408 PERL_UNUSED_ARG(cv);
cbc021f9 409
410 if (items != 2)
46404226 411 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
cbc021f9 412 else {
413 SV * const sv = ST(0);
f778bcfd 414 if (sv_does_sv( sv, ST(1), 0 ))
cbc021f9 415 XSRETURN_YES;
416
417 XSRETURN_NO;
418 }
419}
420
15eb3045 421XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */
8800c35a
JH
422XS(XS_utf8_is_utf8)
423{
41be1fbd
JH
424 dXSARGS;
425 if (items != 1)
afa74d42 426 croak_xs_usage(cv, "sv");
c4420975 427 else {
76f73021 428 SV * const sv = ST(0);
429 SvGETMAGIC(sv);
c4420975
AL
430 if (SvUTF8(sv))
431 XSRETURN_YES;
432 else
433 XSRETURN_NO;
41be1fbd
JH
434 }
435 XSRETURN_EMPTY;
8800c35a
JH
436}
437
15eb3045 438XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
439XS(XS_utf8_valid)
440{
41be1fbd
JH
441 dXSARGS;
442 if (items != 1)
afa74d42 443 croak_xs_usage(cv, "sv");
c4420975
AL
444 else {
445 SV * const sv = ST(0);
446 STRLEN len;
447 const char * const s = SvPV_const(sv,len);
448 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
449 XSRETURN_YES;
450 else
451 XSRETURN_NO;
452 }
41be1fbd 453 XSRETURN_EMPTY;
1b026014
NIS
454}
455
15eb3045 456XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
457XS(XS_utf8_encode)
458{
459 dXSARGS;
460 if (items != 1)
afa74d42 461 croak_xs_usage(cv, "sv");
c4420975 462 sv_utf8_encode(ST(0));
892f9127 463 SvSETMAGIC(ST(0));
1b026014
NIS
464 XSRETURN_EMPTY;
465}
466
15eb3045 467XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
468XS(XS_utf8_decode)
469{
470 dXSARGS;
471 if (items != 1)
afa74d42 472 croak_xs_usage(cv, "sv");
c4420975
AL
473 else {
474 SV * const sv = ST(0);
b2b7346b 475 bool RETVAL;
c7102404 476 SvPV_force_nolen(sv);
b2b7346b 477 RETVAL = sv_utf8_decode(sv);
77fc86ef 478 SvSETMAGIC(sv);
1b026014 479 ST(0) = boolSV(RETVAL);
1b026014
NIS
480 }
481 XSRETURN(1);
482}
483
15eb3045 484XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
485XS(XS_utf8_upgrade)
486{
487 dXSARGS;
488 if (items != 1)
afa74d42 489 croak_xs_usage(cv, "sv");
c4420975
AL
490 else {
491 SV * const sv = ST(0);
1b026014
NIS
492 STRLEN RETVAL;
493 dXSTARG;
494
495 RETVAL = sv_utf8_upgrade(sv);
496 XSprePUSH; PUSHi((IV)RETVAL);
497 }
498 XSRETURN(1);
499}
500
15eb3045 501XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
502XS(XS_utf8_downgrade)
503{
504 dXSARGS;
505 if (items < 1 || items > 2)
afa74d42 506 croak_xs_usage(cv, "sv, failok=0");
c4420975
AL
507 else {
508 SV * const sv = ST(0);
3ca75eca 509 const bool failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0;
6867be6d 510 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 511
1b026014 512 ST(0) = boolSV(RETVAL);
1b026014
NIS
513 }
514 XSRETURN(1);
515}
516
15eb3045 517XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
518XS(XS_utf8_native_to_unicode)
519{
520 dXSARGS;
6867be6d 521 const UV uv = SvUV(ST(0));
b7953727
JH
522
523 if (items > 1)
afa74d42 524 croak_xs_usage(cv, "sv");
b7953727 525
1b026014
NIS
526 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
527 XSRETURN(1);
528}
529
15eb3045 530XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */
1b026014
NIS
531XS(XS_utf8_unicode_to_native)
532{
533 dXSARGS;
6867be6d 534 const UV uv = SvUV(ST(0));
b7953727
JH
535
536 if (items > 1)
afa74d42 537 croak_xs_usage(cv, "sv");
b7953727 538
1b026014
NIS
539 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
540 XSRETURN(1);
541}
542
15eb3045 543XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */
14a976d6 544XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH
545{
546 dXSARGS;
80b6a949
AB
547 SV * const svz = ST(0);
548 SV * sv;
58c0efa5 549 PERL_UNUSED_ARG(cv);
6867be6d 550
80b6a949
AB
551 /* [perl #77776] - called as &foo() not foo() */
552 if (!SvROK(svz))
553 croak_xs_usage(cv, "SCALAR[, ON]");
554
555 sv = SvRV(svz);
556
29569577 557 if (items == 1) {
1620522e 558 if (SvREADONLY(sv))
29569577
JH
559 XSRETURN_YES;
560 else
561 XSRETURN_NO;
562 }
563 else if (items == 2) {
564 if (SvTRUE(ST(1))) {
1620522e 565#ifdef PERL_OLD_COPY_ON_WRITE
3e89ba19 566 if (SvIsCOW(sv)) sv_force_normal(sv);
1620522e 567#endif
a623f893 568 SvFLAGS(sv) |= SVf_READONLY;
29569577
JH
569 XSRETURN_YES;
570 }
571 else {
14a976d6 572 /* I hope you really know what you are doing. */
a623f893 573 SvFLAGS(sv) &=~ SVf_READONLY;
29569577
JH
574 XSRETURN_NO;
575 }
576 }
14a976d6 577 XSRETURN_UNDEF; /* Can't happen. */
29569577 578}
2c6c1df5 579
15eb3045 580XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */
2c6c1df5
FC
581XS(XS_constant__make_const) /* This is dangerous stuff. */
582{
2c6c1df5
FC
583 dXSARGS;
584 SV * const svz = ST(0);
585 SV * sv;
586 PERL_UNUSED_ARG(cv);
587
588 /* [perl #77776] - called as &foo() not foo() */
589 if (!SvROK(svz) || items != 1)
590 croak_xs_usage(cv, "SCALAR");
591
592 sv = SvRV(svz);
593
594#ifdef PERL_OLD_COPY_ON_WRITE
595 if (SvIsCOW(sv)) sv_force_normal(sv);
596#endif
597 SvREADONLY_on(sv);
598 if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) {
599 /* for constant.pm; nobody else should be calling this
600 on arrays anyway. */
601 SV **svp;
602 for (svp = AvARRAY(sv) + AvFILLp(sv)
603 ; svp >= AvARRAY(sv)
604 ; --svp)
605 if (*svp) SvPADTMP_on(*svp);
606 }
607 XSRETURN(0);
608}
609
15eb3045 610XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */
14a976d6 611XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
612{
613 dXSARGS;
80b6a949
AB
614 SV * const svz = ST(0);
615 SV * sv;
fa3febb6 616 U32 refcnt;
58c0efa5 617 PERL_UNUSED_ARG(cv);
6867be6d 618
80b6a949 619 /* [perl #77776] - called as &foo() not foo() */
fa3febb6 620 if ((items != 1 && items != 2) || !SvROK(svz))
80b6a949
AB
621 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
622
623 sv = SvRV(svz);
624
14a976d6 625 /* I hope you really know what you are doing. */
fa3febb6
DD
626 /* idea is for SvREFCNT(sv) to be accessed only once */
627 refcnt = items == 2 ?
628 /* we free one ref on exit */
629 (SvREFCNT(sv) = SvUV(ST(1)) + 1)
630 : SvREFCNT(sv);
631 XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */
632
29569577
JH
633}
634
15eb3045 635XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */
f044d0d1 636XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC
637{
638 dXSARGS;
6867be6d 639
80b6a949 640 if (items != 1 || !SvROK(ST(0)))
afa74d42 641 croak_xs_usage(cv, "hv");
c4420975 642 else {
ef8f7699 643 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
644 hv_clear_placeholders(hv);
645 XSRETURN(0);
646 }
dfd4ef2f 647}
39f7a870 648
15eb3045 649XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */
39f7a870
JH
650XS(XS_PerlIO_get_layers)
651{
652 dXSARGS;
653 if (items < 1 || items % 2 == 0)
afa74d42 654 croak_xs_usage(cv, "filehandle[,args]");
97cb92d6 655#if defined(USE_PERLIO)
39f7a870
JH
656 {
657 SV * sv;
658 GV * gv;
659 IO * io;
660 bool input = TRUE;
661 bool details = FALSE;
662
663 if (items > 1) {
c4420975 664 SV * const *svp;
39f7a870 665 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
666 SV * const * const varp = svp;
667 SV * const * const valp = svp + 1;
39f7a870 668 STRLEN klen;
c4420975 669 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
670
671 switch (*key) {
672 case 'i':
673 if (klen == 5 && memEQ(key, "input", 5)) {
674 input = SvTRUE(*valp);
675 break;
676 }
677 goto fail;
678 case 'o':
679 if (klen == 6 && memEQ(key, "output", 6)) {
680 input = !SvTRUE(*valp);
681 break;
682 }
683 goto fail;
684 case 'd':
685 if (klen == 7 && memEQ(key, "details", 7)) {
686 details = SvTRUE(*valp);
687 break;
688 }
689 goto fail;
690 default:
691 fail:
692 Perl_croak(aTHX_
693 "get_layers: unknown argument '%s'",
694 key);
695 }
696 }
697
698 SP -= (items - 1);
699 }
700
701 sv = POPs;
7f9aa7d3 702 gv = MAYBE_DEREF_GV(sv);
39f7a870 703
3825652d 704 if (!gv && !SvROK(sv))
7f9aa7d3 705 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
39f7a870
JH
706
707 if (gv && (io = GvIO(gv))) {
c4420975 708 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870 709 IoIFP(io) : IoOFP(io));
c70927a6 710 SSize_t i;
b9f2b683 711 const SSize_t last = av_tindex(av);
c70927a6 712 SSize_t nitem = 0;
39f7a870
JH
713
714 for (i = last; i >= 0; i -= 3) {
c4420975
AL
715 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
716 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
717 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 718
c4420975
AL
719 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
720 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
721 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870 722
2102d7a2 723 EXTEND(SP, 3); /* Three is the max in all branches: better check just once */
39f7a870 724 if (details) {
92e45a3e
NC
725 /* Indents of 5? Yuck. */
726 /* We know that PerlIO_get_layers creates a new SV for
727 the name and flags, so we can just take a reference
728 and "steal" it when we free the AV below. */
2102d7a2 729 PUSHs(namok
92e45a3e 730 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e 731 : &PL_sv_undef);
2102d7a2 732 PUSHs(argok
92e45a3e
NC
733 ? newSVpvn_flags(SvPVX_const(*argsvp),
734 SvCUR(*argsvp),
735 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
736 | SVs_TEMP)
737 : &PL_sv_undef);
2102d7a2 738 PUSHs(flgok
92e45a3e 739 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 740 : &PL_sv_undef);
39f7a870
JH
741 nitem += 3;
742 }
743 else {
744 if (namok && argok)
2102d7a2 745 PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 746 SVfARG(*namsvp),
1eb9e81d 747 SVfARG(*argsvp))));
39f7a870 748 else if (namok)
2102d7a2 749 PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870 750 else
2102d7a2 751 PUSHs(&PL_sv_undef);
39f7a870
JH
752 nitem++;
753 if (flgok) {
c4420975 754 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
755
756 if (flags & PERLIO_F_UTF8) {
2102d7a2 757 PUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
758 nitem++;
759 }
760 }
761 }
762 }
763
764 SvREFCNT_dec(av);
765
766 XSRETURN(nitem);
767 }
768 }
5fef3b4a 769#endif
39f7a870
JH
770
771 XSRETURN(0);
772}
773
241d1a3b 774
15eb3045 775XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
80305961
YO
776XS(XS_re_is_regexp)
777{
80305961 778 dXSARGS;
f7e71195
AB
779 PERL_UNUSED_VAR(cv);
780
80305961 781 if (items != 1)
afa74d42 782 croak_xs_usage(cv, "sv");
f7e71195 783
f7e71195
AB
784 if (SvRXOK(ST(0))) {
785 XSRETURN_YES;
786 } else {
787 XSRETURN_NO;
80305961
YO
788 }
789}
790
15eb3045 791XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */
192b9cd1 792XS(XS_re_regnames_count)
80305961 793{
192b9cd1
AB
794 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
795 SV * ret;
80305961 796 dXSARGS;
192b9cd1
AB
797
798 if (items != 0)
afa74d42 799 croak_xs_usage(cv, "");
192b9cd1
AB
800
801 SP -= items;
fdae9473 802 PUTBACK;
192b9cd1
AB
803
804 if (!rx)
805 XSRETURN_UNDEF;
806
807 ret = CALLREG_NAMED_BUFF_COUNT(rx);
808
809 SPAGAIN;
fdae9473
NC
810 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
811 XSRETURN(1);
192b9cd1
AB
812}
813
15eb3045 814XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
192b9cd1
AB
815XS(XS_re_regname)
816{
192b9cd1
AB
817 dXSARGS;
818 REGEXP * rx;
819 U32 flags;
820 SV * ret;
821
28d8d7f4 822 if (items < 1 || items > 2)
afa74d42 823 croak_xs_usage(cv, "name[, all ]");
192b9cd1 824
80305961 825 SP -= items;
fdae9473 826 PUTBACK;
80305961 827
192b9cd1
AB
828 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
829
830 if (!rx)
831 XSRETURN_UNDEF;
832
833 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 834 flags = RXapif_ALL;
192b9cd1 835 } else {
f1b875a0 836 flags = RXapif_ONE;
80305961 837 }
f1b875a0 838 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1 839
fdae9473
NC
840 SPAGAIN;
841 PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef);
842 XSRETURN(1);
80305961
YO
843}
844
192b9cd1 845
15eb3045 846XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
80305961
YO
847XS(XS_re_regnames)
848{
80305961 849 dXSARGS;
192b9cd1
AB
850 REGEXP * rx;
851 U32 flags;
852 SV *ret;
853 AV *av;
c70927a6
FC
854 SSize_t length;
855 SSize_t i;
192b9cd1
AB
856 SV **entry;
857
858 if (items > 1)
afa74d42 859 croak_xs_usage(cv, "[all]");
192b9cd1
AB
860
861 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
862
863 if (!rx)
864 XSRETURN_UNDEF;
865
866 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 867 flags = RXapif_ALL;
192b9cd1 868 } else {
f1b875a0 869 flags = RXapif_ONE;
192b9cd1
AB
870 }
871
80305961 872 SP -= items;
fdae9473 873 PUTBACK;
80305961 874
f1b875a0 875 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
876
877 SPAGAIN;
878
192b9cd1
AB
879 if (!ret)
880 XSRETURN_UNDEF;
881
502c6561 882 av = MUTABLE_AV(SvRV(ret));
b9f2b683 883 length = av_tindex(av);
192b9cd1 884
2102d7a2 885 EXTEND(SP, length+1); /* better extend stack just once */
192b9cd1
AB
886 for (i = 0; i <= length; i++) {
887 entry = av_fetch(av, i, FALSE);
888
889 if (!entry)
890 Perl_croak(aTHX_ "NULL array element in re::regnames()");
891
2102d7a2 892 mPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 893 }
ec83ea38
MHM
894
895 SvREFCNT_dec(ret);
896
192b9cd1
AB
897 PUTBACK;
898 return;
80305961
YO
899}
900
15eb3045 901XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
192c1e27
JH
902XS(XS_re_regexp_pattern)
903{
192c1e27
JH
904 dXSARGS;
905 REGEXP *re;
192c1e27 906
22d874e2
DD
907 EXTEND(SP, 2);
908 SP -= items;
192c1e27 909 if (items != 1)
afa74d42 910 croak_xs_usage(cv, "sv");
192c1e27 911
192c1e27
JH
912 /*
913 Checks if a reference is a regex or not. If the parameter is
914 not a ref, or is not the result of a qr// then returns false
915 in scalar context and an empty list in list context.
916 Otherwise in list context it returns the pattern and the
917 modifiers, in scalar context it returns the pattern just as it
918 would if the qr// was stringified normally, regardless as
486ec47a 919 to the class of the variable and any stringification overloads
192c1e27
JH
920 on the object.
921 */
922
923 if ((re = SvRX(ST(0)))) /* assign deliberate */
924 {
22c985d5 925 /* Houston, we have a regex! */
192c1e27 926 SV *pattern;
192c1e27
JH
927
928 if ( GIMME_V == G_ARRAY ) {
9de15fec 929 STRLEN left = 0;
a62b1201 930 char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
69af1167
SH
931 const char *fptr;
932 char ch;
933 U16 match_flags;
934
192c1e27
JH
935 /*
936 we are in list context so stringify
937 the modifiers that apply. We ignore "negative
a62b1201 938 modifiers" in this scenario, and the default character set
192c1e27
JH
939 */
940
a62b1201
KW
941 if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
942 STRLEN len;
943 const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
944 &len);
945 Copy(name, reflags + left, len, char);
946 left += len;
9de15fec 947 }
69af1167 948 fptr = INT_PAT_MODS;
73134a2e 949 match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
192c1e27
JH
950 >> RXf_PMf_STD_PMMOD_SHIFT);
951
952 while((ch = *fptr++)) {
953 if(match_flags & 1) {
954 reflags[left++] = ch;
955 }
956 match_flags >>= 1;
957 }
958
fb632ce3
NC
959 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
960 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
961
962 /* return the pattern and the modifiers */
2102d7a2
SM
963 PUSHs(pattern);
964 PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
965 XSRETURN(2);
966 } else {
967 /* Scalar, so use the string that Perl would return */
968 /* return the pattern in (?msix:..) format */
969#if PERL_VERSION >= 11
daba3364 970 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 971#else
fb632ce3
NC
972 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
973 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27 974#endif
22d874e2 975 PUSHs(pattern);
192c1e27
JH
976 XSRETURN(1);
977 }
978 } else {
979 /* It ain't a regexp folks */
980 if ( GIMME_V == G_ARRAY ) {
981 /* return the empty list */
982 XSRETURN_UNDEF;
983 } else {
984 /* Because of the (?:..) wrapping involved in a
985 stringified pattern it is impossible to get a
986 result for a real regexp that would evaluate to
987 false. Therefore we can return PL_sv_no to signify
988 that the object is not a regex, this means that one
989 can say
990
991 if (regex($might_be_a_regex) eq '(?:foo)') { }
992
993 and not worry about undefined values.
994 */
995 XSRETURN_NO;
996 }
997 }
998 /* NOT-REACHED */
999}
1000
b7a8ab8f 1001#include "vutil.h"
abc6d738
FC
1002#include "vxs.inc"
1003
eff5b9d5
NC
1004struct xsub_details {
1005 const char *name;
1006 XSUBADDR_t xsub;
1007 const char *proto;
1008};
1009
a9b7658f 1010static const struct xsub_details details[] = {
eff5b9d5
NC
1011 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1012 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1013 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
abc6d738
FC
1014#define VXS_XSUB_DETAILS
1015#include "vxs.inc"
1016#undef VXS_XSUB_DETAILS
eff5b9d5
NC
1017 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1018 {"utf8::valid", XS_utf8_valid, NULL},
1019 {"utf8::encode", XS_utf8_encode, NULL},
1020 {"utf8::decode", XS_utf8_decode, NULL},
1021 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1022 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1023 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1024 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1025 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
2c6c1df5 1026 {"constant::_make_const", XS_constant__make_const, "\\[$@]"},
eff5b9d5
NC
1027 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1028 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1029 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
eff5b9d5
NC
1030 {"re::is_regexp", XS_re_is_regexp, "$"},
1031 {"re::regname", XS_re_regname, ";$$"},
1032 {"re::regnames", XS_re_regnames, ";$"},
1033 {"re::regnames_count", XS_re_regnames_count, ""},
1034 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
eff5b9d5
NC
1035};
1036
1037void
1038Perl_boot_core_UNIVERSAL(pTHX)
1039{
eff5b9d5 1040 static const char file[] = __FILE__;
7a6ecb12 1041 const struct xsub_details *xsub = details;
c3caa5c3 1042 const struct xsub_details *end = C_ARRAY_END(details);
eff5b9d5
NC
1043
1044 do {
1045 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1046 } while (++xsub < end);
1047
eff5b9d5 1048 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
bad4ae38
FC
1049 {
1050 CV * const cv =
1051 newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
1052 Safefree(CvFILE(cv));
1053 CvFILE(cv) = (char *)file;
1054 CvDYNFILE_off(cv);
1055 }
eff5b9d5 1056}
80305961 1057
241d1a3b
NC
1058/*
1059 * Local variables:
1060 * c-indentation-style: bsd
1061 * c-basic-offset: 4
14d04a33 1062 * indent-tabs-mode: nil
241d1a3b
NC
1063 * End:
1064 *
14d04a33 1065 * ex: set ts=8 sts=4 sw=4 et:
37442d52 1066 */