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