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