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