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
Clarify op.h comments for which ops the OPpDEREF* private flags
[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;
79072805 3041 sv_setpvn(TARG, tmps, rem);
12aa1545 3042#ifdef USE_LOCALE_COLLATE
14befaf4 3043 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3044#endif
9402d6ed 3045 if (utf8_curlen)
7f66633b 3046 SvUTF8_on(TARG);
f7928d6c 3047 if (repl) {
13e30c65
JH		 3048 SV* repl_sv_copy = NULL;
3049
3050 if (repl_need_utf8_upgrade) {
3051 repl_sv_copy = newSVsv(repl_sv);
3052 sv_utf8_upgrade(repl_sv_copy);
3053 repl = SvPV(repl_sv_copy, repl_len);
3054 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3055 }
c8faf1c5 3056 sv_insert(sv, pos, rem, repl, repl_len);
9402d6ed 3057 if (repl_is_utf8)
f7928d6c 3058 SvUTF8_on(sv);
9402d6ed
JH		 3059 if (repl_sv_copy)
3060 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3061 }
c8faf1c5 3062 else if (lvalue) { /* it's an lvalue! */
dedeecda 3063 if (!SvGMAGICAL(sv)) {
3064 if (SvROK(sv)) {
2d8e6c8d
GS		 3065 STRLEN n_a;
3066 SvPV_force(sv,n_a);
599cee73 3067 if (ckWARN(WARN_SUBSTR))
9014280d 3068 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
599cee73 3069 "Attempt to use reference as lvalue in substr");
dedeecda 3070 }
3071 if (SvOK(sv)) /* is it defined ? */
7f66633b 3072 (void)SvPOK_only_UTF8(sv);
dedeecda 3073 else
3074 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3075 }
5f05dabc 3076
24aef97f
HS		 3077 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3078 TARG = sv_newmortal();
a0d0e21e
LW		 3079 if (SvTYPE(TARG) < SVt_PVLV) {
3080 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3081 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
ed6116ce 3082 }
6214ab63
AE		 3083 else
3084 (void)SvOK_off(TARG);
a0d0e21e 3085
5f05dabc 3086 LvTYPE(TARG) = 'x';
6ff81951
GS		 3087 if (LvTARG(TARG) != sv) {
3088 if (LvTARG(TARG))
3089 SvREFCNT_dec(LvTARG(TARG));
3090 LvTARG(TARG) = SvREFCNT_inc(sv);
3091 }
9aa983d2
JH		 3092 LvTARGOFF(TARG) = upos;
3093 LvTARGLEN(TARG) = urem;
79072805
LW		 3094 }
3095 }
849ca7ee 3096 SPAGAIN;
79072805
LW		 3097 PUSHs(TARG); /* avoid SvSETMAGIC here */
3098 RETURN;
3099}
3100
3101PP(pp_vec)
3102{
39644a26 3103 dSP; dTARGET;
467f0320
JH		 3104 register IV size = POPi;
3105 register IV offset = POPi;
79072805 3106 register SV *src = POPs;
78f9721b 3107 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e 3108
81e118e0
JH		 3109 SvTAINTED_off(TARG); /* decontaminate */
3110 if (lvalue) { /* it's an lvalue! */
24aef97f
HS		 3111 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3112 TARG = sv_newmortal();
81e118e0
JH		 3113 if (SvTYPE(TARG) < SVt_PVLV) {
3114 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3115 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
79072805 3116 }
81e118e0
JH		 3117 LvTYPE(TARG) = 'v';
3118 if (LvTARG(TARG) != src) {
3119 if (LvTARG(TARG))
3120 SvREFCNT_dec(LvTARG(TARG));
3121 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 3122 }
81e118e0
JH		 3123 LvTARGOFF(TARG) = offset;
3124 LvTARGLEN(TARG) = size;
79072805
LW		 3125 }
3126
81e118e0 3127 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW		 3128 PUSHs(TARG);
3129 RETURN;
3130}
3131
3132PP(pp_index)
3133{
39644a26 3134 dSP; dTARGET;
79072805
LW		 3135 SV *big;
3136 SV *little;
3137 I32 offset;
3138 I32 retval;
3139 char *tmps;
3140 char *tmps2;
463ee0b2 3141 STRLEN biglen;
3280af22 3142 I32 arybase = PL_curcop->cop_arybase;
79072805
LW		 3143
3144 if (MAXARG < 3)
3145 offset = 0;
3146 else
3147 offset = POPi - arybase;
3148 little = POPs;
3149 big = POPs;
463ee0b2 3150 tmps = SvPV(big, biglen);
7e2040f0 3151 if (offset > 0 && DO_UTF8(big))
a0ed51b3 3152 sv_pos_u2b(big, &offset, 0);
79072805
LW		 3153 if (offset < 0)
3154 offset = 0;
eb160463 3155 else if (offset > (I32)biglen)
93a17b20 3156 offset = biglen;
79072805 3157 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 3158 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 3159 retval = -1;
79072805 3160 else
a0ed51b3 3161 retval = tmps2 - tmps;
7e2040f0 3162 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3163 sv_pos_b2u(big, &retval);
3164 PUSHi(retval + arybase);
79072805
LW		 3165 RETURN;
3166}
3167
3168PP(pp_rindex)
3169{
39644a26 3170 dSP; dTARGET;
79072805
LW		 3171 SV *big;
3172 SV *little;
463ee0b2
LW		 3173 STRLEN blen;
3174 STRLEN llen;
79072805
LW		 3175 I32 offset;
3176 I32 retval;
3177 char *tmps;
3178 char *tmps2;
3280af22 3179 I32 arybase = PL_curcop->cop_arybase;
79072805 3180
a0d0e21e 3181 if (MAXARG >= 3)
a0ed51b3 3182 offset = POPi;
79072805
LW		 3183 little = POPs;
3184 big = POPs;
463ee0b2
LW		 3185 tmps2 = SvPV(little, llen);
3186 tmps = SvPV(big, blen);
79072805 3187 if (MAXARG < 3)
463ee0b2 3188 offset = blen;
a0ed51b3 3189 else {
7e2040f0 3190 if (offset > 0 && DO_UTF8(big))
a0ed51b3
LW		 3191 sv_pos_u2b(big, &offset, 0);
3192 offset = offset - arybase + llen;
3193 }
79072805
LW		 3194 if (offset < 0)
3195 offset = 0;
eb160463 3196 else if (offset > (I32)blen)
463ee0b2 3197 offset = blen;
79072805 3198 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 3199 tmps2, tmps2 + llen)))
a0ed51b3 3200 retval = -1;
79072805 3201 else
a0ed51b3 3202 retval = tmps2 - tmps;
7e2040f0 3203 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3204 sv_pos_b2u(big, &retval);
3205 PUSHi(retval + arybase);
79072805
LW		 3206 RETURN;
3207}
3208
3209PP(pp_sprintf)
3210{
39644a26 3211 dSP; dMARK; dORIGMARK; dTARGET;
79072805 3212 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3213 TAINT_IF(SvTAINTED(TARG));
6ee35fb7
JH		 3214 if (DO_UTF8(*(MARK+1)))
3215 SvUTF8_on(TARG);
79072805
LW		 3216 SP = ORIGMARK;
3217 PUSHTARG;
3218 RETURN;
3219}
3220
79072805
LW		 3221PP(pp_ord)
3222{
39644a26 3223 dSP; dTARGET;
7df053ec 3224 SV *argsv = POPs;
ba210ebe 3225 STRLEN len;
7df053ec 3226 U8 *s = (U8*)SvPVx(argsv, len);
121910a4
JH		 3227 SV *tmpsv;
3228
799ef3cb 3229 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
121910a4 3230 tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3231 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH		 3232 argsv = tmpsv;
3233 }
79072805 3234
872c91ae
JH		 3235 XPUSHu(DO_UTF8(argsv) ?
3236 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3237 (*s & 0xff));
68795e93 3238
79072805
LW		 3239 RETURN;
3240}
3241
463ee0b2
LW		 3242PP(pp_chr)
3243{
39644a26 3244 dSP; dTARGET;
463ee0b2 3245 char *tmps;
467f0320 3246 UV value = POPu;
463ee0b2 3247
748a9306 3248 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3249
0064a8a9 3250 if (value > 255 && !IN_BYTES) {
eb160463 3251 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3252 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
a0ed51b3
LW		 3253 SvCUR_set(TARG, tmps - SvPVX(TARG));
3254 *tmps = '\0';
3255 (void)SvPOK_only(TARG);
aa6ffa16 3256 SvUTF8_on(TARG);
a0ed51b3
LW		 3257 XPUSHs(TARG);
3258 RETURN;
3259 }
3260
748a9306 3261 SvGROW(TARG,2);
463ee0b2
LW		 3262 SvCUR_set(TARG, 1);
3263 tmps = SvPVX(TARG);
eb160463 3264 *tmps++ = (char)value;
748a9306 3265 *tmps = '\0';
a0d0e21e 3266 (void)SvPOK_only(TARG);
88632417 3267 if (PL_encoding && !IN_BYTES) {
799ef3cb 3268 sv_recode_to_utf8(TARG, PL_encoding);
88632417
JH		 3269 tmps = SvPVX(TARG);
3270 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3271 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
d5a15ac2
JH		 3272 SvGROW(TARG, 3);
3273 tmps = SvPVX(TARG);
88632417
JH		 3274 SvCUR_set(TARG, 2);
3275 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3276 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3277 *tmps = '\0';
3278 SvUTF8_on(TARG);
3279 }
3280 }
463ee0b2
LW		 3281 XPUSHs(TARG);
3282 RETURN;
3283}
3284
79072805
LW		 3285PP(pp_crypt)
3286{
5f74f29c 3287 dSP; dTARGET;
79072805 3288#ifdef HAS_CRYPT
5f74f29c
JH		 3289 dPOPTOPssrl;
3290 STRLEN n_a;
85c16d83
JH		 3291 STRLEN len;
3292 char *tmps = SvPV(left, len);
2bc69dc4 3293
85c16d83 3294 if (DO_UTF8(left)) {
2bc69dc4 3295 /* If Unicode, try to downgrade.
f2791508
JH		 3296 * If not possible, croak.
3297 * Yes, we made this up. */
3298 SV* tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3299
f2791508 3300 SvUTF8_on(tsv);
2bc69dc4 3301 sv_utf8_downgrade(tsv, FALSE);
f2791508 3302 tmps = SvPVX(tsv);
85c16d83 3303 }
05404ffe
JH		 3304# ifdef USE_ITHREADS
3305# ifdef HAS_CRYPT_R
3306 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3307 /* This should be threadsafe because in ithreads there is only
3308 * one thread per interpreter. If this would not be true,
3309 * we would need a mutex to protect this malloc. */
3310 PL_reentrant_buffer->_crypt_struct_buffer =
3311 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3312#if defined(__GLIBC__) || defined(__EMX__)
3313 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3314 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3315 /* work around glibc-2.2.5 bug */
3316 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3317 }
05404ffe 3318#endif
6ab58e4d 3319 }
05404ffe
JH		 3320# endif /* HAS_CRYPT_R */
3321# endif /* USE_ITHREADS */
5f74f29c 3322# ifdef FCRYPT
2d8e6c8d 3323 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
5f74f29c 3324# else
2d8e6c8d 3325 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
5f74f29c 3326# endif
4808266b
JH		 3327 SETs(TARG);
3328 RETURN;
79072805 3329#else
b13b2135 3330 DIE(aTHX_
79072805
LW		 3331 "The crypt() function is unimplemented due to excessive paranoia.");
3332#endif
79072805
LW		 3333}
3334
3335PP(pp_ucfirst)
3336{
39644a26 3337 dSP;
79072805 3338 SV *sv = TOPs;
a0ed51b3
LW		 3339 register U8 *s;
3340 STRLEN slen;
3341
d104a74c 3342 SvGETMAGIC(sv);
3a2263fe
RGS		 3343 if (DO_UTF8(sv) &&
3344 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3345 UTF8_IS_START(*s)) {
e7ae6809 3346 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
44bc797b
JH		 3347 STRLEN ulen;
3348 STRLEN tculen;
a0ed51b3 3349
44bc797b 3350 utf8_to_uvchr(s, &ulen);
44bc797b
JH		 3351 toTITLE_utf8(s, tmpbuf, &tculen);
3352 utf8_to_uvchr(tmpbuf, 0);
3353
3354 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
a0ed51b3 3355 dTARGET;
3a2263fe
RGS		 3356 /* slen is the byte length of the whole SV.
3357 * ulen is the byte length of the original Unicode character
3358 * stored as UTF-8 at s.
3359 * tculen is the byte length of the freshly titlecased
3360 * Unicode character stored as UTF-8 at tmpbuf.
3361 * We first set the result to be the titlecased character,
3362 * and then append the rest of the SV data. */
44bc797b 3363 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3a2263fe
RGS		 3364 if (slen > ulen)
3365 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3366 SvUTF8_on(TARG);
a0ed51b3
LW		 3367 SETs(TARG);
3368 }
3369 else {
d104a74c 3370 s = (U8*)SvPV_force_nomg(sv, slen);
44bc797b 3371 Copy(tmpbuf, s, tculen, U8);
a0ed51b3 3372 }
a0ed51b3 3373 }
626727d5 3374 else {
014822e4 3375 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3376 dTARGET;
7e2040f0 3377 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3378 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3379 sv = TARG;
3380 SETs(sv);
3381 }
d104a74c 3382 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3383 if (*s) {
2de3dbcc 3384 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3385 TAINT;
3386 SvTAINTED_on(sv);
3387 *s = toUPPER_LC(*s);
3388 }
3389 else
3390 *s = toUPPER(*s);
bbce6d69 3391 }
bbce6d69 3392 }
d104a74c 3393 SvSETMAGIC(sv);
79072805
LW		 3394 RETURN;
3395}
3396
3397PP(pp_lcfirst)
3398{
39644a26 3399 dSP;
79072805 3400 SV *sv = TOPs;
a0ed51b3
LW		 3401 register U8 *s;
3402 STRLEN slen;
3403
d104a74c 3404 SvGETMAGIC(sv);
3a2263fe
RGS		 3405 if (DO_UTF8(sv) &&
3406 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3407 UTF8_IS_START(*s)) {
ba210ebe 3408 STRLEN ulen;
e7ae6809 3409 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3410 U8 *tend;
9041c2e3 3411 UV uv;
a0ed51b3 3412
44bc797b 3413 toLOWER_utf8(s, tmpbuf, &ulen);
a2a2844f 3414 uv = utf8_to_uvchr(tmpbuf, 0);
9041c2e3 3415 tend = uvchr_to_utf8(tmpbuf, uv);
a0ed51b3 3416
eb160463 3417 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
a0ed51b3 3418 dTARGET;
dfe13c55 3419 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3a2263fe
RGS		 3420 if (slen > ulen)
3421 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3422 SvUTF8_on(TARG);
a0ed51b3
LW		 3423 SETs(TARG);
3424 }
3425 else {
d104a74c 3426 s = (U8*)SvPV_force_nomg(sv, slen);
a0ed51b3
LW		 3427 Copy(tmpbuf, s, ulen, U8);
3428 }
a0ed51b3 3429 }
626727d5 3430 else {
014822e4 3431 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3432 dTARGET;
7e2040f0 3433 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3434 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3435 sv = TARG;
3436 SETs(sv);
3437 }
d104a74c 3438 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3439 if (*s) {
2de3dbcc 3440 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3441 TAINT;
3442 SvTAINTED_on(sv);
3443 *s = toLOWER_LC(*s);
3444 }
3445 else
3446 *s = toLOWER(*s);
bbce6d69 3447 }
bbce6d69 3448 }
d104a74c 3449 SvSETMAGIC(sv);
79072805
LW		 3450 RETURN;
3451}
3452
3453PP(pp_uc)
3454{
39644a26 3455 dSP;
79072805 3456 SV *sv = TOPs;
a0ed51b3 3457 register U8 *s;
463ee0b2 3458 STRLEN len;
79072805 3459
d104a74c 3460 SvGETMAGIC(sv);
7e2040f0 3461 if (DO_UTF8(sv)) {
a0ed51b3 3462 dTARGET;
ba210ebe 3463 STRLEN ulen;
a0ed51b3
LW		 3464 register U8 *d;
3465 U8 *send;
e7ae6809 3466 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3467
d104a74c 3468 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3469 if (!len) {
7e2040f0 3470 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3471 sv_setpvn(TARG, "", 0);
3472 SETs(TARG);
a0ed51b3
LW		 3473 }
3474 else {
98b27f73
JH		 3475 STRLEN nchar = utf8_length(s, s + len);
3476
31351b04 3477 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3478 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3479 (void)SvPOK_only(TARG);
3480 d = (U8*)SvPVX(TARG);
3481 send = s + len;
a2a2844f 3482 while (s < send) {
6fdb5f96 3483 toUPPER_utf8(s, tmpbuf, &ulen);
a2a2844f
JH		 3484 Copy(tmpbuf, d, ulen, U8);
3485 d += ulen;
3486 s += UTF8SKIP(s);
a0ed51b3 3487 }
31351b04 3488 *d = '\0';
7e2040f0 3489 SvUTF8_on(TARG);
31351b04
JS		 3490 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3491 SETs(TARG);
a0ed51b3 3492 }
a0ed51b3 3493 }
626727d5 3494 else {
014822e4 3495 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3496 dTARGET;
7e2040f0 3497 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3498 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3499 sv = TARG;
3500 SETs(sv);
3501 }
d104a74c 3502 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3503 if (len) {
3504 register U8 *send = s + len;
3505
2de3dbcc 3506 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3507 TAINT;
3508 SvTAINTED_on(sv);
3509 for (; s < send; s++)
3510 *s = toUPPER_LC(*s);
3511 }
3512 else {
3513 for (; s < send; s++)
3514 *s = toUPPER(*s);
3515 }
bbce6d69 3516 }
79072805 3517 }
d104a74c 3518 SvSETMAGIC(sv);
79072805
LW		 3519 RETURN;
3520}
3521
3522PP(pp_lc)
3523{
39644a26 3524 dSP;
79072805 3525 SV *sv = TOPs;
a0ed51b3 3526 register U8 *s;
463ee0b2 3527 STRLEN len;
79072805 3528
d104a74c 3529 SvGETMAGIC(sv);
7e2040f0 3530 if (DO_UTF8(sv)) {
a0ed51b3 3531 dTARGET;
ba210ebe 3532 STRLEN ulen;
a0ed51b3
LW		 3533 register U8 *d;
3534 U8 *send;
e7ae6809 3535 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3536
d104a74c 3537 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3538 if (!len) {
7e2040f0 3539 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3540 sv_setpvn(TARG, "", 0);
3541 SETs(TARG);
a0ed51b3
LW		 3542 }
3543 else {
98b27f73
JH		 3544 STRLEN nchar = utf8_length(s, s + len);
3545
31351b04 3546 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3547 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3548 (void)SvPOK_only(TARG);
3549 d = (U8*)SvPVX(TARG);
3550 send = s + len;
a2a2844f 3551 while (s < send) {
6fdb5f96
JH		 3552 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3553#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3554 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3555 /*
3556 * Now if the sigma is NOT followed by
3557 * /$ignorable_sequence$cased_letter/;
3558 * and it IS preceded by
3559 * /$cased_letter$ignorable_sequence/;
3560 * where $ignorable_sequence is
3561 * [\x{2010}\x{AD}\p{Mn}]*
3562 * and $cased_letter is
3563 * [\p{Ll}\p{Lo}\p{Lt}]
3564 * then it should be mapped to 0x03C2,
3565 * (GREEK SMALL LETTER FINAL SIGMA),
3566 * instead of staying 0x03A3.
3567 * See lib/unicore/SpecCase.txt.
3568 */
3569 }
a2a2844f
JH		 3570 Copy(tmpbuf, d, ulen, U8);
3571 d += ulen;
3572 s += UTF8SKIP(s);
a0ed51b3 3573 }
31351b04 3574 *d = '\0';
7e2040f0 3575 SvUTF8_on(TARG);
31351b04
JS		 3576 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3577 SETs(TARG);
a0ed51b3 3578 }
79072805 3579 }
626727d5 3580 else {
014822e4 3581 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3582 dTARGET;
7e2040f0 3583 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3584 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3585 sv = TARG;
3586 SETs(sv);
a0ed51b3 3587 }
bbce6d69 3588
d104a74c 3589 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3590 if (len) {
3591 register U8 *send = s + len;
bbce6d69 3592
2de3dbcc 3593 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3594 TAINT;
3595 SvTAINTED_on(sv);
3596 for (; s < send; s++)
3597 *s = toLOWER_LC(*s);
3598 }
3599 else {
3600 for (; s < send; s++)
3601 *s = toLOWER(*s);
3602 }
bbce6d69 3603 }
79072805 3604 }
d104a74c 3605 SvSETMAGIC(sv);
79072805
LW		 3606 RETURN;
3607}
3608
a0d0e21e 3609PP(pp_quotemeta)
79072805 3610{
39644a26 3611 dSP; dTARGET;
a0d0e21e
LW		 3612 SV *sv = TOPs;
3613 STRLEN len;
3614 register char *s = SvPV(sv,len);
3615 register char *d;
79072805 3616
7e2040f0 3617 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW		 3618 if (len) {
3619 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 3620 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3621 d = SvPVX(TARG);
7e2040f0 3622 if (DO_UTF8(sv)) {
0dd2cdef 3623 while (len) {
fd400ab9 3624 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 3625 STRLEN ulen = UTF8SKIP(s);
3626 if (ulen > len)
3627 ulen = len;
3628 len -= ulen;
3629 while (ulen--)
3630 *d++ = *s++;
3631 }
3632 else {
3633 if (!isALNUM(*s))
3634 *d++ = '\\';
3635 *d++ = *s++;
3636 len--;
3637 }
3638 }
7e2040f0 3639 SvUTF8_on(TARG);
0dd2cdef
LW		 3640 }
3641 else {
3642 while (len--) {
3643 if (!isALNUM(*s))
3644 *d++ = '\\';
3645 *d++ = *s++;
3646 }
79072805 3647 }
a0d0e21e
LW		 3648 *d = '\0';
3649 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 3650 (void)SvPOK_only_UTF8(TARG);
79072805 3651 }
a0d0e21e
LW		 3652 else
3653 sv_setpvn(TARG, s, len);
3654 SETs(TARG);
31351b04
JS		 3655 if (SvSMAGICAL(TARG))
3656 mg_set(TARG);
79072805
LW		 3657 RETURN;
3658}
3659
a0d0e21e 3660/* Arrays. */
79072805 3661
a0d0e21e 3662PP(pp_aslice)
79072805 3663{
39644a26 3664 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3665 register SV** svp;
3666 register AV* av = (AV*)POPs;
78f9721b 3667 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3280af22 3668 I32 arybase = PL_curcop->cop_arybase;
748a9306 3669 I32 elem;
79072805 3670
a0d0e21e 3671 if (SvTYPE(av) == SVt_PVAV) {
533c011a 3672 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 3673 I32 max = -1;
924508f0 3674 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 3675 elem = SvIVx(*svp);
3676 if (elem > max)
3677 max = elem;
3678 }
3679 if (max > AvMAX(av))
3680 av_extend(av, max);
3681 }
a0d0e21e 3682 while (++MARK <= SP) {
748a9306 3683 elem = SvIVx(*MARK);
a0d0e21e 3684
748a9306
LW		 3685 if (elem > 0)
3686 elem -= arybase;
a0d0e21e
LW		 3687 svp = av_fetch(av, elem, lval);
3688 if (lval) {
3280af22 3689 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 3690 DIE(aTHX_ PL_no_aelem, elem);
533c011a 3691 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 3692 save_aelem(av, elem, svp);
79072805 3693 }
3280af22 3694 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 3695 }
3696 }
748a9306 3697 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 3698 MARK = ORIGMARK;
3699 *++MARK = *SP;
3700 SP = MARK;
3701 }
79072805
LW		 3702 RETURN;
3703}
3704
3705/* Associative arrays. */
3706
3707PP(pp_each)
3708{
39644a26 3709 dSP;
79072805 3710 HV *hash = (HV*)POPs;
c07a80fd 3711 HE *entry;
54310121 3712 I32 gimme = GIMME_V;
8ec5e241 3713
c07a80fd 3714 PUTBACK;
c750a3ec 3715 /* might clobber stack_sp */
6d822dc4 3716 entry = hv_iternext(hash);
c07a80fd 3717 SPAGAIN;
79072805 3718
79072805
LW		 3719 EXTEND(SP, 2);
3720 if (entry) {
574c8022 3721 SV* sv = hv_iterkeysv(entry);
574c8022 3722 PUSHs(sv); /* won't clobber stack_sp */
54310121 3723 if (gimme == G_ARRAY) {
59af0135 3724 SV *val;
c07a80fd 3725 PUTBACK;
c750a3ec 3726 /* might clobber stack_sp */
6d822dc4 3727 val = hv_iterval(hash, entry);
c07a80fd 3728 SPAGAIN;
59af0135 3729 PUSHs(val);