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