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