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
Tiny doc tweak.
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
4bb101f2
JH		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
79072805 5 *
a0d0e21e
LW		 6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
79072805 8 *
a0d0e21e
LW		 9 */
10
11/*
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
14 */
79072805
LW		 15
16#include "EXTERN.h"
864dbfa3 17#define PERL_IN_PP_C
79072805 18#include "perl.h"
77bc9082 19#include "keywords.h"
79072805 20
a4af207c
JH		 21#include "reentr.h"
22
dfe9444c
AD		 23/* XXX I can't imagine anyone who doesn't have this actually _needs_
24 it, since pid_t is an integral type.
25 --AD 2/20/1998
26*/
27#ifdef NEED_GETPID_PROTO
28extern Pid_t getpid (void);
8ac85365
NIS		 29#endif
30
13017935
SM		 31/* variations on pp_null */
32
93a17b20
LW		 33PP(pp_stub)
34{
39644a26 35 dSP;
54310121 36 if (GIMME_V == G_SCALAR)
3280af22 37 XPUSHs(&PL_sv_undef);
93a17b20
LW		 38 RETURN;
39}
40
79072805
LW		 41PP(pp_scalar)
42{
43 return NORMAL;
44}
45
46/* Pushy stuff. */
47
93a17b20
LW		 48PP(pp_padav)
49{
39644a26 50 dSP; dTARGET;
13017935 51 I32 gimme;
533c011a 52 if (PL_op->op_private & OPpLVAL_INTRO)
dd2155a4 53 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
85e6fe83 54 EXTEND(SP, 1);
533c011a 55 if (PL_op->op_flags & OPf_REF) {
85e6fe83 56 PUSHs(TARG);
93a17b20 57 RETURN;
78f9721b
SM		 58 } else if (LVRET) {
59 if (GIMME == G_SCALAR)
60 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
61 PUSHs(TARG);
62 RETURN;
85e6fe83 63 }
13017935
SM		 64 gimme = GIMME_V;
65 if (gimme == G_ARRAY) {
85e6fe83
LW		 66 I32 maxarg = AvFILL((AV*)TARG) + 1;
67 EXTEND(SP, maxarg);
93965878
NIS		 68 if (SvMAGICAL(TARG)) {
69 U32 i;
eb160463 70 for (i=0; i < (U32)maxarg; i++) {
93965878 71 SV **svp = av_fetch((AV*)TARG, i, FALSE);
3280af22 72 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878
NIS		 73 }
74 }
75 else {
76 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
77 }
85e6fe83
LW		 78 SP += maxarg;
79 }
13017935 80 else if (gimme == G_SCALAR) {
85e6fe83
LW		 81 SV* sv = sv_newmortal();
82 I32 maxarg = AvFILL((AV*)TARG) + 1;
83 sv_setiv(sv, maxarg);
84 PUSHs(sv);
85 }
86 RETURN;
93a17b20
LW		 87}
88
89PP(pp_padhv)
90{
39644a26 91 dSP; dTARGET;
54310121 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) {
85e6fe83 109 SV* sv = sv_newmortal();
126c71c8
YST		 110 if (SvRMAGICAL(TARG) && mg_find(TARG, PERL_MAGIC_tied))
111 Perl_croak(aTHX_ "Can't provide tied hash usage; "
112 "use keys(%%hash) to test if empty");
46fc3d4c 113 if (HvFILL((HV*)TARG))
cea2e8a9 114 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
46fc3d4c 115 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
85e6fe83
LW		 116 else
117 sv_setiv(sv, 0);
118 SETs(sv);
85e6fe83 119 }
54310121 120 RETURN;
93a17b20
LW		 121}
122
ed6116ce
LW		 123PP(pp_padany)
124{
cea2e8a9 125 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
ed6116ce
LW		 126}
127
79072805
LW		 128/* Translations. */
129
130PP(pp_rv2gv)
131{
39644a26 132 dSP; dTOPss;
8ec5e241 133
ed6116ce 134 if (SvROK(sv)) {
a0d0e21e 135 wasref:
f5284f61
IZ		 136 tryAMAGICunDEREF(to_gv);
137
ed6116ce 138 sv = SvRV(sv);
b1dadf13 139 if (SvTYPE(sv) == SVt_PVIO) {
140 GV *gv = (GV*) sv_newmortal();
141 gv_init(gv, 0, "", 0, 0);
142 GvIOp(gv) = (IO *)sv;
3e3baf6d 143 (void)SvREFCNT_inc(sv);
b1dadf13 144 sv = (SV*) gv;
ef54e1a4
JH		 145 }
146 else if (SvTYPE(sv) != SVt_PVGV)
cea2e8a9 147 DIE(aTHX_ "Not a GLOB reference");
79072805
LW		 148 }
149 else {
93a17b20 150 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 151 char *sym;
c9d5ac95 152 STRLEN len;
748a9306 153
a0d0e21e
LW		 154 if (SvGMAGICAL(sv)) {
155 mg_get(sv);
156 if (SvROK(sv))
157 goto wasref;
158 }
afd1915d 159 if (!SvOK(sv) && sv != &PL_sv_undef) {
b13b2135 160 /* If this is a 'my' scalar and flag is set then vivify
853846ea 161 * NI-S 1999/05/07
b13b2135 162 */
1d8d4d2a 163 if (PL_op->op_private & OPpDEREF) {
2c8ac474
GS		 164 char *name;
165 GV *gv;
166 if (cUNOP->op_targ) {
167 STRLEN len;
dd2155a4 168 SV *namesv = PAD_SV(cUNOP->op_targ);
2c8ac474 169 name = SvPV(namesv, len);
2d6d9f7a 170 gv = (GV*)NEWSV(0,0);
2c8ac474
GS		 171 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
172 }
173 else {
174 name = CopSTASHPV(PL_curcop);
175 gv = newGVgen(name);
1d8d4d2a 176 }
b13b2135
NIS		 177 if (SvTYPE(sv) < SVt_RV)
178 sv_upgrade(sv, SVt_RV);
2c8ac474 179 SvRV(sv) = (SV*)gv;
853846ea 180 SvROK_on(sv);
1d8d4d2a 181 SvSETMAGIC(sv);
853846ea 182 goto wasref;
2c8ac474 183 }
533c011a
NIS		 184 if (PL_op->op_flags & OPf_REF ||
185 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 186 DIE(aTHX_ PL_no_usym, "a symbol");
599cee73 187 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 188 report_uninit();
a0d0e21e
LW		 189 RETSETUNDEF;
190 }
c9d5ac95 191 sym = SvPV(sv,len);
35cd451c
GS		 192 if ((PL_op->op_flags & OPf_SPECIAL) &&
193 !(PL_op->op_flags & OPf_MOD))
194 {
195 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
c9d5ac95
GS		 196 if (!sv
197 && (!is_gv_magical(sym,len,0)
198 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
199 {
35cd451c 200 RETSETUNDEF;
c9d5ac95 201 }
35cd451c
GS		 202 }
203 else {
204 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 205 DIE(aTHX_ PL_no_symref, sym, "a symbol");
35cd451c
GS		 206 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
207 }
93a17b20 208 }
79072805 209 }
533c011a
NIS		 210 if (PL_op->op_private & OPpLVAL_INTRO)
211 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
79072805
LW		 212 SETs(sv);
213 RETURN;
214}
215
79072805
LW		 216PP(pp_rv2sv)
217{
82d03984 218 GV *gv = Nullgv;
39644a26 219 dSP; dTOPss;
79072805 220
ed6116ce 221 if (SvROK(sv)) {
a0d0e21e 222 wasref:
f5284f61
IZ		 223 tryAMAGICunDEREF(to_sv);
224
ed6116ce 225 sv = SvRV(sv);
79072805
LW		 226 switch (SvTYPE(sv)) {
227 case SVt_PVAV:
228 case SVt_PVHV:
229 case SVt_PVCV:
cea2e8a9 230 DIE(aTHX_ "Not a SCALAR reference");
79072805
LW		 231 }
232 }
233 else {
748a9306 234 char *sym;
c9d5ac95 235 STRLEN len;
82d03984 236 gv = (GV*)sv;
748a9306 237
463ee0b2 238 if (SvTYPE(gv) != SVt_PVGV) {
a0d0e21e
LW		 239 if (SvGMAGICAL(sv)) {
240 mg_get(sv);
241 if (SvROK(sv))
242 goto wasref;
243 }
244 if (!SvOK(sv)) {
533c011a
NIS		 245 if (PL_op->op_flags & OPf_REF ||
246 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 247 DIE(aTHX_ PL_no_usym, "a SCALAR");
599cee73 248 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 249 report_uninit();
a0d0e21e
LW		 250 RETSETUNDEF;
251 }
c9d5ac95 252 sym = SvPV(sv, len);
35cd451c
GS		 253 if ((PL_op->op_flags & OPf_SPECIAL) &&
254 !(PL_op->op_flags & OPf_MOD))
255 {
256 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
c9d5ac95
GS		 257 if (!gv
258 && (!is_gv_magical(sym,len,0)
259 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
260 {
35cd451c 261 RETSETUNDEF;
c9d5ac95 262 }
35cd451c
GS		 263 }
264 else {
265 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 266 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
35cd451c
GS		 267 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
268 }
463ee0b2
LW		 269 }
270 sv = GvSV(gv);
a0d0e21e 271 }
533c011a 272 if (PL_op->op_flags & OPf_MOD) {
82d03984
RGS		 273 if (PL_op->op_private & OPpLVAL_INTRO) {
274 if (cUNOP->op_first->op_type == OP_NULL)
275 sv = save_scalar((GV*)TOPs);
276 else if (gv)
277 sv = save_scalar(gv);
278 else
279 Perl_croak(aTHX_ PL_no_localize_ref);
280 }
533c011a
NIS		 281 else if (PL_op->op_private & OPpDEREF)
282 vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 283 }
a0d0e21e 284 SETs(sv);
79072805
LW		 285 RETURN;
286}
287
288PP(pp_av2arylen)
289{
39644a26 290 dSP;
79072805
LW		 291 AV *av = (AV*)TOPs;
292 SV *sv = AvARYLEN(av);
293 if (!sv) {
294 AvARYLEN(av) = sv = NEWSV(0,0);
295 sv_upgrade(sv, SVt_IV);
14befaf4 296 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
79072805
LW		 297 }
298 SETs(sv);
299 RETURN;
300}
301
a0d0e21e
LW		 302PP(pp_pos)
303{
39644a26 304 dSP; dTARGET; dPOPss;
8ec5e241 305
78f9721b 306 if (PL_op->op_flags & OPf_MOD || LVRET) {
5f05dabc 307 if (SvTYPE(TARG) < SVt_PVLV) {
308 sv_upgrade(TARG, SVt_PVLV);
14befaf4 309 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
5f05dabc 310 }
311
312 LvTYPE(TARG) = '.';
6ff81951
GS		 313 if (LvTARG(TARG) != sv) {
314 if (LvTARG(TARG))
315 SvREFCNT_dec(LvTARG(TARG));
316 LvTARG(TARG) = SvREFCNT_inc(sv);
317 }
a0d0e21e
LW		 318 PUSHs(TARG); /* no SvSETMAGIC */
319 RETURN;
320 }
321 else {
8ec5e241 322 MAGIC* mg;
a0d0e21e
LW		 323
324 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
14befaf4 325 mg = mg_find(sv, PERL_MAGIC_regex_global);
565764a8 326 if (mg && mg->mg_len >= 0) {
a0ed51b3 327 I32 i = mg->mg_len;
7e2040f0 328 if (DO_UTF8(sv))
a0ed51b3
LW		 329 sv_pos_b2u(sv, &i);
330 PUSHi(i + PL_curcop->cop_arybase);
a0d0e21e
LW		 331 RETURN;
332 }
333 }
334 RETPUSHUNDEF;
335 }
336}
337
79072805
LW		 338PP(pp_rv2cv)
339{
39644a26 340 dSP;
79072805
LW		 341 GV *gv;
342 HV *stash;
8990e307 343
4633a7c4
LW		 344 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
345 /* (But not in defined().) */
533c011a 346 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
07055b4c
CS		 347 if (cv) {
348 if (CvCLONE(cv))
349 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
d32f2495
SC		 350 if ((PL_op->op_private & OPpLVAL_INTRO)) {
351 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
352 cv = GvCV(gv);
353 if (!CvLVALUE(cv))
354 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
355 }
07055b4c
CS		 356 }
357 else
3280af22 358 cv = (CV*)&PL_sv_undef;
79072805
LW		 359 SETs((SV*)cv);
360 RETURN;
361}
362
c07a80fd 363PP(pp_prototype)
364{
39644a26 365 dSP;
c07a80fd 366 CV *cv;
367 HV *stash;
368 GV *gv;
369 SV *ret;
370
3280af22 371 ret = &PL_sv_undef;
b6c543e3
IZ		 372 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
373 char *s = SvPVX(TOPs);
374 if (strnEQ(s, "CORE::", 6)) {
375 int code;
b13b2135 376
b6c543e3
IZ		 377 code = keyword(s + 6, SvCUR(TOPs) - 6);
378 if (code < 0) { /* Overridable. */
379#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
380 int i = 0, n = 0, seen_question = 0;
381 I32 oa;
382 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
383
77bc9082
RGS		 384 if (code == -KEY_chop || code == -KEY_chomp)
385 goto set;
b6c543e3 386 while (i < MAXO) { /* The slow way. */
22c35a8c
GS		 387 if (strEQ(s + 6, PL_op_name[i])
388 || strEQ(s + 6, PL_op_desc[i]))
389 {
b6c543e3 390 goto found;
22c35a8c 391 }
b6c543e3
IZ		 392 i++;
393 }
394 goto nonesuch; /* Should not happen... */
395 found:
22c35a8c 396 oa = PL_opargs[i] >> OASHIFT;
b6c543e3 397 while (oa) {
3012a639 398 if (oa & OA_OPTIONAL && !seen_question) {
b6c543e3
IZ		 399 seen_question = 1;
400 str[n++] = ';';
ef54e1a4 401 }
b13b2135 402 else if (n && str[0] == ';' && seen_question)
b6c543e3 403 goto set; /* XXXX system, exec */
b13b2135 404 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
6e97e420
SC		 405 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
406 /* But globs are already references (kinda) */
407 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
408 ) {
b6c543e3
IZ		 409 str[n++] = '\\';
410 }
b6c543e3
IZ		 411 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
412 oa = oa >> 4;
413 }
414 str[n++] = '\0';
79cb57f6 415 ret = sv_2mortal(newSVpvn(str, n - 1));
ef54e1a4
JH		 416 }
417 else if (code) /* Non-Overridable */
b6c543e3
IZ		 418 goto set;
419 else { /* None such */
420 nonesuch:
d470f89e 421 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
b6c543e3
IZ		 422 }
423 }
424 }
c07a80fd 425 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
5f05dabc 426 if (cv && SvPOK(cv))
79cb57f6 427 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
b6c543e3 428 set:
c07a80fd 429 SETs(ret);
430 RETURN;
431}
432
a0d0e21e
LW		 433PP(pp_anoncode)
434{
39644a26 435 dSP;
dd2155a4 436 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
a5f75d66 437 if (CvCLONE(cv))
b355b4e0 438 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
5f05dabc 439 EXTEND(SP,1);
748a9306 440 PUSHs((SV*)cv);
a0d0e21e
LW		 441 RETURN;
442}
443
444PP(pp_srefgen)
79072805 445{
39644a26 446 dSP;
71be2cbc 447 *SP = refto(*SP);
79072805 448 RETURN;
8ec5e241 449}
a0d0e21e
LW		 450
451PP(pp_refgen)
452{
39644a26 453 dSP; dMARK;
a0d0e21e 454 if (GIMME != G_ARRAY) {
5f0b1d4e
GS		 455 if (++MARK <= SP)
456 *MARK = *SP;
457 else
3280af22 458 *MARK = &PL_sv_undef;
5f0b1d4e
GS		 459 *MARK = refto(*MARK);
460 SP = MARK;
461 RETURN;
a0d0e21e 462 }
bbce6d69 463 EXTEND_MORTAL(SP - MARK);
71be2cbc 464 while (++MARK <= SP)
465 *MARK = refto(*MARK);
a0d0e21e 466 RETURN;
79072805
LW		 467}
468
76e3520e 469STATIC SV*
cea2e8a9 470S_refto(pTHX_ SV *sv)
71be2cbc 471{
472 SV* rv;
473
474 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
475 if (LvTARGLEN(sv))
68dc0745 476 vivify_defelem(sv);
477 if (!(sv = LvTARG(sv)))
3280af22 478 sv = &PL_sv_undef;
0dd88869 479 else
a6c40364 480 (void)SvREFCNT_inc(sv);
71be2cbc 481 }
d8b46c1b
GS		 482 else if (SvTYPE(sv) == SVt_PVAV) {
483 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
484 av_reify((AV*)sv);
485 SvTEMP_off(sv);
486 (void)SvREFCNT_inc(sv);
487 }
f2933f5f
DM		 488 else if (SvPADTMP(sv) && !IS_PADGV(sv))
489 sv = newSVsv(sv);
71be2cbc 490 else {
491 SvTEMP_off(sv);
492 (void)SvREFCNT_inc(sv);
493 }
494 rv = sv_newmortal();
495 sv_upgrade(rv, SVt_RV);
496 SvRV(rv) = sv;
497 SvROK_on(rv);
498 return rv;
499}
500
79072805
LW		 501PP(pp_ref)
502{
39644a26 503 dSP; dTARGET;
463ee0b2 504 SV *sv;
79072805
LW		 505 char *pv;
506
a0d0e21e 507 sv = POPs;
f12c7020 508
509 if (sv && SvGMAGICAL(sv))
8ec5e241 510 mg_get(sv);
f12c7020 511
a0d0e21e 512 if (!sv || !SvROK(sv))
4633a7c4 513 RETPUSHNO;
79072805 514
ed6116ce 515 sv = SvRV(sv);
a0d0e21e 516 pv = sv_reftype(sv,TRUE);
463ee0b2 517 PUSHp(pv, strlen(pv));
79072805
LW		 518 RETURN;
519}
520
521PP(pp_bless)
522{
39644a26 523 dSP;
463ee0b2 524 HV *stash;
79072805 525
463ee0b2 526 if (MAXARG == 1)
11faa288 527 stash = CopSTASH(PL_curcop);
7b8d334a
GS		 528 else {
529 SV *ssv = POPs;
530 STRLEN len;
81689caa
HS		 531 char *ptr;
532
016a42f3 533 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
81689caa
HS		 534 Perl_croak(aTHX_ "Attempt to bless into a reference");
535 ptr = SvPV(ssv,len);
e476b1b5 536 if (ckWARN(WARN_MISC) && len == 0)
9014280d 537 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 538 "Explicit blessing to '' (assuming package main)");
7b8d334a
GS		 539 stash = gv_stashpvn(ptr, len, TRUE);
540 }
a0d0e21e 541
5d3fdfeb 542 (void)sv_bless(TOPs, stash);
79072805
LW		 543 RETURN;
544}
545
fb73857a 546PP(pp_gelem)
547{
548 GV *gv;
549 SV *sv;
76e3520e 550 SV *tmpRef;
fb73857a 551 char *elem;
39644a26 552 dSP;
2d8e6c8d 553 STRLEN n_a;
b13b2135 554
fb73857a 555 sv = POPs;
2d8e6c8d 556 elem = SvPV(sv, n_a);
fb73857a 557 gv = (GV*)POPs;
76e3520e 558 tmpRef = Nullsv;
fb73857a 559 sv = Nullsv;
560 switch (elem ? *elem : '\0')
561 {
562 case 'A':
563 if (strEQ(elem, "ARRAY"))
76e3520e 564 tmpRef = (SV*)GvAV(gv);
fb73857a 565 break;
566 case 'C':
567 if (strEQ(elem, "CODE"))
76e3520e 568 tmpRef = (SV*)GvCVu(gv);
fb73857a 569 break;
570 case 'F':
39b99f21 571 if (strEQ(elem, "FILEHANDLE")) {
572 /* finally deprecated in 5.8.0 */
9014280d 573 deprecate("*glob{FILEHANDLE}");
76e3520e 574 tmpRef = (SV*)GvIOp(gv);
39b99f21 575 }
f4d13ee9
JH		 576 else
577 if (strEQ(elem, "FORMAT"))
578 tmpRef = (SV*)GvFORM(gv);
fb73857a 579 break;
580 case 'G':
581 if (strEQ(elem, "GLOB"))
76e3520e 582 tmpRef = (SV*)gv;
fb73857a 583 break;
584 case 'H':
585 if (strEQ(elem, "HASH"))
76e3520e 586 tmpRef = (SV*)GvHV(gv);
fb73857a 587 break;
588 case 'I':
589 if (strEQ(elem, "IO"))
76e3520e 590 tmpRef = (SV*)GvIOp(gv);
fb73857a 591 break;
592 case 'N':
593 if (strEQ(elem, "NAME"))
79cb57f6 594 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
fb73857a 595 break;
596 case 'P':
3fc84d6d
JH		 597 if (strEQ(elem, "PACKAGE")) {
598 if (HvNAME(GvSTASH(gv)))
599 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
600 else
601 sv = newSVpv("__ANON__",0);
602 }
fb73857a 603 break;
604 case 'S':
605 if (strEQ(elem, "SCALAR"))
76e3520e 606 tmpRef = GvSV(gv);
fb73857a 607 break;
608 }
76e3520e
GS		 609 if (tmpRef)
610 sv = newRV(tmpRef);
fb73857a 611 if (sv)
612 sv_2mortal(sv);
613 else
3280af22 614 sv = &PL_sv_undef;
fb73857a 615 XPUSHs(sv);
616 RETURN;
617}
618
a0d0e21e 619/* Pattern matching */
79072805 620
a0d0e21e 621PP(pp_study)
79072805 622{
39644a26 623 dSP; dPOPss;
a0d0e21e
LW		 624 register unsigned char *s;
625 register I32 pos;
626 register I32 ch;
627 register I32 *sfirst;
628 register I32 *snext;
a0d0e21e
LW		 629 STRLEN len;
630
3280af22 631 if (sv == PL_lastscream) {
1e422769 632 if (SvSCREAM(sv))
633 RETPUSHYES;
634 }
c07a80fd 635 else {
3280af22
NIS		 636 if (PL_lastscream) {
637 SvSCREAM_off(PL_lastscream);
638 SvREFCNT_dec(PL_lastscream);
c07a80fd 639 }
3280af22 640 PL_lastscream = SvREFCNT_inc(sv);
c07a80fd 641 }
1e422769 642
643 s = (unsigned char*)(SvPV(sv, len));
644 pos = len;
645 if (pos <= 0)
646 RETPUSHNO;
3280af22
NIS		 647 if (pos > PL_maxscream) {
648 if (PL_maxscream < 0) {
649 PL_maxscream = pos + 80;
650 New(301, PL_screamfirst, 256, I32);
651 New(302, PL_screamnext, PL_maxscream, I32);
79072805
LW		 652 }
653 else {
3280af22
NIS		 654 PL_maxscream = pos + pos / 4;
655 Renew(PL_screamnext, PL_maxscream, I32);
79072805 656 }
79072805 657 }
a0d0e21e 658
3280af22
NIS		 659 sfirst = PL_screamfirst;
660 snext = PL_screamnext;
a0d0e21e
LW		 661
662 if (!sfirst || !snext)
cea2e8a9 663 DIE(aTHX_ "do_study: out of memory");
a0d0e21e
LW		 664
665 for (ch = 256; ch; --ch)
666 *sfirst++ = -1;
667 sfirst -= 256;
668
669 while (--pos >= 0) {
670 ch = s[pos];
671 if (sfirst[ch] >= 0)
672 snext[pos] = sfirst[ch] - pos;
673 else
674 snext[pos] = -pos;
675 sfirst[ch] = pos;
79072805
LW		 676 }
677
c07a80fd 678 SvSCREAM_on(sv);
14befaf4
DM		 679 /* piggyback on m//g magic */
680 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
1e422769 681 RETPUSHYES;
79072805
LW		 682}
683
a0d0e21e 684PP(pp_trans)
79072805 685{
39644a26 686 dSP; dTARG;
a0d0e21e
LW		 687 SV *sv;
688
533c011a 689 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 690 sv = POPs;
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;
3510b4a1 839 if (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;
3510b4a1 856 if (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;
3510b4a1 878 if (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;
533c011a 1395 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e
LW		 1396 dMARK;
1397 I32 items = SP - MARK;
1398 I32 max;
79072805 1399
a0d0e21e
LW		 1400 max = items * count;
1401 MEXTEND(MARK, max);
1402 if (count > 1) {
1403 while (SP > MARK) {
976c8a39
JH		 1404#if 0
1405 /* This code was intended to fix 20010809.028:
1406
1407 $x = 'abcd';
1408 for (($x =~ /./g) x 2) {
1409 print chop; # "abcdabcd" expected as output.
1410 }
1411
1412 * but that change (#11635) broke this code:
1413
1414 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1415
1416 * I can't think of a better fix that doesn't introduce
1417 * an efficiency hit by copying the SVs. The stack isn't
1418 * refcounted, and mortalisation obviously doesn't
1419 * Do The Right Thing when the stack has more than
1420 * one pointer to the same mortal value.
1421 * .robin.
1422 */
e30acc16
RH		 1423 if (*SP) {
1424 *SP = sv_2mortal(newSVsv(*SP));
1425 SvREADONLY_on(*SP);
1426 }
976c8a39
JH		 1427#else
1428 if (*SP)
1429 SvTEMP_off((*SP));
1430#endif
a0d0e21e 1431 SP--;
79072805 1432 }
a0d0e21e
LW		 1433 MARK++;
1434 repeatcpy((char*)(MARK + items), (char*)MARK,
1435 items * sizeof(SV*), count - 1);
1436 SP += max;
79072805 1437 }
a0d0e21e
LW		 1438 else if (count <= 0)
1439 SP -= items;
79072805 1440 }
a0d0e21e 1441 else { /* Note: mark already snarfed by pp_list */
dfcb284a 1442 SV *tmpstr = POPs;
a0d0e21e 1443 STRLEN len;
9b877dbb 1444 bool isutf;
a0d0e21e 1445
a0d0e21e
LW		 1446 SvSetSV(TARG, tmpstr);
1447 SvPV_force(TARG, len);
9b877dbb 1448 isutf = DO_UTF8(TARG);
8ebc5c01 1449 if (count != 1) {
1450 if (count < 1)
1451 SvCUR_set(TARG, 0);
1452 else {
1453 SvGROW(TARG, (count * len) + 1);
a0d0e21e 1454 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
8ebc5c01 1455 SvCUR(TARG) *= count;
7a4c00b4 1456 }
a0d0e21e 1457 *SvEND(TARG) = '\0';
a0d0e21e 1458 }
dfcb284a
GS		 1459 if (isutf)
1460 (void)SvPOK_only_UTF8(TARG);
1461 else
1462 (void)SvPOK_only(TARG);
b80b6069
RH		 1463
1464 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1465 /* The parser saw this as a list repeat, and there
1466 are probably several items on the stack. But we're
1467 in scalar context, and there's no pp_list to save us
1468 now. So drop the rest of the items -- robin@kitsite.com
1469 */
1470 dMARK;
1471 SP = MARK;
1472 }
a0d0e21e 1473 PUSHTARG;
79072805 1474 }
a0d0e21e 1475 RETURN;
748a9306 1476 }
a0d0e21e 1477}
79072805 1478
a0d0e21e
LW		 1479PP(pp_subtract)
1480{
39644a26 1481 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
28e5dec8
JH		 1482 useleft = USE_LEFT(TOPm1s);
1483#ifdef PERL_PRESERVE_IVUV
7dca457a
NC		 1484 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1485 "bad things" happen if you rely on signed integers wrapping. */
28e5dec8
JH		 1486 SvIV_please(TOPs);
1487 if (SvIOK(TOPs)) {
1488 /* Unless the left argument is integer in range we are going to have to
1489 use NV maths. Hence only attempt to coerce the right argument if
1490 we know the left is integer. */
9c5ffd7c
JH		 1491 register UV auv = 0;
1492 bool auvok = FALSE;
7dca457a
NC		 1493 bool a_valid = 0;
1494
28e5dec8 1495 if (!useleft) {
7dca457a
NC		 1496 auv = 0;
1497 a_valid = auvok = 1;
1498 /* left operand is undef, treat as zero. */
28e5dec8
JH		 1499 } else {
1500 /* Left operand is defined, so is it IV? */
1501 SvIV_please(TOPm1s);
1502 if (SvIOK(TOPm1s)) {
7dca457a
NC		 1503 if ((auvok = SvUOK(TOPm1s)))
1504 auv = SvUVX(TOPm1s);
1505 else {
1506 register IV aiv = SvIVX(TOPm1s);
1507 if (aiv >= 0) {
1508 auv = aiv;
1509 auvok = 1; /* Now acting as a sign flag. */
1510 } else { /* 2s complement assumption for IV_MIN */
1511 auv = (UV)-aiv;
28e5dec8 1512 }
7dca457a
NC		 1513 }
1514 a_valid = 1;
1515 }
1516 }
1517 if (a_valid) {
1518 bool result_good = 0;
1519 UV result;
1520 register UV buv;
1521 bool buvok = SvUOK(TOPs);
9041c2e3 1522
7dca457a
NC		 1523 if (buvok)
1524 buv = SvUVX(TOPs);
1525 else {
1526 register IV biv = SvIVX(TOPs);
1527 if (biv >= 0) {
1528 buv = biv;
1529 buvok = 1;
1530 } else
1531 buv = (UV)-biv;
1532 }
1533 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1534 else "IV" now, independent of how it came in.
7dca457a
NC		 1535 if a, b represents positive, A, B negative, a maps to -A etc
1536 a - b => (a - b)
1537 A - b => -(a + b)
1538 a - B => (a + b)
1539 A - B => -(a - b)
1540 all UV maths. negate result if A negative.
1541 subtract if signs same, add if signs differ. */
1542
1543 if (auvok ^ buvok) {
1544 /* Signs differ. */
1545 result = auv + buv;
1546 if (result >= auv)
1547 result_good = 1;
1548 } else {
1549 /* Signs same */
1550 if (auv >= buv) {
1551 result = auv - buv;
1552 /* Must get smaller */
1553 if (result <= auv)
1554 result_good = 1;
1555 } else {
1556 result = buv - auv;
1557 if (result <= buv) {
1558 /* result really should be -(auv-buv). as its negation
1559 of true value, need to swap our result flag */
1560 auvok = !auvok;
1561 result_good = 1;
28e5dec8 1562 }
28e5dec8
JH		 1563 }
1564 }
7dca457a
NC		 1565 if (result_good) {
1566 SP--;
1567 if (auvok)
1568 SETu( result );
1569 else {
1570 /* Negate result */
1571 if (result <= (UV)IV_MIN)
1572 SETi( -(IV)result );
1573 else {
1574 /* result valid, but out of range for IV. */
1575 SETn( -(NV)result );
1576 }
1577 }
1578 RETURN;
1579 } /* Overflow, drop through to NVs. */
28e5dec8
JH		 1580 }
1581 }
1582#endif
7dca457a 1583 useleft = USE_LEFT(TOPm1s);
a0d0e21e 1584 {
28e5dec8
JH		 1585 dPOPnv;
1586 if (!useleft) {
1587 /* left operand is undef, treat as zero - value */
1588 SETn(-value);
1589 RETURN;
1590 }
1591 SETn( TOPn - value );
1592 RETURN;
79072805 1593 }
a0d0e21e 1594}
79072805 1595
a0d0e21e
LW		 1596PP(pp_left_shift)
1597{
39644a26 1598 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
a0d0e21e 1599 {
972b05a9 1600 IV shift = POPi;
d0ba1bd2 1601 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1602 IV i = TOPi;
1603 SETi(i << shift);
d0ba1bd2
JH		 1604 }
1605 else {
972b05a9
JH		 1606 UV u = TOPu;
1607 SETu(u << shift);
d0ba1bd2 1608 }
55497cff 1609 RETURN;
79072805 1610 }
a0d0e21e 1611}
79072805 1612
a0d0e21e
LW		 1613PP(pp_right_shift)
1614{
39644a26 1615 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
a0d0e21e 1616 {
972b05a9 1617 IV shift = POPi;
d0ba1bd2 1618 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1619 IV i = TOPi;
1620 SETi(i >> shift);
d0ba1bd2
JH		 1621 }
1622 else {
972b05a9
JH		 1623 UV u = TOPu;
1624 SETu(u >> shift);
d0ba1bd2 1625 }
a0d0e21e 1626 RETURN;
93a17b20 1627 }
79072805
LW		 1628}
1629
a0d0e21e 1630PP(pp_lt)
79072805 1631{
39644a26 1632 dSP; tryAMAGICbinSET(lt,0);
28e5dec8
JH		 1633#ifdef PERL_PRESERVE_IVUV
1634 SvIV_please(TOPs);
1635 if (SvIOK(TOPs)) {
1636 SvIV_please(TOPm1s);
1637 if (SvIOK(TOPm1s)) {
1638 bool auvok = SvUOK(TOPm1s);
1639 bool buvok = SvUOK(TOPs);
a227d84d 1640
28e5dec8
JH		 1641 if (!auvok && !buvok) { /* ## IV < IV ## */
1642 IV aiv = SvIVX(TOPm1s);
1643 IV biv = SvIVX(TOPs);
1644
1645 SP--;
1646 SETs(boolSV(aiv < biv));
1647 RETURN;
1648 }
1649 if (auvok && buvok) { /* ## UV < UV ## */
1650 UV auv = SvUVX(TOPm1s);
1651 UV buv = SvUVX(TOPs);
1652
1653 SP--;
1654 SETs(boolSV(auv < buv));
1655 RETURN;
1656 }
1657 if (auvok) { /* ## UV < IV ## */
1658 UV auv;
1659 IV biv;
1660
1661 biv = SvIVX(TOPs);
1662 SP--;
1663 if (biv < 0) {
1664 /* As (a) is a UV, it's >=0, so it cannot be < */
1665 SETs(&PL_sv_no);
1666 RETURN;
1667 }
1668 auv = SvUVX(TOPs);
28e5dec8
JH		 1669 SETs(boolSV(auv < (UV)biv));
1670 RETURN;
1671 }
1672 { /* ## IV < UV ## */
1673 IV aiv;
1674 UV buv;
1675
1676 aiv = SvIVX(TOPm1s);
1677 if (aiv < 0) {
1678 /* As (b) is a UV, it's >=0, so it must be < */
1679 SP--;
1680 SETs(&PL_sv_yes);
1681 RETURN;
1682 }
1683 buv = SvUVX(TOPs);
1684 SP--;
28e5dec8
JH		 1685 SETs(boolSV((UV)aiv < buv));
1686 RETURN;
1687 }
1688 }
1689 }
1690#endif
30de85b6 1691#ifndef NV_PRESERVES_UV
50fb3111
NC		 1692#ifdef PERL_PRESERVE_IVUV
1693 else
1694#endif
1695 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1696 SP--;
1697 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1698 RETURN;
1699 }
30de85b6 1700#endif
a0d0e21e
LW		 1701 {
1702 dPOPnv;
54310121 1703 SETs(boolSV(TOPn < value));
a0d0e21e 1704 RETURN;
79072805 1705 }
a0d0e21e 1706}
79072805 1707
a0d0e21e
LW		 1708PP(pp_gt)
1709{
39644a26 1710 dSP; tryAMAGICbinSET(gt,0);
28e5dec8
JH		 1711#ifdef PERL_PRESERVE_IVUV
1712 SvIV_please(TOPs);
1713 if (SvIOK(TOPs)) {
1714 SvIV_please(TOPm1s);
1715 if (SvIOK(TOPm1s)) {
1716 bool auvok = SvUOK(TOPm1s);
1717 bool buvok = SvUOK(TOPs);
a227d84d 1718
28e5dec8
JH		 1719 if (!auvok && !buvok) { /* ## IV > IV ## */
1720 IV aiv = SvIVX(TOPm1s);
1721 IV biv = SvIVX(TOPs);
1722
1723 SP--;
1724 SETs(boolSV(aiv > biv));
1725 RETURN;
1726 }
1727 if (auvok && buvok) { /* ## UV > UV ## */
1728 UV auv = SvUVX(TOPm1s);
1729 UV buv = SvUVX(TOPs);
1730
1731 SP--;
1732 SETs(boolSV(auv > buv));
1733 RETURN;
1734 }
1735 if (auvok) { /* ## UV > IV ## */
1736 UV auv;
1737 IV biv;
1738
1739 biv = SvIVX(TOPs);
1740 SP--;
1741 if (biv < 0) {
1742 /* As (a) is a UV, it's >=0, so it must be > */
1743 SETs(&PL_sv_yes);
1744 RETURN;
1745 }
1746 auv = SvUVX(TOPs);
28e5dec8
JH		 1747 SETs(boolSV(auv > (UV)biv));
1748 RETURN;
1749 }
1750 { /* ## IV > UV ## */
1751 IV aiv;
1752 UV buv;
1753
1754 aiv = SvIVX(TOPm1s);
1755 if (aiv < 0) {
1756 /* As (b) is a UV, it's >=0, so it cannot be > */
1757 SP--;
1758 SETs(&PL_sv_no);
1759 RETURN;
1760 }
1761 buv = SvUVX(TOPs);
1762 SP--;
28e5dec8
JH		 1763 SETs(boolSV((UV)aiv > buv));
1764 RETURN;
1765 }
1766 }
1767 }
1768#endif
30de85b6 1769#ifndef NV_PRESERVES_UV
50fb3111
NC		 1770#ifdef PERL_PRESERVE_IVUV
1771 else
1772#endif
1773 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1774 SP--;
1775 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1776 RETURN;
1777 }
1778#endif
a0d0e21e
LW		 1779 {
1780 dPOPnv;
54310121 1781 SETs(boolSV(TOPn > value));
a0d0e21e 1782 RETURN;
79072805 1783 }
a0d0e21e
LW		 1784}
1785
1786PP(pp_le)
1787{
39644a26 1788 dSP; tryAMAGICbinSET(le,0);
28e5dec8
JH		 1789#ifdef PERL_PRESERVE_IVUV
1790 SvIV_please(TOPs);
1791 if (SvIOK(TOPs)) {
1792 SvIV_please(TOPm1s);
1793 if (SvIOK(TOPm1s)) {
1794 bool auvok = SvUOK(TOPm1s);
1795 bool buvok = SvUOK(TOPs);
a227d84d 1796
28e5dec8
JH		 1797 if (!auvok && !buvok) { /* ## IV <= IV ## */
1798 IV aiv = SvIVX(TOPm1s);
1799 IV biv = SvIVX(TOPs);
1800
1801 SP--;
1802 SETs(boolSV(aiv <= biv));
1803 RETURN;
1804 }
1805 if (auvok && buvok) { /* ## UV <= UV ## */
1806 UV auv = SvUVX(TOPm1s);
1807 UV buv = SvUVX(TOPs);
1808
1809 SP--;
1810 SETs(boolSV(auv <= buv));
1811 RETURN;
1812 }
1813 if (auvok) { /* ## UV <= IV ## */
1814 UV auv;
1815 IV biv;
1816
1817 biv = SvIVX(TOPs);
1818 SP--;
1819 if (biv < 0) {
1820 /* As (a) is a UV, it's >=0, so a cannot be <= */
1821 SETs(&PL_sv_no);
1822 RETURN;
1823 }
1824 auv = SvUVX(TOPs);
28e5dec8
JH		 1825 SETs(boolSV(auv <= (UV)biv));
1826 RETURN;
1827 }
1828 { /* ## IV <= UV ## */
1829 IV aiv;
1830 UV buv;
1831
1832 aiv = SvIVX(TOPm1s);
1833 if (aiv < 0) {
1834 /* As (b) is a UV, it's >=0, so a must be <= */
1835 SP--;
1836 SETs(&PL_sv_yes);
1837 RETURN;
1838 }
1839 buv = SvUVX(TOPs);
1840 SP--;
28e5dec8
JH		 1841 SETs(boolSV((UV)aiv <= buv));
1842 RETURN;
1843 }
1844 }
1845 }
1846#endif
30de85b6 1847#ifndef NV_PRESERVES_UV
50fb3111
NC		 1848#ifdef PERL_PRESERVE_IVUV
1849 else
1850#endif
1851 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1852 SP--;
1853 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1854 RETURN;
1855 }
1856#endif
a0d0e21e
LW		 1857 {
1858 dPOPnv;
54310121 1859 SETs(boolSV(TOPn <= value));
a0d0e21e 1860 RETURN;
79072805 1861 }
a0d0e21e
LW		 1862}
1863
1864PP(pp_ge)
1865{
39644a26 1866 dSP; tryAMAGICbinSET(ge,0);
28e5dec8
JH		 1867#ifdef PERL_PRESERVE_IVUV
1868 SvIV_please(TOPs);
1869 if (SvIOK(TOPs)) {
1870 SvIV_please(TOPm1s);
1871 if (SvIOK(TOPm1s)) {
1872 bool auvok = SvUOK(TOPm1s);
1873 bool buvok = SvUOK(TOPs);
a227d84d 1874
28e5dec8
JH		 1875 if (!auvok && !buvok) { /* ## IV >= IV ## */
1876 IV aiv = SvIVX(TOPm1s);
1877 IV biv = SvIVX(TOPs);
1878
1879 SP--;
1880 SETs(boolSV(aiv >= biv));
1881 RETURN;
1882 }
1883 if (auvok && buvok) { /* ## UV >= UV ## */
1884 UV auv = SvUVX(TOPm1s);
1885 UV buv = SvUVX(TOPs);
1886
1887 SP--;
1888 SETs(boolSV(auv >= buv));
1889 RETURN;
1890 }
1891 if (auvok) { /* ## UV >= IV ## */
1892 UV auv;
1893 IV biv;
1894
1895 biv = SvIVX(TOPs);
1896 SP--;
1897 if (biv < 0) {
1898 /* As (a) is a UV, it's >=0, so it must be >= */
1899 SETs(&PL_sv_yes);
1900 RETURN;
1901 }
1902 auv = SvUVX(TOPs);
28e5dec8
JH		 1903 SETs(boolSV(auv >= (UV)biv));
1904 RETURN;
1905 }
1906 { /* ## IV >= UV ## */
1907 IV aiv;
1908 UV buv;
1909
1910 aiv = SvIVX(TOPm1s);
1911 if (aiv < 0) {
1912 /* As (b) is a UV, it's >=0, so a cannot be >= */
1913 SP--;
1914 SETs(&PL_sv_no);
1915 RETURN;
1916 }
1917 buv = SvUVX(TOPs);
1918 SP--;
28e5dec8
JH		 1919 SETs(boolSV((UV)aiv >= buv));
1920 RETURN;
1921 }
1922 }
1923 }
1924#endif
30de85b6 1925#ifndef NV_PRESERVES_UV
50fb3111
NC		 1926#ifdef PERL_PRESERVE_IVUV
1927 else
1928#endif
1929 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1930 SP--;
1931 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1932 RETURN;
1933 }
1934#endif
a0d0e21e
LW		 1935 {
1936 dPOPnv;
54310121 1937 SETs(boolSV(TOPn >= value));
a0d0e21e 1938 RETURN;
79072805 1939 }
a0d0e21e 1940}
79072805 1941
a0d0e21e
LW		 1942PP(pp_ne)
1943{
16303949 1944 dSP; tryAMAGICbinSET(ne,0);
3bb2c415
JH		 1945#ifndef NV_PRESERVES_UV
1946 if (SvROK(TOPs) && SvROK(TOPm1s)) {
e61d22ef
NC		 1947 SP--;
1948 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
3bb2c415
JH		 1949 RETURN;
1950 }
1951#endif
28e5dec8
JH		 1952#ifdef PERL_PRESERVE_IVUV
1953 SvIV_please(TOPs);
1954 if (SvIOK(TOPs)) {
1955 SvIV_please(TOPm1s);
1956 if (SvIOK(TOPm1s)) {
1957 bool auvok = SvUOK(TOPm1s);
1958 bool buvok = SvUOK(TOPs);
a227d84d 1959
30de85b6
NC		 1960 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1961 /* Casting IV to UV before comparison isn't going to matter
1962 on 2s complement. On 1s complement or sign&magnitude
1963 (if we have any of them) it could make negative zero
1964 differ from normal zero. As I understand it. (Need to
1965 check - is negative zero implementation defined behaviour
1966 anyway?). NWC */
1967 UV buv = SvUVX(POPs);
1968 UV auv = SvUVX(TOPs);
28e5dec8 1969
28e5dec8
JH		 1970 SETs(boolSV(auv != buv));
1971 RETURN;
1972 }
1973 { /* ## Mixed IV,UV ## */
1974 IV iv;
1975 UV uv;
1976
1977 /* != is commutative so swap if needed (save code) */
1978 if (auvok) {
1979 /* swap. top of stack (b) is the iv */
1980 iv = SvIVX(TOPs);
1981 SP--;
1982 if (iv < 0) {
1983 /* As (a) is a UV, it's >0, so it cannot be == */
1984 SETs(&PL_sv_yes);
1985 RETURN;
1986 }
1987 uv = SvUVX(TOPs);
1988 } else {
1989 iv = SvIVX(TOPm1s);
1990 SP--;
1991 if (iv < 0) {
1992 /* As (b) is a UV, it's >0, so it cannot be == */
1993 SETs(&PL_sv_yes);
1994 RETURN;
1995 }
1996 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1997 }
28e5dec8
JH		 1998 SETs(boolSV((UV)iv != uv));
1999 RETURN;
2000 }
2001 }
2002 }
2003#endif
a0d0e21e
LW		 2004 {
2005 dPOPnv;
54310121 2006 SETs(boolSV(TOPn != value));
a0d0e21e
LW		 2007 RETURN;
2008 }
79072805
LW		 2009}
2010
a0d0e21e 2011PP(pp_ncmp)
79072805 2012{
39644a26 2013 dSP; dTARGET; tryAMAGICbin(ncmp,0);
d8c7644e
JH		 2014#ifndef NV_PRESERVES_UV
2015 if (SvROK(TOPs) && SvROK(TOPm1s)) {
e61d22ef
NC		 2016 UV right = PTR2UV(SvRV(POPs));
2017 UV left = PTR2UV(SvRV(TOPs));
2018 SETi((left > right) - (left < right));
d8c7644e
JH		 2019 RETURN;
2020 }
2021#endif
28e5dec8
JH		 2022#ifdef PERL_PRESERVE_IVUV
2023 /* Fortunately it seems NaN isn't IOK */
2024 SvIV_please(TOPs);
2025 if (SvIOK(TOPs)) {
2026 SvIV_please(TOPm1s);
2027 if (SvIOK(TOPm1s)) {
2028 bool leftuvok = SvUOK(TOPm1s);
2029 bool rightuvok = SvUOK(TOPs);
2030 I32 value;
2031 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2032 IV leftiv = SvIVX(TOPm1s);
2033 IV rightiv = SvIVX(TOPs);
2034
2035 if (leftiv > rightiv)
2036 value = 1;
2037 else if (leftiv < rightiv)
2038 value = -1;
2039 else
2040 value = 0;
2041 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2042 UV leftuv = SvUVX(TOPm1s);
2043 UV rightuv = SvUVX(TOPs);
2044
2045 if (leftuv > rightuv)
2046 value = 1;
2047 else if (leftuv < rightuv)
2048 value = -1;
2049 else
2050 value = 0;
2051 } else if (leftuvok) { /* ## UV <=> IV ## */
2052 UV leftuv;
2053 IV rightiv;
2054
2055 rightiv = SvIVX(TOPs);
2056 if (rightiv < 0) {
2057 /* As (a) is a UV, it's >=0, so it cannot be < */
2058 value = 1;
2059 } else {
2060 leftuv = SvUVX(TOPm1s);
83bac5dd 2061 if (leftuv > (UV)rightiv) {
28e5dec8
JH		 2062 value = 1;
2063 } else if (leftuv < (UV)rightiv) {
2064 value = -1;
2065 } else {
2066 value = 0;
2067 }
2068 }
2069 } else { /* ## IV <=> UV ## */
2070 IV leftiv;
2071 UV rightuv;
2072
2073 leftiv = SvIVX(TOPm1s);
2074 if (leftiv < 0) {
2075 /* As (b) is a UV, it's >=0, so it must be < */
2076 value = -1;
2077 } else {
2078 rightuv = SvUVX(TOPs);
83bac5dd 2079 if ((UV)leftiv > rightuv) {
28e5dec8 2080 value = 1;
83bac5dd 2081 } else if ((UV)leftiv < rightuv) {
28e5dec8
JH		 2082 value = -1;
2083 } else {
2084 value = 0;
2085 }
2086 }
2087 }
2088 SP--;
2089 SETi(value);
2090 RETURN;
2091 }
2092 }
2093#endif
a0d0e21e
LW		 2094 {
2095 dPOPTOPnnrl;
2096 I32 value;
79072805 2097
a3540c92 2098#ifdef Perl_isnan
1ad04cfd
JH		 2099 if (Perl_isnan(left) || Perl_isnan(right)) {
2100 SETs(&PL_sv_undef);
2101 RETURN;
2102 }
2103 value = (left > right) - (left < right);
2104#else
ff0cee69 2105 if (left == right)
a0d0e21e 2106 value = 0;
a0d0e21e
LW		 2107 else if (left < right)
2108 value = -1;
44a8e56a 2109 else if (left > right)
2110 value = 1;
2111 else {
3280af22 2112 SETs(&PL_sv_undef);
44a8e56a 2113 RETURN;
2114 }
1ad04cfd 2115#endif
a0d0e21e
LW		 2116 SETi(value);
2117 RETURN;
79072805 2118 }
a0d0e21e 2119}
79072805 2120
a0d0e21e
LW		 2121PP(pp_slt)
2122{
39644a26 2123 dSP; tryAMAGICbinSET(slt,0);
a0d0e21e
LW		 2124 {
2125 dPOPTOPssrl;
2de3dbcc 2126 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2127 ? sv_cmp_locale(left, right)
2128 : sv_cmp(left, right));
54310121 2129 SETs(boolSV(cmp < 0));
a0d0e21e
LW		 2130 RETURN;
2131 }
79072805
LW		 2132}
2133
a0d0e21e 2134PP(pp_sgt)
79072805 2135{
39644a26 2136 dSP; tryAMAGICbinSET(sgt,0);
a0d0e21e
LW		 2137 {
2138 dPOPTOPssrl;
2de3dbcc 2139 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2140 ? sv_cmp_locale(left, right)
2141 : sv_cmp(left, right));
54310121 2142 SETs(boolSV(cmp > 0));
a0d0e21e
LW		 2143 RETURN;
2144 }
2145}
79072805 2146
a0d0e21e
LW		 2147PP(pp_sle)
2148{
39644a26 2149 dSP; tryAMAGICbinSET(sle,0);
a0d0e21e
LW		 2150 {
2151 dPOPTOPssrl;
2de3dbcc 2152 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2153 ? sv_cmp_locale(left, right)
2154 : sv_cmp(left, right));
54310121 2155 SETs(boolSV(cmp <= 0));
a0d0e21e 2156 RETURN;
79072805 2157 }
79072805
LW		 2158}
2159
a0d0e21e
LW		 2160PP(pp_sge)
2161{
39644a26 2162 dSP; tryAMAGICbinSET(sge,0);
a0d0e21e
LW		 2163 {
2164 dPOPTOPssrl;
2de3dbcc 2165 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2166 ? sv_cmp_locale(left, right)
2167 : sv_cmp(left, right));
54310121 2168 SETs(boolSV(cmp >= 0));
a0d0e21e
LW		 2169 RETURN;
2170 }
2171}
79072805 2172
36477c24 2173PP(pp_seq)
2174{
39644a26 2175 dSP; tryAMAGICbinSET(seq,0);
36477c24 2176 {
2177 dPOPTOPssrl;
54310121 2178 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW		 2179 RETURN;
2180 }
2181}
79072805 2182
a0d0e21e 2183PP(pp_sne)
79072805 2184{
39644a26 2185 dSP; tryAMAGICbinSET(sne,0);
a0d0e21e
LW		 2186 {
2187 dPOPTOPssrl;
54310121 2188 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 2189 RETURN;
463ee0b2 2190 }
79072805
LW		 2191}
2192
a0d0e21e 2193PP(pp_scmp)
79072805 2194{
39644a26 2195 dSP; dTARGET; tryAMAGICbin(scmp,0);
a0d0e21e
LW		 2196 {
2197 dPOPTOPssrl;
2de3dbcc 2198 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2199 ? sv_cmp_locale(left, right)
2200 : sv_cmp(left, right));
2201 SETi( cmp );
a0d0e21e
LW		 2202 RETURN;
2203 }
2204}
79072805 2205
55497cff 2206PP(pp_bit_and)
2207{
39644a26 2208 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
a0d0e21e
LW		 2209 {
2210 dPOPTOPssrl;
4633a7c4 2211 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2212 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2213 IV i = SvIV(left) & SvIV(right);
2214 SETi(i);
d0ba1bd2
JH		 2215 }
2216 else {
972b05a9
JH		 2217 UV u = SvUV(left) & SvUV(right);
2218 SETu(u);
d0ba1bd2 2219 }
a0d0e21e
LW		 2220 }
2221 else {
533c011a 2222 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2223 SETTARG;
2224 }
2225 RETURN;
2226 }
2227}
79072805 2228
a0d0e21e
LW		 2229PP(pp_bit_xor)
2230{
39644a26 2231 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW		 2232 {
2233 dPOPTOPssrl;
4633a7c4 2234 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2235 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2236 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2237 SETi(i);
d0ba1bd2
JH		 2238 }
2239 else {
972b05a9
JH		 2240 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2241 SETu(u);
d0ba1bd2 2242 }
a0d0e21e
LW		 2243 }
2244 else {
533c011a 2245 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2246 SETTARG;
2247 }
2248 RETURN;
2249 }
2250}
79072805 2251
a0d0e21e
LW		 2252PP(pp_bit_or)
2253{
39644a26 2254 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW		 2255 {
2256 dPOPTOPssrl;
4633a7c4 2257 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2258 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2259 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2260 SETi(i);
d0ba1bd2
JH		 2261 }
2262 else {
972b05a9
JH		 2263 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2264 SETu(u);
d0ba1bd2 2265 }
a0d0e21e
LW		 2266 }
2267 else {
533c011a 2268 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2269 SETTARG;
2270 }
2271 RETURN;
79072805 2272 }
a0d0e21e 2273}
79072805 2274
a0d0e21e
LW		 2275PP(pp_negate)
2276{
39644a26 2277 dSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW		 2278 {
2279 dTOPss;
28e5dec8 2280 int flags = SvFLAGS(sv);
4633a7c4
LW		 2281 if (SvGMAGICAL(sv))
2282 mg_get(sv);
28e5dec8
JH		 2283 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2284 /* It's publicly an integer, or privately an integer-not-float */
2285 oops_its_an_int:
9b0e499b
GS		 2286 if (SvIsUV(sv)) {
2287 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2288 /* 2s complement assumption. */
9b0e499b
GS		 2289 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2290 RETURN;
2291 }
2292 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2293 SETi(-SvIVX(sv));
9b0e499b
GS		 2294 RETURN;
2295 }
2296 }
2297 else if (SvIVX(sv) != IV_MIN) {
2298 SETi(-SvIVX(sv));
2299 RETURN;
2300 }
28e5dec8
JH		 2301#ifdef PERL_PRESERVE_IVUV
2302 else {
2303 SETu((UV)IV_MIN);
2304 RETURN;
2305 }
2306#endif
9b0e499b
GS		 2307 }
2308 if (SvNIOKp(sv))
a0d0e21e 2309 SETn(-SvNV(sv));
4633a7c4 2310 else if (SvPOKp(sv)) {
a0d0e21e
LW		 2311 STRLEN len;
2312 char *s = SvPV(sv, len);
bbce6d69 2313 if (isIDFIRST(*s)) {
a0d0e21e
LW		 2314 sv_setpvn(TARG, "-", 1);
2315 sv_catsv(TARG, sv);
79072805 2316 }
a0d0e21e
LW		 2317 else if (*s == '+' || *s == '-') {
2318 sv_setsv(TARG, sv);
2319 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805 2320 }
8eb28a70
JH		 2321 else if (DO_UTF8(sv)) {
2322 SvIV_please(sv);
2323 if (SvIOK(sv))
2324 goto oops_its_an_int;
2325 if (SvNOK(sv))
2326 sv_setnv(TARG, -SvNV(sv));
2327 else {
2328 sv_setpvn(TARG, "-", 1);
2329 sv_catsv(TARG, sv);
2330 }
834a4ddd 2331 }
28e5dec8 2332 else {
8eb28a70
JH		 2333 SvIV_please(sv);
2334 if (SvIOK(sv))
2335 goto oops_its_an_int;
2336 sv_setnv(TARG, -SvNV(sv));
28e5dec8 2337 }
a0d0e21e 2338 SETTARG;
79072805 2339 }
4633a7c4
LW		 2340 else
2341 SETn(-SvNV(sv));
79072805 2342 }
a0d0e21e 2343 RETURN;
79072805
LW		 2344}
2345
a0d0e21e 2346PP(pp_not)
79072805 2347{
39644a26 2348 dSP; tryAMAGICunSET(not);
3280af22 2349 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
a0d0e21e 2350 return NORMAL;
79072805
LW		 2351}
2352
a0d0e21e 2353PP(pp_complement)
79072805 2354{
39644a26 2355 dSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW		 2356 {
2357 dTOPss;
4633a7c4 2358 if (SvNIOKp(sv)) {
d0ba1bd2 2359 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2360 IV i = ~SvIV(sv);
2361 SETi(i);
d0ba1bd2
JH		 2362 }
2363 else {
972b05a9
JH		 2364 UV u = ~SvUV(sv);
2365 SETu(u);
d0ba1bd2 2366 }
a0d0e21e
LW		 2367 }
2368 else {
51723571 2369 register U8 *tmps;
55497cff 2370 register I32 anum;
a0d0e21e
LW		 2371 STRLEN len;
2372
2373 SvSetSV(TARG, sv);
51723571 2374 tmps = (U8*)SvPV_force(TARG, len);
a0d0e21e 2375 anum = len;
1d68d6cd 2376 if (SvUTF8(TARG)) {
a1ca4561 2377 /* Calculate exact length, let's not estimate. */
1d68d6cd
SC		 2378 STRLEN targlen = 0;
2379 U8 *result;
51723571 2380 U8 *send;
ba210ebe 2381 STRLEN l;
a1ca4561
YST		 2382 UV nchar = 0;
2383 UV nwide = 0;
1d68d6cd
SC		 2384
2385 send = tmps + len;
2386 while (tmps < send) {
9041c2e3 2387 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1d68d6cd 2388 tmps += UTF8SKIP(tmps);
5bbb0b5a 2389 targlen += UNISKIP(~c);
a1ca4561
YST		 2390 nchar++;
2391 if (c > 0xff)
2392 nwide++;
1d68d6cd
SC		 2393 }
2394
2395 /* Now rewind strings and write them. */
2396 tmps -= len;
a1ca4561
YST		 2397
2398 if (nwide) {
2399 Newz(0, result, targlen + 1, U8);
2400 while (tmps < send) {
9041c2e3 2401 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
a1ca4561 2402 tmps += UTF8SKIP(tmps);
b851fbc1 2403 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
a1ca4561
YST		 2404 }
2405 *result = '\0';
2406 result -= targlen;
2407 sv_setpvn(TARG, (char*)result, targlen);
2408 SvUTF8_on(TARG);
2409 }
2410 else {
2411 Newz(0, result, nchar + 1, U8);
2412 while (tmps < send) {
9041c2e3 2413 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
a1ca4561
YST		 2414 tmps += UTF8SKIP(tmps);
2415 *result++ = ~c;
2416 }
2417 *result = '\0';
2418 result -= nchar;
2419 sv_setpvn(TARG, (char*)result, nchar);
1d68d6cd 2420 }
1d68d6cd
SC		 2421 Safefree(result);
2422 SETs(TARG);
2423 RETURN;
2424 }
a0d0e21e 2425#ifdef LIBERAL
51723571
JH		 2426 {
2427 register long *tmpl;
2428 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2429 *tmps = ~*tmps;
2430 tmpl = (long*)tmps;
2431 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2432 *tmpl = ~*tmpl;
2433 tmps = (U8*)tmpl;
2434 }
a0d0e21e
LW		 2435#endif
2436 for ( ; anum > 0; anum--, tmps++)
2437 *tmps = ~*tmps;
2438
2439 SETs(TARG);
2440 }
2441 RETURN;
2442 }
79072805
LW		 2443}
2444
a0d0e21e
LW		 2445/* integer versions of some of the above */
2446
a0d0e21e 2447PP(pp_i_multiply)
79072805 2448{
39644a26 2449 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW		 2450 {
2451 dPOPTOPiirl;
2452 SETi( left * right );
2453 RETURN;
2454 }
79072805
LW		 2455}
2456
a0d0e21e 2457PP(pp_i_divide)
79072805 2458{
39644a26 2459 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW		 2460 {
2461 dPOPiv;
2462 if (value == 0)
cea2e8a9 2463 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW		 2464 value = POPi / value;
2465 PUSHi( value );
2466 RETURN;
2467 }
79072805
LW		 2468}
2469
224ec323
JH		 2470STATIC
2471PP(pp_i_modulo_0)
2472{
2473 /* This is the vanilla old i_modulo. */
2474 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2475 {
2476 dPOPTOPiirl;
2477 if (!right)
2478 DIE(aTHX_ "Illegal modulus zero");
2479 SETi( left % right );
2480 RETURN;
2481 }
2482}
2483
11010fa3 2484#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH		 2485STATIC
2486PP(pp_i_modulo_1)
2487{
224ec323 2488 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2489 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323
JH		 2490 * See below for pp_i_modulo. */
2491 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2492 {
2493 dPOPTOPiirl;
2494 if (!right)
2495 DIE(aTHX_ "Illegal modulus zero");
32fdb065 2496 SETi( left % PERL_ABS(right) );
224ec323
JH		 2497 RETURN;
2498 }
224ec323 2499}
fce2b89e 2500#endif
224ec323 2501
a0d0e21e 2502PP(pp_i_modulo)
79072805 2503{
224ec323
JH		 2504 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2505 {
2506 dPOPTOPiirl;
2507 if (!right)
2508 DIE(aTHX_ "Illegal modulus zero");
2509 /* The assumption is to use hereafter the old vanilla version... */
2510 PL_op->op_ppaddr =
2511 PL_ppaddr[OP_I_MODULO] =
2512 &Perl_pp_i_modulo_0;
2513 /* .. but if we have glibc, we might have a buggy _moddi3
2514 * (at least glicb 2.2.5 is known to have this bug), in other
2515 * words our integer modulus with negative quad as the second
2516 * argument might be broken. Test for this and re-patch the
2517 * opcode dispatch table if that is the case, remembering to
2518 * also apply the workaround so that this first round works
2519 * right, too. See [perl #9402] for more information. */
2520#if defined(__GLIBC__) && IVSIZE == 8
2521 {
2522 IV l = 3;
2523 IV r = -10;
2524 /* Cannot do this check with inlined IV constants since
2525 * that seems to work correctly even with the buggy glibc. */
2526 if (l % r == -3) {
2527 /* Yikes, we have the bug.
2528 * Patch in the workaround version. */
2529 PL_op->op_ppaddr =
2530 PL_ppaddr[OP_I_MODULO] =
2531 &Perl_pp_i_modulo_1;
2532 /* Make certain we work right this time, too. */
32fdb065 2533 right = PERL_ABS(right);
224ec323
JH		 2534 }
2535 }
2536#endif
2537 SETi( left % right );
2538 RETURN;
2539 }
79072805
LW		 2540}
2541
a0d0e21e 2542PP(pp_i_add)
79072805 2543{
39644a26 2544 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e 2545 {
5e66d4f1 2546 dPOPTOPiirl_ul;
a0d0e21e
LW		 2547 SETi( left + right );
2548 RETURN;
79072805 2549 }
79072805
LW		 2550}
2551
a0d0e21e 2552PP(pp_i_subtract)
79072805 2553{
39644a26 2554 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 2555 {
5e66d4f1 2556 dPOPTOPiirl_ul;
a0d0e21e
LW		 2557 SETi( left - right );
2558 RETURN;
79072805 2559 }
79072805
LW		 2560}
2561
a0d0e21e 2562PP(pp_i_lt)
79072805 2563{
39644a26 2564 dSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW		 2565 {
2566 dPOPTOPiirl;
54310121 2567 SETs(boolSV(left < right));
a0d0e21e
LW		 2568 RETURN;
2569 }
79072805
LW		 2570}
2571
a0d0e21e 2572PP(pp_i_gt)
79072805 2573{
39644a26 2574 dSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW		 2575 {
2576 dPOPTOPiirl;
54310121 2577 SETs(boolSV(left > right));
a0d0e21e
LW		 2578 RETURN;
2579 }
79072805
LW		 2580}
2581
a0d0e21e 2582PP(pp_i_le)
79072805 2583{
39644a26 2584 dSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW		 2585 {
2586 dPOPTOPiirl;
54310121 2587 SETs(boolSV(left <= right));
a0d0e21e 2588 RETURN;
85e6fe83 2589 }
79072805
LW		 2590}
2591
a0d0e21e 2592PP(pp_i_ge)
79072805 2593{
39644a26 2594 dSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW		 2595 {
2596 dPOPTOPiirl;
54310121 2597 SETs(boolSV(left >= right));
a0d0e21e
LW		 2598 RETURN;
2599 }
79072805
LW		 2600}
2601
a0d0e21e 2602PP(pp_i_eq)
79072805 2603{
39644a26 2604 dSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW		 2605 {
2606 dPOPTOPiirl;
54310121 2607 SETs(boolSV(left == right));
a0d0e21e
LW		 2608 RETURN;
2609 }
79072805
LW		 2610}
2611
a0d0e21e 2612PP(pp_i_ne)
79072805 2613{
39644a26 2614 dSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW		 2615 {
2616 dPOPTOPiirl;
54310121 2617 SETs(boolSV(left != right));
a0d0e21e
LW		 2618 RETURN;
2619 }
79072805
LW		 2620}
2621
a0d0e21e 2622PP(pp_i_ncmp)
79072805 2623{
39644a26 2624 dSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW		 2625 {
2626 dPOPTOPiirl;
2627 I32 value;
79072805 2628
a0d0e21e 2629 if (left > right)
79072805 2630 value = 1;
a0d0e21e 2631 else if (left < right)
79072805 2632 value = -1;
a0d0e21e 2633 else
79072805 2634 value = 0;
a0d0e21e
LW		 2635 SETi(value);
2636 RETURN;
79072805 2637 }
85e6fe83
LW		 2638}
2639
2640PP(pp_i_negate)
2641{
39644a26 2642 dSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW		 2643 SETi(-TOPi);
2644 RETURN;
2645}
2646
79072805
LW		 2647/* High falutin' math. */
2648
2649PP(pp_atan2)
2650{
39644a26 2651 dSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW		 2652 {
2653 dPOPTOPnnrl;
65202027 2654 SETn(Perl_atan2(left, right));
a0d0e21e
LW		 2655 RETURN;
2656 }
79072805
LW		 2657}
2658
2659PP(pp_sin)
2660{
39644a26 2661 dSP; dTARGET; tryAMAGICun(sin);
a0d0e21e 2662 {
65202027 2663 NV value;
a0d0e21e 2664 value = POPn;
65202027 2665 value = Perl_sin(value);
a0d0e21e
LW		 2666 XPUSHn(value);
2667 RETURN;
2668 }
79072805
LW		 2669}
2670
2671PP(pp_cos)
2672{
39644a26 2673 dSP; dTARGET; tryAMAGICun(cos);
a0d0e21e 2674 {
65202027 2675 NV value;
a0d0e21e 2676 value = POPn;
65202027 2677 value = Perl_cos(value);
a0d0e21e
LW		 2678 XPUSHn(value);
2679 RETURN;
2680 }
79072805
LW		 2681}
2682
56cb0a1c
AD		 2683/* Support Configure command-line overrides for rand() functions.
2684 After 5.005, perhaps we should replace this by Configure support
2685 for drand48(), random(), or rand(). For 5.005, though, maintain
2686 compatibility by calling rand() but allow the user to override it.
2687 See INSTALL for details. --Andy Dougherty 15 July 1998
2688*/
85ab1d1d
JH		 2689/* Now it's after 5.005, and Configure supports drand48() and random(),
2690 in addition to rand(). So the overrides should not be needed any more.
2691 --Jarkko Hietaniemi 27 September 1998
2692 */
2693
2694#ifndef HAS_DRAND48_PROTO
20ce7b12 2695extern double drand48 (void);
56cb0a1c
AD		 2696#endif
2697
79072805
LW		 2698PP(pp_rand)
2699{
39644a26 2700 dSP; dTARGET;
65202027 2701 NV value;
79072805
LW		 2702 if (MAXARG < 1)
2703 value = 1.0;
2704 else
2705 value = POPn;
2706 if (value == 0.0)
2707 value = 1.0;
80252599 2708 if (!PL_srand_called) {
85ab1d1d 2709 (void)seedDrand01((Rand_seed_t)seed());
80252599 2710 PL_srand_called = TRUE;
93dc8474 2711 }
85ab1d1d 2712 value *= Drand01();
79072805
LW		 2713 XPUSHn(value);
2714 RETURN;
2715}
2716
2717PP(pp_srand)
2718{
39644a26 2719 dSP;
93dc8474
CS		 2720 UV anum;
2721 if (MAXARG < 1)
2722 anum = seed();
79072805 2723 else
93dc8474 2724 anum = POPu;
85ab1d1d 2725 (void)seedDrand01((Rand_seed_t)anum);
80252599 2726 PL_srand_called = TRUE;
79072805
LW		 2727 EXTEND(SP, 1);
2728 RETPUSHYES;
2729}
2730
2731PP(pp_exp)
2732{
39644a26 2733 dSP; dTARGET; tryAMAGICun(exp);
a0d0e21e 2734 {
65202027 2735 NV value;
a0d0e21e 2736 value = POPn;
65202027 2737 value = Perl_exp(value);
a0d0e21e
LW		 2738 XPUSHn(value);
2739 RETURN;
2740 }
79072805
LW		 2741}
2742
2743PP(pp_log)
2744{
39644a26 2745 dSP; dTARGET; tryAMAGICun(log);
a0d0e21e 2746 {
65202027 2747 NV value;
a0d0e21e 2748 value = POPn;
bbce6d69 2749 if (value <= 0.0) {
f93f4e46 2750 SET_NUMERIC_STANDARD();
1779d84d 2751 DIE(aTHX_ "Can't take log of %"NVgf, value);
bbce6d69 2752 }
65202027 2753 value = Perl_log(value);
a0d0e21e
LW		 2754 XPUSHn(value);
2755 RETURN;
2756 }
79072805
LW		 2757}
2758
2759PP(pp_sqrt)
2760{
39644a26 2761 dSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e 2762 {
65202027 2763 NV value;
a0d0e21e 2764 value = POPn;
bbce6d69 2765 if (value < 0.0) {
f93f4e46 2766 SET_NUMERIC_STANDARD();
1779d84d 2767 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
bbce6d69 2768 }
65202027 2769 value = Perl_sqrt(value);
a0d0e21e
LW		 2770 XPUSHn(value);
2771 RETURN;
2772 }
79072805
LW		 2773}
2774
24da999b
JH		 2775/*
2776 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2777 * These need to be revisited when a newer toolchain becomes available.
2778 */
2779#if defined(__sparc64__) && defined(__GNUC__)
2780# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2781# undef SPARC64_MODF_WORKAROUND
2782# define SPARC64_MODF_WORKAROUND 1
2783# endif
2784#endif
2785
2786#if defined(SPARC64_MODF_WORKAROUND)
2787static NV
2788sparc64_workaround_modf(NV theVal, NV *theIntRes)
2789{
2790 NV res, ret;
2791 ret = Perl_modf(theVal, &res);
2792 *theIntRes = res;
2793 return ret;
2794}
2795#endif
2796
79072805
LW		 2797PP(pp_int)
2798{
39644a26 2799 dSP; dTARGET; tryAMAGICun(int);
774d564b 2800 {
28e5dec8
JH		 2801 NV value;
2802 IV iv = TOPi; /* attempt to convert to IV if possible. */
2803 /* XXX it's arguable that compiler casting to IV might be subtly
2804 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2805 else preferring IV has introduced a subtle behaviour change bug. OTOH
2806 relying on floating point to be accurate is a bug. */
2807
2808 if (SvIOK(TOPs)) {
2809 if (SvIsUV(TOPs)) {
2810 UV uv = TOPu;
2811 SETu(uv);
2812 } else
2813 SETi(iv);
2814 } else {
2815 value = TOPn;
1048ea30 2816 if (value >= 0.0) {
28e5dec8
JH		 2817 if (value < (NV)UV_MAX + 0.5) {
2818 SETu(U_V(value));
2819 } else {
24da999b 2820#if defined(SPARC64_MODF_WORKAROUND)
55954f19
JH		 2821 (void)sparc64_workaround_modf(value, &value);
2822#elif defined(HAS_MODFL_POW32_BUG)
e67aeab1 2823/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
55954f19
JH		 2824 NV offset = Perl_modf(value, &value);
2825 (void)Perl_modf(offset, &offset);
2826 value += offset;
2827#else
2828 (void)Perl_modf(value, &value);
1048ea30 2829#endif
2d9af89d 2830 SETn(value);
28e5dec8 2831 }
1048ea30 2832 }
28e5dec8
JH		 2833 else {
2834 if (value > (NV)IV_MIN - 0.5) {
2835 SETi(I_V(value));
2836 } else {
55954f19
JH		 2837#if defined(SPARC64_MODF_WORKAROUND)
2838 (void)sparc64_workaround_modf(-value, &value);
2839#elif defined(HAS_MODFL_POW32_BUG)
e67aeab1 2840/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
55954f19
JH		 2841 NV offset = Perl_modf(-value, &value);
2842 (void)Perl_modf(offset, &offset);
2843 value += offset;
1048ea30 2844#else
55954f19 2845 (void)Perl_modf(-value, &value);
1048ea30 2846#endif
55954f19 2847 SETn(-value);
28e5dec8
JH		 2848 }
2849 }
774d564b 2850 }
79072805 2851 }
79072805
LW		 2852 RETURN;
2853}
2854
463ee0b2
LW		 2855PP(pp_abs)
2856{
39644a26 2857 dSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 2858 {
28e5dec8
JH		 2859 /* This will cache the NV value if string isn't actually integer */
2860 IV iv = TOPi;
a227d84d 2861
28e5dec8
JH		 2862 if (SvIOK(TOPs)) {
2863 /* IVX is precise */
2864 if (SvIsUV(TOPs)) {
2865 SETu(TOPu); /* force it to be numeric only */
2866 } else {
2867 if (iv >= 0) {
2868 SETi(iv);
2869 } else {
2870 if (iv != IV_MIN) {
2871 SETi(-iv);
2872 } else {
2873 /* 2s complement assumption. Also, not really needed as
2874 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2875 SETu(IV_MIN);
2876 }
a227d84d 2877 }
28e5dec8
JH		 2878 }
2879 } else{
2880 NV value = TOPn;
774d564b 2881 if (value < 0.0)
28e5dec8 2882 value = -value;
774d564b 2883 SETn(value);
2884 }
a0d0e21e 2885 }
774d564b 2886 RETURN;
463ee0b2
LW		 2887}
2888
53305cf1 2889
79072805
LW		 2890PP(pp_hex)
2891{
39644a26 2892 dSP; dTARGET;
79072805 2893 char *tmps;
53305cf1 2894 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2895 STRLEN len;
53305cf1
NC		 2896 NV result_nv;
2897 UV result_uv;
2bc69dc4 2898 SV* sv = POPs;
79072805 2899
2bc69dc4
NIS		 2900 tmps = (SvPVx(sv, len));
2901 if (DO_UTF8(sv)) {
2902 /* If Unicode, try to downgrade
2903 * If not possible, croak. */
2904 SV* tsv = sv_2mortal(newSVsv(sv));
2905
2906 SvUTF8_on(tsv);
2907 sv_utf8_downgrade(tsv, FALSE);
2908 tmps = SvPVX(tsv);
2909 }
53305cf1
NC		 2910 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2911 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2912 XPUSHn(result_nv);
2913 }
2914 else {
2915 XPUSHu(result_uv);
2916 }
79072805
LW		 2917 RETURN;
2918}
2919
2920PP(pp_oct)
2921{
39644a26 2922 dSP; dTARGET;
79072805 2923 char *tmps;
53305cf1 2924 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2925 STRLEN len;
53305cf1
NC		 2926 NV result_nv;
2927 UV result_uv;
2bc69dc4 2928 SV* sv = POPs;
79072805 2929
2bc69dc4
NIS		 2930 tmps = (SvPVx(sv, len));
2931 if (DO_UTF8(sv)) {
2932 /* If Unicode, try to downgrade
2933 * If not possible, croak. */
2934 SV* tsv = sv_2mortal(newSVsv(sv));
2935
2936 SvUTF8_on(tsv);
2937 sv_utf8_downgrade(tsv, FALSE);
2938 tmps = SvPVX(tsv);
2939 }
6f894ead 2940 while (*tmps && len && isSPACE(*tmps))
53305cf1 2941 tmps++, len--;
9e24b6e2 2942 if (*tmps == '0')
53305cf1 2943 tmps++, len--;
9e24b6e2 2944 if (*tmps == 'x')
53305cf1 2945 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
9e24b6e2 2946 else if (*tmps == 'b')
53305cf1 2947 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2948 else
53305cf1
NC		 2949 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2950
2951 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2952 XPUSHn(result_nv);
2953 }
2954 else {
2955 XPUSHu(result_uv);
2956 }
79072805
LW		 2957 RETURN;
2958}
2959
2960/* String stuff. */
2961
2962PP(pp_length)
2963{
39644a26 2964 dSP; dTARGET;
7e2040f0 2965 SV *sv = TOPs;
a0ed51b3 2966
7e2040f0
GS		 2967 if (DO_UTF8(sv))
2968 SETi(sv_len_utf8(sv));
2969 else
2970 SETi(sv_len(sv));
79072805
LW		 2971 RETURN;
2972}
2973
2974PP(pp_substr)
2975{
39644a26 2976 dSP; dTARGET;
79072805 2977 SV *sv;
9c5ffd7c 2978 I32 len = 0;
463ee0b2 2979 STRLEN curlen;
9402d6ed 2980 STRLEN utf8_curlen;
79072805
LW		 2981 I32 pos;
2982 I32 rem;
84902520 2983 I32 fail;
78f9721b 2984 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
79072805 2985 char *tmps;
3280af22 2986 I32 arybase = PL_curcop->cop_arybase;
9402d6ed 2987 SV *repl_sv = NULL;
7b8d334a
GS		 2988 char *repl = 0;
2989 STRLEN repl_len;
78f9721b 2990 int num_args = PL_op->op_private & 7;
13e30c65 2991 bool repl_need_utf8_upgrade = FALSE;
9402d6ed 2992 bool repl_is_utf8 = FALSE;
79072805 2993
20408e3c 2994 SvTAINTED_off(TARG); /* decontaminate */
7e2040f0 2995 SvUTF8_off(TARG); /* decontaminate */
78f9721b
SM		 2996 if (num_args > 2) {
2997 if (num_args > 3) {
9402d6ed
JH		 2998 repl_sv = POPs;
2999 repl = SvPV(repl_sv, repl_len);
3000 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
7b8d334a 3001 }
79072805 3002 len = POPi;
5d82c453 3003 }
84902520 3004 pos = POPi;
79072805 3005 sv = POPs;
849ca7ee 3006 PUTBACK;
9402d6ed
JH		 3007 if (repl_sv) {
3008 if (repl_is_utf8) {
3009 if (!DO_UTF8(sv))
3010 sv_utf8_upgrade(sv);
3011 }
13e30c65
JH		 3012 else if (DO_UTF8(sv))
3013 repl_need_utf8_upgrade = TRUE;
9402d6ed 3014 }
a0d0e21e 3015 tmps = SvPV(sv, curlen);
7e2040f0 3016 if (DO_UTF8(sv)) {
9402d6ed
JH		 3017 utf8_curlen = sv_len_utf8(sv);
3018 if (utf8_curlen == curlen)
3019 utf8_curlen = 0;
a0ed51b3 3020 else
9402d6ed 3021 curlen = utf8_curlen;
a0ed51b3 3022 }
d1c2b58a 3023 else
9402d6ed 3024 utf8_curlen = 0;
a0ed51b3 3025
84902520
TB		 3026 if (pos >= arybase) {
3027 pos -= arybase;
3028 rem = curlen-pos;
3029 fail = rem;
78f9721b 3030 if (num_args > 2) {
5d82c453
GA		 3031 if (len < 0) {
3032 rem += len;
3033 if (rem < 0)
3034 rem = 0;
3035 }
3036 else if (rem > len)
3037 rem = len;
3038 }
68dc0745 3039 }
84902520 3040 else {
5d82c453 3041 pos += curlen;
78f9721b 3042 if (num_args < 3)
5d82c453
GA		 3043 rem = curlen;
3044 else if (len >= 0) {
3045 rem = pos+len;
3046 if (rem > (I32)curlen)
3047 rem = curlen;
3048 }
3049 else {
3050 rem = curlen+len;
3051 if (rem < pos)
3052 rem = pos;
3053 }
3054 if (pos < 0)
3055 pos = 0;
3056 fail = rem;
3057 rem -= pos;
84902520
TB		 3058 }
3059 if (fail < 0) {
e476b1b5
GS		 3060 if (lvalue || repl)
3061 Perl_croak(aTHX_ "substr outside of string");
3062 if (ckWARN(WARN_SUBSTR))
9014280d 3063 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2304df62
AD		 3064 RETPUSHUNDEF;
3065 }
79072805 3066 else {
9aa983d2
JH		 3067 I32 upos = pos;
3068 I32 urem = rem;
9402d6ed 3069 if (utf8_curlen)
a0ed51b3 3070 sv_pos_u2b(sv, &pos, &rem);
79072805 3071 tmps += pos;
79072805 3072 sv_setpvn(TARG, tmps, rem);
12aa1545 3073#ifdef USE_LOCALE_COLLATE
14befaf4 3074 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3075#endif
9402d6ed 3076 if (utf8_curlen)
7f66633b 3077 SvUTF8_on(TARG);
f7928d6c 3078 if (repl) {
13e30c65
JH		 3079 SV* repl_sv_copy = NULL;
3080
3081 if (repl_need_utf8_upgrade) {
3082 repl_sv_copy = newSVsv(repl_sv);
3083 sv_utf8_upgrade(repl_sv_copy);
3084 repl = SvPV(repl_sv_copy, repl_len);
3085 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3086 }
c8faf1c5 3087 sv_insert(sv, pos, rem, repl, repl_len);
9402d6ed 3088 if (repl_is_utf8)
f7928d6c 3089 SvUTF8_on(sv);
9402d6ed
JH		 3090 if (repl_sv_copy)
3091 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3092 }
c8faf1c5 3093 else if (lvalue) { /* it's an lvalue! */
dedeecda 3094 if (!SvGMAGICAL(sv)) {
3095 if (SvROK(sv)) {
2d8e6c8d
GS		 3096 STRLEN n_a;
3097 SvPV_force(sv,n_a);
599cee73 3098 if (ckWARN(WARN_SUBSTR))
9014280d 3099 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
599cee73 3100 "Attempt to use reference as lvalue in substr");
dedeecda 3101 }
3102 if (SvOK(sv)) /* is it defined ? */
7f66633b 3103 (void)SvPOK_only_UTF8(sv);
dedeecda 3104 else
3105 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3106 }
5f05dabc 3107
24aef97f
HS		 3108 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3109 TARG = sv_newmortal();
a0d0e21e
LW		 3110 if (SvTYPE(TARG) < SVt_PVLV) {
3111 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3112 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
ed6116ce 3113 }
6214ab63
AE		 3114 else
3115 (void)SvOK_off(TARG);
a0d0e21e 3116
5f05dabc 3117 LvTYPE(TARG) = 'x';
6ff81951
GS		 3118 if (LvTARG(TARG) != sv) {
3119 if (LvTARG(TARG))
3120 SvREFCNT_dec(LvTARG(TARG));
3121 LvTARG(TARG) = SvREFCNT_inc(sv);
3122 }
9aa983d2
JH		 3123 LvTARGOFF(TARG) = upos;
3124 LvTARGLEN(TARG) = urem;
79072805
LW		 3125 }
3126 }
849ca7ee 3127 SPAGAIN;
79072805
LW		 3128 PUSHs(TARG); /* avoid SvSETMAGIC here */
3129 RETURN;
3130}
3131
3132PP(pp_vec)
3133{
39644a26 3134 dSP; dTARGET;
467f0320
JH		 3135 register IV size = POPi;
3136 register IV offset = POPi;
79072805 3137 register SV *src = POPs;
78f9721b 3138 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e 3139
81e118e0
JH		 3140 SvTAINTED_off(TARG); /* decontaminate */
3141 if (lvalue) { /* it's an lvalue! */
24aef97f
HS		 3142 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3143 TARG = sv_newmortal();
81e118e0
JH		 3144 if (SvTYPE(TARG) < SVt_PVLV) {
3145 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3146 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
79072805 3147 }
81e118e0
JH		 3148 LvTYPE(TARG) = 'v';
3149 if (LvTARG(TARG) != src) {
3150 if (LvTARG(TARG))
3151 SvREFCNT_dec(LvTARG(TARG));
3152 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 3153 }
81e118e0
JH		 3154 LvTARGOFF(TARG) = offset;
3155 LvTARGLEN(TARG) = size;
79072805
LW		 3156 }
3157
81e118e0 3158 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW		 3159 PUSHs(TARG);
3160 RETURN;
3161}
3162
3163PP(pp_index)
3164{
39644a26 3165 dSP; dTARGET;
79072805
LW		 3166 SV *big;
3167 SV *little;
3168 I32 offset;
3169 I32 retval;
3170 char *tmps;
3171 char *tmps2;
463ee0b2 3172 STRLEN biglen;
3280af22 3173 I32 arybase = PL_curcop->cop_arybase;
79072805
LW		 3174
3175 if (MAXARG < 3)
3176 offset = 0;
3177 else
3178 offset = POPi - arybase;
3179 little = POPs;
3180 big = POPs;
463ee0b2 3181 tmps = SvPV(big, biglen);
7e2040f0 3182 if (offset > 0 && DO_UTF8(big))
a0ed51b3 3183 sv_pos_u2b(big, &offset, 0);
79072805
LW		 3184 if (offset < 0)
3185 offset = 0;
eb160463 3186 else if (offset > (I32)biglen)
93a17b20 3187 offset = biglen;
79072805 3188 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 3189 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 3190 retval = -1;
79072805 3191 else
a0ed51b3 3192 retval = tmps2 - tmps;
7e2040f0 3193 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3194 sv_pos_b2u(big, &retval);
3195 PUSHi(retval + arybase);
79072805
LW		 3196 RETURN;
3197}
3198
3199PP(pp_rindex)
3200{
39644a26 3201 dSP; dTARGET;
79072805
LW		 3202 SV *big;
3203 SV *little;
463ee0b2
LW		 3204 STRLEN blen;
3205 STRLEN llen;
79072805
LW		 3206 I32 offset;
3207 I32 retval;
3208 char *tmps;
3209 char *tmps2;
3280af22 3210 I32 arybase = PL_curcop->cop_arybase;
79072805 3211
a0d0e21e 3212 if (MAXARG >= 3)
a0ed51b3 3213 offset = POPi;
79072805
LW		 3214 little = POPs;
3215 big = POPs;
463ee0b2
LW		 3216 tmps2 = SvPV(little, llen);
3217 tmps = SvPV(big, blen);
79072805 3218 if (MAXARG < 3)
463ee0b2 3219 offset = blen;
a0ed51b3 3220 else {
7e2040f0 3221 if (offset > 0 && DO_UTF8(big))
a0ed51b3
LW		 3222 sv_pos_u2b(big, &offset, 0);
3223 offset = offset - arybase + llen;
3224 }
79072805
LW		 3225 if (offset < 0)
3226 offset = 0;
eb160463 3227 else if (offset > (I32)blen)
463ee0b2 3228 offset = blen;
79072805 3229 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 3230 tmps2, tmps2 + llen)))
a0ed51b3 3231 retval = -1;
79072805 3232 else
a0ed51b3 3233 retval = tmps2 - tmps;
7e2040f0 3234 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3235 sv_pos_b2u(big, &retval);
3236 PUSHi(retval + arybase);
79072805
LW		 3237 RETURN;
3238}
3239
3240PP(pp_sprintf)
3241{
39644a26 3242 dSP; dMARK; dORIGMARK; dTARGET;
79072805 3243 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3244 TAINT_IF(SvTAINTED(TARG));
6ee35fb7
JH		 3245 if (DO_UTF8(*(MARK+1)))
3246 SvUTF8_on(TARG);
79072805
LW		 3247 SP = ORIGMARK;
3248 PUSHTARG;
3249 RETURN;
3250}
3251
79072805
LW		 3252PP(pp_ord)
3253{
39644a26 3254 dSP; dTARGET;
7df053ec 3255 SV *argsv = POPs;
ba210ebe 3256 STRLEN len;
7df053ec 3257 U8 *s = (U8*)SvPVx(argsv, len);
121910a4
JH		 3258 SV *tmpsv;
3259
799ef3cb 3260 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
121910a4 3261 tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3262 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH		 3263 argsv = tmpsv;
3264 }
79072805 3265
872c91ae
JH		 3266 XPUSHu(DO_UTF8(argsv) ?
3267 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3268 (*s & 0xff));
68795e93 3269
79072805
LW		 3270 RETURN;
3271}
3272
463ee0b2
LW		 3273PP(pp_chr)
3274{
39644a26 3275 dSP; dTARGET;
463ee0b2 3276 char *tmps;
467f0320 3277 UV value = POPu;
463ee0b2 3278
748a9306 3279 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3280
0064a8a9 3281 if (value > 255 && !IN_BYTES) {
eb160463 3282 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3283 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
a0ed51b3
LW		 3284 SvCUR_set(TARG, tmps - SvPVX(TARG));
3285 *tmps = '\0';
3286 (void)SvPOK_only(TARG);
aa6ffa16 3287 SvUTF8_on(TARG);
a0ed51b3
LW		 3288 XPUSHs(TARG);
3289 RETURN;
3290 }
3291
748a9306 3292 SvGROW(TARG,2);
463ee0b2
LW		 3293 SvCUR_set(TARG, 1);
3294 tmps = SvPVX(TARG);
eb160463 3295 *tmps++ = (char)value;
748a9306 3296 *tmps = '\0';
a0d0e21e 3297 (void)SvPOK_only(TARG);
88632417 3298 if (PL_encoding && !IN_BYTES) {
799ef3cb 3299 sv_recode_to_utf8(TARG, PL_encoding);
88632417
JH		 3300 tmps = SvPVX(TARG);
3301 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3302 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
d5a15ac2
JH		 3303 SvGROW(TARG, 3);
3304 tmps = SvPVX(TARG);
88632417
JH		 3305 SvCUR_set(TARG, 2);
3306 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3307 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3308 *tmps = '\0';
3309 SvUTF8_on(TARG);
3310 }
3311 }
463ee0b2
LW		 3312 XPUSHs(TARG);
3313 RETURN;
3314}
3315
79072805
LW		 3316PP(pp_crypt)
3317{
5f74f29c 3318 dSP; dTARGET;
79072805 3319#ifdef HAS_CRYPT
5f74f29c
JH		 3320 dPOPTOPssrl;
3321 STRLEN n_a;
85c16d83
JH		 3322 STRLEN len;
3323 char *tmps = SvPV(left, len);
2bc69dc4 3324
85c16d83 3325 if (DO_UTF8(left)) {
2bc69dc4 3326 /* If Unicode, try to downgrade.
f2791508
JH		 3327 * If not possible, croak.
3328 * Yes, we made this up. */
3329 SV* tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3330
f2791508 3331 SvUTF8_on(tsv);
2bc69dc4 3332 sv_utf8_downgrade(tsv, FALSE);
f2791508 3333 tmps = SvPVX(tsv);
85c16d83 3334 }
05404ffe
JH		 3335# ifdef USE_ITHREADS
3336# ifdef HAS_CRYPT_R
3337 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3338 /* This should be threadsafe because in ithreads there is only
3339 * one thread per interpreter. If this would not be true,
3340 * we would need a mutex to protect this malloc. */
3341 PL_reentrant_buffer->_crypt_struct_buffer =
3342 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3343#if defined(__GLIBC__) || defined(__EMX__)
3344 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3345 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3346 /* work around glibc-2.2.5 bug */
3347 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3348 }
05404ffe 3349#endif
6ab58e4d 3350 }
05404ffe
JH		 3351# endif /* HAS_CRYPT_R */
3352# endif /* USE_ITHREADS */
5f74f29c 3353# ifdef FCRYPT
2d8e6c8d 3354 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
5f74f29c 3355# else
2d8e6c8d 3356 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
5f74f29c 3357# endif
4808266b
JH		 3358 SETs(TARG);
3359 RETURN;
79072805 3360#else
b13b2135 3361 DIE(aTHX_
79072805
LW		 3362 "The crypt() function is unimplemented due to excessive paranoia.");
3363#endif
79072805
LW		 3364}
3365
3366PP(pp_ucfirst)
3367{
39644a26 3368 dSP;
79072805 3369 SV *sv = TOPs;
a0ed51b3
LW		 3370 register U8 *s;
3371 STRLEN slen;
3372
d104a74c 3373 SvGETMAGIC(sv);
3a2263fe
RGS		 3374 if (DO_UTF8(sv) &&
3375 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3376 UTF8_IS_START(*s)) {
e7ae6809 3377 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
44bc797b
JH		 3378 STRLEN ulen;
3379 STRLEN tculen;
a0ed51b3 3380
44bc797b 3381 utf8_to_uvchr(s, &ulen);
44bc797b
JH		 3382 toTITLE_utf8(s, tmpbuf, &tculen);
3383 utf8_to_uvchr(tmpbuf, 0);
3384
3385 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
a0ed51b3 3386 dTARGET;
3a2263fe
RGS		 3387 /* slen is the byte length of the whole SV.
3388 * ulen is the byte length of the original Unicode character
3389 * stored as UTF-8 at s.
3390 * tculen is the byte length of the freshly titlecased
3391 * Unicode character stored as UTF-8 at tmpbuf.
3392 * We first set the result to be the titlecased character,
3393 * and then append the rest of the SV data. */
44bc797b 3394 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3a2263fe
RGS		 3395 if (slen > ulen)
3396 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3397 SvUTF8_on(TARG);
a0ed51b3
LW		 3398 SETs(TARG);
3399 }
3400 else {
d104a74c 3401 s = (U8*)SvPV_force_nomg(sv, slen);
44bc797b 3402 Copy(tmpbuf, s, tculen, U8);
a0ed51b3 3403 }
a0ed51b3 3404 }
626727d5 3405 else {
014822e4 3406 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3407 dTARGET;
7e2040f0 3408 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3409 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3410 sv = TARG;
3411 SETs(sv);
3412 }
d104a74c 3413 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3414 if (*s) {
2de3dbcc 3415 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3416 TAINT;
3417 SvTAINTED_on(sv);
3418 *s = toUPPER_LC(*s);
3419 }
3420 else
3421 *s = toUPPER(*s);
bbce6d69 3422 }
bbce6d69 3423 }
d104a74c 3424 SvSETMAGIC(sv);
79072805
LW		 3425 RETURN;
3426}
3427
3428PP(pp_lcfirst)
3429{
39644a26 3430 dSP;
79072805 3431 SV *sv = TOPs;
a0ed51b3
LW		 3432 register U8 *s;
3433 STRLEN slen;
3434
d104a74c 3435 SvGETMAGIC(sv);
3a2263fe
RGS		 3436 if (DO_UTF8(sv) &&
3437 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3438 UTF8_IS_START(*s)) {
ba210ebe 3439 STRLEN ulen;
e7ae6809 3440 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3441 U8 *tend;
9041c2e3 3442 UV uv;
a0ed51b3 3443
44bc797b 3444 toLOWER_utf8(s, tmpbuf, &ulen);
a2a2844f 3445 uv = utf8_to_uvchr(tmpbuf, 0);
9041c2e3 3446 tend = uvchr_to_utf8(tmpbuf, uv);
a0ed51b3 3447
eb160463 3448 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
a0ed51b3 3449 dTARGET;
dfe13c55 3450 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3a2263fe
RGS		 3451 if (slen > ulen)
3452 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3453 SvUTF8_on(TARG);
a0ed51b3
LW		 3454 SETs(TARG);
3455 }
3456 else {
d104a74c 3457 s = (U8*)SvPV_force_nomg(sv, slen);
a0ed51b3
LW		 3458 Copy(tmpbuf, s, ulen, U8);
3459 }
a0ed51b3 3460 }
626727d5 3461 else {
014822e4 3462 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3463 dTARGET;
7e2040f0 3464 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3465 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3466 sv = TARG;
3467 SETs(sv);
3468 }
d104a74c 3469 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3470 if (*s) {
2de3dbcc 3471 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3472 TAINT;
3473 SvTAINTED_on(sv);
3474 *s = toLOWER_LC(*s);
3475 }
3476 else
3477 *s = toLOWER(*s);
bbce6d69 3478 }
bbce6d69 3479 }
d104a74c 3480 SvSETMAGIC(sv);
79072805
LW		 3481 RETURN;
3482}
3483
3484PP(pp_uc)
3485{
39644a26 3486 dSP;
79072805 3487 SV *sv = TOPs;
a0ed51b3 3488 register U8 *s;
463ee0b2 3489 STRLEN len;
79072805 3490
d104a74c 3491 SvGETMAGIC(sv);
7e2040f0 3492 if (DO_UTF8(sv)) {
a0ed51b3 3493 dTARGET;
ba210ebe 3494 STRLEN ulen;
a0ed51b3
LW		 3495 register U8 *d;
3496 U8 *send;
e7ae6809 3497 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3498
d104a74c 3499 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3500 if (!len) {
7e2040f0 3501 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3502 sv_setpvn(TARG, "", 0);
3503 SETs(TARG);
a0ed51b3
LW		 3504 }
3505 else {
98b27f73
JH		 3506 STRLEN nchar = utf8_length(s, s + len);
3507
31351b04 3508 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3509 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3510 (void)SvPOK_only(TARG);
3511 d = (U8*)SvPVX(TARG);
3512 send = s + len;
a2a2844f 3513 while (s < send) {
6fdb5f96 3514 toUPPER_utf8(s, tmpbuf, &ulen);
a2a2844f
JH		 3515 Copy(tmpbuf, d, ulen, U8);
3516 d += ulen;
3517 s += UTF8SKIP(s);
a0ed51b3 3518 }
31351b04 3519 *d = '\0';
7e2040f0 3520 SvUTF8_on(TARG);
31351b04
JS		 3521 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3522 SETs(TARG);
a0ed51b3 3523 }
a0ed51b3 3524 }
626727d5 3525 else {
014822e4 3526 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3527 dTARGET;
7e2040f0 3528 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3529 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3530 sv = TARG;
3531 SETs(sv);
3532 }
d104a74c 3533 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3534 if (len) {
3535 register U8 *send = s + len;
3536
2de3dbcc 3537 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3538 TAINT;
3539 SvTAINTED_on(sv);
3540 for (; s < send; s++)
3541 *s = toUPPER_LC(*s);
3542 }
3543 else {
3544 for (; s < send; s++)
3545 *s = toUPPER(*s);
3546 }
bbce6d69 3547 }
79072805 3548 }
d104a74c 3549 SvSETMAGIC(sv);
79072805
LW		 3550 RETURN;
3551}
3552
3553PP(pp_lc)
3554{
39644a26 3555 dSP;
79072805 3556 SV *sv = TOPs;
a0ed51b3 3557 register U8 *s;
463ee0b2 3558 STRLEN len;
79072805 3559
d104a74c 3560 SvGETMAGIC(sv);
7e2040f0 3561 if (DO_UTF8(sv)) {
a0ed51b3 3562 dTARGET;
ba210ebe 3563 STRLEN ulen;
a0ed51b3
LW		 3564 register U8 *d;
3565 U8 *send;
e7ae6809 3566 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3567
d104a74c 3568 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3569 if (!len) {
7e2040f0 3570 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3571 sv_setpvn(TARG, "", 0);
3572 SETs(TARG);
a0ed51b3
LW		 3573 }
3574 else {
98b27f73
JH		 3575 STRLEN nchar = utf8_length(s, s + len);
3576
31351b04 3577 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3578 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3579 (void)SvPOK_only(TARG);
3580 d = (U8*)SvPVX(TARG);
3581 send = s + len;
a2a2844f 3582 while (s < send) {
6fdb5f96
JH		 3583 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3584#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3585 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3586 /*
3587 * Now if the sigma is NOT followed by
3588 * /$ignorable_sequence$cased_letter/;
3589 * and it IS preceded by
3590 * /$cased_letter$ignorable_sequence/;
3591 * where $ignorable_sequence is
3592 * [\x{2010}\x{AD}\p{Mn}]*
3593 * and $cased_letter is
3594 * [\p{Ll}\p{Lo}\p{Lt}]
3595 * then it should be mapped to 0x03C2,
3596 * (GREEK SMALL LETTER FINAL SIGMA),
3597 * instead of staying 0x03A3.
3598 * See lib/unicore/SpecCase.txt.
3599 */
3600 }
a2a2844f
JH		 3601 Copy(tmpbuf, d, ulen, U8);
3602 d += ulen;
3603 s += UTF8SKIP(s);
a0ed51b3 3604 }
31351b04 3605 *d = '\0';
7e2040f0 3606 SvUTF8_on(TARG);
31351b04
JS		 3607 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3608 SETs(TARG);
a0ed51b3 3609 }
79072805 3610 }
626727d5 3611 else {
014822e4 3612 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3613 dTARGET;
7e2040f0 3614 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3615 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3616 sv = TARG;
3617 SETs(sv);
a0ed51b3 3618 }
bbce6d69 3619
d104a74c 3620 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3621 if (len) {
3622 register U8 *send = s + len;
bbce6d69 3623
2de3dbcc 3624 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3625 TAINT;
3626 SvTAINTED_on(sv);
3627 for (; s < send; s++)
3628 *s = toLOWER_LC(*s);
3629 }
3630 else {
3631 for (; s < send; s++)
3632 *s = toLOWER(*s);
3633 }
bbce6d69 3634 }
79072805 3635 }
d104a74c 3636 SvSETMAGIC(sv);
79072805
LW		 3637 RETURN;
3638}
3639
a0d0e21e 3640PP(pp_quotemeta)
79072805 3641{
39644a26 3642 dSP; dTARGET;
a0d0e21e
LW		 3643 SV *sv = TOPs;
3644 STRLEN len;
3645 register char *s = SvPV(sv,len);
3646 register char *d;
79072805 3647
7e2040f0 3648 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW		 3649 if (len) {
3650 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 3651 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3652 d = SvPVX(TARG);
7e2040f0 3653 if (DO_UTF8(sv)) {
0dd2cdef 3654 while (len) {
fd400ab9 3655 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 3656 STRLEN ulen = UTF8SKIP(s);
3657 if (ulen > len)
3658 ulen = len;
3659 len -= ulen;
3660 while (ulen--)
3661 *d++ = *s++;
3662 }
3663 else {
3664 if (!isALNUM(*s))
3665 *d++ = '\\';
3666 *d++ = *s++;
3667 len--;
3668 }
3669 }
7e2040f0 3670 SvUTF8_on(TARG);
0dd2cdef
LW		 3671 }
3672 else {
3673 while (len--) {
3674 if (!isALNUM(*s))
3675 *d++ = '\\';
3676 *d++ = *s++;
3677 }
79072805 3678 }
a0d0e21e
LW		 3679 *d = '\0';
3680 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 3681 (void)SvPOK_only_UTF8(TARG);
79072805 3682 }
a0d0e21e
LW		 3683 else
3684 sv_setpvn(TARG, s, len);
3685 SETs(TARG);
31351b04
JS		 3686 if (SvSMAGICAL(TARG))
3687 mg_set(TARG);
79072805
LW		 3688 RETURN;
3689}
3690
a0d0e21e 3691/* Arrays. */
79072805 3692
a0d0e21e 3693PP(pp_aslice)
79072805 3694{
39644a26 3695 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3696 register SV** svp;
3697 register AV* av = (AV*)POPs;
78f9721b 3698 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3280af22 3699 I32 arybase = PL_curcop->cop_arybase;
748a9306 3700 I32 elem;
79072805 3701
a0d0e21e 3702 if (SvTYPE(av) == SVt_PVAV) {
533c011a 3703 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 3704 I32 max = -1;
924508f0 3705 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 3706 elem = SvIVx(*svp);
3707 if (elem > max)
3708 max = elem;
3709 }
3710 if (max > AvMAX(av))
3711 av_extend(av, max);
3712 }
a0d0e21e 3713 while (++MARK <= SP) {
748a9306 3714 elem = SvIVx(*MARK);
a0d0e21e 3715
748a9306
LW		 3716 if (elem > 0)
3717 elem -= arybase;
a0d0e21e
LW		 3718 svp = av_fetch(av, elem, lval);
3719 if (lval) {
3280af22 3720 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 3721 DIE(aTHX_ PL_no_aelem, elem);
533c011a 3722 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 3723 save_aelem(av, elem, svp);
79072805 3724 }
3280af22 3725 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 3726 }
3727 }
748a9306 3728 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 3729 MARK = ORIGMARK;
3730 *++MARK = *SP;
3731 SP = MARK;
3732 }
79072805
LW		 3733 RETURN;
3734}
3735
3736/* Associative arrays. */
3737
3738PP(pp_each)
3739{
39644a26 3740 dSP;
79072805 3741 HV *hash = (HV*)POPs;
c07a80fd 3742 HE *entry;
54310121 3743 I32 gimme = GIMME_V;
8ec5e241 3744
c07a80fd 3745 PUTBACK;
c750a3ec 3746 /* might clobber stack_sp */
6d822dc4 3747 entry = hv_iternext(hash);
c07a80fd 3748 SPAGAIN;
79072805 3749
79072805
LW		 3750 EXTEND(SP, 2);
3751 if (entry) {
574c8022 3752 SV* sv = hv_iterkeysv(entry);
574c8022 3753 PUSHs(sv); /* won't clobber stack_sp */
54310121 3754 if (gimme == G_ARRAY) {
59af0135 3755 SV *val;
c07a80fd 3756 PUTBACK;
c750a3ec 3757 /* might clobber stack_sp */
6d822dc4 3758 val = hv_iterval(hash, entry);
c07a80fd 3759 SPAGAIN;
59af0135 3760 PUSHs(val);
79072805 3761 }
79072805 3762 }
54310121 3763 else if (gimme == G_SCALAR)
79072805
LW		 3764 RETPUSHUNDEF;
3765
3766 RETURN;
3767}
3768
3769PP(pp_values)
3770{
cea2e8a9 3771 return do_kv();
79072805
LW		 3772}
3773
3774PP(pp_keys)
3775{
cea2e8a9 3776 return do_kv();
79072805
LW		 3777}
3778
3779PP(pp_delete)
3780{
39644a26 3781 dSP;
54310121 3782 I32 gimme = GIMME_V;
3783 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 3784 SV *sv;
5f05dabc 3785 HV *hv;
3786
533c011a 3787 if (PL_op->op_private & OPpSLICE) {
5f05dabc 3788 dMARK; dORIGMARK;
97fcbf96 3789 U32 hvtype;
5f05dabc 3790 hv = (HV*)POPs;
97fcbf96 3791 hvtype = SvTYPE(hv);
01020589
GS		 3792 if (hvtype == SVt_PVHV) { /* hash element */
3793 while (++MARK <= SP) {
ae77835f 3794 sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 3795 *MARK = sv ? sv : &PL_sv_undef;
3796 }
5f05dabc 3797 }
6d822dc4
MS		 3798 else if (hvtype == SVt_PVAV) { /* array element */
3799 if (PL_op->op_flags & OPf_SPECIAL) {
3800 while (++MARK <= SP) {
3801 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3802 *MARK = sv ? sv : &PL_sv_undef;
3803 }
3804 }
01020589
GS		 3805 }
3806 else
3807 DIE(aTHX_ "Not a HASH reference");
54310121 3808 if (discard)
3809 SP = ORIGMARK;
3810 else if (gimme == G_SCALAR) {
5f05dabc 3811 MARK = ORIGMARK;
3812 *++MARK = *SP;
3813 SP = MARK;
3814 }
3815 }
3816 else {
3817 SV *keysv = POPs;
3818 hv = (HV*)POPs;
97fcbf96
MB		 3819 if (SvTYPE(hv) == SVt_PVHV)
3820 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 3821 else if (SvTYPE(hv) == SVt_PVAV) {
3822 if (PL_op->op_flags & OPf_SPECIAL)
3823 sv = av_delete((AV*)hv, SvIV(keysv), discard);
af288a60
HS		 3824 else
3825 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 3826 }
97fcbf96 3827 else
cea2e8a9 3828 DIE(aTHX_ "Not a HASH reference");
5f05dabc 3829 if (!sv)
3280af22 3830 sv = &PL_sv_undef;
54310121 3831 if (!discard)
3832 PUSHs(sv);
79072805 3833 }
79072805
LW		 3834 RETURN;
3835}
3836
a0d0e21e 3837PP(pp_exists)
79072805 3838{
39644a26 3839 dSP;
afebc493
GS		 3840 SV *tmpsv;
3841 HV *hv;
3842
3843 if (PL_op->op_private & OPpEXISTS_SUB) {
3844 GV *gv;
3845 CV *cv;
3846 SV *sv = POPs;
3847 cv = sv_2cv(sv, &hv, &gv, FALSE);
3848 if (cv)
3849 RETPUSHYES;
3850 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3851 RETPUSHYES;
3852 RETPUSHNO;
3853 }
3854 tmpsv = POPs;
3855 hv = (HV*)POPs;
c750a3ec 3856 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 3857 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 3858 RETPUSHYES;
ef54e1a4
JH		 3859 }
3860 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS		 3861 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3862 if (av_exists((AV*)hv, SvIV(tmpsv)))
3863 RETPUSHYES;
3864 }
ef54e1a4
JH		 3865 }
3866 else {
cea2e8a9 3867 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 3868 }
a0d0e21e
LW		 3869 RETPUSHNO;
3870}
79072805 3871
a0d0e21e
LW		 3872PP(pp_hslice)
3873{
39644a26 3874 dSP; dMARK; dORIGMARK;
a0d0e21e 3875 register HV *hv = (HV*)POPs;
78f9721b 3876 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
eb85dfd3
DM		 3877 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3878 bool other_magic = FALSE;
79072805 3879
eb85dfd3
DM		 3880 if (localizing) {
3881 MAGIC *mg;
3882 HV *stash;
3883
3884 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3885 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3886 /* Try to preserve the existenceness of a tied hash
3887 * element by using EXISTS and DELETE if possible.
3888 * Fallback to FETCH and STORE otherwise */
3889 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3890 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3891 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3892 }
3893
6d822dc4
MS		 3894 while (++MARK <= SP) {
3895 SV *keysv = *MARK;
3896 SV **svp;
3897 HE *he;
3898 bool preeminent = FALSE;
0ebe0038 3899
6d822dc4
MS		 3900 if (localizing) {
3901 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3902 hv_exists_ent(hv, keysv, 0);
3903 }
eb85dfd3 3904
6d822dc4
MS		 3905 he = hv_fetch_ent(hv, keysv, lval, 0);
3906 svp = he ? &HeVAL(he) : 0;
eb85dfd3 3907
6d822dc4
MS		 3908 if (lval) {
3909 if (!svp || *svp == &PL_sv_undef) {
3910 STRLEN n_a;
3911 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3912 }
3913 if (localizing) {
3914 if (preeminent)
3915 save_helem(hv, keysv, svp);
3916 else {
3917 STRLEN keylen;
3918 char *key = SvPV(keysv, keylen);
3919 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1f5346dc 3920 }
6d822dc4
MS		 3921 }
3922 }
3923 *MARK = svp ? *svp : &PL_sv_undef;
79072805 3924 }
a0d0e21e
LW		 3925 if (GIMME != G_ARRAY) {
3926 MARK = ORIGMARK;
3927 *++MARK = *SP;
3928 SP = MARK;
79072805 3929 }
a0d0e21e
LW		 3930 RETURN;
3931}
3932
3933/* List operators. */
3934
3935PP(pp_list)
3936{
39644a26 3937 dSP; dMARK;
a0d0e21e
LW		 3938 if (GIMME != G_ARRAY) {
3939 if (++MARK <= SP)
3940 *MARK = *SP; /* unwanted list, return last item */
8990e307 3941 else
3280af22 3942 *MARK = &PL_sv_undef;
a0d0e21e 3943 SP = MARK;
79072805 3944 }
a0d0e21e 3945 RETURN;
79072805
LW		 3946}
3947
a0d0e21e 3948PP(pp_lslice)
79072805 3949{
39644a26 3950 dSP;
3280af22
NIS		 3951 SV **lastrelem = PL_stack_sp;
3952 SV **lastlelem = PL_stack_base + POPMARK;
3953 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 3954 register SV **firstrelem = lastlelem + 1;
3280af22 3955 I32 arybase = PL_curcop->cop_arybase;
533c011a 3956 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 3957 I32 is_something_there = lval;
79072805 3958
a0d0e21e
LW		 3959 register I32 max = lastrelem - lastlelem;
3960 register SV **lelem;
3961 register I32 ix;
3962
3963 if (GIMME != G_ARRAY) {
748a9306
LW		 3964 ix = SvIVx(*lastlelem);
3965 if (ix < 0)
3966 ix += max;
3967 else
3968 ix -= arybase;
a0d0e21e 3969 if (ix < 0 || ix >= max)
3280af22 3970 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 3971 else
3972 *firstlelem = firstrelem[ix];
3973 SP = firstlelem;
3974 RETURN;
3975 }
3976
3977 if (max == 0) {
3978 SP = firstlelem - 1;
3979 RETURN;
3980 }
3981
3982 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 3983 ix = SvIVx(*lelem);
c73bf8e3 3984 if (ix < 0)
a0d0e21e 3985 ix += max;
b13b2135 3986 else
748a9306 3987 ix -= arybase;
c73bf8e3
HS		 3988 if (ix < 0 || ix >= max)
3989 *lelem = &PL_sv_undef;
3990 else {
3991 is_something_there = TRUE;
3992 if (!(*lelem = firstrelem[ix]))
3280af22 3993 *lelem = &PL_sv_undef;
748a9306 3994 }
79072805 3995 }
4633a7c4
LW		 3996 if (is_something_there)
3997 SP = lastlelem;
3998 else
3999 SP = firstlelem - 1;
79072805
LW		 4000 RETURN;
4001}
4002
a0d0e21e
LW		 4003PP(pp_anonlist)
4004{
39644a26 4005 dSP; dMARK; dORIGMARK;
a0d0e21e 4006 I32 items = SP - MARK;
44a8e56a 4007 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4008 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4009 XPUSHs(av);
a0d0e21e
LW		 4010 RETURN;
4011}
4012
4013PP(pp_anonhash)
79072805 4014{
39644a26 4015 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 4016 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4017
4018 while (MARK < SP) {
4019 SV* key = *++MARK;
a0d0e21e
LW		 4020 SV *val = NEWSV(46, 0);
4021 if (MARK < SP)
4022 sv_setsv(val, *++MARK);
e476b1b5 4023 else if (ckWARN(WARN_MISC))
9014280d 4024 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
f12c7020 4025 (void)hv_store_ent(hv,key,val,0);
79072805 4026 }
a0d0e21e
LW		 4027 SP = ORIGMARK;
4028 XPUSHs((SV*)hv);
79072805
LW		 4029 RETURN;
4030}
4031
a0d0e21e 4032PP(pp_splice)
79072805 4033{
39644a26 4034 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 4035 register AV *ary = (AV*)*++MARK;
4036 register SV **src;
4037 register SV **dst;
4038 register I32 i;
4039 register I32 offset;
4040 register I32 length;
4041 I32 newlen;
4042 I32 after;
4043 I32 diff;
4044 SV **tmparyval = 0;
93965878
NIS		 4045 MAGIC *mg;
4046
14befaf4 4047 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4048 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 4049 PUSHMARK(MARK);
8ec5e241 4050 PUTBACK;
a60c0954 4051 ENTER;
864dbfa3 4052 call_method("SPLICE",GIMME_V);
a60c0954 4053 LEAVE;
93965878
NIS		 4054 SPAGAIN;
4055 RETURN;
4056 }
79072805 4057
a0d0e21e 4058 SP++;
79072805 4059
a0d0e21e 4060 if (++MARK < SP) {
84902520 4061 offset = i = SvIVx(*MARK);
a0d0e21e 4062 if (offset < 0)
93965878 4063 offset += AvFILLp(ary) + 1;
a0d0e21e 4064 else
3280af22 4065 offset -= PL_curcop->cop_arybase;
84902520 4066 if (offset < 0)
cea2e8a9 4067 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 4068 if (++MARK < SP) {
4069 length = SvIVx(*MARK++);
48cdf507
GA		 4070 if (length < 0) {
4071 length += AvFILLp(ary) - offset + 1;
4072 if (length < 0)
4073 length = 0;
4074 }
79072805
LW		 4075 }
4076 else
a0d0e21e 4077 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 4078 }
a0d0e21e
LW		 4079 else {
4080 offset = 0;
4081 length = AvMAX(ary) + 1;
4082 }
8cbc2e3b
JH		 4083 if (offset > AvFILLp(ary) + 1) {
4084 if (ckWARN(WARN_MISC))
9014280d 4085 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 4086 offset = AvFILLp(ary) + 1;
8cbc2e3b 4087 }
93965878 4088 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 4089 if (after < 0) { /* not that much array */
4090 length += after; /* offset+length now in array */
4091 after = 0;
4092 if (!AvALLOC(ary))
4093 av_extend(ary, 0);
4094 }
4095
4096 /* At this point, MARK .. SP-1 is our new LIST */
4097
4098 newlen = SP - MARK;
4099 diff = newlen - length;
13d7cbc1
GS		 4100 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4101 av_reify(ary);
a0d0e21e
LW		 4102
4103 if (diff < 0) { /* shrinking the area */
4104 if (newlen) {
4105 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4106 Copy(MARK, tmparyval, newlen, SV*);
79072805 4107 }
a0d0e21e
LW		 4108
4109 MARK = ORIGMARK + 1;
4110 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4111 MEXTEND(MARK, length);
4112 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4113 if (AvREAL(ary)) {
bbce6d69 4114 EXTEND_MORTAL(length);
36477c24 4115 for (i = length, dst = MARK; i; i--) {
d689ffdd 4116 sv_2mortal(*dst); /* free them eventualy */
36477c24 4117 dst++;
4118 }
a0d0e21e
LW		 4119 }
4120 MARK += length - 1;
79072805 4121 }
a0d0e21e
LW		 4122 else {
4123 *MARK = AvARRAY(ary)[offset+length-1];
4124 if (AvREAL(ary)) {
d689ffdd 4125 sv_2mortal(*MARK);
a0d0e21e
LW		 4126 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4127 SvREFCNT_dec(*dst++); /* free them now */
79072805 4128 }
a0d0e21e 4129 }
93965878 4130 AvFILLp(ary) += diff;
a0d0e21e
LW		 4131
4132 /* pull up or down? */
4133
4134 if (offset < after) { /* easier to pull up */
4135 if (offset) { /* esp. if nothing to pull */
4136 src = &AvARRAY(ary)[offset-1];
4137 dst = src - diff; /* diff is negative */
4138 for (i = offset; i > 0; i--) /* can't trust Copy */
4139 *dst-- = *src--;
79072805 4140 }
a0d0e21e
LW		 4141 dst = AvARRAY(ary);
4142 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4143 AvMAX(ary) += diff;
4144 }
4145 else {
4146 if (after) { /* anything to pull down? */
4147 src = AvARRAY(ary) + offset + length;
4148 dst = src + diff; /* diff is negative */
4149 Move(src, dst, after, SV*);
79072805 4150 }
93965878 4151 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 4152 /* avoid later double free */
4153 }
4154 i = -diff;
4155 while (i)
3280af22 4156 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 4157
4158 if (newlen) {
4159 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4160 newlen; newlen--) {
4161 *dst = NEWSV(46, 0);
4162 sv_setsv(*dst++, *src++);
79072805 4163 }
a0d0e21e
LW		 4164 Safefree(tmparyval);
4165 }
4166 }
4167 else { /* no, expanding (or same) */
4168 if (length) {
4169 New(452, tmparyval, length, SV*); /* so remember deletion */
4170 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4171 }
4172
4173 if (diff > 0) { /* expanding */
4174
4175 /* push up or down? */
4176
4177 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4178 if (offset) {
4179 src = AvARRAY(ary);
4180 dst = src - diff;
4181 Move(src, dst, offset, SV*);
79072805 4182 }
a0d0e21e
LW		 4183 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4184 AvMAX(ary) += diff;
93965878 4185 AvFILLp(ary) += diff;
79072805
LW		 4186 }
4187 else {
93965878
NIS		 4188 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4189 av_extend(ary, AvFILLp(ary) + diff);
4190 AvFILLp(ary) += diff;
a0d0e21e
LW		 4191
4192 if (after) {
93965878 4193 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 4194 src = dst - diff;
4195 for (i = after; i; i--) {
4196 *dst-- = *src--;
4197 }
79072805
LW		 4198 }
4199 }
a0d0e21e
LW		 4200 }
4201
4202 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4203 *dst = NEWSV(46, 0);
4204 sv_setsv(*dst++, *src++);
4205 }
4206 MARK = ORIGMARK + 1;
4207 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4208 if (length) {
4209 Copy(tmparyval, MARK, length, SV*);
4210 if (AvREAL(ary)) {
bbce6d69 4211 EXTEND_MORTAL(length);
36477c24 4212 for (i = length, dst = MARK; i; i--) {
d689ffdd 4213 sv_2mortal(*dst); /* free them eventualy */
36477c24 4214 dst++;
4215 }
79072805 4216 }
a0d0e21e 4217 Safefree(tmparyval);
79072805 4218 }
a0d0e21e
LW		 4219 MARK += length - 1;
4220 }
4221 else if (length--) {
4222 *MARK = tmparyval[length];
4223 if (AvREAL(ary)) {
d689ffdd 4224 sv_2mortal(*MARK);
a0d0e21e
LW		 4225 while (length-- > 0)
4226 SvREFCNT_dec(tmparyval[length]);
79072805 4227 }
a0d0e21e 4228 Safefree(tmparyval);
79072805 4229 }
a0d0e21e 4230 else
3280af22 4231 *MARK = &PL_sv_undef;
79072805 4232 }
a0d0e21e 4233 SP = MARK;
79072805
LW		 4234 RETURN;
4235}
4236
a0d0e21e 4237PP(pp_push)
79072805 4238{
39644a26 4239 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4240 register AV *ary = (AV*)*++MARK;
3280af22 4241 register SV *sv = &PL_sv_undef;
93965878 4242 MAGIC *mg;
79072805 4243
14befaf4 4244 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4245 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS		 4246 PUSHMARK(MARK);
4247 PUTBACK;
a60c0954 4248 ENTER;
864dbfa3 4249 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 4250 LEAVE;
93965878 4251 SPAGAIN;
93965878 4252 }
a60c0954
NIS		 4253 else {
4254 /* Why no pre-extend of ary here ? */
4255 for (++MARK; MARK <= SP; MARK++) {
4256 sv = NEWSV(51, 0);
4257 if (*MARK)
4258 sv_setsv(sv, *MARK);
4259 av_push(ary, sv);
4260 }
79072805
LW		 4261 }
4262 SP = ORIGMARK;
a0d0e21e 4263 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 4264 RETURN;
4265}
4266
a0d0e21e 4267PP(pp_pop)
79072805 4268{
39644a26 4269 dSP;
a0d0e21e
LW		 4270 AV *av = (AV*)POPs;
4271 SV *sv = av_pop(av);
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_shift)
79072805 4279{
39644a26 4280 dSP;
a0d0e21e
LW		 4281 AV *av = (AV*)POPs;
4282 SV *sv = av_shift(av);
79072805 4283 EXTEND(SP, 1);
a0d0e21e 4284 if (!sv)
79072805 4285 RETPUSHUNDEF;
d689ffdd 4286 if (AvREAL(av))
a0d0e21e
LW		 4287 (void)sv_2mortal(sv);
4288 PUSHs(sv);
79072805 4289 RETURN;
79072805
LW		 4290}
4291
a0d0e21e 4292PP(pp_unshift)
79072805 4293{
39644a26 4294 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4295 register AV *ary = (AV*)*++MARK;
4296 register SV *sv;
4297 register I32 i = 0;
93965878
NIS		 4298 MAGIC *mg;
4299
14befaf4 4300 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4301 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 4302 PUSHMARK(MARK);
93965878 4303 PUTBACK;
a60c0954 4304 ENTER;
864dbfa3 4305 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 4306 LEAVE;
93965878 4307 SPAGAIN;
93965878 4308 }
a60c0954
NIS		 4309 else {
4310 av_unshift(ary, SP - MARK);
4311 while (MARK < SP) {
4312 sv = NEWSV(27, 0);
4313 sv_setsv(sv, *++MARK);
4314 (void)av_store(ary, i++, sv);
4315 }
79072805 4316 }
a0d0e21e
LW		 4317 SP = ORIGMARK;
4318 PUSHi( AvFILL(ary) + 1 );
79072805 4319 RETURN;
79072805
LW		 4320}
4321
a0d0e21e 4322PP(pp_reverse)
79072805 4323{
39644a26 4324 dSP; dMARK;
a0d0e21e
LW		 4325 register SV *tmp;
4326 SV **oldsp = SP;
79072805 4327
a0d0e21e
LW		 4328 if (GIMME == G_ARRAY) {
4329 MARK++;
4330 while (MARK < SP) {
4331 tmp = *MARK;
4332 *MARK++ = *SP;
4333 *SP-- = tmp;
4334 }
dd58a1ab 4335 /* safe as long as stack cannot get extended in the above */
a0d0e21e 4336 SP = oldsp;
79072805
LW		 4337 }
4338 else {
a0d0e21e
LW		 4339 register char *up;
4340 register char *down;
4341 register I32 tmp;
4342 dTARGET;
4343 STRLEN len;
79072805 4344
7e2040f0 4345 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4346 if (SP - MARK > 1)
3280af22 4347 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 4348 else
54b9620d 4349 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW		 4350 up = SvPV_force(TARG, len);
4351 if (len > 1) {
7e2040f0 4352 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55
GS		 4353 U8* s = (U8*)SvPVX(TARG);
4354 U8* send = (U8*)(s + len);
a0ed51b3 4355 while (s < send) {
d742c382 4356 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 4357 s++;
4358 continue;
4359 }
4360 else {
9041c2e3 4361 if (!utf8_to_uvchr(s, 0))
a0dbb045 4362 break;
dfe13c55 4363 up = (char*)s;
a0ed51b3 4364 s += UTF8SKIP(s);
dfe13c55 4365 down = (char*)(s - 1);
a0dbb045 4366 /* reverse this character */
a0ed51b3
LW		 4367 while (down > up) {
4368 tmp = *up;
4369 *up++ = *down;
eb160463 4370 *down-- = (char)tmp;
a0ed51b3
LW		 4371 }
4372 }
4373 }
4374 up = SvPVX(TARG);
4375 }
a0d0e21e
LW		 4376 down = SvPVX(TARG) + len - 1;
4377 while (down > up) {
4378 tmp = *up;
4379 *up++ = *down;
eb160463 4380 *down-- = (char)tmp;
a0d0e21e 4381 }
3aa33fe5 4382 (void)SvPOK_only_UTF8(TARG);
79072805 4383 }
a0d0e21e
LW		 4384 SP = MARK + 1;
4385 SETTARG;
79072805 4386 }
a0d0e21e 4387 RETURN;
79072805
LW		 4388}
4389
a0d0e21e 4390PP(pp_split)
79072805 4391{
39644a26 4392 dSP; dTARG;
a0d0e21e 4393 AV *ary;
467f0320 4394 register IV limit = POPi; /* note, negative is forever */
a0d0e21e
LW		 4395 SV *sv = POPs;
4396 STRLEN len;
4397 register char *s = SvPV(sv, len);
1aa99e6b 4398 bool do_utf8 = DO_UTF8(sv);
a0d0e21e 4399 char *strend = s + len;
44a8e56a 4400 register PMOP *pm;
d9f97599 4401 register REGEXP *rx;
a0d0e21e
LW		 4402 register SV *dstr;
4403 register char *m;
4404 I32 iters = 0;
792b2c16
JH		 4405 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4406 I32 maxiters = slen + 10;
a0d0e21e
LW		 4407 I32 i;
4408 char *orig;
4409 I32 origlimit = limit;
4410 I32 realarray = 0;
4411 I32 base;
3280af22 4412 AV *oldstack = PL_curstack;
54310121 4413 I32 gimme = GIMME_V;
3280af22 4414 I32 oldsave = PL_savestack_ix;
8ec5e241
NIS		 4415 I32 make_mortal = 1;
4416 MAGIC *mg = (MAGIC *) NULL;
79072805 4417
44a8e56a 4418#ifdef DEBUGGING
4419 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4420#else
4421 pm = (PMOP*)POPs;
4422#endif
a0d0e21e 4423 if (!pm || !s)
2269b42e 4424 DIE(aTHX_ "panic: pp_split");
aaa362c4 4425 rx = PM_GETRE(pm);
bbce6d69 4426
4427 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4428 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4429
a30b2f1f 4430 RX_MATCH_UTF8_set(rx, do_utf8);
d9f424b2 4431
971a9dd3
GS		 4432 if (pm->op_pmreplroot) {
4433#ifdef USE_ITHREADS
dd2155a4 4434 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
971a9dd3 4435#else
a0d0e21e 4436 ary = GvAVn((GV*)pm->op_pmreplroot);
971a9dd3
GS		 4437#endif
4438 }
a0d0e21e 4439 else if (gimme != G_ARRAY)
3280af22 4440 ary = GvAVn(PL_defgv);
79072805 4441 else
a0d0e21e
LW		 4442 ary = Nullav;
4443 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4444 realarray = 1;
8ec5e241 4445 PUTBACK;
a0d0e21e
LW		 4446 av_extend(ary,0);
4447 av_clear(ary);
8ec5e241 4448 SPAGAIN;
14befaf4 4449 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
8ec5e241 4450 PUSHMARK(SP);
33c27489 4451 XPUSHs(SvTIED_obj((SV*)ary, mg));
8ec5e241
NIS		 4452 }
4453 else {
1c0b011c
NIS		 4454 if (!AvREAL(ary)) {
4455 AvREAL_on(ary);
abff13bb 4456 AvREIFY_off(ary);
1c0b011c 4457 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 4458 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 4459 }
4460 /* temporarily switch stacks */
3280af22 4461 SWITCHSTACK(PL_curstack, ary);
3b0d546b 4462 PL_curstackinfo->si_stack = ary;
8ec5e241 4463 make_mortal = 0;
1c0b011c 4464 }
79072805 4465 }
3280af22 4466 base = SP - PL_stack_base;
a0d0e21e
LW		 4467 orig = s;
4468 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 4469 if (pm->op_pmflags & PMf_LOCALE) {
4470 while (isSPACE_LC(*s))
4471 s++;
4472 }
4473 else {
4474 while (isSPACE(*s))
4475 s++;
4476 }
a0d0e21e 4477 }
f02c194e 4478 if ((pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
3280af22
NIS		 4479 SAVEINT(PL_multiline);
4480 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
c07a80fd 4481 }
4482
a0d0e21e
LW		 4483 if (!limit)
4484 limit = maxiters + 2;
4485 if (pm->op_pmflags & PMf_WHITE) {
4486 while (--limit) {
bbce6d69 4487 m = s;
4488 while (m < strend &&
4489 !((pm->op_pmflags & PMf_LOCALE)
4490 ? isSPACE_LC(*m) : isSPACE(*m)))
4491 ++m;
a0d0e21e
LW		 4492 if (m >= strend)
4493 break;
bbce6d69 4494
a0d0e21e
LW		 4495 dstr = NEWSV(30, m-s);
4496 sv_setpvn(dstr, s, m-s);
8ec5e241 4497 if (make_mortal)
a0d0e21e 4498 sv_2mortal(dstr);
792b2c16 4499 if (do_utf8)
28cb3359 4500 (void)SvUTF8_on(dstr);
a0d0e21e 4501 XPUSHs(dstr);
bbce6d69 4502
4503 s = m + 1;
4504 while (s < strend &&
4505 ((pm->op_pmflags & PMf_LOCALE)
4506 ? isSPACE_LC(*s) : isSPACE(*s)))
4507 ++s;
79072805
LW		 4508 }
4509 }
f4091fba 4510 else if (strEQ("^", rx->precomp)) {
a0d0e21e
LW		 4511 while (--limit) {
4512 /*SUPPRESS 530*/
4513 for (m = s; m < strend && *m != '\n'; m++) ;
4514 m++;
4515 if (m >= strend)
4516 break;
4517 dstr = NEWSV(30, m-s);
4518 sv_setpvn(dstr, s, m-s);
8ec5e241 4519 if (make_mortal)
a0d0e21e 4520 sv_2mortal(dstr);
792b2c16 4521 if (do_utf8)
28cb3359 4522 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4523 XPUSHs(dstr);
4524 s = m;
4525 }
4526 }
699c3c34
JH		 4527 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4528 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
d9f97599
GS		 4529 && (rx->reganch & ROPT_CHECK_ALL)
4530 && !(rx->reganch & ROPT_ANCH)) {
f722798b
IZ		 4531 int tail = (rx->reganch & RE_INTUIT_TAIL);
4532 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
cf93c79d 4533
ca5b42cb 4534 len = rx->minlen;
1aa99e6b 4535 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
93f04dac
JH		 4536 STRLEN n_a;
4537 char c = *SvPV(csv, n_a);
a0d0e21e 4538 while (--limit) {
bbce6d69 4539 /*SUPPRESS 530*/
f722798b 4540 for (m = s; m < strend && *m != c; m++) ;
a0d0e21e
LW		 4541 if (m >= strend)
4542 break;
4543 dstr = NEWSV(30, m-s);
4544 sv_setpvn(dstr, s, m-s);
8ec5e241 4545 if (make_mortal)
a0d0e21e 4546 sv_2mortal(dstr);
792b2c16 4547 if (do_utf8)
28cb3359 4548 (void)SvUTF8_on(dstr);
a0d0e21e 4549 XPUSHs(dstr);
93f04dac
JH		 4550 /* The rx->minlen is in characters but we want to step
4551 * s ahead by bytes. */
1aa99e6b
IH		 4552 if (do_utf8)
4553 s = (char*)utf8_hop((U8*)m, len);
4554 else
4555 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 4556 }
4557 }
4558 else {
4559#ifndef lint
4560 while (s < strend && --limit &&
f722798b
IZ		 4561 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4562 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
79072805 4563#endif
a0d0e21e
LW		 4564 {
4565 dstr = NEWSV(31, m-s);
4566 sv_setpvn(dstr, s, m-s);
8ec5e241 4567 if (make_mortal)
a0d0e21e 4568 sv_2mortal(dstr);
792b2c16 4569 if (do_utf8)
28cb3359 4570 (void)SvUTF8_on(dstr);
a0d0e21e 4571 XPUSHs(dstr);
93f04dac
JH		 4572 /* The rx->minlen is in characters but we want to step
4573 * s ahead by bytes. */
1aa99e6b
IH		 4574 if (do_utf8)
4575 s = (char*)utf8_hop((U8*)m, len);
4576 else
4577 s = m + len; /* Fake \n at the end */
a0d0e21e 4578 }
463ee0b2 4579 }
463ee0b2 4580 }
a0d0e21e 4581 else {
792b2c16 4582 maxiters += slen * rx->nparens;
080c2dec 4583 while (s < strend && --limit)
bbce6d69 4584 {
080c2dec
AE		 4585 PUTBACK;
4586 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4587 SPAGAIN;
4588 if (i == 0)
4589 break;
d9f97599 4590 TAINT_IF(RX_MATCH_TAINTED(rx));
cf93c79d 4591 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 4592 m = s;
4593 s = orig;
cf93c79d 4594 orig = rx->subbeg;
a0d0e21e
LW		 4595 s = orig + (m - s);
4596 strend = s + (strend - m);
4597 }
cf93c79d 4598 m = rx->startp[0] + orig;
a0d0e21e
LW		 4599 dstr = NEWSV(32, m-s);
4600 sv_setpvn(dstr, s, m-s);
8ec5e241 4601 if (make_mortal)
a0d0e21e 4602 sv_2mortal(dstr);
792b2c16 4603 if (do_utf8)
28cb3359 4604 (void)SvUTF8_on(dstr);
a0d0e21e 4605 XPUSHs(dstr);
d9f97599 4606 if (rx->nparens) {
eb160463 4607 for (i = 1; i <= (I32)rx->nparens; i++) {
cf93c79d
IZ		 4608 s = rx->startp[i] + orig;
4609 m = rx->endp[i] + orig;
6de67870
JP		 4610
4611 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4612 parens that didn't match -- they should be set to
4613 undef, not the empty string */
4614 if (m >= orig && s >= orig) {
748a9306
LW		 4615 dstr = NEWSV(33, m-s);
4616 sv_setpvn(dstr, s, m-s);
4617 }
4618 else
6de67870 4619 dstr = &PL_sv_undef; /* undef, not "" */
8ec5e241 4620 if (make_mortal)
a0d0e21e 4621 sv_2mortal(dstr);
792b2c16 4622 if (do_utf8)
28cb3359 4623 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4624 XPUSHs(dstr);
4625 }
4626 }
cf93c79d 4627 s = rx->endp[0] + orig;
a0d0e21e 4628 }
79072805 4629 }
8ec5e241 4630
c07a80fd 4631 LEAVE_SCOPE(oldsave);
3280af22 4632 iters = (SP - PL_stack_base) - base;
a0d0e21e 4633 if (iters > maxiters)
cea2e8a9 4634 DIE(aTHX_ "Split loop");
8ec5e241 4635
a0d0e21e
LW		 4636 /* keep field after final delim? */
4637 if (s < strend || (iters && origlimit)) {
93f04dac
JH		 4638 STRLEN l = strend - s;
4639 dstr = NEWSV(34, l);
4640 sv_setpvn(dstr, s, l);
8ec5e241 4641 if (make_mortal)
a0d0e21e 4642 sv_2mortal(dstr);
792b2c16 4643 if (do_utf8)
28cb3359 4644 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4645 XPUSHs(dstr);
4646 iters++;
79072805 4647 }
a0d0e21e 4648 else if (!origlimit) {
89900bd3
SR		 4649 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4650 if (TOPs && !make_mortal)
4651 sv_2mortal(TOPs);
4652 iters--;
4653 SP--;
4654 }
a0d0e21e 4655 }
8ec5e241 4656
a0d0e21e 4657 if (realarray) {
8ec5e241 4658 if (!mg) {
1c0b011c 4659 SWITCHSTACK(ary, oldstack);
3b0d546b 4660 PL_curstackinfo->si_stack = oldstack;
1c0b011c
NIS		 4661 if (SvSMAGICAL(ary)) {
4662 PUTBACK;
4663 mg_set((SV*)ary);
4664 SPAGAIN;
4665 }
4666 if (gimme == G_ARRAY) {
4667 EXTEND(SP, iters);
4668 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4669 SP += iters;
4670 RETURN;
4671 }
8ec5e241 4672 }
1c0b011c 4673 else {
fb73857a 4674 PUTBACK;
8ec5e241 4675 ENTER;
864dbfa3 4676 call_method("PUSH",G_SCALAR|G_DISCARD);
8ec5e241 4677 LEAVE;
fb73857a 4678 SPAGAIN;
8ec5e241
NIS		 4679 if (gimme == G_ARRAY) {
4680 /* EXTEND should not be needed - we just popped them */
4681 EXTEND(SP, iters);
4682 for (i=0; i < iters; i++) {
4683 SV **svp = av_fetch(ary, i, FALSE);
3280af22 4684 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 4685 }
1c0b011c
NIS		 4686 RETURN;
4687 }
a0d0e21e
LW		 4688 }
4689 }
4690 else {
4691 if (gimme == G_ARRAY)
4692 RETURN;
4693 }
7f18b612
YST		 4694
4695 GETTARGET;
4696 PUSHi(iters);
4697 RETURN;
79072805 4698}
85e6fe83 4699
c0329465
MB		 4700PP(pp_lock)
4701{
39644a26 4702 dSP;
c0329465 4703 dTOPss;
e55aaa0e 4704 SV *retsv = sv;
68795e93 4705 SvLOCK(sv);
e55aaa0e
MB		 4706 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4707 || SvTYPE(retsv) == SVt_PVCV) {
4708 retsv = refto(retsv);
4709 }
4710 SETs(retsv);
c0329465
MB		 4711 RETURN;
4712}
a863c7d1 4713
2faa37cc 4714PP(pp_threadsv)
a863c7d1 4715{
cea2e8a9 4716 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
a863c7d1 4717}
Unnamed repository; edit this file 'description' to name the repository.