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