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