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