This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
For shorter strings, store C<study>'s data as U8s or U16s, instead of U32s.
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
1129b882
NC
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805 5 *
a0d0e21e
LW
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.
79072805 8 *
a0d0e21e
LW
9 */
10
11/*
4ac71550
TC
12 * 'It's a big house this, and very peculiar. Always a bit more
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
15 *
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
a0d0e21e 17 */
79072805 18
166f8a29
DM
19/* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
24 */
25
79072805 26#include "EXTERN.h"
864dbfa3 27#define PERL_IN_PP_C
79072805 28#include "perl.h"
77bc9082 29#include "keywords.h"
79072805 30
a4af207c
JH
31#include "reentr.h"
32
dfe9444c
AD
33/* XXX I can't imagine anyone who doesn't have this actually _needs_
34 it, since pid_t is an integral type.
35 --AD 2/20/1998
36*/
37#ifdef NEED_GETPID_PROTO
38extern Pid_t getpid (void);
8ac85365
NIS
39#endif
40
0630166f
SP
41/*
42 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
43 * This switches them over to IEEE.
44 */
45#if defined(LIBM_LIB_VERSION)
46 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
47#endif
48
13017935
SM
49/* variations on pp_null */
50
93a17b20
LW
51PP(pp_stub)
52{
97aff369 53 dVAR;
39644a26 54 dSP;
54310121 55 if (GIMME_V == G_SCALAR)
3280af22 56 XPUSHs(&PL_sv_undef);
93a17b20
LW
57 RETURN;
58}
59
79072805
LW
60/* Pushy stuff. */
61
93a17b20
LW
62PP(pp_padav)
63{
97aff369 64 dVAR; dSP; dTARGET;
13017935 65 I32 gimme;
e190e9b4 66 assert(SvTYPE(TARG) == SVt_PVAV);
533c011a 67 if (PL_op->op_private & OPpLVAL_INTRO)
a5911867
RGS
68 if (!(PL_op->op_private & OPpPAD_STATE))
69 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
85e6fe83 70 EXTEND(SP, 1);
533c011a 71 if (PL_op->op_flags & OPf_REF) {
85e6fe83 72 PUSHs(TARG);
93a17b20 73 RETURN;
40c94d11
FC
74 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
75 const I32 flags = is_lvalue_sub();
76 if (flags && !(flags & OPpENTERSUB_INARGS)) {
78f9721b
SM
77 if (GIMME == G_SCALAR)
78 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
79 PUSHs(TARG);
80 RETURN;
40c94d11 81 }
85e6fe83 82 }
13017935
SM
83 gimme = GIMME_V;
84 if (gimme == G_ARRAY) {
502c6561 85 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
85e6fe83 86 EXTEND(SP, maxarg);
93965878
NIS
87 if (SvMAGICAL(TARG)) {
88 U32 i;
eb160463 89 for (i=0; i < (U32)maxarg; i++) {
502c6561 90 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
3280af22 91 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878
NIS
92 }
93 }
94 else {
502c6561 95 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
93965878 96 }
85e6fe83
LW
97 SP += maxarg;
98 }
13017935 99 else if (gimme == G_SCALAR) {
1b6737cc 100 SV* const sv = sv_newmortal();
502c6561 101 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
85e6fe83
LW
102 sv_setiv(sv, maxarg);
103 PUSHs(sv);
104 }
105 RETURN;
93a17b20
LW
106}
107
108PP(pp_padhv)
109{
97aff369 110 dVAR; dSP; dTARGET;
54310121
PP
111 I32 gimme;
112
e190e9b4 113 assert(SvTYPE(TARG) == SVt_PVHV);
93a17b20 114 XPUSHs(TARG);
533c011a 115 if (PL_op->op_private & OPpLVAL_INTRO)
a5911867
RGS
116 if (!(PL_op->op_private & OPpPAD_STATE))
117 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
533c011a 118 if (PL_op->op_flags & OPf_REF)
93a17b20 119 RETURN;
40c94d11
FC
120 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
121 const I32 flags = is_lvalue_sub();
122 if (flags && !(flags & OPpENTERSUB_INARGS)) {
78f9721b
SM
123 if (GIMME == G_SCALAR)
124 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
125 RETURN;
40c94d11 126 }
78f9721b 127 }
54310121
PP
128 gimme = GIMME_V;
129 if (gimme == G_ARRAY) {
981b7185 130 RETURNOP(Perl_do_kv(aTHX));
85e6fe83 131 }
54310121 132 else if (gimme == G_SCALAR) {
85fbaab2 133 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
85e6fe83 134 SETs(sv);
85e6fe83 135 }
54310121 136 RETURN;
93a17b20
LW
137}
138
79072805
LW
139/* Translations. */
140
4bdf8368 141static const char S_no_symref_sv[] =
def89bff
NC
142 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
143
79072805
LW
144PP(pp_rv2gv)
145{
97aff369 146 dVAR; dSP; dTOPss;
8ec5e241 147
f64c9ac5 148 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
ed6116ce 149 if (SvROK(sv)) {
a0d0e21e 150 wasref:
93d7320b
DM
151 if (SvAMAGIC(sv)) {
152 sv = amagic_deref_call(sv, to_gv_amg);
153 SPAGAIN;
154 }
ed6116ce 155 sv = SvRV(sv);
b1dadf13 156 if (SvTYPE(sv) == SVt_PVIO) {
159b6efe 157 GV * const gv = MUTABLE_GV(sv_newmortal());
b1dadf13 158 gv_init(gv, 0, "", 0, 0);
a45c7426 159 GvIOp(gv) = MUTABLE_IO(sv);
b37c2d43 160 SvREFCNT_inc_void_NN(sv);
ad64d0ec 161 sv = MUTABLE_SV(gv);
ef54e1a4 162 }
6e592b3a 163 else if (!isGV_with_GP(sv))
cea2e8a9 164 DIE(aTHX_ "Not a GLOB reference");
79072805
LW
165 }
166 else {
6e592b3a 167 if (!isGV_with_GP(sv)) {
afd1915d 168 if (!SvOK(sv) && sv != &PL_sv_undef) {
b13b2135 169 /* If this is a 'my' scalar and flag is set then vivify
853846ea 170 * NI-S 1999/05/07
b13b2135 171 */
ac53db4c 172 if (SvREADONLY(sv))
6ad8f254 173 Perl_croak_no_modify(aTHX);
1d8d4d2a 174 if (PL_op->op_private & OPpDEREF) {
2c8ac474
GS
175 GV *gv;
176 if (cUNOP->op_targ) {
177 STRLEN len;
0bd48802
AL
178 SV * const namesv = PAD_SV(cUNOP->op_targ);
179 const char * const name = SvPV(namesv, len);
159b6efe 180 gv = MUTABLE_GV(newSV(0));
2c8ac474
GS
181 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
182 }
183 else {
0bd48802 184 const char * const name = CopSTASHPV(PL_curcop);
2c8ac474 185 gv = newGVgen(name);
1d8d4d2a 186 }
43230e26 187 prepare_SV_for_RV(sv);
ad64d0ec 188 SvRV_set(sv, MUTABLE_SV(gv));
853846ea 189 SvROK_on(sv);
1d8d4d2a 190 SvSETMAGIC(sv);
853846ea 191 goto wasref;
2c8ac474 192 }
533c011a
NIS
193 if (PL_op->op_flags & OPf_REF ||
194 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 195 DIE(aTHX_ PL_no_usym, "a symbol");
599cee73 196 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 197 report_uninit(sv);
a0d0e21e
LW
198 RETSETUNDEF;
199 }
35cd451c
GS
200 if ((PL_op->op_flags & OPf_SPECIAL) &&
201 !(PL_op->op_flags & OPf_MOD))
202 {
ad64d0ec 203 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
7a5fd60d
NC
204 if (!temp
205 && (!is_gv_magical_sv(sv,0)
ad64d0ec
NC
206 || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
207 SVt_PVGV))))) {
35cd451c 208 RETSETUNDEF;
c9d5ac95 209 }
7a5fd60d 210 sv = temp;
35cd451c
GS
211 }
212 else {
213 if (PL_op->op_private & HINT_STRICT_REFS)
10b53e54 214 DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
e26df76a
NC
215 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
216 == OPpDONT_INIT_GV) {
217 /* We are the target of a coderef assignment. Return
218 the scalar unchanged, and let pp_sasssign deal with
219 things. */
220 RETURN;
221 }
ad64d0ec 222 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
35cd451c 223 }
2acc3314
FC
224 /* FAKE globs in the symbol table cause weird bugs (#77810) */
225 if (sv) SvFAKE_off(sv);
93a17b20 226 }
79072805 227 }
2acc3314
FC
228 if (sv && SvFAKE(sv)) {
229 SV *newsv = sv_newmortal();
5cf4b255 230 sv_setsv_flags(newsv, sv, 0);
2acc3314 231 SvFAKE_off(newsv);
d8906c05 232 sv = newsv;
2acc3314 233 }
d8906c05
FC
234 if (PL_op->op_private & OPpLVAL_INTRO)
235 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
236 SETs(sv);
79072805
LW
237 RETURN;
238}
239
dc3c76f8
NC
240/* Helper function for pp_rv2sv and pp_rv2av */
241GV *
fe9845cc
RB
242Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
243 const svtype type, SV ***spp)
dc3c76f8
NC
244{
245 dVAR;
246 GV *gv;
247
7918f24d
NC
248 PERL_ARGS_ASSERT_SOFTREF2XV;
249
dc3c76f8
NC
250 if (PL_op->op_private & HINT_STRICT_REFS) {
251 if (SvOK(sv))
10b53e54 252 Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
dc3c76f8
NC
253 else
254 Perl_die(aTHX_ PL_no_usym, what);
255 }
256 if (!SvOK(sv)) {
fd1d9b5c
FC
257 if (
258 PL_op->op_flags & OPf_REF &&
259 PL_op->op_next->op_type != OP_BOOLKEYS
260 )
dc3c76f8
NC
261 Perl_die(aTHX_ PL_no_usym, what);
262 if (ckWARN(WARN_UNINITIALIZED))
263 report_uninit(sv);
264 if (type != SVt_PV && GIMME_V == G_ARRAY) {
265 (*spp)--;
266 return NULL;
267 }
268 **spp = &PL_sv_undef;
269 return NULL;
270 }
271 if ((PL_op->op_flags & OPf_SPECIAL) &&
272 !(PL_op->op_flags & OPf_MOD))
273 {
81e3fc25 274 gv = gv_fetchsv(sv, 0, type);
dc3c76f8
NC
275 if (!gv
276 && (!is_gv_magical_sv(sv,0)
81e3fc25 277 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
dc3c76f8
NC
278 {
279 **spp = &PL_sv_undef;
280 return NULL;
281 }
282 }
283 else {
81e3fc25 284 gv = gv_fetchsv(sv, GV_ADD, type);
dc3c76f8
NC
285 }
286 return gv;
287}
288
79072805
LW
289PP(pp_rv2sv)
290{
97aff369 291 dVAR; dSP; dTOPss;
c445ea15 292 GV *gv = NULL;
79072805 293
0824d667
DM
294 if (!(PL_op->op_private & OPpDEREFed))
295 SvGETMAGIC(sv);
ed6116ce 296 if (SvROK(sv)) {
93d7320b
DM
297 if (SvAMAGIC(sv)) {
298 sv = amagic_deref_call(sv, to_sv_amg);
299 SPAGAIN;
300 }
f5284f61 301
ed6116ce 302 sv = SvRV(sv);
79072805
LW
303 switch (SvTYPE(sv)) {
304 case SVt_PVAV:
305 case SVt_PVHV:
306 case SVt_PVCV:
cbae9b9f
YST
307 case SVt_PVFM:
308 case SVt_PVIO:
cea2e8a9 309 DIE(aTHX_ "Not a SCALAR reference");
42d0e0b7 310 default: NOOP;
79072805
LW
311 }
312 }
313 else {
159b6efe 314 gv = MUTABLE_GV(sv);
748a9306 315
6e592b3a 316 if (!isGV_with_GP(gv)) {
dc3c76f8
NC
317 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
318 if (!gv)
319 RETURN;
463ee0b2 320 }
29c711a3 321 sv = GvSVn(gv);
a0d0e21e 322 }
533c011a 323 if (PL_op->op_flags & OPf_MOD) {
82d03984
RGS
324 if (PL_op->op_private & OPpLVAL_INTRO) {
325 if (cUNOP->op_first->op_type == OP_NULL)
159b6efe 326 sv = save_scalar(MUTABLE_GV(TOPs));
82d03984
RGS
327 else if (gv)
328 sv = save_scalar(gv);
329 else
f1f66076 330 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
82d03984 331 }
533c011a
NIS
332 else if (PL_op->op_private & OPpDEREF)
333 vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 334 }
a0d0e21e 335 SETs(sv);
79072805
LW
336 RETURN;
337}
338
339PP(pp_av2arylen)
340{
97aff369 341 dVAR; dSP;
502c6561 342 AV * const av = MUTABLE_AV(TOPs);
02d85cc3
EB
343 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
344 if (lvalue) {
345 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
346 if (!*sv) {
347 *sv = newSV_type(SVt_PVMG);
348 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
349 }
350 SETs(*sv);
351 } else {
352 SETs(sv_2mortal(newSViv(
353 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
354 )));
79072805 355 }
79072805
LW
356 RETURN;
357}
358
a0d0e21e
LW
359PP(pp_pos)
360{
2154eca7 361 dVAR; dSP; dPOPss;
8ec5e241 362
78f9721b 363 if (PL_op->op_flags & OPf_MOD || LVRET) {
16eb5365
FC
364 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
365 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
366 LvTYPE(ret) = '.';
367 LvTARG(ret) = SvREFCNT_inc_simple(sv);
2154eca7 368 PUSHs(ret); /* no SvSETMAGIC */
a0d0e21e
LW
369 RETURN;
370 }
371 else {
a0d0e21e 372 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
1b6737cc 373 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
565764a8 374 if (mg && mg->mg_len >= 0) {
2154eca7 375 dTARGET;
a0ed51b3 376 I32 i = mg->mg_len;
7e2040f0 377 if (DO_UTF8(sv))
a0ed51b3 378 sv_pos_b2u(sv, &i);
fc15ae8f 379 PUSHi(i + CopARYBASE_get(PL_curcop));
a0d0e21e
LW
380 RETURN;
381 }
382 }
383 RETPUSHUNDEF;
384 }
385}
386
79072805
LW
387PP(pp_rv2cv)
388{
97aff369 389 dVAR; dSP;
79072805 390 GV *gv;
1eced8f8 391 HV *stash_unused;
c445ea15
AL
392 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
393 ? 0
394 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
395 ? GV_ADD|GV_NOEXPAND
396 : GV_ADD;
4633a7c4
LW
397 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
398 /* (But not in defined().) */
e26df76a 399
1eced8f8 400 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
07055b4c
CS
401 if (cv) {
402 if (CvCLONE(cv))
ad64d0ec 403 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
d32f2495
SC
404 if ((PL_op->op_private & OPpLVAL_INTRO)) {
405 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
406 cv = GvCV(gv);
407 if (!CvLVALUE(cv))
408 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
409 }
07055b4c 410 }
e26df76a 411 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
ea726b52 412 cv = MUTABLE_CV(gv);
e26df76a 413 }
07055b4c 414 else
ea726b52 415 cv = MUTABLE_CV(&PL_sv_undef);
ad64d0ec 416 SETs(MUTABLE_SV(cv));
79072805
LW
417 RETURN;
418}
419
c07a80fd
PP
420PP(pp_prototype)
421{
97aff369 422 dVAR; dSP;
c07a80fd
PP
423 CV *cv;
424 HV *stash;
425 GV *gv;
fabdb6c0 426 SV *ret = &PL_sv_undef;
c07a80fd 427
b6c543e3 428 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
e3f73d4e 429 const char * s = SvPVX_const(TOPs);
b6c543e3 430 if (strnEQ(s, "CORE::", 6)) {
5458a98a 431 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
b6c543e3
IZ
432 if (code < 0) { /* Overridable. */
433#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
59b085e1 434 int i = 0, n = 0, seen_question = 0, defgv = 0;
b6c543e3
IZ
435 I32 oa;
436 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
437
bdf1bb36 438 if (code == -KEY_chop || code == -KEY_chomp
f23102e2 439 || code == -KEY_exec || code == -KEY_system)
77bc9082 440 goto set;
d116c547 441 if (code == -KEY_mkdir) {
84bafc02 442 ret = newSVpvs_flags("_;$", SVs_TEMP);
d116c547
RGS
443 goto set;
444 }
7c8178a1 445 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
cba5a3b0
DG
446 ret = newSVpvs_flags("+", SVs_TEMP);
447 goto set;
448 }
449 if (code == -KEY_push || code == -KEY_unshift) {
450 ret = newSVpvs_flags("+@", SVs_TEMP);
451 goto set;
452 }
453 if (code == -KEY_pop || code == -KEY_shift) {
454 ret = newSVpvs_flags(";+", SVs_TEMP);
455 goto set;
456 }
457 if (code == -KEY_splice) {
458 ret = newSVpvs_flags("+;$$@", SVs_TEMP);
1db4d195
FC
459 goto set;
460 }
461 if (code == -KEY_tied || code == -KEY_untie) {
462 ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP);
463 goto set;
464 }
465 if (code == -KEY_tie) {
466 ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP);
7c8178a1
RGS
467 goto set;
468 }
e3f73d4e
RGS
469 if (code == -KEY_readpipe) {
470 s = "CORE::backtick";
471 }
b6c543e3 472 while (i < MAXO) { /* The slow way. */
22c35a8c
GS
473 if (strEQ(s + 6, PL_op_name[i])
474 || strEQ(s + 6, PL_op_desc[i]))
475 {
b6c543e3 476 goto found;
22c35a8c 477 }
b6c543e3
IZ
478 i++;
479 }
480 goto nonesuch; /* Should not happen... */
481 found:
59b085e1 482 defgv = PL_opargs[i] & OA_DEFGV;
22c35a8c 483 oa = PL_opargs[i] >> OASHIFT;
b6c543e3 484 while (oa) {
59b085e1 485 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
b6c543e3
IZ
486 seen_question = 1;
487 str[n++] = ';';
ef54e1a4 488 }
b13b2135 489 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
6e97e420
SC
490 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
491 /* But globs are already references (kinda) */
492 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
493 ) {
b6c543e3
IZ
494 str[n++] = '\\';
495 }
b6c543e3
IZ
496 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
497 oa = oa >> 4;
498 }
59b085e1
RGS
499 if (defgv && str[n - 1] == '$')
500 str[n - 1] = '_';
b6c543e3 501 str[n++] = '\0';
59cd0e26 502 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
ef54e1a4
JH
503 }
504 else if (code) /* Non-Overridable */
b6c543e3
IZ
505 goto set;
506 else { /* None such */
507 nonesuch:
d470f89e 508 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
b6c543e3
IZ
509 }
510 }
511 }
f2c0649b 512 cv = sv_2cv(TOPs, &stash, &gv, 0);
5f05dabc 513 if (cv && SvPOK(cv))
59cd0e26 514 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
b6c543e3 515 set:
c07a80fd
PP
516 SETs(ret);
517 RETURN;
518}
519
a0d0e21e
LW
520PP(pp_anoncode)
521{
97aff369 522 dVAR; dSP;
ea726b52 523 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
a5f75d66 524 if (CvCLONE(cv))
ad64d0ec 525 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
5f05dabc 526 EXTEND(SP,1);
ad64d0ec 527 PUSHs(MUTABLE_SV(cv));
a0d0e21e
LW
528 RETURN;
529}
530
531PP(pp_srefgen)
79072805 532{
97aff369 533 dVAR; dSP;
71be2cbc 534 *SP = refto(*SP);
79072805 535 RETURN;
8ec5e241 536}
a0d0e21e
LW
537
538PP(pp_refgen)
539{
97aff369 540 dVAR; dSP; dMARK;
a0d0e21e 541 if (GIMME != G_ARRAY) {
5f0b1d4e
GS
542 if (++MARK <= SP)
543 *MARK = *SP;
544 else
3280af22 545 *MARK = &PL_sv_undef;
5f0b1d4e
GS
546 *MARK = refto(*MARK);
547 SP = MARK;
548 RETURN;
a0d0e21e 549 }
bbce6d69 550 EXTEND_MORTAL(SP - MARK);
71be2cbc
PP
551 while (++MARK <= SP)
552 *MARK = refto(*MARK);
a0d0e21e 553 RETURN;
79072805
LW
554}
555
76e3520e 556STATIC SV*
cea2e8a9 557S_refto(pTHX_ SV *sv)
71be2cbc 558{
97aff369 559 dVAR;
71be2cbc
PP
560 SV* rv;
561
7918f24d
NC
562 PERL_ARGS_ASSERT_REFTO;
563
71be2cbc
PP
564 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
565 if (LvTARGLEN(sv))
68dc0745
PP
566 vivify_defelem(sv);
567 if (!(sv = LvTARG(sv)))
3280af22 568 sv = &PL_sv_undef;
0dd88869 569 else
b37c2d43 570 SvREFCNT_inc_void_NN(sv);
71be2cbc 571 }
d8b46c1b 572 else if (SvTYPE(sv) == SVt_PVAV) {
502c6561
NC
573 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
574 av_reify(MUTABLE_AV(sv));
d8b46c1b 575 SvTEMP_off(sv);
b37c2d43 576 SvREFCNT_inc_void_NN(sv);
d8b46c1b 577 }
f2933f5f
DM
578 else if (SvPADTMP(sv) && !IS_PADGV(sv))
579 sv = newSVsv(sv);
71be2cbc
PP
580 else {
581 SvTEMP_off(sv);
b37c2d43 582 SvREFCNT_inc_void_NN(sv);
71be2cbc
PP
583 }
584 rv = sv_newmortal();
4df7f6af 585 sv_upgrade(rv, SVt_IV);
b162af07 586 SvRV_set(rv, sv);
71be2cbc
PP
587 SvROK_on(rv);
588 return rv;
589}
590
79072805
LW
591PP(pp_ref)
592{
97aff369 593 dVAR; dSP; dTARGET;
e1ec3a88 594 const char *pv;
1b6737cc 595 SV * const sv = POPs;
f12c7020 596
5b295bef
RD
597 if (sv)
598 SvGETMAGIC(sv);
f12c7020 599
a0d0e21e 600 if (!sv || !SvROK(sv))
4633a7c4 601 RETPUSHNO;
79072805 602
cba0b539
FR
603 pv = sv_reftype(SvRV(sv),TRUE);
604 PUSHp(pv, strlen(pv));
79072805
LW
605 RETURN;
606}
607
608PP(pp_bless)
609{
97aff369 610 dVAR; dSP;
463ee0b2 611 HV *stash;
79072805 612
463ee0b2 613 if (MAXARG == 1)
11faa288 614 stash = CopSTASH(PL_curcop);
7b8d334a 615 else {
1b6737cc 616 SV * const ssv = POPs;
7b8d334a 617 STRLEN len;
e1ec3a88 618 const char *ptr;
81689caa 619
016a42f3 620 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
81689caa 621 Perl_croak(aTHX_ "Attempt to bless into a reference");
5c144d81 622 ptr = SvPV_const(ssv,len);
a2a5de95
NC
623 if (len == 0)
624 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
625 "Explicit blessing to '' (assuming package main)");
da51bb9b 626 stash = gv_stashpvn(ptr, len, GV_ADD);
7b8d334a 627 }
a0d0e21e 628
5d3fdfeb 629 (void)sv_bless(TOPs, stash);
79072805
LW
630 RETURN;
631}
632
fb73857a
PP
633PP(pp_gelem)
634{
97aff369 635 dVAR; dSP;
b13b2135 636
1b6737cc
AL
637 SV *sv = POPs;
638 const char * const elem = SvPV_nolen_const(sv);
159b6efe 639 GV * const gv = MUTABLE_GV(POPs);
c445ea15 640 SV * tmpRef = NULL;
1b6737cc 641
c445ea15 642 sv = NULL;
c4ba80c3
NC
643 if (elem) {
644 /* elem will always be NUL terminated. */
1b6737cc 645 const char * const second_letter = elem + 1;
c4ba80c3
NC
646 switch (*elem) {
647 case 'A':
1b6737cc 648 if (strEQ(second_letter, "RRAY"))
ad64d0ec 649 tmpRef = MUTABLE_SV(GvAV(gv));
c4ba80c3
NC
650 break;
651 case 'C':
1b6737cc 652 if (strEQ(second_letter, "ODE"))
ad64d0ec 653 tmpRef = MUTABLE_SV(GvCVu(gv));
c4ba80c3
NC
654 break;
655 case 'F':
1b6737cc 656 if (strEQ(second_letter, "ILEHANDLE")) {
c4ba80c3
NC
657 /* finally deprecated in 5.8.0 */
658 deprecate("*glob{FILEHANDLE}");
ad64d0ec 659 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC
660 }
661 else
1b6737cc 662 if (strEQ(second_letter, "ORMAT"))
ad64d0ec 663 tmpRef = MUTABLE_SV(GvFORM(gv));
c4ba80c3
NC
664 break;
665 case 'G':
1b6737cc 666 if (strEQ(second_letter, "LOB"))
ad64d0ec 667 tmpRef = MUTABLE_SV(gv);
c4ba80c3
NC
668 break;
669 case 'H':
1b6737cc 670 if (strEQ(second_letter, "ASH"))
ad64d0ec 671 tmpRef = MUTABLE_SV(GvHV(gv));
c4ba80c3
NC
672 break;
673 case 'I':
1b6737cc 674 if (*second_letter == 'O' && !elem[2])
ad64d0ec 675 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC
676 break;
677 case 'N':
1b6737cc 678 if (strEQ(second_letter, "AME"))
a663657d 679 sv = newSVhek(GvNAME_HEK(gv));
c4ba80c3
NC
680 break;
681 case 'P':
1b6737cc 682 if (strEQ(second_letter, "ACKAGE")) {
7fa3a4ab
NC
683 const HV * const stash = GvSTASH(gv);
684 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
396482e1 685 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
c4ba80c3
NC
686 }
687 break;
688 case 'S':
1b6737cc 689 if (strEQ(second_letter, "CALAR"))
f9d52e31 690 tmpRef = GvSVn(gv);
c4ba80c3 691 break;
39b99f21 692 }
fb73857a 693 }
76e3520e
GS
694 if (tmpRef)
695 sv = newRV(tmpRef);
fb73857a
PP
696 if (sv)
697 sv_2mortal(sv);
698 else
3280af22 699 sv = &PL_sv_undef;
fb73857a
PP
700 XPUSHs(sv);
701 RETURN;
702}
703
a0d0e21e 704/* Pattern matching */
79072805 705
a0d0e21e 706PP(pp_study)
79072805 707{
97aff369 708 dVAR; dSP; dPOPss;
a0d0e21e 709 register unsigned char *s;
72de20cd 710 char *sfirst_raw;
a0d0e21e 711 STRLEN len;
4185c919 712 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_study) : NULL;
72de20cd
NC
713 U8 quanta;
714 STRLEN size;
4185c919
NC
715
716 if (mg && SvSCREAM(sv))
717 RETPUSHYES;
a0d0e21e 718
a4f4e906 719 s = (unsigned char*)(SvPV(sv, len));
bc9a5256 720 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
a4f4e906
NC
721 /* No point in studying a zero length string, and not safe to study
722 anything that doesn't appear to be a simple scalar (and hence might
723 change between now and when the regexp engine runs without our set
bd473224 724 magic ever running) such as a reference to an object with overloaded
bc9a5256
NC
725 stringification. Also refuse to study an FBM scalar, as this gives
726 more flexibility in SV flag usage. No real-world code would ever
727 end up studying an FBM scalar, so this isn't a real pessimisation.
72de20cd
NC
728 Endemic use of I32 in Perl_screaminstr makes it hard to safely push
729 the study length limit from I32_MAX to U32_MAX - 1.
bc9a5256 730 */
a4f4e906
NC
731 RETPUSHNO;
732 }
733
72de20cd
NC
734 if (len < 0xFF) {
735 quanta = 1;
736 } else if (len < 0xFFFF) {
737 quanta = 2;
738 } else
739 quanta = 4;
a0d0e21e 740
72de20cd
NC
741 size = (256 + len) * quanta;
742 sfirst_raw = (char *)safemalloc(size);
743
744 if (!sfirst_raw)
cea2e8a9 745 DIE(aTHX_ "do_study: out of memory");
a0d0e21e 746
4185c919
NC
747 SvSCREAM_on(sv);
748 if (!mg)
749 mg = sv_magicext(sv, NULL, PERL_MAGIC_study, &PL_vtbl_regexp, NULL, 0);
72de20cd
NC
750 mg->mg_ptr = sfirst_raw;
751 mg->mg_len = size;
752 mg->mg_private = quanta;
753
754 memset(sfirst_raw, ~0, 256 * quanta);
755
756 /* The assumption here is that most studied strings are fairly short, hence
757 the pain of the extra code is worth it, given the memory savings.
758 80 character string, 336 bytes as U8, down from 1344 as U32
759 800 character string, 2112 bytes as U16, down from 4224 as U32
760 */
761
762 if (quanta == 1) {
763 U8 *const sfirst = (U8 *)sfirst_raw;
764 U8 *const snext = sfirst + 256;
765 while (len-- > 0) {
766 const U8 ch = s[len];
767 snext[len] = sfirst[ch];
768 sfirst[ch] = len;
769 }
770 } else if (quanta == 2) {
771 U16 *const sfirst = (U16 *)sfirst_raw;
772 U16 *const snext = sfirst + 256;
773 while (len-- > 0) {
774 const U8 ch = s[len];
775 snext[len] = sfirst[ch];
776 sfirst[ch] = len;
777 }
778 } else {
779 U32 *const sfirst = (U32 *)sfirst_raw;
780 U32 *const snext = sfirst + 256;
781 while (len-- > 0) {
782 const U8 ch = s[len];
783 snext[len] = sfirst[ch];
784 sfirst[ch] = len;
785 }
79072805
LW
786 }
787
1e422769 788 RETPUSHYES;
79072805
LW
789}
790
a0d0e21e 791PP(pp_trans)
79072805 792{
97aff369 793 dVAR; dSP; dTARG;
a0d0e21e
LW
794 SV *sv;
795
533c011a 796 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 797 sv = POPs;
59f00321
RGS
798 else if (PL_op->op_private & OPpTARGET_MY)
799 sv = GETTARGET;
79072805 800 else {
54b9620d 801 sv = DEFSV;
a0d0e21e 802 EXTEND(SP,1);
79072805 803 }
adbc6bb1 804 TARG = sv_newmortal();
bb16bae8
FC
805 if(PL_op->op_type == OP_TRANSR) {
806 SV * const newsv = newSVsv(sv);
807 do_trans(newsv);
808 mPUSHs(newsv);
809 }
810 else PUSHi(do_trans(sv));
a0d0e21e 811 RETURN;
79072805
LW
812}
813
a0d0e21e 814/* Lvalue operators. */
79072805 815
81745e4e
NC
816static void
817S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
818{
819 dVAR;
820 STRLEN len;
821 char *s;
822
823 PERL_ARGS_ASSERT_DO_CHOMP;
824
825 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
826 return;
827 if (SvTYPE(sv) == SVt_PVAV) {
828 I32 i;
829 AV *const av = MUTABLE_AV(sv);
830 const I32 max = AvFILL(av);
831
832 for (i = 0; i <= max; i++) {
833 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
834 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
835 do_chomp(retval, sv, chomping);
836 }
837 return;
838 }
839 else if (SvTYPE(sv) == SVt_PVHV) {
840 HV* const hv = MUTABLE_HV(sv);
841 HE* entry;
842 (void)hv_iterinit(hv);
843 while ((entry = hv_iternext(hv)))
844 do_chomp(retval, hv_iterval(hv,entry), chomping);
845 return;
846 }
847 else if (SvREADONLY(sv)) {
848 if (SvFAKE(sv)) {
849 /* SV is copy-on-write */
850 sv_force_normal_flags(sv, 0);
851 }
852 if (SvREADONLY(sv))
853 Perl_croak_no_modify(aTHX);
854 }
855
856 if (PL_encoding) {
857 if (!SvUTF8(sv)) {
858 /* XXX, here sv is utf8-ized as a side-effect!
859 If encoding.pm is used properly, almost string-generating
860 operations, including literal strings, chr(), input data, etc.
861 should have been utf8-ized already, right?
862 */
863 sv_recode_to_utf8(sv, PL_encoding);
864 }
865 }
866
867 s = SvPV(sv, len);
868 if (chomping) {
869 char *temp_buffer = NULL;
870 SV *svrecode = NULL;
871
872 if (s && len) {
873 s += --len;
874 if (RsPARA(PL_rs)) {
875 if (*s != '\n')
876 goto nope;
877 ++SvIVX(retval);
878 while (len && s[-1] == '\n') {
879 --len;
880 --s;
881 ++SvIVX(retval);
882 }
883 }
884 else {
885 STRLEN rslen, rs_charlen;
886 const char *rsptr = SvPV_const(PL_rs, rslen);
887
888 rs_charlen = SvUTF8(PL_rs)
889 ? sv_len_utf8(PL_rs)
890 : rslen;
891
892 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
893 /* Assumption is that rs is shorter than the scalar. */
894 if (SvUTF8(PL_rs)) {
895 /* RS is utf8, scalar is 8 bit. */
896 bool is_utf8 = TRUE;
897 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
898 &rslen, &is_utf8);
899 if (is_utf8) {
900 /* Cannot downgrade, therefore cannot possibly match
901 */
902 assert (temp_buffer == rsptr);
903 temp_buffer = NULL;
904 goto nope;
905 }
906 rsptr = temp_buffer;
907 }
908 else if (PL_encoding) {
909 /* RS is 8 bit, encoding.pm is used.
910 * Do not recode PL_rs as a side-effect. */
911 svrecode = newSVpvn(rsptr, rslen);
912 sv_recode_to_utf8(svrecode, PL_encoding);
913 rsptr = SvPV_const(svrecode, rslen);
914 rs_charlen = sv_len_utf8(svrecode);
915 }
916 else {
917 /* RS is 8 bit, scalar is utf8. */
918 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
919 rsptr = temp_buffer;
920 }
921 }
922 if (rslen == 1) {
923 if (*s != *rsptr)
924 goto nope;
925 ++SvIVX(retval);
926 }
927 else {
928 if (len < rslen - 1)
929 goto nope;
930 len -= rslen - 1;
931 s -= rslen - 1;
932 if (memNE(s, rsptr, rslen))
933 goto nope;
934 SvIVX(retval) += rs_charlen;
935 }
936 }
937 s = SvPV_force_nolen(sv);
938 SvCUR_set(sv, len);
939 *SvEND(sv) = '\0';
940 SvNIOK_off(sv);
941 SvSETMAGIC(sv);
942 }
943 nope:
944
945 SvREFCNT_dec(svrecode);
946
947 Safefree(temp_buffer);
948 } else {
949 if (len && !SvPOK(sv))
950 s = SvPV_force_nomg(sv, len);
951 if (DO_UTF8(sv)) {
952 if (s && len) {
953 char * const send = s + len;
954 char * const start = s;
955 s = send - 1;
956 while (s > start && UTF8_IS_CONTINUATION(*s))
957 s--;
958 if (is_utf8_string((U8*)s, send - s)) {
959 sv_setpvn(retval, s, send - s);
960 *s = '\0';
961 SvCUR_set(sv, s - start);
962 SvNIOK_off(sv);
963 SvUTF8_on(retval);
964 }
965 }
966 else
967 sv_setpvs(retval, "");
968 }
969 else if (s && len) {
970 s += --len;
971 sv_setpvn(retval, s, 1);
972 *s = '\0';
973 SvCUR_set(sv, len);
974 SvUTF8_off(sv);
975 SvNIOK_off(sv);
976 }
977 else
978 sv_setpvs(retval, "");
979 SvSETMAGIC(sv);
980 }
981}
982
a0d0e21e
LW
983PP(pp_schop)
984{
97aff369 985 dVAR; dSP; dTARGET;
fa54efae
NC
986 const bool chomping = PL_op->op_type == OP_SCHOMP;
987
988 if (chomping)
989 sv_setiv(TARG, 0);
990 do_chomp(TARG, TOPs, chomping);
a0d0e21e
LW
991 SETTARG;
992 RETURN;
79072805
LW
993}
994
a0d0e21e 995PP(pp_chop)
79072805 996{
97aff369 997 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
fa54efae 998 const bool chomping = PL_op->op_type == OP_CHOMP;
8ec5e241 999
fa54efae
NC
1000 if (chomping)
1001 sv_setiv(TARG, 0);
20cf1f79 1002 while (MARK < SP)
fa54efae 1003 do_chomp(TARG, *++MARK, chomping);
20cf1f79
NC
1004 SP = ORIGMARK;
1005 XPUSHTARG;
a0d0e21e 1006 RETURN;
79072805
LW
1007}
1008
a0d0e21e
LW
1009PP(pp_undef)
1010{
97aff369 1011 dVAR; dSP;
a0d0e21e
LW
1012 SV *sv;
1013
533c011a 1014 if (!PL_op->op_private) {
774d564b 1015 EXTEND(SP, 1);
a0d0e21e 1016 RETPUSHUNDEF;
774d564b 1017 }
79072805 1018
a0d0e21e
LW
1019 sv = POPs;
1020 if (!sv)
1021 RETPUSHUNDEF;
85e6fe83 1022
765f542d 1023 SV_CHECK_THINKFIRST_COW_DROP(sv);
85e6fe83 1024
a0d0e21e
LW
1025 switch (SvTYPE(sv)) {
1026 case SVt_NULL:
1027 break;
1028 case SVt_PVAV:
502c6561 1029 av_undef(MUTABLE_AV(sv));
a0d0e21e
LW
1030 break;
1031 case SVt_PVHV:
85fbaab2 1032 hv_undef(MUTABLE_HV(sv));
a0d0e21e
LW
1033 break;
1034 case SVt_PVCV:
a2a5de95
NC
1035 if (cv_const_sv((const CV *)sv))
1036 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
1037 CvANON((const CV *)sv) ? "(anonymous)"
1038 : GvENAME(CvGV((const CV *)sv)));
5f66b61c 1039 /* FALLTHROUGH */
9607fc9c 1040 case SVt_PVFM:
6fc92669
GS
1041 {
1042 /* let user-undef'd sub keep its identity */
ea726b52
NC
1043 GV* const gv = CvGV((const CV *)sv);
1044 cv_undef(MUTABLE_CV(sv));
b3f91e91 1045 CvGV_set(MUTABLE_CV(sv), gv);
6fc92669 1046 }
a0d0e21e 1047 break;
8e07c86e 1048 case SVt_PVGV:
6e592b3a 1049 if (SvFAKE(sv)) {
3280af22 1050 SvSetMagicSV(sv, &PL_sv_undef);
6e592b3a
BM
1051 break;
1052 }
1053 else if (isGV_with_GP(sv)) {
20408e3c 1054 GP *gp;
dd69841b
BB
1055 HV *stash;
1056
dd69841b 1057 /* undef *Pkg::meth_name ... */
e530fb81
FC
1058 bool method_changed
1059 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1060 && HvENAME_get(stash);
1061 /* undef *Foo:: */
1062 if((stash = GvHV((const GV *)sv))) {
1063 if(HvENAME_get(stash))
1064 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1065 else stash = NULL;
1066 }
dd69841b 1067
159b6efe 1068 gp_free(MUTABLE_GV(sv));
a02a5408 1069 Newxz(gp, 1, GP);
c43ae56f 1070 GvGP_set(sv, gp_ref(gp));
561b68a9 1071 GvSV(sv) = newSV(0);
57843af0 1072 GvLINE(sv) = CopLINE(PL_curcop);
159b6efe 1073 GvEGV(sv) = MUTABLE_GV(sv);
20408e3c 1074 GvMULTI_on(sv);
e530fb81
FC
1075
1076 if(stash)
afdbe55d 1077 mro_package_moved(NULL, stash, (const GV *)sv, 0);
e530fb81
FC
1078 stash = NULL;
1079 /* undef *Foo::ISA */
1080 if( strEQ(GvNAME((const GV *)sv), "ISA")
1081 && (stash = GvSTASH((const GV *)sv))
1082 && (method_changed || HvENAME(stash)) )
1083 mro_isa_changed_in(stash);
1084 else if(method_changed)
1085 mro_method_changed_in(
da9043f5 1086 GvSTASH((const GV *)sv)
e530fb81
FC
1087 );
1088
6e592b3a 1089 break;
20408e3c 1090 }
6e592b3a 1091 /* FALL THROUGH */
a0d0e21e 1092 default:
b15aece3 1093 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
8bd4d4c5 1094 SvPV_free(sv);
c445ea15 1095 SvPV_set(sv, NULL);
4633a7c4 1096 SvLEN_set(sv, 0);
a0d0e21e 1097 }
0c34ef67 1098 SvOK_off(sv);
4633a7c4 1099 SvSETMAGIC(sv);
79072805 1100 }
a0d0e21e
LW
1101
1102 RETPUSHUNDEF;
79072805
LW
1103}
1104
a0d0e21e 1105PP(pp_predec)
79072805 1106{
97aff369 1107 dVAR; dSP;
6e592b3a 1108 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
6ad8f254 1109 Perl_croak_no_modify(aTHX);
3510b4a1
NC
1110 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1111 && SvIVX(TOPs) != IV_MIN)
55497cff 1112 {
45977657 1113 SvIV_set(TOPs, SvIVX(TOPs) - 1);
55497cff 1114 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
1115 }
1116 else
1117 sv_dec(TOPs);
a0d0e21e
LW
1118 SvSETMAGIC(TOPs);
1119 return NORMAL;
1120}
79072805 1121
a0d0e21e
LW
1122PP(pp_postinc)
1123{
97aff369 1124 dVAR; dSP; dTARGET;
6e592b3a 1125 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
6ad8f254 1126 Perl_croak_no_modify(aTHX);
7dcb9b98
DM
1127 if (SvROK(TOPs))
1128 TARG = sv_newmortal();
a0d0e21e 1129 sv_setsv(TARG, TOPs);
3510b4a1
NC
1130 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1131 && SvIVX(TOPs) != IV_MAX)
55497cff 1132 {
45977657 1133 SvIV_set(TOPs, SvIVX(TOPs) + 1);
55497cff 1134 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
1135 }
1136 else
6f1401dc 1137 sv_inc_nomg(TOPs);
a0d0e21e 1138 SvSETMAGIC(TOPs);
1e54a23f 1139 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
a0d0e21e
LW
1140 if (!SvOK(TARG))
1141 sv_setiv(TARG, 0);
1142 SETs(TARG);
1143 return NORMAL;
1144}
79072805 1145
a0d0e21e
LW
1146PP(pp_postdec)
1147{
97aff369 1148 dVAR; dSP; dTARGET;
6e592b3a 1149 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
6ad8f254 1150 Perl_croak_no_modify(aTHX);
7dcb9b98
DM
1151 if (SvROK(TOPs))
1152 TARG = sv_newmortal();
a0d0e21e 1153 sv_setsv(TARG, TOPs);
3510b4a1
NC
1154 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1155 && SvIVX(TOPs) != IV_MIN)
55497cff 1156 {
45977657 1157 SvIV_set(TOPs, SvIVX(TOPs) - 1);
55497cff 1158 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
1159 }
1160 else
6f1401dc 1161 sv_dec_nomg(TOPs);
a0d0e21e
LW
1162 SvSETMAGIC(TOPs);
1163 SETs(TARG);
1164 return NORMAL;
1165}
79072805 1166
a0d0e21e
LW
1167/* Ordinary operators. */
1168
1169PP(pp_pow)
1170{
800401ee 1171 dVAR; dSP; dATARGET; SV *svl, *svr;
58d76dfd 1172#ifdef PERL_PRESERVE_IVUV
52a96ae6
HS
1173 bool is_int = 0;
1174#endif
6f1401dc
DM
1175 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1176 svr = TOPs;
1177 svl = TOPm1s;
52a96ae6
HS
1178#ifdef PERL_PRESERVE_IVUV
1179 /* For integer to integer power, we do the calculation by hand wherever
1180 we're sure it is safe; otherwise we call pow() and try to convert to
1181 integer afterwards. */
58d76dfd 1182 {
6f1401dc 1183 SvIV_please_nomg(svr);
800401ee 1184 if (SvIOK(svr)) {
6f1401dc 1185 SvIV_please_nomg(svl);
800401ee 1186 if (SvIOK(svl)) {
900658e3
PF
1187 UV power;
1188 bool baseuok;
1189 UV baseuv;
1190
800401ee
JH
1191 if (SvUOK(svr)) {
1192 power = SvUVX(svr);
900658e3 1193 } else {
800401ee 1194 const IV iv = SvIVX(svr);
900658e3
PF
1195 if (iv >= 0) {
1196 power = iv;
1197 } else {
1198 goto float_it; /* Can't do negative powers this way. */
1199 }
1200 }
1201
800401ee 1202 baseuok = SvUOK(svl);
900658e3 1203 if (baseuok) {
800401ee 1204 baseuv = SvUVX(svl);
900658e3 1205 } else {
800401ee 1206 const IV iv = SvIVX(svl);
900658e3
PF
1207 if (iv >= 0) {
1208 baseuv = iv;
1209 baseuok = TRUE; /* effectively it's a UV now */
1210 } else {
1211 baseuv = -iv; /* abs, baseuok == false records sign */
1212 }
1213 }
52a96ae6
HS
1214 /* now we have integer ** positive integer. */
1215 is_int = 1;
1216
1217 /* foo & (foo - 1) is zero only for a power of 2. */
58d76dfd 1218 if (!(baseuv & (baseuv - 1))) {
52a96ae6 1219 /* We are raising power-of-2 to a positive integer.
58d76dfd
JH
1220 The logic here will work for any base (even non-integer
1221 bases) but it can be less accurate than
1222 pow (base,power) or exp (power * log (base)) when the
1223 intermediate values start to spill out of the mantissa.
1224 With powers of 2 we know this can't happen.
1225 And powers of 2 are the favourite thing for perl
1226 programmers to notice ** not doing what they mean. */
1227 NV result = 1.0;
1228 NV base = baseuok ? baseuv : -(NV)baseuv;
900658e3
PF
1229
1230 if (power & 1) {
1231 result *= base;
1232 }
1233 while (power >>= 1) {
1234 base *= base;
1235 if (power & 1) {
1236 result *= base;
1237 }
1238 }
58d76dfd
JH
1239 SP--;
1240 SETn( result );
6f1401dc 1241 SvIV_please_nomg(svr);
58d76dfd 1242 RETURN;
52a96ae6
HS
1243 } else {
1244 register unsigned int highbit = 8 * sizeof(UV);
900658e3
PF
1245 register unsigned int diff = 8 * sizeof(UV);
1246 while (diff >>= 1) {
1247 highbit -= diff;
1248 if (baseuv >> highbit) {
1249 highbit += diff;
1250 }
52a96ae6
HS
1251 }
1252 /* we now have baseuv < 2 ** highbit */
1253 if (power * highbit <= 8 * sizeof(UV)) {
1254 /* result will definitely fit in UV, so use UV math
1255 on same algorithm as above */
1256 register UV result = 1;
1257 register UV base = baseuv;
f2338a2e 1258 const bool odd_power = cBOOL(power & 1);
900658e3
PF
1259 if (odd_power) {
1260 result *= base;
1261 }
1262 while (power >>= 1) {
1263 base *= base;
1264 if (power & 1) {
52a96ae6 1265 result *= base;
52a96ae6
HS
1266 }
1267 }
1268 SP--;
0615a994 1269 if (baseuok || !odd_power)
52a96ae6
HS
1270 /* answer is positive */
1271 SETu( result );
1272 else if (result <= (UV)IV_MAX)
1273 /* answer negative, fits in IV */
1274 SETi( -(IV)result );
1275 else if (result == (UV)IV_MIN)
1276 /* 2's complement assumption: special case IV_MIN */
1277 SETi( IV_MIN );
1278 else
1279 /* answer negative, doesn't fit */
1280 SETn( -(NV)result );
1281 RETURN;
1282 }
1283 }
1284 }
1285 }
58d76dfd 1286 }
52a96ae6 1287 float_it:
58d76dfd 1288#endif
a0d0e21e 1289 {
6f1401dc
DM
1290 NV right = SvNV_nomg(svr);
1291 NV left = SvNV_nomg(svl);
4efa5a16 1292 (void)POPs;
3aaeb624
JA
1293
1294#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1295 /*
1296 We are building perl with long double support and are on an AIX OS
1297 afflicted with a powl() function that wrongly returns NaNQ for any
1298 negative base. This was reported to IBM as PMR #23047-379 on
1299 03/06/2006. The problem exists in at least the following versions
1300 of AIX and the libm fileset, and no doubt others as well:
1301
1302 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1303 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1304 AIX 5.2.0 bos.adt.libm 5.2.0.85
1305
1306 So, until IBM fixes powl(), we provide the following workaround to
1307 handle the problem ourselves. Our logic is as follows: for
1308 negative bases (left), we use fmod(right, 2) to check if the
1309 exponent is an odd or even integer:
1310
1311 - if odd, powl(left, right) == -powl(-left, right)
1312 - if even, powl(left, right) == powl(-left, right)
1313
1314 If the exponent is not an integer, the result is rightly NaNQ, so
1315 we just return that (as NV_NAN).
1316 */
1317
1318 if (left < 0.0) {
1319 NV mod2 = Perl_fmod( right, 2.0 );
1320 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1321 SETn( -Perl_pow( -left, right) );
1322 } else if (mod2 == 0.0) { /* even integer */
1323 SETn( Perl_pow( -left, right) );
1324 } else { /* fractional power */
1325 SETn( NV_NAN );
1326 }
1327 } else {
1328 SETn( Perl_pow( left, right) );
1329 }
1330#else
52a96ae6 1331 SETn( Perl_pow( left, right) );
3aaeb624
JA
1332#endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1333
52a96ae6
HS
1334#ifdef PERL_PRESERVE_IVUV
1335 if (is_int)
6f1401dc 1336 SvIV_please_nomg(svr);
52a96ae6
HS
1337#endif
1338 RETURN;
93a17b20 1339 }
a0d0e21e
LW
1340}
1341
1342PP(pp_multiply)
1343{
800401ee 1344 dVAR; dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM
1345 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1346 svr = TOPs;
1347 svl = TOPm1s;
28e5dec8 1348#ifdef PERL_PRESERVE_IVUV
6f1401dc 1349 SvIV_please_nomg(svr);
800401ee 1350 if (SvIOK(svr)) {
28e5dec8
JH
1351 /* Unless the left argument is integer in range we are going to have to
1352 use NV maths. Hence only attempt to coerce the right argument if
1353 we know the left is integer. */
1354 /* Left operand is defined, so is it IV? */
6f1401dc 1355 SvIV_please_nomg(svl);
800401ee
JH
1356 if (SvIOK(svl)) {
1357 bool auvok = SvUOK(svl);
1358 bool buvok = SvUOK(svr);
28e5dec8
JH
1359 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1360 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1361 UV alow;
1362 UV ahigh;
1363 UV blow;
1364 UV bhigh;
1365
1366 if (auvok) {
800401ee 1367 alow = SvUVX(svl);
28e5dec8 1368 } else {
800401ee 1369 const IV aiv = SvIVX(svl);
28e5dec8
JH
1370 if (aiv >= 0) {
1371 alow = aiv;
1372 auvok = TRUE; /* effectively it's a UV now */
1373 } else {
1374 alow = -aiv; /* abs, auvok == false records sign */
1375 }
1376 }
1377 if (buvok) {
800401ee 1378 blow = SvUVX(svr);
28e5dec8 1379 } else {
800401ee 1380 const IV biv = SvIVX(svr);
28e5dec8
JH
1381 if (biv >= 0) {
1382 blow = biv;
1383 buvok = TRUE; /* effectively it's a UV now */
1384 } else {
1385 blow = -biv; /* abs, buvok == false records sign */
1386 }
1387 }
1388
1389 /* If this does sign extension on unsigned it's time for plan B */
1390 ahigh = alow >> (4 * sizeof (UV));
1391 alow &= botmask;
1392 bhigh = blow >> (4 * sizeof (UV));
1393 blow &= botmask;
1394 if (ahigh && bhigh) {
6f207bd3 1395 NOOP;
28e5dec8
JH
1396 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1397 which is overflow. Drop to NVs below. */
1398 } else if (!ahigh && !bhigh) {
1399 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1400 so the unsigned multiply cannot overflow. */
c445ea15 1401 const UV product = alow * blow;
28e5dec8
JH
1402 if (auvok == buvok) {
1403 /* -ve * -ve or +ve * +ve gives a +ve result. */
1404 SP--;
1405 SETu( product );
1406 RETURN;
1407 } else if (product <= (UV)IV_MIN) {
1408 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1409 /* -ve result, which could overflow an IV */
1410 SP--;
25716404 1411 SETi( -(IV)product );
28e5dec8
JH
1412 RETURN;
1413 } /* else drop to NVs below. */
1414 } else {
1415 /* One operand is large, 1 small */
1416 UV product_middle;
1417 if (bhigh) {
1418 /* swap the operands */
1419 ahigh = bhigh;
1420 bhigh = blow; /* bhigh now the temp var for the swap */
1421 blow = alow;
1422 alow = bhigh;
1423 }
1424 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1425 multiplies can't overflow. shift can, add can, -ve can. */
1426 product_middle = ahigh * blow;
1427 if (!(product_middle & topmask)) {
1428 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1429 UV product_low;
1430 product_middle <<= (4 * sizeof (UV));
1431 product_low = alow * blow;
1432
1433 /* as for pp_add, UV + something mustn't get smaller.
1434 IIRC ANSI mandates this wrapping *behaviour* for
1435 unsigned whatever the actual representation*/
1436 product_low += product_middle;
1437 if (product_low >= product_middle) {
1438 /* didn't overflow */
1439 if (auvok == buvok) {
1440 /* -ve * -ve or +ve * +ve gives a +ve result. */
1441 SP--;
1442 SETu( product_low );
1443 RETURN;
1444 } else if (product_low <= (UV)IV_MIN) {
1445 /* 2s complement assumption again */
1446 /* -ve result, which could overflow an IV */
1447 SP--;
25716404 1448 SETi( -(IV)product_low );
28e5dec8
JH
1449 RETURN;
1450 } /* else drop to NVs below. */
1451 }
1452 } /* product_middle too large */
1453 } /* ahigh && bhigh */
800401ee
JH
1454 } /* SvIOK(svl) */
1455 } /* SvIOK(svr) */
28e5dec8 1456#endif
a0d0e21e 1457 {
6f1401dc
DM
1458 NV right = SvNV_nomg(svr);
1459 NV left = SvNV_nomg(svl);
4efa5a16 1460 (void)POPs;
a0d0e21e
LW
1461 SETn( left * right );
1462 RETURN;
79072805 1463 }
a0d0e21e
LW
1464}
1465
1466PP(pp_divide)
1467{
800401ee 1468 dVAR; dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM
1469 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1470 svr = TOPs;
1471 svl = TOPm1s;
5479d192 1472 /* Only try to do UV divide first
68795e93 1473 if ((SLOPPYDIVIDE is true) or
5479d192
NC
1474 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1475 to preserve))
1476 The assumption is that it is better to use floating point divide
1477 whenever possible, only doing integer divide first if we can't be sure.
1478 If NV_PRESERVES_UV is true then we know at compile time that no UV
1479 can be too large to preserve, so don't need to compile the code to
1480 test the size of UVs. */
1481
a0d0e21e 1482#ifdef SLOPPYDIVIDE
5479d192
NC
1483# define PERL_TRY_UV_DIVIDE
1484 /* ensure that 20./5. == 4. */
a0d0e21e 1485#else
5479d192
NC
1486# ifdef PERL_PRESERVE_IVUV
1487# ifndef NV_PRESERVES_UV
1488# define PERL_TRY_UV_DIVIDE
1489# endif
1490# endif
a0d0e21e 1491#endif
5479d192
NC
1492
1493#ifdef PERL_TRY_UV_DIVIDE
6f1401dc 1494 SvIV_please_nomg(svr);
800401ee 1495 if (SvIOK(svr)) {
6f1401dc 1496 SvIV_please_nomg(svl);
800401ee
JH
1497 if (SvIOK(svl)) {
1498 bool left_non_neg = SvUOK(svl);
1499 bool right_non_neg = SvUOK(svr);
5479d192
NC
1500 UV left;
1501 UV right;
1502
1503 if (right_non_neg) {
800401ee 1504 right = SvUVX(svr);
5479d192
NC
1505 }
1506 else {
800401ee 1507 const IV biv = SvIVX(svr);
5479d192
NC
1508 if (biv >= 0) {
1509 right = biv;
1510 right_non_neg = TRUE; /* effectively it's a UV now */
1511 }
1512 else {
1513 right = -biv;
1514 }
1515 }
1516 /* historically undef()/0 gives a "Use of uninitialized value"
1517 warning before dieing, hence this test goes here.
1518 If it were immediately before the second SvIV_please, then
1519 DIE() would be invoked before left was even inspected, so
486ec47a 1520 no inspection would give no warning. */
5479d192
NC
1521 if (right == 0)
1522 DIE(aTHX_ "Illegal division by zero");
1523
1524 if (left_non_neg) {
800401ee 1525 left = SvUVX(svl);
5479d192
NC
1526 }
1527 else {
800401ee 1528 const IV aiv = SvIVX(svl);
5479d192
NC
1529 if (aiv >= 0) {
1530 left = aiv;
1531 left_non_neg = TRUE; /* effectively it's a UV now */
1532 }
1533 else {
1534 left = -aiv;
1535 }
1536 }
1537
1538 if (left >= right
1539#ifdef SLOPPYDIVIDE
1540 /* For sloppy divide we always attempt integer division. */
1541#else
1542 /* Otherwise we only attempt it if either or both operands
1543 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC
1544 we fall through to the NV divide code below. However,
1545 as left >= right to ensure integer result here, we know that
1546 we can skip the test on the right operand - right big
1547 enough not to be preserved can't get here unless left is
1548 also too big. */
1549
1550 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC
1551#endif
1552 ) {
1553 /* Integer division can't overflow, but it can be imprecise. */
1b6737cc 1554 const UV result = left / right;
5479d192
NC
1555 if (result * right == left) {
1556 SP--; /* result is valid */
1557 if (left_non_neg == right_non_neg) {
1558 /* signs identical, result is positive. */
1559 SETu( result );
1560 RETURN;
1561 }
1562 /* 2s complement assumption */
1563 if (result <= (UV)IV_MIN)
91f3b821 1564 SETi( -(IV)result );
5479d192
NC
1565 else {
1566 /* It's exact but too negative for IV. */
1567 SETn( -(NV)result );
1568 }
1569 RETURN;
1570 } /* tried integer divide but it was not an integer result */
32fdb065 1571 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
5479d192
NC
1572 } /* left wasn't SvIOK */
1573 } /* right wasn't SvIOK */
1574#endif /* PERL_TRY_UV_DIVIDE */
1575 {
6f1401dc
DM
1576 NV right = SvNV_nomg(svr);
1577 NV left = SvNV_nomg(svl);
4efa5a16 1578 (void)POPs;(void)POPs;
ebc6a117
PD
1579#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1580 if (! Perl_isnan(right) && right == 0.0)
1581#else
5479d192 1582 if (right == 0.0)
ebc6a117 1583#endif
5479d192
NC
1584 DIE(aTHX_ "Illegal division by zero");
1585 PUSHn( left / right );
1586 RETURN;
79072805 1587 }
a0d0e21e
LW
1588}
1589
1590PP(pp_modulo)
1591{
6f1401dc
DM
1592 dVAR; dSP; dATARGET;
1593 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
a0d0e21e 1594 {
9c5ffd7c
JH
1595 UV left = 0;
1596 UV right = 0;
dc656993
JH
1597 bool left_neg = FALSE;
1598 bool right_neg = FALSE;
e2c88acc
NC
1599 bool use_double = FALSE;
1600 bool dright_valid = FALSE;
9c5ffd7c
JH
1601 NV dright = 0.0;
1602 NV dleft = 0.0;
6f1401dc
DM
1603 SV * const svr = TOPs;
1604 SV * const svl = TOPm1s;
1605 SvIV_please_nomg(svr);
800401ee
JH
1606 if (SvIOK(svr)) {
1607 right_neg = !SvUOK(svr);
e2c88acc 1608 if (!right_neg) {
800401ee 1609 right = SvUVX(svr);
e2c88acc 1610 } else {
800401ee 1611 const IV biv = SvIVX(svr);
e2c88acc
NC
1612 if (biv >= 0) {
1613 right = biv;
1614 right_neg = FALSE; /* effectively it's a UV now */
1615 } else {
1616 right = -biv;
1617 }
1618 }
1619 }
1620 else {
6f1401dc 1621 dright = SvNV_nomg(svr);
787eafbd
IZ
1622 right_neg = dright < 0;
1623 if (right_neg)
1624 dright = -dright;
e2c88acc
NC
1625 if (dright < UV_MAX_P1) {
1626 right = U_V(dright);
1627 dright_valid = TRUE; /* In case we need to use double below. */
1628 } else {
1629 use_double = TRUE;
1630 }
787eafbd 1631 }
a0d0e21e 1632
e2c88acc
NC
1633 /* At this point use_double is only true if right is out of range for
1634 a UV. In range NV has been rounded down to nearest UV and
1635 use_double false. */
6f1401dc 1636 SvIV_please_nomg(svl);
800401ee
JH
1637 if (!use_double && SvIOK(svl)) {
1638 if (SvIOK(svl)) {
1639 left_neg = !SvUOK(svl);
e2c88acc 1640 if (!left_neg) {
800401ee 1641 left = SvUVX(svl);
e2c88acc 1642 } else {
800401ee 1643 const IV aiv = SvIVX(svl);
e2c88acc
NC
1644 if (aiv >= 0) {
1645 left = aiv;
1646 left_neg = FALSE; /* effectively it's a UV now */
1647 } else {
1648 left = -aiv;
1649 }
1650 }
1651 }
1652 }
787eafbd 1653 else {
6f1401dc 1654 dleft = SvNV_nomg(svl);
787eafbd
IZ
1655 left_neg = dleft < 0;
1656 if (left_neg)
1657 dleft = -dleft;
68dc0745 1658
e2c88acc
NC
1659 /* This should be exactly the 5.6 behaviour - if left and right are
1660 both in range for UV then use U_V() rather than floor. */
1661 if (!use_double) {
1662 if (dleft < UV_MAX_P1) {
1663 /* right was in range, so is dleft, so use UVs not double.
1664 */
1665 left = U_V(dleft);
1666 }
1667 /* left is out of range for UV, right was in range, so promote
1668 right (back) to double. */
1669 else {
1670 /* The +0.5 is used in 5.6 even though it is not strictly
1671 consistent with the implicit +0 floor in the U_V()
1672 inside the #if 1. */
1673 dleft = Perl_floor(dleft + 0.5);
1674 use_double = TRUE;
1675 if (dright_valid)
1676 dright = Perl_floor(dright + 0.5);
1677 else
1678 dright = right;
1679 }
1680 }
1681 }
6f1401dc 1682 sp -= 2;
787eafbd 1683 if (use_double) {
65202027 1684 NV dans;
787eafbd 1685
787eafbd 1686 if (!dright)
cea2e8a9 1687 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1688
65202027 1689 dans = Perl_fmod(dleft, dright);
787eafbd
IZ
1690 if ((left_neg != right_neg) && dans)
1691 dans = dright - dans;
1692 if (right_neg)
1693 dans = -dans;
1694 sv_setnv(TARG, dans);
1695 }
1696 else {
1697 UV ans;
1698
787eafbd 1699 if (!right)
cea2e8a9 1700 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ
1701
1702 ans = left % right;
1703 if ((left_neg != right_neg) && ans)
1704 ans = right - ans;
1705 if (right_neg) {
1706 /* XXX may warn: unary minus operator applied to unsigned type */
1707 /* could change -foo to be (~foo)+1 instead */
1708 if (ans <= ~((UV)IV_MAX)+1)
1709 sv_setiv(TARG, ~ans+1);
1710 else
65202027 1711 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ
1712 }
1713 else
1714 sv_setuv(TARG, ans);
1715 }
1716 PUSHTARG;
1717 RETURN;
79072805 1718 }
a0d0e21e 1719}
79072805 1720
a0d0e21e
LW
1721PP(pp_repeat)
1722{
6f1401dc 1723 dVAR; dSP; dATARGET;
2b573ace 1724 register IV count;
6f1401dc
DM
1725 SV *sv;
1726
1727 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1728 /* TODO: think of some way of doing list-repeat overloading ??? */
1729 sv = POPs;
1730 SvGETMAGIC(sv);
1731 }
1732 else {
1733 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1734 sv = POPs;
1735 }
1736
2b573ace
JH
1737 if (SvIOKp(sv)) {
1738 if (SvUOK(sv)) {
6f1401dc 1739 const UV uv = SvUV_nomg(sv);
2b573ace
JH
1740 if (uv > IV_MAX)
1741 count = IV_MAX; /* The best we can do? */
1742 else
1743 count = uv;
1744 } else {
6f1401dc 1745 const IV iv = SvIV_nomg(sv);
2b573ace
JH
1746 if (iv < 0)
1747 count = 0;
1748 else
1749 count = iv;
1750 }
1751 }
1752 else if (SvNOKp(sv)) {
6f1401dc 1753 const NV nv = SvNV_nomg(sv);
2b573ace
JH
1754 if (nv < 0.0)
1755 count = 0;
1756 else
1757 count = (IV)nv;
1758 }
1759 else
6f1401dc
DM
1760 count = SvIV_nomg(sv);
1761
533c011a 1762 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e 1763 dMARK;
0bd48802
AL
1764 static const char oom_list_extend[] = "Out of memory during list extend";
1765 const I32 items = SP - MARK;
1766 const I32 max = items * count;
79072805 1767
2b573ace
JH
1768 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1769 /* Did the max computation overflow? */
27d5b266 1770 if (items > 0 && max > 0 && (max < items || max < count))
2b573ace 1771 Perl_croak(aTHX_ oom_list_extend);
a0d0e21e
LW
1772 MEXTEND(MARK, max);
1773 if (count > 1) {
1774 while (SP > MARK) {
976c8a39
JH
1775#if 0
1776 /* This code was intended to fix 20010809.028:
1777
1778 $x = 'abcd';
1779 for (($x =~ /./g) x 2) {
1780 print chop; # "abcdabcd" expected as output.
1781 }
1782
1783 * but that change (#11635) broke this code:
1784
1785 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1786
1787 * I can't think of a better fix that doesn't introduce
1788 * an efficiency hit by copying the SVs. The stack isn't
1789 * refcounted, and mortalisation obviously doesn't
1790 * Do The Right Thing when the stack has more than
1791 * one pointer to the same mortal value.
1792 * .robin.
1793 */
e30acc16
RH
1794 if (*SP) {
1795 *SP = sv_2mortal(newSVsv(*SP));
1796 SvREADONLY_on(*SP);
1797 }
976c8a39
JH
1798#else
1799 if (*SP)
1800 SvTEMP_off((*SP));
1801#endif
a0d0e21e 1802 SP--;
79072805 1803 }
a0d0e21e
LW
1804 MARK++;
1805 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1806 items * sizeof(const SV *), count - 1);
a0d0e21e 1807 SP += max;
79072805 1808 }
a0d0e21e
LW
1809 else if (count <= 0)
1810 SP -= items;
79072805 1811 }
a0d0e21e 1812 else { /* Note: mark already snarfed by pp_list */
0bd48802 1813 SV * const tmpstr = POPs;
a0d0e21e 1814 STRLEN len;
9b877dbb 1815 bool isutf;
2b573ace
JH
1816 static const char oom_string_extend[] =
1817 "Out of memory during string extend";
a0d0e21e 1818
6f1401dc
DM
1819 if (TARG != tmpstr)
1820 sv_setsv_nomg(TARG, tmpstr);
1821 SvPV_force_nomg(TARG, len);
9b877dbb 1822 isutf = DO_UTF8(TARG);
8ebc5c01
PP
1823 if (count != 1) {
1824 if (count < 1)
1825 SvCUR_set(TARG, 0);
1826 else {
c445ea15 1827 const STRLEN max = (UV)count * len;
19a94d75 1828 if (len > MEM_SIZE_MAX / count)
2b573ace
JH
1829 Perl_croak(aTHX_ oom_string_extend);
1830 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
8569b9dc 1831 SvGROW(TARG, max + 1);
a0d0e21e 1832 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1833 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1834 }
a0d0e21e 1835 *SvEND(TARG) = '\0';
a0d0e21e 1836 }
dfcb284a
GS
1837 if (isutf)
1838 (void)SvPOK_only_UTF8(TARG);
1839 else
1840 (void)SvPOK_only(TARG);
b80b6069
RH
1841
1842 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1843 /* The parser saw this as a list repeat, and there
1844 are probably several items on the stack. But we're
1845 in scalar context, and there's no pp_list to save us
1846 now. So drop the rest of the items -- robin@kitsite.com
1847 */
1848 dMARK;
1849 SP = MARK;
1850 }
a0d0e21e 1851 PUSHTARG;
79072805 1852 }
a0d0e21e
LW
1853 RETURN;
1854}
79072805 1855
a0d0e21e
LW
1856PP(pp_subtract)
1857{
800401ee 1858 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
1859 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1860 svr = TOPs;
1861 svl = TOPm1s;
800401ee 1862 useleft = USE_LEFT(svl);
28e5dec8 1863#ifdef PERL_PRESERVE_IVUV
7dca457a
NC
1864 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1865 "bad things" happen if you rely on signed integers wrapping. */
6f1401dc 1866 SvIV_please_nomg(svr);
800401ee 1867 if (SvIOK(svr)) {
28e5dec8
JH
1868 /* Unless the left argument is integer in range we are going to have to
1869 use NV maths. Hence only attempt to coerce the right argument if
1870 we know the left is integer. */
9c5ffd7c
JH
1871 register UV auv = 0;
1872 bool auvok = FALSE;
7dca457a
NC
1873 bool a_valid = 0;
1874
28e5dec8 1875 if (!useleft) {
7dca457a
NC
1876 auv = 0;
1877 a_valid = auvok = 1;
1878 /* left operand is undef, treat as zero. */
28e5dec8
JH
1879 } else {
1880 /* Left operand is defined, so is it IV? */
6f1401dc 1881 SvIV_please_nomg(svl);
800401ee
JH
1882 if (SvIOK(svl)) {
1883 if ((auvok = SvUOK(svl)))
1884 auv = SvUVX(svl);
7dca457a 1885 else {
800401ee 1886 register const IV aiv = SvIVX(svl);
7dca457a
NC
1887 if (aiv >= 0) {
1888 auv = aiv;
1889 auvok = 1; /* Now acting as a sign flag. */
1890 } else { /* 2s complement assumption for IV_MIN */
1891 auv = (UV)-aiv;
28e5dec8 1892 }
7dca457a
NC
1893 }
1894 a_valid = 1;
1895 }
1896 }
1897 if (a_valid) {
1898 bool result_good = 0;
1899 UV result;
1900 register UV buv;
800401ee 1901 bool buvok = SvUOK(svr);
9041c2e3 1902
7dca457a 1903 if (buvok)
800401ee 1904 buv = SvUVX(svr);
7dca457a 1905 else {
800401ee 1906 register const IV biv = SvIVX(svr);
7dca457a
NC
1907 if (biv >= 0) {
1908 buv = biv;
1909 buvok = 1;
1910 } else
1911 buv = (UV)-biv;
1912 }
1913 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1914 else "IV" now, independent of how it came in.
7dca457a
NC
1915 if a, b represents positive, A, B negative, a maps to -A etc
1916 a - b => (a - b)
1917 A - b => -(a + b)
1918 a - B => (a + b)
1919 A - B => -(a - b)
1920 all UV maths. negate result if A negative.
1921 subtract if signs same, add if signs differ. */
1922
1923 if (auvok ^ buvok) {
1924 /* Signs differ. */
1925 result = auv + buv;
1926 if (result >= auv)
1927 result_good = 1;
1928 } else {
1929 /* Signs same */
1930 if (auv >= buv) {
1931 result = auv - buv;
1932 /* Must get smaller */
1933 if (result <= auv)
1934 result_good = 1;
1935 } else {
1936 result = buv - auv;
1937 if (result <= buv) {
1938 /* result really should be -(auv-buv). as its negation
1939 of true value, need to swap our result flag */
1940 auvok = !auvok;
1941 result_good = 1;
28e5dec8 1942 }
28e5dec8
JH
1943 }
1944 }
7dca457a
NC
1945 if (result_good) {
1946 SP--;
1947 if (auvok)
1948 SETu( result );
1949 else {
1950 /* Negate result */
1951 if (result <= (UV)IV_MIN)
1952 SETi( -(IV)result );
1953 else {
1954 /* result valid, but out of range for IV. */
1955 SETn( -(NV)result );
1956 }
1957 }
1958 RETURN;
1959 } /* Overflow, drop through to NVs. */
28e5dec8
JH
1960 }
1961 }
1962#endif
a0d0e21e 1963 {
6f1401dc 1964 NV value = SvNV_nomg(svr);
4efa5a16
RD
1965 (void)POPs;
1966
28e5dec8
JH
1967 if (!useleft) {
1968 /* left operand is undef, treat as zero - value */
1969 SETn(-value);
1970 RETURN;
1971 }
6f1401dc 1972 SETn( SvNV_nomg(svl) - value );
28e5dec8 1973 RETURN;
79072805 1974 }
a0d0e21e 1975}
79072805 1976
a0d0e21e
LW
1977PP(pp_left_shift)
1978{
6f1401dc 1979 dVAR; dSP; dATARGET; SV *svl, *svr;
a42d0242 1980 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1981 svr = POPs;
1982 svl = TOPs;
a0d0e21e 1983 {
6f1401dc 1984 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1985 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1986 const IV i = SvIV_nomg(svl);
972b05a9 1987 SETi(i << shift);
d0ba1bd2
JH
1988 }
1989 else {
6f1401dc 1990 const UV u = SvUV_nomg(svl);
972b05a9 1991 SETu(u << shift);
d0ba1bd2 1992 }
55497cff 1993 RETURN;
79072805 1994 }
a0d0e21e 1995}
79072805 1996
a0d0e21e
LW
1997PP(pp_right_shift)
1998{
6f1401dc 1999 dVAR; dSP; dATARGET; SV *svl, *svr;
a42d0242 2000 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
2001 svr = POPs;
2002 svl = TOPs;
a0d0e21e 2003 {
6f1401dc 2004 const IV shift = SvIV_nomg(svr);
d0ba1bd2 2005 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 2006 const IV i = SvIV_nomg(svl);
972b05a9 2007 SETi(i >> shift);
d0ba1bd2
JH
2008 }
2009 else {
6f1401dc 2010 const UV u = SvUV_nomg(svl);
972b05a9 2011 SETu(u >> shift);
d0ba1bd2 2012 }
a0d0e21e 2013 RETURN;
93a17b20 2014 }
79072805
LW
2015}
2016
a0d0e21e 2017PP(pp_lt)
79072805 2018{
6f1401dc 2019 dVAR; dSP;
33efebe6
DM
2020 SV *left, *right;
2021
a42d0242 2022 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
2023 right = POPs;
2024 left = TOPs;
2025 SETs(boolSV(
2026 (SvIOK_notUV(left) && SvIOK_notUV(right))
2027 ? (SvIVX(left) < SvIVX(right))
2028 : (do_ncmp(left, right) == -1)
2029 ));
2030 RETURN;
a0d0e21e 2031}
79072805 2032
a0d0e21e
LW
2033PP(pp_gt)
2034{
6f1401dc 2035 dVAR; dSP;
33efebe6 2036 SV *left, *right;
1b6737cc 2037
33efebe6
DM
2038 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
2039 right = POPs;
2040 left = TOPs;
2041 SETs(boolSV(
2042 (SvIOK_notUV(left) && SvIOK_notUV(right))
2043 ? (SvIVX(left) > SvIVX(right))
2044 : (do_ncmp(left, right) == 1)
2045 ));
2046 RETURN;
a0d0e21e
LW
2047}
2048
2049PP(pp_le)
2050{
6f1401dc 2051 dVAR; dSP;
33efebe6 2052 SV *left, *right;
1b6737cc 2053
33efebe6
DM
2054 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2055 right = POPs;
2056 left = TOPs;
2057 SETs(boolSV(
2058 (SvIOK_notUV(left) && SvIOK_notUV(right))
2059 ? (SvIVX(left) <= SvIVX(right))
2060 : (do_ncmp(left, right) <= 0)
2061 ));
2062 RETURN;
a0d0e21e
LW
2063}
2064
2065PP(pp_ge)
2066{
6f1401dc 2067 dVAR; dSP;
33efebe6
DM
2068 SV *left, *right;
2069
2070 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
2071 right = POPs;
2072 left = TOPs;
2073 SETs(boolSV(
2074 (SvIOK_notUV(left) && SvIOK_notUV(right))
2075 ? (SvIVX(left) >= SvIVX(right))
2076 : ( (do_ncmp(left, right) & 2) == 0)
2077 ));
2078 RETURN;
2079}
1b6737cc 2080
33efebe6
DM
2081PP(pp_ne)
2082{
2083 dVAR; dSP;
2084 SV *left, *right;
2085
2086 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2087 right = POPs;
2088 left = TOPs;
2089 SETs(boolSV(
2090 (SvIOK_notUV(left) && SvIOK_notUV(right))
2091 ? (SvIVX(left) != SvIVX(right))
2092 : (do_ncmp(left, right) != 0)
2093 ));
2094 RETURN;
2095}
1b6737cc 2096
33efebe6
DM
2097/* compare left and right SVs. Returns:
2098 * -1: <
2099 * 0: ==
2100 * 1: >
2101 * 2: left or right was a NaN
2102 */
2103I32
2104Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2105{
2106 dVAR;
1b6737cc 2107
33efebe6
DM
2108 PERL_ARGS_ASSERT_DO_NCMP;
2109#ifdef PERL_PRESERVE_IVUV
2110 SvIV_please_nomg(right);
2111 /* Fortunately it seems NaN isn't IOK */
2112 if (SvIOK(right)) {
2113 SvIV_please_nomg(left);
2114 if (SvIOK(left)) {
2115 if (!SvUOK(left)) {
2116 const IV leftiv = SvIVX(left);
2117 if (!SvUOK(right)) {
2118 /* ## IV <=> IV ## */
2119 const IV rightiv = SvIVX(right);
2120 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2121 }
33efebe6
DM
2122 /* ## IV <=> UV ## */
2123 if (leftiv < 0)
2124 /* As (b) is a UV, it's >=0, so it must be < */
2125 return -1;
2126 {
2127 const UV rightuv = SvUVX(right);
2128 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2129 }
28e5dec8 2130 }
79072805 2131
33efebe6
DM
2132 if (SvUOK(right)) {
2133 /* ## UV <=> UV ## */
2134 const UV leftuv = SvUVX(left);
2135 const UV rightuv = SvUVX(right);
2136 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2137 }
33efebe6
DM
2138 /* ## UV <=> IV ## */
2139 {
2140 const IV rightiv = SvIVX(right);
2141 if (rightiv < 0)
2142 /* As (a) is a UV, it's >=0, so it cannot be < */
2143 return 1;
2144 {
2145 const UV leftuv = SvUVX(left);
2146 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2147 }
28e5dec8 2148 }
33efebe6 2149 /* NOTREACHED */
28e5dec8
JH
2150 }
2151 }
2152#endif
a0d0e21e 2153 {
33efebe6
DM
2154 NV const rnv = SvNV_nomg(right);
2155 NV const lnv = SvNV_nomg(left);
2156
cab190d4 2157#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM
2158 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2159 return 2;
2160 }
2161 return (lnv > rnv) - (lnv < rnv);
cab190d4 2162#else
33efebe6
DM
2163 if (lnv < rnv)
2164 return -1;
2165 if (lnv > rnv)
2166 return 1;
2167 if (lnv == rnv)
2168 return 0;
2169 return 2;
cab190d4 2170#endif
a0d0e21e 2171 }
79072805
LW
2172}
2173
33efebe6 2174
a0d0e21e 2175PP(pp_ncmp)
79072805 2176{
33efebe6
DM
2177 dVAR; dSP;
2178 SV *left, *right;
2179 I32 value;
a42d0242 2180 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM
2181 right = POPs;
2182 left = TOPs;
2183 value = do_ncmp(left, right);
2184 if (value == 2) {
3280af22 2185 SETs(&PL_sv_undef);
79072805 2186 }
33efebe6
DM
2187 else {
2188 dTARGET;
2189 SETi(value);
2190 }
2191 RETURN;
a0d0e21e 2192}
79072805 2193
afd9910b 2194PP(pp_sle)
a0d0e21e 2195{
97aff369 2196 dVAR; dSP;
79072805 2197
afd9910b
NC
2198 int amg_type = sle_amg;
2199 int multiplier = 1;
2200 int rhs = 1;
79072805 2201
afd9910b
NC
2202 switch (PL_op->op_type) {
2203 case OP_SLT:
2204 amg_type = slt_amg;
2205 /* cmp < 0 */
2206 rhs = 0;
2207 break;
2208 case OP_SGT:
2209 amg_type = sgt_amg;
2210 /* cmp > 0 */
2211 multiplier = -1;
2212 rhs = 0;
2213 break;
2214 case OP_SGE:
2215 amg_type = sge_amg;
2216 /* cmp >= 0 */
2217 multiplier = -1;
2218 break;
79072805 2219 }
79072805 2220
6f1401dc 2221 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW
2222 {
2223 dPOPTOPssrl;
1b6737cc 2224 const int cmp = (IN_LOCALE_RUNTIME
078504b2
FC
2225 ? sv_cmp_locale_flags(left, right, 0)
2226 : sv_cmp_flags(left, right, 0));
afd9910b 2227 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW
2228 RETURN;
2229 }
2230}
79072805 2231
36477c24
PP
2232PP(pp_seq)
2233{
6f1401dc
DM
2234 dVAR; dSP;
2235 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24
PP
2236 {
2237 dPOPTOPssrl;
078504b2 2238 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW
2239 RETURN;
2240 }
2241}
79072805 2242
a0d0e21e 2243PP(pp_sne)
79072805 2244{
6f1401dc
DM
2245 dVAR; dSP;
2246 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW
2247 {
2248 dPOPTOPssrl;
078504b2 2249 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2250 RETURN;
463ee0b2 2251 }
79072805
LW
2252}
2253
a0d0e21e 2254PP(pp_scmp)
79072805 2255{
6f1401dc
DM
2256 dVAR; dSP; dTARGET;
2257 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW
2258 {
2259 dPOPTOPssrl;
1b6737cc 2260 const int cmp = (IN_LOCALE_RUNTIME
078504b2
FC
2261 ? sv_cmp_locale_flags(left, right, 0)
2262 : sv_cmp_flags(left, right, 0));
bbce6d69 2263 SETi( cmp );
a0d0e21e
LW
2264 RETURN;
2265 }
2266}
79072805 2267
55497cff
PP
2268PP(pp_bit_and)
2269{
6f1401dc
DM
2270 dVAR; dSP; dATARGET;
2271 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW
2272 {
2273 dPOPTOPssrl;
4633a7c4 2274 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2275 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2276 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2277 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2278 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2279 SETi(i);
d0ba1bd2
JH
2280 }
2281 else {
1b6737cc 2282 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2283 SETu(u);
d0ba1bd2 2284 }
b20c4ee1
FC
2285 if (left_ro_nonnum) SvNIOK_off(left);
2286 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2287 }
2288 else {
533c011a 2289 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2290 SETTARG;
2291 }
2292 RETURN;
2293 }
2294}
79072805 2295
a0d0e21e
LW
2296PP(pp_bit_or)
2297{
3658c1f1
NC
2298 dVAR; dSP; dATARGET;
2299 const int op_type = PL_op->op_type;
2300
6f1401dc 2301 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW
2302 {
2303 dPOPTOPssrl;
4633a7c4 2304 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2305 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2306 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2307 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC
2308 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2309 const IV r = SvIV_nomg(right);
2310 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2311 SETi(result);
d0ba1bd2
JH
2312 }
2313 else {
3658c1f1
NC
2314 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2315 const UV r = SvUV_nomg(right);
2316 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2317 SETu(result);
d0ba1bd2 2318 }
b20c4ee1
FC
2319 if (left_ro_nonnum) SvNIOK_off(left);
2320 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2321 }
2322 else {
3658c1f1 2323 do_vop(op_type, TARG, left, right);
a0d0e21e
LW
2324 SETTARG;
2325 }
2326 RETURN;
79072805 2327 }
a0d0e21e 2328}
79072805 2329
a0d0e21e
LW
2330PP(pp_negate)
2331{
6f1401dc
DM
2332 dVAR; dSP; dTARGET;
2333 tryAMAGICun_MG(neg_amg, AMGf_numeric);
a0d0e21e 2334 {
6f1401dc 2335 SV * const sv = TOPs;
1b6737cc 2336 const int flags = SvFLAGS(sv);
a5b92898 2337
886a4465 2338 if( !SvNIOK( sv ) && looks_like_number( sv ) ){
a5b92898
R
2339 SvIV_please( sv );
2340 }
2341
28e5dec8
JH
2342 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2343 /* It's publicly an integer, or privately an integer-not-float */
2344 oops_its_an_int:
9b0e499b
GS
2345 if (SvIsUV(sv)) {
2346 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2347 /* 2s complement assumption. */
9b0e499b
GS
2348 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2349 RETURN;
2350 }
2351 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2352 SETi(-SvIVX(sv));
9b0e499b
GS
2353 RETURN;
2354 }
2355 }
2356 else if (SvIVX(sv) != IV_MIN) {
2357 SETi(-SvIVX(sv));
2358 RETURN;
2359 }
28e5dec8
JH
2360#ifdef PERL_PRESERVE_IVUV
2361 else {
2362 SETu((UV)IV_MIN);
2363 RETURN;
2364 }
2365#endif
9b0e499b
GS
2366 }
2367 if (SvNIOKp(sv))
6f1401dc 2368 SETn(-SvNV_nomg(sv));
4633a7c4 2369 else if (SvPOKp(sv)) {
a0d0e21e 2370 STRLEN len;
6f1401dc 2371 const char * const s = SvPV_nomg_const(sv, len);
bbce6d69 2372 if (isIDFIRST(*s)) {
76f68e9b 2373 sv_setpvs(TARG, "-");
a0d0e21e 2374 sv_catsv(TARG, sv);
79072805 2375 }
a0d0e21e 2376 else if (*s == '+' || *s == '-') {
6f1401dc
DM
2377 sv_setsv_nomg(TARG, sv);
2378 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
79072805 2379 }
8eb28a70 2380 else if (DO_UTF8(sv)) {
6f1401dc 2381 SvIV_please_nomg(sv);
8eb28a70
JH
2382 if (SvIOK(sv))
2383 goto oops_its_an_int;
2384 if (SvNOK(sv))
6f1401dc 2385 sv_setnv(TARG, -SvNV_nomg(sv));
8eb28a70 2386 else {
76f68e9b 2387 sv_setpvs(TARG, "-");
8eb28a70
JH
2388 sv_catsv(TARG, sv);
2389 }
834a4ddd 2390 }
28e5dec8 2391 else {
6f1401dc 2392 SvIV_please_nomg(sv);
8eb28a70
JH
2393 if (SvIOK(sv))
2394 goto oops_its_an_int;
6f1401dc 2395 sv_setnv(TARG, -SvNV_nomg(sv));
28e5dec8 2396 }
a0d0e21e 2397 SETTARG;
79072805 2398 }
4633a7c4 2399 else
6f1401dc 2400 SETn(-SvNV_nomg(sv));
79072805 2401 }
a0d0e21e 2402 RETURN;
79072805
LW
2403}
2404
a0d0e21e 2405PP(pp_not)
79072805 2406{
6f1401dc
DM
2407 dVAR; dSP;
2408 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2409 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2410 return NORMAL;
79072805
LW
2411}
2412
a0d0e21e 2413PP(pp_complement)
79072805 2414{
6f1401dc 2415 dVAR; dSP; dTARGET;
a42d0242 2416 tryAMAGICun_MG(compl_amg, AMGf_numeric);
a0d0e21e
LW
2417 {
2418 dTOPss;
4633a7c4 2419 if (SvNIOKp(sv)) {
d0ba1bd2 2420 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2421 const IV i = ~SvIV_nomg(sv);
972b05a9 2422 SETi(i);
d0ba1bd2
JH
2423 }
2424 else {
1b6737cc 2425 const UV u = ~SvUV_nomg(sv);
972b05a9 2426 SETu(u);
d0ba1bd2 2427 }
a0d0e21e
LW
2428 }
2429 else {
51723571 2430 register U8 *tmps;
55497cff 2431 register I32 anum;
a0d0e21e
LW
2432 STRLEN len;
2433
10516c54 2434 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
891f9566 2435 sv_setsv_nomg(TARG, sv);
6f1401dc 2436 tmps = (U8*)SvPV_force_nomg(TARG, len);
a0d0e21e 2437 anum = len;
1d68d6cd 2438 if (SvUTF8(TARG)) {
a1ca4561 2439 /* Calculate exact length, let's not estimate. */
1d68d6cd 2440 STRLEN targlen = 0;
ba210ebe 2441 STRLEN l;
a1ca4561
YST
2442 UV nchar = 0;
2443 UV nwide = 0;
01f6e806 2444 U8 * const send = tmps + len;
74d49cd0
ST
2445 U8 * const origtmps = tmps;
2446 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2447
1d68d6cd 2448 while (tmps < send) {
74d49cd0
ST
2449 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2450 tmps += l;
5bbb0b5a 2451 targlen += UNISKIP(~c);
a1ca4561
YST
2452 nchar++;
2453 if (c > 0xff)
2454 nwide++;
1d68d6cd
SC
2455 }
2456
2457 /* Now rewind strings and write them. */
74d49cd0 2458 tmps = origtmps;
a1ca4561
YST
2459
2460 if (nwide) {
01f6e806
AL
2461 U8 *result;
2462 U8 *p;
2463
74d49cd0 2464 Newx(result, targlen + 1, U8);
01f6e806 2465 p = result;
a1ca4561 2466 while (tmps < send) {
74d49cd0
ST
2467 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2468 tmps += l;
01f6e806 2469 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2470 }
01f6e806 2471 *p = '\0';
c1c21316
NC
2472 sv_usepvn_flags(TARG, (char*)result, targlen,
2473 SV_HAS_TRAILING_NUL);
a1ca4561
YST
2474 SvUTF8_on(TARG);
2475 }
2476 else {
01f6e806
AL
2477 U8 *result;
2478 U8 *p;
2479
74d49cd0 2480 Newx(result, nchar + 1, U8);
01f6e806 2481 p = result;
a1ca4561 2482 while (tmps < send) {
74d49cd0
ST
2483 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2484 tmps += l;
01f6e806 2485 *p++ = ~c;
a1ca4561 2486 }
01f6e806 2487 *p = '\0';
c1c21316 2488 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2489 SvUTF8_off(TARG);
1d68d6cd 2490 }
ec93b65f 2491 SETTARG;
1d68d6cd
SC
2492 RETURN;
2493 }
a0d0e21e 2494#ifdef LIBERAL
51723571
JH
2495 {
2496 register long *tmpl;
2497 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2498 *tmps = ~*tmps;
2499 tmpl = (long*)tmps;
bb7a0f54 2500 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH
2501 *tmpl = ~*tmpl;
2502 tmps = (U8*)tmpl;
2503 }
a0d0e21e
LW
2504#endif
2505 for ( ; anum > 0; anum--, tmps++)
2506 *tmps = ~*tmps;
ec93b65f 2507 SETTARG;
a0d0e21e
LW
2508 }
2509 RETURN;
2510 }
79072805
LW
2511}
2512
a0d0e21e
LW
2513/* integer versions of some of the above */
2514
a0d0e21e 2515PP(pp_i_multiply)
79072805 2516{
6f1401dc
DM
2517 dVAR; dSP; dATARGET;
2518 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2519 {
6f1401dc 2520 dPOPTOPiirl_nomg;
a0d0e21e
LW
2521 SETi( left * right );
2522 RETURN;
2523 }
79072805
LW
2524}
2525
a0d0e21e 2526PP(pp_i_divide)
79072805 2527{
85935d8e 2528 IV num;
6f1401dc
DM
2529 dVAR; dSP; dATARGET;
2530 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2531 {
6f1401dc 2532 dPOPTOPssrl;
85935d8e 2533 IV value = SvIV_nomg(right);
a0d0e21e 2534 if (value == 0)
ece1bcef 2535 DIE(aTHX_ "Illegal division by zero");
85935d8e 2536 num = SvIV_nomg(left);
a0cec769
YST
2537
2538 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2539 if (value == -1)
2540 value = - num;
2541 else
2542 value = num / value;
6f1401dc 2543 SETi(value);
a0d0e21e
LW
2544 RETURN;
2545 }
79072805
LW
2546}
2547
befad5d1 2548#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH
2549STATIC
2550PP(pp_i_modulo_0)
befad5d1
NC
2551#else
2552PP(pp_i_modulo)
2553#endif
224ec323
JH
2554{
2555 /* This is the vanilla old i_modulo. */
6f1401dc
DM
2556 dVAR; dSP; dATARGET;
2557 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2558 {
6f1401dc 2559 dPOPTOPiirl_nomg;
224ec323
JH
2560 if (!right)
2561 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2562 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2563 if (right == -1)
2564 SETi( 0 );
2565 else
2566 SETi( left % right );
224ec323
JH
2567 RETURN;
2568 }
2569}
2570
11010fa3 2571#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH
2572STATIC
2573PP(pp_i_modulo_1)
befad5d1 2574
224ec323 2575{
224ec323 2576 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2577 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2578 * See below for pp_i_modulo. */
6f1401dc
DM
2579 dVAR; dSP; dATARGET;
2580 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2581 {
6f1401dc 2582 dPOPTOPiirl_nomg;
224ec323
JH
2583 if (!right)
2584 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2585 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2586 if (right == -1)
2587 SETi( 0 );
2588 else
2589 SETi( left % PERL_ABS(right) );
224ec323
JH
2590 RETURN;
2591 }
224ec323
JH
2592}
2593
a0d0e21e 2594PP(pp_i_modulo)
79072805 2595{
6f1401dc
DM
2596 dVAR; dSP; dATARGET;
2597 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2598 {
6f1401dc 2599 dPOPTOPiirl_nomg;
224ec323
JH
2600 if (!right)
2601 DIE(aTHX_ "Illegal modulus zero");
2602 /* The assumption is to use hereafter the old vanilla version... */
2603 PL_op->op_ppaddr =
2604 PL_ppaddr[OP_I_MODULO] =
1c127fab 2605 Perl_pp_i_modulo_0;
224ec323
JH
2606 /* .. but if we have glibc, we might have a buggy _moddi3
2607 * (at least glicb 2.2.5 is known to have this bug), in other
2608 * words our integer modulus with negative quad as the second
2609 * argument might be broken. Test for this and re-patch the
2610 * opcode dispatch table if that is the case, remembering to
2611 * also apply the workaround so that this first round works
2612 * right, too. See [perl #9402] for more information. */
224ec323
JH
2613 {
2614 IV l = 3;
2615 IV r = -10;
2616 /* Cannot do this check with inlined IV constants since
2617 * that seems to work correctly even with the buggy glibc. */
2618 if (l % r == -3) {
2619 /* Yikes, we have the bug.
2620 * Patch in the workaround version. */
2621 PL_op->op_ppaddr =
2622 PL_ppaddr[OP_I_MODULO] =
2623 &Perl_pp_i_modulo_1;
2624 /* Make certain we work right this time, too. */
32fdb065 2625 right = PERL_ABS(right);
224ec323
JH
2626 }
2627 }
a0cec769
YST
2628 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2629 if (right == -1)
2630 SETi( 0 );
2631 else
2632 SETi( left % right );
224ec323
JH
2633 RETURN;
2634 }
79072805 2635}
befad5d1 2636#endif
79072805 2637
a0d0e21e 2638PP(pp_i_add)
79072805 2639{
6f1401dc
DM
2640 dVAR; dSP; dATARGET;
2641 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2642 {
6f1401dc 2643 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2644 SETi( left + right );
2645 RETURN;
79072805 2646 }
79072805
LW
2647}
2648
a0d0e21e 2649PP(pp_i_subtract)
79072805 2650{
6f1401dc
DM
2651 dVAR; dSP; dATARGET;
2652 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2653 {
6f1401dc 2654 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2655 SETi( left - right );
2656 RETURN;
79072805 2657 }
79072805
LW
2658}
2659
a0d0e21e 2660PP(pp_i_lt)
79072805 2661{
6f1401dc
DM
2662 dVAR; dSP;
2663 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2664 {
96b6b87f 2665 dPOPTOPiirl_nomg;
54310121 2666 SETs(boolSV(left < right));
a0d0e21e
LW
2667 RETURN;
2668 }
79072805
LW
2669}
2670
a0d0e21e 2671PP(pp_i_gt)
79072805 2672{
6f1401dc
DM
2673 dVAR; dSP;
2674 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2675 {
96b6b87f 2676 dPOPTOPiirl_nomg;
54310121 2677 SETs(boolSV(left > right));
a0d0e21e
LW
2678 RETURN;
2679 }
79072805
LW
2680}
2681
a0d0e21e 2682PP(pp_i_le)
79072805 2683{
6f1401dc
DM
2684 dVAR; dSP;
2685 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2686 {
96b6b87f 2687 dPOPTOPiirl_nomg;
54310121 2688 SETs(boolSV(left <= right));
a0d0e21e 2689 RETURN;
85e6fe83 2690 }
79072805
LW
2691}
2692
a0d0e21e 2693PP(pp_i_ge)
79072805 2694{
6f1401dc
DM
2695 dVAR; dSP;
2696 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2697 {
96b6b87f 2698 dPOPTOPiirl_nomg;
54310121 2699 SETs(boolSV(left >= right));
a0d0e21e
LW
2700 RETURN;
2701 }
79072805
LW
2702}
2703
a0d0e21e 2704PP(pp_i_eq)
79072805 2705{
6f1401dc
DM
2706 dVAR; dSP;
2707 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2708 {
96b6b87f 2709 dPOPTOPiirl_nomg;
54310121 2710 SETs(boolSV(left == right));
a0d0e21e
LW
2711 RETURN;
2712 }
79072805
LW
2713}
2714
a0d0e21e 2715PP(pp_i_ne)
79072805 2716{
6f1401dc
DM
2717 dVAR; dSP;
2718 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2719 {
96b6b87f 2720 dPOPTOPiirl_nomg;
54310121 2721 SETs(boolSV(left != right));
a0d0e21e
LW
2722 RETURN;
2723 }
79072805
LW
2724}
2725
a0d0e21e 2726PP(pp_i_ncmp)
79072805 2727{
6f1401dc
DM
2728 dVAR; dSP; dTARGET;
2729 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2730 {
96b6b87f 2731 dPOPTOPiirl_nomg;
a0d0e21e 2732 I32 value;
79072805 2733
a0d0e21e 2734 if (left > right)
79072805 2735 value = 1;
a0d0e21e 2736 else if (left < right)
79072805 2737 value = -1;
a0d0e21e 2738 else
79072805 2739 value = 0;
a0d0e21e
LW
2740 SETi(value);
2741 RETURN;
79072805 2742 }
85e6fe83
LW
2743}
2744
2745PP(pp_i_negate)
2746{
6f1401dc
DM
2747 dVAR; dSP; dTARGET;
2748 tryAMAGICun_MG(neg_amg, 0);
2749 {
2750 SV * const sv = TOPs;
2751 IV const i = SvIV_nomg(sv);
2752 SETi(-i);
2753 RETURN;
2754 }
85e6fe83
LW
2755}
2756
79072805
LW
2757/* High falutin' math. */
2758
2759PP(pp_atan2)
2760{
6f1401dc
DM
2761 dVAR; dSP; dTARGET;
2762 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2763 {
096c060c 2764 dPOPTOPnnrl_nomg;
a1021d57 2765 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2766 RETURN;
2767 }
79072805
LW
2768}
2769
2770PP(pp_sin)
2771{
71302fe3
NC
2772 dVAR; dSP; dTARGET;
2773 int amg_type = sin_amg;
2774 const char *neg_report = NULL;
bc81784a 2775 NV (*func)(NV) = Perl_sin;
71302fe3
NC
2776 const int op_type = PL_op->op_type;
2777
2778 switch (op_type) {
2779 case OP_COS:
2780 amg_type = cos_amg;
bc81784a 2781 func = Perl_cos;
71302fe3
NC
2782 break;
2783 case OP_EXP:
2784 amg_type = exp_amg;
bc81784a 2785 func = Perl_exp;
71302fe3
NC
2786 break;
2787 case OP_LOG:
2788 amg_type = log_amg;
bc81784a 2789 func = Perl_log;
71302fe3
NC
2790 neg_report = "log";
2791 break;
2792 case OP_SQRT:
2793 amg_type = sqrt_amg;
bc81784a 2794 func = Perl_sqrt;
71302fe3
NC
2795 neg_report = "sqrt";
2796 break;
a0d0e21e 2797 }
79072805 2798
6f1401dc
DM
2799
2800 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2801 {
6f1401dc
DM
2802 SV * const arg = POPs;
2803 const NV value = SvNV_nomg(arg);
71302fe3
NC
2804 if (neg_report) {
2805 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2806 SET_NUMERIC_STANDARD();
2807 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2808 }
2809 }
2810 XPUSHn(func(value));
a0d0e21e
LW
2811 RETURN;
2812 }
79072805
LW
2813}
2814
56cb0a1c
AD
2815/* Support Configure command-line overrides for rand() functions.
2816 After 5.005, perhaps we should replace this by Configure support
2817 for drand48(), random(), or rand(). For 5.005, though, maintain
2818 compatibility by calling rand() but allow the user to override it.
2819 See INSTALL for details. --Andy Dougherty 15 July 1998
2820*/
85ab1d1d
JH
2821/* Now it's after 5.005, and Configure supports drand48() and random(),
2822 in addition to rand(). So the overrides should not be needed any more.
2823 --Jarkko Hietaniemi 27 September 1998
2824 */
2825
2826#ifndef HAS_DRAND48_PROTO
20ce7b12 2827extern double drand48 (void);
56cb0a1c
AD
2828#endif
2829
79072805
LW
2830PP(pp_rand)
2831{
97aff369 2832 dVAR; dSP; dTARGET;
65202027 2833 NV value;
79072805
LW
2834 if (MAXARG < 1)
2835 value = 1.0;
2836 else
2837 value = POPn;
2838 if (value == 0.0)
2839 value = 1.0;
80252599 2840 if (!PL_srand_called) {
85ab1d1d 2841 (void)seedDrand01((Rand_seed_t)seed());
80252599 2842 PL_srand_called = TRUE;
93dc8474 2843 }
85ab1d1d 2844 value *= Drand01();
79072805
LW
2845 XPUSHn(value);
2846 RETURN;
2847}
2848
2849PP(pp_srand)
2850{
83832992 2851 dVAR; dSP; dTARGET;
0bd48802 2852 const UV anum = (MAXARG < 1) ? seed() : POPu;
85ab1d1d 2853 (void)seedDrand01((Rand_seed_t)anum);
80252599 2854 PL_srand_called = TRUE;
da1010ec
NC
2855 if (anum)
2856 XPUSHu(anum);
2857 else {
2858 /* Historically srand always returned true. We can avoid breaking
2859 that like this: */
2860 sv_setpvs(TARG, "0 but true");
2861 XPUSHTARG;
2862 }
83832992 2863 RETURN;
79072805
LW
2864}
2865
79072805
LW
2866PP(pp_int)
2867{
6f1401dc
DM
2868 dVAR; dSP; dTARGET;
2869 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2870 {
6f1401dc
DM
2871 SV * const sv = TOPs;
2872 const IV iv = SvIV_nomg(sv);
28e5dec8
JH
2873 /* XXX it's arguable that compiler casting to IV might be subtly
2874 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2875 else preferring IV has introduced a subtle behaviour change bug. OTOH
2876 relying on floating point to be accurate is a bug. */
2877
c781a409 2878 if (!SvOK(sv)) {
922c4365 2879 SETu(0);
c781a409
RD
2880 }
2881 else if (SvIOK(sv)) {
2882 if (SvIsUV(sv))
6f1401dc 2883 SETu(SvUV_nomg(sv));
c781a409 2884 else
28e5dec8 2885 SETi(iv);
c781a409 2886 }
c781a409 2887 else {
6f1401dc 2888 const NV value = SvNV_nomg(sv);
1048ea30 2889 if (value >= 0.0) {
28e5dec8
JH
2890 if (value < (NV)UV_MAX + 0.5) {
2891 SETu(U_V(value));
2892 } else {
059a1014 2893 SETn(Perl_floor(value));
28e5dec8 2894 }
1048ea30 2895 }
28e5dec8
JH
2896 else {
2897 if (value > (NV)IV_MIN - 0.5) {
2898 SETi(I_V(value));
2899 } else {
1bbae031 2900 SETn(Perl_ceil(value));
28e5dec8
JH
2901 }
2902 }
774d564b 2903 }
79072805 2904 }
79072805
LW
2905 RETURN;
2906}
2907
463ee0b2
LW
2908PP(pp_abs)
2909{
6f1401dc
DM
2910 dVAR; dSP; dTARGET;
2911 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 2912 {
6f1401dc 2913 SV * const sv = TOPs;
28e5dec8 2914 /* This will cache the NV value if string isn't actually integer */
6f1401dc 2915 const IV iv = SvIV_nomg(sv);
a227d84d 2916
800401ee 2917 if (!SvOK(sv)) {
922c4365 2918 SETu(0);
800401ee
JH
2919 }
2920 else if (SvIOK(sv)) {
28e5dec8 2921 /* IVX is precise */
800401ee 2922 if (SvIsUV(sv)) {
6f1401dc 2923 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH
2924 } else {
2925 if (iv >= 0) {
2926 SETi(iv);
2927 } else {
2928 if (iv != IV_MIN) {
2929 SETi(-iv);
2930 } else {
2931 /* 2s complement assumption. Also, not really needed as
2932 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2933 SETu(IV_MIN);
2934 }
a227d84d 2935 }
28e5dec8
JH
2936 }
2937 } else{
6f1401dc 2938 const NV value = SvNV_nomg(sv);
774d564b 2939 if (value < 0.0)
1b6737cc 2940 SETn(-value);
a4474c9e
DD
2941 else
2942 SETn(value);
774d564b 2943 }
a0d0e21e 2944 }
774d564b 2945 RETURN;
463ee0b2
LW
2946}
2947
79072805
LW
2948PP(pp_oct)
2949{
97aff369 2950 dVAR; dSP; dTARGET;
5c144d81 2951 const char *tmps;
53305cf1 2952 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2953 STRLEN len;
53305cf1
NC
2954 NV result_nv;
2955 UV result_uv;
1b6737cc 2956 SV* const sv = POPs;
79072805 2957
349d4f2f 2958 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
2959 if (DO_UTF8(sv)) {
2960 /* If Unicode, try to downgrade
2961 * If not possible, croak. */
1b6737cc 2962 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
2963
2964 SvUTF8_on(tsv);
2965 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2966 tmps = SvPV_const(tsv, len);
2bc69dc4 2967 }
daa2adfd
NC
2968 if (PL_op->op_type == OP_HEX)
2969 goto hex;
2970
6f894ead 2971 while (*tmps && len && isSPACE(*tmps))
53305cf1 2972 tmps++, len--;
9e24b6e2 2973 if (*tmps == '0')
53305cf1 2974 tmps++, len--;
a674e8db 2975 if (*tmps == 'x' || *tmps == 'X') {
daa2adfd 2976 hex:
53305cf1 2977 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 2978 }
a674e8db 2979 else if (*tmps == 'b' || *tmps == 'B')
53305cf1 2980 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2981 else
53305cf1
NC
2982 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2983
2984 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2985 XPUSHn(result_nv);
2986 }
2987 else {
2988 XPUSHu(result_uv);
2989 }
79072805
LW
2990 RETURN;
2991}
2992
2993/* String stuff. */
2994
2995PP(pp_length)
2996{
97aff369 2997 dVAR; dSP; dTARGET;
0bd48802 2998 SV * const sv = TOPs;
a0ed51b3 2999
656266fc 3000 if (SvGAMAGIC(sv)) {
9f621bb0
NC
3001 /* For an overloaded or magic scalar, we can't know in advance if
3002 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3003 it likes to cache the length. Maybe that should be a documented
3004 feature of it.
92331800
NC
3005 */
3006 STRLEN len;
9f621bb0
NC
3007 const char *const p
3008 = sv_2pv_flags(sv, &len,
3009 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
92331800 3010
d88e091f 3011 if (!p) {
9407f9c1
DL
3012 if (!SvPADTMP(TARG)) {
3013 sv_setsv(TARG, &PL_sv_undef);
3014 SETTARG;
3015 }
3016 SETs(&PL_sv_undef);
d88e091f 3017 }
9f621bb0 3018 else if (DO_UTF8(sv)) {
899be101 3019 SETi(utf8_length((U8*)p, (U8*)p + len));
92331800
NC
3020 }
3021 else
3022 SETi(len);
656266fc 3023 } else if (SvOK(sv)) {
9f621bb0
NC
3024 /* Neither magic nor overloaded. */
3025 if (DO_UTF8(sv))
3026 SETi(sv_len_utf8(sv));
3027 else
3028 SETi(sv_len(sv));
656266fc 3029 } else {
9407f9c1
DL
3030 if (!SvPADTMP(TARG)) {
3031 sv_setsv_nomg(TARG, &PL_sv_undef);
3032 SETTARG;
3033 }
3034 SETs(&PL_sv_undef);
92331800 3035 }
79072805
LW
3036 RETURN;
3037}
3038
3039PP(pp_substr)
3040{
97aff369 3041 dVAR; dSP; dTARGET;
79072805 3042 SV *sv;
463ee0b2 3043 STRLEN curlen;
9402d6ed 3044 STRLEN utf8_curlen;
777f7c56
EB
3045 SV * pos_sv;
3046 IV pos1_iv;
3047 int pos1_is_uv;
3048 IV pos2_iv;
3049 int pos2_is_uv;
3050 SV * len_sv;
3051 IV len_iv = 0;
3052 int len_is_uv = 1;
050e6362 3053 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
e1ec3a88 3054 const char *tmps;
777f7c56 3055 const IV arybase = CopARYBASE_get(PL_curcop);
9402d6ed 3056 SV *repl_sv = NULL;
cbbf8932 3057 const char *repl = NULL;
7b8d334a 3058 STRLEN repl_len;
050e6362 3059 const int num_args = PL_op->op_private & 7;
13e30c65 3060 bool repl_need_utf8_upgrade = FALSE;
9402d6ed 3061 bool repl_is_utf8 = FALSE;
79072805 3062
78f9721b
SM
3063 if (num_args > 2) {
3064 if (num_args > 3) {
9402d6ed 3065 repl_sv = POPs;
83003860 3066 repl = SvPV_const(repl_sv, repl_len);
9402d6ed 3067 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
7b8d334a 3068 }
777f7c56
EB
3069 len_sv = POPs;
3070 len_iv = SvIV(len_sv);
3071 len_is_uv = SvIOK_UV(len_sv);
5d82c453 3072 }
777f7c56
EB
3073 pos_sv = POPs;
3074 pos1_iv = SvIV(pos_sv);
3075 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3076 sv = POPs;
849ca7ee 3077 PUTBACK;
9402d6ed
JH
3078 if (repl_sv) {
3079 if (repl_is_utf8) {
3080 if (!DO_UTF8(sv))
3081 sv_utf8_upgrade(sv);
3082 }
13e30c65
JH
3083 else if (DO_UTF8(sv))
3084 repl_need_utf8_upgrade = TRUE;
9402d6ed 3085 }
5c144d81 3086 tmps = SvPV_const(sv, curlen);
7e2040f0 3087 if (DO_UTF8(sv)) {
9402d6ed
JH
3088 utf8_curlen = sv_len_utf8(sv);
3089 if (utf8_curlen == curlen)
3090 utf8_curlen = 0;
a0ed51b3 3091 else
9402d6ed 3092 curlen = utf8_curlen;
a0ed51b3 3093 }
d1c2b58a 3094 else
9402d6ed 3095 utf8_curlen = 0;
a0ed51b3 3096
777f7c56
EB
3097 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3098 UV pos1_uv = pos1_iv-arybase;
3099 /* Overflow can occur when $[ < 0 */
3100 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
1c900557 3101 goto bound_fail;
777f7c56
EB
3102 pos1_iv = pos1_uv;
3103 pos1_is_uv = 1;
3104 }
3105 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
1c900557 3106 goto bound_fail; /* $[=3; substr($_,2,...) */
777f7c56
EB
3107 }
3108 else { /* pos < $[ */
3109 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3110 pos1_iv = curlen;
3111 pos1_is_uv = 1;
3112 } else {
3113 if (curlen) {
3114 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3115 pos1_iv += curlen;
3116 }
5d82c453 3117 }
68dc0745 3118 }
777f7c56
EB
3119 if (pos1_is_uv || pos1_iv > 0) {
3120 if ((UV)pos1_iv > curlen)
1c900557 3121 goto bound_fail;
777f7c56
EB
3122 }
3123
3124 if (num_args > 2) {
3125 if (!len_is_uv && len_iv < 0) {
3126 pos2_iv = curlen + len_iv;
3127 if (curlen)
3128 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3129 else
3130 pos2_is_uv = 0;
3131 } else { /* len_iv >= 0 */
3132 if (!pos1_is_uv && pos1_iv < 0) {
3133 pos2_iv = pos1_iv + len_iv;
3134 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3135 } else {
3136 if ((UV)len_iv > curlen-(UV)pos1_iv)
3137 pos2_iv = curlen;
3138 else
3139 pos2_iv = pos1_iv+len_iv;
3140 pos2_is_uv = 1;
3141 }
5d82c453 3142 }
2304df62 3143 }
79072805 3144 else {
777f7c56
EB
3145 pos2_iv = curlen;
3146 pos2_is_uv = 1;
3147 }
3148
3149 if (!pos2_is_uv && pos2_iv < 0) {
3150 if (!pos1_is_uv && pos1_iv < 0)
1c900557 3151 goto bound_fail;
777f7c56
EB
3152 pos2_iv = 0;
3153 }
3154 else if (!pos1_is_uv && pos1_iv < 0)
3155 pos1_iv = 0;
3156
3157 if ((UV)pos2_iv < (UV)pos1_iv)
3158 pos2_iv = pos1_iv;
3159 if ((UV)pos2_iv > curlen)
3160 pos2_iv = curlen;
3161
3162 {
3163 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3164 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3165 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
777f7c56 3166 STRLEN byte_len = len;
d931b1be
NC
3167 STRLEN byte_pos = utf8_curlen
3168 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3169
2154eca7
EB
3170 if (lvalue && !repl) {
3171 SV * ret;
3172
3173 if (!SvGMAGICAL(sv)) {
3174 if (SvROK(sv)) {
3175 SvPV_force_nolen(sv);
3176 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3177 "Attempt to use reference as lvalue in substr");
3178 }
3179 if (isGV_with_GP(sv))
3180 SvPV_force_nolen(sv);
3181 else if (SvOK(sv)) /* is it defined ? */
3182 (void)SvPOK_only_UTF8(sv);
3183 else
3184 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
781e7547 3185 }
2154eca7
EB
3186
3187 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3188 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3189 LvTYPE(ret) = 'x';
3190 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3191 LvTARGOFF(ret) = pos;
3192 LvTARGLEN(ret) = len;
3193
3194 SPAGAIN;
3195 PUSHs(ret); /* avoid SvSETMAGIC here */
3196 RETURN;
781e7547
DM
3197 }
3198
2154eca7
EB
3199 SvTAINTED_off(TARG); /* decontaminate */
3200 SvUTF8_off(TARG); /* decontaminate */
3201
3202 tmps += byte_pos;
777f7c56 3203 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3204#ifdef USE_LOCALE_COLLATE
14befaf4 3205 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3206#endif
9402d6ed 3207 if (utf8_curlen)
7f66633b 3208 SvUTF8_on(TARG);
2154eca7 3209
f7928d6c 3210 if (repl) {
13e30c65
JH
3211 SV* repl_sv_copy = NULL;
3212
3213 if (repl_need_utf8_upgrade) {
3214 repl_sv_copy = newSVsv(repl_sv);
3215 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3216 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65
JH
3217 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3218 }
502d9230
VP
3219 if (!SvOK(sv))
3220 sv_setpvs(sv, "");
777f7c56 3221 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
9402d6ed 3222 if (repl_is_utf8)
f7928d6c 3223 SvUTF8_on(sv);
ef8d46e8 3224 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3225 }
79072805 3226 }
849ca7ee 3227 SPAGAIN;
e27c778f
FC
3228 SvSETMAGIC(TARG);
3229 PUSHs(TARG);
79072805 3230 RETURN;
777f7c56 3231
1c900557 3232bound_fail:
777f7c56
EB
3233 if (lvalue || repl)
3234 Perl_croak(aTHX_ "substr outside of string");
3235 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3236 RETPUSHUNDEF;
79072805
LW
3237}
3238
3239PP(pp_vec)
3240{
2154eca7 3241 dVAR; dSP;
1b6737cc
AL
3242 register const IV size = POPi;
3243 register const IV offset = POPi;
3244 register SV * const src = POPs;
3245 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3246 SV * ret;
a0d0e21e 3247
81e118e0 3248 if (lvalue) { /* it's an lvalue! */
2154eca7
EB
3249 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3250 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3251 LvTYPE(ret) = 'v';
3252 LvTARG(ret) = SvREFCNT_inc_simple(src);
3253 LvTARGOFF(ret) = offset;
3254 LvTARGLEN(ret) = size;
3255 }
3256 else {
3257 dTARGET;
3258 SvTAINTED_off(TARG); /* decontaminate */
3259 ret = TARG;
79072805
LW
3260 }
3261
2154eca7
EB
3262 sv_setuv(ret, do_vecget(src, offset, size));
3263 PUSHs(ret);
79072805
LW
3264 RETURN;
3265}
3266
3267PP(pp_index)
3268{
97aff369 3269 dVAR; dSP; dTARGET;
79072805
LW
3270 SV *big;
3271 SV *little;
c445ea15 3272 SV *temp = NULL;
ad66a58c 3273 STRLEN biglen;
2723d216 3274 STRLEN llen = 0;
79072805
LW
3275 I32 offset;
3276 I32 retval;
73ee8be2
NC
3277 const char *big_p;
3278 const char *little_p;
fc15ae8f 3279 const I32 arybase = CopARYBASE_get(PL_curcop);
2f040f7f
NC
3280 bool big_utf8;
3281 bool little_utf8;
2723d216 3282 const bool is_index = PL_op->op_type == OP_INDEX;
79072805 3283
2723d216
NC
3284 if (MAXARG >= 3) {
3285 /* arybase is in characters, like offset, so combine prior to the
3286 UTF-8 to bytes calculation. */
79072805 3287 offset = POPi - arybase;
2723d216 3288 }
79072805
LW
3289 little = POPs;
3290 big = POPs;
73ee8be2
NC
3291 big_p = SvPV_const(big, biglen);
3292 little_p = SvPV_const(little, llen);
3293
e609e586
NC
3294 big_utf8 = DO_UTF8(big);
3295 little_utf8 = DO_UTF8(little);
3296 if (big_utf8 ^ little_utf8) {
3297 /* One needs to be upgraded. */
2f040f7f
NC
3298 if (little_utf8 && !PL_encoding) {
3299 /* Well, maybe instead we might be able to downgrade the small
3300 string? */
1eced8f8 3301 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC
3302 &little_utf8);
3303 if (little_utf8) {
3304 /* If the large string is ISO-8859-1, and it's not possible to
3305 convert the small string to ISO-8859-1, then there is no
3306 way that it could be found anywhere by index. */
3307 retval = -1;
3308 goto fail;
3309 }
e609e586 3310
2f040f7f
NC
3311 /* At this point, pv is a malloc()ed string. So donate it to temp
3312 to ensure it will get free()d */
3313 little = temp = newSV(0);
73ee8be2
NC
3314 sv_usepvn(temp, pv, llen);
3315 little_p = SvPVX(little);
e609e586 3316 } else {
73ee8be2
NC
3317 temp = little_utf8
3318 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f
NC
3319
3320 if (PL_encoding) {
3321 sv_recode_to_utf8(temp, PL_encoding);
3322 } else {
3323 sv_utf8_upgrade(temp);
3324 }
3325 if (little_utf8) {
3326 big = temp;
3327 big_utf8 = TRUE;
73ee8be2 3328 big_p = SvPV_const(big, biglen);
2f040f7f
NC
3329 } else {
3330 little = temp;
73ee8be2 3331 little_p = SvPV_const(little, llen);
2f040f7f 3332 }
e609e586
NC
3333 }
3334 }
73ee8be2
NC
3335 if (SvGAMAGIC(big)) {
3336 /* Life just becomes a lot easier if I use a temporary here.
3337 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3338 will trigger magic and overloading again, as will fbm_instr()
3339 */
59cd0e26
NC
3340 big = newSVpvn_flags(big_p, biglen,
3341 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3342 big_p = SvPVX(big);
3343 }
e4e44778 3344 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC
3345 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3346 warn on undef, and we've already triggered a warning with the
3347 SvPV_const some lines above. We can't remove that, as we need to
3348 call some SvPV to trigger overloading early and find out if the
3349 string is UTF-8.
3350 This is all getting to messy. The API isn't quite clean enough,
3351 because data access has side effects.
3352 */
59cd0e26
NC
3353 little = newSVpvn_flags(little_p, llen,
3354 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3355 little_p = SvPVX(little);
3356 }
e609e586 3357
79072805 3358 if (MAXARG < 3)
2723d216 3359 offset = is_index ? 0 : biglen;
a0ed51b3 3360 else {
ad66a58c 3361 if (big_utf8 && offset > 0)
a0ed51b3 3362 sv_pos_u2b(big, &offset, 0);
73ee8be2
NC
3363 if (!is_index)
3364 offset += llen;
a0ed51b3 3365 }
79072805
LW
3366 if (offset < 0)
3367 offset = 0;
ad66a58c
NC
3368 else if (offset > (I32)biglen)
3369 offset = biglen;
73ee8be2
NC
3370 if (!(little_p = is_index
3371 ? fbm_instr((unsigned char*)big_p + offset,
3372 (unsigned char*)big_p + biglen, little, 0)
3373 : rninstr(big_p, big_p + offset,
3374 little_p, little_p + llen)))
a0ed51b3 3375 retval = -1;
ad66a58c 3376 else {
73ee8be2 3377 retval = little_p - big_p;
ad66a58c
NC
3378 if (retval > 0 && big_utf8)
3379 sv_pos_b2u(big, &retval);
3380 }
ef8d46e8 3381 SvREFCNT_dec(temp);
2723d216 3382 fail:
a0ed51b3 3383 PUSHi(retval + arybase);
79072805
LW
3384 RETURN;
3385}
3386
3387PP(pp_sprintf)
3388{
97aff369 3389 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3390 SvTAINTED_off(TARG);
79072805 3391 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3392 TAINT_IF(SvTAINTED(TARG));
79072805
LW
3393 SP = ORIGMARK;
3394 PUSHTARG;
3395 RETURN;
3396}
3397
79072805
LW
3398PP(pp_ord)
3399{
97aff369 3400 dVAR; dSP; dTARGET;
1eced8f8 3401
7df053ec 3402 SV *argsv = POPs;
ba210ebe 3403 STRLEN len;
349d4f2f 3404 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3405
799ef3cb 3406 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3407 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3408 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH
3409 argsv = tmpsv;
3410 }
79072805 3411
872c91ae 3412 XPUSHu(DO_UTF8(argsv) ?
89ebb4a3 3413 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
5fc32dea 3414 (UV)(*s & 0xff));
68795e93 3415
79072805
LW
3416 RETURN;
3417}
3418
463ee0b2
LW
3419PP(pp_chr)
3420{
97aff369 3421 dVAR; dSP; dTARGET;
463ee0b2 3422 char *tmps;
8a064bd6
JH
3423 UV value;
3424
3425 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3426 ||
3427 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3428 if (IN_BYTES) {
3429 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3430 } else {
3431 (void) POPs; /* Ignore the argument value. */
3432 value = UNICODE_REPLACEMENT;
3433 }
3434 } else {
3435 value = POPu;
3436 }
463ee0b2 3437
862a34c6 3438 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3439
0064a8a9 3440 if (value > 255 && !IN_BYTES) {
eb160463 3441 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3442 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3443 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW
3444 *tmps = '\0';
3445 (void)SvPOK_only(TARG);
aa6ffa16 3446 SvUTF8_on(TARG);
a0ed51b3
LW
3447 XPUSHs(TARG);
3448 RETURN;
3449 }
3450
748a9306 3451 SvGROW(TARG,2);
463ee0b2
LW
3452 SvCUR_set(TARG, 1);
3453 tmps = SvPVX(TARG);
eb160463 3454 *tmps++ = (char)value;
748a9306 3455 *tmps = '\0';
a0d0e21e 3456 (void)SvPOK_only(TARG);
4c5ed6e2 3457
88632417 3458 if (PL_encoding && !IN_BYTES) {
799ef3cb 3459 sv_recode_to_utf8(TARG, PL_encoding);
88632417
JH
3460 tmps = SvPVX(TARG);
3461 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
4c5ed6e2
ST
3462 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3463 SvGROW(TARG, 2);
d5a15ac2 3464 tmps = SvPVX(TARG);
4c5ed6e2
ST
3465 SvCUR_set(TARG, 1);
3466 *tmps++ = (char)value;
88632417 3467 *tmps = '\0';
4c5ed6e2 3468 SvUTF8_off(TARG);
88632417
JH
3469 }
3470 }
4c5ed6e2 3471
463ee0b2
LW
3472 XPUSHs(TARG);
3473 RETURN;
3474}
3475
79072805
LW
3476PP(pp_crypt)
3477{
79072805 3478#ifdef HAS_CRYPT
97aff369 3479 dVAR; dSP; dTARGET;
5f74f29c 3480 dPOPTOPssrl;
85c16d83 3481 STRLEN len;
10516c54 3482 const char *tmps = SvPV_const(left, len);
2bc69dc4 3483
85c16d83 3484 if (DO_UTF8(left)) {
2bc69dc4 3485 /* If Unicode, try to downgrade.
f2791508
JH
3486 * If not possible, croak.
3487 * Yes, we made this up. */
1b6737cc 3488 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3489
f2791508 3490 SvUTF8_on(tsv);
2bc69dc4 3491 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3492 tmps = SvPV_const(tsv, len);
85c16d83 3493 }
05404ffe
JH
3494# ifdef USE_ITHREADS
3495# ifdef HAS_CRYPT_R
3496 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3497 /* This should be threadsafe because in ithreads there is only
3498 * one thread per interpreter. If this would not be true,
3499 * we would need a mutex to protect this malloc. */
3500 PL_reentrant_buffer->_crypt_struct_buffer =
3501 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3502#if defined(__GLIBC__) || defined(__EMX__)
3503 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3504 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3505 /* work around glibc-2.2.5 bug */
3506 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3507 }
05404ffe 3508#endif
6ab58e4d 3509 }
05404ffe
JH
3510# endif /* HAS_CRYPT_R */
3511# endif /* USE_ITHREADS */
5f74f29c 3512# ifdef FCRYPT
83003860 3513 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3514# else
83003860 3515 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3516# endif
ec93b65f 3517 SETTARG;
4808266b 3518 RETURN;
79072805 3519#else
b13b2135 3520 DIE(aTHX_
79072805
LW
3521 "The crypt() function is unimplemented due to excessive paranoia.");
3522#endif
79072805
LW
3523}
3524
00f254e2
KW
3525/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3526 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3527
00f254e2
KW
3528/* Below are several macros that generate code */
3529/* Generates code to store a unicode codepoint c that is known to occupy
3530 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3531#define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3532 STMT_START { \
3533 *(p) = UTF8_TWO_BYTE_HI(c); \
3534 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3535 } STMT_END
3536
3537/* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3538 * available byte after the two bytes */
3539#define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3540 STMT_START { \
3541 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3542 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3543 } STMT_END
3544
3545/* Generates code to store the upper case of latin1 character l which is known
3546 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3547 * are only two characters that fit this description, and this macro knows
3548 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3549 * bytes */
3550#define STORE_NON_LATIN1_UC(p, l) \
3551STMT_START { \
3552 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3553 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3554 } else { /* Must be the following letter */ \
3555 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3556 } \
3557} STMT_END
3558
3559/* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3560 * after the character stored */
3561#define CAT_NON_LATIN1_UC(p, l) \
3562STMT_START { \
3563 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3564 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3565 } else { \
3566 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3567 } \
3568} STMT_END
3569
3570/* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3571 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3572 * and must require two bytes to store it. Advances p to point to the next
3573 * available position */
3574#define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3575STMT_START { \
3576 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3577 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3578 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3579 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3580 } else {/* else is one of the other two special cases */ \
3581 CAT_NON_LATIN1_UC((p), (l)); \
3582 } \
3583} STMT_END
3584
79072805
LW
3585PP(pp_ucfirst)
3586{
00f254e2
KW
3587 /* Actually is both lcfirst() and ucfirst(). Only the first character
3588 * changes. This means that possibly we can change in-place, ie., just
3589 * take the source and change that one character and store it back, but not
3590 * if read-only etc, or if the length changes */
3591
97aff369 3592 dVAR;
39644a26 3593 dSP;
d54190f6 3594 SV *source = TOPs;
00f254e2 3595 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC
3596 STRLEN need;
3597 SV *dest;
00f254e2
KW
3598 bool inplace; /* ? Convert first char only, in-place */
3599 bool doing_utf8 = FALSE; /* ? using utf8 */
3600 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3601 const int op_type = PL_op->op_type;
d54190f6
NC
3602 const U8 *s;
3603 U8 *d;
3604 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW
3605 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3606 * stored as UTF-8 at s. */
3607 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3608 * lowercased) character stored in tmpbuf. May be either
3609 * UTF-8 or not, but in either case is the number of bytes */
d54190f6
NC
3610
3611 SvGETMAGIC(source);
3612 if (SvOK(source)) {
3613 s = (const U8*)SvPV_nomg_const(source, slen);
3614 } else {
0a0ffbce
RGS
3615 if (ckWARN(WARN_UNINITIALIZED))
3616 report_uninit(source);
1eced8f8 3617 s = (const U8*)"";
d54190f6
NC
3618 slen = 0;
3619 }
a0ed51b3 3620
00f254e2
KW
3621 /* We may be able to get away with changing only the first character, in
3622 * place, but not if read-only, etc. Later we may discover more reasons to
3623 * not convert in-place. */
3624 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3625
3626 /* First calculate what the changed first character should be. This affects
3627 * whether we can just swap it out, leaving the rest of the string unchanged,
3628 * or even if have to convert the dest to UTF-8 when the source isn't */
3629
3630 if (! slen) { /* If empty */
3631 need = 1; /* still need a trailing NUL */
3632 }
3633 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3634 doing_utf8 = TRUE;
00f254e2
KW
3635
3636/* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3637 * and doesn't allow for the user to specify their own. When code is added to
3638 * detect if there is a user-defined mapping in force here, and if so to use
3639 * that, then the code below can be compiled. The detection would be a good
3640 * thing anyway, as currently the user-defined mappings only work on utf8
3641 * strings, and thus depend on the chosen internal storage method, which is a
3642 * bad thing */
3643#ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3644 if (UTF8_IS_INVARIANT(*s)) {
3645
3646 /* An invariant source character is either ASCII or, in EBCDIC, an
3647 * ASCII equivalent or a caseless C1 control. In both these cases,
3648 * the lower and upper cases of any character are also invariants
3649 * (and title case is the same as upper case). So it is safe to
3650 * use the sim