This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make warn handle magic vars (fixes [perl #97480])
[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. */
58d76dfd 1027 {
6f1401dc 1028 SvIV_please_nomg(svr);
800401ee 1029 if (SvIOK(svr)) {
6f1401dc 1030 SvIV_please_nomg(svl);
800401ee 1031 if (SvIOK(svl)) {
900658e3
PF
1032 UV power;
1033 bool baseuok;
1034 UV baseuv;
1035
800401ee
JH
1036 if (SvUOK(svr)) {
1037 power = SvUVX(svr);
900658e3 1038 } else {
800401ee 1039 const IV iv = SvIVX(svr);
900658e3
PF
1040 if (iv >= 0) {
1041 power = iv;
1042 } else {
1043 goto float_it; /* Can't do negative powers this way. */
1044 }
1045 }
1046
800401ee 1047 baseuok = SvUOK(svl);
900658e3 1048 if (baseuok) {
800401ee 1049 baseuv = SvUVX(svl);
900658e3 1050 } else {
800401ee 1051 const IV iv = SvIVX(svl);
900658e3
PF
1052 if (iv >= 0) {
1053 baseuv = iv;
1054 baseuok = TRUE; /* effectively it's a UV now */
1055 } else {
1056 baseuv = -iv; /* abs, baseuok == false records sign */
1057 }
1058 }
52a96ae6
HS
1059 /* now we have integer ** positive integer. */
1060 is_int = 1;
1061
1062 /* foo & (foo - 1) is zero only for a power of 2. */
58d76dfd 1063 if (!(baseuv & (baseuv - 1))) {
52a96ae6 1064 /* We are raising power-of-2 to a positive integer.
58d76dfd
JH
1065 The logic here will work for any base (even non-integer
1066 bases) but it can be less accurate than
1067 pow (base,power) or exp (power * log (base)) when the
1068 intermediate values start to spill out of the mantissa.
1069 With powers of 2 we know this can't happen.
1070 And powers of 2 are the favourite thing for perl
1071 programmers to notice ** not doing what they mean. */
1072 NV result = 1.0;
1073 NV base = baseuok ? baseuv : -(NV)baseuv;
900658e3
PF
1074
1075 if (power & 1) {
1076 result *= base;
1077 }
1078 while (power >>= 1) {
1079 base *= base;
1080 if (power & 1) {
1081 result *= base;
1082 }
1083 }
58d76dfd
JH
1084 SP--;
1085 SETn( result );
6f1401dc 1086 SvIV_please_nomg(svr);
58d76dfd 1087 RETURN;
52a96ae6
HS
1088 } else {
1089 register unsigned int highbit = 8 * sizeof(UV);
900658e3
PF
1090 register unsigned int diff = 8 * sizeof(UV);
1091 while (diff >>= 1) {
1092 highbit -= diff;
1093 if (baseuv >> highbit) {
1094 highbit += diff;
1095 }
52a96ae6
HS
1096 }
1097 /* we now have baseuv < 2 ** highbit */
1098 if (power * highbit <= 8 * sizeof(UV)) {
1099 /* result will definitely fit in UV, so use UV math
1100 on same algorithm as above */
1101 register UV result = 1;
1102 register UV base = baseuv;
f2338a2e 1103 const bool odd_power = cBOOL(power & 1);
900658e3
PF
1104 if (odd_power) {
1105 result *= base;
1106 }
1107 while (power >>= 1) {
1108 base *= base;
1109 if (power & 1) {
52a96ae6 1110 result *= base;
52a96ae6
HS
1111 }
1112 }
1113 SP--;
0615a994 1114 if (baseuok || !odd_power)
52a96ae6
HS
1115 /* answer is positive */
1116 SETu( result );
1117 else if (result <= (UV)IV_MAX)
1118 /* answer negative, fits in IV */
1119 SETi( -(IV)result );
1120 else if (result == (UV)IV_MIN)
1121 /* 2's complement assumption: special case IV_MIN */
1122 SETi( IV_MIN );
1123 else
1124 /* answer negative, doesn't fit */
1125 SETn( -(NV)result );
1126 RETURN;
1127 }
1128 }
1129 }
1130 }
58d76dfd 1131 }
52a96ae6 1132 float_it:
58d76dfd 1133#endif
a0d0e21e 1134 {
6f1401dc
DM
1135 NV right = SvNV_nomg(svr);
1136 NV left = SvNV_nomg(svl);
4efa5a16 1137 (void)POPs;
3aaeb624
JA
1138
1139#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1140 /*
1141 We are building perl with long double support and are on an AIX OS
1142 afflicted with a powl() function that wrongly returns NaNQ for any
1143 negative base. This was reported to IBM as PMR #23047-379 on
1144 03/06/2006. The problem exists in at least the following versions
1145 of AIX and the libm fileset, and no doubt others as well:
1146
1147 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1148 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1149 AIX 5.2.0 bos.adt.libm 5.2.0.85
1150
1151 So, until IBM fixes powl(), we provide the following workaround to
1152 handle the problem ourselves. Our logic is as follows: for
1153 negative bases (left), we use fmod(right, 2) to check if the
1154 exponent is an odd or even integer:
1155
1156 - if odd, powl(left, right) == -powl(-left, right)
1157 - if even, powl(left, right) == powl(-left, right)
1158
1159 If the exponent is not an integer, the result is rightly NaNQ, so
1160 we just return that (as NV_NAN).
1161 */
1162
1163 if (left < 0.0) {
1164 NV mod2 = Perl_fmod( right, 2.0 );
1165 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1166 SETn( -Perl_pow( -left, right) );
1167 } else if (mod2 == 0.0) { /* even integer */
1168 SETn( Perl_pow( -left, right) );
1169 } else { /* fractional power */
1170 SETn( NV_NAN );
1171 }
1172 } else {
1173 SETn( Perl_pow( left, right) );
1174 }
1175#else
52a96ae6 1176 SETn( Perl_pow( left, right) );
3aaeb624
JA
1177#endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1178
52a96ae6
HS
1179#ifdef PERL_PRESERVE_IVUV
1180 if (is_int)
6f1401dc 1181 SvIV_please_nomg(svr);
52a96ae6
HS
1182#endif
1183 RETURN;
93a17b20 1184 }
a0d0e21e
LW
1185}
1186
1187PP(pp_multiply)
1188{
800401ee 1189 dVAR; dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM
1190 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1191 svr = TOPs;
1192 svl = TOPm1s;
28e5dec8 1193#ifdef PERL_PRESERVE_IVUV
6f1401dc 1194 SvIV_please_nomg(svr);
800401ee 1195 if (SvIOK(svr)) {
28e5dec8
JH
1196 /* Unless the left argument is integer in range we are going to have to
1197 use NV maths. Hence only attempt to coerce the right argument if
1198 we know the left is integer. */
1199 /* Left operand is defined, so is it IV? */
6f1401dc 1200 SvIV_please_nomg(svl);
800401ee
JH
1201 if (SvIOK(svl)) {
1202 bool auvok = SvUOK(svl);
1203 bool buvok = SvUOK(svr);
28e5dec8
JH
1204 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1205 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1206 UV alow;
1207 UV ahigh;
1208 UV blow;
1209 UV bhigh;
1210
1211 if (auvok) {
800401ee 1212 alow = SvUVX(svl);
28e5dec8 1213 } else {
800401ee 1214 const IV aiv = SvIVX(svl);
28e5dec8
JH
1215 if (aiv >= 0) {
1216 alow = aiv;
1217 auvok = TRUE; /* effectively it's a UV now */
1218 } else {
1219 alow = -aiv; /* abs, auvok == false records sign */
1220 }
1221 }
1222 if (buvok) {
800401ee 1223 blow = SvUVX(svr);
28e5dec8 1224 } else {
800401ee 1225 const IV biv = SvIVX(svr);
28e5dec8
JH
1226 if (biv >= 0) {
1227 blow = biv;
1228 buvok = TRUE; /* effectively it's a UV now */
1229 } else {
1230 blow = -biv; /* abs, buvok == false records sign */
1231 }
1232 }
1233
1234 /* If this does sign extension on unsigned it's time for plan B */
1235 ahigh = alow >> (4 * sizeof (UV));
1236 alow &= botmask;
1237 bhigh = blow >> (4 * sizeof (UV));
1238 blow &= botmask;
1239 if (ahigh && bhigh) {
6f207bd3 1240 NOOP;
28e5dec8
JH
1241 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1242 which is overflow. Drop to NVs below. */
1243 } else if (!ahigh && !bhigh) {
1244 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1245 so the unsigned multiply cannot overflow. */
c445ea15 1246 const UV product = alow * blow;
28e5dec8
JH
1247 if (auvok == buvok) {
1248 /* -ve * -ve or +ve * +ve gives a +ve result. */
1249 SP--;
1250 SETu( product );
1251 RETURN;
1252 } else if (product <= (UV)IV_MIN) {
1253 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1254 /* -ve result, which could overflow an IV */
1255 SP--;
25716404 1256 SETi( -(IV)product );
28e5dec8
JH
1257 RETURN;
1258 } /* else drop to NVs below. */
1259 } else {
1260 /* One operand is large, 1 small */
1261 UV product_middle;
1262 if (bhigh) {
1263 /* swap the operands */
1264 ahigh = bhigh;
1265 bhigh = blow; /* bhigh now the temp var for the swap */
1266 blow = alow;
1267 alow = bhigh;
1268 }
1269 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1270 multiplies can't overflow. shift can, add can, -ve can. */
1271 product_middle = ahigh * blow;
1272 if (!(product_middle & topmask)) {
1273 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1274 UV product_low;
1275 product_middle <<= (4 * sizeof (UV));
1276 product_low = alow * blow;
1277
1278 /* as for pp_add, UV + something mustn't get smaller.
1279 IIRC ANSI mandates this wrapping *behaviour* for
1280 unsigned whatever the actual representation*/
1281 product_low += product_middle;
1282 if (product_low >= product_middle) {
1283 /* didn't overflow */
1284 if (auvok == buvok) {
1285 /* -ve * -ve or +ve * +ve gives a +ve result. */
1286 SP--;
1287 SETu( product_low );
1288 RETURN;
1289 } else if (product_low <= (UV)IV_MIN) {
1290 /* 2s complement assumption again */
1291 /* -ve result, which could overflow an IV */
1292 SP--;
25716404 1293 SETi( -(IV)product_low );
28e5dec8
JH
1294 RETURN;
1295 } /* else drop to NVs below. */
1296 }
1297 } /* product_middle too large */
1298 } /* ahigh && bhigh */
800401ee
JH
1299 } /* SvIOK(svl) */
1300 } /* SvIOK(svr) */
28e5dec8 1301#endif
a0d0e21e 1302 {
6f1401dc
DM
1303 NV right = SvNV_nomg(svr);
1304 NV left = SvNV_nomg(svl);
4efa5a16 1305 (void)POPs;
a0d0e21e
LW
1306 SETn( left * right );
1307 RETURN;
79072805 1308 }
a0d0e21e
LW
1309}
1310
1311PP(pp_divide)
1312{
800401ee 1313 dVAR; dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM
1314 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1315 svr = TOPs;
1316 svl = TOPm1s;
5479d192 1317 /* Only try to do UV divide first
68795e93 1318 if ((SLOPPYDIVIDE is true) or
5479d192
NC
1319 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1320 to preserve))
1321 The assumption is that it is better to use floating point divide
1322 whenever possible, only doing integer divide first if we can't be sure.
1323 If NV_PRESERVES_UV is true then we know at compile time that no UV
1324 can be too large to preserve, so don't need to compile the code to
1325 test the size of UVs. */
1326
a0d0e21e 1327#ifdef SLOPPYDIVIDE
5479d192
NC
1328# define PERL_TRY_UV_DIVIDE
1329 /* ensure that 20./5. == 4. */
a0d0e21e 1330#else
5479d192
NC
1331# ifdef PERL_PRESERVE_IVUV
1332# ifndef NV_PRESERVES_UV
1333# define PERL_TRY_UV_DIVIDE
1334# endif
1335# endif
a0d0e21e 1336#endif
5479d192
NC
1337
1338#ifdef PERL_TRY_UV_DIVIDE
6f1401dc 1339 SvIV_please_nomg(svr);
800401ee 1340 if (SvIOK(svr)) {
6f1401dc 1341 SvIV_please_nomg(svl);
800401ee
JH
1342 if (SvIOK(svl)) {
1343 bool left_non_neg = SvUOK(svl);
1344 bool right_non_neg = SvUOK(svr);
5479d192
NC
1345 UV left;
1346 UV right;
1347
1348 if (right_non_neg) {
800401ee 1349 right = SvUVX(svr);
5479d192
NC
1350 }
1351 else {
800401ee 1352 const IV biv = SvIVX(svr);
5479d192
NC
1353 if (biv >= 0) {
1354 right = biv;
1355 right_non_neg = TRUE; /* effectively it's a UV now */
1356 }
1357 else {
1358 right = -biv;
1359 }
1360 }
1361 /* historically undef()/0 gives a "Use of uninitialized value"
1362 warning before dieing, hence this test goes here.
1363 If it were immediately before the second SvIV_please, then
1364 DIE() would be invoked before left was even inspected, so
486ec47a 1365 no inspection would give no warning. */
5479d192
NC
1366 if (right == 0)
1367 DIE(aTHX_ "Illegal division by zero");
1368
1369 if (left_non_neg) {
800401ee 1370 left = SvUVX(svl);
5479d192
NC
1371 }
1372 else {
800401ee 1373 const IV aiv = SvIVX(svl);
5479d192
NC
1374 if (aiv >= 0) {
1375 left = aiv;
1376 left_non_neg = TRUE; /* effectively it's a UV now */
1377 }
1378 else {
1379 left = -aiv;
1380 }
1381 }
1382
1383 if (left >= right
1384#ifdef SLOPPYDIVIDE
1385 /* For sloppy divide we always attempt integer division. */
1386#else
1387 /* Otherwise we only attempt it if either or both operands
1388 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC
1389 we fall through to the NV divide code below. However,
1390 as left >= right to ensure integer result here, we know that
1391 we can skip the test on the right operand - right big
1392 enough not to be preserved can't get here unless left is
1393 also too big. */
1394
1395 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC
1396#endif
1397 ) {
1398 /* Integer division can't overflow, but it can be imprecise. */
1b6737cc 1399 const UV result = left / right;
5479d192
NC
1400 if (result * right == left) {
1401 SP--; /* result is valid */
1402 if (left_non_neg == right_non_neg) {
1403 /* signs identical, result is positive. */
1404 SETu( result );
1405 RETURN;
1406 }
1407 /* 2s complement assumption */
1408 if (result <= (UV)IV_MIN)
91f3b821 1409 SETi( -(IV)result );
5479d192
NC
1410 else {
1411 /* It's exact but too negative for IV. */
1412 SETn( -(NV)result );
1413 }
1414 RETURN;
1415 } /* tried integer divide but it was not an integer result */
32fdb065 1416 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
5479d192
NC
1417 } /* left wasn't SvIOK */
1418 } /* right wasn't SvIOK */
1419#endif /* PERL_TRY_UV_DIVIDE */
1420 {
6f1401dc
DM
1421 NV right = SvNV_nomg(svr);
1422 NV left = SvNV_nomg(svl);
4efa5a16 1423 (void)POPs;(void)POPs;
ebc6a117
PD
1424#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1425 if (! Perl_isnan(right) && right == 0.0)
1426#else
5479d192 1427 if (right == 0.0)
ebc6a117 1428#endif
5479d192
NC
1429 DIE(aTHX_ "Illegal division by zero");
1430 PUSHn( left / right );
1431 RETURN;
79072805 1432 }
a0d0e21e
LW
1433}
1434
1435PP(pp_modulo)
1436{
6f1401dc
DM
1437 dVAR; dSP; dATARGET;
1438 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
a0d0e21e 1439 {
9c5ffd7c
JH
1440 UV left = 0;
1441 UV right = 0;
dc656993
JH
1442 bool left_neg = FALSE;
1443 bool right_neg = FALSE;
e2c88acc
NC
1444 bool use_double = FALSE;
1445 bool dright_valid = FALSE;
9c5ffd7c
JH
1446 NV dright = 0.0;
1447 NV dleft = 0.0;
6f1401dc
DM
1448 SV * const svr = TOPs;
1449 SV * const svl = TOPm1s;
1450 SvIV_please_nomg(svr);
800401ee
JH
1451 if (SvIOK(svr)) {
1452 right_neg = !SvUOK(svr);
e2c88acc 1453 if (!right_neg) {
800401ee 1454 right = SvUVX(svr);
e2c88acc 1455 } else {
800401ee 1456 const IV biv = SvIVX(svr);
e2c88acc
NC
1457 if (biv >= 0) {
1458 right = biv;
1459 right_neg = FALSE; /* effectively it's a UV now */
1460 } else {
1461 right = -biv;
1462 }
1463 }
1464 }
1465 else {
6f1401dc 1466 dright = SvNV_nomg(svr);
787eafbd
IZ
1467 right_neg = dright < 0;
1468 if (right_neg)
1469 dright = -dright;
e2c88acc
NC
1470 if (dright < UV_MAX_P1) {
1471 right = U_V(dright);
1472 dright_valid = TRUE; /* In case we need to use double below. */
1473 } else {
1474 use_double = TRUE;
1475 }
787eafbd 1476 }
a0d0e21e 1477
e2c88acc
NC
1478 /* At this point use_double is only true if right is out of range for
1479 a UV. In range NV has been rounded down to nearest UV and
1480 use_double false. */
6f1401dc 1481 SvIV_please_nomg(svl);
800401ee
JH
1482 if (!use_double && SvIOK(svl)) {
1483 if (SvIOK(svl)) {
1484 left_neg = !SvUOK(svl);
e2c88acc 1485 if (!left_neg) {
800401ee 1486 left = SvUVX(svl);
e2c88acc 1487 } else {
800401ee 1488 const IV aiv = SvIVX(svl);
e2c88acc
NC
1489 if (aiv >= 0) {
1490 left = aiv;
1491 left_neg = FALSE; /* effectively it's a UV now */
1492 } else {
1493 left = -aiv;
1494 }
1495 }
1496 }
1497 }
787eafbd 1498 else {
6f1401dc 1499 dleft = SvNV_nomg(svl);
787eafbd
IZ
1500 left_neg = dleft < 0;
1501 if (left_neg)
1502 dleft = -dleft;
68dc0745 1503
e2c88acc
NC
1504 /* This should be exactly the 5.6 behaviour - if left and right are
1505 both in range for UV then use U_V() rather than floor. */
1506 if (!use_double) {
1507 if (dleft < UV_MAX_P1) {
1508 /* right was in range, so is dleft, so use UVs not double.
1509 */
1510 left = U_V(dleft);
1511 }
1512 /* left is out of range for UV, right was in range, so promote
1513 right (back) to double. */
1514 else {
1515 /* The +0.5 is used in 5.6 even though it is not strictly
1516 consistent with the implicit +0 floor in the U_V()
1517 inside the #if 1. */
1518 dleft = Perl_floor(dleft + 0.5);
1519 use_double = TRUE;
1520 if (dright_valid)
1521 dright = Perl_floor(dright + 0.5);
1522 else
1523 dright = right;
1524 }
1525 }
1526 }
6f1401dc 1527 sp -= 2;
787eafbd 1528 if (use_double) {
65202027 1529 NV dans;
787eafbd 1530
787eafbd 1531 if (!dright)
cea2e8a9 1532 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1533
65202027 1534 dans = Perl_fmod(dleft, dright);
787eafbd
IZ
1535 if ((left_neg != right_neg) && dans)
1536 dans = dright - dans;
1537 if (right_neg)
1538 dans = -dans;
1539 sv_setnv(TARG, dans);
1540 }
1541 else {
1542 UV ans;
1543
787eafbd 1544 if (!right)
cea2e8a9 1545 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ
1546
1547 ans = left % right;
1548 if ((left_neg != right_neg) && ans)
1549 ans = right - ans;
1550 if (right_neg) {
1551 /* XXX may warn: unary minus operator applied to unsigned type */
1552 /* could change -foo to be (~foo)+1 instead */
1553 if (ans <= ~((UV)IV_MAX)+1)
1554 sv_setiv(TARG, ~ans+1);
1555 else
65202027 1556 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ
1557 }
1558 else
1559 sv_setuv(TARG, ans);
1560 }
1561 PUSHTARG;
1562 RETURN;
79072805 1563 }
a0d0e21e 1564}
79072805 1565
a0d0e21e
LW
1566PP(pp_repeat)
1567{
6f1401dc 1568 dVAR; dSP; dATARGET;
2b573ace 1569 register IV count;
6f1401dc
DM
1570 SV *sv;
1571
1572 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1573 /* TODO: think of some way of doing list-repeat overloading ??? */
1574 sv = POPs;
1575 SvGETMAGIC(sv);
1576 }
1577 else {
1578 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1579 sv = POPs;
1580 }
1581
2b573ace
JH
1582 if (SvIOKp(sv)) {
1583 if (SvUOK(sv)) {
6f1401dc 1584 const UV uv = SvUV_nomg(sv);
2b573ace
JH
1585 if (uv > IV_MAX)
1586 count = IV_MAX; /* The best we can do? */
1587 else
1588 count = uv;
1589 } else {
6f1401dc 1590 const IV iv = SvIV_nomg(sv);
2b573ace
JH
1591 if (iv < 0)
1592 count = 0;
1593 else
1594 count = iv;
1595 }
1596 }
1597 else if (SvNOKp(sv)) {
6f1401dc 1598 const NV nv = SvNV_nomg(sv);
2b573ace
JH
1599 if (nv < 0.0)
1600 count = 0;
1601 else
1602 count = (IV)nv;
1603 }
1604 else
6f1401dc
DM
1605 count = SvIV_nomg(sv);
1606
533c011a 1607 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e 1608 dMARK;
0bd48802
AL
1609 static const char oom_list_extend[] = "Out of memory during list extend";
1610 const I32 items = SP - MARK;
1611 const I32 max = items * count;
79072805 1612
2b573ace
JH
1613 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1614 /* Did the max computation overflow? */
27d5b266 1615 if (items > 0 && max > 0 && (max < items || max < count))
2b573ace 1616 Perl_croak(aTHX_ oom_list_extend);
a0d0e21e
LW
1617 MEXTEND(MARK, max);
1618 if (count > 1) {
1619 while (SP > MARK) {
976c8a39
JH
1620#if 0
1621 /* This code was intended to fix 20010809.028:
1622
1623 $x = 'abcd';
1624 for (($x =~ /./g) x 2) {
1625 print chop; # "abcdabcd" expected as output.
1626 }
1627
1628 * but that change (#11635) broke this code:
1629
1630 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1631
1632 * I can't think of a better fix that doesn't introduce
1633 * an efficiency hit by copying the SVs. The stack isn't
1634 * refcounted, and mortalisation obviously doesn't
1635 * Do The Right Thing when the stack has more than
1636 * one pointer to the same mortal value.
1637 * .robin.
1638 */
e30acc16
RH
1639 if (*SP) {
1640 *SP = sv_2mortal(newSVsv(*SP));
1641 SvREADONLY_on(*SP);
1642 }
976c8a39
JH
1643#else
1644 if (*SP)
1645 SvTEMP_off((*SP));
1646#endif
a0d0e21e 1647 SP--;
79072805 1648 }
a0d0e21e
LW
1649 MARK++;
1650 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1651 items * sizeof(const SV *), count - 1);
a0d0e21e 1652 SP += max;
79072805 1653 }
a0d0e21e
LW
1654 else if (count <= 0)
1655 SP -= items;
79072805 1656 }
a0d0e21e 1657 else { /* Note: mark already snarfed by pp_list */
0bd48802 1658 SV * const tmpstr = POPs;
a0d0e21e 1659 STRLEN len;
9b877dbb 1660 bool isutf;
2b573ace
JH
1661 static const char oom_string_extend[] =
1662 "Out of memory during string extend";
a0d0e21e 1663
6f1401dc
DM
1664 if (TARG != tmpstr)
1665 sv_setsv_nomg(TARG, tmpstr);
1666 SvPV_force_nomg(TARG, len);
9b877dbb 1667 isutf = DO_UTF8(TARG);
8ebc5c01 1668 if (count != 1) {
1669 if (count < 1)
1670 SvCUR_set(TARG, 0);
1671 else {
c445ea15 1672 const STRLEN max = (UV)count * len;
19a94d75 1673 if (len > MEM_SIZE_MAX / count)
2b573ace
JH
1674 Perl_croak(aTHX_ oom_string_extend);
1675 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
8569b9dc 1676 SvGROW(TARG, max + 1);
a0d0e21e 1677 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1678 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1679 }
a0d0e21e 1680 *SvEND(TARG) = '\0';
a0d0e21e 1681 }
dfcb284a
GS
1682 if (isutf)
1683 (void)SvPOK_only_UTF8(TARG);
1684 else
1685 (void)SvPOK_only(TARG);
b80b6069
RH
1686
1687 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1688 /* The parser saw this as a list repeat, and there
1689 are probably several items on the stack. But we're
1690 in scalar context, and there's no pp_list to save us
1691 now. So drop the rest of the items -- robin@kitsite.com
1692 */
1693 dMARK;
1694 SP = MARK;
1695 }
a0d0e21e 1696 PUSHTARG;
79072805 1697 }
a0d0e21e
LW
1698 RETURN;
1699}
79072805 1700
a0d0e21e
LW
1701PP(pp_subtract)
1702{
800401ee 1703 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
1704 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1705 svr = TOPs;
1706 svl = TOPm1s;
800401ee 1707 useleft = USE_LEFT(svl);
28e5dec8 1708#ifdef PERL_PRESERVE_IVUV
7dca457a
NC
1709 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1710 "bad things" happen if you rely on signed integers wrapping. */
6f1401dc 1711 SvIV_please_nomg(svr);
800401ee 1712 if (SvIOK(svr)) {
28e5dec8
JH
1713 /* Unless the left argument is integer in range we are going to have to
1714 use NV maths. Hence only attempt to coerce the right argument if
1715 we know the left is integer. */
9c5ffd7c
JH
1716 register UV auv = 0;
1717 bool auvok = FALSE;
7dca457a
NC
1718 bool a_valid = 0;
1719
28e5dec8 1720 if (!useleft) {
7dca457a
NC
1721 auv = 0;
1722 a_valid = auvok = 1;
1723 /* left operand is undef, treat as zero. */
28e5dec8
JH
1724 } else {
1725 /* Left operand is defined, so is it IV? */
6f1401dc 1726 SvIV_please_nomg(svl);
800401ee
JH
1727 if (SvIOK(svl)) {
1728 if ((auvok = SvUOK(svl)))
1729 auv = SvUVX(svl);
7dca457a 1730 else {
800401ee 1731 register const IV aiv = SvIVX(svl);
7dca457a
NC
1732 if (aiv >= 0) {
1733 auv = aiv;
1734 auvok = 1; /* Now acting as a sign flag. */
1735 } else { /* 2s complement assumption for IV_MIN */
1736 auv = (UV)-aiv;
28e5dec8 1737 }
7dca457a
NC
1738 }
1739 a_valid = 1;
1740 }
1741 }
1742 if (a_valid) {
1743 bool result_good = 0;
1744 UV result;
1745 register UV buv;
800401ee 1746 bool buvok = SvUOK(svr);
9041c2e3 1747
7dca457a 1748 if (buvok)
800401ee 1749 buv = SvUVX(svr);
7dca457a 1750 else {
800401ee 1751 register const IV biv = SvIVX(svr);
7dca457a
NC
1752 if (biv >= 0) {
1753 buv = biv;
1754 buvok = 1;
1755 } else
1756 buv = (UV)-biv;
1757 }
1758 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1759 else "IV" now, independent of how it came in.
7dca457a
NC
1760 if a, b represents positive, A, B negative, a maps to -A etc
1761 a - b => (a - b)
1762 A - b => -(a + b)
1763 a - B => (a + b)
1764 A - B => -(a - b)
1765 all UV maths. negate result if A negative.
1766 subtract if signs same, add if signs differ. */
1767
1768 if (auvok ^ buvok) {
1769 /* Signs differ. */
1770 result = auv + buv;
1771 if (result >= auv)
1772 result_good = 1;
1773 } else {
1774 /* Signs same */
1775 if (auv >= buv) {
1776 result = auv - buv;
1777 /* Must get smaller */
1778 if (result <= auv)
1779 result_good = 1;
1780 } else {
1781 result = buv - auv;
1782 if (result <= buv) {
1783 /* result really should be -(auv-buv). as its negation
1784 of true value, need to swap our result flag */
1785 auvok = !auvok;
1786 result_good = 1;
28e5dec8 1787 }
28e5dec8
JH
1788 }
1789 }
7dca457a
NC
1790 if (result_good) {
1791 SP--;
1792 if (auvok)
1793 SETu( result );
1794 else {
1795 /* Negate result */
1796 if (result <= (UV)IV_MIN)
1797 SETi( -(IV)result );
1798 else {
1799 /* result valid, but out of range for IV. */
1800 SETn( -(NV)result );
1801 }
1802 }
1803 RETURN;
1804 } /* Overflow, drop through to NVs. */
28e5dec8
JH
1805 }
1806 }
1807#endif
a0d0e21e 1808 {
6f1401dc 1809 NV value = SvNV_nomg(svr);
4efa5a16
RD
1810 (void)POPs;
1811
28e5dec8
JH
1812 if (!useleft) {
1813 /* left operand is undef, treat as zero - value */
1814 SETn(-value);
1815 RETURN;
1816 }
6f1401dc 1817 SETn( SvNV_nomg(svl) - value );
28e5dec8 1818 RETURN;
79072805 1819 }
a0d0e21e 1820}
79072805 1821
a0d0e21e
LW
1822PP(pp_left_shift)
1823{
6f1401dc 1824 dVAR; dSP; dATARGET; SV *svl, *svr;
a42d0242 1825 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1826 svr = POPs;
1827 svl = TOPs;
a0d0e21e 1828 {
6f1401dc 1829 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1830 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1831 const IV i = SvIV_nomg(svl);
972b05a9 1832 SETi(i << shift);
d0ba1bd2
JH
1833 }
1834 else {
6f1401dc 1835 const UV u = SvUV_nomg(svl);
972b05a9 1836 SETu(u << shift);
d0ba1bd2 1837 }
55497cff 1838 RETURN;
79072805 1839 }
a0d0e21e 1840}
79072805 1841
a0d0e21e
LW
1842PP(pp_right_shift)
1843{
6f1401dc 1844 dVAR; dSP; dATARGET; SV *svl, *svr;
a42d0242 1845 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1846 svr = POPs;
1847 svl = TOPs;
a0d0e21e 1848 {
6f1401dc 1849 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1850 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1851 const IV i = SvIV_nomg(svl);
972b05a9 1852 SETi(i >> shift);
d0ba1bd2
JH
1853 }
1854 else {
6f1401dc 1855 const UV u = SvUV_nomg(svl);
972b05a9 1856 SETu(u >> shift);
d0ba1bd2 1857 }
a0d0e21e 1858 RETURN;
93a17b20 1859 }
79072805
LW
1860}
1861
a0d0e21e 1862PP(pp_lt)
79072805 1863{
6f1401dc 1864 dVAR; dSP;
33efebe6
DM
1865 SV *left, *right;
1866
a42d0242 1867 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
1868 right = POPs;
1869 left = TOPs;
1870 SETs(boolSV(
1871 (SvIOK_notUV(left) && SvIOK_notUV(right))
1872 ? (SvIVX(left) < SvIVX(right))
1873 : (do_ncmp(left, right) == -1)
1874 ));
1875 RETURN;
a0d0e21e 1876}
79072805 1877
a0d0e21e
LW
1878PP(pp_gt)
1879{
6f1401dc 1880 dVAR; dSP;
33efebe6 1881 SV *left, *right;
1b6737cc 1882
33efebe6
DM
1883 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1884 right = POPs;
1885 left = TOPs;
1886 SETs(boolSV(
1887 (SvIOK_notUV(left) && SvIOK_notUV(right))
1888 ? (SvIVX(left) > SvIVX(right))
1889 : (do_ncmp(left, right) == 1)
1890 ));
1891 RETURN;
a0d0e21e
LW
1892}
1893
1894PP(pp_le)
1895{
6f1401dc 1896 dVAR; dSP;
33efebe6 1897 SV *left, *right;
1b6737cc 1898
33efebe6
DM
1899 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1900 right = POPs;
1901 left = TOPs;
1902 SETs(boolSV(
1903 (SvIOK_notUV(left) && SvIOK_notUV(right))
1904 ? (SvIVX(left) <= SvIVX(right))
1905 : (do_ncmp(left, right) <= 0)
1906 ));
1907 RETURN;
a0d0e21e
LW
1908}
1909
1910PP(pp_ge)
1911{
6f1401dc 1912 dVAR; dSP;
33efebe6
DM
1913 SV *left, *right;
1914
1915 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1916 right = POPs;
1917 left = TOPs;
1918 SETs(boolSV(
1919 (SvIOK_notUV(left) && SvIOK_notUV(right))
1920 ? (SvIVX(left) >= SvIVX(right))
1921 : ( (do_ncmp(left, right) & 2) == 0)
1922 ));
1923 RETURN;
1924}
1b6737cc 1925
33efebe6
DM
1926PP(pp_ne)
1927{
1928 dVAR; dSP;
1929 SV *left, *right;
1930
1931 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1932 right = POPs;
1933 left = TOPs;
1934 SETs(boolSV(
1935 (SvIOK_notUV(left) && SvIOK_notUV(right))
1936 ? (SvIVX(left) != SvIVX(right))
1937 : (do_ncmp(left, right) != 0)
1938 ));
1939 RETURN;
1940}
1b6737cc 1941
33efebe6
DM
1942/* compare left and right SVs. Returns:
1943 * -1: <
1944 * 0: ==
1945 * 1: >
1946 * 2: left or right was a NaN
1947 */
1948I32
1949Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
1950{
1951 dVAR;
1b6737cc 1952
33efebe6
DM
1953 PERL_ARGS_ASSERT_DO_NCMP;
1954#ifdef PERL_PRESERVE_IVUV
1955 SvIV_please_nomg(right);
1956 /* Fortunately it seems NaN isn't IOK */
1957 if (SvIOK(right)) {
1958 SvIV_please_nomg(left);
1959 if (SvIOK(left)) {
1960 if (!SvUOK(left)) {
1961 const IV leftiv = SvIVX(left);
1962 if (!SvUOK(right)) {
1963 /* ## IV <=> IV ## */
1964 const IV rightiv = SvIVX(right);
1965 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 1966 }
33efebe6
DM
1967 /* ## IV <=> UV ## */
1968 if (leftiv < 0)
1969 /* As (b) is a UV, it's >=0, so it must be < */
1970 return -1;
1971 {
1972 const UV rightuv = SvUVX(right);
1973 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 1974 }
28e5dec8 1975 }
79072805 1976
33efebe6
DM
1977 if (SvUOK(right)) {
1978 /* ## UV <=> UV ## */
1979 const UV leftuv = SvUVX(left);
1980 const UV rightuv = SvUVX(right);
1981 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 1982 }
33efebe6
DM
1983 /* ## UV <=> IV ## */
1984 {
1985 const IV rightiv = SvIVX(right);
1986 if (rightiv < 0)
1987 /* As (a) is a UV, it's >=0, so it cannot be < */
1988 return 1;
1989 {
1990 const UV leftuv = SvUVX(left);
1991 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 1992 }
28e5dec8 1993 }
33efebe6 1994 /* NOTREACHED */
28e5dec8
JH
1995 }
1996 }
1997#endif
a0d0e21e 1998 {
33efebe6
DM
1999 NV const rnv = SvNV_nomg(right);
2000 NV const lnv = SvNV_nomg(left);
2001
cab190d4 2002#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM
2003 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2004 return 2;
2005 }
2006 return (lnv > rnv) - (lnv < rnv);
cab190d4 2007#else
33efebe6
DM
2008 if (lnv < rnv)
2009 return -1;
2010 if (lnv > rnv)
2011 return 1;
2012 if (lnv == rnv)
2013 return 0;
2014 return 2;
cab190d4 2015#endif
a0d0e21e 2016 }
79072805
LW
2017}
2018
33efebe6 2019
a0d0e21e 2020PP(pp_ncmp)
79072805 2021{
33efebe6
DM
2022 dVAR; dSP;
2023 SV *left, *right;
2024 I32 value;
a42d0242 2025 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM
2026 right = POPs;
2027 left = TOPs;
2028 value = do_ncmp(left, right);
2029 if (value == 2) {
3280af22 2030 SETs(&PL_sv_undef);
79072805 2031 }
33efebe6
DM
2032 else {
2033 dTARGET;
2034 SETi(value);
2035 }
2036 RETURN;
a0d0e21e 2037}
79072805 2038
afd9910b 2039PP(pp_sle)
a0d0e21e 2040{
97aff369 2041 dVAR; dSP;
79072805 2042
afd9910b
NC
2043 int amg_type = sle_amg;
2044 int multiplier = 1;
2045 int rhs = 1;
79072805 2046
afd9910b
NC
2047 switch (PL_op->op_type) {
2048 case OP_SLT:
2049 amg_type = slt_amg;
2050 /* cmp < 0 */
2051 rhs = 0;
2052 break;
2053 case OP_SGT:
2054 amg_type = sgt_amg;
2055 /* cmp > 0 */
2056 multiplier = -1;
2057 rhs = 0;
2058 break;
2059 case OP_SGE:
2060 amg_type = sge_amg;
2061 /* cmp >= 0 */
2062 multiplier = -1;
2063 break;
79072805 2064 }
79072805 2065
6f1401dc 2066 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW
2067 {
2068 dPOPTOPssrl;
1b6737cc 2069 const int cmp = (IN_LOCALE_RUNTIME
078504b2
FC
2070 ? sv_cmp_locale_flags(left, right, 0)
2071 : sv_cmp_flags(left, right, 0));
afd9910b 2072 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW
2073 RETURN;
2074 }
2075}
79072805 2076
36477c24 2077PP(pp_seq)
2078{
6f1401dc
DM
2079 dVAR; dSP;
2080 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24 2081 {
2082 dPOPTOPssrl;
078504b2 2083 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW
2084 RETURN;
2085 }
2086}
79072805 2087
a0d0e21e 2088PP(pp_sne)
79072805 2089{
6f1401dc
DM
2090 dVAR; dSP;
2091 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW
2092 {
2093 dPOPTOPssrl;
078504b2 2094 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2095 RETURN;
463ee0b2 2096 }
79072805
LW
2097}
2098
a0d0e21e 2099PP(pp_scmp)
79072805 2100{
6f1401dc
DM
2101 dVAR; dSP; dTARGET;
2102 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW
2103 {
2104 dPOPTOPssrl;
1b6737cc 2105 const int cmp = (IN_LOCALE_RUNTIME
078504b2
FC
2106 ? sv_cmp_locale_flags(left, right, 0)
2107 : sv_cmp_flags(left, right, 0));
bbce6d69 2108 SETi( cmp );
a0d0e21e
LW
2109 RETURN;
2110 }
2111}
79072805 2112
55497cff 2113PP(pp_bit_and)
2114{
6f1401dc
DM
2115 dVAR; dSP; dATARGET;
2116 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW
2117 {
2118 dPOPTOPssrl;
4633a7c4 2119 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2120 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2121 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2122 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2123 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2124 SETi(i);
d0ba1bd2
JH
2125 }
2126 else {
1b6737cc 2127 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2128 SETu(u);
d0ba1bd2 2129 }
5ee80e13 2130 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2131 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2132 }
2133 else {
533c011a 2134 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2135 SETTARG;
2136 }
2137 RETURN;
2138 }
2139}
79072805 2140
a0d0e21e
LW
2141PP(pp_bit_or)
2142{
3658c1f1
NC
2143 dVAR; dSP; dATARGET;
2144 const int op_type = PL_op->op_type;
2145
6f1401dc 2146 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW
2147 {
2148 dPOPTOPssrl;
4633a7c4 2149 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2150 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2151 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2152 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC
2153 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2154 const IV r = SvIV_nomg(right);
2155 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2156 SETi(result);
d0ba1bd2
JH
2157 }
2158 else {
3658c1f1
NC
2159 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2160 const UV r = SvUV_nomg(right);
2161 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2162 SETu(result);
d0ba1bd2 2163 }
5ee80e13 2164 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2165 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2166 }
2167 else {
3658c1f1 2168 do_vop(op_type, TARG, left, right);
a0d0e21e
LW
2169 SETTARG;
2170 }
2171 RETURN;
79072805 2172 }
a0d0e21e 2173}
79072805 2174
a0d0e21e
LW
2175PP(pp_negate)
2176{
6f1401dc
DM
2177 dVAR; dSP; dTARGET;
2178 tryAMAGICun_MG(neg_amg, AMGf_numeric);
a0d0e21e 2179 {
6f1401dc 2180 SV * const sv = TOPs;
1b6737cc 2181 const int flags = SvFLAGS(sv);
a5b92898 2182
886a4465 2183 if( !SvNIOK( sv ) && looks_like_number( sv ) ){
a5b92898
RB
2184 SvIV_please( sv );
2185 }
2186
28e5dec8
JH
2187 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2188 /* It's publicly an integer, or privately an integer-not-float */
2189 oops_its_an_int:
9b0e499b
GS
2190 if (SvIsUV(sv)) {
2191 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2192 /* 2s complement assumption. */
9b0e499b
GS
2193 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2194 RETURN;
2195 }
2196 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2197 SETi(-SvIVX(sv));
9b0e499b
GS
2198 RETURN;
2199 }
2200 }
2201 else if (SvIVX(sv) != IV_MIN) {
2202 SETi(-SvIVX(sv));
2203 RETURN;
2204 }
28e5dec8
JH
2205#ifdef PERL_PRESERVE_IVUV
2206 else {
2207 SETu((UV)IV_MIN);
2208 RETURN;
2209 }
2210#endif
9b0e499b
GS
2211 }
2212 if (SvNIOKp(sv))
6f1401dc 2213 SETn(-SvNV_nomg(sv));
4633a7c4 2214 else if (SvPOKp(sv)) {
a0d0e21e 2215 STRLEN len;
6f1401dc 2216 const char * const s = SvPV_nomg_const(sv, len);
bbce6d69 2217 if (isIDFIRST(*s)) {
76f68e9b 2218 sv_setpvs(TARG, "-");
a0d0e21e 2219 sv_catsv(TARG, sv);
79072805 2220 }
a0d0e21e 2221 else if (*s == '+' || *s == '-') {
6f1401dc
DM
2222 sv_setsv_nomg(TARG, sv);
2223 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
79072805 2224 }
8eb28a70 2225 else if (DO_UTF8(sv)) {
6f1401dc 2226 SvIV_please_nomg(sv);
8eb28a70
JH
2227 if (SvIOK(sv))
2228 goto oops_its_an_int;
2229 if (SvNOK(sv))
6f1401dc 2230 sv_setnv(TARG, -SvNV_nomg(sv));
8eb28a70 2231 else {
76f68e9b 2232 sv_setpvs(TARG, "-");
8eb28a70
JH
2233 sv_catsv(TARG, sv);
2234 }
834a4ddd 2235 }
28e5dec8 2236 else {
6f1401dc 2237 SvIV_please_nomg(sv);
8eb28a70
JH
2238 if (SvIOK(sv))
2239 goto oops_its_an_int;
6f1401dc 2240 sv_setnv(TARG, -SvNV_nomg(sv));
28e5dec8 2241 }
a0d0e21e 2242 SETTARG;
79072805 2243 }
4633a7c4 2244 else
6f1401dc 2245 SETn(-SvNV_nomg(sv));
79072805 2246 }
a0d0e21e 2247 RETURN;
79072805
LW
2248}
2249
a0d0e21e 2250PP(pp_not)
79072805 2251{
6f1401dc
DM
2252 dVAR; dSP;
2253 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2254 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2255 return NORMAL;
79072805
LW
2256}
2257
a0d0e21e 2258PP(pp_complement)
79072805 2259{
6f1401dc 2260 dVAR; dSP; dTARGET;
a42d0242 2261 tryAMAGICun_MG(compl_amg, AMGf_numeric);
a0d0e21e
LW
2262 {
2263 dTOPss;
4633a7c4 2264 if (SvNIOKp(sv)) {
d0ba1bd2 2265 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2266 const IV i = ~SvIV_nomg(sv);
972b05a9 2267 SETi(i);
d0ba1bd2
JH
2268 }
2269 else {
1b6737cc 2270 const UV u = ~SvUV_nomg(sv);
972b05a9 2271 SETu(u);
d0ba1bd2 2272 }
a0d0e21e
LW
2273 }
2274 else {
51723571 2275 register U8 *tmps;
55497cff 2276 register I32 anum;
a0d0e21e
LW
2277 STRLEN len;
2278
10516c54 2279 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
891f9566 2280 sv_setsv_nomg(TARG, sv);
6f1401dc 2281 tmps = (U8*)SvPV_force_nomg(TARG, len);
a0d0e21e 2282 anum = len;
1d68d6cd 2283 if (SvUTF8(TARG)) {
a1ca4561 2284 /* Calculate exact length, let's not estimate. */
1d68d6cd 2285 STRLEN targlen = 0;
ba210ebe 2286 STRLEN l;
a1ca4561
YST
2287 UV nchar = 0;
2288 UV nwide = 0;
01f6e806 2289 U8 * const send = tmps + len;
74d49cd0
TS
2290 U8 * const origtmps = tmps;
2291 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2292
1d68d6cd 2293 while (tmps < send) {
74d49cd0
TS
2294 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2295 tmps += l;
5bbb0b5a 2296 targlen += UNISKIP(~c);
a1ca4561
YST
2297 nchar++;
2298 if (c > 0xff)
2299 nwide++;
1d68d6cd
SC
2300 }
2301
2302 /* Now rewind strings and write them. */
74d49cd0 2303 tmps = origtmps;
a1ca4561
YST
2304
2305 if (nwide) {
01f6e806
AL
2306 U8 *result;
2307 U8 *p;
2308
74d49cd0 2309 Newx(result, targlen + 1, U8);
01f6e806 2310 p = result;
a1ca4561 2311 while (tmps < send) {
74d49cd0
TS
2312 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2313 tmps += l;
01f6e806 2314 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2315 }
01f6e806 2316 *p = '\0';
c1c21316
NC
2317 sv_usepvn_flags(TARG, (char*)result, targlen,
2318 SV_HAS_TRAILING_NUL);
a1ca4561
YST
2319 SvUTF8_on(TARG);
2320 }
2321 else {
01f6e806
AL
2322 U8 *result;
2323 U8 *p;
2324
74d49cd0 2325 Newx(result, nchar + 1, U8);
01f6e806 2326 p = result;
a1ca4561 2327 while (tmps < send) {
74d49cd0
TS
2328 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2329 tmps += l;
01f6e806 2330 *p++ = ~c;
a1ca4561 2331 }
01f6e806 2332 *p = '\0';
c1c21316 2333 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2334 SvUTF8_off(TARG);
1d68d6cd 2335 }
ec93b65f 2336 SETTARG;
1d68d6cd
SC
2337 RETURN;
2338 }
a0d0e21e 2339#ifdef LIBERAL
51723571
JH
2340 {
2341 register long *tmpl;
2342 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2343 *tmps = ~*tmps;
2344 tmpl = (long*)tmps;
bb7a0f54 2345 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH
2346 *tmpl = ~*tmpl;
2347 tmps = (U8*)tmpl;
2348 }
a0d0e21e
LW
2349#endif
2350 for ( ; anum > 0; anum--, tmps++)
2351 *tmps = ~*tmps;
ec93b65f 2352 SETTARG;
a0d0e21e
LW
2353 }
2354 RETURN;
2355 }
79072805
LW
2356}
2357
a0d0e21e
LW
2358/* integer versions of some of the above */
2359
a0d0e21e 2360PP(pp_i_multiply)
79072805 2361{
6f1401dc
DM
2362 dVAR; dSP; dATARGET;
2363 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2364 {
6f1401dc 2365 dPOPTOPiirl_nomg;
a0d0e21e
LW
2366 SETi( left * right );
2367 RETURN;
2368 }
79072805
LW
2369}
2370
a0d0e21e 2371PP(pp_i_divide)
79072805 2372{
85935d8e 2373 IV num;
6f1401dc
DM
2374 dVAR; dSP; dATARGET;
2375 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2376 {
6f1401dc 2377 dPOPTOPssrl;
85935d8e 2378 IV value = SvIV_nomg(right);
a0d0e21e 2379 if (value == 0)
ece1bcef 2380 DIE(aTHX_ "Illegal division by zero");
85935d8e 2381 num = SvIV_nomg(left);
a0cec769
YST
2382
2383 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2384 if (value == -1)
2385 value = - num;
2386 else
2387 value = num / value;
6f1401dc 2388 SETi(value);
a0d0e21e
LW
2389 RETURN;
2390 }
79072805
LW
2391}
2392
befad5d1 2393#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH
2394STATIC
2395PP(pp_i_modulo_0)
befad5d1
NC
2396#else
2397PP(pp_i_modulo)
2398#endif
224ec323
JH
2399{
2400 /* This is the vanilla old i_modulo. */
6f1401dc
DM
2401 dVAR; dSP; dATARGET;
2402 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2403 {
6f1401dc 2404 dPOPTOPiirl_nomg;
224ec323
JH
2405 if (!right)
2406 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2407 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2408 if (right == -1)
2409 SETi( 0 );
2410 else
2411 SETi( left % right );
224ec323
JH
2412 RETURN;
2413 }
2414}
2415
11010fa3 2416#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH
2417STATIC
2418PP(pp_i_modulo_1)
befad5d1 2419
224ec323 2420{
224ec323 2421 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2422 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2423 * See below for pp_i_modulo. */
6f1401dc
DM
2424 dVAR; dSP; dATARGET;
2425 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2426 {
6f1401dc 2427 dPOPTOPiirl_nomg;
224ec323
JH
2428 if (!right)
2429 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2430 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2431 if (right == -1)
2432 SETi( 0 );
2433 else
2434 SETi( left % PERL_ABS(right) );
224ec323
JH
2435 RETURN;
2436 }
224ec323
JH
2437}
2438
a0d0e21e 2439PP(pp_i_modulo)
79072805 2440{
6f1401dc
DM
2441 dVAR; dSP; dATARGET;
2442 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2443 {
6f1401dc 2444 dPOPTOPiirl_nomg;
224ec323
JH
2445 if (!right)
2446 DIE(aTHX_ "Illegal modulus zero");
2447 /* The assumption is to use hereafter the old vanilla version... */
2448 PL_op->op_ppaddr =
2449 PL_ppaddr[OP_I_MODULO] =
1c127fab 2450 Perl_pp_i_modulo_0;
224ec323
JH
2451 /* .. but if we have glibc, we might have a buggy _moddi3
2452 * (at least glicb 2.2.5 is known to have this bug), in other
2453 * words our integer modulus with negative quad as the second
2454 * argument might be broken. Test for this and re-patch the
2455 * opcode dispatch table if that is the case, remembering to
2456 * also apply the workaround so that this first round works
2457 * right, too. See [perl #9402] for more information. */
224ec323
JH
2458 {
2459 IV l = 3;
2460 IV r = -10;
2461 /* Cannot do this check with inlined IV constants since
2462 * that seems to work correctly even with the buggy glibc. */
2463 if (l % r == -3) {
2464 /* Yikes, we have the bug.
2465 * Patch in the workaround version. */
2466 PL_op->op_ppaddr =
2467 PL_ppaddr[OP_I_MODULO] =
2468 &Perl_pp_i_modulo_1;
2469 /* Make certain we work right this time, too. */
32fdb065 2470 right = PERL_ABS(right);
224ec323
JH
2471 }
2472 }
a0cec769
YST
2473 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2474 if (right == -1)
2475 SETi( 0 );
2476 else
2477 SETi( left % right );
224ec323
JH
2478 RETURN;
2479 }
79072805 2480}
befad5d1 2481#endif
79072805 2482
a0d0e21e 2483PP(pp_i_add)
79072805 2484{
6f1401dc
DM
2485 dVAR; dSP; dATARGET;
2486 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2487 {
6f1401dc 2488 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2489 SETi( left + right );
2490 RETURN;
79072805 2491 }
79072805
LW
2492}
2493
a0d0e21e 2494PP(pp_i_subtract)
79072805 2495{
6f1401dc
DM
2496 dVAR; dSP; dATARGET;
2497 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2498 {
6f1401dc 2499 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2500 SETi( left - right );
2501 RETURN;
79072805 2502 }
79072805
LW
2503}
2504
a0d0e21e 2505PP(pp_i_lt)
79072805 2506{
6f1401dc
DM
2507 dVAR; dSP;
2508 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2509 {
96b6b87f 2510 dPOPTOPiirl_nomg;
54310121 2511 SETs(boolSV(left < right));
a0d0e21e
LW
2512 RETURN;
2513 }
79072805
LW
2514}
2515
a0d0e21e 2516PP(pp_i_gt)
79072805 2517{
6f1401dc
DM
2518 dVAR; dSP;
2519 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2520 {
96b6b87f 2521 dPOPTOPiirl_nomg;
54310121 2522 SETs(boolSV(left > right));
a0d0e21e
LW
2523 RETURN;
2524 }
79072805
LW
2525}
2526
a0d0e21e 2527PP(pp_i_le)
79072805 2528{
6f1401dc
DM
2529 dVAR; dSP;
2530 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2531 {
96b6b87f 2532 dPOPTOPiirl_nomg;
54310121 2533 SETs(boolSV(left <= right));
a0d0e21e 2534 RETURN;
85e6fe83 2535 }
79072805
LW
2536}
2537
a0d0e21e 2538PP(pp_i_ge)
79072805 2539{
6f1401dc
DM
2540 dVAR; dSP;
2541 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2542 {
96b6b87f 2543 dPOPTOPiirl_nomg;
54310121 2544 SETs(boolSV(left >= right));
a0d0e21e
LW
2545 RETURN;
2546 }
79072805
LW
2547}
2548
a0d0e21e 2549PP(pp_i_eq)
79072805 2550{
6f1401dc
DM
2551 dVAR; dSP;
2552 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2553 {
96b6b87f 2554 dPOPTOPiirl_nomg;
54310121 2555 SETs(boolSV(left == right));
a0d0e21e
LW
2556 RETURN;
2557 }
79072805
LW
2558}
2559
a0d0e21e 2560PP(pp_i_ne)
79072805 2561{
6f1401dc
DM
2562 dVAR; dSP;
2563 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2564 {
96b6b87f 2565 dPOPTOPiirl_nomg;
54310121 2566 SETs(boolSV(left != right));
a0d0e21e
LW
2567 RETURN;
2568 }
79072805
LW
2569}
2570
a0d0e21e 2571PP(pp_i_ncmp)
79072805 2572{
6f1401dc
DM
2573 dVAR; dSP; dTARGET;
2574 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2575 {
96b6b87f 2576 dPOPTOPiirl_nomg;
a0d0e21e 2577 I32 value;
79072805 2578
a0d0e21e 2579 if (left > right)
79072805 2580 value = 1;
a0d0e21e 2581 else if (left < right)
79072805 2582 value = -1;
a0d0e21e 2583 else
79072805 2584 value = 0;
a0d0e21e
LW
2585 SETi(value);
2586 RETURN;
79072805 2587 }
85e6fe83
LW
2588}
2589
2590PP(pp_i_negate)
2591{
6f1401dc
DM
2592 dVAR; dSP; dTARGET;
2593 tryAMAGICun_MG(neg_amg, 0);
2594 {
2595 SV * const sv = TOPs;
2596 IV const i = SvIV_nomg(sv);
2597 SETi(-i);
2598 RETURN;
2599 }
85e6fe83
LW
2600}
2601
79072805
LW
2602/* High falutin' math. */
2603
2604PP(pp_atan2)
2605{
6f1401dc
DM
2606 dVAR; dSP; dTARGET;
2607 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2608 {
096c060c 2609 dPOPTOPnnrl_nomg;
a1021d57 2610 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2611 RETURN;
2612 }
79072805
LW
2613}
2614
2615PP(pp_sin)
2616{
71302fe3
NC
2617 dVAR; dSP; dTARGET;
2618 int amg_type = sin_amg;
2619 const char *neg_report = NULL;
bc81784a 2620 NV (*func)(NV) = Perl_sin;
71302fe3
NC
2621 const int op_type = PL_op->op_type;
2622
2623 switch (op_type) {
2624 case OP_COS:
2625 amg_type = cos_amg;
bc81784a 2626 func = Perl_cos;
71302fe3
NC
2627 break;
2628 case OP_EXP:
2629 amg_type = exp_amg;
bc81784a 2630 func = Perl_exp;
71302fe3
NC
2631 break;
2632 case OP_LOG:
2633 amg_type = log_amg;
bc81784a 2634 func = Perl_log;
71302fe3
NC
2635 neg_report = "log";
2636 break;
2637 case OP_SQRT:
2638 amg_type = sqrt_amg;
bc81784a 2639 func = Perl_sqrt;
71302fe3
NC
2640 neg_report = "sqrt";
2641 break;
a0d0e21e 2642 }
79072805 2643
6f1401dc
DM
2644
2645 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2646 {
6f1401dc
DM
2647 SV * const arg = POPs;
2648 const NV value = SvNV_nomg(arg);
71302fe3
NC
2649 if (neg_report) {
2650 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2651 SET_NUMERIC_STANDARD();
dcbac5bb 2652 /* diag_listed_as: Can't take log of %g */
71302fe3
NC
2653 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2654 }
2655 }
2656 XPUSHn(func(value));
a0d0e21e
LW
2657 RETURN;
2658 }
79072805
LW
2659}
2660
56cb0a1c
AD
2661/* Support Configure command-line overrides for rand() functions.
2662 After 5.005, perhaps we should replace this by Configure support
2663 for drand48(), random(), or rand(). For 5.005, though, maintain
2664 compatibility by calling rand() but allow the user to override it.
2665 See INSTALL for details. --Andy Dougherty 15 July 1998
2666*/
85ab1d1d
JH
2667/* Now it's after 5.005, and Configure supports drand48() and random(),
2668 in addition to rand(). So the overrides should not be needed any more.
2669 --Jarkko Hietaniemi 27 September 1998
2670 */
2671
2672#ifndef HAS_DRAND48_PROTO
20ce7b12 2673extern double drand48 (void);
56cb0a1c
AD
2674#endif
2675
79072805
LW
2676PP(pp_rand)
2677{
97aff369 2678 dVAR; dSP; dTARGET;
65202027 2679 NV value;
79072805
LW
2680 if (MAXARG < 1)
2681 value = 1.0;
94ec06bc
FC
2682 else if (!TOPs) {
2683 value = 1.0; (void)POPs;
2684 }
79072805
LW
2685 else
2686 value = POPn;
2687 if (value == 0.0)
2688 value = 1.0;
80252599 2689 if (!PL_srand_called) {
85ab1d1d 2690 (void)seedDrand01((Rand_seed_t)seed());
80252599 2691 PL_srand_called = TRUE;
93dc8474 2692 }
85ab1d1d 2693 value *= Drand01();
79072805
LW
2694 XPUSHn(value);
2695 RETURN;
2696}
2697
2698PP(pp_srand)
2699{
83832992 2700 dVAR; dSP; dTARGET;
d22667bf 2701 const UV anum = (MAXARG < 1 || (!TOPs && !POPs)) ? seed() : POPu;
85ab1d1d 2702 (void)seedDrand01((Rand_seed_t)anum);
80252599 2703 PL_srand_called = TRUE;
da1010ec
NC
2704 if (anum)
2705 XPUSHu(anum);
2706 else {
2707 /* Historically srand always returned true. We can avoid breaking
2708 that like this: */
2709 sv_setpvs(TARG, "0 but true");
2710 XPUSHTARG;
2711 }
83832992 2712 RETURN;
79072805
LW
2713}
2714
79072805
LW
2715PP(pp_int)
2716{
6f1401dc
DM
2717 dVAR; dSP; dTARGET;
2718 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2719 {
6f1401dc
DM
2720 SV * const sv = TOPs;
2721 const IV iv = SvIV_nomg(sv);
28e5dec8
JH
2722 /* XXX it's arguable that compiler casting to IV might be subtly
2723 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2724 else preferring IV has introduced a subtle behaviour change bug. OTOH
2725 relying on floating point to be accurate is a bug. */
2726
c781a409 2727 if (!SvOK(sv)) {
922c4365 2728 SETu(0);
c781a409
RD
2729 }
2730 else if (SvIOK(sv)) {
2731 if (SvIsUV(sv))
6f1401dc 2732 SETu(SvUV_nomg(sv));
c781a409 2733 else
28e5dec8 2734 SETi(iv);
c781a409 2735 }
c781a409 2736 else {
6f1401dc 2737 const NV value = SvNV_nomg(sv);
1048ea30 2738 if (value >= 0.0) {
28e5dec8
JH
2739 if (value < (NV)UV_MAX + 0.5) {
2740 SETu(U_V(value));
2741 } else {
059a1014 2742 SETn(Perl_floor(value));
28e5dec8 2743 }
1048ea30 2744 }
28e5dec8
JH
2745 else {
2746 if (value > (NV)IV_MIN - 0.5) {
2747 SETi(I_V(value));
2748 } else {
1bbae031 2749 SETn(Perl_ceil(value));
28e5dec8
JH
2750 }
2751 }
774d564b 2752 }
79072805 2753 }
79072805
LW
2754 RETURN;
2755}
2756
463ee0b2
LW
2757PP(pp_abs)
2758{
6f1401dc
DM
2759 dVAR; dSP; dTARGET;
2760 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 2761 {
6f1401dc 2762 SV * const sv = TOPs;
28e5dec8 2763 /* This will cache the NV value if string isn't actually integer */
6f1401dc 2764 const IV iv = SvIV_nomg(sv);
a227d84d 2765
800401ee 2766 if (!SvOK(sv)) {
922c4365 2767 SETu(0);
800401ee
JH
2768 }
2769 else if (SvIOK(sv)) {
28e5dec8 2770 /* IVX is precise */
800401ee 2771 if (SvIsUV(sv)) {
6f1401dc 2772 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH
2773 } else {
2774 if (iv >= 0) {
2775 SETi(iv);
2776 } else {
2777 if (iv != IV_MIN) {
2778 SETi(-iv);
2779 } else {
2780 /* 2s complement assumption. Also, not really needed as
2781 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2782 SETu(IV_MIN);
2783 }
a227d84d 2784 }
28e5dec8
JH
2785 }
2786 } else{
6f1401dc 2787 const NV value = SvNV_nomg(sv);
774d564b 2788 if (value < 0.0)
1b6737cc 2789 SETn(-value);
a4474c9e
DD
2790 else
2791 SETn(value);
774d564b 2792 }
a0d0e21e 2793 }
774d564b 2794 RETURN;
463ee0b2
LW
2795}
2796
79072805
LW
2797PP(pp_oct)
2798{
97aff369 2799 dVAR; dSP; dTARGET;
5c144d81 2800 const char *tmps;
53305cf1 2801 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2802 STRLEN len;
53305cf1
NC
2803 NV result_nv;
2804 UV result_uv;
1b6737cc 2805 SV* const sv = POPs;
79072805 2806
349d4f2f 2807 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
2808 if (DO_UTF8(sv)) {
2809 /* If Unicode, try to downgrade
2810 * If not possible, croak. */
1b6737cc 2811 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
2812
2813 SvUTF8_on(tsv);
2814 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2815 tmps = SvPV_const(tsv, len);
2bc69dc4 2816 }
daa2adfd
NC
2817 if (PL_op->op_type == OP_HEX)
2818 goto hex;
2819
6f894ead 2820 while (*tmps && len && isSPACE(*tmps))
53305cf1 2821 tmps++, len--;
9e24b6e2 2822 if (*tmps == '0')
53305cf1 2823 tmps++, len--;
a674e8db 2824 if (*tmps == 'x' || *tmps == 'X') {
daa2adfd 2825 hex:
53305cf1 2826 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 2827 }
a674e8db 2828 else if (*tmps == 'b' || *tmps == 'B')
53305cf1 2829 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2830 else
53305cf1
NC
2831 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2832
2833 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2834 XPUSHn(result_nv);
2835 }
2836 else {
2837 XPUSHu(result_uv);
2838 }
79072805
LW
2839 RETURN;
2840}
2841
2842/* String stuff. */
2843
2844PP(pp_length)
2845{
97aff369 2846 dVAR; dSP; dTARGET;
0bd48802 2847 SV * const sv = TOPs;
a0ed51b3 2848
656266fc 2849 if (SvGAMAGIC(sv)) {
9f621bb0
NC
2850 /* For an overloaded or magic scalar, we can't know in advance if
2851 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
2852 it likes to cache the length. Maybe that should be a documented
2853 feature of it.
92331800
NC
2854 */
2855 STRLEN len;
9f621bb0
NC
2856 const char *const p
2857 = sv_2pv_flags(sv, &len,
2858 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
92331800 2859
d88e091f 2860 if (!p) {
9407f9c1
DL
2861 if (!SvPADTMP(TARG)) {
2862 sv_setsv(TARG, &PL_sv_undef);
2863 SETTARG;
2864 }
2865 SETs(&PL_sv_undef);
d88e091f 2866 }
9f621bb0 2867 else if (DO_UTF8(sv)) {
899be101 2868 SETi(utf8_length((U8*)p, (U8*)p + len));
92331800
NC
2869 }
2870 else
2871 SETi(len);
656266fc 2872 } else if (SvOK(sv)) {
9f621bb0
NC
2873 /* Neither magic nor overloaded. */
2874 if (DO_UTF8(sv))
2875 SETi(sv_len_utf8(sv));
2876 else
2877 SETi(sv_len(sv));
656266fc 2878 } else {
9407f9c1
DL
2879 if (!SvPADTMP(TARG)) {
2880 sv_setsv_nomg(TARG, &PL_sv_undef);
2881 SETTARG;
2882 }
2883 SETs(&PL_sv_undef);
92331800 2884 }
79072805
LW
2885 RETURN;
2886}
2887
83f78d1a
FC
2888/* Returns false if substring is completely outside original string.
2889 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2890 always be true for an explicit 0.
2891*/
2892bool
2893Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2894 bool pos1_is_uv, IV len_iv,
2895 bool len_is_uv, STRLEN *posp,
2896 STRLEN *lenp)
2897{
2898 IV pos2_iv;
2899 int pos2_is_uv;
2900
2901 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2902
2903 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2904 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2905 pos1_iv += curlen;
2906 }
2907 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2908 return FALSE;
2909
2910 if (len_iv || len_is_uv) {
2911 if (!len_is_uv && len_iv < 0) {
2912 pos2_iv = curlen + len_iv;
2913 if (curlen)
2914 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2915 else
2916 pos2_is_uv = 0;
2917 } else { /* len_iv >= 0 */
2918 if (!pos1_is_uv && pos1_iv < 0) {
2919 pos2_iv = pos1_iv + len_iv;
2920 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2921 } else {
2922 if ((UV)len_iv > curlen-(UV)pos1_iv)
2923 pos2_iv = curlen;
2924 else
2925 pos2_iv = pos1_iv+len_iv;
2926 pos2_is_uv = 1;
2927 }
2928 }
2929 }
2930 else {
2931 pos2_iv = curlen;
2932 pos2_is_uv = 1;
2933 }
2934
2935 if (!pos2_is_uv && pos2_iv < 0) {
2936 if (!pos1_is_uv && pos1_iv < 0)
2937 return FALSE;
2938 pos2_iv = 0;
2939 }
2940 else if (!pos1_is_uv && pos1_iv < 0)
2941 pos1_iv = 0;
2942
2943 if ((UV)pos2_iv < (UV)pos1_iv)
2944 pos2_iv = pos1_iv;
2945 if ((UV)pos2_iv > curlen)
2946 pos2_iv = curlen;
2947
2948 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
2949 *posp = (STRLEN)( (UV)pos1_iv );
2950 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
2951
2952 return TRUE;
2953}
2954
79072805
LW
2955PP(pp_substr)
2956{
97aff369 2957 dVAR; dSP; dTARGET;
79072805 2958 SV *sv;
463ee0b2 2959 STRLEN curlen;
9402d6ed 2960 STRLEN utf8_curlen;
777f7c56
EB
2961 SV * pos_sv;
2962 IV pos1_iv;
2963 int pos1_is_uv;
777f7c56
EB
2964 SV * len_sv;
2965 IV len_iv = 0;
83f78d1a 2966 int len_is_uv = 0;
24fcb59f 2967 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 2968 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 2969 const char *tmps;
9402d6ed 2970 SV *repl_sv = NULL;
cbbf8932 2971 const char *repl = NULL;
7b8d334a 2972 STRLEN repl_len;
7bc95ae1 2973 int num_args = PL_op->op_private & 7;
13e30c65 2974 bool repl_need_utf8_upgrade = FALSE;
9402d6ed 2975 bool repl_is_utf8 = FALSE;
79072805 2976
78f9721b
SM
2977 if (num_args > 2) {
2978 if (num_args > 3) {
24fcb59f 2979 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC
2980 }
2981 if ((len_sv = POPs)) {
2982 len_iv = SvIV(len_sv);
83f78d1a 2983 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 2984 }
7bc95ae1 2985 else num_args--;
5d82c453 2986 }
777f7c56
EB
2987 pos_sv = POPs;
2988 pos1_iv = SvIV(pos_sv);
2989 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 2990 sv = POPs;
24fcb59f
FC
2991 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
2992 assert(!repl_sv);
2993 repl_sv = POPs;
2994 }
849ca7ee 2995 PUTBACK;
9402d6ed 2996 if (repl_sv) {
24fcb59f
FC
2997 repl = SvPV_const(repl_sv, repl_len);
2998 repl_is_utf8 = DO_UTF8(repl_sv) && repl_len;
9402d6ed
JH
2999 if (repl_is_utf8) {
3000 if (!DO_UTF8(sv))
3001 sv_utf8_upgrade(sv);
3002 }
13e30c65
JH
3003 else if (DO_UTF8(sv))
3004 repl_need_utf8_upgrade = TRUE;
9402d6ed 3005 }
83f78d1a
FC
3006 else if (lvalue) {
3007 SV * ret;
3008 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3009 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3010 LvTYPE(ret) = 'x';
3011 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3012 LvTARGOFF(ret) =
3013 pos1_is_uv || pos1_iv >= 0
3014 ? (STRLEN)(UV)pos1_iv
3015 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3016 LvTARGLEN(ret) =
3017 len_is_uv || len_iv > 0
3018 ? (STRLEN)(UV)len_iv
3019 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3020
3021 SPAGAIN;
3022 PUSHs(ret); /* avoid SvSETMAGIC here */
3023 RETURN;
a74fb2cd 3024 }
83f78d1a 3025 tmps = SvPV_const(sv, curlen);
7e2040f0 3026 if (DO_UTF8(sv)) {
9402d6ed
JH
3027 utf8_curlen = sv_len_utf8(sv);
3028 if (utf8_curlen == curlen)
3029 utf8_curlen = 0;
a0ed51b3 3030 else
9402d6ed 3031 curlen = utf8_curlen;
a0ed51b3 3032 }
d1c2b58a 3033 else
9402d6ed 3034 utf8_curlen = 0;
a0ed51b3 3035
83f78d1a
FC
3036 {
3037 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3038
83f78d1a
FC
3039 if (!translate_substr_offsets(
3040 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3041 )) goto bound_fail;
777f7c56 3042
83f78d1a
FC
3043 byte_len = len;
3044 byte_pos = utf8_curlen
d931b1be
NC
3045 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3046
2154eca7 3047 tmps += byte_pos;
bbddc9e0
CS
3048
3049 if (rvalue) {
3050 SvTAINTED_off(TARG); /* decontaminate */
3051 SvUTF8_off(TARG); /* decontaminate */
3052 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3053#ifdef USE_LOCALE_COLLATE
bbddc9e0 3054 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3055#endif
bbddc9e0
CS
3056 if (utf8_curlen)
3057 SvUTF8_on(TARG);
3058 }
2154eca7 3059
f7928d6c 3060 if (repl) {
13e30c65
JH
3061 SV* repl_sv_copy = NULL;
3062
3063 if (repl_need_utf8_upgrade) {
3064 repl_sv_copy = newSVsv(repl_sv);
3065 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3066 repl = SvPV_const(repl_sv_copy, repl_len);
bf32a30c 3067 repl_is_utf8 = DO_UTF8(repl_sv_copy) && repl_len;
13e30c65 3068 }
24fcb59f
FC
3069 if (SvROK(sv))
3070 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3071 "Attempt to use reference as lvalue in substr"
3072 );
502d9230
VP
3073 if (!SvOK(sv))
3074 sv_setpvs(sv, "");
777f7c56 3075 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
9402d6ed 3076 if (repl_is_utf8)
f7928d6c 3077 SvUTF8_on(sv);
ef8d46e8 3078 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3079 }
79072805 3080 }
849ca7ee 3081 SPAGAIN;
bbddc9e0
CS
3082 if (rvalue) {
3083 SvSETMAGIC(TARG);
3084 PUSHs(TARG);
3085 }
79072805 3086 RETURN;
777f7c56 3087
1c900557 3088bound_fail:
83f78d1a 3089 if (repl)
777f7c56
EB
3090 Perl_croak(aTHX_ "substr outside of string");
3091 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3092 RETPUSHUNDEF;
79072805
LW
3093}
3094
3095PP(pp_vec)
3096{
2154eca7 3097 dVAR; dSP;
1b6737cc
AL
3098 register const IV size = POPi;
3099 register const IV offset = POPi;
3100 register SV * const src = POPs;
3101 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3102 SV * ret;
a0d0e21e 3103
81e118e0 3104 if (lvalue) { /* it's an lvalue! */
2154eca7
EB
3105 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3106 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3107 LvTYPE(ret) = 'v';
3108 LvTARG(ret) = SvREFCNT_inc_simple(src);
3109 LvTARGOFF(ret) = offset;
3110 LvTARGLEN(ret) = size;
3111 }
3112 else {
3113 dTARGET;
3114 SvTAINTED_off(TARG); /* decontaminate */
3115 ret = TARG;
79072805
LW
3116 }
3117
2154eca7
EB
3118 sv_setuv(ret, do_vecget(src, offset, size));
3119 PUSHs(ret);
79072805
LW
3120 RETURN;
3121}
3122
3123PP(pp_index)
3124{
97aff369 3125 dVAR; dSP; dTARGET;
79072805
LW
3126 SV *big;
3127 SV *little;
c445ea15 3128 SV *temp = NULL;
ad66a58c 3129 STRLEN biglen;
2723d216 3130 STRLEN llen = 0;
79072805
LW
3131 I32 offset;
3132 I32 retval;
73ee8be2
NC
3133 const char *big_p;
3134 const char *little_p;
2f040f7f
NC
3135 bool big_utf8;
3136 bool little_utf8;
2723d216 3137 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3138 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3139
e1dccc0d
Z
3140 if (threeargs)
3141 offset = POPi;
79072805
LW
3142 little = POPs;
3143 big = POPs;
73ee8be2
NC
3144 big_p = SvPV_const(big, biglen);
3145 little_p = SvPV_const(little, llen);
3146
e609e586
NC
3147 big_utf8 = DO_UTF8(big);
3148 little_utf8 = DO_UTF8(little);
3149 if (big_utf8 ^ little_utf8) {
3150 /* One needs to be upgraded. */
2f040f7f
NC
3151 if (little_utf8 && !PL_encoding) {
3152 /* Well, maybe instead we might be able to downgrade the small
3153 string? */
1eced8f8 3154 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC
3155 &little_utf8);
3156 if (little_utf8) {
3157 /* If the large string is ISO-8859-1, and it's not possible to
3158 convert the small string to ISO-8859-1, then there is no
3159 way that it could be found anywhere by index. */
3160 retval = -1;
3161 goto fail;
3162 }
e609e586 3163
2f040f7f
NC
3164 /* At this point, pv is a malloc()ed string. So donate it to temp
3165 to ensure it will get free()d */
3166 little = temp = newSV(0);
73ee8be2
NC
3167 sv_usepvn(temp, pv, llen);
3168 little_p = SvPVX(little);
e609e586 3169 } else {
73ee8be2
NC
3170 temp = little_utf8
3171 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f
NC
3172
3173 if (PL_encoding) {
3174 sv_recode_to_utf8(temp, PL_encoding);
3175 } else {
3176 sv_utf8_upgrade(temp);
3177 }
3178 if (little_utf8) {
3179 big = temp;
3180 big_utf8 = TRUE;
73ee8be2 3181 big_p = SvPV_const(big, biglen);
2f040f7f
NC
3182 } else {
3183 little = temp;
73ee8be2 3184 little_p = SvPV_const(little, llen);
2f040f7f 3185 }
e609e586
NC
3186 }
3187 }
73ee8be2
NC
3188 if (SvGAMAGIC(big)) {
3189 /* Life just becomes a lot easier if I use a temporary here.
3190 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3191 will trigger magic and overloading again, as will fbm_instr()
3192 */
59cd0e26
NC
3193 big = newSVpvn_flags(big_p, biglen,
3194 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3195 big_p = SvPVX(big);
3196 }
e4e44778 3197 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC
3198 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3199 warn on undef, and we've already triggered a warning with the
3200 SvPV_const some lines above. We can't remove that, as we need to
3201 call some SvPV to trigger overloading early and find out if the
3202 string is UTF-8.
3203 This is all getting to messy. The API isn't quite clean enough,
3204 because data access has side effects.
3205 */
59cd0e26
NC
3206 little = newSVpvn_flags(little_p, llen,
3207 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3208 little_p = SvPVX(little);
3209 }
e609e586 3210
d3e26383 3211 if (!threeargs)
2723d216 3212 offset = is_index ? 0 : biglen;
a0ed51b3 3213 else {
ad66a58c 3214 if (big_utf8 && offset > 0)
a0ed51b3 3215 sv_pos_u2b(big, &offset, 0);
73ee8be2
NC
3216 if (!is_index)
3217 offset += llen;
a0ed51b3 3218 }
79072805
LW
3219 if (offset < 0)
3220 offset = 0;
ad66a58c
NC
3221 else if (offset > (I32)biglen)
3222 offset = biglen;
73ee8be2
NC
3223 if (!(little_p = is_index
3224 ? fbm_instr((unsigned char*)big_p + offset,
3225 (unsigned char*)big_p + biglen, little, 0)
3226 : rninstr(big_p, big_p + offset,
3227 little_p, little_p + llen)))
a0ed51b3 3228 retval = -1;
ad66a58c 3229 else {
73ee8be2 3230 retval = little_p - big_p;
ad66a58c
NC
3231 if (retval > 0 && big_utf8)
3232 sv_pos_b2u(big, &retval);
3233 }
ef8d46e8 3234 SvREFCNT_dec(temp);
2723d216 3235 fail:
e1dccc0d 3236 PUSHi(retval);
79072805
LW
3237 RETURN;
3238}
3239
3240PP(pp_sprintf)
3241{
97aff369 3242 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3243 SvTAINTED_off(TARG);
79072805 3244 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3245 TAINT_IF(SvTAINTED(TARG));
79072805
LW
3246 SP = ORIGMARK;
3247 PUSHTARG;
3248 RETURN;
3249}
3250
79072805
LW
3251PP(pp_ord)
3252{
97aff369 3253 dVAR; dSP; dTARGET;
1eced8f8 3254
7df053ec 3255 SV *argsv = POPs;
ba210ebe 3256 STRLEN len;
349d4f2f 3257 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3258
799ef3cb 3259 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3260 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3261 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH
3262 argsv = tmpsv;
3263 }
79072805 3264
872c91ae 3265 XPUSHu(DO_UTF8(argsv) ?
89ebb4a3 3266 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
5fc32dea 3267 (UV)(*s & 0xff));
68795e93 3268
79072805
LW
3269 RETURN;
3270}
3271
463ee0b2
LW
3272PP(pp_chr)
3273{
97aff369 3274 dVAR; dSP; dTARGET;
463ee0b2 3275 char *tmps;
8a064bd6
JH
3276 UV value;
3277
3278 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3279 ||
3280 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3281 if (IN_BYTES) {
3282 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3283 } else {
3284 (void) POPs; /* Ignore the argument value. */
3285 value = UNICODE_REPLACEMENT;
3286 }
3287 } else {
3288 value = POPu;
3289 }
463ee0b2 3290
862a34c6 3291 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3292
0064a8a9 3293 if (value > 255 && !IN_BYTES) {
eb160463 3294 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3295 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3296 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW
3297 *tmps = '\0';
3298 (void)SvPOK_only(TARG);
aa6ffa16 3299 SvUTF8_on(TARG);
a0ed51b3
LW
3300 XPUSHs(TARG);
3301 RETURN;
3302 }
3303
748a9306 3304 SvGROW(TARG,2);
463ee0b2
LW
3305 SvCUR_set(TARG, 1);
3306 tmps = SvPVX(TARG);
eb160463 3307 *tmps++ = (char)value;
748a9306 3308 *tmps = '\0';
a0d0e21e 3309 (void)SvPOK_only(TARG);
4c5ed6e2 3310
88632417 3311 if (PL_encoding && !IN_BYTES) {
799ef3cb 3312 sv_recode_to_utf8(TARG, PL_encoding);
88632417 3313 tmps = SvPVX(TARG);
28936164
KW
3314 if (SvCUR(TARG) == 0
3315 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3316 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3317 {
4c5ed6e2 3318 SvGROW(TARG, 2);
d5a15ac2 3319 tmps = SvPVX(TARG);
4c5ed6e2
TS
3320 SvCUR_set(TARG, 1);
3321 *tmps++ = (char)value;
88632417 3322 *tmps = '\0';
4c5ed6e2 3323 SvUTF8_off(TARG);
88632417
JH
3324 }
3325 }
4c5ed6e2 3326
463ee0b2
LW
3327 XPUSHs(TARG);
3328 RETURN;
3329}
3330
79072805
LW
3331PP(pp_crypt)
3332{
79072805 3333#ifdef HAS_CRYPT
97aff369 3334 dVAR; dSP; dTARGET;
5f74f29c 3335 dPOPTOPssrl;
85c16d83 3336 STRLEN len;
10516c54 3337 const char *tmps = SvPV_const(left, len);
2bc69dc4 3338
85c16d83 3339 if (DO_UTF8(left)) {
2bc69dc4 3340 /* If Unicode, try to downgrade.
f2791508
JH
3341 * If not possible, croak.
3342 * Yes, we made this up. */
1b6737cc 3343 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3344
f2791508 3345 SvUTF8_on(tsv);
2bc69dc4 3346 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3347 tmps = SvPV_const(tsv, len);
85c16d83 3348 }
05404ffe
JH
3349# ifdef USE_ITHREADS
3350# ifdef HAS_CRYPT_R
3351 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3352 /* This should be threadsafe because in ithreads there is only
3353 * one thread per interpreter. If this would not be true,
3354 * we would need a mutex to protect this malloc. */
3355 PL_reentrant_buffer->_crypt_struct_buffer =
3356 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3357#if defined(__GLIBC__) || defined(__EMX__)
3358 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3359 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3360 /* work around glibc-2.2.5 bug */
3361 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3362 }
05404ffe 3363#endif
6ab58e4d 3364 }
05404ffe
JH
3365# endif /* HAS_CRYPT_R */
3366# endif /* USE_ITHREADS */
5f74f29c 3367# ifdef FCRYPT
83003860 3368 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3369# else
83003860 3370 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3371# endif
ec93b65f 3372 SETTARG;
4808266b 3373 RETURN;
79072805 3374#else
b13b2135 3375 DIE(aTHX_
79072805
LW
3376 "The crypt() function is unimplemented due to excessive paranoia.");
3377#endif
79072805
LW
3378}
3379
00f254e2
KW
3380/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3381 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3382
00f254e2 3383/* Generates code to store a unicode codepoint c that is known to occupy
12b093a1
KW
3384 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1,
3385 * and p is advanced to point to the next available byte after the two bytes */
00f254e2
KW
3386#define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3387 STMT_START { \
3388 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3389 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3390 } STMT_END
3391
79072805
LW
3392PP(pp_ucfirst)
3393{
00f254e2
KW
3394 /* Actually is both lcfirst() and ucfirst(). Only the first character
3395 * changes. This means that possibly we can change in-place, ie., just
3396 * take the source and change that one character and store it back, but not
3397 * if read-only etc, or if the length changes */
3398
97aff369 3399 dVAR;
39644a26 3400 dSP;
d54190f6 3401 SV *source = TOPs;
00f254e2 3402 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC
3403 STRLEN need;
3404 SV *dest;
00f254e2
KW
3405 bool inplace; /* ? Convert first char only, in-place */
3406 bool doing_utf8 = FALSE; /* ? using utf8 */
3407 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3408 const int op_type = PL_op->op_type;
d54190f6
NC
3409 const U8 *s;
3410 U8 *d;
3411 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW
3412 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3413 * stored as UTF-8 at s. */
3414 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3415 * lowercased) character stored in tmpbuf. May be either
3416 * UTF-8 or not, but in either case is the number of bytes */
094a2f8c 3417 bool tainted = FALSE;
d54190f6
NC
3418
3419 SvGETMAGIC(source);
3420 if (SvOK(source)) {
3421 s = (const U8*)SvPV_nomg_const(source, slen);
3422 } else {
0a0ffbce
RGS
3423 if (ckWARN(WARN_UNINITIALIZED))
3424 report_uninit(source);
1eced8f8 3425 s = (const U8*)"";
d54190f6
NC
3426 slen = 0;
3427 }
a0ed51b3 3428
00f254e2
KW
3429 /* We may be able to get away with changing only the first character, in
3430 * place, but not if read-only, etc. Later we may discover more reasons to
3431 * not convert in-place. */
3432 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3433
3434 /* First calculate what the changed first character should be. This affects
3435 * whether we can just swap it out, leaving the rest of the string unchanged,
3436 * or even if have to convert the dest to UTF-8 when the source isn't */
3437
3438 if (! slen) { /* If empty */
3439 need = 1; /* still need a trailing NUL */
b7576bcb 3440 ulen = 0;
00f254e2
KW
3441 }
3442 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3443 doing_utf8 = TRUE;
17e95c9d 3444 ulen = UTF8SKIP(s);
094a2f8c
KW
3445 if (op_type == OP_UCFIRST) {
3446 _to_utf8_title_flags(s, tmpbuf, &tculen,
3447 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3448 }
3449 else {
3450 _to_utf8_lower_flags(s, tmpbuf, &tculen,
3451 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3452 }
00f254e2 3453
17e95c9d
KW
3454 /* we can't do in-place if the length changes. */
3455 if (ulen != tculen) inplace = FALSE;
3456 need = slen + 1 - ulen + tculen;
d54190f6 3457 }
00f254e2
KW
3458 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3459 * latin1 is treated as caseless. Note that a locale takes
3460 * precedence */
167d19f2 3461 ulen = 1; /* Original character is 1 byte */
00f254e2
KW
3462 tculen = 1; /* Most characters will require one byte, but this will
3463 * need to be overridden for the tricky ones */
3464 need = slen + 1;
3465
3466 if (op_type == OP_LCFIRST) {
d54190f6 3467
00f254e2
KW
3468 /* lower case the first letter: no trickiness for any character */
3469 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3470 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3471 }
3472 /* is ucfirst() */
3473 else if (IN_LOCALE_RUNTIME) {
3474 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3475 * have upper and title case different
3476 */
3477 }
3478 else if (! IN_UNI_8_BIT) {
3479 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3480 * on EBCDIC machines whatever the
3481 * native function does */
3482 }
3483 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
167d19f2
KW
3484 UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3485 if (tculen > 1) {
3486 assert(tculen == 2);
3487
3488 /* If the result is an upper Latin1-range character, it can
3489 * still be represented in one byte, which is its ordinal */
3490 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3491 *tmpbuf = (U8) title_ord;
3492 tculen = 1;
00f254e2
KW
3493 }
3494 else {
167d19f2
KW
3495 /* Otherwise it became more than one ASCII character (in
3496 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3497 * beyond Latin1, so the number of bytes changed, so can't
3498 * replace just the first character in place. */
3499 inplace = FALSE;
3500
3501 /* If the result won't fit in a byte, the entire result will
3502 * have to be in UTF-8. Assume worst case sizing in
3503 * conversion. (all latin1 characters occupy at most two bytes
3504 * in utf8) */
3505 if (title_ord > 255) {
3506 doing_utf8 = TRUE;
3507 convert_source_to_utf8 = TRUE;
3508 need = slen * 2 + 1;
3509
3510 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3511 * (both) characters whose title case is above 255 is
3512 * 2. */
3513 ulen = 2;
3514 }
3515 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3516 need = slen + 1 + 1;
3517 }
00f254e2 3518 }
167d19f2 3519 }
00f254e2
KW
3520 } /* End of use Unicode (Latin1) semantics */
3521 } /* End of changing the case of the first character */
3522
3523 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3524 * generate the result */
3525 if (inplace) {
3526
3527 /* We can convert in place. This means we change just the first
3528 * character without disturbing the rest; no need to grow */
d54190f6
NC
3529 dest = source;
3530 s = d = (U8*)SvPV_force_nomg(source, slen);
3531 } else {
3532 dTARGET;
3533
3534 dest = TARG;
3535
00f254e2
KW
3536 /* Here, we can't convert in place; we earlier calculated how much
3537 * space we will need, so grow to accommodate that */
d54190f6 3538 SvUPGRADE(dest, SVt_PV);
3b416f41 3539 d = (U8*)SvGROW(dest, need);
d54190f6
NC
3540 (void)SvPOK_only(dest);
3541
3542 SETs(dest);
d54190f6 3543 }
44bc797b 3544
d54190f6 3545 if (doing_utf8) {
00f254e2
KW
3546 if (! inplace) {
3547 if (! convert_source_to_utf8) {
3548
3549 /* Here both source and dest are in UTF-8, but have to create
3550 * the entire output. We initialize the result to be the
3551 * title/lower cased first character, and then append the rest
3552 * of the string. */
3553 sv_setpvn(dest, (char*)tmpbuf, tculen);
3554 if (slen > ulen) {
3555 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3556 }
3557 }
3558 else {
3559 const U8 *const send = s + slen;
3560
3561 /* Here the dest needs to be in UTF-8, but the source isn't,
3562 * except we earlier UTF-8'd the first character of the source
3563 * into tmpbuf. First put that into dest, and then append the
3564 * rest of the source, converting it to UTF-8 as we go. */
3565
3566 /* Assert tculen is 2 here because the only two characters that
3567 * get to this part of the code have 2-byte UTF-8 equivalents */
3568 *d++ = *tmpbuf;
3569 *d++ = *(tmpbuf + 1);
3570 s++; /* We have just processed the 1st char */
3571
3572 for (; s < send; s++) {
3573 d = uvchr_to_utf8(d, *s);
3574 }
3575 *d = '\0';
3576 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3577 }
d54190f6 3578 SvUTF8_on(dest);
a0ed51b3 3579 }
00f254e2 3580 else { /* in-place UTF-8. Just overwrite the first character */
d54190f6
NC
3581 Copy(tmpbuf, d, tculen, U8);
3582 SvCUR_set(dest, need - 1);
a0ed51b3 3583 }
094a2f8c
KW
3584
3585 if (tainted) {
3586 TAINT;
3587 SvTAINTED_on(dest);
3588 }
a0ed51b3 3589 }
00f254e2
KW
3590 else { /* Neither source nor dest are in or need to be UTF-8 */
3591 if (slen) {
2de3dbcc 3592 if (IN_LOCALE_RUNTIME) {
31351b04 3593 TAINT;
d54190f6 3594 SvTAINTED_on(dest);
31351b04 3595 }
00f254e2
KW
3596 if (inplace) { /* in-place, only need to change the 1st char */
3597 *d = *tmpbuf;
3598 }
3599 else { /* Not in-place */
3600
3601 /* Copy the case-changed character(s) from tmpbuf */
3602 Copy(tmpbuf, d, tculen, U8);
3603 d += tculen - 1; /* Code below expects d to point to final
3604 * character stored */
3605 }
3606 }
3607 else { /* empty source */
3608 /* See bug #39028: Don't taint if empty */
d54190f6
NC
3609 *d = *s;
3610 }
3611
00f254e2
KW
3612 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3613 * the destination to retain that flag */
d54190f6
NC
3614 if (SvUTF8(source))
3615 SvUTF8_on(dest);
3616
00f254e2 3617 if (!inplace) { /* Finish the rest of the string, unchanged */
d54190f6
NC
3618 /* This will copy the trailing NUL */
3619 Copy(s + 1, d + 1, slen, U8);
3620 SvCUR_set(dest, need - 1);
bbce6d69 3621 }
bbce6d69 3622 }
539689e7
FC
3623 if (dest != source && SvTAINTED(source))
3624 SvTAINT(dest);
d54190f6 3625 SvSETMAGIC(dest);
79072805
LW
3626 RETURN;
3627}
3628
67306194
NC
3629/* There's so much setup/teardown code common between uc and lc, I wonder if
3630 it would be worth merging the two, and just having a switch outside each
00f254e2 3631 of the three tight loops. There is less and less commonality though */
79072805
LW
3632PP(pp_uc)
3633{
97aff369 3634 dVAR;
39644a26 3635 dSP;
67306194 3636 SV *source = TOPs;
463ee0b2 3637 STRLEN len;
67306194
NC
3638 STRLEN min;
3639 SV *dest;
3640 const U8 *s;
3641 U8 *d;