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