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
Second attempt to fix Devel::Peek test of $ENV{PATH}, after #17956
[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
44bc797b 3326 if (DO_UTF8(sv)) {
e7ae6809 3327 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
44bc797b
JH		 3328 STRLEN ulen;
3329 STRLEN tculen;
a0ed51b3 3330
44bc797b
JH		 3331 s = (U8*)SvPV(sv, slen);
3332 utf8_to_uvchr(s, &ulen);
a0ed51b3 3333
44bc797b
JH		 3334 toTITLE_utf8(s, tmpbuf, &tculen);
3335 utf8_to_uvchr(tmpbuf, 0);
3336
3337 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
a0ed51b3 3338 dTARGET;
44bc797b 3339 sv_setpvn(TARG, (char*)tmpbuf, tculen);
dfe13c55 3340 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3341 SvUTF8_on(TARG);
a0ed51b3
LW		 3342 SETs(TARG);
3343 }
3344 else {
dfe13c55 3345 s = (U8*)SvPV_force(sv, slen);
44bc797b 3346 Copy(tmpbuf, s, tculen, U8);
a0ed51b3 3347 }
a0ed51b3 3348 }
626727d5 3349 else {
014822e4 3350 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3351 dTARGET;
7e2040f0 3352 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 3353 sv_setsv(TARG, sv);
3354 sv = TARG;
3355 SETs(sv);
3356 }
3357 s = (U8*)SvPV_force(sv, slen);
3358 if (*s) {
2de3dbcc 3359 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3360 TAINT;
3361 SvTAINTED_on(sv);
3362 *s = toUPPER_LC(*s);
3363 }
3364 else
3365 *s = toUPPER(*s);
bbce6d69 3366 }
bbce6d69 3367 }
31351b04
JS		 3368 if (SvSMAGICAL(sv))
3369 mg_set(sv);
79072805
LW		 3370 RETURN;
3371}
3372
3373PP(pp_lcfirst)
3374{
39644a26 3375 dSP;
79072805 3376 SV *sv = TOPs;
a0ed51b3
LW		 3377 register U8 *s;
3378 STRLEN slen;
3379
fd400ab9 3380 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
ba210ebe 3381 STRLEN ulen;
e7ae6809 3382 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3383 U8 *tend;
9041c2e3 3384 UV uv;
a0ed51b3 3385
44bc797b 3386 toLOWER_utf8(s, tmpbuf, &ulen);
a2a2844f 3387 uv = utf8_to_uvchr(tmpbuf, 0);
a0ed51b3 3388
9041c2e3 3389 tend = uvchr_to_utf8(tmpbuf, uv);
a0ed51b3 3390
eb160463 3391 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
a0ed51b3 3392 dTARGET;
dfe13c55
GS		 3393 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3394 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3395 SvUTF8_on(TARG);
a0ed51b3
LW		 3396 SETs(TARG);
3397 }
3398 else {
dfe13c55 3399 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW		 3400 Copy(tmpbuf, s, ulen, U8);
3401 }
a0ed51b3 3402 }
626727d5 3403 else {
014822e4 3404 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3405 dTARGET;
7e2040f0 3406 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 3407 sv_setsv(TARG, sv);
3408 sv = TARG;
3409 SETs(sv);
3410 }
3411 s = (U8*)SvPV_force(sv, slen);
3412 if (*s) {
2de3dbcc 3413 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3414 TAINT;
3415 SvTAINTED_on(sv);
3416 *s = toLOWER_LC(*s);
3417 }
3418 else
3419 *s = toLOWER(*s);
bbce6d69 3420 }
bbce6d69 3421 }
31351b04
JS		 3422 if (SvSMAGICAL(sv))
3423 mg_set(sv);
79072805
LW		 3424 RETURN;
3425}
3426
3427PP(pp_uc)
3428{
39644a26 3429 dSP;
79072805 3430 SV *sv = TOPs;
a0ed51b3 3431 register U8 *s;
463ee0b2 3432 STRLEN len;
79072805 3433
7e2040f0 3434 if (DO_UTF8(sv)) {
a0ed51b3 3435 dTARGET;
ba210ebe 3436 STRLEN ulen;
a0ed51b3
LW		 3437 register U8 *d;
3438 U8 *send;
e7ae6809 3439 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3440
dfe13c55 3441 s = (U8*)SvPV(sv,len);
a5a20234 3442 if (!len) {
7e2040f0 3443 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3444 sv_setpvn(TARG, "", 0);
3445 SETs(TARG);
a0ed51b3
LW		 3446 }
3447 else {
98b27f73
JH		 3448 STRLEN nchar = utf8_length(s, s + len);
3449
31351b04 3450 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3451 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3452 (void)SvPOK_only(TARG);
3453 d = (U8*)SvPVX(TARG);
3454 send = s + len;
a2a2844f 3455 while (s < send) {
6fdb5f96 3456 toUPPER_utf8(s, tmpbuf, &ulen);
a2a2844f
JH		 3457 Copy(tmpbuf, d, ulen, U8);
3458 d += ulen;
3459 s += UTF8SKIP(s);
a0ed51b3 3460 }
31351b04 3461 *d = '\0';
7e2040f0 3462 SvUTF8_on(TARG);
31351b04
JS		 3463 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3464 SETs(TARG);
a0ed51b3 3465 }
a0ed51b3 3466 }
626727d5 3467 else {
014822e4 3468 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3469 dTARGET;
7e2040f0 3470 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 3471 sv_setsv(TARG, sv);
3472 sv = TARG;
3473 SETs(sv);
3474 }
3475 s = (U8*)SvPV_force(sv, len);
3476 if (len) {
3477 register U8 *send = s + len;
3478
2de3dbcc 3479 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3480 TAINT;
3481 SvTAINTED_on(sv);
3482 for (; s < send; s++)
3483 *s = toUPPER_LC(*s);
3484 }
3485 else {
3486 for (; s < send; s++)
3487 *s = toUPPER(*s);
3488 }
bbce6d69 3489 }
79072805 3490 }
31351b04
JS		 3491 if (SvSMAGICAL(sv))
3492 mg_set(sv);
79072805
LW		 3493 RETURN;
3494}
3495
3496PP(pp_lc)
3497{
39644a26 3498 dSP;
79072805 3499 SV *sv = TOPs;
a0ed51b3 3500 register U8 *s;
463ee0b2 3501 STRLEN len;
79072805 3502
7e2040f0 3503 if (DO_UTF8(sv)) {
a0ed51b3 3504 dTARGET;
ba210ebe 3505 STRLEN ulen;
a0ed51b3
LW		 3506 register U8 *d;
3507 U8 *send;
e7ae6809 3508 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3509
dfe13c55 3510 s = (U8*)SvPV(sv,len);
a5a20234 3511 if (!len) {
7e2040f0 3512 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3513 sv_setpvn(TARG, "", 0);
3514 SETs(TARG);
a0ed51b3
LW		 3515 }
3516 else {
98b27f73
JH		 3517 STRLEN nchar = utf8_length(s, s + len);
3518
31351b04 3519 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3520 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3521 (void)SvPOK_only(TARG);
3522 d = (U8*)SvPVX(TARG);
3523 send = s + len;
a2a2844f 3524 while (s < send) {
6fdb5f96
JH		 3525 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3526#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3527 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3528 /*
3529 * Now if the sigma is NOT followed by
3530 * /$ignorable_sequence$cased_letter/;
3531 * and it IS preceded by
3532 * /$cased_letter$ignorable_sequence/;
3533 * where $ignorable_sequence is
3534 * [\x{2010}\x{AD}\p{Mn}]*
3535 * and $cased_letter is
3536 * [\p{Ll}\p{Lo}\p{Lt}]
3537 * then it should be mapped to 0x03C2,
3538 * (GREEK SMALL LETTER FINAL SIGMA),
3539 * instead of staying 0x03A3.
3540 * See lib/unicore/SpecCase.txt.
3541 */
3542 }
a2a2844f
JH		 3543 Copy(tmpbuf, d, ulen, U8);
3544 d += ulen;
3545 s += UTF8SKIP(s);
a0ed51b3 3546 }
31351b04 3547 *d = '\0';
7e2040f0 3548 SvUTF8_on(TARG);
31351b04
JS		 3549 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3550 SETs(TARG);
a0ed51b3 3551 }
79072805 3552 }
626727d5 3553 else {
014822e4 3554 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3555 dTARGET;
7e2040f0 3556 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 3557 sv_setsv(TARG, sv);
3558 sv = TARG;
3559 SETs(sv);
a0ed51b3 3560 }
bbce6d69 3561
31351b04
JS		 3562 s = (U8*)SvPV_force(sv, len);
3563 if (len) {
3564 register U8 *send = s + len;
bbce6d69 3565
2de3dbcc 3566 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3567 TAINT;
3568 SvTAINTED_on(sv);
3569 for (; s < send; s++)
3570 *s = toLOWER_LC(*s);
3571 }
3572 else {
3573 for (; s < send; s++)
3574 *s = toLOWER(*s);
3575 }
bbce6d69 3576 }
79072805 3577 }
31351b04
JS		 3578 if (SvSMAGICAL(sv))
3579 mg_set(sv);
79072805
LW		 3580 RETURN;
3581}
3582
a0d0e21e 3583PP(pp_quotemeta)
79072805 3584{
39644a26 3585 dSP; dTARGET;
a0d0e21e
LW		 3586 SV *sv = TOPs;
3587 STRLEN len;
3588 register char *s = SvPV(sv,len);
3589 register char *d;
79072805 3590
7e2040f0 3591 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW		 3592 if (len) {
3593 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 3594 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3595 d = SvPVX(TARG);
7e2040f0 3596 if (DO_UTF8(sv)) {
0dd2cdef 3597 while (len) {
fd400ab9 3598 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 3599 STRLEN ulen = UTF8SKIP(s);
3600 if (ulen > len)
3601 ulen = len;
3602 len -= ulen;
3603 while (ulen--)
3604 *d++ = *s++;
3605 }
3606 else {
3607 if (!isALNUM(*s))
3608 *d++ = '\\';
3609 *d++ = *s++;
3610 len--;
3611 }
3612 }
7e2040f0 3613 SvUTF8_on(TARG);
0dd2cdef
LW		 3614 }
3615 else {
3616 while (len--) {
3617 if (!isALNUM(*s))
3618 *d++ = '\\';
3619 *d++ = *s++;
3620 }
79072805 3621 }
a0d0e21e
LW		 3622 *d = '\0';
3623 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 3624 (void)SvPOK_only_UTF8(TARG);
79072805 3625 }
a0d0e21e
LW		 3626 else
3627 sv_setpvn(TARG, s, len);
3628 SETs(TARG);
31351b04
JS		 3629 if (SvSMAGICAL(TARG))
3630 mg_set(TARG);
79072805
LW		 3631 RETURN;
3632}
3633
a0d0e21e 3634/* Arrays. */
79072805 3635
a0d0e21e 3636PP(pp_aslice)
79072805 3637{
39644a26 3638 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3639 register SV** svp;
3640 register AV* av = (AV*)POPs;
78f9721b 3641 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3280af22 3642 I32 arybase = PL_curcop->cop_arybase;
748a9306 3643 I32 elem;
79072805 3644
a0d0e21e 3645 if (SvTYPE(av) == SVt_PVAV) {
533c011a 3646 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 3647 I32 max = -1;
924508f0 3648 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 3649 elem = SvIVx(*svp);
3650 if (elem > max)
3651 max = elem;
3652 }
3653 if (max > AvMAX(av))
3654 av_extend(av, max);
3655 }
a0d0e21e 3656 while (++MARK <= SP) {
748a9306 3657 elem = SvIVx(*MARK);
a0d0e21e 3658
748a9306
LW		 3659 if (elem > 0)
3660 elem -= arybase;
a0d0e21e
LW		 3661 svp = av_fetch(av, elem, lval);
3662 if (lval) {
3280af22 3663 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 3664 DIE(aTHX_ PL_no_aelem, elem);
533c011a 3665 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 3666 save_aelem(av, elem, svp);
79072805 3667 }
3280af22 3668 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 3669 }
3670 }
748a9306 3671 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 3672 MARK = ORIGMARK;
3673 *++MARK = *SP;
3674 SP = MARK;
3675 }
79072805
LW		 3676 RETURN;
3677}
3678
3679/* Associative arrays. */
3680
3681PP(pp_each)
3682{
39644a26 3683 dSP;
79072805 3684 HV *hash = (HV*)POPs;
c07a80fd 3685 HE *entry;
54310121 3686 I32 gimme = GIMME_V;
8ec5e241 3687
c07a80fd 3688 PUTBACK;
c750a3ec 3689 /* might clobber stack_sp */
6d822dc4 3690 entry = hv_iternext(hash);
c07a80fd 3691 SPAGAIN;
79072805 3692
79072805
LW		 3693 EXTEND(SP, 2);
3694 if (entry) {
574c8022 3695 SV* sv = hv_iterkeysv(entry);
574c8022 3696 PUSHs(sv); /* won't clobber stack_sp */
54310121 3697 if (gimme == G_ARRAY) {
59af0135 3698 SV *val;
c07a80fd 3699 PUTBACK;
c750a3ec 3700 /* might clobber stack_sp */
6d822dc4 3701 val = hv_iterval(hash, entry);
c07a80fd 3702 SPAGAIN;
59af0135 3703 PUSHs(val);
79072805 3704 }
79072805 3705 }
54310121 3706 else if (gimme == G_SCALAR)
79072805
LW		 3707 RETPUSHUNDEF;
3708
3709 RETURN;
3710}
3711
3712PP(pp_values)
3713{
cea2e8a9 3714 return do_kv();
79072805
LW		 3715}
3716
3717PP(pp_keys)
3718{
cea2e8a9 3719 return do_kv();
79072805
LW		 3720}
3721
3722PP(pp_delete)
3723{
39644a26 3724 dSP;
54310121 3725 I32 gimme = GIMME_V;
3726 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 3727 SV *sv;
5f05dabc 3728 HV *hv;
3729
533c011a 3730 if (PL_op->op_private & OPpSLICE) {
5f05dabc 3731 dMARK; dORIGMARK;
97fcbf96 3732 U32 hvtype;
5f05dabc 3733 hv = (HV*)POPs;
97fcbf96 3734 hvtype = SvTYPE(hv);
01020589
GS		 3735 if (hvtype == SVt_PVHV) { /* hash element */
3736 while (++MARK <= SP) {
ae77835f 3737 sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 3738 *MARK = sv ? sv : &PL_sv_undef;
3739 }
5f05dabc 3740 }
6d822dc4
MS		 3741 else if (hvtype == SVt_PVAV) { /* array element */
3742 if (PL_op->op_flags & OPf_SPECIAL) {
3743 while (++MARK <= SP) {
3744 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3745 *MARK = sv ? sv : &PL_sv_undef;
3746 }
3747 }
01020589
GS		 3748 }
3749 else
3750 DIE(aTHX_ "Not a HASH reference");
54310121 3751 if (discard)
3752 SP = ORIGMARK;
3753 else if (gimme == G_SCALAR) {
5f05dabc 3754 MARK = ORIGMARK;
3755 *++MARK = *SP;
3756 SP = MARK;
3757 }
3758 }
3759 else {
3760 SV *keysv = POPs;
3761 hv = (HV*)POPs;
97fcbf96
MB		 3762 if (SvTYPE(hv) == SVt_PVHV)
3763 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 3764 else if (SvTYPE(hv) == SVt_PVAV) {
3765 if (PL_op->op_flags & OPf_SPECIAL)
3766 sv = av_delete((AV*)hv, SvIV(keysv), discard);
af288a60
HS		 3767 else
3768 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 3769 }
97fcbf96 3770 else
cea2e8a9 3771 DIE(aTHX_ "Not a HASH reference");
5f05dabc 3772 if (!sv)
3280af22 3773 sv = &PL_sv_undef;
54310121 3774 if (!discard)
3775 PUSHs(sv);
79072805 3776 }
79072805
LW		 3777 RETURN;
3778}
3779
a0d0e21e 3780PP(pp_exists)
79072805 3781{
39644a26 3782 dSP;
afebc493
GS		 3783 SV *tmpsv;
3784 HV *hv;
3785
3786 if (PL_op->op_private & OPpEXISTS_SUB) {
3787 GV *gv;
3788 CV *cv;
3789 SV *sv = POPs;
3790 cv = sv_2cv(sv, &hv, &gv, FALSE);
3791 if (cv)
3792 RETPUSHYES;
3793 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3794 RETPUSHYES;
3795 RETPUSHNO;
3796 }
3797 tmpsv = POPs;
3798 hv = (HV*)POPs;
c750a3ec 3799 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 3800 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 3801 RETPUSHYES;
ef54e1a4
JH		 3802 }
3803 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS		 3804 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3805 if (av_exists((AV*)hv, SvIV(tmpsv)))
3806 RETPUSHYES;
3807 }
ef54e1a4
JH		 3808 }
3809 else {
cea2e8a9 3810 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 3811 }
a0d0e21e
LW		 3812 RETPUSHNO;
3813}
79072805 3814
a0d0e21e
LW		 3815PP(pp_hslice)
3816{
39644a26 3817 dSP; dMARK; dORIGMARK;
a0d0e21e 3818 register HV *hv = (HV*)POPs;
78f9721b 3819 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
eb85dfd3
DM		 3820 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3821 bool other_magic = FALSE;
79072805 3822
eb85dfd3
DM		 3823 if (localizing) {
3824 MAGIC *mg;
3825 HV *stash;
3826
3827 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3828 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3829 /* Try to preserve the existenceness of a tied hash
3830 * element by using EXISTS and DELETE if possible.
3831 * Fallback to FETCH and STORE otherwise */
3832 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3833 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3834 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3835 }
3836
6d822dc4
MS		 3837 while (++MARK <= SP) {
3838 SV *keysv = *MARK;
3839 SV **svp;
3840 HE *he;
3841 bool preeminent = FALSE;
0ebe0038 3842
6d822dc4
MS		 3843 if (localizing) {
3844 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3845 hv_exists_ent(hv, keysv, 0);
3846 }
eb85dfd3 3847
6d822dc4
MS		 3848 he = hv_fetch_ent(hv, keysv, lval, 0);
3849 svp = he ? &HeVAL(he) : 0;
eb85dfd3 3850
6d822dc4
MS		 3851 if (lval) {
3852 if (!svp || *svp == &PL_sv_undef) {
3853 STRLEN n_a;
3854 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3855 }
3856 if (localizing) {
3857 if (preeminent)
3858 save_helem(hv, keysv, svp);
3859 else {
3860 STRLEN keylen;
3861 char *key = SvPV(keysv, keylen);
3862 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1f5346dc 3863 }
6d822dc4
MS		 3864 }
3865 }
3866 *MARK = svp ? *svp : &PL_sv_undef;
79072805 3867 }
a0d0e21e
LW		 3868 if (GIMME != G_ARRAY) {
3869 MARK = ORIGMARK;
3870 *++MARK = *SP;
3871 SP = MARK;
79072805 3872 }
a0d0e21e
LW		 3873 RETURN;
3874}
3875
3876/* List operators. */
3877
3878PP(pp_list)
3879{
39644a26 3880 dSP; dMARK;
a0d0e21e
LW		 3881 if (GIMME != G_ARRAY) {
3882 if (++MARK <= SP)
3883 *MARK = *SP; /* unwanted list, return last item */
8990e307 3884 else
3280af22 3885 *MARK = &PL_sv_undef;
a0d0e21e 3886 SP = MARK;
79072805 3887 }
a0d0e21e 3888 RETURN;
79072805
LW		 3889}
3890
a0d0e21e 3891PP(pp_lslice)
79072805 3892{
39644a26 3893 dSP;
3280af22
NIS		 3894 SV **lastrelem = PL_stack_sp;
3895 SV **lastlelem = PL_stack_base + POPMARK;
3896 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 3897 register SV **firstrelem = lastlelem + 1;
3280af22 3898 I32 arybase = PL_curcop->cop_arybase;
533c011a 3899 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 3900 I32 is_something_there = lval;
79072805 3901
a0d0e21e
LW		 3902 register I32 max = lastrelem - lastlelem;
3903 register SV **lelem;
3904 register I32 ix;
3905
3906 if (GIMME != G_ARRAY) {
748a9306
LW		 3907 ix = SvIVx(*lastlelem);
3908 if (ix < 0)
3909 ix += max;
3910 else
3911 ix -= arybase;
a0d0e21e 3912 if (ix < 0 || ix >= max)
3280af22 3913 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 3914 else
3915 *firstlelem = firstrelem[ix];
3916 SP = firstlelem;
3917 RETURN;
3918 }
3919
3920 if (max == 0) {
3921 SP = firstlelem - 1;
3922 RETURN;
3923 }
3924
3925 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 3926 ix = SvIVx(*lelem);
c73bf8e3 3927 if (ix < 0)
a0d0e21e 3928 ix += max;
b13b2135 3929 else
748a9306 3930 ix -= arybase;
c73bf8e3
HS		 3931 if (ix < 0 || ix >= max)
3932 *lelem = &PL_sv_undef;
3933 else {
3934 is_something_there = TRUE;
3935 if (!(*lelem = firstrelem[ix]))
3280af22 3936 *lelem = &PL_sv_undef;
748a9306 3937 }
79072805 3938 }
4633a7c4
LW		 3939 if (is_something_there)
3940 SP = lastlelem;
3941 else
3942 SP = firstlelem - 1;
79072805
LW		 3943 RETURN;
3944}
3945
a0d0e21e
LW		 3946PP(pp_anonlist)
3947{
39644a26 3948 dSP; dMARK; dORIGMARK;
a0d0e21e 3949 I32 items = SP - MARK;
44a8e56a 3950 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3951 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3952 XPUSHs(av);
a0d0e21e
LW		 3953 RETURN;
3954}
3955
3956PP(pp_anonhash)
79072805 3957{
39644a26 3958 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3959 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3960
3961 while (MARK < SP) {
3962 SV* key = *++MARK;
a0d0e21e
LW		 3963 SV *val = NEWSV(46, 0);
3964 if (MARK < SP)
3965 sv_setsv(val, *++MARK);
e476b1b5 3966 else if (ckWARN(WARN_MISC))
9014280d 3967 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
f12c7020 3968 (void)hv_store_ent(hv,key,val,0);
79072805 3969 }
a0d0e21e
LW		 3970 SP = ORIGMARK;
3971 XPUSHs((SV*)hv);
79072805
LW		 3972 RETURN;
3973}
3974
a0d0e21e 3975PP(pp_splice)
79072805 3976{
39644a26 3977 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3978 register AV *ary = (AV*)*++MARK;
3979 register SV **src;
3980 register SV **dst;
3981 register I32 i;
3982 register I32 offset;
3983 register I32 length;
3984 I32 newlen;
3985 I32 after;
3986 I32 diff;
3987 SV **tmparyval = 0;
93965878
NIS		 3988 MAGIC *mg;
3989
14befaf4 3990 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 3991 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 3992 PUSHMARK(MARK);
8ec5e241 3993 PUTBACK;
a60c0954 3994 ENTER;
864dbfa3 3995 call_method("SPLICE",GIMME_V);
a60c0954 3996 LEAVE;
93965878
NIS		 3997 SPAGAIN;
3998 RETURN;
3999 }
79072805 4000
a0d0e21e 4001 SP++;
79072805 4002
a0d0e21e 4003 if (++MARK < SP) {
84902520 4004 offset = i = SvIVx(*MARK);
a0d0e21e 4005 if (offset < 0)
93965878 4006 offset += AvFILLp(ary) + 1;
a0d0e21e 4007 else
3280af22 4008 offset -= PL_curcop->cop_arybase;
84902520 4009 if (offset < 0)
cea2e8a9 4010 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 4011 if (++MARK < SP) {
4012 length = SvIVx(*MARK++);
48cdf507
GA		 4013 if (length < 0) {
4014 length += AvFILLp(ary) - offset + 1;
4015 if (length < 0)
4016 length = 0;
4017 }
79072805
LW		 4018 }
4019 else
a0d0e21e 4020 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 4021 }
a0d0e21e
LW		 4022 else {
4023 offset = 0;
4024 length = AvMAX(ary) + 1;
4025 }
8cbc2e3b
JH		 4026 if (offset > AvFILLp(ary) + 1) {
4027 if (ckWARN(WARN_MISC))
9014280d 4028 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 4029 offset = AvFILLp(ary) + 1;
8cbc2e3b 4030 }
93965878 4031 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 4032 if (after < 0) { /* not that much array */
4033 length += after; /* offset+length now in array */
4034 after = 0;
4035 if (!AvALLOC(ary))
4036 av_extend(ary, 0);
4037 }
4038
4039 /* At this point, MARK .. SP-1 is our new LIST */
4040
4041 newlen = SP - MARK;
4042 diff = newlen - length;
13d7cbc1
GS		 4043 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4044 av_reify(ary);
a0d0e21e
LW		 4045
4046 if (diff < 0) { /* shrinking the area */
4047 if (newlen) {
4048 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4049 Copy(MARK, tmparyval, newlen, SV*);
79072805 4050 }
a0d0e21e
LW		 4051
4052 MARK = ORIGMARK + 1;
4053 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4054 MEXTEND(MARK, length);
4055 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4056 if (AvREAL(ary)) {
bbce6d69 4057 EXTEND_MORTAL(length);
36477c24 4058 for (i = length, dst = MARK; i; i--) {
d689ffdd 4059 sv_2mortal(*dst); /* free them eventualy */
36477c24 4060 dst++;
4061 }
a0d0e21e
LW		 4062 }
4063 MARK += length - 1;
79072805 4064 }
a0d0e21e
LW		 4065 else {
4066 *MARK = AvARRAY(ary)[offset+length-1];
4067 if (AvREAL(ary)) {
d689ffdd 4068 sv_2mortal(*MARK);
a0d0e21e
LW		 4069 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4070 SvREFCNT_dec(*dst++); /* free them now */
79072805 4071 }
a0d0e21e 4072 }
93965878 4073 AvFILLp(ary) += diff;
a0d0e21e
LW		 4074
4075 /* pull up or down? */
4076
4077 if (offset < after) { /* easier to pull up */
4078 if (offset) { /* esp. if nothing to pull */
4079 src = &AvARRAY(ary)[offset-1];
4080 dst = src - diff; /* diff is negative */
4081 for (i = offset; i > 0; i--) /* can't trust Copy */
4082 *dst-- = *src--;
79072805 4083 }
a0d0e21e
LW		 4084 dst = AvARRAY(ary);
4085 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4086 AvMAX(ary) += diff;
4087 }
4088 else {
4089 if (after) { /* anything to pull down? */
4090 src = AvARRAY(ary) + offset + length;
4091 dst = src + diff; /* diff is negative */
4092 Move(src, dst, after, SV*);
79072805 4093 }
93965878 4094 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 4095 /* avoid later double free */
4096 }
4097 i = -diff;
4098 while (i)
3280af22 4099 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 4100
4101 if (newlen) {
4102 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4103 newlen; newlen--) {
4104 *dst = NEWSV(46, 0);
4105 sv_setsv(*dst++, *src++);
79072805 4106 }
a0d0e21e
LW		 4107 Safefree(tmparyval);
4108 }
4109 }
4110 else { /* no, expanding (or same) */
4111 if (length) {
4112 New(452, tmparyval, length, SV*); /* so remember deletion */
4113 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4114 }
4115
4116 if (diff > 0) { /* expanding */
4117
4118 /* push up or down? */
4119
4120 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4121 if (offset) {
4122 src = AvARRAY(ary);
4123 dst = src - diff;
4124 Move(src, dst, offset, SV*);
79072805 4125 }
a0d0e21e
LW		 4126 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4127 AvMAX(ary) += diff;
93965878 4128 AvFILLp(ary) += diff;
79072805
LW		 4129 }
4130 else {
93965878
NIS		 4131 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4132 av_extend(ary, AvFILLp(ary) + diff);
4133 AvFILLp(ary) += diff;
a0d0e21e
LW		 4134
4135 if (after) {
93965878 4136 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 4137 src = dst - diff;
4138 for (i = after; i; i--) {
4139 *dst-- = *src--;
4140 }
79072805
LW		 4141 }
4142 }
a0d0e21e
LW		 4143 }
4144
4145 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4146 *dst = NEWSV(46, 0);
4147 sv_setsv(*dst++, *src++);
4148 }
4149 MARK = ORIGMARK + 1;
4150 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4151 if (length) {
4152 Copy(tmparyval, MARK, length, SV*);
4153 if (AvREAL(ary)) {
bbce6d69 4154 EXTEND_MORTAL(length);
36477c24 4155 for (i = length, dst = MARK; i; i--) {
d689ffdd 4156 sv_2mortal(*dst); /* free them eventualy */
36477c24 4157 dst++;
4158 }
79072805 4159 }
a0d0e21e 4160 Safefree(tmparyval);
79072805 4161 }
a0d0e21e
LW		 4162 MARK += length - 1;
4163 }
4164 else if (length--) {
4165 *MARK = tmparyval[length];
4166 if (AvREAL(ary)) {
d689ffdd 4167 sv_2mortal(*MARK);
a0d0e21e
LW		 4168 while (length-- > 0)
4169 SvREFCNT_dec(tmparyval[length]);
79072805 4170 }
a0d0e21e 4171 Safefree(tmparyval);
79072805 4172 }
a0d0e21e 4173 else
3280af22 4174 *MARK = &PL_sv_undef;
79072805 4175 }
a0d0e21e 4176 SP = MARK;
79072805
LW		 4177 RETURN;
4178}
4179
a0d0e21e 4180PP(pp_push)
79072805 4181{
39644a26 4182 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4183 register AV *ary = (AV*)*++MARK;
3280af22 4184 register SV *sv = &PL_sv_undef;
93965878 4185 MAGIC *mg;
79072805 4186
14befaf4 4187 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4188 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS		 4189 PUSHMARK(MARK);
4190 PUTBACK;
a60c0954 4191 ENTER;
864dbfa3 4192 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 4193 LEAVE;
93965878 4194 SPAGAIN;
93965878 4195 }
a60c0954
NIS		 4196 else {
4197 /* Why no pre-extend of ary here ? */
4198 for (++MARK; MARK <= SP; MARK++) {
4199 sv = NEWSV(51, 0);
4200 if (*MARK)
4201 sv_setsv(sv, *MARK);
4202 av_push(ary, sv);
4203 }
79072805
LW		 4204 }
4205 SP = ORIGMARK;
a0d0e21e 4206 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 4207 RETURN;
4208}
4209
a0d0e21e 4210PP(pp_pop)
79072805 4211{
39644a26 4212 dSP;
a0d0e21e
LW		 4213 AV *av = (AV*)POPs;
4214 SV *sv = av_pop(av);
d689ffdd 4215 if (AvREAL(av))
a0d0e21e
LW		 4216 (void)sv_2mortal(sv);
4217 PUSHs(sv);
79072805 4218 RETURN;
79072805
LW		 4219}
4220
a0d0e21e 4221PP(pp_shift)
79072805 4222{
39644a26 4223 dSP;
a0d0e21e
LW		 4224 AV *av = (AV*)POPs;
4225 SV *sv = av_shift(av);
79072805 4226 EXTEND(SP, 1);
a0d0e21e 4227 if (!sv)
79072805 4228 RETPUSHUNDEF;
d689ffdd 4229 if (AvREAL(av))
a0d0e21e
LW		 4230 (void)sv_2mortal(sv);
4231 PUSHs(sv);
79072805 4232 RETURN;
79072805
LW		 4233}
4234
a0d0e21e 4235PP(pp_unshift)
79072805 4236{
39644a26 4237 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4238 register AV *ary = (AV*)*++MARK;
4239 register SV *sv;
4240 register I32 i = 0;
93965878
NIS		 4241 MAGIC *mg;
4242
14befaf4 4243 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4244 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 4245 PUSHMARK(MARK);
93965878 4246 PUTBACK;
a60c0954 4247 ENTER;
864dbfa3 4248 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 4249 LEAVE;
93965878 4250 SPAGAIN;
93965878 4251 }
a60c0954
NIS		 4252 else {
4253 av_unshift(ary, SP - MARK);
4254 while (MARK < SP) {
4255 sv = NEWSV(27, 0);
4256 sv_setsv(sv, *++MARK);
4257 (void)av_store(ary, i++, sv);
4258 }
79072805 4259 }
a0d0e21e
LW		 4260 SP = ORIGMARK;
4261 PUSHi( AvFILL(ary) + 1 );
79072805 4262 RETURN;
79072805
LW		 4263}
4264
a0d0e21e 4265PP(pp_reverse)
79072805 4266{
39644a26 4267 dSP; dMARK;
a0d0e21e
LW		 4268 register SV *tmp;
4269 SV **oldsp = SP;
79072805 4270
a0d0e21e
LW		 4271 if (GIMME == G_ARRAY) {
4272 MARK++;
4273 while (MARK < SP) {
4274 tmp = *MARK;
4275 *MARK++ = *SP;
4276 *SP-- = tmp;
4277 }
dd58a1ab 4278 /* safe as long as stack cannot get extended in the above */
a0d0e21e 4279 SP = oldsp;
79072805
LW		 4280 }
4281 else {
a0d0e21e
LW		 4282 register char *up;
4283 register char *down;
4284 register I32 tmp;
4285 dTARGET;
4286 STRLEN len;
79072805 4287
7e2040f0 4288 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4289 if (SP - MARK > 1)
3280af22 4290 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 4291 else
54b9620d 4292 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW		 4293 up = SvPV_force(TARG, len);
4294 if (len > 1) {
7e2040f0 4295 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55
GS		 4296 U8* s = (U8*)SvPVX(TARG);
4297 U8* send = (U8*)(s + len);
a0ed51b3 4298 while (s < send) {
d742c382 4299 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 4300 s++;
4301 continue;
4302 }
4303 else {
9041c2e3 4304 if (!utf8_to_uvchr(s, 0))
a0dbb045 4305 break;
dfe13c55 4306 up = (char*)s;
a0ed51b3 4307 s += UTF8SKIP(s);
dfe13c55 4308 down = (char*)(s - 1);
a0dbb045 4309 /* reverse this character */
a0ed51b3
LW		 4310 while (down > up) {
4311 tmp = *up;
4312 *up++ = *down;
eb160463 4313 *down-- = (char)tmp;
a0ed51b3
LW		 4314 }
4315 }
4316 }
4317 up = SvPVX(TARG);
4318 }
a0d0e21e
LW		 4319 down = SvPVX(TARG) + len - 1;
4320 while (down > up) {
4321 tmp = *up;
4322 *up++ = *down;
eb160463 4323 *down-- = (char)tmp;
a0d0e21e 4324 }
3aa33fe5 4325 (void)SvPOK_only_UTF8(TARG);
79072805 4326 }
a0d0e21e
LW		 4327 SP = MARK + 1;
4328 SETTARG;
79072805 4329 }
a0d0e21e 4330 RETURN;
79072805
LW		 4331}
4332
a0d0e21e 4333PP(pp_split)
79072805 4334{
39644a26 4335 dSP; dTARG;
a0d0e21e 4336 AV *ary;
467f0320 4337 register IV limit = POPi; /* note, negative is forever */
a0d0e21e
LW		 4338 SV *sv = POPs;
4339 STRLEN len;
4340 register char *s = SvPV(sv, len);
1aa99e6b 4341 bool do_utf8 = DO_UTF8(sv);
a0d0e21e 4342 char *strend = s + len;
44a8e56a 4343 register PMOP *pm;
d9f97599 4344 register REGEXP *rx;
a0d0e21e
LW		 4345 register SV *dstr;
4346 register char *m;
4347 I32 iters = 0;
792b2c16
JH		 4348 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4349 I32 maxiters = slen + 10;
a0d0e21e
LW		 4350 I32 i;
4351 char *orig;
4352 I32 origlimit = limit;
4353 I32 realarray = 0;
4354 I32 base;
3280af22 4355 AV *oldstack = PL_curstack;
54310121 4356 I32 gimme = GIMME_V;
3280af22 4357 I32 oldsave = PL_savestack_ix;
8ec5e241
NIS		 4358 I32 make_mortal = 1;
4359 MAGIC *mg = (MAGIC *) NULL;
79072805 4360
44a8e56a 4361#ifdef DEBUGGING
4362 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4363#else
4364 pm = (PMOP*)POPs;
4365#endif
a0d0e21e 4366 if (!pm || !s)
2269b42e 4367 DIE(aTHX_ "panic: pp_split");
aaa362c4 4368 rx = PM_GETRE(pm);
bbce6d69 4369
4370 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4371 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4372
53c4c00c 4373 PL_reg_match_utf8 = do_utf8;
d9f424b2 4374
971a9dd3
GS		 4375 if (pm->op_pmreplroot) {
4376#ifdef USE_ITHREADS
dd2155a4 4377 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
971a9dd3 4378#else
a0d0e21e 4379 ary = GvAVn((GV*)pm->op_pmreplroot);
971a9dd3
GS		 4380#endif
4381 }
a0d0e21e 4382 else if (gimme != G_ARRAY)
4d1ff10f 4383#ifdef USE_5005THREADS
dd2155a4 4384 ary = (AV*)PAD_SVl(0);
6d4ff0d2 4385#else
3280af22 4386 ary = GvAVn(PL_defgv);
4d1ff10f 4387#endif /* USE_5005THREADS */
79072805 4388 else
a0d0e21e
LW		 4389 ary = Nullav;
4390 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4391 realarray = 1;
8ec5e241 4392 PUTBACK;
a0d0e21e
LW		 4393 av_extend(ary,0);
4394 av_clear(ary);
8ec5e241 4395 SPAGAIN;
14befaf4 4396 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
8ec5e241 4397 PUSHMARK(SP);
33c27489 4398 XPUSHs(SvTIED_obj((SV*)ary, mg));
8ec5e241
NIS		 4399 }
4400 else {
1c0b011c
NIS		 4401 if (!AvREAL(ary)) {
4402 AvREAL_on(ary);
abff13bb 4403 AvREIFY_off(ary);
1c0b011c 4404 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 4405 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 4406 }
4407 /* temporarily switch stacks */
3280af22 4408 SWITCHSTACK(PL_curstack, ary);
8ec5e241 4409 make_mortal = 0;
1c0b011c 4410 }
79072805 4411 }
3280af22 4412 base = SP - PL_stack_base;
a0d0e21e
LW		 4413 orig = s;
4414 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 4415 if (pm->op_pmflags & PMf_LOCALE) {
4416 while (isSPACE_LC(*s))
4417 s++;
4418 }
4419 else {
4420 while (isSPACE(*s))
4421 s++;
4422 }
a0d0e21e 4423 }
c07a80fd 4424 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS		 4425 SAVEINT(PL_multiline);
4426 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
c07a80fd 4427 }
4428
a0d0e21e
LW		 4429 if (!limit)
4430 limit = maxiters + 2;
4431 if (pm->op_pmflags & PMf_WHITE) {
4432 while (--limit) {
bbce6d69 4433 m = s;
4434 while (m < strend &&
4435 !((pm->op_pmflags & PMf_LOCALE)
4436 ? isSPACE_LC(*m) : isSPACE(*m)))
4437 ++m;
a0d0e21e
LW		 4438 if (m >= strend)
4439 break;
bbce6d69 4440
a0d0e21e
LW		 4441 dstr = NEWSV(30, m-s);
4442 sv_setpvn(dstr, s, m-s);
8ec5e241 4443 if (make_mortal)
a0d0e21e 4444 sv_2mortal(dstr);
792b2c16 4445 if (do_utf8)
28cb3359 4446 (void)SvUTF8_on(dstr);
a0d0e21e 4447 XPUSHs(dstr);
bbce6d69 4448
4449 s = m + 1;
4450 while (s < strend &&
4451 ((pm->op_pmflags & PMf_LOCALE)
4452 ? isSPACE_LC(*s) : isSPACE(*s)))
4453 ++s;
79072805
LW		 4454 }
4455 }
f4091fba 4456 else if (strEQ("^", rx->precomp)) {
a0d0e21e
LW		 4457 while (--limit) {
4458 /*SUPPRESS 530*/
4459 for (m = s; m < strend && *m != '\n'; m++) ;
4460 m++;
4461 if (m >= strend)
4462 break;
4463 dstr = NEWSV(30, m-s);
4464 sv_setpvn(dstr, s, m-s);
8ec5e241 4465 if (make_mortal)
a0d0e21e 4466 sv_2mortal(dstr);
792b2c16 4467 if (do_utf8)
28cb3359 4468 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4469 XPUSHs(dstr);
4470 s = m;
4471 }
4472 }
699c3c34
JH		 4473 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4474 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
d9f97599
GS		 4475 && (rx->reganch & ROPT_CHECK_ALL)
4476 && !(rx->reganch & ROPT_ANCH)) {
f722798b
IZ		 4477 int tail = (rx->reganch & RE_INTUIT_TAIL);
4478 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
cf93c79d 4479
ca5b42cb 4480 len = rx->minlen;
1aa99e6b 4481 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
93f04dac
JH		 4482 STRLEN n_a;
4483 char c = *SvPV(csv, n_a);
a0d0e21e 4484 while (--limit) {
bbce6d69 4485 /*SUPPRESS 530*/
f722798b 4486 for (m = s; m < strend && *m != c; m++) ;
a0d0e21e
LW		 4487 if (m >= strend)
4488 break;
4489 dstr = NEWSV(30, m-s);
4490 sv_setpvn(dstr, s, m-s);
8ec5e241 4491 if (make_mortal)
a0d0e21e 4492 sv_2mortal(dstr);
792b2c16 4493 if (do_utf8)
28cb3359 4494 (void)SvUTF8_on(dstr);
a0d0e21e 4495 XPUSHs(dstr);
93f04dac
JH		 4496 /* The rx->minlen is in characters but we want to step
4497 * s ahead by bytes. */
1aa99e6b
IH		 4498 if (do_utf8)
4499 s = (char*)utf8_hop((U8*)m, len);
4500 else
4501 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 4502 }
4503 }
4504 else {
4505#ifndef lint
4506 while (s < strend && --limit &&
f722798b
IZ		 4507 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4508 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
79072805 4509#endif
a0d0e21e
LW		 4510 {
4511 dstr = NEWSV(31, m-s);
4512 sv_setpvn(dstr, s, m-s);
8ec5e241 4513 if (make_mortal)
a0d0e21e 4514 sv_2mortal(dstr);
792b2c16 4515 if (do_utf8)
28cb3359 4516 (void)SvUTF8_on(dstr);
a0d0e21e 4517 XPUSHs(dstr);
93f04dac
JH		 4518 /* The rx->minlen is in characters but we want to step
4519 * s ahead by bytes. */
1aa99e6b
IH		 4520 if (do_utf8)
4521 s = (char*)utf8_hop((U8*)m, len);
4522 else
4523 s = m + len; /* Fake \n at the end */
a0d0e21e 4524 }
463ee0b2 4525 }
463ee0b2 4526 }
a0d0e21e 4527 else {
792b2c16 4528 maxiters += slen * rx->nparens;
f722798b 4529 while (s < strend && --limit
b13b2135 4530/* && (!rx->check_substr
f722798b
IZ		 4531 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4532 0, NULL))))
4533*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4534 1 /* minend */, sv, NULL, 0))
bbce6d69 4535 {
d9f97599 4536 TAINT_IF(RX_MATCH_TAINTED(rx));
cf93c79d 4537 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 4538 m = s;
4539 s = orig;
cf93c79d 4540 orig = rx->subbeg;
a0d0e21e
LW		 4541 s = orig + (m - s);
4542 strend = s + (strend - m);
4543 }
cf93c79d 4544 m = rx->startp[0] + orig;
a0d0e21e
LW		 4545 dstr = NEWSV(32, m-s);
4546 sv_setpvn(dstr, s, m-s);
8ec5e241 4547 if (make_mortal)
a0d0e21e 4548 sv_2mortal(dstr);
792b2c16 4549 if (do_utf8)
28cb3359 4550 (void)SvUTF8_on(dstr);
a0d0e21e 4551 XPUSHs(dstr);
d9f97599 4552 if (rx->nparens) {
eb160463 4553 for (i = 1; i <= (I32)rx->nparens; i++) {
cf93c79d
IZ		 4554 s = rx->startp[i] + orig;
4555 m = rx->endp[i] + orig;
6de67870
JP		 4556
4557 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4558 parens that didn't match -- they should be set to
4559 undef, not the empty string */
4560 if (m >= orig && s >= orig) {
748a9306
LW		 4561 dstr = NEWSV(33, m-s);
4562 sv_setpvn(dstr, s, m-s);
4563 }
4564 else
6de67870 4565 dstr = &PL_sv_undef; /* undef, not "" */
8ec5e241 4566 if (make_mortal)
a0d0e21e 4567 sv_2mortal(dstr);
792b2c16 4568 if (do_utf8)
28cb3359 4569 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4570 XPUSHs(dstr);
4571 }
4572 }
cf93c79d 4573 s = rx->endp[0] + orig;
a0d0e21e 4574 }
79072805 4575 }
8ec5e241 4576
c07a80fd 4577 LEAVE_SCOPE(oldsave);
3280af22 4578 iters = (SP - PL_stack_base) - base;
a0d0e21e 4579 if (iters > maxiters)
cea2e8a9 4580 DIE(aTHX_ "Split loop");
8ec5e241 4581
a0d0e21e
LW		 4582 /* keep field after final delim? */
4583 if (s < strend || (iters && origlimit)) {
93f04dac
JH		 4584 STRLEN l = strend - s;
4585 dstr = NEWSV(34, l);
4586 sv_setpvn(dstr, s, l);
8ec5e241 4587 if (make_mortal)
a0d0e21e 4588 sv_2mortal(dstr);
792b2c16 4589 if (do_utf8)
28cb3359 4590 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4591 XPUSHs(dstr);
4592 iters++;
79072805 4593 }
a0d0e21e 4594 else if (!origlimit) {
89900bd3
SR		 4595 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4596 if (TOPs && !make_mortal)
4597 sv_2mortal(TOPs);
4598 iters--;
4599 SP--;
4600 }
a0d0e21e 4601 }
8ec5e241 4602
a0d0e21e 4603 if (realarray) {
8ec5e241 4604 if (!mg) {
1c0b011c
NIS		 4605 SWITCHSTACK(ary, oldstack);
4606 if (SvSMAGICAL(ary)) {
4607 PUTBACK;
4608 mg_set((SV*)ary);
4609 SPAGAIN;
4610 }
4611 if (gimme == G_ARRAY) {
4612 EXTEND(SP, iters);
4613 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4614 SP += iters;
4615 RETURN;
4616 }
8ec5e241 4617 }
1c0b011c 4618 else {
fb73857a 4619 PUTBACK;
8ec5e241 4620 ENTER;
864dbfa3 4621 call_method("PUSH",G_SCALAR|G_DISCARD);
8ec5e241 4622 LEAVE;
fb73857a 4623 SPAGAIN;
8ec5e241
NIS		 4624 if (gimme == G_ARRAY) {
4625 /* EXTEND should not be needed - we just popped them */
4626 EXTEND(SP, iters);
4627 for (i=0; i < iters; i++) {
4628 SV **svp = av_fetch(ary, i, FALSE);
3280af22 4629 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 4630 }
1c0b011c
NIS		 4631 RETURN;
4632 }
a0d0e21e
LW		 4633 }
4634 }
4635 else {
4636 if (gimme == G_ARRAY)
4637 RETURN;
4638 }
4639 if (iters || !pm->op_pmreplroot) {
4640 GETTARGET;
4641 PUSHi(iters);
4642 RETURN;
4643 }
4644 RETPUSHUNDEF;
79072805 4645}
85e6fe83 4646
4d1ff10f 4647#ifdef USE_5005THREADS
77a005ab 4648void
864dbfa3 4649Perl_unlock_condpair(pTHX_ void *svv)
c0329465 4650{
14befaf4 4651 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
8ec5e241 4652
c0329465 4653 if (!mg)
cea2e8a9 4654 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
c0329465
MB		 4655 MUTEX_LOCK(MgMUTEXP(mg));
4656 if (MgOWNER(mg) != thr)
cea2e8a9 4657 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
c0329465
MB		 4658 MgOWNER(mg) = 0;
4659 COND_SIGNAL(MgOWNERCONDP(mg));
b900a521 4660 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
a674cc95 4661 PTR2UV(thr), PTR2UV(svv)));
c0329465
MB		 4662 MUTEX_UNLOCK(MgMUTEXP(mg));
4663}
4d1ff10f 4664#endif /* USE_5005THREADS */
c0329465
MB		 4665
4666PP(pp_lock)
4667{
39644a26 4668 dSP;
c0329465 4669 dTOPss;
e55aaa0e 4670 SV *retsv = sv;
68795e93 4671 SvLOCK(sv);
e55aaa0e
MB		 4672 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4673 || SvTYPE(retsv) == SVt_PVCV) {
4674 retsv = refto(retsv);
4675 }
4676 SETs(retsv);
c0329465
MB		 4677 RETURN;
4678}
a863c7d1 4679
2faa37cc 4680PP(pp_threadsv)
a863c7d1 4681{
4d1ff10f 4682#ifdef USE_5005THREADS
39644a26 4683 dSP;
924508f0 4684 EXTEND(SP, 1);
533c011a
NIS		 4685 if (PL_op->op_private & OPpLVAL_INTRO)
4686 PUSHs(*save_threadsv(PL_op->op_targ));
554b3eca 4687 else
533c011a 4688 PUSHs(THREADSV(PL_op->op_targ));
fdb47d66 4689 RETURN;
a863c7d1 4690#else
cea2e8a9 4691 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4d1ff10f 4692#endif /* USE_5005THREADS */
a863c7d1 4693}
Unnamed repository; edit this file 'description' to name the repository.