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