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