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