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