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