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