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