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