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