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