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