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