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