This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
minor code simplification made possible by change #30627
[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().
19 */
20
6d4a7be2 21#include "EXTERN.h"
864dbfa3 22#define PERL_IN_UNIVERSAL_C
6d4a7be2 23#include "perl.h"
6d4a7be2 24
39f7a870
JH
25#ifdef USE_PERLIO
26#include "perliol.h" /* For the PERLIO_F_XXX */
27#endif
28
6d4a7be2
PP
29/*
30 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
31 * The main guts of traverse_isa was actually copied from gv_fetchmeth
32 */
33
a9ec700e 34STATIC bool
34692224 35S_isa_lookup(pTHX_ HV *stash, const char *name, const HV* const name_stash,
301daebc 36 int len, int level)
6d4a7be2 37{
97aff369 38 dVAR;
6d4a7be2
PP
39 AV* av;
40 GV* gv;
41 GV** gvp;
5c284bb0 42 HV* hv = NULL;
c445ea15 43 SV* subgen = NULL;
bfcb3514 44 const char *hvname;
6d4a7be2 45
301daebc
MS
46 /* A stash/class can go by many names (ie. User == main::User), so
47 we compare the stash itself just in case */
34692224 48 if (name_stash && ((const HV *)stash == name_stash))
a9ec700e 49 return TRUE;
6d4a7be2 50
bfcb3514
NC
51 hvname = HvNAME_get(stash);
52
53 if (strEQ(hvname, name))
a9ec700e 54 return TRUE;
6d4a7be2 55
a1d407e8 56 if (strEQ(name, "UNIVERSAL"))
a9ec700e 57 return TRUE;
a1d407e8 58
6d4a7be2 59 if (level > 100)
46e4b22b 60 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
bfcb3514 61 hvname);
6d4a7be2 62
017a3ce5 63 gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE);
6d4a7be2 64
9e0d86f8 65 if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (subgen = GvSV(gv))
46e4b22b
GS
66 && (hv = GvHV(gv)))
67 {
eb160463 68 if (SvIV(subgen) == (IV)PL_sub_generation) {
7452cf6a 69 SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
34692224
AL
70 if (svp) {
71 SV * const sv = *svp;
17bcfd59 72#ifdef DEBUGGING
34692224
AL
73 if (sv != &PL_sv_undef)
74 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
75 name, hvname) );
17bcfd59 76#endif
a9ec700e 77 return (sv == &PL_sv_yes);
46e4b22b
GS
78 }
79 }
80 else {
81 DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
bfcb3514 82 hvname) );
46e4b22b
GS
83 hv_clear(hv);
84 sv_setiv(subgen, PL_sub_generation);
85 }
6d4a7be2
PP
86 }
87
017a3ce5 88 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
46e4b22b 89
9e0d86f8 90 if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) {
46e4b22b 91 if (!hv || !subgen) {
017a3ce5 92 gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE);
6d4a7be2
PP
93
94 gv = *gvp;
95
96 if (SvTYPE(gv) != SVt_PVGV)
97 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
98
46e4b22b
GS
99 if (!hv)
100 hv = GvHVn(gv);
101 if (!subgen) {
102 subgen = newSViv(PL_sub_generation);
103 GvSV(gv) = subgen;
104 }
6d4a7be2 105 }
46e4b22b 106 if (hv) {
6d4a7be2 107 SV** svp = AvARRAY(av);
93965878
NIS
108 /* NOTE: No support for tied ISA */
109 I32 items = AvFILLp(av) + 1;
6d4a7be2 110 while (items--) {
c4420975 111 SV* const sv = *svp++;
da51bb9b 112 HV* const basestash = gv_stashsv(sv, 0);
6d4a7be2 113 if (!basestash) {
599cee73 114 if (ckWARN(WARN_MISC))
9014280d 115 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
bfcb3514 116 "Can't locate package %"SVf" for @%s::ISA",
be2597df 117 SVfARG(sv), hvname);
6d4a7be2
PP
118 continue;
119 }
a9ec700e 120 if (isa_lookup(basestash, name, name_stash, len, level + 1)) {
3280af22 121 (void)hv_store(hv,name,len,&PL_sv_yes,0);
a9ec700e 122 return TRUE;
6d4a7be2
PP
123 }
124 }
3280af22 125 (void)hv_store(hv,name,len,&PL_sv_no,0);
6d4a7be2
PP
126 }
127 }
a9ec700e 128 return FALSE;
6d4a7be2
PP
129}
130
954c1994 131/*
ccfc67b7
JH
132=head1 SV Manipulation Functions
133
954c1994
GS
134=for apidoc sv_derived_from
135
6885da0e 136Returns a boolean indicating whether the SV is derived from the specified class
137I<at the C level>. To check derivation at the Perl level, call C<isa()> as a
138normal Perl method.
954c1994
GS
139
140=cut
141*/
142
55497cff 143bool
864dbfa3 144Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
55497cff 145{
97aff369 146 dVAR;
0b6f4f5c 147 HV *stash;
46e4b22b 148
5b295bef 149 SvGETMAGIC(sv);
55497cff
PP
150
151 if (SvROK(sv)) {
0b6f4f5c 152 const char *type;
55497cff
PP
153 sv = SvRV(sv);
154 type = sv_reftype(sv,0);
0b6f4f5c
AL
155 if (type && strEQ(type,name))
156 return TRUE;
157 stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL;
55497cff
PP
158 }
159 else {
da51bb9b 160 stash = gv_stashsv(sv, 0);
55497cff 161 }
46e4b22b 162
0b6f4f5c 163 if (stash) {
da51bb9b 164 HV * const name_stash = gv_stashpv(name, 0);
a9ec700e 165 return isa_lookup(stash, name, name_stash, strlen(name), 0);
0b6f4f5c
AL
166 }
167 else
168 return FALSE;
301daebc 169
55497cff
PP
170}
171
cbc021f9 172/*
173=for apidoc sv_does
174
175Returns a boolean indicating whether the SV performs a specific, named role.
176The SV can be a Perl object or the name of a Perl class.
177
178=cut
179*/
180
1b026014
NIS
181#include "XSUB.h"
182
cbc021f9 183bool
184Perl_sv_does(pTHX_ SV *sv, const char *name)
185{
186 const char *classname;
187 bool does_it;
188
189 dSP;
190 ENTER;
191 SAVETMPS;
192
193 SvGETMAGIC(sv);
194
195 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
196 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
197 return FALSE;
198
199 if (sv_isobject(sv)) {
200 classname = sv_reftype(SvRV(sv),TRUE);
201 } else {
202 classname = SvPV(sv,PL_na);
203 }
204
205 if (strEQ(name,classname))
206 return TRUE;
207
208 PUSHMARK(SP);
209 XPUSHs(sv);
210 XPUSHs(sv_2mortal(newSVpv(name, 0)));
211 PUTBACK;
212
213 call_method("isa", G_SCALAR);
214 SPAGAIN;
215
216 does_it = SvTRUE( TOPs );
217 FREETMPS;
218 LEAVE;
219
220 return does_it;
221}
222
80305961
YO
223regexp *
224Perl_get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) {
225 MAGIC *mg;
226 if (sv) {
227 if (SvMAGICAL(sv))
228 mg_get(sv);
229 if (SvROK(sv) &&
230 (sv = (SV*)SvRV(sv)) && /* assign deliberate */
231 SvTYPE(sv) == SVt_PVMG &&
232 (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */
233 {
234 if (mgp) *mgp = mg;
235 return (regexp *)mg->mg_obj;
236 }
237 }
238 if (mgp) *mgp = NULL;
239 return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL);
240}
241
242
27da23d5
JH
243PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
244PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
cbc021f9 245PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
27da23d5 246PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
439cb1c4
JP
247XS(XS_version_new);
248XS(XS_version_stringify);
249XS(XS_version_numify);
9137345a 250XS(XS_version_normal);
439cb1c4
JP
251XS(XS_version_vcmp);
252XS(XS_version_boolean);
2dfd8427
AL
253#ifdef HASATTRIBUTE_NORETURN
254XS(XS_version_noop) __attribute__noreturn__;
255#else
439cb1c4 256XS(XS_version_noop);
2dfd8427 257#endif
c8d69e4a 258XS(XS_version_is_alpha);
137d6fc0 259XS(XS_version_qv);
8800c35a 260XS(XS_utf8_is_utf8);
1b026014
NIS
261XS(XS_utf8_valid);
262XS(XS_utf8_encode);
263XS(XS_utf8_decode);
264XS(XS_utf8_upgrade);
265XS(XS_utf8_downgrade);
266XS(XS_utf8_unicode_to_native);
267XS(XS_utf8_native_to_unicode);
29569577
JH
268XS(XS_Internals_SvREADONLY);
269XS(XS_Internals_SvREFCNT);
f044d0d1 270XS(XS_Internals_hv_clear_placehold);
39f7a870 271XS(XS_PerlIO_get_layers);
39cff0d9 272XS(XS_Regexp_DESTROY);
9a7034eb 273XS(XS_Internals_hash_seed);
008fb0c0 274XS(XS_Internals_rehash_seed);
05619474 275XS(XS_Internals_HvREHASH);
e1234d8e 276XS(XS_Internals_inc_sub_generation);
80305961
YO
277XS(XS_re_is_regexp);
278XS(XS_re_regname);
279XS(XS_re_regnames);
280XS(XS_re_regnames_iterinit);
281XS(XS_re_regnames_iternext);
282XS(XS_re_regnames_count);
0cb96387
GS
283
284void
285Perl_boot_core_UNIVERSAL(pTHX)
286{
97aff369 287 dVAR;
157e3fc8 288 static const char file[] = __FILE__;
0cb96387
GS
289
290 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
291 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
cbc021f9 292 newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file);
0cb96387 293 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
439cb1c4 294 {
ad63d80f
JP
295 /* register the overloading (type 'A') magic */
296 PL_amagic_generation++;
439cb1c4 297 /* Make it findable via fetchmethod */
be2ebcad 298 newXS("version::()", XS_version_noop, file);
439cb1c4
JP
299 newXS("version::new", XS_version_new, file);
300 newXS("version::(\"\"", XS_version_stringify, file);
301 newXS("version::stringify", XS_version_stringify, file);
302 newXS("version::(0+", XS_version_numify, file);
303 newXS("version::numify", XS_version_numify, file);
9137345a 304 newXS("version::normal", XS_version_normal, file);
439cb1c4
JP
305 newXS("version::(cmp", XS_version_vcmp, file);
306 newXS("version::(<=>", XS_version_vcmp, file);
307 newXS("version::vcmp", XS_version_vcmp, file);
308 newXS("version::(bool", XS_version_boolean, file);
309 newXS("version::boolean", XS_version_boolean, file);
310 newXS("version::(nomethod", XS_version_noop, file);
311 newXS("version::noop", XS_version_noop, file);
c8d69e4a 312 newXS("version::is_alpha", XS_version_is_alpha, file);
137d6fc0 313 newXS("version::qv", XS_version_qv, file);
439cb1c4 314 }
8800c35a 315 newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
1b026014
NIS
316 newXS("utf8::valid", XS_utf8_valid, file);
317 newXS("utf8::encode", XS_utf8_encode, file);
318 newXS("utf8::decode", XS_utf8_decode, file);
319 newXS("utf8::upgrade", XS_utf8_upgrade, file);
320 newXS("utf8::downgrade", XS_utf8_downgrade, file);
321 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
322 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577
JH
323 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
324 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f 325 newXSproto("Internals::hv_clear_placeholders",
f044d0d1 326 XS_Internals_hv_clear_placehold, file, "\\%");
9d569fce
JH
327 newXSproto("PerlIO::get_layers",
328 XS_PerlIO_get_layers, file, "*;@");
39cff0d9 329 newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
9a7034eb 330 newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
008fb0c0 331 newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
05619474 332 newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
e1234d8e
NC
333 newXSproto("Internals::inc_sub_generation",XS_Internals_inc_sub_generation,
334 file, "");
80305961
YO
335 newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
336 newXSproto("re::regname", XS_re_regname, file, ";$$$");
337 newXSproto("re::regnames", XS_re_regnames, file, ";$$");
338 newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, ";$");
339 newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$$");
340 newXSproto("re::regnames_count", XS_re_regnames_count, file, ";$");
0cb96387
GS
341}
342
55497cff 343
6d4a7be2
PP
344XS(XS_UNIVERSAL_isa)
345{
97aff369 346 dVAR;
6d4a7be2 347 dXSARGS;
58c0efa5 348 PERL_UNUSED_ARG(cv);
6d4a7be2
PP
349
350 if (items != 2)
cea2e8a9 351 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
c4420975
AL
352 else {
353 SV * const sv = ST(0);
354 const char *name;
6d4a7be2 355
c4420975 356 SvGETMAGIC(sv);
d3f7f2b2 357
c4420975
AL
358 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
359 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
360 XSRETURN_UNDEF;
f8f70380 361
c4420975 362 name = SvPV_nolen_const(ST(1));
6d4a7be2 363
c4420975
AL
364 ST(0) = boolSV(sv_derived_from(sv, name));
365 XSRETURN(1);
366 }
6d4a7be2
PP
367}
368
6d4a7be2
PP
369XS(XS_UNIVERSAL_can)
370{
97aff369 371 dVAR;
6d4a7be2
PP
372 dXSARGS;
373 SV *sv;
6867be6d 374 const char *name;
6d4a7be2 375 SV *rv;
6f08146e 376 HV *pkg = NULL;
58c0efa5 377 PERL_UNUSED_ARG(cv);
6d4a7be2
PP
378
379 if (items != 2)
cea2e8a9 380 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2
PP
381
382 sv = ST(0);
f8f70380 383
5b295bef 384 SvGETMAGIC(sv);
d3f7f2b2 385
253ecd6d
RGS
386 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
387 || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
f8f70380
GS
388 XSRETURN_UNDEF;
389
0510663f 390 name = SvPV_nolen_const(ST(1));
3280af22 391 rv = &PL_sv_undef;
6d4a7be2 392
46e4b22b 393 if (SvROK(sv)) {
6f08146e 394 sv = (SV*)SvRV(sv);
46e4b22b 395 if (SvOBJECT(sv))
6f08146e
NIS
396 pkg = SvSTASH(sv);
397 }
398 else {
da51bb9b 399 pkg = gv_stashsv(sv, 0);
6f08146e
NIS
400 }
401
402 if (pkg) {
c4420975 403 GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE);
dc848c6f
PP
404 if (gv && isGV(gv))
405 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2
PP
406 }
407
408 ST(0) = rv;
409 XSRETURN(1);
410}
411
cbc021f9 412XS(XS_UNIVERSAL_DOES)
413{
414 dVAR;
415 dXSARGS;
58c0efa5 416 PERL_UNUSED_ARG(cv);
cbc021f9 417
418 if (items != 2)
419 Perl_croak(aTHX_ "Usage: invocant->does(kind)");
420 else {
421 SV * const sv = ST(0);
422 const char *name;
423
424 name = SvPV_nolen_const(ST(1));
425 if (sv_does( sv, name ))
426 XSRETURN_YES;
427
428 XSRETURN_NO;
429 }
430}
431
6d4a7be2
PP
432XS(XS_UNIVERSAL_VERSION)
433{
97aff369 434 dVAR;
6d4a7be2
PP
435 dXSARGS;
436 HV *pkg;
437 GV **gvp;
438 GV *gv;
439 SV *sv;
e1ec3a88 440 const char *undef;
58c0efa5 441 PERL_UNUSED_ARG(cv);
6d4a7be2 442
1571675a 443 if (SvROK(ST(0))) {
6d4a7be2 444 sv = (SV*)SvRV(ST(0));
1571675a 445 if (!SvOBJECT(sv))
cea2e8a9 446 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2
PP
447 pkg = SvSTASH(sv);
448 }
449 else {
da51bb9b 450 pkg = gv_stashsv(ST(0), 0);
6d4a7be2
PP
451 }
452
4608196e 453 gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
6d4a7be2 454
0008872a 455 if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
c4420975 456 SV * const nsv = sv_newmortal();
6d4a7be2
PP
457 sv_setsv(nsv, sv);
458 sv = nsv;
137d6fc0
JP
459 if ( !sv_derived_from(sv, "version"))
460 upg_version(sv);
c445ea15 461 undef = NULL;
6d4a7be2
PP
462 }
463 else {
3280af22 464 sv = (SV*)&PL_sv_undef;
6d4a7be2
PP
465 undef = "(undef)";
466 }
467
1571675a 468 if (items > 1) {
1571675a
GS
469 SV *req = ST(1);
470
62658f4d 471 if (undef) {
bfcb3514 472 if (pkg) {
c4420975 473 const char * const name = HvNAME_get(pkg);
a3b680e6 474 Perl_croak(aTHX_
bfcb3514
NC
475 "%s does not define $%s::VERSION--version check failed",
476 name, name);
477 } else {
a3b680e6
AL
478 Perl_croak(aTHX_
479 "%s defines neither package nor VERSION--version check failed",
0510663f 480 SvPVx_nolen_const(ST(0)) );
62658f4d
PM
481 }
482 }
ad63d80f 483
137d6fc0
JP
484 if ( !sv_derived_from(req, "version")) {
485 /* req may very well be R/O, so create a new object */
c4420975 486 SV * const nsv = sv_newmortal();
137d6fc0
JP
487 sv_setsv(nsv, req);
488 req = nsv;
489 upg_version(req);
490 }
1571675a 491
137d6fc0 492 if ( vcmp( req, sv ) > 0 )
b9381830 493 Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--"
95b63a38 494 "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg),
be2597df
MHM
495 SVfARG(vnumify(req)),
496 SVfARG(vnormal(req)),
497 SVfARG(vnumify(sv)),
498 SVfARG(vnormal(sv)));
2d8e6c8d 499 }
6d4a7be2 500
2b140d5b 501 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
b38a9dc5 502 ST(0) = vnumify(sv);
13f8f398
JP
503 } else {
504 ST(0) = sv;
b38a9dc5 505 }
6d4a7be2
PP
506
507 XSRETURN(1);
508}
509
439cb1c4
JP
510XS(XS_version_new)
511{
97aff369 512 dVAR;
439cb1c4 513 dXSARGS;
58c0efa5 514 PERL_UNUSED_ARG(cv);
129318bd 515 if (items > 3)
439cb1c4
JP
516 Perl_croak(aTHX_ "Usage: version::new(class, version)");
517 SP -= items;
518 {
137d6fc0
JP
519 SV *vs = ST(1);
520 SV *rv;
c4420975
AL
521 const char * const classname =
522 sv_isobject(ST(0)) /* get the class if called as an object method */
523 ? HvNAME(SvSTASH(SvRV(ST(0))))
524 : (char *)SvPV_nolen(ST(0));
9137345a 525
92dcf8ce
JP
526 if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
527 /* create empty object */
528 vs = sv_newmortal();
529 sv_setpvn(vs,"",0);
9137345a
JP
530 }
531 else if ( items == 3 ) {
532 vs = sv_newmortal();
cfd0369c 533 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
129318bd 534 }
439cb1c4 535
137d6fc0 536 rv = new_version(vs);
0723351e 537 if ( strcmp(classname,"version") != 0 ) /* inherited new() */
da51bb9b 538 sv_bless(rv, gv_stashpv(classname, GV_ADD));
137d6fc0
JP
539
540 PUSHs(sv_2mortal(rv));
439cb1c4
JP
541 PUTBACK;
542 return;
543 }
544}
545
546XS(XS_version_stringify)
547{
97aff369 548 dVAR;
41be1fbd 549 dXSARGS;
58c0efa5 550 PERL_UNUSED_ARG(cv);
41be1fbd
JH
551 if (items < 1)
552 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
553 SP -= items;
554 {
7452cf6a 555 SV * lobj;
41be1fbd
JH
556
557 if (sv_derived_from(ST(0), "version")) {
9137345a 558 lobj = SvRV(ST(0));
41be1fbd
JH
559 }
560 else
561 Perl_croak(aTHX_ "lobj is not of type version");
562
137d6fc0 563 PUSHs(sv_2mortal(vstringify(lobj)));
41be1fbd
JH
564
565 PUTBACK;
566 return;
567 }
439cb1c4
JP
568}
569
570XS(XS_version_numify)
571{
97aff369 572 dVAR;
41be1fbd 573 dXSARGS;
58c0efa5 574 PERL_UNUSED_ARG(cv);
41be1fbd
JH
575 if (items < 1)
576 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
577 SP -= items;
578 {
7452cf6a 579 SV * lobj;
41be1fbd
JH
580
581 if (sv_derived_from(ST(0), "version")) {
9137345a 582 lobj = SvRV(ST(0));
41be1fbd
JH
583 }
584 else
585 Perl_croak(aTHX_ "lobj is not of type version");
586
137d6fc0 587 PUSHs(sv_2mortal(vnumify(lobj)));
41be1fbd
JH
588
589 PUTBACK;
590 return;
591 }
439cb1c4
JP
592}
593
9137345a
JP
594XS(XS_version_normal)
595{
97aff369 596 dVAR;
9137345a 597 dXSARGS;
58c0efa5 598 PERL_UNUSED_ARG(cv);
9137345a
JP
599 if (items < 1)
600 Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
601 SP -= items;
602 {
7452cf6a 603 SV * lobj;
9137345a
JP
604
605 if (sv_derived_from(ST(0), "version")) {
606 lobj = SvRV(ST(0));
607 }
608 else
609 Perl_croak(aTHX_ "lobj is not of type version");
610
611 PUSHs(sv_2mortal(vnormal(lobj)));
612
613 PUTBACK;
614 return;
615 }
616}
617
439cb1c4
JP
618XS(XS_version_vcmp)
619{
97aff369 620 dVAR;
41be1fbd 621 dXSARGS;
58c0efa5 622 PERL_UNUSED_ARG(cv);
41be1fbd
JH
623 if (items < 1)
624 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
625 SP -= items;
626 {
7452cf6a 627 SV * lobj;
41be1fbd
JH
628
629 if (sv_derived_from(ST(0), "version")) {
9137345a 630 lobj = SvRV(ST(0));
41be1fbd
JH
631 }
632 else
633 Perl_croak(aTHX_ "lobj is not of type version");
634
635 {
636 SV *rs;
637 SV *rvs;
638 SV * robj = ST(1);
7452cf6a 639 const IV swap = (IV)SvIV(ST(2));
41be1fbd
JH
640
641 if ( ! sv_derived_from(robj, "version") )
642 {
643 robj = new_version(robj);
644 }
645 rvs = SvRV(robj);
646
647 if ( swap )
648 {
649 rs = newSViv(vcmp(rvs,lobj));
650 }
651 else
652 {
653 rs = newSViv(vcmp(lobj,rvs));
654 }
655
137d6fc0 656 PUSHs(sv_2mortal(rs));
41be1fbd
JH
657 }
658
659 PUTBACK;
660 return;
661 }
439cb1c4
JP
662}
663
664XS(XS_version_boolean)
665{
97aff369
JH
666 dVAR;
667 dXSARGS;
58c0efa5 668 PERL_UNUSED_ARG(cv);
97aff369
JH
669 if (items < 1)
670 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
671 SP -= items;
c4420975
AL
672 if (sv_derived_from(ST(0), "version")) {
673 SV * const lobj = SvRV(ST(0));
396482e1 674 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
c4420975
AL
675 PUSHs(sv_2mortal(rs));
676 PUTBACK;
677 return;
678 }
679 else
680 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
681}
682
683XS(XS_version_noop)
684{
97aff369 685 dVAR;
2dfd8427 686 dXSARGS;
58c0efa5 687 PERL_UNUSED_ARG(cv);
2dfd8427
AL
688 if (items < 1)
689 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
690 if (sv_derived_from(ST(0), "version"))
691 Perl_croak(aTHX_ "operation not supported with version object");
692 else
693 Perl_croak(aTHX_ "lobj is not of type version");
694#ifndef HASATTRIBUTE_NORETURN
695 XSRETURN_EMPTY;
696#endif
439cb1c4
JP
697}
698
c8d69e4a
JP
699XS(XS_version_is_alpha)
700{
97aff369 701 dVAR;
c8d69e4a 702 dXSARGS;
58c0efa5 703 PERL_UNUSED_ARG(cv);
c8d69e4a
JP
704 if (items != 1)
705 Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
706 SP -= items;
c4420975
AL
707 if (sv_derived_from(ST(0), "version")) {
708 SV * const lobj = ST(0);
709 if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
710 XSRETURN_YES;
711 else
712 XSRETURN_NO;
c8d69e4a
JP
713 PUTBACK;
714 return;
715 }
c4420975
AL
716 else
717 Perl_croak(aTHX_ "lobj is not of type version");
c8d69e4a
JP
718}
719
137d6fc0
JP
720XS(XS_version_qv)
721{
97aff369 722 dVAR;
137d6fc0 723 dXSARGS;
58c0efa5 724 PERL_UNUSED_ARG(cv);
137d6fc0
JP
725 if (items != 1)
726 Perl_croak(aTHX_ "Usage: version::qv(ver)");
727 SP -= items;
728 {
729 SV * ver = ST(0);
c4420975
AL
730 if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
731 SV * const vs = sv_newmortal();
137d6fc0
JP
732 char *version;
733 if ( SvNOK(ver) ) /* may get too much accuracy */
734 {
735 char tbuf[64];
b5b5a8f0
RGS
736#ifdef USE_LOCALE_NUMERIC
737 char *loc = setlocale(LC_NUMERIC, "C");
738#endif
63e3af20 739 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver));
b5b5a8f0
RGS
740#ifdef USE_LOCALE_NUMERIC
741 setlocale(LC_NUMERIC, loc);
742#endif
63e3af20 743 while (tbuf[len-1] == '0' && len > 0) len--;
86c11942 744 version = savepvn(tbuf, len);
137d6fc0
JP
745 }
746 else
747 {
2e0de35c 748 version = savesvpv(ver);
137d6fc0
JP
749 }
750 (void)scan_version(version,vs,TRUE);
751 Safefree(version);
752
753 PUSHs(vs);
754 }
755 else
756 {
757 PUSHs(sv_2mortal(new_version(ver)));
758 }
759
760 PUTBACK;
761 return;
762 }
763}
764
8800c35a
JH
765XS(XS_utf8_is_utf8)
766{
97aff369 767 dVAR;
41be1fbd 768 dXSARGS;
58c0efa5 769 PERL_UNUSED_ARG(cv);
41be1fbd
JH
770 if (items != 1)
771 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
c4420975
AL
772 else {
773 const SV * const sv = ST(0);
774 if (SvUTF8(sv))
775 XSRETURN_YES;
776 else
777 XSRETURN_NO;
41be1fbd
JH
778 }
779 XSRETURN_EMPTY;
8800c35a
JH
780}
781
1b026014
NIS
782XS(XS_utf8_valid)
783{
97aff369 784 dVAR;
41be1fbd 785 dXSARGS;
58c0efa5 786 PERL_UNUSED_ARG(cv);
41be1fbd
JH
787 if (items != 1)
788 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
c4420975
AL
789 else {
790 SV * const sv = ST(0);
791 STRLEN len;
792 const char * const s = SvPV_const(sv,len);
793 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
794 XSRETURN_YES;
795 else
796 XSRETURN_NO;
797 }
41be1fbd 798 XSRETURN_EMPTY;
1b026014
NIS
799}
800
801XS(XS_utf8_encode)
802{
97aff369 803 dVAR;
1b026014 804 dXSARGS;
58c0efa5 805 PERL_UNUSED_ARG(cv);
1b026014
NIS
806 if (items != 1)
807 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
c4420975 808 sv_utf8_encode(ST(0));
1b026014
NIS
809 XSRETURN_EMPTY;
810}
811
812XS(XS_utf8_decode)
813{
97aff369 814 dVAR;
1b026014 815 dXSARGS;
58c0efa5 816 PERL_UNUSED_ARG(cv);
1b026014
NIS
817 if (items != 1)
818 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
c4420975
AL
819 else {
820 SV * const sv = ST(0);
6867be6d 821 const bool RETVAL = sv_utf8_decode(sv);
1b026014
NIS
822 ST(0) = boolSV(RETVAL);
823 sv_2mortal(ST(0));
824 }
825 XSRETURN(1);
826}
827
828XS(XS_utf8_upgrade)
829{
97aff369 830 dVAR;
1b026014 831 dXSARGS;
58c0efa5 832 PERL_UNUSED_ARG(cv);
1b026014
NIS
833 if (items != 1)
834 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
c4420975
AL
835 else {
836 SV * const sv = ST(0);
1b026014
NIS
837 STRLEN RETVAL;
838 dXSTARG;
839
840 RETVAL = sv_utf8_upgrade(sv);
841 XSprePUSH; PUSHi((IV)RETVAL);
842 }
843 XSRETURN(1);
844}
845
846XS(XS_utf8_downgrade)
847{
97aff369 848 dVAR;
1b026014 849 dXSARGS;
58c0efa5 850 PERL_UNUSED_ARG(cv);
1b026014
NIS
851 if (items < 1 || items > 2)
852 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
c4420975
AL
853 else {
854 SV * const sv = ST(0);
6867be6d
AL
855 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
856 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 857
1b026014
NIS
858 ST(0) = boolSV(RETVAL);
859 sv_2mortal(ST(0));
860 }
861 XSRETURN(1);
862}
863
864XS(XS_utf8_native_to_unicode)
865{
97aff369 866 dVAR;
1b026014 867 dXSARGS;
6867be6d 868 const UV uv = SvUV(ST(0));
58c0efa5 869 PERL_UNUSED_ARG(cv);
b7953727
JH
870
871 if (items > 1)
872 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
873
1b026014
NIS
874 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
875 XSRETURN(1);
876}
877
878XS(XS_utf8_unicode_to_native)
879{
97aff369 880 dVAR;
1b026014 881 dXSARGS;
6867be6d 882 const UV uv = SvUV(ST(0));
58c0efa5 883 PERL_UNUSED_ARG(cv);
b7953727
JH
884
885 if (items > 1)
886 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
887
1b026014
NIS
888 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
889 XSRETURN(1);
890}
891
14a976d6 892XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577 893{
97aff369 894 dVAR;
29569577 895 dXSARGS;
c4420975 896 SV * const sv = SvRV(ST(0));
58c0efa5 897 PERL_UNUSED_ARG(cv);
6867be6d 898
29569577
JH
899 if (items == 1) {
900 if (SvREADONLY(sv))
901 XSRETURN_YES;
902 else
903 XSRETURN_NO;
904 }
905 else if (items == 2) {
906 if (SvTRUE(ST(1))) {
907 SvREADONLY_on(sv);
908 XSRETURN_YES;
909 }
910 else {
14a976d6 911 /* I hope you really know what you are doing. */
29569577
JH
912 SvREADONLY_off(sv);
913 XSRETURN_NO;
914 }
915 }
14a976d6 916 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
917}
918
14a976d6 919XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577 920{
97aff369 921 dVAR;
29569577 922 dXSARGS;
c4420975 923 SV * const sv = SvRV(ST(0));
58c0efa5 924 PERL_UNUSED_ARG(cv);
6867be6d 925
29569577 926 if (items == 1)
14a976d6 927 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 928 else if (items == 2) {
14a976d6 929 /* I hope you really know what you are doing. */
29569577
JH
930 SvREFCNT(sv) = SvIV(ST(1));
931 XSRETURN_IV(SvREFCNT(sv));
932 }
14a976d6 933 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
934}
935
f044d0d1 936XS(XS_Internals_hv_clear_placehold)
dfd4ef2f 937{
97aff369 938 dVAR;
dfd4ef2f 939 dXSARGS;
58c0efa5 940 PERL_UNUSED_ARG(cv);
6867be6d 941
3540d4ce
AB
942 if (items != 1)
943 Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
c4420975
AL
944 else {
945 HV * const hv = (HV *) SvRV(ST(0));
946 hv_clear_placeholders(hv);
947 XSRETURN(0);
948 }
dfd4ef2f 949}
39f7a870 950
39cff0d9
AE
951XS(XS_Regexp_DESTROY)
952{
96a5add6 953 PERL_UNUSED_CONTEXT;
53c1dcc0 954 PERL_UNUSED_ARG(cv);
39cff0d9
AE
955}
956
39f7a870
JH
957XS(XS_PerlIO_get_layers)
958{
97aff369 959 dVAR;
39f7a870 960 dXSARGS;
58c0efa5 961 PERL_UNUSED_ARG(cv);
39f7a870
JH
962 if (items < 1 || items % 2 == 0)
963 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
5fef3b4a 964#ifdef USE_PERLIO
39f7a870
JH
965 {
966 SV * sv;
967 GV * gv;
968 IO * io;
969 bool input = TRUE;
970 bool details = FALSE;
971
972 if (items > 1) {
c4420975 973 SV * const *svp;
39f7a870 974 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
975 SV * const * const varp = svp;
976 SV * const * const valp = svp + 1;
39f7a870 977 STRLEN klen;
c4420975 978 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
979
980 switch (*key) {
981 case 'i':
982 if (klen == 5 && memEQ(key, "input", 5)) {
983 input = SvTRUE(*valp);
984 break;
985 }
986 goto fail;
987 case 'o':
988 if (klen == 6 && memEQ(key, "output", 6)) {
989 input = !SvTRUE(*valp);
990 break;
991 }
992 goto fail;
993 case 'd':
994 if (klen == 7 && memEQ(key, "details", 7)) {
995 details = SvTRUE(*valp);
996 break;
997 }
998 goto fail;
999 default:
1000 fail:
1001 Perl_croak(aTHX_
1002 "get_layers: unknown argument '%s'",
1003 key);
1004 }
1005 }
1006
1007 SP -= (items - 1);
1008 }
1009
1010 sv = POPs;
1011 gv = (GV*)sv;
1012
1013 if (!isGV(sv)) {
1014 if (SvROK(sv) && isGV(SvRV(sv)))
1015 gv = (GV*)SvRV(sv);
671d49be 1016 else if (SvPOKp(sv))
f776e3cd 1017 gv = gv_fetchsv(sv, 0, SVt_PVIO);
39f7a870
JH
1018 }
1019
1020 if (gv && (io = GvIO(gv))) {
1021 dTARGET;
c4420975 1022 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870
JH
1023 IoIFP(io) : IoOFP(io));
1024 I32 i;
c4420975 1025 const I32 last = av_len(av);
39f7a870
JH
1026 I32 nitem = 0;
1027
1028 for (i = last; i >= 0; i -= 3) {
c4420975
AL
1029 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1030 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1031 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 1032
c4420975
AL
1033 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1034 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1035 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870
JH
1036
1037 if (details) {
ec3bab8e
NC
1038 XPUSHs(namok
1039 ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
1040 : &PL_sv_undef);
1041 XPUSHs(argok
1042 ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
1043 : &PL_sv_undef);
39f7a870
JH
1044 if (flgok)
1045 XPUSHi(SvIVX(*flgsvp));
1046 else
1047 XPUSHs(&PL_sv_undef);
1048 nitem += 3;
1049 }
1050 else {
1051 if (namok && argok)
1052 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df
MHM
1053 SVfARG(*namsvp),
1054 SVfARG(*argsvp)));
39f7a870 1055 else if (namok)
95b63a38 1056 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf,
be2597df 1057 SVfARG(*namsvp)));
39f7a870
JH
1058 else
1059 XPUSHs(&PL_sv_undef);
1060 nitem++;
1061 if (flgok) {
c4420975 1062 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
1063
1064 if (flags & PERLIO_F_UTF8) {
396482e1 1065 XPUSHs(newSVpvs("utf8"));
39f7a870
JH
1066 nitem++;
1067 }
1068 }
1069 }
1070 }
1071
1072 SvREFCNT_dec(av);
1073
1074 XSRETURN(nitem);
1075 }
1076 }
5fef3b4a 1077#endif
39f7a870
JH
1078
1079 XSRETURN(0);
1080}
1081
9a7034eb 1082XS(XS_Internals_hash_seed)
c910b28a 1083{
97aff369 1084 dVAR;
c85d3f85
NC
1085 /* Using dXSARGS would also have dITEM and dSP,
1086 * which define 2 unused local variables. */
557b887a 1087 dAXMARK;
53c1dcc0 1088 PERL_UNUSED_ARG(cv);
ad73156c 1089 PERL_UNUSED_VAR(mark);
81eaca17 1090 XSRETURN_UV(PERL_HASH_SEED);
c910b28a
JH
1091}
1092
008fb0c0 1093XS(XS_Internals_rehash_seed)
8e90d776 1094{
97aff369 1095 dVAR;
8e90d776
NC
1096 /* Using dXSARGS would also have dITEM and dSP,
1097 * which define 2 unused local variables. */
557b887a 1098 dAXMARK;
53c1dcc0 1099 PERL_UNUSED_ARG(cv);
ad73156c 1100 PERL_UNUSED_VAR(mark);
008fb0c0 1101 XSRETURN_UV(PL_rehash_seed);
8e90d776
NC
1102}
1103
05619474
NC
1104XS(XS_Internals_HvREHASH) /* Subject to change */
1105{
97aff369 1106 dVAR;
05619474 1107 dXSARGS;
58c0efa5 1108 PERL_UNUSED_ARG(cv);
05619474 1109 if (SvROK(ST(0))) {
c4420975 1110 const HV * const hv = (HV *) SvRV(ST(0));
05619474
NC
1111 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1112 if (HvREHASH(hv))
1113 XSRETURN_YES;
1114 else
1115 XSRETURN_NO;
1116 }
1117 }
1118 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1119}
241d1a3b 1120
e1234d8e
NC
1121XS(XS_Internals_inc_sub_generation)
1122{
97aff369 1123 dVAR;
e1234d8e
NC
1124 /* Using dXSARGS would also have dITEM and dSP,
1125 * which define 2 unused local variables. */
1126 dAXMARK;
1127 PERL_UNUSED_ARG(cv);
1128 PERL_UNUSED_VAR(mark);
1129 ++PL_sub_generation;
1130 XSRETURN_EMPTY;
1131}
1132
80305961
YO
1133XS(XS_re_is_regexp)
1134{
1135 dVAR;
1136 dXSARGS;
1137 if (items != 1)
1138 Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
1139 PERL_UNUSED_VAR(cv); /* -W */
1140 PERL_UNUSED_VAR(ax); /* -Wall */
1141 SP -= items;
1142 {
1143 SV * sv = ST(0);
1144 if ( Perl_get_re_arg( aTHX_ sv, 0, NULL ) )
1145 {
1146 XSRETURN_YES;
1147 } else {
1148 XSRETURN_NO;
1149 }
1150 /* NOTREACHED */
1151 PUTBACK;
1152 return;
1153 }
1154}
1155
1156XS(XS_re_regname)
1157{
1158
1159 dVAR;
1160 dXSARGS;
1161 if (items < 1 || items > 3)
1162 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "sv, qr = NULL, all = NULL");
1163 PERL_UNUSED_VAR(cv); /* -W */
1164 PERL_UNUSED_VAR(ax); /* -Wall */
1165 SP -= items;
1166 {
1167 SV * sv = ST(0);
1168 SV * qr;
1169 SV * all;
1170 regexp *re = NULL;
1171 SV *bufs = NULL;
1172
1173 if (items < 2)
1174 qr = NULL;
1175 else {
1176 qr = ST(1);
1177 }
1178
1179 if (items < 3)
1180 all = NULL;
1181 else {
1182 all = ST(2);
1183 }
1184 {
1185 re = Perl_get_re_arg( aTHX_ qr, 1, NULL);
1186 if (SvPOK(sv) && re && re->paren_names) {
1187 bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all));
1188 if (bufs) {
1189 if (all && SvTRUE(all))
1190 XPUSHs(newRV(bufs));
1191 else
1192 XPUSHs(SvREFCNT_inc(bufs));
1193 XSRETURN(1);
1194 }
1195 }
1196 XSRETURN_UNDEF;
1197 }
1198 PUTBACK;
1199 return;
1200 }
1201}
1202
1203XS(XS_re_regnames)
1204{
1205 dVAR;
1206 dXSARGS;
1207 if (items < 0 || items > 2)
1208 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "sv = NULL, all = NULL");
1209 PERL_UNUSED_VAR(cv); /* -W */
1210 PERL_UNUSED_VAR(ax); /* -Wall */
1211 SP -= items;
1212 {
1213 SV * sv;
1214 SV * all;
1215 regexp *re = NULL;
1216 IV count = 0;
1217
1218 if (items < 1)
1219 sv = NULL;
1220 else {
1221 sv = ST(0);
1222 }
1223
1224 if (items < 2)
1225 all = NULL;
1226 else {
1227 all = ST(1);
1228 }
1229 {
1230 re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
1231 if (re && re->paren_names) {
1232 HV *hv= re->paren_names;
1233 (void)hv_iterinit(hv);
1234 while (1) {
1235 HE *temphe = hv_iternext_flags(hv,0);
1236 if (temphe) {
1237 IV i;
1238 IV parno = 0;
1239 SV* sv_dat = HeVAL(temphe);
1240 I32 *nums = (I32*)SvPVX(sv_dat);
1241 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1242 if ((I32)(re->lastcloseparen) >= nums[i] &&
1243 re->startp[nums[i]] != -1 &&
1244 re->endp[nums[i]] != -1)
1245 {
1246 parno = nums[i];
1247 break;
1248 }
1249 }
1250 if (parno || (all && SvTRUE(all))) {
1251 STRLEN len;
1252 char *pv = HePV(temphe, len);
1253 if ( GIMME_V == G_ARRAY )
1254 XPUSHs(newSVpvn(pv,len));
1255 count++;
1256 }
1257 } else {
1258 break;
1259 }
1260 }
1261 }
1262 if ( GIMME_V == G_ARRAY )
1263 XSRETURN(count);
1264 else
1265 XSRETURN_UNDEF;
1266 }
1267 PUTBACK;
1268 return;
1269 }
1270}
1271
1272
1273XS(XS_re_regnames_iterinit)
1274{
1275 dVAR;
1276 dXSARGS;
1277 if (items < 0 || items > 1)
1278 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iterinit", "sv = NULL");
1279 PERL_UNUSED_VAR(cv); /* -W */
1280 PERL_UNUSED_VAR(ax); /* -Wall */
1281 SP -= items;
1282 {
1283 SV * sv;
1284 regexp *re = NULL;
1285
1286 if (items < 1)
1287 sv = NULL;
1288 else {
1289 sv = ST(0);
1290 }
1291 {
1292 re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
1293 if (re && re->paren_names) {
1294 (void)hv_iterinit(re->paren_names);
1295 XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1296 } else {
1297 XSRETURN_UNDEF;
1298 }
1299 }
1300 PUTBACK;
1301 return;
1302 }
1303}
1304
1305
1306XS(XS_re_regnames_iternext)
1307{
1308 dVAR;
1309 dXSARGS;
1310 if (items < 0 || items > 2)
1311 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "sv = NULL, all = NULL");
1312 PERL_UNUSED_VAR(cv); /* -W */
1313 PERL_UNUSED_VAR(ax); /* -Wall */
1314 SP -= items;
1315 {
1316 SV * sv;
1317 SV * all;
1318 regexp *re;
1319
1320 if (items < 1)
1321 sv = NULL;
1322 else {
1323 sv = ST(0);
1324 }
1325
1326 if (items < 2)
1327 all = NULL;
1328 else {
1329 all = ST(1);
1330 }
1331 {
1332 re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
1333 if (re && re->paren_names) {
1334 HV *hv= re->paren_names;
1335 while (1) {
1336 HE *temphe = hv_iternext_flags(hv,0);
1337 if (temphe) {
1338 IV i;
1339 IV parno = 0;
1340 SV* sv_dat = HeVAL(temphe);
1341 I32 *nums = (I32*)SvPVX(sv_dat);
1342 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1343 if ((I32)(re->lastcloseparen) >= nums[i] &&
1344 re->startp[nums[i]] != -1 &&
1345 re->endp[nums[i]] != -1)
1346 {
1347 parno = nums[i];
1348 break;
1349 }
1350 }
1351 if (parno || (all && SvTRUE(all))) {
1352 STRLEN len;
1353 char *pv = HePV(temphe, len);
1354 XPUSHs(newSVpvn(pv,len));
1355 XSRETURN(1);
1356 }
1357 } else {
1358 break;
1359 }
1360 }
1361 }
1362 XSRETURN_UNDEF;
1363 }
1364 PUTBACK;
1365 return;
1366 }
1367}
1368
1369
1370XS(XS_re_regnames_count)
1371{
1372 SV * sv;
1373 regexp *re = NULL;
1374 dVAR;
1375 dXSARGS;
1376
1377 if (items < 0 || items > 1)
1378 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "sv = NULL");
1379 PERL_UNUSED_VAR(cv); /* -W */
1380 PERL_UNUSED_VAR(ax); /* -Wall */
1381 SP -= items;
1382 if (items < 1)
1383 sv = NULL;
1384 else {
1385 sv = ST(0);
1386 }
1387 re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
1388 if (re && re->paren_names) {
1389 XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1390 } else {
1391 XSRETURN_UNDEF;
1392 }
1393 PUTBACK;
1394 return;
1395}
1396
1397
241d1a3b
NC
1398/*
1399 * Local variables:
1400 * c-indentation-style: bsd
1401 * c-basic-offset: 4
1402 * indent-tabs-mode: t
1403 * End:
1404 *
37442d52
RGS
1405 * ex: set ts=8 sts=4 sw=4 noet:
1406 */