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