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