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