This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
More pixie cleaning.
[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
JH
2701 SV *repl_sv = NULL;
2702 SV *repl_sv_copy = NULL;
7b8d334a
GS
2703 char *repl = 0;
2704 STRLEN repl_len;
78f9721b 2705 int num_args = PL_op->op_private & 7;
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 }
2726 else if (DO_UTF8(sv)) {
2727 repl_sv_copy = newSVsv(repl_sv);
2728 sv_utf8_upgrade(repl_sv_copy);
2729 repl = SvPV(repl_sv_copy, repl_len);
2730 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
2731 }
2732 }
a0d0e21e 2733 tmps = SvPV(sv, curlen);
7e2040f0 2734 if (DO_UTF8(sv)) {
9402d6ed
JH
2735 utf8_curlen = sv_len_utf8(sv);
2736 if (utf8_curlen == curlen)
2737 utf8_curlen = 0;
a0ed51b3 2738 else
9402d6ed 2739 curlen = utf8_curlen;
a0ed51b3 2740 }
d1c2b58a 2741 else
9402d6ed 2742 utf8_curlen = 0;
a0ed51b3 2743
84902520
TB
2744 if (pos >= arybase) {
2745 pos -= arybase;
2746 rem = curlen-pos;
2747 fail = rem;
78f9721b 2748 if (num_args > 2) {
5d82c453
GA
2749 if (len < 0) {
2750 rem += len;
2751 if (rem < 0)
2752 rem = 0;
2753 }
2754 else if (rem > len)
2755 rem = len;
2756 }
68dc0745 2757 }
84902520 2758 else {
5d82c453 2759 pos += curlen;
78f9721b 2760 if (num_args < 3)
5d82c453
GA
2761 rem = curlen;
2762 else if (len >= 0) {
2763 rem = pos+len;
2764 if (rem > (I32)curlen)
2765 rem = curlen;
2766 }
2767 else {
2768 rem = curlen+len;
2769 if (rem < pos)
2770 rem = pos;
2771 }
2772 if (pos < 0)
2773 pos = 0;
2774 fail = rem;
2775 rem -= pos;
84902520
TB
2776 }
2777 if (fail < 0) {
e476b1b5
GS
2778 if (lvalue || repl)
2779 Perl_croak(aTHX_ "substr outside of string");
2780 if (ckWARN(WARN_SUBSTR))
cea2e8a9 2781 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2304df62
AD
2782 RETPUSHUNDEF;
2783 }
79072805 2784 else {
9aa983d2
JH
2785 I32 upos = pos;
2786 I32 urem = rem;
9402d6ed 2787 if (utf8_curlen)
a0ed51b3 2788 sv_pos_u2b(sv, &pos, &rem);
79072805 2789 tmps += pos;
79072805 2790 sv_setpvn(TARG, tmps, rem);
9402d6ed 2791 if (utf8_curlen)
7f66633b 2792 SvUTF8_on(TARG);
f7928d6c 2793 if (repl) {
c8faf1c5 2794 sv_insert(sv, pos, rem, repl, repl_len);
9402d6ed 2795 if (repl_is_utf8)
f7928d6c 2796 SvUTF8_on(sv);
9402d6ed
JH
2797 if (repl_sv_copy)
2798 SvREFCNT_dec(repl_sv_copy);
f7928d6c 2799 }
c8faf1c5 2800 else if (lvalue) { /* it's an lvalue! */
dedeecda
PP
2801 if (!SvGMAGICAL(sv)) {
2802 if (SvROK(sv)) {
2d8e6c8d
GS
2803 STRLEN n_a;
2804 SvPV_force(sv,n_a);
599cee73 2805 if (ckWARN(WARN_SUBSTR))
cea2e8a9 2806 Perl_warner(aTHX_ WARN_SUBSTR,
599cee73 2807 "Attempt to use reference as lvalue in substr");
dedeecda
PP
2808 }
2809 if (SvOK(sv)) /* is it defined ? */
7f66633b 2810 (void)SvPOK_only_UTF8(sv);
dedeecda
PP
2811 else
2812 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2813 }
5f05dabc 2814
a0d0e21e
LW
2815 if (SvTYPE(TARG) < SVt_PVLV) {
2816 sv_upgrade(TARG, SVt_PVLV);
2817 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
ed6116ce 2818 }
a0d0e21e 2819
5f05dabc 2820 LvTYPE(TARG) = 'x';
6ff81951
GS
2821 if (LvTARG(TARG) != sv) {
2822 if (LvTARG(TARG))
2823 SvREFCNT_dec(LvTARG(TARG));
2824 LvTARG(TARG) = SvREFCNT_inc(sv);
2825 }
9aa983d2
JH
2826 LvTARGOFF(TARG) = upos;
2827 LvTARGLEN(TARG) = urem;
79072805
LW
2828 }
2829 }
849ca7ee 2830 SPAGAIN;
79072805
LW
2831 PUSHs(TARG); /* avoid SvSETMAGIC here */
2832 RETURN;
2833}
2834
2835PP(pp_vec)
2836{
39644a26 2837 dSP; dTARGET;
467f0320
JH
2838 register IV size = POPi;
2839 register IV offset = POPi;
79072805 2840 register SV *src = POPs;
78f9721b 2841 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e 2842
81e118e0
JH
2843 SvTAINTED_off(TARG); /* decontaminate */
2844 if (lvalue) { /* it's an lvalue! */
2845 if (SvTYPE(TARG) < SVt_PVLV) {
2846 sv_upgrade(TARG, SVt_PVLV);
2847 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
79072805 2848 }
81e118e0
JH
2849 LvTYPE(TARG) = 'v';
2850 if (LvTARG(TARG) != src) {
2851 if (LvTARG(TARG))
2852 SvREFCNT_dec(LvTARG(TARG));
2853 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 2854 }
81e118e0
JH
2855 LvTARGOFF(TARG) = offset;
2856 LvTARGLEN(TARG) = size;
79072805
LW
2857 }
2858
81e118e0 2859 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW
2860 PUSHs(TARG);
2861 RETURN;
2862}
2863
2864PP(pp_index)
2865{
39644a26 2866 dSP; dTARGET;
79072805
LW
2867 SV *big;
2868 SV *little;
2869 I32 offset;
2870 I32 retval;
2871 char *tmps;
2872 char *tmps2;
463ee0b2 2873 STRLEN biglen;
3280af22 2874 I32 arybase = PL_curcop->cop_arybase;
79072805
LW
2875
2876 if (MAXARG < 3)
2877 offset = 0;
2878 else
2879 offset = POPi - arybase;
2880 little = POPs;
2881 big = POPs;
463ee0b2 2882 tmps = SvPV(big, biglen);
7e2040f0 2883 if (offset > 0 && DO_UTF8(big))
a0ed51b3 2884 sv_pos_u2b(big, &offset, 0);
79072805
LW
2885 if (offset < 0)
2886 offset = 0;
93a17b20
LW
2887 else if (offset > biglen)
2888 offset = biglen;
79072805 2889 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 2890 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 2891 retval = -1;
79072805 2892 else
a0ed51b3 2893 retval = tmps2 - tmps;
7e2040f0 2894 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW
2895 sv_pos_b2u(big, &retval);
2896 PUSHi(retval + arybase);
79072805
LW
2897 RETURN;
2898}
2899
2900PP(pp_rindex)
2901{
39644a26 2902 dSP; dTARGET;
79072805
LW
2903 SV *big;
2904 SV *little;
463ee0b2
LW
2905 STRLEN blen;
2906 STRLEN llen;
79072805
LW
2907 I32 offset;
2908 I32 retval;
2909 char *tmps;
2910 char *tmps2;
3280af22 2911 I32 arybase = PL_curcop->cop_arybase;
79072805 2912
a0d0e21e 2913 if (MAXARG >= 3)
a0ed51b3 2914 offset = POPi;
79072805
LW
2915 little = POPs;
2916 big = POPs;
463ee0b2
LW
2917 tmps2 = SvPV(little, llen);
2918 tmps = SvPV(big, blen);
79072805 2919 if (MAXARG < 3)
463ee0b2 2920 offset = blen;
a0ed51b3 2921 else {
7e2040f0 2922 if (offset > 0 && DO_UTF8(big))
a0ed51b3
LW
2923 sv_pos_u2b(big, &offset, 0);
2924 offset = offset - arybase + llen;
2925 }
79072805
LW
2926 if (offset < 0)
2927 offset = 0;
463ee0b2
LW
2928 else if (offset > blen)
2929 offset = blen;
79072805 2930 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 2931 tmps2, tmps2 + llen)))
a0ed51b3 2932 retval = -1;
79072805 2933 else
a0ed51b3 2934 retval = tmps2 - tmps;
7e2040f0 2935 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW
2936 sv_pos_b2u(big, &retval);
2937 PUSHi(retval + arybase);
79072805
LW
2938 RETURN;
2939}
2940
2941PP(pp_sprintf)
2942{
39644a26 2943 dSP; dMARK; dORIGMARK; dTARGET;
79072805 2944 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 2945 TAINT_IF(SvTAINTED(TARG));
79072805
LW
2946 SP = ORIGMARK;
2947 PUSHTARG;
2948 RETURN;
2949}
2950
79072805
LW
2951PP(pp_ord)
2952{
39644a26 2953 dSP; dTARGET;
7df053ec 2954 SV *argsv = POPs;
ba210ebe 2955 STRLEN len;
7df053ec 2956 U8 *s = (U8*)SvPVx(argsv, len);
79072805 2957
9041c2e3 2958 XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
79072805
LW
2959 RETURN;
2960}
2961
463ee0b2
LW
2962PP(pp_chr)
2963{
39644a26 2964 dSP; dTARGET;
463ee0b2 2965 char *tmps;
467f0320 2966 UV value = POPu;
463ee0b2 2967
748a9306 2968 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3 2969
9aa983d2
JH
2970 if (value > 255 && !IN_BYTE) {
2971 SvGROW(TARG, UNISKIP(value)+1);
9041c2e3 2972 tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
a0ed51b3
LW
2973 SvCUR_set(TARG, tmps - SvPVX(TARG));
2974 *tmps = '\0';
2975 (void)SvPOK_only(TARG);
aa6ffa16 2976 SvUTF8_on(TARG);
a0ed51b3
LW
2977 XPUSHs(TARG);
2978 RETURN;
2979 }
2980
748a9306 2981 SvGROW(TARG,2);
463ee0b2
LW
2982 SvCUR_set(TARG, 1);
2983 tmps = SvPVX(TARG);
a0ed51b3 2984 *tmps++ = value;
748a9306 2985 *tmps = '\0';
a0d0e21e 2986 (void)SvPOK_only(TARG);
463ee0b2
LW
2987 XPUSHs(TARG);
2988 RETURN;
2989}
2990
79072805
LW
2991PP(pp_crypt)
2992{
39644a26 2993 dSP; dTARGET; dPOPTOPssrl;
2d8e6c8d 2994 STRLEN n_a;
79072805 2995#ifdef HAS_CRYPT
2d8e6c8d 2996 char *tmps = SvPV(left, n_a);
79072805 2997#ifdef FCRYPT
2d8e6c8d 2998 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
79072805 2999#else
2d8e6c8d 3000 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
79072805
LW
3001#endif
3002#else
b13b2135 3003 DIE(aTHX_
79072805
LW
3004 "The crypt() function is unimplemented due to excessive paranoia.");
3005#endif
3006 SETs(TARG);
3007 RETURN;
3008}
3009
3010PP(pp_ucfirst)
3011{
39644a26 3012 dSP;
79072805 3013 SV *sv = TOPs;
a0ed51b3
LW
3014 register U8 *s;
3015 STRLEN slen;
3016
fd400ab9 3017 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
ba210ebe 3018 STRLEN ulen;
ad391ad9 3019 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3 3020 U8 *tend;
9041c2e3 3021 UV uv;
a0ed51b3
LW
3022
3023 if (PL_op->op_private & OPpLOCALE) {
3024 TAINT;
3025 SvTAINTED_on(sv);
9041c2e3 3026 uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
a0ed51b3
LW
3027 }
3028 else
3029 uv = toTITLE_utf8(s);
3030
9041c2e3 3031 tend = uvchr_to_utf8(tmpbuf, uv);
a0ed51b3 3032
014822e4 3033 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 3034 dTARGET;
dfe13c55
GS
3035 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3036 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3037 SvUTF8_on(TARG);
a0ed51b3
LW
3038 SETs(TARG);
3039 }
3040 else {
dfe13c55 3041 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW
3042 Copy(tmpbuf, s, ulen, U8);
3043 }
a0ed51b3 3044 }
626727d5 3045 else {
014822e4 3046 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3047 dTARGET;
7e2040f0 3048 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
3049 sv_setsv(TARG, sv);
3050 sv = TARG;
3051 SETs(sv);
3052 }
3053 s = (U8*)SvPV_force(sv, slen);
3054 if (*s) {
3055 if (PL_op->op_private & OPpLOCALE) {
3056 TAINT;
3057 SvTAINTED_on(sv);
3058 *s = toUPPER_LC(*s);
3059 }
3060 else
3061 *s = toUPPER(*s);
bbce6d69 3062 }
bbce6d69 3063 }
31351b04
JS
3064 if (SvSMAGICAL(sv))
3065 mg_set(sv);
79072805
LW
3066 RETURN;
3067}
3068
3069PP(pp_lcfirst)
3070{
39644a26 3071 dSP;
79072805 3072 SV *sv = TOPs;
a0ed51b3
LW
3073 register U8 *s;
3074 STRLEN slen;
3075
fd400ab9 3076 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
ba210ebe 3077 STRLEN ulen;
ad391ad9 3078 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3 3079 U8 *tend;
9041c2e3 3080 UV uv;
a0ed51b3
LW
3081
3082 if (PL_op->op_private & OPpLOCALE) {
3083 TAINT;
3084 SvTAINTED_on(sv);
9041c2e3 3085 uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
a0ed51b3
LW
3086 }
3087 else
3088 uv = toLOWER_utf8(s);
3089
9041c2e3 3090 tend = uvchr_to_utf8(tmpbuf, uv);
a0ed51b3 3091
014822e4 3092 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 3093 dTARGET;
dfe13c55
GS
3094 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3095 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3096 SvUTF8_on(TARG);
a0ed51b3
LW
3097 SETs(TARG);
3098 }
3099 else {
dfe13c55 3100 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW
3101 Copy(tmpbuf, s, ulen, U8);
3102 }
a0ed51b3 3103 }
626727d5 3104 else {
014822e4 3105 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3106 dTARGET;
7e2040f0 3107 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
3108 sv_setsv(TARG, sv);
3109 sv = TARG;
3110 SETs(sv);
3111 }
3112 s = (U8*)SvPV_force(sv, slen);
3113 if (*s) {
3114 if (PL_op->op_private & OPpLOCALE) {
3115 TAINT;
3116 SvTAINTED_on(sv);
3117 *s = toLOWER_LC(*s);
3118 }
3119 else
3120 *s = toLOWER(*s);
bbce6d69 3121 }
bbce6d69 3122 }
31351b04
JS
3123 if (SvSMAGICAL(sv))
3124 mg_set(sv);
79072805
LW
3125 RETURN;
3126}
3127
3128PP(pp_uc)
3129{
39644a26 3130 dSP;
79072805 3131 SV *sv = TOPs;
a0ed51b3 3132 register U8 *s;
463ee0b2 3133 STRLEN len;
79072805 3134
7e2040f0 3135 if (DO_UTF8(sv)) {
a0ed51b3 3136 dTARGET;
ba210ebe 3137 STRLEN ulen;
a0ed51b3
LW
3138 register U8 *d;
3139 U8 *send;
3140
dfe13c55 3141 s = (U8*)SvPV(sv,len);
a5a20234 3142 if (!len) {
7e2040f0 3143 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW
3144 sv_setpvn(TARG, "", 0);
3145 SETs(TARG);
a0ed51b3
LW
3146 }
3147 else {
31351b04
JS
3148 (void)SvUPGRADE(TARG, SVt_PV);
3149 SvGROW(TARG, (len * 2) + 1);
3150 (void)SvPOK_only(TARG);
3151 d = (U8*)SvPVX(TARG);
3152 send = s + len;
3153 if (PL_op->op_private & OPpLOCALE) {
3154 TAINT;
3155 SvTAINTED_on(TARG);
3156 while (s < send) {
9041c2e3 3157 d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
31351b04
JS
3158 s += ulen;
3159 }
a0ed51b3 3160 }
31351b04
JS
3161 else {
3162 while (s < send) {
9041c2e3 3163 d = uvchr_to_utf8(d, toUPPER_utf8( s ));
31351b04
JS
3164 s += UTF8SKIP(s);
3165 }
a0ed51b3 3166 }
31351b04 3167 *d = '\0';
7e2040f0 3168 SvUTF8_on(TARG);
31351b04
JS
3169 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3170 SETs(TARG);
a0ed51b3 3171 }
a0ed51b3 3172 }
626727d5 3173 else {
014822e4 3174 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3175 dTARGET;
7e2040f0 3176 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
3177 sv_setsv(TARG, sv);
3178 sv = TARG;
3179 SETs(sv);
3180 }
3181 s = (U8*)SvPV_force(sv, len);
3182 if (len) {
3183 register U8 *send = s + len;
3184
3185 if (PL_op->op_private & OPpLOCALE) {
3186 TAINT;
3187 SvTAINTED_on(sv);
3188 for (; s < send; s++)
3189 *s = toUPPER_LC(*s);
3190 }
3191 else {
3192 for (; s < send; s++)
3193 *s = toUPPER(*s);
3194 }
bbce6d69 3195 }
79072805 3196 }
31351b04
JS
3197 if (SvSMAGICAL(sv))
3198 mg_set(sv);
79072805
LW
3199 RETURN;
3200}
3201
3202PP(pp_lc)
3203{
39644a26 3204 dSP;
79072805 3205 SV *sv = TOPs;
a0ed51b3 3206 register U8 *s;
463ee0b2 3207 STRLEN len;
79072805 3208
7e2040f0 3209 if (DO_UTF8(sv)) {
a0ed51b3 3210 dTARGET;
ba210ebe 3211 STRLEN ulen;
a0ed51b3
LW
3212 register U8 *d;
3213 U8 *send;
3214
dfe13c55 3215 s = (U8*)SvPV(sv,len);
a5a20234 3216 if (!len) {
7e2040f0 3217 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW
3218 sv_setpvn(TARG, "", 0);
3219 SETs(TARG);
a0ed51b3
LW
3220 }
3221 else {
31351b04
JS
3222 (void)SvUPGRADE(TARG, SVt_PV);
3223 SvGROW(TARG, (len * 2) + 1);
3224 (void)SvPOK_only(TARG);
3225 d = (U8*)SvPVX(TARG);
3226 send = s + len;
3227 if (PL_op->op_private & OPpLOCALE) {
3228 TAINT;
3229 SvTAINTED_on(TARG);
3230 while (s < send) {
9041c2e3 3231 d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
31351b04
JS
3232 s += ulen;
3233 }
a0ed51b3 3234 }
31351b04
JS
3235 else {
3236 while (s < send) {
9041c2e3 3237 d = uvchr_to_utf8(d, toLOWER_utf8(s));
31351b04
JS
3238 s += UTF8SKIP(s);
3239 }
a0ed51b3 3240 }
31351b04 3241 *d = '\0';
7e2040f0 3242 SvUTF8_on(TARG);
31351b04
JS
3243 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3244 SETs(TARG);
a0ed51b3 3245 }
79072805 3246 }
626727d5 3247 else {
014822e4 3248 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3249 dTARGET;
7e2040f0 3250 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
3251 sv_setsv(TARG, sv);
3252 sv = TARG;
3253 SETs(sv);
a0ed51b3 3254 }
bbce6d69 3255
31351b04
JS
3256 s = (U8*)SvPV_force(sv, len);
3257 if (len) {
3258 register U8 *send = s + len;
bbce6d69 3259
31351b04
JS
3260 if (PL_op->op_private & OPpLOCALE) {
3261 TAINT;
3262 SvTAINTED_on(sv);
3263 for (; s < send; s++)
3264 *s = toLOWER_LC(*s);
3265 }
3266 else {
3267 for (; s < send; s++)
3268 *s = toLOWER(*s);
3269 }
bbce6d69 3270 }
79072805 3271 }
31351b04
JS
3272 if (SvSMAGICAL(sv))
3273 mg_set(sv);
79072805
LW
3274 RETURN;
3275}
3276
a0d0e21e 3277PP(pp_quotemeta)
79072805 3278{
39644a26 3279 dSP; dTARGET;
a0d0e21e
LW
3280 SV *sv = TOPs;
3281 STRLEN len;
3282 register char *s = SvPV(sv,len);
3283 register char *d;
79072805 3284
7e2040f0 3285 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW
3286 if (len) {
3287 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 3288 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3289 d = SvPVX(TARG);
7e2040f0 3290 if (DO_UTF8(sv)) {
0dd2cdef 3291 while (len) {
fd400ab9 3292 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW
3293 STRLEN ulen = UTF8SKIP(s);
3294 if (ulen > len)
3295 ulen = len;
3296 len -= ulen;
3297 while (ulen--)
3298 *d++ = *s++;
3299 }
3300 else {
3301 if (!isALNUM(*s))
3302 *d++ = '\\';
3303 *d++ = *s++;
3304 len--;
3305 }
3306 }
7e2040f0 3307 SvUTF8_on(TARG);
0dd2cdef
LW
3308 }
3309 else {
3310 while (len--) {
3311 if (!isALNUM(*s))
3312 *d++ = '\\';
3313 *d++ = *s++;
3314 }
79072805 3315 }
a0d0e21e
LW
3316 *d = '\0';
3317 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 3318 (void)SvPOK_only_UTF8(TARG);
79072805 3319 }
a0d0e21e
LW
3320 else
3321 sv_setpvn(TARG, s, len);
3322 SETs(TARG);
31351b04
JS
3323 if (SvSMAGICAL(TARG))
3324 mg_set(TARG);
79072805
LW
3325 RETURN;
3326}
3327
a0d0e21e 3328/* Arrays. */
79072805 3329
a0d0e21e 3330PP(pp_aslice)
79072805 3331{
39644a26 3332 dSP; dMARK; dORIGMARK;
a0d0e21e
LW
3333 register SV** svp;
3334 register AV* av = (AV*)POPs;
78f9721b 3335 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3280af22 3336 I32 arybase = PL_curcop->cop_arybase;
748a9306 3337 I32 elem;
79072805 3338
a0d0e21e 3339 if (SvTYPE(av) == SVt_PVAV) {
533c011a 3340 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 3341 I32 max = -1;
924508f0 3342 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW
3343 elem = SvIVx(*svp);
3344 if (elem > max)
3345 max = elem;
3346 }
3347 if (max > AvMAX(av))
3348 av_extend(av, max);
3349 }
a0d0e21e 3350 while (++MARK <= SP) {
748a9306 3351 elem = SvIVx(*MARK);
a0d0e21e 3352
748a9306
LW
3353 if (elem > 0)
3354 elem -= arybase;
a0d0e21e
LW
3355 svp = av_fetch(av, elem, lval);
3356 if (lval) {
3280af22 3357 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 3358 DIE(aTHX_ PL_no_aelem, elem);
533c011a 3359 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 3360 save_aelem(av, elem, svp);
79072805 3361 }
3280af22 3362 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW
3363 }
3364 }
748a9306 3365 if (GIMME != G_ARRAY) {
a0d0e21e
LW
3366 MARK = ORIGMARK;
3367 *++MARK = *SP;
3368 SP = MARK;
3369 }
79072805
LW
3370 RETURN;
3371}
3372
3373/* Associative arrays. */
3374
3375PP(pp_each)
3376{
39644a26 3377 dSP;
79072805 3378 HV *hash = (HV*)POPs;
c07a80fd 3379 HE *entry;
54310121 3380 I32 gimme = GIMME_V;
c750a3ec 3381 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
8ec5e241 3382
c07a80fd 3383 PUTBACK;
c750a3ec
MB
3384 /* might clobber stack_sp */
3385 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
c07a80fd 3386 SPAGAIN;
79072805 3387
79072805
LW
3388 EXTEND(SP, 2);
3389 if (entry) {
54310121
PP
3390 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3391 if (gimme == G_ARRAY) {
59af0135 3392 SV *val;
c07a80fd 3393 PUTBACK;
c750a3ec 3394 /* might clobber stack_sp */
59af0135
GS
3395 val = realhv ?
3396 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
c07a80fd 3397 SPAGAIN;
59af0135 3398 PUSHs(val);
79072805 3399 }
79072805 3400 }
54310121 3401 else if (gimme == G_SCALAR)
79072805
LW
3402 RETPUSHUNDEF;
3403
3404 RETURN;
3405}
3406
3407PP(pp_values)
3408{
cea2e8a9 3409 return do_kv();
79072805
LW
3410}
3411
3412PP(pp_keys)
3413{
cea2e8a9 3414 return do_kv();
79072805
LW
3415}
3416
3417PP(pp_delete)
3418{
39644a26 3419 dSP;
54310121
PP
3420 I32 gimme = GIMME_V;
3421 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 3422 SV *sv;
5f05dabc
PP
3423 HV *hv;
3424
533c011a 3425 if (PL_op->op_private & OPpSLICE) {
5f05dabc 3426 dMARK; dORIGMARK;
97fcbf96 3427 U32 hvtype;
5f05dabc 3428 hv = (HV*)POPs;
97fcbf96 3429 hvtype = SvTYPE(hv);
01020589
GS
3430 if (hvtype == SVt_PVHV) { /* hash element */
3431 while (++MARK <= SP) {
ae77835f 3432 sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS
3433 *MARK = sv ? sv : &PL_sv_undef;
3434 }
5f05dabc 3435 }
01020589
GS
3436 else if (hvtype == SVt_PVAV) {
3437 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3438 while (++MARK <= SP) {
3439 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3440 *MARK = sv ? sv : &PL_sv_undef;
3441 }
3442 }
3443 else { /* pseudo-hash element */
3444 while (++MARK <= SP) {
3445 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3446 *MARK = sv ? sv : &PL_sv_undef;
3447 }
3448 }
3449 }
3450 else
3451 DIE(aTHX_ "Not a HASH reference");
54310121
PP
3452 if (discard)
3453 SP = ORIGMARK;
3454 else if (gimme == G_SCALAR) {
5f05dabc
PP
3455 MARK = ORIGMARK;
3456 *++MARK = *SP;
3457 SP = MARK;
3458 }
3459 }
3460 else {
3461 SV *keysv = POPs;
3462 hv = (HV*)POPs;
97fcbf96
MB
3463 if (SvTYPE(hv) == SVt_PVHV)
3464 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS
3465 else if (SvTYPE(hv) == SVt_PVAV) {
3466 if (PL_op->op_flags & OPf_SPECIAL)
3467 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3468 else
3469 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3470 }
97fcbf96 3471 else
cea2e8a9 3472 DIE(aTHX_ "Not a HASH reference");
5f05dabc 3473 if (!sv)
3280af22 3474 sv = &PL_sv_undef;
54310121
PP
3475 if (!discard)
3476 PUSHs(sv);
79072805 3477 }
79072805
LW
3478 RETURN;
3479}
3480
a0d0e21e 3481PP(pp_exists)
79072805 3482{
39644a26 3483 dSP;
afebc493
GS
3484 SV *tmpsv;
3485 HV *hv;
3486
3487 if (PL_op->op_private & OPpEXISTS_SUB) {
3488 GV *gv;
3489 CV *cv;
3490 SV *sv = POPs;
3491 cv = sv_2cv(sv, &hv, &gv, FALSE);
3492 if (cv)
3493 RETPUSHYES;
3494 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3495 RETPUSHYES;
3496 RETPUSHNO;
3497 }
3498 tmpsv = POPs;
3499 hv = (HV*)POPs;
c750a3ec 3500 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 3501 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 3502 RETPUSHYES;
ef54e1a4
JH
3503 }
3504 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS
3505 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3506 if (av_exists((AV*)hv, SvIV(tmpsv)))
3507 RETPUSHYES;
3508 }
3509 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
c750a3ec 3510 RETPUSHYES;
ef54e1a4
JH
3511 }
3512 else {
cea2e8a9 3513 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 3514 }
a0d0e21e
LW
3515 RETPUSHNO;
3516}
79072805 3517
a0d0e21e
LW
3518PP(pp_hslice)
3519{
39644a26 3520 dSP; dMARK; dORIGMARK;
a0d0e21e 3521 register HV *hv = (HV*)POPs;
78f9721b 3522 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
c750a3ec 3523 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 3524
0ebe0038 3525 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 3526 DIE(aTHX_ "Can't localize pseudo-hash element");
0ebe0038 3527
c750a3ec 3528 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 3529 while (++MARK <= SP) {
f12c7020 3530 SV *keysv = *MARK;
ae77835f 3531 SV **svp;
1f5346dc 3532 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
ae77835f 3533 if (realhv) {
800e9ae0 3534 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
ae77835f 3535 svp = he ? &HeVAL(he) : 0;
ef54e1a4
JH
3536 }
3537 else {
97fcbf96 3538 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 3539 }
a0d0e21e 3540 if (lval) {
2d8e6c8d
GS
3541 if (!svp || *svp == &PL_sv_undef) {
3542 STRLEN n_a;
cea2e8a9 3543 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 3544 }
1f5346dc 3545 if (PL_op->op_private & OPpLVAL_INTRO) {
a227d84d 3546 if (preeminent)
1f5346dc
SC
3547 save_helem(hv, keysv, svp);
3548 else {
3549 STRLEN keylen;
3550 char *key = SvPV(keysv, keylen);
57813020 3551 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1f5346dc
SC
3552 }
3553 }
93a17b20 3554 }
3280af22 3555 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW
3556 }
3557 }
a0d0e21e
LW
3558 if (GIMME != G_ARRAY) {
3559 MARK = ORIGMARK;
3560 *++MARK = *SP;
3561 SP = MARK;
79072805 3562 }
a0d0e21e
LW
3563 RETURN;
3564}
3565
3566/* List operators. */
3567
3568PP(pp_list)
3569{
39644a26 3570 dSP; dMARK;
a0d0e21e
LW
3571 if (GIMME != G_ARRAY) {
3572 if (++MARK <= SP)
3573 *MARK = *SP; /* unwanted list, return last item */
8990e307 3574 else
3280af22 3575 *MARK = &PL_sv_undef;
a0d0e21e 3576 SP = MARK;
79072805 3577 }
a0d0e21e 3578 RETURN;
79072805
LW
3579}
3580
a0d0e21e 3581PP(pp_lslice)
79072805 3582{
39644a26 3583 dSP;
3280af22
NIS
3584 SV **lastrelem = PL_stack_sp;
3585 SV **lastlelem = PL_stack_base + POPMARK;
3586 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 3587 register SV **firstrelem = lastlelem + 1;
3280af22 3588 I32 arybase = PL_curcop->cop_arybase;
533c011a 3589 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 3590 I32 is_something_there = lval;
79072805 3591
a0d0e21e
LW
3592 register I32 max = lastrelem - lastlelem;
3593 register SV **lelem;
3594 register I32 ix;
3595
3596 if (GIMME != G_ARRAY) {
748a9306
LW
3597 ix = SvIVx(*lastlelem);
3598 if (ix < 0)
3599 ix += max;
3600 else
3601 ix -= arybase;
a0d0e21e 3602 if (ix < 0 || ix >= max)
3280af22 3603 *firstlelem = &PL_sv_undef;
a0d0e21e
LW
3604 else
3605 *firstlelem = firstrelem[ix];
3606 SP = firstlelem;
3607 RETURN;
3608 }
3609
3610 if (max == 0) {
3611 SP = firstlelem - 1;
3612 RETURN;
3613 }
3614
3615 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 3616 ix = SvIVx(*lelem);
c73bf8e3 3617 if (ix < 0)
a0d0e21e 3618 ix += max;
b13b2135 3619 else
748a9306 3620 ix -= arybase;
c73bf8e3
HS
3621 if (ix < 0 || ix >= max)
3622 *lelem = &PL_sv_undef;
3623 else {
3624 is_something_there = TRUE;
3625 if (!(*lelem = firstrelem[ix]))
3280af22 3626 *lelem = &PL_sv_undef;
748a9306 3627 }
79072805 3628 }
4633a7c4
LW
3629 if (is_something_there)
3630 SP = lastlelem;
3631 else
3632 SP = firstlelem - 1;
79072805
LW
3633 RETURN;
3634}
3635
a0d0e21e
LW
3636PP(pp_anonlist)
3637{
39644a26 3638 dSP; dMARK; dORIGMARK;
a0d0e21e 3639 I32 items = SP - MARK;
44a8e56a
PP
3640 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3641 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3642 XPUSHs(av);
a0d0e21e
LW
3643 RETURN;
3644}
3645
3646PP(pp_anonhash)
79072805 3647{
39644a26 3648 dSP; dMARK; dORIGMARK;
a0d0e21e
LW
3649 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3650
3651 while (MARK < SP) {
3652 SV* key = *++MARK;
a0d0e21e
LW
3653 SV *val = NEWSV(46, 0);
3654 if (MARK < SP)
3655 sv_setsv(val, *++MARK);
e476b1b5
GS
3656 else if (ckWARN(WARN_MISC))
3657 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
f12c7020 3658 (void)hv_store_ent(hv,key,val,0);
79072805 3659 }
a0d0e21e
LW
3660 SP = ORIGMARK;
3661 XPUSHs((SV*)hv);
79072805
LW
3662 RETURN;
3663}
3664
a0d0e21e 3665PP(pp_splice)
79072805 3666{
39644a26 3667 dSP; dMARK; dORIGMARK;
a0d0e21e
LW
3668 register AV *ary = (AV*)*++MARK;
3669 register SV **src;
3670 register SV **dst;
3671 register I32 i;
3672 register I32 offset;
3673 register I32 length;
3674 I32 newlen;
3675 I32 after;
3676 I32 diff;
3677 SV **tmparyval = 0;
93965878
NIS
3678 MAGIC *mg;
3679
155aba94 3680 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
33c27489 3681 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 3682 PUSHMARK(MARK);
8ec5e241 3683 PUTBACK;
a60c0954 3684 ENTER;
864dbfa3 3685 call_method("SPLICE",GIMME_V);
a60c0954 3686 LEAVE;
93965878
NIS
3687 SPAGAIN;
3688 RETURN;
3689 }
79072805 3690
a0d0e21e 3691 SP++;
79072805 3692
a0d0e21e 3693 if (++MARK < SP) {
84902520 3694 offset = i = SvIVx(*MARK);
a0d0e21e 3695 if (offset < 0)
93965878 3696 offset += AvFILLp(ary) + 1;
a0d0e21e 3697 else
3280af22 3698 offset -= PL_curcop->cop_arybase;
84902520 3699 if (offset < 0)
cea2e8a9 3700 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW
3701 if (++MARK < SP) {
3702 length = SvIVx(*MARK++);
48cdf507
GA
3703 if (length < 0) {
3704 length += AvFILLp(ary) - offset + 1;
3705 if (length < 0)
3706 length = 0;
3707 }
79072805
LW
3708 }
3709 else
a0d0e21e 3710 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 3711 }
a0d0e21e
LW
3712 else {
3713 offset = 0;
3714 length = AvMAX(ary) + 1;
3715 }
93965878
NIS
3716 if (offset > AvFILLp(ary) + 1)
3717 offset = AvFILLp(ary) + 1;
3718 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW
3719 if (after < 0) { /* not that much array */
3720 length += after; /* offset+length now in array */
3721 after = 0;
3722 if (!AvALLOC(ary))
3723 av_extend(ary, 0);
3724 }
3725
3726 /* At this point, MARK .. SP-1 is our new LIST */
3727
3728 newlen = SP - MARK;
3729 diff = newlen - length;
13d7cbc1
GS
3730 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3731 av_reify(ary);
a0d0e21e
LW
3732
3733 if (diff < 0) { /* shrinking the area */
3734 if (newlen) {
3735 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3736 Copy(MARK, tmparyval, newlen, SV*);
79072805 3737 }
a0d0e21e
LW
3738
3739 MARK = ORIGMARK + 1;
3740 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3741 MEXTEND(MARK, length);
3742 Copy(AvARRAY(ary)+offset, MARK, length, SV*);