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
Re: "fuzzy" in mktables
[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
2803 if (SvIOK(TOPs)) {
2804 if (SvIsUV(TOPs)) {
2805 UV uv = TOPu;
2806 SETu(uv);
2807 } else
2808 SETi(iv);
2809 } else {
2810 value = TOPn;
1048ea30 2811 if (value >= 0.0) {
28e5dec8
JH		 2812 if (value < (NV)UV_MAX + 0.5) {
2813 SETu(U_V(value));
2814 } else {
059a1014 2815 SETn(Perl_floor(value));
28e5dec8 2816 }
1048ea30 2817 }
28e5dec8
JH		 2818 else {
2819 if (value > (NV)IV_MIN - 0.5) {
2820 SETi(I_V(value));
2821 } else {
1bbae031 2822 SETn(Perl_ceil(value));
28e5dec8
JH		 2823 }
2824 }
774d564b 2825 }
79072805 2826 }
79072805
LW		 2827 RETURN;
2828}
2829
463ee0b2
LW		 2830PP(pp_abs)
2831{
39644a26 2832 dSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 2833 {
28e5dec8
JH		 2834 /* This will cache the NV value if string isn't actually integer */
2835 IV iv = TOPi;
a227d84d 2836
28e5dec8
JH		 2837 if (SvIOK(TOPs)) {
2838 /* IVX is precise */
2839 if (SvIsUV(TOPs)) {
2840 SETu(TOPu); /* force it to be numeric only */
2841 } else {
2842 if (iv >= 0) {
2843 SETi(iv);
2844 } else {
2845 if (iv != IV_MIN) {
2846 SETi(-iv);
2847 } else {
2848 /* 2s complement assumption. Also, not really needed as
2849 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2850 SETu(IV_MIN);
2851 }
a227d84d 2852 }
28e5dec8
JH		 2853 }
2854 } else{
2855 NV value = TOPn;
774d564b 2856 if (value < 0.0)
28e5dec8 2857 value = -value;
774d564b 2858 SETn(value);
2859 }
a0d0e21e 2860 }
774d564b 2861 RETURN;
463ee0b2
LW		 2862}
2863
53305cf1 2864
79072805
LW		 2865PP(pp_hex)
2866{
39644a26 2867 dSP; dTARGET;
79072805 2868 char *tmps;
53305cf1 2869 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2870 STRLEN len;
53305cf1
NC		 2871 NV result_nv;
2872 UV result_uv;
2bc69dc4 2873 SV* sv = POPs;
79072805 2874
2bc69dc4
NIS		 2875 tmps = (SvPVx(sv, len));
2876 if (DO_UTF8(sv)) {
2877 /* If Unicode, try to downgrade
2878 * If not possible, croak. */
2879 SV* tsv = sv_2mortal(newSVsv(sv));
2880
2881 SvUTF8_on(tsv);
2882 sv_utf8_downgrade(tsv, FALSE);
2883 tmps = SvPVX(tsv);
2884 }
53305cf1
NC		 2885 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2886 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2887 XPUSHn(result_nv);
2888 }
2889 else {
2890 XPUSHu(result_uv);
2891 }
79072805
LW		 2892 RETURN;
2893}
2894
2895PP(pp_oct)
2896{
39644a26 2897 dSP; dTARGET;
79072805 2898 char *tmps;
53305cf1 2899 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2900 STRLEN len;
53305cf1
NC		 2901 NV result_nv;
2902 UV result_uv;
2bc69dc4 2903 SV* sv = POPs;
79072805 2904
2bc69dc4
NIS		 2905 tmps = (SvPVx(sv, len));
2906 if (DO_UTF8(sv)) {
2907 /* If Unicode, try to downgrade
2908 * If not possible, croak. */
2909 SV* tsv = sv_2mortal(newSVsv(sv));
2910
2911 SvUTF8_on(tsv);
2912 sv_utf8_downgrade(tsv, FALSE);
2913 tmps = SvPVX(tsv);
2914 }
6f894ead 2915 while (*tmps && len && isSPACE(*tmps))
53305cf1 2916 tmps++, len--;
9e24b6e2 2917 if (*tmps == '0')
53305cf1 2918 tmps++, len--;
9e24b6e2 2919 if (*tmps == 'x')
53305cf1 2920 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
9e24b6e2 2921 else if (*tmps == 'b')
53305cf1 2922 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2923 else
53305cf1
NC		 2924 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2925
2926 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2927 XPUSHn(result_nv);
2928 }
2929 else {
2930 XPUSHu(result_uv);
2931 }
79072805
LW		 2932 RETURN;
2933}
2934
2935/* String stuff. */
2936
2937PP(pp_length)
2938{
39644a26 2939 dSP; dTARGET;
7e2040f0 2940 SV *sv = TOPs;
a0ed51b3 2941
7e2040f0
GS		 2942 if (DO_UTF8(sv))
2943 SETi(sv_len_utf8(sv));
2944 else
2945 SETi(sv_len(sv));
79072805
LW		 2946 RETURN;
2947}
2948
2949PP(pp_substr)
2950{
39644a26 2951 dSP; dTARGET;
79072805 2952 SV *sv;
9c5ffd7c 2953 I32 len = 0;
463ee0b2 2954 STRLEN curlen;
9402d6ed 2955 STRLEN utf8_curlen;
79072805
LW		 2956 I32 pos;
2957 I32 rem;
84902520 2958 I32 fail;
78f9721b 2959 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
79072805 2960 char *tmps;
3280af22 2961 I32 arybase = PL_curcop->cop_arybase;
9402d6ed 2962 SV *repl_sv = NULL;
7b8d334a
GS		 2963 char *repl = 0;
2964 STRLEN repl_len;
78f9721b 2965 int num_args = PL_op->op_private & 7;
13e30c65 2966 bool repl_need_utf8_upgrade = FALSE;
9402d6ed 2967 bool repl_is_utf8 = FALSE;
79072805 2968
20408e3c 2969 SvTAINTED_off(TARG); /* decontaminate */
7e2040f0 2970 SvUTF8_off(TARG); /* decontaminate */
78f9721b
SM		 2971 if (num_args > 2) {
2972 if (num_args > 3) {
9402d6ed
JH		 2973 repl_sv = POPs;
2974 repl = SvPV(repl_sv, repl_len);
2975 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
7b8d334a 2976 }
79072805 2977 len = POPi;
5d82c453 2978 }
84902520 2979 pos = POPi;
79072805 2980 sv = POPs;
849ca7ee 2981 PUTBACK;
9402d6ed
JH		 2982 if (repl_sv) {
2983 if (repl_is_utf8) {
2984 if (!DO_UTF8(sv))
2985 sv_utf8_upgrade(sv);
2986 }
13e30c65
JH		 2987 else if (DO_UTF8(sv))
2988 repl_need_utf8_upgrade = TRUE;
9402d6ed 2989 }
a0d0e21e 2990 tmps = SvPV(sv, curlen);
7e2040f0 2991 if (DO_UTF8(sv)) {
9402d6ed
JH		 2992 utf8_curlen = sv_len_utf8(sv);
2993 if (utf8_curlen == curlen)
2994 utf8_curlen = 0;
a0ed51b3 2995 else
9402d6ed 2996 curlen = utf8_curlen;
a0ed51b3 2997 }
d1c2b58a 2998 else
9402d6ed 2999 utf8_curlen = 0;
a0ed51b3 3000
84902520
TB		 3001 if (pos >= arybase) {
3002 pos -= arybase;
3003 rem = curlen-pos;
3004 fail = rem;
78f9721b 3005 if (num_args > 2) {
5d82c453
GA		 3006 if (len < 0) {
3007 rem += len;
3008 if (rem < 0)
3009 rem = 0;
3010 }
3011 else if (rem > len)
3012 rem = len;
3013 }
68dc0745 3014 }
84902520 3015 else {
5d82c453 3016 pos += curlen;
78f9721b 3017 if (num_args < 3)
5d82c453
GA		 3018 rem = curlen;
3019 else if (len >= 0) {
3020 rem = pos+len;
3021 if (rem > (I32)curlen)
3022 rem = curlen;
3023 }
3024 else {
3025 rem = curlen+len;
3026 if (rem < pos)
3027 rem = pos;
3028 }
3029 if (pos < 0)
3030 pos = 0;
3031 fail = rem;
3032 rem -= pos;
84902520
TB		 3033 }
3034 if (fail < 0) {
e476b1b5
GS		 3035 if (lvalue || repl)
3036 Perl_croak(aTHX_ "substr outside of string");
3037 if (ckWARN(WARN_SUBSTR))
9014280d 3038 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2304df62
AD		 3039 RETPUSHUNDEF;
3040 }
79072805 3041 else {
9aa983d2
JH		 3042 I32 upos = pos;
3043 I32 urem = rem;
9402d6ed 3044 if (utf8_curlen)
a0ed51b3 3045 sv_pos_u2b(sv, &pos, &rem);
79072805 3046 tmps += pos;
781e7547
DM		 3047 /* we either return a PV or an LV. If the TARG hasn't been used
3048 * before, or is of that type, reuse it; otherwise use a mortal
3049 * instead. Note that LVs can have an extended lifetime, so also
3050 * dont reuse if refcount > 1 (bug #20933) */
3051 if (SvTYPE(TARG) > SVt_NULL) {
3052 if ( (SvTYPE(TARG) == SVt_PVLV)
3053 ? (!lvalue || SvREFCNT(TARG) > 1)
3054 : lvalue)
3055 {
3056 TARG = sv_newmortal();
3057 }
3058 }
3059
79072805 3060 sv_setpvn(TARG, tmps, rem);
12aa1545 3061#ifdef USE_LOCALE_COLLATE
14befaf4 3062 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3063#endif
9402d6ed 3064 if (utf8_curlen)
7f66633b 3065 SvUTF8_on(TARG);
f7928d6c 3066 if (repl) {
13e30c65
JH		 3067 SV* repl_sv_copy = NULL;
3068
3069 if (repl_need_utf8_upgrade) {
3070 repl_sv_copy = newSVsv(repl_sv);
3071 sv_utf8_upgrade(repl_sv_copy);
3072 repl = SvPV(repl_sv_copy, repl_len);
3073 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3074 }
c8faf1c5 3075 sv_insert(sv, pos, rem, repl, repl_len);
9402d6ed 3076 if (repl_is_utf8)
f7928d6c 3077 SvUTF8_on(sv);
9402d6ed
JH		 3078 if (repl_sv_copy)
3079 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3080 }
c8faf1c5 3081 else if (lvalue) { /* it's an lvalue! */
dedeecda 3082 if (!SvGMAGICAL(sv)) {
3083 if (SvROK(sv)) {
2d8e6c8d
GS		 3084 STRLEN n_a;
3085 SvPV_force(sv,n_a);
599cee73 3086 if (ckWARN(WARN_SUBSTR))
9014280d 3087 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
599cee73 3088 "Attempt to use reference as lvalue in substr");
dedeecda 3089 }
3090 if (SvOK(sv)) /* is it defined ? */
7f66633b 3091 (void)SvPOK_only_UTF8(sv);
dedeecda 3092 else
3093 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3094 }
5f05dabc 3095
a0d0e21e
LW		 3096 if (SvTYPE(TARG) < SVt_PVLV) {
3097 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3098 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
ed6116ce 3099 }
6214ab63
AE		 3100 else
3101 (void)SvOK_off(TARG);
a0d0e21e 3102
5f05dabc 3103 LvTYPE(TARG) = 'x';
6ff81951
GS		 3104 if (LvTARG(TARG) != sv) {
3105 if (LvTARG(TARG))
3106 SvREFCNT_dec(LvTARG(TARG));
3107 LvTARG(TARG) = SvREFCNT_inc(sv);
3108 }
9aa983d2
JH		 3109 LvTARGOFF(TARG) = upos;
3110 LvTARGLEN(TARG) = urem;
79072805
LW		 3111 }
3112 }
849ca7ee 3113 SPAGAIN;
79072805
LW		 3114 PUSHs(TARG); /* avoid SvSETMAGIC here */
3115 RETURN;
3116}
3117
3118PP(pp_vec)
3119{
39644a26 3120 dSP; dTARGET;
467f0320
JH		 3121 register IV size = POPi;
3122 register IV offset = POPi;
79072805 3123 register SV *src = POPs;
78f9721b 3124 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e 3125
81e118e0
JH		 3126 SvTAINTED_off(TARG); /* decontaminate */
3127 if (lvalue) { /* it's an lvalue! */
24aef97f
HS		 3128 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3129 TARG = sv_newmortal();
81e118e0
JH		 3130 if (SvTYPE(TARG) < SVt_PVLV) {
3131 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3132 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
79072805 3133 }
81e118e0
JH		 3134 LvTYPE(TARG) = 'v';
3135 if (LvTARG(TARG) != src) {
3136 if (LvTARG(TARG))
3137 SvREFCNT_dec(LvTARG(TARG));
3138 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 3139 }
81e118e0
JH		 3140 LvTARGOFF(TARG) = offset;
3141 LvTARGLEN(TARG) = size;
79072805
LW		 3142 }
3143
81e118e0 3144 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW		 3145 PUSHs(TARG);
3146 RETURN;
3147}
3148
3149PP(pp_index)
3150{
39644a26 3151 dSP; dTARGET;
79072805
LW		 3152 SV *big;
3153 SV *little;
3154 I32 offset;
3155 I32 retval;
3156 char *tmps;
3157 char *tmps2;
463ee0b2 3158 STRLEN biglen;
3280af22 3159 I32 arybase = PL_curcop->cop_arybase;
79072805
LW		 3160
3161 if (MAXARG < 3)
3162 offset = 0;
3163 else
3164 offset = POPi - arybase;
3165 little = POPs;
3166 big = POPs;
463ee0b2 3167 tmps = SvPV(big, biglen);
7e2040f0 3168 if (offset > 0 && DO_UTF8(big))
a0ed51b3 3169 sv_pos_u2b(big, &offset, 0);
79072805
LW		 3170 if (offset < 0)
3171 offset = 0;
eb160463 3172 else if (offset > (I32)biglen)
93a17b20 3173 offset = biglen;
79072805 3174 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 3175 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 3176 retval = -1;
79072805 3177 else
a0ed51b3 3178 retval = tmps2 - tmps;
7e2040f0 3179 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3180 sv_pos_b2u(big, &retval);
3181 PUSHi(retval + arybase);
79072805
LW		 3182 RETURN;
3183}
3184
3185PP(pp_rindex)
3186{
39644a26 3187 dSP; dTARGET;
79072805
LW		 3188 SV *big;
3189 SV *little;
463ee0b2
LW		 3190 STRLEN blen;
3191 STRLEN llen;
79072805
LW		 3192 I32 offset;
3193 I32 retval;
3194 char *tmps;
3195 char *tmps2;
3280af22 3196 I32 arybase = PL_curcop->cop_arybase;
79072805 3197
a0d0e21e 3198 if (MAXARG >= 3)
a0ed51b3 3199 offset = POPi;
79072805
LW		 3200 little = POPs;
3201 big = POPs;
463ee0b2
LW		 3202 tmps2 = SvPV(little, llen);
3203 tmps = SvPV(big, blen);
79072805 3204 if (MAXARG < 3)
463ee0b2 3205 offset = blen;
a0ed51b3 3206 else {
7e2040f0 3207 if (offset > 0 && DO_UTF8(big))
a0ed51b3
LW		 3208 sv_pos_u2b(big, &offset, 0);
3209 offset = offset - arybase + llen;
3210 }
79072805
LW		 3211 if (offset < 0)
3212 offset = 0;
eb160463 3213 else if (offset > (I32)blen)
463ee0b2 3214 offset = blen;
79072805 3215 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 3216 tmps2, tmps2 + llen)))
a0ed51b3 3217 retval = -1;
79072805 3218 else
a0ed51b3 3219 retval = tmps2 - tmps;
7e2040f0 3220 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3221 sv_pos_b2u(big, &retval);
3222 PUSHi(retval + arybase);
79072805
LW		 3223 RETURN;
3224}
3225
3226PP(pp_sprintf)
3227{
39644a26 3228 dSP; dMARK; dORIGMARK; dTARGET;
79072805 3229 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3230 TAINT_IF(SvTAINTED(TARG));
6ee35fb7
JH		 3231 if (DO_UTF8(*(MARK+1)))
3232 SvUTF8_on(TARG);
79072805
LW		 3233 SP = ORIGMARK;
3234 PUSHTARG;
3235 RETURN;
3236}
3237
79072805
LW		 3238PP(pp_ord)
3239{
39644a26 3240 dSP; dTARGET;
7df053ec 3241 SV *argsv = POPs;
ba210ebe 3242 STRLEN len;
7df053ec 3243 U8 *s = (U8*)SvPVx(argsv, len);
121910a4
JH		 3244 SV *tmpsv;
3245
799ef3cb 3246 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
121910a4 3247 tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3248 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH		 3249 argsv = tmpsv;
3250 }
79072805 3251
872c91ae
JH		 3252 XPUSHu(DO_UTF8(argsv) ?
3253 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3254 (*s & 0xff));
68795e93 3255
79072805
LW		 3256 RETURN;
3257}
3258
463ee0b2
LW		 3259PP(pp_chr)
3260{
39644a26 3261 dSP; dTARGET;
463ee0b2 3262 char *tmps;
467f0320 3263 UV value = POPu;
463ee0b2 3264
748a9306 3265 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3266
0064a8a9 3267 if (value > 255 && !IN_BYTES) {
eb160463 3268 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3269 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
a0ed51b3
LW		 3270 SvCUR_set(TARG, tmps - SvPVX(TARG));
3271 *tmps = '\0';
3272 (void)SvPOK_only(TARG);
aa6ffa16 3273 SvUTF8_on(TARG);
a0ed51b3
LW		 3274 XPUSHs(TARG);
3275 RETURN;
3276 }
3277
748a9306 3278 SvGROW(TARG,2);
463ee0b2
LW		 3279 SvCUR_set(TARG, 1);
3280 tmps = SvPVX(TARG);
eb160463 3281 *tmps++ = (char)value;
748a9306 3282 *tmps = '\0';
a0d0e21e 3283 (void)SvPOK_only(TARG);
88632417 3284 if (PL_encoding && !IN_BYTES) {
799ef3cb 3285 sv_recode_to_utf8(TARG, PL_encoding);
88632417
JH		 3286 tmps = SvPVX(TARG);
3287 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3288 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
d5a15ac2
JH		 3289 SvGROW(TARG, 3);
3290 tmps = SvPVX(TARG);
88632417
JH		 3291 SvCUR_set(TARG, 2);
3292 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3293 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3294 *tmps = '\0';
3295 SvUTF8_on(TARG);
3296 }
3297 }
463ee0b2
LW		 3298 XPUSHs(TARG);
3299 RETURN;
3300}
3301
79072805
LW		 3302PP(pp_crypt)
3303{
5f74f29c 3304 dSP; dTARGET;
79072805 3305#ifdef HAS_CRYPT
5f74f29c
JH		 3306 dPOPTOPssrl;
3307 STRLEN n_a;
85c16d83
JH		 3308 STRLEN len;
3309 char *tmps = SvPV(left, len);
2bc69dc4 3310
85c16d83 3311 if (DO_UTF8(left)) {
2bc69dc4 3312 /* If Unicode, try to downgrade.
f2791508
JH		 3313 * If not possible, croak.
3314 * Yes, we made this up. */
3315 SV* tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3316
f2791508 3317 SvUTF8_on(tsv);
2bc69dc4 3318 sv_utf8_downgrade(tsv, FALSE);
f2791508 3319 tmps = SvPVX(tsv);
85c16d83 3320 }
05404ffe
JH		 3321# ifdef USE_ITHREADS
3322# ifdef HAS_CRYPT_R
3323 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3324 /* This should be threadsafe because in ithreads there is only
3325 * one thread per interpreter. If this would not be true,
3326 * we would need a mutex to protect this malloc. */
3327 PL_reentrant_buffer->_crypt_struct_buffer =
3328 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3329#if defined(__GLIBC__) || defined(__EMX__)
3330 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3331 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3332 /* work around glibc-2.2.5 bug */
3333 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3334 }
05404ffe 3335#endif
6ab58e4d 3336 }
05404ffe
JH		 3337# endif /* HAS_CRYPT_R */
3338# endif /* USE_ITHREADS */
5f74f29c 3339# ifdef FCRYPT
2d8e6c8d 3340 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
5f74f29c 3341# else
2d8e6c8d 3342 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
5f74f29c 3343# endif
4808266b
JH		 3344 SETs(TARG);
3345 RETURN;
79072805 3346#else
b13b2135 3347 DIE(aTHX_
79072805
LW		 3348 "The crypt() function is unimplemented due to excessive paranoia.");
3349#endif
79072805
LW		 3350}
3351
3352PP(pp_ucfirst)
3353{
39644a26 3354 dSP;
79072805 3355 SV *sv = TOPs;
a0ed51b3
LW		 3356 register U8 *s;
3357 STRLEN slen;
3358
d104a74c 3359 SvGETMAGIC(sv);
3a2263fe
RGS		 3360 if (DO_UTF8(sv) &&
3361 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3362 UTF8_IS_START(*s)) {
e7ae6809 3363 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
44bc797b
JH		 3364 STRLEN ulen;
3365 STRLEN tculen;
a0ed51b3 3366
44bc797b 3367 utf8_to_uvchr(s, &ulen);
44bc797b
JH		 3368 toTITLE_utf8(s, tmpbuf, &tculen);
3369 utf8_to_uvchr(tmpbuf, 0);
3370
3371 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
a0ed51b3 3372 dTARGET;
3a2263fe
RGS		 3373 /* slen is the byte length of the whole SV.
3374 * ulen is the byte length of the original Unicode character
3375 * stored as UTF-8 at s.
3376 * tculen is the byte length of the freshly titlecased
3377 * Unicode character stored as UTF-8 at tmpbuf.
3378 * We first set the result to be the titlecased character,
3379 * and then append the rest of the SV data. */
44bc797b 3380 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3a2263fe
RGS		 3381 if (slen > ulen)
3382 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3383 SvUTF8_on(TARG);
a0ed51b3
LW		 3384 SETs(TARG);
3385 }
3386 else {
d104a74c 3387 s = (U8*)SvPV_force_nomg(sv, slen);
44bc797b 3388 Copy(tmpbuf, s, tculen, U8);
a0ed51b3 3389 }
a0ed51b3 3390 }
626727d5 3391 else {
014822e4 3392 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3393 dTARGET;
7e2040f0 3394 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3395 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3396 sv = TARG;
3397 SETs(sv);
3398 }
d104a74c 3399 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3400 if (*s) {
2de3dbcc 3401 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3402 TAINT;
3403 SvTAINTED_on(sv);
3404 *s = toUPPER_LC(*s);
3405 }
3406 else
3407 *s = toUPPER(*s);
bbce6d69 3408 }
bbce6d69 3409 }
d104a74c 3410 SvSETMAGIC(sv);
79072805
LW		 3411 RETURN;
3412}
3413
3414PP(pp_lcfirst)
3415{
39644a26 3416 dSP;
79072805 3417 SV *sv = TOPs;
a0ed51b3
LW		 3418 register U8 *s;
3419 STRLEN slen;
3420
d104a74c 3421 SvGETMAGIC(sv);
3a2263fe
RGS		 3422 if (DO_UTF8(sv) &&
3423 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3424 UTF8_IS_START(*s)) {
ba210ebe 3425 STRLEN ulen;
e7ae6809 3426 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3427 U8 *tend;
9041c2e3 3428 UV uv;
a0ed51b3 3429
44bc797b 3430 toLOWER_utf8(s, tmpbuf, &ulen);
a2a2844f 3431 uv = utf8_to_uvchr(tmpbuf, 0);
9041c2e3 3432 tend = uvchr_to_utf8(tmpbuf, uv);
a0ed51b3 3433
eb160463 3434 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
a0ed51b3 3435 dTARGET;
dfe13c55 3436 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3a2263fe
RGS		 3437 if (slen > ulen)
3438 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3439 SvUTF8_on(TARG);
a0ed51b3
LW		 3440 SETs(TARG);
3441 }
3442 else {
d104a74c 3443 s = (U8*)SvPV_force_nomg(sv, slen);
a0ed51b3
LW		 3444 Copy(tmpbuf, s, ulen, U8);
3445 }
a0ed51b3 3446 }
626727d5 3447 else {
014822e4 3448 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3449 dTARGET;
7e2040f0 3450 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3451 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3452 sv = TARG;
3453 SETs(sv);
3454 }
d104a74c 3455 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3456 if (*s) {
2de3dbcc 3457 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3458 TAINT;
3459 SvTAINTED_on(sv);
3460 *s = toLOWER_LC(*s);
3461 }
3462 else
3463 *s = toLOWER(*s);
bbce6d69 3464 }
bbce6d69 3465 }
d104a74c 3466 SvSETMAGIC(sv);
79072805
LW		 3467 RETURN;
3468}
3469
3470PP(pp_uc)
3471{
39644a26 3472 dSP;
79072805 3473 SV *sv = TOPs;
a0ed51b3 3474 register U8 *s;
463ee0b2 3475 STRLEN len;
79072805 3476
d104a74c 3477 SvGETMAGIC(sv);
7e2040f0 3478 if (DO_UTF8(sv)) {
a0ed51b3 3479 dTARGET;
ba210ebe 3480 STRLEN ulen;
a0ed51b3
LW		 3481 register U8 *d;
3482 U8 *send;
e7ae6809 3483 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3484
d104a74c 3485 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3486 if (!len) {
7e2040f0 3487 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3488 sv_setpvn(TARG, "", 0);
3489 SETs(TARG);
a0ed51b3
LW		 3490 }
3491 else {
98b27f73
JH		 3492 STRLEN nchar = utf8_length(s, s + len);
3493
31351b04 3494 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3495 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3496 (void)SvPOK_only(TARG);
3497 d = (U8*)SvPVX(TARG);
3498 send = s + len;
a2a2844f 3499 while (s < send) {
6fdb5f96 3500 toUPPER_utf8(s, tmpbuf, &ulen);
a2a2844f
JH		 3501 Copy(tmpbuf, d, ulen, U8);
3502 d += ulen;
3503 s += UTF8SKIP(s);
a0ed51b3 3504 }
31351b04 3505 *d = '\0';
7e2040f0 3506 SvUTF8_on(TARG);
31351b04
JS		 3507 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3508 SETs(TARG);
a0ed51b3 3509 }
a0ed51b3 3510 }
626727d5 3511 else {
014822e4 3512 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3513 dTARGET;
7e2040f0 3514 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3515 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3516 sv = TARG;
3517 SETs(sv);
3518 }
d104a74c 3519 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3520 if (len) {
3521 register U8 *send = s + len;
3522
2de3dbcc 3523 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3524 TAINT;
3525 SvTAINTED_on(sv);
3526 for (; s < send; s++)
3527 *s = toUPPER_LC(*s);
3528 }
3529 else {
3530 for (; s < send; s++)
3531 *s = toUPPER(*s);
3532 }
bbce6d69 3533 }
79072805 3534 }
d104a74c 3535 SvSETMAGIC(sv);
79072805
LW		 3536 RETURN;
3537}
3538
3539PP(pp_lc)
3540{
39644a26 3541 dSP;
79072805 3542 SV *sv = TOPs;
a0ed51b3 3543 register U8 *s;
463ee0b2 3544 STRLEN len;
79072805 3545
d104a74c 3546 SvGETMAGIC(sv);
7e2040f0 3547 if (DO_UTF8(sv)) {
a0ed51b3 3548 dTARGET;
ba210ebe 3549 STRLEN ulen;
a0ed51b3
LW		 3550 register U8 *d;
3551 U8 *send;
e7ae6809 3552 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3553
d104a74c 3554 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3555 if (!len) {
7e2040f0 3556 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3557 sv_setpvn(TARG, "", 0);
3558 SETs(TARG);
a0ed51b3
LW		 3559 }
3560 else {
98b27f73
JH		 3561 STRLEN nchar = utf8_length(s, s + len);
3562
31351b04 3563 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3564 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3565 (void)SvPOK_only(TARG);
3566 d = (U8*)SvPVX(TARG);
3567 send = s + len;
a2a2844f 3568 while (s < send) {
6fdb5f96
JH		 3569 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3570#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3571 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3572 /*
3573 * Now if the sigma is NOT followed by
3574 * /$ignorable_sequence$cased_letter/;
3575 * and it IS preceded by
3576 * /$cased_letter$ignorable_sequence/;
3577 * where $ignorable_sequence is
3578 * [\x{2010}\x{AD}\p{Mn}]*
3579 * and $cased_letter is
3580 * [\p{Ll}\p{Lo}\p{Lt}]
3581 * then it should be mapped to 0x03C2,
3582 * (GREEK SMALL LETTER FINAL SIGMA),
3583 * instead of staying 0x03A3.
3584 * See lib/unicore/SpecCase.txt.
3585 */
3586 }
a2a2844f
JH		 3587 Copy(tmpbuf, d, ulen, U8);
3588 d += ulen;
3589 s += UTF8SKIP(s);
a0ed51b3 3590 }
31351b04 3591 *d = '\0';
7e2040f0 3592 SvUTF8_on(TARG);
31351b04
JS		 3593 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3594 SETs(TARG);
a0ed51b3 3595 }
79072805 3596 }
626727d5 3597 else {
014822e4 3598 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3599 dTARGET;
7e2040f0 3600 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3601 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3602 sv = TARG;
3603 SETs(sv);
a0ed51b3 3604 }
bbce6d69 3605
d104a74c 3606 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3607 if (len) {
3608 register U8 *send = s + len;
bbce6d69 3609
2de3dbcc 3610 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3611 TAINT;
3612 SvTAINTED_on(sv);
3613 for (; s < send; s++)
3614 *s = toLOWER_LC(*s);
3615 }
3616 else {
3617 for (; s < send; s++)
3618 *s = toLOWER(*s);
3619 }
bbce6d69 3620 }
79072805 3621 }
d104a74c 3622 SvSETMAGIC(sv);
79072805
LW		 3623 RETURN;
3624}
3625
a0d0e21e 3626PP(pp_quotemeta)
79072805 3627{
39644a26 3628 dSP; dTARGET;
a0d0e21e
LW		 3629 SV *sv = TOPs;
3630 STRLEN len;
3631 register char *s = SvPV(sv,len);
3632 register char *d;
79072805 3633
7e2040f0 3634 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW		 3635 if (len) {
3636 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 3637 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3638 d = SvPVX(TARG);
7e2040f0 3639 if (DO_UTF8(sv)) {
0dd2cdef 3640 while (len) {
fd400ab9 3641 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 3642 STRLEN ulen = UTF8SKIP(s);
3643 if (ulen > len)
3644 ulen = len;
3645 len -= ulen;
3646 while (ulen--)
3647 *d++ = *s++;
3648 }
3649 else {
3650 if (!isALNUM(*s))
3651 *d++ = '\\';
3652 *d++ = *s++;
3653 len--;
3654 }
3655 }
7e2040f0 3656 SvUTF8_on(TARG);
0dd2cdef
LW		 3657 }
3658 else {
3659 while (len--) {
3660 if (!isALNUM(*s))
3661 *d++ = '\\';
3662 *d++ = *s++;
3663 }
79072805 3664 }
a0d0e21e
LW		 3665 *d = '\0';
3666 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 3667 (void)SvPOK_only_UTF8(TARG);
79072805 3668 }
a0d0e21e
LW		 3669 else
3670 sv_setpvn(TARG, s, len);
3671 SETs(TARG);
31351b04
JS		 3672 if (SvSMAGICAL(TARG))
3673 mg_set(TARG);
79072805
LW		 3674 RETURN;
3675}
3676
a0d0e21e 3677/* Arrays. */
79072805 3678
a0d0e21e 3679PP(pp_aslice)
79072805 3680{
39644a26 3681 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3682 register SV** svp;
3683 register AV* av = (AV*)POPs;
78f9721b 3684 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3280af22 3685 I32 arybase = PL_curcop->cop_arybase;
748a9306 3686 I32 elem;
79072805 3687
a0d0e21e 3688 if (SvTYPE(av) == SVt_PVAV) {
533c011a 3689 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 3690 I32 max = -1;
924508f0 3691 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 3692 elem = SvIVx(*svp);
3693 if (elem > max)
3694 max = elem;
3695 }
3696 if (max > AvMAX(av))
3697 av_extend(av, max);
3698 }
a0d0e21e 3699 while (++MARK <= SP) {
748a9306 3700 elem = SvIVx(*MARK);
a0d0e21e 3701
748a9306
LW		 3702 if (elem > 0)
3703 elem -= arybase;
a0d0e21e
LW		 3704 svp = av_fetch(av, elem, lval);
3705 if (lval) {
3280af22 3706 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 3707 DIE(aTHX_ PL_no_aelem, elem);
533c011a 3708 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 3709 save_aelem(av, elem, svp);
79072805 3710 }
3280af22 3711 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 3712 }
3713 }
748a9306 3714 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 3715 MARK = ORIGMARK;
3716 *++MARK = *SP;
3717 SP = MARK;
3718 }
79072805
LW		 3719 RETURN;
3720}
3721
3722/* Associative arrays. */
3723
3724PP(pp_each)
3725{
39644a26 3726 dSP;
79072805 3727 HV *hash = (HV*)POPs;
c07a80fd 3728 HE *entry;
54310121 3729 I32 gimme = GIMME_V;
8ec5e241 3730
c07a80fd 3731 PUTBACK;
c750a3ec 3732 /* might clobber stack_sp */
6d822dc4 3733 entry = hv_iternext(hash);
c07a80fd 3734 SPAGAIN;
79072805 3735
79072805
LW		 3736 EXTEND(SP, 2);
3737 if (entry) {
574c8022 3738 SV* sv = hv_iterkeysv(entry);
574c8022 3739 PUSHs(sv); /* won't clobber stack_sp */
54310121 3740 if (gimme == G_ARRAY) {
59af0135 3741 SV *val;
c07a80fd 3742 PUTBACK;
c750a3ec 3743 /* might clobber stack_sp */
6d822dc4 3744 val = hv_iterval(hash, entry);
c07a80fd 3745 SPAGAIN;
59af0135 3746 PUSHs(val);
79072805 3747 }
79072805 3748 }
54310121 3749 else if (gimme == G_SCALAR)
79072805
LW		 3750 RETPUSHUNDEF;
3751
3752 RETURN;
3753}
3754
3755PP(pp_values)
3756{
cea2e8a9 3757 return do_kv();
79072805
LW		 3758}
3759
3760PP(pp_keys)
3761{
cea2e8a9 3762 return do_kv();
79072805
LW		 3763}
3764
3765PP(pp_delete)
3766{
39644a26 3767 dSP;
54310121 3768 I32 gimme = GIMME_V;
3769 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 3770 SV *sv;
5f05dabc 3771 HV *hv;
3772
533c011a 3773 if (PL_op->op_private & OPpSLICE) {
5f05dabc 3774 dMARK; dORIGMARK;
97fcbf96 3775 U32 hvtype;
5f05dabc 3776 hv = (HV*)POPs;
97fcbf96 3777 hvtype = SvTYPE(hv);
01020589
GS		 3778 if (hvtype == SVt_PVHV) { /* hash element */
3779 while (++MARK <= SP) {
ae77835f 3780 sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 3781 *MARK = sv ? sv : &PL_sv_undef;
3782 }
5f05dabc 3783 }
6d822dc4
MS		 3784 else if (hvtype == SVt_PVAV) { /* array element */
3785 if (PL_op->op_flags & OPf_SPECIAL) {
3786 while (++MARK <= SP) {
3787 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3788 *MARK = sv ? sv : &PL_sv_undef;
3789 }
3790 }
01020589
GS		 3791 }
3792 else
3793 DIE(aTHX_ "Not a HASH reference");
54310121 3794 if (discard)
3795 SP = ORIGMARK;
3796 else if (gimme == G_SCALAR) {
5f05dabc 3797 MARK = ORIGMARK;
3798 *++MARK = *SP;
3799 SP = MARK;
3800 }
3801 }
3802 else {
3803 SV *keysv = POPs;
3804 hv = (HV*)POPs;
97fcbf96
MB		 3805 if (SvTYPE(hv) == SVt_PVHV)
3806 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 3807 else if (SvTYPE(hv) == SVt_PVAV) {
3808 if (PL_op->op_flags & OPf_SPECIAL)
3809 sv = av_delete((AV*)hv, SvIV(keysv), discard);
af288a60
HS		 3810 else
3811 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 3812 }
97fcbf96 3813 else
cea2e8a9 3814 DIE(aTHX_ "Not a HASH reference");
5f05dabc 3815 if (!sv)
3280af22 3816 sv = &PL_sv_undef;
54310121 3817 if (!discard)
3818 PUSHs(sv);
79072805 3819 }
79072805
LW		 3820 RETURN;
3821}
3822
a0d0e21e 3823PP(pp_exists)
79072805 3824{
39644a26 3825 dSP;
afebc493
GS		 3826 SV *tmpsv;
3827 HV *hv;
3828
3829 if (PL_op->op_private & OPpEXISTS_SUB) {
3830 GV *gv;
3831 CV *cv;
3832 SV *sv = POPs;
3833 cv = sv_2cv(sv, &hv, &gv, FALSE);
3834 if (cv)
3835 RETPUSHYES;
3836 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3837 RETPUSHYES;
3838 RETPUSHNO;
3839 }
3840 tmpsv = POPs;
3841 hv = (HV*)POPs;
c750a3ec 3842 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 3843 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 3844 RETPUSHYES;
ef54e1a4
JH		 3845 }
3846 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS		 3847 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3848 if (av_exists((AV*)hv, SvIV(tmpsv)))
3849 RETPUSHYES;
3850 }
ef54e1a4
JH		 3851 }
3852 else {
cea2e8a9 3853 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 3854 }
a0d0e21e
LW		 3855 RETPUSHNO;
3856}
79072805 3857
a0d0e21e
LW		 3858PP(pp_hslice)
3859{
39644a26 3860 dSP; dMARK; dORIGMARK;
a0d0e21e 3861 register HV *hv = (HV*)POPs;
78f9721b 3862 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
eb85dfd3
DM		 3863 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3864 bool other_magic = FALSE;
79072805 3865
eb85dfd3
DM		 3866 if (localizing) {
3867 MAGIC *mg;
3868 HV *stash;
3869
3870 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3871 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3872 /* Try to preserve the existenceness of a tied hash
3873 * element by using EXISTS and DELETE if possible.
3874 * Fallback to FETCH and STORE otherwise */
3875 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3876 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3877 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3878 }
3879
6d822dc4
MS		 3880 while (++MARK <= SP) {
3881 SV *keysv = *MARK;
3882 SV **svp;
3883 HE *he;
3884 bool preeminent = FALSE;
0ebe0038 3885
6d822dc4
MS		 3886 if (localizing) {
3887 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3888 hv_exists_ent(hv, keysv, 0);
3889 }
eb85dfd3 3890
6d822dc4
MS		 3891 he = hv_fetch_ent(hv, keysv, lval, 0);
3892 svp = he ? &HeVAL(he) : 0;
eb85dfd3 3893
6d822dc4
MS		 3894 if (lval) {
3895 if (!svp || *svp == &PL_sv_undef) {
3896 STRLEN n_a;
3897 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3898 }
3899 if (localizing) {
3900 if (preeminent)
3901 save_helem(hv, keysv, svp);
3902 else {
3903 STRLEN keylen;
3904 char *key = SvPV(keysv, keylen);
3905 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1f5346dc 3906 }
6d822dc4
MS		 3907 }
3908 }
3909 *MARK = svp ? *svp : &PL_sv_undef;
79072805 3910 }
a0d0e21e
LW		 3911 if (GIMME != G_ARRAY) {
3912 MARK = ORIGMARK;
3913 *++MARK = *SP;
3914 SP = MARK;
79072805 3915 }
a0d0e21e
LW		 3916 RETURN;
3917}
3918
3919/* List operators. */
3920
3921PP(pp_list)
3922{
39644a26 3923 dSP; dMARK;
a0d0e21e
LW		 3924 if (GIMME != G_ARRAY) {
3925 if (++MARK <= SP)
3926 *MARK = *SP; /* unwanted list, return last item */
8990e307 3927 else
3280af22 3928 *MARK = &PL_sv_undef;
a0d0e21e 3929 SP = MARK;
79072805 3930 }
a0d0e21e 3931 RETURN;
79072805
LW		 3932}
3933
a0d0e21e 3934PP(pp_lslice)
79072805 3935{
39644a26 3936 dSP;
3280af22
NIS		 3937 SV **lastrelem = PL_stack_sp;
3938 SV **lastlelem = PL_stack_base + POPMARK;
3939 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 3940 register SV **firstrelem = lastlelem + 1;
3280af22 3941 I32 arybase = PL_curcop->cop_arybase;
533c011a 3942 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 3943 I32 is_something_there = lval;
79072805 3944
a0d0e21e
LW		 3945 register I32 max = lastrelem - lastlelem;
3946 register SV **lelem;
3947 register I32 ix;
3948
3949 if (GIMME != G_ARRAY) {
748a9306
LW		 3950 ix = SvIVx(*lastlelem);
3951 if (ix < 0)
3952 ix += max;
3953 else
3954 ix -= arybase;
a0d0e21e 3955 if (ix < 0 || ix >= max)
3280af22 3956 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 3957 else
3958 *firstlelem = firstrelem[ix];
3959 SP = firstlelem;
3960 RETURN;
3961 }
3962
3963 if (max == 0) {
3964 SP = firstlelem - 1;
3965 RETURN;
3966 }
3967
3968 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 3969 ix = SvIVx(*lelem);
c73bf8e3 3970 if (ix < 0)
a0d0e21e 3971 ix += max;
b13b2135 3972 else
748a9306 3973 ix -= arybase;
c73bf8e3
HS		 3974 if (ix < 0 || ix >= max)
3975 *lelem = &PL_sv_undef;
3976 else {
3977 is_something_there = TRUE;
3978 if (!(*lelem = firstrelem[ix]))
3280af22 3979 *lelem = &PL_sv_undef;
748a9306 3980 }
79072805 3981 }
4633a7c4
LW		 3982 if (is_something_there)
3983 SP = lastlelem;
3984 else
3985 SP = firstlelem - 1;
79072805
LW		 3986 RETURN;
3987}
3988
a0d0e21e
LW		 3989PP(pp_anonlist)
3990{
39644a26 3991 dSP; dMARK; dORIGMARK;
a0d0e21e 3992 I32 items = SP - MARK;
44a8e56a 3993 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3994 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3995 XPUSHs(av);
a0d0e21e
LW		 3996 RETURN;
3997}
3998
3999PP(pp_anonhash)
79072805 4000{
39644a26 4001 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 4002 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4003
4004 while (MARK < SP) {
4005 SV* key = *++MARK;
a0d0e21e
LW		 4006 SV *val = NEWSV(46, 0);
4007 if (MARK < SP)
4008 sv_setsv(val, *++MARK);
e476b1b5 4009 else if (ckWARN(WARN_MISC))
9014280d 4010 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
f12c7020 4011 (void)hv_store_ent(hv,key,val,0);
79072805 4012 }
a0d0e21e
LW		 4013 SP = ORIGMARK;
4014 XPUSHs((SV*)hv);
79072805
LW		 4015 RETURN;
4016}
4017
a0d0e21e 4018PP(pp_splice)
79072805 4019{
39644a26 4020 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 4021 register AV *ary = (AV*)*++MARK;
4022 register SV **src;
4023 register SV **dst;
4024 register I32 i;
4025 register I32 offset;
4026 register I32 length;
4027 I32 newlen;
4028 I32 after;
4029 I32 diff;
4030 SV **tmparyval = 0;
93965878
NIS		 4031 MAGIC *mg;
4032
14befaf4 4033 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4034 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 4035 PUSHMARK(MARK);
8ec5e241 4036 PUTBACK;
a60c0954 4037 ENTER;
864dbfa3 4038 call_method("SPLICE",GIMME_V);
a60c0954 4039 LEAVE;
93965878
NIS		 4040 SPAGAIN;
4041 RETURN;
4042 }
79072805 4043
a0d0e21e 4044 SP++;
79072805 4045
a0d0e21e 4046 if (++MARK < SP) {
84902520 4047 offset = i = SvIVx(*MARK);
a0d0e21e 4048 if (offset < 0)
93965878 4049 offset += AvFILLp(ary) + 1;
a0d0e21e 4050 else
3280af22 4051 offset -= PL_curcop->cop_arybase;
84902520 4052 if (offset < 0)
cea2e8a9 4053 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 4054 if (++MARK < SP) {
4055 length = SvIVx(*MARK++);
48cdf507
GA		 4056 if (length < 0) {
4057 length += AvFILLp(ary) - offset + 1;
4058 if (length < 0)
4059 length = 0;
4060 }
79072805
LW		 4061 }
4062 else
a0d0e21e 4063 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 4064 }
a0d0e21e
LW		 4065 else {
4066 offset = 0;
4067 length = AvMAX(ary) + 1;
4068 }
8cbc2e3b
JH		 4069 if (offset > AvFILLp(ary) + 1) {
4070 if (ckWARN(WARN_MISC))
9014280d 4071 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 4072 offset = AvFILLp(ary) + 1;
8cbc2e3b 4073 }
93965878 4074 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 4075 if (after < 0) { /* not that much array */
4076 length += after; /* offset+length now in array */
4077 after = 0;
4078 if (!AvALLOC(ary))
4079 av_extend(ary, 0);
4080 }
4081
4082 /* At this point, MARK .. SP-1 is our new LIST */
4083
4084 newlen = SP - MARK;
4085 diff = newlen - length;
13d7cbc1
GS		 4086 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4087 av_reify(ary);
a0d0e21e
LW		 4088
4089 if (diff < 0) { /* shrinking the area */
4090 if (newlen) {
4091 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4092 Copy(MARK, tmparyval, newlen, SV*);
79072805 4093 }
a0d0e21e
LW		 4094
4095 MARK = ORIGMARK + 1;
4096 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4097 MEXTEND(MARK, length);
4098 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4099 if (AvREAL(ary)) {
bbce6d69 4100 EXTEND_MORTAL(length);
36477c24 4101 for (i = length, dst = MARK; i; i--) {
d689ffdd 4102 sv_2mortal(*dst); /* free them eventualy */
36477c24 4103 dst++;
4104 }
a0d0e21e
LW		 4105 }
4106 MARK += length - 1;
79072805 4107 }
a0d0e21e
LW		 4108 else {
4109 *MARK = AvARRAY(ary)[offset+length-1];
4110 if (AvREAL(ary)) {
d689ffdd 4111 sv_2mortal(*MARK);
a0d0e21e
LW		 4112 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4113 SvREFCNT_dec(*dst++); /* free them now */
79072805 4114 }
a0d0e21e 4115 }
93965878 4116 AvFILLp(ary) += diff;
a0d0e21e
LW		 4117
4118 /* pull up or down? */
4119
4120 if (offset < after) { /* easier to pull up */
4121 if (offset) { /* esp. if nothing to pull */
4122 src = &AvARRAY(ary)[offset-1];
4123 dst = src - diff; /* diff is negative */
4124 for (i = offset; i > 0; i--) /* can't trust Copy */
4125 *dst-- = *src--;
79072805 4126 }
a0d0e21e
LW		 4127 dst = AvARRAY(ary);
4128 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4129 AvMAX(ary) += diff;
4130 }
4131 else {
4132 if (after) { /* anything to pull down? */
4133 src = AvARRAY(ary) + offset + length;
4134 dst = src + diff; /* diff is negative */
4135 Move(src, dst, after, SV*);
79072805 4136 }
93965878 4137 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 4138 /* avoid later double free */
4139 }
4140 i = -diff;
4141 while (i)
3280af22 4142 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 4143
4144 if (newlen) {
4145 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4146 newlen; newlen--) {
4147 *dst = NEWSV(46, 0);
4148 sv_setsv(*dst++, *src++);
79072805 4149 }
a0d0e21e
LW		 4150 Safefree(tmparyval);
4151 }
4152 }
4153 else { /* no, expanding (or same) */
4154 if (length) {
4155 New(452, tmparyval, length, SV*); /* so remember deletion */
4156 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4157 }
4158
4159 if (diff > 0) { /* expanding */
4160
4161 /* push up or down? */
4162
4163 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4164 if (offset) {
4165 src = AvARRAY(ary);
4166 dst = src - diff;
4167 Move(src, dst, offset, SV*);
79072805 4168 }
a0d0e21e
LW		 4169 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4170 AvMAX(ary) += diff;
93965878 4171 AvFILLp(ary) += diff;
79072805
LW		 4172 }
4173 else {
93965878
NIS		 4174 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4175 av_extend(ary, AvFILLp(ary) + diff);
4176 AvFILLp(ary) += diff;
a0d0e21e
LW		 4177
4178 if (after) {
93965878 4179 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 4180 src = dst - diff;
4181 for (i = after; i; i--) {
4182 *dst-- = *src--;
4183 }
79072805
LW		 4184 }
4185 }
a0d0e21e
LW		 4186 }
4187
4188 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4189 *dst = NEWSV(46, 0);
4190 sv_setsv(*dst++, *src++);
4191 }
4192 MARK = ORIGMARK + 1;
4193 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4194 if (length) {
4195 Copy(tmparyval, MARK, length, SV*);
4196 if (AvREAL(ary)) {
bbce6d69 4197 EXTEND_MORTAL(length);
36477c24 4198 for (i = length, dst = MARK; i; i--) {
d689ffdd 4199 sv_2mortal(*dst); /* free them eventualy */
36477c24 4200 dst++;
4201 }
79072805 4202 }
a0d0e21e 4203 Safefree(tmparyval);
79072805 4204 }
a0d0e21e
LW		 4205 MARK += length - 1;
4206 }
4207 else if (length--) {
4208 *MARK = tmparyval[length];
4209 if (AvREAL(ary)) {
d689ffdd 4210 sv_2mortal(*MARK);
a0d0e21e
LW		 4211 while (length-- > 0)
4212 SvREFCNT_dec(tmparyval[length]);
79072805 4213 }
a0d0e21e 4214 Safefree(tmparyval);
79072805 4215 }
a0d0e21e 4216 else
3280af22 4217 *MARK = &PL_sv_undef;
79072805 4218 }
a0d0e21e 4219 SP = MARK;
79072805
LW		 4220 RETURN;
4221}
4222
a0d0e21e 4223PP(pp_push)
79072805 4224{
39644a26 4225 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4226 register AV *ary = (AV*)*++MARK;
3280af22 4227 register SV *sv = &PL_sv_undef;
93965878 4228 MAGIC *mg;
79072805 4229
14befaf4 4230 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4231 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS		 4232 PUSHMARK(MARK);
4233 PUTBACK;
a60c0954 4234 ENTER;
864dbfa3 4235 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 4236 LEAVE;
93965878 4237 SPAGAIN;
93965878 4238 }
a60c0954
NIS		 4239 else {
4240 /* Why no pre-extend of ary here ? */
4241 for (++MARK; MARK <= SP; MARK++) {
4242 sv = NEWSV(51, 0);
4243 if (*MARK)
4244 sv_setsv(sv, *MARK);
4245 av_push(ary, sv);
4246 }
79072805
LW		 4247 }
4248 SP = ORIGMARK;
a0d0e21e 4249 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 4250 RETURN;
4251}
4252
a0d0e21e 4253PP(pp_pop)
79072805 4254{
39644a26 4255 dSP;
a0d0e21e
LW		 4256 AV *av = (AV*)POPs;
4257 SV *sv = av_pop(av);
d689ffdd 4258 if (AvREAL(av))
a0d0e21e
LW		 4259 (void)sv_2mortal(sv);
4260 PUSHs(sv);
79072805 4261 RETURN;
79072805
LW		 4262}
4263
a0d0e21e 4264PP(pp_shift)
79072805 4265{
39644a26 4266 dSP;
a0d0e21e
LW		 4267 AV *av = (AV*)POPs;
4268 SV *sv = av_shift(av);
79072805 4269 EXTEND(SP, 1);
a0d0e21e 4270 if (!sv)
79072805 4271 RETPUSHUNDEF;
d689ffdd 4272 if (AvREAL(av))
a0d0e21e
LW		 4273 (void)sv_2mortal(sv);
4274 PUSHs(sv);
79072805 4275 RETURN;
79072805
LW		 4276}
4277
a0d0e21e 4278PP(pp_unshift)
79072805 4279{
39644a26 4280 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4281 register AV *ary = (AV*)*++MARK;
4282 register SV *sv;
4283 register I32 i = 0;
93965878
NIS		 4284 MAGIC *mg;
4285
14befaf4 4286 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4287 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 4288 PUSHMARK(MARK);
93965878 4289 PUTBACK;
a60c0954 4290 ENTER;
864dbfa3 4291 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 4292 LEAVE;
93965878 4293 SPAGAIN;
93965878 4294 }
a60c0954
NIS		 4295 else {
4296 av_unshift(ary, SP - MARK);
4297 while (MARK < SP) {
4298 sv = NEWSV(27, 0);
4299 sv_setsv(sv, *++MARK);
4300 (void)av_store(ary, i++, sv);
4301 }
79072805 4302 }
a0d0e21e
LW		 4303 SP = ORIGMARK;
4304 PUSHi( AvFILL(ary) + 1 );
79072805 4305 RETURN;
79072805
LW		 4306}
4307
a0d0e21e 4308PP(pp_reverse)
79072805 4309{
39644a26 4310 dSP; dMARK;
a0d0e21e
LW		 4311 register SV *tmp;
4312 SV **oldsp = SP;
79072805 4313
a0d0e21e
LW		 4314 if (GIMME == G_ARRAY) {
4315 MARK++;
4316 while (MARK < SP) {
4317 tmp = *MARK;
4318 *MARK++ = *SP;
4319 *SP-- = tmp;
4320 }
dd58a1ab 4321 /* safe as long as stack cannot get extended in the above */
a0d0e21e 4322 SP = oldsp;
79072805
LW		 4323 }
4324 else {
a0d0e21e
LW		 4325 register char *up;
4326 register char *down;
4327 register I32 tmp;
4328 dTARGET;
4329 STRLEN len;
79072805 4330
7e2040f0 4331 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4332 if (SP - MARK > 1)
3280af22 4333 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 4334 else
54b9620d 4335 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW		 4336 up = SvPV_force(TARG, len);
4337 if (len > 1) {
7e2040f0 4338 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55
GS		 4339 U8* s = (U8*)SvPVX(TARG);
4340 U8* send = (U8*)(s + len);
a0ed51b3 4341 while (s < send) {
d742c382 4342 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 4343 s++;
4344 continue;
4345 }
4346 else {
9041c2e3 4347 if (!utf8_to_uvchr(s, 0))
a0dbb045 4348 break;
dfe13c55 4349 up = (char*)s;
a0ed51b3 4350 s += UTF8SKIP(s);
dfe13c55 4351 down = (char*)(s - 1);
a0dbb045 4352 /* reverse this character */
a0ed51b3
LW		 4353 while (down > up) {
4354 tmp = *up;
4355 *up++ = *down;
eb160463 4356 *down-- = (char)tmp;
a0ed51b3
LW		 4357 }
4358 }
4359 }
4360 up = SvPVX(TARG);
4361 }
a0d0e21e
LW		 4362 down = SvPVX(TARG) + len - 1;
4363 while (down > up) {
4364 tmp = *up;
4365 *up++ = *down;
eb160463 4366 *down-- = (char)tmp;
a0d0e21e 4367 }
3aa33fe5 4368 (void)SvPOK_only_UTF8(TARG);
79072805 4369 }
a0d0e21e
LW		 4370 SP = MARK + 1;
4371 SETTARG;
79072805 4372 }
a0d0e21e 4373 RETURN;
79072805
LW		 4374}
4375
a0d0e21e 4376PP(pp_split)
79072805 4377{
39644a26 4378 dSP; dTARG;
a0d0e21e 4379 AV *ary;
467f0320 4380 register IV limit = POPi; /* note, negative is forever */
a0d0e21e
LW		 4381 SV *sv = POPs;
4382 STRLEN len;
4383 register char *s = SvPV(sv, len);
1aa99e6b 4384 bool do_utf8 = DO_UTF8(sv);
a0d0e21e 4385 char *strend = s + len;
44a8e56a 4386 register PMOP *pm;
d9f97599 4387 register REGEXP *rx;
a0d0e21e
LW		 4388 register SV *dstr;
4389 register char *m;
4390 I32 iters = 0;
792b2c16
JH		 4391 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4392 I32 maxiters = slen + 10;
a0d0e21e
LW		 4393 I32 i;
4394 char *orig;
4395 I32 origlimit = limit;
4396 I32 realarray = 0;
4397 I32 base;
3280af22 4398 AV *oldstack = PL_curstack;
54310121 4399 I32 gimme = GIMME_V;
3280af22 4400 I32 oldsave = PL_savestack_ix;
8ec5e241
NIS		 4401 I32 make_mortal = 1;
4402 MAGIC *mg = (MAGIC *) NULL;
79072805 4403
44a8e56a 4404#ifdef DEBUGGING
4405 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4406#else
4407 pm = (PMOP*)POPs;
4408#endif
a0d0e21e 4409 if (!pm || !s)
2269b42e 4410 DIE(aTHX_ "panic: pp_split");
aaa362c4 4411 rx = PM_GETRE(pm);
bbce6d69 4412
4413 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4414 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4415
a30b2f1f 4416 RX_MATCH_UTF8_set(rx, do_utf8);
d9f424b2 4417
971a9dd3
GS		 4418 if (pm->op_pmreplroot) {
4419#ifdef USE_ITHREADS
dd2155a4 4420 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
971a9dd3 4421#else
a0d0e21e 4422 ary = GvAVn((GV*)pm->op_pmreplroot);
971a9dd3
GS		 4423#endif
4424 }
a0d0e21e 4425 else if (gimme != G_ARRAY)
3280af22 4426 ary = GvAVn(PL_defgv);
79072805 4427 else
a0d0e21e
LW		 4428 ary = Nullav;
4429 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4430 realarray = 1;
8ec5e241 4431 PUTBACK;
a0d0e21e
LW		 4432 av_extend(ary,0);
4433 av_clear(ary);
8ec5e241 4434 SPAGAIN;
14befaf4 4435 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
8ec5e241 4436 PUSHMARK(SP);
33c27489 4437 XPUSHs(SvTIED_obj((SV*)ary, mg));
8ec5e241
NIS		 4438 }
4439 else {
1c0b011c
NIS		 4440 if (!AvREAL(ary)) {
4441 AvREAL_on(ary);
abff13bb 4442 AvREIFY_off(ary);
1c0b011c 4443 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 4444 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 4445 }
4446 /* temporarily switch stacks */
3280af22 4447 SWITCHSTACK(PL_curstack, ary);
3b0d546b 4448 PL_curstackinfo->si_stack = ary;
8ec5e241 4449 make_mortal = 0;
1c0b011c 4450 }
79072805 4451 }
3280af22 4452 base = SP - PL_stack_base;
a0d0e21e
LW		 4453 orig = s;
4454 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 4455 if (pm->op_pmflags & PMf_LOCALE) {
4456 while (isSPACE_LC(*s))
4457 s++;
4458 }
4459 else {
4460 while (isSPACE(*s))
4461 s++;
4462 }
a0d0e21e 4463 }
e8f49695 4464 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
3280af22
NIS		 4465 SAVEINT(PL_multiline);
4466 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
c07a80fd 4467 }
4468
a0d0e21e
LW		 4469 if (!limit)
4470 limit = maxiters + 2;
4471 if (pm->op_pmflags & PMf_WHITE) {
4472 while (--limit) {
bbce6d69 4473 m = s;
4474 while (m < strend &&
4475 !((pm->op_pmflags & PMf_LOCALE)
4476 ? isSPACE_LC(*m) : isSPACE(*m)))
4477 ++m;
a0d0e21e
LW		 4478 if (m >= strend)
4479 break;
bbce6d69 4480
a0d0e21e
LW		 4481 dstr = NEWSV(30, m-s);
4482 sv_setpvn(dstr, s, m-s);
8ec5e241 4483 if (make_mortal)
a0d0e21e 4484 sv_2mortal(dstr);
792b2c16 4485 if (do_utf8)
28cb3359 4486 (void)SvUTF8_on(dstr);
a0d0e21e 4487 XPUSHs(dstr);
bbce6d69 4488
4489 s = m + 1;
4490 while (s < strend &&
4491 ((pm->op_pmflags & PMf_LOCALE)
4492 ? isSPACE_LC(*s) : isSPACE(*s)))
4493 ++s;
79072805
LW		 4494 }
4495 }
f4091fba 4496 else if (strEQ("^", rx->precomp)) {
a0d0e21e
LW		 4497 while (--limit) {
4498 /*SUPPRESS 530*/
4499 for (m = s; m < strend && *m != '\n'; m++) ;
4500 m++;
4501 if (m >= strend)
4502 break;
4503 dstr = NEWSV(30, m-s);
4504 sv_setpvn(dstr, s, m-s);
8ec5e241 4505 if (make_mortal)
a0d0e21e 4506 sv_2mortal(dstr);
792b2c16 4507 if (do_utf8)
28cb3359 4508 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4509 XPUSHs(dstr);
4510 s = m;
4511 }
4512 }
699c3c34
JH		 4513 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4514 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
d9f97599
GS		 4515 && (rx->reganch & ROPT_CHECK_ALL)
4516 && !(rx->reganch & ROPT_ANCH)) {
f722798b
IZ		 4517 int tail = (rx->reganch & RE_INTUIT_TAIL);
4518 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
cf93c79d 4519
ca5b42cb 4520 len = rx->minlen;
1aa99e6b 4521 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
93f04dac
JH		 4522 STRLEN n_a;
4523 char c = *SvPV(csv, n_a);
a0d0e21e 4524 while (--limit) {
bbce6d69 4525 /*SUPPRESS 530*/
f722798b 4526 for (m = s; m < strend && *m != c; m++) ;
a0d0e21e
LW		 4527 if (m >= strend)
4528 break;
4529 dstr = NEWSV(30, m-s);
4530 sv_setpvn(dstr, s, m-s);
8ec5e241 4531 if (make_mortal)
a0d0e21e 4532 sv_2mortal(dstr);
792b2c16 4533 if (do_utf8)
28cb3359 4534 (void)SvUTF8_on(dstr);
a0d0e21e 4535 XPUSHs(dstr);
93f04dac
JH		 4536 /* The rx->minlen is in characters but we want to step
4537 * s ahead by bytes. */
1aa99e6b
IH		 4538 if (do_utf8)
4539 s = (char*)utf8_hop((U8*)m, len);
4540 else
4541 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 4542 }
4543 }
4544 else {
4545#ifndef lint
4546 while (s < strend && --limit &&
f722798b
IZ		 4547 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4548 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
79072805 4549#endif
a0d0e21e
LW		 4550 {
4551 dstr = NEWSV(31, m-s);
4552 sv_setpvn(dstr, s, m-s);
8ec5e241 4553 if (make_mortal)
a0d0e21e 4554 sv_2mortal(dstr);
792b2c16 4555 if (do_utf8)
28cb3359 4556 (void)SvUTF8_on(dstr);
a0d0e21e 4557 XPUSHs(dstr);
93f04dac
JH		 4558 /* The rx->minlen is in characters but we want to step
4559 * s ahead by bytes. */
1aa99e6b
IH		 4560 if (do_utf8)
4561 s = (char*)utf8_hop((U8*)m, len);
4562 else
4563 s = m + len; /* Fake \n at the end */
a0d0e21e 4564 }
463ee0b2 4565 }
463ee0b2 4566 }
a0d0e21e 4567 else {
792b2c16 4568 maxiters += slen * rx->nparens;
080c2dec 4569 while (s < strend && --limit)
bbce6d69 4570 {
080c2dec
AE		 4571 PUTBACK;
4572 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4573 SPAGAIN;
4574 if (i == 0)
4575 break;
d9f97599 4576 TAINT_IF(RX_MATCH_TAINTED(rx));
cf93c79d 4577 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 4578 m = s;
4579 s = orig;
cf93c79d 4580 orig = rx->subbeg;
a0d0e21e
LW		 4581 s = orig + (m - s);
4582 strend = s + (strend - m);
4583 }
cf93c79d 4584 m = rx->startp[0] + orig;
a0d0e21e
LW		 4585 dstr = NEWSV(32, m-s);
4586 sv_setpvn(dstr, s, m-s);
8ec5e241 4587 if (make_mortal)
a0d0e21e 4588 sv_2mortal(dstr);
792b2c16 4589 if (do_utf8)
28cb3359 4590 (void)SvUTF8_on(dstr);
a0d0e21e 4591 XPUSHs(dstr);
d9f97599 4592 if (rx->nparens) {
eb160463 4593 for (i = 1; i <= (I32)rx->nparens; i++) {
cf93c79d
IZ		 4594 s = rx->startp[i] + orig;
4595 m = rx->endp[i] + orig;
6de67870
JP		 4596
4597 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4598 parens that didn't match -- they should be set to
4599 undef, not the empty string */
4600 if (m >= orig && s >= orig) {
748a9306
LW		 4601 dstr = NEWSV(33, m-s);
4602 sv_setpvn(dstr, s, m-s);
4603 }
4604 else
6de67870 4605 dstr = &PL_sv_undef; /* undef, not "" */
8ec5e241 4606 if (make_mortal)
a0d0e21e 4607 sv_2mortal(dstr);
792b2c16 4608 if (do_utf8)
28cb3359 4609 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4610 XPUSHs(dstr);
4611 }
4612 }
cf93c79d 4613 s = rx->endp[0] + orig;
a0d0e21e 4614 }
79072805 4615 }
8ec5e241 4616
c07a80fd 4617 LEAVE_SCOPE(oldsave);
3280af22 4618 iters = (SP - PL_stack_base) - base;
a0d0e21e 4619 if (iters > maxiters)
cea2e8a9 4620 DIE(aTHX_ "Split loop");
8ec5e241 4621
a0d0e21e
LW		 4622 /* keep field after final delim? */
4623 if (s < strend || (iters && origlimit)) {
93f04dac
JH		 4624 STRLEN l = strend - s;
4625 dstr = NEWSV(34, l);
4626 sv_setpvn(dstr, s, l);
8ec5e241 4627 if (make_mortal)
a0d0e21e 4628 sv_2mortal(dstr);
792b2c16 4629 if (do_utf8)
28cb3359 4630 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4631 XPUSHs(dstr);
4632 iters++;
79072805 4633 }
a0d0e21e 4634 else if (!origlimit) {
89900bd3
SR		 4635 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4636 if (TOPs && !make_mortal)
4637 sv_2mortal(TOPs);
4638 iters--;
4639 SP--;
4640 }
a0d0e21e 4641 }
8ec5e241 4642
a0d0e21e 4643 if (realarray) {
8ec5e241 4644 if (!mg) {
1c0b011c 4645 SWITCHSTACK(ary, oldstack);
3b0d546b 4646 PL_curstackinfo->si_stack = oldstack;
1c0b011c
NIS		 4647 if (SvSMAGICAL(ary)) {
4648 PUTBACK;
4649 mg_set((SV*)ary);
4650 SPAGAIN;
4651 }
4652 if (gimme == G_ARRAY) {
4653 EXTEND(SP, iters);
4654 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4655 SP += iters;
4656 RETURN;
4657 }
8ec5e241 4658 }
1c0b011c 4659 else {
fb73857a 4660 PUTBACK;
8ec5e241 4661 ENTER;
864dbfa3 4662 call_method("PUSH",G_SCALAR|G_DISCARD);
8ec5e241 4663 LEAVE;
fb73857a 4664 SPAGAIN;
8ec5e241
NIS		 4665 if (gimme == G_ARRAY) {
4666 /* EXTEND should not be needed - we just popped them */
4667 EXTEND(SP, iters);
4668 for (i=0; i < iters; i++) {
4669 SV **svp = av_fetch(ary, i, FALSE);
3280af22 4670 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 4671 }
1c0b011c
NIS		 4672 RETURN;
4673 }
a0d0e21e
LW		 4674 }
4675 }
4676 else {
4677 if (gimme == G_ARRAY)
4678 RETURN;
4679 }
7f18b612
YST		 4680
4681 GETTARGET;
4682 PUSHi(iters);
4683 RETURN;
79072805 4684}
85e6fe83 4685
c0329465
MB		 4686PP(pp_lock)
4687{
39644a26 4688 dSP;
c0329465 4689 dTOPss;
e55aaa0e 4690 SV *retsv = sv;
68795e93 4691 SvLOCK(sv);
e55aaa0e
MB		 4692 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4693 || SvTYPE(retsv) == SVt_PVCV) {
4694 retsv = refto(retsv);
4695 }
4696 SETs(retsv);
c0329465
MB		 4697 RETURN;
4698}
a863c7d1 4699
2faa37cc 4700PP(pp_threadsv)
a863c7d1 4701{
cea2e8a9 4702 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
a863c7d1 4703}
Unnamed repository; edit this file 'description' to name the repository.