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
skip num.t #47 on VMS
[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;
4633a7c4 2203 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2204 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2205 IV i = SvIV(left) & SvIV(right);
2206 SETi(i);
d0ba1bd2
JH		 2207 }
2208 else {
972b05a9
JH		 2209 UV u = SvUV(left) & SvUV(right);
2210 SETu(u);
d0ba1bd2 2211 }
a0d0e21e
LW		 2212 }
2213 else {
533c011a 2214 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2215 SETTARG;
2216 }
2217 RETURN;
2218 }
2219}
79072805 2220
a0d0e21e
LW		 2221PP(pp_bit_xor)
2222{
39644a26 2223 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW		 2224 {
2225 dPOPTOPssrl;
4633a7c4 2226 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2227 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2228 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2229 SETi(i);
d0ba1bd2
JH		 2230 }
2231 else {
972b05a9
JH		 2232 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2233 SETu(u);
d0ba1bd2 2234 }
a0d0e21e
LW		 2235 }
2236 else {
533c011a 2237 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2238 SETTARG;
2239 }
2240 RETURN;
2241 }
2242}
79072805 2243
a0d0e21e
LW		 2244PP(pp_bit_or)
2245{
39644a26 2246 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW		 2247 {
2248 dPOPTOPssrl;
4633a7c4 2249 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 2250 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2251 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2252 SETi(i);
d0ba1bd2
JH		 2253 }
2254 else {
972b05a9
JH		 2255 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2256 SETu(u);
d0ba1bd2 2257 }
a0d0e21e
LW		 2258 }
2259 else {
533c011a 2260 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2261 SETTARG;
2262 }
2263 RETURN;
79072805 2264 }
a0d0e21e 2265}
79072805 2266
a0d0e21e
LW		 2267PP(pp_negate)
2268{
39644a26 2269 dSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW		 2270 {
2271 dTOPss;
28e5dec8 2272 int flags = SvFLAGS(sv);
4633a7c4
LW		 2273 if (SvGMAGICAL(sv))
2274 mg_get(sv);
28e5dec8
JH		 2275 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2276 /* It's publicly an integer, or privately an integer-not-float */
2277 oops_its_an_int:
9b0e499b
GS		 2278 if (SvIsUV(sv)) {
2279 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2280 /* 2s complement assumption. */
9b0e499b
GS		 2281 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2282 RETURN;
2283 }
2284 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2285 SETi(-SvIVX(sv));
9b0e499b
GS		 2286 RETURN;
2287 }
2288 }
2289 else if (SvIVX(sv) != IV_MIN) {
2290 SETi(-SvIVX(sv));
2291 RETURN;
2292 }
28e5dec8
JH		 2293#ifdef PERL_PRESERVE_IVUV
2294 else {
2295 SETu((UV)IV_MIN);
2296 RETURN;
2297 }
2298#endif
9b0e499b
GS		 2299 }
2300 if (SvNIOKp(sv))
a0d0e21e 2301 SETn(-SvNV(sv));
4633a7c4 2302 else if (SvPOKp(sv)) {
a0d0e21e
LW		 2303 STRLEN len;
2304 char *s = SvPV(sv, len);
bbce6d69 2305 if (isIDFIRST(*s)) {
a0d0e21e
LW		 2306 sv_setpvn(TARG, "-", 1);
2307 sv_catsv(TARG, sv);
79072805 2308 }
a0d0e21e
LW		 2309 else if (*s == '+' || *s == '-') {
2310 sv_setsv(TARG, sv);
2311 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805 2312 }
8eb28a70
JH		 2313 else if (DO_UTF8(sv)) {
2314 SvIV_please(sv);
2315 if (SvIOK(sv))
2316 goto oops_its_an_int;
2317 if (SvNOK(sv))
2318 sv_setnv(TARG, -SvNV(sv));
2319 else {
2320 sv_setpvn(TARG, "-", 1);
2321 sv_catsv(TARG, sv);
2322 }
834a4ddd 2323 }
28e5dec8 2324 else {
8eb28a70
JH		 2325 SvIV_please(sv);
2326 if (SvIOK(sv))
2327 goto oops_its_an_int;
2328 sv_setnv(TARG, -SvNV(sv));
28e5dec8 2329 }
a0d0e21e 2330 SETTARG;
79072805 2331 }
4633a7c4
LW		 2332 else
2333 SETn(-SvNV(sv));
79072805 2334 }
a0d0e21e 2335 RETURN;
79072805
LW		 2336}
2337
a0d0e21e 2338PP(pp_not)
79072805 2339{
39644a26 2340 dSP; tryAMAGICunSET(not);
3280af22 2341 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
a0d0e21e 2342 return NORMAL;
79072805
LW		 2343}
2344
a0d0e21e 2345PP(pp_complement)
79072805 2346{
39644a26 2347 dSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW		 2348 {
2349 dTOPss;
4633a7c4 2350 if (SvNIOKp(sv)) {
d0ba1bd2 2351 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 2352 IV i = ~SvIV(sv);
2353 SETi(i);
d0ba1bd2
JH		 2354 }
2355 else {
972b05a9
JH		 2356 UV u = ~SvUV(sv);
2357 SETu(u);
d0ba1bd2 2358 }
a0d0e21e
LW		 2359 }
2360 else {
51723571 2361 register U8 *tmps;
55497cff 2362 register I32 anum;
a0d0e21e
LW		 2363 STRLEN len;
2364
2365 SvSetSV(TARG, sv);
51723571 2366 tmps = (U8*)SvPV_force(TARG, len);
a0d0e21e 2367 anum = len;
1d68d6cd 2368 if (SvUTF8(TARG)) {
a1ca4561 2369 /* Calculate exact length, let's not estimate. */
1d68d6cd
SC		 2370 STRLEN targlen = 0;
2371 U8 *result;
51723571 2372 U8 *send;
ba210ebe 2373 STRLEN l;
a1ca4561
YST		 2374 UV nchar = 0;
2375 UV nwide = 0;
1d68d6cd
SC		 2376
2377 send = tmps + len;
2378 while (tmps < send) {
9041c2e3 2379 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1d68d6cd 2380 tmps += UTF8SKIP(tmps);
5bbb0b5a 2381 targlen += UNISKIP(~c);
a1ca4561
YST		 2382 nchar++;
2383 if (c > 0xff)
2384 nwide++;
1d68d6cd
SC		 2385 }
2386
2387 /* Now rewind strings and write them. */
2388 tmps -= len;
a1ca4561
YST		 2389
2390 if (nwide) {
2391 Newz(0, result, targlen + 1, U8);
2392 while (tmps < send) {
9041c2e3 2393 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
a1ca4561 2394 tmps += UTF8SKIP(tmps);
b851fbc1 2395 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
a1ca4561
YST		 2396 }
2397 *result = '\0';
2398 result -= targlen;
2399 sv_setpvn(TARG, (char*)result, targlen);
2400 SvUTF8_on(TARG);
2401 }
2402 else {
2403 Newz(0, result, nchar + 1, U8);
2404 while (tmps < send) {
9041c2e3 2405 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
a1ca4561
YST		 2406 tmps += UTF8SKIP(tmps);
2407 *result++ = ~c;
2408 }
2409 *result = '\0';
2410 result -= nchar;
2411 sv_setpvn(TARG, (char*)result, nchar);
1d68d6cd 2412 }
1d68d6cd
SC		 2413 Safefree(result);
2414 SETs(TARG);
2415 RETURN;
2416 }
a0d0e21e 2417#ifdef LIBERAL
51723571
JH		 2418 {
2419 register long *tmpl;
2420 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2421 *tmps = ~*tmps;
2422 tmpl = (long*)tmps;
2423 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2424 *tmpl = ~*tmpl;
2425 tmps = (U8*)tmpl;
2426 }
a0d0e21e
LW		 2427#endif
2428 for ( ; anum > 0; anum--, tmps++)
2429 *tmps = ~*tmps;
2430
2431 SETs(TARG);
2432 }
2433 RETURN;
2434 }
79072805
LW		 2435}
2436
a0d0e21e
LW		 2437/* integer versions of some of the above */
2438
a0d0e21e 2439PP(pp_i_multiply)
79072805 2440{
39644a26 2441 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW		 2442 {
2443 dPOPTOPiirl;
2444 SETi( left * right );
2445 RETURN;
2446 }
79072805
LW		 2447}
2448
a0d0e21e 2449PP(pp_i_divide)
79072805 2450{
39644a26 2451 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW		 2452 {
2453 dPOPiv;
2454 if (value == 0)
cea2e8a9 2455 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW		 2456 value = POPi / value;
2457 PUSHi( value );
2458 RETURN;
2459 }
79072805
LW		 2460}
2461
224ec323
JH		 2462STATIC
2463PP(pp_i_modulo_0)
2464{
2465 /* This is the vanilla old i_modulo. */
2466 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2467 {
2468 dPOPTOPiirl;
2469 if (!right)
2470 DIE(aTHX_ "Illegal modulus zero");
2471 SETi( left % right );
2472 RETURN;
2473 }
2474}
2475
11010fa3 2476#if defined(__GLIBC__) && IVSIZE == 8
224ec323
JH		 2477STATIC
2478PP(pp_i_modulo_1)
2479{
224ec323 2480 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2481 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323
JH		 2482 * See below for pp_i_modulo. */
2483 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2484 {
2485 dPOPTOPiirl;
2486 if (!right)
2487 DIE(aTHX_ "Illegal modulus zero");
32fdb065 2488 SETi( left % PERL_ABS(right) );
224ec323
JH		 2489 RETURN;
2490 }
224ec323 2491}
fce2b89e 2492#endif
224ec323 2493
a0d0e21e 2494PP(pp_i_modulo)
79072805 2495{
224ec323
JH		 2496 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2497 {
2498 dPOPTOPiirl;
2499 if (!right)
2500 DIE(aTHX_ "Illegal modulus zero");
2501 /* The assumption is to use hereafter the old vanilla version... */
2502 PL_op->op_ppaddr =
2503 PL_ppaddr[OP_I_MODULO] =
2504 &Perl_pp_i_modulo_0;
2505 /* .. but if we have glibc, we might have a buggy _moddi3
2506 * (at least glicb 2.2.5 is known to have this bug), in other
2507 * words our integer modulus with negative quad as the second
2508 * argument might be broken. Test for this and re-patch the
2509 * opcode dispatch table if that is the case, remembering to
2510 * also apply the workaround so that this first round works
2511 * right, too. See [perl #9402] for more information. */
2512#if defined(__GLIBC__) && IVSIZE == 8
2513 {
2514 IV l = 3;
2515 IV r = -10;
2516 /* Cannot do this check with inlined IV constants since
2517 * that seems to work correctly even with the buggy glibc. */
2518 if (l % r == -3) {
2519 /* Yikes, we have the bug.
2520 * Patch in the workaround version. */
2521 PL_op->op_ppaddr =
2522 PL_ppaddr[OP_I_MODULO] =
2523 &Perl_pp_i_modulo_1;
2524 /* Make certain we work right this time, too. */
32fdb065 2525 right = PERL_ABS(right);
224ec323
JH		 2526 }
2527 }
2528#endif
2529 SETi( left % right );
2530 RETURN;
2531 }
79072805
LW		 2532}
2533
a0d0e21e 2534PP(pp_i_add)
79072805 2535{
39644a26 2536 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e 2537 {
5e66d4f1 2538 dPOPTOPiirl_ul;
a0d0e21e
LW		 2539 SETi( left + right );
2540 RETURN;
79072805 2541 }
79072805
LW		 2542}
2543
a0d0e21e 2544PP(pp_i_subtract)
79072805 2545{
39644a26 2546 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 2547 {
5e66d4f1 2548 dPOPTOPiirl_ul;
a0d0e21e
LW		 2549 SETi( left - right );
2550 RETURN;
79072805 2551 }
79072805
LW		 2552}
2553
a0d0e21e 2554PP(pp_i_lt)
79072805 2555{
39644a26 2556 dSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW		 2557 {
2558 dPOPTOPiirl;
54310121 2559 SETs(boolSV(left < right));
a0d0e21e
LW		 2560 RETURN;
2561 }
79072805
LW		 2562}
2563
a0d0e21e 2564PP(pp_i_gt)
79072805 2565{
39644a26 2566 dSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW		 2567 {
2568 dPOPTOPiirl;
54310121 2569 SETs(boolSV(left > right));
a0d0e21e
LW		 2570 RETURN;
2571 }
79072805
LW		 2572}
2573
a0d0e21e 2574PP(pp_i_le)
79072805 2575{
39644a26 2576 dSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW		 2577 {
2578 dPOPTOPiirl;
54310121 2579 SETs(boolSV(left <= right));
a0d0e21e 2580 RETURN;
85e6fe83 2581 }
79072805
LW		 2582}
2583
a0d0e21e 2584PP(pp_i_ge)
79072805 2585{
39644a26 2586 dSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW		 2587 {
2588 dPOPTOPiirl;
54310121 2589 SETs(boolSV(left >= right));
a0d0e21e
LW		 2590 RETURN;
2591 }
79072805
LW		 2592}
2593
a0d0e21e 2594PP(pp_i_eq)
79072805 2595{
39644a26 2596 dSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW		 2597 {
2598 dPOPTOPiirl;
54310121 2599 SETs(boolSV(left == right));
a0d0e21e
LW		 2600 RETURN;
2601 }
79072805
LW		 2602}
2603
a0d0e21e 2604PP(pp_i_ne)
79072805 2605{
39644a26 2606 dSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW		 2607 {
2608 dPOPTOPiirl;
54310121 2609 SETs(boolSV(left != right));
a0d0e21e
LW		 2610 RETURN;
2611 }
79072805
LW		 2612}
2613
a0d0e21e 2614PP(pp_i_ncmp)
79072805 2615{
39644a26 2616 dSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW		 2617 {
2618 dPOPTOPiirl;
2619 I32 value;
79072805 2620
a0d0e21e 2621 if (left > right)
79072805 2622 value = 1;
a0d0e21e 2623 else if (left < right)
79072805 2624 value = -1;
a0d0e21e 2625 else
79072805 2626 value = 0;
a0d0e21e
LW		 2627 SETi(value);
2628 RETURN;
79072805 2629 }
85e6fe83
LW		 2630}
2631
2632PP(pp_i_negate)
2633{
39644a26 2634 dSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW		 2635 SETi(-TOPi);
2636 RETURN;
2637}
2638
79072805
LW		 2639/* High falutin' math. */
2640
2641PP(pp_atan2)
2642{
39644a26 2643 dSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW		 2644 {
2645 dPOPTOPnnrl;
65202027 2646 SETn(Perl_atan2(left, right));
a0d0e21e
LW		 2647 RETURN;
2648 }
79072805
LW		 2649}
2650
2651PP(pp_sin)
2652{
39644a26 2653 dSP; dTARGET; tryAMAGICun(sin);
a0d0e21e 2654 {
65202027 2655 NV value;
a0d0e21e 2656 value = POPn;
65202027 2657 value = Perl_sin(value);
a0d0e21e
LW		 2658 XPUSHn(value);
2659 RETURN;
2660 }
79072805
LW		 2661}
2662
2663PP(pp_cos)
2664{
39644a26 2665 dSP; dTARGET; tryAMAGICun(cos);
a0d0e21e 2666 {
65202027 2667 NV value;
a0d0e21e 2668 value = POPn;
65202027 2669 value = Perl_cos(value);
a0d0e21e
LW		 2670 XPUSHn(value);
2671 RETURN;
2672 }
79072805
LW		 2673}
2674
56cb0a1c
AD		 2675/* Support Configure command-line overrides for rand() functions.
2676 After 5.005, perhaps we should replace this by Configure support
2677 for drand48(), random(), or rand(). For 5.005, though, maintain
2678 compatibility by calling rand() but allow the user to override it.
2679 See INSTALL for details. --Andy Dougherty 15 July 1998
2680*/
85ab1d1d
JH		 2681/* Now it's after 5.005, and Configure supports drand48() and random(),
2682 in addition to rand(). So the overrides should not be needed any more.
2683 --Jarkko Hietaniemi 27 September 1998
2684 */
2685
2686#ifndef HAS_DRAND48_PROTO
20ce7b12 2687extern double drand48 (void);
56cb0a1c
AD		 2688#endif
2689
79072805
LW		 2690PP(pp_rand)
2691{
39644a26 2692 dSP; dTARGET;
65202027 2693 NV value;
79072805
LW		 2694 if (MAXARG < 1)
2695 value = 1.0;
2696 else
2697 value = POPn;
2698 if (value == 0.0)
2699 value = 1.0;
80252599 2700 if (!PL_srand_called) {
85ab1d1d 2701 (void)seedDrand01((Rand_seed_t)seed());
80252599 2702 PL_srand_called = TRUE;
93dc8474 2703 }
85ab1d1d 2704 value *= Drand01();
79072805
LW		 2705 XPUSHn(value);
2706 RETURN;
2707}
2708
2709PP(pp_srand)
2710{
39644a26 2711 dSP;
93dc8474
CS		 2712 UV anum;
2713 if (MAXARG < 1)
2714 anum = seed();
79072805 2715 else
93dc8474 2716 anum = POPu;
85ab1d1d 2717 (void)seedDrand01((Rand_seed_t)anum);
80252599 2718 PL_srand_called = TRUE;
79072805
LW		 2719 EXTEND(SP, 1);
2720 RETPUSHYES;
2721}
2722
2723PP(pp_exp)
2724{
39644a26 2725 dSP; dTARGET; tryAMAGICun(exp);
a0d0e21e 2726 {
65202027 2727 NV value;
a0d0e21e 2728 value = POPn;
65202027 2729 value = Perl_exp(value);
a0d0e21e
LW		 2730 XPUSHn(value);
2731 RETURN;
2732 }
79072805
LW		 2733}
2734
2735PP(pp_log)
2736{
39644a26 2737 dSP; dTARGET; tryAMAGICun(log);
a0d0e21e 2738 {
65202027 2739 NV value;
a0d0e21e 2740 value = POPn;
bbce6d69 2741 if (value <= 0.0) {
f93f4e46 2742 SET_NUMERIC_STANDARD();
1779d84d 2743 DIE(aTHX_ "Can't take log of %"NVgf, value);
bbce6d69 2744 }
65202027 2745 value = Perl_log(value);
a0d0e21e
LW		 2746 XPUSHn(value);
2747 RETURN;
2748 }
79072805
LW		 2749}
2750
2751PP(pp_sqrt)
2752{
39644a26 2753 dSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e 2754 {
65202027 2755 NV value;
a0d0e21e 2756 value = POPn;
bbce6d69 2757 if (value < 0.0) {
f93f4e46 2758 SET_NUMERIC_STANDARD();
1779d84d 2759 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
bbce6d69 2760 }
65202027 2761 value = Perl_sqrt(value);
a0d0e21e
LW		 2762 XPUSHn(value);
2763 RETURN;
2764 }
79072805
LW		 2765}
2766
2767PP(pp_int)
2768{
39644a26 2769 dSP; dTARGET; tryAMAGICun(int);
774d564b 2770 {
28e5dec8
JH		 2771 NV value;
2772 IV iv = TOPi; /* attempt to convert to IV if possible. */
2773 /* XXX it's arguable that compiler casting to IV might be subtly
2774 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2775 else preferring IV has introduced a subtle behaviour change bug. OTOH
2776 relying on floating point to be accurate is a bug. */
2777
2778 if (SvIOK(TOPs)) {
2779 if (SvIsUV(TOPs)) {
2780 UV uv = TOPu;
2781 SETu(uv);
2782 } else
2783 SETi(iv);
2784 } else {
2785 value = TOPn;
1048ea30 2786 if (value >= 0.0) {
28e5dec8
JH		 2787 if (value < (NV)UV_MAX + 0.5) {
2788 SETu(U_V(value));
2789 } else {
059a1014 2790 SETn(Perl_floor(value));
28e5dec8 2791 }
1048ea30 2792 }
28e5dec8
JH		 2793 else {
2794 if (value > (NV)IV_MIN - 0.5) {
2795 SETi(I_V(value));
2796 } else {
1bbae031 2797 SETn(Perl_ceil(value));
28e5dec8
JH		 2798 }
2799 }
774d564b 2800 }
79072805 2801 }
79072805
LW		 2802 RETURN;
2803}
2804
463ee0b2
LW		 2805PP(pp_abs)
2806{
39644a26 2807 dSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 2808 {
28e5dec8
JH		 2809 /* This will cache the NV value if string isn't actually integer */
2810 IV iv = TOPi;
a227d84d 2811
28e5dec8
JH		 2812 if (SvIOK(TOPs)) {
2813 /* IVX is precise */
2814 if (SvIsUV(TOPs)) {
2815 SETu(TOPu); /* force it to be numeric only */
2816 } else {
2817 if (iv >= 0) {
2818 SETi(iv);
2819 } else {
2820 if (iv != IV_MIN) {
2821 SETi(-iv);
2822 } else {
2823 /* 2s complement assumption. Also, not really needed as
2824 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2825 SETu(IV_MIN);
2826 }
a227d84d 2827 }
28e5dec8
JH		 2828 }
2829 } else{
2830 NV value = TOPn;
774d564b 2831 if (value < 0.0)
28e5dec8 2832 value = -value;
774d564b 2833 SETn(value);
2834 }
a0d0e21e 2835 }
774d564b 2836 RETURN;
463ee0b2
LW		 2837}
2838
53305cf1 2839
79072805
LW		 2840PP(pp_hex)
2841{
39644a26 2842 dSP; dTARGET;
79072805 2843 char *tmps;
53305cf1 2844 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2845 STRLEN len;
53305cf1
NC		 2846 NV result_nv;
2847 UV result_uv;
2bc69dc4 2848 SV* sv = POPs;
79072805 2849
2bc69dc4
NIS		 2850 tmps = (SvPVx(sv, len));
2851 if (DO_UTF8(sv)) {
2852 /* If Unicode, try to downgrade
2853 * If not possible, croak. */
2854 SV* tsv = sv_2mortal(newSVsv(sv));
2855
2856 SvUTF8_on(tsv);
2857 sv_utf8_downgrade(tsv, FALSE);
2858 tmps = SvPVX(tsv);
2859 }
53305cf1
NC		 2860 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2861 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2862 XPUSHn(result_nv);
2863 }
2864 else {
2865 XPUSHu(result_uv);
2866 }
79072805
LW		 2867 RETURN;
2868}
2869
2870PP(pp_oct)
2871{
39644a26 2872 dSP; dTARGET;
79072805 2873 char *tmps;
53305cf1 2874 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2875 STRLEN len;
53305cf1
NC		 2876 NV result_nv;
2877 UV result_uv;
2bc69dc4 2878 SV* sv = POPs;
79072805 2879
2bc69dc4
NIS		 2880 tmps = (SvPVx(sv, len));
2881 if (DO_UTF8(sv)) {
2882 /* If Unicode, try to downgrade
2883 * If not possible, croak. */
2884 SV* tsv = sv_2mortal(newSVsv(sv));
2885
2886 SvUTF8_on(tsv);
2887 sv_utf8_downgrade(tsv, FALSE);
2888 tmps = SvPVX(tsv);
2889 }
6f894ead 2890 while (*tmps && len && isSPACE(*tmps))
53305cf1 2891 tmps++, len--;
9e24b6e2 2892 if (*tmps == '0')
53305cf1 2893 tmps++, len--;
9e24b6e2 2894 if (*tmps == 'x')
53305cf1 2895 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
9e24b6e2 2896 else if (*tmps == 'b')
53305cf1 2897 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2898 else
53305cf1
NC		 2899 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2900
2901 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2902 XPUSHn(result_nv);
2903 }
2904 else {
2905 XPUSHu(result_uv);
2906 }
79072805
LW		 2907 RETURN;
2908}
2909
2910/* String stuff. */
2911
2912PP(pp_length)
2913{
39644a26 2914 dSP; dTARGET;
7e2040f0 2915 SV *sv = TOPs;
a0ed51b3 2916
7e2040f0
GS		 2917 if (DO_UTF8(sv))
2918 SETi(sv_len_utf8(sv));
2919 else
2920 SETi(sv_len(sv));
79072805
LW		 2921 RETURN;
2922}
2923
2924PP(pp_substr)
2925{
39644a26 2926 dSP; dTARGET;
79072805 2927 SV *sv;
9c5ffd7c 2928 I32 len = 0;
463ee0b2 2929 STRLEN curlen;
9402d6ed 2930 STRLEN utf8_curlen;
79072805
LW		 2931 I32 pos;
2932 I32 rem;
84902520 2933 I32 fail;
78f9721b 2934 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
79072805 2935 char *tmps;
3280af22 2936 I32 arybase = PL_curcop->cop_arybase;
9402d6ed 2937 SV *repl_sv = NULL;
7b8d334a
GS		 2938 char *repl = 0;
2939 STRLEN repl_len;
78f9721b 2940 int num_args = PL_op->op_private & 7;
13e30c65 2941 bool repl_need_utf8_upgrade = FALSE;
9402d6ed 2942 bool repl_is_utf8 = FALSE;
79072805 2943
20408e3c 2944 SvTAINTED_off(TARG); /* decontaminate */
7e2040f0 2945 SvUTF8_off(TARG); /* decontaminate */
78f9721b
SM		 2946 if (num_args > 2) {
2947 if (num_args > 3) {
9402d6ed
JH		 2948 repl_sv = POPs;
2949 repl = SvPV(repl_sv, repl_len);
2950 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
7b8d334a 2951 }
79072805 2952 len = POPi;
5d82c453 2953 }
84902520 2954 pos = POPi;
79072805 2955 sv = POPs;
849ca7ee 2956 PUTBACK;
9402d6ed
JH		 2957 if (repl_sv) {
2958 if (repl_is_utf8) {
2959 if (!DO_UTF8(sv))
2960 sv_utf8_upgrade(sv);
2961 }
13e30c65
JH		 2962 else if (DO_UTF8(sv))
2963 repl_need_utf8_upgrade = TRUE;
9402d6ed 2964 }
a0d0e21e 2965 tmps = SvPV(sv, curlen);
7e2040f0 2966 if (DO_UTF8(sv)) {
9402d6ed
JH		 2967 utf8_curlen = sv_len_utf8(sv);
2968 if (utf8_curlen == curlen)
2969 utf8_curlen = 0;
a0ed51b3 2970 else
9402d6ed 2971 curlen = utf8_curlen;
a0ed51b3 2972 }
d1c2b58a 2973 else
9402d6ed 2974 utf8_curlen = 0;
a0ed51b3 2975
84902520
TB		 2976 if (pos >= arybase) {
2977 pos -= arybase;
2978 rem = curlen-pos;
2979 fail = rem;
78f9721b 2980 if (num_args > 2) {
5d82c453
GA		 2981 if (len < 0) {
2982 rem += len;
2983 if (rem < 0)
2984 rem = 0;
2985 }
2986 else if (rem > len)
2987 rem = len;
2988 }
68dc0745 2989 }
84902520 2990 else {
5d82c453 2991 pos += curlen;
78f9721b 2992 if (num_args < 3)
5d82c453
GA		 2993 rem = curlen;
2994 else if (len >= 0) {
2995 rem = pos+len;
2996 if (rem > (I32)curlen)
2997 rem = curlen;
2998 }
2999 else {
3000 rem = curlen+len;
3001 if (rem < pos)
3002 rem = pos;
3003 }
3004 if (pos < 0)
3005 pos = 0;
3006 fail = rem;
3007 rem -= pos;
84902520
TB		 3008 }
3009 if (fail < 0) {
e476b1b5
GS		 3010 if (lvalue || repl)
3011 Perl_croak(aTHX_ "substr outside of string");
3012 if (ckWARN(WARN_SUBSTR))
9014280d 3013 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2304df62
AD		 3014 RETPUSHUNDEF;
3015 }
79072805 3016 else {
9aa983d2
JH		 3017 I32 upos = pos;
3018 I32 urem = rem;
9402d6ed 3019 if (utf8_curlen)
a0ed51b3 3020 sv_pos_u2b(sv, &pos, &rem);
79072805 3021 tmps += pos;
79072805 3022 sv_setpvn(TARG, tmps, rem);
12aa1545 3023#ifdef USE_LOCALE_COLLATE
14befaf4 3024 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3025#endif
9402d6ed 3026 if (utf8_curlen)
7f66633b 3027 SvUTF8_on(TARG);
f7928d6c 3028 if (repl) {
13e30c65
JH		 3029 SV* repl_sv_copy = NULL;
3030
3031 if (repl_need_utf8_upgrade) {
3032 repl_sv_copy = newSVsv(repl_sv);
3033 sv_utf8_upgrade(repl_sv_copy);
3034 repl = SvPV(repl_sv_copy, repl_len);
3035 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3036 }
c8faf1c5 3037 sv_insert(sv, pos, rem, repl, repl_len);
9402d6ed 3038 if (repl_is_utf8)
f7928d6c 3039 SvUTF8_on(sv);
9402d6ed
JH		 3040 if (repl_sv_copy)
3041 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3042 }
c8faf1c5 3043 else if (lvalue) { /* it's an lvalue! */
dedeecda 3044 if (!SvGMAGICAL(sv)) {
3045 if (SvROK(sv)) {
2d8e6c8d
GS		 3046 STRLEN n_a;
3047 SvPV_force(sv,n_a);
599cee73 3048 if (ckWARN(WARN_SUBSTR))
9014280d 3049 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
599cee73 3050 "Attempt to use reference as lvalue in substr");
dedeecda 3051 }
3052 if (SvOK(sv)) /* is it defined ? */
7f66633b 3053 (void)SvPOK_only_UTF8(sv);
dedeecda 3054 else
3055 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3056 }
5f05dabc 3057
24aef97f
HS		 3058 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3059 TARG = sv_newmortal();
a0d0e21e
LW		 3060 if (SvTYPE(TARG) < SVt_PVLV) {
3061 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3062 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
ed6116ce 3063 }
6214ab63
AE		 3064 else
3065 (void)SvOK_off(TARG);
a0d0e21e 3066
5f05dabc 3067 LvTYPE(TARG) = 'x';
6ff81951
GS		 3068 if (LvTARG(TARG) != sv) {
3069 if (LvTARG(TARG))
3070 SvREFCNT_dec(LvTARG(TARG));
3071 LvTARG(TARG) = SvREFCNT_inc(sv);
3072 }
9aa983d2
JH		 3073 LvTARGOFF(TARG) = upos;
3074 LvTARGLEN(TARG) = urem;
79072805
LW		 3075 }
3076 }
849ca7ee 3077 SPAGAIN;
79072805
LW		 3078 PUSHs(TARG); /* avoid SvSETMAGIC here */
3079 RETURN;
3080}
3081
3082PP(pp_vec)
3083{
39644a26 3084 dSP; dTARGET;
467f0320
JH		 3085 register IV size = POPi;
3086 register IV offset = POPi;
79072805 3087 register SV *src = POPs;
78f9721b 3088 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e 3089
81e118e0
JH		 3090 SvTAINTED_off(TARG); /* decontaminate */
3091 if (lvalue) { /* it's an lvalue! */
24aef97f
HS		 3092 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3093 TARG = sv_newmortal();
81e118e0
JH		 3094 if (SvTYPE(TARG) < SVt_PVLV) {
3095 sv_upgrade(TARG, SVt_PVLV);
14befaf4 3096 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
79072805 3097 }
81e118e0
JH		 3098 LvTYPE(TARG) = 'v';
3099 if (LvTARG(TARG) != src) {
3100 if (LvTARG(TARG))
3101 SvREFCNT_dec(LvTARG(TARG));
3102 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 3103 }
81e118e0
JH		 3104 LvTARGOFF(TARG) = offset;
3105 LvTARGLEN(TARG) = size;
79072805
LW		 3106 }
3107
81e118e0 3108 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW		 3109 PUSHs(TARG);
3110 RETURN;
3111}
3112
3113PP(pp_index)
3114{
39644a26 3115 dSP; dTARGET;
79072805
LW		 3116 SV *big;
3117 SV *little;
3118 I32 offset;
3119 I32 retval;
3120 char *tmps;
3121 char *tmps2;
463ee0b2 3122 STRLEN biglen;
3280af22 3123 I32 arybase = PL_curcop->cop_arybase;
79072805
LW		 3124
3125 if (MAXARG < 3)
3126 offset = 0;
3127 else
3128 offset = POPi - arybase;
3129 little = POPs;
3130 big = POPs;
463ee0b2 3131 tmps = SvPV(big, biglen);
7e2040f0 3132 if (offset > 0 && DO_UTF8(big))
a0ed51b3 3133 sv_pos_u2b(big, &offset, 0);
79072805
LW		 3134 if (offset < 0)
3135 offset = 0;
eb160463 3136 else if (offset > (I32)biglen)
93a17b20 3137 offset = biglen;
79072805 3138 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 3139 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 3140 retval = -1;
79072805 3141 else
a0ed51b3 3142 retval = tmps2 - tmps;
7e2040f0 3143 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3144 sv_pos_b2u(big, &retval);
3145 PUSHi(retval + arybase);
79072805
LW		 3146 RETURN;
3147}
3148
3149PP(pp_rindex)
3150{
39644a26 3151 dSP; dTARGET;
79072805
LW		 3152 SV *big;
3153 SV *little;
463ee0b2
LW		 3154 STRLEN blen;
3155 STRLEN llen;
79072805
LW		 3156 I32 offset;
3157 I32 retval;
3158 char *tmps;
3159 char *tmps2;
3280af22 3160 I32 arybase = PL_curcop->cop_arybase;
79072805 3161
a0d0e21e 3162 if (MAXARG >= 3)
a0ed51b3 3163 offset = POPi;
79072805
LW		 3164 little = POPs;
3165 big = POPs;
463ee0b2
LW		 3166 tmps2 = SvPV(little, llen);
3167 tmps = SvPV(big, blen);
79072805 3168 if (MAXARG < 3)
463ee0b2 3169 offset = blen;
a0ed51b3 3170 else {
7e2040f0 3171 if (offset > 0 && DO_UTF8(big))
a0ed51b3
LW		 3172 sv_pos_u2b(big, &offset, 0);
3173 offset = offset - arybase + llen;
3174 }
79072805
LW		 3175 if (offset < 0)
3176 offset = 0;
eb160463 3177 else if (offset > (I32)blen)
463ee0b2 3178 offset = blen;
79072805 3179 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 3180 tmps2, tmps2 + llen)))
a0ed51b3 3181 retval = -1;
79072805 3182 else
a0ed51b3 3183 retval = tmps2 - tmps;
7e2040f0 3184 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 3185 sv_pos_b2u(big, &retval);
3186 PUSHi(retval + arybase);
79072805
LW		 3187 RETURN;
3188}
3189
3190PP(pp_sprintf)
3191{
39644a26 3192 dSP; dMARK; dORIGMARK; dTARGET;
79072805 3193 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3194 TAINT_IF(SvTAINTED(TARG));
6ee35fb7
JH		 3195 if (DO_UTF8(*(MARK+1)))
3196 SvUTF8_on(TARG);
79072805
LW		 3197 SP = ORIGMARK;
3198 PUSHTARG;
3199 RETURN;
3200}
3201
79072805
LW		 3202PP(pp_ord)
3203{
39644a26 3204 dSP; dTARGET;
7df053ec 3205 SV *argsv = POPs;
ba210ebe 3206 STRLEN len;
7df053ec 3207 U8 *s = (U8*)SvPVx(argsv, len);
121910a4
JH		 3208 SV *tmpsv;
3209
799ef3cb 3210 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
121910a4 3211 tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3212 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
121910a4
JH		 3213 argsv = tmpsv;
3214 }
79072805 3215
872c91ae
JH		 3216 XPUSHu(DO_UTF8(argsv) ?
3217 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3218 (*s & 0xff));
68795e93 3219
79072805
LW		 3220 RETURN;
3221}
3222
463ee0b2
LW		 3223PP(pp_chr)
3224{
39644a26 3225 dSP; dTARGET;
463ee0b2 3226 char *tmps;
467f0320 3227 UV value = POPu;
463ee0b2 3228
748a9306 3229 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3230
0064a8a9 3231 if (value > 255 && !IN_BYTES) {
eb160463 3232 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3233 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
a0ed51b3
LW		 3234 SvCUR_set(TARG, tmps - SvPVX(TARG));
3235 *tmps = '\0';
3236 (void)SvPOK_only(TARG);
aa6ffa16 3237 SvUTF8_on(TARG);
a0ed51b3
LW		 3238 XPUSHs(TARG);
3239 RETURN;
3240 }
3241
748a9306 3242 SvGROW(TARG,2);
463ee0b2
LW		 3243 SvCUR_set(TARG, 1);
3244 tmps = SvPVX(TARG);
eb160463 3245 *tmps++ = (char)value;
748a9306 3246 *tmps = '\0';
a0d0e21e 3247 (void)SvPOK_only(TARG);
88632417 3248 if (PL_encoding && !IN_BYTES) {
799ef3cb 3249 sv_recode_to_utf8(TARG, PL_encoding);
88632417
JH		 3250 tmps = SvPVX(TARG);
3251 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3252 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
d5a15ac2
JH		 3253 SvGROW(TARG, 3);
3254 tmps = SvPVX(TARG);
88632417
JH		 3255 SvCUR_set(TARG, 2);
3256 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3257 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3258 *tmps = '\0';
3259 SvUTF8_on(TARG);
3260 }
3261 }
463ee0b2
LW		 3262 XPUSHs(TARG);
3263 RETURN;
3264}
3265
79072805
LW		 3266PP(pp_crypt)
3267{
5f74f29c 3268 dSP; dTARGET;
79072805 3269#ifdef HAS_CRYPT
5f74f29c
JH		 3270 dPOPTOPssrl;
3271 STRLEN n_a;
85c16d83
JH		 3272 STRLEN len;
3273 char *tmps = SvPV(left, len);
2bc69dc4 3274
85c16d83 3275 if (DO_UTF8(left)) {
2bc69dc4 3276 /* If Unicode, try to downgrade.
f2791508
JH		 3277 * If not possible, croak.
3278 * Yes, we made this up. */
3279 SV* tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3280
f2791508 3281 SvUTF8_on(tsv);
2bc69dc4 3282 sv_utf8_downgrade(tsv, FALSE);
f2791508 3283 tmps = SvPVX(tsv);
85c16d83 3284 }
05404ffe
JH		 3285# ifdef USE_ITHREADS
3286# ifdef HAS_CRYPT_R
3287 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3288 /* This should be threadsafe because in ithreads there is only
3289 * one thread per interpreter. If this would not be true,
3290 * we would need a mutex to protect this malloc. */
3291 PL_reentrant_buffer->_crypt_struct_buffer =
3292 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3293#if defined(__GLIBC__) || defined(__EMX__)
3294 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3295 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3296 /* work around glibc-2.2.5 bug */
3297 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3298 }
05404ffe 3299#endif
6ab58e4d 3300 }
05404ffe
JH		 3301# endif /* HAS_CRYPT_R */
3302# endif /* USE_ITHREADS */
5f74f29c 3303# ifdef FCRYPT
2d8e6c8d 3304 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
5f74f29c 3305# else
2d8e6c8d 3306 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
5f74f29c 3307# endif
4808266b
JH		 3308 SETs(TARG);
3309 RETURN;
79072805 3310#else
b13b2135 3311 DIE(aTHX_
79072805
LW		 3312 "The crypt() function is unimplemented due to excessive paranoia.");
3313#endif
79072805
LW		 3314}
3315
3316PP(pp_ucfirst)
3317{
39644a26 3318 dSP;
79072805 3319 SV *sv = TOPs;
a0ed51b3
LW		 3320 register U8 *s;
3321 STRLEN slen;
3322
d104a74c 3323 SvGETMAGIC(sv);
3a2263fe
RGS		 3324 if (DO_UTF8(sv) &&
3325 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3326 UTF8_IS_START(*s)) {
e7ae6809 3327 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
44bc797b
JH		 3328 STRLEN ulen;
3329 STRLEN tculen;
a0ed51b3 3330
44bc797b 3331 utf8_to_uvchr(s, &ulen);
44bc797b
JH		 3332 toTITLE_utf8(s, tmpbuf, &tculen);
3333 utf8_to_uvchr(tmpbuf, 0);
3334
3335 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
a0ed51b3 3336 dTARGET;
3a2263fe
RGS		 3337 /* slen is the byte length of the whole SV.
3338 * ulen is the byte length of the original Unicode character
3339 * stored as UTF-8 at s.
3340 * tculen is the byte length of the freshly titlecased
3341 * Unicode character stored as UTF-8 at tmpbuf.
3342 * We first set the result to be the titlecased character,
3343 * and then append the rest of the SV data. */
44bc797b 3344 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3a2263fe
RGS		 3345 if (slen > ulen)
3346 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3347 SvUTF8_on(TARG);
a0ed51b3
LW		 3348 SETs(TARG);
3349 }
3350 else {
d104a74c 3351 s = (U8*)SvPV_force_nomg(sv, slen);
44bc797b 3352 Copy(tmpbuf, s, tculen, U8);
a0ed51b3 3353 }
a0ed51b3 3354 }
626727d5 3355 else {
014822e4 3356 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3357 dTARGET;
7e2040f0 3358 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3359 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3360 sv = TARG;
3361 SETs(sv);
3362 }
d104a74c 3363 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3364 if (*s) {
2de3dbcc 3365 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3366 TAINT;
3367 SvTAINTED_on(sv);
3368 *s = toUPPER_LC(*s);
3369 }
3370 else
3371 *s = toUPPER(*s);
bbce6d69 3372 }
bbce6d69 3373 }
d104a74c 3374 SvSETMAGIC(sv);
79072805
LW		 3375 RETURN;
3376}
3377
3378PP(pp_lcfirst)
3379{
39644a26 3380 dSP;
79072805 3381 SV *sv = TOPs;
a0ed51b3
LW		 3382 register U8 *s;
3383 STRLEN slen;
3384
d104a74c 3385 SvGETMAGIC(sv);
3a2263fe
RGS		 3386 if (DO_UTF8(sv) &&
3387 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3388 UTF8_IS_START(*s)) {
ba210ebe 3389 STRLEN ulen;
e7ae6809 3390 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3391 U8 *tend;
9041c2e3 3392 UV uv;
a0ed51b3 3393
44bc797b 3394 toLOWER_utf8(s, tmpbuf, &ulen);
a2a2844f 3395 uv = utf8_to_uvchr(tmpbuf, 0);
9041c2e3 3396 tend = uvchr_to_utf8(tmpbuf, uv);
a0ed51b3 3397
eb160463 3398 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
a0ed51b3 3399 dTARGET;
dfe13c55 3400 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3a2263fe
RGS		 3401 if (slen > ulen)
3402 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 3403 SvUTF8_on(TARG);
a0ed51b3
LW		 3404 SETs(TARG);
3405 }
3406 else {
d104a74c 3407 s = (U8*)SvPV_force_nomg(sv, slen);
a0ed51b3
LW		 3408 Copy(tmpbuf, s, ulen, U8);
3409 }
a0ed51b3 3410 }
626727d5 3411 else {
014822e4 3412 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3413 dTARGET;
7e2040f0 3414 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3415 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3416 sv = TARG;
3417 SETs(sv);
3418 }
d104a74c 3419 s = (U8*)SvPV_force_nomg(sv, slen);
31351b04 3420 if (*s) {
2de3dbcc 3421 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3422 TAINT;
3423 SvTAINTED_on(sv);
3424 *s = toLOWER_LC(*s);
3425 }
3426 else
3427 *s = toLOWER(*s);
bbce6d69 3428 }
bbce6d69 3429 }
d104a74c 3430 SvSETMAGIC(sv);
79072805
LW		 3431 RETURN;
3432}
3433
3434PP(pp_uc)
3435{
39644a26 3436 dSP;
79072805 3437 SV *sv = TOPs;
a0ed51b3 3438 register U8 *s;
463ee0b2 3439 STRLEN len;
79072805 3440
d104a74c 3441 SvGETMAGIC(sv);
7e2040f0 3442 if (DO_UTF8(sv)) {
a0ed51b3 3443 dTARGET;
ba210ebe 3444 STRLEN ulen;
a0ed51b3
LW		 3445 register U8 *d;
3446 U8 *send;
e7ae6809 3447 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3448
d104a74c 3449 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3450 if (!len) {
7e2040f0 3451 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3452 sv_setpvn(TARG, "", 0);
3453 SETs(TARG);
a0ed51b3
LW		 3454 }
3455 else {
98b27f73
JH		 3456 STRLEN nchar = utf8_length(s, s + len);
3457
31351b04 3458 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3459 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3460 (void)SvPOK_only(TARG);
3461 d = (U8*)SvPVX(TARG);
3462 send = s + len;
a2a2844f 3463 while (s < send) {
6fdb5f96 3464 toUPPER_utf8(s, tmpbuf, &ulen);
a2a2844f
JH		 3465 Copy(tmpbuf, d, ulen, U8);
3466 d += ulen;
3467 s += UTF8SKIP(s);
a0ed51b3 3468 }
31351b04 3469 *d = '\0';
7e2040f0 3470 SvUTF8_on(TARG);
31351b04
JS		 3471 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3472 SETs(TARG);
a0ed51b3 3473 }
a0ed51b3 3474 }
626727d5 3475 else {
014822e4 3476 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3477 dTARGET;
7e2040f0 3478 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3479 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3480 sv = TARG;
3481 SETs(sv);
3482 }
d104a74c 3483 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3484 if (len) {
3485 register U8 *send = s + len;
3486
2de3dbcc 3487 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3488 TAINT;
3489 SvTAINTED_on(sv);
3490 for (; s < send; s++)
3491 *s = toUPPER_LC(*s);
3492 }
3493 else {
3494 for (; s < send; s++)
3495 *s = toUPPER(*s);
3496 }
bbce6d69 3497 }
79072805 3498 }
d104a74c 3499 SvSETMAGIC(sv);
79072805
LW		 3500 RETURN;
3501}
3502
3503PP(pp_lc)
3504{
39644a26 3505 dSP;
79072805 3506 SV *sv = TOPs;
a0ed51b3 3507 register U8 *s;
463ee0b2 3508 STRLEN len;
79072805 3509
d104a74c 3510 SvGETMAGIC(sv);
7e2040f0 3511 if (DO_UTF8(sv)) {
a0ed51b3 3512 dTARGET;
ba210ebe 3513 STRLEN ulen;
a0ed51b3
LW		 3514 register U8 *d;
3515 U8 *send;
e7ae6809 3516 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
a0ed51b3 3517
d104a74c 3518 s = (U8*)SvPV_nomg(sv,len);
a5a20234 3519 if (!len) {
7e2040f0 3520 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 3521 sv_setpvn(TARG, "", 0);
3522 SETs(TARG);
a0ed51b3
LW		 3523 }
3524 else {
98b27f73
JH		 3525 STRLEN nchar = utf8_length(s, s + len);
3526
31351b04 3527 (void)SvUPGRADE(TARG, SVt_PV);
98b27f73 3528 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
31351b04
JS		 3529 (void)SvPOK_only(TARG);
3530 d = (U8*)SvPVX(TARG);
3531 send = s + len;
a2a2844f 3532 while (s < send) {
6fdb5f96
JH		 3533 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3534#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3535 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3536 /*
3537 * Now if the sigma is NOT followed by
3538 * /$ignorable_sequence$cased_letter/;
3539 * and it IS preceded by
3540 * /$cased_letter$ignorable_sequence/;
3541 * where $ignorable_sequence is
3542 * [\x{2010}\x{AD}\p{Mn}]*
3543 * and $cased_letter is
3544 * [\p{Ll}\p{Lo}\p{Lt}]
3545 * then it should be mapped to 0x03C2,
3546 * (GREEK SMALL LETTER FINAL SIGMA),
3547 * instead of staying 0x03A3.
3548 * See lib/unicore/SpecCase.txt.
3549 */
3550 }
a2a2844f
JH		 3551 Copy(tmpbuf, d, ulen, U8);
3552 d += ulen;
3553 s += UTF8SKIP(s);
a0ed51b3 3554 }
31351b04 3555 *d = '\0';
7e2040f0 3556 SvUTF8_on(TARG);
31351b04
JS		 3557 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3558 SETs(TARG);
a0ed51b3 3559 }
79072805 3560 }
626727d5 3561 else {
014822e4 3562 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 3563 dTARGET;
7e2040f0 3564 SvUTF8_off(TARG); /* decontaminate */
d104a74c 3565 sv_setsv_nomg(TARG, sv);
31351b04
JS		 3566 sv = TARG;
3567 SETs(sv);
a0ed51b3 3568 }
bbce6d69 3569
d104a74c 3570 s = (U8*)SvPV_force_nomg(sv, len);
31351b04
JS		 3571 if (len) {
3572 register U8 *send = s + len;
bbce6d69 3573
2de3dbcc 3574 if (IN_LOCALE_RUNTIME) {
31351b04
JS		 3575 TAINT;
3576 SvTAINTED_on(sv);
3577 for (; s < send; s++)
3578 *s = toLOWER_LC(*s);
3579 }
3580 else {
3581 for (; s < send; s++)
3582 *s = toLOWER(*s);
3583 }
bbce6d69 3584 }
79072805 3585 }
d104a74c 3586 SvSETMAGIC(sv);
79072805
LW		 3587 RETURN;
3588}
3589
a0d0e21e 3590PP(pp_quotemeta)
79072805 3591{
39644a26 3592 dSP; dTARGET;
a0d0e21e
LW		 3593 SV *sv = TOPs;
3594 STRLEN len;
3595 register char *s = SvPV(sv,len);
3596 register char *d;
79072805 3597
7e2040f0 3598 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW		 3599 if (len) {
3600 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 3601 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 3602 d = SvPVX(TARG);
7e2040f0 3603 if (DO_UTF8(sv)) {
0dd2cdef 3604 while (len) {
fd400ab9 3605 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 3606 STRLEN ulen = UTF8SKIP(s);
3607 if (ulen > len)
3608 ulen = len;
3609 len -= ulen;
3610 while (ulen--)
3611 *d++ = *s++;
3612 }
3613 else {
3614 if (!isALNUM(*s))
3615 *d++ = '\\';
3616 *d++ = *s++;
3617 len--;
3618 }
3619 }
7e2040f0 3620 SvUTF8_on(TARG);
0dd2cdef
LW		 3621 }
3622 else {
3623 while (len--) {
3624 if (!isALNUM(*s))
3625 *d++ = '\\';
3626 *d++ = *s++;
3627 }
79072805 3628 }
a0d0e21e
LW		 3629 *d = '\0';
3630 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 3631 (void)SvPOK_only_UTF8(TARG);
79072805 3632 }
a0d0e21e
LW		 3633 else
3634 sv_setpvn(TARG, s, len);
3635 SETs(TARG);
31351b04
JS		 3636 if (SvSMAGICAL(TARG))
3637 mg_set(TARG);
79072805
LW		 3638 RETURN;
3639}
3640
a0d0e21e 3641/* Arrays. */
79072805 3642
a0d0e21e 3643PP(pp_aslice)
79072805 3644{
39644a26 3645 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3646 register SV** svp;
3647 register AV* av = (AV*)POPs;
78f9721b 3648 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3280af22 3649 I32 arybase = PL_curcop->cop_arybase;
748a9306 3650 I32 elem;
79072805 3651
a0d0e21e 3652 if (SvTYPE(av) == SVt_PVAV) {
533c011a 3653 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 3654 I32 max = -1;
924508f0 3655 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 3656 elem = SvIVx(*svp);
3657 if (elem > max)
3658 max = elem;
3659 }
3660 if (max > AvMAX(av))
3661 av_extend(av, max);
3662 }
a0d0e21e 3663 while (++MARK <= SP) {
748a9306 3664 elem = SvIVx(*MARK);
a0d0e21e 3665
748a9306
LW		 3666 if (elem > 0)
3667 elem -= arybase;
a0d0e21e
LW		 3668 svp = av_fetch(av, elem, lval);
3669 if (lval) {
3280af22 3670 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 3671 DIE(aTHX_ PL_no_aelem, elem);
533c011a 3672 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 3673 save_aelem(av, elem, svp);
79072805 3674 }
3280af22 3675 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 3676 }
3677 }
748a9306 3678 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 3679 MARK = ORIGMARK;
3680 *++MARK = *SP;
3681 SP = MARK;
3682 }
79072805
LW		 3683 RETURN;
3684}
3685
3686/* Associative arrays. */
3687
3688PP(pp_each)
3689{
39644a26 3690 dSP;
79072805 3691 HV *hash = (HV*)POPs;
c07a80fd 3692 HE *entry;
54310121 3693 I32 gimme = GIMME_V;
8ec5e241 3694
c07a80fd 3695 PUTBACK;
c750a3ec 3696 /* might clobber stack_sp */
6d822dc4 3697 entry = hv_iternext(hash);
c07a80fd 3698 SPAGAIN;
79072805 3699
79072805
LW		 3700 EXTEND(SP, 2);
3701 if (entry) {
574c8022 3702 SV* sv = hv_iterkeysv(entry);
574c8022 3703 PUSHs(sv); /* won't clobber stack_sp */
54310121 3704 if (gimme == G_ARRAY) {
59af0135 3705 SV *val;
c07a80fd 3706 PUTBACK;
c750a3ec 3707 /* might clobber stack_sp */
6d822dc4 3708 val = hv_iterval(hash, entry);
c07a80fd 3709 SPAGAIN;
59af0135 3710 PUSHs(val);
79072805 3711 }
79072805 3712 }
54310121 3713 else if (gimme == G_SCALAR)
79072805
LW		 3714 RETPUSHUNDEF;
3715
3716 RETURN;
3717}
3718
3719PP(pp_values)
3720{
cea2e8a9 3721 return do_kv();
79072805
LW		 3722}
3723
3724PP(pp_keys)
3725{
cea2e8a9 3726 return do_kv();
79072805
LW		 3727}
3728
3729PP(pp_delete)
3730{
39644a26 3731 dSP;
54310121 3732 I32 gimme = GIMME_V;
3733 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 3734 SV *sv;
5f05dabc 3735 HV *hv;
3736
533c011a 3737 if (PL_op->op_private & OPpSLICE) {
5f05dabc 3738 dMARK; dORIGMARK;
97fcbf96 3739 U32 hvtype;
5f05dabc 3740 hv = (HV*)POPs;
97fcbf96 3741 hvtype = SvTYPE(hv);
01020589
GS		 3742 if (hvtype == SVt_PVHV) { /* hash element */
3743 while (++MARK <= SP) {
ae77835f 3744 sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 3745 *MARK = sv ? sv : &PL_sv_undef;
3746 }
5f05dabc 3747 }
6d822dc4
MS		 3748 else if (hvtype == SVt_PVAV) { /* array element */
3749 if (PL_op->op_flags & OPf_SPECIAL) {
3750 while (++MARK <= SP) {
3751 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3752 *MARK = sv ? sv : &PL_sv_undef;
3753 }
3754 }
01020589
GS		 3755 }
3756 else
3757 DIE(aTHX_ "Not a HASH reference");
54310121 3758 if (discard)
3759 SP = ORIGMARK;
3760 else if (gimme == G_SCALAR) {
5f05dabc 3761 MARK = ORIGMARK;
3762 *++MARK = *SP;
3763 SP = MARK;
3764 }
3765 }
3766 else {
3767 SV *keysv = POPs;
3768 hv = (HV*)POPs;
97fcbf96
MB		 3769 if (SvTYPE(hv) == SVt_PVHV)
3770 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 3771 else if (SvTYPE(hv) == SVt_PVAV) {
3772 if (PL_op->op_flags & OPf_SPECIAL)
3773 sv = av_delete((AV*)hv, SvIV(keysv), discard);
af288a60
HS		 3774 else
3775 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 3776 }
97fcbf96 3777 else
cea2e8a9 3778 DIE(aTHX_ "Not a HASH reference");
5f05dabc 3779 if (!sv)
3280af22 3780 sv = &PL_sv_undef;
54310121 3781 if (!discard)
3782 PUSHs(sv);
79072805 3783 }
79072805
LW		 3784 RETURN;
3785}
3786
a0d0e21e 3787PP(pp_exists)
79072805 3788{
39644a26 3789 dSP;
afebc493
GS		 3790 SV *tmpsv;
3791 HV *hv;
3792
3793 if (PL_op->op_private & OPpEXISTS_SUB) {
3794 GV *gv;
3795 CV *cv;
3796 SV *sv = POPs;
3797 cv = sv_2cv(sv, &hv, &gv, FALSE);
3798 if (cv)
3799 RETPUSHYES;
3800 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3801 RETPUSHYES;
3802 RETPUSHNO;
3803 }
3804 tmpsv = POPs;
3805 hv = (HV*)POPs;
c750a3ec 3806 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 3807 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 3808 RETPUSHYES;
ef54e1a4
JH		 3809 }
3810 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS		 3811 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3812 if (av_exists((AV*)hv, SvIV(tmpsv)))
3813 RETPUSHYES;
3814 }
ef54e1a4
JH		 3815 }
3816 else {
cea2e8a9 3817 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 3818 }
a0d0e21e
LW		 3819 RETPUSHNO;
3820}
79072805 3821
a0d0e21e
LW		 3822PP(pp_hslice)
3823{
39644a26 3824 dSP; dMARK; dORIGMARK;
a0d0e21e 3825 register HV *hv = (HV*)POPs;
78f9721b 3826 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
eb85dfd3
DM		 3827 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3828 bool other_magic = FALSE;
79072805 3829
eb85dfd3
DM		 3830 if (localizing) {
3831 MAGIC *mg;
3832 HV *stash;
3833
3834 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3835 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3836 /* Try to preserve the existenceness of a tied hash
3837 * element by using EXISTS and DELETE if possible.
3838 * Fallback to FETCH and STORE otherwise */
3839 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3840 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3841 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3842 }
3843
6d822dc4
MS		 3844 while (++MARK <= SP) {
3845 SV *keysv = *MARK;
3846 SV **svp;
3847 HE *he;
3848 bool preeminent = FALSE;
0ebe0038 3849
6d822dc4
MS		 3850 if (localizing) {
3851 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3852 hv_exists_ent(hv, keysv, 0);
3853 }
eb85dfd3 3854
6d822dc4
MS		 3855 he = hv_fetch_ent(hv, keysv, lval, 0);
3856 svp = he ? &HeVAL(he) : 0;
eb85dfd3 3857
6d822dc4
MS		 3858 if (lval) {
3859 if (!svp || *svp == &PL_sv_undef) {
3860 STRLEN n_a;
3861 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3862 }
3863 if (localizing) {
3864 if (preeminent)
3865 save_helem(hv, keysv, svp);
3866 else {
3867 STRLEN keylen;
3868 char *key = SvPV(keysv, keylen);
3869 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1f5346dc 3870 }
6d822dc4
MS		 3871 }
3872 }
3873 *MARK = svp ? *svp : &PL_sv_undef;
79072805 3874 }
a0d0e21e
LW		 3875 if (GIMME != G_ARRAY) {
3876 MARK = ORIGMARK;
3877 *++MARK = *SP;
3878 SP = MARK;
79072805 3879 }
a0d0e21e
LW		 3880 RETURN;
3881}
3882
3883/* List operators. */
3884
3885PP(pp_list)
3886{
39644a26 3887 dSP; dMARK;
a0d0e21e
LW		 3888 if (GIMME != G_ARRAY) {
3889 if (++MARK <= SP)
3890 *MARK = *SP; /* unwanted list, return last item */
8990e307 3891 else
3280af22 3892 *MARK = &PL_sv_undef;
a0d0e21e 3893 SP = MARK;
79072805 3894 }
a0d0e21e 3895 RETURN;
79072805
LW		 3896}
3897
a0d0e21e 3898PP(pp_lslice)
79072805 3899{
39644a26 3900 dSP;
3280af22
NIS		 3901 SV **lastrelem = PL_stack_sp;
3902 SV **lastlelem = PL_stack_base + POPMARK;
3903 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 3904 register SV **firstrelem = lastlelem + 1;
3280af22 3905 I32 arybase = PL_curcop->cop_arybase;
533c011a 3906 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 3907 I32 is_something_there = lval;
79072805 3908
a0d0e21e
LW		 3909 register I32 max = lastrelem - lastlelem;
3910 register SV **lelem;
3911 register I32 ix;
3912
3913 if (GIMME != G_ARRAY) {
748a9306
LW		 3914 ix = SvIVx(*lastlelem);
3915 if (ix < 0)
3916 ix += max;
3917 else
3918 ix -= arybase;
a0d0e21e 3919 if (ix < 0 || ix >= max)
3280af22 3920 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 3921 else
3922 *firstlelem = firstrelem[ix];
3923 SP = firstlelem;
3924 RETURN;
3925 }
3926
3927 if (max == 0) {
3928 SP = firstlelem - 1;
3929 RETURN;
3930 }
3931
3932 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 3933 ix = SvIVx(*lelem);
c73bf8e3 3934 if (ix < 0)
a0d0e21e 3935 ix += max;
b13b2135 3936 else
748a9306 3937 ix -= arybase;
c73bf8e3
HS		 3938 if (ix < 0 || ix >= max)
3939 *lelem = &PL_sv_undef;
3940 else {
3941 is_something_there = TRUE;
3942 if (!(*lelem = firstrelem[ix]))
3280af22 3943 *lelem = &PL_sv_undef;
748a9306 3944 }
79072805 3945 }
4633a7c4
LW		 3946 if (is_something_there)
3947 SP = lastlelem;
3948 else
3949 SP = firstlelem - 1;
79072805
LW		 3950 RETURN;
3951}
3952
a0d0e21e
LW		 3953PP(pp_anonlist)
3954{
39644a26 3955 dSP; dMARK; dORIGMARK;
a0d0e21e 3956 I32 items = SP - MARK;
44a8e56a 3957 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
3958 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3959 XPUSHs(av);
a0d0e21e
LW		 3960 RETURN;
3961}
3962
3963PP(pp_anonhash)
79072805 3964{
39644a26 3965 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3966 HV* hv = (HV*)sv_2mortal((SV*)newHV());
3967
3968 while (MARK < SP) {
3969 SV* key = *++MARK;
a0d0e21e
LW		 3970 SV *val = NEWSV(46, 0);
3971 if (MARK < SP)
3972 sv_setsv(val, *++MARK);
e476b1b5 3973 else if (ckWARN(WARN_MISC))
9014280d 3974 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
f12c7020 3975 (void)hv_store_ent(hv,key,val,0);
79072805 3976 }
a0d0e21e
LW		 3977 SP = ORIGMARK;
3978 XPUSHs((SV*)hv);
79072805
LW		 3979 RETURN;
3980}
3981
a0d0e21e 3982PP(pp_splice)
79072805 3983{
39644a26 3984 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 3985 register AV *ary = (AV*)*++MARK;
3986 register SV **src;
3987 register SV **dst;
3988 register I32 i;
3989 register I32 offset;
3990 register I32 length;
3991 I32 newlen;
3992 I32 after;
3993 I32 diff;
3994 SV **tmparyval = 0;
93965878
NIS		 3995 MAGIC *mg;
3996
14befaf4 3997 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 3998 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 3999 PUSHMARK(MARK);
8ec5e241 4000 PUTBACK;
a60c0954 4001 ENTER;
864dbfa3 4002 call_method("SPLICE",GIMME_V);
a60c0954 4003 LEAVE;
93965878
NIS		 4004 SPAGAIN;
4005 RETURN;
4006 }
79072805 4007
a0d0e21e 4008 SP++;
79072805 4009
a0d0e21e 4010 if (++MARK < SP) {
84902520 4011 offset = i = SvIVx(*MARK);
a0d0e21e 4012 if (offset < 0)
93965878 4013 offset += AvFILLp(ary) + 1;
a0d0e21e 4014 else
3280af22 4015 offset -= PL_curcop->cop_arybase;
84902520 4016 if (offset < 0)
cea2e8a9 4017 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 4018 if (++MARK < SP) {
4019 length = SvIVx(*MARK++);
48cdf507
GA		 4020 if (length < 0) {
4021 length += AvFILLp(ary) - offset + 1;
4022 if (length < 0)
4023 length = 0;
4024 }
79072805
LW		 4025 }
4026 else
a0d0e21e 4027 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 4028 }
a0d0e21e
LW		 4029 else {
4030 offset = 0;
4031 length = AvMAX(ary) + 1;
4032 }
8cbc2e3b
JH		 4033 if (offset > AvFILLp(ary) + 1) {
4034 if (ckWARN(WARN_MISC))
9014280d 4035 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 4036 offset = AvFILLp(ary) + 1;
8cbc2e3b 4037 }
93965878 4038 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 4039 if (after < 0) { /* not that much array */
4040 length += after; /* offset+length now in array */
4041 after = 0;
4042 if (!AvALLOC(ary))
4043 av_extend(ary, 0);
4044 }
4045
4046 /* At this point, MARK .. SP-1 is our new LIST */
4047
4048 newlen = SP - MARK;
4049 diff = newlen - length;
13d7cbc1
GS		 4050 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4051 av_reify(ary);
a0d0e21e
LW		 4052
4053 if (diff < 0) { /* shrinking the area */
4054 if (newlen) {
4055 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4056 Copy(MARK, tmparyval, newlen, SV*);
79072805 4057 }
a0d0e21e
LW		 4058
4059 MARK = ORIGMARK + 1;
4060 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4061 MEXTEND(MARK, length);
4062 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4063 if (AvREAL(ary)) {
bbce6d69 4064 EXTEND_MORTAL(length);
36477c24 4065 for (i = length, dst = MARK; i; i--) {
d689ffdd 4066 sv_2mortal(*dst); /* free them eventualy */
36477c24 4067 dst++;
4068 }
a0d0e21e
LW		 4069 }
4070 MARK += length - 1;
79072805 4071 }
a0d0e21e
LW		 4072 else {
4073 *MARK = AvARRAY(ary)[offset+length-1];
4074 if (AvREAL(ary)) {
d689ffdd 4075 sv_2mortal(*MARK);
a0d0e21e
LW		 4076 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4077 SvREFCNT_dec(*dst++); /* free them now */
79072805 4078 }
a0d0e21e 4079 }
93965878 4080 AvFILLp(ary) += diff;
a0d0e21e
LW		 4081
4082 /* pull up or down? */
4083
4084 if (offset < after) { /* easier to pull up */
4085 if (offset) { /* esp. if nothing to pull */
4086 src = &AvARRAY(ary)[offset-1];
4087 dst = src - diff; /* diff is negative */
4088 for (i = offset; i > 0; i--) /* can't trust Copy */
4089 *dst-- = *src--;
79072805 4090 }
a0d0e21e
LW		 4091 dst = AvARRAY(ary);
4092 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4093 AvMAX(ary) += diff;
4094 }
4095 else {
4096 if (after) { /* anything to pull down? */
4097 src = AvARRAY(ary) + offset + length;
4098 dst = src + diff; /* diff is negative */
4099 Move(src, dst, after, SV*);
79072805 4100 }
93965878 4101 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 4102 /* avoid later double free */
4103 }
4104 i = -diff;
4105 while (i)
3280af22 4106 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 4107
4108 if (newlen) {
4109 for (src = tmparyval, dst = AvARRAY(ary) + offset;
4110 newlen; newlen--) {
4111 *dst = NEWSV(46, 0);
4112 sv_setsv(*dst++, *src++);
79072805 4113 }
a0d0e21e
LW		 4114 Safefree(tmparyval);
4115 }
4116 }
4117 else { /* no, expanding (or same) */
4118 if (length) {
4119 New(452, tmparyval, length, SV*); /* so remember deletion */
4120 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4121 }
4122
4123 if (diff > 0) { /* expanding */
4124
4125 /* push up or down? */
4126
4127 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4128 if (offset) {
4129 src = AvARRAY(ary);
4130 dst = src - diff;
4131 Move(src, dst, offset, SV*);
79072805 4132 }
a0d0e21e
LW		 4133 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4134 AvMAX(ary) += diff;
93965878 4135 AvFILLp(ary) += diff;
79072805
LW		 4136 }
4137 else {
93965878
NIS		 4138 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4139 av_extend(ary, AvFILLp(ary) + diff);
4140 AvFILLp(ary) += diff;
a0d0e21e
LW		 4141
4142 if (after) {
93965878 4143 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 4144 src = dst - diff;
4145 for (i = after; i; i--) {
4146 *dst-- = *src--;
4147 }
79072805
LW		 4148 }
4149 }
a0d0e21e
LW		 4150 }
4151
4152 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
4153 *dst = NEWSV(46, 0);
4154 sv_setsv(*dst++, *src++);
4155 }
4156 MARK = ORIGMARK + 1;
4157 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4158 if (length) {
4159 Copy(tmparyval, MARK, length, SV*);
4160 if (AvREAL(ary)) {
bbce6d69 4161 EXTEND_MORTAL(length);
36477c24 4162 for (i = length, dst = MARK; i; i--) {
d689ffdd 4163 sv_2mortal(*dst); /* free them eventualy */
36477c24 4164 dst++;
4165 }
79072805 4166 }
a0d0e21e 4167 Safefree(tmparyval);
79072805 4168 }
a0d0e21e
LW		 4169 MARK += length - 1;
4170 }
4171 else if (length--) {
4172 *MARK = tmparyval[length];
4173 if (AvREAL(ary)) {
d689ffdd 4174 sv_2mortal(*MARK);
a0d0e21e
LW		 4175 while (length-- > 0)
4176 SvREFCNT_dec(tmparyval[length]);
79072805 4177 }
a0d0e21e 4178 Safefree(tmparyval);
79072805 4179 }
a0d0e21e 4180 else
3280af22 4181 *MARK = &PL_sv_undef;
79072805 4182 }
a0d0e21e 4183 SP = MARK;
79072805
LW		 4184 RETURN;
4185}
4186
a0d0e21e 4187PP(pp_push)
79072805 4188{
39644a26 4189 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4190 register AV *ary = (AV*)*++MARK;
3280af22 4191 register SV *sv = &PL_sv_undef;
93965878 4192 MAGIC *mg;
79072805 4193
14befaf4 4194 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4195 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS		 4196 PUSHMARK(MARK);
4197 PUTBACK;
a60c0954 4198 ENTER;
864dbfa3 4199 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 4200 LEAVE;
93965878 4201 SPAGAIN;
93965878 4202 }
a60c0954
NIS		 4203 else {
4204 /* Why no pre-extend of ary here ? */
4205 for (++MARK; MARK <= SP; MARK++) {
4206 sv = NEWSV(51, 0);
4207 if (*MARK)
4208 sv_setsv(sv, *MARK);
4209 av_push(ary, sv);
4210 }
79072805
LW		 4211 }
4212 SP = ORIGMARK;
a0d0e21e 4213 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 4214 RETURN;
4215}
4216
a0d0e21e 4217PP(pp_pop)
79072805 4218{
39644a26 4219 dSP;
a0d0e21e
LW		 4220 AV *av = (AV*)POPs;
4221 SV *sv = av_pop(av);
d689ffdd 4222 if (AvREAL(av))
a0d0e21e
LW		 4223 (void)sv_2mortal(sv);
4224 PUSHs(sv);
79072805 4225 RETURN;
79072805
LW		 4226}
4227
a0d0e21e 4228PP(pp_shift)
79072805 4229{
39644a26 4230 dSP;
a0d0e21e
LW		 4231 AV *av = (AV*)POPs;
4232 SV *sv = av_shift(av);
79072805 4233 EXTEND(SP, 1);
a0d0e21e 4234 if (!sv)
79072805 4235 RETPUSHUNDEF;
d689ffdd 4236 if (AvREAL(av))
a0d0e21e
LW		 4237 (void)sv_2mortal(sv);
4238 PUSHs(sv);
79072805 4239 RETURN;
79072805
LW		 4240}
4241
a0d0e21e 4242PP(pp_unshift)
79072805 4243{
39644a26 4244 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4245 register AV *ary = (AV*)*++MARK;
4246 register SV *sv;
4247 register I32 i = 0;
93965878
NIS		 4248 MAGIC *mg;
4249
14befaf4 4250 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
33c27489 4251 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 4252 PUSHMARK(MARK);
93965878 4253 PUTBACK;
a60c0954 4254 ENTER;
864dbfa3 4255 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 4256 LEAVE;
93965878 4257 SPAGAIN;
93965878 4258 }
a60c0954
NIS		 4259 else {
4260 av_unshift(ary, SP - MARK);
4261 while (MARK < SP) {
4262 sv = NEWSV(27, 0);
4263 sv_setsv(sv, *++MARK);
4264 (void)av_store(ary, i++, sv);
4265 }
79072805 4266 }
a0d0e21e
LW		 4267 SP = ORIGMARK;
4268 PUSHi( AvFILL(ary) + 1 );
79072805 4269 RETURN;
79072805
LW		 4270}
4271
a0d0e21e 4272PP(pp_reverse)
79072805 4273{
39644a26 4274 dSP; dMARK;
a0d0e21e
LW		 4275 register SV *tmp;
4276 SV **oldsp = SP;
79072805 4277
a0d0e21e
LW		 4278 if (GIMME == G_ARRAY) {
4279 MARK++;
4280 while (MARK < SP) {
4281 tmp = *MARK;
4282 *MARK++ = *SP;
4283 *SP-- = tmp;
4284 }
dd58a1ab 4285 /* safe as long as stack cannot get extended in the above */
a0d0e21e 4286 SP = oldsp;
79072805
LW		 4287 }
4288 else {
a0d0e21e
LW		 4289 register char *up;
4290 register char *down;
4291 register I32 tmp;
4292 dTARGET;
4293 STRLEN len;
79072805 4294
7e2040f0 4295 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4296 if (SP - MARK > 1)
3280af22 4297 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 4298 else
54b9620d 4299 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW		 4300 up = SvPV_force(TARG, len);
4301 if (len > 1) {
7e2040f0 4302 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55
GS		 4303 U8* s = (U8*)SvPVX(TARG);
4304 U8* send = (U8*)(s + len);
a0ed51b3 4305 while (s < send) {
d742c382 4306 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 4307 s++;
4308 continue;
4309 }
4310 else {
9041c2e3 4311 if (!utf8_to_uvchr(s, 0))
a0dbb045 4312 break;
dfe13c55 4313 up = (char*)s;
a0ed51b3 4314 s += UTF8SKIP(s);
dfe13c55 4315 down = (char*)(s - 1);
a0dbb045 4316 /* reverse this character */
a0ed51b3
LW		 4317 while (down > up) {
4318 tmp = *up;
4319 *up++ = *down;
eb160463 4320 *down-- = (char)tmp;
a0ed51b3
LW		 4321 }
4322 }
4323 }
4324 up = SvPVX(TARG);
4325 }
a0d0e21e
LW		 4326 down = SvPVX(TARG) + len - 1;
4327 while (down > up) {
4328 tmp = *up;
4329 *up++ = *down;
eb160463 4330 *down-- = (char)tmp;
a0d0e21e 4331 }
3aa33fe5 4332 (void)SvPOK_only_UTF8(TARG);
79072805 4333 }
a0d0e21e
LW		 4334 SP = MARK + 1;
4335 SETTARG;
79072805 4336 }
a0d0e21e 4337 RETURN;
79072805
LW		 4338}
4339
a0d0e21e 4340PP(pp_split)
79072805 4341{
39644a26 4342 dSP; dTARG;
a0d0e21e 4343 AV *ary;
467f0320 4344 register IV limit = POPi; /* note, negative is forever */
a0d0e21e
LW		 4345 SV *sv = POPs;
4346 STRLEN len;
4347 register char *s = SvPV(sv, len);
1aa99e6b 4348 bool do_utf8 = DO_UTF8(sv);
a0d0e21e 4349 char *strend = s + len;
44a8e56a 4350 register PMOP *pm;
d9f97599 4351 register REGEXP *rx;
a0d0e21e
LW		 4352 register SV *dstr;
4353 register char *m;
4354 I32 iters = 0;
792b2c16
JH		 4355 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4356 I32 maxiters = slen + 10;
a0d0e21e
LW		 4357 I32 i;
4358 char *orig;
4359 I32 origlimit = limit;
4360 I32 realarray = 0;
4361 I32 base;
3280af22 4362 AV *oldstack = PL_curstack;
54310121 4363 I32 gimme = GIMME_V;
3280af22 4364 I32 oldsave = PL_savestack_ix;
8ec5e241
NIS		 4365 I32 make_mortal = 1;
4366 MAGIC *mg = (MAGIC *) NULL;
79072805 4367
44a8e56a 4368#ifdef DEBUGGING
4369 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4370#else
4371 pm = (PMOP*)POPs;
4372#endif
a0d0e21e 4373 if (!pm || !s)
2269b42e 4374 DIE(aTHX_ "panic: pp_split");
aaa362c4 4375 rx = PM_GETRE(pm);
bbce6d69 4376
4377 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4378 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4379
a30b2f1f 4380 RX_MATCH_UTF8_set(rx, do_utf8);
d9f424b2 4381
971a9dd3
GS		 4382 if (pm->op_pmreplroot) {
4383#ifdef USE_ITHREADS
dd2155a4 4384 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
971a9dd3 4385#else
a0d0e21e 4386 ary = GvAVn((GV*)pm->op_pmreplroot);
971a9dd3
GS		 4387#endif
4388 }
a0d0e21e 4389 else if (gimme != G_ARRAY)
3280af22 4390 ary = GvAVn(PL_defgv);
79072805 4391 else
a0d0e21e
LW		 4392 ary = Nullav;
4393 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4394 realarray = 1;
8ec5e241 4395 PUTBACK;
a0d0e21e
LW		 4396 av_extend(ary,0);
4397 av_clear(ary);
8ec5e241 4398 SPAGAIN;
14befaf4 4399 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
8ec5e241 4400 PUSHMARK(SP);
33c27489 4401 XPUSHs(SvTIED_obj((SV*)ary, mg));
8ec5e241
NIS		 4402 }
4403 else {
1c0b011c
NIS		 4404 if (!AvREAL(ary)) {
4405 AvREAL_on(ary);
abff13bb 4406 AvREIFY_off(ary);
1c0b011c 4407 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 4408 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 4409 }
4410 /* temporarily switch stacks */
3280af22 4411 SWITCHSTACK(PL_curstack, ary);
3b0d546b 4412 PL_curstackinfo->si_stack = ary;
8ec5e241 4413 make_mortal = 0;
1c0b011c 4414 }
79072805 4415 }
3280af22 4416 base = SP - PL_stack_base;
a0d0e21e
LW		 4417 orig = s;
4418 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 4419 if (pm->op_pmflags & PMf_LOCALE) {
4420 while (isSPACE_LC(*s))
4421 s++;
4422 }
4423 else {
4424 while (isSPACE(*s))
4425 s++;
4426 }
a0d0e21e 4427 }
e8f49695 4428 if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
3280af22
NIS		 4429 SAVEINT(PL_multiline);
4430 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
c07a80fd 4431 }
4432
a0d0e21e
LW		 4433 if (!limit)
4434 limit = maxiters + 2;
4435 if (pm->op_pmflags & PMf_WHITE) {
4436 while (--limit) {
bbce6d69 4437 m = s;
4438 while (m < strend &&
4439 !((pm->op_pmflags & PMf_LOCALE)
4440 ? isSPACE_LC(*m) : isSPACE(*m)))
4441 ++m;
a0d0e21e
LW		 4442 if (m >= strend)
4443 break;
bbce6d69 4444
a0d0e21e
LW		 4445 dstr = NEWSV(30, m-s);
4446 sv_setpvn(dstr, s, m-s);
8ec5e241 4447 if (make_mortal)
a0d0e21e 4448 sv_2mortal(dstr);
792b2c16 4449 if (do_utf8)
28cb3359 4450 (void)SvUTF8_on(dstr);
a0d0e21e 4451 XPUSHs(dstr);
bbce6d69 4452
4453 s = m + 1;
4454 while (s < strend &&
4455 ((pm->op_pmflags & PMf_LOCALE)
4456 ? isSPACE_LC(*s) : isSPACE(*s)))
4457 ++s;
79072805
LW		 4458 }
4459 }
f4091fba 4460 else if (strEQ("^", rx->precomp)) {
a0d0e21e
LW		 4461 while (--limit) {
4462 /*SUPPRESS 530*/
4463 for (m = s; m < strend && *m != '\n'; m++) ;
4464 m++;
4465 if (m >= strend)
4466 break;
4467 dstr = NEWSV(30, m-s);
4468 sv_setpvn(dstr, s, m-s);
8ec5e241 4469 if (make_mortal)
a0d0e21e 4470 sv_2mortal(dstr);
792b2c16 4471 if (do_utf8)
28cb3359 4472 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4473 XPUSHs(dstr);
4474 s = m;
4475 }
4476 }
699c3c34
JH		 4477 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4478 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
d9f97599
GS		 4479 && (rx->reganch & ROPT_CHECK_ALL)
4480 && !(rx->reganch & ROPT_ANCH)) {
f722798b
IZ		 4481 int tail = (rx->reganch & RE_INTUIT_TAIL);
4482 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
cf93c79d 4483
ca5b42cb 4484 len = rx->minlen;
1aa99e6b 4485 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
93f04dac
JH		 4486 STRLEN n_a;
4487 char c = *SvPV(csv, n_a);
a0d0e21e 4488 while (--limit) {
bbce6d69 4489 /*SUPPRESS 530*/
f722798b 4490 for (m = s; m < strend && *m != c; m++) ;
a0d0e21e
LW		 4491 if (m >= strend)
4492 break;
4493 dstr = NEWSV(30, m-s);
4494 sv_setpvn(dstr, s, m-s);
8ec5e241 4495 if (make_mortal)
a0d0e21e 4496 sv_2mortal(dstr);
792b2c16 4497 if (do_utf8)
28cb3359 4498 (void)SvUTF8_on(dstr);
a0d0e21e 4499 XPUSHs(dstr);
93f04dac
JH		 4500 /* The rx->minlen is in characters but we want to step
4501 * s ahead by bytes. */
1aa99e6b
IH		 4502 if (do_utf8)
4503 s = (char*)utf8_hop((U8*)m, len);
4504 else
4505 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 4506 }
4507 }
4508 else {
4509#ifndef lint
4510 while (s < strend && --limit &&
f722798b
IZ		 4511 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4512 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
79072805 4513#endif
a0d0e21e
LW		 4514 {
4515 dstr = NEWSV(31, m-s);
4516 sv_setpvn(dstr, s, m-s);
8ec5e241 4517 if (make_mortal)
a0d0e21e 4518 sv_2mortal(dstr);
792b2c16 4519 if (do_utf8)
28cb3359 4520 (void)SvUTF8_on(dstr);
a0d0e21e 4521 XPUSHs(dstr);
93f04dac
JH		 4522 /* The rx->minlen is in characters but we want to step
4523 * s ahead by bytes. */
1aa99e6b
IH		 4524 if (do_utf8)
4525 s = (char*)utf8_hop((U8*)m, len);
4526 else
4527 s = m + len; /* Fake \n at the end */
a0d0e21e 4528 }
463ee0b2 4529 }
463ee0b2 4530 }
a0d0e21e 4531 else {
792b2c16 4532 maxiters += slen * rx->nparens;
080c2dec 4533 while (s < strend && --limit)
bbce6d69 4534 {
080c2dec
AE		 4535 PUTBACK;
4536 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4537 SPAGAIN;
4538 if (i == 0)
4539 break;
d9f97599 4540 TAINT_IF(RX_MATCH_TAINTED(rx));
cf93c79d 4541 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 4542 m = s;
4543 s = orig;
cf93c79d 4544 orig = rx->subbeg;
a0d0e21e
LW		 4545 s = orig + (m - s);
4546 strend = s + (strend - m);
4547 }
cf93c79d 4548 m = rx->startp[0] + orig;
a0d0e21e
LW		 4549 dstr = NEWSV(32, m-s);
4550 sv_setpvn(dstr, s, m-s);
8ec5e241 4551 if (make_mortal)
a0d0e21e 4552 sv_2mortal(dstr);
792b2c16 4553 if (do_utf8)
28cb3359 4554 (void)SvUTF8_on(dstr);
a0d0e21e 4555 XPUSHs(dstr);
d9f97599 4556 if (rx->nparens) {
eb160463 4557 for (i = 1; i <= (I32)rx->nparens; i++) {
cf93c79d
IZ		 4558 s = rx->startp[i] + orig;
4559 m = rx->endp[i] + orig;
6de67870
JP		 4560
4561 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4562 parens that didn't match -- they should be set to
4563 undef, not the empty string */
4564 if (m >= orig && s >= orig) {
748a9306
LW		 4565 dstr = NEWSV(33, m-s);
4566 sv_setpvn(dstr, s, m-s);
4567 }
4568 else
6de67870 4569 dstr = &PL_sv_undef; /* undef, not "" */
8ec5e241 4570 if (make_mortal)
a0d0e21e 4571 sv_2mortal(dstr);
792b2c16 4572 if (do_utf8)
28cb3359 4573 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4574 XPUSHs(dstr);
4575 }
4576 }
cf93c79d 4577 s = rx->endp[0] + orig;
a0d0e21e 4578 }
79072805 4579 }
8ec5e241 4580
c07a80fd 4581 LEAVE_SCOPE(oldsave);
3280af22 4582 iters = (SP - PL_stack_base) - base;
a0d0e21e 4583 if (iters > maxiters)
cea2e8a9 4584 DIE(aTHX_ "Split loop");
8ec5e241 4585
a0d0e21e
LW		 4586 /* keep field after final delim? */
4587 if (s < strend || (iters && origlimit)) {
93f04dac
JH		 4588 STRLEN l = strend - s;
4589 dstr = NEWSV(34, l);
4590 sv_setpvn(dstr, s, l);
8ec5e241 4591 if (make_mortal)
a0d0e21e 4592 sv_2mortal(dstr);
792b2c16 4593 if (do_utf8)
28cb3359 4594 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 4595 XPUSHs(dstr);
4596 iters++;
79072805 4597 }
a0d0e21e 4598 else if (!origlimit) {
89900bd3
SR		 4599 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4600 if (TOPs && !make_mortal)
4601 sv_2mortal(TOPs);
4602 iters--;
4603 SP--;
4604 }
a0d0e21e 4605 }
8ec5e241 4606
a0d0e21e 4607 if (realarray) {
8ec5e241 4608 if (!mg) {
1c0b011c 4609 SWITCHSTACK(ary, oldstack);
3b0d546b 4610 PL_curstackinfo->si_stack = oldstack;
1c0b011c
NIS		 4611 if (SvSMAGICAL(ary)) {
4612 PUTBACK;
4613 mg_set((SV*)ary);
4614 SPAGAIN;
4615 }
4616 if (gimme == G_ARRAY) {
4617 EXTEND(SP, iters);
4618 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4619 SP += iters;
4620 RETURN;
4621 }
8ec5e241 4622 }
1c0b011c 4623 else {
fb73857a 4624 PUTBACK;
8ec5e241 4625 ENTER;
864dbfa3 4626 call_method("PUSH",G_SCALAR|G_DISCARD);
8ec5e241 4627 LEAVE;
fb73857a 4628 SPAGAIN;
8ec5e241
NIS		 4629 if (gimme == G_ARRAY) {
4630 /* EXTEND should not be needed - we just popped them */
4631 EXTEND(SP, iters);
4632 for (i=0; i < iters; i++) {
4633 SV **svp = av_fetch(ary, i, FALSE);
3280af22 4634 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 4635 }
1c0b011c
NIS		 4636 RETURN;
4637 }
a0d0e21e
LW		 4638 }
4639 }
4640 else {
4641 if (gimme == G_ARRAY)
4642 RETURN;
4643 }
7f18b612
YST		 4644
4645 GETTARGET;
4646 PUSHi(iters);
4647 RETURN;
79072805 4648}
85e6fe83 4649
c0329465
MB		 4650PP(pp_lock)
4651{
39644a26 4652 dSP;
c0329465 4653 dTOPss;
e55aaa0e 4654 SV *retsv = sv;
68795e93 4655 SvLOCK(sv);
e55aaa0e
MB		 4656 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4657 || SvTYPE(retsv) == SVt_PVCV) {
4658 retsv = refto(retsv);
4659 }
4660 SETs(retsv);
c0329465
MB		 4661 RETURN;
4662}
a863c7d1 4663
2faa37cc 4664PP(pp_threadsv)
a863c7d1 4665{
cea2e8a9 4666 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
a863c7d1 4667}
Unnamed repository; edit this file 'description' to name the repository.