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