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