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