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