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