This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to version.pm 0.71, by John Peacock
[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 459 if ( !sv_derived_from(sv, "version"))
ac0e6a2f 460 upg_version(sv, FALSE);
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 */
ac0e6a2f 486 req = sv_2mortal( new_version(req) );
137d6fc0 487 }
1571675a 488
ac0e6a2f
RGS
489 if ( vcmp( req, sv ) > 0 ) {
490 if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) {
491 Perl_croak(aTHX_ "%s version %"SVf" required--"
492 "this is only version %"SVf"", HvNAME_get(pkg),
be2597df 493 SVfARG(vnormal(req)),
be2597df 494 SVfARG(vnormal(sv)));
ac0e6a2f
RGS
495 } else {
496 Perl_croak(aTHX_ "%s version %"SVf" required--"
497 "this is only version %"SVf"", HvNAME_get(pkg),
498 SVfARG(vnumify(req)),
499 SVfARG(vnumify(sv)));
500 }
501 }
502
2d8e6c8d 503 }
6d4a7be2 504
2b140d5b 505 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
b38a9dc5 506 ST(0) = vnumify(sv);
13f8f398
JP
507 } else {
508 ST(0) = sv;
b38a9dc5 509 }
6d4a7be2
PP
510
511 XSRETURN(1);
512}
513
439cb1c4
JP
514XS(XS_version_new)
515{
97aff369 516 dVAR;
439cb1c4 517 dXSARGS;
58c0efa5 518 PERL_UNUSED_ARG(cv);
129318bd 519 if (items > 3)
439cb1c4
JP
520 Perl_croak(aTHX_ "Usage: version::new(class, version)");
521 SP -= items;
522 {
137d6fc0
JP
523 SV *vs = ST(1);
524 SV *rv;
c4420975
AL
525 const char * const classname =
526 sv_isobject(ST(0)) /* get the class if called as an object method */
527 ? HvNAME(SvSTASH(SvRV(ST(0))))
528 : (char *)SvPV_nolen(ST(0));
9137345a 529
92dcf8ce
JP
530 if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
531 /* create empty object */
532 vs = sv_newmortal();
533 sv_setpvn(vs,"",0);
9137345a
JP
534 }
535 else if ( items == 3 ) {
536 vs = sv_newmortal();
cfd0369c 537 Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2)));
129318bd 538 }
439cb1c4 539
137d6fc0 540 rv = new_version(vs);
0723351e 541 if ( strcmp(classname,"version") != 0 ) /* inherited new() */
da51bb9b 542 sv_bless(rv, gv_stashpv(classname, GV_ADD));
137d6fc0
JP
543
544 PUSHs(sv_2mortal(rv));
439cb1c4
JP
545 PUTBACK;
546 return;
547 }
548}
549
550XS(XS_version_stringify)
551{
97aff369 552 dVAR;
41be1fbd 553 dXSARGS;
58c0efa5 554 PERL_UNUSED_ARG(cv);
41be1fbd
JH
555 if (items < 1)
556 Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
557 SP -= items;
558 {
7452cf6a 559 SV * lobj;
41be1fbd
JH
560
561 if (sv_derived_from(ST(0), "version")) {
9137345a 562 lobj = SvRV(ST(0));
41be1fbd
JH
563 }
564 else
565 Perl_croak(aTHX_ "lobj is not of type version");
566
137d6fc0 567 PUSHs(sv_2mortal(vstringify(lobj)));
41be1fbd
JH
568
569 PUTBACK;
570 return;
571 }
439cb1c4
JP
572}
573
574XS(XS_version_numify)
575{
97aff369 576 dVAR;
41be1fbd 577 dXSARGS;
58c0efa5 578 PERL_UNUSED_ARG(cv);
41be1fbd
JH
579 if (items < 1)
580 Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
581 SP -= items;
582 {
7452cf6a 583 SV * lobj;
41be1fbd
JH
584
585 if (sv_derived_from(ST(0), "version")) {
9137345a 586 lobj = SvRV(ST(0));
41be1fbd
JH
587 }
588 else
589 Perl_croak(aTHX_ "lobj is not of type version");
590
137d6fc0 591 PUSHs(sv_2mortal(vnumify(lobj)));
41be1fbd
JH
592
593 PUTBACK;
594 return;
595 }
439cb1c4
JP
596}
597
9137345a
JP
598XS(XS_version_normal)
599{
97aff369 600 dVAR;
9137345a 601 dXSARGS;
58c0efa5 602 PERL_UNUSED_ARG(cv);
9137345a
JP
603 if (items < 1)
604 Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
605 SP -= items;
606 {
7452cf6a 607 SV * lobj;
9137345a
JP
608
609 if (sv_derived_from(ST(0), "version")) {
610 lobj = SvRV(ST(0));
611 }
612 else
613 Perl_croak(aTHX_ "lobj is not of type version");
614
615 PUSHs(sv_2mortal(vnormal(lobj)));
616
617 PUTBACK;
618 return;
619 }
620}
621
439cb1c4
JP
622XS(XS_version_vcmp)
623{
97aff369 624 dVAR;
41be1fbd 625 dXSARGS;
58c0efa5 626 PERL_UNUSED_ARG(cv);
41be1fbd
JH
627 if (items < 1)
628 Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
629 SP -= items;
630 {
7452cf6a 631 SV * lobj;
41be1fbd
JH
632
633 if (sv_derived_from(ST(0), "version")) {
9137345a 634 lobj = SvRV(ST(0));
41be1fbd
JH
635 }
636 else
637 Perl_croak(aTHX_ "lobj is not of type version");
638
639 {
640 SV *rs;
641 SV *rvs;
642 SV * robj = ST(1);
7452cf6a 643 const IV swap = (IV)SvIV(ST(2));
41be1fbd
JH
644
645 if ( ! sv_derived_from(robj, "version") )
646 {
647 robj = new_version(robj);
648 }
649 rvs = SvRV(robj);
650
651 if ( swap )
652 {
653 rs = newSViv(vcmp(rvs,lobj));
654 }
655 else
656 {
657 rs = newSViv(vcmp(lobj,rvs));
658 }
659
137d6fc0 660 PUSHs(sv_2mortal(rs));
41be1fbd
JH
661 }
662
663 PUTBACK;
664 return;
665 }
439cb1c4
JP
666}
667
668XS(XS_version_boolean)
669{
97aff369
JH
670 dVAR;
671 dXSARGS;
58c0efa5 672 PERL_UNUSED_ARG(cv);
97aff369
JH
673 if (items < 1)
674 Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
675 SP -= items;
c4420975
AL
676 if (sv_derived_from(ST(0), "version")) {
677 SV * const lobj = SvRV(ST(0));
396482e1 678 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
c4420975
AL
679 PUSHs(sv_2mortal(rs));
680 PUTBACK;
681 return;
682 }
683 else
684 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
685}
686
687XS(XS_version_noop)
688{
97aff369 689 dVAR;
2dfd8427 690 dXSARGS;
58c0efa5 691 PERL_UNUSED_ARG(cv);
2dfd8427
AL
692 if (items < 1)
693 Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
694 if (sv_derived_from(ST(0), "version"))
695 Perl_croak(aTHX_ "operation not supported with version object");
696 else
697 Perl_croak(aTHX_ "lobj is not of type version");
698#ifndef HASATTRIBUTE_NORETURN
699 XSRETURN_EMPTY;
700#endif
439cb1c4
JP
701}
702
c8d69e4a
JP
703XS(XS_version_is_alpha)
704{
97aff369 705 dVAR;
c8d69e4a 706 dXSARGS;
58c0efa5 707 PERL_UNUSED_ARG(cv);
c8d69e4a
JP
708 if (items != 1)
709 Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
710 SP -= items;
c4420975
AL
711 if (sv_derived_from(ST(0), "version")) {
712 SV * const lobj = ST(0);
713 if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) )
714 XSRETURN_YES;
715 else
716 XSRETURN_NO;
c8d69e4a
JP
717 PUTBACK;
718 return;
719 }
c4420975
AL
720 else
721 Perl_croak(aTHX_ "lobj is not of type version");
c8d69e4a
JP
722}
723
137d6fc0
JP
724XS(XS_version_qv)
725{
97aff369 726 dVAR;
137d6fc0 727 dXSARGS;
58c0efa5 728 PERL_UNUSED_ARG(cv);
137d6fc0
JP
729 if (items != 1)
730 Perl_croak(aTHX_ "Usage: version::qv(ver)");
731 SP -= items;
732 {
733 SV * ver = ST(0);
c4420975 734 if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
ac0e6a2f
RGS
735 SV * const rv = sv_newmortal();
736 sv_setsv(rv,ver); /* make a duplicate */
737 upg_version(rv, TRUE);
738 PUSHs(rv);
137d6fc0
JP
739 }
740 else
741 {
742 PUSHs(sv_2mortal(new_version(ver)));
743 }
744
745 PUTBACK;
746 return;
747 }
748}
749
8800c35a
JH
750XS(XS_utf8_is_utf8)
751{
97aff369 752 dVAR;
41be1fbd 753 dXSARGS;
58c0efa5 754 PERL_UNUSED_ARG(cv);
41be1fbd
JH
755 if (items != 1)
756 Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
c4420975
AL
757 else {
758 const SV * const sv = ST(0);
759 if (SvUTF8(sv))
760 XSRETURN_YES;
761 else
762 XSRETURN_NO;
41be1fbd
JH
763 }
764 XSRETURN_EMPTY;
8800c35a
JH
765}
766
1b026014
NIS
767XS(XS_utf8_valid)
768{
97aff369 769 dVAR;
41be1fbd 770 dXSARGS;
58c0efa5 771 PERL_UNUSED_ARG(cv);
41be1fbd
JH
772 if (items != 1)
773 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
c4420975
AL
774 else {
775 SV * const sv = ST(0);
776 STRLEN len;
777 const char * const s = SvPV_const(sv,len);
778 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
779 XSRETURN_YES;
780 else
781 XSRETURN_NO;
782 }
41be1fbd 783 XSRETURN_EMPTY;
1b026014
NIS
784}
785
786XS(XS_utf8_encode)
787{
97aff369 788 dVAR;
1b026014 789 dXSARGS;
58c0efa5 790 PERL_UNUSED_ARG(cv);
1b026014
NIS
791 if (items != 1)
792 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
c4420975 793 sv_utf8_encode(ST(0));
1b026014
NIS
794 XSRETURN_EMPTY;
795}
796
797XS(XS_utf8_decode)
798{
97aff369 799 dVAR;
1b026014 800 dXSARGS;
58c0efa5 801 PERL_UNUSED_ARG(cv);
1b026014
NIS
802 if (items != 1)
803 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
c4420975
AL
804 else {
805 SV * const sv = ST(0);
6867be6d 806 const bool RETVAL = sv_utf8_decode(sv);
1b026014
NIS
807 ST(0) = boolSV(RETVAL);
808 sv_2mortal(ST(0));
809 }
810 XSRETURN(1);
811}
812
813XS(XS_utf8_upgrade)
814{
97aff369 815 dVAR;
1b026014 816 dXSARGS;
58c0efa5 817 PERL_UNUSED_ARG(cv);
1b026014
NIS
818 if (items != 1)
819 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
c4420975
AL
820 else {
821 SV * const sv = ST(0);
1b026014
NIS
822 STRLEN RETVAL;
823 dXSTARG;
824
825 RETVAL = sv_utf8_upgrade(sv);
826 XSprePUSH; PUSHi((IV)RETVAL);
827 }
828 XSRETURN(1);
829}
830
831XS(XS_utf8_downgrade)
832{
97aff369 833 dVAR;
1b026014 834 dXSARGS;
58c0efa5 835 PERL_UNUSED_ARG(cv);
1b026014
NIS
836 if (items < 1 || items > 2)
837 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
c4420975
AL
838 else {
839 SV * const sv = ST(0);
6867be6d
AL
840 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
841 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 842
1b026014
NIS
843 ST(0) = boolSV(RETVAL);
844 sv_2mortal(ST(0));
845 }
846 XSRETURN(1);
847}
848
849XS(XS_utf8_native_to_unicode)
850{
97aff369 851 dVAR;
1b026014 852 dXSARGS;
6867be6d 853 const UV uv = SvUV(ST(0));
58c0efa5 854 PERL_UNUSED_ARG(cv);
b7953727
JH
855
856 if (items > 1)
857 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
858
1b026014
NIS
859 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
860 XSRETURN(1);
861}
862
863XS(XS_utf8_unicode_to_native)
864{
97aff369 865 dVAR;
1b026014 866 dXSARGS;
6867be6d 867 const UV uv = SvUV(ST(0));
58c0efa5 868 PERL_UNUSED_ARG(cv);
b7953727
JH
869
870 if (items > 1)
871 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
872
1b026014
NIS
873 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
874 XSRETURN(1);
875}
876
14a976d6 877XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577 878{
97aff369 879 dVAR;
29569577 880 dXSARGS;
c4420975 881 SV * const sv = SvRV(ST(0));
58c0efa5 882 PERL_UNUSED_ARG(cv);
6867be6d 883
29569577
JH
884 if (items == 1) {
885 if (SvREADONLY(sv))
886 XSRETURN_YES;
887 else
888 XSRETURN_NO;
889 }
890 else if (items == 2) {
891 if (SvTRUE(ST(1))) {
892 SvREADONLY_on(sv);
893 XSRETURN_YES;
894 }
895 else {
14a976d6 896 /* I hope you really know what you are doing. */
29569577
JH
897 SvREADONLY_off(sv);
898 XSRETURN_NO;
899 }
900 }
14a976d6 901 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
902}
903
14a976d6 904XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577 905{
97aff369 906 dVAR;
29569577 907 dXSARGS;
c4420975 908 SV * const sv = SvRV(ST(0));
58c0efa5 909 PERL_UNUSED_ARG(cv);
6867be6d 910
29569577 911 if (items == 1)
14a976d6 912 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 913 else if (items == 2) {
14a976d6 914 /* I hope you really know what you are doing. */
29569577
JH
915 SvREFCNT(sv) = SvIV(ST(1));
916 XSRETURN_IV(SvREFCNT(sv));
917 }
14a976d6 918 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
919}
920
f044d0d1 921XS(XS_Internals_hv_clear_placehold)
dfd4ef2f 922{
97aff369 923 dVAR;
dfd4ef2f 924 dXSARGS;
58c0efa5 925 PERL_UNUSED_ARG(cv);
6867be6d 926
3540d4ce
AB
927 if (items != 1)
928 Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
c4420975
AL
929 else {
930 HV * const hv = (HV *) SvRV(ST(0));
931 hv_clear_placeholders(hv);
932 XSRETURN(0);
933 }
dfd4ef2f 934}
39f7a870 935
39cff0d9
AE
936XS(XS_Regexp_DESTROY)
937{
96a5add6 938 PERL_UNUSED_CONTEXT;
53c1dcc0 939 PERL_UNUSED_ARG(cv);
39cff0d9
AE
940}
941
39f7a870
JH
942XS(XS_PerlIO_get_layers)
943{
97aff369 944 dVAR;
39f7a870 945 dXSARGS;
58c0efa5 946 PERL_UNUSED_ARG(cv);
39f7a870
JH
947 if (items < 1 || items % 2 == 0)
948 Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
5fef3b4a 949#ifdef USE_PERLIO
39f7a870
JH
950 {
951 SV * sv;
952 GV * gv;
953 IO * io;
954 bool input = TRUE;
955 bool details = FALSE;
956
957 if (items > 1) {
c4420975 958 SV * const *svp;
39f7a870 959 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
960 SV * const * const varp = svp;
961 SV * const * const valp = svp + 1;
39f7a870 962 STRLEN klen;
c4420975 963 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
964
965 switch (*key) {
966 case 'i':
967 if (klen == 5 && memEQ(key, "input", 5)) {
968 input = SvTRUE(*valp);
969 break;
970 }
971 goto fail;
972 case 'o':
973 if (klen == 6 && memEQ(key, "output", 6)) {
974 input = !SvTRUE(*valp);
975 break;
976 }
977 goto fail;
978 case 'd':
979 if (klen == 7 && memEQ(key, "details", 7)) {
980 details = SvTRUE(*valp);
981 break;
982 }
983 goto fail;
984 default:
985 fail:
986 Perl_croak(aTHX_
987 "get_layers: unknown argument '%s'",
988 key);
989 }
990 }
991
992 SP -= (items - 1);
993 }
994
995 sv = POPs;
996 gv = (GV*)sv;
997
998 if (!isGV(sv)) {
999 if (SvROK(sv) && isGV(SvRV(sv)))
1000 gv = (GV*)SvRV(sv);
671d49be 1001 else if (SvPOKp(sv))
f776e3cd 1002 gv = gv_fetchsv(sv, 0, SVt_PVIO);
39f7a870
JH
1003 }
1004
1005 if (gv && (io = GvIO(gv))) {
1006 dTARGET;
c4420975 1007 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870
JH
1008 IoIFP(io) : IoOFP(io));
1009 I32 i;
c4420975 1010 const I32 last = av_len(av);
39f7a870
JH
1011 I32 nitem = 0;
1012
1013 for (i = last; i >= 0; i -= 3) {
c4420975
AL
1014 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
1015 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
1016 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 1017
c4420975
AL
1018 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
1019 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
1020 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870
JH
1021
1022 if (details) {
ec3bab8e
NC
1023 XPUSHs(namok
1024 ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp))
1025 : &PL_sv_undef);
1026 XPUSHs(argok
1027 ? newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp))
1028 : &PL_sv_undef);
39f7a870
JH
1029 if (flgok)
1030 XPUSHi(SvIVX(*flgsvp));
1031 else
1032 XPUSHs(&PL_sv_undef);
1033 nitem += 3;
1034 }
1035 else {
1036 if (namok && argok)
1037 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df
MHM
1038 SVfARG(*namsvp),
1039 SVfARG(*argsvp)));
39f7a870 1040 else if (namok)
95b63a38 1041 XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf,
be2597df 1042 SVfARG(*namsvp)));
39f7a870
JH
1043 else
1044 XPUSHs(&PL_sv_undef);
1045 nitem++;
1046 if (flgok) {
c4420975 1047 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
1048
1049 if (flags & PERLIO_F_UTF8) {
396482e1 1050 XPUSHs(newSVpvs("utf8"));
39f7a870
JH
1051 nitem++;
1052 }
1053 }
1054 }
1055 }
1056
1057 SvREFCNT_dec(av);
1058
1059 XSRETURN(nitem);
1060 }
1061 }
5fef3b4a 1062#endif
39f7a870
JH
1063
1064 XSRETURN(0);
1065}
1066
9a7034eb 1067XS(XS_Internals_hash_seed)
c910b28a 1068{
97aff369 1069 dVAR;
c85d3f85
NC
1070 /* Using dXSARGS would also have dITEM and dSP,
1071 * which define 2 unused local variables. */
557b887a 1072 dAXMARK;
53c1dcc0 1073 PERL_UNUSED_ARG(cv);
ad73156c 1074 PERL_UNUSED_VAR(mark);
81eaca17 1075 XSRETURN_UV(PERL_HASH_SEED);
c910b28a
JH
1076}
1077
008fb0c0 1078XS(XS_Internals_rehash_seed)
8e90d776 1079{
97aff369 1080 dVAR;
8e90d776
NC
1081 /* Using dXSARGS would also have dITEM and dSP,
1082 * which define 2 unused local variables. */
557b887a 1083 dAXMARK;
53c1dcc0 1084 PERL_UNUSED_ARG(cv);
ad73156c 1085 PERL_UNUSED_VAR(mark);
008fb0c0 1086 XSRETURN_UV(PL_rehash_seed);
8e90d776
NC
1087}
1088
05619474
NC
1089XS(XS_Internals_HvREHASH) /* Subject to change */
1090{
97aff369 1091 dVAR;
05619474 1092 dXSARGS;
58c0efa5 1093 PERL_UNUSED_ARG(cv);
05619474 1094 if (SvROK(ST(0))) {
c4420975 1095 const HV * const hv = (HV *) SvRV(ST(0));
05619474
NC
1096 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1097 if (HvREHASH(hv))
1098 XSRETURN_YES;
1099 else
1100 XSRETURN_NO;
1101 }
1102 }
1103 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1104}
241d1a3b 1105
e1234d8e
NC
1106XS(XS_Internals_inc_sub_generation)
1107{
97aff369 1108 dVAR;
e1234d8e
NC
1109 /* Using dXSARGS would also have dITEM and dSP,
1110 * which define 2 unused local variables. */
1111 dAXMARK;
1112 PERL_UNUSED_ARG(cv);
1113 PERL_UNUSED_VAR(mark);
1114 ++PL_sub_generation;
1115 XSRETURN_EMPTY;
1116}
1117
80305961
YO
1118XS(XS_re_is_regexp)
1119{
1120 dVAR;
1121 dXSARGS;
1122 if (items != 1)
1123 Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
1124 PERL_UNUSED_VAR(cv); /* -W */
1125 PERL_UNUSED_VAR(ax); /* -Wall */
1126 SP -= items;
1127 {
1128 SV * sv = ST(0);
1129 if ( Perl_get_re_arg( aTHX_ sv, 0, NULL ) )
1130 {
1131 XSRETURN_YES;
1132 } else {
1133 XSRETURN_NO;
1134 }
1135 /* NOTREACHED */
1136 PUTBACK;
1137 return;
1138 }
1139}
1140
1141XS(XS_re_regname)
1142{
1143
1144 dVAR;
1145 dXSARGS;
1146 if (items < 1 || items > 3)
1147 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "sv, qr = NULL, all = NULL");
1148 PERL_UNUSED_VAR(cv); /* -W */
1149 PERL_UNUSED_VAR(ax); /* -Wall */
1150 SP -= items;
1151 {
1152 SV * sv = ST(0);
1153 SV * qr;
1154 SV * all;
1155 regexp *re = NULL;
1156 SV *bufs = NULL;
1157
1158 if (items < 2)
1159 qr = NULL;
1160 else {
1161 qr = ST(1);
1162 }
1163
1164 if (items < 3)
1165 all = NULL;
1166 else {
1167 all = ST(2);
1168 }
1169 {
1170 re = Perl_get_re_arg( aTHX_ qr, 1, NULL);
1171 if (SvPOK(sv) && re && re->paren_names) {
1172 bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all));
1173 if (bufs) {
1174 if (all && SvTRUE(all))
1175 XPUSHs(newRV(bufs));
1176 else
1177 XPUSHs(SvREFCNT_inc(bufs));
1178 XSRETURN(1);
1179 }
1180 }
1181 XSRETURN_UNDEF;
1182 }
1183 PUTBACK;
1184 return;
1185 }
1186}
1187
1188XS(XS_re_regnames)
1189{
1190 dVAR;
1191 dXSARGS;
1192 if (items < 0 || items > 2)
1193 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "sv = NULL, all = NULL");
1194 PERL_UNUSED_VAR(cv); /* -W */
1195 PERL_UNUSED_VAR(ax); /* -Wall */
1196 SP -= items;
1197 {
1198 SV * sv;
1199 SV * all;
1200 regexp *re = NULL;
1201 IV count = 0;
1202
1203 if (items < 1)
1204 sv = NULL;
1205 else {
1206 sv = ST(0);
1207 }
1208
1209 if (items < 2)
1210 all = NULL;
1211 else {
1212 all = ST(1);
1213 }
1214 {
1215 re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
1216 if (re && re->paren_names) {
1217 HV *hv= re->paren_names;
1218 (void)hv_iterinit(hv);
1219 while (1) {
1220 HE *temphe = hv_iternext_flags(hv,0);
1221 if (temphe) {
1222 IV i;
1223 IV parno = 0;
1224 SV* sv_dat = HeVAL(temphe);
1225 I32 *nums = (I32*)SvPVX(sv_dat);
1226 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1227 if ((I32)(re->lastcloseparen) >= nums[i] &&
1228 re->startp[nums[i]] != -1 &&
1229 re->endp[nums[i]] != -1)
1230 {
1231 parno = nums[i];
1232 break;
1233 }
1234 }
1235 if (parno || (all && SvTRUE(all))) {
1236 STRLEN len;
1237 char *pv = HePV(temphe, len);
1238 if ( GIMME_V == G_ARRAY )
1239 XPUSHs(newSVpvn(pv,len));
1240 count++;
1241 }
1242 } else {
1243 break;
1244 }
1245 }
1246 }
1247 if ( GIMME_V == G_ARRAY )
1248 XSRETURN(count);
1249 else
1250 XSRETURN_UNDEF;
1251 }
1252 PUTBACK;
1253 return;
1254 }
1255}
1256
1257
1258XS(XS_re_regnames_iterinit)
1259{
1260 dVAR;
1261 dXSARGS;
1262 if (items < 0 || items > 1)
1263 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iterinit", "sv = NULL");
1264 PERL_UNUSED_VAR(cv); /* -W */
1265 PERL_UNUSED_VAR(ax); /* -Wall */
1266 SP -= items;
1267 {
1268 SV * sv;
1269 regexp *re = NULL;
1270
1271 if (items < 1)
1272 sv = NULL;
1273 else {
1274 sv = ST(0);
1275 }
1276 {
1277 re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
1278 if (re && re->paren_names) {
1279 (void)hv_iterinit(re->paren_names);
1280 XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1281 } else {
1282 XSRETURN_UNDEF;
1283 }
1284 }
1285 PUTBACK;
1286 return;
1287 }
1288}
1289
1290
1291XS(XS_re_regnames_iternext)
1292{
1293 dVAR;
1294 dXSARGS;
1295 if (items < 0 || items > 2)
1296 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "sv = NULL, all = NULL");
1297 PERL_UNUSED_VAR(cv); /* -W */
1298 PERL_UNUSED_VAR(ax); /* -Wall */
1299 SP -= items;
1300 {
1301 SV * sv;
1302 SV * all;
1303 regexp *re;
1304
1305 if (items < 1)
1306 sv = NULL;
1307 else {
1308 sv = ST(0);
1309 }
1310
1311 if (items < 2)
1312 all = NULL;
1313 else {
1314 all = ST(1);
1315 }
1316 {
1317 re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
1318 if (re && re->paren_names) {
1319 HV *hv= re->paren_names;
1320 while (1) {
1321 HE *temphe = hv_iternext_flags(hv,0);
1322 if (temphe) {
1323 IV i;
1324 IV parno = 0;
1325 SV* sv_dat = HeVAL(temphe);
1326 I32 *nums = (I32*)SvPVX(sv_dat);
1327 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
1328 if ((I32)(re->lastcloseparen) >= nums[i] &&
1329 re->startp[nums[i]] != -1 &&
1330 re->endp[nums[i]] != -1)
1331 {
1332 parno = nums[i];
1333 break;
1334 }
1335 }
1336 if (parno || (all && SvTRUE(all))) {
1337 STRLEN len;
1338 char *pv = HePV(temphe, len);
1339 XPUSHs(newSVpvn(pv,len));
1340 XSRETURN(1);
1341 }
1342 } else {
1343 break;
1344 }
1345 }
1346 }
1347 XSRETURN_UNDEF;
1348 }
1349 PUTBACK;
1350 return;
1351 }
1352}
1353
1354
1355XS(XS_re_regnames_count)
1356{
1357 SV * sv;
1358 regexp *re = NULL;
1359 dVAR;
1360 dXSARGS;
1361
1362 if (items < 0 || items > 1)
1363 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "sv = NULL");
1364 PERL_UNUSED_VAR(cv); /* -W */
1365 PERL_UNUSED_VAR(ax); /* -Wall */
1366 SP -= items;
1367 if (items < 1)
1368 sv = NULL;
1369 else {
1370 sv = ST(0);
1371 }
1372 re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
1373 if (re && re->paren_names) {
1374 XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
1375 } else {
1376 XSRETURN_UNDEF;
1377 }
1378 PUTBACK;
1379 return;
1380}
1381
1382
241d1a3b
NC
1383/*
1384 * Local variables:
1385 * c-indentation-style: bsd
1386 * c-basic-offset: 4
1387 * indent-tabs-mode: t
1388 * End:
1389 *
37442d52
RGS
1390 * ex: set ts=8 sts=4 sw=4 noet:
1391 */