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