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