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