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