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