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