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