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