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