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