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