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