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