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