This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid multiple FETCHes
[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
AL
796 else {
797 const SV * const sv = ST(0);
798 if (SvUTF8(sv))
799 XSRETURN_YES;
800 else
801 XSRETURN_NO;
41be1fbd
JH
802 }
803 XSRETURN_EMPTY;
8800c35a
JH
804}
805
1b026014
NIS
806XS(XS_utf8_valid)
807{
97aff369 808 dVAR;
41be1fbd
JH
809 dXSARGS;
810 if (items != 1)
afa74d42 811 croak_xs_usage(cv, "sv");
c4420975
AL
812 else {
813 SV * const sv = ST(0);
814 STRLEN len;
815 const char * const s = SvPV_const(sv,len);
816 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
817 XSRETURN_YES;
818 else
819 XSRETURN_NO;
820 }
41be1fbd 821 XSRETURN_EMPTY;
1b026014
NIS
822}
823
824XS(XS_utf8_encode)
825{
97aff369 826 dVAR;
1b026014
NIS
827 dXSARGS;
828 if (items != 1)
afa74d42 829 croak_xs_usage(cv, "sv");
c4420975 830 sv_utf8_encode(ST(0));
1b026014
NIS
831 XSRETURN_EMPTY;
832}
833
834XS(XS_utf8_decode)
835{
97aff369 836 dVAR;
1b026014
NIS
837 dXSARGS;
838 if (items != 1)
afa74d42 839 croak_xs_usage(cv, "sv");
c4420975
AL
840 else {
841 SV * const sv = ST(0);
6867be6d 842 const bool RETVAL = sv_utf8_decode(sv);
1b026014
NIS
843 ST(0) = boolSV(RETVAL);
844 sv_2mortal(ST(0));
845 }
846 XSRETURN(1);
847}
848
849XS(XS_utf8_upgrade)
850{
97aff369 851 dVAR;
1b026014
NIS
852 dXSARGS;
853 if (items != 1)
afa74d42 854 croak_xs_usage(cv, "sv");
c4420975
AL
855 else {
856 SV * const sv = ST(0);
1b026014
NIS
857 STRLEN RETVAL;
858 dXSTARG;
859
860 RETVAL = sv_utf8_upgrade(sv);
861 XSprePUSH; PUSHi((IV)RETVAL);
862 }
863 XSRETURN(1);
864}
865
866XS(XS_utf8_downgrade)
867{
97aff369 868 dVAR;
1b026014
NIS
869 dXSARGS;
870 if (items < 1 || items > 2)
afa74d42 871 croak_xs_usage(cv, "sv, failok=0");
c4420975
AL
872 else {
873 SV * const sv = ST(0);
6867be6d
AL
874 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
875 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 876
1b026014
NIS
877 ST(0) = boolSV(RETVAL);
878 sv_2mortal(ST(0));
879 }
880 XSRETURN(1);
881}
882
883XS(XS_utf8_native_to_unicode)
884{
97aff369 885 dVAR;
1b026014 886 dXSARGS;
6867be6d 887 const UV uv = SvUV(ST(0));
b7953727
JH
888
889 if (items > 1)
afa74d42 890 croak_xs_usage(cv, "sv");
b7953727 891
1b026014
NIS
892 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
893 XSRETURN(1);
894}
895
896XS(XS_utf8_unicode_to_native)
897{
97aff369 898 dVAR;
1b026014 899 dXSARGS;
6867be6d 900 const UV uv = SvUV(ST(0));
b7953727
JH
901
902 if (items > 1)
afa74d42 903 croak_xs_usage(cv, "sv");
b7953727 904
1b026014
NIS
905 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
906 XSRETURN(1);
907}
908
14a976d6 909XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577 910{
97aff369 911 dVAR;
29569577 912 dXSARGS;
c4420975 913 SV * const sv = SvRV(ST(0));
58c0efa5 914 PERL_UNUSED_ARG(cv);
6867be6d 915
29569577
JH
916 if (items == 1) {
917 if (SvREADONLY(sv))
918 XSRETURN_YES;
919 else
920 XSRETURN_NO;
921 }
922 else if (items == 2) {
923 if (SvTRUE(ST(1))) {
924 SvREADONLY_on(sv);
925 XSRETURN_YES;
926 }
927 else {
14a976d6 928 /* I hope you really know what you are doing. */
29569577
JH
929 SvREADONLY_off(sv);
930 XSRETURN_NO;
931 }
932 }
14a976d6 933 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
934}
935
14a976d6 936XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577 937{
97aff369 938 dVAR;
29569577 939 dXSARGS;
c4420975 940 SV * const sv = SvRV(ST(0));
58c0efa5 941 PERL_UNUSED_ARG(cv);
6867be6d 942
29569577 943 if (items == 1)
14a976d6 944 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 945 else if (items == 2) {
14a976d6 946 /* I hope you really know what you are doing. */
29569577
JH
947 SvREFCNT(sv) = SvIV(ST(1));
948 XSRETURN_IV(SvREFCNT(sv));
949 }
14a976d6 950 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
951}
952
f044d0d1 953XS(XS_Internals_hv_clear_placehold)
dfd4ef2f 954{
97aff369 955 dVAR;
dfd4ef2f 956 dXSARGS;
6867be6d 957
3540d4ce 958 if (items != 1)
afa74d42 959 croak_xs_usage(cv, "hv");
c4420975 960 else {
ef8f7699 961 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
962 hv_clear_placeholders(hv);
963 XSRETURN(0);
964 }
dfd4ef2f 965}
39f7a870
JH
966
967XS(XS_PerlIO_get_layers)
968{
97aff369 969 dVAR;
39f7a870
JH
970 dXSARGS;
971 if (items < 1 || items % 2 == 0)
afa74d42 972 croak_xs_usage(cv, "filehandle[,args]");
5fef3b4a 973#ifdef USE_PERLIO
39f7a870
JH
974 {
975 SV * sv;
976 GV * gv;
977 IO * io;
978 bool input = TRUE;
979 bool details = FALSE;
980
981 if (items > 1) {
c4420975 982 SV * const *svp;
39f7a870 983 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
984 SV * const * const varp = svp;
985 SV * const * const valp = svp + 1;
39f7a870 986 STRLEN klen;
c4420975 987 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
988
989 switch (*key) {
990 case 'i':
991 if (klen == 5 && memEQ(key, "input", 5)) {
992 input = SvTRUE(*valp);
993 break;
994 }
995 goto fail;
996 case 'o':
997 if (klen == 6 && memEQ(key, "output", 6)) {
998 input = !SvTRUE(*valp);
999 break;
1000 }
1001 goto fail;
1002 case 'd':
1003 if (klen == 7 && memEQ(key, "details", 7)) {
1004 details = SvTRUE(*valp);
1005 break;
1006 }
1007 goto fail;
1008 default:
1009 fail:
1010 Perl_croak(aTHX_
1011 "get_layers: unknown argument '%s'",
1012 key);
1013 }
1014 }
1015
1016 SP -= (items - 1);
1017 }
1018
1019 sv = POPs;
159b6efe 1020 gv = MUTABLE_GV(sv);
39f7a870
JH
1021
1022 if (!isGV(sv)) {
1023 if (SvROK(sv) && isGV(SvRV(sv)))
159b6efe 1024 gv = MUTABLE_GV(SvRV(sv));
671d49be 1025 else if (SvPOKp(sv))
f776e3cd 1026 gv = gv_fetchsv(sv, 0, SVt_PVIO);
39f7a870
JH
1027 }
1028
1029 if (gv && (io = GvIO(gv))) {
c4420975 1030 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870
JH
1031 IoIFP(io) : IoOFP(io));
1032 I32 i;
c4420975 1033 const I32 last = av_len(av);
39f7a870
JH
1034 I32 nitem = 0;
1035
1036 for (i = last; i >= 0; i -= 3) {
c4420975
AL
1037 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1038 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1039 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 1040
c4420975
AL
1041 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1042 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1043 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870
JH
1044
1045 if (details) {
92e45a3e
NC
1046 /* Indents of 5? Yuck. */
1047 /* We know that PerlIO_get_layers creates a new SV for
1048 the name and flags, so we can just take a reference
1049 and "steal" it when we free the AV below. */
ec3bab8e 1050 XPUSHs(namok
92e45a3e 1051 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e
NC
1052 : &PL_sv_undef);
1053 XPUSHs(argok
92e45a3e
NC
1054 ? newSVpvn_flags(SvPVX_const(*argsvp),
1055 SvCUR(*argsvp),
1056 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
1057 | SVs_TEMP)
1058 : &PL_sv_undef);
96ccaf53 1059 XPUSHs(flgok
92e45a3e 1060 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 1061 : &PL_sv_undef);
39f7a870
JH
1062 nitem += 3;
1063 }
1064 else {
1065 if (namok && argok)
1eb9e81d 1066 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 1067 SVfARG(*namsvp),
1eb9e81d 1068 SVfARG(*argsvp))));
39f7a870 1069 else if (namok)
92e45a3e 1070 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870
JH
1071 else
1072 XPUSHs(&PL_sv_undef);
1073 nitem++;
1074 if (flgok) {
c4420975 1075 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
1076
1077 if (flags & PERLIO_F_UTF8) {
84bafc02 1078 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
1079 nitem++;
1080 }
1081 }
1082 }
1083 }
1084
1085 SvREFCNT_dec(av);
1086
1087 XSRETURN(nitem);
1088 }
1089 }
5fef3b4a 1090#endif
39f7a870
JH
1091
1092 XSRETURN(0);
1093}
1094
9a7034eb 1095XS(XS_Internals_hash_seed)
c910b28a 1096{
97aff369 1097 dVAR;
c85d3f85
NC
1098 /* Using dXSARGS would also have dITEM and dSP,
1099 * which define 2 unused local variables. */
557b887a 1100 dAXMARK;
53c1dcc0 1101 PERL_UNUSED_ARG(cv);
ad73156c 1102 PERL_UNUSED_VAR(mark);
81eaca17 1103 XSRETURN_UV(PERL_HASH_SEED);
c910b28a
JH
1104}
1105
008fb0c0 1106XS(XS_Internals_rehash_seed)
8e90d776 1107{
97aff369 1108 dVAR;
8e90d776
NC
1109 /* Using dXSARGS would also have dITEM and dSP,
1110 * which define 2 unused local variables. */
557b887a 1111 dAXMARK;
53c1dcc0 1112 PERL_UNUSED_ARG(cv);
ad73156c 1113 PERL_UNUSED_VAR(mark);
008fb0c0 1114 XSRETURN_UV(PL_rehash_seed);
8e90d776
NC
1115}
1116
05619474
NC
1117XS(XS_Internals_HvREHASH) /* Subject to change */
1118{
97aff369 1119 dVAR;
05619474 1120 dXSARGS;
93c51217 1121 PERL_UNUSED_ARG(cv);
05619474 1122 if (SvROK(ST(0))) {
ef8f7699 1123 const HV * const hv = (const HV *) SvRV(ST(0));
05619474
NC
1124 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1125 if (HvREHASH(hv))
1126 XSRETURN_YES;
1127 else
1128 XSRETURN_NO;
1129 }
1130 }
1131 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1132}
241d1a3b 1133
80305961
YO
1134XS(XS_re_is_regexp)
1135{
1136 dVAR;
1137 dXSARGS;
f7e71195
AB
1138 PERL_UNUSED_VAR(cv);
1139
80305961 1140 if (items != 1)
afa74d42 1141 croak_xs_usage(cv, "sv");
f7e71195 1142
80305961 1143 SP -= items;
f7e71195
AB
1144
1145 if (SvRXOK(ST(0))) {
1146 XSRETURN_YES;
1147 } else {
1148 XSRETURN_NO;
80305961
YO
1149 }
1150}
1151
192b9cd1 1152XS(XS_re_regnames_count)
80305961 1153{
192b9cd1
AB
1154 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1155 SV * ret;
80305961
YO
1156 dVAR;
1157 dXSARGS;
192b9cd1
AB
1158
1159 if (items != 0)
afa74d42 1160 croak_xs_usage(cv, "");
192b9cd1
AB
1161
1162 SP -= items;
1163
1164 if (!rx)
1165 XSRETURN_UNDEF;
1166
1167 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1168
1169 SPAGAIN;
1170
1171 if (ret) {
ec83ea38 1172 mXPUSHs(ret);
192b9cd1
AB
1173 PUTBACK;
1174 return;
1175 } else {
1176 XSRETURN_UNDEF;
1177 }
1178}
1179
1180XS(XS_re_regname)
1181{
1182 dVAR;
1183 dXSARGS;
1184 REGEXP * rx;
1185 U32 flags;
1186 SV * ret;
1187
28d8d7f4 1188 if (items < 1 || items > 2)
afa74d42 1189 croak_xs_usage(cv, "name[, all ]");
192b9cd1 1190
80305961 1191 SP -= items;
80305961 1192
192b9cd1
AB
1193 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1194
1195 if (!rx)
1196 XSRETURN_UNDEF;
1197
1198 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 1199 flags = RXapif_ALL;
192b9cd1 1200 } else {
f1b875a0 1201 flags = RXapif_ONE;
80305961 1202 }
f1b875a0 1203 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1
AB
1204
1205 if (ret) {
ec83ea38 1206 mXPUSHs(ret);
192b9cd1
AB
1207 XSRETURN(1);
1208 }
1209 XSRETURN_UNDEF;
80305961
YO
1210}
1211
192b9cd1 1212
80305961
YO
1213XS(XS_re_regnames)
1214{
192b9cd1 1215 dVAR;
80305961 1216 dXSARGS;
192b9cd1
AB
1217 REGEXP * rx;
1218 U32 flags;
1219 SV *ret;
1220 AV *av;
1221 I32 length;
1222 I32 i;
1223 SV **entry;
1224
1225 if (items > 1)
afa74d42 1226 croak_xs_usage(cv, "[all]");
192b9cd1
AB
1227
1228 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1229
1230 if (!rx)
1231 XSRETURN_UNDEF;
1232
1233 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 1234 flags = RXapif_ALL;
192b9cd1 1235 } else {
f1b875a0 1236 flags = RXapif_ONE;
192b9cd1
AB
1237 }
1238
80305961 1239 SP -= items;
80305961 1240
f1b875a0 1241 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
1242
1243 SPAGAIN;
1244
1245 SP -= items;
1246
1247 if (!ret)
1248 XSRETURN_UNDEF;
1249
502c6561 1250 av = MUTABLE_AV(SvRV(ret));
192b9cd1
AB
1251 length = av_len(av);
1252
1253 for (i = 0; i <= length; i++) {
1254 entry = av_fetch(av, i, FALSE);
1255
1256 if (!entry)
1257 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1258
ec83ea38 1259 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 1260 }
ec83ea38
MHM
1261
1262 SvREFCNT_dec(ret);
1263
192b9cd1
AB
1264 PUTBACK;
1265 return;
80305961
YO
1266}
1267
192c1e27
JH
1268XS(XS_re_regexp_pattern)
1269{
1270 dVAR;
1271 dXSARGS;
1272 REGEXP *re;
192c1e27
JH
1273
1274 if (items != 1)
afa74d42 1275 croak_xs_usage(cv, "sv");
192c1e27
JH
1276
1277 SP -= items;
1278
1279 /*
1280 Checks if a reference is a regex or not. If the parameter is
1281 not a ref, or is not the result of a qr// then returns false
1282 in scalar context and an empty list in list context.
1283 Otherwise in list context it returns the pattern and the
1284 modifiers, in scalar context it returns the pattern just as it
1285 would if the qr// was stringified normally, regardless as
1286 to the class of the variable and any strigification overloads
1287 on the object.
1288 */
1289
1290 if ((re = SvRX(ST(0)))) /* assign deliberate */
1291 {
1292 /* Housten, we have a regex! */
1293 SV *pattern;
1294 STRLEN left = 0;
1295 char reflags[6];
1296
1297 if ( GIMME_V == G_ARRAY ) {
1298 /*
1299 we are in list context so stringify
1300 the modifiers that apply. We ignore "negative
1301 modifiers" in this scenario.
1302 */
1303
1304 const char *fptr = INT_PAT_MODS;
1305 char ch;
1306 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1307 >> RXf_PMf_STD_PMMOD_SHIFT);
1308
1309 while((ch = *fptr++)) {
1310 if(match_flags & 1) {
1311 reflags[left++] = ch;
1312 }
1313 match_flags >>= 1;
1314 }
1315
fb632ce3
NC
1316 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1317 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1318
1319 /* return the pattern and the modifiers */
1320 XPUSHs(pattern);
fb632ce3 1321 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
1322 XSRETURN(2);
1323 } else {
1324 /* Scalar, so use the string that Perl would return */
1325 /* return the pattern in (?msix:..) format */
1326#if PERL_VERSION >= 11
daba3364 1327 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 1328#else
fb632ce3
NC
1329 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1330 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1331#endif
1332 XPUSHs(pattern);
1333 XSRETURN(1);
1334 }
1335 } else {
1336 /* It ain't a regexp folks */
1337 if ( GIMME_V == G_ARRAY ) {
1338 /* return the empty list */
1339 XSRETURN_UNDEF;
1340 } else {
1341 /* Because of the (?:..) wrapping involved in a
1342 stringified pattern it is impossible to get a
1343 result for a real regexp that would evaluate to
1344 false. Therefore we can return PL_sv_no to signify
1345 that the object is not a regex, this means that one
1346 can say
1347
1348 if (regex($might_be_a_regex) eq '(?:foo)') { }
1349
1350 and not worry about undefined values.
1351 */
1352 XSRETURN_NO;
1353 }
1354 }
1355 /* NOT-REACHED */
1356}
1357
192b9cd1 1358XS(XS_Tie_Hash_NamedCapture_FETCH)
80305961 1359{
192b9cd1 1360 dVAR;
80305961 1361 dXSARGS;
192b9cd1
AB
1362 REGEXP * rx;
1363 U32 flags;
1364 SV * ret;
1365
1366 if (items != 2)
afa74d42 1367 croak_xs_usage(cv, "$key, $flags");
192b9cd1
AB
1368
1369 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1370
1d021cc8 1371 if (!rx || !SvROK(ST(0)))
192b9cd1
AB
1372 XSRETURN_UNDEF;
1373
80305961 1374 SP -= items;
192b9cd1 1375
daba3364 1376 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1377 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1378
1379 SPAGAIN;
1380
1381 if (ret) {
ec83ea38 1382 mXPUSHs(ret);
192b9cd1
AB
1383 PUTBACK;
1384 return;
1385 }
1386 XSRETURN_UNDEF;
1387}
1388
1389XS(XS_Tie_Hash_NamedCapture_STORE)
1390{
1391 dVAR;
1392 dXSARGS;
1393 REGEXP * rx;
1394 U32 flags;
1395
1396 if (items != 3)
afa74d42 1397 croak_xs_usage(cv, "$key, $value, $flags");
192b9cd1
AB
1398
1399 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1400
1d021cc8 1401 if (!rx || !SvROK(ST(0))) {
192b9cd1 1402 if (!PL_localizing)
f1f66076 1403 Perl_croak(aTHX_ "%s", PL_no_modify);
192b9cd1 1404 else
28d8d7f4 1405 XSRETURN_UNDEF;
80305961 1406 }
192b9cd1
AB
1407
1408 SP -= items;
1409
daba3364 1410 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1 1411 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
80305961
YO
1412}
1413
192b9cd1
AB
1414XS(XS_Tie_Hash_NamedCapture_DELETE)
1415{
1416 dVAR;
1417 dXSARGS;
1418 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1419 U32 flags;
80305961 1420
192b9cd1 1421 if (items != 2)
afa74d42 1422 croak_xs_usage(cv, "$key, $flags");
192b9cd1 1423
1d021cc8 1424 if (!rx || !SvROK(ST(0)))
f1f66076 1425 Perl_croak(aTHX_ "%s", PL_no_modify);
192b9cd1
AB
1426
1427 SP -= items;
1428
daba3364 1429 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1430 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1431}
1432
1433XS(XS_Tie_Hash_NamedCapture_CLEAR)
80305961 1434{
192b9cd1 1435 dVAR;
80305961 1436 dXSARGS;
192b9cd1
AB
1437 REGEXP * rx;
1438 U32 flags;
1439
1440 if (items != 1)
afa74d42 1441 croak_xs_usage(cv, "$flags");
192b9cd1
AB
1442
1443 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1444
1d021cc8 1445 if (!rx || !SvROK(ST(0)))
f1f66076 1446 Perl_croak(aTHX_ "%s", PL_no_modify);
192b9cd1 1447
80305961 1448 SP -= items;
80305961 1449
daba3364 1450 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1451 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1452}
1453
1454XS(XS_Tie_Hash_NamedCapture_EXISTS)
1455{
1456 dVAR;
1457 dXSARGS;
1458 REGEXP * rx;
1459 U32 flags;
1460 SV * ret;
1461
1462 if (items != 2)
afa74d42 1463 croak_xs_usage(cv, "$key, $flags");
192b9cd1
AB
1464
1465 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1466
1d021cc8 1467 if (!rx || !SvROK(ST(0)))
28d8d7f4 1468 XSRETURN_UNDEF;
192b9cd1
AB
1469
1470 SP -= items;
1471
daba3364 1472 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1473 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1474
1475 SPAGAIN;
1476
1477 XPUSHs(ret);
80305961
YO
1478 PUTBACK;
1479 return;
80305961
YO
1480}
1481
86aa3d53 1482XS(XS_Tie_Hash_NamedCapture_FIRSTK)
192b9cd1
AB
1483{
1484 dVAR;
1485 dXSARGS;
1486 REGEXP * rx;
1487 U32 flags;
1488 SV * ret;
80305961 1489
192b9cd1 1490 if (items != 1)
afa74d42 1491 croak_xs_usage(cv, "");
192b9cd1
AB
1492
1493 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1494
1d021cc8 1495 if (!rx || !SvROK(ST(0)))
192b9cd1
AB
1496 XSRETURN_UNDEF;
1497
1498 SP -= items;
1499
daba3364 1500 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1501 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1502
1503 SPAGAIN;
1504
1505 if (ret) {
ec83ea38 1506 mXPUSHs(ret);
192b9cd1
AB
1507 PUTBACK;
1508 } else {
1509 XSRETURN_UNDEF;
1510 }
1511
1512}
1513
86aa3d53 1514XS(XS_Tie_Hash_NamedCapture_NEXTK)
80305961 1515{
192b9cd1 1516 dVAR;
80305961 1517 dXSARGS;
192b9cd1
AB
1518 REGEXP * rx;
1519 U32 flags;
1520 SV * ret;
1521
1522 if (items != 2)
afa74d42 1523 croak_xs_usage(cv, "$lastkey");
192b9cd1
AB
1524
1525 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1526
1d021cc8 1527 if (!rx || !SvROK(ST(0)))
192b9cd1 1528 XSRETURN_UNDEF;
80305961 1529
80305961 1530 SP -= items;
192b9cd1 1531
daba3364 1532 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1533 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1534
1535 SPAGAIN;
1536
1537 if (ret) {
ec83ea38 1538 mXPUSHs(ret);
80305961
YO
1539 } else {
1540 XSRETURN_UNDEF;
1541 }
1542 PUTBACK;
192b9cd1
AB
1543}
1544
1545XS(XS_Tie_Hash_NamedCapture_SCALAR)
1546{
1547 dVAR;
1548 dXSARGS;
1549 REGEXP * rx;
1550 U32 flags;
1551 SV * ret;
1552
1553 if (items != 1)
afa74d42 1554 croak_xs_usage(cv, "");
192b9cd1
AB
1555
1556 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1557
1d021cc8 1558 if (!rx || !SvROK(ST(0)))
192b9cd1
AB
1559 XSRETURN_UNDEF;
1560
1561 SP -= items;
1562
daba3364 1563 flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
192b9cd1
AB
1564 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1565
1566 SPAGAIN;
1567
1568 if (ret) {
ec83ea38 1569 mXPUSHs(ret);
192b9cd1
AB
1570 PUTBACK;
1571 return;
1572 } else {
1573 XSRETURN_UNDEF;
1574 }
1575}
1576
1577XS(XS_Tie_Hash_NamedCapture_flags)
1578{
1579 dVAR;
1580 dXSARGS;
1581
1582 if (items != 0)
afa74d42 1583 croak_xs_usage(cv, "");
192b9cd1 1584
6e449a3a
MHM
1585 mXPUSHu(RXapif_ONE);
1586 mXPUSHu(RXapif_ALL);
192b9cd1
AB
1587 PUTBACK;
1588 return;
80305961
YO
1589}
1590
1591
241d1a3b
NC
1592/*
1593 * Local variables:
1594 * c-indentation-style: bsd
1595 * c-basic-offset: 4
1596 * indent-tabs-mode: t
1597 * End:
1598 *
37442d52
RGS
1599 * ex: set ts=8 sts=4 sw=4 noet:
1600 */