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