This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make PerlIO::get_layers really test flgok before reading *flgsvp
[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
24 * clever to move them to seperate XS files which would then be pulled
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
39f7a870
JH
32#ifdef USE_PERLIO
33#include "perliol.h" /* For the PERLIO_F_XXX */
34#endif
35
aea32303
NC
36static HV *
37S_get_isa_hash(pTHX_ HV *const stash)
00bf72ff
NC
38{
39 dVAR;
40 struct mro_meta *const meta = HvMROMETA(stash);
41
42 PERL_ARGS_ASSERT_GET_ISA_HASH;
43
44 if (!meta->isa) {
45 AV *const isa = mro_get_linear_isa(stash);
46 if (!meta->isa) {
47 HV *const isa_hash = newHV();
48 /* Linearisation didn't build it for us, so do it here. */
49 SV *const *svp = AvARRAY(isa);
50 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
51 const HEK *const canon_name = HvNAME_HEK(stash);
52
53 while (svp < svp_end) {
54 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
55 }
56
57 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
58 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
59 HV_FETCH_ISSTORE, &PL_sv_undef,
60 HEK_HASH(canon_name));
61 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
62
63 SvREADONLY_on(isa_hash);
64
65 meta->isa = isa_hash;
66 }
67 }
68 return meta->isa;
69}
70
6d4a7be2 71/*
72 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
73 * The main guts of traverse_isa was actually copied from gv_fetchmeth
74 */
75
a9ec700e 76STATIC bool
515a4f72 77S_isa_lookup(pTHX_ HV *stash, const char * const name)
6d4a7be2 78{
97aff369 79 dVAR;
a49ba3fc 80 const struct mro_meta *const meta = HvMROMETA(stash);
aea32303 81 HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash);
a49ba3fc
NC
82 STRLEN len = strlen(name);
83 const HV *our_stash;
6d4a7be2 84
7918f24d
NC
85 PERL_ARGS_ASSERT_ISA_LOOKUP;
86
a49ba3fc
NC
87 if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only
88 a char * argument*/,
89 HV_FETCH_ISEXISTS, NULL, 0)) {
90 /* Direct name lookup worked. */
a9ec700e 91 return TRUE;
a49ba3fc 92 }
6d4a7be2 93
a49ba3fc
NC
94 /* A stash/class can go by many names (ie. User == main::User), so
95 we use the name in the stash itself, which is canonical. */
96 our_stash = gv_stashpvn(name, len, 0);
97
98 if (our_stash) {
99 HEK *const canon_name = HvNAME_HEK(our_stash);
a1d407e8 100
a49ba3fc
NC
101 if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name),
102 HEK_FLAGS(canon_name),
103 HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) {
e1a479c5 104 return TRUE;
a49ba3fc 105 }
6d4a7be2 106 }
107
a9ec700e 108 return FALSE;
6d4a7be2 109}
110
954c1994 111/*
ccfc67b7
JH
112=head1 SV Manipulation Functions
113
954c1994
GS
114=for apidoc sv_derived_from
115
6885da0e 116Returns a boolean indicating whether the SV is derived from the specified class
117I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
118normal Perl method.
954c1994
GS
119
120=cut
121*/
122
55497cff 123bool
15f169a1 124Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
55497cff 125{
97aff369 126 dVAR;
0b6f4f5c 127 HV *stash;
46e4b22b 128
7918f24d
NC
129 PERL_ARGS_ASSERT_SV_DERIVED_FROM;
130
5b295bef 131 SvGETMAGIC(sv);
55497cff 132
133 if (SvROK(sv)) {
0b6f4f5c 134 const char *type;
55497cff 135 sv = SvRV(sv);
136 type = sv_reftype(sv,0);
0b6f4f5c
AL
137 if (type && strEQ(type,name))
138 return TRUE;
139 stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
55497cff 140 }
141 else {
da51bb9b 142 stash = gv_stashsv(sv, 0);
55497cff 143 }
46e4b22b 144
4a9e32d8 145 return stash ? isa_lookup(stash, name) : FALSE;
55497cff 146}
147
cbc021f9 148/*
149=for apidoc sv_does
150
151Returns a boolean indicating whether the SV performs a specific, named role.
152The SV can be a Perl object or the name of a Perl class.
153
154=cut
155*/
156
1b026014
NIS
157#include "XSUB.h"
158
cbc021f9 159bool
15f169a1 160Perl_sv_does(pTHX_ SV *sv, const char *const name)
cbc021f9 161{
162 const char *classname;
163 bool does_it;
59e7186f 164 SV *methodname;
cbc021f9 165 dSP;
7918f24d
NC
166
167 PERL_ARGS_ASSERT_SV_DOES;
168
cbc021f9 169 ENTER;
170 SAVETMPS;
171
172 SvGETMAGIC(sv);
173
174 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
175 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
176 return FALSE;
177
178 if (sv_isobject(sv)) {
179 classname = sv_reftype(SvRV(sv),TRUE);
180 } else {
94707740 181 classname = SvPV_nolen(sv);
cbc021f9 182 }
183
184 if (strEQ(name,classname))
185 return TRUE;
186
187 PUSHMARK(SP);
188 XPUSHs(sv);
6e449a3a 189 mXPUSHs(newSVpv(name, 0));
cbc021f9 190 PUTBACK;
191
84bafc02 192 methodname = newSVpvs_flags("isa", SVs_TEMP);
59e7186f
RGS
193 /* ugly hack: use the SvSCREAM flag so S_method_common
194 * can figure out we're calling DOES() and not isa(),
195 * and report eventual errors correctly. --rgs */
196 SvSCREAM_on(methodname);
197 call_sv(methodname, G_SCALAR | G_METHOD);
cbc021f9 198 SPAGAIN;
199
200 does_it = SvTRUE( TOPs );
201 FREETMPS;
202 LEAVE;
203
204 return does_it;
205}
206
27da23d5
JH
207PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
208PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
cbc021f9 209PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
27da23d5 210PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
439cb1c4
JP
211XS(XS_version_new);
212XS(XS_version_stringify);
213XS(XS_version_numify);
9137345a 214XS(XS_version_normal);
439cb1c4
JP
215XS(XS_version_vcmp);
216XS(XS_version_boolean);
2dfd8427
AL
217#ifdef HASATTRIBUTE_NORETURN
218XS(XS_version_noop) __attribute__noreturn__;
219#else
439cb1c4 220XS(XS_version_noop);
2dfd8427 221#endif
c8d69e4a 222XS(XS_version_is_alpha);
137d6fc0 223XS(XS_version_qv);
8800c35a 224XS(XS_utf8_is_utf8);
1b026014
NIS
225XS(XS_utf8_valid);
226XS(XS_utf8_encode);
227XS(XS_utf8_decode);
228XS(XS_utf8_upgrade);
229XS(XS_utf8_downgrade);
230XS(XS_utf8_unicode_to_native);
231XS(XS_utf8_native_to_unicode);
29569577
JH
232XS(XS_Internals_SvREADONLY);
233XS(XS_Internals_SvREFCNT);
f044d0d1 234XS(XS_Internals_hv_clear_placehold);
39f7a870 235XS(XS_PerlIO_get_layers);
f63535fc 236XS(XS_Regexp_DESTROY);
9a7034eb 237XS(XS_Internals_hash_seed);
008fb0c0 238XS(XS_Internals_rehash_seed);
05619474 239XS(XS_Internals_HvREHASH);
e1234d8e 240XS(XS_Internals_inc_sub_generation);
80305961 241XS(XS_re_is_regexp);
192b9cd1
AB
242XS(XS_re_regname);
243XS(XS_re_regnames);
80305961 244XS(XS_re_regnames_count);
192c1e27 245XS(XS_re_regexp_pattern);
192b9cd1
AB
246XS(XS_Tie_Hash_NamedCapture_FETCH);
247XS(XS_Tie_Hash_NamedCapture_STORE);
248XS(XS_Tie_Hash_NamedCapture_DELETE);
249XS(XS_Tie_Hash_NamedCapture_CLEAR);
250XS(XS_Tie_Hash_NamedCapture_EXISTS);
86aa3d53
CB
251XS(XS_Tie_Hash_NamedCapture_FIRSTK);
252XS(XS_Tie_Hash_NamedCapture_NEXTK);
192b9cd1
AB
253XS(XS_Tie_Hash_NamedCapture_SCALAR);
254XS(XS_Tie_Hash_NamedCapture_flags);
0cb96387
GS
255
256void
257Perl_boot_core_UNIVERSAL(pTHX)
258{
97aff369 259 dVAR;
157e3fc8 260 static const char file[] = __FILE__;
0cb96387
GS
261
262 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
263 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
cbc021f9 264 newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file);
0cb96387 265 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
439cb1c4 266 {
ad63d80f
JP
267 /* register the overloading (type 'A') magic */
268 PL_amagic_generation++;
439cb1c4 269 /* Make it findable via fetchmethod */
be2ebcad 270 newXS("version::()", XS_version_noop, file);
439cb1c4
JP
271 newXS("version::new", XS_version_new, file);
272 newXS("version::(\"\"", XS_version_stringify, file);
273 newXS("version::stringify", XS_version_stringify, file);
274 newXS("version::(0+", XS_version_numify, file);
275 newXS("version::numify", XS_version_numify, file);
9137345a 276 newXS("version::normal", XS_version_normal, file);
439cb1c4
JP
277 newXS("version::(cmp", XS_version_vcmp, file);
278 newXS("version::(<=>", XS_version_vcmp, file);
279 newXS("version::vcmp", XS_version_vcmp, file);
280 newXS("version::(bool", XS_version_boolean, file);
281 newXS("version::boolean", XS_version_boolean, file);
282 newXS("version::(nomethod", XS_version_noop, file);
283 newXS("version::noop", XS_version_noop, file);
c8d69e4a 284 newXS("version::is_alpha", XS_version_is_alpha, file);
137d6fc0 285 newXS("version::qv", XS_version_qv, file);
439cb1c4 286 }
8800c35a 287 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
1b026014
NIS
288 newXS("utf8::valid", XS_utf8_valid, file);
289 newXS("utf8::encode", XS_utf8_encode, file);
290 newXS("utf8::decode", XS_utf8_decode, file);
291 newXS("utf8::upgrade", XS_utf8_upgrade, file);
292 newXS("utf8::downgrade", XS_utf8_downgrade, file);
293 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
294 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577
JH
295 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
296 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f 297 newXSproto("Internals::hv_clear_placeholders",
f044d0d1 298 XS_Internals_hv_clear_placehold, file, "\\%");
9d569fce
JH
299 newXSproto("PerlIO::get_layers",
300 XS_PerlIO_get_layers, file, "*;@");
f63535fc 301 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
9a7034eb 302 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
008fb0c0 303 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
05619474 304 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
80305961 305 newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
28d8d7f4
YO
306 newXSproto("re::regname", XS_re_regname, file, ";$$");
307 newXSproto("re::regnames", XS_re_regnames, file, ";$");
28d8d7f4 308 newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
192c1e27 309 newXSproto("re::regexp_pattern", XS_re_regexp_pattern, file, "$");
192b9cd1
AB
310 newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
311 newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
312 newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
313 newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file);
314 newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file);
86aa3d53
CB
315 newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, file);
316 newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, file);
192b9cd1
AB
317 newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file);
318 newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file);
0cb96387
GS
319}
320
afa74d42
NC
321/*
322=for apidoc croak_xs_usage
323
324A specialised variant of C<croak()> for emitting the usage message for xsubs
325
326 croak_xs_usage(cv, "eee_yow");
327
328works out the package name and subroutine name from C<cv>, and then calls
329C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
330
331 Perl_croak(aTHX_ "Usage %s::%s(%s)", "ouch" "awk", "eee_yow");
332
333=cut
334*/
335
336void
337Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
338{
339 const GV *const gv = CvGV(cv);
340
341 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
342
343 if (gv) {
344 const char *const gvname = GvNAME(gv);
345 const HV *const stash = GvSTASH(gv);
346 const char *const hvname = stash ? HvNAME_get(stash) : NULL;
347
348 if (hvname)
349 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
350 else
351 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
352 } else {
353 /* Pants. I don't think that it should be possible to get here. */
93c51217 354 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
afa74d42
NC
355 }
356}
55497cff 357
6d4a7be2 358XS(XS_UNIVERSAL_isa)
359{
97aff369 360 dVAR;
6d4a7be2 361 dXSARGS;
6d4a7be2 362
363 if (items != 2)
afa74d42 364 croak_xs_usage(cv, "reference, kind");
c4420975
AL
365 else {
366 SV * const sv = ST(0);
367 const char *name;
6d4a7be2 368
c4420975 369 SvGETMAGIC(sv);
d3f7f2b2 370
c4420975
AL
371 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
372 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
373 XSRETURN_UNDEF;
f8f70380 374
c4420975 375 name = SvPV_nolen_const(ST(1));
6d4a7be2 376
c4420975
AL
377 ST(0) = boolSV(sv_derived_from(sv, name));
378 XSRETURN(1);
379 }
6d4a7be2 380}
381
6d4a7be2 382XS(XS_UNIVERSAL_can)
383{
97aff369 384 dVAR;
6d4a7be2 385 dXSARGS;
386 SV *sv;
6867be6d 387 const char *name;
6d4a7be2 388 SV *rv;
6f08146e 389 HV *pkg = NULL;
6d4a7be2 390
391 if (items != 2)
afa74d42 392 croak_xs_usage(cv, "object-ref, method");
6d4a7be2 393
394 sv = ST(0);
f8f70380 395
5b295bef 396 SvGETMAGIC(sv);
d3f7f2b2 397
253ecd6d
RGS
398 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
399 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380
GS
400 XSRETURN_UNDEF;
401
0510663f 402 name = SvPV_nolen_const(ST(1));
3280af22 403 rv = &PL_sv_undef;
6d4a7be2 404
46e4b22b 405 if (SvROK(sv)) {
daba3364 406 sv = MUTABLE_SV(SvRV(sv));
46e4b22b 407 if (SvOBJECT(sv))
6f08146e
NIS
408 pkg = SvSTASH(sv);
409 }
410 else {
da51bb9b 411 pkg = gv_stashsv(sv, 0);
6f08146e
NIS
412 }
413
414 if (pkg) {
c4420975 415 GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
dc848c6f 416 if (gv && isGV(gv))
daba3364 417 rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv))));
6d4a7be2 418 }
419
420 ST(0) = rv;
421 XSRETURN(1);
422}
423
cbc021f9 424XS(XS_UNIVERSAL_DOES)
425{
426 dVAR;
427 dXSARGS;
58c0efa5 428 PERL_UNUSED_ARG(cv);
cbc021f9 429
430 if (items != 2)
26be3db7 431 Perl_croak(aTHX_ "Usage: invocant->DOES(kind)");
cbc021f9 432 else {
433 SV * const sv = ST(0);
434 const char *name;
435
436 name = SvPV_nolen_const(ST(1));
437 if (sv_does( sv, name ))
438 XSRETURN_YES;
439
440 XSRETURN_NO;
441 }
442}
443
6d4a7be2 444XS(XS_UNIVERSAL_VERSION)
445{
97aff369 446 dVAR;
6d4a7be2 447 dXSARGS;
448 HV *pkg;
449 GV **gvp;
450 GV *gv;
451 SV *sv;
e1ec3a88 452 const char *undef;
58c0efa5 453 PERL_UNUSED_ARG(cv);
6d4a7be2 454
1571675a 455 if (SvROK(ST(0))) {
daba3364 456 sv = MUTABLE_SV(SvRV(ST(0)));
1571675a 457 if (!SvOBJECT(sv))
cea2e8a9 458 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2 459 pkg = SvSTASH(sv);
460 }
461 else {
da51bb9b 462 pkg = gv_stashsv(ST(0), 0);
6d4a7be2 463 }
464
4608196e 465 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
6d4a7be2 466
0008872a 467 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
c4420975 468 SV * const nsv = sv_newmortal();
6d4a7be2 469 sv_setsv(nsv, sv);
470 sv = nsv;
137d6fc0 471 if ( !sv_derived_from(sv, "version"))
ac0e6a2f 472 upg_version(sv, FALSE);
c445ea15 473 undef = NULL;
6d4a7be2 474 }
475 else {
daba3364 476 sv = &PL_sv_undef;
6d4a7be2 477 undef = "(undef)";
478 }
479
1571675a 480 if (items > 1) {
1571675a
GS
481 SV *req = ST(1);
482
62658f4d 483 if (undef) {
bfcb3514 484 if (pkg) {
c4420975 485 const char * const name = HvNAME_get(pkg);
a3b680e6 486 Perl_croak(aTHX_
bfcb3514
NC
487 "%s does not define $%s::VERSION--version check failed",
488 name, name);
489 } else {
a3b680e6
AL
490 Perl_croak(aTHX_
491 "%s defines neither package nor VERSION--version check failed",
0510663f 492 SvPVx_nolen_const(ST(0)) );
62658f4d
PM
493 }
494 }
ad63d80f 495
137d6fc0
JP
496 if ( !sv_derived_from(req, "version")) {
497 /* req may very well be R/O, so create a new object */
ac0e6a2f 498 req = sv_2mortal( new_version(req) );
137d6fc0 499 }
1571675a 500
ac0e6a2f 501 if ( vcmp( req, sv ) > 0 ) {
ef8f7699 502 if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
ac0e6a2f
RGS
503 Perl_croak(aTHX_ "%s version %"SVf" required--"
504 "this is only version %"SVf"", HvNAME_get(pkg),
be2597df 505 SVfARG(vnormal(req)),
be2597df 506 SVfARG(vnormal(sv)));
ac0e6a2f
RGS
507 } else {
508 Perl_croak(aTHX_ "%s version %"SVf" required--"
509 "this is only version %"SVf"", HvNAME_get(pkg),
8cb289bd
RGS
510 SVfARG(vstringify(req)),
511 SVfARG(vstringify(sv)));
ac0e6a2f
RGS
512 }
513 }
514
2d8e6c8d 515 }
6d4a7be2 516
2b140d5b 517 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
8cb289bd 518 ST(0) = vstringify(sv);
13f8f398
JP
519 } else {
520 ST(0) = sv;
b38a9dc5 521 }
6d4a7be2 522
523 XSRETURN(1);
524}
525
439cb1c4
JP
526XS(XS_version_new)
527{
97aff369 528 dVAR;
439cb1c4 529 dXSARGS;
129318bd 530 if (items > 3)
afa74d42 531 croak_xs_usage(cv, "class, version");
439cb1c4
JP
532 SP -= items;
533 {
137d6fc0
JP
534 SV *vs = ST(1);
535 SV *rv;
c4420975
AL
536 const char * const classname =
537 sv_isobject(ST(0)) /* get the class if called as an object method */
538 ? HvNAME(SvSTASH(SvRV(ST(0))))
539 : (char *)SvPV_nolen(ST(0));
9137345a 540
92dcf8ce
JP
541 if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
542 /* create empty object */
543 vs = sv_newmortal();
76f68e9b 544 sv_setpvs(vs,"");
9137345a
JP
545 }
546 else if ( items == 3 ) {
547 vs = sv_newmortal();
cfd0369c 548 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
129318bd 549 }
439cb1c4 550
137d6fc0 551 rv = new_version(vs);
0723351e 552 if ( strcmp(classname,"version") != 0 ) /* inherited new() */
da51bb9b 553 sv_bless(rv, gv_stashpv(classname, GV_ADD));
137d6fc0 554
6e449a3a 555 mPUSHs(rv);
439cb1c4
JP
556 PUTBACK;
557 return;
558 }
559}
560
561XS(XS_version_stringify)
562{
97aff369 563 dVAR;
41be1fbd
JH
564 dXSARGS;
565 if (items < 1)
afa74d42 566 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
567 SP -= items;
568 {
7452cf6a 569 SV * lobj;
41be1fbd
JH
570
571 if (sv_derived_from(ST(0), "version")) {
9137345a 572 lobj = SvRV(ST(0));
41be1fbd
JH
573 }
574 else
575 Perl_croak(aTHX_ "lobj is not of type version");
576
6e449a3a 577 mPUSHs(vstringify(lobj));
41be1fbd
JH
578
579 PUTBACK;
580 return;
581 }
439cb1c4
JP
582}
583
584XS(XS_version_numify)
585{
97aff369 586 dVAR;
41be1fbd
JH
587 dXSARGS;
588 if (items < 1)
afa74d42 589 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
590 SP -= items;
591 {
7452cf6a 592 SV * lobj;
41be1fbd
JH
593
594 if (sv_derived_from(ST(0), "version")) {
9137345a 595 lobj = SvRV(ST(0));
41be1fbd
JH
596 }
597 else
598 Perl_croak(aTHX_ "lobj is not of type version");
599
6e449a3a 600 mPUSHs(vnumify(lobj));
41be1fbd
JH
601
602 PUTBACK;
603 return;
604 }
439cb1c4
JP
605}
606
9137345a
JP
607XS(XS_version_normal)
608{
97aff369 609 dVAR;
9137345a
JP
610 dXSARGS;
611 if (items < 1)
afa74d42 612 croak_xs_usage(cv, "lobj, ...");
9137345a
JP
613 SP -= items;
614 {
7452cf6a 615 SV * lobj;
9137345a
JP
616
617 if (sv_derived_from(ST(0), "version")) {
618 lobj = SvRV(ST(0));
619 }
620 else
621 Perl_croak(aTHX_ "lobj is not of type version");
622
6e449a3a 623 mPUSHs(vnormal(lobj));
9137345a
JP
624
625 PUTBACK;
626 return;
627 }
628}
629
439cb1c4
JP
630XS(XS_version_vcmp)
631{
97aff369 632 dVAR;
41be1fbd
JH
633 dXSARGS;
634 if (items < 1)
afa74d42 635 croak_xs_usage(cv, "lobj, ...");
41be1fbd
JH
636 SP -= items;
637 {
7452cf6a 638 SV * lobj;
41be1fbd
JH
639
640 if (sv_derived_from(ST(0), "version")) {
9137345a 641 lobj = SvRV(ST(0));
41be1fbd
JH
642 }
643 else
644 Perl_croak(aTHX_ "lobj is not of type version");
645
646 {
647 SV *rs;
648 SV *rvs;
649 SV * robj = ST(1);
7452cf6a 650 const IV swap = (IV)SvIV(ST(2));
41be1fbd
JH
651
652 if ( ! sv_derived_from(robj, "version") )
653 {
654 robj = new_version(robj);
655 }
656 rvs = SvRV(robj);
657
658 if ( swap )
659 {
660 rs = newSViv(vcmp(rvs,lobj));
661 }
662 else
663 {
664 rs = newSViv(vcmp(lobj,rvs));
665 }
666
6e449a3a 667 mPUSHs(rs);
41be1fbd
JH
668 }
669
670 PUTBACK;
671 return;
672 }
439cb1c4
JP
673}
674
675XS(XS_version_boolean)
676{
97aff369
JH
677 dVAR;
678 dXSARGS;
679 if (items < 1)
afa74d42 680 croak_xs_usage(cv, "lobj, ...");
97aff369 681 SP -= items;
c4420975
AL
682 if (sv_derived_from(ST(0), "version")) {
683 SV * const lobj = SvRV(ST(0));
396482e1 684 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
6e449a3a 685 mPUSHs(rs);
c4420975
AL
686 PUTBACK;
687 return;
688 }
689 else
690 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
691}
692
693XS(XS_version_noop)
694{
97aff369 695 dVAR;
2dfd8427
AL
696 dXSARGS;
697 if (items < 1)
afa74d42 698 croak_xs_usage(cv, "lobj, ...");
2dfd8427
AL
699 if (sv_derived_from(ST(0), "version"))
700 Perl_croak(aTHX_ "operation not supported with version object");
701 else
702 Perl_croak(aTHX_ "lobj is not of type version");
703#ifndef HASATTRIBUTE_NORETURN
704 XSRETURN_EMPTY;
705#endif
439cb1c4
JP
706}
707
c8d69e4a
JP
708XS(XS_version_is_alpha)
709{
97aff369 710 dVAR;
c8d69e4a
JP
711 dXSARGS;
712 if (items != 1)
afa74d42 713 croak_xs_usage(cv, "lobj");
c8d69e4a 714 SP -= items;
c4420975
AL
715 if (sv_derived_from(ST(0), "version")) {
716 SV * const lobj = ST(0);
ef8f7699 717 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
c4420975
AL
718 XSRETURN_YES;
719 else
720 XSRETURN_NO;
c8d69e4a
JP
721 PUTBACK;
722 return;
723 }
c4420975
AL
724 else
725 Perl_croak(aTHX_ "lobj is not of type version");
c8d69e4a
JP
726}
727
137d6fc0
JP
728XS(XS_version_qv)
729{
97aff369 730 dVAR;
137d6fc0
JP
731 dXSARGS;
732 if (items != 1)
afa74d42 733 croak_xs_usage(cv, "ver");
137d6fc0
JP
734 SP -= items;
735 {
736 SV * ver = ST(0);
c4420975 737 if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
ac0e6a2f
RGS
738 SV * const rv = sv_newmortal();
739 sv_setsv(rv,ver); /* make a duplicate */
740 upg_version(rv, TRUE);
741 PUSHs(rv);
137d6fc0
JP
742 }
743 else
744 {
6e449a3a 745 mPUSHs(new_version(ver));
137d6fc0
JP
746 }
747
748 PUTBACK;
749 return;
750 }
751}
752
8800c35a
JH
753XS(XS_utf8_is_utf8)
754{
97aff369 755 dVAR;
41be1fbd
JH
756 dXSARGS;
757 if (items != 1)
afa74d42 758 croak_xs_usage(cv, "sv");
c4420975
AL
759 else {
760 const SV * const sv = ST(0);
761 if (SvUTF8(sv))
762 XSRETURN_YES;
763 else
764 XSRETURN_NO;
41be1fbd
JH
765 }
766 XSRETURN_EMPTY;
8800c35a
JH
767}
768
1b026014
NIS
769XS(XS_utf8_valid)
770{
97aff369 771 dVAR;
41be1fbd
JH
772 dXSARGS;
773 if (items != 1)
afa74d42 774 croak_xs_usage(cv, "sv");
c4420975
AL
775 else {
776 SV * const sv = ST(0);
777 STRLEN len;
778 const char * const s = SvPV_const(sv,len);
779 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
780 XSRETURN_YES;
781 else
782 XSRETURN_NO;
783 }
41be1fbd 784 XSRETURN_EMPTY;
1b026014
NIS
785}
786
787XS(XS_utf8_encode)
788{
97aff369 789 dVAR;
1b026014
NIS
790 dXSARGS;
791 if (items != 1)
afa74d42 792 croak_xs_usage(cv, "sv");
c4420975 793 sv_utf8_encode(ST(0));
1b026014
NIS
794 XSRETURN_EMPTY;
795}
796
797XS(XS_utf8_decode)
798{
97aff369 799 dVAR;
1b026014
NIS
800 dXSARGS;
801 if (items != 1)
afa74d42 802 croak_xs_usage(cv, "sv");
c4420975
AL
803 else {
804 SV * const sv = ST(0);
6867be6d 805 const bool RETVAL = sv_utf8_decode(sv);
1b026014
NIS
806 ST(0) = boolSV(RETVAL);
807 sv_2mortal(ST(0));
808 }
809 XSRETURN(1);
810}
811
812XS(XS_utf8_upgrade)
813{
97aff369 814 dVAR;
1b026014
NIS
815 dXSARGS;
816 if (items != 1)
afa74d42 817 croak_xs_usage(cv, "sv");
c4420975
AL
818 else {
819 SV * const sv = ST(0);
1b026014
NIS
820 STRLEN RETVAL;
821 dXSTARG;
822
823 RETVAL = sv_utf8_upgrade(sv);
824 XSprePUSH; PUSHi((IV)RETVAL);
825 }
826 XSRETURN(1);
827}
828
829XS(XS_utf8_downgrade)
830{
97aff369 831 dVAR;
1b026014
NIS
832 dXSARGS;
833 if (items < 1 || items > 2)
afa74d42 834 croak_xs_usage(cv, "sv, failok=0");
c4420975
AL
835 else {
836 SV * const sv = ST(0);
6867be6d
AL
837 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
838 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 839
1b026014
NIS
840 ST(0) = boolSV(RETVAL);
841 sv_2mortal(ST(0));
842 }
843 XSRETURN(1);
844}
845
846XS(XS_utf8_native_to_unicode)
847{
97aff369 848 dVAR;
1b026014 849 dXSARGS;
6867be6d 850 const UV uv = SvUV(ST(0));
b7953727
JH
851
852 if (items > 1)
afa74d42 853 croak_xs_usage(cv, "sv");
b7953727 854
1b026014
NIS
855 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
856 XSRETURN(1);
857}
858
859XS(XS_utf8_unicode_to_native)
860{
97aff369 861 dVAR;
1b026014 862 dXSARGS;
6867be6d 863 const UV uv = SvUV(ST(0));
b7953727
JH
864
865 if (items > 1)
afa74d42 866 croak_xs_usage(cv, "sv");
b7953727 867
1b026014
NIS
868 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
869 XSRETURN(1);
870}
871
14a976d6 872XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577 873{
97aff369 874 dVAR;
29569577 875 dXSARGS;
c4420975 876 SV * const sv = SvRV(ST(0));
58c0efa5 877 PERL_UNUSED_ARG(cv);
6867be6d 878
29569577
JH
879 if (items == 1) {
880 if (SvREADONLY(sv))
881 XSRETURN_YES;
882 else
883 XSRETURN_NO;
884 }
885 else if (items == 2) {
886 if (SvTRUE(ST(1))) {
887 SvREADONLY_on(sv);
888 XSRETURN_YES;
889 }
890 else {
14a976d6 891 /* I hope you really know what you are doing. */
29569577
JH
892 SvREADONLY_off(sv);
893 XSRETURN_NO;
894 }
895 }
14a976d6 896 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
897}
898
14a976d6 899XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577 900{
97aff369 901 dVAR;
29569577 902 dXSARGS;
c4420975 903 SV * const sv = SvRV(ST(0));
58c0efa5 904 PERL_UNUSED_ARG(cv);
6867be6d 905
29569577 906 if (items == 1)
14a976d6 907 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 908 else if (items == 2) {
14a976d6 909 /* I hope you really know what you are doing. */
29569577
JH
910 SvREFCNT(sv) = SvIV(ST(1));
911 XSRETURN_IV(SvREFCNT(sv));
912 }
14a976d6 913 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
914}
915
f044d0d1 916XS(XS_Internals_hv_clear_placehold)
dfd4ef2f 917{
97aff369 918 dVAR;
dfd4ef2f 919 dXSARGS;
6867be6d 920
3540d4ce 921 if (items != 1)
afa74d42 922 croak_xs_usage(cv, "hv");
c4420975 923 else {
ef8f7699 924 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
925 hv_clear_placeholders(hv);
926 XSRETURN(0);
927 }
dfd4ef2f 928}
39f7a870 929
f63535fc
NC
930XS(XS_Regexp_DESTROY)
931{
932 PERL_UNUSED_CONTEXT;
933 PERL_UNUSED_ARG(cv);
934}
935
39f7a870
JH
936XS(XS_PerlIO_get_layers)
937{
97aff369 938 dVAR;
39f7a870
JH
939 dXSARGS;
940 if (items < 1 || items % 2 == 0)
afa74d42 941 croak_xs_usage(cv, "filehandle[,args]");
5fef3b4a 942#ifdef USE_PERLIO
39f7a870
JH
943 {
944 SV * sv;
945 GV * gv;
946 IO * io;
947 bool input = TRUE;
948 bool details = FALSE;
949
950 if (items > 1) {
c4420975 951 SV * const *svp;
39f7a870 952 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
953 SV * const * const varp = svp;
954 SV * const * const valp = svp + 1;
39f7a870 955 STRLEN klen;
c4420975 956 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
957
958 switch (*key) {
959 case 'i':
960 if (klen == 5 && memEQ(key, "input", 5)) {
961 input = SvTRUE(*valp);
962 break;
963 }
964 goto fail;
965 case 'o':
966 if (klen == 6 && memEQ(key, "output", 6)) {
967 input = !SvTRUE(*valp);
968 break;
969 }
970 goto fail;
971 case 'd':
972 if (klen == 7 && memEQ(key, "details", 7)) {
973 details = SvTRUE(*valp);
974 break;
975 }
976 goto fail;
977 default:
978 fail:
979 Perl_croak(aTHX_
980 "get_layers: unknown argument '%s'",
981 key);
982 }
983 }
984
985 SP -= (items - 1);
986 }
987
988 sv = POPs;
159b6efe 989 gv = MUTABLE_GV(sv);
39f7a870
JH
990
991 if (!isGV(sv)) {
992 if (SvROK(sv) && isGV(SvRV(sv)))
159b6efe 993 gv = MUTABLE_GV(SvRV(sv));
671d49be 994 else if (SvPOKp(sv))
f776e3cd 995 gv = gv_fetchsv(sv, 0, SVt_PVIO);
39f7a870
JH
996 }
997
998 if (gv && (io = GvIO(gv))) {
c4420975 999 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870
JH
1000 IoIFP(io) : IoOFP(io));
1001 I32 i;
c4420975 1002 const I32 last = av_len(av);
39f7a870
JH
1003 I32 nitem = 0;
1004
1005 for (i = last; i >= 0; i -= 3) {
c4420975
AL
1006 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1007 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1008 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 1009
c4420975
AL
1010 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1011 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1012 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870
JH
1013
1014 if (details) {
92e45a3e
NC
1015 /* Indents of 5? Yuck. */
1016 /* We know that PerlIO_get_layers creates a new SV for
1017 the name and flags, so we can just take a reference
1018 and "steal" it when we free the AV below. */
ec3bab8e 1019 XPUSHs(namok
92e45a3e 1020 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e
NC
1021 : &PL_sv_undef);
1022 XPUSHs(argok
92e45a3e
NC
1023 ? newSVpvn_flags(SvPVX_const(*argsvp),
1024 SvCUR(*argsvp),
1025 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1026 | SVs_TEMP)
1027 : &PL_sv_undef);
96ccaf53 1028 XPUSHs(flgok
92e45a3e 1029 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 1030 : &PL_sv_undef);
39f7a870
JH
1031 nitem += 3;
1032 }
1033 else {
1034 if (namok && argok)
1eb9e81d 1035 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 1036 SVfARG(*namsvp),
1eb9e81d 1037 SVfARG(*argsvp))));
39f7a870 1038 else if (namok)
92e45a3e 1039 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870
JH
1040 else
1041 XPUSHs(&PL_sv_undef);
1042 nitem++;
1043 if (flgok) {
c4420975 1044 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
1045
1046 if (flags & PERLIO_F_UTF8) {
84bafc02 1047 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
1048 nitem++;
1049 }
1050 }
1051 }
1052 }
1053
1054 SvREFCNT_dec(av);
1055
1056 XSRETURN(nitem);
1057 }
1058 }
5fef3b4a 1059#endif
39f7a870
JH
1060
1061 XSRETURN(0);
1062}
1063
9a7034eb 1064XS(XS_Internals_hash_seed)
c910b28a 1065{
97aff369 1066 dVAR;
c85d3f85
NC
1067 /* Using dXSARGS would also have dITEM and dSP,
1068 * which define 2 unused local variables. */
557b887a 1069 dAXMARK;
53c1dcc0 1070 PERL_UNUSED_ARG(cv);
ad73156c 1071 PERL_UNUSED_VAR(mark);
81eaca17 1072 XSRETURN_UV(PERL_HASH_SEED);
c910b28a
JH
1073}
1074
008fb0c0 1075XS(XS_Internals_rehash_seed)
8e90d776 1076{
97aff369 1077 dVAR;
8e90d776
NC
1078 /* Using dXSARGS would also have dITEM and dSP,
1079 * which define 2 unused local variables. */
557b887a 1080 dAXMARK;
53c1dcc0 1081 PERL_UNUSED_ARG(cv);
ad73156c 1082 PERL_UNUSED_VAR(mark);
008fb0c0 1083 XSRETURN_UV(PL_rehash_seed);
8e90d776
NC
1084}
1085
05619474
NC
1086XS(XS_Internals_HvREHASH) /* Subject to change */
1087{
97aff369 1088 dVAR;
05619474 1089 dXSARGS;
93c51217 1090 PERL_UNUSED_ARG(cv);
05619474 1091 if (SvROK(ST(0))) {
ef8f7699 1092 const HV * const hv = (const HV *) SvRV(ST(0));
05619474
NC
1093 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1094 if (HvREHASH(hv))
1095 XSRETURN_YES;
1096 else
1097 XSRETURN_NO;
1098 }
1099 }
1100 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1101}
241d1a3b 1102
80305961
YO
1103XS(XS_re_is_regexp)
1104{
1105 dVAR;
1106 dXSARGS;
f7e71195
AB
1107 PERL_UNUSED_VAR(cv);
1108
80305961 1109 if (items != 1)
afa74d42 1110 croak_xs_usage(cv, "sv");
f7e71195 1111
80305961 1112 SP -= items;
f7e71195
AB
1113
1114 if (SvRXOK(ST(0))) {
1115 XSRETURN_YES;
1116 } else {
1117 XSRETURN_NO;
80305961
YO
1118 }
1119}
1120
192b9cd1 1121XS(XS_re_regnames_count)
80305961 1122{
192b9cd1
AB
1123 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1124 SV * ret;
80305961
YO
1125 dVAR;
1126 dXSARGS;
192b9cd1
AB
1127
1128 if (items != 0)
afa74d42 1129 croak_xs_usage(cv, "");
192b9cd1
AB
1130
1131 SP -= items;
1132
1133 if (!rx)
1134 XSRETURN_UNDEF;
1135
1136 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1137
1138 SPAGAIN;
1139
1140 if (ret) {
ec83ea38 1141 mXPUSHs(ret);
192b9cd1
AB
1142 PUTBACK;
1143 return;
1144 } else {
1145 XSRETURN_UNDEF;
1146 }
1147}
1148
1149XS(XS_re_regname)
1150{
1151 dVAR;
1152 dXSARGS;
1153 REGEXP * rx;
1154 U32 flags;
1155 SV * ret;
1156
28d8d7f4 1157 if (items < 1 || items > 2)
afa74d42 1158 croak_xs_usage(cv, "name[, all ]");
192b9cd1 1159
80305961 1160 SP -= items;
80305961 1161
192b9cd1
AB
1162 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1163
1164 if (!rx)
1165 XSRETURN_UNDEF;
1166
1167 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 1168 flags = RXapif_ALL;
192b9cd1 1169 } else {
f1b875a0 1170 flags = RXapif_ONE;
80305961 1171 }
f1b875a0 1172 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1
AB
1173
1174 if (ret) {
ec83ea38 1175 mXPUSHs(ret);
192b9cd1
AB
1176 XSRETURN(1);
1177 }
1178 XSRETURN_UNDEF;
80305961
YO
1179}
1180
192b9cd1 1181
80305961
YO
1182XS(XS_re_regnames)
1183{
192b9cd1 1184 dVAR;
80305961 1185 dXSARGS;
192b9cd1
AB
1186 REGEXP * rx;
1187 U32 flags;
1188 SV *ret;
1189 AV *av;
1190 I32 length;
1191 I32 i;
1192 SV **entry;
1193
1194 if (items > 1)
afa74d42 1195 croak_xs_usage(cv, "[all]");
192b9cd1
AB
1196
1197 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1198
1199 if (!rx)
1200 XSRETURN_UNDEF;
1201
1202 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 1203 flags = RXapif_ALL;
192b9cd1 1204 } else {
f1b875a0 1205 flags = RXapif_ONE;
192b9cd1
AB
1206 }
1207
80305961 1208 SP -= items;
80305961 1209
f1b875a0 1210 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
1211
1212 SPAGAIN;
1213
1214 SP -= items;
1215
1216 if (!ret)
1217 XSRETURN_UNDEF;
1218
502c6561 1219 av = MUTABLE_AV(SvRV(ret));
192b9cd1
AB
1220 length = av_len(av);
1221
1222 for (i = 0; i <= length; i++) {
1223 entry = av_fetch(av, i, FALSE);
1224
1225 if (!entry)
1226 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1227
ec83ea38 1228 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 1229 }
ec83ea38
MHM
1230
1231 SvREFCNT_dec(ret);
1232
192b9cd1
AB
1233 PUTBACK;
1234 return;
80305961
YO
1235}
1236
192c1e27
JH
1237XS(XS_re_regexp_pattern)
1238{
1239 dVAR;
1240 dXSARGS;
1241 REGEXP *re;
192c1e27
JH
1242
1243 if (items != 1)
afa74d42 1244 croak_xs_usage(cv, "sv");
192c1e27
JH
1245
1246 SP -= items;
1247
1248 /*
1249 Checks if a reference is a regex or not. If the parameter is
1250 not a ref, or is not the result of a qr// then returns false
1251 in scalar context and an empty list in list context.
1252 Otherwise in list context it returns the pattern and the
1253 modifiers, in scalar context it returns the pattern just as it
1254 would if the qr// was stringified normally, regardless as
1255 to the class of the variable and any strigification overloads
1256 on the object.
1257 */
1258
1259 if ((re = SvRX(ST(0)))) /* assign deliberate */
1260 {
1261 /* Housten, we have a regex! */
1262 SV *pattern;
1263 STRLEN left = 0;
1264 char reflags[6];
1265
1266 if ( GIMME_V == G_ARRAY ) {
1267 /*
1268 we are in list context so stringify
1269 the modifiers that apply. We ignore "negative
1270 modifiers" in this scenario.
1271 */
1272
1273 const char *fptr = INT_PAT_MODS;
1274 char ch;
1275 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1276 >> RXf_PMf_STD_PMMOD_SHIFT);
1277
1278 while((ch = *fptr++)) {
1279 if(match_flags & 1) {
1280 reflags[left++] = ch;
1281 }
1282 match_flags >>= 1;
1283 }
1284
fb632ce3
NC
1285 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1286 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1287
1288 /* return the pattern and the modifiers */
1289 XPUSHs(pattern);
fb632ce3 1290 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
1291 XSRETURN(2);
1292 } else {
1293 /* Scalar, so use the string that Perl would return */
1294 /* return the pattern in (?msix:..) format */
1295#if PERL_VERSION >= 11
daba3364 1296 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 1297#else
fb632ce3
NC
1298 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1299 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1300#endif
1301 XPUSHs(pattern);
1302 XSRETURN(1);
1303 }
1304 } else {
1305 /* It ain't a regexp folks */
1306 if ( GIMME_V == G_ARRAY ) {
1307 /* return the empty list */
1308 XSRETURN_UNDEF;
1309 } else {
1310 /* Because of the (?:..) wrapping involved in a
1311 stringified pattern it is impossible to get a
1312 result for a real regexp that would evaluate to
1313 false. Therefore we can return PL_sv_no to signify
1314 that the object is not a regex, this means that one
1315 can say
1316
1317 if (regex($might_be_a_regex) eq '(?:foo)') { }
1318
1319 and not worry about undefined values.
1320 */
1321 XSRETURN_NO;
1322 }
1323 }
1324 /* NOT-REACHED */
1325}
1326
192b9cd1 1327XS(XS_Tie_Hash_NamedCapture_FETCH)
80305961 1328{
192b9cd1 1329 dVAR;
80305961 1330 dXSARGS;
192b9cd1
AB
1331 REGEXP * rx;
1332 U32 flags;
1333 SV * ret;
1334
1335 if (items != 2)
afa74d42 1336 croak_xs_usage(cv, "$key, $flags");
192b9cd1
AB
1337
1338 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1339
1340 if (!rx)
1341 XSRETURN_UNDEF;
1342
80305961 1343 SP -= items;
192b9cd1 1344
daba3364 1345 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1346 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1347
1348 SPAGAIN;
1349
1350 if (ret) {
ec83ea38 1351 mXPUSHs(ret);
192b9cd1
AB
1352 PUTBACK;
1353 return;
1354 }
1355 XSRETURN_UNDEF;
1356}
1357
1358XS(XS_Tie_Hash_NamedCapture_STORE)
1359{
1360 dVAR;
1361 dXSARGS;
1362 REGEXP * rx;
1363 U32 flags;
1364
1365 if (items != 3)
afa74d42 1366 croak_xs_usage(cv, "$key, $value, $flags");
192b9cd1
AB
1367
1368 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1369
1370 if (!rx) {
1371 if (!PL_localizing)
f1f66076 1372 Perl_croak(aTHX_ "%s", PL_no_modify);
192b9cd1 1373 else
28d8d7f4 1374 XSRETURN_UNDEF;
80305961 1375 }
192b9cd1
AB
1376
1377 SP -= items;
1378
daba3364 1379 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1 1380 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
80305961
YO
1381}
1382
192b9cd1
AB
1383XS(XS_Tie_Hash_NamedCapture_DELETE)
1384{
1385 dVAR;
1386 dXSARGS;
1387 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1388 U32 flags;
80305961 1389
192b9cd1 1390 if (items != 2)
afa74d42 1391 croak_xs_usage(cv, "$key, $flags");
192b9cd1
AB
1392
1393 if (!rx)
f1f66076 1394 Perl_croak(aTHX_ "%s", PL_no_modify);
192b9cd1
AB
1395
1396 SP -= items;
1397
daba3364 1398 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1399 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1400}
1401
1402XS(XS_Tie_Hash_NamedCapture_CLEAR)
80305961 1403{
192b9cd1 1404 dVAR;
80305961 1405 dXSARGS;
192b9cd1
AB
1406 REGEXP * rx;
1407 U32 flags;
1408
1409 if (items != 1)
afa74d42 1410 croak_xs_usage(cv, "$flags");
192b9cd1
AB
1411
1412 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1413
1414 if (!rx)
f1f66076 1415 Perl_croak(aTHX_ "%s", PL_no_modify);
192b9cd1 1416
80305961 1417 SP -= items;
80305961 1418
daba3364 1419 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1420 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1421}
1422
1423XS(XS_Tie_Hash_NamedCapture_EXISTS)
1424{
1425 dVAR;
1426 dXSARGS;
1427 REGEXP * rx;
1428 U32 flags;
1429 SV * ret;
1430
1431 if (items != 2)
afa74d42 1432 croak_xs_usage(cv, "$key, $flags");
192b9cd1
AB
1433
1434 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1435
1436 if (!rx)
28d8d7f4 1437 XSRETURN_UNDEF;
192b9cd1
AB
1438
1439 SP -= items;
1440
daba3364 1441 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1442 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1443
1444 SPAGAIN;
1445
1446 XPUSHs(ret);
80305961
YO
1447 PUTBACK;
1448 return;
80305961
YO
1449}
1450
86aa3d53 1451XS(XS_Tie_Hash_NamedCapture_FIRSTK)
192b9cd1
AB
1452{
1453 dVAR;
1454 dXSARGS;
1455 REGEXP * rx;
1456 U32 flags;
1457 SV * ret;
80305961 1458
192b9cd1 1459 if (items != 1)
afa74d42 1460 croak_xs_usage(cv, "");
192b9cd1
AB
1461
1462 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1463
1464 if (!rx)
1465 XSRETURN_UNDEF;
1466
1467 SP -= items;
1468
daba3364 1469 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1470 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1471
1472 SPAGAIN;
1473
1474 if (ret) {
ec83ea38 1475 mXPUSHs(ret);
192b9cd1
AB
1476 PUTBACK;
1477 } else {
1478 XSRETURN_UNDEF;
1479 }
1480
1481}
1482
86aa3d53 1483XS(XS_Tie_Hash_NamedCapture_NEXTK)
80305961 1484{
192b9cd1 1485 dVAR;
80305961 1486 dXSARGS;
192b9cd1
AB
1487 REGEXP * rx;
1488 U32 flags;
1489 SV * ret;
1490
1491 if (items != 2)
afa74d42 1492 croak_xs_usage(cv, "$lastkey");
192b9cd1
AB
1493
1494 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1495
1496 if (!rx)
1497 XSRETURN_UNDEF;
80305961 1498
80305961 1499 SP -= items;
192b9cd1 1500
daba3364 1501 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1502 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1503
1504 SPAGAIN;
1505
1506 if (ret) {
ec83ea38 1507 mXPUSHs(ret);
80305961
YO
1508 } else {
1509 XSRETURN_UNDEF;
1510 }
1511 PUTBACK;
192b9cd1
AB
1512}
1513
1514XS(XS_Tie_Hash_NamedCapture_SCALAR)
1515{
1516 dVAR;
1517 dXSARGS;
1518 REGEXP * rx;
1519 U32 flags;
1520 SV * ret;
1521
1522 if (items != 1)
afa74d42 1523 croak_xs_usage(cv, "");
192b9cd1
AB
1524
1525 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1526
1527 if (!rx)
1528 XSRETURN_UNDEF;
1529
1530 SP -= items;
1531
daba3364 1532 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1533 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1534
1535 SPAGAIN;
1536
1537 if (ret) {
ec83ea38 1538 mXPUSHs(ret);
192b9cd1
AB
1539 PUTBACK;
1540 return;
1541 } else {
1542 XSRETURN_UNDEF;
1543 }
1544}
1545
1546XS(XS_Tie_Hash_NamedCapture_flags)
1547{
1548 dVAR;
1549 dXSARGS;
1550
1551 if (items != 0)
afa74d42 1552 croak_xs_usage(cv, "");
192b9cd1 1553
6e449a3a
MHM
1554 mXPUSHu(RXapif_ONE);
1555 mXPUSHu(RXapif_ALL);
192b9cd1
AB
1556 PUTBACK;
1557 return;
80305961
YO
1558}
1559
1560
241d1a3b
NC
1561/*
1562 * Local variables:
1563 * c-indentation-style: bsd
1564 * c-basic-offset: 4
1565 * indent-tabs-mode: t
1566 * End:
1567 *
37442d52
RGS
1568 * ex: set ts=8 sts=4 sw=4 noet:
1569 */