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