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