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