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