This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
segfault on &Internals::* due to missing SvROK()
[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),
e3a22e3f 395 SVfARG(sv_2mortal(vnormal(req))),
396 SVfARG(sv_2mortal(vnormal(sv))));
ac0e6a2f
RGS
397 } else {
398 Perl_croak(aTHX_ "%s version %"SVf" required--"
399 "this is only version %"SVf"", HvNAME_get(pkg),
e3a22e3f 400 SVfARG(sv_2mortal(vstringify(req))),
401 SVfARG(sv_2mortal(vstringify(sv))));
ac0e6a2f
RGS
402 }
403 }
404
2d8e6c8d 405 }
6d4a7be2 406
2b140d5b 407 if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
e3a22e3f 408 ST(0) = sv_2mortal(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 {
d808b681 459 SV * lobj = ST(0);
41be1fbd 460
d808b681
JP
461 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
462 lobj = SvRV(lobj);
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 {
d808b681 482 SV * lobj = ST(0);
41be1fbd 483
d808b681
JP
484 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
485 lobj = SvRV(lobj);
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 {
d808b681 505 SV * lobj = ST(0);
9137345a 506
d808b681
JP
507 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
508 lobj = SvRV(lobj);
9137345a
JP
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 {
d808b681 528 SV * lobj = ST(0);
41be1fbd 529
d808b681
JP
530 if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
531 lobj = SvRV(lobj);
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 {
e3a22e3f 544 robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
545 sv_2mortal(robj);
41be1fbd
JH
546 }
547 rvs = SvRV(robj);
548
549 if ( swap )
550 {
551 rs = newSViv(vcmp(rvs,lobj));
552 }
553 else
554 {
555 rs = newSViv(vcmp(lobj,rvs));
556 }
557
6e449a3a 558 mPUSHs(rs);
41be1fbd
JH
559 }
560
561 PUTBACK;
562 return;
563 }
439cb1c4
JP
564}
565
566XS(XS_version_boolean)
567{
97aff369
JH
568 dVAR;
569 dXSARGS;
570 if (items < 1)
afa74d42 571 croak_xs_usage(cv, "lobj, ...");
97aff369 572 SP -= items;
d808b681 573 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
c4420975 574 SV * const lobj = SvRV(ST(0));
396482e1 575 SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
6e449a3a 576 mPUSHs(rs);
c4420975
AL
577 PUTBACK;
578 return;
579 }
580 else
581 Perl_croak(aTHX_ "lobj is not of type version");
439cb1c4
JP
582}
583
584XS(XS_version_noop)
585{
97aff369 586 dVAR;
2dfd8427
AL
587 dXSARGS;
588 if (items < 1)
afa74d42 589 croak_xs_usage(cv, "lobj, ...");
d808b681 590 if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
2dfd8427
AL
591 Perl_croak(aTHX_ "operation not supported with version object");
592 else
593 Perl_croak(aTHX_ "lobj is not of type version");
594#ifndef HASATTRIBUTE_NORETURN
595 XSRETURN_EMPTY;
596#endif
439cb1c4
JP
597}
598
c8d69e4a
JP
599XS(XS_version_is_alpha)
600{
97aff369 601 dVAR;
c8d69e4a
JP
602 dXSARGS;
603 if (items != 1)
afa74d42 604 croak_xs_usage(cv, "lobj");
c8d69e4a 605 SP -= items;
d808b681 606 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
c4420975 607 SV * const lobj = ST(0);
ef8f7699 608 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
c4420975
AL
609 XSRETURN_YES;
610 else
611 XSRETURN_NO;
c8d69e4a
JP
612 PUTBACK;
613 return;
614 }
c4420975
AL
615 else
616 Perl_croak(aTHX_ "lobj is not of type version");
c8d69e4a
JP
617}
618
137d6fc0
JP
619XS(XS_version_qv)
620{
97aff369 621 dVAR;
137d6fc0 622 dXSARGS;
4ed3fda4 623 PERL_UNUSED_ARG(cv);
137d6fc0
JP
624 SP -= items;
625 {
f941e658
JP
626 SV * ver = ST(0);
627 SV * rv;
628 const char * classname = "";
91152fc1 629 if ( items == 2 && SvOK(ST(1)) ) {
f941e658
JP
630 /* getting called as object or class method */
631 ver = ST(1);
632 classname =
633 sv_isobject(ST(0)) /* class called as an object method */
634 ? HvNAME_get(SvSTASH(SvRV(ST(0))))
635 : (char *)SvPV_nolen(ST(0));
636 }
637 if ( !SvVOK(ver) ) { /* not already a v-string */
638 rv = sv_newmortal();
ac0e6a2f
RGS
639 sv_setsv(rv,ver); /* make a duplicate */
640 upg_version(rv, TRUE);
f941e658
JP
641 } else {
642 rv = sv_2mortal(new_version(ver));
137d6fc0 643 }
f941e658
JP
644 if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
645 sv_bless(rv, gv_stashpv(classname, GV_ADD));
137d6fc0 646 }
f941e658
JP
647 PUSHs(rv);
648 }
649 PUTBACK;
650 return;
651}
137d6fc0 652
f941e658
JP
653XS(XS_version_is_qv)
654{
655 dVAR;
656 dXSARGS;
657 if (items != 1)
658 croak_xs_usage(cv, "lobj");
659 SP -= items;
d808b681 660 if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
f941e658
JP
661 SV * const lobj = ST(0);
662 if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
663 XSRETURN_YES;
664 else
665 XSRETURN_NO;
137d6fc0
JP
666 PUTBACK;
667 return;
668 }
f941e658
JP
669 else
670 Perl_croak(aTHX_ "lobj is not of type version");
137d6fc0
JP
671}
672
8800c35a
JH
673XS(XS_utf8_is_utf8)
674{
97aff369 675 dVAR;
41be1fbd
JH
676 dXSARGS;
677 if (items != 1)
afa74d42 678 croak_xs_usage(cv, "sv");
c4420975 679 else {
76f73021 680 SV * const sv = ST(0);
681 SvGETMAGIC(sv);
c4420975
AL
682 if (SvUTF8(sv))
683 XSRETURN_YES;
684 else
685 XSRETURN_NO;
41be1fbd
JH
686 }
687 XSRETURN_EMPTY;
8800c35a
JH
688}
689
1b026014
NIS
690XS(XS_utf8_valid)
691{
97aff369 692 dVAR;
41be1fbd
JH
693 dXSARGS;
694 if (items != 1)
afa74d42 695 croak_xs_usage(cv, "sv");
c4420975
AL
696 else {
697 SV * const sv = ST(0);
698 STRLEN len;
699 const char * const s = SvPV_const(sv,len);
700 if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len))
701 XSRETURN_YES;
702 else
703 XSRETURN_NO;
704 }
41be1fbd 705 XSRETURN_EMPTY;
1b026014
NIS
706}
707
708XS(XS_utf8_encode)
709{
97aff369 710 dVAR;
1b026014
NIS
711 dXSARGS;
712 if (items != 1)
afa74d42 713 croak_xs_usage(cv, "sv");
c4420975 714 sv_utf8_encode(ST(0));
1b026014
NIS
715 XSRETURN_EMPTY;
716}
717
718XS(XS_utf8_decode)
719{
97aff369 720 dVAR;
1b026014
NIS
721 dXSARGS;
722 if (items != 1)
afa74d42 723 croak_xs_usage(cv, "sv");
c4420975
AL
724 else {
725 SV * const sv = ST(0);
6867be6d 726 const bool RETVAL = sv_utf8_decode(sv);
1b026014
NIS
727 ST(0) = boolSV(RETVAL);
728 sv_2mortal(ST(0));
729 }
730 XSRETURN(1);
731}
732
733XS(XS_utf8_upgrade)
734{
97aff369 735 dVAR;
1b026014
NIS
736 dXSARGS;
737 if (items != 1)
afa74d42 738 croak_xs_usage(cv, "sv");
c4420975
AL
739 else {
740 SV * const sv = ST(0);
1b026014
NIS
741 STRLEN RETVAL;
742 dXSTARG;
743
744 RETVAL = sv_utf8_upgrade(sv);
745 XSprePUSH; PUSHi((IV)RETVAL);
746 }
747 XSRETURN(1);
748}
749
750XS(XS_utf8_downgrade)
751{
97aff369 752 dVAR;
1b026014
NIS
753 dXSARGS;
754 if (items < 1 || items > 2)
afa74d42 755 croak_xs_usage(cv, "sv, failok=0");
c4420975
AL
756 else {
757 SV * const sv = ST(0);
6867be6d
AL
758 const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
759 const bool RETVAL = sv_utf8_downgrade(sv, failok);
1b026014 760
1b026014
NIS
761 ST(0) = boolSV(RETVAL);
762 sv_2mortal(ST(0));
763 }
764 XSRETURN(1);
765}
766
767XS(XS_utf8_native_to_unicode)
768{
97aff369 769 dVAR;
1b026014 770 dXSARGS;
6867be6d 771 const UV uv = SvUV(ST(0));
b7953727
JH
772
773 if (items > 1)
afa74d42 774 croak_xs_usage(cv, "sv");
b7953727 775
1b026014
NIS
776 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
777 XSRETURN(1);
778}
779
780XS(XS_utf8_unicode_to_native)
781{
97aff369 782 dVAR;
1b026014 783 dXSARGS;
6867be6d 784 const UV uv = SvUV(ST(0));
b7953727
JH
785
786 if (items > 1)
afa74d42 787 croak_xs_usage(cv, "sv");
b7953727 788
1b026014
NIS
789 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
790 XSRETURN(1);
791}
792
14a976d6 793XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577 794{
97aff369 795 dVAR;
29569577 796 dXSARGS;
80b6a949
AB
797 SV * const svz = ST(0);
798 SV * sv;
58c0efa5 799 PERL_UNUSED_ARG(cv);
6867be6d 800
80b6a949
AB
801 /* [perl #77776] - called as &foo() not foo() */
802 if (!SvROK(svz))
803 croak_xs_usage(cv, "SCALAR[, ON]");
804
805 sv = SvRV(svz);
806
29569577
JH
807 if (items == 1) {
808 if (SvREADONLY(sv))
809 XSRETURN_YES;
810 else
811 XSRETURN_NO;
812 }
813 else if (items == 2) {
814 if (SvTRUE(ST(1))) {
815 SvREADONLY_on(sv);
816 XSRETURN_YES;
817 }
818 else {
14a976d6 819 /* I hope you really know what you are doing. */
29569577
JH
820 SvREADONLY_off(sv);
821 XSRETURN_NO;
822 }
823 }
14a976d6 824 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
825}
826
14a976d6 827XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577 828{
97aff369 829 dVAR;
29569577 830 dXSARGS;
80b6a949
AB
831 SV * const svz = ST(0);
832 SV * sv;
58c0efa5 833 PERL_UNUSED_ARG(cv);
6867be6d 834
80b6a949
AB
835 /* [perl #77776] - called as &foo() not foo() */
836 if (!SvROK(svz))
837 croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
838
839 sv = SvRV(svz);
840
29569577 841 if (items == 1)
14a976d6 842 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 843 else if (items == 2) {
14a976d6 844 /* I hope you really know what you are doing. */
29569577
JH
845 SvREFCNT(sv) = SvIV(ST(1));
846 XSRETURN_IV(SvREFCNT(sv));
847 }
14a976d6 848 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
849}
850
f044d0d1 851XS(XS_Internals_hv_clear_placehold)
dfd4ef2f 852{
97aff369 853 dVAR;
dfd4ef2f 854 dXSARGS;
6867be6d 855
80b6a949 856 if (items != 1 || !SvROK(ST(0)))
afa74d42 857 croak_xs_usage(cv, "hv");
c4420975 858 else {
ef8f7699 859 HV * const hv = MUTABLE_HV(SvRV(ST(0)));
c4420975
AL
860 hv_clear_placeholders(hv);
861 XSRETURN(0);
862 }
dfd4ef2f 863}
39f7a870
JH
864
865XS(XS_PerlIO_get_layers)
866{
97aff369 867 dVAR;
39f7a870
JH
868 dXSARGS;
869 if (items < 1 || items % 2 == 0)
afa74d42 870 croak_xs_usage(cv, "filehandle[,args]");
5fef3b4a 871#ifdef USE_PERLIO
39f7a870
JH
872 {
873 SV * sv;
874 GV * gv;
875 IO * io;
876 bool input = TRUE;
877 bool details = FALSE;
878
879 if (items > 1) {
c4420975 880 SV * const *svp;
39f7a870 881 for (svp = MARK + 2; svp <= SP; svp += 2) {
c4420975
AL
882 SV * const * const varp = svp;
883 SV * const * const valp = svp + 1;
39f7a870 884 STRLEN klen;
c4420975 885 const char * const key = SvPV_const(*varp, klen);
39f7a870
JH
886
887 switch (*key) {
888 case 'i':
889 if (klen == 5 && memEQ(key, "input", 5)) {
890 input = SvTRUE(*valp);
891 break;
892 }
893 goto fail;
894 case 'o':
895 if (klen == 6 && memEQ(key, "output", 6)) {
896 input = !SvTRUE(*valp);
897 break;
898 }
899 goto fail;
900 case 'd':
901 if (klen == 7 && memEQ(key, "details", 7)) {
902 details = SvTRUE(*valp);
903 break;
904 }
905 goto fail;
906 default:
907 fail:
908 Perl_croak(aTHX_
909 "get_layers: unknown argument '%s'",
910 key);
911 }
912 }
913
914 SP -= (items - 1);
915 }
916
917 sv = POPs;
159b6efe 918 gv = MUTABLE_GV(sv);
39f7a870
JH
919
920 if (!isGV(sv)) {
921 if (SvROK(sv) && isGV(SvRV(sv)))
159b6efe 922 gv = MUTABLE_GV(SvRV(sv));
671d49be 923 else if (SvPOKp(sv))
f776e3cd 924 gv = gv_fetchsv(sv, 0, SVt_PVIO);
39f7a870
JH
925 }
926
927 if (gv && (io = GvIO(gv))) {
c4420975 928 AV* const av = PerlIO_get_layers(aTHX_ input ?
39f7a870
JH
929 IoIFP(io) : IoOFP(io));
930 I32 i;
c4420975 931 const I32 last = av_len(av);
39f7a870
JH
932 I32 nitem = 0;
933
934 for (i = last; i >= 0; i -= 3) {
c4420975
AL
935 SV * const * const namsvp = av_fetch(av, i - 2, FALSE);
936 SV * const * const argsvp = av_fetch(av, i - 1, FALSE);
937 SV * const * const flgsvp = av_fetch(av, i, FALSE);
39f7a870 938
c4420975
AL
939 const bool namok = namsvp && *namsvp && SvPOK(*namsvp);
940 const bool argok = argsvp && *argsvp && SvPOK(*argsvp);
941 const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
39f7a870
JH
942
943 if (details) {
92e45a3e
NC
944 /* Indents of 5? Yuck. */
945 /* We know that PerlIO_get_layers creates a new SV for
946 the name and flags, so we can just take a reference
947 and "steal" it when we free the AV below. */
ec3bab8e 948 XPUSHs(namok
92e45a3e 949 ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
ec3bab8e
NC
950 : &PL_sv_undef);
951 XPUSHs(argok
92e45a3e
NC
952 ? newSVpvn_flags(SvPVX_const(*argsvp),
953 SvCUR(*argsvp),
954 (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
955 | SVs_TEMP)
956 : &PL_sv_undef);
96ccaf53 957 XPUSHs(flgok
92e45a3e 958 ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
ec3bab8e 959 : &PL_sv_undef);
39f7a870
JH
960 nitem += 3;
961 }
962 else {
963 if (namok && argok)
1eb9e81d 964 XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
be2597df 965 SVfARG(*namsvp),
1eb9e81d 966 SVfARG(*argsvp))));
39f7a870 967 else if (namok)
92e45a3e 968 XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
39f7a870
JH
969 else
970 XPUSHs(&PL_sv_undef);
971 nitem++;
972 if (flgok) {
c4420975 973 const IV flags = SvIVX(*flgsvp);
39f7a870
JH
974
975 if (flags & PERLIO_F_UTF8) {
84bafc02 976 XPUSHs(newSVpvs_flags("utf8", SVs_TEMP));
39f7a870
JH
977 nitem++;
978 }
979 }
980 }
981 }
982
983 SvREFCNT_dec(av);
984
985 XSRETURN(nitem);
986 }
987 }
5fef3b4a 988#endif
39f7a870
JH
989
990 XSRETURN(0);
991}
992
9a7034eb 993XS(XS_Internals_hash_seed)
c910b28a 994{
97aff369 995 dVAR;
c85d3f85
NC
996 /* Using dXSARGS would also have dITEM and dSP,
997 * which define 2 unused local variables. */
557b887a 998 dAXMARK;
53c1dcc0 999 PERL_UNUSED_ARG(cv);
ad73156c 1000 PERL_UNUSED_VAR(mark);
81eaca17 1001 XSRETURN_UV(PERL_HASH_SEED);
c910b28a
JH
1002}
1003
008fb0c0 1004XS(XS_Internals_rehash_seed)
8e90d776 1005{
97aff369 1006 dVAR;
8e90d776
NC
1007 /* Using dXSARGS would also have dITEM and dSP,
1008 * which define 2 unused local variables. */
557b887a 1009 dAXMARK;
53c1dcc0 1010 PERL_UNUSED_ARG(cv);
ad73156c 1011 PERL_UNUSED_VAR(mark);
008fb0c0 1012 XSRETURN_UV(PL_rehash_seed);
8e90d776
NC
1013}
1014
05619474
NC
1015XS(XS_Internals_HvREHASH) /* Subject to change */
1016{
97aff369 1017 dVAR;
05619474 1018 dXSARGS;
93c51217 1019 PERL_UNUSED_ARG(cv);
05619474 1020 if (SvROK(ST(0))) {
ef8f7699 1021 const HV * const hv = (const HV *) SvRV(ST(0));
05619474
NC
1022 if (items == 1 && SvTYPE(hv) == SVt_PVHV) {
1023 if (HvREHASH(hv))
1024 XSRETURN_YES;
1025 else
1026 XSRETURN_NO;
1027 }
1028 }
1029 Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
1030}
241d1a3b 1031
792477b9
YO
1032XS(XS_mauve_reftype)
1033{
1034 SV *sv;
1035 dVAR;
1036 dXSARGS;
1037 PERL_UNUSED_VAR(cv);
1038
1039 if (items != 1)
1040 croak_xs_usage(cv, "sv");
1041
1042 SP -= items;
1043 sv = (SV*)ST(0);
1044
1045 if (SvMAGICAL(sv))
1046 mg_get(sv);
1047 if (!SvROK(sv)) {
1048 XSRETURN_NO;
1049 } else {
1050 STRLEN len;
1051 char *type= (char *)sv_reftype_len(SvRV(sv),FALSE,&len);
1052 XPUSHs(sv_2mortal(newSVpv(type,len)));
1053 }
1054}
1055
1056XS(XS_mauve_refaddr)
1057{
1058 SV *sv;
1059 dVAR;
1060 dXSARGS;
1061 PERL_UNUSED_VAR(cv);
1062
1063 if (items != 1)
1064 croak_xs_usage(cv, "sv");
1065
1066 SP -= items;
1067 sv = (SV*)ST(0);
1068
1069 if (SvMAGICAL(sv))
1070 mg_get(sv);
1071 if (!SvROK(sv)) {
1072 XSRETURN_NO;
1073 } else {
1074 XPUSHs(sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))));
1075 }
1076}
1077
1078XS(XS_mauve_blessed)
1079{
1080 SV *sv;
1081 dVAR;
1082 dXSARGS;
1083 PERL_UNUSED_VAR(cv);
1084
1085 if (items != 1)
1086 croak_xs_usage(cv, "sv");
1087
1088 SP -= items;
1089 sv = (SV*)ST(0);
1090
1091 if (SvMAGICAL(sv))
1092 mg_get(sv);
1093 if ( SvROK(sv) && SvOBJECT(SvRV(sv)) ) {
1094 STRLEN len;
1095 char *type= (char *)sv_reftype_len(SvRV(sv),TRUE,&len);
1096 XPUSHs(sv_2mortal(newSVpv(type,len)));
1097 } else {
1098 XPUSHs(sv_2mortal(newSVpv("",0)));
1099 }
1100}
1101
1102XS(XS_mauve_weaken)
1103{
1104 SV *sv;
1105 dVAR;
1106 dXSARGS;
1107 PERL_UNUSED_VAR(cv);
1108
1109 if (items != 1)
1110 croak_xs_usage(cv, "sv");
1111
1112 SP -= items;
1113 sv = (SV*)ST(0);
1114
1115 if (SvMAGICAL(sv))
1116 mg_get(sv);
1117 sv_rvweaken(sv);
1118 XSRETURN_EMPTY;
1119}
1120
1121XS(XS_mauve_isweak)
1122{
1123 dVAR;
1124 dXSARGS;
1125 if (items != 1)
1126 croak_xs_usage(cv, "sv");
1127 {
1128 SV * sv = ST(0);
1129 if (SvMAGICAL(sv))
1130 mg_get(sv);
1131 ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
1132 XSRETURN(1);
1133 }
1134 XSRETURN(1);
1135}
1136
80305961
YO
1137XS(XS_re_is_regexp)
1138{
1139 dVAR;
1140 dXSARGS;
f7e71195
AB
1141 PERL_UNUSED_VAR(cv);
1142
80305961 1143 if (items != 1)
afa74d42 1144 croak_xs_usage(cv, "sv");
f7e71195 1145
80305961 1146 SP -= items;
f7e71195
AB
1147
1148 if (SvRXOK(ST(0))) {
1149 XSRETURN_YES;
1150 } else {
1151 XSRETURN_NO;
80305961
YO
1152 }
1153}
1154
192b9cd1 1155XS(XS_re_regnames_count)
80305961 1156{
192b9cd1
AB
1157 REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1158 SV * ret;
80305961
YO
1159 dVAR;
1160 dXSARGS;
192b9cd1
AB
1161
1162 if (items != 0)
afa74d42 1163 croak_xs_usage(cv, "");
192b9cd1
AB
1164
1165 SP -= items;
1166
1167 if (!rx)
1168 XSRETURN_UNDEF;
1169
1170 ret = CALLREG_NAMED_BUFF_COUNT(rx);
1171
1172 SPAGAIN;
1173
1174 if (ret) {
ec83ea38 1175 mXPUSHs(ret);
192b9cd1
AB
1176 PUTBACK;
1177 return;
1178 } else {
1179 XSRETURN_UNDEF;
1180 }
1181}
1182
1183XS(XS_re_regname)
1184{
1185 dVAR;
1186 dXSARGS;
1187 REGEXP * rx;
1188 U32 flags;
1189 SV * ret;
1190
28d8d7f4 1191 if (items < 1 || items > 2)
afa74d42 1192 croak_xs_usage(cv, "name[, all ]");
192b9cd1 1193
80305961 1194 SP -= items;
80305961 1195
192b9cd1
AB
1196 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1197
1198 if (!rx)
1199 XSRETURN_UNDEF;
1200
1201 if (items == 2 && SvTRUE(ST(1))) {
f1b875a0 1202 flags = RXapif_ALL;
192b9cd1 1203 } else {
f1b875a0 1204 flags = RXapif_ONE;
80305961 1205 }
f1b875a0 1206 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
192b9cd1
AB
1207
1208 if (ret) {
ec83ea38 1209 mXPUSHs(ret);
192b9cd1
AB
1210 XSRETURN(1);
1211 }
1212 XSRETURN_UNDEF;
80305961
YO
1213}
1214
192b9cd1 1215
80305961
YO
1216XS(XS_re_regnames)
1217{
192b9cd1 1218 dVAR;
80305961 1219 dXSARGS;
192b9cd1
AB
1220 REGEXP * rx;
1221 U32 flags;
1222 SV *ret;
1223 AV *av;
1224 I32 length;
1225 I32 i;
1226 SV **entry;
1227
1228 if (items > 1)
afa74d42 1229 croak_xs_usage(cv, "[all]");
192b9cd1
AB
1230
1231 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1232
1233 if (!rx)
1234 XSRETURN_UNDEF;
1235
1236 if (items == 1 && SvTRUE(ST(0))) {
f1b875a0 1237 flags = RXapif_ALL;
192b9cd1 1238 } else {
f1b875a0 1239 flags = RXapif_ONE;
192b9cd1
AB
1240 }
1241
80305961 1242 SP -= items;
80305961 1243
f1b875a0 1244 ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
192b9cd1
AB
1245
1246 SPAGAIN;
1247
1248 SP -= items;
1249
1250 if (!ret)
1251 XSRETURN_UNDEF;
1252
502c6561 1253 av = MUTABLE_AV(SvRV(ret));
192b9cd1
AB
1254 length = av_len(av);
1255
1256 for (i = 0; i <= length; i++) {
1257 entry = av_fetch(av, i, FALSE);
1258
1259 if (!entry)
1260 Perl_croak(aTHX_ "NULL array element in re::regnames()");
1261
ec83ea38 1262 mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
80305961 1263 }
ec83ea38
MHM
1264
1265 SvREFCNT_dec(ret);
1266
192b9cd1
AB
1267 PUTBACK;
1268 return;
80305961
YO
1269}
1270
192c1e27
JH
1271XS(XS_re_regexp_pattern)
1272{
1273 dVAR;
1274 dXSARGS;
1275 REGEXP *re;
192c1e27
JH
1276
1277 if (items != 1)
afa74d42 1278 croak_xs_usage(cv, "sv");
192c1e27
JH
1279
1280 SP -= items;
1281
1282 /*
1283 Checks if a reference is a regex or not. If the parameter is
1284 not a ref, or is not the result of a qr// then returns false
1285 in scalar context and an empty list in list context.
1286 Otherwise in list context it returns the pattern and the
1287 modifiers, in scalar context it returns the pattern just as it
1288 would if the qr// was stringified normally, regardless as
1289 to the class of the variable and any strigification overloads
1290 on the object.
1291 */
1292
1293 if ((re = SvRX(ST(0)))) /* assign deliberate */
1294 {
22c985d5 1295 /* Houston, we have a regex! */
192c1e27
JH
1296 SV *pattern;
1297 STRLEN left = 0;
525aa621 1298 char reflags[sizeof(INT_PAT_MODS)];
192c1e27
JH
1299
1300 if ( GIMME_V == G_ARRAY ) {
1301 /*
1302 we are in list context so stringify
1303 the modifiers that apply. We ignore "negative
1304 modifiers" in this scenario.
1305 */
1306
1307 const char *fptr = INT_PAT_MODS;
1308 char ch;
1309 U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
1310 >> RXf_PMf_STD_PMMOD_SHIFT);
1311
1312 while((ch = *fptr++)) {
1313 if(match_flags & 1) {
1314 reflags[left++] = ch;
1315 }
1316 match_flags >>= 1;
1317 }
1318
fb632ce3
NC
1319 pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
1320 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1321
1322 /* return the pattern and the modifiers */
1323 XPUSHs(pattern);
fb632ce3 1324 XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
192c1e27
JH
1325 XSRETURN(2);
1326 } else {
1327 /* Scalar, so use the string that Perl would return */
1328 /* return the pattern in (?msix:..) format */
1329#if PERL_VERSION >= 11
daba3364 1330 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re)));
192c1e27 1331#else
fb632ce3
NC
1332 pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
1333 (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
192c1e27
JH
1334#endif
1335 XPUSHs(pattern);
1336 XSRETURN(1);
1337 }
1338 } else {
1339 /* It ain't a regexp folks */
1340 if ( GIMME_V == G_ARRAY ) {
1341 /* return the empty list */
1342 XSRETURN_UNDEF;
1343 } else {
1344 /* Because of the (?:..) wrapping involved in a
1345 stringified pattern it is impossible to get a
1346 result for a real regexp that would evaluate to
1347 false. Therefore we can return PL_sv_no to signify
1348 that the object is not a regex, this means that one
1349 can say
1350
1351 if (regex($might_be_a_regex) eq '(?:foo)') { }
1352
1353 and not worry about undefined values.
1354 */
1355 XSRETURN_NO;
1356 }
1357 }
1358 /* NOT-REACHED */
1359}
1360
192b9cd1 1361XS(XS_Tie_Hash_NamedCapture_FETCH)
80305961 1362{
192b9cd1 1363 dVAR;
80305961 1364 dXSARGS;
192b9cd1
AB
1365 REGEXP * rx;
1366 U32 flags;
1367 SV * ret;
1368
1369 if (items != 2)
afa74d42 1370 croak_xs_usage(cv, "$key, $flags");
192b9cd1
AB
1371
1372 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1373
1d021cc8 1374 if (!rx || !SvROK(ST(0)))
192b9cd1
AB
1375 XSRETURN_UNDEF;
1376
80305961 1377 SP -= items;
192b9cd1 1378
bd7e438e 1379 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
192b9cd1
AB
1380 ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
1381
1382 SPAGAIN;
1383
1384 if (ret) {
ec83ea38 1385 mXPUSHs(ret);
192b9cd1
AB
1386 PUTBACK;
1387 return;
1388 }
1389 XSRETURN_UNDEF;
1390}
1391
1392XS(XS_Tie_Hash_NamedCapture_STORE)
1393{
1394 dVAR;
1395 dXSARGS;
1396 REGEXP * rx;
1397 U32 flags;
1398
1399 if (items != 3)
afa74d42 1400 croak_xs_usage(cv, "$key, $value, $flags");
192b9cd1
AB
1401
1402 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1403
1d021cc8 1404 if (!rx || !SvROK(ST(0))) {
192b9cd1 1405 if (!PL_localizing)
6ad8f254 1406 Perl_croak_no_modify(aTHX);
192b9cd1 1407 else
28d8d7f4 1408 XSRETURN_UNDEF;
80305961 1409 }
192b9cd1
AB
1410
1411 SP -= items;
1412
bd7e438e 1413 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
192b9cd1 1414 CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
80305961
YO
1415}
1416
192b9cd1
AB
1417XS(XS_Tie_Hash_NamedCapture_DELETE)
1418{
1419 dVAR;
1420 dXSARGS;
1421 REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1422 U32 flags;
80305961 1423
192b9cd1 1424 if (items != 2)
afa74d42 1425 croak_xs_usage(cv, "$key, $flags");
192b9cd1 1426
1d021cc8 1427 if (!rx || !SvROK(ST(0)))
6ad8f254 1428 Perl_croak_no_modify(aTHX);
192b9cd1
AB
1429
1430 SP -= items;
1431
bd7e438e 1432 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
192b9cd1
AB
1433 CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
1434}
1435
1436XS(XS_Tie_Hash_NamedCapture_CLEAR)
80305961 1437{
192b9cd1 1438 dVAR;
80305961 1439 dXSARGS;
192b9cd1
AB
1440 REGEXP * rx;
1441 U32 flags;
1442
1443 if (items != 1)
afa74d42 1444 croak_xs_usage(cv, "$flags");
192b9cd1
AB
1445
1446 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1447
1d021cc8 1448 if (!rx || !SvROK(ST(0)))
6ad8f254 1449 Perl_croak_no_modify(aTHX);
192b9cd1 1450
80305961 1451 SP -= items;
80305961 1452
bd7e438e 1453 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
192b9cd1
AB
1454 CALLREG_NAMED_BUFF_CLEAR(rx, flags);
1455}
1456
1457XS(XS_Tie_Hash_NamedCapture_EXISTS)
1458{
1459 dVAR;
1460 dXSARGS;
1461 REGEXP * rx;
1462 U32 flags;
1463 SV * ret;
1464
1465 if (items != 2)
afa74d42 1466 croak_xs_usage(cv, "$key, $flags");
192b9cd1
AB
1467
1468 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1469
1d021cc8 1470 if (!rx || !SvROK(ST(0)))
28d8d7f4 1471 XSRETURN_UNDEF;
192b9cd1
AB
1472
1473 SP -= items;
1474
bd7e438e 1475 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
192b9cd1
AB
1476 ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
1477
1478 SPAGAIN;
1479
1480 XPUSHs(ret);
80305961
YO
1481 PUTBACK;
1482 return;
80305961
YO
1483}
1484
86aa3d53 1485XS(XS_Tie_Hash_NamedCapture_FIRSTK)
192b9cd1
AB
1486{
1487 dVAR;
1488 dXSARGS;
1489 REGEXP * rx;
1490 U32 flags;
1491 SV * ret;
80305961 1492
192b9cd1 1493 if (items != 1)
afa74d42 1494 croak_xs_usage(cv, "");
192b9cd1
AB
1495
1496 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1497
1d021cc8 1498 if (!rx || !SvROK(ST(0)))
192b9cd1
AB
1499 XSRETURN_UNDEF;
1500
1501 SP -= items;
1502
bd7e438e 1503 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
192b9cd1
AB
1504 ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
1505
1506 SPAGAIN;
1507
1508 if (ret) {
ec83ea38 1509 mXPUSHs(ret);
192b9cd1
AB
1510 PUTBACK;
1511 } else {
1512 XSRETURN_UNDEF;
1513 }
1514
1515}
1516
86aa3d53 1517XS(XS_Tie_Hash_NamedCapture_NEXTK)
80305961 1518{
192b9cd1 1519 dVAR;
80305961 1520 dXSARGS;
192b9cd1
AB
1521 REGEXP * rx;
1522 U32 flags;
1523 SV * ret;
1524
1525 if (items != 2)
afa74d42 1526 croak_xs_usage(cv, "$lastkey");
192b9cd1
AB
1527
1528 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1529
1d021cc8 1530 if (!rx || !SvROK(ST(0)))
192b9cd1 1531 XSRETURN_UNDEF;
80305961 1532
80305961 1533 SP -= items;
192b9cd1 1534
bd7e438e 1535 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
192b9cd1
AB
1536 ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
1537
1538 SPAGAIN;
1539
1540 if (ret) {
ec83ea38 1541 mXPUSHs(ret);
80305961
YO
1542 } else {
1543 XSRETURN_UNDEF;
1544 }
1545 PUTBACK;
192b9cd1
AB
1546}
1547
1548XS(XS_Tie_Hash_NamedCapture_SCALAR)
1549{
1550 dVAR;
1551 dXSARGS;
1552 REGEXP * rx;
1553 U32 flags;
1554 SV * ret;
1555
1556 if (items != 1)
afa74d42 1557 croak_xs_usage(cv, "");
192b9cd1
AB
1558
1559 rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
1560
1d021cc8 1561 if (!rx || !SvROK(ST(0)))
192b9cd1
AB
1562 XSRETURN_UNDEF;
1563
1564 SP -= items;
1565
bd7e438e 1566 flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
192b9cd1
AB
1567 ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
1568
1569 SPAGAIN;
1570
1571 if (ret) {
ec83ea38 1572 mXPUSHs(ret);
192b9cd1
AB
1573 PUTBACK;
1574 return;
1575 } else {
1576 XSRETURN_UNDEF;
1577 }
1578}
1579
1580XS(XS_Tie_Hash_NamedCapture_flags)
1581{
1582 dVAR;
1583 dXSARGS;
1584
1585 if (items != 0)
afa74d42 1586 croak_xs_usage(cv, "");
192b9cd1 1587
6e449a3a
MHM
1588 mXPUSHu(RXapif_ONE);
1589 mXPUSHu(RXapif_ALL);
192b9cd1
AB
1590 PUTBACK;
1591 return;
80305961
YO
1592}
1593
eff5b9d5
NC
1594struct xsub_details {
1595 const char *name;
1596 XSUBADDR_t xsub;
1597 const char *proto;
1598};
1599
1600struct xsub_details details[] = {
1601 {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
1602 {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
1603 {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
1604 {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
1605 {"version::()", XS_version_noop, NULL},
1606 {"version::new", XS_version_new, NULL},
1607 {"version::parse", XS_version_new, NULL},
1608 {"version::(\"\"", XS_version_stringify, NULL},
1609 {"version::stringify", XS_version_stringify, NULL},
1610 {"version::(0+", XS_version_numify, NULL},
1611 {"version::numify", XS_version_numify, NULL},
1612 {"version::normal", XS_version_normal, NULL},
1613 {"version::(cmp", XS_version_vcmp, NULL},
1614 {"version::(<=>", XS_version_vcmp, NULL},
1615 {"version::vcmp", XS_version_vcmp, NULL},
1616 {"version::(bool", XS_version_boolean, NULL},
1617 {"version::boolean", XS_version_boolean, NULL},
1618 {"version::(nomethod", XS_version_noop, NULL},
1619 {"version::noop", XS_version_noop, NULL},
1620 {"version::is_alpha", XS_version_is_alpha, NULL},
1621 {"version::qv", XS_version_qv, NULL},
1622 {"version::declare", XS_version_qv, NULL},
1623 {"version::is_qv", XS_version_is_qv, NULL},
1624 {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
1625 {"utf8::valid", XS_utf8_valid, NULL},
1626 {"utf8::encode", XS_utf8_encode, NULL},
1627 {"utf8::decode", XS_utf8_decode, NULL},
1628 {"utf8::upgrade", XS_utf8_upgrade, NULL},
1629 {"utf8::downgrade", XS_utf8_downgrade, NULL},
1630 {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
1631 {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
1632 {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
1633 {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
1634 {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
1635 {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
1636 {"Internals::hash_seed", XS_Internals_hash_seed, ""},
1637 {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
1638 {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
1639 {"re::is_regexp", XS_re_is_regexp, "$"},
1640 {"re::regname", XS_re_regname, ";$$"},
1641 {"re::regnames", XS_re_regnames, ";$"},
1642 {"re::regnames_count", XS_re_regnames_count, ""},
1643 {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
1644 {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
1645 {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
1646 {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
1647 {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
1648 {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
1649 {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
1650 {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
1651 {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
1652 {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
792477b9
YO
1653 ,{"mauve::reftype", XS_mauve_reftype, "$"}
1654 ,{"mauve::refaddr", XS_mauve_refaddr, "$"}
1655 ,{"mauve::blessed", XS_mauve_blessed, "$"}
1656 ,{"mauve::weaken", XS_mauve_weaken, "$"}
1657 ,{"mauve::isweak", XS_mauve_isweak, "$"}
eff5b9d5
NC
1658};
1659
1660void
1661Perl_boot_core_UNIVERSAL(pTHX)
1662{
1663 dVAR;
1664 static const char file[] = __FILE__;
1665 struct xsub_details *xsub = details;
1666 const struct xsub_details *end
1667 = details + sizeof(details) / sizeof(details[0]);
1668
1669 do {
1670 newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
1671 } while (++xsub < end);
1672
1673 /* register the overloading (type 'A') magic */
1674 PL_amagic_generation++;
1675
1676 /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */
1677 CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
1678 = (char *)file;
1679}
80305961 1680
241d1a3b
NC
1681/*
1682 * Local variables:
1683 * c-indentation-style: bsd
1684 * c-basic-offset: 4
1685 * indent-tabs-mode: t
1686 * End:
1687 *
37442d52
RGS
1688 * ex: set ts=8 sts=4 sw=4 noet:
1689 */