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