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
myconfig.SH
[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) {
243d6ab3 109 SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
85e6fe83 110 SETs(sv);
85e6fe83 111 }
54310121 112 RETURN;
93a17b20
LW		 113}
114
ed6116ce
LW		 115PP(pp_padany)
116{
cea2e8a9 117 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
ed6116ce
LW		 118}
119
79072805
LW		 120/* Translations. */
121
122PP(pp_rv2gv)
123{
39644a26 124 dSP; dTOPss;
8ec5e241 125
ed6116ce 126 if (SvROK(sv)) {
a0d0e21e 127 wasref:
f5284f61
IZ		 128 tryAMAGICunDEREF(to_gv);
129
ed6116ce 130 sv = SvRV(sv);
b1dadf13 131 if (SvTYPE(sv) == SVt_PVIO) {
132 GV *gv = (GV*) sv_newmortal();
133 gv_init(gv, 0, "", 0, 0);
134 GvIOp(gv) = (IO *)sv;
3e3baf6d 135 (void)SvREFCNT_inc(sv);
b1dadf13 136 sv = (SV*) gv;
ef54e1a4
JH		 137 }
138 else if (SvTYPE(sv) != SVt_PVGV)
cea2e8a9 139 DIE(aTHX_ "Not a GLOB reference");
79072805
LW		 140 }
141 else {
93a17b20 142 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 143 char *sym;
c9d5ac95 144 STRLEN len;
748a9306 145
a0d0e21e
LW		 146 if (SvGMAGICAL(sv)) {
147 mg_get(sv);
148 if (SvROK(sv))
149 goto wasref;
150 }
afd1915d 151 if (!SvOK(sv) && sv != &PL_sv_undef) {
b13b2135 152 /* If this is a 'my' scalar and flag is set then vivify
853846ea 153 * NI-S 1999/05/07
b13b2135 154 */
1d8d4d2a 155 if (PL_op->op_private & OPpDEREF) {
2c8ac474
GS		 156 char *name;
157 GV *gv;
158 if (cUNOP->op_targ) {
159 STRLEN len;
dd2155a4 160 SV *namesv = PAD_SV(cUNOP->op_targ);
2c8ac474 161 name = SvPV(namesv, len);
2d6d9f7a 162 gv = (GV*)NEWSV(0,0);
2c8ac474
GS		 163 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
164 }
165 else {
166 name = CopSTASHPV(PL_curcop);
167 gv = newGVgen(name);
1d8d4d2a 168 }
b13b2135
NIS		 169 if (SvTYPE(sv) < SVt_RV)
170 sv_upgrade(sv, SVt_RV);
2c8ac474 171 SvRV(sv) = (SV*)gv;
853846ea 172 SvROK_on(sv);
1d8d4d2a 173 SvSETMAGIC(sv);
853846ea 174 goto wasref;
2c8ac474 175 }
533c011a
NIS		 176 if (PL_op->op_flags & OPf_REF ||
177 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 178 DIE(aTHX_ PL_no_usym, "a symbol");
599cee73 179 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 180 report_uninit();
a0d0e21e
LW		 181 RETSETUNDEF;
182 }
c9d5ac95 183 sym = SvPV(sv,len);
35cd451c
GS		 184 if ((PL_op->op_flags & OPf_SPECIAL) &&
185 !(PL_op->op_flags & OPf_MOD))
186 {
187 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
c9d5ac95
GS		 188 if (!sv
189 && (!is_gv_magical(sym,len,0)
190 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
191 {
35cd451c 192 RETSETUNDEF;
c9d5ac95 193 }
35cd451c
GS		 194 }
195 else {
196 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 197 DIE(aTHX_ PL_no_symref, sym, "a symbol");
35cd451c
GS		 198 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
199 }
93a17b20 200 }
79072805 201 }
533c011a
NIS		 202 if (PL_op->op_private & OPpLVAL_INTRO)
203 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
79072805
LW		 204 SETs(sv);
205 RETURN;
206}
207
79072805
LW		 208PP(pp_rv2sv)
209{
82d03984 210 GV *gv = Nullgv;
39644a26 211 dSP; dTOPss;
79072805 212
ed6116ce 213 if (SvROK(sv)) {
a0d0e21e 214 wasref:
f5284f61
IZ		 215 tryAMAGICunDEREF(to_sv);
216
ed6116ce 217 sv = SvRV(sv);
79072805
LW		 218 switch (SvTYPE(sv)) {
219 case SVt_PVAV:
220 case SVt_PVHV:
221 case SVt_PVCV:
cea2e8a9 222 DIE(aTHX_ "Not a SCALAR reference");
79072805
LW		 223 }
224 }
225 else {
748a9306 226 char *sym;
c9d5ac95 227 STRLEN len;
82d03984 228 gv = (GV*)sv;
748a9306 229
463ee0b2 230 if (SvTYPE(gv) != SVt_PVGV) {
a0d0e21e
LW		 231 if (SvGMAGICAL(sv)) {
232 mg_get(sv);
233 if (SvROK(sv))
234 goto wasref;
235 }
236 if (!SvOK(sv)) {
533c011a
NIS		 237 if (PL_op->op_flags & OPf_REF ||
238 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 239 DIE(aTHX_ PL_no_usym, "a SCALAR");
599cee73 240 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 241 report_uninit();
a0d0e21e
LW		 242 RETSETUNDEF;
243 }
c9d5ac95 244 sym = SvPV(sv, len);
35cd451c
GS		 245 if ((PL_op->op_flags & OPf_SPECIAL) &&
246 !(PL_op->op_flags & OPf_MOD))
247 {
248 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
c9d5ac95
GS		 249 if (!gv
250 && (!is_gv_magical(sym,len,0)
251 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
252 {
35cd451c 253 RETSETUNDEF;
c9d5ac95 254 }
35cd451c
GS		 255 }
256 else {
257 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 258 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
35cd451c
GS		 259 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
260 }
463ee0b2
LW		 261 }
262 sv = GvSV(gv);
a0d0e21e 263 }
533c011a 264 if (PL_op->op_flags & OPf_MOD) {
82d03984
RGS		 265 if (PL_op->op_private & OPpLVAL_INTRO) {
266 if (cUNOP->op_first->op_type == OP_NULL)
267 sv = save_scalar((GV*)TOPs);
268 else if (gv)
269 sv = save_scalar(gv);
270 else
271 Perl_croak(aTHX_ PL_no_localize_ref);
272 }
533c011a
NIS		 273 else if (PL_op->op_private & OPpDEREF)
274 vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 275 }
a0d0e21e 276 SETs(sv);
79072805
LW		 277 RETURN;
278}
279
280PP(pp_av2arylen)
281{
39644a26 282 dSP;
79072805
LW		 283 AV *av = (AV*)TOPs;
284 SV *sv = AvARYLEN(av);
285 if (!sv) {
286 AvARYLEN(av) = sv = NEWSV(0,0);
287 sv_upgrade(sv, SVt_IV);
14befaf4 288 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
79072805
LW		 289 }
290 SETs(sv);
291 RETURN;
292}
293
a0d0e21e
LW		 294PP(pp_pos)
295{
39644a26 296 dSP; dTARGET; dPOPss;
8ec5e241 297
78f9721b 298 if (PL_op->op_flags & OPf_MOD || LVRET) {
5f05dabc 299 if (SvTYPE(TARG) < SVt_PVLV) {
300 sv_upgrade(TARG, SVt_PVLV);
14befaf4 301 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
5f05dabc 302 }
303
304 LvTYPE(TARG) = '.';
6ff81951
GS		 305 if (LvTARG(TARG) != sv) {
306 if (LvTARG(TARG))
307 SvREFCNT_dec(LvTARG(TARG));
308 LvTARG(TARG) = SvREFCNT_inc(sv);
309 }
a0d0e21e
LW		 310 PUSHs(TARG); /* no SvSETMAGIC */
311 RETURN;
312 }
313 else {
8ec5e241 314 MAGIC* mg;
a0d0e21e
LW		 315
316 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
14befaf4 317 mg = mg_find(sv, PERL_MAGIC_regex_global);
565764a8 318 if (mg && mg->mg_len >= 0) {
a0ed51b3 319 I32 i = mg->mg_len;
7e2040f0 320 if (DO_UTF8(sv))
a0ed51b3
LW		 321 sv_pos_b2u(sv, &i);
322 PUSHi(i + PL_curcop->cop_arybase);
a0d0e21e
LW		 323 RETURN;
324 }
325 }
326 RETPUSHUNDEF;
327 }
328}
329
79072805
LW		 330PP(pp_rv2cv)
331{
39644a26 332 dSP;
79072805
LW		 333 GV *gv;
334 HV *stash;
8990e307 335
4633a7c4
LW		 336 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
337 /* (But not in defined().) */
533c011a 338 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
07055b4c
CS		 339 if (cv) {
340 if (CvCLONE(cv))
341 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
d32f2495
SC		 342 if ((PL_op->op_private & OPpLVAL_INTRO)) {
343 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
344 cv = GvCV(gv);
345 if (!CvLVALUE(cv))
346 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
347 }
07055b4c
CS		 348 }
349 else
3280af22 350 cv = (CV*)&PL_sv_undef;
79072805
LW		 351 SETs((SV*)cv);
352 RETURN;
353}
354
c07a80fd 355PP(pp_prototype)
356{
39644a26 357 dSP;
c07a80fd 358 CV *cv;
359 HV *stash;
360 GV *gv;
361 SV *ret;
362
3280af22 363 ret = &PL_sv_undef;
b6c543e3
IZ		 364 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
365 char *s = SvPVX(TOPs);
366 if (strnEQ(s, "CORE::", 6)) {
367 int code;
b13b2135 368
b6c543e3
IZ		 369 code = keyword(s + 6, SvCUR(TOPs) - 6);
370 if (code < 0) { /* Overridable. */
371#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
372 int i = 0, n = 0, seen_question = 0;
373 I32 oa;
374 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
375
77bc9082
RGS		 376 if (code == -KEY_chop || code == -KEY_chomp)
377 goto set;
b6c543e3 378 while (i < MAXO) { /* The slow way. */
22c35a8c
GS		 379 if (strEQ(s + 6, PL_op_name[i])
380 || strEQ(s + 6, PL_op_desc[i]))
381 {
b6c543e3 382 goto found;
22c35a8c 383 }
b6c543e3
IZ		 384 i++;
385 }
386 goto nonesuch; /* Should not happen... */
387 found:
22c35a8c 388 oa = PL_opargs[i] >> OASHIFT;
b6c543e3 389 while (oa) {
3012a639 390 if (oa & OA_OPTIONAL && !seen_question) {
b6c543e3
IZ		 391 seen_question = 1;
392 str[n++] = ';';
ef54e1a4 393 }
b13b2135 394 else if (n && str[0] == ';' && seen_question)
b6c543e3 395 goto set; /* XXXX system, exec */
b13b2135 396 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
6e97e420
SC		 397 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
398 /* But globs are already references (kinda) */
399 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
400 ) {
b6c543e3
IZ		 401 str[n++] = '\\';
402 }
b6c543e3
IZ		 403 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
404 oa = oa >> 4;
405 }
406 str[n++] = '\0';
79cb57f6 407 ret = sv_2mortal(newSVpvn(str, n - 1));
ef54e1a4
JH		 408 }
409 else if (code) /* Non-Overridable */
b6c543e3
IZ		 410 goto set;
411 else { /* None such */
412 nonesuch:
d470f89e 413 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
b6c543e3
IZ		 414 }
415 }
416 }
c07a80fd 417 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
5f05dabc 418 if (cv && SvPOK(cv))
79cb57f6 419 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
b6c543e3 420 set:
c07a80fd 421 SETs(ret);
422 RETURN;
423}
424
a0d0e21e
LW		 425PP(pp_anoncode)
426{
39644a26 427 dSP;
dd2155a4 428 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
a5f75d66 429 if (CvCLONE(cv))
b355b4e0 430 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
5f05dabc 431 EXTEND(SP,1);
748a9306 432 PUSHs((SV*)cv);
a0d0e21e
LW		 433 RETURN;
434}
435
436PP(pp_srefgen)
79072805 437{
39644a26 438 dSP;
71be2cbc 439 *SP = refto(*SP);
79072805 440 RETURN;
8ec5e241 441}
a0d0e21e
LW		 442
443PP(pp_refgen)
444{
39644a26 445 dSP; dMARK;
a0d0e21e 446 if (GIMME != G_ARRAY) {
5f0b1d4e
GS		 447 if (++MARK <= SP)
448 *MARK = *SP;
449 else
3280af22 450 *MARK = &PL_sv_undef;
5f0b1d4e
GS		 451 *MARK = refto(*MARK);
452 SP = MARK;
453 RETURN;
a0d0e21e 454 }
bbce6d69 455 EXTEND_MORTAL(SP - MARK);
71be2cbc 456 while (++MARK <= SP)
457 *MARK = refto(*MARK);
a0d0e21e 458 RETURN;
79072805
LW		 459}
460
76e3520e 461STATIC SV*
cea2e8a9 462S_refto(pTHX_ SV *sv)
71be2cbc 463{
464 SV* rv;
465
466 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
467 if (LvTARGLEN(sv))
68dc0745 468 vivify_defelem(sv);
469 if (!(sv = LvTARG(sv)))
3280af22 470 sv = &PL_sv_undef;
0dd88869 471 else
a6c40364 472 (void)SvREFCNT_inc(sv);
71be2cbc 473 }
d8b46c1b
GS		 474 else if (SvTYPE(sv) == SVt_PVAV) {
475 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
476 av_reify((AV*)sv);
477 SvTEMP_off(sv);
478 (void)SvREFCNT_inc(sv);
479 }
f2933f5f
DM		 480 else if (SvPADTMP(sv) && !IS_PADGV(sv))
481 sv = newSVsv(sv);
71be2cbc 482 else {
483 SvTEMP_off(sv);
484 (void)SvREFCNT_inc(sv);
485 }
486 rv = sv_newmortal();
487 sv_upgrade(rv, SVt_RV);
488 SvRV(rv) = sv;
489 SvROK_on(rv);
490 return rv;
491}
492
79072805
LW		 493PP(pp_ref)
494{
39644a26 495 dSP; dTARGET;
463ee0b2 496 SV *sv;
79072805
LW		 497 char *pv;
498
a0d0e21e 499 sv = POPs;
f12c7020 500
501 if (sv && SvGMAGICAL(sv))
8ec5e241 502 mg_get(sv);
f12c7020 503
a0d0e21e 504 if (!sv || !SvROK(sv))
4633a7c4 505 RETPUSHNO;
79072805 506
ed6116ce 507 sv = SvRV(sv);
a0d0e21e 508 pv = sv_reftype(sv,TRUE);
463ee0b2 509 PUSHp(pv, strlen(pv));
79072805
LW		 510 RETURN;
511}
512
513PP(pp_bless)
514{
39644a26 515 dSP;
463ee0b2 516 HV *stash;
79072805 517
463ee0b2 518 if (MAXARG == 1)
11faa288 519 stash = CopSTASH(PL_curcop);
7b8d334a
GS		 520 else {
521 SV *ssv = POPs;
522 STRLEN len;
81689caa
HS		 523 char *ptr;
524
016a42f3 525 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
81689caa
HS		 526 Perl_croak(aTHX_ "Attempt to bless into a reference");
527 ptr = SvPV(ssv,len);
e476b1b5 528 if (ckWARN(WARN_MISC) && len == 0)
9014280d 529 Perl_warner(aTHX_ packWARN(WARN_MISC),
599cee73 530 "Explicit blessing to '' (assuming package main)");
7b8d334a
GS		 531 stash = gv_stashpvn(ptr, len, TRUE);
532 }
a0d0e21e 533
5d3fdfeb 534 (void)sv_bless(TOPs, stash);
79072805
LW		 535 RETURN;
536}
537
fb73857a 538PP(pp_gelem)
539{
540 GV *gv;
541 SV *sv;
76e3520e 542 SV *tmpRef;
fb73857a 543 char *elem;
39644a26 544 dSP;
2d8e6c8d 545 STRLEN n_a;
b13b2135 546
fb73857a 547 sv = POPs;
2d8e6c8d 548 elem = SvPV(sv, n_a);
fb73857a 549 gv = (GV*)POPs;
76e3520e 550 tmpRef = Nullsv;
fb73857a 551 sv = Nullsv;
552 switch (elem ? *elem : '\0')
553 {
554 case 'A':
555 if (strEQ(elem, "ARRAY"))
76e3520e 556 tmpRef = (SV*)GvAV(gv);
fb73857a 557 break;
558 case 'C':
559 if (strEQ(elem, "CODE"))
76e3520e 560 tmpRef = (SV*)GvCVu(gv);
fb73857a 561 break;
562 case 'F':
39b99f21 563 if (strEQ(elem, "FILEHANDLE")) {
564 /* finally deprecated in 5.8.0 */
9014280d 565 deprecate("*glob{FILEHANDLE}");
76e3520e 566 tmpRef = (SV*)GvIOp(gv);
39b99f21 567 }
f4d13ee9
JH		 568 else
569 if (strEQ(elem, "FORMAT"))
570 tmpRef = (SV*)GvFORM(gv);
fb73857a 571 break;
572 case 'G':
573 if (strEQ(elem, "GLOB"))
76e3520e 574 tmpRef = (SV*)gv;
fb73857a 575 break;
576 case 'H':
577 if (strEQ(elem, "HASH"))
76e3520e 578 tmpRef = (SV*)GvHV(gv);
fb73857a 579 break;
580 case 'I':
581 if (strEQ(elem, "IO"))
76e3520e 582 tmpRef = (SV*)GvIOp(gv);
fb73857a 583 break;
584 case 'N':
585 if (strEQ(elem, "NAME"))
79cb57f6 586 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
fb73857a 587 break;
588 case 'P':
3fc84d6d
JH		 589 if (strEQ(elem, "PACKAGE")) {
590 if (HvNAME(GvSTASH(gv)))
591 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
592 else
593 sv = newSVpv("__ANON__",0);
594 }
fb73857a 595 break;
596 case 'S':
597 if (strEQ(elem, "SCALAR"))
76e3520e 598 tmpRef = GvSV(gv);
fb73857a 599 break;
600 }
76e3520e
GS		 601 if (tmpRef)
602 sv = newRV(tmpRef);
fb73857a 603 if (sv)
604 sv_2mortal(sv);
605 else
3280af22 606 sv = &PL_sv_undef;
fb73857a 607 XPUSHs(sv);
608 RETURN;
609}
610
a0d0e21e 611/* Pattern matching */
79072805 612
a0d0e21e 613PP(pp_study)
79072805 614{
39644a26 615 dSP; dPOPss;
a0d0e21e
LW		 616 register unsigned char *s;
617 register I32 pos;
618 register I32 ch;
619 register I32 *sfirst;
620 register I32 *snext;
a0d0e21e
LW		 621 STRLEN len;
622
3280af22 623 if (sv == PL_lastscream) {
1e422769 624 if (SvSCREAM(sv))
625 RETPUSHYES;
626 }
c07a80fd 627 else {
3280af22
NIS		 628 if (PL_lastscream) {
629 SvSCREAM_off(PL_lastscream);
630 SvREFCNT_dec(PL_lastscream);
c07a80fd 631 }
3280af22 632 PL_lastscream = SvREFCNT_inc(sv);
c07a80fd 633 }
1e422769 634
635 s = (unsigned char*)(SvPV(sv, len));
636 pos = len;
637 if (pos <= 0)
638 RETPUSHNO;
3280af22
NIS		 639 if (pos > PL_maxscream) {
640 if (PL_maxscream < 0) {
641 PL_maxscream = pos + 80;
642 New(301, PL_screamfirst, 256, I32);
643 New(302, PL_screamnext, PL_maxscream, I32);
79072805
LW		 644 }
645 else {
3280af22
NIS		 646 PL_maxscream = pos + pos / 4;
647 Renew(PL_screamnext, PL_maxscream, I32);
79072805 648 }
79072805 649 }
a0d0e21e 650
3280af22
NIS		 651 sfirst = PL_screamfirst;
652 snext = PL_screamnext;
a0d0e21e
LW		 653
654 if (!sfirst || !snext)
cea2e8a9 655 DIE(aTHX_ "do_study: out of memory");
a0d0e21e
LW		 656
657 for (ch = 256; ch; --ch)
658 *sfirst++ = -1;
659 sfirst -= 256;
660
661 while (--pos >= 0) {
662 ch = s[pos];
663 if (sfirst[ch] >= 0)
664 snext[pos] = sfirst[ch] - pos;
665 else
666 snext[pos] = -pos;
667 sfirst[ch] = pos;
79072805
LW		 668 }
669
c07a80fd 670 SvSCREAM_on(sv);
14befaf4
DM		 671 /* piggyback on m//g magic */
672 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
1e422769 673 RETPUSHYES;
79072805
LW		 674}
675
a0d0e21e 676PP(pp_trans)
79072805 677{
39644a26 678 dSP; dTARG;
a0d0e21e
LW		 679 SV *sv;
680
533c011a 681 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 682 sv = POPs;
79072805 683 else {
54b9620d 684 sv = DEFSV;
a0d0e21e 685 EXTEND(SP,1);
79072805 686 }
adbc6bb1 687 TARG = sv_newmortal();
4757a243 688 PUSHi(do_trans(sv));
a0d0e21e 689 RETURN;
79072805
LW		 690}
691
a0d0e21e 692/* Lvalue operators. */
79072805 693
a0d0e21e
LW		 694PP(pp_schop)
695{
39644a26 696 dSP; dTARGET;
a0d0e21e
LW		 697 do_chop(TARG, TOPs);
698 SETTARG;
699 RETURN;
79072805
LW		 700}
701
a0d0e21e 702PP(pp_chop)
79072805 703{
2ec6af5f
RG		 704 dSP; dMARK; dTARGET; dORIGMARK;
705 while (MARK < SP)
706 do_chop(TARG, *++MARK);
707 SP = ORIGMARK;
a0d0e21e
LW		 708 PUSHTARG;
709 RETURN;
79072805
LW		 710}
711
a0d0e21e 712PP(pp_schomp)
79072805 713{
39644a26 714 dSP; dTARGET;
a0d0e21e
LW		 715 SETi(do_chomp(TOPs));
716 RETURN;
79072805
LW		 717}
718
a0d0e21e 719PP(pp_chomp)
79072805 720{
39644a26 721 dSP; dMARK; dTARGET;
a0d0e21e 722 register I32 count = 0;
8ec5e241 723
a0d0e21e
LW		 724 while (SP > MARK)
725 count += do_chomp(POPs);
726 PUSHi(count);
727 RETURN;
79072805
LW		 728}
729
a0d0e21e 730PP(pp_defined)
463ee0b2 731{
39644a26 732 dSP;
a0d0e21e
LW		 733 register SV* sv;
734
735 sv = POPs;
736 if (!sv || !SvANY(sv))
737 RETPUSHNO;
738 switch (SvTYPE(sv)) {
739 case SVt_PVAV:
14befaf4
DM		 740 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
741 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
a0d0e21e
LW		 742 RETPUSHYES;
743 break;
744 case SVt_PVHV:
14befaf4
DM		 745 if (HvARRAY(sv) || SvGMAGICAL(sv)
746 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
a0d0e21e
LW		 747 RETPUSHYES;
748 break;
749 case SVt_PVCV:
750 if (CvROOT(sv) || CvXSUB(sv))
751 RETPUSHYES;
752 break;
753 default:
754 if (SvGMAGICAL(sv))
755 mg_get(sv);
756 if (SvOK(sv))
757 RETPUSHYES;
758 }
759 RETPUSHNO;
463ee0b2
LW		 760}
761
a0d0e21e
LW		 762PP(pp_undef)
763{
39644a26 764 dSP;
a0d0e21e
LW		 765 SV *sv;
766
533c011a 767 if (!PL_op->op_private) {
774d564b 768 EXTEND(SP, 1);
a0d0e21e 769 RETPUSHUNDEF;
774d564b 770 }
79072805 771
a0d0e21e
LW		 772 sv = POPs;
773 if (!sv)
774 RETPUSHUNDEF;
85e6fe83 775
765f542d 776 SV_CHECK_THINKFIRST_COW_DROP(sv);
85e6fe83 777
a0d0e21e
LW		 778 switch (SvTYPE(sv)) {
779 case SVt_NULL:
780 break;
781 case SVt_PVAV:
782 av_undef((AV*)sv);
783 break;
784 case SVt_PVHV:
785 hv_undef((HV*)sv);
786 break;
787 case SVt_PVCV:
e476b1b5 788 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
9014280d 789 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
54310121 790 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
9607fc9c 791 /* FALL THROUGH */
792 case SVt_PVFM:
6fc92669
GS		 793 {
794 /* let user-undef'd sub keep its identity */
65c50114 795 GV* gv = CvGV((CV*)sv);
6fc92669
GS		 796 cv_undef((CV*)sv);
797 CvGV((CV*)sv) = gv;
798 }
a0d0e21e 799 break;
8e07c86e 800 case SVt_PVGV:
44a8e56a 801 if (SvFAKE(sv))
3280af22 802 SvSetMagicSV(sv, &PL_sv_undef);
20408e3c
GS		 803 else {
804 GP *gp;
805 gp_free((GV*)sv);
806 Newz(602, gp, 1, GP);
807 GvGP(sv) = gp_ref(gp);
808 GvSV(sv) = NEWSV(72,0);
57843af0 809 GvLINE(sv) = CopLINE(PL_curcop);
20408e3c
GS		 810 GvEGV(sv) = (GV*)sv;
811 GvMULTI_on(sv);
812 }
44a8e56a 813 break;
a0d0e21e 814 default:
1e422769 815 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
4633a7c4
LW		 816 (void)SvOOK_off(sv);
817 Safefree(SvPVX(sv));
818 SvPV_set(sv, Nullch);
819 SvLEN_set(sv, 0);
a0d0e21e 820 }
4633a7c4
LW		 821 (void)SvOK_off(sv);
822 SvSETMAGIC(sv);
79072805 823 }
a0d0e21e
LW		 824
825 RETPUSHUNDEF;
79072805
LW		 826}
827
a0d0e21e 828PP(pp_predec)
79072805 829{
39644a26 830 dSP;
3510b4a1 831 if (SvTYPE(TOPs) > SVt_PVLV)
d470f89e 832 DIE(aTHX_ PL_no_modify);
3510b4a1
NC		 833 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
834 && SvIVX(TOPs) != IV_MIN)
55497cff 835 {
748a9306 836 --SvIVX(TOPs);
55497cff 837 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 838 }
839 else
840 sv_dec(TOPs);
a0d0e21e
LW		 841 SvSETMAGIC(TOPs);
842 return NORMAL;
843}
79072805 844
a0d0e21e
LW		 845PP(pp_postinc)
846{
39644a26 847 dSP; dTARGET;
3510b4a1 848 if (SvTYPE(TOPs) > SVt_PVLV)
d470f89e 849 DIE(aTHX_ PL_no_modify);
a0d0e21e 850 sv_setsv(TARG, TOPs);
3510b4a1
NC		 851 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
852 && SvIVX(TOPs) != IV_MAX)
55497cff 853 {
748a9306 854 ++SvIVX(TOPs);
55497cff 855 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 856 }
857 else
858 sv_inc(TOPs);
a0d0e21e 859 SvSETMAGIC(TOPs);
1e54a23f 860 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
a0d0e21e
LW		 861 if (!SvOK(TARG))
862 sv_setiv(TARG, 0);
863 SETs(TARG);
864 return NORMAL;
865}
79072805 866
a0d0e21e
LW		 867PP(pp_postdec)
868{
39644a26 869 dSP; dTARGET;
3510b4a1 870 if (SvTYPE(TOPs) > SVt_PVLV)
d470f89e 871 DIE(aTHX_ PL_no_modify);
a0d0e21e 872 sv_setsv(TARG, TOPs);
3510b4a1
NC		 873 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
874 && SvIVX(TOPs) != IV_MIN)
55497cff 875 {
748a9306 876 --SvIVX(TOPs);
55497cff 877 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 878 }
879 else
880 sv_dec(TOPs);
a0d0e21e
LW		 881 SvSETMAGIC(TOPs);
882 SETs(TARG);
883 return NORMAL;
884}
79072805 885
a0d0e21e
LW		 886/* Ordinary operators. */
887
888PP(pp_pow)
889{
52a96ae6 890 dSP; dATARGET;
58d76dfd 891#ifdef PERL_PRESERVE_IVUV
52a96ae6
HS		 892 bool is_int = 0;
893#endif
894 tryAMAGICbin(pow,opASSIGN);
895#ifdef PERL_PRESERVE_IVUV
896 /* For integer to integer power, we do the calculation by hand wherever
897 we're sure it is safe; otherwise we call pow() and try to convert to
898 integer afterwards. */
58d76dfd
JH		 899 {
900 SvIV_please(TOPm1s);
901 if (SvIOK(TOPm1s)) {
902 bool baseuok = SvUOK(TOPm1s);
903 UV baseuv;
904
905 if (baseuok) {
906 baseuv = SvUVX(TOPm1s);
907 } else {
908 IV iv = SvIVX(TOPm1s);
909 if (iv >= 0) {
910 baseuv = iv;
911 baseuok = TRUE; /* effectively it's a UV now */
912 } else {
913 baseuv = -iv; /* abs, baseuok == false records sign */
914 }
915 }
916 SvIV_please(TOPs);
917 if (SvIOK(TOPs)) {
918 UV power;
919
920 if (SvUOK(TOPs)) {
921 power = SvUVX(TOPs);
922 } else {
923 IV iv = SvIVX(TOPs);
924 if (iv >= 0) {
925 power = iv;
926 } else {
927 goto float_it; /* Can't do negative powers this way. */
928 }
929 }
52a96ae6
HS		 930 /* now we have integer ** positive integer. */
931 is_int = 1;
932
933 /* foo & (foo - 1) is zero only for a power of 2. */
58d76dfd 934 if (!(baseuv & (baseuv - 1))) {
52a96ae6 935 /* We are raising power-of-2 to a positive integer.
58d76dfd
JH		 936 The logic here will work for any base (even non-integer
937 bases) but it can be less accurate than
938 pow (base,power) or exp (power * log (base)) when the
939 intermediate values start to spill out of the mantissa.
940 With powers of 2 we know this can't happen.
941 And powers of 2 are the favourite thing for perl
942 programmers to notice ** not doing what they mean. */
943 NV result = 1.0;
944 NV base = baseuok ? baseuv : -(NV)baseuv;
945 int n = 0;
946
58d76dfd
JH		 947 for (; power; base *= base, n++) {
948 /* Do I look like I trust gcc with long longs here?
949 Do I hell. */
950 UV bit = (UV)1 << (UV)n;
951 if (power & bit) {
952 result *= base;
953 /* Only bother to clear the bit if it is set. */
52a96ae6 954 power -= bit;
90fcb902
CB		 955 /* Avoid squaring base again if we're done. */
956 if (power == 0) break;
58d76dfd
JH		 957 }
958 }
959 SP--;
960 SETn( result );
52a96ae6 961 SvIV_please(TOPs);
58d76dfd 962 RETURN;
52a96ae6
HS		 963 } else {
964 register unsigned int highbit = 8 * sizeof(UV);
965 register unsigned int lowbit = 0;
966 register unsigned int diff;
56c23875 967 bool odd_power = (bool)(power & 1);
52a96ae6
HS		 968 while ((diff = (highbit - lowbit) >> 1)) {
969 if (baseuv & ~((1 << (lowbit + diff)) - 1))
970 lowbit += diff;
971 else
972 highbit -= diff;
973 }
974 /* we now have baseuv < 2 ** highbit */
975 if (power * highbit <= 8 * sizeof(UV)) {
976 /* result will definitely fit in UV, so use UV math
977 on same algorithm as above */
978 register UV result = 1;
979 register UV base = baseuv;
980 register int n = 0;
981 for (; power; base *= base, n++) {
982 register UV bit = (UV)1 << (UV)n;
983 if (power & bit) {
984 result *= base;
985 power -= bit;
986 if (power == 0) break;
987 }
988 }
989 SP--;
0615a994 990 if (baseuok || !odd_power)
52a96ae6
HS		 991 /* answer is positive */
992 SETu( result );
993 else if (result <= (UV)IV_MAX)
994 /* answer negative, fits in IV */
995 SETi( -(IV)result );
996 else if (result == (UV)IV_MIN)
997 /* 2's complement assumption: special case IV_MIN */
998 SETi( IV_MIN );
999 else
1000 /* answer negative, doesn't fit */
1001 SETn( -(NV)result );
1002 RETURN;
1003 }
1004 }
1005 }
1006 }
58d76dfd 1007 }
52a96ae6 1008 float_it:
58d76dfd 1009#endif
a0d0e21e 1010 {
52a96ae6
HS		 1011 dPOPTOPnnrl;
1012 SETn( Perl_pow( left, right) );
1013#ifdef PERL_PRESERVE_IVUV
1014 if (is_int)
1015 SvIV_please(TOPs);
1016#endif
1017 RETURN;
93a17b20 1018 }
a0d0e21e
LW		 1019}
1020
1021PP(pp_multiply)
1022{
39644a26 1023 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
28e5dec8
JH		 1024#ifdef PERL_PRESERVE_IVUV
1025 SvIV_please(TOPs);
1026 if (SvIOK(TOPs)) {
1027 /* Unless the left argument is integer in range we are going to have to
1028 use NV maths. Hence only attempt to coerce the right argument if
1029 we know the left is integer. */
1030 /* Left operand is defined, so is it IV? */
1031 SvIV_please(TOPm1s);
1032 if (SvIOK(TOPm1s)) {
1033 bool auvok = SvUOK(TOPm1s);
1034 bool buvok = SvUOK(TOPs);
1035 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1036 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1037 UV alow;
1038 UV ahigh;
1039 UV blow;
1040 UV bhigh;
1041
1042 if (auvok) {
1043 alow = SvUVX(TOPm1s);
1044 } else {
1045 IV aiv = SvIVX(TOPm1s);
1046 if (aiv >= 0) {
1047 alow = aiv;
1048 auvok = TRUE; /* effectively it's a UV now */
1049 } else {
1050 alow = -aiv; /* abs, auvok == false records sign */
1051 }
1052 }
1053 if (buvok) {
1054 blow = SvUVX(TOPs);
1055 } else {
1056 IV biv = SvIVX(TOPs);
1057 if (biv >= 0) {
1058 blow = biv;
1059 buvok = TRUE; /* effectively it's a UV now */
1060 } else {
1061 blow = -biv; /* abs, buvok == false records sign */
1062 }
1063 }
1064
1065 /* If this does sign extension on unsigned it's time for plan B */
1066 ahigh = alow >> (4 * sizeof (UV));
1067 alow &= botmask;
1068 bhigh = blow >> (4 * sizeof (UV));
1069 blow &= botmask;
1070 if (ahigh && bhigh) {
1071 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1072 which is overflow. Drop to NVs below. */
1073 } else if (!ahigh && !bhigh) {
1074 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1075 so the unsigned multiply cannot overflow. */
1076 UV product = alow * blow;
1077 if (auvok == buvok) {
1078 /* -ve * -ve or +ve * +ve gives a +ve result. */
1079 SP--;
1080 SETu( product );
1081 RETURN;
1082 } else if (product <= (UV)IV_MIN) {
1083 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1084 /* -ve result, which could overflow an IV */
1085 SP--;
25716404 1086 SETi( -(IV)product );
28e5dec8
JH		 1087 RETURN;
1088 } /* else drop to NVs below. */
1089 } else {
1090 /* One operand is large, 1 small */
1091 UV product_middle;
1092 if (bhigh) {
1093 /* swap the operands */
1094 ahigh = bhigh;
1095 bhigh = blow; /* bhigh now the temp var for the swap */
1096 blow = alow;
1097 alow = bhigh;
1098 }
1099 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1100 multiplies can't overflow. shift can, add can, -ve can. */
1101 product_middle = ahigh * blow;
1102 if (!(product_middle & topmask)) {
1103 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1104 UV product_low;
1105 product_middle <<= (4 * sizeof (UV));
1106 product_low = alow * blow;
1107
1108 /* as for pp_add, UV + something mustn't get smaller.
1109 IIRC ANSI mandates this wrapping *behaviour* for
1110 unsigned whatever the actual representation*/
1111 product_low += product_middle;
1112 if (product_low >= product_middle) {
1113 /* didn't overflow */
1114 if (auvok == buvok) {
1115 /* -ve * -ve or +ve * +ve gives a +ve result. */
1116 SP--;
1117 SETu( product_low );
1118 RETURN;
1119 } else if (product_low <= (UV)IV_MIN) {
1120 /* 2s complement assumption again */
1121 /* -ve result, which could overflow an IV */
1122 SP--;
25716404 1123 SETi( -(IV)product_low );
28e5dec8
JH		 1124 RETURN;
1125 } /* else drop to NVs below. */
1126 }
1127 } /* product_middle too large */
1128 } /* ahigh && bhigh */
1129 } /* SvIOK(TOPm1s) */
1130 } /* SvIOK(TOPs) */
1131#endif
a0d0e21e
LW		 1132 {
1133 dPOPTOPnnrl;
1134 SETn( left * right );
1135 RETURN;
79072805 1136 }
a0d0e21e
LW		 1137}
1138
1139PP(pp_divide)
1140{
39644a26 1141 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
5479d192 1142 /* Only try to do UV divide first
68795e93 1143 if ((SLOPPYDIVIDE is true) or
5479d192
NC		 1144 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1145 to preserve))
1146 The assumption is that it is better to use floating point divide
1147 whenever possible, only doing integer divide first if we can't be sure.
1148 If NV_PRESERVES_UV is true then we know at compile time that no UV
1149 can be too large to preserve, so don't need to compile the code to
1150 test the size of UVs. */
1151
a0d0e21e 1152#ifdef SLOPPYDIVIDE
5479d192
NC		 1153# define PERL_TRY_UV_DIVIDE
1154 /* ensure that 20./5. == 4. */
a0d0e21e 1155#else
5479d192
NC		 1156# ifdef PERL_PRESERVE_IVUV
1157# ifndef NV_PRESERVES_UV
1158# define PERL_TRY_UV_DIVIDE
1159# endif
1160# endif
a0d0e21e 1161#endif
5479d192
NC		 1162
1163#ifdef PERL_TRY_UV_DIVIDE
1164 SvIV_please(TOPs);
1165 if (SvIOK(TOPs)) {
1166 SvIV_please(TOPm1s);
1167 if (SvIOK(TOPm1s)) {
1168 bool left_non_neg = SvUOK(TOPm1s);
1169 bool right_non_neg = SvUOK(TOPs);
1170 UV left;
1171 UV right;
1172
1173 if (right_non_neg) {
1174 right = SvUVX(TOPs);
1175 }
1176 else {
1177 IV biv = SvIVX(TOPs);
1178 if (biv >= 0) {
1179 right = biv;
1180 right_non_neg = TRUE; /* effectively it's a UV now */
1181 }
1182 else {
1183 right = -biv;
1184 }
1185 }
1186 /* historically undef()/0 gives a "Use of uninitialized value"
1187 warning before dieing, hence this test goes here.
1188 If it were immediately before the second SvIV_please, then
1189 DIE() would be invoked before left was even inspected, so
1190 no inpsection would give no warning. */
1191 if (right == 0)
1192 DIE(aTHX_ "Illegal division by zero");
1193
1194 if (left_non_neg) {
1195 left = SvUVX(TOPm1s);
1196 }
1197 else {
1198 IV aiv = SvIVX(TOPm1s);
1199 if (aiv >= 0) {
1200 left = aiv;
1201 left_non_neg = TRUE; /* effectively it's a UV now */
1202 }
1203 else {
1204 left = -aiv;
1205 }
1206 }
1207
1208 if (left >= right
1209#ifdef SLOPPYDIVIDE
1210 /* For sloppy divide we always attempt integer division. */
1211#else
1212 /* Otherwise we only attempt it if either or both operands
1213 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC		 1214 we fall through to the NV divide code below. However,
1215 as left >= right to ensure integer result here, we know that
1216 we can skip the test on the right operand - right big
1217 enough not to be preserved can't get here unless left is
1218 also too big. */
1219
1220 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC		 1221#endif
1222 ) {
1223 /* Integer division can't overflow, but it can be imprecise. */
1224 UV result = left / right;
1225 if (result * right == left) {
1226 SP--; /* result is valid */
1227 if (left_non_neg == right_non_neg) {
1228 /* signs identical, result is positive. */
1229 SETu( result );
1230 RETURN;
1231 }
1232 /* 2s complement assumption */
1233 if (result <= (UV)IV_MIN)
91f3b821 1234 SETi( -(IV)result );
5479d192
NC		 1235 else {
1236 /* It's exact but too negative for IV. */
1237 SETn( -(NV)result );
1238 }
1239 RETURN;
1240 } /* tried integer divide but it was not an integer result */
32fdb065 1241 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
5479d192
NC		 1242 } /* left wasn't SvIOK */
1243 } /* right wasn't SvIOK */
1244#endif /* PERL_TRY_UV_DIVIDE */
1245 {
1246 dPOPPOPnnrl;
1247 if (right == 0.0)
1248 DIE(aTHX_ "Illegal division by zero");
1249 PUSHn( left / right );
1250 RETURN;
79072805 1251 }
a0d0e21e
LW		 1252}
1253
1254PP(pp_modulo)
1255{
39644a26 1256 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
a0d0e21e 1257 {
9c5ffd7c
JH		 1258 UV left = 0;
1259 UV right = 0;
dc656993
JH		 1260 bool left_neg = FALSE;
1261 bool right_neg = FALSE;
e2c88acc
NC		 1262 bool use_double = FALSE;
1263 bool dright_valid = FALSE;
9c5ffd7c
JH		 1264 NV dright = 0.0;
1265 NV dleft = 0.0;
787eafbd 1266
e2c88acc
NC		 1267 SvIV_please(TOPs);
1268 if (SvIOK(TOPs)) {
1269 right_neg = !SvUOK(TOPs);
1270 if (!right_neg) {
1271 right = SvUVX(POPs);
1272 } else {
1273 IV biv = SvIVX(POPs);
1274 if (biv >= 0) {
1275 right = biv;
1276 right_neg = FALSE; /* effectively it's a UV now */
1277 } else {
1278 right = -biv;
1279 }
1280 }
1281 }
1282 else {
787eafbd 1283 dright = POPn;
787eafbd
IZ		 1284 right_neg = dright < 0;
1285 if (right_neg)
1286 dright = -dright;
e2c88acc
NC		 1287 if (dright < UV_MAX_P1) {
1288 right = U_V(dright);
1289 dright_valid = TRUE; /* In case we need to use double below. */
1290 } else {
1291 use_double = TRUE;
1292 }
787eafbd 1293 }
a0d0e21e 1294
e2c88acc
NC		 1295 /* At this point use_double is only true if right is out of range for
1296 a UV. In range NV has been rounded down to nearest UV and
1297 use_double false. */
1298 SvIV_please(TOPs);
1299 if (!use_double && SvIOK(TOPs)) {
1300 if (SvIOK(TOPs)) {
1301 left_neg = !SvUOK(TOPs);
1302 if (!left_neg) {
1303 left = SvUVX(POPs);
1304 } else {
1305 IV aiv = SvIVX(POPs);
1306 if (aiv >= 0) {
1307 left = aiv;
1308 left_neg = FALSE; /* effectively it's a UV now */
1309 } else {
1310 left = -aiv;
1311 }
1312 }
1313 }
1314 }
787eafbd
IZ		 1315 else {
1316 dleft = POPn;
787eafbd
IZ		 1317 left_neg = dleft < 0;
1318 if (left_neg)
1319 dleft = -dleft;
68dc0745 1320
e2c88acc
NC		 1321 /* This should be exactly the 5.6 behaviour - if left and right are
1322 both in range for UV then use U_V() rather than floor. */
1323 if (!use_double) {
1324 if (dleft < UV_MAX_P1) {
1325 /* right was in range, so is dleft, so use UVs not double.
1326 */
1327 left = U_V(dleft);
1328 }
1329 /* left is out of range for UV, right was in range, so promote
1330 right (back) to double. */
1331 else {
1332 /* The +0.5 is used in 5.6 even though it is not strictly
1333 consistent with the implicit +0 floor in the U_V()
1334 inside the #if 1. */
1335 dleft = Perl_floor(dleft + 0.5);
1336 use_double = TRUE;
1337 if (dright_valid)
1338 dright = Perl_floor(dright + 0.5);
1339 else
1340 dright = right;
1341 }
1342 }
1343 }
787eafbd 1344 if (use_double) {
65202027 1345 NV dans;
787eafbd 1346
787eafbd 1347 if (!dright)
cea2e8a9 1348 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1349
65202027 1350 dans = Perl_fmod(dleft, dright);
787eafbd
IZ		 1351 if ((left_neg != right_neg) && dans)
1352 dans = dright - dans;
1353 if (right_neg)
1354 dans = -dans;
1355 sv_setnv(TARG, dans);
1356 }
1357 else {
1358 UV ans;
1359
787eafbd 1360 if (!right)
cea2e8a9 1361 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ		 1362
1363 ans = left % right;
1364 if ((left_neg != right_neg) && ans)
1365 ans = right - ans;
1366 if (right_neg) {
1367 /* XXX may warn: unary minus operator applied to unsigned type */
1368 /* could change -foo to be (~foo)+1 instead */
1369 if (ans <= ~((UV)IV_MAX)+1)
1370 sv_setiv(TARG, ~ans+1);
1371 else
65202027 1372 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ		 1373 }
1374 else
1375 sv_setuv(TARG, ans);
1376 }
1377 PUSHTARG;
1378 RETURN;
79072805 1379 }
a0d0e21e 1380}
79072805 1381
a0d0e21e
LW		 1382PP(pp_repeat)
1383{
39644a26 1384 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
748a9306 1385 {
467f0320 1386 register IV count = POPi;
533c011a 1387 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e
LW		 1388 dMARK;
1389 I32 items = SP - MARK;
1390 I32 max;
79072805 1391
a0d0e21e
LW		 1392 max = items * count;
1393 MEXTEND(MARK, max);
1394 if (count > 1) {
1395 while (SP > MARK) {
976c8a39
JH		 1396#if 0
1397 /* This code was intended to fix 20010809.028:
1398
1399 $x = 'abcd';
1400 for (($x =~ /./g) x 2) {
1401 print chop; # "abcdabcd" expected as output.
1402 }
1403
1404 * but that change (#11635) broke this code:
1405
1406 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1407
1408 * I can't think of a better fix that doesn't introduce
1409 * an efficiency hit by copying the SVs. The stack isn't
1410 * refcounted, and mortalisation obviously doesn't
1411 * Do The Right Thing when the stack has more than
1412 * one pointer to the same mortal value.
1413 * .robin.
1414 */
e30acc16
RH		 1415 if (*SP) {
1416 *SP = sv_2mortal(newSVsv(*SP));
1417 SvREADONLY_on(*SP);
1418 }
976c8a39
JH		 1419#else
1420 if (*SP)
1421 SvTEMP_off((*SP));
1422#endif
a0d0e21e 1423 SP--;
79072805 1424 }
a0d0e21e
LW		 1425 MARK++;
1426 repeatcpy((char*)(MARK + items), (char*)MARK,
1427 items * sizeof(SV*), count - 1);
1428 SP += max;
79072805 1429 }
a0d0e21e
LW		 1430 else if (count <= 0)
1431 SP -= items;
79072805 1432 }
a0d0e21e 1433 else { /* Note: mark already snarfed by pp_list */
dfcb284a 1434 SV *tmpstr = POPs;
a0d0e21e 1435 STRLEN len;
9b877dbb 1436 bool isutf;
a0d0e21e 1437
a0d0e21e
LW		 1438 SvSetSV(TARG, tmpstr);
1439 SvPV_force(TARG, len);
9b877dbb 1440 isutf = DO_UTF8(TARG);
8ebc5c01 1441 if (count != 1) {
1442 if (count < 1)
1443 SvCUR_set(TARG, 0);
1444 else {
1445 SvGROW(TARG, (count * len) + 1);
a0d0e21e 1446 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
8ebc5c01 1447 SvCUR(TARG) *= count;
7a4c00b4 1448 }
a0d0e21e 1449 *SvEND(TARG) = '\0';
a0d0e21e 1450 }
dfcb284a
GS		 1451 if (isutf)
1452 (void)SvPOK_only_UTF8(TARG);
1453 else
1454 (void)SvPOK_only(TARG);
b80b6069
RH		 1455
1456 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1457 /* The parser saw this as a list repeat, and there
1458 are probably several items on the stack. But we're
1459 in scalar context, and there's no pp_list to save us
1460 now. So drop the rest of the items -- robin@kitsite.com
1461 */
1462 dMARK;
1463 SP = MARK;
1464 }
a0d0e21e 1465 PUSHTARG;
79072805 1466 }
a0d0e21e 1467 RETURN;
748a9306 1468 }
a0d0e21e 1469}
79072805 1470
a0d0e21e
LW		 1471PP(pp_subtract)
1472{
39644a26 1473 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
28e5dec8
JH		 1474 useleft = USE_LEFT(TOPm1s);
1475#ifdef PERL_PRESERVE_IVUV
7dca457a
NC		 1476 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1477 "bad things" happen if you rely on signed integers wrapping. */
28e5dec8
JH		 1478 SvIV_please(TOPs);
1479 if (SvIOK(TOPs)) {
1480 /* Unless the left argument is integer in range we are going to have to
1481 use NV maths. Hence only attempt to coerce the right argument if
1482 we know the left is integer. */
9c5ffd7c
JH		 1483 register UV auv = 0;
1484 bool auvok = FALSE;
7dca457a
NC		 1485 bool a_valid = 0;
1486
28e5dec8 1487 if (!useleft) {
7dca457a
NC		 1488 auv = 0;
1489 a_valid = auvok = 1;
1490 /* left operand is undef, treat as zero. */
28e5dec8
JH		 1491 } else {
1492 /* Left operand is defined, so is it IV? */
1493 SvIV_please(TOPm1s);
1494 if (SvIOK(TOPm1s)) {
7dca457a
NC		 1495 if ((auvok = SvUOK(TOPm1s)))
1496 auv = SvUVX(TOPm1s);
1497 else {
1498 register IV aiv = SvIVX(TOPm1s);
1499 if (aiv >= 0) {
1500 auv = aiv;
1501 auvok = 1; /* Now acting as a sign flag. */
1502 } else { /* 2s complement assumption for IV_MIN */
1503 auv = (UV)-aiv;
28e5dec8 1504 }
7dca457a
NC		 1505 }
1506 a_valid = 1;
1507 }
1508 }
1509 if (a_valid) {
1510 bool result_good = 0;
1511 UV result;
1512 register UV buv;
1513 bool buvok = SvUOK(TOPs);
9041c2e3 1514
7dca457a
NC		 1515 if (buvok)
1516 buv = SvUVX(TOPs);
1517 else {
1518 register IV biv = SvIVX(TOPs);
1519 if (biv >= 0) {
1520 buv = biv;
1521 buvok = 1;
1522 } else
1523 buv = (UV)-biv;
1524 }
1525 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1526 else "IV" now, independent of how it came in.
7dca457a
NC		 1527 if a, b represents positive, A, B negative, a maps to -A etc
1528 a - b => (a - b)
1529 A - b => -(a + b)
1530 a - B => (a + b)
1531 A - B => -(a - b)
1532 all UV maths. negate result if A negative.
1533 subtract if signs same, add if signs differ. */
1534
1535 if (auvok ^ buvok) {
1536 /* Signs differ. */
1537 result = auv + buv;
1538 if (result >= auv)
1539 result_good = 1;
1540 } else {
1541 /* Signs same */
1542 if (auv >= buv) {
1543 result = auv - buv;
1544 /* Must get smaller */
1545 if (result <= auv)
1546 result_good = 1;
1547 } else {
1548 result = buv - auv;
1549 if (result <= buv) {
1550 /* result really should be -(auv-buv). as its negation
1551 of true value, need to swap our result flag */
1552 auvok = !auvok;
1553 result_good = 1;
28e5dec8 1554 }
28e5dec8
JH		 1555 }
1556 }
7dca457a
NC		 1557 if (result_good) {
1558 SP--;
1559 if (auvok)
1560 SETu( result );
1561 else {
1562 /* Negate result */
1563 if (result <= (UV)IV_MIN)
1564 SETi( -(IV)result );
1565 else {
1566 /* result valid, but out of range for IV. */
1567 SETn( -(NV)result );
1568 }
1569 }
1570 RETURN;
1571 } /* Overflow, drop through to NVs. */
28e5dec8
JH		 1572 }
1573 }
1574#endif
7dca457a 1575 useleft = USE_LEFT(TOPm1s);
a0d0e21e 1576 {
28e5dec8
JH		 1577 dPOPnv;
1578 if (!useleft) {
1579 /* left operand is undef, treat as zero - value */
1580 SETn(-value);
1581 RETURN;
1582 }
1583 SETn( TOPn - value );
1584 RETURN;
79072805 1585 }
a0d0e21e 1586}
79072805 1587
a0d0e21e
LW		 1588PP(pp_left_shift)
1589{
39644a26 1590 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
a0d0e21e 1591 {
972b05a9 1592 IV shift = POPi;
d0ba1bd2 1593 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1594 IV i = TOPi;
1595 SETi(i << shift);
d0ba1bd2
JH		 1596 }
1597 else {
972b05a9
JH		 1598 UV u = TOPu;
1599 SETu(u << shift);
d0ba1bd2 1600 }
55497cff 1601 RETURN;
79072805 1602 }
a0d0e21e 1603}
79072805 1604
a0d0e21e
LW		 1605PP(pp_right_shift)
1606{
39644a26 1607 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
a0d0e21e 1608 {
972b05a9 1609 IV shift = POPi;
d0ba1bd2 1610 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1611 IV i = TOPi;
1612 SETi(i >> shift);
d0ba1bd2
JH		 1613 }
1614 else {
972b05a9
JH		 1615 UV u = TOPu;
1616 SETu(u >> shift);
d0ba1bd2 1617 }
a0d0e21e 1618 RETURN;
93a17b20 1619 }
79072805
LW		 1620}
1621
a0d0e21e 1622PP(pp_lt)
79072805 1623{
39644a26 1624 dSP; tryAMAGICbinSET(lt,0);
28e5dec8
JH		 1625#ifdef PERL_PRESERVE_IVUV
1626 SvIV_please(TOPs);
1627 if (SvIOK(TOPs)) {
1628 SvIV_please(TOPm1s);
1629 if (SvIOK(TOPm1s)) {
1630 bool auvok = SvUOK(TOPm1s);
1631 bool buvok = SvUOK(TOPs);
a227d84d 1632
28e5dec8
JH		 1633 if (!auvok && !buvok) { /* ## IV < IV ## */
1634 IV aiv = SvIVX(TOPm1s);
1635 IV biv = SvIVX(TOPs);
1636
1637 SP--;
1638 SETs(boolSV(aiv < biv));
1639 RETURN;
1640 }
1641 if (auvok && buvok) { /* ## UV < UV ## */
1642 UV auv = SvUVX(TOPm1s);
1643 UV buv = SvUVX(TOPs);
1644
1645 SP--;
1646 SETs(boolSV(auv < buv));
1647 RETURN;
1648 }
1649 if (auvok) { /* ## UV < IV ## */
1650 UV auv;
1651 IV biv;
1652
1653 biv = SvIVX(TOPs);
1654 SP--;
1655 if (biv < 0) {
1656 /* As (a) is a UV, it's >=0, so it cannot be < */
1657 SETs(&PL_sv_no);
1658 RETURN;
1659 }
1660 auv = SvUVX(TOPs);
28e5dec8
JH		 1661 SETs(boolSV(auv < (UV)biv));
1662 RETURN;
1663 }
1664 { /* ## IV < UV ## */
1665 IV aiv;
1666 UV buv;
1667
1668 aiv = SvIVX(TOPm1s);
1669 if (aiv < 0) {
1670 /* As (b) is a UV, it's >=0, so it must be < */
1671 SP--;
1672 SETs(&PL_sv_yes);
1673 RETURN;
1674 }
1675 buv = SvUVX(TOPs);
1676 SP--;
28e5dec8
JH		 1677 SETs(boolSV((UV)aiv < buv));
1678 RETURN;
1679 }
1680 }
1681 }
1682#endif
30de85b6 1683#ifndef NV_PRESERVES_UV
50fb3111
NC		 1684#ifdef PERL_PRESERVE_IVUV
1685 else
1686#endif
1687 if (SvROK(TOPs) && SvROK(TOPm1s)) {
1688 SP--;
1689 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1690 RETURN;
1691 }
30de85b6 1692#endif
a0d0e21e
LW		 1693 {
1694 dPOPnv;
54310121 1695 SETs(boolSV(TOPn < value));
a0d0e21e 1696 RETURN;
79072805 1697 }
a0d0e21e 1698}
79072805 1699
a0d0e21e
LW		 1700PP(pp_gt)
1701{
39644a26 1702 dSP; tryAMAGICbinSET(gt,0);
28e5dec8
JH		 1703#ifdef PERL_PRESERVE_IVUV
1704 SvIV_please(TOPs);
1705 if (SvIOK(TOPs)) {
1706 SvIV_please(TOPm1s);
1707 if (SvIOK(TOPm1s)) {
1708 bool auvok = SvUOK(TOPm1s);
1709 bool buvok = SvUOK(TOPs);
a227d84d 1710
28e5dec8
JH		 1711 if (!auvok && !buvok) { /* ## IV > IV ## */
1712 IV aiv = SvIVX(TOPm1s);
1713 IV biv = SvIVX(TOPs);
1714
1715 SP--;
1716 SETs(boolSV(aiv > biv));
1717 RETURN;
1718 }
1719 if (auvok && buvok) { /* ## UV > UV ## */
1720 UV auv = SvUVX(TOPm1s);
1721 UV buv = SvUVX(TOPs);
1722
1723 SP--;
1724 SETs(boolSV(auv > buv));
1725 RETURN;
1726 }
1727 if (auvok) { /* ## UV > IV ## */
1728 UV auv;
1729 IV biv;
1730
1731 biv = SvIVX(TOPs);
1732 SP--;
1733 if (biv < 0) {
1734 /* As (a) is a UV, it's >=0, so it must be > */
1735 SETs(&PL_sv_yes);
1736 RETURN;
1737 }
1738 auv = SvUVX(TOPs);
28e5dec8
JH		 1739 SETs(boolSV(auv > (UV)biv));
1740 RETURN;
1741 }
1742 { /* ## IV > UV ## */
1743 IV aiv;
1744 UV buv;
1745
1746 aiv = SvIVX(TOPm1s);
1747 if (aiv < 0) {
1748 /* As (b) is a UV, it's >=0, so it cannot be > */
1749 SP--;
1750 SETs(&PL_sv_no);
1751 RETURN;
1752 }
1753 buv = SvUVX(TOPs);
1754 SP--;
28e5dec8
JH		 1755 SETs(boolSV((UV)aiv > buv));
1756 RETURN;
1757 }
1758 }
1759 }
1760#endif
30de85b6 1761#ifndef NV_PRESERVES_UV
50fb3111
NC		 1762#ifdef PERL_PRESERVE_IVUV
1763 else
1764#endif
1765 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1766 SP--;
1767 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1768 RETURN;
1769 }
1770#endif
a0d0e21e
LW		 1771 {
1772 dPOPnv;
54310121 1773 SETs(boolSV(TOPn > value));
a0d0e21e 1774 RETURN;
79072805 1775 }
a0d0e21e
LW		 1776}
1777
1778PP(pp_le)
1779{
39644a26 1780 dSP; tryAMAGICbinSET(le,0);
28e5dec8
JH		 1781#ifdef PERL_PRESERVE_IVUV
1782 SvIV_please(TOPs);
1783 if (SvIOK(TOPs)) {
1784 SvIV_please(TOPm1s);
1785 if (SvIOK(TOPm1s)) {
1786 bool auvok = SvUOK(TOPm1s);
1787 bool buvok = SvUOK(TOPs);
a227d84d 1788
28e5dec8
JH		 1789 if (!auvok && !buvok) { /* ## IV <= IV ## */
1790 IV aiv = SvIVX(TOPm1s);
1791 IV biv = SvIVX(TOPs);
1792
1793 SP--;
1794 SETs(boolSV(aiv <= biv));
1795 RETURN;
1796 }
1797 if (auvok && buvok) { /* ## UV <= UV ## */
1798 UV auv = SvUVX(TOPm1s);
1799 UV buv = SvUVX(TOPs);
1800
1801 SP--;
1802 SETs(boolSV(auv <= buv));
1803 RETURN;
1804 }
1805 if (auvok) { /* ## UV <= IV ## */
1806 UV auv;
1807 IV biv;
1808
1809 biv = SvIVX(TOPs);
1810 SP--;
1811 if (biv < 0) {
1812 /* As (a) is a UV, it's >=0, so a cannot be <= */
1813 SETs(&PL_sv_no);
1814 RETURN;
1815 }
1816 auv = SvUVX(TOPs);
28e5dec8
JH		 1817 SETs(boolSV(auv <= (UV)biv));
1818 RETURN;
1819 }
1820 { /* ## IV <= UV ## */
1821 IV aiv;
1822 UV buv;
1823
1824 aiv = SvIVX(TOPm1s);
1825 if (aiv < 0) {
1826 /* As (b) is a UV, it's >=0, so a must be <= */
1827 SP--;
1828 SETs(&PL_sv_yes);
1829 RETURN;
1830 }
1831 buv = SvUVX(TOPs);
1832 SP--;
28e5dec8
JH		 1833 SETs(boolSV((UV)aiv <= buv));
1834 RETURN;
1835 }
1836 }
1837 }
1838#endif
30de85b6 1839#ifndef NV_PRESERVES_UV
50fb3111
NC		 1840#ifdef PERL_PRESERVE_IVUV
1841 else
1842#endif
1843 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1844 SP--;
1845 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1846 RETURN;
1847 }
1848#endif
a0d0e21e
LW		 1849 {
1850 dPOPnv;
54310121 1851 SETs(boolSV(TOPn <= value));
a0d0e21e 1852 RETURN;
79072805 1853 }
a0d0e21e
LW		 1854}
1855
1856PP(pp_ge)
1857{
39644a26 1858 dSP; tryAMAGICbinSET(ge,0);
28e5dec8
JH		 1859#ifdef PERL_PRESERVE_IVUV
1860 SvIV_please(TOPs);
1861 if (SvIOK(TOPs)) {
1862 SvIV_please(TOPm1s);
1863 if (SvIOK(TOPm1s)) {
1864 bool auvok = SvUOK(TOPm1s);
1865 bool buvok = SvUOK(TOPs);
a227d84d 1866
28e5dec8
JH		 1867 if (!auvok && !buvok) { /* ## IV >= IV ## */
1868 IV aiv = SvIVX(TOPm1s);
1869 IV biv = SvIVX(TOPs);
1870
1871 SP--;
1872 SETs(boolSV(aiv >= biv));
1873 RETURN;
1874 }
1875 if (auvok && buvok) { /* ## UV >= UV ## */
1876 UV auv = SvUVX(TOPm1s);
1877 UV buv = SvUVX(TOPs);
1878
1879 SP--;
1880 SETs(boolSV(auv >= buv));
1881 RETURN;
1882 }
1883 if (auvok) { /* ## UV >= IV ## */
1884 UV auv;
1885 IV biv;
1886
1887 biv = SvIVX(TOPs);
1888 SP--;
1889 if (biv < 0) {
1890 /* As (a) is a UV, it's >=0, so it must be >= */
1891 SETs(&PL_sv_yes);
1892 RETURN;
1893 }
1894 auv = SvUVX(TOPs);
28e5dec8
JH		 1895 SETs(boolSV(auv >= (UV)biv));
1896 RETURN;
1897 }
1898 { /* ## IV >= UV ## */
1899 IV aiv;
1900 UV buv;
1901
1902 aiv = SvIVX(TOPm1s);
1903 if (aiv < 0) {
1904 /* As (b) is a UV, it's >=0, so a cannot be >= */
1905 SP--;
1906 SETs(&PL_sv_no);
1907 RETURN;
1908 }
1909 buv = SvUVX(TOPs);
1910 SP--;
28e5dec8
JH		 1911 SETs(boolSV((UV)aiv >= buv));
1912 RETURN;
1913 }
1914 }
1915 }
1916#endif
30de85b6 1917#ifndef NV_PRESERVES_UV
50fb3111
NC		 1918#ifdef PERL_PRESERVE_IVUV
1919 else
1920#endif
1921 if (SvROK(TOPs) && SvROK(TOPm1s)) {
30de85b6
NC		 1922 SP--;
1923 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1924 RETURN;
1925 }
1926#endif
a0d0e21e
LW		 1927 {
1928 dPOPnv;
54310121 1929 SETs(boolSV(TOPn >= value));
a0d0e21e 1930 RETURN;
79072805 1931 }
a0d0e21e 1932}
79072805 1933
a0d0e21e
LW		 1934PP(pp_ne)
1935{
16303949 1936 dSP; tryAMAGICbinSET(ne,0);
3bb2c415
JH		 1937#ifndef NV_PRESERVES_UV
1938 if (SvROK(TOPs) && SvROK(TOPm1s)) {
e61d22ef
NC		 1939 SP--;
1940 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
3bb2c415
JH		 1941 RETURN;
1942 }
1943#endif
28e5dec8
JH		 1944#ifdef PERL_PRESERVE_IVUV
1945 SvIV_please(TOPs);
1946 if (SvIOK(TOPs)) {
1947 SvIV_please(TOPm1s);
1948 if (SvIOK(TOPm1s)) {
1949 bool auvok = SvUOK(TOPm1s);
1950 bool buvok = SvUOK(TOPs);
a227d84d 1951
30de85b6
NC		 1952 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1953 /* Casting IV to UV before comparison isn't going to matter
1954 on 2s complement. On 1s complement or sign&magnitude
1955 (if we have any of them) it could make negative zero
1956 differ from normal zero. As I understand it. (Need to
1957 check - is negative zero implementation defined behaviour
1958 anyway?). NWC */
1959 UV buv = SvUVX(POPs);
1960 UV auv = SvUVX(TOPs);
28e5dec8 1961
28e5dec8
JH		 1962 SETs(boolSV(auv != buv));
1963 RETURN;
1964 }
1965 { /* ## Mixed IV,UV ## */
1966 IV iv;
1967 UV uv;
1968
1969 /* != is commutative so swap if needed (save code) */
1970 if (auvok) {
1971 /* swap. top of stack (b) is the iv */
1972 iv = SvIVX(TOPs);
1973 SP--;
1974 if (iv < 0) {
1975 /* As (a) is a UV, it's >0, so it cannot be == */
1976 SETs(&PL_sv_yes);
1977 RETURN;
1978 }
1979 uv = SvUVX(TOPs);
1980 } else {
1981 iv = SvIVX(TOPm1s);
1982 SP--;
1983 if (iv < 0) {
1984 /* As (b) is a UV, it's >0, so it cannot be == */
1985 SETs(&PL_sv_yes);
1986 RETURN;
1987 }
1988 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
1989 }
28e5dec8
JH		 1990 SETs(boolSV((UV)iv != uv));
1991 RETURN;
1992 }
1993 }
1994 }
1995#endif
a0d0e21e
LW		 1996 {
1997 dPOPnv;
54310121 1998 SETs(boolSV(TOPn != value));
a0d0e21e
LW		 1999 RETURN;
2000 }
79072805
LW		 2001}
2002
a0d0e21e 2003PP(pp_ncmp)
79072805 2004{
39644a26 2005 dSP; dTARGET; tryAMAGICbin(ncmp,0);
d8c7644e
JH		 2006#ifndef NV_PRESERVES_UV
2007 if (SvROK(TOPs) && SvROK(TOPm1s)) {
e61d22ef
NC		 2008 UV right = PTR2UV(SvRV(POPs));
2009 UV left = PTR2UV(SvRV(TOPs));
2010 SETi((left > right) - (left < right));
d8c7644e
JH		 2011 RETURN;
2012 }
2013#endif
28e5dec8
JH		 2014#ifdef PERL_PRESERVE_IVUV
2015 /* Fortunately it seems NaN isn't IOK */
2016 SvIV_please(TOPs);
2017 if (SvIOK(TOPs)) {
2018 SvIV_please(TOPm1s);
2019 if (SvIOK(TOPm1s)) {
2020 bool leftuvok = SvUOK(TOPm1s);
2021 bool rightuvok = SvUOK(TOPs);
2022 I32 value;
2023 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2024 IV leftiv = SvIVX(TOPm1s);
2025 IV rightiv = SvIVX(TOPs);
2026
2027 if (leftiv > rightiv)
2028 value = 1;
2029 else if (leftiv < rightiv)
2030 value = -1;
2031 else
2032 value = 0;
2033 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2034 UV leftuv = SvUVX(TOPm1s);
2035 UV rightuv = SvUVX(TOPs);
2036
2037 if (leftuv > rightuv)
2038 value = 1;
2039 else if (leftuv < rightuv)
2040 value = -1;
2041 else
2042 value = 0;
2043 } else if (leftuvok) { /* ## UV <=> IV ## */
2044 UV leftuv;
2045 IV rightiv;
2046
2047 rightiv = SvIVX(TOPs);
2048 if (rightiv < 0) {
2049 /* As (a) is a UV, it's >=0, so it cannot be < */
2050 value = 1;
2051 } else {
2052 leftuv = SvUVX(TOPm1s);
83bac5dd 2053 if (leftuv > (UV)rightiv) {
28e5dec8
JH		 2054 value = 1;
2055 } else if (leftuv < (UV)rightiv) {
2056 value = -1;
2057 } else {
2058 value = 0;
2059 }
2060 }
2061 } else { /* ## IV <=> UV ## */
2062 IV leftiv;
2063 UV rightuv;
2064
2065 leftiv = SvIVX(TOPm1s);
2066 if (leftiv < 0) {
2067 /* As (b) is a UV, it's >=0, so it must be < */
2068 value = -1;
2069 } else {
2070 rightuv = SvUVX(TOPs);
83bac5dd 2071 if ((UV)leftiv > rightuv) {
28e5dec8 2072 value = 1;
83bac5dd 2073 } else if ((UV)leftiv < rightuv) {
28e5dec8
JH		 2074 value = -1;
2075 } else {
2076 value = 0;
2077 }
2078 }
2079 }
2080 SP--;
2081 SETi(value);
2082 RETURN;
2083 }
2084 }
2085#endif
a0d0e21e
LW		 2086 {
2087 dPOPTOPnnrl;
2088 I32 value;
79072805 2089
a3540c92 2090#ifdef Perl_isnan
1ad04cfd
JH		 2091 if (Perl_isnan(left) || Perl_isnan(right)) {
2092 SETs(&PL_sv_undef);
2093 RETURN;
2094 }
2095 value = (left > right) - (left < right);
2096#else
ff0cee69 2097 if (left == right)
a0d0e21e 2098 value = 0;
a0d0e21e
LW		 2099 else if (left < right)
2100 value = -1;
44a8e56a 2101 else if (left > right)
2102 value = 1;
2103 else {
3280af22 2104 SETs(&PL_sv_undef);
44a8e56a 2105 RETURN;
2106 }
1ad04cfd 2107#endif
a0d0e21e
LW		 2108 SETi(value);
2109 RETURN;
79072805 2110 }
a0d0e21e 2111}
79072805 2112
a0d0e21e
LW		 2113PP(pp_slt)
2114{
39644a26 2115 dSP; tryAMAGICbinSET(slt,0);
a0d0e21e
LW		 2116 {
2117 dPOPTOPssrl;
2de3dbcc 2118 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2119 ? sv_cmp_locale(left, right)
2120 : sv_cmp(left, right));
54310121 2121 SETs(boolSV(cmp < 0));
a0d0e21e
LW		 2122 RETURN;
2123 }
79072805
LW		 2124}
2125
a0d0e21e 2126PP(pp_sgt)
79072805 2127{
39644a26 2128 dSP; tryAMAGICbinSET(sgt,0);
a0d0e21e
LW		 2129 {
2130 dPOPTOPssrl;
2de3dbcc 2131 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2132 ? sv_cmp_locale(left, right)
2133 : sv_cmp(left, right));
54310121 2134 SETs(boolSV(cmp > 0));
a0d0e21e
LW		 2135 RETURN;
2136 }
2137}
79072805 2138
a0d0e21e
LW		 2139PP(pp_sle)
2140{
39644a26 2141 dSP; tryAMAGICbinSET(sle,0);
a0d0e21e
LW		 2142 {
2143 dPOPTOPssrl;
2de3dbcc 2144 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2145 ? sv_cmp_locale(left, right)
2146 : sv_cmp(left, right));
54310121 2147 SETs(boolSV(cmp <= 0));
a0d0e21e 2148 RETURN;
79072805 2149 }
79072805
LW		 2150}
2151
a0d0e21e
LW		 2152PP(pp_sge)
2153{
39644a26 2154 dSP; tryAMAGICbinSET(sge,0);
a0d0e21e
LW		 2155 {
2156 dPOPTOPssrl;
2de3dbcc 2157 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2158 ? sv_cmp_locale(left, right)
2159 : sv_cmp(left, right));
54310121 2160 SETs(boolSV(cmp >= 0));
a0d0e21e
LW		 2161 RETURN;
2162 }
2163}
79072805 2164
36477c24 2165PP(pp_seq)
2166{
39644a26 2167 dSP; tryAMAGICbinSET(seq,0);
36477c24 2168 {
2169 dPOPTOPssrl;
54310121 2170 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW		 2171 RETURN;
2172 }
2173}
79072805 2174
a0d0e21e 2175PP(pp_sne)
79072805 2176{
39644a26 2177 dSP; tryAMAGICbinSET(sne,0);
a0d0e21e
LW		 2178 {
2179 dPOPTOPssrl;
54310121 2180 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 2181 RETURN;
463ee0b2 2182 }
79072805
LW		 2183}
2184
a0d0e21e 2185PP(pp_scmp)
79072805 2186{
39644a26 2187 dSP; dTARGET; tryAMAGICbin(scmp,0);
a0d0e21e
LW		 2188 {
2189 dPOPTOPssrl;
2de3dbcc 2190 int cmp = (IN_LOCALE_RUNTIME
bbce6d69 2191 ? sv_cmp_locale(left, right)
2192 : sv_cmp(left, right));
2193 SETi( cmp );
a0d0e21e
LW		 2194 RETURN;
2195 }
2196}
79072805 2197
55497cff 2198PP(pp_bit_and)
2199{
39644a26 2200 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
a0d0e21e
LW		 2201 {
2202 dPOPTOPssrl;
028c96eb
RGS		 2203 if (SvGMAGICAL(left)) mg_get(left);
2204 if (SvGMAGICAL(right)) mg_get(right);
4633a7c4 2205 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2206 if (PL_op->op_private & HINT_INTEGER) {
891f9566 2207 IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2208 SETi(i);
d0ba1bd2
JH		 2209 }
2210 else {
891f9566 2211 UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2212 SETu(u);
d0ba1bd2 2213 }
a0d0e21e
LW		 2214 }
2215 else {
533c011a 2216 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2217 SETTARG;
2218 }
2219 RETURN;
2220 }
2221}
79072805 2222
a0d0e21e
LW		 2223PP(pp_bit_xor)
2224{
39644a26 2225 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW		 2226 {
2227 dPOPTOPssrl;
028c96eb
RGS		 2228 if (SvGMAGICAL(left)) mg_get(left);
2229 if (SvGMAGICAL(right)) mg_get(right);
4633a7c4 2230 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2231 if (PL_op->op_private & HINT_INTEGER) {
891f9566 2232 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
972b05a9 2233 SETi(i);
d0ba1bd2
JH		 2234 }
2235 else {
891f9566 2236 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
972b05a9 2237 SETu(u);
d0ba1bd2 2238 }
a0d0e21e
LW		 2239 }
2240 else {
533c011a 2241 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2242 SETTARG;
2243 }
2244 RETURN;
2245 }
2246}
79072805 2247
a0d0e21e
LW		 2248PP(pp_bit_or)
2249{
39644a26 2250 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW		 2251 {
2252 dPOPTOPssrl;
028c96eb
RGS		 2253 if (SvGMAGICAL(left)) mg_get(left);
2254 if (SvGMAGICAL(right)) mg_get(right);
4633a7c4 2255 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2256 if (PL_op->op_private & HINT_INTEGER) {
891f9566 2257 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
972b05a9 2258 SETi(i);
d0ba1bd2
JH		 2259 }
2260 else {
891f9566 2261 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
972b05a9 2262 SETu(u);
d0ba1bd2 2263 }
a0d0e21e
LW		 2264 }
2265 else {
533c011a 2266 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2267 SETTARG;
2268 }
2269 RETURN;
79072805 2270 }
a0d0e21e 2271}
79072805 2272
a0d0e21e
LW		 2273PP(pp_negate)
2274{
39644a26 2275 dSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW		 2276 {
2277 dTOPss;
28e5dec8 2278 int flags = SvFLAGS(sv);
4633a7c4
LW		 2279 if (SvGMAGICAL(sv))
2280 mg_get(sv);
28e5dec8
JH		 2281 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2282 /* It's publicly an integer, or privately an integer-not-float */
2283 oops_its_an_int:
9b0e499b
GS		 2284 if (SvIsUV(sv)) {
2285 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2286 /* 2s complement assumption. */
9b0e499b
GS		 2287 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2288 RETURN;
2289 }
2290 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2291 SETi(-SvIVX(sv));
9b0e499b
GS		 2292 RETURN;
2293 }
2294 }
2295 else if (SvIVX(sv) != IV_MIN) {
2296 SETi(-SvIVX(sv));
2297 RETURN;
2298 }
28e5dec8
JH		 2299#ifdef PERL_PRESERVE_IVUV
2300 else {
2301 SETu((UV)IV_MIN);
2302 RETURN;
2303 }
2304#endif
9b0e499b
GS		 2305 }
2306 if (SvNIOKp(sv))
a0d0e21e 2307 SETn(-SvNV(sv));
4633a7c4 2308 else if (SvPOKp(sv)) {
a0d0e21e
LW		 2309 STRLEN len;
2310 char *s = SvPV(sv, len);
bbce6d69 2311 if (isIDFIRST(*s)) {
a0d0e21e
LW		 2312 sv_setpvn(TARG, "-", 1);
2313 sv_catsv(TARG, sv);
79072805 2314 }
a0d0e21e
LW		 2315 else if (*s == '+' || *s == '-') {
2316 sv_setsv(TARG, sv);
2317 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805 2318 }
8eb28a70
JH		 2319 else if (DO_UTF8(sv)) {
2320 SvIV_please(sv);
2321 if (SvIOK(sv))
2322 goto oops_its_an_int;
2323 if (SvNOK(sv))
2324 sv_setnv(TARG, -SvNV(sv));
2325 else {
2326 sv_setpvn(TARG, "-", 1);
2327 sv_catsv(TARG, sv);
2328 }
834a4ddd 2329 }
28e5dec8 2330 else {
8eb28a70
JH		 2331 SvIV_please(sv);
2332 if (SvIOK(sv))
2333 goto oops_its_an_int;
2334 sv_setnv(TARG, -SvNV(sv));
28e5dec8 2335 }
a0d0e21e 2336 SETTARG;
79072805 2337 }
4633a7c4
LW		 2338 else
2339 SETn(-SvNV(sv));
79072805 2340 }
a0d0e21e 2341 RETURN;
79072805
LW		 2342}
2343
a0d0e21e 2344PP(pp_not)
79072805 2345{
39644a26 2346 dSP; tryAMAGICunSET(not);
3280af22 2347 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
a0d0e21e 2348 return NORMAL;
79072805
LW		 2349}
2350
a0d0e21e 2351PP(pp_complement)
79072805 2352{
39644a26 2353 dSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW		 2354 {
2355 dTOPss;
028c96eb
RGS		 2356 if (SvGMAGICAL(sv))
2357 mg_get(sv);
4633a7c4 2358 if (SvNIOKp(sv)) {
d0ba1bd2 2359 if (PL_op->op_private & HINT_INTEGER) {
891f9566 2360 IV i = ~SvIV_nomg(sv);
972b05a9 2361 SETi(i);
d0ba1bd2
JH		 2362 }
2363 else {
891f9566 2364 UV u = ~SvUV_nomg(sv);
972b05a9 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
891f9566 2373 sv_setsv_nomg(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);
d0a21e00 2420 SvUTF8_off(TARG);
1d68d6cd 2421 }
1d68d6cd
SC		 2422 Safefree(result);
2423 SETs(TARG);
2424 RETURN;
2425 }
a0d0e21e 2426#ifdef LIBERAL
51723571
JH		 2427 {
2428 register long *tmpl;
2429 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2430 *tmps = ~*tmps;
2431 tmpl = (long*)tmps;
2432 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2433 *tmpl = ~*tmpl;
2434 tmps = (U8*)tmpl;
2435 }
a0d0e21e
LW		 2436#endif
2437 for ( ; anum > 0; anum--, tmps++)
2438 *tmps = ~*tmps;
2439
2440 SETs(TARG);
2441 }
2442 RETURN;
2443 }
79072805
LW		 2444}
2445
a0d0e21e
LW		 2446/* integer versions of some of the above */
2447
a0d0e21e 2448PP(pp_i_multiply)
79072805 2449{
39644a26 2450 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW		 2451 {
2452 dPOPTOPiirl;
2453 SETi( left * right );
2454 RETURN;
2455 }
79072805
LW		 2456}
2457
a0d0e21e 2458PP(pp_i_divide)
79072805 2459{
39644a26 2460 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW		 2461 {
2462 dPOPiv;
2463 if (value == 0)
cea2e8a9 2464 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW		 2465 value = POPi / value;
2466 PUSHi( value );
2467 RETURN;
2468 }
79072805
LW		 2469}
2470
224ec323
JH		 2471STATIC
2472PP(pp_i_modulo_0)
2473{
2474 /* This is the vanilla old i_modulo. */
2475 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2476 {
2477 dPOPTOPiirl;
2478 if (!right)
2479 DIE(aTHX_ "Illegal modulus zero");
2480 SETi( left % right );
2481 RETURN;
2482 }
2483}
2484
11010fa3 2485#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH		 2486STATIC
2487PP(pp_i_modulo_1)
2488{
224ec323 2489 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2490 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323
JH		 2491 * See below for pp_i_modulo. */
2492 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2493 {
2494 dPOPTOPiirl;
2495 if (!right)
2496 DIE(aTHX_ "Illegal modulus zero");
32fdb065 2497 SETi( left % PERL_ABS(right) );
224ec323
JH		 2498 RETURN;
2499 }
224ec323 2500}
fce2b89e 2501#endif
224ec323 2502
a0d0e21e 2503PP(pp_i_modulo)
79072805 2504{
224ec323
JH		 2505 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2506 {
2507 dPOPTOPiirl;
2508 if (!right)
2509 DIE(aTHX_ "Illegal modulus zero");
2510 /* The assumption is to use hereafter the old vanilla version... */
2511 PL_op->op_ppaddr =
2512 PL_ppaddr[OP_I_MODULO] =
2513 &Perl_pp_i_modulo_0;
2514 /* .. but if we have glibc, we might have a buggy _moddi3
2515 * (at least glicb 2.2.5 is known to have this bug), in other
2516 * words our integer modulus with negative quad as the second
2517 * argument might be broken. Test for this and re-patch the
2518 * opcode dispatch table if that is the case, remembering to
2519 * also apply the workaround so that this first round works
2520 * right, too. See [perl #9402] for more information. */
2521#if defined(__GLIBC__) && IVSIZE == 8
2522 {
2523 IV l = 3;
2524 IV r = -10;
2525 /* Cannot do this check with inlined IV constants since
2526 * that seems to work correctly even with the buggy glibc. */
2527 if (l % r == -3) {
2528 /* Yikes, we have the bug.
2529 * Patch in the workaround version. */
2530 PL_op->op_ppaddr =
2531 PL_ppaddr[OP_I_MODULO] =
2532 &Perl_pp_i_modulo_1;
2533 /* Make certain we work right this time, too. */
32fdb065 2534 right = PERL_ABS(right);
224ec323
JH		 2535 }
2536 }
2537#endif
2538 SETi( left % right );
2539 RETURN;
2540 }
79072805
LW		 2541}
2542
a0d0e21e 2543PP(pp_i_add)
79072805 2544{
39644a26 2545 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e 2546 {
5e66d4f1 2547 dPOPTOPiirl_ul;
a0d0e21e
LW		 2548 SETi( left + right );
2549 RETURN;
79072805 2550 }
79072805
LW		 2551}
2552
a0d0e21e 2553PP(pp_i_subtract)
79072805 2554{
39644a26 2555 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 2556 {
5e66d4f1 2557 dPOPTOPiirl_ul;
a0d0e21e
LW		 2558 SETi( left - right );
2559 RETURN;
79072805 2560 }
79072805
LW		 2561}
2562
a0d0e21e 2563PP(pp_i_lt)
79072805 2564{
39644a26 2565 dSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW		 2566 {
2567 dPOPTOPiirl;
54310121 2568 SETs(boolSV(left < right));
a0d0e21e
LW		 2569 RETURN;
2570 }
79072805
LW		 2571}
2572
a0d0e21e 2573PP(pp_i_gt)
79072805 2574{
39644a26 2575 dSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW		 2576 {
2577 dPOPTOPiirl;
54310121 2578 SETs(boolSV(left > right));
a0d0e21e
LW		 2579 RETURN;
2580 }
79072805
LW		 2581}
2582
a0d0e21e 2583PP(pp_i_le)
79072805 2584{
39644a26 2585 dSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW		 2586 {
2587 dPOPTOPiirl;
54310121 2588 SETs(boolSV(left <= right));
a0d0e21e 2589 RETURN;
85e6fe83 2590 }
79072805
LW		 2591}
2592
a0d0e21e 2593PP(pp_i_ge)
79072805 2594{
39644a26 2595 dSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW		 2596 {
2597 dPOPTOPiirl;
54310121 2598 SETs(boolSV(left >= right));
a0d0e21e
LW		 2599 RETURN;
2600 }
79072805
LW		 2601}
2602
a0d0e21e 2603PP(pp_i_eq)
79072805 2604{
39644a26 2605 dSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW		 2606 {
2607 dPOPTOPiirl;
54310121 2608 SETs(boolSV(left == right));
a0d0e21e
LW		 2609 RETURN;
2610 }
79072805
LW		 2611}
2612
a0d0e21e 2613PP(pp_i_ne)
79072805 2614{
39644a26 2615 dSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW		 2616 {
2617 dPOPTOPiirl;
54310121 2618 SETs(boolSV(left != right));
a0d0e21e
LW		 2619 RETURN;
2620 }
79072805
LW		 2621}
2622
a0d0e21e 2623PP(pp_i_ncmp)
79072805 2624{
39644a26 2625 dSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW		 2626 {
2627 dPOPTOPiirl;
2628 I32 value;
79072805 2629
a0d0e21e 2630 if (left > right)
79072805 2631 value = 1;
a0d0e21e 2632 else if (left < right)
79072805 2633 value = -1;
a0d0e21e 2634 else
79072805 2635 value = 0;
a0d0e21e
LW		 2636 SETi(value);
2637 RETURN;
79072805 2638 }
85e6fe83
LW		 2639}
2640
2641PP(pp_i_negate)
2642{
39644a26 2643 dSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW		 2644 SETi(-TOPi);
2645 RETURN;
2646}
2647
79072805
LW		 2648/* High falutin' math. */
2649
2650PP(pp_atan2)
2651{
39644a26 2652 dSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW		 2653 {
2654 dPOPTOPnnrl;
65202027 2655 SETn(Perl_atan2(left, right));
a0d0e21e
LW		 2656 RETURN;
2657 }
79072805
LW		 2658}
2659
2660PP(pp_sin)
2661{
39644a26 2662 dSP; dTARGET; tryAMAGICun(sin);
a0d0e21e 2663 {
65202027 2664 NV value;
a0d0e21e 2665 value = POPn;
65202027 2666 value = Perl_sin(value);
a0d0e21e
LW		 2667 XPUSHn(value);
2668 RETURN;
2669 }
79072805
LW		 2670}
2671
2672PP(pp_cos)
2673{
39644a26 2674 dSP; dTARGET; tryAMAGICun(cos);
a0d0e21e 2675 {
65202027 2676 NV value;
a0d0e21e 2677 value = POPn;
65202027 2678 value = Perl_cos(value);
a0d0e21e
LW		 2679 XPUSHn(value);
2680 RETURN;
2681 }
79072805
LW		 2682}
2683
56cb0a1c
AD		 2684/* Support Configure command-line overrides for rand() functions.
2685 After 5.005, perhaps we should replace this by Configure support
2686 for drand48(), random(), or rand(). For 5.005, though, maintain
2687 compatibility by calling rand() but allow the user to override it.
2688 See INSTALL for details. --Andy Dougherty 15 July 1998
2689*/
85ab1d1d
JH		 2690/* Now it's after 5.005, and Configure supports drand48() and random(),
2691 in addition to rand(). So the overrides should not be needed any more.
2692 --Jarkko Hietaniemi 27 September 1998
2693 */
2694
2695#ifndef HAS_DRAND48_PROTO
20ce7b12 2696extern double drand48 (void);
56cb0a1c
AD		 2697#endif
2698
79072805
LW		 2699PP(pp_rand)
2700{
39644a26 2701 dSP; dTARGET;
65202027 2702 NV value;
79072805
LW		 2703 if (MAXARG < 1)
2704 value = 1.0;
2705 else
2706 value = POPn;
2707 if (value == 0.0)
2708 value = 1.0;
80252599 2709 if (!PL_srand_called) {
85ab1d1d 2710 (void)seedDrand01((Rand_seed_t)seed());
80252599 2711 PL_srand_called = TRUE;
93dc8474 2712 }
85ab1d1d 2713 value *= Drand01();
79072805
LW		 2714 XPUSHn(value);
2715 RETURN;
2716}
2717
2718PP(pp_srand)
2719{
39644a26 2720 dSP;
93dc8474
CS		 2721 UV anum;
2722 if (MAXARG < 1)
2723 anum = seed();
79072805 2724 else
93dc8474 2725 anum = POPu;
85ab1d1d 2726 (void)seedDrand01((Rand_seed_t)anum);
80252599 2727 PL_srand_called = TRUE;
79072805
LW		 2728 EXTEND(SP, 1);
2729 RETPUSHYES;
2730}
2731
2732PP(pp_exp)
2733{
39644a26 2734 dSP; dTARGET; tryAMAGICun(exp);
a0d0e21e 2735 {
65202027 2736 NV value;
a0d0e21e 2737 value = POPn;
65202027 2738 value = Perl_exp(value);
a0d0e21e
LW		 2739 XPUSHn(value);
2740 RETURN;
2741 }
79072805
LW		 2742}
2743
2744PP(pp_log)
2745{
39644a26 2746 dSP; dTARGET; tryAMAGICun(log);
a0d0e21e 2747 {
65202027 2748 NV value;
a0d0e21e 2749 value = POPn;
bbce6d69 2750 if (value <= 0.0) {
f93f4e46 2751 SET_NUMERIC_STANDARD();
1779d84d 2752 DIE(aTHX_ "Can't take log of %"NVgf, value);
bbce6d69 2753 }
65202027 2754 value = Perl_log(value);
a0d0e21e
LW		 2755 XPUSHn(value);
2756 RETURN;
2757 }
79072805
LW		 2758}
2759
2760PP(pp_sqrt)
2761{
39644a26 2762 dSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e 2763 {
65202027 2764 NV value;
a0d0e21e 2765 value = POPn;
bbce6d69 2766 if (value < 0.0) {
f93f4e46 2767 SET_NUMERIC_STANDARD();
1779d84d 2768 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
bbce6d69 2769 }
65202027 2770 value = Perl_sqrt(value);
a0d0e21e
LW		 2771 XPUSHn(value);
2772 RETURN;
2773 }
79072805
LW		 2774}
2775
2776PP(pp_int)
2777{
39644a26 2778 dSP; dTARGET; tryAMAGICun(int);
774d564b 2779 {
28e5dec8
JH		 2780 NV value;
2781 IV iv = TOPi; /* attempt to convert to IV if possible. */
2782 /* XXX it's arguable that compiler casting to IV might be subtly
2783 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2784 else preferring IV has introduced a subtle behaviour change bug. OTOH
2785 relying on floating point to be accurate is a bug. */
2786
2787 if (SvIOK(TOPs)) {
2788 if (SvIsUV(TOPs)) {
2789 UV uv = TOPu;
2790 SETu(uv);
2791 } else
2792 SETi(iv);
2793 } else {
2794 value = TOPn;
1048ea30 2795 if (value >= 0.0) {
28e5dec8
JH		 2796 if (value < (NV)UV_MAX + 0.5) {
2797 SETu(U_V(value));
2798 } else {
059a1014 2799 SETn(Perl_floor(value));
28e5dec8 2800 }
1048ea30 2801 }
28e5dec8
JH		 2802 else {
2803 if (value > (NV)IV_MIN - 0.5) {
2804 SETi(I_V(value));
2805 } else {
1bbae031 2806 SETn(Perl_ceil(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.