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