This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix assertion failure with undef &my_sub/&anon
[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
DM
575 else if (SvPADTMP(sv)) {
576 assert(!IS_PADGV(sv));
f2933f5f 577 sv = newSVsv(sv);
60779a30 578 }
71be2cbc
PP
579 else {
580 SvTEMP_off(sv);
b37c2d43 581 SvREFCNT_inc_void_NN(sv);
71be2cbc
PP
582 }
583 rv = sv_newmortal();
4df7f6af 584 sv_upgrade(rv, SVt_IV);
b162af07 585 SvRV_set(rv, sv);
71be2cbc
PP
586 SvROK_on(rv);
587 return rv;
588}
589
79072805
LW
590PP(pp_ref)
591{
3c1e67ac
DD
592 dSP;
593 SV * const sv = TOPs;
f12c7020 594
511ddbdf
FC
595 SvGETMAGIC(sv);
596 if (!SvROK(sv))
3c1e67ac
DD
597 SETs(&PL_sv_no);
598 else {
599 dTARGET;
600 SETs(TARG);
601 /* use the return value that is in a register, its the same as TARG */
602 TARG = sv_ref(TARG,SvRV(sv),TRUE);
603 SvSETMAGIC(TARG);
604 }
79072805 605
3c1e67ac 606 return NORMAL;
79072805
LW
607}
608
609PP(pp_bless)
610{
20b7effb 611 dSP;
463ee0b2 612 HV *stash;
79072805 613
463ee0b2 614 if (MAXARG == 1)
dcdfe746 615 {
c2f922f1 616 curstash:
11faa288 617 stash = CopSTASH(PL_curcop);
dcdfe746
FC
618 if (SvTYPE(stash) != SVt_PVHV)
619 Perl_croak(aTHX_ "Attempt to bless into a freed package");
620 }
7b8d334a 621 else {
1b6737cc 622 SV * const ssv = POPs;
7b8d334a 623 STRLEN len;
e1ec3a88 624 const char *ptr;
81689caa 625
c2f922f1 626 if (!ssv) goto curstash;
8d9dd4b9 627 SvGETMAGIC(ssv);
c7ea825d
FC
628 if (SvROK(ssv)) {
629 if (!SvAMAGIC(ssv)) {
630 frog:
81689caa 631 Perl_croak(aTHX_ "Attempt to bless into a reference");
c7ea825d
FC
632 }
633 /* SvAMAGIC is on here, but it only means potentially overloaded,
634 so after stringification: */
635 ptr = SvPV_nomg_const(ssv,len);
636 /* We need to check the flag again: */
637 if (!SvAMAGIC(ssv)) goto frog;
638 }
639 else ptr = SvPV_nomg_const(ssv,len);
a2a5de95
NC
640 if (len == 0)
641 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
642 "Explicit blessing to '' (assuming package main)");
e69c50fe 643 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
7b8d334a 644 }
a0d0e21e 645
5d3fdfeb 646 (void)sv_bless(TOPs, stash);
79072805
LW
647 RETURN;
648}
649
fb73857a
PP
650PP(pp_gelem)
651{
20b7effb 652 dSP;
b13b2135 653
1b6737cc 654 SV *sv = POPs;
a180b31a
BF
655 STRLEN len;
656 const char * const elem = SvPV_const(sv, len);
159b6efe 657 GV * const gv = MUTABLE_GV(POPs);
c445ea15 658 SV * tmpRef = NULL;
1b6737cc 659
c445ea15 660 sv = NULL;
c4ba80c3
NC
661 if (elem) {
662 /* elem will always be NUL terminated. */
1b6737cc 663 const char * const second_letter = elem + 1;
c4ba80c3
NC
664 switch (*elem) {
665 case 'A':
a180b31a 666 if (len == 5 && strEQ(second_letter, "RRAY"))
e14698d8 667 {
ad64d0ec 668 tmpRef = MUTABLE_SV(GvAV(gv));
e14698d8
FC
669 if (tmpRef && !AvREAL((const AV *)tmpRef)
670 && AvREIFY((const AV *)tmpRef))
671 av_reify(MUTABLE_AV(tmpRef));
672 }
c4ba80c3
NC
673 break;
674 case 'C':
a180b31a 675 if (len == 4 && strEQ(second_letter, "ODE"))
ad64d0ec 676 tmpRef = MUTABLE_SV(GvCVu(gv));
c4ba80c3
NC
677 break;
678 case 'F':
a180b31a 679 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
c4ba80c3
NC
680 /* finally deprecated in 5.8.0 */
681 deprecate("*glob{FILEHANDLE}");
ad64d0ec 682 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC
683 }
684 else
a180b31a 685 if (len == 6 && strEQ(second_letter, "ORMAT"))
ad64d0ec 686 tmpRef = MUTABLE_SV(GvFORM(gv));
c4ba80c3
NC
687 break;
688 case 'G':
a180b31a 689 if (len == 4 && strEQ(second_letter, "LOB"))
ad64d0ec 690 tmpRef = MUTABLE_SV(gv);
c4ba80c3
NC
691 break;
692 case 'H':
a180b31a 693 if (len == 4 && strEQ(second_letter, "ASH"))
ad64d0ec 694 tmpRef = MUTABLE_SV(GvHV(gv));
c4ba80c3
NC
695 break;
696 case 'I':
a180b31a 697 if (*second_letter == 'O' && !elem[2] && len == 2)
ad64d0ec 698 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC
699 break;
700 case 'N':
a180b31a 701 if (len == 4 && strEQ(second_letter, "AME"))
a663657d 702 sv = newSVhek(GvNAME_HEK(gv));
c4ba80c3
NC
703 break;
704 case 'P':
a180b31a 705 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
7fa3a4ab
NC
706 const HV * const stash = GvSTASH(gv);
707 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
396482e1 708 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
c4ba80c3
NC
709 }
710 break;
711 case 'S':
a180b31a 712 if (len == 6 && strEQ(second_letter, "CALAR"))
f9d52e31 713 tmpRef = GvSVn(gv);
c4ba80c3 714 break;
39b99f21 715 }
fb73857a 716 }
76e3520e
GS
717 if (tmpRef)
718 sv = newRV(tmpRef);
fb73857a
PP
719 if (sv)
720 sv_2mortal(sv);
721 else
3280af22 722 sv = &PL_sv_undef;
fb73857a
PP
723 XPUSHs(sv);
724 RETURN;
725}
726
a0d0e21e 727/* Pattern matching */
79072805 728
a0d0e21e 729PP(pp_study)
79072805 730{
20b7effb 731 dSP; dPOPss;
a0d0e21e
LW
732 STRLEN len;
733
1fa930f2 734 (void)SvPV(sv, len);
bc9a5256 735 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
32f0ea87 736 /* Historically, study was skipped in these cases. */
a4f4e906
NC
737 RETPUSHNO;
738 }
739
a58a85fa 740 /* Make study a no-op. It's no longer useful and its existence
32f0ea87 741 complicates matters elsewhere. */
1e422769 742 RETPUSHYES;
79072805
LW
743}
744
a0d0e21e 745PP(pp_trans)
79072805 746{
20b7effb 747 dSP; dTARG;
a0d0e21e
LW
748 SV *sv;
749
533c011a 750 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 751 sv = POPs;
59f00321
RGS
752 else if (PL_op->op_private & OPpTARGET_MY)
753 sv = GETTARGET;
79072805 754 else {
54b9620d 755 sv = DEFSV;
a0d0e21e 756 EXTEND(SP,1);
79072805 757 }
bb16bae8 758 if(PL_op->op_type == OP_TRANSR) {
290797f7
FC
759 STRLEN len;
760 const char * const pv = SvPV(sv,len);
761 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
bb16bae8 762 do_trans(newsv);
290797f7 763 PUSHs(newsv);
bb16bae8 764 }
5bbe7184
FC
765 else {
766 TARG = sv_newmortal();
767 PUSHi(do_trans(sv));
768 }
a0d0e21e 769 RETURN;
79072805
LW
770}
771
a0d0e21e 772/* Lvalue operators. */
79072805 773
81745e4e
NC
774static void
775S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
776{
81745e4e
NC
777 STRLEN len;
778 char *s;
779
780 PERL_ARGS_ASSERT_DO_CHOMP;
781
782 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
783 return;
784 if (SvTYPE(sv) == SVt_PVAV) {
785 I32 i;
786 AV *const av = MUTABLE_AV(sv);
787 const I32 max = AvFILL(av);
788
789 for (i = 0; i <= max; i++) {
790 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
791 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
792 do_chomp(retval, sv, chomping);
793 }
794 return;
795 }
796 else if (SvTYPE(sv) == SVt_PVHV) {
797 HV* const hv = MUTABLE_HV(sv);
798 HE* entry;
799 (void)hv_iterinit(hv);
800 while ((entry = hv_iternext(hv)))
801 do_chomp(retval, hv_iterval(hv,entry), chomping);
802 return;
803 }
804 else if (SvREADONLY(sv)) {
cb077ed2 805 Perl_croak_no_modify();
81745e4e 806 }
e3918bb7
FC
807 else if (SvIsCOW(sv)) {
808 sv_force_normal_flags(sv, 0);
809 }
81745e4e
NC
810
811 if (PL_encoding) {
812 if (!SvUTF8(sv)) {
813 /* XXX, here sv is utf8-ized as a side-effect!
814 If encoding.pm is used properly, almost string-generating
815 operations, including literal strings, chr(), input data, etc.
816 should have been utf8-ized already, right?
817 */
818 sv_recode_to_utf8(sv, PL_encoding);
819 }
820 }
821
822 s = SvPV(sv, len);
823 if (chomping) {
824 char *temp_buffer = NULL;
825 SV *svrecode = NULL;
826
827 if (s && len) {
828 s += --len;
829 if (RsPARA(PL_rs)) {
830 if (*s != '\n')
831 goto nope;
832 ++SvIVX(retval);
833 while (len && s[-1] == '\n') {
834 --len;
835 --s;
836 ++SvIVX(retval);
837 }
838 }
839 else {
840 STRLEN rslen, rs_charlen;
841 const char *rsptr = SvPV_const(PL_rs, rslen);
842
843 rs_charlen = SvUTF8(PL_rs)
844 ? sv_len_utf8(PL_rs)
845 : rslen;
846
847 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
848 /* Assumption is that rs is shorter than the scalar. */
849 if (SvUTF8(PL_rs)) {
850 /* RS is utf8, scalar is 8 bit. */
851 bool is_utf8 = TRUE;
852 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
853 &rslen, &is_utf8);
854 if (is_utf8) {
855 /* Cannot downgrade, therefore cannot possibly match
856 */
857 assert (temp_buffer == rsptr);
858 temp_buffer = NULL;
859 goto nope;
860 }
861 rsptr = temp_buffer;
862 }
863 else if (PL_encoding) {
864 /* RS is 8 bit, encoding.pm is used.
865 * Do not recode PL_rs as a side-effect. */
866 svrecode = newSVpvn(rsptr, rslen);
867 sv_recode_to_utf8(svrecode, PL_encoding);
868 rsptr = SvPV_const(svrecode, rslen);
869 rs_charlen = sv_len_utf8(svrecode);
870 }
871 else {
872 /* RS is 8 bit, scalar is utf8. */
873 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
874 rsptr = temp_buffer;
875 }
876 }
877 if (rslen == 1) {
878 if (*s != *rsptr)
879 goto nope;
880 ++SvIVX(retval);
881 }
882 else {
883 if (len < rslen - 1)
884 goto nope;
885 len -= rslen - 1;
886 s -= rslen - 1;
887 if (memNE(s, rsptr, rslen))
888 goto nope;
889 SvIVX(retval) += rs_charlen;
890 }
891 }
fbac7ddf 892 s = SvPV_force_nomg_nolen(sv);
81745e4e
NC
893 SvCUR_set(sv, len);
894 *SvEND(sv) = '\0';
895 SvNIOK_off(sv);
896 SvSETMAGIC(sv);
897 }
898 nope:
899
900 SvREFCNT_dec(svrecode);
901
902 Safefree(temp_buffer);
903 } else {
904 if (len && !SvPOK(sv))
905 s = SvPV_force_nomg(sv, len);
906 if (DO_UTF8(sv)) {
907 if (s && len) {
908 char * const send = s + len;
909 char * const start = s;
910 s = send - 1;
911 while (s > start && UTF8_IS_CONTINUATION(*s))
912 s--;
913 if (is_utf8_string((U8*)s, send - s)) {
914 sv_setpvn(retval, s, send - s);
915 *s = '\0';
916 SvCUR_set(sv, s - start);
917 SvNIOK_off(sv);
918 SvUTF8_on(retval);
919 }
920 }
921 else
922 sv_setpvs(retval, "");
923 }
924 else if (s && len) {
925 s += --len;
926 sv_setpvn(retval, s, 1);
927 *s = '\0';
928 SvCUR_set(sv, len);
929 SvUTF8_off(sv);
930 SvNIOK_off(sv);
931 }
932 else
933 sv_setpvs(retval, "");
934 SvSETMAGIC(sv);
935 }
936}
937
a0d0e21e
LW
938PP(pp_schop)
939{
20b7effb 940 dSP; dTARGET;
fa54efae
NC
941 const bool chomping = PL_op->op_type == OP_SCHOMP;
942
943 if (chomping)
944 sv_setiv(TARG, 0);
945 do_chomp(TARG, TOPs, chomping);
a0d0e21e
LW
946 SETTARG;
947 RETURN;
79072805
LW
948}
949
a0d0e21e 950PP(pp_chop)
79072805 951{
20b7effb 952 dSP; dMARK; dTARGET; dORIGMARK;
fa54efae 953 const bool chomping = PL_op->op_type == OP_CHOMP;
8ec5e241 954
fa54efae
NC
955 if (chomping)
956 sv_setiv(TARG, 0);
20cf1f79 957 while (MARK < SP)
fa54efae 958 do_chomp(TARG, *++MARK, chomping);
20cf1f79
NC
959 SP = ORIGMARK;
960 XPUSHTARG;
a0d0e21e 961 RETURN;
79072805
LW
962}
963
a0d0e21e
LW
964PP(pp_undef)
965{
20b7effb 966 dSP;
a0d0e21e
LW
967 SV *sv;
968
533c011a 969 if (!PL_op->op_private) {
774d564b 970 EXTEND(SP, 1);
a0d0e21e 971 RETPUSHUNDEF;
774d564b 972 }
79072805 973
a0d0e21e
LW
974 sv = POPs;
975 if (!sv)
976 RETPUSHUNDEF;
85e6fe83 977
4dda930b
FC
978 if (SvTHINKFIRST(sv))
979 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
85e6fe83 980
a0d0e21e
LW
981 switch (SvTYPE(sv)) {
982 case SVt_NULL:
983 break;
984 case SVt_PVAV:
60edcf09 985 av_undef(MUTABLE_AV(sv));
a0d0e21e
LW
986 break;
987 case SVt_PVHV:
60edcf09 988 hv_undef(MUTABLE_HV(sv));
a0d0e21e
LW
989 break;
990 case SVt_PVCV:
a2a5de95 991 if (cv_const_sv((const CV *)sv))
714cd18f
BF
992 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
993 "Constant subroutine %"SVf" undefined",
994 SVfARG(CvANON((const CV *)sv)
995 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
bdbfc51a
FC
996 : sv_2mortal(newSVhek(
997 CvNAMED(sv)
998 ? CvNAME_HEK((CV *)sv)
999 : GvENAME_HEK(CvGV((const CV *)sv))
1000 ))
1001 ));
5f66b61c 1002 /* FALLTHROUGH */
9607fc9c 1003 case SVt_PVFM:
6fc92669
GS
1004 {
1005 /* let user-undef'd sub keep its identity */
ea726b52 1006 GV* const gv = CvGV((const CV *)sv);
b290562e
FC
1007 HEK * const hek = CvNAME_HEK((CV *)sv);
1008 if (hek) share_hek_hek(hek);
7fcb4126 1009 if (gv) SvREFCNT_inc_void_NN(sv_2mortal((SV *)gv));
ea726b52 1010 cv_undef(MUTABLE_CV(sv));
b290562e
FC
1011 if (gv) CvGV_set(MUTABLE_CV(sv), gv);
1012 else if (hek) {
1013 SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
1014 CvNAMED_on(sv);
1015 }
6fc92669 1016 }
a0d0e21e 1017 break;
8e07c86e 1018 case SVt_PVGV:
bc1df6c2
FC
1019 assert(isGV_with_GP(sv));
1020 assert(!SvFAKE(sv));
1021 {
20408e3c 1022 GP *gp;
dd69841b
BB
1023 HV *stash;
1024
dd69841b 1025 /* undef *Pkg::meth_name ... */
e530fb81
FC
1026 bool method_changed
1027 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1028 && HvENAME_get(stash);
1029 /* undef *Foo:: */
1030 if((stash = GvHV((const GV *)sv))) {
1031 if(HvENAME_get(stash))
1032 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1033 else stash = NULL;
1034 }
dd69841b 1035
795eb8c8 1036 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
159b6efe 1037 gp_free(MUTABLE_GV(sv));
a02a5408 1038 Newxz(gp, 1, GP);
c43ae56f 1039 GvGP_set(sv, gp_ref(gp));
2e3295e3 1040#ifndef PERL_DONT_CREATE_GVSV
561b68a9 1041 GvSV(sv) = newSV(0);
2e3295e3 1042#endif
57843af0 1043 GvLINE(sv) = CopLINE(PL_curcop);
159b6efe 1044 GvEGV(sv) = MUTABLE_GV(sv);
20408e3c 1045 GvMULTI_on(sv);
e530fb81
FC
1046
1047 if(stash)
afdbe55d 1048 mro_package_moved(NULL, stash, (const GV *)sv, 0);
e530fb81
FC
1049 stash = NULL;
1050 /* undef *Foo::ISA */
1051 if( strEQ(GvNAME((const GV *)sv), "ISA")
1052 && (stash = GvSTASH((const GV *)sv))
1053 && (method_changed || HvENAME(stash)) )
1054 mro_isa_changed_in(stash);
1055 else if(method_changed)
1056 mro_method_changed_in(
da9043f5 1057 GvSTASH((const GV *)sv)
e530fb81
FC
1058 );
1059
6e592b3a 1060 break;
20408e3c 1061 }
a0d0e21e 1062 default:
b15aece3 1063 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
8bd4d4c5 1064 SvPV_free(sv);
c445ea15 1065 SvPV_set(sv, NULL);
4633a7c4 1066 SvLEN_set(sv, 0);
a0d0e21e 1067 }
0c34ef67 1068 SvOK_off(sv);
4633a7c4 1069 SvSETMAGIC(sv);
79072805 1070 }
a0d0e21e
LW
1071
1072 RETPUSHUNDEF;
79072805
LW
1073}
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)) {
1723 assert(!IS_PADGV(*SP));
da9e430b 1724 *SP = sv_mortalcopy(*SP);
60779a30 1725 }
976c8a39 1726 SvTEMP_off((*SP));
da9e430b 1727 }
976c8a39 1728#endif
a0d0e21e 1729 SP--;
79072805 1730 }
a0d0e21e
LW
1731 MARK++;
1732 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1733 items * sizeof(const SV *), count - 1);
a0d0e21e 1734 SP += max;
79072805 1735 }
a0d0e21e
LW
1736 else if (count <= 0)
1737 SP -= items;
79072805 1738 }
a0d0e21e 1739 else { /* Note: mark already snarfed by pp_list */
0bd48802 1740 SV * const tmpstr = POPs;
a0d0e21e 1741 STRLEN len;
9b877dbb 1742 bool isutf;
a1894d81 1743 static const char* const oom_string_extend =
2b573ace 1744 "Out of memory during string extend";
a0d0e21e 1745
6f1401dc
DM
1746 if (TARG != tmpstr)
1747 sv_setsv_nomg(TARG, tmpstr);
1748 SvPV_force_nomg(TARG, len);
9b877dbb 1749 isutf = DO_UTF8(TARG);
8ebc5c01
PP
1750 if (count != 1) {
1751 if (count < 1)
1752 SvCUR_set(TARG, 0);
1753 else {
c445ea15 1754 const STRLEN max = (UV)count * len;
19a94d75 1755 if (len > MEM_SIZE_MAX / count)
0157ef98 1756 Perl_croak(aTHX_ "%s", oom_string_extend);
2b573ace 1757 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
8569b9dc 1758 SvGROW(TARG, max + 1);
a0d0e21e 1759 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1760 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1761 }
a0d0e21e 1762 *SvEND(TARG) = '\0';
a0d0e21e 1763 }
dfcb284a
GS
1764 if (isutf)
1765 (void)SvPOK_only_UTF8(TARG);
1766 else
1767 (void)SvPOK_only(TARG);
b80b6069
RH
1768
1769 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1770 /* The parser saw this as a list repeat, and there
1771 are probably several items on the stack. But we're
1772 in scalar context, and there's no pp_list to save us
1773 now. So drop the rest of the items -- robin@kitsite.com
1774 */
1775 dMARK;
1776 SP = MARK;
1777 }
a0d0e21e 1778 PUSHTARG;
79072805 1779 }
a0d0e21e
LW
1780 RETURN;
1781}
79072805 1782
a0d0e21e
LW
1783PP(pp_subtract)
1784{
20b7effb 1785 dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
1786 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1787 svr = TOPs;
1788 svl = TOPm1s;
800401ee 1789 useleft = USE_LEFT(svl);
28e5dec8 1790#ifdef PERL_PRESERVE_IVUV
7dca457a
NC
1791 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1792 "bad things" happen if you rely on signed integers wrapping. */
01f91bf2 1793 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1794 /* Unless the left argument is integer in range we are going to have to
1795 use NV maths. Hence only attempt to coerce the right argument if
1796 we know the left is integer. */
eb578fdb 1797 UV auv = 0;
9c5ffd7c 1798 bool auvok = FALSE;
7dca457a
NC
1799 bool a_valid = 0;
1800
28e5dec8 1801 if (!useleft) {
7dca457a
NC
1802 auv = 0;
1803 a_valid = auvok = 1;
1804 /* left operand is undef, treat as zero. */
28e5dec8
JH
1805 } else {
1806 /* Left operand is defined, so is it IV? */
01f91bf2 1807 if (SvIV_please_nomg(svl)) {
800401ee
JH
1808 if ((auvok = SvUOK(svl)))
1809 auv = SvUVX(svl);
7dca457a 1810 else {
eb578fdb 1811 const IV aiv = SvIVX(svl);
7dca457a
NC
1812 if (aiv >= 0) {
1813 auv = aiv;
1814 auvok = 1; /* Now acting as a sign flag. */
1815 } else { /* 2s complement assumption for IV_MIN */
1816 auv = (UV)-aiv;
28e5dec8 1817 }
7dca457a
NC
1818 }
1819 a_valid = 1;
1820 }
1821 }
1822 if (a_valid) {
1823 bool result_good = 0;
1824 UV result;
eb578fdb 1825 UV buv;
800401ee 1826 bool buvok = SvUOK(svr);
9041c2e3 1827
7dca457a 1828 if (buvok)
800401ee 1829 buv = SvUVX(svr);
7dca457a 1830 else {
eb578fdb 1831 const IV biv = SvIVX(svr);
7dca457a
NC
1832 if (biv >= 0) {
1833 buv = biv;
1834 buvok = 1;
1835 } else
1836 buv = (UV)-biv;
1837 }
1838 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1839 else "IV" now, independent of how it came in.
7dca457a
NC
1840 if a, b represents positive, A, B negative, a maps to -A etc
1841 a - b => (a - b)
1842 A - b => -(a + b)
1843 a - B => (a + b)
1844 A - B => -(a - b)
1845 all UV maths. negate result if A negative.
1846 subtract if signs same, add if signs differ. */
1847
1848 if (auvok ^ buvok) {
1849 /* Signs differ. */
1850 result = auv + buv;
1851 if (result >= auv)
1852 result_good = 1;
1853 } else {
1854 /* Signs same */
1855 if (auv >= buv) {
1856 result = auv - buv;
1857 /* Must get smaller */
1858 if (result <= auv)
1859 result_good = 1;
1860 } else {
1861 result = buv - auv;
1862 if (result <= buv) {
1863 /* result really should be -(auv-buv). as its negation
1864 of true value, need to swap our result flag */
1865 auvok = !auvok;
1866 result_good = 1;
28e5dec8 1867 }
28e5dec8
JH
1868 }
1869 }
7dca457a
NC
1870 if (result_good) {
1871 SP--;
1872 if (auvok)
1873 SETu( result );
1874 else {
1875 /* Negate result */
1876 if (result <= (UV)IV_MIN)
1877 SETi( -(IV)result );
1878 else {
1879 /* result valid, but out of range for IV. */
1880 SETn( -(NV)result );
1881 }
1882 }
1883 RETURN;
1884 } /* Overflow, drop through to NVs. */
28e5dec8
JH
1885 }
1886 }
1887#endif
a0d0e21e 1888 {
6f1401dc 1889 NV value = SvNV_nomg(svr);
4efa5a16
RD
1890 (void)POPs;
1891
28e5dec8
JH
1892 if (!useleft) {
1893 /* left operand is undef, treat as zero - value */
1894 SETn(-value);
1895 RETURN;
1896 }
6f1401dc 1897 SETn( SvNV_nomg(svl) - value );
28e5dec8 1898 RETURN;
79072805 1899 }
a0d0e21e 1900}
79072805 1901
a0d0e21e
LW
1902PP(pp_left_shift)
1903{
20b7effb 1904 dSP; dATARGET; SV *svl, *svr;
a42d0242 1905 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1906 svr = POPs;
1907 svl = TOPs;
a0d0e21e 1908 {
6f1401dc 1909 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1910 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1911 const IV i = SvIV_nomg(svl);
972b05a9 1912 SETi(i << shift);
d0ba1bd2
JH
1913 }
1914 else {
6f1401dc 1915 const UV u = SvUV_nomg(svl);
972b05a9 1916 SETu(u << shift);
d0ba1bd2 1917 }
55497cff 1918 RETURN;
79072805 1919 }
a0d0e21e 1920}
79072805 1921
a0d0e21e
LW
1922PP(pp_right_shift)
1923{
20b7effb 1924 dSP; dATARGET; SV *svl, *svr;
a42d0242 1925 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1926 svr = POPs;
1927 svl = TOPs;
a0d0e21e 1928 {
6f1401dc 1929 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1930 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1931 const IV i = SvIV_nomg(svl);
972b05a9 1932 SETi(i >> shift);
d0ba1bd2
JH
1933 }
1934 else {
6f1401dc 1935 const UV u = SvUV_nomg(svl);
972b05a9 1936 SETu(u >> shift);
d0ba1bd2 1937 }
a0d0e21e 1938 RETURN;
93a17b20 1939 }
79072805
LW
1940}
1941
a0d0e21e 1942PP(pp_lt)
79072805 1943{
20b7effb 1944 dSP;
33efebe6
DM
1945 SV *left, *right;
1946
a42d0242 1947 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
1948 right = POPs;
1949 left = TOPs;
1950 SETs(boolSV(
1951 (SvIOK_notUV(left) && SvIOK_notUV(right))
1952 ? (SvIVX(left) < SvIVX(right))
1953 : (do_ncmp(left, right) == -1)
1954 ));
1955 RETURN;
a0d0e21e 1956}
79072805 1957
a0d0e21e
LW
1958PP(pp_gt)
1959{
20b7effb 1960 dSP;
33efebe6 1961 SV *left, *right;
1b6737cc 1962
33efebe6
DM
1963 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1964 right = POPs;
1965 left = TOPs;
1966 SETs(boolSV(
1967 (SvIOK_notUV(left) && SvIOK_notUV(right))
1968 ? (SvIVX(left) > SvIVX(right))
1969 : (do_ncmp(left, right) == 1)
1970 ));
1971 RETURN;
a0d0e21e
LW
1972}
1973
1974PP(pp_le)
1975{
20b7effb 1976 dSP;
33efebe6 1977 SV *left, *right;
1b6737cc 1978
33efebe6
DM
1979 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1980 right = POPs;
1981 left = TOPs;
1982 SETs(boolSV(
1983 (SvIOK_notUV(left) && SvIOK_notUV(right))
1984 ? (SvIVX(left) <= SvIVX(right))
1985 : (do_ncmp(left, right) <= 0)
1986 ));
1987 RETURN;
a0d0e21e
LW
1988}
1989
1990PP(pp_ge)
1991{
20b7effb 1992 dSP;
33efebe6
DM
1993 SV *left, *right;
1994
1995 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1996 right = POPs;
1997 left = TOPs;
1998 SETs(boolSV(
1999 (SvIOK_notUV(left) && SvIOK_notUV(right))
2000 ? (SvIVX(left) >= SvIVX(right))
2001 : ( (do_ncmp(left, right) & 2) == 0)
2002 ));
2003 RETURN;
2004}
1b6737cc 2005
33efebe6
DM
2006PP(pp_ne)
2007{
20b7effb 2008 dSP;
33efebe6
DM
2009 SV *left, *right;
2010
2011 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2012 right = POPs;
2013 left = TOPs;
2014 SETs(boolSV(
2015 (SvIOK_notUV(left) && SvIOK_notUV(right))
2016 ? (SvIVX(left) != SvIVX(right))
2017 : (do_ncmp(left, right) != 0)
2018 ));
2019 RETURN;
2020}
1b6737cc 2021
33efebe6
DM
2022/* compare left and right SVs. Returns:
2023 * -1: <
2024 * 0: ==
2025 * 1: >
2026 * 2: left or right was a NaN
2027 */
2028I32
2029Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2030{
33efebe6
DM
2031 PERL_ARGS_ASSERT_DO_NCMP;
2032#ifdef PERL_PRESERVE_IVUV
33efebe6 2033 /* Fortunately it seems NaN isn't IOK */
01f91bf2 2034 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
33efebe6
DM
2035 if (!SvUOK(left)) {
2036 const IV leftiv = SvIVX(left);
2037 if (!SvUOK(right)) {
2038 /* ## IV <=> IV ## */
2039 const IV rightiv = SvIVX(right);
2040 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2041 }
33efebe6
DM
2042 /* ## IV <=> UV ## */
2043 if (leftiv < 0)
2044 /* As (b) is a UV, it's >=0, so it must be < */
2045 return -1;
2046 {
2047 const UV rightuv = SvUVX(right);
2048 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2049 }
28e5dec8 2050 }
79072805 2051
33efebe6
DM
2052 if (SvUOK(right)) {
2053 /* ## UV <=> UV ## */
2054 const UV leftuv = SvUVX(left);
2055 const UV rightuv = SvUVX(right);
2056 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2057 }
33efebe6
DM
2058 /* ## UV <=> IV ## */
2059 {
2060 const IV rightiv = SvIVX(right);
2061 if (rightiv < 0)
2062 /* As (a) is a UV, it's >=0, so it cannot be < */
2063 return 1;
2064 {
2065 const UV leftuv = SvUVX(left);
2066 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2067 }
28e5dec8 2068 }
a25b5927 2069 assert(0); /* NOTREACHED */
28e5dec8
JH
2070 }
2071#endif
a0d0e21e 2072 {
33efebe6
DM
2073 NV const rnv = SvNV_nomg(right);
2074 NV const lnv = SvNV_nomg(left);
2075
cab190d4 2076#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM
2077 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2078 return 2;
2079 }
2080 return (lnv > rnv) - (lnv < rnv);
cab190d4 2081#else
33efebe6
DM
2082 if (lnv < rnv)
2083 return -1;
2084 if (lnv > rnv)
2085 return 1;
659c4b96 2086 if (lnv == rnv)
33efebe6
DM
2087 return 0;
2088 return 2;
cab190d4 2089#endif
a0d0e21e 2090 }
79072805
LW
2091}
2092
33efebe6 2093
a0d0e21e 2094PP(pp_ncmp)
79072805 2095{
20b7effb 2096 dSP;
33efebe6
DM
2097 SV *left, *right;
2098 I32 value;
a42d0242 2099 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM
2100 right = POPs;
2101 left = TOPs;
2102 value = do_ncmp(left, right);
2103 if (value == 2) {
3280af22 2104 SETs(&PL_sv_undef);
79072805 2105 }
33efebe6
DM
2106 else {
2107 dTARGET;
2108 SETi(value);
2109 }
2110 RETURN;
a0d0e21e 2111}
79072805 2112
afd9910b 2113PP(pp_sle)
a0d0e21e 2114{
20b7effb 2115 dSP;
79072805 2116
afd9910b
NC
2117 int amg_type = sle_amg;
2118 int multiplier = 1;
2119 int rhs = 1;
79072805 2120
afd9910b
NC
2121 switch (PL_op->op_type) {
2122 case OP_SLT:
2123 amg_type = slt_amg;
2124 /* cmp < 0 */
2125 rhs = 0;
2126 break;
2127 case OP_SGT:
2128 amg_type = sgt_amg;
2129 /* cmp > 0 */
2130 multiplier = -1;
2131 rhs = 0;
2132 break;
2133 case OP_SGE:
2134 amg_type = sge_amg;
2135 /* cmp >= 0 */
2136 multiplier = -1;
2137 break;
79072805 2138 }
79072805 2139
6f1401dc 2140 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW
2141 {
2142 dPOPTOPssrl;
130c5df3 2143 const int cmp =
5778acb6 2144#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2145 (IN_LC_RUNTIME(LC_COLLATE))
2146 ? sv_cmp_locale_flags(left, right, 0)
2147 :
2148#endif
2149 sv_cmp_flags(left, right, 0);
afd9910b 2150 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW
2151 RETURN;
2152 }
2153}
79072805 2154
36477c24
PP
2155PP(pp_seq)
2156{
20b7effb 2157 dSP;
6f1401dc 2158 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24
PP
2159 {
2160 dPOPTOPssrl;
078504b2 2161 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW
2162 RETURN;
2163 }
2164}
79072805 2165
a0d0e21e 2166PP(pp_sne)
79072805 2167{
20b7effb 2168 dSP;
6f1401dc 2169 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW
2170 {
2171 dPOPTOPssrl;
078504b2 2172 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2173 RETURN;
463ee0b2 2174 }
79072805
LW
2175}
2176
a0d0e21e 2177PP(pp_scmp)
79072805 2178{
20b7effb 2179 dSP; dTARGET;
6f1401dc 2180 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW
2181 {
2182 dPOPTOPssrl;
130c5df3 2183 const int cmp =
5778acb6 2184#ifdef USE_LOCALE_COLLATE
130c5df3
KW
2185 (IN_LC_RUNTIME(LC_COLLATE))
2186 ? sv_cmp_locale_flags(left, right, 0)
2187 :
2188#endif
2189 sv_cmp_flags(left, right, 0);
bbce6d69 2190 SETi( cmp );
a0d0e21e
LW
2191 RETURN;
2192 }
2193}
79072805 2194
55497cff
PP
2195PP(pp_bit_and)
2196{
20b7effb 2197 dSP; dATARGET;
6f1401dc 2198 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW
2199 {
2200 dPOPTOPssrl;
4633a7c4 2201 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2202 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2203 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2204 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2205 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2206 SETi(i);
d0ba1bd2
JH
2207 }
2208 else {
1b6737cc 2209 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2210 SETu(u);
d0ba1bd2 2211 }
5ee80e13 2212 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2213 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2214 }
2215 else {
533c011a 2216 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2217 SETTARG;
2218 }
2219 RETURN;
2220 }
2221}
79072805 2222
a0d0e21e
LW
2223PP(pp_bit_or)
2224{
20b7effb 2225 dSP; dATARGET;
3658c1f1
NC
2226 const int op_type = PL_op->op_type;
2227
6f1401dc 2228 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW
2229 {
2230 dPOPTOPssrl;
4633a7c4 2231 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2232 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2233 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2234 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC
2235 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2236 const IV r = SvIV_nomg(right);
2237 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2238 SETi(result);
d0ba1bd2
JH
2239 }
2240 else {
3658c1f1
NC
2241 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2242 const UV r = SvUV_nomg(right);
2243 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2244 SETu(result);
d0ba1bd2 2245 }
5ee80e13 2246 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2247 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2248 }
2249 else {
3658c1f1 2250 do_vop(op_type, TARG, left, right);
a0d0e21e
LW
2251 SETTARG;
2252 }
2253 RETURN;
79072805 2254 }
a0d0e21e 2255}
79072805 2256
1c2b3fd6
FC
2257PERL_STATIC_INLINE bool
2258S_negate_string(pTHX)
2259{
2260 dTARGET; dSP;
2261 STRLEN len;
2262 const char *s;
2263 SV * const sv = TOPs;
2264 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2265 return FALSE;
2266 s = SvPV_nomg_const(sv, len);
2267 if (isIDFIRST(*s)) {
2268 sv_setpvs(TARG, "-");
2269 sv_catsv(TARG, sv);
2270 }
2271 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2272 sv_setsv_nomg(TARG, sv);
2273 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2274 }
2275 else return FALSE;
2276 SETTARG; PUTBACK;
2277 return TRUE;
2278}
2279
a0d0e21e
LW
2280PP(pp_negate)
2281{
20b7effb 2282 dSP; dTARGET;
6f1401dc 2283 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2284 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2285 {
6f1401dc 2286 SV * const sv = TOPs;
a5b92898 2287
d96ab1b5 2288 if (SvIOK(sv)) {
7dbe3150 2289 /* It's publicly an integer */
28e5dec8 2290 oops_its_an_int:
9b0e499b
GS
2291 if (SvIsUV(sv)) {
2292 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2293 /* 2s complement assumption. */
d14578b8
KW
2294 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2295 IV_MIN */
9b0e499b
GS
2296 RETURN;
2297 }
2298 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2299 SETi(-SvIVX(sv));
9b0e499b
GS
2300 RETURN;
2301 }
2302 }
2303 else if (SvIVX(sv) != IV_MIN) {
2304 SETi(-SvIVX(sv));
2305 RETURN;
2306 }
28e5dec8
JH
2307#ifdef PERL_PRESERVE_IVUV
2308 else {
2309 SETu((UV)IV_MIN);
2310 RETURN;
2311 }
2312#endif
9b0e499b 2313 }
8a5decd8 2314 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2315 SETn(-SvNV_nomg(sv));
1c2b3fd6 2316 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2317 goto oops_its_an_int;
4633a7c4 2318 else
6f1401dc 2319 SETn(-SvNV_nomg(sv));
79072805 2320 }
a0d0e21e 2321 RETURN;
79072805
LW
2322}
2323
a0d0e21e 2324PP(pp_not)
79072805 2325{
20b7effb 2326 dSP;
6f1401dc 2327 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2328 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2329 return NORMAL;
79072805
LW
2330}
2331
a0d0e21e 2332PP(pp_complement)
79072805 2333{
20b7effb 2334 dSP; dTARGET;
a42d0242 2335 tryAMAGICun_MG(compl_amg, AMGf_numeric);
a0d0e21e
LW
2336 {
2337 dTOPss;
4633a7c4 2338 if (SvNIOKp(sv)) {
d0ba1bd2 2339 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2340 const IV i = ~SvIV_nomg(sv);
972b05a9 2341 SETi(i);
d0ba1bd2
JH
2342 }
2343 else {
1b6737cc 2344 const UV u = ~SvUV_nomg(sv);
972b05a9 2345 SETu(u);
d0ba1bd2 2346 }
a0d0e21e
LW
2347 }
2348 else {
eb578fdb
KW
2349 U8 *tmps;
2350 I32 anum;
a0d0e21e
LW
2351 STRLEN len;
2352
85b0ee6e
FC
2353 sv_copypv_nomg(TARG, sv);
2354 tmps = (U8*)SvPV_nomg(TARG, len);
a0d0e21e 2355 anum = len;
1d68d6cd 2356 if (SvUTF8(TARG)) {
a1ca4561 2357 /* Calculate exact length, let's not estimate. */
1d68d6cd 2358 STRLEN targlen = 0;
ba210ebe 2359 STRLEN l;
a1ca4561
YST
2360 UV nchar = 0;
2361 UV nwide = 0;
01f6e806 2362 U8 * const send = tmps + len;
74d49cd0
ST
2363 U8 * const origtmps = tmps;
2364 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2365
1d68d6cd 2366 while (tmps < send) {
74d49cd0
ST
2367 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2368 tmps += l;
5bbb0b5a 2369 targlen += UNISKIP(~c);
a1ca4561
YST
2370 nchar++;
2371 if (c > 0xff)
2372 nwide++;
1d68d6cd
SC
2373 }
2374
2375 /* Now rewind strings and write them. */
74d49cd0 2376 tmps = origtmps;
a1ca4561
YST
2377
2378 if (nwide) {
01f6e806
AL
2379 U8 *result;
2380 U8 *p;
2381
74d49cd0 2382 Newx(result, targlen + 1, U8);
01f6e806 2383 p = result;
a1ca4561 2384 while (tmps < send) {
74d49cd0
ST
2385 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2386 tmps += l;
01f6e806 2387 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2388 }
01f6e806 2389 *p = '\0';
c1c21316
NC
2390 sv_usepvn_flags(TARG, (char*)result, targlen,
2391 SV_HAS_TRAILING_NUL);
a1ca4561
YST
2392 SvUTF8_on(TARG);
2393 }
2394 else {
01f6e806
AL
2395 U8 *result;
2396 U8 *p;
2397
74d49cd0 2398 Newx(result, nchar + 1, U8);
01f6e806 2399 p = result;
a1ca4561 2400 while (tmps < send) {
74d49cd0
ST
2401 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2402 tmps += l;
01f6e806 2403 *p++ = ~c;
a1ca4561 2404 }
01f6e806 2405 *p = '\0';
c1c21316 2406 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2407 SvUTF8_off(TARG);
1d68d6cd 2408 }
ec93b65f 2409 SETTARG;
1d68d6cd
SC
2410 RETURN;
2411 }
a0d0e21e 2412#ifdef LIBERAL
51723571 2413 {
eb578fdb 2414 long *tmpl;
51723571
JH
2415 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2416 *tmps = ~*tmps;
2417 tmpl = (long*)tmps;
bb7a0f54 2418 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH
2419 *tmpl = ~*tmpl;
2420 tmps = (U8*)tmpl;
2421 }
a0d0e21e
LW
2422#endif
2423 for ( ; anum > 0; anum--, tmps++)
2424 *tmps = ~*tmps;
ec93b65f 2425 SETTARG;
a0d0e21e
LW
2426 }
2427 RETURN;
2428 }
79072805
LW
2429}
2430
a0d0e21e
LW
2431/* integer versions of some of the above */
2432
a0d0e21e 2433PP(pp_i_multiply)
79072805 2434{
20b7effb 2435 dSP; dATARGET;
6f1401dc 2436 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2437 {
6f1401dc 2438 dPOPTOPiirl_nomg;
a0d0e21e
LW
2439 SETi( left * right );
2440 RETURN;
2441 }
79072805
LW
2442}
2443
a0d0e21e 2444PP(pp_i_divide)
79072805 2445{
85935d8e 2446 IV num;
20b7effb 2447 dSP; dATARGET;
6f1401dc 2448 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2449 {
6f1401dc 2450 dPOPTOPssrl;
85935d8e 2451 IV value = SvIV_nomg(right);
a0d0e21e 2452 if (value == 0)
ece1bcef 2453 DIE(aTHX_ "Illegal division by zero");
85935d8e 2454 num = SvIV_nomg(left);
a0cec769
YST
2455
2456 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2457 if (value == -1)
2458 value = - num;
2459 else
2460 value = num / value;
6f1401dc 2461 SETi(value);
a0d0e21e
LW
2462 RETURN;
2463 }
79072805
LW
2464}
2465
a5bd31f4 2466#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH
2467STATIC
2468PP(pp_i_modulo_0)
befad5d1
NC
2469#else
2470PP(pp_i_modulo)
2471#endif
224ec323
JH
2472{
2473 /* This is the vanilla old i_modulo. */
20b7effb 2474 dSP; dATARGET;
6f1401dc 2475 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2476 {
6f1401dc 2477 dPOPTOPiirl_nomg;
224ec323
JH
2478 if (!right)
2479 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2480 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2481 if (right == -1)
2482 SETi( 0 );
2483 else
2484 SETi( left % right );
224ec323
JH
2485 RETURN;
2486 }
2487}
2488
a5bd31f4 2489#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH
2490STATIC
2491PP(pp_i_modulo_1)
befad5d1 2492
224ec323 2493{
224ec323 2494 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2495 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2496 * See below for pp_i_modulo. */
20b7effb 2497 dSP; dATARGET;
6f1401dc 2498 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2499 {
6f1401dc 2500 dPOPTOPiirl_nomg;
224ec323
JH
2501 if (!right)
2502 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2503 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2504 if (right == -1)
2505 SETi( 0 );
2506 else
2507 SETi( left % PERL_ABS(right) );
224ec323
JH
2508 RETURN;
2509 }
224ec323
JH
2510}
2511
a0d0e21e 2512PP(pp_i_modulo)
79072805 2513{
6f1401dc
DM
2514 dVAR; dSP; dATARGET;
2515 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2516 {
6f1401dc 2517 dPOPTOPiirl_nomg;
224ec323
JH
2518 if (!right)
2519 DIE(aTHX_ "Illegal modulus zero");
2520 /* The assumption is to use hereafter the old vanilla version... */
2521 PL_op->op_ppaddr =
2522 PL_ppaddr[OP_I_MODULO] =
1c127fab 2523 Perl_pp_i_modulo_0;
224ec323
JH
2524 /* .. but if we have glibc, we might have a buggy _moddi3
2525 * (at least glicb 2.2.5 is known to have this bug), in other
2526 * words our integer modulus with negative quad as the second
2527 * argument might be broken. Test for this and re-patch the
2528 * opcode dispatch table if that is the case, remembering to
2529 * also apply the workaround so that this first round works
2530 * right, too. See [perl #9402] for more information. */
224ec323
JH
2531 {
2532 IV l = 3;
2533 IV r = -10;
2534 /* Cannot do this check with inlined IV constants since
2535 * that seems to work correctly even with the buggy glibc. */
2536 if (l % r == -3) {
2537 /* Yikes, we have the bug.
2538 * Patch in the workaround version. */
2539 PL_op->op_ppaddr =
2540 PL_ppaddr[OP_I_MODULO] =
2541 &Perl_pp_i_modulo_1;
2542 /* Make certain we work right this time, too. */
32fdb065 2543 right = PERL_ABS(right);
224ec323
JH
2544 }
2545 }
a0cec769
YST
2546 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2547 if (right == -1)
2548 SETi( 0 );
2549 else
2550 SETi( left % right );
224ec323
JH
2551 RETURN;
2552 }
79072805 2553}
befad5d1 2554#endif
79072805 2555
a0d0e21e 2556PP(pp_i_add)
79072805 2557{
20b7effb 2558 dSP; dATARGET;
6f1401dc 2559 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2560 {
6f1401dc 2561 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2562 SETi( left + right );
2563 RETURN;
79072805 2564 }
79072805
LW
2565}
2566
a0d0e21e 2567PP(pp_i_subtract)
79072805 2568{
20b7effb 2569 dSP; dATARGET;
6f1401dc 2570 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2571 {
6f1401dc 2572 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2573 SETi( left - right );
2574 RETURN;
79072805 2575 }
79072805
LW
2576}
2577
a0d0e21e 2578PP(pp_i_lt)
79072805 2579{
20b7effb 2580 dSP;
6f1401dc 2581 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2582 {
96b6b87f 2583 dPOPTOPiirl_nomg;
54310121 2584 SETs(boolSV(left < right));
a0d0e21e
LW
2585 RETURN;
2586 }
79072805
LW
2587}
2588
a0d0e21e 2589PP(pp_i_gt)
79072805 2590{
20b7effb 2591 dSP;
6f1401dc 2592 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2593 {
96b6b87f 2594 dPOPTOPiirl_nomg;
54310121 2595 SETs(boolSV(left > right));
a0d0e21e
LW
2596 RETURN;
2597 }
79072805
LW
2598}
2599
a0d0e21e 2600PP(pp_i_le)
79072805 2601{
20b7effb 2602 dSP;
6f1401dc 2603 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2604 {
96b6b87f 2605 dPOPTOPiirl_nomg;
54310121 2606 SETs(boolSV(left <= right));
a0d0e21e 2607 RETURN;
85e6fe83 2608 }
79072805
LW
2609}
2610
a0d0e21e 2611PP(pp_i_ge)
79072805 2612{
20b7effb 2613 dSP;
6f1401dc 2614 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2615 {
96b6b87f 2616 dPOPTOPiirl_nomg;
54310121 2617 SETs(boolSV(left >= right));
a0d0e21e
LW
2618 RETURN;
2619 }
79072805
LW
2620}
2621
a0d0e21e 2622PP(pp_i_eq)
79072805 2623{
20b7effb 2624 dSP;
6f1401dc 2625 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2626 {
96b6b87f 2627 dPOPTOPiirl_nomg;
54310121 2628 SETs(boolSV(left == right));
a0d0e21e
LW
2629 RETURN;
2630 }
79072805
LW
2631}
2632
a0d0e21e 2633PP(pp_i_ne)
79072805 2634{
20b7effb 2635 dSP;
6f1401dc 2636 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2637 {
96b6b87f 2638 dPOPTOPiirl_nomg;
54310121 2639 SETs(boolSV(left != right));
a0d0e21e
LW
2640 RETURN;
2641 }
79072805
LW
2642}
2643
a0d0e21e 2644PP(pp_i_ncmp)
79072805 2645{
20b7effb 2646 dSP; dTARGET;
6f1401dc 2647 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2648 {
96b6b87f 2649 dPOPTOPiirl_nomg;
a0d0e21e 2650 I32 value;
79072805 2651
a0d0e21e 2652 if (left > right)
79072805 2653 value = 1;
a0d0e21e 2654 else if (left < right)
79072805 2655 value = -1;
a0d0e21e 2656 else
79072805 2657 value = 0;
a0d0e21e
LW
2658 SETi(value);
2659 RETURN;
79072805 2660 }
85e6fe83
LW
2661}
2662
2663PP(pp_i_negate)
2664{
20b7effb 2665 dSP; dTARGET;
6f1401dc 2666 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2667 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM
2668 {
2669 SV * const sv = TOPs;
2670 IV const i = SvIV_nomg(sv);
2671 SETi(-i);
2672 RETURN;
2673 }
85e6fe83
LW
2674}
2675
79072805
LW
2676/* High falutin' math. */
2677
2678PP(pp_atan2)
2679{
20b7effb 2680 dSP; dTARGET;
6f1401dc 2681 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2682 {
096c060c 2683 dPOPTOPnnrl_nomg;
a1021d57 2684 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2685 RETURN;
2686 }
79072805
LW
2687}
2688
2689PP(pp_sin)
2690{
20b7effb 2691 dSP; dTARGET;
af71714e 2692 int amg_type = fallback_amg;
71302fe3 2693 const char *neg_report = NULL;
71302fe3
NC
2694 const int op_type = PL_op->op_type;
2695
2696 switch (op_type) {
af71714e
JH
2697 case OP_SIN: amg_type = sin_amg; break;
2698 case OP_COS: amg_type = cos_amg; break;
2699 case OP_EXP: amg_type = exp_amg; break;
2700 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2701 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
a0d0e21e 2702 }
79072805 2703
af71714e 2704 assert(amg_type != fallback_amg);
6f1401dc
DM
2705
2706 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2707 {
6f1401dc
DM
2708 SV * const arg = POPs;
2709 const NV value = SvNV_nomg(arg);
f256868e 2710 NV result = NV_NAN;
af71714e 2711 if (neg_report) { /* log or sqrt */
71302fe3
NC
2712 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2713 SET_NUMERIC_STANDARD();
dcbac5bb 2714 /* diag_listed_as: Can't take log of %g */
71302fe3
NC
2715 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2716 }
2717 }
af71714e 2718 switch (op_type) {
f256868e 2719 default:
af71714e
JH
2720 case OP_SIN: result = Perl_sin(value); break;
2721 case OP_COS: result = Perl_cos(value); break;
2722 case OP_EXP: result = Perl_exp(value); break;
2723 case OP_LOG: result = Perl_log(value); break;
2724 case OP_SQRT: result = Perl_sqrt(value); break;
2725 }
2726 XPUSHn(result);
a0d0e21e
LW
2727 RETURN;
2728 }
79072805
LW
2729}
2730
56cb0a1c
AD
2731/* Support Configure command-line overrides for rand() functions.
2732 After 5.005, perhaps we should replace this by Configure support
2733 for drand48(), random(), or rand(). For 5.005, though, maintain
2734 compatibility by calling rand() but allow the user to override it.
2735 See INSTALL for details. --Andy Dougherty 15 July 1998
2736*/
85ab1d1d
JH
2737/* Now it's after 5.005, and Configure supports drand48() and random(),
2738 in addition to rand(). So the overrides should not be needed any more.
2739 --Jarkko Hietaniemi 27 September 1998
2740 */
2741
79072805
LW
2742PP(pp_rand)
2743{
80252599 2744 if (!PL_srand_called) {
85ab1d1d 2745 (void)seedDrand01((Rand_seed_t)seed());
80252599 2746 PL_srand_called = TRUE;
93dc8474 2747 }
fdf4dddd
DD
2748 {
2749 dSP;
2750 NV value;
2751 EXTEND(SP, 1);
2752
2753 if (MAXARG < 1)
2754 value = 1.0;
2755 else {
2756 SV * const sv = POPs;
2757 if(!sv)
2758 value = 1.0;
2759 else
2760 value = SvNV(sv);
2761 }
2762 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
659c4b96 2763 if (value == 0.0)
fdf4dddd
DD
2764 value = 1.0;
2765 {
2766 dTARGET;
2767 PUSHs(TARG);
2768 PUTBACK;
2769 value *= Drand01();
2770 sv_setnv_mg(TARG, value);
2771 }
2772 }
2773 return NORMAL;
79072805
LW
2774}
2775
2776PP(pp_srand)
2777{
20b7effb 2778 dSP; dTARGET;
f914a682
JL
2779 UV anum;
2780
0a5f3363 2781 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL
2782 SV *top;
2783 char *pv;
2784 STRLEN len;
2785 int flags;
2786
2787 top = POPs;
2788 pv = SvPV(top, len);
2789 flags = grok_number(pv, len, &anum);
2790
2791 if (!(flags & IS_NUMBER_IN_UV)) {
2792 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2793 "Integer overflow in srand");
2794 anum = UV_MAX;
2795 }
2796 }
2797 else {
2798 anum = seed();
2799 }
2800
85ab1d1d 2801 (void)seedDrand01((Rand_seed_t)anum);
80252599 2802 PL_srand_called = TRUE;
da1010ec
NC
2803 if (anum)
2804 XPUSHu(anum);
2805 else {
2806 /* Historically srand always returned true. We can avoid breaking
2807 that like this: */
2808 sv_setpvs(TARG, "0 but true");
2809 XPUSHTARG;
2810 }
83832992 2811 RETURN;
79072805
LW
2812}
2813
79072805
LW
2814PP(pp_int)
2815{
20b7effb 2816 dSP; dTARGET;
6f1401dc 2817 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2818 {
6f1401dc
DM
2819 SV * const sv = TOPs;
2820 const IV iv = SvIV_nomg(sv);
28e5dec8
JH
2821 /* XXX it's arguable that compiler casting to IV might be subtly
2822 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2823 else preferring IV has introduced a subtle behaviour change bug. OTOH
2824 relying on floating point to be accurate is a bug. */
2825
c781a409 2826 if (!SvOK(sv)) {
922c4365 2827 SETu(0);
c781a409
RD
2828 }
2829 else if (SvIOK(sv)) {
2830 if (SvIsUV(sv))
6f1401dc 2831 SETu(SvUV_nomg(sv));
c781a409 2832 else
28e5dec8 2833 SETi(iv);
c781a409 2834 }
c781a409 2835 else {
6f1401dc 2836 const NV value = SvNV_nomg(sv);
1048ea30 2837 if (value >= 0.0) {
28e5dec8
JH
2838 if (value < (NV)UV_MAX + 0.5) {
2839 SETu(U_V(value));
2840 } else {
059a1014 2841 SETn(Perl_floor(value));
28e5dec8 2842 }
1048ea30 2843 }
28e5dec8
JH
2844 else {
2845 if (value > (NV)IV_MIN - 0.5) {
2846 SETi(I_V(value));
2847 } else {
1bbae031 2848 SETn(Perl_ceil(value));
28e5dec8
JH
2849 }
2850 }
774d564b 2851 }
79072805 2852 }
79072805
LW
2853 RETURN;
2854}
2855
463ee0b2
LW
2856PP(pp_abs)
2857{
20b7effb 2858 dSP; dTARGET;
6f1401dc 2859 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 2860 {
6f1401dc 2861 SV * const sv = TOPs;
28e5dec8 2862 /* This will cache the NV value if string isn't actually integer */
6f1401dc 2863 const IV iv = SvIV_nomg(sv);
a227d84d 2864
800401ee 2865 if (!SvOK(sv)) {
922c4365 2866 SETu(0);
800401ee
JH
2867 }
2868 else if (SvIOK(sv)) {
28e5dec8 2869 /* IVX is precise */
800401ee 2870 if (SvIsUV(sv)) {
6f1401dc 2871 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH
2872 } else {
2873 if (iv >= 0) {
2874 SETi(iv);
2875 } else {
2876 if (iv != IV_MIN) {
2877 SETi(-iv);
2878 } else {
2879 /* 2s complement assumption. Also, not really needed as
2880 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2881 SETu(IV_MIN);
2882 }
a227d84d 2883 }
28e5dec8
JH
2884 }
2885 } else{
6f1401dc 2886 const NV value = SvNV_nomg(sv);
774d564b 2887 if (value < 0.0)
1b6737cc 2888 SETn(-value);
a4474c9e
DD
2889 else
2890 SETn(value);
774d564b 2891 }
a0d0e21e 2892 }
774d564b 2893 RETURN;
463ee0b2
LW
2894}
2895
79072805
LW
2896PP(pp_oct)
2897{
20b7effb 2898 dSP; dTARGET;
5c144d81 2899 const char *tmps;
53305cf1 2900 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2901 STRLEN len;
53305cf1
NC
2902 NV result_nv;
2903 UV result_uv;
1b6737cc 2904 SV* const sv = POPs;
79072805 2905
349d4f2f 2906 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
2907 if (DO_UTF8(sv)) {
2908 /* If Unicode, try to downgrade
2909 * If not possible, croak. */
1b6737cc 2910 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
2911
2912 SvUTF8_on(tsv);
2913 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2914 tmps = SvPV_const(tsv, len);
2bc69dc4 2915 }
daa2adfd
NC
2916 if (PL_op->op_type == OP_HEX)
2917 goto hex;
2918
6f894ead 2919 while (*tmps && len && isSPACE(*tmps))
53305cf1 2920 tmps++, len--;
9e24b6e2 2921 if (*tmps == '0')
53305cf1 2922 tmps++, len--;
305b8651 2923 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
daa2adfd 2924 hex:
53305cf1 2925 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 2926 }
305b8651 2927 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
53305cf1 2928 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2929 else
53305cf1
NC
2930 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2931
2932 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2933 XPUSHn(result_nv);
2934 }
2935 else {
2936 XPUSHu(result_uv);
2937 }
79072805
LW
2938 RETURN;
2939}
2940
2941/* String stuff. */
2942
2943PP(pp_length)
2944{
20b7effb 2945 dSP; dTARGET;
0bd48802 2946 SV * const sv = TOPs;
a0ed51b3 2947
0f43fd57
FC
2948 SvGETMAGIC(sv);
2949 if (SvOK(sv)) {
193059ca 2950 if (!IN_BYTES)
0f43fd57 2951 SETi(sv_len_utf8_nomg(sv));
9f621bb0 2952 else
0f43fd57
FC
2953 {
2954 STRLEN len;
2955 (void)SvPV_nomg_const(sv,len);
2956 SETi(len);
2957 }
656266fc 2958 } else {
9407f9c1
DL
2959 if (!SvPADTMP(TARG)) {
2960 sv_setsv_nomg(TARG, &PL_sv_undef);
2961 SETTARG;
2962 }
2963 SETs(&PL_sv_undef);
92331800 2964 }
79072805
LW
2965 RETURN;
2966}
2967
83f78d1a
FC
2968/* Returns false if substring is completely outside original string.
2969 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2970 always be true for an explicit 0.
2971*/
2972bool
ddeaf645
DD
2973Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
2974 bool pos1_is_uv, IV len_iv,
2975 bool len_is_uv, STRLEN *posp,
2976 STRLEN *lenp)
83f78d1a
FC
2977{
2978 IV pos2_iv;
2979 int pos2_is_uv;
2980
2981 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2982
2983 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2984 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2985 pos1_iv += curlen;
2986 }
2987 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2988 return FALSE;
2989
2990 if (len_iv || len_is_uv) {
2991 if (!len_is_uv && len_iv < 0) {
2992 pos2_iv = curlen + len_iv;
2993 if (curlen)
2994 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2995 else
2996 pos2_is_uv = 0;
2997 } else { /* len_iv >= 0 */
2998 if (!pos1_is_uv && pos1_iv < 0) {
2999 pos2_iv = pos1_iv + len_iv;
3000 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3001 } else {
3002 if ((UV)len_iv > curlen-(UV)pos1_iv)
3003 pos2_iv = curlen;
3004 else
3005 pos2_iv = pos1_iv+len_iv;
3006 pos2_is_uv = 1;
3007 }
3008 }
3009 }
3010 else {
3011 pos2_iv = curlen;
3012 pos2_is_uv = 1;
3013 }
3014
3015 if (!pos2_is_uv && pos2_iv < 0) {
3016 if (!pos1_is_uv && pos1_iv < 0)
3017 return FALSE;
3018 pos2_iv = 0;
3019 }
3020 else if (!pos1_is_uv && pos1_iv < 0)
3021 pos1_iv = 0;
3022
3023 if ((UV)pos2_iv < (UV)pos1_iv)
3024 pos2_iv = pos1_iv;
3025 if ((UV)pos2_iv > curlen)
3026 pos2_iv = curlen;
3027
3028 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3029 *posp = (STRLEN)( (UV)pos1_iv );
3030 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3031
3032 return TRUE;
3033}
3034
79072805
LW
3035PP(pp_substr)
3036{
20b7effb 3037 dSP; dTARGET;
79072805 3038 SV *sv;
463ee0b2 3039 STRLEN curlen;
9402d6ed 3040 STRLEN utf8_curlen;
777f7c56
EB
3041 SV * pos_sv;
3042 IV pos1_iv;
3043 int pos1_is_uv;
777f7c56
EB
3044 SV * len_sv;
3045 IV len_iv = 0;
83f78d1a 3046 int len_is_uv = 0;
24fcb59f 3047 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3048 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3049 const char *tmps;
9402d6ed 3050 SV *repl_sv = NULL;
cbbf8932 3051 const char *repl = NULL;
7b8d334a 3052 STRLEN repl_len;
7bc95ae1 3053 int num_args = PL_op->op_private & 7;
13e30c65 3054 bool repl_need_utf8_upgrade = FALSE;
79072805 3055
78f9721b
SM
3056 if (num_args > 2) {
3057 if (num_args > 3) {
24fcb59f 3058 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC
3059 }
3060 if ((len_sv = POPs)) {
3061 len_iv = SvIV(len_sv);
83f78d1a 3062 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3063 }
7bc95ae1 3064 else num_args--;
5d82c453 3065 }
777f7c56
EB
3066 pos_sv = POPs;
3067 pos1_iv = SvIV(pos_sv);
3068 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3069 sv = POPs;
24fcb59f
FC
3070 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3071 assert(!repl_sv);
3072 repl_sv = POPs;
3073 }
849ca7ee 3074 PUTBACK;
6582db62 3075 if (lvalue && !repl_sv) {
83f78d1a
FC
3076 SV * ret;
3077 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3078 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3079 LvTYPE(ret) = 'x';
3080 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3081 LvTARGOFF(ret) =
3082 pos1_is_uv || pos1_iv >= 0
3083 ? (STRLEN)(UV)pos1_iv
3084 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3085 LvTARGLEN(ret) =
3086 len_is_uv || len_iv > 0
3087 ? (STRLEN)(UV)len_iv
3088 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3089
3090 SPAGAIN;
3091 PUSHs(ret); /* avoid SvSETMAGIC here */
3092 RETURN;
a74fb2cd 3093 }
6582db62
FC
3094 if (repl_sv) {
3095 repl = SvPV_const(repl_sv, repl_len);
3096 SvGETMAGIC(sv);
3097 if (SvROK(sv))
3098 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3099 "Attempt to use reference as lvalue in substr"
3100 );
3101 tmps = SvPV_force_nomg(sv, curlen);
3102 if (DO_UTF8(repl_sv) && repl_len) {
3103 if (!DO_UTF8(sv)) {
01680ee9 3104 sv_utf8_upgrade_nomg(sv);
6582db62
FC
3105 curlen = SvCUR(sv);
3106 }
3107 }
3108 else if (DO_UTF8(sv))
3109 repl_need_utf8_upgrade = TRUE;
3110 }
3111 else tmps = SvPV_const(sv, curlen);
7e2040f0 3112 if (DO_UTF8(sv)) {
0d788f38 3113 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH
3114 if (utf8_curlen == curlen)
3115 utf8_curlen = 0;
a0ed51b3 3116 else
9402d6ed 3117 curlen = utf8_curlen;
a0ed51b3 3118 }
d1c2b58a 3119 else
9402d6ed 3120 utf8_curlen = 0;
a0ed51b3 3121
83f78d1a
FC
3122 {
3123 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3124
83f78d1a
FC
3125 if (!translate_substr_offsets(
3126 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3127 )) goto bound_fail;
777f7c56 3128
83f78d1a
FC
3129 byte_len = len;
3130 byte_pos = utf8_curlen
0d788f38 3131 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3132
2154eca7 3133 tmps += byte_pos;
bbddc9e0
CS
3134
3135 if (rvalue) {
3136 SvTAINTED_off(TARG); /* decontaminate */
3137 SvUTF8_off(TARG); /* decontaminate */
3138 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3139#ifdef USE_LOCALE_COLLATE
bbddc9e0 3140 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3141#endif
bbddc9e0
CS
3142 if (utf8_curlen)
3143 SvUTF8_on(TARG);
3144 }
2154eca7 3145
f7928d6c 3146 if (repl) {
13e30c65
JH
3147 SV* repl_sv_copy = NULL;
3148
3149 if (repl_need_utf8_upgrade) {
3150 repl_sv_copy = newSVsv(repl_sv);
3151 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3152 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3153 }
502d9230
VP
3154 if (!SvOK(sv))
3155 sv_setpvs(sv, "");
777f7c56 3156 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3157 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3158 }
79072805 3159 }
849ca7ee 3160 SPAGAIN;
bbddc9e0
CS
3161 if (rvalue) {
3162 SvSETMAGIC(TARG);
3163 PUSHs(TARG);
3164 }
79072805 3165 RETURN;
777f7c56 3166
1c900557 3167bound_fail:
83f78d1a 3168 if (repl)
777f7c56
EB
3169 Perl_croak(aTHX_ "substr outside of string");
3170 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3171 RETPUSHUNDEF;
79072805
LW
3172}
3173
3174PP(pp_vec)
3175{
20b7effb 3176 dSP;
eb578fdb
KW
3177 const IV size = POPi;
3178 const IV offset = POPi;
3179 SV * const src = POPs;
1b6737cc 3180 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3181 SV * ret;
a0d0e21e 3182
81e118e0 3183 if (lvalue) { /* it's an lvalue! */
2154eca7
EB
3184 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3185 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3186 LvTYPE(ret) = 'v';
3187 LvTARG(ret) = SvREFCNT_inc_simple(src);
3188 LvTARGOFF(ret) = offset;
3189 LvTARGLEN(ret) = size;
3190 }
3191 else {
3192 dTARGET;
3193 SvTAINTED_off(TARG); /* decontaminate */
3194 ret = TARG;
79072805
LW
3195 }
3196
2154eca7
EB
3197 sv_setuv(ret, do_vecget(src, offset, size));
3198 PUSHs(ret);
79072805
LW
3199 RETURN;
3200}
3201
3202PP(pp_index)
3203{
20b7effb 3204 dSP; dTARGET;
79072805
LW
3205 SV *big;
3206 SV *little;
c445ea15 3207 SV *temp = NULL;
ad66a58c 3208 STRLEN biglen;
2723d216 3209 STRLEN llen = 0;
b464e2b7
TC
3210 SSize_t offset = 0;
3211 SSize_t retval;
73ee8be2
NC
3212 const char *big_p;
3213 const char *little_p;
2f040f7f
NC
3214 bool big_utf8;
3215 bool little_utf8;
2723d216 3216 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3217 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3218
e1dccc0d
Z
3219 if (threeargs)
3220 offset = POPi;
79072805
LW
3221 little = POPs;
3222 big = POPs;
73ee8be2
NC
3223 big_p = SvPV_const(big, biglen);
3224 little_p = SvPV_const(little, llen);
3225
e609e586
NC
3226 big_utf8 = DO_UTF8(big);
3227 little_utf8 = DO_UTF8(little);
3228 if (big_utf8 ^ little_utf8) {
3229 /* One needs to be upgraded. */
2f040f7f
NC
3230 if (little_utf8 && !PL_encoding) {
3231 /* Well, maybe instead we might be able to downgrade the small
3232 string? */
1eced8f8 3233 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC
3234 &little_utf8);
3235 if (little_utf8) {
3236 /* If the large string is ISO-8859-1, and it's not possible to
3237 convert the small string to ISO-8859-1, then there is no
3238 way that it could be found anywhere by index. */
3239 retval = -1;
3240 goto fail;
3241 }
e609e586 3242
2f040f7f
NC
3243 /* At this point, pv is a malloc()ed string. So donate it to temp
3244 to ensure it will get free()d */
3245 little = temp = newSV(0);
73ee8be2
NC
3246 sv_usepvn(temp, pv, llen);
3247 little_p = SvPVX(little);
e609e586 3248 } else {
73ee8be2
NC
3249 temp = little_utf8
3250 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f
NC
3251
3252 if (PL_encoding) {
3253 sv_recode_to_utf8(temp, PL_encoding);
3254 } else {
3255 sv_utf8_upgrade(temp);
3256 }
3257 if (little_utf8) {
3258 big = temp;
3259 big_utf8 = TRUE;
73ee8be2 3260 big_p = SvPV_const(big, biglen);
2f040f7f
NC
3261 } else {
3262 little = temp;
73ee8be2 3263 little_p = SvPV_const(little, llen);
2f040f7f 3264 }
e609e586
NC
3265 }
3266 }
73ee8be2
NC
3267 if (SvGAMAGIC(big)) {
3268 /* Life just becomes a lot easier if I use a temporary here.
3269 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3270 will trigger magic and overloading again, as will fbm_instr()
3271 */
59cd0e26
NC
3272 big = newSVpvn_flags(big_p, biglen,
3273 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3274 big_p = SvPVX(big);
3275 }
e4e44778 3276 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC
3277 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3278 warn on undef, and we've already triggered a warning with the
3279 SvPV_const some lines above. We can't remove that, as we need to
3280 call some SvPV to trigger overloading early and find out if the
3281 string is UTF-8.
3282 This is all getting to messy. The API isn't quite clean enough,
3283 because data access has side effects.
3284 */
59cd0e26
NC
3285 little = newSVpvn_flags(little_p, llen,
3286 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3287 little_p = SvPVX(little);
3288 }
e609e586 3289
d3e26383 3290 if (!threeargs)
2723d216 3291 offset = is_index ? 0 : biglen;
a0ed51b3 3292 else {
ad66a58c 3293 if (big_utf8 && offset > 0)
b464e2b7 3294 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
73ee8be2
NC
3295 if (!is_index)
3296 offset += llen;
a0ed51b3 3297 }
79072805
LW
3298 if (offset < 0)
3299 offset = 0;
b464e2b7 3300 else if (offset > (SSize_t)biglen)
ad66a58c 3301 offset = biglen;
73ee8be2
NC
3302 if (!(little_p = is_index
3303 ? fbm_instr((unsigned char*)big_p + offset,
3304 (unsigned char*)big_p + biglen, little, 0)
3305 : rninstr(big_p, big_p + offset,
3306 little_p, little_p + llen)))
a0ed51b3 3307 retval = -1;
ad66a58c 3308 else {
73ee8be2 3309 retval = little_p - big_p;
ad66a58c 3310 if (retval > 0 && big_utf8)
b464e2b7 3311 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
ad66a58c 3312 }
ef8d46e8 3313 SvREFCNT_dec(temp);
2723d216 3314 fail:
e1dccc0d 3315 PUSHi(retval);
79072805
LW
3316 RETURN;
3317}
3318
3319PP(pp_sprintf)
3320{
20b7effb 3321 dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3322 SvTAINTED_off(TARG);
79072805 3323 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3324 TAINT_IF(SvTAINTED(TARG));
79072805
LW
3325 SP = ORIGMARK;
3326 PUSHTARG;
3327 RETURN;
3328}
3329
79072805
LW
3330PP(pp_ord)
3331{
20b7effb 3332 dSP; dTARGET;
1eced8f8 3333
7df053ec 3334 SV *argsv = POPs;
ba210ebe 3335 STRLEN len;
349d4f2f 3336 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3337
799ef3cb 3338 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3339 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3340 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
4f6386b6 3341 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
121910a4
JH
3342 argsv = tmpsv;
3343 }
79072805 3344
d8f42585 3345 XPUSHu(DO_UTF8(argsv)
4f6386b6 3346 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
f3943cf2 3347 : (UV)(*s));
68795e93 3348
79072805
LW
3349 RETURN;
3350}
3351
463ee0b2
LW
3352PP(pp_chr)
3353{
20b7effb 3354 dSP; dTARGET;
463ee0b2 3355 char *tmps;
8a064bd6 3356 UV value;
71739502 3357 SV *top = POPs;
8a064bd6 3358
71739502 3359 SvGETMAGIC(top);
1cd88304
JH
3360 if (SvNOK(top) && Perl_isinfnan(SvNV(top))) {
3361 if (ckWARN(WARN_UTF8)) {
3362 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3363 "Invalid number (%"NVgf") in chr", SvNV(top));
3364 }
3365 value = UNICODE_REPLACEMENT;
3366 }
3367 else {
3368 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3369 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3370 ||
3371 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3372 && SvNV_nomg(top) < 0.0))) {
b3fe8680
FC
3373 if (ckWARN(WARN_UTF8)) {
3374 if (SvGMAGICAL(top)) {
3375 SV *top2 = sv_newmortal();
3376 sv_setsv_nomg(top2, top);
3377 top = top2;
3378 }
1cd88304
JH
3379 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3380 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3381 }
3382 value = UNICODE_REPLACEMENT;
3383 } else {
3384 value = SvUV_nomg(top);
3385 }
8a064bd6 3386 }
463ee0b2 3387
862a34c6 3388 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3389
0064a8a9 3390 if (value > 255 && !IN_BYTES) {
eb160463 3391 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3392 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3393 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW
3394 *tmps = '\0';
3395 (void)SvPOK_only(TARG);
aa6ffa16 3396 SvUTF8_on(TARG);
a0ed51b3
LW
3397 XPUSHs(TARG);
3398 RETURN;
3399 }
3400
748a9306 3401 SvGROW(TARG,2);
463ee0b2
LW
3402 SvCUR_set(TARG, 1);
3403 tmps = SvPVX(TARG);
eb160463 3404 *tmps++ = (char)value;
748a9306 3405 *tmps = '\0';
a0d0e21e 3406 (void)SvPOK_only(TARG);
4c5ed6e2 3407
88632417 3408 if (PL_encoding && !IN_BYTES) {
799ef3cb 3409 sv_recode_to_utf8(TARG, PL_encoding);
88632417 3410 tmps = SvPVX(TARG);
28936164
KW
3411 if (SvCUR(TARG) == 0
3412 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3413 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3414 {
4c5ed6e2 3415 SvGROW(TARG, 2);
d5a15ac2 3416 tmps = SvPVX(TARG);
4c5ed6e2
ST
3417 SvCUR_set(TARG, 1);
3418 *tmps++ = (char)value;
88632417 3419 *tmps = '\0';
4c5ed6e2 3420 SvUTF8_off(TARG);
88632417
JH
3421 }
3422 }
4c5ed6e2 3423
463ee0b2
LW
3424 XPUSHs(TARG);
3425 RETURN;
3426}
3427
79072805
LW
3428PP(pp_crypt)
3429{
79072805 3430#ifdef HAS_CRYPT
20b7effb 3431 dSP; dTARGET;
5f74f29c 3432 dPOPTOPssrl;
85c16d83 3433 STRLEN len;
10516c54 3434 const char *tmps = SvPV_const(left, len);
2bc69dc4 3435
85c16d83 3436 if (DO_UTF8(left)) {
2bc69dc4 3437 /* If Unicode, try to downgrade.
f2791508
JH
3438 * If not possible, croak.
3439 * Yes, we made this up. */
1b6737cc 3440 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3441
f2791508 3442 SvUTF8_on(tsv);
2bc69dc4 3443 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3444 tmps = SvPV_const(tsv, len);
85c16d83 3445 }
05404ffe
JH
3446# ifdef USE_ITHREADS
3447# ifdef HAS_CRYPT_R
3448 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3449 /* This should be threadsafe because in ithreads there is only
3450 * one thread per interpreter. If this would not be true,
3451 * we would need a mutex to protect this malloc. */
3452 PL_reentrant_buffer->_crypt_struct_buffer =
3453 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3454#if defined(__GLIBC__) || defined(__EMX__)
3455 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3456 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3457 /* work around glibc-2.2.5 bug */
3458 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3459 }
05404ffe 3460#endif
6ab58e4d 3461 }
05404ffe
JH
3462# endif /* HAS_CRYPT_R */
3463# endif /* USE_ITHREADS */
5f74f29c 3464# ifdef FCRYPT
83003860 3465 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3466# else
83003860 3467 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3468# endif
ec93b65f 3469 SETTARG;
4808266b 3470 RETURN;
79072805 3471#else
b13b2135 3472 DIE(aTHX_
79072805
LW
3473 "The crypt() function is unimplemented due to excessive paranoia.");
3474#endif
79072805
LW
3475}
3476
00f254e2
KW
3477/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3478 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3479
79072805
LW
3480PP(pp_ucfirst)
3481{
00f254e2
KW
3482 /* Actually is both lcfirst() and ucfirst(). Only the first character
3483 * changes. This means that possibly we can change in-place, ie., just
3484 * take the source and change that one character and store it back, but not
3485 * if read-only etc, or if the length changes */
3486
39644a26 3487 dSP;
d54190f6 3488 SV *source = TOPs;
00f254e2 3489 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC
3490 STRLEN need;
3491 SV *dest;
00f254e2
KW
3492 bool inplace; /* ? Convert first char only, in-place */
3493 bool doing_utf8 = FALSE; /* ? using utf8 */
3494 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3495 const int op_type = PL_op->op_type;
d54190f6
NC
3496 const U8 *s;
3497 U8 *d;
3498 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW
3499 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3500 * stored as UTF-8 at s. */
3501 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3502 * lowercased) character stored in tmpbuf. May be either
3503 * UTF-8 or not, but in either case is the number of bytes */
d54190f6 3504
841a5e18 3505 s = (const U8*)SvPV_const(source, slen);
a0ed51b3 3506
00f254e2
KW
3507 /* We may be able to get away with changing only the first character, in
3508 * place, but not if read-only, etc. Later we may discover more reasons to
3509 * not convert in-place. */
5cd5e2d6
FC
3510 inplace = !SvREADONLY(source)
3511 && ( SvPADTMP(source)
3512 || ( SvTEMP(source) && !SvSMAGICAL(source)
3513 && SvREFCNT(source) == 1));
00f254e2
KW
3514
3515 /* First calculate what the changed first character should be. This affects
3516 * whether we can just swap it out, leaving the rest of the string unchanged,
3517 * or even if have to convert the dest to UTF-8 when the source isn't */
3518
3519 if (! slen) { /* If empty */
3520 need = 1; /* still need a trailing NUL */
b7576bcb 3521 ulen = 0;
00f254e2
KW
3522 }
3523 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3524 doing_utf8 = TRUE;
17e95c9d 3525 ulen = UTF8SKIP(s);
094a2f8c 3526 if (op_type == OP_UCFIRST) {
130c5df3 3527#ifdef USE_LOCALE_CTYPE
5a6bb681 3528 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3529#else
5a6bb681 3530 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
130c5df3 3531#endif
094a2f8c
KW
3532 }
3533 else {
130c5df3 3534#ifdef USE_LOCALE_CTYPE
5a6bb681 3535 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3536#else
5a6bb681 3537 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
130c5df3 3538#endif
094a2f8c 3539 }
00f254e2 3540
17e95c9d
KW
3541 /* we can't do in-place if the length changes. */
3542 if (ulen != tculen) inplace = FALSE;
3543 need = slen + 1 - ulen + tculen;
d54190f6 3544 }
00f254e2
KW
3545 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3546 * latin1 is treated as caseless. Note that a locale takes
3547 * precedence */
167d19f2 3548 ulen = 1; /* Original character is 1 byte */
00f254e2
KW
3549 tculen = 1; /* Most characters will require one byte, but this will
3550 * need to be overridden for the tricky ones */
3551 need = slen + 1;
3552
3553 if (op_type == OP_LCFIRST) {
d54190f6 3554
00f254e2 3555 /* lower case the first letter: no trickiness for any character */
130c5df3
KW
3556 *tmpbuf =
3557#ifdef USE_LOCALE_CTYPE
3558 (IN_LC_RUNTIME(LC_CTYPE))
86a1f7fd 3559 ? toLOWER_LC(*s)
130c5df3
KW
3560 :
3561#endif
3562 (IN_UNI_8_BIT)
86a1f7fd
KW
3563 ? toLOWER_LATIN1(*s)
3564 : toLOWER(*s);
00f254e2
KW
3565 }
3566 /* is ucfirst() */
130c5df3 3567#ifdef USE_LOCALE_CTYPE
d6ded950 3568 else if (IN_LC_RUNTIME(LC_CTYPE)) {
31f05a37
KW
3569 if (IN_UTF8_CTYPE_LOCALE) {
3570 goto do_uni_rules;
3571 }
3572
3573 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3574 locales have upper and title case
3575 different */
00f254e2 3576 }
130c5df3 3577#endif
00f254e2
KW
3578 else if (! IN_UNI_8_BIT) {
3579 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3580 * on EBCDIC machines whatever the
3581 * native function does */
3582 }
31f05a37
KW
3583 else {
3584 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3585 * UTF-8, which we treat as not in locale), and cased latin1 */
3586 UV title_ord;
91191cf7 3587#ifdef USE_LOCALE_CTYPE
31f05a37 3588 do_uni_rules:
91191cf7 3589#endif
31f05a37
KW
3590
3591 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
167d19f2
KW
3592 if (tculen > 1) {
3593 assert(tculen == 2);
3594
3595 /* If the result is an upper Latin1-range character, it can
3596 * still be represented in one byte, which is its ordinal */
3597 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3598 *tmpbuf = (U8) title_ord;
3599 tculen = 1;
00f254e2
KW
3600 }
3601 else {
167d19f2
KW
3602 /* Otherwise it became more than one ASCII character (in