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