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