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