This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
On Linux-PPC, using gcc, downgrade to the -O1 optimisation
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
b5f8cc5c 4 * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
79072805 5 *
a0d0e21e
LW		 6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
79072805 8 *
a0d0e21e
LW		 9 */
10
11/*
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
14 */
79072805
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 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 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 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 299 if (SvTYPE(TARG) < SVt_PVLV) {
300 sv_upgrade(TARG, SVt_PVLV);
14befaf4 301 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
5f05dabc 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 355PP(pp_prototype)
356{
39644a26 357 dSP;
c07a80fd 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 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 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 463{
464 SV* rv;
465
466 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
467 if (LvTARGLEN(sv))
68dc0745 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 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 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 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 551 sv = Nullsv;
552 switch (elem ? *elem : '\0')
553 {
554 case 'A':
555 if (strEQ(elem, "ARRAY"))
76e3520e 556 tmpRef = (SV*)GvAV(gv);
fb73857a 557 break;
558 case 'C':
559 if (strEQ(elem, "CODE"))
76e3520e 560 tmpRef = (SV*)GvCVu(gv);
fb73857a 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 571 break;
572 case 'G':
573 if (strEQ(elem, "GLOB"))
76e3520e 574 tmpRef = (SV*)gv;
fb73857a 575 break;
576 case 'H':
577 if (strEQ(elem, "HASH"))
76e3520e 578 tmpRef = (SV*)GvHV(gv);
fb73857a 579 break;
580 case 'I':
581 if (strEQ(elem, "IO"))
76e3520e 582 tmpRef = (SV*)GvIOp(gv);
fb73857a 583 break;
584 case 'N':
585 if (strEQ(elem, "NAME"))
79cb57f6 586 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
fb73857a 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 595 break;
596 case 'S':
597 if (strEQ(elem, "SCALAR"))
76e3520e 598 tmpRef = GvSV(gv);
fb73857a 599 break;
600 }
76e3520e
GS		 601 if (tmpRef)
602 sv = newRV(tmpRef);
fb73857a 603 if (sv)
604 sv_2mortal(sv);
605 else
3280af22 606 sv = &PL_sv_undef;
fb73857a 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 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 634
635 s = (unsigned char*)(SvPV(sv, len));
636 pos = len;
637 if (pos <= 0)
638 RETPUSHNO;
3280af22
NIS		 639 if (pos > PL_maxscream) {
640 if (PL_maxscream < 0) {
641 PL_maxscream = pos + 80;
642 New(301, PL_screamfirst, 256, I32);
643 New(302, PL_screamnext, PL_maxscream, I32);
79072805
LW		 644 }
645 else {
3280af22
NIS		 646 PL_maxscream = pos + pos / 4;
647 Renew(PL_screamnext, PL_maxscream, I32);
79072805 648 }
79072805 649 }
a0d0e21e 650
3280af22
NIS		 651 sfirst = PL_screamfirst;
652 snext = PL_screamnext;
a0d0e21e
LW		 653
654 if (!sfirst || !snext)
cea2e8a9 655 DIE(aTHX_ "do_study: out of memory");
a0d0e21e
LW		 656
657 for (ch = 256; ch; --ch)
658 *sfirst++ = -1;
659 sfirst -= 256;
660
661 while (--pos >= 0) {
662 ch = s[pos];
663 if (sfirst[ch] >= 0)
664 snext[pos] = sfirst[ch] - pos;
665 else
666 snext[pos] = -pos;
667 sfirst[ch] = pos;
79072805
LW		 668 }
669
c07a80fd 670 SvSCREAM_on(sv);
14befaf4
DM		 671 /* piggyback on m//g magic */
672 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
1e422769 673 RETPUSHYES;
79072805
LW		 674}
675
a0d0e21e 676PP(pp_trans)
79072805 677{
39644a26 678 dSP; dTARG;
a0d0e21e
LW		 679 SV *sv;
680
533c011a 681 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 682 sv = POPs;
59f00321
RGS		 683 else if (PL_op->op_private & OPpTARGET_MY)
684 sv = GETTARGET;
79072805 685 else {
54b9620d 686 sv = DEFSV;
a0d0e21e 687 EXTEND(SP,1);
79072805 688 }
adbc6bb1 689 TARG = sv_newmortal();
4757a243 690 PUSHi(do_trans(sv));
a0d0e21e 691 RETURN;
79072805
LW		 692}
693
a0d0e21e 694/* Lvalue operators. */
79072805 695
a0d0e21e
LW		 696PP(pp_schop)
697{
39644a26 698 dSP; dTARGET;
a0d0e21e
LW		 699 do_chop(TARG, TOPs);
700 SETTARG;
701 RETURN;
79072805
LW		 702}
703
a0d0e21e 704PP(pp_chop)
79072805 705{
2ec6af5f
RG		 706 dSP; dMARK; dTARGET; dORIGMARK;
707 while (MARK < SP)
708 do_chop(TARG, *++MARK);
709 SP = ORIGMARK;
a0d0e21e
LW		 710 PUSHTARG;
711 RETURN;
79072805
LW		 712}
713
a0d0e21e 714PP(pp_schomp)
79072805 715{
39644a26 716 dSP; dTARGET;
a0d0e21e
LW		 717 SETi(do_chomp(TOPs));
718 RETURN;
79072805
LW		 719}
720
a0d0e21e 721PP(pp_chomp)
79072805 722{
39644a26 723 dSP; dMARK; dTARGET;
a0d0e21e 724 register I32 count = 0;
8ec5e241 725
a0d0e21e
LW		 726 while (SP > MARK)
727 count += do_chomp(POPs);
728 PUSHi(count);
729 RETURN;
79072805
LW		 730}
731
a0d0e21e 732PP(pp_defined)
463ee0b2 733{
39644a26 734 dSP;
a0d0e21e
LW		 735 register SV* sv;
736
737 sv = POPs;
738 if (!sv || !SvANY(sv))
739 RETPUSHNO;
740 switch (SvTYPE(sv)) {
741 case SVt_PVAV:
14befaf4
DM		 742 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
743 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
a0d0e21e
LW		 744 RETPUSHYES;
745 break;
746 case SVt_PVHV:
14befaf4
DM		 747 if (HvARRAY(sv) || SvGMAGICAL(sv)
748 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
a0d0e21e
LW		 749 RETPUSHYES;
750 break;
751 case SVt_PVCV:
752 if (CvROOT(sv) || CvXSUB(sv))
753 RETPUSHYES;
754 break;
755 default:
756 if (SvGMAGICAL(sv))
757 mg_get(sv);
758 if (SvOK(sv))
759 RETPUSHYES;
760 }
761 RETPUSHNO;
463ee0b2
LW		 762}
763
a0d0e21e
LW		 764PP(pp_undef)
765{
39644a26 766 dSP;
a0d0e21e
LW		 767 SV *sv;
768
533c011a 769 if (!PL_op->op_private) {
774d564b 770 EXTEND(SP, 1);
a0d0e21e 771 RETPUSHUNDEF;
774d564b 772 }
79072805 773
a0d0e21e
LW		 774 sv = POPs;
775 if (!sv)
776 RETPUSHUNDEF;
85e6fe83 777
765f542d 778 SV_CHECK_THINKFIRST_COW_DROP(sv);
85e6fe83 779
a0d0e21e
LW		 780 switch (SvTYPE(sv)) {
781 case SVt_NULL:
782 break;
783 case SVt_PVAV:
784 av_undef((AV*)sv);
785 break;
786 case SVt_PVHV:
787 hv_undef((HV*)sv);
788 break;
789 case SVt_PVCV:
e476b1b5 790 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
9014280d 791 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
54310121 792 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
9607fc9c 793 /* FALL THROUGH */
794 case SVt_PVFM:
6fc92669
GS		 795 {
796 /* let user-undef'd sub keep its identity */
65c50114 797 GV* gv = CvGV((CV*)sv);
6fc92669
GS		 798 cv_undef((CV*)sv);
799 CvGV((CV*)sv) = gv;
800 }
a0d0e21e 801 break;
8e07c86e 802 case SVt_PVGV:
44a8e56a 803 if (SvFAKE(sv))
3280af22 804 SvSetMagicSV(sv, &PL_sv_undef);
20408e3c
GS		 805 else {
806 GP *gp;
807 gp_free((GV*)sv);
808 Newz(602, gp, 1, GP);
809 GvGP(sv) = gp_ref(gp);
810 GvSV(sv) = NEWSV(72,0);
57843af0 811 GvLINE(sv) = CopLINE(PL_curcop);
20408e3c
GS		 812 GvEGV(sv) = (GV*)sv;
813 GvMULTI_on(sv);
814 }
44a8e56a 815 break;
a0d0e21e 816 default:
1e422769 817 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
4633a7c4
LW		 818 (void)SvOOK_off(sv);
819 Safefree(SvPVX(sv));
820 SvPV_set(sv, Nullch);
821 SvLEN_set(sv, 0);
a0d0e21e 822 }
4633a7c4
LW		 823 (void)SvOK_off(sv);
824 SvSETMAGIC(sv);
79072805 825 }
a0d0e21e
LW		 826
827 RETPUSHUNDEF;
79072805
LW		 828}
829
a0d0e21e 830PP(pp_predec)
79072805 831{
39644a26 832 dSP;
f39684df 833 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
d470f89e 834 DIE(aTHX_ PL_no_modify);
3510b4a1
NC		 835 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
836 && SvIVX(TOPs) != IV_MIN)
55497cff 837 {
748a9306 838 --SvIVX(TOPs);
55497cff 839 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 840 }
841 else
842 sv_dec(TOPs);
a0d0e21e
LW		 843 SvSETMAGIC(TOPs);
844 return NORMAL;
845}
79072805 846
a0d0e21e
LW		 847PP(pp_postinc)
848{
39644a26 849 dSP; dTARGET;
f39684df 850 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
d470f89e 851 DIE(aTHX_ PL_no_modify);
a0d0e21e 852 sv_setsv(TARG, TOPs);
3510b4a1
NC		 853 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
854 && SvIVX(TOPs) != IV_MAX)
55497cff 855 {
748a9306 856 ++SvIVX(TOPs);
55497cff 857 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 858 }
859 else
860 sv_inc(TOPs);
a0d0e21e 861 SvSETMAGIC(TOPs);
1e54a23f 862 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
a0d0e21e
LW		 863 if (!SvOK(TARG))
864 sv_setiv(TARG, 0);
865 SETs(TARG);
866 return NORMAL;
867}
79072805 868
a0d0e21e
LW		 869PP(pp_postdec)
870{
39644a26 871 dSP; dTARGET;
f39684df 872 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
d470f89e 873 DIE(aTHX_ PL_no_modify);
a0d0e21e 874 sv_setsv(TARG, TOPs);
3510b4a1
NC		 875 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
876 && SvIVX(TOPs) != IV_MIN)
55497cff 877 {
748a9306 878 --SvIVX(TOPs);
55497cff 879 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 880 }
881 else
882 sv_dec(TOPs);
a0d0e21e
LW		 883 SvSETMAGIC(TOPs);
884 SETs(TARG);
885 return NORMAL;
886}
79072805 887
a0d0e21e
LW		 888/* Ordinary operators. */
889
890PP(pp_pow)
891{
52a96ae6 892 dSP; dATARGET;
58d76dfd 893#ifdef PERL_PRESERVE_IVUV
52a96ae6
HS		 894 bool is_int = 0;
895#endif
896 tryAMAGICbin(pow,opASSIGN);
897#ifdef PERL_PRESERVE_IVUV
898 /* For integer to integer power, we do the calculation by hand wherever
899 we're sure it is safe; otherwise we call pow() and try to convert to
900 integer afterwards. */
58d76dfd
JH		 901 {
902 SvIV_please(TOPm1s);
903 if (SvIOK(TOPm1s)) {
904 bool baseuok = SvUOK(TOPm1s);
905 UV baseuv;
906
907 if (baseuok) {
908 baseuv = SvUVX(TOPm1s);
909 } else {
910 IV iv = SvIVX(TOPm1s);
911 if (iv >= 0) {
912 baseuv = iv;
913 baseuok = TRUE; /* effectively it's a UV now */
914 } else {
915 baseuv = -iv; /* abs, baseuok == false records sign */
916 }
917 }
918 SvIV_please(TOPs);
919 if (SvIOK(TOPs)) {
920 UV power;
921
922 if (SvUOK(TOPs)) {
923 power = SvUVX(TOPs);
924 } else {
925 IV iv = SvIVX(TOPs);
926 if (iv >= 0) {
927 power = iv;
928 } else {
929 goto float_it; /* Can't do negative powers this way. */
930 }
931 }
52a96ae6
HS		 932 /* now we have integer ** positive integer. */
933 is_int = 1;
934
935 /* foo & (foo - 1) is zero only for a power of 2. */
58d76dfd 936 if (!(baseuv & (baseuv - 1))) {
52a96ae6 937 /* We are raising power-of-2 to a positive integer.
58d76dfd
JH		 938 The logic here will work for any base (even non-integer
939 bases) but it can be less accurate than
940 pow (base,power) or exp (power * log (base)) when the
941 intermediate values start to spill out of the mantissa.
942 With powers of 2 we know this can't happen.
943 And powers of 2 are the favourite thing for perl
944 programmers to notice ** not doing what they mean. */
945 NV result = 1.0;
946 NV base = baseuok ? baseuv : -(NV)baseuv;
947 int n = 0;
948
58d76dfd
JH		 949 for (; power; base *= base, n++) {
950 /* Do I look like I trust gcc with long longs here?
951 Do I hell. */
952 UV bit = (UV)1 << (UV)n;
953 if (power & bit) {
954 result *= base;
955 /* Only bother to clear the bit if it is set. */
52a96ae6 956 power -= bit;
90fcb902
CB		 957 /* Avoid squaring base again if we're done. */
958 if (power == 0) break;
58d76dfd
JH		 959 }
960 }
961 SP--;
962 SETn( result );
52a96ae6 963 SvIV_please(TOPs);
58d76dfd 964 RETURN;
52a96ae6
HS		 965 } else {
966 register unsigned int highbit = 8 * sizeof(UV);
967 register unsigned int lowbit = 0;
968 register unsigned int diff;
56c23875 969 bool odd_power = (bool)(power & 1);
52a96ae6
HS		 970 while ((diff = (highbit - lowbit) >> 1)) {
971 if (baseuv & ~((1 << (lowbit + diff)) - 1))
972 lowbit += diff;
973 else
974 highbit -= diff;
975 }
976 /* we now have baseuv < 2 ** highbit */
977 if (power * highbit <= 8 * sizeof(UV)) {
978 /* result will definitely fit in UV, so use UV math
979 on same algorithm as above */
980 register UV result = 1;
981 register UV base = baseuv;
982 register int n = 0;
983 for (; power; base *= base, n++) {
984 register UV bit = (UV)1 << (UV)n;
985 if (power & bit) {
986 result *= base;
987 power -= bit;
988 if (power == 0) break;
989 }
990 }
991 SP--;
0615a994 992 if (baseuok || !odd_power)
52a96ae6
HS		 993 /* answer is positive */
994 SETu( result );
995 else if (result <= (UV)IV_MAX)
996 /* answer negative, fits in IV */
997 SETi( -(IV)result );
998 else if (result == (UV)IV_MIN)
999 /* 2's complement assumption: special case IV_MIN */
1000 SETi( IV_MIN );
1001 else
1002 /* answer negative, doesn't fit */
1003 SETn( -(NV)result );
1004 RETURN;
1005 }
1006 }
1007 }
1008 }
58d76dfd 1009 }
52a96ae6 1010 float_it:
58d76dfd 1011#endif
a0d0e21e 1012 {
52a96ae6
HS		 1013 dPOPTOPnnrl;
1014 SETn( Perl_pow( left, right) );
1015#ifdef PERL_PRESERVE_IVUV
1016 if (is_int)
1017 SvIV_please(TOPs);
1018#endif
1019 RETURN;
93a17b20 1020 }
a0d0e21e
LW		 1021}
1022
1023PP(pp_multiply)
1024{
39644a26 1025 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
28e5dec8
JH		 1026#ifdef PERL_PRESERVE_IVUV
1027 SvIV_please(TOPs);
1028 if (SvIOK(TOPs)) {
1029 /* Unless the left argument is integer in range we are going to have to
1030 use NV maths. Hence only attempt to coerce the right argument if
1031 we know the left is integer. */
1032 /* Left operand is defined, so is it IV? */
1033 SvIV_please(TOPm1s);
1034 if (SvIOK(TOPm1s)) {
1035 bool auvok = SvUOK(TOPm1s);
1036 bool buvok = SvUOK(TOPs);
1037 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1038 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1039 UV alow;
1040 UV ahigh;
1041 UV blow;
1042 UV bhigh;
1043
1044 if (auvok) {
1045 alow = SvUVX(TOPm1s);
1046 } else {
1047 IV aiv = SvIVX(TOPm1s);
1048 if (aiv >= 0) {
1049 alow = aiv;
1050 auvok = TRUE; /* effectively it's a UV now */
1051 } else {
1052 alow = -aiv; /* abs, auvok == false records sign */
1053 }
1054 }
1055 if (buvok) {
1056 blow = SvUVX(TOPs);
1057 } else {
1058 IV biv = SvIVX(TOPs);
1059 if (biv >= 0) {
1060 blow = biv;
1061 buvok = TRUE; /* effectively it's a UV now */
1062 } else {
1063 blow = -biv; /* abs, buvok == false records sign */
1064 }
1065 }
1066
1067 /* If this does sign extension on unsigned it's time for plan B */
1068 ahigh = alow >> (4 * sizeof (UV));
1069 alow &= botmask;
1070 bhigh = blow >> (4 * sizeof (UV));
1071 blow &= botmask;
1072 if (ahigh && bhigh) {
1073 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1074 which is overflow. Drop to NVs below. */
1075 } else if (!ahigh && !bhigh) {
1076 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1077 so the unsigned multiply cannot overflow. */
1078 UV product = alow * blow;
1079 if (auvok == buvok) {
1080 /* -ve * -ve or +ve * +ve gives a +ve result. */
1081 SP--;
1082 SETu( product );
1083 RETURN;
1084 } else if (product <= (UV)IV_MIN) {
1085 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1086 /* -ve result, which could overflow an IV */
1087 SP--;
25716404 1088 SETi( -(IV)product );
28e5dec8
JH		 1089 RETURN;
1090 } /* else drop to NVs below. */
1091 } else {
1092 /* One operand is large, 1 small */
1093 UV product_middle;
1094 if (bhigh) {
1095 /* swap the operands */
1096 ahigh = bhigh;
1097 bhigh = blow; /* bhigh now the temp var for the swap */
1098 blow = alow;
1099 alow = bhigh;
1100 }
1101 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1102 multiplies can't overflow. shift can, add can, -ve can. */
1103 product_middle = ahigh * blow;
1104 if (!(product_middle & topmask)) {
1105 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1106 UV product_low;
1107 product_middle <<= (4 * sizeof (UV));
1108 product_low = alow * blow;
1109
1110 /* as for pp_add, UV + something mustn't get smaller.
1111 IIRC ANSI mandates this wrapping *behaviour* for
1112 unsigned whatever the actual representation*/
1113 product_low += product_middle;
1114 if (product_low >= product_middle) {
1115 /* didn't overflow */
1116 if (auvok == buvok) {
1117 /* -ve * -ve or +ve * +ve gives a +ve result. */
1118 SP--;
1119 SETu( product_low );
1120 RETURN;
1121 } else if (product_low <= (UV)IV_MIN) {
1122 /* 2s complement assumption again */
1123 /* -ve result, which could overflow an IV */
1124 SP--;
25716404 1125 SETi( -(IV)product_low );
28e5dec8
JH		 1126 RETURN;
1127 } /* else drop to NVs below. */
1128 }
1129 } /* product_middle too large */
1130 } /* ahigh && bhigh */
1131 } /* SvIOK(TOPm1s) */
1132 } /* SvIOK(TOPs) */
1133#endif
a0d0e21e
LW		 1134 {
1135 dPOPTOPnnrl;
1136 SETn( left * right );
1137 RETURN;
79072805 1138 }
a0d0e21e
LW		 1139}
1140
1141PP(pp_divide)
1142{
39644a26 1143 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
5479d192 1144 /* Only try to do UV divide first
68795e93 1145 if ((SLOPPYDIVIDE is true) or
5479d192
NC		 1146 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1147 to preserve))
1148 The assumption is that it is better to use floating point divide
1149 whenever possible, only doing integer divide first if we can't be sure.
1150 If NV_PRESERVES_UV is true then we know at compile time that no UV
1151 can be too large to preserve, so don't need to compile the code to
1152 test the size of UVs. */
1153
a0d0e21e 1154#ifdef SLOPPYDIVIDE
5479d192
NC		 1155# define PERL_TRY_UV_DIVIDE
1156 /* ensure that 20./5. == 4. */
a0d0e21e 1157#else
5479d192
NC		 1158# ifdef PERL_PRESERVE_IVUV
1159# ifndef NV_PRESERVES_UV
1160# define PERL_TRY_UV_DIVIDE
1161# endif
1162# endif
a0d0e21e 1163#endif
5479d192
NC		 1164
1165#ifdef PERL_TRY_UV_DIVIDE
1166 SvIV_please(TOPs);
1167 if (SvIOK(TOPs)) {
1168 SvIV_please(TOPm1s);
1169 if (SvIOK(TOPm1s)) {
1170 bool left_non_neg = SvUOK(TOPm1s);
1171 bool right_non_neg = SvUOK(TOPs);
1172 UV left;
1173 UV right;
1174
1175 if (right_non_neg) {
1176 right = SvUVX(TOPs);
1177 }
1178 else {
1179 IV biv = SvIVX(TOPs);
1180 if (biv >= 0) {
1181 right = biv;
1182 right_non_neg = TRUE; /* effectively it's a UV now */
1183 }
1184 else {
1185 right = -biv;
1186 }
1187 }
1188 /* historically undef()/0 gives a "Use of uninitialized value"
1189 warning before dieing, hence this test goes here.
1190 If it were immediately before the second SvIV_please, then
1191 DIE() would be invoked before left was even inspected, so
1192 no inpsection would give no warning. */
1193 if (right == 0)
1194 DIE(aTHX_ "Illegal division by zero");
1195
1196 if (left_non_neg) {
1197 left = SvUVX(TOPm1s);
1198 }
1199 else {
1200 IV aiv = SvIVX(TOPm1s);
1201 if (aiv >= 0) {
1202 left = aiv;
1203 left_non_neg = TRUE; /* effectively it's a UV now */
1204 }
1205 else {
1206 left = -aiv;
1207 }
1208 }
1209
1210 if (left >= right
1211#ifdef SLOPPYDIVIDE
1212 /* For sloppy divide we always attempt integer division. */
1213#else
1214 /* Otherwise we only attempt it if either or both operands
1215 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC		 1216 we fall through to the NV divide code below. However,
1217 as left >= right to ensure integer result here, we know that
1218 we can skip the test on the right operand - right big
1219 enough not to be preserved can't get here unless left is
1220 also too big. */
1221
1222 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC		 1223#endif
1224 ) {
1225 /* Integer division can't overflow, but it can be imprecise. */
1226 UV result = left / right;
1227 if (result * right == left) {
1228 SP--; /* result is valid */
1229 if (left_non_neg == right_non_neg) {
1230 /* signs identical, result is positive. */
1231 SETu( result );
1232 RETURN;
1233 }
1234 /* 2s complement assumption */
1235 if (result <= (UV)IV_MIN)
91f3b821 1236 SETi( -(IV)result );
5479d192
NC		 1237 else {
1238 /* It's exact but too negative for IV. */
1239 SETn( -(NV)result );
1240 }
1241 RETURN;
1242 } /* tried integer divide but it was not an integer result */
32fdb065 1243 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
5479d192
NC		 1244 } /* left wasn't SvIOK */
1245 } /* right wasn't SvIOK */
1246#endif /* PERL_TRY_UV_DIVIDE */
1247 {
1248 dPOPPOPnnrl;
1249 if (right == 0.0)
1250 DIE(aTHX_ "Illegal division by zero");
1251 PUSHn( left / right );
1252 RETURN;
79072805 1253 }
a0d0e21e
LW		 1254}
1255
1256PP(pp_modulo)
1257{
39644a26 1258 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
a0d0e21e 1259 {
9c5ffd7c
JH		 1260 UV left = 0;
1261 UV right = 0;
dc656993
JH		 1262 bool left_neg = FALSE;
1263 bool right_neg = FALSE;
e2c88acc
NC		 1264 bool use_double = FALSE;
1265 bool dright_valid = FALSE;
9c5ffd7c
JH		 1266 NV dright = 0.0;
1267 NV dleft = 0.0;
787eafbd 1268
e2c88acc
NC		 1269 SvIV_please(TOPs);
1270 if (SvIOK(TOPs)) {
1271 right_neg = !SvUOK(TOPs);
1272 if (!right_neg) {
1273 right = SvUVX(POPs);
1274 } else {
1275 IV biv = SvIVX(POPs);
1276 if (biv >= 0) {
1277 right = biv;
1278 right_neg = FALSE; /* effectively it's a UV now */
1279 } else {
1280 right = -biv;
1281 }
1282 }
1283 }
1284 else {
787eafbd 1285 dright = POPn;
787eafbd
IZ		 1286 right_neg = dright < 0;
1287 if (right_neg)
1288 dright = -dright;
e2c88acc
NC		 1289 if (dright < UV_MAX_P1) {
1290 right = U_V(dright);
1291 dright_valid = TRUE; /* In case we need to use double below. */
1292 } else {
1293 use_double = TRUE;
1294 }
787eafbd 1295 }
a0d0e21e 1296
e2c88acc
NC		 1297 /* At this point use_double is only true if right is out of range for
1298 a UV. In range NV has been rounded down to nearest UV and
1299 use_double false. */
1300 SvIV_please(TOPs);
1301 if (!use_double && SvIOK(TOPs)) {
1302 if (SvIOK(TOPs)) {
1303 left_neg = !SvUOK(TOPs);
1304 if (!left_neg) {
1305 left = SvUVX(POPs);
1306 } else {
1307 IV aiv = SvIVX(POPs);
1308 if (aiv >= 0) {
1309 left = aiv;
1310 left_neg = FALSE; /* effectively it's a UV now */
1311 } else {
1312 left = -aiv;
1313 }
1314 }
1315 }
1316 }
787eafbd
IZ		 1317 else {
1318 dleft = POPn;
787eafbd
IZ		 1319 left_neg = dleft < 0;
1320 if (left_neg)
1321 dleft = -dleft;
68dc0745 1322
e2c88acc
NC		 1323 /* This should be exactly the 5.6 behaviour - if left and right are
1324 both in range for UV then use U_V() rather than floor. */
1325 if (!use_double) {
1326 if (dleft < UV_MAX_P1) {
1327 /* right was in range, so is dleft, so use UVs not double.
1328 */
1329 left = U_V(dleft);
1330 }
1331 /* left is out of range for UV, right was in range, so promote
1332 right (back) to double. */
1333 else {
1334 /* The +0.5 is used in 5.6 even though it is not strictly
1335 consistent with the implicit +0 floor in the U_V()
1336 inside the #if 1. */
1337 dleft = Perl_floor(dleft + 0.5);
1338 use_double = TRUE;
1339 if (dright_valid)
1340 dright = Perl_floor(dright + 0.5);
1341 else
1342 dright = right;
1343 }
1344 }
1345 }
787eafbd 1346 if (use_double) {
65202027 1347 NV dans;
787eafbd 1348
787eafbd 1349 if (!dright)
cea2e8a9 1350 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1351
65202027 1352 dans = Perl_fmod(dleft, dright);
787eafbd
IZ		 1353 if ((left_neg != right_neg) && dans)
1354 dans = dright - dans;
1355 if (right_neg)
1356 dans = -dans;
1357 sv_setnv(TARG, dans);
1358 }
1359 else {
1360 UV ans;
1361
787eafbd 1362 if (!right)
cea2e8a9 1363 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ		 1364
1365 ans = left % right;
1366 if ((left_neg != right_neg) && ans)
1367 ans = right - ans;
1368 if (right_neg) {
1369 /* XXX may warn: unary minus operator applied to unsigned type */
1370 /* could change -foo to be (~foo)+1 instead */
1371 if (ans <= ~((UV)IV_MAX)+1)
1372 sv_setiv(TARG, ~ans+1);
1373 else
65202027 1374 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ		 1375 }
1376 else
1377 sv_setuv(TARG, ans);
1378 }
1379 PUSHTARG;
1380 RETURN;
79072805 1381 }
a0d0e21e 1382}
79072805 1383
a0d0e21e
LW		 1384PP(pp_repeat)
1385{
39644a26 1386 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
748a9306 1387 {
467f0320 1388 register IV count = POPi;
3b8c0df9 1389 if (count < 0)
58a9d1fc 1390 count = 0;
533c011a 1391 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e
LW		 1392 dMARK;
1393 I32 items = SP - MARK;
1394 I32 max;
27d5b266 1395 static const char list_extend[] = "panic: list extend";
79072805 1396
a0d0e21e 1397 max = items * count;
27d5b266
JH		 1398 MEM_WRAP_CHECK_1(max, SV*, list_extend);
1399 if (items > 0 && max > 0 && (max < items || max < count))
1400 Perl_croak(aTHX_ list_extend);
a0d0e21e
LW		 1401 MEXTEND(MARK, max);
1402 if (count > 1) {
1403 while (SP > MARK) {
976c8a39
JH		 1404#if 0
1405 /* This code was intended to fix 20010809.028:
1406
1407 $x = 'abcd';
1408 for (($x =~ /./g) x 2) {
1409 print chop; # "abcdabcd" expected as output.
1410 }
1411
1412 * but that change (#11635) broke this code:
1413
1414 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1415
1416 * I can't think of a better fix that doesn't introduce
1417 * an efficiency hit by copying the SVs. The stack isn't
1418 * refcounted, and mortalisation obviously doesn't
1419 * Do The Right Thing when the stack has more than
1420 * one pointer to the same mortal value.
1421 * .robin.
1422 */
e30acc16
RH		 1423 if (*SP) {
1424 *SP = sv_2mortal(newSVsv(*SP));
1425 SvREADONLY_on(*SP);
1426 }
976c8a39
JH		 1427#else
1428 if (*SP)
1429 SvTEMP_off((*SP));
1430#endif
a0d0e21e 1431 SP--;
79072805 1432 }
a0d0e21e
LW		 1433 MARK++;
1434 repeatcpy((char*)(MARK + items), (char*)MARK,
1435 items * sizeof(SV*), count - 1);
1436 SP += max;
79072805 1437 }
a0d0e21e
LW		 1438 else if (count <= 0)
1439 SP -= items;
79072805 1440 }
a0d0e21e 1441 else { /* Note: mark already snarfed by pp_list */
dfcb284a 1442 SV *tmpstr = POPs;
a0d0e21e 1443 STRLEN len;
9b877dbb 1444 bool isutf;
a0d0e21e 1445
a0d0e21e
LW		 1446 SvSetSV(TARG, tmpstr);
1447 SvPV_force(TARG, len);
9b877dbb 1448 isutf = DO_UTF8(TARG);
8ebc5c01 1449 if (count != 1) {
1450 if (count < 1)
1451 SvCUR_set(TARG, 0);
1452 else {
27d5b266 1453 MEM_WRAP_CHECK_1(count, len, "panic: string extend");
8ebc5c01 1454 SvGROW(TARG, (count * len) + 1);
a0d0e21e 1455 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
8ebc5c01 1456 SvCUR(TARG) *= count;
7a4c00b4 1457 }
a0d0e21e 1458 *SvEND(TARG) = '\0';
a0d0e21e 1459 }
dfcb284a
GS		 1460 if (isutf)
1461 (void)SvPOK_only_UTF8(TARG);
1462 else
1463 (void)SvPOK_only(TARG);
b80b6069
RH		 1464
1465 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1466 /* The parser saw this as a list repeat, and there
1467 are probably several items on the stack. But we're
1468 in scalar context, and there's no pp_list to save us
1469 now. So drop the rest of the items -- robin@kitsite.com
1470 */
1471 dMARK;
1472 SP = MARK;
1473 }
a0d0e21e 1474 PUSHTARG;
79072805 1475 }
a0d0e21e 1476 RETURN;
748a9306 1477 }
a0d0e21e 1478}
79072805 1479
a0d0e21e
LW		 1480PP(pp_subtract)
1481{
39644a26 1482 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
28e5dec8
JH		 1483 useleft = USE_LEFT(TOPm1s);
1484#ifdef PERL_PRESERVE_IVUV
7dca457a
NC		 1485 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1486 "bad things" happen if you rely on signed integers wrapping. */
28e5dec8
JH		 1487 SvIV_please(TOPs);
1488 if (SvIOK(TOPs)) {
1489 /* Unless the left argument is integer in range we are going to have to
1490 use NV maths. Hence only attempt to coerce the right argument if
1491 we know the left is integer. */
9c5ffd7c
JH		 1492 register UV auv = 0;
1493 bool auvok = FALSE;
7dca457a
NC		 1494 bool a_valid = 0;
1495
28e5dec8 1496 if (!useleft) {
7dca457a
NC		 1497 auv = 0;
1498 a_valid = auvok = 1;
1499 /* left operand is undef, treat as zero. */
28e5dec8
JH		 1500 } else {
1501 /* Left operand is defined, so is it IV? */
1502 SvIV_please(TOPm1s);
1503 if (SvIOK(TOPm1s)) {
7dca457a
NC		 1504 if ((auvok = SvUOK(TOPm1s)))
1505 auv = SvUVX(TOPm1s);
1506 else {
1507 register IV aiv = SvIVX(TOPm1s);
1508 if (aiv >= 0) {
1509 auv = aiv;
1510 auvok = 1; /* Now acting as a sign flag. */
1511 } else { /* 2s complement assumption for IV_MIN */
1512 auv = (UV)-aiv;
28e5dec8 1513 }
7dca457a
NC		 1514 }
1515 a_valid = 1;
1516 }
1517 }
1518 if (a_valid) {
1519 bool result_good = 0;
1520 UV result;
1521 register UV buv;
1522 bool buvok = SvUOK(TOPs);
9041c2e3 1523
7dca457a
NC		 1524 if (buvok)
1525 buv = SvUVX(TOPs);
1526 else {
1527 register IV biv = SvIVX(TOPs);
1528 if (biv >= 0) {
1529 buv = biv;
1530 buvok = 1;
1531 } else
1532 buv = (UV)-biv;
1533 }
1534 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1535 else "IV" now, independent of how it came in.
7dca457a
NC		 1536 if a, b represents positive, A, B negative, a maps to -A etc
1537 a - b => (a - b)
1538 A - b => -(a + b)
1539 a - B => (a + b)
1540 A - B => -(a - b)
1541 all UV maths. negate result if A negative.
1542 subtract if signs same, add if signs differ. */
1543
1544 if (auvok ^ buvok) {
1545 /* Signs differ. */
1546 result = auv + buv;
1547 if (result >= auv)
1548 result_good = 1;
1549 } else {
1550 /* Signs same */
1551 if (auv >= buv) {
1552 result = auv - buv;
1553 /* Must get smaller */
1554 if (result <= auv)
1555 result_good = 1;
1556 } else {
1557 result = buv - auv;
1558 if (result <= buv) {
1559 /* result really should be -(auv-buv). as its negation
1560 of true value, need to swap our result flag */
1561 auvok = !auvok;
1562 result_good = 1;
28e5dec8 1563 }
28e5dec8
JH		 1564 }
1565 }
7dca457a
NC		 1566 if (result_good) {
1567 SP--;
1568 if (auvok)
1569 SETu( result );
1570 else {
1571 /* Negate result */
1572 if (result <= (UV)IV_MIN)
1573 SETi( -(IV)result );
1574 else {
1575 /* result valid, but out of range for IV. */
1576 SETn( -(NV)result );
1577 }
1578 }
1579 RETURN;
1580 } /* Overflow, drop through to NVs. */
28e5dec8
JH		 1581 }
1582 }
1583#endif
7dca457a 1584 useleft = USE_LEFT(TOPm1s);
a0d0e21e 1585 {
28e5dec8
JH		 1586 dPOPnv;
1587 if (!useleft) {
1588 /* left operand is undef, treat as zero - value */
1589 SETn(-value);
1590 RETURN;
1591 }
1592 SETn( TOPn - value );
1593 RETURN;
79072805 1594 }
a0d0e21e 1595}
79072805 1596
a0d0e21e
LW		 1597PP(pp_left_shift)
1598{
39644a26 1599 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
a0d0e21e 1600 {
972b05a9 1601 IV shift = POPi;
d0ba1bd2 1602 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1603 IV i = TOPi;
1604 SETi(i << shift);
d0ba1bd2
JH		 1605 }
1606 else {
972b05a9
JH		 1607 UV u = TOPu;
1608 SETu(u << shift);
d0ba1bd2 1609 }
55497cff 1610 RETURN;
79072805 1611 }
a0d0e21e 1612}
79072805 1613
a0d0e21e
LW		 1614PP(pp_right_shift)
1615{
39644a26 1616 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
a0d0e21e 1617 {
972b05a9 1618 IV shift = POPi;
d0ba1bd2 1619 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1620 IV i = TOPi;
1621 SETi(i >> shift);
d0ba1bd2
JH		 1622 }
1623 else {
972b05a9
JH		 1624 UV u = TOPu;
1625 SETu(u >> shift);
d0ba1bd2 1626 }
a0d0e21e 1627 RETURN;
93a17b20 1628 }
79072805
LW		 1629}
1630
a0d0e21e 1631PP(pp_lt)
79072805 1632{
39644a26 1633 dSP; tryAMAGICbinSET(lt,0);
28e5dec8
JH		 1634#ifdef PERL_PRESERVE_IVUV
1635 SvIV_please(TOPs);
1636 if (SvIOK(TOPs)) {
1637 SvIV_please(TOPm1s);
1638 if (SvIOK(TOPm1s)) {
1639 bool auvok = SvUOK(TOPm1s);
1640 bool buvok = SvUOK(TOPs);
a227d84d 1641
28e5dec8
JH		 1642 if (!auvok && !buvok) { /* ## IV < IV ## */
1643 IV aiv = SvIVX(TOPm1s);
1644 IV biv = SvIVX(TOPs);
1645
1646 SP--;
1647 SETs(boolSV(aiv < biv));
1648 RETURN;
1649 }
1650 if (auvok && buvok) { /* ## UV < UV ## */
1651 UV auv = SvUVX(TOPm1s);
1652 UV buv = SvUVX(TOPs);
1653
1654 SP--;
1655 SETs(boolSV(auv < buv));
1656 RETURN;
1657 }
1658 if (auvok) { /* ## UV < IV ## */
1659 UV auv;
1660 IV biv;
1661
1662 biv = SvIVX(TOPs);
1663 SP--;
1664 if (biv < 0) {
1665 /* As (a) is a UV, it's >=0, so it cannot be < */
1666 SETs(&PL_sv_no);
1667 RETURN;
1668 }
1669 auv = SvUVX(TOPs);
28e5dec8
JH		 1670 SETs(boolSV(auv < (UV)biv));
1671 RETURN;
1672 }
1673 { /* ## IV < UV ## */
1674 IV aiv;
1675 UV buv;
1676
1677 aiv = SvIVX(TOPm1s);
1678 if (aiv < 0) {
1679 /* As (b) is a UV, it's >=0, so it must be < */
1680 SP--;
1681 SETs(&PL_sv_yes);
1682 RETURN;
1683 }
1684 buv = SvUVX(TOPs);
1685 SP--;
28e5dec8
JH		 1686 SETs(boolSV((UV)aiv < buv));
1687 RETURN;
1688 }
1689 }
1690 }
1691#endif
30de85b6 1692#ifndef NV_PRESERVES_UV
50fb3111
NC		 1693#ifdef PERL_PRESERVE_IVUV
1694 else
1695#endif
1696 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1697 SP--;
1698 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1699 RETURN;
1700 }
30de85b6 1701#endif
a0d0e21e
LW		 1702 {
1703 dPOPnv;
54310121 1704 SETs(boolSV(TOPn < value));
a0d0e21e 1705 RETURN;
79072805 1706 }
a0d0e21e 1707}
79072805 1708
a0d0e21e
LW		 1709PP(pp_gt)
1710{
39644a26 1711 dSP; tryAMAGICbinSET(gt,0);
28e5dec8
JH		 1712#ifdef PERL_PRESERVE_IVUV
1713 SvIV_please(TOPs);
1714 if (SvIOK(TOPs)) {
1715 SvIV_please(TOPm1s);
1716 if (SvIOK(TOPm1s)) {
1717 bool auvok = SvUOK(TOPm1s);
1718 bool buvok = SvUOK(TOPs);
a227d84d 1719
28e5dec8
JH		 1720 if (!auvok && !buvok) { /* ## IV > IV ## */
1721 IV aiv = SvIVX(TOPm1s);
1722 IV biv = SvIVX(TOPs);
1723
1724 SP--;
1725 SETs(boolSV(aiv > biv));
1726 RETURN;
1727 }
1728 if (auvok && buvok) { /* ## UV > UV ## */
1729 UV auv = SvUVX(TOPm1s);
1730 UV buv = SvUVX(TOPs);
1731
1732 SP--;
1733 SETs(boolSV(auv > buv));
1734 RETURN;
1735 }
1736 if (auvok) { /* ## UV > IV ## */
1737 UV auv;
1738 IV biv;
1739
1740 biv = SvIVX(TOPs);
1741 SP--;
1742 if (biv < 0) {
1743 /* As (a) is a UV, it's >=0, so it must be > */
1744 SETs(&PL_sv_yes);
1745 RETURN;
1746 }
1747 auv = SvUVX(TOPs);
28e5dec8
JH		 1748 SETs(boolSV(auv > (UV)biv));
1749 RETURN;
1750 }
1751 { /* ## IV > UV ## */
1752 IV aiv;
1753 UV buv;
1754
1755 aiv = SvIVX(TOPm1s);
1756 if (aiv < 0) {
1757 /* As (b) is a UV, it's >=0, so it cannot be > */
1758 SP--;
1759 SETs(&PL_sv_no);
1760 RETURN;
1761 }
1762 buv = SvUVX(TOPs);
1763 SP--;
28e5dec8
JH		 1764 SETs(boolSV((UV)aiv > buv));
1765 RETURN;
1766 }
1767 }
1768 }
1769#endif
30de85b6 1770#ifndef NV_PRESERVES_UV
50fb3111
NC		 1771#ifdef PERL_PRESERVE_IVUV
1772 else
1773#endif
1774 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1775 SP--;
1776 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1777 RETURN;
1778 }
1779#endif
a0d0e21e
LW		 1780 {
1781 dPOPnv;
54310121 1782 SETs(boolSV(TOPn > value));
a0d0e21e 1783 RETURN;
79072805 1784 }
a0d0e21e
LW		 1785}
1786
1787PP(pp_le)
1788{
39644a26 1789 dSP; tryAMAGICbinSET(le,0);
28e5dec8
JH		 1790#ifdef PERL_PRESERVE_IVUV
1791 SvIV_please(TOPs);
1792 if (SvIOK(TOPs)) {
1793 SvIV_please(TOPm1s);
1794 if (SvIOK(TOPm1s)) {
1795 bool auvok = SvUOK(TOPm1s);
1796 bool buvok = SvUOK(TOPs);
a227d84d 1797
28e5dec8
JH		 1798 if (!auvok && !buvok) { /* ## IV <= IV ## */
1799 IV aiv = SvIVX(TOPm1s);
1800 IV biv = SvIVX(TOPs);
1801
1802 SP--;
1803 SETs(boolSV(aiv <= biv));
1804 RETURN;
1805 }
1806 if (auvok && buvok) { /* ## UV <= UV ## */
1807 UV auv = SvUVX(TOPm1s);
1808 UV buv = SvUVX(TOPs);
1809
1810 SP--;
1811 SETs(boolSV(auv <= buv));
1812 RETURN;
1813 }
1814 if (auvok) { /* ## UV <= IV ## */
1815 UV auv;
1816 IV biv;
1817
1818 biv = SvIVX(TOPs);
1819 SP--;
1820 if (biv < 0) {
1821 /* As (a) is a UV, it's >=0, so a cannot be <= */
1822 SETs(&PL_sv_no);
1823 RETURN;
1824 }
1825 auv = SvUVX(TOPs);
28e5dec8
JH		 1826 SETs(boolSV(auv <= (UV)biv));
1827 RETURN;
1828 }
1829 { /* ## IV <= UV ## */
1830 IV aiv;
1831 UV buv;
1832
1833 aiv = SvIVX(TOPm1s);
1834 if (aiv < 0) {
1835 /* As (b) is a UV, it's >=0, so a must be <= */
1836 SP--;
1837 SETs(&PL_sv_yes);
1838 RETURN;
1839 }
1840 buv = SvUVX(TOPs);
1841 SP--;
28e5dec8
JH		 1842 SETs(boolSV((UV)aiv <= buv));
1843 RETURN;
1844 }
1845 }
1846 }
1847#endif
30de85b6 1848#ifndef NV_PRESERVES_UV
50fb3111
NC		 1849#ifdef PERL_PRESERVE_IVUV
1850 else
1851#endif
1852 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1853 SP--;
1854 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1855 RETURN;
1856 }
1857#endif
a0d0e21e
LW		 1858 {
1859 dPOPnv;
54310121 1860 SETs(boolSV(TOPn <= value));
a0d0e21e 1861 RETURN;
79072805 1862 }
a0d0e21e
LW		 1863}
1864
1865PP(pp_ge)
1866{
39644a26 1867 dSP; tryAMAGICbinSET(ge,0);
28e5dec8
JH		 1868#ifdef PERL_PRESERVE_IVUV
1869 SvIV_please(TOPs);
1870 if (SvIOK(TOPs)) {
1871 SvIV_please(TOPm1s);
1872 if (SvIOK(TOPm1s)) {
1873 bool auvok = SvUOK(TOPm1s);
1874 bool buvok = SvUOK(TOPs);
a227d84d 1875
28e5dec8
JH		 1876 if (!auvok && !buvok) { /* ## IV >= IV ## */
1877 IV aiv = SvIVX(TOPm1s);
1878 IV biv = SvIVX(TOPs);
1879
1880 SP--;
1881 SETs(boolSV(aiv >= biv));
1882 RETURN;
1883 }
1884 if (auvok && buvok) { /* ## UV >= UV ## */
1885 UV auv = SvUVX(TOPm1s);
1886 UV buv = SvUVX(TOPs);
1887
1888 SP--;
1889 SETs(boolSV(auv >= buv));
1890 RETURN;
1891 }
1892 if (auvok) { /* ## UV >= IV ## */
1893 UV auv;
1894 IV biv;
1895
1896 biv = SvIVX(TOPs);
1897 SP--;
1898 if (biv < 0) {
1899 /* As (a) is a UV, it's >=0, so it must be >= */
1900 SETs(&PL_sv_yes);
1901 RETURN;
1902 }
1903 auv = SvUVX(TOPs);
28e5dec8
JH		 1904 SETs(boolSV(auv >= (UV)biv));
1905 RETURN;
1906 }
1907 { /* ## IV >= UV ## */
1908 IV aiv;
1909 UV buv;
1910
1911 aiv = SvIVX(TOPm1s);
1912 if (aiv < 0) {
1913 /* As (b) is a UV, it's >=0, so a cannot be >= */
1914 SP--;
1915 SETs(&PL_sv_no);
1916 RETURN;
1917 }
1918 buv = SvUVX(TOPs);
1919 SP--;
28e5dec8
JH		 1920 SETs(boolSV((UV)aiv >= buv));
1921 RETURN;
1922 }
1923 }
1924 }
1925#endif
30de85b6 1926#ifndef NV_PRESERVES_UV
50fb3111
NC		 1927#ifdef PERL_PRESERVE_IVUV
1928 else
1929#endif
1930 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1931 SP--;
1932 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1933 RETURN;
1934 }
1935#endif
a0d0e21e
LW		 1936 {
1937 dPOPnv;
54310121 1938 SETs(boolSV(TOPn >= value));
a0d0e21e 1939 RETURN;
79072805 1940 }
a0d0e21e 1941}
79072805 1942
a0d0e21e
LW		 1943PP(pp_ne)
1944{
16303949 1945 dSP; tryAMAGICbinSET(ne,0);
3bb2c415
JH		 1946#ifndef NV_PRESERVES_UV
1947 if (SvROK(TOPs) && SvROK(TOPm1s)) {
e61d22ef
NC		 1948 SP--;
1949 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
3bb2c415
JH		 1950 RETURN;
1951 }
1952#endif
28e5dec8
JH		 1953#ifdef PERL_PRESERVE_IVUV
1954 SvIV_please(TOPs);
1955 if (SvIOK(TOPs)) {
1956 SvIV_please(TOPm1s);
1957 if (SvIOK(TOPm1s)) {
1958 bool auvok = SvUOK(TOPm1s);
1959 bool buvok = SvUOK(TOPs);
a227d84d 1960
30de85b6
NC		 1961 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1962 /* Casting IV to UV before comparison isn't going to matter
1963 on 2s complement. On 1s complement or sign&magnitude
1964 (if we have any of them) it could make negative zero
1965 differ from normal zero. As I understand it. (Need to
1966 check - is negative zero implementation defined behaviour
1967 anyway?). NWC */
1968 UV buv = SvUVX(POPs);
1969 UV auv = SvUVX(TOPs);
28e5dec8 1970
28e5dec8
JH		 1971 SETs(boolSV(auv != buv));
1972 RETURN;
1973 }
1974 { /* ## Mixed IV,UV ## */
1975 IV iv;
1976 UV uv;
1977
1978 /* != is commutative so swap if needed (save code) */
1979 if (auvok) {
1980 /* swap. top of stack (b) is the iv */
1981 iv = SvIVX(TOPs);
1982 SP--;
1983 if (iv < 0) {
1984 /* As (a) is a UV, it's >0, so it cannot be == */
1985 SETs(&PL_sv_yes);
1986 RETURN;
1987 }
1988 uv = SvUVX(TOPs);
1989 } else {
1990 iv = SvIVX(TOPm1s);
1991 SP--;
1992 if (iv < 0) {
1993 /* As (b) is a UV, it's >0, so it cannot be == */
1994 SETs(&PL_sv_yes);
1995 RETURN;
1996 }
1997 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1998 }
28e5dec8
JH		 1999 SETs(boolSV((UV)iv != uv));
2000 RETURN;
2001 }
2002 }
2003 }
2004#endif
a0d0e21e
LW		 2005 {
2006 dPOPnv;
54310121 2007 SETs(boolSV(TOPn != value));
a0d0e21e
LW		 2008 RETURN;
2009 }
79072805
LW		 2010}
2011
a0d0e21e 2012PP(pp_ncmp)
79072805 2013{
39644a26 2014 dSP; dTARGET; tryAMAGICbin(ncmp,0);
d8c7644e
JH		 2015#ifndef NV_PRESERVES_UV
2016 if (SvROK(TOPs) && SvROK(TOPm1s)) {
e61d22ef
NC		 2017 UV right = PTR2UV(SvRV(POPs));
2018 UV left = PTR2UV(SvRV(TOPs));
2019 SETi((left > right) - (left < right));
d8c7644e
JH		 2020 RETURN;
2021 }
2022#endif
28e5dec8
JH		 2023#ifdef PERL_PRESERVE_IVUV
2024 /* Fortunately it seems NaN isn't IOK */
2025 SvIV_please(TOPs);
2026 if (SvIOK(TOPs)) {
2027 SvIV_please(TOPm1s);
2028 if (SvIOK(TOPm1s)) {
2029 bool leftuvok = SvUOK(TOPm1s);
2030 bool rightuvok = SvUOK(TOPs);
2031 I32 value;
2032 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2033 IV leftiv = SvIVX(TOPm1s);
2034 IV rightiv = SvIVX(TOPs);
2035
2036 if (leftiv > rightiv)
2037 value = 1;
2038 else if (leftiv < rightiv)
2039 value = -1;
2040 else
2041 value = 0;
2042 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2043 UV leftuv = SvUVX(TOPm1s);
2044 UV rightuv = SvUVX(TOPs);
2045
2046 if (leftuv > rightuv)
2047 value = 1;
2048 else if (leftuv < rightuv)
2049 value = -1;
2050 else
2051 value = 0;
2052 } else if (leftuvok) { /* ## UV <=> IV ## */
2053 UV leftuv;
2054 IV rightiv;
2055
2056 rightiv = SvIVX(TOPs);
2057 if (rightiv < 0) {
2058 /* As (a) is a UV, it's >=0, so it cannot be < */
2059 value = 1;
2060 } else {
2061 leftuv = SvUVX(TOPm1s);
83bac5dd 2062 if (leftuv > (UV)rightiv) {
28e5dec8
JH		 2063 value = 1;
2064 } else if (leftuv < (UV)rightiv) {
2065 value = -1;
2066 } else {
2067 value = 0;
2068 }
2069 }
2070 } else { /* ## IV <=> UV ## */
2071 IV leftiv;
2072 UV rightuv;
2073
2074 leftiv = SvIVX(TOPm1s);
2075 if (leftiv < 0) {
2076 /* As (b) is a UV, it's >=0, so it must be < */
2077 value = -1;
2078 } else {
2079 rightuv = SvUVX(TOPs);
83bac5dd 2080 if ((UV)leftiv > rightuv) {
28e5dec8 2081 value = 1;
83bac5dd 2082 } else if ((UV)leftiv < rightuv) {
28e5dec8
JH		 2083 value = -1;
2084 } else {
2085 value = 0;
2086 }
2087 }
2088 }
2089 SP--;
2090 SETi(value);
2091 RETURN;
2092 }
2093 }
2094#endif
a0d0e21e
LW		 2095 {
2096 dPOPTOPnnrl;
2097 I32 value;
79072805 2098
a3540c92 2099#ifdef Perl_isnan
1ad04cfd
JH		 2100 if (Perl_isnan(left) || Perl_isnan(right)) {
2101 SETs(&PL_sv_undef);
2102 RETURN;
2103 }
2104 value = (left > right) - (left < right);
2105#else
ff0cee69 2106 if (left == right)
a0d0e21e 2107 value = 0;
a0d0e21e
LW		 2108 else if (left < right)
2109 value = -1;
44a8e56a 2110 else if (left > right)
2111 value = 1;
2112 else {
3280af22 2113 SETs(&PL_sv_undef);
44a8e56a 2114 RETURN;
2115 }
1ad04cfd 2116#endif
a0d0e21e
LW		 2117 SETi(value);
2118 RETURN;
79072805 2119 }
a0d0e21e 2120}
79072805 2121
a0d0e21e
LW		 2122PP(pp_slt)
2123{
39644a26 2124 dSP; tryAMAGICbinSET(slt,0);
a0d0e21e
LW		 2125 {
2126 dPOPTOPssrl;
2de3dbcc 2127 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2128 ? sv_cmp_locale(left, right)
2129 : sv_cmp(left, right));
54310121 2130 SETs(boolSV(cmp < 0));
a0d0e21e
LW		 2131 RETURN;
2132 }
79072805
LW		 2133}
2134
a0d0e21e 2135PP(pp_sgt)
79072805 2136{
39644a26 2137 dSP; tryAMAGICbinSET(sgt,0);
a0d0e21e
LW		 2138 {
2139 dPOPTOPssrl;
2de3dbcc 2140 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2141 ? sv_cmp_locale(left, right)
2142 : sv_cmp(left, right));
54310121 2143 SETs(boolSV(cmp > 0));
a0d0e21e
LW		 2144 RETURN;
2145 }
2146}
79072805 2147
a0d0e21e
LW		 2148PP(pp_sle)
2149{
39644a26 2150 dSP; tryAMAGICbinSET(sle,0);
a0d0e21e
LW		 2151 {
2152 dPOPTOPssrl;
2de3dbcc 2153 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2154 ? sv_cmp_locale(left, right)
2155 : sv_cmp(left, right));
54310121 2156 SETs(boolSV(cmp <= 0));
a0d0e21e 2157 RETURN;
79072805 2158 }
79072805
LW		 2159}
2160
a0d0e21e
LW		 2161PP(pp_sge)
2162{
39644a26 2163 dSP; tryAMAGICbinSET(sge,0);
a0d0e21e
LW		 2164 {
2165 dPOPTOPssrl;
2de3dbcc 2166 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2167 ? sv_cmp_locale(left, right)
2168 : sv_cmp(left, right));
54310121 2169 SETs(boolSV(cmp >= 0));
a0d0e21e
LW		 2170 RETURN;
2171 }
2172}
79072805 2173
36477c24 2174PP(pp_seq)
2175{
39644a26 2176 dSP; tryAMAGICbinSET(seq,0);
36477c24 2177 {
2178 dPOPTOPssrl;
54310121 2179 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW		 2180 RETURN;
2181 }
2182}
79072805 2183
a0d0e21e 2184PP(pp_sne)
79072805 2185{
39644a26 2186 dSP; tryAMAGICbinSET(sne,0);
a0d0e21e
LW		 2187 {
2188 dPOPTOPssrl;
54310121 2189 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 2190 RETURN;
463ee0b2 2191 }
79072805
LW		 2192}
2193
a0d0e21e 2194PP(pp_scmp)
79072805 2195{
39644a26 2196 dSP; dTARGET; tryAMAGICbin(scmp,0);
a0d0e21e
LW		 2197 {
2198 dPOPTOPssrl;
2de3dbcc 2199 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2200 ? sv_cmp_locale(left, right)
2201 : sv_cmp(left, right));
2202 SETi( cmp );
a0d0e21e
LW		 2203 RETURN;
2204 }
2205}
79072805 2206
55497cff 2207PP(pp_bit_and)
2208{
39644a26 2209 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
a0d0e21e
LW		 2210 {
2211 dPOPTOPssrl;
028c96eb
RGS		 2212 if (SvGMAGICAL(left)) mg_get(left);
2213 if (SvGMAGICAL(right)) mg_get(right);
4633a7c4 2214 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2215 if (PL_op->op_private & HINT_INTEGER) {
891f9566 2216 IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2217 SETi(i);
d0ba1bd2
JH		 2218 }
2219 else {
891f9566 2220 UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2221 SETu(u);
d0ba1bd2 2222 }
a0d0e21e
LW		 2223 }
2224 else {
533c011a 2225 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2226 SETTARG;
2227 }
2228 RETURN;
2229 }
2230}
79072805 2231
a0d0e21e
LW		 2232PP(pp_bit_xor)
2233{
39644a26 2234 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW		 2235 {
2236 dPOPTOPssrl;
028c96eb
RGS		 2237 if (SvGMAGICAL(left)) mg_get(left);
2238 if (SvGMAGICAL(right)) mg_get(right);
4633a7c4 2239 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2240 if (PL_op->op_private & HINT_INTEGER) {
891f9566 2241 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
972b05a9 2242 SETi(i);
d0ba1bd2
JH		 2243 }
2244 else {
891f9566 2245 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
972b05a9 2246 SETu(u);
d0ba1bd2 2247 }
a0d0e21e
LW		 2248 }
2249 else {
533c011a 2250 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2251 SETTARG;
2252 }
2253 RETURN;
2254 }
2255}
79072805 2256
a0d0e21e
LW		 2257PP(pp_bit_or)
2258{
39644a26 2259 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW		 2260 {
2261 dPOPTOPssrl;
028c96eb
RGS		 2262 if (SvGMAGICAL(left)) mg_get(left);
2263 if (SvGMAGICAL(right)) mg_get(right);
4633a7c4 2264 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2265 if (PL_op->op_private & HINT_INTEGER) {
891f9566 2266 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
972b05a9 2267 SETi(i);
d0ba1bd2
JH		 2268 }
2269 else {
891f9566 2270 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
972b05a9 2271 SETu(u);
d0ba1bd2 2272 }
a0d0e21e
LW		 2273 }
2274 else {
533c011a 2275 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2276 SETTARG;
2277 }
2278 RETURN;
79072805 2279 }
a0d0e21e 2280}
79072805 2281
a0d0e21e
LW		 2282PP(pp_negate)
2283{
39644a26 2284 dSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW		 2285 {
2286 dTOPss;
28e5dec8 2287 int flags = SvFLAGS(sv);
4633a7c4
LW		 2288 if (SvGMAGICAL(sv))
2289 mg_get(sv);
28e5dec8
JH		 2290 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2291 /* It's publicly an integer, or privately an integer-not-float */
2292 oops_its_an_int:
9b0e499b
GS		 2293 if (SvIsUV(sv)) {
2294 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2295 /* 2s complement assumption. */
9b0e499b
GS		 2296 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2297 RETURN;
2298 }
2299 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2300 SETi(-SvIVX(sv));
9b0e499b
GS		 2301 RETURN;
2302 }
2303 }
2304 else if (SvIVX(sv) != IV_MIN) {
2305 SETi(-SvIVX(sv));
2306 RETURN;
2307 }
28e5dec8
JH		 2308#ifdef PERL_PRESERVE_IVUV
2309 else {
2310 SETu((UV)IV_MIN);
2311 RETURN;
2312 }
2313#endif
9b0e499b
GS		 2314 }
2315 if (SvNIOKp(sv))
a0d0e21e 2316 SETn(-SvNV(sv));
4633a7c4 2317 else if (SvPOKp(sv)) {
a0d0e21e
LW		 2318 STRLEN len;
2319 char *s = SvPV(sv, len);
bbce6d69 2320 if (isIDFIRST(*s)) {
a0d0e21e
LW		 2321 sv_setpvn(TARG, "-", 1);
2322 sv_catsv(TARG, sv);
79072805 2323 }
a0d0e21e
LW		 2324 else if (*s == '+' || *s == '-') {
2325 sv_setsv(TARG, sv);
2326 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805 2327 }
8eb28a70
JH		 2328 else if (DO_UTF8(sv)) {
2329 SvIV_please(sv);
2330 if (SvIOK(sv))
2331 goto oops_its_an_int;
2332 if (SvNOK(sv))
2333 sv_setnv(TARG, -SvNV(sv));
2334 else {
2335 sv_setpvn(TARG, "-", 1);
2336 sv_catsv(TARG, sv);
2337 }
834a4ddd 2338 }
28e5dec8 2339 else {
8eb28a70
JH		 2340 SvIV_please(sv);
2341 if (SvIOK(sv))
2342 goto oops_its_an_int;
2343 sv_setnv(TARG, -SvNV(sv));
28e5dec8 2344 }
a0d0e21e 2345 SETTARG;
79072805 2346 }
4633a7c4
LW		 2347 else
2348 SETn(-SvNV(sv));
79072805 2349 }
a0d0e21e 2350 RETURN;
79072805
LW		 2351}
2352
a0d0e21e 2353PP(pp_not)
79072805 2354{
39644a26 2355 dSP; tryAMAGICunSET(not);
3280af22 2356 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
a0d0e21e 2357 return NORMAL;
79072805
LW		 2358}
2359
a0d0e21e 2360PP(pp_complement)
79072805 2361{
39644a26 2362 dSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW		 2363 {
2364 dTOPss;
028c96eb
RGS		 2365 if (SvGMAGICAL(sv))
2366 mg_get(sv);
4633a7c4 2367 if (SvNIOKp(sv)) {
d0ba1bd2 2368 if (PL_op->op_private & HINT_INTEGER) {
891f9566 2369 IV i = ~SvIV_nomg(sv);
972b05a9 2370 SETi(i);
d0ba1bd2
JH		 2371 }
2372 else {
891f9566 2373 UV u = ~SvUV_nomg(sv);
972b05a9 2374 SETu(u);
d0ba1bd2 2375 }
a0d0e21e
LW		 2376 }
2377 else {
51723571 2378 register U8 *tmps;
55497cff 2379 register I32 anum;
a0d0e21e
LW		 2380 STRLEN len;
2381
5ab053b0 2382 (void)SvPV_nomg(sv,len); /* force check for uninit var */
891f9566 2383 sv_setsv_nomg(TARG, sv);
51723571 2384 tmps = (U8*)SvPV_force(TARG, len);
a0d0e21e 2385 anum = len;
1d68d6cd 2386 if (SvUTF8(TARG)) {
a1ca4561 2387 /* Calculate exact length, let's not estimate. */
1d68d6cd
SC		 2388 STRLEN targlen = 0;
2389 U8 *result;
51723571 2390 U8 *send;
ba210ebe 2391 STRLEN l;
a1ca4561
YST		 2392 UV nchar = 0;
2393 UV nwide = 0;
1d68d6cd
SC		 2394
2395 send = tmps + len;
2396 while (tmps < send) {
9041c2e3 2397 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1d68d6cd 2398 tmps += UTF8SKIP(tmps);
5bbb0b5a 2399 targlen += UNISKIP(~c);
a1ca4561
YST		 2400 nchar++;
2401 if (c > 0xff)
2402 nwide++;
1d68d6cd
SC		 2403 }
2404
2405 /* Now rewind strings and write them. */
2406 tmps -= len;
a1ca4561
YST		 2407
2408 if (nwide) {
2409 Newz(0, result, targlen + 1, U8);
2410 while (tmps < send) {
9041c2e3 2411 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
a1ca4561 2412 tmps += UTF8SKIP(tmps);
b851fbc1 2413 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
a1ca4561
YST		 2414 }
2415 *result = '\0';
2416 result -= targlen;
2417 sv_setpvn(TARG, (char*)result, targlen);
2418 SvUTF8_on(TARG);
2419 }
2420 else {
2421 Newz(0, result, nchar + 1, U8);
2422 while (tmps < send) {
9041c2e3 2423 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
a1ca4561
YST		 2424 tmps += UTF8SKIP(tmps);
2425 *result++ = ~c;
2426 }
2427 *result = '\0';
2428 result -= nchar;
2429 sv_setpvn(TARG, (char*)result, nchar);
d0a21e00 2430 SvUTF8_off(TARG);
1d68d6cd 2431 }
1d68d6cd
SC		 2432 Safefree(result);
2433 SETs(TARG);
2434 RETURN;
2435 }
a0d0e21e 2436#ifdef LIBERAL
51723571
JH		 2437 {
2438 register long *tmpl;
2439 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2440 *tmps = ~*tmps;
2441 tmpl = (long*)tmps;
2442 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2443 *tmpl = ~*tmpl;
2444 tmps = (U8*)tmpl;
2445 }
a0d0e21e
LW		 2446#endif
2447 for ( ; anum > 0; anum--, tmps++)
2448 *tmps = ~*tmps;
2449
2450 SETs(TARG);
2451 }
2452 RETURN;
2453 }
79072805
LW		 2454}
2455
a0d0e21e
LW		 2456/* integer versions of some of the above */
2457
a0d0e21e 2458PP(pp_i_multiply)
79072805 2459{
39644a26 2460 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW		 2461 {
2462 dPOPTOPiirl;
2463 SETi( left * right );
2464 RETURN;
2465 }
79072805
LW		 2466}
2467
a0d0e21e 2468PP(pp_i_divide)
79072805 2469{
39644a26 2470 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW		 2471 {
2472 dPOPiv;
2473 if (value == 0)
cea2e8a9 2474 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW		 2475 value = POPi / value;
2476 PUSHi( value );
2477 RETURN;
2478 }
79072805
LW		 2479}
2480
224ec323
JH		 2481STATIC
2482PP(pp_i_modulo_0)
2483{
2484 /* This is the vanilla old i_modulo. */
2485 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2486 {
2487 dPOPTOPiirl;
2488 if (!right)
2489 DIE(aTHX_ "Illegal modulus zero");
2490 SETi( left % right );
2491 RETURN;
2492 }
2493}
2494
11010fa3 2495#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH		 2496STATIC
2497PP(pp_i_modulo_1)
2498{
224ec323 2499 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2500 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323
JH		 2501 * See below for pp_i_modulo. */
2502 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2503 {
2504 dPOPTOPiirl;
2505 if (!right)
2506 DIE(aTHX_ "Illegal modulus zero");
32fdb065 2507 SETi( left % PERL_ABS(right) );
224ec323
JH		 2508 RETURN;
2509 }
224ec323 2510}
fce2b89e 2511#endif
224ec323 2512
a0d0e21e 2513PP(pp_i_modulo)
79072805 2514{
224ec323
JH		 2515 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2516 {
2517 dPOPTOPiirl;
2518 if (!right)
2519 DIE(aTHX_ "Illegal modulus zero");
2520 /* The assumption is to use hereafter the old vanilla version... */
2521 PL_op->op_ppaddr =
2522 PL_ppaddr[OP_I_MODULO] =
2523 &Perl_pp_i_modulo_0;
2524 /* .. but if we have glibc, we might have a buggy _moddi3
2525 * (at least glicb 2.2.5 is known to have this bug), in other
2526 * words our integer modulus with negative quad as the second
2527 * argument might be broken. Test for this and re-patch the
2528 * opcode dispatch table if that is the case, remembering to
2529 * also apply the workaround so that this first round works
2530 * right, too. See [perl #9402] for more information. */
2531#if defined(__GLIBC__) && IVSIZE == 8
2532 {
2533 IV l = 3;
2534 IV r = -10;
2535 /* Cannot do this check with inlined IV constants since
2536 * that seems to work correctly even with the buggy glibc. */
2537 if (l % r == -3) {
2538 /* Yikes, we have the bug.
2539 * Patch in the workaround version. */
2540 PL_op->op_ppaddr =
2541 PL_ppaddr[OP_I_MODULO] =
2542 &Perl_pp_i_modulo_1;
2543 /* Make certain we work right this time, too. */
32fdb065 2544 right = PERL_ABS(right);
224ec323
JH		 2545 }
2546 }
2547#endif
2548 SETi( left % right );
2549 RETURN;
2550 }
79072805
LW		 2551}
2552
a0d0e21e 2553PP(pp_i_add)
79072805 2554{
39644a26 2555 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e 2556 {
5e66d4f1 2557 dPOPTOPiirl_ul;
a0d0e21e
LW		 2558 SETi( left + right );
2559 RETURN;
79072805 2560 }
79072805
LW		 2561}
2562
a0d0e21e 2563PP(pp_i_subtract)
79072805 2564{
39644a26 2565 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 2566 {
5e66d4f1 2567 dPOPTOPiirl_ul;
a0d0e21e
LW		 2568 SETi( left - right );
2569 RETURN;
79072805 2570 }
79072805
LW		 2571}
2572
a0d0e21e 2573PP(pp_i_lt)
79072805 2574{
39644a26 2575 dSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW		 2576 {
2577 dPOPTOPiirl;
54310121 2578 SETs(boolSV(left < right));
a0d0e21e
LW		 2579 RETURN;
2580 }
79072805
LW		 2581}
2582
a0d0e21e 2583PP(pp_i_gt)
79072805 2584{
39644a26 2585 dSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW		 2586 {
2587 dPOPTOPiirl;
54310121 2588 SETs(boolSV(left > right));
a0d0e21e
LW		 2589 RETURN;
2590 }
79072805
LW		 2591}
2592
a0d0e21e 2593PP(pp_i_le)
79072805 2594{
39644a26 2595 dSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW		 2596 {
2597 dPOPTOPiirl;
54310121 2598 SETs(boolSV(left <= right));
a0d0e21e 2599 RETURN;
85e6fe83 2600 }
79072805
LW		 2601}
2602
a0d0e21e 2603PP(pp_i_ge)
79072805 2604{
39644a26 2605 dSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW		 2606 {
2607 dPOPTOPiirl;
54310121 2608 SETs(boolSV(left >= right));
a0d0e21e
LW		 2609 RETURN;
2610 }
79072805
LW		 2611}
2612
a0d0e21e 2613PP(pp_i_eq)
79072805 2614{
39644a26 2615 dSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW		 2616 {
2617 dPOPTOPiirl;
54310121 2618 SETs(boolSV(left == right));
a0d0e21e
LW		 2619 RETURN;
2620 }
79072805
LW		 2621}
2622
a0d0e21e 2623PP(pp_i_ne)
79072805 2624{
39644a26 2625 dSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW		 2626 {
2627 dPOPTOPiirl;
54310121 2628 SETs(boolSV(left != right));
a0d0e21e
LW		 2629 RETURN;
2630 }
79072805
LW		 2631}
2632
a0d0e21e 2633PP(pp_i_ncmp)
79072805 2634{
39644a26 2635 dSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW		 2636 {
2637 dPOPTOPiirl;
2638 I32 value;
79072805 2639
a0d0e21e 2640 if (left > right)
79072805 2641 value = 1;
a0d0e21e 2642 else if (left < right)
79072805 2643 value = -1;
a0d0e21e 2644 else
79072805 2645 value = 0;
a0d0e21e
LW		 2646 SETi(value);
2647 RETURN;
79072805 2648 }
85e6fe83
LW		 2649}
2650
2651PP(pp_i_negate)
2652{
39644a26 2653 dSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW		 2654 SETi(-TOPi);
2655 RETURN;
2656}
2657
79072805
LW		 2658/* High falutin' math. */
2659
2660PP(pp_atan2)
2661{
39644a26 2662 dSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW		 2663 {
2664 dPOPTOPnnrl;
65202027 2665 SETn(Perl_atan2(left, right));
a0d0e21e
LW		 2666 RETURN;
2667 }
79072805
LW		 2668}
2669
2670PP(pp_sin)
2671{
39644a26 2672 dSP; dTARGET; tryAMAGICun(sin);
a0d0e21e 2673 {
65202027 2674 NV value;
a0d0e21e 2675 value = POPn;
65202027 2676 value = Perl_sin(value);
a0d0e21e
LW		 2677 XPUSHn(value);
2678 RETURN;
2679 }
79072805
LW		 2680}
2681
2682PP(pp_cos)
2683{
39644a26 2684 dSP; dTARGET; tryAMAGICun(cos);
a0d0e21e 2685 {
65202027 2686 NV value;
a0d0e21e 2687 value = POPn;
65202027 2688 value = Perl_cos(value);
a0d0e21e
LW		 2689 XPUSHn(value);
2690 RETURN;
2691 }
79072805
LW		 2692}
2693
56cb0a1c
AD		 2694/* Support Configure command-line overrides for rand() functions.
2695 After 5.005, perhaps we should replace this by Configure support
2696 for drand48(), random(), or rand(). For 5.005, though, maintain
2697 compatibility by calling rand() but allow the user to override it.
2698 See INSTALL for details. --Andy Dougherty 15 July 1998
2699*/
85ab1d1d
JH		 2700/* Now it's after 5.005, and Configure supports drand48() and random(),
2701 in addition to rand(). So the overrides should not be needed any more.
2702 --Jarkko Hietaniemi 27 September 1998
2703 */
2704
2705#ifndef HAS_DRAND48_PROTO
20ce7b12 2706extern double drand48 (void);
56cb0a1c
AD		 2707#endif
2708
79072805
LW		 2709PP(pp_rand)
2710{
39644a26 2711 dSP; dTARGET;
65202027 2712 NV value;
79072805
LW		 2713 if (MAXARG < 1)
2714 value = 1.0;
2715 else
2716 value = POPn;
2717 if (value == 0.0)
2718 value = 1.0;
80252599 2719 if (!PL_srand_called) {
85ab1d1d 2720 (void)seedDrand01((Rand_seed_t)seed());
80252599 2721 PL_srand_called = TRUE;
93dc8474 2722 }
85ab1d1d 2723 value *= Drand01();
79072805
LW		 2724 XPUSHn(value);
2725 RETURN;
2726}
2727
2728PP(pp_srand)
2729{
39644a26 2730 dSP;
93dc8474
CS		 2731 UV anum;
2732 if (MAXARG < 1)
2733 anum = seed();
79072805 2734 else
93dc8474 2735 anum = POPu;
85ab1d1d 2736 (void)seedDrand01((Rand_seed_t)anum);
80252599 2737 PL_srand_called = TRUE;
79072805
LW		 2738 EXTEND(SP, 1);
2739 RETPUSHYES;
2740}
2741
2742PP(pp_exp)
2743{
39644a26 2744 dSP; dTARGET; tryAMAGICun(exp);
a0d0e21e 2745 {
65202027 2746 NV value;
a0d0e21e 2747 value = POPn;
65202027 2748 value = Perl_exp(value);
a0d0e21e
LW		 2749 XPUSHn(value);
2750 RETURN;
2751 }
79072805
LW		 2752}
2753
2754PP(pp_log)
2755{
39644a26 2756 dSP; dTARGET; tryAMAGICun(log);
a0d0e21e 2757 {
65202027 2758 NV value;
a0d0e21e 2759 value = POPn;
bbce6d69 2760 if (value <= 0.0) {
f93f4e46 2761 SET_NUMERIC_STANDARD();
1779d84d 2762 DIE(aTHX_ "Can't take log of %"NVgf, value);
bbce6d69 2763 }
65202027 2764 value = Perl_log(value);
a0d0e21e
LW		 2765 XPUSHn(value);
2766 RETURN;
2767 }
79072805
LW		 2768}
2769
2770PP(pp_sqrt)
2771{
39644a26 2772 dSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e 2773 {
65202027 2774 NV value;
a0d0e21e 2775 value = POPn;
bbce6d69 2776 if (value < 0.0) {
f93f4e46 2777 SET_NUMERIC_STANDARD();
1779d84d 2778 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
bbce6d69 2779 }
65202027 2780 value = Perl_sqrt(value);
a0d0e21e
LW		 2781 XPUSHn(value);
2782 RETURN;
2783 }
79072805
LW		 2784}
2785
2786PP(pp_int)
2787{
39644a26 2788 dSP; dTARGET; tryAMAGICun(int);
774d564b 2789 {
28e5dec8
JH		 2790 NV value;
2791 IV iv = TOPi; /* attempt to convert to IV if possible. */
2792 /* XXX it's arguable that compiler casting to IV might be subtly
2793 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2794 else preferring IV has introduced a subtle behaviour change bug. OTOH
2795 relying on floating point to be accurate is a bug. */
2796
2797 if (SvIOK(TOPs)) {
2798 if (SvIsUV(TOPs)) {
2799 UV uv = TOPu;
2800 SETu(uv);
2801 } else
2802 SETi(iv);
2803 } else {
2804 value = TOPn;
1048ea30 2805 if (value >= 0.0) {
28e5dec8
JH		 2806 if (value < (NV)UV_MAX + 0.5) {
2807 SETu(U_V(value));
2808 } else {
059a1014 2809 SETn(Perl_floor(value));
28e5dec8 2810 }
1048ea30 2811 }
28e5dec8
JH		 2812 else {
2813 if (value > (NV)IV_MIN - 0.5) {
2814 SETi(I_V(value));
2815 } else {
1bbae031 2816 SETn(Perl_ceil(value));
28e5dec8
JH		 2817 }
2818 }
774d564b 2819 }
79072805 2820 }
79072805
LW		 2821 RETURN;
2822}
2823
463ee0b2
LW		 2824PP(pp_abs)
2825{
39644a26 2826 dSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 2827 {
28e5dec8
JH		 2828 /* This will cache the NV value if string isn't actually integer */
2829 IV iv = TOPi;
a227d84d 2830
28e5dec8
JH		 2831 if (SvIOK(TOPs)) {
2832 /* IVX is precise */
2833 if (SvIsUV(TOPs)) {
2834 SETu(TOPu); /* force it to be numeric only */
2835 } else {
2836 if (iv >= 0) {
2837 SETi(iv);
2838 } else {
2839 if (iv != IV_MIN) {
2840 SETi(-iv);
2841 } else {
2842 /* 2s complement assumption. Also, not really needed as
2843 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2844 SETu(IV_MIN);
2845 }
a227d84d 2846 }
28e5dec8
JH		 2847 }
2848 } else{
2849 NV value = TOPn;
774d564b 2850 if (value < 0.0)
28e5dec8 2851 value = -value;
774d564b 2852 SETn(value);
2853 }
a0d0e21e 2854 }
774d564b 2855 RETURN;
463ee0b2
LW		 2856}
2857
53305cf1 2858
79072805
LW		 2859PP(pp_hex)
2860{
39644a26 2861 dSP; dTARGET;
79072805 2862 char *tmps;
53305cf1 2863 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2864 STRLEN len;
53305cf1
NC		 2865 NV result_nv;
2866 UV result_uv;
2bc69dc4 2867 SV* sv = POPs;
79072805 2868
2bc69dc4
NIS		 2869 tmps = (SvPVx(sv, len));
2870 if (DO_UTF8(sv)) {
2871 /* If Unicode, try to downgrade
2872 * If not possible, croak. */
2873 SV* tsv = sv_2mortal(newSVsv(sv));
2874
2875 SvUTF8_on(tsv);
2876 sv_utf8_downgrade(tsv, FALSE);
2877 tmps = SvPVX(tsv);
2878 }
53305cf1
NC		 2879 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2880 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2881 XPUSHn(result_nv);
2882 }
2883 else {
2884 XPUSHu(result_uv);
2885 }
79072805
LW		 2886 RETURN;
2887}
2888
2889PP(pp_oct)
2890{
39644a26 2891 dSP; dTARGET;
79072805 2892 char *tmps;
53305cf1 2893 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2894 STRLEN len;
53305cf1
NC		 2895 NV result_nv;
2896 UV result_uv;
2bc69dc4 2897 SV* sv = POPs;
79072805 2898
2bc69dc4
NIS		 2899 tmps = (SvPVx(sv, len));
2900 if (DO_UTF8(sv)) {
2901 /* If Unicode, try to downgrade
2902 * If not possible, croak. */
2903 SV* tsv = sv_2mortal(newSVsv(sv));
2904
2905 SvUTF8_on(tsv);
2906 sv_utf8_downgrade(tsv, FALSE);
2907 tmps = SvPVX(tsv);
2908 }
6f894ead 2909 while (*tmps && len && isSPACE(*tmps))
53305cf1 2910 tmps++, len--;
9e24b6e2 2911 if (*tmps == '0')
53305cf1 2912 tmps++, len--;
9e24b6e2 2913 if (*tmps == 'x')
53305cf1 2914 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
9e24b6e2 2915 else if (*tmps == 'b')
53305cf1 2916 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2917 else
53305cf1
NC		 2918 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2919
2920 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2921 XPUSHn(result_nv);
2922 }
2923 else {
2924 XPUSHu(result_uv);
2925 }
79072805
LW		 2926 RETURN;
2927}
2928
2929/* String stuff. */
2930
2931PP(pp_length)
2932{
39644a26 2933 dSP; dTARGET;
7e2040f0 2934 SV *sv = TOPs;
a0ed51b3 2935
7e2040f0
GS		 2936 if (DO_UTF8(sv))
2937 SETi(sv_len_utf8(sv));
2938 else
2939 SETi(sv_len(sv));
79072805
LW		 2940 RETURN;
2941}
2942
2943PP(pp_substr)
2944{
39644a26 2945 dSP; dTARGET;
79072805 2946 SV *sv;
9c5ffd7c 2947 I32 len = 0;
463ee0b2 2948 STRLEN curlen;
9402d6ed 2949 STRLEN utf8_curlen;
79072805
LW		 2950 I32 pos;
2951 I32 rem;
84902520 2952 I32 fail;
78f9721b 2953 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
79072805 2954 char *tmps;
3280af22 2955 I32 arybase = PL_curcop->cop_arybase;
9402d6ed 2956 SV *repl_sv = NULL;
7b8d334a
GS		 2957 char *repl = 0;
2958 STRLEN repl_len;
78f9721b 2959 int num_args = PL_op->op_private & 7;
13e30c65 2960 bool repl_need_utf8_upgrade = FALSE;
9402d6ed 2961 bool repl_is_utf8 = FALSE;
79072805 2962
20408e3c 2963 SvTAINTED_off(TARG); /* decontaminate */
7e2040f0 2964 SvUTF8_off(TARG); /* decontaminate */
78f9721b
SM		 2965 if (num_args > 2) {
2966 if (num_args > 3) {
9402d6ed
JH		 2967 repl_sv = POPs;
2968 repl = SvPV(repl_sv, repl_len);
2969 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
7b8d334a 2970 }
79072805 2971 len = POPi;
5d82c453 2972 }
84902520 2973 pos = POPi;
79072805 2974 sv = POPs;
849ca7ee 2975 PUTBACK;
9402d6ed
JH		 2976 if (repl_sv) {
2977 if (repl_is_utf8) {
2978 if (!DO_UTF8(sv))
2979 sv_utf8_upgrade(sv);
2980 }
13e30c65
JH		 2981 else if (DO_UTF8(sv))
2982 repl_need_utf8_upgrade = TRUE;
9402d6ed 2983 }
a0d0e21e 2984 tmps = SvPV(sv, curlen);
7e2040f0 2985 if (DO_UTF8(sv)) {
9402d6ed
JH		 2986 utf8_curlen = sv_len_utf8(sv);
2987 if (utf8_curlen == curlen)
2988 utf8_curlen = 0;
a0ed51b3 2989 else
9402d6ed 2990 curlen = utf8_curlen;
a0ed51b3 2991 }
d1c2b58a 2992 else
9402d6ed 2993 utf8_curlen = 0;
a0ed51b3 2994
84902520
TB		 2995 if (pos >= arybase) {
2996 pos -= arybase;
2997 rem = curlen-pos;
2998 fail = rem;
78f9721b 2999 if (num_args > 2) {
5d82c453
GA		 3000 if (len < 0) {
3001 rem += len;
3002 if (rem < 0)
3003 rem = 0;
3004 }
3005 else if (rem > len)
3006 rem = len;
3007 }
68dc0745 3008 }
84902520 3009 else {
5d82c453 3010 pos += curlen;
78f9721b 3011 if (num_args < 3)
5d82c453
GA		 3012 rem = curlen;
3013 else if (len >= 0) {
3014 rem = pos+len;
3015 if (rem > (I32)curlen)
3016 rem = curlen;
3017 }
3018 else {
3019 rem = curlen+len;
3020 if (rem < pos)
3021 rem = pos;
3022 }
3023 if (pos < 0)
3024 pos = 0;
3025 fail = rem;
3026 rem -= pos;
84902520
TB		 3027 }
3028 if (fail < 0) {
e476b1b5
GS		 3029 if (lvalue || repl)
3030 Perl_croak(aTHX_ "substr outside of string");
3031 if (ckWARN(WARN_SUBSTR))
9014280d 3032 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2304df62
AD		 3033 RETPUSHUNDEF;
3034 }
79072805 3035 else {
9aa983d2
JH		 3036 I32 upos = pos;
3037 I32 urem = rem;
9402d6ed 3038 if (utf8_curlen)
a0ed51b3 3039 sv_pos_u2b(sv, &pos, &rem);
79072805 3040 tmps += pos;
781e7547
DM		 3041 /* we either return a PV or an LV. If the TARG hasn't been used
3042 * before, or is of that type, reuse it; otherwise use a mortal
3043 * instead. Note that LVs can have an extended lifetime, so also
3044 * dont reuse if refcount > 1 (bug #20933) */
3045 if (SvTYPE(TARG) > SVt_NULL) {
3046 if ( (SvTYPE(TARG) == SVt_PVLV)
3047 ? (!lvalue || SvREFCNT(TARG) > 1)
3048 : lvalue)
3049 {
3050 TARG = sv_newmortal();
3051 }
3052 }
3053
79072805 3054 sv_setpvn(TARG, tmps, rem);
12aa1545 3055#ifdef USE_LOCALE_COLLATE
14befaf4 3056 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3057#endif
9402d6ed 3058 if (utf8_curlen)
7f66633b 3059 SvUTF8_on(TARG);
f7928d6c 3060 if (repl) {
13e30c65
JH		 3061 SV* repl_sv_copy = NULL;
3062
3063 if (repl_need_utf8_upgrade) {
3064 repl_sv_copy = newSVsv(repl_sv);
3065 sv_utf8_upgrade(repl_sv_copy);
3066 repl = SvPV(repl_sv_copy, repl_len);
3067 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3068 }
c8faf1c5 3069 sv_insert(sv, pos, rem, repl, repl_len);
9402d6ed 3070 if (repl_is_utf8)
f7928d6c 3071 SvUTF8_on(sv);
9402d6ed
JH		 3072 if (repl_sv_copy)
3073 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3074 }
c8faf1c5 3075 else if (lvalue) { /* it's an lvalue! */
dedeecda 3076 if (!SvGMAGICAL(sv)) {
3077 if (SvROK(sv)) {
2d8e6c8d
GS		 3078 STRLEN n_a;
3079 SvPV_force(sv,n_a);
599cee73 3080 if (ckWARN(WARN_SUBSTR))
9014280d 3081 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
599cee73 3082 "Attempt to use reference as lvalue in substr");
dedeecda 3083 }
3084 if (SvOK(sv)) /* is it defined ? */
7f66633b 3085 (void)SvPOK_only_UTF8(sv);
dedeecda 3086 else
3087 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3088 }
5f05dabc 3089
a0d0e21e
LW		 3090 if (SvTYPE(TARG) < SVt_PVLV) {
3091 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3092 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
ed6116ce 3093 }
6214ab63
AE		 3094 else
3095 (void)SvOK_off(TARG);
a0d0e21e 3096
5f05dabc 3097 LvTYPE(TARG) = 'x';
6ff81951
GS		 3098 if (LvTARG(TARG) != sv) {
3099 if (LvTARG(TARG))
3100 SvREFCNT_dec(LvTARG(TARG));
3101 LvTARG(TARG) = SvREFCNT_inc(sv);
3102 }
9aa983d2
JH		 3103 LvTARGOFF(TARG) = upos;
3104 LvTARGLEN(TARG) = urem;
79072805
LW		 3105 }
3106 }
849ca7ee 3107 SPAGAIN;
79072805
LW		 3108 PUSHs(TARG); /* avoid SvSETMAGIC here */
3109 RETURN;
3110}
3111
3112PP(pp_vec)
3113{
39644a26 3114 dSP; dTARGET;
467f0320
JH		 3115 register IV size = POPi;
3116 register IV offset = POPi;
79072805 3117 register SV *src = POPs;
78f9721b 3118 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e 3119
81e118e0
JH		 3120 SvTAINTED_off(TARG); /* decontaminate */
3121 if (lvalue) { /* it's an lvalue! */
24aef97f
HS		 3122 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3123 TARG = sv_newmortal();
81e118e0
JH		 3124 if (SvTYPE(TARG) < SVt_PVLV) {
3125 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3126 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
79072805 3127 }
81e118e0
JH		 3128 LvTYPE(TARG) = 'v';
3129 if (LvTARG(TARG) != src) {
3130 if (LvTARG(TARG))
3131 SvREFCNT_dec(LvTARG(TARG));
3132 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 3133 }
81e118e0
JH		 3134 LvTARGOFF(TARG) = offset;
3135 LvTARGLEN(TARG) = size;
79072805
LW		 3136 }
3137
81e118e0 3138 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW		 3139 PUSHs(TARG);
3140 RETURN;
3141}
3142
3143PP(pp_index)
3144{
39644a26 3145 dSP; dTARGET;
79072805
LW		 3146 SV *big;
3147 SV *little;
3148 I32 offset;
3149 I32 retval;
3150 char *tmps;
3151 char *tmps2;
463ee0b2 3152 STRLEN biglen;
3280af22 3153 I32 arybase = PL_curcop->cop_arybase;
79072805
LW		 3154
3155 if (MAXARG < 3)
3156 offset = 0;
3157 else
3158 offset = POPi - arybase;
3159 little = POPs;
3160 big = POPs;
463ee0b2 3161 tmps = SvPV(big, biglen);
7e2040f0 3162 if (offset > 0 && DO_UTF8(big))
a0ed51b3 3163 sv_pos_u2b(big, &offset, 0);
79072805
LW		 3164 if (offset < 0)
3165 offset = 0;
eb160463 3166 else if (offset > (I32)biglen)
93a17b20 3167 offset = biglen;
79072805 3168 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 3169 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 3170 retval = -1;
79072805 3171 else
a0ed51b3 3172 retval = tmps2 - tmps;
7e2040f0 3173 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3174 sv_pos_b2u(big, &retval);
3175 PUSHi(retval + arybase);
79072805
LW		 3176 RETURN;
3177}
3178
3179PP(pp_rindex)
3180{
39644a26 3181 dSP; dTARGET;
79072805
LW		 3182 SV *big;
3183 SV *little;
463ee0b2
LW		 3184 STRLEN blen;
3185 STRLEN llen;
79072805
LW		 3186 I32 offset;
3187 I32 retval;
3188 char *tmps;
3189 char *tmps2;
3280af22 3190 I32 arybase = PL_curcop->cop_arybase;
79072805 3191
a0d0e21e 3192 if (MAXARG >= 3)
a0ed51b3 3193 offset = POPi;
79072805
LW		 3194 little = POPs;
3195 big = POPs;
463ee0b2
LW		 3196 tmps2 = SvPV(little, llen);
3197 tmps = SvPV(big, blen);
79072805 3198 if (MAXARG < 3)
463ee0b2 3199 offset = blen;
a0ed51b3 3200 else {
7e2040f0 3201 if (offset > 0 && DO_UTF8(big))
a0ed51b3
LW		 3202 sv_pos_u2b(big, &offset, 0);
3203 offset = offset - arybase + llen;
3204 }
79072805
LW		 3205 if (offset < 0)
3206 offset = 0;
eb160463 3207 else if (offset > (I32)blen)
463ee0b2 3208 offset = blen;
79072805 3209 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 3210 tmps2, tmps2 + llen)))
a0ed51b3 3211 retval = -1;
79072805 3212 else
a0ed51b3 3213 retval = tmps2 - tmps;
7e2040f0 3214 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3215 sv_pos_b2u(big, &retval);
3216 PUSHi(retval + arybase);
79072805
LW		 3217 RETURN;
3218}
3219
3220PP(pp_sprintf)
3221{
39644a26 3222 dSP; dMARK; dORIGMARK; dTARGET;
79072805 3223 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3224 TAINT_IF(SvTAINTED(TARG));
6ee35fb7
JH		 3225 if (DO_UTF8(*(MARK+1)))
3226 SvUTF8_on(TARG);
79072805
LW		 3227 SP = ORIGMARK;
3228 PUSHTARG;
3229 RETURN;
3230}
3231
79072805
LW		 3232PP(pp_ord)
3233{
39644a26 3234 dSP; dTARGET;
7df053ec 3235 SV *argsv = POPs;
ba210ebe 3236 STRLEN len;
7df053ec 3237 U8 *s = (U8*)SvPVx(argsv, len);
121910a4
JH		 3238 SV *tmpsv;
3239
799ef3cb 3240 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
121910a4 3241 tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3242 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH		 3243 argsv = tmpsv;
3244 }
79072805 3245
872c91ae
JH		 3246 XPUSHu(DO_UTF8(argsv) ?
3247 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3248 (*s & 0xff));
68795e93 3249
79072805
LW		 3250 RETURN;
3251}
3252
463ee0b2
LW		 3253PP(pp_chr)
3254{
39644a26 3255 dSP; dTARGET;
463ee0b2 3256 char *tmps;
467f0320 3257 UV value = POPu;
463ee0b2 3258
748a9306 3259 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3260
0064a8a9 3261 if (value > 255 && !IN_BYTES) {
eb160463 3262 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3263 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
a0ed51b3
LW		 3264 SvCUR_set(TARG, tmps - SvPVX(TARG));
3265 *tmps = '\0';
3266 (void)SvPOK_only(TARG);
aa6ffa16 3267 SvUTF8_on(TARG);
a0ed51b3
LW		 3268 XPUSHs(TARG);
3269 RETURN;
3270 }
3271
748a9306 3272 SvGROW(TARG,2);
463ee0b2
LW		 3273 SvCUR_set(TARG, 1);
3274 tmps = SvPVX(TARG);
eb160463 3275 *tmps++ = (char)value;
748a9306 3276 *tmps = '\0';
a0d0e21e 3277 (void)SvPOK_only(TARG);
88632417 3278 if (PL_encoding && !IN_BYTES) {
799ef3cb 3279 sv_recode_to_utf8(TARG, PL_encoding);
88632417
JH		 3280 tmps = SvPVX(TARG);
3281 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3282 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
d5a15ac2
JH		 3283 SvGROW(TARG, 3);
3284 tmps = SvPVX(TARG);
88632417
JH		 3285 SvCUR_set(TARG, 2);
3286 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3287 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3288 *tmps = '\0';
3289 SvUTF8_on(TARG);
3290 }
3291 }
463ee0b2
LW		 3292 XPUSHs(TARG);
3293 RETURN;
3294}
3295
79072805
LW		 3296PP(pp_crypt)
3297{
5f74f29c 3298 dSP; dTARGET;
79072805 3299#ifdef HAS_CRYPT
5f74f29c
JH		 3300 dPOPTOPssrl;
3301 STRLEN n_a;
85c16d83
JH		 3302 STRLEN len;
3303 char *tmps = SvPV(left, len);
2bc69dc4 3304
85c16d83 3305 if (DO_UTF8(left)) {
2bc69dc4 3306 /* If Unicode, try to downgrade.
f2791508
JH		 3307 * If not possible, croak.
3308 * Yes, we made this up. */
3309 SV* tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3310
f2791508 3311 SvUTF8_on(tsv);
2bc69dc4 3312 sv_utf8_downgrade(tsv, FALSE);
f2791508 3313 tmps = SvPVX(tsv);
85c16d83 3314 }
05404ffe
JH		 3315# ifdef USE_ITHREADS
3316# ifdef HAS_CRYPT_R
3317 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3318 /* This should be threadsafe because in ithreads there is only
3319 * one thread per interpreter. If this would not be true,
3320 * we would need a mutex to protect this malloc. */
3321 PL_reentrant_buffer->_crypt_struct_buffer =
3322 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3323#if defined(__GLIBC__) || defined(__EMX__)
3324 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3325 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3326 /* work around glibc-2.2.5 bug */
3327 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3328 }
05404ffe 3329#endif
6ab58e4d 3330 }
05404ffe
JH		 3331# endif /* HAS_CRYPT_R */
3332# endif /* USE_ITHREADS */
5f74f29c 3333# ifdef FCRYPT
2d8e6c8d 3334 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
5f74f29c 3335# else
2d8e6c8d 3336 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
5f74f29c 3337# endif
4808266b
JH		 3338 SETs(TARG);
3339 RETURN;
79072805 3340#else
b13b2135 3341 DIE(aTHX_
79072805
LW		 3342 "The crypt() function is unimplemented due to excessive paranoia.");
3343#endif
79072805
LW		 3344}
3345
3346PP(pp_ucfirst)
3347{
39644a26 3348 dSP;
79072805 3349 SV *sv = TOPs;
a0ed51b3
LW		 3350 register U8 *s;
3351 STRLEN slen;
3352
d104a74c 3353 SvGETMAGIC(sv);
3a2263fe
RGS		 3354 if (DO_UTF8(sv) &&
3355 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3356 UTF8_IS_START(*s)) {
e7ae6809 3357 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
44bc797b
JH		 3358 STRLEN ulen;
3359 STRLEN tculen;
a0ed51b3 3360
44bc797b 3361 utf8_to_uvchr(s, &ulen);
44bc797b
JH		 3362 toTITLE_utf8(s, tmpbuf, &tculen);
3363 utf8_to_uvchr(tmpbuf, 0);
3364
3365 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
a0ed51b3 3366 dTARGET;
3a2263fe
RGS		 3367 /* slen is the byte length of the whole SV.
3368 * ulen is the byte length of the original Unicode character
3369 * stored as UTF-8 at s.
3370 * tculen is the byte length of the freshly titlecased
3371 * Unicode character stored as UTF-8 at tmpbuf.
3372 * We first set the result to be the titlecased character,
3373 * and then append the rest of the SV data. */
44bc797b 3374 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3a2263fe
RGS		 3375 if (slen > ulen)
3376 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3377 SvUTF8_on(TARG);
a0ed51b3
LW		 3378 SETs(TARG);
3379 }
3380 else {
d104a74c 3381 s = (U8*)SvPV_force_nomg(sv, slen);
44bc797b 3382 Copy(tmpbuf, s, tculen, U8);
a0ed51b3 3383 }
a0ed51b3 3384 }
626727d5 3385 else {
014822e4 3386 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3387 dTARGET;
7e2040f0 3388 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3389 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3390 sv = TARG;
3391 SETs(sv);
3392 }
d104a74c 3393 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3394 if (*s) {
2de3dbcc 3395 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3396 TAINT;
3397 SvTAINTED_on(sv);
3398 *s = toUPPER_LC(*s);
3399 }
3400 else
3401 *s = toUPPER(*s);
bbce6d69 3402 }
bbce6d69 3403 }
d104a74c 3404 SvSETMAGIC(sv);
79072805
LW		 3405 RETURN;
3406}
3407
3408PP(pp_lcfirst)
3409{
39644a26 3410 dSP;
79072805 3411 SV *sv = TOPs;
a0ed51b3
LW		 3412 register U8 *s;
3413 STRLEN slen;
3414
d104a74c 3415 SvGETMAGIC(sv);
3a2263fe
RGS		 3416 if (DO_UTF8(sv) &&
3417 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3418 UTF8_IS_START(*s)) {
ba210ebe 3419 STRLEN ulen;
e7ae6809 3420 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3421 U8 *tend;
9041c2e3 3422 UV uv;
a0ed51b3 3423
44bc797b 3424 toLOWER_utf8(s, tmpbuf, &ulen);
a2a2844f 3425 uv = utf8_to_uvchr(tmpbuf, 0);
9041c2e3 3426 tend = uvchr_to_utf8(tmpbuf, uv);
a0ed51b3 3427
eb160463 3428 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
a0ed51b3 3429 dTARGET;
dfe13c55 3430 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3a2263fe
RGS		 3431 if (slen > ulen)
3432 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3433 SvUTF8_on(TARG);
a0ed51b3
LW		 3434 SETs(TARG);
3435 }
3436 else {
d104a74c 3437 s = (U8*)SvPV_force_nomg(sv, slen);
a0ed51b3
LW		 3438 Copy(tmpbuf, s, ulen, U8);
3439 }
a0ed51b3 3440 }
626727d5 3441 else {
014822e4 3442 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3443 dTARGET;
7e2040f0 3444 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3445 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3446 sv = TARG;
3447 SETs(sv);
3448 }
d104a74c 3449 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3450 if (*s) {
2de3dbcc 3451 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3452 TAINT;
3453 SvTAINTED_on(sv);
3454 *s = toLOWER_LC(*s);
3455 }
3456 else
3457 *s = toLOWER(*s);
bbce6d69 3458 }
bbce6d69 3459 }
d104a74c 3460 SvSETMAGIC(sv);
79072805
LW		 3461 RETURN;
3462}
3463
3464PP(pp_uc)
3465{
39644a26 3466 dSP;
79072805 3467 SV *sv = TOPs;
a0ed51b3 3468 register U8 *s;
463ee0b2 3469 STRLEN len;
79072805 3470
d104a74c 3471 SvGETMAGIC(sv);
7e2040f0 3472 if (DO_UTF8(sv)) {
a0ed51b3 3473 dTARGET;
ba210ebe 3474 STRLEN ulen;
a0ed51b3
LW		 3475 register U8 *d;
3476 U8 *send;
e7ae6809 3477 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3478
d104a74c 3479 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3480 if (!len) {
7e2040f0 3481 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3482 sv_setpvn(TARG, "", 0);
3483 SETs(TARG);
a0ed51b3
LW		 3484 }
3485 else {
98b27f73
JH		 3486 STRLEN nchar = utf8_length(s, s + len);
3487
31351b04 3488 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3489 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3490 (void)SvPOK_only(TARG);
3491 d = (U8*)SvPVX(TARG);
3492 send = s + len;
a2a2844f 3493 while (s < send) {
6fdb5f96 3494 toUPPER_utf8(s, tmpbuf, &ulen);
a2a2844f
JH		 3495 Copy(tmpbuf, d, ulen, U8);
3496 d += ulen;
3497 s += UTF8SKIP(s);
a0ed51b3 3498 }
31351b04 3499 *d = '\0';
7e2040f0 3500 SvUTF8_on(TARG);
31351b04
JS		 3501 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3502 SETs(TARG);
a0ed51b3 3503 }
a0ed51b3 3504 }
626727d5 3505 else {
014822e4 3506 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3507 dTARGET;
7e2040f0 3508 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3509 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3510 sv = TARG;
3511 SETs(sv);
3512 }
d104a74c 3513 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3514 if (len) {
3515 register U8 *send = s + len;
3516
2de3dbcc 3517 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3518 TAINT;
3519 SvTAINTED_on(sv);
3520 for (; s < send; s++)
3521 *s = toUPPER_LC(*s);
3522 }
3523 else {
3524 for (; s < send; s++)
3525 *s = toUPPER(*s);
3526 }
bbce6d69 3527 }
79072805 3528 }
d104a74c 3529 SvSETMAGIC(sv);
79072805
LW		 3530 RETURN;
3531}
3532
3533PP(pp_lc)
3534{
39644a26 3535 dSP;
79072805 3536 SV *sv = TOPs;
a0ed51b3 3537 register U8 *s;
463ee0b2 3538 STRLEN len;
79072805 3539
d104a74c 3540 SvGETMAGIC(sv);
7e2040f0 3541 if (DO_UTF8(sv)) {
a0ed51b3 3542 dTARGET;
ba210ebe 3543 STRLEN ulen;
a0ed51b3
LW		 3544 register U8 *d;
3545 U8 *send;
e7ae6809 3546 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3547
d104a74c 3548 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3549 if (!len) {
7e2040f0 3550 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3551 sv_setpvn(TARG, "", 0);
3552 SETs(TARG);
a0ed51b3
LW		 3553 }
3554 else {
98b27f73
JH		 3555 STRLEN nchar = utf8_length(s, s + len);
3556
31351b04 3557 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3558 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3559 (void)SvPOK_only(TARG);
3560 d = (U8*)SvPVX(TARG);
3561 send = s + len;
a2a2844f 3562 while (s < send) {
6fdb5f96
JH		 3563 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3564#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3565 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3566 /*
3567 * Now if the sigma is NOT followed by
3568 * /$ignorable_sequence$cased_letter/;
3569 * and it IS preceded by
3570 * /$cased_letter$ignorable_sequence/;
3571 * where $ignorable_sequence is
3572 * [\x{2010}\x{AD}\p{Mn}]*
3573 * and $cased_letter is
3574 * [\p{Ll}\p{Lo}\p{Lt}]
3575 * then it should be mapped to 0x03C2,
3576 * (GREEK SMALL LETTER FINAL SIGMA),
3577 * instead of staying 0x03A3.
3578 * See lib/unicore/SpecCase.txt.
3579 */
3580 }
a2a2844f
JH		 3581 Copy(tmpbuf, d, ulen, U8);
3582 d += ulen;
3583 s += UTF8SKIP(s);
a0ed51b3 3584 }
31351b04 3585 *d = '\0';
7e2040f0 3586 SvUTF8_on(TARG);
31351b04
JS		 3587 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3588 SETs(TARG);
a0ed51b3 3589 }
79072805 3590 }
626727d5 3591 else {
014822e4 3592 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3593 dTARGET;
7e2040f0 3594 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3595 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3596 sv = TARG;
3597 SETs(sv);
a0ed51b3 3598 }
bbce6d69 3599
d104a74c 3600 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3601 if (len) {
3602 register U8 *send = s + len;
bbce6d69 3603
2de3dbcc 3604 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3605 TAINT;
3606 SvTAINTED_on(sv);
3607 for (; s < send; s++)
3608 *s = toLOWER_LC(*s);
3609 }
3610 else {
3611 for (; s < send; s++)
3612 *s = toLOWER(*s);
3613 }
bbce6d69 3614 }
79072805 3615 }
d104a74c 3616 SvSETMAGIC(sv);
79072805
LW		 3617 RETURN;
3618}
3619
a0d0e21e 3620PP(pp_quotemeta)
79072805 3621{
39644a26 3622 dSP; dTARGET;
a0d0e21e
LW		 3623 SV *sv = TOPs;
3624 STRLEN len;
3625 register char *s = SvPV(sv,len);
3626 register char *d;
79072805 3627
7e2040f0 3628 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW		 3629 if (len) {
3630 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 3631 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3632 d = SvPVX(TARG);
7e2040f0 3633 if (DO_UTF8(sv)) {
0dd2cdef 3634 while (len) {
fd400ab9 3635 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 3636 STRLEN ulen = UTF8SKIP(s);
3637 if (ulen > len)
3638 ulen = len;
3639 len -= ulen;
3640 while (ulen--)
3641 *d++ = *s++;
3642 }
3643 else {
3644 if (!isALNUM(*s))
3645 *d++ = '\\';
3646 *d++ = *s++;
3647 len--;
3648 }
3649 }
7e2040f0 3650 SvUTF8_on(TARG);
0dd2cdef
LW		 3651 }
3652 else {
3653 while (len--) {
3654 if (!isALNUM(*s))
3655 *d++ = '\\';
3656 *d++ = *s++;
3657 }
79072805 3658 }
a0d0e21e
LW		 3659 *d = '\0';
3660 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 3661 (void)SvPOK_only_UTF8(TARG);
79072805 3662 }
a0d0e21e
LW		 3663 else
3664 sv_setpvn(TARG, s, len);
3665 SETs(TARG);
31351b04
JS		 3666 if (SvSMAGICAL(TARG))
3667 mg_set(TARG);
79072805
LW		 3668 RETURN;
3669}
3670
a0d0e21e 3671/* Arrays. */
79072805 3672
a0d0e21e 3673PP(pp_aslice)
79072805 3674{
39644a26 3675 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3676 register SV** svp;
3677 register AV* av = (AV*)POPs;
78f9721b 3678 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3280af22 3679 I32 arybase = PL_curcop->cop_arybase;
748a9306 3680 I32 elem;
79072805 3681
a0d0e21e 3682 if (SvTYPE(av) == SVt_PVAV) {
533c011a 3683 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 3684 I32 max = -1;
924508f0 3685 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 3686 elem = SvIVx(*svp);
3687 if (elem > max)
3688 max = elem;
3689 }
3690 if (max > AvMAX(av))
3691 av_extend(av, max);
3692 }
a0d0e21e 3693 while (++MARK <= SP) {
748a9306 3694 elem = SvIVx(*MARK);
a0d0e21e 3695
748a9306
LW		 3696 if (elem > 0)
3697 elem -= arybase;
a0d0e21e
LW		 3698 svp = av_fetch(av, elem, lval);
3699 if (lval) {
3280af22 3700 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 3701 DIE(aTHX_ PL_no_aelem, elem);
533c011a 3702 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 3703 save_aelem(av, elem, svp);
79072805 3704 }
3280af22 3705 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 3706 }
3707 }
748a9306 3708 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 3709 MARK = ORIGMARK;
3710 *++MARK = *SP;
3711 SP = MARK;
3712 }
79072805
LW		 3713 RETURN;
3714}
3715
3716/* Associative arrays. */
3717
3718PP(pp_each)
3719{
39644a26 3720 dSP;
79072805 3721 HV *hash = (HV*)POPs;
c07a80fd 3722 HE *entry;
54310121 3723 I32 gimme = GIMME_V;
8ec5e241 3724
c07a80fd 3725 PUTBACK;
c750a3ec 3726 /* might clobber stack_sp */
6d822dc4 3727 entry = hv_iternext(hash);
c07a80fd 3728 SPAGAIN;
79072805 3729
79072805
LW		 3730 EXTEND(SP, 2);
3731 if (entry) {
574c8022 3732 SV* sv = hv_iterkeysv(entry);
574c8022 3733 PUSHs(sv); /* won't clobber stack_sp */
54310121 3734 if (gimme == G_ARRAY) {
59af0135 3735 SV *val;
c07a80fd 3736 PUTBACK;
c750a3ec 3737 /* might clobber stack_sp */
6d822dc4 3738 val = hv_iterval(hash, entry);
c07a80fd 3739 SPAGAIN;
59af0135 3740 PUSHs(val);
79072805 3741 }
79072805 3742 }
54310121 3743 else if (gimme == G_SCALAR)
79072805
LW		 3744 RETPUSHUNDEF;
3745
3746 RETURN;
3747}
3748
3749PP(pp_values)
3750{
cea2e8a9 3751 return do_kv();
79072805
LW		 3752}
3753
3754PP(pp_keys)
3755{
cea2e8a9 3756 return do_kv();
79072805
LW		 3757}
3758
3759PP(pp_delete)
3760{
39644a26 3761 dSP;
54310121 3762 I32 gimme = GIMME_V;
3763 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 3764 SV *sv;
5f05dabc 3765 HV *hv;
3766
533c011a 3767 if (PL_op->op_private & OPpSLICE) {
5f05dabc 3768 dMARK; dORIGMARK;
97fcbf96 3769 U32 hvtype;
5f05dabc 3770 hv = (HV*)POPs;
97fcbf96 3771 hvtype = SvTYPE(hv);
01020589
GS		 3772 if (hvtype == SVt_PVHV) { /* hash element */
3773 while (++MARK <= SP) {
ae77835f 3774 sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 3775 *MARK = sv ? sv : &PL_sv_undef;
3776 }
5f05dabc 3777 }
6d822dc4
MS		 3778 else if (hvtype == SVt_PVAV) { /* array element */
3779 if (PL_op->op_flags & OPf_SPECIAL) {
3780 while (++MARK <= SP) {
3781 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3782 *MARK = sv ? sv : &PL_sv_undef;
3783 }
3784 }
01020589
GS		 3785 }
3786 else
3787 DIE(aTHX_ "Not a HASH reference");
54310121 3788 if (discard)
3789 SP = ORIGMARK;
3790 else if (gimme == G_SCALAR) {
5f05dabc 3791 MARK = ORIGMARK;
3792 *++MARK = *SP;
3793 SP = MARK;
3794 }
3795 }
3796 else {
3797 SV *keysv = POPs;
3798 hv = (HV*)POPs;
97fcbf96
MB		 3799 if (SvTYPE(hv) == SVt_PVHV)
3800 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 3801 else if (SvTYPE(hv) == SVt_PVAV) {
3802 if (PL_op->op_flags & OPf_SPECIAL)
3803 sv = av_delete((AV*)hv, SvIV(keysv), discard);
af288a60
HS		 3804 else
3805 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 3806 }
97fcbf96 3807 else
cea2e8a9 3808 DIE(aTHX_ "Not a HASH reference");
5f05dabc 3809 if (!sv)
3280af22 3810 sv = &PL_sv_undef;
54310121 3811 if (!discard)
3812 PUSHs(sv);
79072805 3813 }
79072805
LW		 3814 RETURN;
3815}
3816
a0d0e21e 3817PP(pp_exists)
79072805 3818{
39644a26 3819 dSP;
afebc493
GS		 3820 SV *tmpsv;
3821 HV *hv;
3822
3823 if (PL_op->op_private & OPpEXISTS_SUB) {
3824 GV *gv;
3825 CV *cv;
3826 SV *sv = POPs;
3827 cv = sv_2cv(sv, &hv, &gv, FALSE);
3828 if (cv)
3829 RETPUSHYES;
3830 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3831 RETPUSHYES;
3832 RETPUSHNO;
3833 }
3834 tmpsv = POPs;
3835 hv = (HV*)POPs;
c750a3ec 3836 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 3837 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 3838 RETPUSHYES;
ef54e1a4
JH		 3839 }
3840 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS		 3841 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3842 if (av_exists((AV*)hv, SvIV(tmpsv)))
3843 RETPUSHYES;
3844 }
ef54e1a4
JH		 3845 }
3846 else {
cea2e8a9 3847 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 3848 }
a0d0e21e
LW		 3849 RETPUSHNO;
3850}
79072805 3851
a0d0e21e
LW		 3852PP(pp_hslice)
3853{
39644a26 3854 dSP; dMARK; dORIGMARK;
a0d0e21e 3855 register HV *hv = (HV*)POPs;
78f9721b 3856 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
eb85dfd3
DM		 3857 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3858 bool other_magic = FALSE;
79072805 3859
eb85dfd3
DM		 3860 if (localizing) {
3861 MAGIC *mg;
3862 HV *stash;
3863
3864 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3865 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3866 /* Try to preserve the existenceness of a tied hash
3867 * element by using EXISTS and DELETE if possible.
3868 * Fallback to FETCH and STORE otherwise */
3869 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3870 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3871 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3872 }
3873
6d822dc4
MS		 3874 while (++MARK <= SP) {
3875 SV *keysv = *MARK;
3876 SV **svp;
3877 HE *he;
3878 bool preeminent = FALSE;
0ebe0038 3879
6d822dc4
MS		 3880 if (localizing) {
3881 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3882 hv_exists_ent(hv, keysv, 0);
3883 }
eb85dfd3 3884
6d822dc4
MS		 3885 he = hv_fetch_ent(hv, keysv, lval, 0);
3886 svp = he ? &HeVAL(he) : 0;
eb85dfd3 3887
6d822dc4
MS		 3888 if (lval) {
3889 if (!svp || *svp == &PL_sv_undef) {
3890 STRLEN n_a;
3891 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3892 }
3893 if (localizing) {
3894 if (preeminent)
3895 save_helem(hv, keysv, svp);
3896 else {
3897 STRLEN keylen;
3898 char *key = SvPV(keysv, keylen);
3899 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1f5346dc 3900 }
6d822dc4
MS		 3901 }
3902 }
3903 *MARK = svp ? *svp : &PL_sv_undef;
79072805 3904 }
a0d0e21e
LW		 3905 if (GIMME != G_ARRAY) {
3906 MARK = ORIGMARK;
3907 *++MARK = *SP;
3908 SP = MARK;
79072805 3909 }
a0d0e21e
LW		 3910 RETURN;
3911}
3912
3913/* List operators. */
3914
3915PP(pp_list)
3916{
39644a26 3917 dSP; dMARK;
a0d0e21e
LW		 3918 if (GIMME != G_ARRAY) {
3919 if (++MARK <= SP)
3920 *MARK = *SP; /* unwanted list, return last item */
8990e307 3921 else
3280af22 3922 *MARK = &PL_sv_undef;
a0d0e21e 3923 SP = MARK;
79072805 3924 }
a0d0e21e 3925 RETURN;
79072805
LW		 3926}
3927
a0d0e21e 3928PP(pp_lslice)
79072805 3929{
39644a26 3930 dSP;
3280af22
NIS		 3931 SV **lastrelem = PL_stack_sp;
3932 SV **lastlelem = PL_stack_base + POPMARK;
3933 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 3934 register SV **firstrelem = lastlelem + 1;
3280af22 3935 I32 arybase = PL_curcop->cop_arybase;
533c011a 3936 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 3937 I32 is_something_there = lval;
79072805 3938
a0d0e21e
LW		 3939 register I32 max = lastrelem - lastlelem;
3940 register SV **lelem;
3941 register I32 ix;
3942
3943 if (GIMME != G_ARRAY) {
748a9306
LW		 3944 ix = SvIVx(*lastlelem);
3945 if (ix < 0)
3946 ix += max;
3947 else
3948 ix -= arybase;
a0d0e21e 3949 if (ix < 0 || ix >= max)
3280af22 3950 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 3951 else
3952 *firstlelem = firstrelem[ix];
3953 SP = firstlelem;
3954 RETURN;
3955 }
3956
3957 if (max == 0) {
3958 SP = firstlelem - 1;
3959 RETURN;
3960 }
3961
3962 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 3963 ix = SvIVx(*lelem);
c73bf8e3 3964 if (ix < 0)
a0d0e21e 3965 ix += max;
b13b2135 3966 else
748a9306 3967 ix -= arybase;
c73bf8e3
HS		 3968 if (ix < 0 || ix >= max)
3969 *lelem = &PL_sv_undef;
3970 else {
3971 is_something_there = TRUE;
3972 if (!(*lelem = firstrelem[ix]))
3280af22 3973 *lelem = &PL_sv_undef;
748a9306 3974 }
79072805 3975 }
4633a7c4
LW		 3976 if (is_something_there)
3977 SP = lastlelem;
3978 else
3979 SP = firstlelem - 1;
79072805
LW		 3980 RETURN;
3981}
3982
a0d0e21e
LW		 3983PP(pp_anonlist)
3984{
39644a26 3985 dSP; dMARK; dORIGMARK;
a0d0e21e 3986 I32 items = SP - MARK;
44a8e56a 3987 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3988 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3989 XPUSHs(av);
a0d0e21e
LW		 3990 RETURN;
3991}
3992
3993PP(pp_anonhash)
79072805 3994{
39644a26 3995 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3996 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3997
3998 while (MARK < SP) {
3999 SV* key = *++MARK;
a0d0e21e
LW		 4000 SV *val = NEWSV(46, 0);
4001 if (MARK < SP)
4002 sv_setsv(val, *++MARK);
e476b1b5 4003 else if (ckWARN(WARN_MISC))
9014280d 4004 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
f12c7020 4005 (void)hv_store_ent(hv,key,val,0);
79072805 4006 }
a0d0e21e
LW		 4007 SP = ORIGMARK;
4008 XPUSHs((SV*)hv);
79072805
LW		 4009 RETURN;
4010}
4011
a0d0e21e 4012PP(pp_splice)
79072805 4013{
39644a26 4014 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 4015 register AV *ary = (AV*)*++MARK;
4016 register SV **src;
4017 register SV **dst;
4018 register I32 i;
4019 register I32 offset;
4020 register I32 length;
4021 I32 newlen;
4022 I32 after;
4023 I32 diff;
4024 SV **tmparyval = 0;
93965878
NIS		 4025 MAGIC *mg;
4026
14befaf4 4027 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4028 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 4029 PUSHMARK(MARK);
8ec5e241 4030 PUTBACK;
a60c0954 4031 ENTER;
864dbfa3 4032 call_method("SPLICE",GIMME_V);
a60c0954 4033 LEAVE;
93965878
NIS		 4034 SPAGAIN;
4035 RETURN;
4036 }
79072805 4037
a0d0e21e 4038 SP++;
79072805 4039
a0d0e21e 4040 if (++MARK < SP) {
84902520 4041 offset = i = SvIVx(*MARK);
a0d0e21e 4042 if (offset < 0)
93965878 4043 offset += AvFILLp(ary) + 1;
a0d0e21e 4044 else
3280af22 4045 offset -= PL_curcop->cop_arybase;
84902520 4046 if (offset < 0)
cea2e8a9 4047 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 4048 if (++MARK < SP) {
4049 length = SvIVx(*MARK++);
48cdf507
GA		 4050 if (length < 0) {
4051 length += AvFILLp(ary) - offset + 1;
4052 if (length < 0)
4053 length = 0;
4054 }
79072805
LW		 4055 }
4056 else
a0d0e21e 4057 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 4058 }
a0d0e21e
LW		 4059 else {
4060 offset = 0;
4061 length = AvMAX(ary) + 1;
4062 }
8cbc2e3b
JH		 4063 if (offset > AvFILLp(ary) + 1) {
4064 if (ckWARN(WARN_MISC))
9014280d 4065 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 4066 offset = AvFILLp(ary) + 1;
8cbc2e3b 4067 }
93965878 4068 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 4069 if (after < 0) { /* not that much array */
4070 length += after; /* offset+length now in array */
4071 after = 0;
4072 if (!AvALLOC(ary))
4073 av_extend(ary, 0);
4074 }
4075
4076 /* At this point, MARK .. SP-1 is our new LIST */
4077
4078 newlen = SP - MARK;
4079 diff = newlen - length;
13d7cbc1
GS		 4080 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4081 av_reify(ary);
a0d0e21e
LW		 4082
4083 if (diff < 0) { /* shrinking the area */
4084 if (newlen) {
4085 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4086 Copy(MARK, tmparyval, newlen, SV*);
79072805 4087 }
a0d0e21e
LW		 4088
4089 MARK = ORIGMARK + 1;
4090 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4091 MEXTEND(MARK, length);
4092 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4093 if (AvREAL(ary)) {
bbce6d69 4094 EXTEND_MORTAL(length);
36477c24 4095 for (i = length, dst = MARK; i; i--) {
d689ffdd 4096 sv_2mortal(*dst); /* free them eventualy */
36477c24 4097 dst++;
4098 }
a0d0e21e
LW		 4099 }
4100 MARK += length - 1;
79072805 4101 }
a0d0e21e
LW		 4102 else {
4103 *MARK = AvARRAY(ary)[offset+length-1];
4104 if (AvREAL(ary)) {
d689ffdd 4105 sv_2mortal(*MARK);
a0d0e21e
LW		 4106 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4107 SvREFCNT_dec(*dst++); /* free them now */
79072805 4108 }
a0d0e21e 4109 }
93965878 4110 AvFILLp(ary) += diff;
a0d0e21e
LW		 4111
4112 /* pull up or down? */
4113
4114 if (offset < after) { /* easier to pull up */
4115 if (offset) { /* esp. if nothing to pull */
4116 src = &AvARRAY(ary)[offset-1];
4117 dst = src - diff; /* diff is negative */
4118 for (i = offset; i > 0; i--) /* can't trust Copy */
4119 *dst-- = *src--;
79072805 4120 }
a0d0e21e
LW		 4121 dst = AvARRAY(ary);
4122 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4123 AvMAX(ary) += diff;
4124 }
4125 else {
4126 if (after) { /* anything to pull down? */
4127 src = AvARRAY(ary) + offset + length;
4128 dst = src + diff; /* diff is negative */
4129 Move(src, dst, after, SV*);
79072805 4130 }
93965878 4131 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 4132 /* avoid later double free */
4133 }
4134 i = -diff;
4135 while (i)
3280af22 4136 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 4137
4138 if (newlen) {
4139 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4140 newlen; newlen--) {
4141 *dst = NEWSV(46, 0);
4142 sv_setsv(*dst++, *src++);
79072805 4143 }
a0d0e21e
LW		 4144 Safefree(tmparyval);
4145 }
4146 }
4147 else { /* no, expanding (or same) */
4148 if (length) {
4149 New(452, tmparyval, length, SV*); /* so remember deletion */
4150 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4151 }
4152
4153 if (diff > 0) { /* expanding */
4154
4155 /* push up or down? */
4156
4157 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4158 if (offset) {
4159 src = AvARRAY(ary);
4160 dst = src - diff;
4161 Move(src, dst, offset, SV*);
79072805 4162 }
a0d0e21e
LW		 4163 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4164 AvMAX(ary) += diff;
93965878 4165 AvFILLp(ary) += diff;
79072805
LW		 4166 }
4167 else {
93965878
NIS		 4168 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4169 av_extend(ary, AvFILLp(ary) + diff);
4170 AvFILLp(ary) += diff;
a0d0e21e
LW		 4171
4172 if (after) {
93965878 4173 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 4174 src = dst - diff;
4175 for (i = after; i; i--) {
4176 *dst-- = *src--;
4177 }
79072805
LW		 4178 }
4179 }
a0d0e21e
LW		 4180 }
4181
4182 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4183 *dst = NEWSV(46, 0);
4184 sv_setsv(*dst++, *src++);
4185 }
4186 MARK = ORIGMARK + 1;
4187 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4188 if (length) {
4189 Copy(tmparyval, MARK, length, SV*);
4190 if (AvREAL(ary)) {
bbce6d69 4191 EXTEND_MORTAL(length);
36477c24 4192 for (i = length, dst = MARK; i; i--) {
d689ffdd 4193 sv_2mortal(*dst); /* free them eventualy */
36477c24 4194 dst++;
4195 }
79072805 4196 }
a0d0e21e 4197 Safefree(tmparyval);
79072805 4198 }
a0d0e21e
LW		 4199 MARK += length - 1;
4200 }
4201 else if (length--) {
4202 *MARK = tmparyval[length];
4203 if (AvREAL(ary)) {
d689ffdd 4204 sv_2mortal(*MARK);
a0d0e21e
LW		 4205 while (length-- > 0)
4206 SvREFCNT_dec(tmparyval[length]);
79072805 4207 }
a0d0e21e 4208 Safefree(tmparyval);
79072805 4209 }
a0d0e21e 4210 else
3280af22 4211 *MARK = &PL_sv_undef;
79072805 4212 }
a0d0e21e 4213 SP = MARK;
79072805
LW		 4214 RETURN;
4215}
4216
a0d0e21e 4217PP(pp_push)
79072805 4218{
39644a26 4219 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4220 register AV *ary = (AV*)*++MARK;
3280af22 4221 register SV *sv = &PL_sv_undef;
93965878 4222 MAGIC *mg;
79072805 4223
14befaf4 4224 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4225 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS		 4226 PUSHMARK(MARK);
4227 PUTBACK;
a60c0954 4228 ENTER;
864dbfa3 4229 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 4230 LEAVE;
93965878 4231 SPAGAIN;
93965878 4232 }
a60c0954
NIS		 4233 else {
4234 /* Why no pre-extend of ary here ? */
4235 for (++MARK; MARK <= SP; MARK++) {
4236 sv = NEWSV(51, 0);
4237 if (*MARK)
4238 sv_setsv(sv, *MARK);
4239 av_push(ary, sv);
4240 }
79072805
LW		 4241 }
4242 SP = ORIGMARK;
a0d0e21e 4243 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 4244 RETURN;
4245}
4246
a0d0e21e 4247PP(pp_pop)
79072805 4248{
39644a26 4249 dSP;
a0d0e21e
LW		 4250 AV *av = (AV*)POPs;
4251 SV *sv = av_pop(av);
d689ffdd 4252 if (AvREAL(av))
a0d0e21e
LW		 4253 (void)sv_2mortal(sv);
4254 PUSHs(sv);
79072805 4255 RETURN;
79072805
LW		 4256}
4257
a0d0e21e 4258PP(pp_shift)
79072805 4259{
39644a26 4260 dSP;
a0d0e21e
LW		 4261 AV *av = (AV*)POPs;
4262 SV *sv = av_shift(av);
79072805 4263 EXTEND(SP, 1);
a0d0e21e 4264 if (!sv)
79072805 4265 RETPUSHUNDEF;
d689ffdd 4266 if (AvREAL(av))
a0d0e21e
LW		 4267 (void)sv_2mortal(sv);
4268 PUSHs(sv);
79072805 4269 RETURN;
79072805
LW		 4270}
4271
a0d0e21e 4272PP(pp_unshift)
79072805 4273{
39644a26 4274 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4275 register AV *ary = (AV*)*++MARK;
4276 register SV *sv;
4277 register I32 i = 0;
93965878
NIS		 4278 MAGIC *mg;
4279
14befaf4 4280 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4281 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 4282 PUSHMARK(MARK);
93965878 4283 PUTBACK;
a60c0954 4284 ENTER;
864dbfa3 4285 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 4286 LEAVE;
93965878 4287 SPAGAIN;
93965878 4288 }
a60c0954
NIS		 4289 else {
4290 av_unshift(ary, SP - MARK);
4291 while (MARK < SP) {
4292 sv = NEWSV(27, 0);
4293 sv_setsv(sv, *++MARK);
4294 (void)av_store(ary, i++, sv);
4295 }
79072805 4296 }
a0d0e21e
LW		 4297 SP = ORIGMARK;
4298 PUSHi( AvFILL(ary) + 1 );
79072805 4299 RETURN;
79072805
LW		 4300}
4301
a0d0e21e 4302PP(pp_reverse)
79072805 4303{
39644a26 4304 dSP; dMARK;
a0d0e21e
LW		 4305 register SV *tmp;
4306 SV **oldsp = SP;
79072805 4307
a0d0e21e
LW		 4308 if (GIMME == G_ARRAY) {
4309 MARK++;
4310 while (MARK < SP) {
4311 tmp = *MARK;
4312 *MARK++ = *SP;
4313 *SP-- = tmp;
4314 }
dd58a1ab 4315 /* safe as long as stack cannot get extended in the above */
a0d0e21e 4316 SP = oldsp;
79072805
LW		 4317 }
4318 else {
a0d0e21e
LW		 4319 register char *up;
4320 register char *down;
4321 register I32 tmp;
4322 dTARGET;
4323 STRLEN len;
79072805 4324
7e2040f0 4325 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4326 if (SP - MARK > 1)
3280af22 4327 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 4328 else
54b9620d 4329 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW		 4330 up = SvPV_force(TARG, len);
4331 if (len > 1) {
7e2040f0 4332 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55
GS		 4333 U8* s = (U8*)SvPVX(TARG);
4334 U8* send = (U8*)(s + len);
a0ed51b3 4335 while (s < send) {
d742c382 4336 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 4337 s++;
4338 continue;
4339 }
4340 else {
9041c2e3 4341 if (!utf8_to_uvchr(s, 0))
a0dbb045 4342 break;
dfe13c55 4343 up = (char*)s;
a0ed51b3 4344 s += UTF8SKIP(s);
dfe13c55 4345 down = (char*)(s - 1);
a0dbb045 4346 /* reverse this character */
a0ed51b3
LW		 4347 while (down > up) {
4348 tmp = *up;
4349 *up++ = *down;
eb160463 4350 *down-- = (char)tmp;
a0ed51b3
LW		 4351 }
4352 }
4353 }
4354 up = SvPVX(TARG);
4355 }
a0d0e21e
LW		 4356 down = SvPVX(TARG) + len - 1;
4357 while (down > up) {
4358 tmp = *up;
4359 *up++ = *down;
eb160463 4360 *down-- = (char)tmp;
a0d0e21e 4361 }
3aa33fe5 4362 (void)SvPOK_only_UTF8(TARG);
79072805 4363 }
a0d0e21e
LW		 4364 SP = MARK + 1;
4365 SETTARG;
79072805 4366 }
a0d0e21e 4367 RETURN;
79072805
LW		 4368}
4369
a0d0e21e 4370PP(pp_split)
79072805 4371{
39644a26 4372 dSP; dTARG;
a0d0e21e 4373 AV *ary;
467f0320 4374 register IV limit = POPi; /* note, negative is forever */
a0d0e21e
LW		 4375 SV *sv = POPs;
4376 STRLEN len;
4377 register char *s = SvPV(sv, len);
1aa99e6b 4378 bool do_utf8 = DO_UTF8(sv);
a0d0e21e 4379 char *strend = s + len;
44a8e56a 4380 register PMOP *pm;
d9f97599 4381 register REGEXP *rx;
a0d0e21e
LW		 4382 register SV *dstr;
4383 register char *m;
4384 I32 iters = 0;
792b2c16
JH		 4385 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4386 I32 maxiters = slen + 10;
a0d0e21e
LW		 4387 I32 i;
4388 char *orig;
4389 I32 origlimit = limit;
4390 I32 realarray = 0;
4391 I32 base;
3280af22 4392 AV *oldstack = PL_curstack;
54310121 4393 I32 gimme = GIMME_V;
3280af22 4394 I32 oldsave = PL_savestack_ix;
8ec5e241
NIS		 4395 I32 make_mortal = 1;
4396 MAGIC *mg = (MAGIC *) NULL;
79072805 4397
44a8e56a 4398#ifdef DEBUGGING
4399 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4400#else
4401 pm = (PMOP*)POPs;
4402#endif
a0d0e21e 4403 if (!pm || !s)
2269b42e 4404 DIE(aTHX_ "panic: pp_split");
aaa362c4 4405 rx = PM_GETRE(pm);
bbce6d69 4406
4407 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4408 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4409
a30b2f1f 4410 RX_MATCH_UTF8_set(rx, do_utf8);
d9f424b2 4411
971a9dd3
GS		 4412 if (pm->op_pmreplroot) {
4413#ifdef USE_ITHREADS
dd2155a4 4414 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
971a9dd3 4415#else
a0d0e21e 4416 ary = GvAVn((GV*)pm->op_pmreplroot);
971a9dd3
GS		 4417#endif
4418 }
a0d0e21e 4419 else if (gimme != G_ARRAY)
3280af22 4420 ary = GvAVn(PL_defgv);
79072805 4421 else
a0d0e21e
LW		 4422 ary = Nullav;
4423 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4424 realarray = 1;
8ec5e241 4425 PUTBACK;
a0d0e21e
LW		 4426 av_extend(ary,0);
4427 av_clear(ary);
8ec5e241 4428 SPAGAIN;
14befaf4 4429 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
8ec5e241 4430 PUSHMARK(SP);
33c27489 4431 XPUSHs(SvTIED_obj((SV*)ary, mg));
8ec5e241
NIS		 4432 }
4433 else {
1c0b011c
NIS		 4434 if (!AvREAL(ary)) {
4435 AvREAL_on(ary);
abff13bb 4436 AvREIFY_off(ary);
1c0b011c 4437 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 4438 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 4439 }
4440 /* temporarily switch stacks */
3280af22 4441 SWITCHSTACK(PL_curstack, ary);
3b0d546b 4442 PL_curstackinfo->si_stack = ary;
8ec5e241 4443 make_mortal = 0;
1c0b011c 4444 }
79072805 4445 }
3280af22 4446 base = SP - PL_stack_base;
a0d0e21e
LW		 4447 orig = s;
4448 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 4449 if (pm->op_pmflags & PMf_LOCALE) {
4450 while (isSPACE_LC(*s))
4451 s++;
4452 }
4453 else {
4454 while (isSPACE(*s))
4455 s++;
4456 }
a0d0e21e 4457 }
e8f49695 4458 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
3280af22
NIS		 4459 SAVEINT(PL_multiline);
4460 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
c07a80fd 4461 }
4462
a0d0e21e
LW		 4463 if (!limit)
4464 limit = maxiters + 2;
4465 if (pm->op_pmflags & PMf_WHITE) {
4466 while (--limit) {
bbce6d69 4467 m = s;
4468 while (m < strend &&
4469 !((pm->op_pmflags & PMf_LOCALE)
4470 ? isSPACE_LC(*m) : isSPACE(*m)))
4471 ++m;
a0d0e21e
LW		 4472 if (m >= strend)
4473 break;
bbce6d69 4474
a0d0e21e
LW		 4475 dstr = NEWSV(30, m-s);
4476 sv_setpvn(dstr, s, m-s);
8ec5e241 4477 if (make_mortal)
a0d0e21e 4478 sv_2mortal(dstr);
792b2c16 4479 if (do_utf8)
28cb3359 4480 (void)SvUTF8_on(dstr);
a0d0e21e 4481 XPUSHs(dstr);
bbce6d69 4482
4483 s = m + 1;
4484 while (s < strend &&
4485 ((pm->op_pmflags & PMf_LOCALE)
4486 ? isSPACE_LC(*s) : isSPACE(*s)))
4487 ++s;
79072805
LW		 4488 }
4489 }
f4091fba 4490 else if (strEQ("^", rx->precomp)) {
a0d0e21e
LW		 4491 while (--limit) {
4492 /*SUPPRESS 530*/
4493 for (m = s; m < strend && *m != '\n'; m++) ;
4494 m++;
4495 if (m >= strend)
4496 break;
4497 dstr = NEWSV(30, m-s);
4498 sv_setpvn(dstr, s, m-s);
8ec5e241 4499 if (make_mortal)
a0d0e21e 4500 sv_2mortal(dstr);
792b2c16 4501 if (do_utf8)
28cb3359 4502 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4503 XPUSHs(dstr);
4504 s = m;
4505 }
4506 }
699c3c34
JH		 4507 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4508 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
d9f97599
GS		 4509 && (rx->reganch & ROPT_CHECK_ALL)
4510 && !(rx->reganch & ROPT_ANCH)) {
f722798b
IZ		 4511 int tail = (rx->reganch & RE_INTUIT_TAIL);
4512 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
cf93c79d 4513
ca5b42cb 4514 len = rx->minlen;
1aa99e6b 4515 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
93f04dac
JH		 4516 STRLEN n_a;
4517 char c = *SvPV(csv, n_a);
a0d0e21e 4518 while (--limit) {
bbce6d69 4519 /*SUPPRESS 530*/
f722798b 4520 for (m = s; m < strend && *m != c; m++) ;
a0d0e21e
LW		 4521 if (m >= strend)
4522 break;
4523 dstr = NEWSV(30, m-s);
4524 sv_setpvn(dstr, s, m-s);
8ec5e241 4525 if (make_mortal)
a0d0e21e 4526 sv_2mortal(dstr);
792b2c16 4527 if (do_utf8)
28cb3359 4528 (void)SvUTF8_on(dstr);
a0d0e21e 4529 XPUSHs(dstr);
93f04dac
JH		 4530 /* The rx->minlen is in characters but we want to step
4531 * s ahead by bytes. */
1aa99e6b
IH		 4532 if (do_utf8)
4533 s = (char*)utf8_hop((U8*)m, len);
4534 else
4535 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 4536 }
4537 }
4538 else {
4539#ifndef lint
4540 while (s < strend && --limit &&
f722798b
IZ		 4541 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4542 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
79072805 4543#endif
a0d0e21e
LW		 4544 {
4545 dstr = NEWSV(31, m-s);
4546 sv_setpvn(dstr, s, m-s);
8ec5e241 4547 if (make_mortal)
a0d0e21e 4548 sv_2mortal(dstr);
792b2c16 4549 if (do_utf8)
28cb3359 4550 (void)SvUTF8_on(dstr);
a0d0e21e 4551 XPUSHs(dstr);
93f04dac
JH		 4552 /* The rx->minlen is in characters but we want to step
4553 * s ahead by bytes. */
1aa99e6b
IH		 4554 if (do_utf8)
4555 s = (char*)utf8_hop((U8*)m, len);
4556 else
4557 s = m + len; /* Fake \n at the end */
a0d0e21e 4558 }
463ee0b2 4559 }
463ee0b2 4560 }
a0d0e21e 4561 else {
792b2c16 4562 maxiters += slen * rx->nparens;
080c2dec 4563 while (s < strend && --limit)
bbce6d69 4564 {
080c2dec
AE		 4565 PUTBACK;
4566 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4567 SPAGAIN;
4568 if (i == 0)
4569 break;
d9f97599 4570 TAINT_IF(RX_MATCH_TAINTED(rx));
cf93c79d 4571 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 4572 m = s;
4573 s = orig;
cf93c79d 4574 orig = rx->subbeg;
a0d0e21e
LW		 4575 s = orig + (m - s);
4576 strend = s + (strend - m);
4577 }
cf93c79d 4578 m = rx->startp[0] + orig;
a0d0e21e
LW		 4579 dstr = NEWSV(32, m-s);
4580 sv_setpvn(dstr, s, m-s);
8ec5e241 4581 if (make_mortal)
a0d0e21e 4582 sv_2mortal(dstr);
792b2c16 4583 if (do_utf8)
28cb3359 4584 (void)SvUTF8_on(dstr);
a0d0e21e 4585 XPUSHs(dstr);
d9f97599 4586 if (rx->nparens) {
eb160463 4587 for (i = 1; i <= (I32)rx->nparens; i++) {
cf93c79d
IZ		 4588 s = rx->startp[i] + orig;
4589 m = rx->endp[i] + orig;
6de67870
JP		 4590
4591 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4592 parens that didn't match -- they should be set to
4593 undef, not the empty string */
4594 if (m >= orig && s >= orig) {
748a9306
LW		 4595 dstr = NEWSV(33, m-s);
4596 sv_setpvn(dstr, s, m-s);
4597 }
4598 else
6de67870 4599 dstr = &PL_sv_undef; /* undef, not "" */
8ec5e241 4600 if (make_mortal)
a0d0e21e 4601 sv_2mortal(dstr);
792b2c16 4602 if (do_utf8)
28cb3359 4603 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4604 XPUSHs(dstr);
4605 }
4606 }
cf93c79d 4607 s = rx->endp[0] + orig;
a0d0e21e 4608 }
79072805 4609 }
8ec5e241 4610
c07a80fd 4611 LEAVE_SCOPE(oldsave);
3280af22 4612 iters = (SP - PL_stack_base) - base;
a0d0e21e 4613 if (iters > maxiters)
cea2e8a9 4614 DIE(aTHX_ "Split loop");
8ec5e241 4615
a0d0e21e
LW		 4616 /* keep field after final delim? */
4617 if (s < strend || (iters && origlimit)) {
93f04dac
JH		 4618 STRLEN l = strend - s;
4619 dstr = NEWSV(34, l);
4620 sv_setpvn(dstr, s, l);
8ec5e241 4621 if (make_mortal)
a0d0e21e 4622 sv_2mortal(dstr);
792b2c16 4623 if (do_utf8)
28cb3359 4624 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4625 XPUSHs(dstr);
4626 iters++;
79072805 4627 }
a0d0e21e 4628 else if (!origlimit) {
89900bd3
SR		 4629 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4630 if (TOPs && !make_mortal)
4631 sv_2mortal(TOPs);
4632 iters--;
4633 SP--;
4634 }
a0d0e21e 4635 }
8ec5e241 4636
a0d0e21e 4637 if (realarray) {
8ec5e241 4638 if (!mg) {
1c0b011c 4639 SWITCHSTACK(ary, oldstack);
3b0d546b 4640 PL_curstackinfo->si_stack = oldstack;
1c0b011c
NIS		 4641 if (SvSMAGICAL(ary)) {
4642 PUTBACK;
4643 mg_set((SV*)ary);
4644 SPAGAIN;
4645 }
4646 if (gimme == G_ARRAY) {
4647 EXTEND(SP, iters);
4648 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4649 SP += iters;
4650 RETURN;
4651 }
8ec5e241 4652 }
1c0b011c 4653 else {
fb73857a 4654 PUTBACK;
8ec5e241 4655 ENTER;
864dbfa3 4656 call_method("PUSH",G_SCALAR|G_DISCARD);
8ec5e241 4657 LEAVE;
fb73857a 4658 SPAGAIN;
8ec5e241
NIS		 4659 if (gimme == G_ARRAY) {
4660 /* EXTEND should not be needed - we just popped them */
4661 EXTEND(SP, iters);
4662 for (i=0; i < iters; i++) {
4663 SV **svp = av_fetch(ary, i, FALSE);
3280af22 4664 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 4665 }
1c0b011c
NIS		 4666 RETURN;
4667 }
a0d0e21e
LW		 4668 }
4669 }
4670 else {
4671 if (gimme == G_ARRAY)
4672 RETURN;
4673 }
7f18b612
YST		 4674
4675 GETTARGET;
4676 PUSHi(iters);
4677 RETURN;
79072805 4678}
85e6fe83 4679
c0329465
MB		 4680PP(pp_lock)
4681{
39644a26 4682 dSP;
c0329465 4683 dTOPss;
e55aaa0e 4684 SV *retsv = sv;
68795e93 4685 SvLOCK(sv);
e55aaa0e
MB		 4686 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4687 || SvTYPE(retsv) == SVt_PVCV) {
4688 retsv = refto(retsv);
4689 }
4690 SETs(retsv);
c0329465
MB		 4691 RETURN;
4692}
a863c7d1 4693
2faa37cc 4694PP(pp_threadsv)
a863c7d1 4695{
cea2e8a9 4696 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
a863c7d1 4697}
Unnamed repository; edit this file 'description' to name the repository.