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
It seems the binmode() is needed with UTF-8 locales enabled.
[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{
39644a26 882 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
58d76dfd
JH		 883#ifdef PERL_PRESERVE_IVUV
884 /* ** is implemented with pow. pow is floating point. Perl programmers
885 write 2 ** 31 and expect it to be 2147483648
886 pow never made any guarantee to deliver a result to 53 (or whatever)
887 bits of accuracy. Which is unfortunate, as perl programmers expect it
888 to, and on some platforms (eg Irix with long doubles) it doesn't in
889 a very visible case. (2 ** 31, which a regression test uses)
890 So we'll implement power-of-2 ** +ve integer with multiplies, to avoid
891 these problems. */
892 {
893 SvIV_please(TOPm1s);
894 if (SvIOK(TOPm1s)) {
895 bool baseuok = SvUOK(TOPm1s);
896 UV baseuv;
897
898 if (baseuok) {
899 baseuv = SvUVX(TOPm1s);
900 } else {
901 IV iv = SvIVX(TOPm1s);
902 if (iv >= 0) {
903 baseuv = iv;
904 baseuok = TRUE; /* effectively it's a UV now */
905 } else {
906 baseuv = -iv; /* abs, baseuok == false records sign */
907 }
908 }
909 SvIV_please(TOPs);
910 if (SvIOK(TOPs)) {
911 UV power;
912
913 if (SvUOK(TOPs)) {
914 power = SvUVX(TOPs);
915 } else {
916 IV iv = SvIVX(TOPs);
917 if (iv >= 0) {
918 power = iv;
919 } else {
920 goto float_it; /* Can't do negative powers this way. */
921 }
922 }
923 /* now we have integer ** positive integer.
924 foo & (foo - 1) is zero only for a power of 2. */
925 if (!(baseuv & (baseuv - 1))) {
926 /* We are raising power-of-2 to postive integer.
927 The logic here will work for any base (even non-integer
928 bases) but it can be less accurate than
929 pow (base,power) or exp (power * log (base)) when the
930 intermediate values start to spill out of the mantissa.
931 With powers of 2 we know this can't happen.
932 And powers of 2 are the favourite thing for perl
933 programmers to notice ** not doing what they mean. */
934 NV result = 1.0;
935 NV base = baseuok ? baseuv : -(NV)baseuv;
936 int n = 0;
937
938 /* The logic is this.
939 x ** n === x ** m1 * x ** m2 where n = m1 + m2
940 so as 42 is 32 + 8 + 2
941 x ** 42 can be written as
942 x ** 32 * x ** 8 * x ** 2
943 I can calculate x ** 2, x ** 4, x ** 8 etc trivially:
944 x ** 2n is x ** n * x ** n
945 So I loop round, squaring x each time
946 (x, x ** 2, x ** 4, x ** 8) and multiply the result
947 by the x-value whenever that bit is set in the power.
948 To finish as soon as possible I zero bits in the power
949 when I've done them, so that power becomes zero when
950 I clear the last bit (no more to do), and the loop
951 terminates. */
952 for (; power; base *= base, n++) {
953 /* Do I look like I trust gcc with long longs here?
954 Do I hell. */
955 UV bit = (UV)1 << (UV)n;
956 if (power & bit) {
957 result *= base;
958 /* Only bother to clear the bit if it is set. */
959 power &= ~bit;
90fcb902
CB		 960 /* Avoid squaring base again if we're done. */
961 if (power == 0) break;
58d76dfd
JH		 962 }
963 }
964 SP--;
965 SETn( result );
966 RETURN;
967 }
968 }
969 }
970 }
971 float_it:
972#endif
a0d0e21e 973 {
58d76dfd
JH		 974 dPOPTOPnnrl;
975 SETn( Perl_pow( left, right) );
976 RETURN;
93a17b20 977 }
a0d0e21e
LW		 978}
979
980PP(pp_multiply)
981{
39644a26 982 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
28e5dec8
JH		 983#ifdef PERL_PRESERVE_IVUV
984 SvIV_please(TOPs);
985 if (SvIOK(TOPs)) {
986 /* Unless the left argument is integer in range we are going to have to
987 use NV maths. Hence only attempt to coerce the right argument if
988 we know the left is integer. */
989 /* Left operand is defined, so is it IV? */
990 SvIV_please(TOPm1s);
991 if (SvIOK(TOPm1s)) {
992 bool auvok = SvUOK(TOPm1s);
993 bool buvok = SvUOK(TOPs);
994 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
995 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
996 UV alow;
997 UV ahigh;
998 UV blow;
999 UV bhigh;
1000
1001 if (auvok) {
1002 alow = SvUVX(TOPm1s);
1003 } else {
1004 IV aiv = SvIVX(TOPm1s);
1005 if (aiv >= 0) {
1006 alow = aiv;
1007 auvok = TRUE; /* effectively it's a UV now */
1008 } else {
1009 alow = -aiv; /* abs, auvok == false records sign */
1010 }
1011 }
1012 if (buvok) {
1013 blow = SvUVX(TOPs);
1014 } else {
1015 IV biv = SvIVX(TOPs);
1016 if (biv >= 0) {
1017 blow = biv;
1018 buvok = TRUE; /* effectively it's a UV now */
1019 } else {
1020 blow = -biv; /* abs, buvok == false records sign */
1021 }
1022 }
1023
1024 /* If this does sign extension on unsigned it's time for plan B */
1025 ahigh = alow >> (4 * sizeof (UV));
1026 alow &= botmask;
1027 bhigh = blow >> (4 * sizeof (UV));
1028 blow &= botmask;
1029 if (ahigh && bhigh) {
1030 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1031 which is overflow. Drop to NVs below. */
1032 } else if (!ahigh && !bhigh) {
1033 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1034 so the unsigned multiply cannot overflow. */
1035 UV product = alow * blow;
1036 if (auvok == buvok) {
1037 /* -ve * -ve or +ve * +ve gives a +ve result. */
1038 SP--;
1039 SETu( product );
1040 RETURN;
1041 } else if (product <= (UV)IV_MIN) {
1042 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1043 /* -ve result, which could overflow an IV */
1044 SP--;
25716404 1045 SETi( -(IV)product );
28e5dec8
JH		 1046 RETURN;
1047 } /* else drop to NVs below. */
1048 } else {
1049 /* One operand is large, 1 small */
1050 UV product_middle;
1051 if (bhigh) {
1052 /* swap the operands */
1053 ahigh = bhigh;
1054 bhigh = blow; /* bhigh now the temp var for the swap */
1055 blow = alow;
1056 alow = bhigh;
1057 }
1058 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1059 multiplies can't overflow. shift can, add can, -ve can. */
1060 product_middle = ahigh * blow;
1061 if (!(product_middle & topmask)) {
1062 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1063 UV product_low;
1064 product_middle <<= (4 * sizeof (UV));
1065 product_low = alow * blow;
1066
1067 /* as for pp_add, UV + something mustn't get smaller.
1068 IIRC ANSI mandates this wrapping *behaviour* for
1069 unsigned whatever the actual representation*/
1070 product_low += product_middle;
1071 if (product_low >= product_middle) {
1072 /* didn't overflow */
1073 if (auvok == buvok) {
1074 /* -ve * -ve or +ve * +ve gives a +ve result. */
1075 SP--;
1076 SETu( product_low );
1077 RETURN;
1078 } else if (product_low <= (UV)IV_MIN) {
1079 /* 2s complement assumption again */
1080 /* -ve result, which could overflow an IV */
1081 SP--;
25716404 1082 SETi( -(IV)product_low );
28e5dec8
JH		 1083 RETURN;
1084 } /* else drop to NVs below. */
1085 }
1086 } /* product_middle too large */
1087 } /* ahigh && bhigh */
1088 } /* SvIOK(TOPm1s) */
1089 } /* SvIOK(TOPs) */
1090#endif
a0d0e21e
LW		 1091 {
1092 dPOPTOPnnrl;
1093 SETn( left * right );
1094 RETURN;
79072805 1095 }
a0d0e21e
LW		 1096}
1097
1098PP(pp_divide)
1099{
39644a26 1100 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
5479d192 1101 /* Only try to do UV divide first
68795e93 1102 if ((SLOPPYDIVIDE is true) or
5479d192
NC		 1103 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1104 to preserve))
1105 The assumption is that it is better to use floating point divide
1106 whenever possible, only doing integer divide first if we can't be sure.
1107 If NV_PRESERVES_UV is true then we know at compile time that no UV
1108 can be too large to preserve, so don't need to compile the code to
1109 test the size of UVs. */
1110
a0d0e21e 1111#ifdef SLOPPYDIVIDE
5479d192
NC		 1112# define PERL_TRY_UV_DIVIDE
1113 /* ensure that 20./5. == 4. */
a0d0e21e 1114#else
5479d192
NC		 1115# ifdef PERL_PRESERVE_IVUV
1116# ifndef NV_PRESERVES_UV
1117# define PERL_TRY_UV_DIVIDE
1118# endif
1119# endif
a0d0e21e 1120#endif
5479d192
NC		 1121
1122#ifdef PERL_TRY_UV_DIVIDE
1123 SvIV_please(TOPs);
1124 if (SvIOK(TOPs)) {
1125 SvIV_please(TOPm1s);
1126 if (SvIOK(TOPm1s)) {
1127 bool left_non_neg = SvUOK(TOPm1s);
1128 bool right_non_neg = SvUOK(TOPs);
1129 UV left;
1130 UV right;
1131
1132 if (right_non_neg) {
1133 right = SvUVX(TOPs);
1134 }
1135 else {
1136 IV biv = SvIVX(TOPs);
1137 if (biv >= 0) {
1138 right = biv;
1139 right_non_neg = TRUE; /* effectively it's a UV now */
1140 }
1141 else {
1142 right = -biv;
1143 }
1144 }
1145 /* historically undef()/0 gives a "Use of uninitialized value"
1146 warning before dieing, hence this test goes here.
1147 If it were immediately before the second SvIV_please, then
1148 DIE() would be invoked before left was even inspected, so
1149 no inpsection would give no warning. */
1150 if (right == 0)
1151 DIE(aTHX_ "Illegal division by zero");
1152
1153 if (left_non_neg) {
1154 left = SvUVX(TOPm1s);
1155 }
1156 else {
1157 IV aiv = SvIVX(TOPm1s);
1158 if (aiv >= 0) {
1159 left = aiv;
1160 left_non_neg = TRUE; /* effectively it's a UV now */
1161 }
1162 else {
1163 left = -aiv;
1164 }
1165 }
1166
1167 if (left >= right
1168#ifdef SLOPPYDIVIDE
1169 /* For sloppy divide we always attempt integer division. */
1170#else
1171 /* Otherwise we only attempt it if either or both operands
1172 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC		 1173 we fall through to the NV divide code below. However,
1174 as left >= right to ensure integer result here, we know that
1175 we can skip the test on the right operand - right big
1176 enough not to be preserved can't get here unless left is
1177 also too big. */
1178
1179 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC		 1180#endif
1181 ) {
1182 /* Integer division can't overflow, but it can be imprecise. */
1183 UV result = left / right;
1184 if (result * right == left) {
1185 SP--; /* result is valid */
1186 if (left_non_neg == right_non_neg) {
1187 /* signs identical, result is positive. */
1188 SETu( result );
1189 RETURN;
1190 }
1191 /* 2s complement assumption */
1192 if (result <= (UV)IV_MIN)
91f3b821 1193 SETi( -(IV)result );
5479d192
NC		 1194 else {
1195 /* It's exact but too negative for IV. */
1196 SETn( -(NV)result );
1197 }
1198 RETURN;
1199 } /* tried integer divide but it was not an integer result */
1200 } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
1201 } /* left wasn't SvIOK */
1202 } /* right wasn't SvIOK */
1203#endif /* PERL_TRY_UV_DIVIDE */
1204 {
1205 dPOPPOPnnrl;
1206 if (right == 0.0)
1207 DIE(aTHX_ "Illegal division by zero");
1208 PUSHn( left / right );
1209 RETURN;
79072805 1210 }
a0d0e21e
LW		 1211}
1212
1213PP(pp_modulo)
1214{
39644a26 1215 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
a0d0e21e 1216 {
9c5ffd7c
JH		 1217 UV left = 0;
1218 UV right = 0;
dc656993
JH		 1219 bool left_neg = FALSE;
1220 bool right_neg = FALSE;
e2c88acc
NC		 1221 bool use_double = FALSE;
1222 bool dright_valid = FALSE;
9c5ffd7c
JH		 1223 NV dright = 0.0;
1224 NV dleft = 0.0;
787eafbd 1225
e2c88acc
NC		 1226 SvIV_please(TOPs);
1227 if (SvIOK(TOPs)) {
1228 right_neg = !SvUOK(TOPs);
1229 if (!right_neg) {
1230 right = SvUVX(POPs);
1231 } else {
1232 IV biv = SvIVX(POPs);
1233 if (biv >= 0) {
1234 right = biv;
1235 right_neg = FALSE; /* effectively it's a UV now */
1236 } else {
1237 right = -biv;
1238 }
1239 }
1240 }
1241 else {
787eafbd 1242 dright = POPn;
787eafbd
IZ		 1243 right_neg = dright < 0;
1244 if (right_neg)
1245 dright = -dright;
e2c88acc
NC		 1246 if (dright < UV_MAX_P1) {
1247 right = U_V(dright);
1248 dright_valid = TRUE; /* In case we need to use double below. */
1249 } else {
1250 use_double = TRUE;
1251 }
787eafbd 1252 }
a0d0e21e 1253
e2c88acc
NC		 1254 /* At this point use_double is only true if right is out of range for
1255 a UV. In range NV has been rounded down to nearest UV and
1256 use_double false. */
1257 SvIV_please(TOPs);
1258 if (!use_double && SvIOK(TOPs)) {
1259 if (SvIOK(TOPs)) {
1260 left_neg = !SvUOK(TOPs);
1261 if (!left_neg) {
1262 left = SvUVX(POPs);
1263 } else {
1264 IV aiv = SvIVX(POPs);
1265 if (aiv >= 0) {
1266 left = aiv;
1267 left_neg = FALSE; /* effectively it's a UV now */
1268 } else {
1269 left = -aiv;
1270 }
1271 }
1272 }
1273 }
787eafbd
IZ		 1274 else {
1275 dleft = POPn;
787eafbd
IZ		 1276 left_neg = dleft < 0;
1277 if (left_neg)
1278 dleft = -dleft;
68dc0745 1279
e2c88acc
NC		 1280 /* This should be exactly the 5.6 behaviour - if left and right are
1281 both in range for UV then use U_V() rather than floor. */
1282 if (!use_double) {
1283 if (dleft < UV_MAX_P1) {
1284 /* right was in range, so is dleft, so use UVs not double.
1285 */
1286 left = U_V(dleft);
1287 }
1288 /* left is out of range for UV, right was in range, so promote
1289 right (back) to double. */
1290 else {
1291 /* The +0.5 is used in 5.6 even though it is not strictly
1292 consistent with the implicit +0 floor in the U_V()
1293 inside the #if 1. */
1294 dleft = Perl_floor(dleft + 0.5);
1295 use_double = TRUE;
1296 if (dright_valid)
1297 dright = Perl_floor(dright + 0.5);
1298 else
1299 dright = right;
1300 }
1301 }
1302 }
787eafbd 1303 if (use_double) {
65202027 1304 NV dans;
787eafbd 1305
787eafbd 1306 if (!dright)
cea2e8a9 1307 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1308
65202027 1309 dans = Perl_fmod(dleft, dright);
787eafbd
IZ		 1310 if ((left_neg != right_neg) && dans)
1311 dans = dright - dans;
1312 if (right_neg)
1313 dans = -dans;
1314 sv_setnv(TARG, dans);
1315 }
1316 else {
1317 UV ans;
1318
787eafbd 1319 if (!right)
cea2e8a9 1320 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ		 1321
1322 ans = left % right;
1323 if ((left_neg != right_neg) && ans)
1324 ans = right - ans;
1325 if (right_neg) {
1326 /* XXX may warn: unary minus operator applied to unsigned type */
1327 /* could change -foo to be (~foo)+1 instead */
1328 if (ans <= ~((UV)IV_MAX)+1)
1329 sv_setiv(TARG, ~ans+1);
1330 else
65202027 1331 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ		 1332 }
1333 else
1334 sv_setuv(TARG, ans);
1335 }
1336 PUSHTARG;
1337 RETURN;
79072805 1338 }
a0d0e21e 1339}
79072805 1340
a0d0e21e
LW		 1341PP(pp_repeat)
1342{
39644a26 1343 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
748a9306 1344 {
467f0320 1345 register IV count = POPi;
533c011a 1346 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e
LW		 1347 dMARK;
1348 I32 items = SP - MARK;
1349 I32 max;
79072805 1350
a0d0e21e
LW		 1351 max = items * count;
1352 MEXTEND(MARK, max);
1353 if (count > 1) {
1354 while (SP > MARK) {
976c8a39
JH		 1355#if 0
1356 /* This code was intended to fix 20010809.028:
1357
1358 $x = 'abcd';
1359 for (($x =~ /./g) x 2) {
1360 print chop; # "abcdabcd" expected as output.
1361 }
1362
1363 * but that change (#11635) broke this code:
1364
1365 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1366
1367 * I can't think of a better fix that doesn't introduce
1368 * an efficiency hit by copying the SVs. The stack isn't
1369 * refcounted, and mortalisation obviously doesn't
1370 * Do The Right Thing when the stack has more than
1371 * one pointer to the same mortal value.
1372 * .robin.
1373 */
e30acc16
RH		 1374 if (*SP) {
1375 *SP = sv_2mortal(newSVsv(*SP));
1376 SvREADONLY_on(*SP);
1377 }
976c8a39
JH		 1378#else
1379 if (*SP)
1380 SvTEMP_off((*SP));
1381#endif
a0d0e21e 1382 SP--;
79072805 1383 }
a0d0e21e
LW		 1384 MARK++;
1385 repeatcpy((char*)(MARK + items), (char*)MARK,
1386 items * sizeof(SV*), count - 1);
1387 SP += max;
79072805 1388 }
a0d0e21e
LW		 1389 else if (count <= 0)
1390 SP -= items;
79072805 1391 }
a0d0e21e 1392 else { /* Note: mark already snarfed by pp_list */
dfcb284a 1393 SV *tmpstr = POPs;
a0d0e21e 1394 STRLEN len;
9b877dbb 1395 bool isutf;
a0d0e21e 1396
a0d0e21e
LW		 1397 SvSetSV(TARG, tmpstr);
1398 SvPV_force(TARG, len);
9b877dbb 1399 isutf = DO_UTF8(TARG);
8ebc5c01 1400 if (count != 1) {
1401 if (count < 1)
1402 SvCUR_set(TARG, 0);
1403 else {
1404 SvGROW(TARG, (count * len) + 1);
a0d0e21e 1405 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
8ebc5c01 1406 SvCUR(TARG) *= count;
7a4c00b4 1407 }
a0d0e21e 1408 *SvEND(TARG) = '\0';
a0d0e21e 1409 }
dfcb284a
GS		 1410 if (isutf)
1411 (void)SvPOK_only_UTF8(TARG);
1412 else
1413 (void)SvPOK_only(TARG);
b80b6069
RH		 1414
1415 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1416 /* The parser saw this as a list repeat, and there
1417 are probably several items on the stack. But we're
1418 in scalar context, and there's no pp_list to save us
1419 now. So drop the rest of the items -- robin@kitsite.com
1420 */
1421 dMARK;
1422 SP = MARK;
1423 }
a0d0e21e 1424 PUSHTARG;
79072805 1425 }
a0d0e21e 1426 RETURN;
748a9306 1427 }
a0d0e21e 1428}
79072805 1429
a0d0e21e
LW		 1430PP(pp_subtract)
1431{
39644a26 1432 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
28e5dec8
JH		 1433 useleft = USE_LEFT(TOPm1s);
1434#ifdef PERL_PRESERVE_IVUV
7dca457a
NC		 1435 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1436 "bad things" happen if you rely on signed integers wrapping. */
28e5dec8
JH		 1437 SvIV_please(TOPs);
1438 if (SvIOK(TOPs)) {
1439 /* Unless the left argument is integer in range we are going to have to
1440 use NV maths. Hence only attempt to coerce the right argument if
1441 we know the left is integer. */
9c5ffd7c
JH		 1442 register UV auv = 0;
1443 bool auvok = FALSE;
7dca457a
NC		 1444 bool a_valid = 0;
1445
28e5dec8 1446 if (!useleft) {
7dca457a
NC		 1447 auv = 0;
1448 a_valid = auvok = 1;
1449 /* left operand is undef, treat as zero. */
28e5dec8
JH		 1450 } else {
1451 /* Left operand is defined, so is it IV? */
1452 SvIV_please(TOPm1s);
1453 if (SvIOK(TOPm1s)) {
7dca457a
NC		 1454 if ((auvok = SvUOK(TOPm1s)))
1455 auv = SvUVX(TOPm1s);
1456 else {
1457 register IV aiv = SvIVX(TOPm1s);
1458 if (aiv >= 0) {
1459 auv = aiv;
1460 auvok = 1; /* Now acting as a sign flag. */
1461 } else { /* 2s complement assumption for IV_MIN */
1462 auv = (UV)-aiv;
28e5dec8 1463 }
7dca457a
NC		 1464 }
1465 a_valid = 1;
1466 }
1467 }
1468 if (a_valid) {
1469 bool result_good = 0;
1470 UV result;
1471 register UV buv;
1472 bool buvok = SvUOK(TOPs);
9041c2e3 1473
7dca457a
NC		 1474 if (buvok)
1475 buv = SvUVX(TOPs);
1476 else {
1477 register IV biv = SvIVX(TOPs);
1478 if (biv >= 0) {
1479 buv = biv;
1480 buvok = 1;
1481 } else
1482 buv = (UV)-biv;
1483 }
1484 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1485 else "IV" now, independent of how it came in.
7dca457a
NC		 1486 if a, b represents positive, A, B negative, a maps to -A etc
1487 a - b => (a - b)
1488 A - b => -(a + b)
1489 a - B => (a + b)
1490 A - B => -(a - b)
1491 all UV maths. negate result if A negative.
1492 subtract if signs same, add if signs differ. */
1493
1494 if (auvok ^ buvok) {
1495 /* Signs differ. */
1496 result = auv + buv;
1497 if (result >= auv)
1498 result_good = 1;
1499 } else {
1500 /* Signs same */
1501 if (auv >= buv) {
1502 result = auv - buv;
1503 /* Must get smaller */
1504 if (result <= auv)
1505 result_good = 1;
1506 } else {
1507 result = buv - auv;
1508 if (result <= buv) {
1509 /* result really should be -(auv-buv). as its negation
1510 of true value, need to swap our result flag */
1511 auvok = !auvok;
1512 result_good = 1;
28e5dec8 1513 }
28e5dec8
JH		 1514 }
1515 }
7dca457a
NC		 1516 if (result_good) {
1517 SP--;
1518 if (auvok)
1519 SETu( result );
1520 else {
1521 /* Negate result */
1522 if (result <= (UV)IV_MIN)
1523 SETi( -(IV)result );
1524 else {
1525 /* result valid, but out of range for IV. */
1526 SETn( -(NV)result );
1527 }
1528 }
1529 RETURN;
1530 } /* Overflow, drop through to NVs. */
28e5dec8
JH		 1531 }
1532 }
1533#endif
7dca457a 1534 useleft = USE_LEFT(TOPm1s);
a0d0e21e 1535 {
28e5dec8
JH		 1536 dPOPnv;
1537 if (!useleft) {
1538 /* left operand is undef, treat as zero - value */
1539 SETn(-value);
1540 RETURN;
1541 }
1542 SETn( TOPn - value );
1543 RETURN;
79072805 1544 }
a0d0e21e 1545}
79072805 1546
a0d0e21e
LW		 1547PP(pp_left_shift)
1548{
39644a26 1549 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
a0d0e21e 1550 {
972b05a9 1551 IV shift = POPi;
d0ba1bd2 1552 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1553 IV i = TOPi;
1554 SETi(i << shift);
d0ba1bd2
JH		 1555 }
1556 else {
972b05a9
JH		 1557 UV u = TOPu;
1558 SETu(u << shift);
d0ba1bd2 1559 }
55497cff 1560 RETURN;
79072805 1561 }
a0d0e21e 1562}
79072805 1563
a0d0e21e
LW		 1564PP(pp_right_shift)
1565{
39644a26 1566 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
a0d0e21e 1567 {
972b05a9 1568 IV shift = POPi;
d0ba1bd2 1569 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1570 IV i = TOPi;
1571 SETi(i >> shift);
d0ba1bd2
JH		 1572 }
1573 else {
972b05a9
JH		 1574 UV u = TOPu;
1575 SETu(u >> shift);
d0ba1bd2 1576 }
a0d0e21e 1577 RETURN;
93a17b20 1578 }
79072805
LW		 1579}
1580
a0d0e21e 1581PP(pp_lt)
79072805 1582{
39644a26 1583 dSP; tryAMAGICbinSET(lt,0);
28e5dec8
JH		 1584#ifdef PERL_PRESERVE_IVUV
1585 SvIV_please(TOPs);
1586 if (SvIOK(TOPs)) {
1587 SvIV_please(TOPm1s);
1588 if (SvIOK(TOPm1s)) {
1589 bool auvok = SvUOK(TOPm1s);
1590 bool buvok = SvUOK(TOPs);
a227d84d 1591
28e5dec8
JH		 1592 if (!auvok && !buvok) { /* ## IV < IV ## */
1593 IV aiv = SvIVX(TOPm1s);
1594 IV biv = SvIVX(TOPs);
1595
1596 SP--;
1597 SETs(boolSV(aiv < biv));
1598 RETURN;
1599 }
1600 if (auvok && buvok) { /* ## UV < UV ## */
1601 UV auv = SvUVX(TOPm1s);
1602 UV buv = SvUVX(TOPs);
1603
1604 SP--;
1605 SETs(boolSV(auv < buv));
1606 RETURN;
1607 }
1608 if (auvok) { /* ## UV < IV ## */
1609 UV auv;
1610 IV biv;
1611
1612 biv = SvIVX(TOPs);
1613 SP--;
1614 if (biv < 0) {
1615 /* As (a) is a UV, it's >=0, so it cannot be < */
1616 SETs(&PL_sv_no);
1617 RETURN;
1618 }
1619 auv = SvUVX(TOPs);
28e5dec8
JH		 1620 SETs(boolSV(auv < (UV)biv));
1621 RETURN;
1622 }
1623 { /* ## IV < UV ## */
1624 IV aiv;
1625 UV buv;
1626
1627 aiv = SvIVX(TOPm1s);
1628 if (aiv < 0) {
1629 /* As (b) is a UV, it's >=0, so it must be < */
1630 SP--;
1631 SETs(&PL_sv_yes);
1632 RETURN;
1633 }
1634 buv = SvUVX(TOPs);
1635 SP--;
28e5dec8
JH		 1636 SETs(boolSV((UV)aiv < buv));
1637 RETURN;
1638 }
1639 }
1640 }
1641#endif
30de85b6 1642#ifndef NV_PRESERVES_UV
50fb3111
NC		 1643#ifdef PERL_PRESERVE_IVUV
1644 else
1645#endif
1646 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1647 SP--;
1648 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1649 RETURN;
1650 }
30de85b6 1651#endif
a0d0e21e
LW		 1652 {
1653 dPOPnv;
54310121 1654 SETs(boolSV(TOPn < value));
a0d0e21e 1655 RETURN;
79072805 1656 }
a0d0e21e 1657}
79072805 1658
a0d0e21e
LW		 1659PP(pp_gt)
1660{
39644a26 1661 dSP; tryAMAGICbinSET(gt,0);
28e5dec8
JH		 1662#ifdef PERL_PRESERVE_IVUV
1663 SvIV_please(TOPs);
1664 if (SvIOK(TOPs)) {
1665 SvIV_please(TOPm1s);
1666 if (SvIOK(TOPm1s)) {
1667 bool auvok = SvUOK(TOPm1s);
1668 bool buvok = SvUOK(TOPs);
a227d84d 1669
28e5dec8
JH		 1670 if (!auvok && !buvok) { /* ## IV > IV ## */
1671 IV aiv = SvIVX(TOPm1s);
1672 IV biv = SvIVX(TOPs);
1673
1674 SP--;
1675 SETs(boolSV(aiv > biv));
1676 RETURN;
1677 }
1678 if (auvok && buvok) { /* ## UV > UV ## */
1679 UV auv = SvUVX(TOPm1s);
1680 UV buv = SvUVX(TOPs);
1681
1682 SP--;
1683 SETs(boolSV(auv > buv));
1684 RETURN;
1685 }
1686 if (auvok) { /* ## UV > IV ## */
1687 UV auv;
1688 IV biv;
1689
1690 biv = SvIVX(TOPs);
1691 SP--;
1692 if (biv < 0) {
1693 /* As (a) is a UV, it's >=0, so it must be > */
1694 SETs(&PL_sv_yes);
1695 RETURN;
1696 }
1697 auv = SvUVX(TOPs);
28e5dec8
JH		 1698 SETs(boolSV(auv > (UV)biv));
1699 RETURN;
1700 }
1701 { /* ## IV > UV ## */
1702 IV aiv;
1703 UV buv;
1704
1705 aiv = SvIVX(TOPm1s);
1706 if (aiv < 0) {
1707 /* As (b) is a UV, it's >=0, so it cannot be > */
1708 SP--;
1709 SETs(&PL_sv_no);
1710 RETURN;
1711 }
1712 buv = SvUVX(TOPs);
1713 SP--;
28e5dec8
JH		 1714 SETs(boolSV((UV)aiv > buv));
1715 RETURN;
1716 }
1717 }
1718 }
1719#endif
30de85b6 1720#ifndef NV_PRESERVES_UV
50fb3111
NC		 1721#ifdef PERL_PRESERVE_IVUV
1722 else
1723#endif
1724 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1725 SP--;
1726 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1727 RETURN;
1728 }
1729#endif
a0d0e21e
LW		 1730 {
1731 dPOPnv;
54310121 1732 SETs(boolSV(TOPn > value));
a0d0e21e 1733 RETURN;
79072805 1734 }
a0d0e21e
LW		 1735}
1736
1737PP(pp_le)
1738{
39644a26 1739 dSP; tryAMAGICbinSET(le,0);
28e5dec8
JH		 1740#ifdef PERL_PRESERVE_IVUV
1741 SvIV_please(TOPs);
1742 if (SvIOK(TOPs)) {
1743 SvIV_please(TOPm1s);
1744 if (SvIOK(TOPm1s)) {
1745 bool auvok = SvUOK(TOPm1s);
1746 bool buvok = SvUOK(TOPs);
a227d84d 1747
28e5dec8
JH		 1748 if (!auvok && !buvok) { /* ## IV <= IV ## */
1749 IV aiv = SvIVX(TOPm1s);
1750 IV biv = SvIVX(TOPs);
1751
1752 SP--;
1753 SETs(boolSV(aiv <= biv));
1754 RETURN;
1755 }
1756 if (auvok && buvok) { /* ## UV <= UV ## */
1757 UV auv = SvUVX(TOPm1s);
1758 UV buv = SvUVX(TOPs);
1759
1760 SP--;
1761 SETs(boolSV(auv <= buv));
1762 RETURN;
1763 }
1764 if (auvok) { /* ## UV <= IV ## */
1765 UV auv;
1766 IV biv;
1767
1768 biv = SvIVX(TOPs);
1769 SP--;
1770 if (biv < 0) {
1771 /* As (a) is a UV, it's >=0, so a cannot be <= */
1772 SETs(&PL_sv_no);
1773 RETURN;
1774 }
1775 auv = SvUVX(TOPs);
28e5dec8
JH		 1776 SETs(boolSV(auv <= (UV)biv));
1777 RETURN;
1778 }
1779 { /* ## IV <= UV ## */
1780 IV aiv;
1781 UV buv;
1782
1783 aiv = SvIVX(TOPm1s);
1784 if (aiv < 0) {
1785 /* As (b) is a UV, it's >=0, so a must be <= */
1786 SP--;
1787 SETs(&PL_sv_yes);
1788 RETURN;
1789 }
1790 buv = SvUVX(TOPs);
1791 SP--;
28e5dec8
JH		 1792 SETs(boolSV((UV)aiv <= buv));
1793 RETURN;
1794 }
1795 }
1796 }
1797#endif
30de85b6 1798#ifndef NV_PRESERVES_UV
50fb3111
NC		 1799#ifdef PERL_PRESERVE_IVUV
1800 else
1801#endif
1802 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1803 SP--;
1804 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1805 RETURN;
1806 }
1807#endif
a0d0e21e
LW		 1808 {
1809 dPOPnv;
54310121 1810 SETs(boolSV(TOPn <= value));
a0d0e21e 1811 RETURN;
79072805 1812 }
a0d0e21e
LW		 1813}
1814
1815PP(pp_ge)
1816{
39644a26 1817 dSP; tryAMAGICbinSET(ge,0);
28e5dec8
JH		 1818#ifdef PERL_PRESERVE_IVUV
1819 SvIV_please(TOPs);
1820 if (SvIOK(TOPs)) {
1821 SvIV_please(TOPm1s);
1822 if (SvIOK(TOPm1s)) {
1823 bool auvok = SvUOK(TOPm1s);
1824 bool buvok = SvUOK(TOPs);
a227d84d 1825
28e5dec8
JH		 1826 if (!auvok && !buvok) { /* ## IV >= IV ## */
1827 IV aiv = SvIVX(TOPm1s);
1828 IV biv = SvIVX(TOPs);
1829
1830 SP--;
1831 SETs(boolSV(aiv >= biv));
1832 RETURN;
1833 }
1834 if (auvok && buvok) { /* ## UV >= UV ## */
1835 UV auv = SvUVX(TOPm1s);
1836 UV buv = SvUVX(TOPs);
1837
1838 SP--;
1839 SETs(boolSV(auv >= buv));
1840 RETURN;
1841 }
1842 if (auvok) { /* ## UV >= IV ## */
1843 UV auv;
1844 IV biv;
1845
1846 biv = SvIVX(TOPs);
1847 SP--;
1848 if (biv < 0) {
1849 /* As (a) is a UV, it's >=0, so it must be >= */
1850 SETs(&PL_sv_yes);
1851 RETURN;
1852 }
1853 auv = SvUVX(TOPs);
28e5dec8
JH		 1854 SETs(boolSV(auv >= (UV)biv));
1855 RETURN;
1856 }
1857 { /* ## IV >= UV ## */
1858 IV aiv;
1859 UV buv;
1860
1861 aiv = SvIVX(TOPm1s);
1862 if (aiv < 0) {
1863 /* As (b) is a UV, it's >=0, so a cannot be >= */
1864 SP--;
1865 SETs(&PL_sv_no);
1866 RETURN;
1867 }
1868 buv = SvUVX(TOPs);
1869 SP--;
28e5dec8
JH		 1870 SETs(boolSV((UV)aiv >= buv));
1871 RETURN;
1872 }
1873 }
1874 }
1875#endif
30de85b6 1876#ifndef NV_PRESERVES_UV
50fb3111
NC		 1877#ifdef PERL_PRESERVE_IVUV
1878 else
1879#endif
1880 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1881 SP--;
1882 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1883 RETURN;
1884 }
1885#endif
a0d0e21e
LW		 1886 {
1887 dPOPnv;
54310121 1888 SETs(boolSV(TOPn >= value));
a0d0e21e 1889 RETURN;
79072805 1890 }
a0d0e21e 1891}
79072805 1892
a0d0e21e
LW		 1893PP(pp_ne)
1894{
16303949 1895 dSP; tryAMAGICbinSET(ne,0);
3bb2c415
JH		 1896#ifndef NV_PRESERVES_UV
1897 if (SvROK(TOPs) && SvROK(TOPm1s)) {
e61d22ef
NC		 1898 SP--;
1899 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
3bb2c415
JH		 1900 RETURN;
1901 }
1902#endif
28e5dec8
JH		 1903#ifdef PERL_PRESERVE_IVUV
1904 SvIV_please(TOPs);
1905 if (SvIOK(TOPs)) {
1906 SvIV_please(TOPm1s);
1907 if (SvIOK(TOPm1s)) {
1908 bool auvok = SvUOK(TOPm1s);
1909 bool buvok = SvUOK(TOPs);
a227d84d 1910
30de85b6
NC		 1911 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1912 /* Casting IV to UV before comparison isn't going to matter
1913 on 2s complement. On 1s complement or sign&magnitude
1914 (if we have any of them) it could make negative zero
1915 differ from normal zero. As I understand it. (Need to
1916 check - is negative zero implementation defined behaviour
1917 anyway?). NWC */
1918 UV buv = SvUVX(POPs);
1919 UV auv = SvUVX(TOPs);
28e5dec8 1920
28e5dec8
JH		 1921 SETs(boolSV(auv != buv));
1922 RETURN;
1923 }
1924 { /* ## Mixed IV,UV ## */
1925 IV iv;
1926 UV uv;
1927
1928 /* != is commutative so swap if needed (save code) */
1929 if (auvok) {
1930 /* swap. top of stack (b) is the iv */
1931 iv = SvIVX(TOPs);
1932 SP--;
1933 if (iv < 0) {
1934 /* As (a) is a UV, it's >0, so it cannot be == */
1935 SETs(&PL_sv_yes);
1936 RETURN;
1937 }
1938 uv = SvUVX(TOPs);
1939 } else {
1940 iv = SvIVX(TOPm1s);
1941 SP--;
1942 if (iv < 0) {
1943 /* As (b) is a UV, it's >0, so it cannot be == */
1944 SETs(&PL_sv_yes);
1945 RETURN;
1946 }
1947 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1948 }
28e5dec8
JH		 1949 SETs(boolSV((UV)iv != uv));
1950 RETURN;
1951 }
1952 }
1953 }
1954#endif
a0d0e21e
LW		 1955 {
1956 dPOPnv;
54310121 1957 SETs(boolSV(TOPn != value));
a0d0e21e
LW		 1958 RETURN;
1959 }
79072805
LW		 1960}
1961
a0d0e21e 1962PP(pp_ncmp)
79072805 1963{
39644a26 1964 dSP; dTARGET; tryAMAGICbin(ncmp,0);
d8c7644e
JH		 1965#ifndef NV_PRESERVES_UV
1966 if (SvROK(TOPs) && SvROK(TOPm1s)) {
e61d22ef
NC		 1967 UV right = PTR2UV(SvRV(POPs));
1968 UV left = PTR2UV(SvRV(TOPs));
1969 SETi((left > right) - (left < right));
d8c7644e
JH		 1970 RETURN;
1971 }
1972#endif
28e5dec8
JH		 1973#ifdef PERL_PRESERVE_IVUV
1974 /* Fortunately it seems NaN isn't IOK */
1975 SvIV_please(TOPs);
1976 if (SvIOK(TOPs)) {
1977 SvIV_please(TOPm1s);
1978 if (SvIOK(TOPm1s)) {
1979 bool leftuvok = SvUOK(TOPm1s);
1980 bool rightuvok = SvUOK(TOPs);
1981 I32 value;
1982 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1983 IV leftiv = SvIVX(TOPm1s);
1984 IV rightiv = SvIVX(TOPs);
1985
1986 if (leftiv > rightiv)
1987 value = 1;
1988 else if (leftiv < rightiv)
1989 value = -1;
1990 else
1991 value = 0;
1992 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1993 UV leftuv = SvUVX(TOPm1s);
1994 UV rightuv = SvUVX(TOPs);
1995
1996 if (leftuv > rightuv)
1997 value = 1;
1998 else if (leftuv < rightuv)
1999 value = -1;
2000 else
2001 value = 0;
2002 } else if (leftuvok) { /* ## UV <=> IV ## */
2003 UV leftuv;
2004 IV rightiv;
2005
2006 rightiv = SvIVX(TOPs);
2007 if (rightiv < 0) {
2008 /* As (a) is a UV, it's >=0, so it cannot be < */
2009 value = 1;
2010 } else {
2011 leftuv = SvUVX(TOPm1s);
83bac5dd 2012 if (leftuv > (UV)rightiv) {
28e5dec8
JH		 2013 value = 1;
2014 } else if (leftuv < (UV)rightiv) {
2015 value = -1;
2016 } else {
2017 value = 0;
2018 }
2019 }
2020 } else { /* ## IV <=> UV ## */
2021 IV leftiv;
2022 UV rightuv;
2023
2024 leftiv = SvIVX(TOPm1s);
2025 if (leftiv < 0) {
2026 /* As (b) is a UV, it's >=0, so it must be < */
2027 value = -1;
2028 } else {
2029 rightuv = SvUVX(TOPs);
83bac5dd 2030 if ((UV)leftiv > rightuv) {
28e5dec8 2031 value = 1;
83bac5dd 2032 } else if ((UV)leftiv < rightuv) {
28e5dec8
JH		 2033 value = -1;
2034 } else {
2035 value = 0;
2036 }
2037 }
2038 }
2039 SP--;
2040 SETi(value);
2041 RETURN;
2042 }
2043 }
2044#endif
a0d0e21e
LW		 2045 {
2046 dPOPTOPnnrl;
2047 I32 value;
79072805 2048
a3540c92 2049#ifdef Perl_isnan
1ad04cfd
JH		 2050 if (Perl_isnan(left) || Perl_isnan(right)) {
2051 SETs(&PL_sv_undef);
2052 RETURN;
2053 }
2054 value = (left > right) - (left < right);
2055#else
ff0cee69 2056 if (left == right)
a0d0e21e 2057 value = 0;
a0d0e21e
LW		 2058 else if (left < right)
2059 value = -1;
44a8e56a 2060 else if (left > right)
2061 value = 1;
2062 else {
3280af22 2063 SETs(&PL_sv_undef);
44a8e56a 2064 RETURN;
2065 }
1ad04cfd 2066#endif
a0d0e21e
LW		 2067 SETi(value);
2068 RETURN;
79072805 2069 }
a0d0e21e 2070}
79072805 2071
a0d0e21e
LW		 2072PP(pp_slt)
2073{
39644a26 2074 dSP; tryAMAGICbinSET(slt,0);
a0d0e21e
LW		 2075 {
2076 dPOPTOPssrl;
2de3dbcc 2077 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2078 ? sv_cmp_locale(left, right)
2079 : sv_cmp(left, right));
54310121 2080 SETs(boolSV(cmp < 0));
a0d0e21e
LW		 2081 RETURN;
2082 }
79072805
LW		 2083}
2084
a0d0e21e 2085PP(pp_sgt)
79072805 2086{
39644a26 2087 dSP; tryAMAGICbinSET(sgt,0);
a0d0e21e
LW		 2088 {
2089 dPOPTOPssrl;
2de3dbcc 2090 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2091 ? sv_cmp_locale(left, right)
2092 : sv_cmp(left, right));
54310121 2093 SETs(boolSV(cmp > 0));
a0d0e21e
LW		 2094 RETURN;
2095 }
2096}
79072805 2097
a0d0e21e
LW		 2098PP(pp_sle)
2099{
39644a26 2100 dSP; tryAMAGICbinSET(sle,0);
a0d0e21e
LW		 2101 {
2102 dPOPTOPssrl;
2de3dbcc 2103 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2104 ? sv_cmp_locale(left, right)
2105 : sv_cmp(left, right));
54310121 2106 SETs(boolSV(cmp <= 0));
a0d0e21e 2107 RETURN;
79072805 2108 }
79072805
LW		 2109}
2110
a0d0e21e
LW		 2111PP(pp_sge)
2112{
39644a26 2113 dSP; tryAMAGICbinSET(sge,0);
a0d0e21e
LW		 2114 {
2115 dPOPTOPssrl;
2de3dbcc 2116 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2117 ? sv_cmp_locale(left, right)
2118 : sv_cmp(left, right));
54310121 2119 SETs(boolSV(cmp >= 0));
a0d0e21e
LW		 2120 RETURN;
2121 }
2122}
79072805 2123
36477c24 2124PP(pp_seq)
2125{
39644a26 2126 dSP; tryAMAGICbinSET(seq,0);
36477c24 2127 {
2128 dPOPTOPssrl;
54310121 2129 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW		 2130 RETURN;
2131 }
2132}
79072805 2133
a0d0e21e 2134PP(pp_sne)
79072805 2135{
39644a26 2136 dSP; tryAMAGICbinSET(sne,0);
a0d0e21e
LW		 2137 {
2138 dPOPTOPssrl;
54310121 2139 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 2140 RETURN;
463ee0b2 2141 }
79072805
LW		 2142}
2143
a0d0e21e 2144PP(pp_scmp)
79072805 2145{
39644a26 2146 dSP; dTARGET; tryAMAGICbin(scmp,0);
a0d0e21e
LW		 2147 {
2148 dPOPTOPssrl;
2de3dbcc 2149 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2150 ? sv_cmp_locale(left, right)
2151 : sv_cmp(left, right));
2152 SETi( cmp );
a0d0e21e
LW		 2153 RETURN;
2154 }
2155}
79072805 2156
55497cff 2157PP(pp_bit_and)
2158{
39644a26 2159 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
a0d0e21e
LW		 2160 {
2161 dPOPTOPssrl;
4633a7c4 2162 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2163 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2164 IV i = SvIV(left) & SvIV(right);
2165 SETi(i);
d0ba1bd2
JH		 2166 }
2167 else {
972b05a9
JH		 2168 UV u = SvUV(left) & SvUV(right);
2169 SETu(u);
d0ba1bd2 2170 }
a0d0e21e
LW		 2171 }
2172 else {
533c011a 2173 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2174 SETTARG;
2175 }
2176 RETURN;
2177 }
2178}
79072805 2179
a0d0e21e
LW		 2180PP(pp_bit_xor)
2181{
39644a26 2182 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW		 2183 {
2184 dPOPTOPssrl;
4633a7c4 2185 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2186 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2187 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2188 SETi(i);
d0ba1bd2
JH		 2189 }
2190 else {
972b05a9
JH		 2191 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2192 SETu(u);
d0ba1bd2 2193 }
a0d0e21e
LW		 2194 }
2195 else {
533c011a 2196 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2197 SETTARG;
2198 }
2199 RETURN;
2200 }
2201}
79072805 2202
a0d0e21e
LW		 2203PP(pp_bit_or)
2204{
39644a26 2205 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW		 2206 {
2207 dPOPTOPssrl;
4633a7c4 2208 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2209 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2210 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2211 SETi(i);
d0ba1bd2
JH		 2212 }
2213 else {
972b05a9
JH		 2214 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2215 SETu(u);
d0ba1bd2 2216 }
a0d0e21e
LW		 2217 }
2218 else {
533c011a 2219 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2220 SETTARG;
2221 }
2222 RETURN;
79072805 2223 }
a0d0e21e 2224}
79072805 2225
a0d0e21e
LW		 2226PP(pp_negate)
2227{
39644a26 2228 dSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW		 2229 {
2230 dTOPss;
28e5dec8 2231 int flags = SvFLAGS(sv);
4633a7c4
LW		 2232 if (SvGMAGICAL(sv))
2233 mg_get(sv);
28e5dec8
JH		 2234 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2235 /* It's publicly an integer, or privately an integer-not-float */
2236 oops_its_an_int:
9b0e499b
GS		 2237 if (SvIsUV(sv)) {
2238 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2239 /* 2s complement assumption. */
9b0e499b
GS		 2240 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2241 RETURN;
2242 }
2243 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2244 SETi(-SvIVX(sv));
9b0e499b
GS		 2245 RETURN;
2246 }
2247 }
2248 else if (SvIVX(sv) != IV_MIN) {
2249 SETi(-SvIVX(sv));
2250 RETURN;
2251 }
28e5dec8
JH		 2252#ifdef PERL_PRESERVE_IVUV
2253 else {
2254 SETu((UV)IV_MIN);
2255 RETURN;
2256 }
2257#endif
9b0e499b
GS		 2258 }
2259 if (SvNIOKp(sv))
a0d0e21e 2260 SETn(-SvNV(sv));
4633a7c4 2261 else if (SvPOKp(sv)) {
a0d0e21e
LW		 2262 STRLEN len;
2263 char *s = SvPV(sv, len);
bbce6d69 2264 if (isIDFIRST(*s)) {
a0d0e21e
LW		 2265 sv_setpvn(TARG, "-", 1);
2266 sv_catsv(TARG, sv);
79072805 2267 }
a0d0e21e
LW		 2268 else if (*s == '+' || *s == '-') {
2269 sv_setsv(TARG, sv);
2270 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805 2271 }
8eb28a70
JH		 2272 else if (DO_UTF8(sv)) {
2273 SvIV_please(sv);
2274 if (SvIOK(sv))
2275 goto oops_its_an_int;
2276 if (SvNOK(sv))
2277 sv_setnv(TARG, -SvNV(sv));
2278 else {
2279 sv_setpvn(TARG, "-", 1);
2280 sv_catsv(TARG, sv);
2281 }
834a4ddd 2282 }
28e5dec8 2283 else {
8eb28a70
JH		 2284 SvIV_please(sv);
2285 if (SvIOK(sv))
2286 goto oops_its_an_int;
2287 sv_setnv(TARG, -SvNV(sv));
28e5dec8 2288 }
a0d0e21e 2289 SETTARG;
79072805 2290 }
4633a7c4
LW		 2291 else
2292 SETn(-SvNV(sv));
79072805 2293 }
a0d0e21e 2294 RETURN;
79072805
LW		 2295}
2296
a0d0e21e 2297PP(pp_not)
79072805 2298{
39644a26 2299 dSP; tryAMAGICunSET(not);
3280af22 2300 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
a0d0e21e 2301 return NORMAL;
79072805
LW		 2302}
2303
a0d0e21e 2304PP(pp_complement)
79072805 2305{
39644a26 2306 dSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW		 2307 {
2308 dTOPss;
4633a7c4 2309 if (SvNIOKp(sv)) {
d0ba1bd2 2310 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2311 IV i = ~SvIV(sv);
2312 SETi(i);
d0ba1bd2
JH		 2313 }
2314 else {
972b05a9
JH		 2315 UV u = ~SvUV(sv);
2316 SETu(u);
d0ba1bd2 2317 }
a0d0e21e
LW		 2318 }
2319 else {
51723571 2320 register U8 *tmps;
55497cff 2321 register I32 anum;
a0d0e21e
LW		 2322 STRLEN len;
2323
2324 SvSetSV(TARG, sv);
51723571 2325 tmps = (U8*)SvPV_force(TARG, len);
a0d0e21e 2326 anum = len;
1d68d6cd 2327 if (SvUTF8(TARG)) {
a1ca4561 2328 /* Calculate exact length, let's not estimate. */
1d68d6cd
SC		 2329 STRLEN targlen = 0;
2330 U8 *result;
51723571 2331 U8 *send;
ba210ebe 2332 STRLEN l;
a1ca4561
YST		 2333 UV nchar = 0;
2334 UV nwide = 0;
1d68d6cd
SC		 2335
2336 send = tmps + len;
2337 while (tmps < send) {
9041c2e3 2338 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1d68d6cd 2339 tmps += UTF8SKIP(tmps);
5bbb0b5a 2340 targlen += UNISKIP(~c);
a1ca4561
YST		 2341 nchar++;
2342 if (c > 0xff)
2343 nwide++;
1d68d6cd
SC		 2344 }
2345
2346 /* Now rewind strings and write them. */
2347 tmps -= len;
a1ca4561
YST		 2348
2349 if (nwide) {
2350 Newz(0, result, targlen + 1, U8);
2351 while (tmps < send) {
9041c2e3 2352 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
a1ca4561 2353 tmps += UTF8SKIP(tmps);
b851fbc1 2354 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
a1ca4561
YST		 2355 }
2356 *result = '\0';
2357 result -= targlen;
2358 sv_setpvn(TARG, (char*)result, targlen);
2359 SvUTF8_on(TARG);
2360 }
2361 else {
2362 Newz(0, result, nchar + 1, U8);
2363 while (tmps < send) {
9041c2e3 2364 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
a1ca4561
YST		 2365 tmps += UTF8SKIP(tmps);
2366 *result++ = ~c;
2367 }
2368 *result = '\0';
2369 result -= nchar;
2370 sv_setpvn(TARG, (char*)result, nchar);
1d68d6cd 2371 }
1d68d6cd
SC		 2372 Safefree(result);
2373 SETs(TARG);
2374 RETURN;
2375 }
a0d0e21e 2376#ifdef LIBERAL
51723571
JH		 2377 {
2378 register long *tmpl;
2379 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2380 *tmps = ~*tmps;
2381 tmpl = (long*)tmps;
2382 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2383 *tmpl = ~*tmpl;
2384 tmps = (U8*)tmpl;
2385 }
a0d0e21e
LW		 2386#endif
2387 for ( ; anum > 0; anum--, tmps++)
2388 *tmps = ~*tmps;
2389
2390 SETs(TARG);
2391 }
2392 RETURN;
2393 }
79072805
LW		 2394}
2395
a0d0e21e
LW		 2396/* integer versions of some of the above */
2397
a0d0e21e 2398PP(pp_i_multiply)
79072805 2399{
39644a26 2400 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW		 2401 {
2402 dPOPTOPiirl;
2403 SETi( left * right );
2404 RETURN;
2405 }
79072805
LW		 2406}
2407
a0d0e21e 2408PP(pp_i_divide)
79072805 2409{
39644a26 2410 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW		 2411 {
2412 dPOPiv;
2413 if (value == 0)
cea2e8a9 2414 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW		 2415 value = POPi / value;
2416 PUSHi( value );
2417 RETURN;
2418 }
79072805
LW		 2419}
2420
a0d0e21e 2421PP(pp_i_modulo)
79072805 2422{
39644a26 2423 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
79072805 2424 {
a0d0e21e 2425 dPOPTOPiirl;
aa306039 2426 if (!right)
cea2e8a9 2427 DIE(aTHX_ "Illegal modulus zero");
a0d0e21e
LW		 2428 SETi( left % right );
2429 RETURN;
79072805 2430 }
79072805
LW		 2431}
2432
a0d0e21e 2433PP(pp_i_add)
79072805 2434{
39644a26 2435 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e 2436 {
5e66d4f1 2437 dPOPTOPiirl_ul;
a0d0e21e
LW		 2438 SETi( left + right );
2439 RETURN;
79072805 2440 }
79072805
LW		 2441}
2442
a0d0e21e 2443PP(pp_i_subtract)
79072805 2444{
39644a26 2445 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 2446 {
5e66d4f1 2447 dPOPTOPiirl_ul;
a0d0e21e
LW		 2448 SETi( left - right );
2449 RETURN;
79072805 2450 }
79072805
LW		 2451}
2452
a0d0e21e 2453PP(pp_i_lt)
79072805 2454{
39644a26 2455 dSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW		 2456 {
2457 dPOPTOPiirl;
54310121 2458 SETs(boolSV(left < right));
a0d0e21e
LW		 2459 RETURN;
2460 }
79072805
LW		 2461}
2462
a0d0e21e 2463PP(pp_i_gt)
79072805 2464{
39644a26 2465 dSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW		 2466 {
2467 dPOPTOPiirl;
54310121 2468 SETs(boolSV(left > right));
a0d0e21e
LW		 2469 RETURN;
2470 }
79072805
LW		 2471}
2472
a0d0e21e 2473PP(pp_i_le)
79072805 2474{
39644a26 2475 dSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW		 2476 {
2477 dPOPTOPiirl;
54310121 2478 SETs(boolSV(left <= right));
a0d0e21e 2479 RETURN;
85e6fe83 2480 }
79072805
LW		 2481}
2482
a0d0e21e 2483PP(pp_i_ge)
79072805 2484{
39644a26 2485 dSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW		 2486 {
2487 dPOPTOPiirl;
54310121 2488 SETs(boolSV(left >= right));
a0d0e21e
LW		 2489 RETURN;
2490 }
79072805
LW		 2491}
2492
a0d0e21e 2493PP(pp_i_eq)
79072805 2494{
39644a26 2495 dSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW		 2496 {
2497 dPOPTOPiirl;
54310121 2498 SETs(boolSV(left == right));
a0d0e21e
LW		 2499 RETURN;
2500 }
79072805
LW		 2501}
2502
a0d0e21e 2503PP(pp_i_ne)
79072805 2504{
39644a26 2505 dSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW		 2506 {
2507 dPOPTOPiirl;
54310121 2508 SETs(boolSV(left != right));
a0d0e21e
LW		 2509 RETURN;
2510 }
79072805
LW		 2511}
2512
a0d0e21e 2513PP(pp_i_ncmp)
79072805 2514{
39644a26 2515 dSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW		 2516 {
2517 dPOPTOPiirl;
2518 I32 value;
79072805 2519
a0d0e21e 2520 if (left > right)
79072805 2521 value = 1;
a0d0e21e 2522 else if (left < right)
79072805 2523 value = -1;
a0d0e21e 2524 else
79072805 2525 value = 0;
a0d0e21e
LW		 2526 SETi(value);
2527 RETURN;
79072805 2528 }
85e6fe83
LW		 2529}
2530
2531PP(pp_i_negate)
2532{
39644a26 2533 dSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW		 2534 SETi(-TOPi);
2535 RETURN;
2536}
2537
79072805
LW		 2538/* High falutin' math. */
2539
2540PP(pp_atan2)
2541{
39644a26 2542 dSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW		 2543 {
2544 dPOPTOPnnrl;
65202027 2545 SETn(Perl_atan2(left, right));
a0d0e21e
LW		 2546 RETURN;
2547 }
79072805
LW		 2548}
2549
2550PP(pp_sin)
2551{
39644a26 2552 dSP; dTARGET; tryAMAGICun(sin);
a0d0e21e 2553 {
65202027 2554 NV value;
a0d0e21e 2555 value = POPn;
65202027 2556 value = Perl_sin(value);
a0d0e21e
LW		 2557 XPUSHn(value);
2558 RETURN;
2559 }
79072805
LW		 2560}
2561
2562PP(pp_cos)
2563{
39644a26 2564 dSP; dTARGET; tryAMAGICun(cos);
a0d0e21e 2565 {
65202027 2566 NV value;
a0d0e21e 2567 value = POPn;
65202027 2568 value = Perl_cos(value);
a0d0e21e
LW		 2569 XPUSHn(value);
2570 RETURN;
2571 }
79072805
LW		 2572}
2573
56cb0a1c
AD		 2574/* Support Configure command-line overrides for rand() functions.
2575 After 5.005, perhaps we should replace this by Configure support
2576 for drand48(), random(), or rand(). For 5.005, though, maintain
2577 compatibility by calling rand() but allow the user to override it.
2578 See INSTALL for details. --Andy Dougherty 15 July 1998
2579*/
85ab1d1d
JH		 2580/* Now it's after 5.005, and Configure supports drand48() and random(),
2581 in addition to rand(). So the overrides should not be needed any more.
2582 --Jarkko Hietaniemi 27 September 1998
2583 */
2584
2585#ifndef HAS_DRAND48_PROTO
20ce7b12 2586extern double drand48 (void);
56cb0a1c
AD		 2587#endif
2588
79072805
LW		 2589PP(pp_rand)
2590{
39644a26 2591 dSP; dTARGET;
65202027 2592 NV value;
79072805
LW		 2593 if (MAXARG < 1)
2594 value = 1.0;
2595 else
2596 value = POPn;
2597 if (value == 0.0)
2598 value = 1.0;
80252599 2599 if (!PL_srand_called) {
85ab1d1d 2600 (void)seedDrand01((Rand_seed_t)seed());
80252599 2601 PL_srand_called = TRUE;
93dc8474 2602 }
85ab1d1d 2603 value *= Drand01();
79072805
LW		 2604 XPUSHn(value);
2605 RETURN;
2606}
2607
2608PP(pp_srand)
2609{
39644a26 2610 dSP;
93dc8474
CS		 2611 UV anum;
2612 if (MAXARG < 1)
2613 anum = seed();
79072805 2614 else
93dc8474 2615 anum = POPu;
85ab1d1d 2616 (void)seedDrand01((Rand_seed_t)anum);
80252599 2617 PL_srand_called = TRUE;
79072805
LW		 2618 EXTEND(SP, 1);
2619 RETPUSHYES;
2620}
2621
76e3520e 2622STATIC U32
cea2e8a9 2623S_seed(pTHX)
93dc8474 2624{
54310121 2625 /*
2626 * This is really just a quick hack which grabs various garbage
2627 * values. It really should be a real hash algorithm which
2628 * spreads the effect of every input bit onto every output bit,
85ab1d1d 2629 * if someone who knows about such things would bother to write it.
54310121 2630 * Might be a good idea to add that function to CORE as well.
85ab1d1d 2631 * No numbers below come from careful analysis or anything here,
54310121 2632 * except they are primes and SEED_C1 > 1E6 to get a full-width
2633 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2634 * probably be bigger too.
2635 */
2636#if RANDBITS > 16
2637# define SEED_C1 1000003
2638#define SEED_C4 73819
2639#else
2640# define SEED_C1 25747
2641#define SEED_C4 20639
2642#endif
2643#define SEED_C2 3
2644#define SEED_C3 269
2645#define SEED_C5 26107
2646
73c60299
RS		 2647#ifndef PERL_NO_DEV_RANDOM
2648 int fd;
2649#endif
93dc8474 2650 U32 u;
f12c7020 2651#ifdef VMS
2652# include <starlet.h>
43c92808
HF		 2653 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2654 * in 100-ns units, typically incremented ever 10 ms. */
93dc8474 2655 unsigned int when[2];
73c60299
RS		 2656#else
2657# ifdef HAS_GETTIMEOFDAY
2658 struct timeval when;
2659# else
2660 Time_t when;
2661# endif
2662#endif
2663
2664/* This test is an escape hatch, this symbol isn't set by Configure. */
2665#ifndef PERL_NO_DEV_RANDOM
2666#ifndef PERL_RANDOM_DEVICE
2667 /* /dev/random isn't used by default because reads from it will block
2668 * if there isn't enough entropy available. You can compile with
2669 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2670 * is enough real entropy to fill the seed. */
2671# define PERL_RANDOM_DEVICE "/dev/urandom"
2672#endif
2673 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2674 if (fd != -1) {
2675 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2676 u = 0;
2677 PerlLIO_close(fd);
2678 if (u)
2679 return u;
2680 }
2681#endif
2682
2683#ifdef VMS
93dc8474 2684 _ckvmssts(sys$gettim(when));
54310121 2685 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
f12c7020 2686#else
5f05dabc 2687# ifdef HAS_GETTIMEOFDAY
57ab3dfe 2688 PerlProc_gettimeofday(&when,NULL);
54310121 2689 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
f12c7020 2690# else
93dc8474 2691 (void)time(&when);
54310121 2692 u = (U32)SEED_C1 * when;
f12c7020 2693# endif
2694#endif
7766f137 2695 u += SEED_C3 * (U32)PerlProc_getpid();
56431972 2696 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
54310121 2697#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
56431972 2698 u += SEED_C5 * (U32)PTR2UV(&when);
f12c7020 2699#endif
93dc8474 2700 return u;
79072805
LW		 2701}
2702
2703PP(pp_exp)
2704{
39644a26 2705 dSP; dTARGET; tryAMAGICun(exp);
a0d0e21e 2706 {
65202027 2707 NV value;
a0d0e21e 2708 value = POPn;
65202027 2709 value = Perl_exp(value);
a0d0e21e
LW		 2710 XPUSHn(value);
2711 RETURN;
2712 }
79072805
LW		 2713}
2714
2715PP(pp_log)
2716{
39644a26 2717 dSP; dTARGET; tryAMAGICun(log);
a0d0e21e 2718 {
65202027 2719 NV value;
a0d0e21e 2720 value = POPn;
bbce6d69 2721 if (value <= 0.0) {
f93f4e46 2722 SET_NUMERIC_STANDARD();
1779d84d 2723 DIE(aTHX_ "Can't take log of %"NVgf, value);
bbce6d69 2724 }
65202027 2725 value = Perl_log(value);
a0d0e21e
LW		 2726 XPUSHn(value);
2727 RETURN;
2728 }
79072805
LW		 2729}
2730
2731PP(pp_sqrt)
2732{
39644a26 2733 dSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e 2734 {
65202027 2735 NV value;
a0d0e21e 2736 value = POPn;
bbce6d69 2737 if (value < 0.0) {
f93f4e46 2738 SET_NUMERIC_STANDARD();
1779d84d 2739 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
bbce6d69 2740 }
65202027 2741 value = Perl_sqrt(value);
a0d0e21e
LW		 2742 XPUSHn(value);
2743 RETURN;
2744 }
79072805
LW		 2745}
2746
24da999b
JH		 2747/*
2748 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2749 * These need to be revisited when a newer toolchain becomes available.
2750 */
2751#if defined(__sparc64__) && defined(__GNUC__)
2752# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2753# undef SPARC64_MODF_WORKAROUND
2754# define SPARC64_MODF_WORKAROUND 1
2755# endif
2756#endif
2757
2758#if defined(SPARC64_MODF_WORKAROUND)
2759static NV
2760sparc64_workaround_modf(NV theVal, NV *theIntRes)
2761{
2762 NV res, ret;
2763 ret = Perl_modf(theVal, &res);
2764 *theIntRes = res;
2765 return ret;
2766}
2767#endif
2768
79072805
LW		 2769PP(pp_int)
2770{
39644a26 2771 dSP; dTARGET; tryAMAGICun(int);
774d564b 2772 {
28e5dec8
JH		 2773 NV value;
2774 IV iv = TOPi; /* attempt to convert to IV if possible. */
2775 /* XXX it's arguable that compiler casting to IV might be subtly
2776 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2777 else preferring IV has introduced a subtle behaviour change bug. OTOH
2778 relying on floating point to be accurate is a bug. */
2779
2780 if (SvIOK(TOPs)) {
2781 if (SvIsUV(TOPs)) {
2782 UV uv = TOPu;
2783 SETu(uv);
2784 } else
2785 SETi(iv);
2786 } else {
2787 value = TOPn;
1048ea30 2788 if (value >= 0.0) {
28e5dec8
JH		 2789 if (value < (NV)UV_MAX + 0.5) {
2790 SETu(U_V(value));
2791 } else {
24da999b
JH		 2792#if defined(SPARC64_MODF_WORKAROUND)
2793 (void)sparc64_workaround_modf(value, &value);
2794#else
2795# if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
2796# ifdef HAS_MODFL_POW32_BUG
e67aeab1 2797/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
68795e93 2798 {
e67aeab1
JH		 2799 NV offset = Perl_modf(value, &value);
2800 (void)Perl_modf(offset, &offset);
2801 value += offset;
2802 }
24da999b 2803# else
28e5dec8 2804 (void)Perl_modf(value, &value);
24da999b
JH		 2805# endif
2806# else
28e5dec8
JH		 2807 double tmp = (double)value;
2808 (void)Perl_modf(tmp, &tmp);
2809 value = (NV)tmp;
24da999b 2810# endif
1048ea30 2811#endif
2d9af89d 2812 SETn(value);
28e5dec8 2813 }
1048ea30 2814 }
28e5dec8
JH		 2815 else {
2816 if (value > (NV)IV_MIN - 0.5) {
2817 SETi(I_V(value));
2818 } else {
1048ea30 2819#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
e67aeab1
JH		 2820# ifdef HAS_MODFL_POW32_BUG
2821/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
2822 {
2823 NV offset = Perl_modf(-value, &value);
2824 (void)Perl_modf(offset, &offset);
2825 value += offset;
2826 }
2827# else
28e5dec8 2828 (void)Perl_modf(-value, &value);
e67aeab1 2829# endif
28e5dec8 2830 value = -value;
1048ea30 2831#else
28e5dec8
JH		 2832 double tmp = (double)value;
2833 (void)Perl_modf(-tmp, &tmp);
2834 value = -(NV)tmp;
1048ea30 2835#endif
28e5dec8
JH		 2836 SETn(value);
2837 }
2838 }
774d564b 2839 }
79072805 2840 }
79072805
LW		 2841 RETURN;
2842}
2843
463ee0b2
LW		 2844PP(pp_abs)
2845{
39644a26 2846 dSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 2847 {
28e5dec8
JH		 2848 /* This will cache the NV value if string isn't actually integer */
2849 IV iv = TOPi;
a227d84d 2850
28e5dec8
JH		 2851 if (SvIOK(TOPs)) {
2852 /* IVX is precise */
2853 if (SvIsUV(TOPs)) {
2854 SETu(TOPu); /* force it to be numeric only */
2855 } else {
2856 if (iv >= 0) {
2857 SETi(iv);
2858 } else {
2859 if (iv != IV_MIN) {
2860 SETi(-iv);
2861 } else {
2862 /* 2s complement assumption. Also, not really needed as
2863 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2864 SETu(IV_MIN);
2865 }
a227d84d 2866 }
28e5dec8
JH		 2867 }
2868 } else{
2869 NV value = TOPn;
774d564b 2870 if (value < 0.0)
28e5dec8 2871 value = -value;
774d564b 2872 SETn(value);
2873 }
a0d0e21e 2874 }
774d564b 2875 RETURN;
463ee0b2
LW		 2876}
2877
53305cf1 2878
79072805
LW		 2879PP(pp_hex)
2880{
39644a26 2881 dSP; dTARGET;
79072805 2882 char *tmps;
53305cf1 2883 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2884 STRLEN len;
53305cf1
NC		 2885 NV result_nv;
2886 UV result_uv;
2bc69dc4 2887 SV* sv = POPs;
79072805 2888
2bc69dc4
NIS		 2889 tmps = (SvPVx(sv, len));
2890 if (DO_UTF8(sv)) {
2891 /* If Unicode, try to downgrade
2892 * If not possible, croak. */
2893 SV* tsv = sv_2mortal(newSVsv(sv));
2894
2895 SvUTF8_on(tsv);
2896 sv_utf8_downgrade(tsv, FALSE);
2897 tmps = SvPVX(tsv);
2898 }
53305cf1
NC		 2899 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2900 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2901 XPUSHn(result_nv);
2902 }
2903 else {
2904 XPUSHu(result_uv);
2905 }
79072805
LW		 2906 RETURN;
2907}
2908
2909PP(pp_oct)
2910{
39644a26 2911 dSP; dTARGET;
79072805 2912 char *tmps;
53305cf1 2913 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2914 STRLEN len;
53305cf1
NC		 2915 NV result_nv;
2916 UV result_uv;
2bc69dc4 2917 SV* sv = POPs;
79072805 2918
2bc69dc4
NIS		 2919 tmps = (SvPVx(sv, len));
2920 if (DO_UTF8(sv)) {
2921 /* If Unicode, try to downgrade
2922 * If not possible, croak. */
2923 SV* tsv = sv_2mortal(newSVsv(sv));
2924
2925 SvUTF8_on(tsv);
2926 sv_utf8_downgrade(tsv, FALSE);
2927 tmps = SvPVX(tsv);
2928 }
6f894ead 2929 while (*tmps && len && isSPACE(*tmps))
53305cf1 2930 tmps++, len--;
9e24b6e2 2931 if (*tmps == '0')
53305cf1 2932 tmps++, len--;
9e24b6e2 2933 if (*tmps == 'x')
53305cf1 2934 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
9e24b6e2 2935 else if (*tmps == 'b')
53305cf1 2936 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2937 else
53305cf1
NC		 2938 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2939
2940 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2941 XPUSHn(result_nv);
2942 }
2943 else {
2944 XPUSHu(result_uv);
2945 }
79072805
LW		 2946 RETURN;
2947}
2948
2949/* String stuff. */
2950
2951PP(pp_length)
2952{
39644a26 2953 dSP; dTARGET;
7e2040f0 2954 SV *sv = TOPs;
a0ed51b3 2955
7e2040f0
GS		 2956 if (DO_UTF8(sv))
2957 SETi(sv_len_utf8(sv));
2958 else
2959 SETi(sv_len(sv));
79072805
LW		 2960 RETURN;
2961}
2962
2963PP(pp_substr)
2964{
39644a26 2965 dSP; dTARGET;
79072805 2966 SV *sv;
9c5ffd7c 2967 I32 len = 0;
463ee0b2 2968 STRLEN curlen;
9402d6ed 2969 STRLEN utf8_curlen;
79072805
LW		 2970 I32 pos;
2971 I32 rem;
84902520 2972 I32 fail;
78f9721b 2973 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
79072805 2974 char *tmps;
3280af22 2975 I32 arybase = PL_curcop->cop_arybase;
9402d6ed 2976 SV *repl_sv = NULL;
7b8d334a
GS		 2977 char *repl = 0;
2978 STRLEN repl_len;
78f9721b 2979 int num_args = PL_op->op_private & 7;
13e30c65 2980 bool repl_need_utf8_upgrade = FALSE;
9402d6ed 2981 bool repl_is_utf8 = FALSE;
79072805 2982
20408e3c 2983 SvTAINTED_off(TARG); /* decontaminate */
7e2040f0 2984 SvUTF8_off(TARG); /* decontaminate */
78f9721b
SM		 2985 if (num_args > 2) {
2986 if (num_args > 3) {
9402d6ed
JH		 2987 repl_sv = POPs;
2988 repl = SvPV(repl_sv, repl_len);
2989 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
7b8d334a 2990 }
79072805 2991 len = POPi;
5d82c453 2992 }
84902520 2993 pos = POPi;
79072805 2994 sv = POPs;
849ca7ee 2995 PUTBACK;
9402d6ed
JH		 2996 if (repl_sv) {
2997 if (repl_is_utf8) {
2998 if (!DO_UTF8(sv))
2999 sv_utf8_upgrade(sv);
3000 }
13e30c65
JH		 3001 else if (DO_UTF8(sv))
3002 repl_need_utf8_upgrade = TRUE;
9402d6ed 3003 }
a0d0e21e 3004 tmps = SvPV(sv, curlen);
7e2040f0 3005 if (DO_UTF8(sv)) {
9402d6ed
JH		 3006 utf8_curlen = sv_len_utf8(sv);
3007 if (utf8_curlen == curlen)
3008 utf8_curlen = 0;
a0ed51b3 3009 else
9402d6ed 3010 curlen = utf8_curlen;
a0ed51b3 3011 }
d1c2b58a 3012 else
9402d6ed 3013 utf8_curlen = 0;
a0ed51b3 3014
84902520
TB		 3015 if (pos >= arybase) {
3016 pos -= arybase;
3017 rem = curlen-pos;
3018 fail = rem;
78f9721b 3019 if (num_args > 2) {
5d82c453
GA		 3020 if (len < 0) {
3021 rem += len;
3022 if (rem < 0)
3023 rem = 0;
3024 }
3025 else if (rem > len)
3026 rem = len;
3027 }
68dc0745 3028 }
84902520 3029 else {
5d82c453 3030 pos += curlen;
78f9721b 3031 if (num_args < 3)
5d82c453
GA		 3032 rem = curlen;
3033 else if (len >= 0) {
3034 rem = pos+len;
3035 if (rem > (I32)curlen)
3036 rem = curlen;
3037 }
3038 else {
3039 rem = curlen+len;
3040 if (rem < pos)
3041 rem = pos;
3042 }
3043 if (pos < 0)
3044 pos = 0;
3045 fail = rem;
3046 rem -= pos;
84902520
TB		 3047 }
3048 if (fail < 0) {
e476b1b5
GS		 3049 if (lvalue || repl)
3050 Perl_croak(aTHX_ "substr outside of string");
3051 if (ckWARN(WARN_SUBSTR))
9014280d 3052 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2304df62
AD		 3053 RETPUSHUNDEF;
3054 }
79072805 3055 else {
9aa983d2
JH		 3056 I32 upos = pos;
3057 I32 urem = rem;
9402d6ed 3058 if (utf8_curlen)
a0ed51b3 3059 sv_pos_u2b(sv, &pos, &rem);
79072805 3060 tmps += pos;
79072805 3061 sv_setpvn(TARG, tmps, rem);
12aa1545 3062#ifdef USE_LOCALE_COLLATE
14befaf4 3063 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3064#endif
9402d6ed 3065 if (utf8_curlen)
7f66633b 3066 SvUTF8_on(TARG);
f7928d6c 3067 if (repl) {
13e30c65
JH		 3068 SV* repl_sv_copy = NULL;
3069
3070 if (repl_need_utf8_upgrade) {
3071 repl_sv_copy = newSVsv(repl_sv);
3072 sv_utf8_upgrade(repl_sv_copy);
3073 repl = SvPV(repl_sv_copy, repl_len);
3074 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3075 }
c8faf1c5 3076 sv_insert(sv, pos, rem, repl, repl_len);
9402d6ed 3077 if (repl_is_utf8)
f7928d6c 3078 SvUTF8_on(sv);
9402d6ed
JH		 3079 if (repl_sv_copy)
3080 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3081 }
c8faf1c5 3082 else if (lvalue) { /* it's an lvalue! */
dedeecda 3083 if (!SvGMAGICAL(sv)) {
3084 if (SvROK(sv)) {
2d8e6c8d
GS		 3085 STRLEN n_a;
3086 SvPV_force(sv,n_a);
599cee73 3087 if (ckWARN(WARN_SUBSTR))
9014280d 3088 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
599cee73 3089 "Attempt to use reference as lvalue in substr");
dedeecda 3090 }
3091 if (SvOK(sv)) /* is it defined ? */
7f66633b 3092 (void)SvPOK_only_UTF8(sv);
dedeecda 3093 else
3094 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3095 }
5f05dabc 3096
a0d0e21e
LW		 3097 if (SvTYPE(TARG) < SVt_PVLV) {
3098 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3099 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
ed6116ce 3100 }
a0d0e21e 3101
5f05dabc 3102 LvTYPE(TARG) = 'x';
6ff81951
GS		 3103 if (LvTARG(TARG) != sv) {
3104 if (LvTARG(TARG))
3105 SvREFCNT_dec(LvTARG(TARG));
3106 LvTARG(TARG) = SvREFCNT_inc(sv);
3107 }
9aa983d2
JH		 3108 LvTARGOFF(TARG) = upos;
3109 LvTARGLEN(TARG) = urem;
79072805
LW		 3110 }
3111 }
849ca7ee 3112 SPAGAIN;
79072805
LW		 3113 PUSHs(TARG); /* avoid SvSETMAGIC here */
3114 RETURN;
3115}
3116
3117PP(pp_vec)
3118{
39644a26 3119 dSP; dTARGET;
467f0320
JH		 3120 register IV size = POPi;
3121 register IV offset = POPi;
79072805 3122 register SV *src = POPs;
78f9721b 3123 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e 3124
81e118e0
JH		 3125 SvTAINTED_off(TARG); /* decontaminate */
3126 if (lvalue) { /* it's an lvalue! */
3127 if (SvTYPE(TARG) < SVt_PVLV) {
3128 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3129 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
79072805 3130 }
81e118e0
JH		 3131 LvTYPE(TARG) = 'v';
3132 if (LvTARG(TARG) != src) {
3133 if (LvTARG(TARG))
3134 SvREFCNT_dec(LvTARG(TARG));
3135 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 3136 }
81e118e0
JH		 3137 LvTARGOFF(TARG) = offset;
3138 LvTARGLEN(TARG) = size;
79072805
LW		 3139 }
3140
81e118e0 3141 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW		 3142 PUSHs(TARG);
3143 RETURN;
3144}
3145
3146PP(pp_index)
3147{
39644a26 3148 dSP; dTARGET;
79072805
LW		 3149 SV *big;
3150 SV *little;
3151 I32 offset;
3152 I32 retval;
3153 char *tmps;
3154 char *tmps2;
463ee0b2 3155 STRLEN biglen;
3280af22 3156 I32 arybase = PL_curcop->cop_arybase;
79072805
LW		 3157
3158 if (MAXARG < 3)
3159 offset = 0;
3160 else
3161 offset = POPi - arybase;
3162 little = POPs;
3163 big = POPs;
463ee0b2 3164 tmps = SvPV(big, biglen);
7e2040f0 3165 if (offset > 0 && DO_UTF8(big))
a0ed51b3 3166 sv_pos_u2b(big, &offset, 0);
79072805
LW		 3167 if (offset < 0)
3168 offset = 0;
eb160463 3169 else if (offset > (I32)biglen)
93a17b20 3170 offset = biglen;
79072805 3171 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 3172 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 3173 retval = -1;
79072805 3174 else
a0ed51b3 3175 retval = tmps2 - tmps;
7e2040f0 3176 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3177 sv_pos_b2u(big, &retval);
3178 PUSHi(retval + arybase);
79072805
LW		 3179 RETURN;
3180}
3181
3182PP(pp_rindex)
3183{
39644a26 3184 dSP; dTARGET;
79072805
LW		 3185 SV *big;
3186 SV *little;
463ee0b2
LW		 3187 STRLEN blen;
3188 STRLEN llen;
79072805
LW		 3189 I32 offset;
3190 I32 retval;
3191 char *tmps;
3192 char *tmps2;
3280af22 3193 I32 arybase = PL_curcop->cop_arybase;
79072805 3194
a0d0e21e 3195 if (MAXARG >= 3)
a0ed51b3 3196 offset = POPi;
79072805
LW		 3197 little = POPs;
3198 big = POPs;
463ee0b2
LW		 3199 tmps2 = SvPV(little, llen);
3200 tmps = SvPV(big, blen);
79072805 3201 if (MAXARG < 3)
463ee0b2 3202 offset = blen;
a0ed51b3 3203 else {
7e2040f0 3204 if (offset > 0 && DO_UTF8(big))
a0ed51b3
LW		 3205 sv_pos_u2b(big, &offset, 0);
3206 offset = offset - arybase + llen;
3207 }
79072805
LW		 3208 if (offset < 0)
3209 offset = 0;
eb160463 3210 else if (offset > (I32)blen)
463ee0b2 3211 offset = blen;
79072805 3212 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 3213 tmps2, tmps2 + llen)))
a0ed51b3 3214 retval = -1;
79072805 3215 else
a0ed51b3 3216 retval = tmps2 - tmps;
7e2040f0 3217 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3218 sv_pos_b2u(big, &retval);
3219 PUSHi(retval + arybase);
79072805
LW		 3220 RETURN;
3221}
3222
3223PP(pp_sprintf)
3224{
39644a26 3225 dSP; dMARK; dORIGMARK; dTARGET;
79072805 3226 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3227 TAINT_IF(SvTAINTED(TARG));
6ee35fb7
JH		 3228 if (DO_UTF8(*(MARK+1)))
3229 SvUTF8_on(TARG);
79072805
LW		 3230 SP = ORIGMARK;
3231 PUSHTARG;
3232 RETURN;
3233}
3234
79072805
LW		 3235PP(pp_ord)
3236{
39644a26 3237 dSP; dTARGET;
7df053ec 3238 SV *argsv = POPs;
ba210ebe 3239 STRLEN len;
7df053ec 3240 U8 *s = (U8*)SvPVx(argsv, len);
121910a4
JH		 3241 SV *tmpsv;
3242
799ef3cb 3243 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
121910a4 3244 tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3245 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH		 3246 argsv = tmpsv;
3247 }
79072805 3248
872c91ae
JH		 3249 XPUSHu(DO_UTF8(argsv) ?
3250 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3251 (*s & 0xff));
68795e93 3252
79072805
LW		 3253 RETURN;
3254}
3255
463ee0b2
LW		 3256PP(pp_chr)
3257{
39644a26 3258 dSP; dTARGET;
463ee0b2 3259 char *tmps;
467f0320 3260 UV value = POPu;
463ee0b2 3261
748a9306 3262 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3263
0064a8a9 3264 if (value > 255 && !IN_BYTES) {
eb160463 3265 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3266 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
a0ed51b3
LW		 3267 SvCUR_set(TARG, tmps - SvPVX(TARG));
3268 *tmps = '\0';
3269 (void)SvPOK_only(TARG);
aa6ffa16 3270 SvUTF8_on(TARG);
a0ed51b3
LW		 3271 XPUSHs(TARG);
3272 RETURN;
3273 }
3274
748a9306 3275 SvGROW(TARG,2);
463ee0b2
LW		 3276 SvCUR_set(TARG, 1);
3277 tmps = SvPVX(TARG);
eb160463 3278 *tmps++ = (char)value;
748a9306 3279 *tmps = '\0';
a0d0e21e 3280 (void)SvPOK_only(TARG);
121910a4 3281 if (PL_encoding)
799ef3cb 3282 sv_recode_to_utf8(TARG, PL_encoding);
463ee0b2
LW		 3283 XPUSHs(TARG);
3284 RETURN;
3285}
3286
79072805
LW		 3287PP(pp_crypt)
3288{
5f74f29c 3289 dSP; dTARGET;
79072805 3290#ifdef HAS_CRYPT
5f74f29c
JH		 3291 dPOPTOPssrl;
3292 STRLEN n_a;
85c16d83
JH		 3293 STRLEN len;
3294 char *tmps = SvPV(left, len);
2bc69dc4 3295
85c16d83 3296 if (DO_UTF8(left)) {
2bc69dc4 3297 /* If Unicode, try to downgrade.
f2791508
JH		 3298 * If not possible, croak.
3299 * Yes, we made this up. */
3300 SV* tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3301
f2791508 3302 SvUTF8_on(tsv);
2bc69dc4 3303 sv_utf8_downgrade(tsv, FALSE);
f2791508 3304 tmps = SvPVX(tsv);
85c16d83 3305 }
5f74f29c 3306# ifdef FCRYPT
2d8e6c8d 3307 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
5f74f29c 3308# else
2d8e6c8d 3309 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
5f74f29c 3310# endif
4808266b
JH		 3311 SETs(TARG);
3312 RETURN;
79072805 3313#else
b13b2135 3314 DIE(aTHX_
79072805
LW		 3315 "The crypt() function is unimplemented due to excessive paranoia.");
3316#endif
79072805
LW		 3317}
3318
3319PP(pp_ucfirst)
3320{
39644a26 3321 dSP;
79072805 3322 SV *sv = TOPs;
a0ed51b3
LW		 3323 register U8 *s;
3324 STRLEN slen;
3325
d104a74c 3326 SvGETMAGIC(sv);
3a2263fe
RGS		 3327 if (DO_UTF8(sv) &&
3328 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3329 UTF8_IS_START(*s)) {
e7ae6809 3330 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
44bc797b
JH		 3331 STRLEN ulen;
3332 STRLEN tculen;
a0ed51b3 3333
44bc797b 3334 utf8_to_uvchr(s, &ulen);
44bc797b
JH		 3335 toTITLE_utf8(s, tmpbuf, &tculen);
3336 utf8_to_uvchr(tmpbuf, 0);
3337
3338 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
a0ed51b3 3339 dTARGET;
3a2263fe
RGS		 3340 /* slen is the byte length of the whole SV.
3341 * ulen is the byte length of the original Unicode character
3342 * stored as UTF-8 at s.
3343 * tculen is the byte length of the freshly titlecased
3344 * Unicode character stored as UTF-8 at tmpbuf.
3345 * We first set the result to be the titlecased character,
3346 * and then append the rest of the SV data. */
44bc797b 3347 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3a2263fe
RGS		 3348 if (slen > ulen)
3349 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3350 SvUTF8_on(TARG);
a0ed51b3
LW		 3351 SETs(TARG);
3352 }
3353 else {
d104a74c 3354 s = (U8*)SvPV_force_nomg(sv, slen);
44bc797b 3355 Copy(tmpbuf, s, tculen, U8);
a0ed51b3 3356 }
a0ed51b3 3357 }
626727d5 3358 else {
014822e4 3359 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3360 dTARGET;
7e2040f0 3361 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3362 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3363 sv = TARG;
3364 SETs(sv);
3365 }
d104a74c 3366 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3367 if (*s) {
2de3dbcc 3368 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3369 TAINT;
3370 SvTAINTED_on(sv);
3371 *s = toUPPER_LC(*s);
3372 }
3373 else
3374 *s = toUPPER(*s);
bbce6d69 3375 }
bbce6d69 3376 }
d104a74c 3377 SvSETMAGIC(sv);
79072805
LW		 3378 RETURN;
3379}
3380
3381PP(pp_lcfirst)
3382{
39644a26 3383 dSP;
79072805 3384 SV *sv = TOPs;
a0ed51b3
LW		 3385 register U8 *s;
3386 STRLEN slen;
3387
d104a74c 3388 SvGETMAGIC(sv);
3a2263fe
RGS		 3389 if (DO_UTF8(sv) &&
3390 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3391 UTF8_IS_START(*s)) {
ba210ebe 3392 STRLEN ulen;
e7ae6809 3393 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3394 U8 *tend;
9041c2e3 3395 UV uv;
a0ed51b3 3396
44bc797b 3397 toLOWER_utf8(s, tmpbuf, &ulen);
a2a2844f 3398 uv = utf8_to_uvchr(tmpbuf, 0);
9041c2e3 3399 tend = uvchr_to_utf8(tmpbuf, uv);
a0ed51b3 3400
eb160463 3401 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
a0ed51b3 3402 dTARGET;
dfe13c55 3403 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3a2263fe
RGS		 3404 if (slen > ulen)
3405 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3406 SvUTF8_on(TARG);
a0ed51b3
LW		 3407 SETs(TARG);
3408 }
3409 else {
d104a74c 3410 s = (U8*)SvPV_force_nomg(sv, slen);
a0ed51b3
LW		 3411 Copy(tmpbuf, s, ulen, U8);
3412 }
a0ed51b3 3413 }
626727d5 3414 else {
014822e4 3415 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3416 dTARGET;
7e2040f0 3417 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3418 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3419 sv = TARG;
3420 SETs(sv);
3421 }
d104a74c 3422 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3423 if (*s) {
2de3dbcc 3424 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3425 TAINT;
3426 SvTAINTED_on(sv);
3427 *s = toLOWER_LC(*s);
3428 }
3429 else
3430 *s = toLOWER(*s);
bbce6d69 3431 }
bbce6d69 3432 }
d104a74c 3433 SvSETMAGIC(sv);
79072805
LW		 3434 RETURN;
3435}
3436
3437PP(pp_uc)
3438{
39644a26 3439 dSP;
79072805 3440 SV *sv = TOPs;
a0ed51b3 3441 register U8 *s;
463ee0b2 3442 STRLEN len;
79072805 3443
d104a74c 3444 SvGETMAGIC(sv);
7e2040f0 3445 if (DO_UTF8(sv)) {
a0ed51b3 3446 dTARGET;
ba210ebe 3447 STRLEN ulen;
a0ed51b3
LW		 3448 register U8 *d;
3449 U8 *send;
e7ae6809 3450 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3451
d104a74c 3452 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3453 if (!len) {
7e2040f0 3454 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3455 sv_setpvn(TARG, "", 0);
3456 SETs(TARG);
a0ed51b3
LW		 3457 }
3458 else {
98b27f73
JH		 3459 STRLEN nchar = utf8_length(s, s + len);
3460
31351b04 3461 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3462 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3463 (void)SvPOK_only(TARG);
3464 d = (U8*)SvPVX(TARG);
3465 send = s + len;
a2a2844f 3466 while (s < send) {
6fdb5f96 3467 toUPPER_utf8(s, tmpbuf, &ulen);
a2a2844f
JH		 3468 Copy(tmpbuf, d, ulen, U8);
3469 d += ulen;
3470 s += UTF8SKIP(s);
a0ed51b3 3471 }
31351b04 3472 *d = '\0';
7e2040f0 3473 SvUTF8_on(TARG);
31351b04
JS		 3474 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3475 SETs(TARG);
a0ed51b3 3476 }
a0ed51b3 3477 }
626727d5 3478 else {
014822e4 3479 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3480 dTARGET;
7e2040f0 3481 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3482 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3483 sv = TARG;
3484 SETs(sv);
3485 }
d104a74c 3486 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3487 if (len) {
3488 register U8 *send = s + len;
3489
2de3dbcc 3490 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3491 TAINT;
3492 SvTAINTED_on(sv);
3493 for (; s < send; s++)
3494 *s = toUPPER_LC(*s);
3495 }
3496 else {
3497 for (; s < send; s++)
3498 *s = toUPPER(*s);
3499 }
bbce6d69 3500 }
79072805 3501 }
d104a74c 3502 SvSETMAGIC(sv);
79072805
LW		 3503 RETURN;
3504}
3505
3506PP(pp_lc)
3507{
39644a26 3508 dSP;
79072805 3509 SV *sv = TOPs;
a0ed51b3 3510 register U8 *s;
463ee0b2 3511 STRLEN len;
79072805 3512
d104a74c 3513 SvGETMAGIC(sv);
7e2040f0 3514 if (DO_UTF8(sv)) {
a0ed51b3 3515 dTARGET;
ba210ebe 3516 STRLEN ulen;
a0ed51b3
LW		 3517 register U8 *d;
3518 U8 *send;
e7ae6809 3519 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3520
d104a74c 3521 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3522 if (!len) {
7e2040f0 3523 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3524 sv_setpvn(TARG, "", 0);
3525 SETs(TARG);
a0ed51b3
LW		 3526 }
3527 else {
98b27f73
JH		 3528 STRLEN nchar = utf8_length(s, s + len);
3529
31351b04 3530 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3531 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3532 (void)SvPOK_only(TARG);
3533 d = (U8*)SvPVX(TARG);
3534 send = s + len;
a2a2844f 3535 while (s < send) {
6fdb5f96
JH		 3536 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3537#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3538 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3539 /*
3540 * Now if the sigma is NOT followed by
3541 * /$ignorable_sequence$cased_letter/;
3542 * and it IS preceded by
3543 * /$cased_letter$ignorable_sequence/;
3544 * where $ignorable_sequence is
3545 * [\x{2010}\x{AD}\p{Mn}]*
3546 * and $cased_letter is
3547 * [\p{Ll}\p{Lo}\p{Lt}]
3548 * then it should be mapped to 0x03C2,
3549 * (GREEK SMALL LETTER FINAL SIGMA),
3550 * instead of staying 0x03A3.
3551 * See lib/unicore/SpecCase.txt.
3552 */
3553 }
a2a2844f
JH		 3554 Copy(tmpbuf, d, ulen, U8);
3555 d += ulen;
3556 s += UTF8SKIP(s);
a0ed51b3 3557 }
31351b04 3558 *d = '\0';
7e2040f0 3559 SvUTF8_on(TARG);
31351b04
JS		 3560 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3561 SETs(TARG);
a0ed51b3 3562 }
79072805 3563 }
626727d5 3564 else {
014822e4 3565 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3566 dTARGET;
7e2040f0 3567 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3568 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3569 sv = TARG;
3570 SETs(sv);
a0ed51b3 3571 }
bbce6d69 3572
d104a74c 3573 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3574 if (len) {
3575 register U8 *send = s + len;
bbce6d69 3576
2de3dbcc 3577 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3578 TAINT;
3579 SvTAINTED_on(sv);
3580 for (; s < send; s++)
3581 *s = toLOWER_LC(*s);
3582 }
3583 else {
3584 for (; s < send; s++)
3585 *s = toLOWER(*s);
3586 }
bbce6d69 3587 }
79072805 3588 }
d104a74c 3589 SvSETMAGIC(sv);
79072805
LW		 3590 RETURN;
3591}
3592
a0d0e21e 3593PP(pp_quotemeta)
79072805 3594{
39644a26 3595 dSP; dTARGET;
a0d0e21e
LW		 3596 SV *sv = TOPs;
3597 STRLEN len;
3598 register char *s = SvPV(sv,len);
3599 register char *d;
79072805 3600
7e2040f0 3601 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW		 3602 if (len) {
3603 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 3604 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3605 d = SvPVX(TARG);
7e2040f0 3606 if (DO_UTF8(sv)) {
0dd2cdef 3607 while (len) {
fd400ab9 3608 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 3609 STRLEN ulen = UTF8SKIP(s);
3610 if (ulen > len)
3611 ulen = len;
3612 len -= ulen;
3613 while (ulen--)
3614 *d++ = *s++;
3615 }
3616 else {
3617 if (!isALNUM(*s))
3618 *d++ = '\\';
3619 *d++ = *s++;
3620 len--;
3621 }
3622 }
7e2040f0 3623 SvUTF8_on(TARG);
0dd2cdef
LW		 3624 }
3625 else {
3626 while (len--) {
3627 if (!isALNUM(*s))
3628 *d++ = '\\';
3629 *d++ = *s++;
3630 }
79072805 3631 }
a0d0e21e
LW		 3632 *d = '\0';
3633 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 3634 (void)SvPOK_only_UTF8(TARG);
79072805 3635 }
a0d0e21e
LW		 3636 else
3637 sv_setpvn(TARG, s, len);
3638 SETs(TARG);
31351b04
JS		 3639 if (SvSMAGICAL(TARG))
3640 mg_set(TARG);
79072805
LW		 3641 RETURN;
3642}
3643
a0d0e21e 3644/* Arrays. */
79072805 3645
a0d0e21e 3646PP(pp_aslice)
79072805 3647{
39644a26 3648 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3649 register SV** svp;
3650 register AV* av = (AV*)POPs;
78f9721b 3651 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3280af22 3652 I32 arybase = PL_curcop->cop_arybase;
748a9306 3653 I32 elem;
79072805 3654
a0d0e21e 3655 if (SvTYPE(av) == SVt_PVAV) {
533c011a 3656 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 3657 I32 max = -1;
924508f0 3658 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 3659 elem = SvIVx(*svp);
3660 if (elem > max)
3661 max = elem;
3662 }
3663 if (max > AvMAX(av))
3664 av_extend(av, max);
3665 }
a0d0e21e 3666 while (++MARK <= SP) {
748a9306 3667 elem = SvIVx(*MARK);
a0d0e21e 3668
748a9306
LW		 3669 if (elem > 0)
3670 elem -= arybase;
a0d0e21e
LW		 3671 svp = av_fetch(av, elem, lval);
3672 if (lval) {
3280af22 3673 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 3674 DIE(aTHX_ PL_no_aelem, elem);
533c011a 3675 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 3676 save_aelem(av, elem, svp);
79072805 3677 }
3280af22 3678 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 3679 }
3680 }
748a9306 3681 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 3682 MARK = ORIGMARK;
3683 *++MARK = *SP;
3684 SP = MARK;
3685 }
79072805
LW		 3686 RETURN;
3687}
3688
3689/* Associative arrays. */
3690
3691PP(pp_each)
3692{
39644a26 3693 dSP;
79072805 3694 HV *hash = (HV*)POPs;
c07a80fd 3695 HE *entry;
54310121 3696 I32 gimme = GIMME_V;
8ec5e241 3697
c07a80fd 3698 PUTBACK;
c750a3ec 3699 /* might clobber stack_sp */
6d822dc4 3700 entry = hv_iternext(hash);
c07a80fd 3701 SPAGAIN;
79072805 3702
79072805
LW		 3703 EXTEND(SP, 2);
3704 if (entry) {
574c8022 3705 SV* sv = hv_iterkeysv(entry);
574c8022 3706 PUSHs(sv); /* won't clobber stack_sp */
54310121 3707 if (gimme == G_ARRAY) {
59af0135 3708 SV *val;
c07a80fd 3709 PUTBACK;
c750a3ec 3710 /* might clobber stack_sp */
6d822dc4 3711 val = hv_iterval(hash, entry);
c07a80fd 3712 SPAGAIN;
59af0135 3713 PUSHs(val);
79072805 3714 }
79072805 3715 }
54310121 3716 else if (gimme == G_SCALAR)
79072805
LW		 3717 RETPUSHUNDEF;
3718
3719 RETURN;
3720}
3721
3722PP(pp_values)
3723{
cea2e8a9 3724 return do_kv();
79072805
LW		 3725}
3726
3727PP(pp_keys)
3728{
cea2e8a9 3729 return do_kv();
79072805
LW		 3730}
3731
3732PP(pp_delete)
3733{
39644a26 3734 dSP;
54310121 3735 I32 gimme = GIMME_V;