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