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