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