This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix for the fa_IR locale failure. The reason for the failure
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
bc89e66f 3 * Copyright (c) 1991-2001, 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
LW
17#include "perl.h"
18
36477c24 19/*
ef2d312d
TH
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
25 */
26#ifdef CXUX_BROKEN_CONSTANT_CONVERT
27static double UV_MAX_cxux = ((double)UV_MAX);
8ec5e241 28#endif
ef2d312d
TH
29
30/*
96e4d5b1
PP
31 * Offset for integer pack/unpack.
32 *
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
35 */
36
37/*
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
dc45a647
MB
42 * the preprocessor.) --???
43 */
44/*
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
96e4d5b1
PP
47 */
48#define SIZE16 2
49#define SIZE32 4
50
9851f69c
JH
51/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
52 --jhi Feb 1999 */
53
726ea183
JH
54#if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55# define PERL_NATINT_PACK
56#endif
57
0f9dfb06 58#if LONGSIZE > 4 && defined(_CRAY)
96e4d5b1
PP
59# if BYTEORDER == 0x12345678
60# define OFF16(p) (char*)(p)
61# define OFF32(p) (char*)(p)
62# else
63# if BYTEORDER == 0x87654321
64# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
66# else
67 }}}} bad cray byte order
68# endif
69# endif
70# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
ef54e1a4 72# define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
96e4d5b1
PP
73# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
75#else
76# define COPY16(s,p) Copy(s, p, SIZE16, char)
77# define COPY32(s,p) Copy(s, p, SIZE32, char)
ef54e1a4 78# define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
96e4d5b1
PP
79# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
81#endif
82
a0d0e21e 83/* variations on pp_null */
79072805 84
dfe9444c
AD
85/* XXX I can't imagine anyone who doesn't have this actually _needs_
86 it, since pid_t is an integral type.
87 --AD 2/20/1998
88*/
89#ifdef NEED_GETPID_PROTO
90extern Pid_t getpid (void);
8ac85365
NIS
91#endif
92
93a17b20
LW
93PP(pp_stub)
94{
4e35701f 95 djSP;
54310121 96 if (GIMME_V == G_SCALAR)
3280af22 97 XPUSHs(&PL_sv_undef);
93a17b20
LW
98 RETURN;
99}
100
79072805
LW
101PP(pp_scalar)
102{
103 return NORMAL;
104}
105
106/* Pushy stuff. */
107
93a17b20
LW
108PP(pp_padav)
109{
4e35701f 110 djSP; dTARGET;
533c011a
NIS
111 if (PL_op->op_private & OPpLVAL_INTRO)
112 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
85e6fe83 113 EXTEND(SP, 1);
533c011a 114 if (PL_op->op_flags & OPf_REF) {
85e6fe83 115 PUSHs(TARG);
93a17b20 116 RETURN;
78f9721b
SM
117 } else if (LVRET) {
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
120 PUSHs(TARG);
121 RETURN;
85e6fe83
LW
122 }
123 if (GIMME == G_ARRAY) {
124 I32 maxarg = AvFILL((AV*)TARG) + 1;
125 EXTEND(SP, maxarg);
93965878
NIS
126 if (SvMAGICAL(TARG)) {
127 U32 i;
128 for (i=0; i < maxarg; i++) {
129 SV **svp = av_fetch((AV*)TARG, i, FALSE);
3280af22 130 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878
NIS
131 }
132 }
133 else {
134 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
135 }
85e6fe83
LW
136 SP += maxarg;
137 }
138 else {
139 SV* sv = sv_newmortal();
140 I32 maxarg = AvFILL((AV*)TARG) + 1;
141 sv_setiv(sv, maxarg);
142 PUSHs(sv);
143 }
144 RETURN;
93a17b20
LW
145}
146
147PP(pp_padhv)
148{
4e35701f 149 djSP; dTARGET;
54310121
PP
150 I32 gimme;
151
93a17b20 152 XPUSHs(TARG);
533c011a
NIS
153 if (PL_op->op_private & OPpLVAL_INTRO)
154 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
155 if (PL_op->op_flags & OPf_REF)
93a17b20 156 RETURN;
78f9721b
SM
157 else if (LVRET) {
158 if (GIMME == G_SCALAR)
159 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
160 RETURN;
161 }
54310121
PP
162 gimme = GIMME_V;
163 if (gimme == G_ARRAY) {
cea2e8a9 164 RETURNOP(do_kv());
85e6fe83 165 }
54310121 166 else if (gimme == G_SCALAR) {
85e6fe83 167 SV* sv = sv_newmortal();
46fc3d4c 168 if (HvFILL((HV*)TARG))
cea2e8a9 169 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
46fc3d4c 170 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
85e6fe83
LW
171 else
172 sv_setiv(sv, 0);
173 SETs(sv);
85e6fe83 174 }
54310121 175 RETURN;
93a17b20
LW
176}
177
ed6116ce
LW
178PP(pp_padany)
179{
cea2e8a9 180 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
ed6116ce
LW
181}
182
79072805
LW
183/* Translations. */
184
185PP(pp_rv2gv)
186{
b13b2135 187 djSP; dTOPss;
8ec5e241 188
ed6116ce 189 if (SvROK(sv)) {
a0d0e21e 190 wasref:
f5284f61
IZ
191 tryAMAGICunDEREF(to_gv);
192
ed6116ce 193 sv = SvRV(sv);
b1dadf13
PP
194 if (SvTYPE(sv) == SVt_PVIO) {
195 GV *gv = (GV*) sv_newmortal();
196 gv_init(gv, 0, "", 0, 0);
197 GvIOp(gv) = (IO *)sv;
3e3baf6d 198 (void)SvREFCNT_inc(sv);
b1dadf13 199 sv = (SV*) gv;
ef54e1a4
JH
200 }
201 else if (SvTYPE(sv) != SVt_PVGV)
cea2e8a9 202 DIE(aTHX_ "Not a GLOB reference");
79072805
LW
203 }
204 else {
93a17b20 205 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 206 char *sym;
c9d5ac95 207 STRLEN len;
748a9306 208
a0d0e21e
LW
209 if (SvGMAGICAL(sv)) {
210 mg_get(sv);
211 if (SvROK(sv))
212 goto wasref;
213 }
afd1915d 214 if (!SvOK(sv) && sv != &PL_sv_undef) {
b13b2135 215 /* If this is a 'my' scalar and flag is set then vivify
853846ea 216 * NI-S 1999/05/07
b13b2135 217 */
1d8d4d2a 218 if (PL_op->op_private & OPpDEREF) {
2c8ac474
GS
219 char *name;
220 GV *gv;
221 if (cUNOP->op_targ) {
222 STRLEN len;
223 SV *namesv = PL_curpad[cUNOP->op_targ];
224 name = SvPV(namesv, len);
2d6d9f7a 225 gv = (GV*)NEWSV(0,0);
2c8ac474
GS
226 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
227 }
228 else {
229 name = CopSTASHPV(PL_curcop);
230 gv = newGVgen(name);
1d8d4d2a 231 }
b13b2135
NIS
232 if (SvTYPE(sv) < SVt_RV)
233 sv_upgrade(sv, SVt_RV);
2c8ac474 234 SvRV(sv) = (SV*)gv;
853846ea 235 SvROK_on(sv);
1d8d4d2a 236 SvSETMAGIC(sv);
853846ea 237 goto wasref;
2c8ac474 238 }
533c011a
NIS
239 if (PL_op->op_flags & OPf_REF ||
240 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 241 DIE(aTHX_ PL_no_usym, "a symbol");
599cee73 242 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 243 report_uninit();
a0d0e21e
LW
244 RETSETUNDEF;
245 }
c9d5ac95 246 sym = SvPV(sv,len);
35cd451c
GS
247 if ((PL_op->op_flags & OPf_SPECIAL) &&
248 !(PL_op->op_flags & OPf_MOD))
249 {
250 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
c9d5ac95
GS
251 if (!sv
252 && (!is_gv_magical(sym,len,0)
253 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
254 {
35cd451c 255 RETSETUNDEF;
c9d5ac95 256 }
35cd451c
GS
257 }
258 else {
259 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 260 DIE(aTHX_ PL_no_symref, sym, "a symbol");
35cd451c
GS
261 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
262 }
93a17b20 263 }
79072805 264 }
533c011a
NIS
265 if (PL_op->op_private & OPpLVAL_INTRO)
266 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
79072805
LW
267 SETs(sv);
268 RETURN;
269}
270
79072805
LW
271PP(pp_rv2sv)
272{
4e35701f 273 djSP; dTOPss;
79072805 274
ed6116ce 275 if (SvROK(sv)) {
a0d0e21e 276 wasref:
f5284f61
IZ
277 tryAMAGICunDEREF(to_sv);
278
ed6116ce 279 sv = SvRV(sv);
79072805
LW
280 switch (SvTYPE(sv)) {
281 case SVt_PVAV:
282 case SVt_PVHV:
283 case SVt_PVCV:
cea2e8a9 284 DIE(aTHX_ "Not a SCALAR reference");
79072805
LW
285 }
286 }
287 else {
f12c7020 288 GV *gv = (GV*)sv;
748a9306 289 char *sym;
c9d5ac95 290 STRLEN len;
748a9306 291
463ee0b2 292 if (SvTYPE(gv) != SVt_PVGV) {
a0d0e21e
LW
293 if (SvGMAGICAL(sv)) {
294 mg_get(sv);
295 if (SvROK(sv))
296 goto wasref;
297 }
298 if (!SvOK(sv)) {
533c011a
NIS
299 if (PL_op->op_flags & OPf_REF ||
300 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 301 DIE(aTHX_ PL_no_usym, "a SCALAR");
599cee73 302 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 303 report_uninit();
a0d0e21e
LW
304 RETSETUNDEF;
305 }
c9d5ac95 306 sym = SvPV(sv, len);
35cd451c
GS
307 if ((PL_op->op_flags & OPf_SPECIAL) &&
308 !(PL_op->op_flags & OPf_MOD))
309 {
310 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
c9d5ac95
GS
311 if (!gv
312 && (!is_gv_magical(sym,len,0)
313 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
314 {
35cd451c 315 RETSETUNDEF;
c9d5ac95 316 }
35cd451c
GS
317 }
318 else {
319 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 320 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
35cd451c
GS
321 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
322 }
463ee0b2
LW
323 }
324 sv = GvSV(gv);
a0d0e21e 325 }
533c011a
NIS
326 if (PL_op->op_flags & OPf_MOD) {
327 if (PL_op->op_private & OPpLVAL_INTRO)
a0d0e21e 328 sv = save_scalar((GV*)TOPs);
533c011a
NIS
329 else if (PL_op->op_private & OPpDEREF)
330 vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 331 }
a0d0e21e 332 SETs(sv);
79072805
LW
333 RETURN;
334}
335
336PP(pp_av2arylen)
337{
4e35701f 338 djSP;
79072805
LW
339 AV *av = (AV*)TOPs;
340 SV *sv = AvARYLEN(av);
341 if (!sv) {
342 AvARYLEN(av) = sv = NEWSV(0,0);
343 sv_upgrade(sv, SVt_IV);
344 sv_magic(sv, (SV*)av, '#', Nullch, 0);
345 }
346 SETs(sv);
347 RETURN;
348}
349
a0d0e21e
LW
350PP(pp_pos)
351{
4e35701f 352 djSP; dTARGET; dPOPss;
8ec5e241 353
78f9721b 354 if (PL_op->op_flags & OPf_MOD || LVRET) {
5f05dabc
PP
355 if (SvTYPE(TARG) < SVt_PVLV) {
356 sv_upgrade(TARG, SVt_PVLV);
357 sv_magic(TARG, Nullsv, '.', Nullch, 0);
358 }
359
360 LvTYPE(TARG) = '.';
6ff81951
GS
361 if (LvTARG(TARG) != sv) {
362 if (LvTARG(TARG))
363 SvREFCNT_dec(LvTARG(TARG));
364 LvTARG(TARG) = SvREFCNT_inc(sv);
365 }
a0d0e21e
LW
366 PUSHs(TARG); /* no SvSETMAGIC */
367 RETURN;
368 }
369 else {
8ec5e241 370 MAGIC* mg;
a0d0e21e
LW
371
372 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
373 mg = mg_find(sv, 'g');
565764a8 374 if (mg && mg->mg_len >= 0) {
a0ed51b3 375 I32 i = mg->mg_len;
7e2040f0 376 if (DO_UTF8(sv))
a0ed51b3
LW
377 sv_pos_b2u(sv, &i);
378 PUSHi(i + PL_curcop->cop_arybase);
a0d0e21e
LW
379 RETURN;
380 }
381 }
382 RETPUSHUNDEF;
383 }
384}
385
79072805
LW
386PP(pp_rv2cv)
387{
4e35701f 388 djSP;
79072805
LW
389 GV *gv;
390 HV *stash;
8990e307 391
4633a7c4
LW
392 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
393 /* (But not in defined().) */
533c011a 394 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
07055b4c
CS
395 if (cv) {
396 if (CvCLONE(cv))
397 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
d32f2495
SC
398 if ((PL_op->op_private & OPpLVAL_INTRO)) {
399 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
400 cv = GvCV(gv);
401 if (!CvLVALUE(cv))
402 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
403 }
07055b4c
CS
404 }
405 else
3280af22 406 cv = (CV*)&PL_sv_undef;
79072805
LW
407 SETs((SV*)cv);
408 RETURN;
409}
410
c07a80fd
PP
411PP(pp_prototype)
412{
4e35701f 413 djSP;
c07a80fd
PP
414 CV *cv;
415 HV *stash;
416 GV *gv;
417 SV *ret;
418
3280af22 419 ret = &PL_sv_undef;
b6c543e3
IZ
420 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
421 char *s = SvPVX(TOPs);
422 if (strnEQ(s, "CORE::", 6)) {
423 int code;
b13b2135 424
b6c543e3
IZ
425 code = keyword(s + 6, SvCUR(TOPs) - 6);
426 if (code < 0) { /* Overridable. */
427#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
428 int i = 0, n = 0, seen_question = 0;
429 I32 oa;
430 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
431
432 while (i < MAXO) { /* The slow way. */
22c35a8c
GS
433 if (strEQ(s + 6, PL_op_name[i])
434 || strEQ(s + 6, PL_op_desc[i]))
435 {
b6c543e3 436 goto found;
22c35a8c 437 }
b6c543e3
IZ
438 i++;
439 }
440 goto nonesuch; /* Should not happen... */
441 found:
22c35a8c 442 oa = PL_opargs[i] >> OASHIFT;
b6c543e3 443 while (oa) {
3012a639 444 if (oa & OA_OPTIONAL && !seen_question) {
b6c543e3
IZ
445 seen_question = 1;
446 str[n++] = ';';
ef54e1a4 447 }
b13b2135 448 else if (n && str[0] == ';' && seen_question)
b6c543e3 449 goto set; /* XXXX system, exec */
b13b2135 450 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
b6c543e3
IZ
451 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
452 str[n++] = '\\';
453 }
454 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
455 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
456 oa = oa >> 4;
457 }
458 str[n++] = '\0';
79cb57f6 459 ret = sv_2mortal(newSVpvn(str, n - 1));
ef54e1a4
JH
460 }
461 else if (code) /* Non-Overridable */
b6c543e3
IZ
462 goto set;
463 else { /* None such */
464 nonesuch:
d470f89e 465 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
b6c543e3
IZ
466 }
467 }
468 }
c07a80fd 469 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
5f05dabc 470 if (cv && SvPOK(cv))
79cb57f6 471 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
b6c543e3 472 set:
c07a80fd
PP
473 SETs(ret);
474 RETURN;
475}
476
a0d0e21e
LW
477PP(pp_anoncode)
478{
4e35701f 479 djSP;
533c011a 480 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
a5f75d66 481 if (CvCLONE(cv))
b355b4e0 482 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
5f05dabc 483 EXTEND(SP,1);
748a9306 484 PUSHs((SV*)cv);
a0d0e21e
LW
485 RETURN;
486}
487
488PP(pp_srefgen)
79072805 489{
4e35701f 490 djSP;
71be2cbc 491 *SP = refto(*SP);
79072805 492 RETURN;
8ec5e241 493}
a0d0e21e
LW
494
495PP(pp_refgen)
496{
4e35701f 497 djSP; dMARK;
a0d0e21e 498 if (GIMME != G_ARRAY) {
5f0b1d4e
GS
499 if (++MARK <= SP)
500 *MARK = *SP;
501 else
3280af22 502 *MARK = &PL_sv_undef;
5f0b1d4e
GS
503 *MARK = refto(*MARK);
504 SP = MARK;
505 RETURN;
a0d0e21e 506 }
bbce6d69 507 EXTEND_MORTAL(SP - MARK);
71be2cbc
PP
508 while (++MARK <= SP)
509 *MARK = refto(*MARK);
a0d0e21e 510 RETURN;
79072805
LW
511}
512
76e3520e 513STATIC SV*
cea2e8a9 514S_refto(pTHX_ SV *sv)
71be2cbc
PP
515{
516 SV* rv;
517
518 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
519 if (LvTARGLEN(sv))
68dc0745
PP
520 vivify_defelem(sv);
521 if (!(sv = LvTARG(sv)))
3280af22 522 sv = &PL_sv_undef;
0dd88869 523 else
a6c40364 524 (void)SvREFCNT_inc(sv);
71be2cbc 525 }
d8b46c1b
GS
526 else if (SvTYPE(sv) == SVt_PVAV) {
527 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
528 av_reify((AV*)sv);
529 SvTEMP_off(sv);
530 (void)SvREFCNT_inc(sv);
531 }
71be2cbc
PP
532 else if (SvPADTMP(sv))
533 sv = newSVsv(sv);
534 else {
535 SvTEMP_off(sv);
536 (void)SvREFCNT_inc(sv);
537 }
538 rv = sv_newmortal();
539 sv_upgrade(rv, SVt_RV);
540 SvRV(rv) = sv;
541 SvROK_on(rv);
542 return rv;
543}
544
79072805
LW
545PP(pp_ref)
546{
4e35701f 547 djSP; dTARGET;
463ee0b2 548 SV *sv;
79072805
LW
549 char *pv;
550
a0d0e21e 551 sv = POPs;
f12c7020
PP
552
553 if (sv && SvGMAGICAL(sv))
8ec5e241 554 mg_get(sv);
f12c7020 555
a0d0e21e 556 if (!sv || !SvROK(sv))
4633a7c4 557 RETPUSHNO;
79072805 558
ed6116ce 559 sv = SvRV(sv);
a0d0e21e 560 pv = sv_reftype(sv,TRUE);
463ee0b2 561 PUSHp(pv, strlen(pv));
79072805
LW
562 RETURN;
563}
564
565PP(pp_bless)
566{
4e35701f 567 djSP;
463ee0b2 568 HV *stash;
79072805 569
463ee0b2 570 if (MAXARG == 1)
11faa288 571 stash = CopSTASH(PL_curcop);
7b8d334a
GS
572 else {
573 SV *ssv = POPs;
574 STRLEN len;
81689caa
HS
575 char *ptr;
576
016a42f3 577 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
81689caa
HS
578 Perl_croak(aTHX_ "Attempt to bless into a reference");
579 ptr = SvPV(ssv,len);
e476b1b5 580 if (ckWARN(WARN_MISC) && len == 0)
b13b2135 581 Perl_warner(aTHX_ WARN_MISC,
599cee73 582 "Explicit blessing to '' (assuming package main)");
7b8d334a
GS
583 stash = gv_stashpvn(ptr, len, TRUE);
584 }
a0d0e21e 585
5d3fdfeb 586 (void)sv_bless(TOPs, stash);
79072805
LW
587 RETURN;
588}
589
fb73857a
PP
590PP(pp_gelem)
591{
592 GV *gv;
593 SV *sv;
76e3520e 594 SV *tmpRef;
fb73857a 595 char *elem;
4e35701f 596 djSP;
2d8e6c8d 597 STRLEN n_a;
b13b2135 598
fb73857a 599 sv = POPs;
2d8e6c8d 600 elem = SvPV(sv, n_a);
fb73857a 601 gv = (GV*)POPs;
76e3520e 602 tmpRef = Nullsv;
fb73857a
PP
603 sv = Nullsv;
604 switch (elem ? *elem : '\0')
605 {
606 case 'A':
607 if (strEQ(elem, "ARRAY"))
76e3520e 608 tmpRef = (SV*)GvAV(gv);
fb73857a
PP
609 break;
610 case 'C':
611 if (strEQ(elem, "CODE"))
76e3520e 612 tmpRef = (SV*)GvCVu(gv);
fb73857a
PP
613 break;
614 case 'F':
615 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
76e3520e 616 tmpRef = (SV*)GvIOp(gv);
f4d13ee9
JH
617 else
618 if (strEQ(elem, "FORMAT"))
619 tmpRef = (SV*)GvFORM(gv);
fb73857a
PP
620 break;
621 case 'G':
622 if (strEQ(elem, "GLOB"))
76e3520e 623 tmpRef = (SV*)gv;
fb73857a
PP
624 break;
625 case 'H':
626 if (strEQ(elem, "HASH"))
76e3520e 627 tmpRef = (SV*)GvHV(gv);
fb73857a
PP
628 break;
629 case 'I':
630 if (strEQ(elem, "IO"))
76e3520e 631 tmpRef = (SV*)GvIOp(gv);
fb73857a
PP
632 break;
633 case 'N':
634 if (strEQ(elem, "NAME"))
79cb57f6 635 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
fb73857a
PP
636 break;
637 case 'P':
638 if (strEQ(elem, "PACKAGE"))
639 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
640 break;
641 case 'S':
642 if (strEQ(elem, "SCALAR"))
76e3520e 643 tmpRef = GvSV(gv);
fb73857a
PP
644 break;
645 }
76e3520e
GS
646 if (tmpRef)
647 sv = newRV(tmpRef);
fb73857a
PP
648 if (sv)
649 sv_2mortal(sv);
650 else
3280af22 651 sv = &PL_sv_undef;
fb73857a
PP
652 XPUSHs(sv);
653 RETURN;
654}
655
a0d0e21e 656/* Pattern matching */
79072805 657
a0d0e21e 658PP(pp_study)
79072805 659{
4e35701f 660 djSP; dPOPss;
a0d0e21e
LW
661 register unsigned char *s;
662 register I32 pos;
663 register I32 ch;
664 register I32 *sfirst;
665 register I32 *snext;
a0d0e21e
LW
666 STRLEN len;
667
3280af22 668 if (sv == PL_lastscream) {
1e422769
PP
669 if (SvSCREAM(sv))
670 RETPUSHYES;
671 }
c07a80fd 672 else {
3280af22
NIS
673 if (PL_lastscream) {
674 SvSCREAM_off(PL_lastscream);
675 SvREFCNT_dec(PL_lastscream);
c07a80fd 676 }
3280af22 677 PL_lastscream = SvREFCNT_inc(sv);
c07a80fd 678 }
1e422769
PP
679
680 s = (unsigned char*)(SvPV(sv, len));
681 pos = len;
682 if (pos <= 0)
683 RETPUSHNO;
3280af22
NIS
684 if (pos > PL_maxscream) {
685 if (PL_maxscream < 0) {
686 PL_maxscream = pos + 80;
687 New(301, PL_screamfirst, 256, I32);
688 New(302, PL_screamnext, PL_maxscream, I32);
79072805
LW
689 }
690 else {
3280af22
NIS
691 PL_maxscream = pos + pos / 4;
692 Renew(PL_screamnext, PL_maxscream, I32);
79072805 693 }
79072805 694 }
a0d0e21e 695
3280af22
NIS
696 sfirst = PL_screamfirst;
697 snext = PL_screamnext;
a0d0e21e
LW
698
699 if (!sfirst || !snext)
cea2e8a9 700 DIE(aTHX_ "do_study: out of memory");
a0d0e21e
LW
701
702 for (ch = 256; ch; --ch)
703 *sfirst++ = -1;
704 sfirst -= 256;
705
706 while (--pos >= 0) {
707 ch = s[pos];
708 if (sfirst[ch] >= 0)
709 snext[pos] = sfirst[ch] - pos;
710 else
711 snext[pos] = -pos;
712 sfirst[ch] = pos;
79072805
LW
713 }
714
c07a80fd 715 SvSCREAM_on(sv);
464e2e8a 716 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
1e422769 717 RETPUSHYES;
79072805
LW
718}
719
a0d0e21e 720PP(pp_trans)
79072805 721{
4e35701f 722 djSP; dTARG;
a0d0e21e
LW
723 SV *sv;
724
533c011a 725 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 726 sv = POPs;
79072805 727 else {
54b9620d 728 sv = DEFSV;
a0d0e21e 729 EXTEND(SP,1);
79072805 730 }
adbc6bb1 731 TARG = sv_newmortal();
4757a243 732 PUSHi(do_trans(sv));
a0d0e21e 733 RETURN;
79072805
LW
734}
735
a0d0e21e 736/* Lvalue operators. */
79072805 737
a0d0e21e
LW
738PP(pp_schop)
739{
4e35701f 740 djSP; dTARGET;
a0d0e21e
LW
741 do_chop(TARG, TOPs);
742 SETTARG;
743 RETURN;
79072805
LW
744}
745
a0d0e21e 746PP(pp_chop)
79072805 747{
4e35701f 748 djSP; dMARK; dTARGET;
a0d0e21e
LW
749 while (SP > MARK)
750 do_chop(TARG, POPs);
751 PUSHTARG;
752 RETURN;
79072805
LW
753}
754
a0d0e21e 755PP(pp_schomp)
79072805 756{
4e35701f 757 djSP; dTARGET;
a0d0e21e
LW
758 SETi(do_chomp(TOPs));
759 RETURN;
79072805
LW
760}
761
a0d0e21e 762PP(pp_chomp)
79072805 763{
4e35701f 764 djSP; dMARK; dTARGET;
a0d0e21e 765 register I32 count = 0;
8ec5e241 766
a0d0e21e
LW
767 while (SP > MARK)
768 count += do_chomp(POPs);
769 PUSHi(count);
770 RETURN;
79072805
LW
771}
772
a0d0e21e 773PP(pp_defined)
463ee0b2 774{
4e35701f 775 djSP;
a0d0e21e
LW
776 register SV* sv;
777
778 sv = POPs;
779 if (!sv || !SvANY(sv))
780 RETPUSHNO;
781 switch (SvTYPE(sv)) {
782 case SVt_PVAV:
6051dbdb 783 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
a0d0e21e
LW
784 RETPUSHYES;
785 break;
786 case SVt_PVHV:
6051dbdb 787 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
a0d0e21e
LW
788 RETPUSHYES;
789 break;
790 case SVt_PVCV:
791 if (CvROOT(sv) || CvXSUB(sv))
792 RETPUSHYES;
793 break;
794 default:
795 if (SvGMAGICAL(sv))
796 mg_get(sv);
797 if (SvOK(sv))
798 RETPUSHYES;
799 }
800 RETPUSHNO;
463ee0b2
LW
801}
802
a0d0e21e
LW
803PP(pp_undef)
804{
4e35701f 805 djSP;
a0d0e21e
LW
806 SV *sv;
807
533c011a 808 if (!PL_op->op_private) {
774d564b 809 EXTEND(SP, 1);
a0d0e21e 810 RETPUSHUNDEF;
774d564b 811 }
79072805 812
a0d0e21e
LW
813 sv = POPs;
814 if (!sv)
815 RETPUSHUNDEF;
85e6fe83 816
6fc92669
GS
817 if (SvTHINKFIRST(sv))
818 sv_force_normal(sv);
85e6fe83 819
a0d0e21e
LW
820 switch (SvTYPE(sv)) {
821 case SVt_NULL:
822 break;
823 case SVt_PVAV:
824 av_undef((AV*)sv);
825 break;
826 case SVt_PVHV:
827 hv_undef((HV*)sv);
828 break;
829 case SVt_PVCV:
e476b1b5
GS
830 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
831 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
54310121 832 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
9607fc9c
PP
833 /* FALL THROUGH */
834 case SVt_PVFM:
6fc92669
GS
835 {
836 /* let user-undef'd sub keep its identity */
837 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
838 cv_undef((CV*)sv);
839 CvGV((CV*)sv) = gv;
840 }
a0d0e21e 841 break;
8e07c86e 842 case SVt_PVGV:
44a8e56a 843 if (SvFAKE(sv))
3280af22 844 SvSetMagicSV(sv, &PL_sv_undef);
20408e3c
GS
845 else {
846 GP *gp;
847 gp_free((GV*)sv);
848 Newz(602, gp, 1, GP);
849 GvGP(sv) = gp_ref(gp);
850 GvSV(sv) = NEWSV(72,0);
57843af0 851 GvLINE(sv) = CopLINE(PL_curcop);
20408e3c
GS
852 GvEGV(sv) = (GV*)sv;
853 GvMULTI_on(sv);
854 }
44a8e56a 855 break;
a0d0e21e 856 default:
1e422769 857 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
4633a7c4
LW
858 (void)SvOOK_off(sv);
859 Safefree(SvPVX(sv));
860 SvPV_set(sv, Nullch);
861 SvLEN_set(sv, 0);
a0d0e21e 862 }
4633a7c4
LW
863 (void)SvOK_off(sv);
864 SvSETMAGIC(sv);
79072805 865 }
a0d0e21e
LW
866
867 RETPUSHUNDEF;
79072805
LW
868}
869
a0d0e21e 870PP(pp_predec)
79072805 871{
4e35701f 872 djSP;
68dc0745 873 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 874 DIE(aTHX_ PL_no_modify);
25da4f38 875 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff
PP
876 SvIVX(TOPs) != IV_MIN)
877 {
748a9306 878 --SvIVX(TOPs);
55497cff 879 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
880 }
881 else
882 sv_dec(TOPs);
a0d0e21e
LW
883 SvSETMAGIC(TOPs);
884 return NORMAL;
885}
79072805 886
a0d0e21e
LW
887PP(pp_postinc)
888{
4e35701f 889 djSP; dTARGET;
68dc0745 890 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 891 DIE(aTHX_ PL_no_modify);
a0d0e21e 892 sv_setsv(TARG, TOPs);
25da4f38 893 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff
PP
894 SvIVX(TOPs) != IV_MAX)
895 {
748a9306 896 ++SvIVX(TOPs);
55497cff 897 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
898 }
899 else
900 sv_inc(TOPs);
a0d0e21e
LW
901 SvSETMAGIC(TOPs);
902 if (!SvOK(TARG))
903 sv_setiv(TARG, 0);
904 SETs(TARG);
905 return NORMAL;
906}
79072805 907
a0d0e21e
LW
908PP(pp_postdec)
909{
4e35701f 910 djSP; dTARGET;
43192e07 911 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 912 DIE(aTHX_ PL_no_modify);
a0d0e21e 913 sv_setsv(TARG, TOPs);
25da4f38 914 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff
PP
915 SvIVX(TOPs) != IV_MIN)
916 {
748a9306 917 --SvIVX(TOPs);
55497cff 918 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
919 }
920 else
921 sv_dec(TOPs);
a0d0e21e
LW
922 SvSETMAGIC(TOPs);
923 SETs(TARG);
924 return NORMAL;
925}
79072805 926
a0d0e21e
LW
927/* Ordinary operators. */
928
929PP(pp_pow)
930{
8ec5e241 931 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
a0d0e21e
LW
932 {
933 dPOPTOPnnrl;
73b309ea 934 SETn( Perl_pow( left, right) );
a0d0e21e 935 RETURN;
93a17b20 936 }
a0d0e21e
LW
937}
938
939PP(pp_multiply)
940{
8ec5e241 941 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
28e5dec8
JH
942#ifdef PERL_PRESERVE_IVUV
943 SvIV_please(TOPs);
944 if (SvIOK(TOPs)) {
945 /* Unless the left argument is integer in range we are going to have to
946 use NV maths. Hence only attempt to coerce the right argument if
947 we know the left is integer. */
948 /* Left operand is defined, so is it IV? */
949 SvIV_please(TOPm1s);
950 if (SvIOK(TOPm1s)) {
951 bool auvok = SvUOK(TOPm1s);
952 bool buvok = SvUOK(TOPs);
953 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
954 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
955 UV alow;
956 UV ahigh;
957 UV blow;
958 UV bhigh;
959
960 if (auvok) {
961 alow = SvUVX(TOPm1s);
962 } else {
963 IV aiv = SvIVX(TOPm1s);
964 if (aiv >= 0) {
965 alow = aiv;
966 auvok = TRUE; /* effectively it's a UV now */
967 } else {
968 alow = -aiv; /* abs, auvok == false records sign */
969 }
970 }
971 if (buvok) {
972 blow = SvUVX(TOPs);
973 } else {
974 IV biv = SvIVX(TOPs);
975 if (biv >= 0) {
976 blow = biv;
977 buvok = TRUE; /* effectively it's a UV now */
978 } else {
979 blow = -biv; /* abs, buvok == false records sign */
980 }
981 }
982
983 /* If this does sign extension on unsigned it's time for plan B */
984 ahigh = alow >> (4 * sizeof (UV));
985 alow &= botmask;
986 bhigh = blow >> (4 * sizeof (UV));
987 blow &= botmask;
988 if (ahigh && bhigh) {
989 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
990 which is overflow. Drop to NVs below. */
991 } else if (!ahigh && !bhigh) {
992 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
993 so the unsigned multiply cannot overflow. */
994 UV product = alow * blow;
995 if (auvok == buvok) {
996 /* -ve * -ve or +ve * +ve gives a +ve result. */
997 SP--;
998 SETu( product );
999 RETURN;
1000 } else if (product <= (UV)IV_MIN) {
1001 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1002 /* -ve result, which could overflow an IV */
1003 SP--;
1004 SETi( -product );
1005 RETURN;
1006 } /* else drop to NVs below. */
1007 } else {
1008 /* One operand is large, 1 small */
1009 UV product_middle;
1010 if (bhigh) {
1011 /* swap the operands */
1012 ahigh = bhigh;
1013 bhigh = blow; /* bhigh now the temp var for the swap */
1014 blow = alow;
1015 alow = bhigh;
1016 }
1017 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1018 multiplies can't overflow. shift can, add can, -ve can. */
1019 product_middle = ahigh * blow;
1020 if (!(product_middle & topmask)) {
1021 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1022 UV product_low;
1023 product_middle <<= (4 * sizeof (UV));
1024 product_low = alow * blow;
1025
1026 /* as for pp_add, UV + something mustn't get smaller.
1027 IIRC ANSI mandates this wrapping *behaviour* for
1028 unsigned whatever the actual representation*/
1029 product_low += product_middle;
1030 if (product_low >= product_middle) {
1031 /* didn't overflow */
1032 if (auvok == buvok) {
1033 /* -ve * -ve or +ve * +ve gives a +ve result. */
1034 SP--;
1035 SETu( product_low );
1036 RETURN;
1037 } else if (product_low <= (UV)IV_MIN) {
1038 /* 2s complement assumption again */
1039 /* -ve result, which could overflow an IV */
1040 SP--;
1041 SETi( -product_low );
1042 RETURN;
1043 } /* else drop to NVs below. */
1044 }
1045 } /* product_middle too large */
1046 } /* ahigh && bhigh */
1047 } /* SvIOK(TOPm1s) */
1048 } /* SvIOK(TOPs) */
1049#endif
a0d0e21e
LW
1050 {
1051 dPOPTOPnnrl;
1052 SETn( left * right );
1053 RETURN;
79072805 1054 }
a0d0e21e
LW
1055}
1056
1057PP(pp_divide)
1058{
8ec5e241 1059 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e 1060 {
77676ba1 1061 dPOPPOPnnrl;
65202027 1062 NV value;
7a4c00b4 1063 if (right == 0.0)
cea2e8a9 1064 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW
1065#ifdef SLOPPYDIVIDE
1066 /* insure that 20./5. == 4. */
1067 {
7a4c00b4 1068 IV k;
65202027
DS
1069 if ((NV)I_V(left) == left &&
1070 (NV)I_V(right) == right &&
7a4c00b4 1071 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
a0d0e21e 1072 value = k;
ef54e1a4
JH
1073 }
1074 else {
7a4c00b4 1075 value = left / right;
79072805 1076 }
a0d0e21e
LW
1077 }
1078#else
7a4c00b4 1079 value = left / right;
a0d0e21e
LW
1080#endif
1081 PUSHn( value );
1082 RETURN;
79072805 1083 }
a0d0e21e
LW
1084}
1085
1086PP(pp_modulo)
1087{
76e3520e 1088 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
a0d0e21e 1089 {
787eafbd
IZ
1090 UV left;
1091 UV right;
1092 bool left_neg;
1093 bool right_neg;
1094 bool use_double = 0;
65202027
DS
1095 NV dright;
1096 NV dleft;
787eafbd 1097
d658dc55 1098 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
787eafbd
IZ
1099 IV i = SvIVX(POPs);
1100 right = (right_neg = (i < 0)) ? -i : i;
1101 }
1102 else {
1103 dright = POPn;
1104 use_double = 1;
1105 right_neg = dright < 0;
1106 if (right_neg)
1107 dright = -dright;
1108 }
a0d0e21e 1109
d658dc55 1110 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
787eafbd
IZ
1111 IV i = SvIVX(POPs);
1112 left = (left_neg = (i < 0)) ? -i : i;
1113 }
1114 else {
1115 dleft = POPn;
1116 if (!use_double) {
a1bd196e
GS
1117 use_double = 1;
1118 dright = right;
787eafbd
IZ
1119 }
1120 left_neg = dleft < 0;
1121 if (left_neg)
1122 dleft = -dleft;
1123 }
68dc0745 1124
787eafbd 1125 if (use_double) {
65202027 1126 NV dans;
787eafbd
IZ
1127
1128#if 1
787eafbd
IZ
1129/* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1130# if CASTFLAGS & 2
1131# define CAST_D2UV(d) U_V(d)
1132# else
1133# define CAST_D2UV(d) ((UV)(d))
1134# endif
a1bd196e
GS
1135 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1136 * or, in other words, precision of UV more than of NV.
1137 * But in fact the approach below turned out to be an
1138 * optimization - floor() may be slow */
787eafbd
IZ
1139 if (dright <= UV_MAX && dleft <= UV_MAX) {
1140 right = CAST_D2UV(dright);
1141 left = CAST_D2UV(dleft);
1142 goto do_uv;
1143 }
1144#endif
1145
1146 /* Backward-compatibility clause: */
73b309ea
JH
1147 dright = Perl_floor(dright + 0.5);
1148 dleft = Perl_floor(dleft + 0.5);
787eafbd
IZ
1149
1150 if (!dright)
cea2e8a9 1151 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1152
65202027 1153 dans = Perl_fmod(dleft, dright);
787eafbd
IZ
1154 if ((left_neg != right_neg) && dans)
1155 dans = dright - dans;
1156 if (right_neg)
1157 dans = -dans;
1158 sv_setnv(TARG, dans);
1159 }
1160 else {
1161 UV ans;
1162
1163 do_uv:
1164 if (!right)
cea2e8a9 1165 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ
1166
1167 ans = left % right;
1168 if ((left_neg != right_neg) && ans)
1169 ans = right - ans;
1170 if (right_neg) {
1171 /* XXX may warn: unary minus operator applied to unsigned type */
1172 /* could change -foo to be (~foo)+1 instead */
1173 if (ans <= ~((UV)IV_MAX)+1)
1174 sv_setiv(TARG, ~ans+1);
1175 else
65202027 1176 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ
1177 }
1178 else
1179 sv_setuv(TARG, ans);
1180 }
1181 PUSHTARG;
1182 RETURN;
79072805 1183 }
a0d0e21e 1184}
79072805 1185
a0d0e21e
LW
1186PP(pp_repeat)
1187{
4e35701f 1188 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
748a9306 1189 {
467f0320 1190 register IV count = POPi;
533c011a 1191 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e
LW
1192 dMARK;
1193 I32 items = SP - MARK;
1194 I32 max;
79072805 1195
a0d0e21e
LW
1196 max = items * count;
1197 MEXTEND(MARK, max);
1198 if (count > 1) {
1199 while (SP > MARK) {
1200 if (*SP)
1201 SvTEMP_off((*SP));
1202 SP--;
79072805 1203 }
a0d0e21e
LW
1204 MARK++;
1205 repeatcpy((char*)(MARK + items), (char*)MARK,
1206 items * sizeof(SV*), count - 1);
1207 SP += max;
79072805 1208 }
a0d0e21e
LW
1209 else if (count <= 0)
1210 SP -= items;
79072805 1211 }
a0d0e21e 1212 else { /* Note: mark already snarfed by pp_list */
dfcb284a 1213 SV *tmpstr = POPs;
a0d0e21e 1214 STRLEN len;
9b877dbb 1215 bool isutf;
a0d0e21e 1216
a0d0e21e
LW
1217 SvSetSV(TARG, tmpstr);
1218 SvPV_force(TARG, len);
9b877dbb 1219 isutf = DO_UTF8(TARG);
8ebc5c01
PP
1220 if (count != 1) {
1221 if (count < 1)
1222 SvCUR_set(TARG, 0);
1223 else {
1224 SvGROW(TARG, (count * len) + 1);
a0d0e21e 1225 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
8ebc5c01 1226 SvCUR(TARG) *= count;
7a4c00b4 1227 }
a0d0e21e 1228 *SvEND(TARG) = '\0';
a0d0e21e 1229 }
dfcb284a
GS
1230 if (isutf)
1231 (void)SvPOK_only_UTF8(TARG);
1232 else
1233 (void)SvPOK_only(TARG);
a0d0e21e 1234 PUSHTARG;
79072805 1235 }
a0d0e21e 1236 RETURN;
748a9306 1237 }
a0d0e21e 1238}
79072805 1239
a0d0e21e
LW
1240PP(pp_subtract)
1241{
28e5dec8
JH
1242 djSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1243 useleft = USE_LEFT(TOPm1s);
1244#ifdef PERL_PRESERVE_IVUV
1245 /* We must see if we can perform the addition with integers if possible,
1246 as the integer code detects overflow while the NV code doesn't.
1247 If either argument hasn't had a numeric conversion yet attempt to get
1248 the IV. It's important to do this now, rather than just assuming that
1249 it's not IOK as a PV of "9223372036854775806" may not take well to NV
1250 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
1251 integer in case the second argument is IV=9223372036854775806
1252 We can (now) rely on sv_2iv to do the right thing, only setting the
1253 public IOK flag if the value in the NV (or PV) slot is truly integer.
1254
1255 A side effect is that this also aggressively prefers integer maths over
1256 fp maths for integer values. */
1257 SvIV_please(TOPs);
1258 if (SvIOK(TOPs)) {
1259 /* Unless the left argument is integer in range we are going to have to
1260 use NV maths. Hence only attempt to coerce the right argument if
1261 we know the left is integer. */
1262 if (!useleft) {
1263 /* left operand is undef, treat as zero. + 0 is identity. */
1264 if (SvUOK(TOPs)) {
1265 dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
1266 if (value <= (UV)IV_MIN) {
1267 /* 2s complement assumption. */
1268 SETi(-(IV)value);
1269 RETURN;
1270 } /* else drop through into NVs below */
1271 } else {
1272 dPOPiv;
1273 SETu((UV)-value);
1274 RETURN;
1275 }
1276 } else {
1277 /* Left operand is defined, so is it IV? */
1278 SvIV_please(TOPm1s);
1279 if (SvIOK(TOPm1s)) {
1280 bool auvok = SvUOK(TOPm1s);
1281 bool buvok = SvUOK(TOPs);
a227d84d 1282
28e5dec8
JH
1283 if (!auvok && !buvok) { /* ## IV - IV ## */
1284 IV aiv = SvIVX(TOPm1s);
1285 IV biv = SvIVX(TOPs);
1286 IV result = aiv - biv;
1287
1288 if (biv >= 0 ? (result < aiv) : (result >= aiv)) {
1289 SP--;
1290 SETi( result );
1291 RETURN;
1292 }
1293 /* +ve - +ve can't overflow. (worst case 0 - IV_MAX) */
1294 /* -ve - -ve can't overflow. (worst case -1 - IV_MIN) */
1295 /* -ve - +ve can only overflow too negative. */
1296 /* leaving +ve - -ve, which will go UV */
1297 if (aiv >= 0 && biv < 0) { /* assert don't need biv <0 */
1298 /* 2s complement assumption for IV_MIN */
1299 UV result = (UV)aiv + (UV)-biv;
1300 /* UV + UV must get bigger. +ve IV + +ve IV +1 can't
1301 overflow UV (2s complement assumption */
1302 assert (result >= (UV) aiv);
1303 SP--;
1304 SETu( result );
1305 RETURN;
1306 }
1307 /* Overflow, drop through to NVs */
1308 } else if (auvok && buvok) { /* ## UV - UV ## */
1309 UV auv = SvUVX(TOPm1s);
1310 UV buv = SvUVX(TOPs);
1311 IV result;
a227d84d 1312
28e5dec8
JH
1313 if (auv >= buv) {
1314 SP--;
1315 SETu( auv - buv );
1316 RETURN;
1317 }
1318 /* Blatant 2s complement assumption. */
1319 result = (IV)(auv - buv);
1320 if (result < 0) {
1321 SP--;
1322 SETi( result );
1323 RETURN;
1324 }
1325 /* Overflow on IV - IV, drop through to NVs */
1326 } else if (auvok) { /* ## Mixed UV - IV ## */
1327 UV auv = SvUVX(TOPm1s);
1328 IV biv = SvIVX(TOPs);
1329
1330 if (biv < 0) {
1331 /* 2s complement assumptions for IV_MIN */
1332 UV result = auv + ((UV)-biv);
1333 /* UV + UV can only get bigger... */
1334 if (result >= auv) {
1335 SP--;
1336 SETu( result );
1337 RETURN;
1338 }
1339 /* and if it gets too big for UV then it's NV time. */
1340 } else if (auv > (UV)IV_MAX) {
1341 /* I think I'm making an implicit 2s complement
1342 assumption that IV_MIN == -IV_MAX - 1 */
1343 /* biv is >= 0 */
1344 UV result = auv - (UV)biv;
1345 assert (result <= auv);
1346 SP--;
1347 SETu( result );
1348 RETURN;
1349 } else {
1350 /* biv is >= 0 */
1351 IV result = (IV)auv - biv;
1352 assert (result <= (IV)auv);
1353 SP--;
1354 SETi( result );
1355 RETURN;
1356 }
1357 } else { /* ## Mixed IV - UV ## */
1358 IV aiv = SvIVX(TOPm1s);
1359 UV buv = SvUVX(TOPs);
1360 IV result = aiv - (IV)buv; /* 2s complement assumption. */
1361
1362 /* result must not get larger. */
1363 if (result <= aiv) {
1364 SP--;
1365 SETi( result );
1366 RETURN;
1367 } /* end of IV-IV / UV-UV / UV-IV / IV-UV */
1368 }
1369 }
1370 }
1371 }
1372#endif
a0d0e21e 1373 {
28e5dec8
JH
1374 dPOPnv;
1375 if (!useleft) {
1376 /* left operand is undef, treat as zero - value */
1377 SETn(-value);
1378 RETURN;
1379 }
1380 SETn( TOPn - value );
1381 RETURN;
79072805 1382 }
a0d0e21e 1383}
79072805 1384
a0d0e21e
LW
1385PP(pp_left_shift)
1386{
8ec5e241 1387 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
a0d0e21e 1388 {
972b05a9 1389 IV shift = POPi;
d0ba1bd2 1390 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
1391 IV i = TOPi;
1392 SETi(i << shift);
d0ba1bd2
JH
1393 }
1394 else {
972b05a9
JH
1395 UV u = TOPu;
1396 SETu(u << shift);
d0ba1bd2 1397 }
55497cff 1398 RETURN;
79072805 1399 }
a0d0e21e 1400}
79072805 1401
a0d0e21e
LW
1402PP(pp_right_shift)
1403{
8ec5e241 1404 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
a0d0e21e 1405 {
972b05a9 1406 IV shift = POPi;
d0ba1bd2 1407 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
1408 IV i = TOPi;
1409 SETi(i >> shift);
d0ba1bd2
JH
1410 }
1411 else {
972b05a9
JH
1412 UV u = TOPu;
1413 SETu(u >> shift);
d0ba1bd2 1414 }
a0d0e21e 1415 RETURN;
93a17b20 1416 }
79072805
LW
1417}
1418
a0d0e21e 1419PP(pp_lt)
79072805 1420{
8ec5e241 1421 djSP; tryAMAGICbinSET(lt,0);
28e5dec8
JH
1422#ifdef PERL_PRESERVE_IVUV
1423 SvIV_please(TOPs);
1424 if (SvIOK(TOPs)) {
1425 SvIV_please(TOPm1s);
1426 if (SvIOK(TOPm1s)) {
1427 bool auvok = SvUOK(TOPm1s);
1428 bool buvok = SvUOK(TOPs);
a227d84d 1429
28e5dec8
JH
1430 if (!auvok && !buvok) { /* ## IV < IV ## */
1431 IV aiv = SvIVX(TOPm1s);
1432 IV biv = SvIVX(TOPs);
1433
1434 SP--;
1435 SETs(boolSV(aiv < biv));
1436 RETURN;
1437 }
1438 if (auvok && buvok) { /* ## UV < UV ## */
1439 UV auv = SvUVX(TOPm1s);
1440 UV buv = SvUVX(TOPs);
1441
1442 SP--;
1443 SETs(boolSV(auv < buv));
1444 RETURN;
1445 }
1446 if (auvok) { /* ## UV < IV ## */
1447 UV auv;
1448 IV biv;
1449
1450 biv = SvIVX(TOPs);
1451 SP--;
1452 if (biv < 0) {
1453 /* As (a) is a UV, it's >=0, so it cannot be < */
1454 SETs(&PL_sv_no);
1455 RETURN;
1456 }
1457 auv = SvUVX(TOPs);
1458 if (auv >= (UV) IV_MAX) {
1459 /* As (b) is an IV, it cannot be > IV_MAX */
1460 SETs(&PL_sv_no);
1461 RETURN;
1462 }
1463 SETs(boolSV(auv < (UV)biv));
1464 RETURN;
1465 }
1466 { /* ## IV < UV ## */
1467 IV aiv;
1468 UV buv;
1469
1470 aiv = SvIVX(TOPm1s);
1471 if (aiv < 0) {
1472 /* As (b) is a UV, it's >=0, so it must be < */
1473 SP--;
1474 SETs(&PL_sv_yes);
1475 RETURN;
1476 }
1477 buv = SvUVX(TOPs);
1478 SP--;
1479 if (buv > (UV) IV_MAX) {
1480 /* As (a) is an IV, it cannot be > IV_MAX */
1481 SETs(&PL_sv_yes);
1482 RETURN;
1483 }
1484 SETs(boolSV((UV)aiv < buv));
1485 RETURN;
1486 }
1487 }
1488 }
1489#endif
a0d0e21e
LW
1490 {
1491 dPOPnv;
54310121 1492 SETs(boolSV(TOPn < value));
a0d0e21e 1493 RETURN;
79072805 1494 }
a0d0e21e 1495}
79072805 1496
a0d0e21e
LW
1497PP(pp_gt)
1498{
8ec5e241 1499 djSP; tryAMAGICbinSET(gt,0);
28e5dec8
JH
1500#ifdef PERL_PRESERVE_IVUV
1501 SvIV_please(TOPs);
1502 if (SvIOK(TOPs)) {
1503 SvIV_please(TOPm1s);
1504 if (SvIOK(TOPm1s)) {
1505 bool auvok = SvUOK(TOPm1s);
1506 bool buvok = SvUOK(TOPs);
a227d84d 1507
28e5dec8
JH
1508 if (!auvok && !buvok) { /* ## IV > IV ## */
1509 IV aiv = SvIVX(TOPm1s);
1510 IV biv = SvIVX(TOPs);
1511
1512 SP--;
1513 SETs(boolSV(aiv > biv));
1514 RETURN;
1515 }
1516 if (auvok && buvok) { /* ## UV > UV ## */
1517 UV auv = SvUVX(TOPm1s);
1518 UV buv = SvUVX(TOPs);
1519
1520 SP--;
1521 SETs(boolSV(auv > buv));
1522 RETURN;
1523 }
1524 if (auvok) { /* ## UV > IV ## */
1525 UV auv;
1526 IV biv;
1527
1528 biv = SvIVX(TOPs);
1529 SP--;
1530 if (biv < 0) {
1531 /* As (a) is a UV, it's >=0, so it must be > */
1532 SETs(&PL_sv_yes);
1533 RETURN;
1534 }
1535 auv = SvUVX(TOPs);
1536 if (auv > (UV) IV_MAX) {
1537 /* As (b) is an IV, it cannot be > IV_MAX */
1538 SETs(&PL_sv_yes);
1539 RETURN;
1540 }
1541 SETs(boolSV(auv > (UV)biv));
1542 RETURN;
1543 }
1544 { /* ## IV > UV ## */
1545 IV aiv;
1546 UV buv;
1547
1548 aiv = SvIVX(TOPm1s);
1549 if (aiv < 0) {
1550 /* As (b) is a UV, it's >=0, so it cannot be > */
1551 SP--;
1552 SETs(&PL_sv_no);
1553 RETURN;
1554 }
1555 buv = SvUVX(TOPs);
1556 SP--;
1557 if (buv >= (UV) IV_MAX) {
1558 /* As (a) is an IV, it cannot be > IV_MAX */
1559 SETs(&PL_sv_no);
1560 RETURN;
1561 }
1562 SETs(boolSV((UV)aiv > buv));
1563 RETURN;
1564 }
1565 }
1566 }
1567#endif
a0d0e21e
LW
1568 {
1569 dPOPnv;
54310121 1570 SETs(boolSV(TOPn > value));
a0d0e21e 1571 RETURN;
79072805 1572 }
a0d0e21e
LW
1573}
1574
1575PP(pp_le)
1576{
8ec5e241 1577 djSP; tryAMAGICbinSET(le,0);
28e5dec8
JH
1578#ifdef PERL_PRESERVE_IVUV
1579 SvIV_please(TOPs);
1580 if (SvIOK(TOPs)) {
1581 SvIV_please(TOPm1s);
1582 if (SvIOK(TOPm1s)) {
1583 bool auvok = SvUOK(TOPm1s);
1584 bool buvok = SvUOK(TOPs);
a227d84d 1585
28e5dec8
JH
1586 if (!auvok && !buvok) { /* ## IV <= IV ## */
1587 IV aiv = SvIVX(TOPm1s);
1588 IV biv = SvIVX(TOPs);
1589
1590 SP--;
1591 SETs(boolSV(aiv <= biv));
1592 RETURN;
1593 }
1594 if (auvok && buvok) { /* ## UV <= UV ## */
1595 UV auv = SvUVX(TOPm1s);
1596 UV buv = SvUVX(TOPs);
1597
1598 SP--;
1599 SETs(boolSV(auv <= buv));
1600 RETURN;
1601 }
1602 if (auvok) { /* ## UV <= IV ## */
1603 UV auv;
1604 IV biv;
1605
1606 biv = SvIVX(TOPs);
1607 SP--;
1608 if (biv < 0) {
1609 /* As (a) is a UV, it's >=0, so a cannot be <= */
1610 SETs(&PL_sv_no);
1611 RETURN;
1612 }
1613 auv = SvUVX(TOPs);
1614 if (auv > (UV) IV_MAX) {
1615 /* As (b) is an IV, it cannot be > IV_MAX */
1616 SETs(&PL_sv_no);
1617 RETURN;
1618 }
1619 SETs(boolSV(auv <= (UV)biv));
1620 RETURN;
1621 }
1622 { /* ## IV <= UV ## */
1623 IV aiv;
1624 UV buv;
1625
1626 aiv = SvIVX(TOPm1s);
1627 if (aiv < 0) {
1628 /* As (b) is a UV, it's >=0, so a must be <= */
1629 SP--;
1630 SETs(&PL_sv_yes);
1631 RETURN;
1632 }
1633 buv = SvUVX(TOPs);
1634 SP--;
1635 if (buv >= (UV) IV_MAX) {
1636 /* As (a) is an IV, it cannot be > IV_MAX */
1637 SETs(&PL_sv_yes);
1638 RETURN;
1639 }
1640 SETs(boolSV((UV)aiv <= buv));
1641 RETURN;
1642 }
1643 }
1644 }
1645#endif
a0d0e21e
LW
1646 {
1647 dPOPnv;
54310121 1648 SETs(boolSV(TOPn <= value));
a0d0e21e 1649 RETURN;
79072805 1650 }
a0d0e21e
LW
1651}
1652
1653PP(pp_ge)
1654{
8ec5e241 1655 djSP; tryAMAGICbinSET(ge,0);
28e5dec8
JH
1656#ifdef PERL_PRESERVE_IVUV
1657 SvIV_please(TOPs);
1658 if (SvIOK(TOPs)) {
1659 SvIV_please(TOPm1s);
1660 if (SvIOK(TOPm1s)) {
1661 bool auvok = SvUOK(TOPm1s);
1662 bool buvok = SvUOK(TOPs);
a227d84d 1663
28e5dec8
JH
1664 if (!auvok && !buvok) { /* ## IV >= IV ## */
1665 IV aiv = SvIVX(TOPm1s);
1666 IV biv = SvIVX(TOPs);
1667
1668 SP--;
1669 SETs(boolSV(aiv >= biv));
1670 RETURN;
1671 }
1672 if (auvok && buvok) { /* ## UV >= UV ## */
1673 UV auv = SvUVX(TOPm1s);
1674 UV buv = SvUVX(TOPs);
1675
1676 SP--;
1677 SETs(boolSV(auv >= buv));
1678 RETURN;
1679 }
1680 if (auvok) { /* ## UV >= IV ## */
1681 UV auv;
1682 IV biv;
1683
1684 biv = SvIVX(TOPs);
1685 SP--;
1686 if (biv < 0) {
1687 /* As (a) is a UV, it's >=0, so it must be >= */
1688 SETs(&PL_sv_yes);
1689 RETURN;
1690 }
1691 auv = SvUVX(TOPs);
1692 if (auv >= (UV) IV_MAX) {
1693 /* As (b) is an IV, it cannot be > IV_MAX */
1694 SETs(&PL_sv_yes);
1695 RETURN;
1696 }
1697 SETs(boolSV(auv >= (UV)biv));
1698 RETURN;
1699 }
1700 { /* ## IV >= UV ## */
1701 IV aiv;
1702 UV buv;
1703
1704 aiv = SvIVX(TOPm1s);
1705 if (aiv < 0) {
1706 /* As (b) is a UV, it's >=0, so a cannot be >= */
1707 SP--;
1708 SETs(&PL_sv_no);
1709 RETURN;
1710 }
1711 buv = SvUVX(TOPs);
1712 SP--;
1713 if (buv > (UV) IV_MAX) {
1714 /* As (a) is an IV, it cannot be > IV_MAX */
1715 SETs(&PL_sv_no);
1716 RETURN;
1717 }
1718 SETs(boolSV((UV)aiv >= buv));
1719 RETURN;
1720 }
1721 }
1722 }
1723#endif
a0d0e21e
LW
1724 {
1725 dPOPnv;
54310121 1726 SETs(boolSV(TOPn >= value));
a0d0e21e 1727 RETURN;
79072805 1728 }
a0d0e21e 1729}
79072805 1730
a0d0e21e
LW
1731PP(pp_ne)
1732{
8ec5e241 1733 djSP; tryAMAGICbinSET(ne,0);
28e5dec8
JH
1734#ifdef PERL_PRESERVE_IVUV
1735 SvIV_please(TOPs);
1736 if (SvIOK(TOPs)) {
1737 SvIV_please(TOPm1s);
1738 if (SvIOK(TOPm1s)) {
1739 bool auvok = SvUOK(TOPm1s);
1740 bool buvok = SvUOK(TOPs);
a227d84d 1741
28e5dec8
JH
1742 if (!auvok && !buvok) { /* ## IV <=> IV ## */
1743 IV aiv = SvIVX(TOPm1s);
1744 IV biv = SvIVX(TOPs);
1745
1746 SP--;
1747 SETs(boolSV(aiv != biv));
1748 RETURN;
1749 }
1750 if (auvok && buvok) { /* ## UV != UV ## */
1751 UV auv = SvUVX(TOPm1s);
1752 UV buv = SvUVX(TOPs);
1753
1754 SP--;
1755 SETs(boolSV(auv != buv));
1756 RETURN;
1757 }
1758 { /* ## Mixed IV,UV ## */
1759 IV iv;
1760 UV uv;
1761
1762 /* != is commutative so swap if needed (save code) */
1763 if (auvok) {
1764 /* swap. top of stack (b) is the iv */
1765 iv = SvIVX(TOPs);
1766 SP--;
1767 if (iv < 0) {
1768 /* As (a) is a UV, it's >0, so it cannot be == */
1769 SETs(&PL_sv_yes);
1770 RETURN;
1771 }
1772 uv = SvUVX(TOPs);
1773 } else {
1774 iv = SvIVX(TOPm1s);
1775 SP--;
1776 if (iv < 0) {
1777 /* As (b) is a UV, it's >0, so it cannot be == */
1778 SETs(&PL_sv_yes);
1779 RETURN;
1780 }
1781 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1782 }
1783 /* we know iv is >= 0 */
1784 if (uv > (UV) IV_MAX) {
1785 SETs(&PL_sv_yes);
1786 RETURN;
1787 }
1788 SETs(boolSV((UV)iv != uv));
1789 RETURN;
1790 }
1791 }
1792 }
1793#endif
a0d0e21e
LW
1794 {
1795 dPOPnv;
54310121 1796 SETs(boolSV(TOPn != value));
a0d0e21e
LW
1797 RETURN;
1798 }
79072805
LW
1799}
1800
a0d0e21e 1801PP(pp_ncmp)
79072805 1802{
8ec5e241 1803 djSP; dTARGET; tryAMAGICbin(ncmp,0);
28e5dec8
JH
1804#ifdef PERL_PRESERVE_IVUV
1805 /* Fortunately it seems NaN isn't IOK */
1806 SvIV_please(TOPs);
1807 if (SvIOK(TOPs)) {
1808 SvIV_please(TOPm1s);
1809 if (SvIOK(TOPm1s)) {
1810 bool leftuvok = SvUOK(TOPm1s);
1811 bool rightuvok = SvUOK(TOPs);
1812 I32 value;
1813 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
1814 IV leftiv = SvIVX(TOPm1s);
1815 IV rightiv = SvIVX(TOPs);
1816
1817 if (leftiv > rightiv)
1818 value = 1;
1819 else if (leftiv < rightiv)
1820 value = -1;
1821 else
1822 value = 0;
1823 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
1824 UV leftuv = SvUVX(TOPm1s);
1825 UV rightuv = SvUVX(TOPs);
1826
1827 if (leftuv > rightuv)
1828 value = 1;
1829 else if (leftuv < rightuv)
1830 value = -1;
1831 else
1832 value = 0;
1833 } else if (leftuvok) { /* ## UV <=> IV ## */
1834 UV leftuv;
1835 IV rightiv;
1836
1837 rightiv = SvIVX(TOPs);
1838 if (rightiv < 0) {
1839 /* As (a) is a UV, it's >=0, so it cannot be < */
1840 value = 1;
1841 } else {
1842 leftuv = SvUVX(TOPm1s);
1843 if (leftuv > (UV) IV_MAX) {
1844 /* As (b) is an IV, it cannot be > IV_MAX */
1845 value = 1;
1846 } else if (leftuv > (UV)rightiv) {
1847 value = 1;
1848 } else if (leftuv < (UV)rightiv) {
1849 value = -1;
1850 } else {
1851 value = 0;
1852 }
1853 }
1854 } else { /* ## IV <=> UV ## */
1855 IV leftiv;
1856 UV rightuv;
1857
1858 leftiv = SvIVX(TOPm1s);
1859 if (leftiv < 0) {
1860 /* As (b) is a UV, it's >=0, so it must be < */
1861 value = -1;
1862 } else {
1863 rightuv = SvUVX(TOPs);
1864 if (rightuv > (UV) IV_MAX) {
1865 /* As (a) is an IV, it cannot be > IV_MAX */
1866 value = -1;
1867 } else if (leftiv > (UV)rightuv) {
1868 value = 1;
1869 } else if (leftiv < (UV)rightuv) {
1870 value = -1;
1871 } else {
1872 value = 0;
1873 }
1874 }
1875 }
1876 SP--;
1877 SETi(value);
1878 RETURN;
1879 }
1880 }
1881#endif
a0d0e21e
LW
1882 {
1883 dPOPTOPnnrl;
1884 I32 value;
79072805 1885
a3540c92 1886#ifdef Perl_isnan
1ad04cfd
JH
1887 if (Perl_isnan(left) || Perl_isnan(right)) {
1888 SETs(&PL_sv_undef);
1889 RETURN;
1890 }
1891 value = (left > right) - (left < right);
1892#else
ff0cee69 1893 if (left == right)
a0d0e21e 1894 value = 0;
a0d0e21e
LW
1895 else if (left < right)
1896 value = -1;
44a8e56a
PP
1897 else if (left > right)
1898 value = 1;
1899 else {
3280af22 1900 SETs(&PL_sv_undef);
44a8e56a
PP
1901 RETURN;
1902 }
1ad04cfd 1903#endif
a0d0e21e
LW
1904 SETi(value);
1905 RETURN;
79072805 1906 }
a0d0e21e 1907}
79072805 1908
a0d0e21e
LW
1909PP(pp_slt)
1910{
8ec5e241 1911 djSP; tryAMAGICbinSET(slt,0);
a0d0e21e
LW
1912 {
1913 dPOPTOPssrl;
533c011a 1914 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69
PP
1915 ? sv_cmp_locale(left, right)
1916 : sv_cmp(left, right));
54310121 1917 SETs(boolSV(cmp < 0));
a0d0e21e
LW
1918 RETURN;
1919 }
79072805
LW
1920}
1921
a0d0e21e 1922PP(pp_sgt)
79072805 1923{
8ec5e241 1924 djSP; tryAMAGICbinSET(sgt,0);
a0d0e21e
LW
1925 {
1926 dPOPTOPssrl;
533c011a 1927 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69
PP
1928 ? sv_cmp_locale(left, right)
1929 : sv_cmp(left, right));
54310121 1930 SETs(boolSV(cmp > 0));
a0d0e21e
LW
1931 RETURN;
1932 }
1933}
79072805 1934
a0d0e21e
LW
1935PP(pp_sle)
1936{
8ec5e241 1937 djSP; tryAMAGICbinSET(sle,0);
a0d0e21e
LW
1938 {
1939 dPOPTOPssrl;
533c011a 1940 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69
PP
1941 ? sv_cmp_locale(left, right)
1942 : sv_cmp(left, right));
54310121 1943 SETs(boolSV(cmp <= 0));
a0d0e21e 1944 RETURN;
79072805 1945 }
79072805
LW
1946}
1947
a0d0e21e
LW
1948PP(pp_sge)
1949{
8ec5e241 1950 djSP; tryAMAGICbinSET(sge,0);
a0d0e21e
LW
1951 {
1952 dPOPTOPssrl;
533c011a 1953 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69
PP
1954 ? sv_cmp_locale(left, right)
1955 : sv_cmp(left, right));
54310121 1956 SETs(boolSV(cmp >= 0));
a0d0e21e
LW
1957 RETURN;
1958 }
1959}
79072805 1960
36477c24
PP
1961PP(pp_seq)
1962{
8ec5e241 1963 djSP; tryAMAGICbinSET(seq,0);
36477c24
PP
1964 {
1965 dPOPTOPssrl;
54310121 1966 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW
1967 RETURN;
1968 }
1969}
79072805 1970
a0d0e21e 1971PP(pp_sne)
79072805 1972{
8ec5e241 1973 djSP; tryAMAGICbinSET(sne,0);
a0d0e21e
LW
1974 {
1975 dPOPTOPssrl;
54310121 1976 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 1977 RETURN;
463ee0b2 1978 }
79072805
LW
1979}
1980
a0d0e21e 1981PP(pp_scmp)
79072805 1982{
4e35701f 1983 djSP; dTARGET; tryAMAGICbin(scmp,0);
a0d0e21e
LW
1984 {
1985 dPOPTOPssrl;
533c011a 1986 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69
PP
1987 ? sv_cmp_locale(left, right)
1988 : sv_cmp(left, right));
1989 SETi( cmp );
a0d0e21e
LW
1990 RETURN;
1991 }
1992}
79072805 1993
55497cff
PP
1994PP(pp_bit_and)
1995{
8ec5e241 1996 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
a0d0e21e
LW
1997 {
1998 dPOPTOPssrl;
4633a7c4 1999 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2000 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
2001 IV i = SvIV(left) & SvIV(right);
2002 SETi(i);
d0ba1bd2
JH
2003 }
2004 else {
972b05a9
JH
2005 UV u = SvUV(left) & SvUV(right);
2006 SETu(u);
d0ba1bd2 2007 }
a0d0e21e
LW
2008 }
2009 else {
533c011a 2010 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2011 SETTARG;
2012 }
2013 RETURN;
2014 }
2015}
79072805 2016
a0d0e21e
LW
2017PP(pp_bit_xor)
2018{
8ec5e241 2019 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW
2020 {
2021 dPOPTOPssrl;
4633a7c4 2022 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2023 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
2024 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2025 SETi(i);
d0ba1bd2
JH
2026 }
2027 else {
972b05a9
JH
2028 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2029 SETu(u);
d0ba1bd2 2030 }
a0d0e21e
LW
2031 }
2032 else {
533c011a 2033 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2034 SETTARG;
2035 }
2036 RETURN;
2037 }
2038}
79072805 2039
a0d0e21e
LW
2040PP(pp_bit_or)
2041{
8ec5e241 2042 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW
2043 {
2044 dPOPTOPssrl;
4633a7c4 2045 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2046 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
2047 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2048 SETi(i);
d0ba1bd2
JH
2049 }
2050 else {
972b05a9
JH
2051 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2052 SETu(u);
d0ba1bd2 2053 }
a0d0e21e
LW
2054 }
2055 else {
533c011a 2056 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2057 SETTARG;
2058 }
2059 RETURN;
79072805 2060 }
a0d0e21e 2061}
79072805 2062
a0d0e21e
LW
2063PP(pp_negate)
2064{
4e35701f 2065 djSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW
2066 {
2067 dTOPss;
28e5dec8 2068 int flags = SvFLAGS(sv);
4633a7c4
LW
2069 if (SvGMAGICAL(sv))
2070 mg_get(sv);
28e5dec8
JH
2071 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2072 /* It's publicly an integer, or privately an integer-not-float */
2073 oops_its_an_int:
9b0e499b
GS
2074 if (SvIsUV(sv)) {
2075 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2076 /* 2s complement assumption. */
9b0e499b
GS
2077 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2078 RETURN;
2079 }
2080 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2081 SETi(-SvIVX(sv));
9b0e499b
GS
2082 RETURN;
2083 }
2084 }
2085 else if (SvIVX(sv) != IV_MIN) {
2086 SETi(-SvIVX(sv));
2087 RETURN;
2088 }
28e5dec8
JH
2089#ifdef PERL_PRESERVE_IVUV
2090 else {
2091 SETu((UV)IV_MIN);
2092 RETURN;
2093 }
2094#endif
9b0e499b
GS
2095 }
2096 if (SvNIOKp(sv))
a0d0e21e 2097 SETn(-SvNV(sv));
4633a7c4 2098 else if (SvPOKp(sv)) {
a0d0e21e
LW
2099 STRLEN len;
2100 char *s = SvPV(sv, len);
bbce6d69 2101 if (isIDFIRST(*s)) {
a0d0e21e
LW
2102 sv_setpvn(TARG, "-", 1);
2103 sv_catsv(TARG, sv);
79072805 2104 }
a0d0e21e
LW
2105 else if (*s == '+' || *s == '-') {
2106 sv_setsv(TARG, sv);
2107 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805 2108 }
fd400ab9 2109 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
834a4ddd
LW
2110 sv_setpvn(TARG, "-", 1);
2111 sv_catsv(TARG, sv);
2112 }
28e5dec8
JH
2113 else {
2114 SvIV_please(sv);
2115 if (SvIOK(sv))
2116 goto oops_its_an_int;
2117 sv_setnv(TARG, -SvNV(sv));
2118 }
a0d0e21e 2119 SETTARG;
79072805 2120 }
4633a7c4
LW
2121 else
2122 SETn(-SvNV(sv));
79072805 2123 }
a0d0e21e 2124 RETURN;
79072805
LW
2125}
2126
a0d0e21e 2127PP(pp_not)
79072805 2128{
4e35701f 2129 djSP; tryAMAGICunSET(not);
3280af22 2130 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
a0d0e21e 2131 return NORMAL;
79072805
LW
2132}
2133
a0d0e21e 2134PP(pp_complement)
79072805 2135{
8ec5e241 2136 djSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW
2137 {
2138 dTOPss;
4633a7c4 2139 if (SvNIOKp(sv)) {
d0ba1bd2 2140 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
2141 IV i = ~SvIV(sv);
2142 SETi(i);
d0ba1bd2
JH
2143 }
2144 else {
972b05a9
JH
2145 UV u = ~SvUV(sv);
2146 SETu(u);
d0ba1bd2 2147 }
a0d0e21e
LW
2148 }
2149 else {
51723571 2150 register U8 *tmps;
55497cff 2151 register I32 anum;
a0d0e21e
LW
2152 STRLEN len;
2153
2154 SvSetSV(TARG, sv);
51723571 2155 tmps = (U8*)SvPV_force(TARG, len);
a0d0e21e 2156 anum = len;
1d68d6cd 2157 if (SvUTF8(TARG)) {
a1ca4561 2158 /* Calculate exact length, let's not estimate. */
1d68d6cd
SC
2159 STRLEN targlen = 0;
2160 U8 *result;
51723571 2161 U8 *send;
ba210ebe 2162 STRLEN l;
a1ca4561
YST
2163 UV nchar = 0;
2164 UV nwide = 0;
1d68d6cd
SC
2165
2166 send = tmps + len;
2167 while (tmps < send) {
cc366d4b 2168 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1d68d6cd 2169 tmps += UTF8SKIP(tmps);
5bbb0b5a 2170 targlen += UNISKIP(~c);
a1ca4561
YST
2171 nchar++;
2172 if (c > 0xff)
2173 nwide++;
1d68d6cd
SC
2174 }
2175
2176 /* Now rewind strings and write them. */
2177 tmps -= len;
a1ca4561
YST
2178
2179 if (nwide) {
2180 Newz(0, result, targlen + 1, U8);
2181 while (tmps < send) {
cc366d4b 2182 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
a1ca4561
YST
2183 tmps += UTF8SKIP(tmps);
2184 result = uv_to_utf8(result, ~c);
2185 }
2186 *result = '\0';
2187 result -= targlen;
2188 sv_setpvn(TARG, (char*)result, targlen);
2189 SvUTF8_on(TARG);
2190 }
2191 else {
2192 Newz(0, result, nchar + 1, U8);
2193 while (tmps < send) {
2194 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
2195 tmps += UTF8SKIP(tmps);
2196 *result++ = ~c;
2197 }
2198 *result = '\0';
2199 result -= nchar;
2200 sv_setpvn(TARG, (char*)result, nchar);
1d68d6cd 2201 }
1d68d6cd
SC
2202 Safefree(result);
2203 SETs(TARG);
2204 RETURN;
2205 }
a0d0e21e 2206#ifdef LIBERAL
51723571
JH
2207 {
2208 register long *tmpl;
2209 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2210 *tmps = ~*tmps;
2211 tmpl = (long*)tmps;
2212 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2213 *tmpl = ~*tmpl;
2214 tmps = (U8*)tmpl;
2215 }
a0d0e21e
LW
2216#endif
2217 for ( ; anum > 0; anum--, tmps++)
2218 *tmps = ~*tmps;
2219
2220 SETs(TARG);
2221 }
2222 RETURN;
2223 }
79072805
LW
2224}
2225
a0d0e21e
LW
2226/* integer versions of some of the above */
2227
a0d0e21e 2228PP(pp_i_multiply)
79072805 2229{
8ec5e241 2230 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW
2231 {
2232 dPOPTOPiirl;
2233 SETi( left * right );
2234 RETURN;
2235 }
79072805
LW
2236}
2237
a0d0e21e 2238PP(pp_i_divide)
79072805 2239{
8ec5e241 2240 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW
2241 {
2242 dPOPiv;
2243 if (value == 0)
cea2e8a9 2244 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW
2245 value = POPi / value;
2246 PUSHi( value );
2247 RETURN;
2248 }
79072805
LW
2249}
2250
a0d0e21e 2251PP(pp_i_modulo)
79072805 2252{
b13b2135 2253 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
79072805 2254 {
a0d0e21e 2255 dPOPTOPiirl;
aa306039 2256 if (!right)
cea2e8a9 2257 DIE(aTHX_ "Illegal modulus zero");
a0d0e21e
LW
2258 SETi( left % right );
2259 RETURN;
79072805 2260 }
79072805
LW
2261}
2262
a0d0e21e 2263PP(pp_i_add)
79072805 2264{
8ec5e241 2265 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e 2266 {
5e66d4f1 2267 dPOPTOPiirl_ul;
a0d0e21e
LW
2268 SETi( left + right );
2269 RETURN;
79072805 2270 }
79072805
LW
2271}
2272
a0d0e21e 2273PP(pp_i_subtract)
79072805 2274{
8ec5e241 2275 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 2276 {
5e66d4f1 2277 dPOPTOPiirl_ul;
a0d0e21e
LW
2278 SETi( left - right );
2279 RETURN;
79072805 2280 }
79072805
LW
2281}
2282
a0d0e21e 2283PP(pp_i_lt)
79072805 2284{
8ec5e241 2285 djSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW
2286 {
2287 dPOPTOPiirl;
54310121 2288 SETs(boolSV(left < right));
a0d0e21e
LW
2289 RETURN;
2290 }
79072805
LW
2291}
2292
a0d0e21e 2293PP(pp_i_gt)
79072805 2294{
8ec5e241 2295 djSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW
2296 {
2297 dPOPTOPiirl;
54310121 2298 SETs(boolSV(left > right));
a0d0e21e
LW
2299 RETURN;
2300 }
79072805
LW
2301}
2302
a0d0e21e 2303PP(pp_i_le)
79072805 2304{
8ec5e241 2305 djSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW
2306 {
2307 dPOPTOPiirl;
54310121 2308 SETs(boolSV(left <= right));
a0d0e21e 2309 RETURN;
85e6fe83 2310 }
79072805
LW
2311}
2312
a0d0e21e 2313PP(pp_i_ge)
79072805 2314{
8ec5e241 2315 djSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW
2316 {
2317 dPOPTOPiirl;
54310121 2318 SETs(boolSV(left >= right));
a0d0e21e
LW
2319 RETURN;
2320 }
79072805
LW
2321}
2322
a0d0e21e 2323PP(pp_i_eq)
79072805 2324{
8ec5e241 2325 djSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW
2326 {
2327 dPOPTOPiirl;
54310121 2328 SETs(boolSV(left == right));
a0d0e21e
LW
2329 RETURN;
2330 }
79072805
LW
2331}
2332
a0d0e21e 2333PP(pp_i_ne)
79072805 2334{
8ec5e241 2335 djSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW
2336 {
2337 dPOPTOPiirl;
54310121 2338 SETs(boolSV(left != right));
a0d0e21e
LW
2339 RETURN;
2340 }
79072805
LW
2341}
2342
a0d0e21e 2343PP(pp_i_ncmp)
79072805 2344{
8ec5e241 2345 djSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW
2346 {
2347 dPOPTOPiirl;
2348 I32 value;
79072805 2349
a0d0e21e 2350 if (left > right)
79072805 2351 value = 1;
a0d0e21e 2352 else if (left < right)
79072805 2353 value = -1;
a0d0e21e 2354 else
79072805 2355 value = 0;
a0d0e21e
LW
2356 SETi(value);
2357 RETURN;
79072805 2358 }
85e6fe83
LW
2359}
2360
2361PP(pp_i_negate)
2362{
4e35701f 2363 djSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW
2364 SETi(-TOPi);
2365 RETURN;
2366}
2367
79072805
LW
2368/* High falutin' math. */
2369
2370PP(pp_atan2)
2371{
8ec5e241 2372 djSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW
2373 {
2374 dPOPTOPnnrl;
65202027 2375 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2376 RETURN;
2377 }
79072805
LW
2378}
2379
2380PP(pp_sin)
2381{
4e35701f 2382 djSP; dTARGET; tryAMAGICun(sin);
a0d0e21e 2383 {
65202027 2384 NV value;
a0d0e21e 2385 value = POPn;
65202027 2386 value = Perl_sin(value);
a0d0e21e
LW
2387 XPUSHn(value);
2388 RETURN;
2389 }
79072805
LW
2390}
2391
2392PP(pp_cos)
2393{
4e35701f 2394 djSP; dTARGET; tryAMAGICun(cos);
a0d0e21e 2395 {
65202027 2396 NV value;
a0d0e21e 2397 value = POPn;
65202027 2398 value = Perl_cos(value);
a0d0e21e
LW
2399 XPUSHn(value);
2400 RETURN;
2401 }
79072805
LW
2402}
2403
56cb0a1c
AD
2404/* Support Configure command-line overrides for rand() functions.
2405 After 5.005, perhaps we should replace this by Configure support
2406 for drand48(), random(), or rand(). For 5.005, though, maintain
2407 compatibility by calling rand() but allow the user to override it.
2408 See INSTALL for details. --Andy Dougherty 15 July 1998
2409*/
85ab1d1d
JH
2410/* Now it's after 5.005, and Configure supports drand48() and random(),
2411 in addition to rand(). So the overrides should not be needed any more.
2412 --Jarkko Hietaniemi 27 September 1998
2413 */
2414
2415#ifndef HAS_DRAND48_PROTO
20ce7b12 2416extern double drand48 (void);
56cb0a1c
AD
2417#endif
2418
79072805
LW
2419PP(pp_rand)
2420{
4e35701f 2421 djSP; dTARGET;
65202027 2422 NV value;
79072805
LW
2423 if (MAXARG < 1)
2424 value = 1.0;
2425 else
2426 value = POPn;
2427 if (value == 0.0)
2428 value = 1.0;
80252599 2429 if (!PL_srand_called) {
85ab1d1d 2430 (void)seedDrand01((Rand_seed_t)seed());
80252599 2431 PL_srand_called = TRUE;
93dc8474 2432 }
85ab1d1d 2433 value *= Drand01();
79072805
LW
2434 XPUSHn(value);
2435 RETURN;
2436}
2437
2438PP(pp_srand)
2439{
4e35701f 2440 djSP;
93dc8474
CS
2441 UV anum;
2442 if (MAXARG < 1)
2443 anum = seed();
79072805 2444 else
93dc8474 2445 anum = POPu;
85ab1d1d 2446 (void)seedDrand01((Rand_seed_t)anum);
80252599 2447 PL_srand_called = TRUE;
79072805
LW
2448 EXTEND(SP, 1);
2449 RETPUSHYES;
2450}
2451
76e3520e 2452STATIC U32
cea2e8a9 2453S_seed(pTHX)
93dc8474 2454{
54310121
PP
2455 /*
2456 * This is really just a quick hack which grabs various garbage
2457 * values. It really should be a real hash algorithm which
2458 * spreads the effect of every input bit onto every output bit,
85ab1d1d 2459 * if someone who knows about such things would bother to write it.
54310121 2460 * Might be a good idea to add that function to CORE as well.
85ab1d1d 2461 * No numbers below come from careful analysis or anything here,
54310121
PP
2462 * except they are primes and SEED_C1 > 1E6 to get a full-width
2463 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
2464 * probably be bigger too.
2465 */
2466#if RANDBITS > 16
2467# define SEED_C1 1000003
2468#define SEED_C4 73819
2469#else
2470# define SEED_C1 25747
2471#define SEED_C4 20639
2472#endif
2473#define SEED_C2 3
2474#define SEED_C3 269
2475#define SEED_C5 26107
2476
73c60299
RS
2477#ifndef PERL_NO_DEV_RANDOM
2478 int fd;
2479#endif
93dc8474 2480 U32 u;
f12c7020
PP
2481#ifdef VMS
2482# include <starlet.h>
43c92808
HF
2483 /* when[] = (low 32 bits, high 32 bits) of time since epoch
2484 * in 100-ns units, typically incremented ever 10 ms. */
93dc8474 2485 unsigned int when[2];
73c60299
RS
2486#else
2487# ifdef HAS_GETTIMEOFDAY
2488 struct timeval when;
2489# else
2490 Time_t when;
2491# endif
2492#endif
2493
2494/* This test is an escape hatch, this symbol isn't set by Configure. */
2495#ifndef PERL_NO_DEV_RANDOM
2496#ifndef PERL_RANDOM_DEVICE
2497 /* /dev/random isn't used by default because reads from it will block
2498 * if there isn't enough entropy available. You can compile with
2499 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
2500 * is enough real entropy to fill the seed. */
2501# define PERL_RANDOM_DEVICE "/dev/urandom"
2502#endif
2503 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
2504 if (fd != -1) {
2505 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
2506 u = 0;
2507 PerlLIO_close(fd);
2508 if (u)
2509 return u;
2510 }
2511#endif
2512
2513#ifdef VMS
93dc8474 2514 _ckvmssts(sys$gettim(when));
54310121 2515 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
f12c7020 2516#else
5f05dabc 2517# ifdef HAS_GETTIMEOFDAY
93dc8474 2518 gettimeofday(&when,(struct timezone *) 0);
54310121 2519 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
f12c7020 2520# else
93dc8474 2521 (void)time(&when);
54310121 2522 u = (U32)SEED_C1 * when;
f12c7020
PP
2523# endif
2524#endif
7766f137 2525 u += SEED_C3 * (U32)PerlProc_getpid();
56431972 2526 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
54310121 2527#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
56431972 2528 u += SEED_C5 * (U32)PTR2UV(&when);
f12c7020 2529#endif
93dc8474 2530 return u;
79072805
LW
2531}
2532
2533PP(pp_exp)
2534{
4e35701f 2535 djSP; dTARGET; tryAMAGICun(exp);
a0d0e21e 2536 {
65202027 2537 NV value;
a0d0e21e 2538 value = POPn;
65202027 2539 value = Perl_exp(value);
a0d0e21e
LW
2540 XPUSHn(value);
2541 RETURN;
2542 }
79072805
LW
2543}
2544
2545PP(pp_log)
2546{
4e35701f 2547 djSP; dTARGET; tryAMAGICun(log);
a0d0e21e 2548 {
65202027 2549 NV value;
a0d0e21e 2550 value = POPn;
bbce6d69 2551 if (value <= 0.0) {
f93f4e46 2552 SET_NUMERIC_STANDARD();
cea2e8a9 2553 DIE(aTHX_ "Can't take log of %g", value);
bbce6d69 2554 }
65202027 2555 value = Perl_log(value);
a0d0e21e
LW
2556 XPUSHn(value);
2557 RETURN;
2558 }
79072805
LW
2559}
2560
2561PP(pp_sqrt)
2562{
4e35701f 2563 djSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e 2564 {
65202027 2565 NV value;
a0d0e21e 2566 value = POPn;
bbce6d69 2567 if (value < 0.0) {
f93f4e46 2568 SET_NUMERIC_STANDARD();
cea2e8a9 2569 DIE(aTHX_ "Can't take sqrt of %g", value);
bbce6d69 2570 }
65202027 2571 value = Perl_sqrt(value);
a0d0e21e
LW
2572 XPUSHn(value);
2573 RETURN;
2574 }
79072805
LW
2575}
2576
2577PP(pp_int)
2578{
78f67eb5 2579 djSP; dTARGET; tryAMAGICun(int);
774d564b 2580 {
28e5dec8
JH
2581 NV value;
2582 IV iv = TOPi; /* attempt to convert to IV if possible. */
2583 /* XXX it's arguable that compiler casting to IV might be subtly
2584 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2585 else preferring IV has introduced a subtle behaviour change bug. OTOH
2586 relying on floating point to be accurate is a bug. */
2587
2588 if (SvIOK(TOPs)) {
2589 if (SvIsUV(TOPs)) {
2590 UV uv = TOPu;
2591 SETu(uv);
2592 } else
2593 SETi(iv);
2594 } else {
2595 value = TOPn;
1048ea30 2596 if (value >= 0.0) {
28e5dec8
JH
2597 if (value < (NV)UV_MAX + 0.5) {
2598 SETu(U_V(value));
2599 } else {
1048ea30 2600#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
28e5dec8 2601 (void)Perl_modf(value, &value);
1048ea30 2602#else
28e5dec8
JH
2603 double tmp = (double)value;
2604 (void)Perl_modf(tmp, &tmp);
2605 value = (NV)tmp;
1048ea30 2606#endif
2d9af89d 2607 SETn(value);
28e5dec8 2608 }
1048ea30 2609 }
28e5dec8
JH
2610 else {
2611 if (value > (NV)IV_MIN - 0.5) {
2612 SETi(I_V(value));
2613 } else {
1048ea30 2614#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
28e5dec8
JH
2615 (void)Perl_modf(-value, &value);
2616 value = -value;
1048ea30 2617#else
28e5dec8
JH
2618 double tmp = (double)value;
2619 (void)Perl_modf(-tmp, &tmp);
2620 value = -(NV)tmp;
1048ea30 2621#endif
28e5dec8
JH
2622 SETn(value);
2623 }
2624 }
774d564b 2625 }
79072805 2626 }
79072805
LW
2627 RETURN;
2628}
2629
463ee0b2
LW
2630PP(pp_abs)
2631{
4e35701f 2632 djSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 2633 {
28e5dec8
JH
2634 /* This will cache the NV value if string isn't actually integer */
2635 IV iv = TOPi;
a227d84d 2636
28e5dec8
JH
2637 if (SvIOK(TOPs)) {
2638 /* IVX is precise */
2639 if (SvIsUV(TOPs)) {
2640 SETu(TOPu); /* force it to be numeric only */
2641 } else {
2642 if (iv >= 0) {
2643 SETi(iv);
2644 } else {
2645 if (iv != IV_MIN) {
2646 SETi(-iv);
2647 } else {
2648 /* 2s complement assumption. Also, not really needed as
2649 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2650 SETu(IV_MIN);
2651 }
a227d84d 2652 }
28e5dec8
JH
2653 }
2654 } else{
2655 NV value = TOPn;
774d564b 2656 if (value < 0.0)
28e5dec8 2657 value = -value;
774d564b
PP
2658 SETn(value);
2659 }
a0d0e21e 2660 }
774d564b 2661 RETURN;
463ee0b2
LW
2662}
2663
79072805
LW
2664PP(pp_hex)
2665{
4e35701f 2666 djSP; dTARGET;
79072805 2667 char *tmps;
ba210ebe 2668 STRLEN argtype;
2d8e6c8d 2669 STRLEN n_a;
79072805 2670
2d8e6c8d 2671 tmps = POPpx;
b21ed0a9 2672 argtype = 1; /* allow underscores */
9e24b6e2 2673 XPUSHn(scan_hex(tmps, 99, &argtype));
79072805
LW
2674 RETURN;
2675}
2676
2677PP(pp_oct)
2678{
4e35701f 2679 djSP; dTARGET;
9e24b6e2 2680 NV value;
ba210ebe 2681 STRLEN argtype;
79072805 2682 char *tmps;
2d8e6c8d 2683 STRLEN n_a;
79072805 2684
2d8e6c8d 2685 tmps = POPpx;
464e2e8a
PP
2686 while (*tmps && isSPACE(*tmps))
2687 tmps++;
9e24b6e2
JH
2688 if (*tmps == '0')
2689 tmps++;
b21ed0a9 2690 argtype = 1; /* allow underscores */
9e24b6e2
JH
2691 if (*tmps == 'x')
2692 value = scan_hex(++tmps, 99, &argtype);
2693 else if (*tmps == 'b')
2694 value = scan_bin(++tmps, 99, &argtype);
464e2e8a 2695 else
9e24b6e2
JH
2696 value = scan_oct(tmps, 99, &argtype);
2697 XPUSHn(value);
79072805
LW
2698 RETURN;
2699}
2700
2701/* String stuff. */
2702
2703PP(pp_length)
2704{
4e35701f 2705 djSP; dTARGET;
7e2040f0 2706 SV *sv = TOPs;
a0ed51b3 2707
7e2040f0
GS
2708 if (DO_UTF8(sv))
2709 SETi(sv_len_utf8(sv));
2710 else
2711 SETi(sv_len(sv));
79072805
LW
2712 RETURN;
2713}
2714
2715PP(pp_substr)
2716{
4e35701f 2717 djSP; dTARGET;
79072805
LW
2718 SV *sv;
2719 I32 len;
463ee0b2 2720 STRLEN curlen;
a0ed51b3 2721 STRLEN utfcurlen;
79072805
LW
2722 I32 pos;
2723 I32 rem;
84902520 2724 I32 fail;
78f9721b 2725 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
79072805 2726 char *tmps;
3280af22 2727 I32 arybase = PL_curcop->cop_arybase;
7b8d334a
GS
2728 char *repl = 0;
2729 STRLEN repl_len;
78f9721b 2730 int num_args = PL_op->op_private & 7;
79072805 2731
20408e3c 2732 SvTAINTED_off(TARG); /* decontaminate */
7e2040f0 2733 SvUTF8_off(TARG); /* decontaminate */
78f9721b
SM
2734 if (num_args > 2) {
2735 if (num_args > 3) {
5d82c453
GA
2736 sv = POPs;
2737 repl = SvPV(sv, repl_len);
7b8d334a 2738 }
79072805 2739 len = POPi;
5d82c453 2740 }
84902520 2741 pos = POPi;
79072805 2742 sv = POPs;
849ca7ee 2743 PUTBACK;
a0d0e21e 2744 tmps = SvPV(sv, curlen);
7e2040f0 2745 if (DO_UTF8(sv)) {
a0ed51b3
LW
2746 utfcurlen = sv_len_utf8(sv);
2747 if (utfcurlen == curlen)
2748 utfcurlen = 0;
2749 else
2750 curlen = utfcurlen;
2751 }
d1c2b58a
LW
2752 else
2753 utfcurlen = 0;
a0ed51b3 2754
84902520
TB
2755 if (pos >= arybase) {
2756 pos -= arybase;
2757 rem = curlen-pos;
2758 fail = rem;
78f9721b 2759 if (num_args > 2) {
5d82c453
GA
2760 if (len < 0) {
2761 rem += len;
2762 if (rem < 0)
2763 rem = 0;
2764 }
2765 else if (rem > len)
2766 rem = len;
2767 }
68dc0745 2768 }
84902520 2769 else {
5d82c453 2770 pos += curlen;
78f9721b 2771 if (num_args < 3)
5d82c453
GA
2772 rem = curlen;
2773 else if (len >= 0) {
2774 rem = pos+len;
2775 if (rem > (I32)curlen)
2776 rem = curlen;
2777 }
2778 else {
2779 rem = curlen+len;
2780 if (rem < pos)
2781 rem = pos;
2782 }
2783 if (pos < 0)
2784 pos = 0;
2785 fail = rem;
2786 rem -= pos;
84902520
TB
2787 }
2788 if (fail < 0) {
e476b1b5
GS
2789 if (lvalue || repl)
2790 Perl_croak(aTHX_ "substr outside of string");
2791 if (ckWARN(WARN_SUBSTR))
cea2e8a9 2792 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2304df62
AD
2793 RETPUSHUNDEF;
2794 }
79072805 2795 else {
9aa983d2
JH
2796 I32 upos = pos;
2797 I32 urem = rem;
7f66633b 2798 if (utfcurlen)
a0ed51b3 2799 sv_pos_u2b(sv, &pos, &rem);
79072805 2800 tmps += pos;
79072805 2801 sv_setpvn(TARG, tmps, rem);
7f66633b
GS
2802 if (utfcurlen)
2803 SvUTF8_on(TARG);
c8faf1c5
GS
2804 if (repl)
2805 sv_insert(sv, pos, rem, repl, repl_len);
2806 else if (lvalue) { /* it's an lvalue! */
dedeecda
PP
2807 if (!SvGMAGICAL(sv)) {
2808 if (SvROK(sv)) {
2d8e6c8d
GS
2809 STRLEN n_a;
2810 SvPV_force(sv,n_a);
599cee73 2811 if (ckWARN(WARN_SUBSTR))
cea2e8a9 2812 Perl_warner(aTHX_ WARN_SUBSTR,
599cee73 2813 "Attempt to use reference as lvalue in substr");
dedeecda
PP
2814 }
2815 if (SvOK(sv)) /* is it defined ? */
7f66633b 2816 (void)SvPOK_only_UTF8(sv);
dedeecda
PP
2817 else
2818 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2819 }
5f05dabc 2820
a0d0e21e
LW
2821 if (SvTYPE(TARG) < SVt_PVLV) {
2822 sv_upgrade(TARG, SVt_PVLV);
2823 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
ed6116ce 2824 }
a0d0e21e 2825
5f05dabc 2826 LvTYPE(TARG) = 'x';
6ff81951
GS
2827 if (LvTARG(TARG) != sv) {
2828 if (LvTARG(TARG))
2829 SvREFCNT_dec(LvTARG(TARG));
2830 LvTARG(TARG) = SvREFCNT_inc(sv);
2831 }
9aa983d2
JH
2832 LvTARGOFF(TARG) = upos;
2833 LvTARGLEN(TARG) = urem;
79072805
LW
2834 }
2835 }
849ca7ee 2836 SPAGAIN;
79072805
LW
2837 PUSHs(TARG); /* avoid SvSETMAGIC here */
2838 RETURN;
2839}
2840
2841PP(pp_vec)
2842{
4e35701f 2843 djSP; dTARGET;
467f0320
JH
2844 register IV size = POPi;
2845 register IV offset = POPi;
79072805 2846 register SV *src = POPs;
78f9721b 2847 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e 2848
81e118e0
JH
2849 SvTAINTED_off(TARG); /* decontaminate */
2850 if (lvalue) { /* it's an lvalue! */
2851 if (SvTYPE(TARG) < SVt_PVLV) {
2852 sv_upgrade(TARG, SVt_PVLV);
2853 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
79072805 2854 }
81e118e0
JH
2855 LvTYPE(TARG) = 'v';
2856 if (LvTARG(TARG) != src) {
2857 if (LvTARG(TARG))
2858 SvREFCNT_dec(LvTARG(TARG));
2859 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 2860 }
81e118e0
JH
2861 LvTARGOFF(TARG) = offset;
2862 LvTARGLEN(TARG) = size;
79072805
LW
2863 }
2864
81e118e0 2865 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW
2866 PUSHs(TARG);
2867 RETURN;
2868}
2869
2870PP(pp_index)
2871{
4e35701f 2872 djSP; dTARGET;
79072805
LW
2873 SV *big;
2874 SV *little;
2875 I32 offset;
2876 I32 retval;
2877 char *tmps;
2878 char *tmps2;
463ee0b2 2879 STRLEN biglen;
3280af22 2880 I32 arybase = PL_curcop->cop_arybase;
79072805
LW
2881
2882 if (MAXARG < 3)
2883 offset = 0;
2884 else
2885 offset = POPi - arybase;
2886 little = POPs;
2887 big = POPs;
463ee0b2 2888 tmps = SvPV(big, biglen);
7e2040f0 2889 if (offset > 0 && DO_UTF8(big))
a0ed51b3 2890 sv_pos_u2b(big, &offset, 0);
79072805
LW
2891 if (offset < 0)
2892 offset = 0;
93a17b20
LW
2893 else if (offset > biglen)
2894 offset = biglen;
79072805 2895 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 2896 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 2897 retval = -1;
79072805 2898 else
a0ed51b3 2899 retval = tmps2 - tmps;
7e2040f0 2900 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW
2901 sv_pos_b2u(big, &retval);
2902 PUSHi(retval + arybase);
79072805
LW
2903 RETURN;
2904}
2905
2906PP(pp_rindex)
2907{
4e35701f 2908 djSP; dTARGET;
79072805
LW
2909 SV *big;
2910 SV *little;
463ee0b2
LW
2911 STRLEN blen;
2912 STRLEN llen;
79072805
LW
2913 I32 offset;
2914 I32 retval;
2915 char *tmps;
2916 char *tmps2;
3280af22 2917 I32 arybase = PL_curcop->cop_arybase;
79072805 2918
a0d0e21e 2919 if (MAXARG >= 3)
a0ed51b3 2920 offset = POPi;
79072805
LW
2921 little = POPs;
2922 big = POPs;
463ee0b2
LW
2923 tmps2 = SvPV(little, llen);
2924 tmps = SvPV(big, blen);
79072805 2925 if (MAXARG < 3)
463ee0b2 2926 offset = blen;
a0ed51b3 2927 else {
7e2040f0 2928 if (offset > 0 && DO_UTF8(big))
a0ed51b3
LW
2929 sv_pos_u2b(big, &offset, 0);
2930 offset = offset - arybase + llen;
2931 }
79072805
LW
2932 if (offset < 0)
2933 offset = 0;
463ee0b2
LW
2934 else if (offset > blen)
2935 offset = blen;
79072805 2936 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 2937 tmps2, tmps2 + llen)))
a0ed51b3 2938 retval = -1;
79072805 2939 else
a0ed51b3 2940 retval = tmps2 - tmps;
7e2040f0 2941 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW
2942 sv_pos_b2u(big, &retval);
2943 PUSHi(retval + arybase);
79072805
LW
2944 RETURN;
2945}
2946
2947PP(pp_sprintf)
2948{
4e35701f 2949 djSP; dMARK; dORIGMARK; dTARGET;
79072805 2950 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 2951 TAINT_IF(SvTAINTED(TARG));
79072805
LW
2952 SP = ORIGMARK;
2953 PUSHTARG;
2954 RETURN;
2955}
2956
79072805
LW
2957PP(pp_ord)
2958{
4e35701f 2959 djSP; dTARGET;
7df053ec 2960 SV *argsv = POPs;
ba210ebe 2961 STRLEN len;
7df053ec 2962 U8 *s = (U8*)SvPVx(argsv, len);
79072805 2963
7df053ec 2964 XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff));
79072805
LW
2965 RETURN;
2966}
2967
463ee0b2
LW
2968PP(pp_chr)
2969{
4e35701f 2970 djSP; dTARGET;
463ee0b2 2971 char *tmps;
467f0320 2972 UV value = POPu;
463ee0b2 2973
748a9306 2974 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3 2975
9aa983d2
JH
2976 if (value > 255 && !IN_BYTE) {
2977 SvGROW(TARG, UNISKIP(value)+1);
2978 tmps = (char*)uv_to_utf8((U8*)SvPVX(TARG), value);
a0ed51b3
LW
2979 SvCUR_set(TARG, tmps - SvPVX(TARG));
2980 *tmps = '\0';
2981 (void)SvPOK_only(TARG);
aa6ffa16 2982 SvUTF8_on(TARG);
a0ed51b3
LW
2983 XPUSHs(TARG);
2984 RETURN;
2985 }
2986
748a9306 2987 SvGROW(TARG,2);
463ee0b2
LW
2988 SvCUR_set(TARG, 1);
2989 tmps = SvPVX(TARG);
a0ed51b3 2990 *tmps++ = value;
748a9306 2991 *tmps = '\0';
a0d0e21e 2992 (void)SvPOK_only(TARG);
463ee0b2
LW
2993 XPUSHs(TARG);
2994 RETURN;
2995}
2996
79072805
LW
2997PP(pp_crypt)
2998{
4e35701f 2999 djSP; dTARGET; dPOPTOPssrl;
2d8e6c8d 3000 STRLEN n_a;
79072805 3001#ifdef HAS_CRYPT
2d8e6c8d 3002 char *tmps = SvPV(left, n_a);
79072805 3003#ifdef FCRYPT
2d8e6c8d 3004 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
79072805 3005#else
2d8e6c8d 3006 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
79072805
LW
3007#endif
3008#else
b13b2135 3009 DIE(aTHX_
79072805
LW
3010 "The crypt() function is unimplemented due to excessive paranoia.");
3011#endif
3012 SETs(TARG);
3013 RETURN;
3014}
3015
3016PP(pp_ucfirst)
3017{
4e35701f 3018 djSP;
79072805 3019 SV *sv = TOPs;
a0ed51b3
LW
3020 register U8 *s;
3021 STRLEN slen;
3022
fd400ab9 3023 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
ba210ebe 3024 STRLEN ulen;
ad391ad9 3025 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3 3026 U8 *tend;
dcad2880 3027 UV uv = utf8_to_uv(s, slen, &ulen, 0);
a0ed51b3
LW
3028
3029 if (PL_op->op_private & OPpLOCALE) {
3030 TAINT;
3031 SvTAINTED_on(sv);
3032 uv = toTITLE_LC_uni(uv);
3033 }
3034 else
3035 uv = toTITLE_utf8(s);
3036
3037 tend = uv_to_utf8(tmpbuf, uv);
3038
014822e4 3039 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 3040 dTARGET;
dfe13c55
GS
3041 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3042 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3043 SvUTF8_on(TARG);
a0ed51b3
LW
3044 SETs(TARG);
3045 }
3046 else {
dfe13c55 3047 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW
3048 Copy(tmpbuf, s, ulen, U8);
3049 }
a0ed51b3 3050 }
626727d5 3051 else {
014822e4 3052 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3053 dTARGET;
7e2040f0 3054 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
3055 sv_setsv(TARG, sv);
3056 sv = TARG;
3057 SETs(sv);
3058 }
3059 s = (U8*)SvPV_force(sv, slen);
3060 if (*s) {
3061 if (PL_op->op_private & OPpLOCALE) {
3062 TAINT;
3063 SvTAINTED_on(sv);
3064 *s = toUPPER_LC(*s);
3065 }
3066 else
3067 *s = toUPPER(*s);
bbce6d69 3068 }
bbce6d69 3069 }
31351b04
JS
3070 if (SvSMAGICAL(sv))
3071 mg_set(sv);
79072805
LW
3072 RETURN;
3073}
3074
3075PP(pp_lcfirst)
3076{
4e35701f 3077 djSP;
79072805 3078 SV *sv = TOPs;
a0ed51b3
LW
3079 register U8 *s;
3080 STRLEN slen;
3081
fd400ab9 3082 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
ba210ebe 3083 STRLEN ulen;
ad391ad9 3084 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3 3085 U8 *tend;
dcad2880 3086 UV uv = utf8_to_uv(s, slen, &ulen, 0);
a0ed51b3
LW
3087
3088 if (PL_op->op_private & OPpLOCALE) {
3089 TAINT;
3090 SvTAINTED_on(sv);
3091 uv = toLOWER_LC_uni(uv);
3092 }
3093 else
3094 uv = toLOWER_utf8(s);
3095
3096 tend = uv_to_utf8(tmpbuf, uv);
3097
014822e4 3098 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 3099 dTARGET;
dfe13c55
GS
3100 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3101 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3102 SvUTF8_on(TARG);
a0ed51b3
LW
3103 SETs(TARG);
3104 }
3105 else {
dfe13c55 3106 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW
3107 Copy(tmpbuf, s, ulen, U8);
3108 }
a0ed51b3 3109 }
626727d5 3110 else {
014822e4 3111 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3112 dTARGET;
7e2040f0 3113 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
3114 sv_setsv(TARG, sv);
3115 sv = TARG;
3116 SETs(sv);
3117 }
3118 s = (U8*)SvPV_force(sv, slen);
3119 if (*s) {
3120 if (PL_op->op_private & OPpLOCALE) {
3121 TAINT;
3122 SvTAINTED_on(sv);
3123 *s = toLOWER_LC(*s);
3124 }
3125 else
3126 *s = toLOWER(*s);
bbce6d69 3127 }
bbce6d69 3128 }
31351b04
JS
3129 if (SvSMAGICAL(sv))
3130 mg_set(sv);
79072805
LW
3131 RETURN;
3132}
3133
3134PP(pp_uc)
3135{
4e35701f 3136 djSP;
79072805 3137 SV *sv = TOPs;
a0ed51b3 3138 register U8 *s;
463ee0b2 3139 STRLEN len;
79072805 3140
7e2040f0 3141 if (DO_UTF8(sv)) {
a0ed51b3 3142 dTARGET;
ba210ebe 3143 STRLEN ulen;
a0ed51b3
LW
3144 register U8 *d;
3145 U8 *send;
3146
dfe13c55 3147 s = (U8*)SvPV(sv,len);
a5a20234 3148 if (!len) {
7e2040f0 3149 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW
3150 sv_setpvn(TARG, "", 0);
3151 SETs(TARG);
a0ed51b3
LW
3152 }
3153 else {
31351b04
JS
3154 (void)SvUPGRADE(TARG, SVt_PV);
3155 SvGROW(TARG, (len * 2) + 1);
3156 (void)SvPOK_only(TARG);
3157 d = (U8*)SvPVX(TARG);
3158 send = s + len;
3159 if (PL_op->op_private & OPpLOCALE) {
3160 TAINT;
3161 SvTAINTED_on(TARG);
3162 while (s < send) {
dcad2880 3163 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
31351b04
JS
3164 s += ulen;
3165 }
a0ed51b3 3166 }
31351b04
JS
3167 else {
3168 while (s < send) {
3169 d = uv_to_utf8(d, toUPPER_utf8( s ));
3170 s += UTF8SKIP(s);
3171 }
a0ed51b3 3172 }
31351b04 3173 *d = '\0';
7e2040f0 3174 SvUTF8_on(TARG);
31351b04
JS
3175 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3176 SETs(TARG);
a0ed51b3 3177 }
a0ed51b3 3178 }
626727d5 3179 else {
014822e4 3180 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3181 dTARGET;
7e2040f0 3182 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
3183 sv_setsv(TARG, sv);
3184 sv = TARG;
3185 SETs(sv);
3186 }
3187 s = (U8*)SvPV_force(sv, len);
3188 if (len) {
3189 register U8 *send = s + len;
3190
3191 if (PL_op->op_private & OPpLOCALE) {
3192 TAINT;
3193 SvTAINTED_on(sv);
3194 for (; s < send; s++)
3195 *s = toUPPER_LC(*s);
3196 }
3197 else {
3198 for (; s < send; s++)
3199 *s = toUPPER(*s);
3200 }
bbce6d69 3201 }
79072805 3202 }
31351b04
JS
3203 if (SvSMAGICAL(sv))
3204 mg_set(sv);
79072805
LW
3205 RETURN;
3206}
3207
3208PP(pp_lc)
3209{
4e35701f 3210 djSP;
79072805 3211 SV *sv = TOPs;
a0ed51b3 3212 register U8 *s;
463ee0b2 3213 STRLEN len;
79072805 3214
7e2040f0 3215 if (DO_UTF8(sv)) {
a0ed51b3 3216 dTARGET;
ba210ebe 3217 STRLEN ulen;
a0ed51b3
LW
3218 register U8 *d;
3219 U8 *send;
3220
dfe13c55 3221 s = (U8*)SvPV(sv,len);
a5a20234 3222 if (!len) {
7e2040f0 3223 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW
3224 sv_setpvn(TARG, "", 0);
3225 SETs(TARG);
a0ed51b3
LW
3226 }
3227 else {
31351b04
JS
3228 (void)SvUPGRADE(TARG, SVt_PV);
3229 SvGROW(TARG, (len * 2) + 1);
3230 (void)SvPOK_only(TARG);
3231 d = (U8*)SvPVX(TARG);
3232 send = s + len;
3233 if (PL_op->op_private & OPpLOCALE) {
3234 TAINT;
3235 SvTAINTED_on(TARG);
3236 while (s < send) {
dcad2880 3237 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
31351b04
JS
3238 s += ulen;
3239 }
a0ed51b3 3240 }
31351b04
JS
3241 else {
3242 while (s < send) {
3243 d = uv_to_utf8(d, toLOWER_utf8(s));
3244 s += UTF8SKIP(s);
3245 }
a0ed51b3 3246 }
31351b04 3247 *d = '\0';
7e2040f0 3248 SvUTF8_on(TARG);
31351b04
JS
3249 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3250 SETs(TARG);
a0ed51b3 3251 }
79072805 3252 }
626727d5 3253 else {
014822e4 3254 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3255 dTARGET;
7e2040f0 3256 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
3257 sv_setsv(TARG, sv);
3258 sv = TARG;
3259 SETs(sv);
a0ed51b3 3260 }
bbce6d69 3261
31351b04
JS
3262 s = (U8*)SvPV_force(sv, len);
3263 if (len) {
3264 register U8 *send = s + len;
bbce6d69 3265
31351b04
JS
3266 if (PL_op->op_private & OPpLOCALE) {
3267 TAINT;
3268 SvTAINTED_on(sv);
3269 for (; s < send; s++)
3270 *s = toLOWER_LC(*s);
3271 }
3272 else {
3273 for (; s < send; s++)
3274 *s = toLOWER(*s);
3275 }
bbce6d69 3276 }
79072805 3277 }
31351b04
JS
3278 if (SvSMAGICAL(sv))
3279 mg_set(sv);
79072805
LW
3280 RETURN;
3281}
3282
a0d0e21e 3283PP(pp_quotemeta)
79072805 3284{
4e35701f 3285 djSP; dTARGET;
a0d0e21e
LW
3286 SV *sv = TOPs;
3287 STRLEN len;
3288 register char *s = SvPV(sv,len);
3289 register char *d;
79072805 3290
7e2040f0 3291 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW
3292 if (len) {
3293 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 3294 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3295 d = SvPVX(TARG);
7e2040f0 3296 if (DO_UTF8(sv)) {
0dd2cdef 3297 while (len) {
fd400ab9 3298 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW
3299 STRLEN ulen = UTF8SKIP(s);
3300 if (ulen > len)
3301 ulen = len;
3302 len -= ulen;
3303 while (ulen--)
3304 *d++ = *s++;
3305 }
3306 else {
3307 if (!isALNUM(*s))
3308 *d++ = '\\';
3309 *d++ = *s++;
3310 len--;
3311 }
3312 }
7e2040f0 3313 SvUTF8_on(TARG);
0dd2cdef
LW
3314 }
3315 else {
3316 while (len--) {
3317 if (!isALNUM(*s))
3318 *d++ = '\\';
3319 *d++ = *s++;
3320 }
79072805 3321 }
a0d0e21e
LW
3322 *d = '\0';
3323 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 3324 (void)SvPOK_only_UTF8(TARG);
79072805 3325 }
a0d0e21e
LW
3326 else
3327 sv_setpvn(TARG, s, len);
3328 SETs(TARG);
31351b04
JS
3329 if (SvSMAGICAL(TARG))
3330 mg_set(TARG);
79072805
LW
3331 RETURN;
3332}
3333
a0d0e21e 3334/* Arrays. */
79072805 3335
a0d0e21e 3336PP(pp_aslice)
79072805 3337{
4e35701f 3338 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
3339 register SV** svp;
3340 register AV* av = (AV*)POPs;
78f9721b 3341 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3280af22 3342 I32 arybase = PL_curcop->cop_arybase;
748a9306 3343 I32 elem;
79072805 3344
a0d0e21e 3345 if (SvTYPE(av) == SVt_PVAV) {
533c011a 3346 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 3347 I32 max = -1;
924508f0 3348 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW
3349 elem = SvIVx(*svp);
3350 if (elem > max)
3351 max = elem;
3352 }
3353 if (max > AvMAX(av))
3354 av_extend(av, max);
3355 }
a0d0e21e 3356 while (++MARK <= SP) {
748a9306 3357 elem = SvIVx(*MARK);
a0d0e21e 3358
748a9306
LW
3359 if (elem > 0)
3360 elem -= arybase;
a0d0e21e
LW
3361 svp = av_fetch(av, elem, lval);
3362 if (lval) {
3280af22 3363 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 3364 DIE(aTHX_ PL_no_aelem, elem);
533c011a 3365 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 3366 save_aelem(av, elem, svp);
79072805 3367 }
3280af22 3368 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW
3369 }
3370 }
748a9306 3371 if (GIMME != G_ARRAY) {
a0d0e21e
LW
3372 MARK = ORIGMARK;
3373 *++MARK = *SP;
3374 SP = MARK;
3375 }
79072805
LW
3376 RETURN;
3377}
3378
3379/* Associative arrays. */
3380
3381PP(pp_each)
3382{
59af0135 3383 djSP;
79072805 3384 HV *hash = (HV*)POPs;
c07a80fd 3385 HE *entry;
54310121 3386 I32 gimme = GIMME_V;
c750a3ec 3387 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
8ec5e241 3388
c07a80fd 3389 PUTBACK;
c750a3ec
MB
3390 /* might clobber stack_sp */
3391 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
c07a80fd 3392 SPAGAIN;
79072805 3393
79072805
LW
3394 EXTEND(SP, 2);
3395 if (entry) {
54310121
PP
3396 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3397 if (gimme == G_ARRAY) {
59af0135 3398 SV *val;
c07a80fd 3399 PUTBACK;
c750a3ec 3400 /* might clobber stack_sp */
59af0135
GS
3401 val = realhv ?
3402 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
c07a80fd 3403 SPAGAIN;
59af0135 3404 PUSHs(val);
79072805 3405 }
79072805 3406 }
54310121 3407 else if (gimme == G_SCALAR)
79072805
LW
3408 RETPUSHUNDEF;
3409
3410 RETURN;
3411}
3412
3413PP(pp_values)
3414{
cea2e8a9 3415 return do_kv();
79072805
LW
3416}
3417
3418PP(pp_keys)
3419{
cea2e8a9 3420 return do_kv();
79072805
LW
3421}
3422
3423PP(pp_delete)
3424{
4e35701f 3425 djSP;
54310121
PP
3426 I32 gimme = GIMME_V;
3427 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 3428 SV *sv;
5f05dabc
PP
3429 HV *hv;
3430
533c011a 3431 if (PL_op->op_private & OPpSLICE) {
5f05dabc 3432 dMARK; dORIGMARK;
97fcbf96 3433 U32 hvtype;
5f05dabc 3434 hv = (HV*)POPs;
97fcbf96 3435 hvtype = SvTYPE(hv);
01020589
GS
3436 if (hvtype == SVt_PVHV) { /* hash element */
3437 while (++MARK <= SP) {
ae77835f 3438 sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS
3439 *MARK = sv ? sv : &PL_sv_undef;
3440 }
5f05dabc 3441 }
01020589
GS
3442 else if (hvtype == SVt_PVAV) {
3443 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3444 while (++MARK <= SP) {
3445 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3446 *MARK = sv ? sv : &PL_sv_undef;
3447 }
3448 }
3449 else { /* pseudo-hash element */
3450 while (++MARK <= SP) {
3451 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3452 *MARK = sv ? sv : &PL_sv_undef;
3453 }
3454 }
3455 }
3456 else
3457 DIE(aTHX_ "Not a HASH reference");
54310121
PP
3458 if (discard)
3459 SP = ORIGMARK;
3460 else if (gimme == G_SCALAR) {
5f05dabc
PP
3461 MARK = ORIGMARK;
3462 *++MARK = *SP;
3463 SP = MARK;
3464 }
3465 }
3466 else {
3467 SV *keysv = POPs;
3468 hv = (HV*)POPs;
97fcbf96
MB
3469 if (SvTYPE(hv) == SVt_PVHV)
3470 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS
3471 else if (SvTYPE(hv) == SVt_PVAV) {
3472 if (PL_op->op_flags & OPf_SPECIAL)
3473 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3474 else
3475 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3476 }
97fcbf96 3477 else
cea2e8a9 3478 DIE(aTHX_ "Not a HASH reference");
5f05dabc 3479 if (!sv)
3280af22 3480 sv = &PL_sv_undef;
54310121
PP
3481 if (!discard)
3482 PUSHs(sv);
79072805 3483 }
79072805
LW
3484 RETURN;
3485}
3486
a0d0e21e 3487PP(pp_exists)
79072805 3488{
4e35701f 3489 djSP;
afebc493
GS
3490 SV *tmpsv;
3491 HV *hv;
3492
3493 if (PL_op->op_private & OPpEXISTS_SUB) {
3494 GV *gv;
3495 CV *cv;
3496 SV *sv = POPs;
3497 cv = sv_2cv(sv, &hv, &gv, FALSE);
3498 if (cv)
3499 RETPUSHYES;
3500 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3501 RETPUSHYES;
3502 RETPUSHNO;
3503 }
3504 tmpsv = POPs;
3505 hv = (HV*)POPs;
c750a3ec 3506 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 3507 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 3508 RETPUSHYES;
ef54e1a4
JH
3509 }
3510 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS
3511 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3512 if (av_exists((AV*)hv, SvIV(tmpsv)))
3513 RETPUSHYES;
3514 }
3515 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
c750a3ec 3516 RETPUSHYES;
ef54e1a4
JH
3517 }
3518 else {
cea2e8a9 3519 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 3520 }
a0d0e21e
LW
3521 RETPUSHNO;
3522}
79072805 3523
a0d0e21e
LW
3524PP(pp_hslice)
3525{
4e35701f 3526 djSP; dMARK; dORIGMARK;
a0d0e21e 3527 register HV *hv = (HV*)POPs;
78f9721b 3528 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
c750a3ec 3529 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 3530
0ebe0038 3531 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 3532 DIE(aTHX_ "Can't localize pseudo-hash element");
0ebe0038 3533
c750a3ec 3534 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 3535 while (++MARK <= SP) {
f12c7020 3536 SV *keysv = *MARK;
ae77835f 3537 SV **svp;
1f5346dc 3538 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
ae77835f 3539 if (realhv) {
800e9ae0 3540 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
ae77835f 3541 svp = he ? &HeVAL(he) : 0;
ef54e1a4
JH
3542 }
3543 else {
97fcbf96 3544 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 3545 }
a0d0e21e 3546 if (lval) {
2d8e6c8d
GS
3547 if (!svp || *svp == &PL_sv_undef) {
3548 STRLEN n_a;
cea2e8a9 3549 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 3550 }
1f5346dc 3551 if (PL_op->op_private & OPpLVAL_INTRO) {
a227d84d 3552 if (preeminent)
1f5346dc
SC
3553 save_helem(hv, keysv, svp);
3554 else {
3555 STRLEN keylen;
3556 char *key = SvPV(keysv, keylen);
57813020 3557 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1f5346dc
SC
3558 }
3559 }
93a17b20 3560 }
3280af22 3561 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW
3562 }
3563 }
a0d0e21e
LW
3564 if (GIMME != G_ARRAY) {
3565 MARK = ORIGMARK;
3566 *++MARK = *SP;
3567 SP = MARK;
79072805 3568 }
a0d0e21e
LW
3569 RETURN;
3570}
3571
3572/* List operators. */
3573
3574PP(pp_list)
3575{
4e35701f 3576 djSP; dMARK;
a0d0e21e
LW
3577 if (GIMME != G_ARRAY) {
3578 if (++MARK <= SP)
3579 *MARK = *SP; /* unwanted list, return last item */
8990e307 3580 else
3280af22 3581 *MARK = &PL_sv_undef;
a0d0e21e 3582 SP = MARK;
79072805 3583 }
a0d0e21e 3584 RETURN;
79072805
LW
3585}
3586
a0d0e21e 3587PP(pp_lslice)
79072805 3588{
4e35701f 3589 djSP;
3280af22
NIS
3590 SV **lastrelem = PL_stack_sp;
3591 SV **lastlelem = PL_stack_base + POPMARK;
3592 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 3593 register SV **firstrelem = lastlelem + 1;
3280af22 3594 I32 arybase = PL_curcop->cop_arybase;
533c011a 3595 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 3596 I32 is_something_there = lval;
79072805 3597
a0d0e21e
LW
3598 register I32 max = lastrelem - lastlelem;
3599 register SV **lelem;
3600 register I32 ix;
3601
3602 if (GIMME != G_ARRAY) {
748a9306
LW
3603 ix = SvIVx(*lastlelem);
3604 if (ix < 0)
3605 ix += max;
3606 else
3607 ix -= arybase;
a0d0e21e 3608 if (ix < 0 || ix >= max)
3280af22 3609 *firstlelem = &PL_sv_undef;
a0d0e21e
LW
3610 else
3611 *firstlelem = firstrelem[ix];
3612 SP = firstlelem;
3613 RETURN;
3614 }
3615
3616 if (max == 0) {
3617 SP = firstlelem - 1;
3618 RETURN;
3619 }
3620
3621 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 3622 ix = SvIVx(*lelem);
c73bf8e3 3623 if (ix < 0)
a0d0e21e 3624 ix += max;
b13b2135 3625 else
748a9306 3626 ix -= arybase;
c73bf8e3
HS
3627 if (ix < 0 || ix >= max)
3628 *lelem = &PL_sv_undef;
3629 else {
3630 is_something_there = TRUE;
3631 if (!(*lelem = firstrelem[ix]))
3280af22 3632 *lelem = &PL_sv_undef;
748a9306 3633 }
79072805 3634 }
4633a7c4
LW
3635 if (is_something_there)
3636 SP = lastlelem;
3637 else
3638 SP = firstlelem - 1;
79072805
LW
3639 RETURN;
3640}
3641
a0d0e21e
LW
3642PP(pp_anonlist)
3643{
4e35701f 3644 djSP; dMARK; dORIGMARK;
a0d0e21e 3645 I32 items = SP - MARK;
44a8e56a
PP
3646 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3647 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3648 XPUSHs(av);
a0d0e21e
LW
3649 RETURN;
3650}
3651
3652PP(pp_anonhash)
79072805 3653{
4e35701f 3654 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
3655 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3656
3657 while (MARK < SP) {
3658 SV* key = *++MARK;
a0d0e21e
LW
3659 SV *val = NEWSV(46, 0);
3660 if (MARK < SP)
3661 sv_setsv(val, *++MARK);
e476b1b5
GS
3662 else if (ckWARN(WARN_MISC))
3663 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
f12c7020 3664 (void)hv_store_ent(hv,key,val,0);
79072805 3665 }
a0d0e21e
LW
3666 SP = ORIGMARK;
3667 XPUSHs((SV*)hv);
79072805
LW
3668 RETURN;
3669}
3670
a0d0e21e 3671PP(pp_splice)
79072805 3672{
4e35701f 3673 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
3674 register AV *ary = (AV*)*++MARK;
3675 register SV **src;
3676 register SV **dst;
3677 register I32 i;
3678 register I32 offset;
3679 register I32 length;
3680 I32 newlen;
3681 I32 after;
3682 I32 diff;
3683 SV **tmparyval = 0;
93965878
NIS
3684 MAGIC *mg;
3685
155aba94 3686 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
33c27489 3687 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 3688 PUSHMARK(MARK);
8ec5e241 3689 PUTBACK;
a60c0954 3690 ENTER;
864dbfa3 3691 call_method("SPLICE",GIMME_V);
a60c0954 3692 LEAVE;
93965878
NIS
3693 SPAGAIN;
3694 RETURN;
3695 }
79072805 3696
a0d0e21e 3697 SP++;
79072805 3698
a0d0e21e 3699 if (++MARK < SP) {
84902520 3700 offset = i = SvIVx(*MARK);
a0d0e21e 3701 if (offset < 0)
93965878 3702 offset += AvFILLp(ary) + 1;
a0d0e21e 3703 else
3280af22 3704 offset -= PL_curcop->cop_arybase;
84902520 3705 if (offset < 0)
cea2e8a9 3706 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW
3707 if (++MARK < SP) {
3708 length = SvIVx(*MARK++);
48cdf507
GA
3709 if (length < 0) {
3710 length += AvFILLp(ary) - offset + 1;
3711 if (length < 0)
3712 length = 0;
3713 }
79072805
LW
3714 }
3715 else
a0d0e21e 3716 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 3717 }
a0d0e21e
LW
3718 else {
3719 offset = 0;
3720 length = AvMAX(ary) + 1;
3721 }
93965878
NIS
3722 if (offset > AvFILLp(ary) + 1)
3723 offset = AvFILLp(ary) + 1;
3724 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW
3725 if (after < 0) { /* not that much array */
3726 length += after; /* offset+length now in array */
3727 after = 0;
3728 if (!AvALLOC(ary))
3729 av_extend(ary, 0);
3730 }
3731
3732 /* At this point, MARK .. SP-1 is our new LIST */
3733
3734 newlen = SP - MARK;
3735 diff = newlen - length;
13d7cbc1
GS
3736 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3737 av_reify(ary);
a0d0e21e
LW
3738
3739 if (diff < 0) { /* shrinking the area */
3740 if (newlen) {
3741 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3742 Copy(MARK, tmparyval, newlen, SV*);
79072805 3743 }
a0d0e21e
LW
3744
3745 MARK = ORIGMARK + 1;
3746 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3747 MEXTEND(MARK, length);
3748 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3749 if (AvREAL(ary)) {
bbce6d69 3750 EXTEND_MORTAL(length);
36477c24 3751 for (i = length, dst = MARK; i; i--) {
d689ffdd 3752 sv_2mortal(*dst); /* free them eventualy */
36477c24
PP
3753 dst++;
3754 }
a0d0e21e
LW
3755 }
3756 MARK += length - 1;
79072805 3757 }
a0d0e21e
LW
3758 else {
3759 *MARK = AvARRAY(ary)[offset+length-1];
3760 if (AvREAL(ary)) {
d689ffdd 3761 sv_2mortal(*MARK);
a0d0e21e
LW
3762 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3763 SvREFCNT_dec(*dst++); /* free them now */
79072805 3764 }