This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Make Encode.pm implicitly load external CJK tables the first
[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 */
12bcd1a6 558 deprecate_old("*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
799ef3cb 3150 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
121910a4 3151 tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3152 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH		 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 3186 if (PL_encoding)
799ef3cb 3187 sv_recode_to_utf8(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 {
98b27f73
JH		 3353 STRLEN nchar = utf8_length(s, s + len);
3354
31351b04 3355 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3356 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3357 (void)SvPOK_only(TARG);
3358 d = (U8*)SvPVX(TARG);
3359 send = s + len;
a2a2844f 3360 while (s < send) {
6fdb5f96 3361 toUPPER_utf8(s, tmpbuf, &ulen);
a2a2844f
JH		 3362 Copy(tmpbuf, d, ulen, U8);
3363 d += ulen;
3364 s += UTF8SKIP(s);
a0ed51b3 3365 }
31351b04 3366 *d = '\0';
7e2040f0 3367 SvUTF8_on(TARG);
31351b04
JS		 3368 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3369 SETs(TARG);
a0ed51b3 3370 }
a0ed51b3 3371 }
626727d5 3372 else {
014822e4 3373 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3374 dTARGET;
7e2040f0 3375 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 3376 sv_setsv(TARG, sv);
3377 sv = TARG;
3378 SETs(sv);
3379 }
3380 s = (U8*)SvPV_force(sv, len);
3381 if (len) {
3382 register U8 *send = s + len;
3383
2de3dbcc 3384 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3385 TAINT;
3386 SvTAINTED_on(sv);
3387 for (; s < send; s++)
3388 *s = toUPPER_LC(*s);
3389 }
3390 else {
3391 for (; s < send; s++)
3392 *s = toUPPER(*s);
3393 }
bbce6d69 3394 }
79072805 3395 }
31351b04
JS		 3396 if (SvSMAGICAL(sv))
3397 mg_set(sv);
79072805
LW		 3398 RETURN;
3399}
3400
3401PP(pp_lc)
3402{
39644a26 3403 dSP;
79072805 3404 SV *sv = TOPs;
a0ed51b3 3405 register U8 *s;
463ee0b2 3406 STRLEN len;
79072805 3407
7e2040f0 3408 if (DO_UTF8(sv)) {
a0ed51b3 3409 dTARGET;
ba210ebe 3410 STRLEN ulen;
a0ed51b3
LW		 3411 register U8 *d;
3412 U8 *send;
e7ae6809 3413 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3414
dfe13c55 3415 s = (U8*)SvPV(sv,len);
a5a20234 3416 if (!len) {
7e2040f0 3417 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3418 sv_setpvn(TARG, "", 0);
3419 SETs(TARG);
a0ed51b3
LW		 3420 }
3421 else {
98b27f73
JH		 3422 STRLEN nchar = utf8_length(s, s + len);
3423
31351b04 3424 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3425 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3426 (void)SvPOK_only(TARG);
3427 d = (U8*)SvPVX(TARG);
3428 send = s + len;
a2a2844f 3429 while (s < send) {
6fdb5f96
JH		 3430 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3431#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3432 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3433 /*
3434 * Now if the sigma is NOT followed by
3435 * /$ignorable_sequence$cased_letter/;
3436 * and it IS preceded by
3437 * /$cased_letter$ignorable_sequence/;
3438 * where $ignorable_sequence is
3439 * [\x{2010}\x{AD}\p{Mn}]*
3440 * and $cased_letter is
3441 * [\p{Ll}\p{Lo}\p{Lt}]
3442 * then it should be mapped to 0x03C2,
3443 * (GREEK SMALL LETTER FINAL SIGMA),
3444 * instead of staying 0x03A3.
3445 * See lib/unicore/SpecCase.txt.
3446 */
3447 }
a2a2844f
JH		 3448 Copy(tmpbuf, d, ulen, U8);
3449 d += ulen;
3450 s += UTF8SKIP(s);
a0ed51b3 3451 }
31351b04 3452 *d = '\0';
7e2040f0 3453 SvUTF8_on(TARG);
31351b04
JS		 3454 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3455 SETs(TARG);
a0ed51b3 3456 }
79072805 3457 }
626727d5 3458 else {
014822e4 3459 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3460 dTARGET;
7e2040f0 3461 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 3462 sv_setsv(TARG, sv);
3463 sv = TARG;
3464 SETs(sv);
a0ed51b3 3465 }
bbce6d69 3466
31351b04
JS		 3467 s = (U8*)SvPV_force(sv, len);
3468 if (len) {
3469 register U8 *send = s + len;
bbce6d69 3470
2de3dbcc 3471 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3472 TAINT;
3473 SvTAINTED_on(sv);
3474 for (; s < send; s++)
3475 *s = toLOWER_LC(*s);
3476 }
3477 else {
3478 for (; s < send; s++)
3479 *s = toLOWER(*s);
3480 }
bbce6d69 3481 }
79072805 3482 }
31351b04
JS		 3483 if (SvSMAGICAL(sv))
3484 mg_set(sv);
79072805
LW		 3485 RETURN;
3486}
3487
a0d0e21e 3488PP(pp_quotemeta)
79072805 3489{
39644a26 3490 dSP; dTARGET;
a0d0e21e
LW		 3491 SV *sv = TOPs;
3492 STRLEN len;
3493 register char *s = SvPV(sv,len);
3494 register char *d;
79072805 3495
7e2040f0 3496 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW		 3497 if (len) {
3498 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 3499 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3500 d = SvPVX(TARG);
7e2040f0 3501 if (DO_UTF8(sv)) {
0dd2cdef 3502 while (len) {
fd400ab9 3503 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 3504 STRLEN ulen = UTF8SKIP(s);
3505 if (ulen > len)
3506 ulen = len;
3507 len -= ulen;
3508 while (ulen--)
3509 *d++ = *s++;
3510 }
3511 else {
3512 if (!isALNUM(*s))
3513 *d++ = '\\';
3514 *d++ = *s++;
3515 len--;
3516 }
3517 }
7e2040f0 3518 SvUTF8_on(TARG);
0dd2cdef
LW		 3519 }
3520 else {
3521 while (len--) {
3522 if (!isALNUM(*s))
3523 *d++ = '\\';
3524 *d++ = *s++;
3525 }
79072805 3526 }
a0d0e21e
LW		 3527 *d = '\0';
3528 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 3529 (void)SvPOK_only_UTF8(TARG);
79072805 3530 }
a0d0e21e
LW		 3531 else
3532 sv_setpvn(TARG, s, len);
3533 SETs(TARG);
31351b04
JS		 3534 if (SvSMAGICAL(TARG))
3535 mg_set(TARG);
79072805
LW		 3536 RETURN;
3537}
3538
a0d0e21e 3539/* Arrays. */
79072805 3540
a0d0e21e 3541PP(pp_aslice)
79072805 3542{
39644a26 3543 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3544 register SV** svp;
3545 register AV* av = (AV*)POPs;
78f9721b 3546 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3280af22 3547 I32 arybase = PL_curcop->cop_arybase;
748a9306 3548 I32 elem;
79072805 3549
a0d0e21e 3550 if (SvTYPE(av) == SVt_PVAV) {
533c011a 3551 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 3552 I32 max = -1;
924508f0 3553 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 3554 elem = SvIVx(*svp);
3555 if (elem > max)
3556 max = elem;
3557 }
3558 if (max > AvMAX(av))
3559 av_extend(av, max);
3560 }
a0d0e21e 3561 while (++MARK <= SP) {
748a9306 3562 elem = SvIVx(*MARK);
a0d0e21e 3563
748a9306
LW		 3564 if (elem > 0)
3565 elem -= arybase;
a0d0e21e
LW		 3566 svp = av_fetch(av, elem, lval);
3567 if (lval) {
3280af22 3568 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 3569 DIE(aTHX_ PL_no_aelem, elem);
533c011a 3570 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 3571 save_aelem(av, elem, svp);
79072805 3572 }
3280af22 3573 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 3574 }
3575 }
748a9306 3576 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 3577 MARK = ORIGMARK;
3578 *++MARK = *SP;
3579 SP = MARK;
3580 }
79072805
LW		 3581 RETURN;
3582}
3583
3584/* Associative arrays. */
3585
3586PP(pp_each)
3587{
39644a26 3588 dSP;
79072805 3589 HV *hash = (HV*)POPs;
c07a80fd 3590 HE *entry;
54310121 3591 I32 gimme = GIMME_V;
c750a3ec 3592 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
8ec5e241 3593
c07a80fd 3594 PUTBACK;
c750a3ec
MB		 3595 /* might clobber stack_sp */
3596 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
c07a80fd 3597 SPAGAIN;
79072805 3598
79072805
LW		 3599 EXTEND(SP, 2);
3600 if (entry) {
54310121 3601 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
3602 if (gimme == G_ARRAY) {
59af0135 3603 SV *val;
c07a80fd 3604 PUTBACK;
c750a3ec 3605 /* might clobber stack_sp */
59af0135
GS		 3606 val = realhv ?
3607 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
c07a80fd 3608 SPAGAIN;
59af0135 3609 PUSHs(val);
79072805 3610 }
79072805 3611 }
54310121 3612 else if (gimme == G_SCALAR)
79072805
LW		 3613 RETPUSHUNDEF;
3614
3615 RETURN;
3616}
3617
3618PP(pp_values)
3619{
cea2e8a9 3620 return do_kv();
79072805
LW		 3621}
3622
3623PP(pp_keys)
3624{
cea2e8a9 3625 return do_kv();
79072805
LW		 3626}
3627
3628PP(pp_delete)
3629{
39644a26 3630 dSP;
54310121 3631 I32 gimme = GIMME_V;
3632 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 3633 SV *sv;
5f05dabc 3634 HV *hv;
3635
533c011a 3636 if (PL_op->op_private & OPpSLICE) {
5f05dabc 3637 dMARK; dORIGMARK;
97fcbf96 3638 U32 hvtype;
5f05dabc 3639 hv = (HV*)POPs;
97fcbf96 3640 hvtype = SvTYPE(hv);
01020589
GS		 3641 if (hvtype == SVt_PVHV) { /* hash element */
3642 while (++MARK <= SP) {
ae77835f 3643 sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 3644 *MARK = sv ? sv : &PL_sv_undef;
3645 }
5f05dabc 3646 }
01020589
GS		 3647 else if (hvtype == SVt_PVAV) {
3648 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3649 while (++MARK <= SP) {
3650 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3651 *MARK = sv ? sv : &PL_sv_undef;
3652 }
3653 }
3654 else { /* pseudo-hash element */
3655 while (++MARK <= SP) {
3656 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3657 *MARK = sv ? sv : &PL_sv_undef;
3658 }
3659 }
3660 }
3661 else
3662 DIE(aTHX_ "Not a HASH reference");
54310121 3663 if (discard)
3664 SP = ORIGMARK;
3665 else if (gimme == G_SCALAR) {
5f05dabc 3666 MARK = ORIGMARK;
3667 *++MARK = *SP;
3668 SP = MARK;
3669 }
3670 }
3671 else {
3672 SV *keysv = POPs;
3673 hv = (HV*)POPs;
97fcbf96
MB		 3674 if (SvTYPE(hv) == SVt_PVHV)
3675 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 3676 else if (SvTYPE(hv) == SVt_PVAV) {
3677 if (PL_op->op_flags & OPf_SPECIAL)
3678 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3679 else
3680 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3681 }
97fcbf96 3682 else
cea2e8a9 3683 DIE(aTHX_ "Not a HASH reference");
5f05dabc 3684 if (!sv)
3280af22 3685 sv = &PL_sv_undef;
54310121 3686 if (!discard)
3687 PUSHs(sv);
79072805 3688 }
79072805
LW		 3689 RETURN;
3690}
3691
a0d0e21e 3692PP(pp_exists)
79072805 3693{
39644a26 3694 dSP;
afebc493
GS		 3695 SV *tmpsv;
3696 HV *hv;
3697
3698 if (PL_op->op_private & OPpEXISTS_SUB) {
3699 GV *gv;
3700 CV *cv;
3701 SV *sv = POPs;
3702 cv = sv_2cv(sv, &hv, &gv, FALSE);
3703 if (cv)
3704 RETPUSHYES;
3705 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3706 RETPUSHYES;
3707 RETPUSHNO;
3708 }
3709 tmpsv = POPs;
3710 hv = (HV*)POPs;
c750a3ec 3711 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 3712 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 3713 RETPUSHYES;
ef54e1a4
JH		 3714 }
3715 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS		 3716 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3717 if (av_exists((AV*)hv, SvIV(tmpsv)))
3718 RETPUSHYES;
3719 }
3720 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
c750a3ec 3721 RETPUSHYES;
ef54e1a4
JH		 3722 }
3723 else {
cea2e8a9 3724 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 3725 }
a0d0e21e
LW		 3726 RETPUSHNO;
3727}
79072805 3728
a0d0e21e
LW		 3729PP(pp_hslice)
3730{
39644a26 3731 dSP; dMARK; dORIGMARK;
a0d0e21e 3732 register HV *hv = (HV*)POPs;
78f9721b 3733 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
c750a3ec 3734 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 3735
0ebe0038 3736 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 3737 DIE(aTHX_ "Can't localize pseudo-hash element");
0ebe0038 3738
c750a3ec 3739 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 3740 while (++MARK <= SP) {
f12c7020 3741 SV *keysv = *MARK;
ae77835f 3742 SV **svp;
d4fa047a
RH		 3743 I32 preeminent = SvRMAGICAL(hv) ? 1 :
3744 realhv ? hv_exists_ent(hv, keysv, 0)
3745 : avhv_exists_ent((AV*)hv, keysv, 0);
ae77835f 3746 if (realhv) {
800e9ae0 3747 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
ae77835f 3748 svp = he ? &HeVAL(he) : 0;
ef54e1a4
JH		 3749 }
3750 else {
97fcbf96 3751 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 3752 }
a0d0e21e 3753 if (lval) {
2d8e6c8d
GS		 3754 if (!svp || *svp == &PL_sv_undef) {
3755 STRLEN n_a;
cea2e8a9 3756 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 3757 }
1f5346dc 3758 if (PL_op->op_private & OPpLVAL_INTRO) {
a227d84d 3759 if (preeminent)
1f5346dc
SC		 3760 save_helem(hv, keysv, svp);
3761 else {
3762 STRLEN keylen;
3763 char *key = SvPV(keysv, keylen);
57813020 3764 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1f5346dc
SC		 3765 }
3766 }
93a17b20 3767 }
3280af22 3768 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 3769 }
3770 }
a0d0e21e
LW		 3771 if (GIMME != G_ARRAY) {
3772 MARK = ORIGMARK;
3773 *++MARK = *SP;
3774 SP = MARK;
79072805 3775 }
a0d0e21e
LW		 3776 RETURN;
3777}
3778
3779/* List operators. */
3780
3781PP(pp_list)
3782{
39644a26 3783 dSP; dMARK;
a0d0e21e
LW		 3784 if (GIMME != G_ARRAY) {
3785 if (++MARK <= SP)
3786 *MARK = *SP; /* unwanted list, return last item */
8990e307 3787 else
3280af22 3788 *MARK = &PL_sv_undef;
a0d0e21e 3789 SP = MARK;
79072805 3790 }
a0d0e21e 3791 RETURN;
79072805
LW		 3792}
3793
a0d0e21e 3794PP(pp_lslice)
79072805 3795{
39644a26 3796 dSP;
3280af22
NIS		 3797 SV **lastrelem = PL_stack_sp;
3798 SV **lastlelem = PL_stack_base + POPMARK;
3799 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 3800 register SV **firstrelem = lastlelem + 1;
3280af22 3801 I32 arybase = PL_curcop->cop_arybase;
533c011a 3802 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 3803 I32 is_something_there = lval;
79072805 3804
a0d0e21e
LW		 3805 register I32 max = lastrelem - lastlelem;
3806 register SV **lelem;
3807 register I32 ix;
3808
3809 if (GIMME != G_ARRAY) {
748a9306
LW		 3810 ix = SvIVx(*lastlelem);
3811 if (ix < 0)
3812 ix += max;
3813 else
3814 ix -= arybase;
a0d0e21e 3815 if (ix < 0 || ix >= max)
3280af22 3816 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 3817 else
3818 *firstlelem = firstrelem[ix];
3819 SP = firstlelem;
3820 RETURN;
3821 }
3822
3823 if (max == 0) {
3824 SP = firstlelem - 1;
3825 RETURN;
3826 }
3827
3828 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 3829 ix = SvIVx(*lelem);
c73bf8e3 3830 if (ix < 0)
a0d0e21e 3831 ix += max;
b13b2135 3832 else
748a9306 3833 ix -= arybase;
c73bf8e3
HS		 3834 if (ix < 0 || ix >= max)
3835 *lelem = &PL_sv_undef;
3836 else {
3837 is_something_there = TRUE;
3838 if (!(*lelem = firstrelem[ix]))
3280af22 3839 *lelem = &PL_sv_undef;
748a9306 3840 }
79072805 3841 }
4633a7c4
LW		 3842 if (is_something_there)
3843 SP = lastlelem;
3844 else
3845 SP = firstlelem - 1;
79072805
LW		 3846 RETURN;
3847}
3848
a0d0e21e
LW		 3849PP(pp_anonlist)
3850{
39644a26 3851 dSP; dMARK; dORIGMARK;
a0d0e21e 3852 I32 items = SP - MARK;
44a8e56a 3853 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3854 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3855 XPUSHs(av);
a0d0e21e
LW		 3856 RETURN;
3857}
3858
3859PP(pp_anonhash)
79072805 3860{
39644a26 3861 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3862 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3863
3864 while (MARK < SP) {
3865 SV* key = *++MARK;
a0d0e21e
LW		 3866 SV *val = NEWSV(46, 0);
3867 if (MARK < SP)
3868 sv_setsv(val, *++MARK);
e476b1b5 3869 else if (ckWARN(WARN_MISC))
b21befc1 3870 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in anonymous hash");
f12c7020 3871 (void)hv_store_ent(hv,key,val,0);
79072805 3872 }
a0d0e21e
LW		 3873 SP = ORIGMARK;
3874 XPUSHs((SV*)hv);
79072805
LW		 3875 RETURN;
3876}
3877
a0d0e21e 3878PP(pp_splice)
79072805 3879{
39644a26 3880 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3881 register AV *ary = (AV*)*++MARK;
3882 register SV **src;
3883 register SV **dst;
3884 register I32 i;
3885 register I32 offset;
3886 register I32 length;
3887 I32 newlen;
3888 I32 after;
3889 I32 diff;
3890 SV **tmparyval = 0;
93965878
NIS		 3891 MAGIC *mg;
3892
14befaf4 3893 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 3894 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 3895 PUSHMARK(MARK);
8ec5e241 3896 PUTBACK;
a60c0954 3897 ENTER;
864dbfa3 3898 call_method("SPLICE",GIMME_V);
a60c0954 3899 LEAVE;
93965878
NIS		 3900 SPAGAIN;
3901 RETURN;
3902 }
79072805 3903
a0d0e21e 3904 SP++;
79072805 3905
a0d0e21e 3906 if (++MARK < SP) {
84902520 3907 offset = i = SvIVx(*MARK);
a0d0e21e 3908 if (offset < 0)
93965878 3909 offset += AvFILLp(ary) + 1;
a0d0e21e 3910 else
3280af22 3911 offset -= PL_curcop->cop_arybase;
84902520 3912 if (offset < 0)
cea2e8a9 3913 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 3914 if (++MARK < SP) {
3915 length = SvIVx(*MARK++);
48cdf507
GA		 3916 if (length < 0) {
3917 length += AvFILLp(ary) - offset + 1;
3918 if (length < 0)
3919 length = 0;
3920 }
79072805
LW		 3921 }
3922 else
a0d0e21e 3923 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 3924 }
a0d0e21e
LW		 3925 else {
3926 offset = 0;
3927 length = AvMAX(ary) + 1;
3928 }
8cbc2e3b
JH		 3929 if (offset > AvFILLp(ary) + 1) {
3930 if (ckWARN(WARN_MISC))
3931 Perl_warner(aTHX_ WARN_MISC, "splice() offset past end of array" );
93965878 3932 offset = AvFILLp(ary) + 1;
8cbc2e3b 3933 }
93965878 3934 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 3935 if (after < 0) { /* not that much array */
3936 length += after; /* offset+length now in array */
3937 after = 0;
3938 if (!AvALLOC(ary))
3939 av_extend(ary, 0);
3940 }
3941
3942 /* At this point, MARK .. SP-1 is our new LIST */
3943
3944 newlen = SP - MARK;
3945 diff = newlen - length;
13d7cbc1
GS		 3946 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3947 av_reify(ary);
a0d0e21e
LW		 3948
3949 if (diff < 0) { /* shrinking the area */
3950 if (newlen) {
3951 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3952 Copy(MARK, tmparyval, newlen, SV*);
79072805 3953 }
a0d0e21e
LW		 3954
3955 MARK = ORIGMARK + 1;
3956 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3957 MEXTEND(MARK, length);
3958 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3959 if (AvREAL(ary)) {
bbce6d69 3960 EXTEND_MORTAL(length);
36477c24 3961 for (i = length, dst = MARK; i; i--) {
d689ffdd 3962 sv_2mortal(*dst); /* free them eventualy */
36477c24 3963 dst++;
3964 }
a0d0e21e
LW		 3965 }
3966 MARK += length - 1;
79072805 3967 }
a0d0e21e
LW		 3968 else {
3969 *MARK = AvARRAY(ary)[offset+length-1];
3970 if (AvREAL(ary)) {
d689ffdd 3971 sv_2mortal(*MARK);
a0d0e21e
LW		 3972 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3973 SvREFCNT_dec(*dst++); /* free them now */
79072805 3974 }
a0d0e21e 3975 }
93965878 3976 AvFILLp(ary) += diff;
a0d0e21e
LW		 3977
3978 /* pull up or down? */
3979
3980 if (offset < after) { /* easier to pull up */
3981 if (offset) { /* esp. if nothing to pull */
3982 src = &AvARRAY(ary)[offset-1];
3983 dst = src - diff; /* diff is negative */
3984 for (i = offset; i > 0; i--) /* can't trust Copy */
3985 *dst-- = *src--;
79072805 3986 }
a0d0e21e
LW		 3987 dst = AvARRAY(ary);
3988 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3989 AvMAX(ary) += diff;
3990 }
3991 else {
3992 if (after) { /* anything to pull down? */
3993 src = AvARRAY(ary) + offset + length;
3994 dst = src + diff; /* diff is negative */
3995 Move(src, dst, after, SV*);
79072805 3996 }
93965878 3997 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 3998 /* avoid later double free */
3999 }
4000 i = -diff;
4001 while (i)
3280af22 4002 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 4003
4004 if (newlen) {
4005 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4006 newlen; newlen--) {
4007 *dst = NEWSV(46, 0);
4008 sv_setsv(*dst++, *src++);
79072805 4009 }
a0d0e21e
LW		 4010 Safefree(tmparyval);
4011 }
4012 }
4013 else { /* no, expanding (or same) */
4014 if (length) {
4015 New(452, tmparyval, length, SV*); /* so remember deletion */
4016 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4017 }
4018
4019 if (diff > 0) { /* expanding */
4020
4021 /* push up or down? */
4022
4023 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4024 if (offset) {
4025 src = AvARRAY(ary);
4026 dst = src - diff;
4027 Move(src, dst, offset, SV*);
79072805 4028 }
a0d0e21e
LW		 4029 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4030 AvMAX(ary) += diff;
93965878 4031 AvFILLp(ary) += diff;
79072805
LW		 4032 }
4033 else {
93965878
NIS		 4034 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4035 av_extend(ary, AvFILLp(ary) + diff);
4036 AvFILLp(ary) += diff;
a0d0e21e
LW		 4037
4038 if (after) {
93965878 4039 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 4040 src = dst - diff;
4041 for (i = after; i; i--) {
4042 *dst-- = *src--;
4043 }
79072805
LW		 4044 }
4045 }
a0d0e21e
LW		 4046 }
4047
4048 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4049 *dst = NEWSV(46, 0);
4050 sv_setsv(*dst++, *src++);
4051 }
4052 MARK = ORIGMARK + 1;
4053 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4054 if (length) {
4055 Copy(tmparyval, MARK, length, SV*);
4056 if (AvREAL(ary)) {
bbce6d69 4057 EXTEND_MORTAL(length);
36477c24 4058 for (i = length, dst = MARK; i; i--) {
d689ffdd 4059 sv_2mortal(*dst); /* free them eventualy */
36477c24 4060 dst++;
4061 }
79072805 4062 }
a0d0e21e 4063 Safefree(tmparyval);
79072805 4064 }
a0d0e21e
LW		 4065 MARK += length - 1;
4066 }
4067 else if (length--) {
4068 *MARK = tmparyval[length];
4069 if (AvREAL(ary)) {
d689ffdd 4070 sv_2mortal(*MARK);
a0d0e21e
LW		 4071 while (length-- > 0)
4072 SvREFCNT_dec(tmparyval[length]);
79072805 4073 }
a0d0e21e 4074 Safefree(tmparyval);
79072805 4075 }
a0d0e21e 4076 else
3280af22 4077 *MARK = &PL_sv_undef;
79072805 4078 }
a0d0e21e 4079 SP = MARK;
79072805
LW		 4080 RETURN;
4081}
4082
a0d0e21e 4083PP(pp_push)
79072805 4084{
39644a26 4085 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4086 register AV *ary = (AV*)*++MARK;
3280af22 4087 register SV *sv = &PL_sv_undef;
93965878 4088 MAGIC *mg;
79072805 4089
14befaf4 4090 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4091 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS		 4092 PUSHMARK(MARK);
4093 PUTBACK;
a60c0954 4094 ENTER;
864dbfa3 4095 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 4096 LEAVE;
93965878 4097 SPAGAIN;
93965878 4098 }
a60c0954
NIS		 4099 else {
4100 /* Why no pre-extend of ary here ? */
4101 for (++MARK; MARK <= SP; MARK++) {
4102 sv = NEWSV(51, 0);
4103 if (*MARK)
4104 sv_setsv(sv, *MARK);
4105 av_push(ary, sv);
4106 }
79072805
LW		 4107 }
4108 SP = ORIGMARK;
a0d0e21e 4109 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 4110 RETURN;
4111}
4112
a0d0e21e 4113PP(pp_pop)
79072805 4114{
39644a26 4115 dSP;
a0d0e21e
LW		 4116 AV *av = (AV*)POPs;
4117 SV *sv = av_pop(av);
d689ffdd 4118 if (AvREAL(av))
a0d0e21e
LW		 4119 (void)sv_2mortal(sv);
4120 PUSHs(sv);
79072805 4121 RETURN;
79072805
LW		 4122}
4123
a0d0e21e 4124PP(pp_shift)
79072805 4125{
39644a26 4126 dSP;
a0d0e21e
LW		 4127 AV *av = (AV*)POPs;
4128 SV *sv = av_shift(av);
79072805 4129 EXTEND(SP, 1);
a0d0e21e 4130 if (!sv)
79072805 4131 RETPUSHUNDEF;
d689ffdd 4132 if (AvREAL(av))
a0d0e21e
LW		 4133 (void)sv_2mortal(sv);
4134 PUSHs(sv);
79072805 4135 RETURN;
79072805
LW		 4136}
4137
a0d0e21e 4138PP(pp_unshift)
79072805 4139{
39644a26 4140 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4141 register AV *ary = (AV*)*++MARK;
4142 register SV *sv;
4143 register I32 i = 0;
93965878
NIS		 4144 MAGIC *mg;
4145
14befaf4 4146 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4147 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 4148 PUSHMARK(MARK);
93965878 4149 PUTBACK;
a60c0954 4150 ENTER;
864dbfa3 4151 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 4152 LEAVE;
93965878 4153 SPAGAIN;
93965878 4154 }
a60c0954
NIS		 4155 else {
4156 av_unshift(ary, SP - MARK);
4157 while (MARK < SP) {
4158 sv = NEWSV(27, 0);
4159 sv_setsv(sv, *++MARK);
4160 (void)av_store(ary, i++, sv);
4161 }
79072805 4162 }
a0d0e21e
LW		 4163 SP = ORIGMARK;
4164 PUSHi( AvFILL(ary) + 1 );
79072805 4165 RETURN;
79072805
LW		 4166}
4167
a0d0e21e 4168PP(pp_reverse)
79072805 4169{
39644a26 4170 dSP; dMARK;
a0d0e21e
LW		 4171 register SV *tmp;
4172 SV **oldsp = SP;
79072805 4173
a0d0e21e
LW		 4174 if (GIMME == G_ARRAY) {
4175 MARK++;
4176 while (MARK < SP) {
4177 tmp = *MARK;
4178 *MARK++ = *SP;
4179 *SP-- = tmp;
4180 }
dd58a1ab 4181 /* safe as long as stack cannot get extended in the above */
a0d0e21e 4182 SP = oldsp;
79072805
LW		 4183 }
4184 else {
a0d0e21e
LW		 4185 register char *up;
4186 register char *down;
4187 register I32 tmp;
4188 dTARGET;
4189 STRLEN len;
79072805 4190
7e2040f0 4191 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4192 if (SP - MARK > 1)
3280af22 4193 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 4194 else
54b9620d 4195 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW		 4196 up = SvPV_force(TARG, len);
4197 if (len > 1) {
7e2040f0 4198 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55
GS		 4199 U8* s = (U8*)SvPVX(TARG);
4200 U8* send = (U8*)(s + len);
a0ed51b3 4201 while (s < send) {
d742c382 4202 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 4203 s++;
4204 continue;
4205 }
4206 else {
9041c2e3 4207 if (!utf8_to_uvchr(s, 0))
a0dbb045 4208 break;
dfe13c55 4209 up = (char*)s;
a0ed51b3 4210 s += UTF8SKIP(s);
dfe13c55 4211 down = (char*)(s - 1);
a0dbb045 4212 /* reverse this character */
a0ed51b3
LW		 4213 while (down > up) {
4214 tmp = *up;
4215 *up++ = *down;
4216 *down-- = tmp;
4217 }
4218 }
4219 }
4220 up = SvPVX(TARG);
4221 }
a0d0e21e
LW		 4222 down = SvPVX(TARG) + len - 1;
4223 while (down > up) {
4224 tmp = *up;
4225 *up++ = *down;
4226 *down-- = tmp;
4227 }
3aa33fe5 4228 (void)SvPOK_only_UTF8(TARG);
79072805 4229 }
a0d0e21e
LW		 4230 SP = MARK + 1;
4231 SETTARG;
79072805 4232 }
a0d0e21e 4233 RETURN;
79072805
LW		 4234}
4235
a0d0e21e 4236PP(pp_split)
79072805 4237{
39644a26 4238 dSP; dTARG;
a0d0e21e 4239 AV *ary;
467f0320 4240 register IV limit = POPi; /* note, negative is forever */
a0d0e21e
LW		 4241 SV *sv = POPs;
4242 STRLEN len;
4243 register char *s = SvPV(sv, len);
1aa99e6b 4244 bool do_utf8 = DO_UTF8(sv);
a0d0e21e 4245 char *strend = s + len;
44a8e56a 4246 register PMOP *pm;
d9f97599 4247 register REGEXP *rx;
a0d0e21e
LW		 4248 register SV *dstr;
4249 register char *m;
4250 I32 iters = 0;
792b2c16
JH		 4251 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4252 I32 maxiters = slen + 10;
a0d0e21e
LW		 4253 I32 i;
4254 char *orig;
4255 I32 origlimit = limit;
4256 I32 realarray = 0;
4257 I32 base;
3280af22 4258 AV *oldstack = PL_curstack;
54310121 4259 I32 gimme = GIMME_V;
3280af22 4260 I32 oldsave = PL_savestack_ix;
8ec5e241
NIS		 4261 I32 make_mortal = 1;
4262 MAGIC *mg = (MAGIC *) NULL;
79072805 4263
44a8e56a 4264#ifdef DEBUGGING
4265 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4266#else
4267 pm = (PMOP*)POPs;
4268#endif
a0d0e21e 4269 if (!pm || !s)
2269b42e 4270 DIE(aTHX_ "panic: pp_split");
aaa362c4 4271 rx = PM_GETRE(pm);
bbce6d69 4272
4273 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4274 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4275
53c4c00c 4276 PL_reg_match_utf8 = do_utf8;
d9f424b2 4277
971a9dd3
GS		 4278 if (pm->op_pmreplroot) {
4279#ifdef USE_ITHREADS
cbfa9890 4280 ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
971a9dd3 4281#else
a0d0e21e 4282 ary = GvAVn((GV*)pm->op_pmreplroot);
971a9dd3
GS		 4283#endif
4284 }
a0d0e21e 4285 else if (gimme != G_ARRAY)
4d1ff10f 4286#ifdef USE_5005THREADS
533c011a 4287 ary = (AV*)PL_curpad[0];
6d4ff0d2 4288#else
3280af22 4289 ary = GvAVn(PL_defgv);
4d1ff10f 4290#endif /* USE_5005THREADS */
79072805 4291 else
a0d0e21e
LW		 4292 ary = Nullav;
4293 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4294 realarray = 1;
8ec5e241 4295 PUTBACK;
a0d0e21e
LW		 4296 av_extend(ary,0);
4297 av_clear(ary);
8ec5e241 4298 SPAGAIN;
14befaf4 4299 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
8ec5e241 4300 PUSHMARK(SP);
33c27489 4301 XPUSHs(SvTIED_obj((SV*)ary, mg));
8ec5e241
NIS		 4302 }
4303 else {
1c0b011c
NIS		 4304 if (!AvREAL(ary)) {
4305 AvREAL_on(ary);
abff13bb 4306 AvREIFY_off(ary);
1c0b011c 4307 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 4308 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 4309 }
4310 /* temporarily switch stacks */
3280af22 4311 SWITCHSTACK(PL_curstack, ary);
8ec5e241 4312 make_mortal = 0;
1c0b011c 4313 }
79072805 4314 }
3280af22 4315 base = SP - PL_stack_base;
a0d0e21e
LW		 4316 orig = s;
4317 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 4318 if (pm->op_pmflags & PMf_LOCALE) {
4319 while (isSPACE_LC(*s))
4320 s++;
4321 }
4322 else {
4323 while (isSPACE(*s))
4324 s++;
4325 }
a0d0e21e 4326 }
c07a80fd 4327 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS		 4328 SAVEINT(PL_multiline);
4329 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
c07a80fd 4330 }
4331
a0d0e21e
LW		 4332 if (!limit)
4333 limit = maxiters + 2;
4334 if (pm->op_pmflags & PMf_WHITE) {
4335 while (--limit) {
bbce6d69 4336 m = s;
4337 while (m < strend &&
4338 !((pm->op_pmflags & PMf_LOCALE)
4339 ? isSPACE_LC(*m) : isSPACE(*m)))
4340 ++m;
a0d0e21e
LW		 4341 if (m >= strend)
4342 break;
bbce6d69 4343
a0d0e21e
LW		 4344 dstr = NEWSV(30, m-s);
4345 sv_setpvn(dstr, s, m-s);
8ec5e241 4346 if (make_mortal)
a0d0e21e 4347 sv_2mortal(dstr);
792b2c16 4348 if (do_utf8)
28cb3359 4349 (void)SvUTF8_on(dstr);
a0d0e21e 4350 XPUSHs(dstr);
bbce6d69 4351
4352 s = m + 1;
4353 while (s < strend &&
4354 ((pm->op_pmflags & PMf_LOCALE)
4355 ? isSPACE_LC(*s) : isSPACE(*s)))
4356 ++s;
79072805
LW		 4357 }
4358 }
f4091fba 4359 else if (strEQ("^", rx->precomp)) {
a0d0e21e
LW		 4360 while (--limit) {
4361 /*SUPPRESS 530*/
4362 for (m = s; m < strend && *m != '\n'; m++) ;
4363 m++;
4364 if (m >= strend)
4365 break;
4366 dstr = NEWSV(30, m-s);
4367 sv_setpvn(dstr, s, m-s);
8ec5e241 4368 if (make_mortal)
a0d0e21e 4369 sv_2mortal(dstr);
792b2c16 4370 if (do_utf8)
28cb3359 4371 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4372 XPUSHs(dstr);
4373 s = m;
4374 }
4375 }
699c3c34
JH		 4376 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4377 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
d9f97599
GS		 4378 && (rx->reganch & ROPT_CHECK_ALL)
4379 && !(rx->reganch & ROPT_ANCH)) {
f722798b
IZ		 4380 int tail = (rx->reganch & RE_INTUIT_TAIL);
4381 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
cf93c79d 4382
ca5b42cb 4383 len = rx->minlen;
1aa99e6b 4384 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
93f04dac
JH		 4385 STRLEN n_a;
4386 char c = *SvPV(csv, n_a);
a0d0e21e 4387 while (--limit) {
bbce6d69 4388 /*SUPPRESS 530*/
f722798b 4389 for (m = s; m < strend && *m != c; m++) ;
a0d0e21e
LW		 4390 if (m >= strend)
4391 break;
4392 dstr = NEWSV(30, m-s);
4393 sv_setpvn(dstr, s, m-s);
8ec5e241 4394 if (make_mortal)
a0d0e21e 4395 sv_2mortal(dstr);
792b2c16 4396 if (do_utf8)
28cb3359 4397 (void)SvUTF8_on(dstr);
a0d0e21e 4398 XPUSHs(dstr);
93f04dac
JH		 4399 /* The rx->minlen is in characters but we want to step
4400 * s ahead by bytes. */
1aa99e6b
IH		 4401 if (do_utf8)
4402 s = (char*)utf8_hop((U8*)m, len);
4403 else
4404 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 4405 }
4406 }
4407 else {
4408#ifndef lint
4409 while (s < strend && --limit &&
f722798b
IZ		 4410 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4411 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
79072805 4412#endif
a0d0e21e
LW		 4413 {
4414 dstr = NEWSV(31, m-s);
4415 sv_setpvn(dstr, s, m-s);
8ec5e241 4416 if (make_mortal)
a0d0e21e 4417 sv_2mortal(dstr);
792b2c16 4418 if (do_utf8)
28cb3359 4419 (void)SvUTF8_on(dstr);
a0d0e21e 4420 XPUSHs(dstr);
93f04dac
JH		 4421 /* The rx->minlen is in characters but we want to step
4422 * s ahead by bytes. */
1aa99e6b
IH		 4423 if (do_utf8)
4424 s = (char*)utf8_hop((U8*)m, len);
4425 else
4426 s = m + len; /* Fake \n at the end */
a0d0e21e 4427 }
463ee0b2 4428 }
463ee0b2 4429 }
a0d0e21e 4430 else {
792b2c16 4431 maxiters += slen * rx->nparens;
f722798b 4432 while (s < strend && --limit
b13b2135 4433/* && (!rx->check_substr
f722798b
IZ		 4434 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
4435 0, NULL))))
4436*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
4437 1 /* minend */, sv, NULL, 0))
bbce6d69 4438 {
d9f97599 4439 TAINT_IF(RX_MATCH_TAINTED(rx));
cf93c79d 4440 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 4441 m = s;
4442 s = orig;
cf93c79d 4443 orig = rx->subbeg;
a0d0e21e
LW		 4444 s = orig + (m - s);
4445 strend = s + (strend - m);
4446 }
cf93c79d 4447 m = rx->startp[0] + orig;
a0d0e21e
LW		 4448 dstr = NEWSV(32, m-s);
4449 sv_setpvn(dstr, s, m-s);
8ec5e241 4450 if (make_mortal)
a0d0e21e 4451 sv_2mortal(dstr);
792b2c16 4452 if (do_utf8)
28cb3359 4453 (void)SvUTF8_on(dstr);
a0d0e21e 4454 XPUSHs(dstr);
d9f97599
GS		 4455 if (rx->nparens) {
4456 for (i = 1; i <= rx->nparens; i++) {
cf93c79d
IZ		 4457 s = rx->startp[i] + orig;
4458 m = rx->endp[i] + orig;
6de67870
JP		 4459
4460 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4461 parens that didn't match -- they should be set to
4462 undef, not the empty string */
4463 if (m >= orig && s >= orig) {
748a9306
LW		 4464 dstr = NEWSV(33, m-s);
4465 sv_setpvn(dstr, s, m-s);
4466 }
4467 else
6de67870 4468 dstr = &PL_sv_undef; /* undef, not "" */
8ec5e241 4469 if (make_mortal)
a0d0e21e 4470 sv_2mortal(dstr);
792b2c16 4471 if (do_utf8)
28cb3359 4472 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4473 XPUSHs(dstr);
4474 }
4475 }
cf93c79d 4476 s = rx->endp[0] + orig;
a0d0e21e 4477 }
79072805 4478 }
8ec5e241 4479
c07a80fd 4480 LEAVE_SCOPE(oldsave);
3280af22 4481 iters = (SP - PL_stack_base) - base;
a0d0e21e 4482 if (iters > maxiters)
cea2e8a9 4483 DIE(aTHX_ "Split loop");
8ec5e241 4484
a0d0e21e
LW		 4485 /* keep field after final delim? */
4486 if (s < strend || (iters && origlimit)) {
93f04dac
JH		 4487 STRLEN l = strend - s;
4488 dstr = NEWSV(34, l);
4489 sv_setpvn(dstr, s, l);
8ec5e241 4490 if (make_mortal)
a0d0e21e 4491 sv_2mortal(dstr);
792b2c16 4492 if (do_utf8)
28cb3359 4493 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4494 XPUSHs(dstr);
4495 iters++;
79072805 4496 }
a0d0e21e 4497 else if (!origlimit) {
b1dadf13 4498 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
a0d0e21e
LW		 4499 iters--, SP--;
4500 }
8ec5e241 4501
a0d0e21e 4502 if (realarray) {
8ec5e241 4503 if (!mg) {
1c0b011c
NIS		 4504 SWITCHSTACK(ary, oldstack);
4505 if (SvSMAGICAL(ary)) {
4506 PUTBACK;
4507 mg_set((SV*)ary);
4508 SPAGAIN;
4509 }
4510 if (gimme == G_ARRAY) {
4511 EXTEND(SP, iters);
4512 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4513 SP += iters;
4514 RETURN;
4515 }
8ec5e241 4516 }
1c0b011c 4517 else {
fb73857a 4518 PUTBACK;
8ec5e241 4519 ENTER;
864dbfa3 4520 call_method("PUSH",G_SCALAR|G_DISCARD);
8ec5e241 4521 LEAVE;
fb73857a 4522 SPAGAIN;
8ec5e241
NIS		 4523 if (gimme == G_ARRAY) {
4524 /* EXTEND should not be needed - we just popped them */
4525 EXTEND(SP, iters);
4526 for (i=0; i < iters; i++) {
4527 SV **svp = av_fetch(ary, i, FALSE);
3280af22 4528 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 4529 }
1c0b011c
NIS		 4530 RETURN;
4531 }
a0d0e21e
LW		 4532 }
4533 }
4534 else {
4535 if (gimme == G_ARRAY)
4536 RETURN;
4537 }
4538 if (iters || !pm->op_pmreplroot) {
4539 GETTARGET;
4540 PUSHi(iters);
4541 RETURN;
4542 }
4543 RETPUSHUNDEF;
79072805 4544}
85e6fe83 4545
4d1ff10f 4546#ifdef USE_5005THREADS
77a005ab 4547void
864dbfa3 4548Perl_unlock_condpair(pTHX_ void *svv)
c0329465 4549{
14befaf4 4550 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
8ec5e241 4551
c0329465 4552 if (!mg)
cea2e8a9 4553 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
c0329465
MB		 4554 MUTEX_LOCK(MgMUTEXP(mg));
4555 if (MgOWNER(mg) != thr)
cea2e8a9 4556 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
c0329465
MB		 4557 MgOWNER(mg) = 0;
4558 COND_SIGNAL(MgOWNERCONDP(mg));
b900a521 4559 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
a674cc95 4560 PTR2UV(thr), PTR2UV(svv)));
c0329465
MB		 4561 MUTEX_UNLOCK(MgMUTEXP(mg));
4562}
4d1ff10f 4563#endif /* USE_5005THREADS */
c0329465
MB		 4564
4565PP(pp_lock)
4566{
39644a26 4567 dSP;
c0329465 4568 dTOPss;
e55aaa0e 4569 SV *retsv = sv;
68795e93 4570 SvLOCK(sv);
e55aaa0e
MB		 4571 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4572 || SvTYPE(retsv) == SVt_PVCV) {
4573 retsv = refto(retsv);
4574 }
4575 SETs(retsv);
c0329465
MB		 4576 RETURN;
4577}
a863c7d1 4578
2faa37cc 4579PP(pp_threadsv)
a863c7d1 4580{
4d1ff10f 4581#ifdef USE_5005THREADS
39644a26 4582 dSP;
924508f0 4583 EXTEND(SP, 1);
533c011a
NIS		 4584 if (PL_op->op_private & OPpLVAL_INTRO)
4585 PUSHs(*save_threadsv(PL_op->op_targ));
554b3eca 4586 else
533c011a 4587 PUSHs(THREADSV(PL_op->op_targ));
fdb47d66 4588 RETURN;
a863c7d1 4589#else
cea2e8a9 4590 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4d1ff10f 4591#endif /* USE_5005THREADS */
a863c7d1 4592}
Unnamed repository; edit this file 'description' to name the repository.