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