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