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