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