projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
B::Deparse fixes for implicit smartmatching in given/when
[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);
6e449a3a 161 mXPUSHs(newSVpv(name, 0));
cbc021f9 162 PUTBACK;
163
84bafc02 164 methodname = newSVpvs_flags("isa", SVs_TEMP);
59e7186f 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);
f63535fc 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, "*;@");
f63535fc 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
6e449a3a 492 mPUSHs(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
6e449a3a 515 mPUSHs(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
6e449a3a 539 mPUSHs(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
6e449a3a 563 mPUSHs(vnormal(lobj));
9137345a 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
6e449a3a 608 mPUSHs(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"))) );
6e449a3a 627 mPUSHs(rs);
c4420975 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 {
6e449a3a 690 mPUSHs(new_version(ver));
137d6fc0 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
f63535fc 884XS(XS_Regexp_DESTROY)
885{
886 PERL_UNUSED_CONTEXT;
887 PERL_UNUSED_ARG(cv);
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))) {
c4420975 954 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870 955 IoIFP(io) : IoOFP(io));
956 I32 i;
c4420975 957 const I32 last = av_len(av);
39f7a870 958 I32 nitem = 0;
959
960 for (i = last; i >= 0; i -= 3) {
c4420975 961 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
962 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
963 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 964
c4420975 965 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
966 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
967 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870 968
969 if (details) {
ec3bab8e 970 XPUSHs(namok
1eb9e81d 971 ? sv_2mortal(newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp)))
ec3bab8e 972 : &PL_sv_undef);
973 XPUSHs(argok
1eb9e81d 974 ? sv_2mortal(newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp)))
ec3bab8e 975 : &PL_sv_undef);
39f7a870 976 if (flgok)
1eb9e81d 977 mXPUSHi(SvIVX(*flgsvp));
39f7a870 978 else
979 XPUSHs(&PL_sv_undef);
980 nitem += 3;
981 }
982 else {
983 if (namok && argok)
1eb9e81d 984 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 985 SVfARG(*namsvp),
1eb9e81d 986 SVfARG(*argsvp))));
39f7a870 987 else if (namok)
1eb9e81d 988 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf,
989 SVfARG(*namsvp))));
39f7a870 990 else
991 XPUSHs(&PL_sv_undef);
992 nitem++;
993 if (flgok) {
c4420975 994 const IV flags = SvIVX(*flgsvp);
39f7a870 995
996 if (flags & PERLIO_F_UTF8) {
84bafc02 997 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870 998 nitem++;
999 }
1000 }
1001 }
1002 }
1003
1004 SvREFCNT_dec(av);
1005
1006 XSRETURN(nitem);
1007 }
1008 }
5fef3b4a 1009#endif
39f7a870 1010
1011 XSRETURN(0);
1012}
1013
9a7034eb 1014XS(XS_Internals_hash_seed)
c910b28a 1015{
97aff369 1016 dVAR;
c85d3f85 1017 /* Using dXSARGS would also have dITEM and dSP,
1018 * which define 2 unused local variables. */
557b887a 1019 dAXMARK;
53c1dcc0 1020 PERL_UNUSED_ARG(cv);
ad73156c 1021 PERL_UNUSED_VAR(mark);
81eaca17 1022 XSRETURN_UV(PERL_HASH_SEED);
c910b28a 1023}
1024
008fb0c0 1025XS(XS_Internals_rehash_seed)
8e90d776 1026{
97aff369 1027 dVAR;
8e90d776 1028 /* Using dXSARGS would also have dITEM and dSP,
1029 * which define 2 unused local variables. */
557b887a 1030 dAXMARK;
53c1dcc0 1031 PERL_UNUSED_ARG(cv);
ad73156c 1032 PERL_UNUSED_VAR(mark);
008fb0c0 1033 XSRETURN_UV(PL_rehash_seed);
8e90d776 1034}
1035
05619474 1036XS(XS_Internals_HvREHASH) /* Subject to change */
1037{
97aff369 1038 dVAR;
05619474 1039 dXSARGS;
58c0efa5 1040 PERL_UNUSED_ARG(cv);
05619474 1041 if (SvROK(ST(0))) {
c4420975 1042 const HV * const hv = (HV *) SvRV(ST(0));
05619474 1043 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1044 if (HvREHASH(hv))
1045 XSRETURN_YES;
1046 else
1047 XSRETURN_NO;
1048 }
1049 }
1050 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1051}
241d1a3b 1052
80305961 1053XS(XS_re_is_regexp)
1054{
1055 dVAR;
1056 dXSARGS;
f7e71195 1057 PERL_UNUSED_VAR(cv);
1058
80305961 1059 if (items != 1)
1060 Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
f7e71195 1061
80305961 1062 SP -= items;
f7e71195 1063
1064 if (SvRXOK(ST(0))) {
1065 XSRETURN_YES;
1066 } else {
1067 XSRETURN_NO;
80305961 1068 }
1069}
1070
192b9cd1 1071XS(XS_re_regnames_count)
80305961 1072{
192b9cd1 1073 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1074 SV * ret;
80305961 1075 dVAR;
1076 dXSARGS;
48fc4736 1077 PERL_UNUSED_ARG(cv);
192b9cd1 1078
1079 if (items != 0)
1080 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
1081
1082 SP -= items;
1083
1084 if (!rx)
1085 XSRETURN_UNDEF;
1086
1087 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1088
1089 SPAGAIN;
1090
1091 if (ret) {
1092 XPUSHs(ret);
1093 PUTBACK;
1094 return;
1095 } else {
1096 XSRETURN_UNDEF;
1097 }
1098}
1099
1100XS(XS_re_regname)
1101{
1102 dVAR;
1103 dXSARGS;
1104 REGEXP * rx;
1105 U32 flags;
1106 SV * ret;
48fc4736 1107 PERL_UNUSED_ARG(cv);
192b9cd1 1108
28d8d7f4 1109 if (items < 1 || items > 2)
192b9cd1 1110 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
1111
80305961 1112 SP -= items;
80305961 1113
192b9cd1 1114 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1115
1116 if (!rx)
1117 XSRETURN_UNDEF;
1118
1119 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 1120 flags = RXapif_ALL;
192b9cd1 1121 } else {
f1b875a0 1122 flags = RXapif_ONE;
80305961 1123 }
f1b875a0 1124 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1 1125
1126 if (ret) {
1127 if (SvROK(ret))
1128 XPUSHs(ret);
1129 else
1130 XPUSHs(SvREFCNT_inc(ret));
1131 XSRETURN(1);
1132 }
1133 XSRETURN_UNDEF;
80305961 1134}
1135
192b9cd1 1136
80305961 1137XS(XS_re_regnames)
1138{
192b9cd1 1139 dVAR;
80305961 1140 dXSARGS;
192b9cd1 1141 REGEXP * rx;
1142 U32 flags;
1143 SV *ret;
1144 AV *av;
1145 I32 length;
1146 I32 i;
1147 SV **entry;
48fc4736 1148 PERL_UNUSED_ARG(cv);
192b9cd1 1149
1150 if (items > 1)
1151 Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
1152
1153 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1154
1155 if (!rx)
1156 XSRETURN_UNDEF;
1157
1158 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 1159 flags = RXapif_ALL;
192b9cd1 1160 } else {
f1b875a0 1161 flags = RXapif_ONE;
192b9cd1 1162 }
1163
80305961 1164 SP -= items;
80305961 1165
f1b875a0 1166 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1 1167
1168 SPAGAIN;
1169
1170 SP -= items;
1171
1172 if (!ret)
1173 XSRETURN_UNDEF;
1174
1175 av = (AV*)SvRV(ret);
1176 length = av_len(av);
1177
1178 for (i = 0; i <= length; i++) {
1179 entry = av_fetch(av, i, FALSE);
1180
1181 if (!entry)
1182 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1183
1184 XPUSHs(*entry);
80305961 1185 }
192b9cd1 1186 PUTBACK;
1187 return;
80305961 1188}
1189
192b9cd1 1190XS(XS_Tie_Hash_NamedCapture_FETCH)
80305961 1191{
192b9cd1 1192 dVAR;
80305961 1193 dXSARGS;
192b9cd1 1194 REGEXP * rx;
1195 U32 flags;
1196 SV * ret;
48fc4736 1197 PERL_UNUSED_ARG(cv);
192b9cd1 1198
1199 if (items != 2)
1200 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $flags)");
1201
1202 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1203
1204 if (!rx)
1205 XSRETURN_UNDEF;
1206
80305961 1207 SP -= items;
192b9cd1 1208
1209 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1210 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1211
1212 SPAGAIN;
1213
1214 if (ret) {
1215 if (SvROK(ret))
1216 XPUSHs(ret);
1217 else
1218 XPUSHs(SvREFCNT_inc(ret));
1219 PUTBACK;
1220 return;
1221 }
1222 XSRETURN_UNDEF;
1223}
1224
1225XS(XS_Tie_Hash_NamedCapture_STORE)
1226{
1227 dVAR;
1228 dXSARGS;
1229 REGEXP * rx;
1230 U32 flags;
48fc4736 1231 PERL_UNUSED_ARG(cv);
192b9cd1 1232
1233 if (items != 3)
1234 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $value, $flags)");
1235
1236 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1237
1238 if (!rx) {
1239 if (!PL_localizing)
1240 Perl_croak(aTHX_ PL_no_modify);
1241 else
28d8d7f4 1242 XSRETURN_UNDEF;
80305961 1243 }
192b9cd1 1244
1245 SP -= items;
1246
1247 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1248 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
80305961 1249}
1250
192b9cd1 1251XS(XS_Tie_Hash_NamedCapture_DELETE)
1252{
1253 dVAR;
1254 dXSARGS;
1255 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1256 U32 flags;
48fc4736 1257 PERL_UNUSED_ARG(cv);
80305961 1258
192b9cd1 1259 if (items != 2)
1260 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::DELETE($key, $flags)");
1261
1262 if (!rx)
1263 Perl_croak(aTHX_ PL_no_modify);
1264
1265 SP -= items;
1266
1267 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1268 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1269}
1270
1271XS(XS_Tie_Hash_NamedCapture_CLEAR)
80305961 1272{
192b9cd1 1273 dVAR;
80305961 1274 dXSARGS;
192b9cd1 1275 REGEXP * rx;
1276 U32 flags;
48fc4736 1277 PERL_UNUSED_ARG(cv);
192b9cd1 1278
1279 if (items != 1)
1280 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::CLEAR($flags)");
1281
1282 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1283
1284 if (!rx)
1285 Perl_croak(aTHX_ PL_no_modify);
1286
80305961 1287 SP -= items;
80305961 1288
192b9cd1 1289 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1290 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1291}
1292
1293XS(XS_Tie_Hash_NamedCapture_EXISTS)
1294{
1295 dVAR;
1296 dXSARGS;
1297 REGEXP * rx;
1298 U32 flags;
1299 SV * ret;
48fc4736 1300 PERL_UNUSED_ARG(cv);
192b9cd1 1301
1302 if (items != 2)
1303 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::EXISTS($key, $flags)");
1304
1305 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1306
1307 if (!rx)
28d8d7f4 1308 XSRETURN_UNDEF;
192b9cd1 1309
1310 SP -= items;
1311
1312 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1313 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1314
1315 SPAGAIN;
1316
1317 XPUSHs(ret);
80305961 1318 PUTBACK;
1319 return;
80305961 1320}
1321
86aa3d53 1322XS(XS_Tie_Hash_NamedCapture_FIRSTK)
192b9cd1 1323{
1324 dVAR;
1325 dXSARGS;
1326 REGEXP * rx;
1327 U32 flags;
1328 SV * ret;
48fc4736 1329 PERL_UNUSED_ARG(cv);
80305961 1330
192b9cd1 1331 if (items != 1)
1332 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::FIRSTKEY()");
1333
1334 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1335
1336 if (!rx)
1337 XSRETURN_UNDEF;
1338
1339 SP -= items;
1340
1341 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1342 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1343
1344 SPAGAIN;
1345
1346 if (ret) {
1347 XPUSHs(SvREFCNT_inc(ret));
1348 PUTBACK;
1349 } else {
1350 XSRETURN_UNDEF;
1351 }
1352
1353}
1354
86aa3d53 1355XS(XS_Tie_Hash_NamedCapture_NEXTK)
80305961 1356{
192b9cd1 1357 dVAR;
80305961 1358 dXSARGS;
192b9cd1 1359 REGEXP * rx;
1360 U32 flags;
1361 SV * ret;
48fc4736 1362 PERL_UNUSED_ARG(cv);
192b9cd1 1363
1364 if (items != 2)
1365 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::NEXTKEY($lastkey)");
1366
1367 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1368
1369 if (!rx)
1370 XSRETURN_UNDEF;
80305961 1371
80305961 1372 SP -= items;
192b9cd1 1373
1374 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1375 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1376
1377 SPAGAIN;
1378
1379 if (ret) {
1380 XPUSHs(ret);
80305961 1381 } else {
1382 XSRETURN_UNDEF;
1383 }
1384 PUTBACK;
192b9cd1 1385}
1386
1387XS(XS_Tie_Hash_NamedCapture_SCALAR)
1388{
1389 dVAR;
1390 dXSARGS;
1391 REGEXP * rx;
1392 U32 flags;
1393 SV * ret;
48fc4736 1394 PERL_UNUSED_ARG(cv);
192b9cd1 1395
1396 if (items != 1)
1397 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::SCALAR()");
1398
1399 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1400
1401 if (!rx)
1402 XSRETURN_UNDEF;
1403
1404 SP -= items;
1405
1406 flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0))));
1407 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1408
1409 SPAGAIN;
1410
1411 if (ret) {
1412 XPUSHs(ret);
1413 PUTBACK;
1414 return;
1415 } else {
1416 XSRETURN_UNDEF;
1417 }
1418}
1419
1420XS(XS_Tie_Hash_NamedCapture_flags)
1421{
1422 dVAR;
1423 dXSARGS;
48fc4736 1424 PERL_UNUSED_ARG(cv);
192b9cd1 1425
1426 if (items != 0)
1427 Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::flags()");
1428
6e449a3a 1429 mXPUSHu(RXapif_ONE);
1430 mXPUSHu(RXapif_ALL);
192b9cd1 1431 PUTBACK;
1432 return;
80305961 1433}
1434
1435
241d1a3b 1436/*
1437 * Local variables:
1438 * c-indentation-style: bsd
1439 * c-basic-offset: 4
1440 * indent-tabs-mode: t
1441 * End:
1442 *
37442d52 1443 * ex: set ts=8 sts=4 sw=4 noet:
1444 */
Unnamed repository; edit this file to name it for gitweb.