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