This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Removed obsolete E32Dll dll entry point which was removed from Symbian SDKs a long...
[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
PP
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
PP
106 }
107
a9ec700e 108 return FALSE;
6d4a7be2
PP
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
PP
132
133 if (SvROK(sv)) {
0b6f4f5c 134 const char *type;
55497cff
PP
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
PP
140 }
141 else {
da51bb9b 142 stash = gv_stashsv(sv, 0);
55497cff 143 }
46e4b22b 144
4a9e32d8 145 return stash ? isa_lookup(stash, name) : FALSE;
55497cff
PP
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);
9a7034eb 236XS(XS_Internals_hash_seed);
008fb0c0 237XS(XS_Internals_rehash_seed);
05619474 238XS(XS_Internals_HvREHASH);
80305961 239XS(XS_re_is_regexp);
192b9cd1
AB
240XS(XS_re_regname);
241XS(XS_re_regnames);
80305961 242XS(XS_re_regnames_count);
192c1e27 243XS(XS_re_regexp_pattern);
192b9cd1
AB
244XS(XS_Tie_Hash_NamedCapture_FETCH);
245XS(XS_Tie_Hash_NamedCapture_STORE);
246XS(XS_Tie_Hash_NamedCapture_DELETE);
247XS(XS_Tie_Hash_NamedCapture_CLEAR);
248XS(XS_Tie_Hash_NamedCapture_EXISTS);
86aa3d53
CB
249XS(XS_Tie_Hash_NamedCapture_FIRSTK);
250XS(XS_Tie_Hash_NamedCapture_NEXTK);
192b9cd1
AB
251XS(XS_Tie_Hash_NamedCapture_SCALAR);
252XS(XS_Tie_Hash_NamedCapture_flags);
0cb96387
GS
253
254void
255Perl_boot_core_UNIVERSAL(pTHX)
256{
97aff369 257 dVAR;
157e3fc8 258 static const char file[] = __FILE__;
0cb96387
GS
259
260 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
261 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
cbc021f9 262 newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file);
0cb96387 263 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
439cb1c4 264 {
ad63d80f
JP
265 /* register the overloading (type 'A') magic */
266 PL_amagic_generation++;
439cb1c4 267 /* Make it findable via fetchmethod */
be2ebcad 268 newXS("version::()", XS_version_noop, file);
439cb1c4
JP
269 newXS("version::new", XS_version_new, file);
270 newXS("version::(\"\"", XS_version_stringify, file);
271 newXS("version::stringify", XS_version_stringify, file);
272 newXS("version::(0+", XS_version_numify, file);
273 newXS("version::numify", XS_version_numify, file);
9137345a 274 newXS("version::normal", XS_version_normal, file);
439cb1c4
JP
275 newXS("version::(cmp", XS_version_vcmp, file);
276 newXS("version::(<=>", XS_version_vcmp, file);
277 newXS("version::vcmp", XS_version_vcmp, file);
278 newXS("version::(bool", XS_version_boolean, file);
279 newXS("version::boolean", XS_version_boolean, file);
280 newXS("version::(nomethod", XS_version_noop, file);
281 newXS("version::noop", XS_version_noop, file);
c8d69e4a 282 newXS("version::is_alpha", XS_version_is_alpha, file);
137d6fc0 283 newXS("version::qv", XS_version_qv, file);
439cb1c4 284 }
8800c35a 285 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
1b026014
NIS
286 newXS("utf8::valid", XS_utf8_valid, file);
287 newXS("utf8::encode", XS_utf8_encode, file);
288 newXS("utf8::decode", XS_utf8_decode, file);
289 newXS("utf8::upgrade", XS_utf8_upgrade, file);
290 newXS("utf8::downgrade", XS_utf8_downgrade, file);
291 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
292 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577
JH
293 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
294 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f 295 newXSproto("Internals::hv_clear_placeholders",
f044d0d1 296 XS_Internals_hv_clear_placehold, file, "\\%");
9d569fce
JH
297 newXSproto("PerlIO::get_layers",
298 XS_PerlIO_get_layers, file, "*;@");
85a79b09 299 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
d5cecc0e
NC
300 CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
301 = (char *)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
PP
358XS(XS_UNIVERSAL_isa)
359{
97aff369 360 dVAR;
6d4a7be2 361 dXSARGS;
6d4a7be2
PP
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
PP
380}
381
6d4a7be2
PP
382XS(XS_UNIVERSAL_can)
383{
97aff369 384 dVAR;
6d4a7be2
PP
385 dXSARGS;
386 SV *sv;
6867be6d 387 const char *name;
6d4a7be2 388 SV *rv;
6f08146e 389 HV *pkg = NULL;
6d4a7be2
PP
390
391 if (items != 2)
afa74d42 392 croak_xs_usage(cv, "object-ref, method");
6d4a7be2
PP
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
PP
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
PP
444XS(XS_UNIVERSAL_VERSION)
445{
97aff369 446 dVAR;
6d4a7be2
PP
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
PP
459 pkg = SvSTASH(sv);
460 }
461 else {
da51bb9b 462 pkg = gv_stashsv(ST(0), 0);
6d4a7be2
PP
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
PP
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
PP
474 }
475 else {
daba3364 476 sv = &PL_sv_undef;
6d4a7be2
PP
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
PP
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
JH
929
930XS(XS_PerlIO_get_layers)
931{
97aff369 932 dVAR;
39f7a870
JH
933 dXSARGS;
934 if (items < 1 || items % 2 == 0)
afa74d42 935 croak_xs_usage(cv, "filehandle[,args]");
5fef3b4a 936#ifdef USE_PERLIO
39f7a870
JH
937 {
938 SV * sv;
939 GV * gv;
940 IO * io;
941 bool input = TRUE;
942 bool details = FALSE;
943
944 if (items > 1) {
c4420975 945 SV * const *svp;
39f7a870 946 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
947 SV * const * const varp = svp;
948 SV * const * const valp = svp + 1;
39f7a870 949 STRLEN klen;
c4420975 950 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
951
952 switch (*key) {
953 case 'i':
954 if (klen == 5 && memEQ(key, "input", 5)) {
955 input = SvTRUE(*valp);
956 break;
957 }
958 goto fail;
959 case 'o':
960 if (klen == 6 && memEQ(key, "output", 6)) {
961 input = !SvTRUE(*valp);
962 break;
963 }
964 goto fail;
965 case 'd':
966 if (klen == 7 && memEQ(key, "details", 7)) {
967 details = SvTRUE(*valp);
968 break;
969 }
970 goto fail;
971 default:
972 fail:
973 Perl_croak(aTHX_
974 "get_layers: unknown argument '%s'",
975 key);
976 }
977 }
978
979 SP -= (items - 1);
980 }
981
982 sv = POPs;
159b6efe 983 gv = MUTABLE_GV(sv);
39f7a870
JH
984
985 if (!isGV(sv)) {
986 if (SvROK(sv) && isGV(SvRV(sv)))
159b6efe 987 gv = MUTABLE_GV(SvRV(sv));
671d49be 988 else if (SvPOKp(sv))
f776e3cd 989 gv = gv_fetchsv(sv, 0, SVt_PVIO);
39f7a870
JH
990 }
991
992 if (gv && (io = GvIO(gv))) {
c4420975 993 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870
JH
994 IoIFP(io) : IoOFP(io));
995 I32 i;
c4420975 996 const I32 last = av_len(av);
39f7a870
JH
997 I32 nitem = 0;
998
999 for (i = last; i >= 0; i -= 3) {
c4420975
AL
1000 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1001 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1002 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 1003
c4420975
AL
1004 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1005 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1006 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870
JH
1007
1008 if (details) {
92e45a3e
NC
1009 /* Indents of 5? Yuck. */
1010 /* We know that PerlIO_get_layers creates a new SV for
1011 the name and flags, so we can just take a reference
1012 and "steal" it when we free the AV below. */
ec3bab8e 1013 XPUSHs(namok
92e45a3e 1014 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e
NC
1015 : &PL_sv_undef);
1016 XPUSHs(argok
92e45a3e
NC
1017 ? newSVpvn_flags(SvPVX_const(*argsvp),
1018 SvCUR(*argsvp),
1019 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1020 | SVs_TEMP)
1021 : &PL_sv_undef);
96ccaf53 1022 XPUSHs(flgok
92e45a3e 1023 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 1024 : &PL_sv_undef);
39f7a870
JH
1025 nitem += 3;
1026 }
1027 else {
1028 if (namok && argok)
1eb9e81d 1029 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 1030 SVfARG(*namsvp),
1eb9e81d 1031 SVfARG(*argsvp))));
39f7a870 1032 else if (namok)
92e45a3e 1033 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870
JH
1034 else
1035 XPUSHs(&PL_sv_undef);
1036 nitem++;
1037 if (flgok) {
c4420975 1038 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
1039
1040 if (flags & PERLIO_F_UTF8) {
84bafc02 1041 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
1042 nitem++;
1043 }
1044 }
1045 }
1046 }
1047
1048 SvREFCNT_dec(av);
1049
1050 XSRETURN(nitem);
1051 }
1052 }
5fef3b4a 1053#endif
39f7a870
JH
1054
1055 XSRETURN(0);
1056}
1057
9a7034eb 1058XS(XS_Internals_hash_seed)
c910b28a 1059{
97aff369 1060 dVAR;
c85d3f85
NC
1061 /* Using dXSARGS would also have dITEM and dSP,
1062 * which define 2 unused local variables. */
557b887a 1063 dAXMARK;
53c1dcc0 1064 PERL_UNUSED_ARG(cv);
ad73156c 1065 PERL_UNUSED_VAR(mark);
81eaca17 1066 XSRETURN_UV(PERL_HASH_SEED);
c910b28a
JH
1067}
1068
008fb0c0 1069XS(XS_Internals_rehash_seed)
8e90d776 1070{
97aff369 1071 dVAR;
8e90d776
NC
1072 /* Using dXSARGS would also have dITEM and dSP,
1073 * which define 2 unused local variables. */
557b887a 1074 dAXMARK;
53c1dcc0 1075 PERL_UNUSED_ARG(cv);
ad73156c 1076 PERL_UNUSED_VAR(mark);
008fb0c0 1077 XSRETURN_UV(PL_rehash_seed);
8e90d776
NC
1078}
1079
05619474
NC
1080XS(XS_Internals_HvREHASH) /* Subject to change */
1081{
97aff369 1082 dVAR;
05619474 1083 dXSARGS;
93c51217 1084 PERL_UNUSED_ARG(cv);
05619474 1085 if (SvROK(ST(0))) {
ef8f7699 1086 const HV * const hv = (const HV *) SvRV(ST(0));
05619474
NC
1087 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1088 if (HvREHASH(hv))
1089 XSRETURN_YES;
1090 else
1091 XSRETURN_NO;
1092 }
1093 }
1094 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1095}
241d1a3b 1096
80305961
YO
1097XS(XS_re_is_regexp)
1098{
1099 dVAR;
1100 dXSARGS;
f7e71195
AB
1101 PERL_UNUSED_VAR(cv);
1102
80305961 1103 if (items != 1)
afa74d42 1104 croak_xs_usage(cv, "sv");
f7e71195 1105
80305961 1106 SP -= items;
f7e71195
AB
1107
1108 if (SvRXOK(ST(0))) {
1109 XSRETURN_YES;
1110 } else {
1111 XSRETURN_NO;
80305961
YO
1112 }
1113}
1114
192b9cd1 1115XS(XS_re_regnames_count)
80305961 1116{
192b9cd1
AB
1117 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1118 SV * ret;
80305961
YO
1119 dVAR;
1120 dXSARGS;
192b9cd1
AB
1121
1122 if (items != 0)
afa74d42 1123 croak_xs_usage(cv, "");
192b9cd1
AB
1124
1125 SP -= items;
1126
1127 if (!rx)
1128 XSRETURN_UNDEF;
1129
1130 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1131
1132 SPAGAIN;
1133
1134 if (ret) {
ec83ea38 1135 mXPUSHs(ret);
192b9cd1
AB
1136 PUTBACK;
1137 return;
1138 } else {
1139 XSRETURN_UNDEF;
1140 }
1141}
1142
1143XS(XS_re_regname)
1144{
1145 dVAR;
1146 dXSARGS;
1147 REGEXP * rx;
1148 U32 flags;
1149 SV * ret;
1150
28d8d7f4 1151 if (items < 1 || items > 2)
afa74d42 1152 croak_xs_usage(cv, "name[, all ]");
192b9cd1 1153
80305961 1154 SP -= items;
80305961 1155
192b9cd1
AB
1156 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1157
1158 if (!rx)
1159 XSRETURN_UNDEF;
1160
1161 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 1162 flags = RXapif_ALL;
192b9cd1 1163 } else {
f1b875a0 1164 flags = RXapif_ONE;
80305961 1165 }
f1b875a0 1166 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1
AB
1167
1168 if (ret) {
ec83ea38 1169 mXPUSHs(ret);
192b9cd1
AB
1170 XSRETURN(1);
1171 }
1172 XSRETURN_UNDEF;
80305961
YO
1173}
1174
192b9cd1 1175
80305961
YO
1176XS(XS_re_regnames)
1177{
192b9cd1 1178 dVAR;
80305961 1179 dXSARGS;
192b9cd1
AB
1180 REGEXP * rx;
1181 U32 flags;
1182 SV *ret;
1183 AV *av;
1184 I32 length;
1185 I32 i;
1186 SV **entry;
1187
1188 if (items > 1)
afa74d42 1189 croak_xs_usage(cv, "[all]");
192b9cd1
AB
1190
1191 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1192
1193 if (!rx)
1194 XSRETURN_UNDEF;
1195
1196 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 1197 flags = RXapif_ALL;
192b9cd1 1198 } else {
f1b875a0 1199 flags = RXapif_ONE;
192b9cd1
AB
1200 }
1201
80305961 1202 SP -= items;
80305961 1203
f1b875a0 1204 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
1205
1206 SPAGAIN;
1207
1208 SP -= items;
1209
1210 if (!ret)
1211 XSRETURN_UNDEF;
1212
502c6561 1213 av = MUTABLE_AV(SvRV(ret));
192b9cd1
AB
1214 length = av_len(av);
1215
1216 for (i = 0; i <= length; i++) {
1217 entry = av_fetch(av, i, FALSE);
1218
1219 if (!entry)
1220 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1221
ec83ea38 1222 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 1223 }
ec83ea38
MHM
1224
1225 SvREFCNT_dec(ret);
1226
192b9cd1
AB
1227 PUTBACK;
1228 return;
80305961
YO
1229}
1230
192c1e27
JH
1231XS(XS_re_regexp_pattern)
1232{
1233 dVAR;
1234 dXSARGS;
1235 REGEXP *re;
192c1e27
JH
1236
1237 if (items != 1)
afa74d42 1238 croak_xs_usage(cv, "sv");
192c1e27
JH
1239
1240 SP -= items;
1241
1242 /*
1243 Checks if a reference is a regex or not. If the parameter is
1244 not a ref, or is not the result of a qr// then returns false
1245 in scalar context and an empty list in list context.
1246 Otherwise in list context it returns the pattern and the
1247 modifiers, in scalar context it returns the pattern just as it
1248 would if the qr// was stringified normally, regardless as
1249 to the class of the variable and any strigification overloads
1250 on the object.
1251 */
1252
1253 if ((re = SvRX(ST(0)))) /* assign deliberate */
1254 {
1255 /* Housten, we have a regex! */
1256 SV *pattern;
1257 STRLEN left = 0;
1258 char reflags[6];
1259
1260 if ( GIMME_V == G_ARRAY ) {
1261 /*
1262 we are in list context so stringify
1263 the modifiers that apply. We ignore "negative
1264 modifiers" in this scenario.
1265 */
1266
1267 const char *fptr = INT_PAT_MODS;
1268 char ch;
1269 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1270 >> RXf_PMf_STD_PMMOD_SHIFT);
1271
1272 while((ch = *fptr++)) {
1273 if(match_flags & 1) {
1274 reflags[left++] = ch;
1275 }
1276 match_flags >>= 1;
1277 }
1278
fb632ce3
NC
1279 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1280 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1281
1282 /* return the pattern and the modifiers */
1283 XPUSHs(pattern);
fb632ce3 1284 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
1285 XSRETURN(2);
1286 } else {
1287 /* Scalar, so use the string that Perl would return */
1288 /* return the pattern in (?msix:..) format */
1289#if PERL_VERSION >= 11
daba3364 1290 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 1291#else
fb632ce3
NC
1292 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1293 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1294#endif
1295 XPUSHs(pattern);
1296 XSRETURN(1);
1297 }
1298 } else {
1299 /* It ain't a regexp folks */
1300 if ( GIMME_V == G_ARRAY ) {
1301 /* return the empty list */
1302 XSRETURN_UNDEF;
1303 } else {
1304 /* Because of the (?:..) wrapping involved in a
1305 stringified pattern it is impossible to get a
1306 result for a real regexp that would evaluate to
1307 false. Therefore we can return PL_sv_no to signify
1308 that the object is not a regex, this means that one
1309 can say
1310
1311 if (regex($might_be_a_regex) eq '(?:foo)') { }
1312
1313 and not worry about undefined values.
1314 */
1315 XSRETURN_NO;
1316 }
1317 }
1318 /* NOT-REACHED */
1319}
1320
192b9cd1 1321XS(XS_Tie_Hash_NamedCapture_FETCH)
80305961 1322{
192b9cd1 1323 dVAR;
80305961 1324 dXSARGS;
192b9cd1
AB
1325 REGEXP * rx;
1326 U32 flags;
1327 SV * ret;
1328
1329 if (items != 2)
afa74d42 1330 croak_xs_usage(cv, "$key, $flags");
192b9cd1
AB
1331
1332 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1333
1334 if (!rx)
1335 XSRETURN_UNDEF;
1336
80305961 1337 SP -= items;
192b9cd1 1338
daba3364 1339 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1340 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1341
1342 SPAGAIN;
1343
1344 if (ret) {
ec83ea38 1345 mXPUSHs(ret);
192b9cd1
AB
1346 PUTBACK;
1347 return;
1348 }
1349 XSRETURN_UNDEF;
1350}
1351
1352XS(XS_Tie_Hash_NamedCapture_STORE)
1353{
1354 dVAR;
1355 dXSARGS;
1356 REGEXP * rx;
1357 U32 flags;
1358
1359 if (items != 3)
afa74d42 1360 croak_xs_usage(cv, "$key, $value, $flags");
192b9cd1
AB
1361
1362 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1363
1364 if (!rx) {
1365 if (!PL_localizing)
f1f66076 1366 Perl_croak(aTHX_ "%s", PL_no_modify);
192b9cd1 1367 else
28d8d7f4 1368 XSRETURN_UNDEF;
80305961 1369 }
192b9cd1
AB
1370
1371 SP -= items;
1372
daba3364 1373 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1 1374 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
80305961
YO
1375}
1376
192b9cd1
AB
1377XS(XS_Tie_Hash_NamedCapture_DELETE)
1378{
1379 dVAR;
1380 dXSARGS;
1381 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1382 U32 flags;
80305961 1383
192b9cd1 1384 if (items != 2)
afa74d42 1385 croak_xs_usage(cv, "$key, $flags");
192b9cd1
AB
1386
1387 if (!rx)
f1f66076 1388 Perl_croak(aTHX_ "%s", PL_no_modify);
192b9cd1
AB
1389
1390 SP -= items;
1391
daba3364 1392 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1393 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1394}
1395
1396XS(XS_Tie_Hash_NamedCapture_CLEAR)
80305961 1397{
192b9cd1 1398 dVAR;
80305961 1399 dXSARGS;
192b9cd1
AB
1400 REGEXP * rx;
1401 U32 flags;
1402
1403 if (items != 1)
afa74d42 1404 croak_xs_usage(cv, "$flags");
192b9cd1
AB
1405
1406 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1407
1408 if (!rx)
f1f66076 1409 Perl_croak(aTHX_ "%s", PL_no_modify);
192b9cd1 1410
80305961 1411 SP -= items;
80305961 1412
daba3364 1413 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1414 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1415}
1416
1417XS(XS_Tie_Hash_NamedCapture_EXISTS)
1418{
1419 dVAR;
1420 dXSARGS;
1421 REGEXP * rx;
1422 U32 flags;
1423 SV * ret;
1424
1425 if (items != 2)
afa74d42 1426 croak_xs_usage(cv, "$key, $flags");
192b9cd1
AB
1427
1428 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1429
1430 if (!rx)
28d8d7f4 1431 XSRETURN_UNDEF;
192b9cd1
AB
1432
1433 SP -= items;
1434
daba3364 1435 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1436 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1437
1438 SPAGAIN;
1439
1440 XPUSHs(ret);
80305961
YO
1441 PUTBACK;
1442 return;
80305961
YO
1443}
1444
86aa3d53 1445XS(XS_Tie_Hash_NamedCapture_FIRSTK)
192b9cd1
AB
1446{
1447 dVAR;
1448 dXSARGS;
1449 REGEXP * rx;
1450 U32 flags;
1451 SV * ret;
80305961 1452
192b9cd1 1453 if (items != 1)
afa74d42 1454 croak_xs_usage(cv, "");
192b9cd1
AB
1455
1456 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1457
1458 if (!rx)
1459 XSRETURN_UNDEF;
1460
1461 SP -= items;
1462
daba3364 1463 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1464 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1465
1466 SPAGAIN;
1467
1468 if (ret) {
ec83ea38 1469 mXPUSHs(ret);
192b9cd1
AB
1470 PUTBACK;
1471 } else {
1472 XSRETURN_UNDEF;
1473 }
1474
1475}
1476
86aa3d53 1477XS(XS_Tie_Hash_NamedCapture_NEXTK)
80305961 1478{
192b9cd1 1479 dVAR;
80305961 1480 dXSARGS;
192b9cd1
AB
1481 REGEXP * rx;
1482 U32 flags;
1483 SV * ret;
1484
1485 if (items != 2)
afa74d42 1486 croak_xs_usage(cv, "$lastkey");
192b9cd1
AB
1487
1488 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1489
1490 if (!rx)
1491 XSRETURN_UNDEF;
80305961 1492
80305961 1493 SP -= items;
192b9cd1 1494
daba3364 1495 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1496 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1497
1498 SPAGAIN;
1499
1500 if (ret) {
ec83ea38 1501 mXPUSHs(ret);
80305961
YO
1502 } else {
1503 XSRETURN_UNDEF;
1504 }
1505 PUTBACK;
192b9cd1
AB
1506}
1507
1508XS(XS_Tie_Hash_NamedCapture_SCALAR)
1509{
1510 dVAR;
1511 dXSARGS;
1512 REGEXP * rx;
1513 U32 flags;
1514 SV * ret;
1515
1516 if (items != 1)
afa74d42 1517 croak_xs_usage(cv, "");
192b9cd1
AB
1518
1519 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1520
1521 if (!rx)
1522 XSRETURN_UNDEF;
1523
1524 SP -= items;
1525
daba3364 1526 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1527 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1528
1529 SPAGAIN;
1530
1531 if (ret) {
ec83ea38 1532 mXPUSHs(ret);
192b9cd1
AB
1533 PUTBACK;
1534 return;
1535 } else {
1536 XSRETURN_UNDEF;
1537 }
1538}
1539
1540XS(XS_Tie_Hash_NamedCapture_flags)
1541{
1542 dVAR;
1543 dXSARGS;
1544
1545 if (items != 0)
afa74d42 1546 croak_xs_usage(cv, "");
192b9cd1 1547
6e449a3a
MHM
1548 mXPUSHu(RXapif_ONE);
1549 mXPUSHu(RXapif_ALL);
192b9cd1
AB
1550 PUTBACK;
1551 return;
80305961
YO
1552}
1553
1554
241d1a3b
NC
1555/*
1556 * Local variables:
1557 * c-indentation-style: bsd
1558 * c-basic-offset: 4
1559 * indent-tabs-mode: t
1560 * End:
1561 *
37442d52
RGS
1562 * ex: set ts=8 sts=4 sw=4 noet:
1563 */