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
Increase $Hash::Util::FieldHash::VERSION to 1.14
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
1129b882
NC		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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/*
4ac71550
TC		 12 * 'It's a big house this, and very peculiar. Always a bit more
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
15 *
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
a0d0e21e 17 */
79072805 18
166f8a29
DM		 19/* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
24 */
25
79072805 26#include "EXTERN.h"
864dbfa3 27#define PERL_IN_PP_C
79072805 28#include "perl.h"
77bc9082 29#include "keywords.h"
79072805 30
a4af207c 31#include "reentr.h"
685289b5 32#include "regcharclass.h"
a4af207c 33
dfe9444c
AD		 34/* XXX I can't imagine anyone who doesn't have this actually _needs_
35 it, since pid_t is an integral type.
36 --AD 2/20/1998
37*/
38#ifdef NEED_GETPID_PROTO
39extern Pid_t getpid (void);
8ac85365
NIS		 40#endif
41
0630166f
SP		 42/*
43 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44 * This switches them over to IEEE.
45 */
46#if defined(LIBM_LIB_VERSION)
47 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
48#endif
49
a78bc3c6
KW		 50static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
52
13017935
SM		 53/* variations on pp_null */
54
93a17b20
LW		 55PP(pp_stub)
56{
97aff369 57 dVAR;
39644a26 58 dSP;
54310121 59 if (GIMME_V == G_SCALAR)
3280af22 60 XPUSHs(&PL_sv_undef);
93a17b20
LW		 61 RETURN;
62}
63
79072805
LW		 64/* Pushy stuff. */
65
93a17b20
LW		 66PP(pp_padav)
67{
97aff369 68 dVAR; dSP; dTARGET;
13017935 69 I32 gimme;
e190e9b4 70 assert(SvTYPE(TARG) == SVt_PVAV);
3dbcc5e0
S		 71 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
a5911867 73 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
85e6fe83 74 EXTEND(SP, 1);
533c011a 75 if (PL_op->op_flags & OPf_REF) {
85e6fe83 76 PUSHs(TARG);
93a17b20 77 RETURN;
40c94d11
FC		 78 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
79 const I32 flags = is_lvalue_sub();
80 if (flags && !(flags & OPpENTERSUB_INARGS)) {
78f9721b 81 if (GIMME == G_SCALAR)
a84828f3 82 /* diag_listed_as: Can't return %s to lvalue scalar context */
78f9721b
SM		 83 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
84 PUSHs(TARG);
85 RETURN;
40c94d11 86 }
85e6fe83 87 }
13017935
SM		 88 gimme = GIMME_V;
89 if (gimme == G_ARRAY) {
d5524600 90 /* XXX see also S_pushav in pp_hot.c */
c70927a6 91 const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
85e6fe83 92 EXTEND(SP, maxarg);
93965878 93 if (SvMAGICAL(TARG)) {
c70927a6
FC		 94 Size_t i;
95 for (i=0; i < maxarg; i++) {
502c6561 96 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
3280af22 97 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878
NIS		 98 }
99 }
100 else {
428ccf1e
FC		 101 PADOFFSET i;
102 for (i=0; i < (PADOFFSET)maxarg; i++) {
103 SV * const sv = AvARRAY((const AV *)TARG)[i];
104 SP[i+1] = sv ? sv : &PL_sv_undef;
105 }
93965878 106 }
85e6fe83
LW		 107 SP += maxarg;
108 }
13017935 109 else if (gimme == G_SCALAR) {
1b6737cc 110 SV* const sv = sv_newmortal();
c70927a6 111 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
85e6fe83
LW		 112 sv_setiv(sv, maxarg);
113 PUSHs(sv);
114 }
115 RETURN;
93a17b20
LW		 116}
117
118PP(pp_padhv)
119{
97aff369 120 dVAR; dSP; dTARGET;
54310121 121 I32 gimme;
122
e190e9b4 123 assert(SvTYPE(TARG) == SVt_PVHV);
93a17b20 124 XPUSHs(TARG);
3dbcc5e0
S		 125 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
126 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
a5911867 127 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
533c011a 128 if (PL_op->op_flags & OPf_REF)
93a17b20 129 RETURN;
40c94d11
FC		 130 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
131 const I32 flags = is_lvalue_sub();
132 if (flags && !(flags & OPpENTERSUB_INARGS)) {
78f9721b 133 if (GIMME == G_SCALAR)
a84828f3 134 /* diag_listed_as: Can't return %s to lvalue scalar context */
78f9721b
SM		 135 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
136 RETURN;
40c94d11 137 }
78f9721b 138 }
54310121 139 gimme = GIMME_V;
140 if (gimme == G_ARRAY) {
981b7185 141 RETURNOP(Perl_do_kv(aTHX));
85e6fe83 142 }
c8fe3bdf 143 else if ((PL_op->op_private & OPpTRUEBOOL
adc42c31 144 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
c8fe3bdf
FC		 145 && block_gimme() == G_VOID ))
146 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
147 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
54310121 148 else if (gimme == G_SCALAR) {
85fbaab2 149 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
85e6fe83 150 SETs(sv);
85e6fe83 151 }
54310121 152 RETURN;
93a17b20
LW		 153}
154
ac217057
FC		 155PP(pp_padcv)
156{
97b03d64
FC		 157 dVAR; dSP; dTARGET;
158 assert(SvTYPE(TARG) == SVt_PVCV);
159 XPUSHs(TARG);
160 RETURN;
ac217057
FC		 161}
162
ecf9c8b7
FC		 163PP(pp_introcv)
164{
6d5c2147
FC		 165 dVAR; dTARGET;
166 SvPADSTALE_off(TARG);
167 return NORMAL;
ecf9c8b7
FC		 168}
169
13f89586
FC		 170PP(pp_clonecv)
171{
6d5c2147 172 dVAR; dTARGET;
81df9f6f 173 MAGIC * const mg =
62698e04
FC		 174 mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
175 PERL_MAGIC_proto);
6d5c2147
FC		 176 assert(SvTYPE(TARG) == SVt_PVCV);
177 assert(mg);
178 assert(mg->mg_obj);
179 if (CvISXSUB(mg->mg_obj)) { /* constant */
180 /* XXX Should we clone it here? */
6d5c2147
FC		 181 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
182 to introcv and remove the SvPADSTALE_off. */
183 SAVEPADSVANDMORTALIZE(ARGTARG);
4ded55f3 184 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
6d5c2147
FC		 185 }
186 else {
187 if (CvROOT(mg->mg_obj)) {
188 assert(CvCLONE(mg->mg_obj));
189 assert(!CvCLONED(mg->mg_obj));
190 }
191 cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
192 SAVECLEARSV(PAD_SVl(ARGTARG));
193 }
194 return NORMAL;
13f89586
FC		 195}
196
79072805
LW		 197/* Translations. */
198
4bdf8368 199static const char S_no_symref_sv[] =
def89bff
NC		 200 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
201
6f7909da
FC		 202/* In some cases this function inspects PL_op. If this function is called
203 for new op types, more bool parameters may need to be added in place of
204 the checks.
205
206 When noinit is true, the absence of a gv will cause a retval of undef.
207 This is unrelated to the cv-to-gv assignment case.
6f7909da
FC		 208*/
209
210static SV *
211S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
212 const bool noinit)
213{
14f0f125 214 dVAR;
f64c9ac5 215 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
ed6116ce 216 if (SvROK(sv)) {
93d7320b
DM		 217 if (SvAMAGIC(sv)) {
218 sv = amagic_deref_call(sv, to_gv_amg);
93d7320b 219 }
e4a1664f 220 wasref:
ed6116ce 221 sv = SvRV(sv);
b1dadf13 222 if (SvTYPE(sv) == SVt_PVIO) {
159b6efe 223 GV * const gv = MUTABLE_GV(sv_newmortal());
885f468a 224 gv_init(gv, 0, "__ANONIO__", 10, 0);
a45c7426 225 GvIOp(gv) = MUTABLE_IO(sv);
b37c2d43 226 SvREFCNT_inc_void_NN(sv);
ad64d0ec 227 sv = MUTABLE_SV(gv);
ef54e1a4 228 }
6e592b3a 229 else if (!isGV_with_GP(sv))
6f7909da 230 return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
79072805
LW		 231 }
232 else {
6e592b3a 233 if (!isGV_with_GP(sv)) {
f132ae69 234 if (!SvOK(sv)) {
b13b2135 235 /* If this is a 'my' scalar and flag is set then vivify
853846ea 236 * NI-S 1999/05/07
b13b2135 237 */
f132ae69 238 if (vivify_sv && sv != &PL_sv_undef) {
2c8ac474 239 GV *gv;
ce74145d 240 if (SvREADONLY(sv))
cb077ed2 241 Perl_croak_no_modify();
2c8ac474 242 if (cUNOP->op_targ) {
0bd48802 243 SV * const namesv = PAD_SV(cUNOP->op_targ);
94e7eb6f
FC		 244 HV *stash = CopSTASH(PL_curcop);
245 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
159b6efe 246 gv = MUTABLE_GV(newSV(0));
94e7eb6f 247 gv_init_sv(gv, stash, namesv, 0);
2c8ac474
GS		 248 }
249 else {
0bd48802 250 const char * const name = CopSTASHPV(PL_curcop);
6b10071b 251 gv = newGVgen_flags(name,
d14578b8 252 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
1d8d4d2a 253 }
43230e26 254 prepare_SV_for_RV(sv);
ad64d0ec 255 SvRV_set(sv, MUTABLE_SV(gv));
853846ea 256 SvROK_on(sv);
1d8d4d2a 257 SvSETMAGIC(sv);
853846ea 258 goto wasref;
2c8ac474 259 }
6f7909da
FC		 260 if (PL_op->op_flags & OPf_REF || strict)
261 return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
599cee73 262 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 263 report_uninit(sv);
6f7909da 264 return &PL_sv_undef;
a0d0e21e 265 }
6f7909da 266 if (noinit)
35cd451c 267 {
77cb3b01
FC		 268 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
269 sv, GV_ADDMG, SVt_PVGV
23496c6e 270 ))))
6f7909da 271 return &PL_sv_undef;
35cd451c
GS		 272 }
273 else {
6f7909da
FC		 274 if (strict)
275 return
276 (SV *)Perl_die(aTHX_
277 S_no_symref_sv,
278 sv,
bf3d870f 279 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
6f7909da
FC		 280 "a symbol"
281 );
e26df76a
NC		 282 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
283 == OPpDONT_INIT_GV) {
284 /* We are the target of a coderef assignment. Return
285 the scalar unchanged, and let pp_sasssign deal with
286 things. */
6f7909da 287 return sv;
e26df76a 288 }
77cb3b01 289 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
35cd451c 290 }
2acc3314 291 /* FAKE globs in the symbol table cause weird bugs (#77810) */
96293f45 292 SvFAKE_off(sv);
93a17b20 293 }
79072805 294 }
8dc99089 295 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
2acc3314 296 SV *newsv = sv_newmortal();
5cf4b255 297 sv_setsv_flags(newsv, sv, 0);
2acc3314 298 SvFAKE_off(newsv);
d8906c05 299 sv = newsv;
2acc3314 300 }
6f7909da
FC		 301 return sv;
302}
303
304PP(pp_rv2gv)
305{
306 dVAR; dSP; dTOPss;
307
308 sv = S_rv2gv(aTHX_
309 sv, PL_op->op_private & OPpDEREF,
310 PL_op->op_private & HINT_STRICT_REFS,
311 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
312 || PL_op->op_type == OP_READLINE
313 );
d8906c05
FC		 314 if (PL_op->op_private & OPpLVAL_INTRO)
315 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
316 SETs(sv);
79072805
LW		 317 RETURN;
318}
319
dc3c76f8
NC		 320/* Helper function for pp_rv2sv and pp_rv2av */
321GV *
fe9845cc
RB		 322Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
323 const svtype type, SV ***spp)
dc3c76f8
NC		 324{
325 dVAR;
326 GV *gv;
327
7918f24d
NC		 328 PERL_ARGS_ASSERT_SOFTREF2XV;
329
dc3c76f8
NC		 330 if (PL_op->op_private & HINT_STRICT_REFS) {
331 if (SvOK(sv))
bf3d870f
FC		 332 Perl_die(aTHX_ S_no_symref_sv, sv,
333 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
dc3c76f8
NC		 334 else
335 Perl_die(aTHX_ PL_no_usym, what);
336 }
337 if (!SvOK(sv)) {
fd1d9b5c 338 if (
c8fe3bdf 339 PL_op->op_flags & OPf_REF
fd1d9b5c 340 )
dc3c76f8
NC		 341 Perl_die(aTHX_ PL_no_usym, what);
342 if (ckWARN(WARN_UNINITIALIZED))
343 report_uninit(sv);
344 if (type != SVt_PV && GIMME_V == G_ARRAY) {
345 (*spp)--;
346 return NULL;
347 }
348 **spp = &PL_sv_undef;
349 return NULL;
350 }
351 if ((PL_op->op_flags & OPf_SPECIAL) &&
352 !(PL_op->op_flags & OPf_MOD))
353 {
77cb3b01 354 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
dc3c76f8
NC		 355 {
356 **spp = &PL_sv_undef;
357 return NULL;
358 }
359 }
360 else {
77cb3b01 361 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
dc3c76f8
NC		 362 }
363 return gv;
364}
365
79072805
LW		 366PP(pp_rv2sv)
367{
97aff369 368 dVAR; dSP; dTOPss;
c445ea15 369 GV *gv = NULL;
79072805 370
9026059d 371 SvGETMAGIC(sv);
ed6116ce 372 if (SvROK(sv)) {
93d7320b
DM		 373 if (SvAMAGIC(sv)) {
374 sv = amagic_deref_call(sv, to_sv_amg);
93d7320b 375 }
f5284f61 376
ed6116ce 377 sv = SvRV(sv);
79072805
LW		 378 switch (SvTYPE(sv)) {
379 case SVt_PVAV:
380 case SVt_PVHV:
381 case SVt_PVCV:
cbae9b9f
YST		 382 case SVt_PVFM:
383 case SVt_PVIO:
cea2e8a9 384 DIE(aTHX_ "Not a SCALAR reference");
42d0e0b7 385 default: NOOP;
79072805
LW		 386 }
387 }
388 else {
159b6efe 389 gv = MUTABLE_GV(sv);
748a9306 390
6e592b3a 391 if (!isGV_with_GP(gv)) {
dc3c76f8
NC		 392 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
393 if (!gv)
394 RETURN;
463ee0b2 395 }
29c711a3 396 sv = GvSVn(gv);
a0d0e21e 397 }
533c011a 398 if (PL_op->op_flags & OPf_MOD) {
82d03984
RGS		 399 if (PL_op->op_private & OPpLVAL_INTRO) {
400 if (cUNOP->op_first->op_type == OP_NULL)
159b6efe 401 sv = save_scalar(MUTABLE_GV(TOPs));
82d03984
RGS		 402 else if (gv)
403 sv = save_scalar(gv);
404 else
f1f66076 405 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
82d03984 406 }
533c011a 407 else if (PL_op->op_private & OPpDEREF)
9026059d 408 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 409 }
a0d0e21e 410 SETs(sv);
79072805
LW		 411 RETURN;
412}
413
414PP(pp_av2arylen)
415{
97aff369 416 dVAR; dSP;
502c6561 417 AV * const av = MUTABLE_AV(TOPs);
02d85cc3
EB		 418 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
419 if (lvalue) {
420 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
421 if (!*sv) {
422 *sv = newSV_type(SVt_PVMG);
423 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
424 }
425 SETs(*sv);
426 } else {
e1dccc0d 427 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
79072805 428 }
79072805
LW		 429 RETURN;
430}
431
a0d0e21e
LW		 432PP(pp_pos)
433{
2154eca7 434 dVAR; dSP; dPOPss;
8ec5e241 435
78f9721b 436 if (PL_op->op_flags & OPf_MOD || LVRET) {
d14578b8 437 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
16eb5365
FC		 438 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
439 LvTYPE(ret) = '.';
440 LvTARG(ret) = SvREFCNT_inc_simple(sv);
2154eca7 441 PUSHs(ret); /* no SvSETMAGIC */
a0d0e21e
LW		 442 RETURN;
443 }
444 else {
96c2a8ff 445 const MAGIC * const mg = mg_find_mglob(sv);
6174b39a 446 if (mg && mg->mg_len != -1) {
2154eca7 447 dTARGET;
6174b39a 448 STRLEN i = mg->mg_len;
25fdce4a 449 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
6174b39a
FC		 450 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
451 PUSHu(i);
a0d0e21e
LW		 452 RETURN;
453 }
96c2a8ff 454 RETPUSHUNDEF;
a0d0e21e
LW		 455 }
456}
457
79072805
LW		 458PP(pp_rv2cv)
459{
97aff369 460 dVAR; dSP;
79072805 461 GV *gv;
1eced8f8 462 HV *stash_unused;
c445ea15 463 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
9da346da 464 ? GV_ADDMG
d14578b8
KW		 465 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
466 == OPpMAY_RETURN_CONSTANT)
c445ea15
AL		 467 ? GV_ADD|GV_NOEXPAND
468 : GV_ADD;
4633a7c4
LW		 469 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
470 /* (But not in defined().) */
e26df76a 471
1eced8f8 472 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
5a20ba3d 473 if (cv) NOOP;
e26df76a 474 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
ea726b52 475 cv = MUTABLE_CV(gv);
e26df76a 476 }
07055b4c 477 else
ea726b52 478 cv = MUTABLE_CV(&PL_sv_undef);
ad64d0ec 479 SETs(MUTABLE_SV(cv));
79072805
LW		 480 RETURN;
481}
482
c07a80fd 483PP(pp_prototype)
484{
97aff369 485 dVAR; dSP;
c07a80fd 486 CV *cv;
487 HV *stash;
488 GV *gv;
fabdb6c0 489 SV *ret = &PL_sv_undef;
c07a80fd 490
6954f42f 491 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
b6c543e3 492 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
e3f73d4e 493 const char * s = SvPVX_const(TOPs);
b6c543e3 494 if (strnEQ(s, "CORE::", 6)) {
be1b855b 495 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
a96df643 496 if (!code)
b17a0679
FC		 497 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
498 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
4e338c21 499 {
b66130dd
FC		 500 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
501 if (sv) ret = sv;
502 }
b8c38f0a 503 goto set;
b6c543e3
IZ		 504 }
505 }
f2c0649b 506 cv = sv_2cv(TOPs, &stash, &gv, 0);
5f05dabc 507 if (cv && SvPOK(cv))
8fa6a409
FC		 508 ret = newSVpvn_flags(
509 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
510 );
b6c543e3 511 set:
c07a80fd 512 SETs(ret);
513 RETURN;
514}
515
a0d0e21e
LW		 516PP(pp_anoncode)
517{
97aff369 518 dVAR; dSP;
ea726b52 519 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
a5f75d66 520 if (CvCLONE(cv))
ad64d0ec 521 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
5f05dabc 522 EXTEND(SP,1);
ad64d0ec 523 PUSHs(MUTABLE_SV(cv));
a0d0e21e
LW		 524 RETURN;
525}
526
527PP(pp_srefgen)
79072805 528{
97aff369 529 dVAR; dSP;
71be2cbc 530 *SP = refto(*SP);
79072805 531 RETURN;
8ec5e241 532}
a0d0e21e
LW		 533
534PP(pp_refgen)
535{
97aff369 536 dVAR; dSP; dMARK;
a0d0e21e 537 if (GIMME != G_ARRAY) {
5f0b1d4e
GS		 538 if (++MARK <= SP)
539 *MARK = *SP;
540 else
3280af22 541 *MARK = &PL_sv_undef;
5f0b1d4e
GS		 542 *MARK = refto(*MARK);
543 SP = MARK;
544 RETURN;
a0d0e21e 545 }
bbce6d69 546 EXTEND_MORTAL(SP - MARK);
71be2cbc 547 while (++MARK <= SP)
548 *MARK = refto(*MARK);
a0d0e21e 549 RETURN;
79072805
LW		 550}
551
76e3520e 552STATIC SV*
cea2e8a9 553S_refto(pTHX_ SV *sv)
71be2cbc 554{
97aff369 555 dVAR;
71be2cbc 556 SV* rv;
557
7918f24d
NC		 558 PERL_ARGS_ASSERT_REFTO;
559
71be2cbc 560 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
561 if (LvTARGLEN(sv))
68dc0745 562 vivify_defelem(sv);
563 if (!(sv = LvTARG(sv)))
3280af22 564 sv = &PL_sv_undef;
0dd88869 565 else
b37c2d43 566 SvREFCNT_inc_void_NN(sv);
71be2cbc 567 }
d8b46c1b 568 else if (SvTYPE(sv) == SVt_PVAV) {
502c6561
NC		 569 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
570 av_reify(MUTABLE_AV(sv));
d8b46c1b 571 SvTEMP_off(sv);
b37c2d43 572 SvREFCNT_inc_void_NN(sv);
d8b46c1b 573 }
f2933f5f
DM		 574 else if (SvPADTMP(sv) && !IS_PADGV(sv))
575 sv = newSVsv(sv);
71be2cbc 576 else {
577 SvTEMP_off(sv);
b37c2d43 578 SvREFCNT_inc_void_NN(sv);
71be2cbc 579 }
580 rv = sv_newmortal();
4df7f6af 581 sv_upgrade(rv, SVt_IV);
b162af07 582 SvRV_set(rv, sv);
71be2cbc 583 SvROK_on(rv);
584 return rv;
585}
586
79072805
LW		 587PP(pp_ref)
588{
97aff369 589 dVAR; dSP; dTARGET;
1b6737cc 590 SV * const sv = POPs;
f12c7020 591
511ddbdf
FC		 592 SvGETMAGIC(sv);
593 if (!SvROK(sv))
4633a7c4 594 RETPUSHNO;
79072805 595
a15456de
BF		 596 (void)sv_ref(TARG,SvRV(sv),TRUE);
597 PUSHTARG;
79072805
LW		 598 RETURN;
599}
600
601PP(pp_bless)
602{
97aff369 603 dVAR; dSP;
463ee0b2 604 HV *stash;
79072805 605
463ee0b2 606 if (MAXARG == 1)
dcdfe746 607 {
c2f922f1 608 curstash:
11faa288 609 stash = CopSTASH(PL_curcop);
dcdfe746
FC		 610 if (SvTYPE(stash) != SVt_PVHV)
611 Perl_croak(aTHX_ "Attempt to bless into a freed package");
612 }
7b8d334a 613 else {
1b6737cc 614 SV * const ssv = POPs;
7b8d334a 615 STRLEN len;
e1ec3a88 616 const char *ptr;
81689caa 617
c2f922f1 618 if (!ssv) goto curstash;
8d9dd4b9 619 SvGETMAGIC(ssv);
c7ea825d
FC		 620 if (SvROK(ssv)) {
621 if (!SvAMAGIC(ssv)) {
622 frog:
81689caa 623 Perl_croak(aTHX_ "Attempt to bless into a reference");
c7ea825d
FC		 624 }
625 /* SvAMAGIC is on here, but it only means potentially overloaded,
626 so after stringification: */
627 ptr = SvPV_nomg_const(ssv,len);
628 /* We need to check the flag again: */
629 if (!SvAMAGIC(ssv)) goto frog;
630 }
631 else ptr = SvPV_nomg_const(ssv,len);
a2a5de95
NC		 632 if (len == 0)
633 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
634 "Explicit blessing to '' (assuming package main)");
e69c50fe 635 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
7b8d334a 636 }
a0d0e21e 637
5d3fdfeb 638 (void)sv_bless(TOPs, stash);
79072805
LW		 639 RETURN;
640}
641
fb73857a 642PP(pp_gelem)
643{
97aff369 644 dVAR; dSP;
b13b2135 645
1b6737cc 646 SV *sv = POPs;
a180b31a
BF		 647 STRLEN len;
648 const char * const elem = SvPV_const(sv, len);
159b6efe 649 GV * const gv = MUTABLE_GV(POPs);
c445ea15 650 SV * tmpRef = NULL;
1b6737cc 651
c445ea15 652 sv = NULL;
c4ba80c3
NC		 653 if (elem) {
654 /* elem will always be NUL terminated. */
1b6737cc 655 const char * const second_letter = elem + 1;
c4ba80c3
NC		 656 switch (*elem) {
657 case 'A':
a180b31a 658 if (len == 5 && strEQ(second_letter, "RRAY"))
e14698d8 659 {
ad64d0ec 660 tmpRef = MUTABLE_SV(GvAV(gv));
e14698d8
FC		 661 if (tmpRef && !AvREAL((const AV *)tmpRef)
662 && AvREIFY((const AV *)tmpRef))
663 av_reify(MUTABLE_AV(tmpRef));
664 }
c4ba80c3
NC		 665 break;
666 case 'C':
a180b31a 667 if (len == 4 && strEQ(second_letter, "ODE"))
ad64d0ec 668 tmpRef = MUTABLE_SV(GvCVu(gv));
c4ba80c3
NC		 669 break;
670 case 'F':
a180b31a 671 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
c4ba80c3
NC		 672 /* finally deprecated in 5.8.0 */
673 deprecate("*glob{FILEHANDLE}");
ad64d0ec 674 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC		 675 }
676 else
a180b31a 677 if (len == 6 && strEQ(second_letter, "ORMAT"))
ad64d0ec 678 tmpRef = MUTABLE_SV(GvFORM(gv));
c4ba80c3
NC		 679 break;
680 case 'G':
a180b31a 681 if (len == 4 && strEQ(second_letter, "LOB"))
ad64d0ec 682 tmpRef = MUTABLE_SV(gv);
c4ba80c3
NC		 683 break;
684 case 'H':
a180b31a 685 if (len == 4 && strEQ(second_letter, "ASH"))
ad64d0ec 686 tmpRef = MUTABLE_SV(GvHV(gv));
c4ba80c3
NC		 687 break;
688 case 'I':
a180b31a 689 if (*second_letter == 'O' && !elem[2] && len == 2)
ad64d0ec 690 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC		 691 break;
692 case 'N':
a180b31a 693 if (len == 4 && strEQ(second_letter, "AME"))
a663657d 694 sv = newSVhek(GvNAME_HEK(gv));
c4ba80c3
NC		 695 break;
696 case 'P':
a180b31a 697 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
7fa3a4ab
NC		 698 const HV * const stash = GvSTASH(gv);
699 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
396482e1 700 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
c4ba80c3
NC		 701 }
702 break;
703 case 'S':
a180b31a 704 if (len == 6 && strEQ(second_letter, "CALAR"))
f9d52e31 705 tmpRef = GvSVn(gv);
c4ba80c3 706 break;
39b99f21 707 }
fb73857a 708 }
76e3520e
GS		 709 if (tmpRef)
710 sv = newRV(tmpRef);
fb73857a 711 if (sv)
712 sv_2mortal(sv);
713 else
3280af22 714 sv = &PL_sv_undef;
fb73857a 715 XPUSHs(sv);
716 RETURN;
717}
718
a0d0e21e 719/* Pattern matching */
79072805 720
a0d0e21e 721PP(pp_study)
79072805 722{
97aff369 723 dVAR; dSP; dPOPss;
a0d0e21e
LW		 724 STRLEN len;
725
1fa930f2 726 (void)SvPV(sv, len);
bc9a5256 727 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
32f0ea87 728 /* Historically, study was skipped in these cases. */
a4f4e906
NC		 729 RETPUSHNO;
730 }
731
a58a85fa 732 /* Make study a no-op. It's no longer useful and its existence
32f0ea87 733 complicates matters elsewhere. */
1e422769 734 RETPUSHYES;
79072805
LW		 735}
736
a0d0e21e 737PP(pp_trans)
79072805 738{
97aff369 739 dVAR; dSP; dTARG;
a0d0e21e
LW		 740 SV *sv;
741
533c011a 742 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 743 sv = POPs;
59f00321
RGS		 744 else if (PL_op->op_private & OPpTARGET_MY)
745 sv = GETTARGET;
79072805 746 else {
54b9620d 747 sv = DEFSV;
a0d0e21e 748 EXTEND(SP,1);
79072805 749 }
bb16bae8 750 if(PL_op->op_type == OP_TRANSR) {
290797f7
FC		 751 STRLEN len;
752 const char * const pv = SvPV(sv,len);
753 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
bb16bae8 754 do_trans(newsv);
290797f7 755 PUSHs(newsv);
bb16bae8 756 }
5bbe7184
FC		 757 else {
758 TARG = sv_newmortal();
759 PUSHi(do_trans(sv));
760 }
a0d0e21e 761 RETURN;
79072805
LW		 762}
763
a0d0e21e 764/* Lvalue operators. */
79072805 765
81745e4e
NC		 766static void
767S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
768{
769 dVAR;
770 STRLEN len;
771 char *s;
772
773 PERL_ARGS_ASSERT_DO_CHOMP;
774
775 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
776 return;
777 if (SvTYPE(sv) == SVt_PVAV) {
778 I32 i;
779 AV *const av = MUTABLE_AV(sv);
780 const I32 max = AvFILL(av);
781
782 for (i = 0; i <= max; i++) {
783 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
784 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
785 do_chomp(retval, sv, chomping);
786 }
787 return;
788 }
789 else if (SvTYPE(sv) == SVt_PVHV) {
790 HV* const hv = MUTABLE_HV(sv);
791 HE* entry;
792 (void)hv_iterinit(hv);
793 while ((entry = hv_iternext(hv)))
794 do_chomp(retval, hv_iterval(hv,entry), chomping);
795 return;
796 }
797 else if (SvREADONLY(sv)) {
cb077ed2 798 Perl_croak_no_modify();
81745e4e 799 }
e3918bb7
FC		 800 else if (SvIsCOW(sv)) {
801 sv_force_normal_flags(sv, 0);
802 }
81745e4e
NC		 803
804 if (PL_encoding) {
805 if (!SvUTF8(sv)) {
806 /* XXX, here sv is utf8-ized as a side-effect!
807 If encoding.pm is used properly, almost string-generating
808 operations, including literal strings, chr(), input data, etc.
809 should have been utf8-ized already, right?
810 */
811 sv_recode_to_utf8(sv, PL_encoding);
812 }
813 }
814
815 s = SvPV(sv, len);
816 if (chomping) {
817 char *temp_buffer = NULL;
818 SV *svrecode = NULL;
819
820 if (s && len) {
821 s += --len;
822 if (RsPARA(PL_rs)) {
823 if (*s != '\n')
824 goto nope;
825 ++SvIVX(retval);
826 while (len && s[-1] == '\n') {
827 --len;
828 --s;
829 ++SvIVX(retval);
830 }
831 }
832 else {
833 STRLEN rslen, rs_charlen;
834 const char *rsptr = SvPV_const(PL_rs, rslen);
835
836 rs_charlen = SvUTF8(PL_rs)
837 ? sv_len_utf8(PL_rs)
838 : rslen;
839
840 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
841 /* Assumption is that rs is shorter than the scalar. */
842 if (SvUTF8(PL_rs)) {
843 /* RS is utf8, scalar is 8 bit. */
844 bool is_utf8 = TRUE;
845 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
846 &rslen, &is_utf8);
847 if (is_utf8) {
848 /* Cannot downgrade, therefore cannot possibly match
849 */
850 assert (temp_buffer == rsptr);
851 temp_buffer = NULL;
852 goto nope;
853 }
854 rsptr = temp_buffer;
855 }
856 else if (PL_encoding) {
857 /* RS is 8 bit, encoding.pm is used.
858 * Do not recode PL_rs as a side-effect. */
859 svrecode = newSVpvn(rsptr, rslen);
860 sv_recode_to_utf8(svrecode, PL_encoding);
861 rsptr = SvPV_const(svrecode, rslen);
862 rs_charlen = sv_len_utf8(svrecode);
863 }
864 else {
865 /* RS is 8 bit, scalar is utf8. */
866 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
867 rsptr = temp_buffer;
868 }
869 }
870 if (rslen == 1) {
871 if (*s != *rsptr)
872 goto nope;
873 ++SvIVX(retval);
874 }
875 else {
876 if (len < rslen - 1)
877 goto nope;
878 len -= rslen - 1;
879 s -= rslen - 1;
880 if (memNE(s, rsptr, rslen))
881 goto nope;
882 SvIVX(retval) += rs_charlen;
883 }
884 }
fbac7ddf 885 s = SvPV_force_nomg_nolen(sv);
81745e4e
NC		 886 SvCUR_set(sv, len);
887 *SvEND(sv) = '\0';
888 SvNIOK_off(sv);
889 SvSETMAGIC(sv);
890 }
891 nope:
892
893 SvREFCNT_dec(svrecode);
894
895 Safefree(temp_buffer);
896 } else {
897 if (len && !SvPOK(sv))
898 s = SvPV_force_nomg(sv, len);
899 if (DO_UTF8(sv)) {
900 if (s && len) {
901 char * const send = s + len;
902 char * const start = s;
903 s = send - 1;
904 while (s > start && UTF8_IS_CONTINUATION(*s))
905 s--;
906 if (is_utf8_string((U8*)s, send - s)) {
907 sv_setpvn(retval, s, send - s);
908 *s = '\0';
909 SvCUR_set(sv, s - start);
910 SvNIOK_off(sv);
911 SvUTF8_on(retval);
912 }
913 }
914 else
915 sv_setpvs(retval, "");
916 }
917 else if (s && len) {
918 s += --len;
919 sv_setpvn(retval, s, 1);
920 *s = '\0';
921 SvCUR_set(sv, len);
922 SvUTF8_off(sv);
923 SvNIOK_off(sv);
924 }
925 else
926 sv_setpvs(retval, "");
927 SvSETMAGIC(sv);
928 }
929}
930
a0d0e21e
LW		 931PP(pp_schop)
932{
97aff369 933 dVAR; dSP; dTARGET;
fa54efae
NC		 934 const bool chomping = PL_op->op_type == OP_SCHOMP;
935
936 if (chomping)
937 sv_setiv(TARG, 0);
938 do_chomp(TARG, TOPs, chomping);
a0d0e21e
LW		 939 SETTARG;
940 RETURN;
79072805
LW		 941}
942
a0d0e21e 943PP(pp_chop)
79072805 944{
97aff369 945 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
fa54efae 946 const bool chomping = PL_op->op_type == OP_CHOMP;
8ec5e241 947
fa54efae
NC		 948 if (chomping)
949 sv_setiv(TARG, 0);
20cf1f79 950 while (MARK < SP)
fa54efae 951 do_chomp(TARG, *++MARK, chomping);
20cf1f79
NC		 952 SP = ORIGMARK;
953 XPUSHTARG;
a0d0e21e 954 RETURN;
79072805
LW		 955}
956
a0d0e21e
LW		 957PP(pp_undef)
958{
97aff369 959 dVAR; dSP;
a0d0e21e
LW		 960 SV *sv;
961
533c011a 962 if (!PL_op->op_private) {
774d564b 963 EXTEND(SP, 1);
a0d0e21e 964 RETPUSHUNDEF;
774d564b 965 }
79072805 966
a0d0e21e
LW		 967 sv = POPs;
968 if (!sv)
969 RETPUSHUNDEF;
85e6fe83 970
765f542d 971 SV_CHECK_THINKFIRST_COW_DROP(sv);
85e6fe83 972
a0d0e21e
LW		 973 switch (SvTYPE(sv)) {
974 case SVt_NULL:
975 break;
976 case SVt_PVAV:
60edcf09 977 av_undef(MUTABLE_AV(sv));
a0d0e21e
LW		 978 break;
979 case SVt_PVHV:
60edcf09 980 hv_undef(MUTABLE_HV(sv));
a0d0e21e
LW		 981 break;
982 case SVt_PVCV:
a2a5de95 983 if (cv_const_sv((const CV *)sv))
714cd18f
BF		 984 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
985 "Constant subroutine %"SVf" undefined",
986 SVfARG(CvANON((const CV *)sv)
987 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
bdbfc51a
FC		 988 : sv_2mortal(newSVhek(
989 CvNAMED(sv)
990 ? CvNAME_HEK((CV *)sv)
991 : GvENAME_HEK(CvGV((const CV *)sv))
992 ))
993 ));
5f66b61c 994 /* FALLTHROUGH */
9607fc9c 995 case SVt_PVFM:
6fc92669
GS		 996 {
997 /* let user-undef'd sub keep its identity */
ea726b52 998 GV* const gv = CvGV((const CV *)sv);
b290562e
FC		 999 HEK * const hek = CvNAME_HEK((CV *)sv);
1000 if (hek) share_hek_hek(hek);
ea726b52 1001 cv_undef(MUTABLE_CV(sv));
b290562e
FC		 1002 if (gv) CvGV_set(MUTABLE_CV(sv), gv);
1003 else if (hek) {
1004 SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
1005 CvNAMED_on(sv);
1006 }
6fc92669 1007 }
a0d0e21e 1008 break;
8e07c86e 1009 case SVt_PVGV:
bc1df6c2
FC		 1010 assert(isGV_with_GP(sv));
1011 assert(!SvFAKE(sv));
1012 {
20408e3c 1013 GP *gp;
dd69841b
BB		 1014 HV *stash;
1015
dd69841b 1016 /* undef *Pkg::meth_name ... */
e530fb81
FC		 1017 bool method_changed
1018 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1019 && HvENAME_get(stash);
1020 /* undef *Foo:: */
1021 if((stash = GvHV((const GV *)sv))) {
1022 if(HvENAME_get(stash))
1023 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1024 else stash = NULL;
1025 }
dd69841b 1026
159b6efe 1027 gp_free(MUTABLE_GV(sv));
a02a5408 1028 Newxz(gp, 1, GP);
c43ae56f 1029 GvGP_set(sv, gp_ref(gp));
2e3295e3 1030#ifndef PERL_DONT_CREATE_GVSV
561b68a9 1031 GvSV(sv) = newSV(0);
2e3295e3 1032#endif
57843af0 1033 GvLINE(sv) = CopLINE(PL_curcop);
159b6efe 1034 GvEGV(sv) = MUTABLE_GV(sv);
20408e3c 1035 GvMULTI_on(sv);
e530fb81
FC		 1036
1037 if(stash)
afdbe55d 1038 mro_package_moved(NULL, stash, (const GV *)sv, 0);
e530fb81
FC		 1039 stash = NULL;
1040 /* undef *Foo::ISA */
1041 if( strEQ(GvNAME((const GV *)sv), "ISA")
1042 && (stash = GvSTASH((const GV *)sv))
1043 && (method_changed || HvENAME(stash)) )
1044 mro_isa_changed_in(stash);
1045 else if(method_changed)
1046 mro_method_changed_in(
da9043f5 1047 GvSTASH((const GV *)sv)
e530fb81
FC		 1048 );
1049
6e592b3a 1050 break;
20408e3c 1051 }
a0d0e21e 1052 default:
b15aece3 1053 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
8bd4d4c5 1054 SvPV_free(sv);
c445ea15 1055 SvPV_set(sv, NULL);
4633a7c4 1056 SvLEN_set(sv, 0);
a0d0e21e 1057 }
0c34ef67 1058 SvOK_off(sv);
4633a7c4 1059 SvSETMAGIC(sv);
79072805 1060 }
a0d0e21e
LW		 1061
1062 RETPUSHUNDEF;
79072805
LW		 1063}
1064
a0d0e21e
LW		 1065PP(pp_postinc)
1066{
97aff369 1067 dVAR; dSP; dTARGET;
c22c99bc
FC		 1068 const bool inc =
1069 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
60092ce4 1070 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
cb077ed2 1071 Perl_croak_no_modify();
7dcb9b98
DM		 1072 if (SvROK(TOPs))
1073 TARG = sv_newmortal();
a0d0e21e 1074 sv_setsv(TARG, TOPs);
4bac9ae4 1075 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
c22c99bc 1076 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
55497cff 1077 {
c22c99bc 1078 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
55497cff 1079 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 1080 }
c22c99bc 1081 else if (inc)
6f1401dc 1082 sv_inc_nomg(TOPs);
c22c99bc 1083 else sv_dec_nomg(TOPs);
a0d0e21e 1084 SvSETMAGIC(TOPs);
1e54a23f 1085 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
c22c99bc 1086 if (inc && !SvOK(TARG))
a0d0e21e
LW		 1087 sv_setiv(TARG, 0);
1088 SETs(TARG);
1089 return NORMAL;
1090}
79072805 1091
a0d0e21e
LW		 1092/* Ordinary operators. */
1093
1094PP(pp_pow)
1095{
800401ee 1096 dVAR; dSP; dATARGET; SV *svl, *svr;
58d76dfd 1097#ifdef PERL_PRESERVE_IVUV
52a96ae6
HS		 1098 bool is_int = 0;
1099#endif
6f1401dc
DM		 1100 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1101 svr = TOPs;
1102 svl = TOPm1s;
52a96ae6
HS		 1103#ifdef PERL_PRESERVE_IVUV
1104 /* For integer to integer power, we do the calculation by hand wherever
1105 we're sure it is safe; otherwise we call pow() and try to convert to
1106 integer afterwards. */
01f91bf2 1107 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
900658e3
PF		 1108 UV power;
1109 bool baseuok;
1110 UV baseuv;
1111
800401ee
JH		 1112 if (SvUOK(svr)) {
1113 power = SvUVX(svr);
900658e3 1114 } else {
800401ee 1115 const IV iv = SvIVX(svr);
900658e3
PF		 1116 if (iv >= 0) {
1117 power = iv;
1118 } else {
1119 goto float_it; /* Can't do negative powers this way. */
1120 }
1121 }
1122
800401ee 1123 baseuok = SvUOK(svl);
900658e3 1124 if (baseuok) {
800401ee 1125 baseuv = SvUVX(svl);
900658e3 1126 } else {
800401ee 1127 const IV iv = SvIVX(svl);
900658e3
PF		 1128 if (iv >= 0) {
1129 baseuv = iv;
1130 baseuok = TRUE; /* effectively it's a UV now */
1131 } else {
1132 baseuv = -iv; /* abs, baseuok == false records sign */
1133 }
1134 }
52a96ae6
HS		 1135 /* now we have integer ** positive integer. */
1136 is_int = 1;
1137
1138 /* foo & (foo - 1) is zero only for a power of 2. */
58d76dfd 1139 if (!(baseuv & (baseuv - 1))) {
52a96ae6 1140 /* We are raising power-of-2 to a positive integer.
58d76dfd
JH		 1141 The logic here will work for any base (even non-integer
1142 bases) but it can be less accurate than
1143 pow (base,power) or exp (power * log (base)) when the
1144 intermediate values start to spill out of the mantissa.
1145 With powers of 2 we know this can't happen.
1146 And powers of 2 are the favourite thing for perl
1147 programmers to notice ** not doing what they mean. */
1148 NV result = 1.0;
1149 NV base = baseuok ? baseuv : -(NV)baseuv;
900658e3
PF		 1150
1151 if (power & 1) {
1152 result *= base;
1153 }
1154 while (power >>= 1) {
1155 base *= base;
1156 if (power & 1) {
1157 result *= base;
1158 }
1159 }
58d76dfd
JH		 1160 SP--;
1161 SETn( result );
6f1401dc 1162 SvIV_please_nomg(svr);
58d76dfd 1163 RETURN;
52a96ae6 1164 } else {
eb578fdb
KW		 1165 unsigned int highbit = 8 * sizeof(UV);
1166 unsigned int diff = 8 * sizeof(UV);
900658e3
PF		 1167 while (diff >>= 1) {
1168 highbit -= diff;
1169 if (baseuv >> highbit) {
1170 highbit += diff;
1171 }
52a96ae6
HS		 1172 }
1173 /* we now have baseuv < 2 ** highbit */
1174 if (power * highbit <= 8 * sizeof(UV)) {
1175 /* result will definitely fit in UV, so use UV math
1176 on same algorithm as above */
eb578fdb
KW		 1177 UV result = 1;
1178 UV base = baseuv;
f2338a2e 1179 const bool odd_power = cBOOL(power & 1);
900658e3
PF		 1180 if (odd_power) {
1181 result *= base;
1182 }
1183 while (power >>= 1) {
1184 base *= base;
1185 if (power & 1) {
52a96ae6 1186 result *= base;
52a96ae6
HS		 1187 }
1188 }
1189 SP--;
0615a994 1190 if (baseuok || !odd_power)
52a96ae6
HS		 1191 /* answer is positive */
1192 SETu( result );
1193 else if (result <= (UV)IV_MAX)
1194 /* answer negative, fits in IV */
1195 SETi( -(IV)result );
1196 else if (result == (UV)IV_MIN)
1197 /* 2's complement assumption: special case IV_MIN */
1198 SETi( IV_MIN );
1199 else
1200 /* answer negative, doesn't fit */
1201 SETn( -(NV)result );
1202 RETURN;
1203 }
1204 }
58d76dfd 1205 }
52a96ae6 1206 float_it:
58d76dfd 1207#endif
a0d0e21e 1208 {
6f1401dc
DM		 1209 NV right = SvNV_nomg(svr);
1210 NV left = SvNV_nomg(svl);
4efa5a16 1211 (void)POPs;
3aaeb624
JA		 1212
1213#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1214 /*
1215 We are building perl with long double support and are on an AIX OS
1216 afflicted with a powl() function that wrongly returns NaNQ for any
1217 negative base. This was reported to IBM as PMR #23047-379 on
1218 03/06/2006. The problem exists in at least the following versions
1219 of AIX and the libm fileset, and no doubt others as well:
1220
1221 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1222 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1223 AIX 5.2.0 bos.adt.libm 5.2.0.85
1224
1225 So, until IBM fixes powl(), we provide the following workaround to
1226 handle the problem ourselves. Our logic is as follows: for
1227 negative bases (left), we use fmod(right, 2) to check if the
1228 exponent is an odd or even integer:
1229
1230 - if odd, powl(left, right) == -powl(-left, right)
1231 - if even, powl(left, right) == powl(-left, right)
1232
1233 If the exponent is not an integer, the result is rightly NaNQ, so
1234 we just return that (as NV_NAN).
1235 */
1236
1237 if (left < 0.0) {
1238 NV mod2 = Perl_fmod( right, 2.0 );
1239 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1240 SETn( -Perl_pow( -left, right) );
1241 } else if (mod2 == 0.0) { /* even integer */
1242 SETn( Perl_pow( -left, right) );
1243 } else { /* fractional power */
1244 SETn( NV_NAN );
1245 }
1246 } else {
1247 SETn( Perl_pow( left, right) );
1248 }
1249#else
52a96ae6 1250 SETn( Perl_pow( left, right) );
3aaeb624
JA		 1251#endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1252
52a96ae6
HS		 1253#ifdef PERL_PRESERVE_IVUV
1254 if (is_int)
6f1401dc 1255 SvIV_please_nomg(svr);
52a96ae6
HS		 1256#endif
1257 RETURN;
93a17b20 1258 }
a0d0e21e
LW		 1259}
1260
1261PP(pp_multiply)
1262{
800401ee 1263 dVAR; dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM		 1264 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1265 svr = TOPs;
1266 svl = TOPm1s;
28e5dec8 1267#ifdef PERL_PRESERVE_IVUV
01f91bf2 1268 if (SvIV_please_nomg(svr)) {
28e5dec8
JH		 1269 /* Unless the left argument is integer in range we are going to have to
1270 use NV maths. Hence only attempt to coerce the right argument if
1271 we know the left is integer. */
1272 /* Left operand is defined, so is it IV? */
01f91bf2 1273 if (SvIV_please_nomg(svl)) {
800401ee
JH		 1274 bool auvok = SvUOK(svl);
1275 bool buvok = SvUOK(svr);
28e5dec8
JH		 1276 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1277 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1278 UV alow;
1279 UV ahigh;
1280 UV blow;
1281 UV bhigh;
1282
1283 if (auvok) {
800401ee 1284 alow = SvUVX(svl);
28e5dec8 1285 } else {
800401ee 1286 const IV aiv = SvIVX(svl);
28e5dec8
JH		 1287 if (aiv >= 0) {
1288 alow = aiv;
1289 auvok = TRUE; /* effectively it's a UV now */
1290 } else {
1291 alow = -aiv; /* abs, auvok == false records sign */
1292 }
1293 }
1294 if (buvok) {
800401ee 1295 blow = SvUVX(svr);
28e5dec8 1296 } else {
800401ee 1297 const IV biv = SvIVX(svr);
28e5dec8
JH		 1298 if (biv >= 0) {
1299 blow = biv;
1300 buvok = TRUE; /* effectively it's a UV now */
1301 } else {
1302 blow = -biv; /* abs, buvok == false records sign */
1303 }
1304 }
1305
1306 /* If this does sign extension on unsigned it's time for plan B */
1307 ahigh = alow >> (4 * sizeof (UV));
1308 alow &= botmask;
1309 bhigh = blow >> (4 * sizeof (UV));
1310 blow &= botmask;
1311 if (ahigh && bhigh) {
6f207bd3 1312 NOOP;
28e5dec8
JH		 1313 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1314 which is overflow. Drop to NVs below. */
1315 } else if (!ahigh && !bhigh) {
1316 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1317 so the unsigned multiply cannot overflow. */
c445ea15 1318 const UV product = alow * blow;
28e5dec8
JH		 1319 if (auvok == buvok) {
1320 /* -ve * -ve or +ve * +ve gives a +ve result. */
1321 SP--;
1322 SETu( product );
1323 RETURN;
1324 } else if (product <= (UV)IV_MIN) {
1325 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1326 /* -ve result, which could overflow an IV */
1327 SP--;
25716404 1328 SETi( -(IV)product );
28e5dec8
JH		 1329 RETURN;
1330 } /* else drop to NVs below. */
1331 } else {
1332 /* One operand is large, 1 small */
1333 UV product_middle;
1334 if (bhigh) {
1335 /* swap the operands */
1336 ahigh = bhigh;
1337 bhigh = blow; /* bhigh now the temp var for the swap */
1338 blow = alow;
1339 alow = bhigh;
1340 }
1341 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1342 multiplies can't overflow. shift can, add can, -ve can. */
1343 product_middle = ahigh * blow;
1344 if (!(product_middle & topmask)) {
1345 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1346 UV product_low;
1347 product_middle <<= (4 * sizeof (UV));
1348 product_low = alow * blow;
1349
1350 /* as for pp_add, UV + something mustn't get smaller.
1351 IIRC ANSI mandates this wrapping *behaviour* for
1352 unsigned whatever the actual representation*/
1353 product_low += product_middle;
1354 if (product_low >= product_middle) {
1355 /* didn't overflow */
1356 if (auvok == buvok) {
1357 /* -ve * -ve or +ve * +ve gives a +ve result. */
1358 SP--;
1359 SETu( product_low );
1360 RETURN;
1361 } else if (product_low <= (UV)IV_MIN) {
1362 /* 2s complement assumption again */
1363 /* -ve result, which could overflow an IV */
1364 SP--;
25716404 1365 SETi( -(IV)product_low );
28e5dec8
JH		 1366 RETURN;
1367 } /* else drop to NVs below. */
1368 }
1369 } /* product_middle too large */
1370 } /* ahigh && bhigh */
800401ee
JH		 1371 } /* SvIOK(svl) */
1372 } /* SvIOK(svr) */
28e5dec8 1373#endif
a0d0e21e 1374 {
6f1401dc
DM		 1375 NV right = SvNV_nomg(svr);
1376 NV left = SvNV_nomg(svl);
4efa5a16 1377 (void)POPs;
a0d0e21e
LW		 1378 SETn( left * right );
1379 RETURN;
79072805 1380 }
a0d0e21e
LW		 1381}
1382
1383PP(pp_divide)
1384{
800401ee 1385 dVAR; dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM		 1386 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1387 svr = TOPs;
1388 svl = TOPm1s;
5479d192 1389 /* Only try to do UV divide first
68795e93 1390 if ((SLOPPYDIVIDE is true) or
5479d192
NC		 1391 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1392 to preserve))
1393 The assumption is that it is better to use floating point divide
1394 whenever possible, only doing integer divide first if we can't be sure.
1395 If NV_PRESERVES_UV is true then we know at compile time that no UV
1396 can be too large to preserve, so don't need to compile the code to
1397 test the size of UVs. */
1398
a0d0e21e 1399#ifdef SLOPPYDIVIDE
5479d192
NC		 1400# define PERL_TRY_UV_DIVIDE
1401 /* ensure that 20./5. == 4. */
a0d0e21e 1402#else
5479d192
NC		 1403# ifdef PERL_PRESERVE_IVUV
1404# ifndef NV_PRESERVES_UV
1405# define PERL_TRY_UV_DIVIDE
1406# endif
1407# endif
a0d0e21e 1408#endif
5479d192
NC		 1409
1410#ifdef PERL_TRY_UV_DIVIDE
01f91bf2 1411 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
800401ee
JH		 1412 bool left_non_neg = SvUOK(svl);
1413 bool right_non_neg = SvUOK(svr);
5479d192
NC		 1414 UV left;
1415 UV right;
1416
1417 if (right_non_neg) {
800401ee 1418 right = SvUVX(svr);
5479d192
NC		 1419 }
1420 else {
800401ee 1421 const IV biv = SvIVX(svr);
5479d192
NC		 1422 if (biv >= 0) {
1423 right = biv;
1424 right_non_neg = TRUE; /* effectively it's a UV now */
1425 }
1426 else {
1427 right = -biv;
1428 }
1429 }
1430 /* historically undef()/0 gives a "Use of uninitialized value"
1431 warning before dieing, hence this test goes here.
1432 If it were immediately before the second SvIV_please, then
1433 DIE() would be invoked before left was even inspected, so
486ec47a 1434 no inspection would give no warning. */
5479d192
NC		 1435 if (right == 0)
1436 DIE(aTHX_ "Illegal division by zero");
1437
1438 if (left_non_neg) {
800401ee 1439 left = SvUVX(svl);
5479d192
NC		 1440 }
1441 else {
800401ee 1442 const IV aiv = SvIVX(svl);
5479d192
NC		 1443 if (aiv >= 0) {
1444 left = aiv;
1445 left_non_neg = TRUE; /* effectively it's a UV now */
1446 }
1447 else {
1448 left = -aiv;
1449 }
1450 }
1451
1452 if (left >= right
1453#ifdef SLOPPYDIVIDE
1454 /* For sloppy divide we always attempt integer division. */
1455#else
1456 /* Otherwise we only attempt it if either or both operands
1457 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC		 1458 we fall through to the NV divide code below. However,
1459 as left >= right to ensure integer result here, we know that
1460 we can skip the test on the right operand - right big
1461 enough not to be preserved can't get here unless left is
1462 also too big. */
1463
1464 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC		 1465#endif
1466 ) {
1467 /* Integer division can't overflow, but it can be imprecise. */
1b6737cc 1468 const UV result = left / right;
5479d192
NC		 1469 if (result * right == left) {
1470 SP--; /* result is valid */
1471 if (left_non_neg == right_non_neg) {
1472 /* signs identical, result is positive. */
1473 SETu( result );
1474 RETURN;
1475 }
1476 /* 2s complement assumption */
1477 if (result <= (UV)IV_MIN)
91f3b821 1478 SETi( -(IV)result );
5479d192
NC		 1479 else {
1480 /* It's exact but too negative for IV. */
1481 SETn( -(NV)result );
1482 }
1483 RETURN;
1484 } /* tried integer divide but it was not an integer result */
32fdb065 1485 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
01f91bf2 1486 } /* one operand wasn't SvIOK */
5479d192
NC		 1487#endif /* PERL_TRY_UV_DIVIDE */
1488 {
6f1401dc
DM		 1489 NV right = SvNV_nomg(svr);
1490 NV left = SvNV_nomg(svl);
4efa5a16 1491 (void)POPs;(void)POPs;
ebc6a117
PD		 1492#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1493 if (! Perl_isnan(right) && right == 0.0)
1494#else
659c4b96 1495 if (right == 0.0)
ebc6a117 1496#endif
5479d192
NC		 1497 DIE(aTHX_ "Illegal division by zero");
1498 PUSHn( left / right );
1499 RETURN;
79072805 1500 }
a0d0e21e
LW		 1501}
1502
1503PP(pp_modulo)
1504{
6f1401dc
DM		 1505 dVAR; dSP; dATARGET;
1506 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
a0d0e21e 1507 {
9c5ffd7c
JH		 1508 UV left = 0;
1509 UV right = 0;
dc656993
JH		 1510 bool left_neg = FALSE;
1511 bool right_neg = FALSE;
e2c88acc
NC		 1512 bool use_double = FALSE;
1513 bool dright_valid = FALSE;
9c5ffd7c
JH		 1514 NV dright = 0.0;
1515 NV dleft = 0.0;
6f1401dc
DM		 1516 SV * const svr = TOPs;
1517 SV * const svl = TOPm1s;
01f91bf2 1518 if (SvIV_please_nomg(svr)) {
800401ee 1519 right_neg = !SvUOK(svr);
e2c88acc 1520 if (!right_neg) {
800401ee 1521 right = SvUVX(svr);
e2c88acc 1522 } else {
800401ee 1523 const IV biv = SvIVX(svr);
e2c88acc
NC		 1524 if (biv >= 0) {
1525 right = biv;
1526 right_neg = FALSE; /* effectively it's a UV now */
1527 } else {
1528 right = -biv;
1529 }
1530 }
1531 }
1532 else {
6f1401dc 1533 dright = SvNV_nomg(svr);
787eafbd
IZ		 1534 right_neg = dright < 0;
1535 if (right_neg)
1536 dright = -dright;
e2c88acc
NC		 1537 if (dright < UV_MAX_P1) {
1538 right = U_V(dright);
1539 dright_valid = TRUE; /* In case we need to use double below. */
1540 } else {
1541 use_double = TRUE;
1542 }
787eafbd 1543 }
a0d0e21e 1544
e2c88acc
NC		 1545 /* At this point use_double is only true if right is out of range for
1546 a UV. In range NV has been rounded down to nearest UV and
1547 use_double false. */
01f91bf2 1548 if (!use_double && SvIV_please_nomg(svl)) {
800401ee 1549 left_neg = !SvUOK(svl);
e2c88acc 1550 if (!left_neg) {
800401ee 1551 left = SvUVX(svl);
e2c88acc 1552 } else {
800401ee 1553 const IV aiv = SvIVX(svl);
e2c88acc
NC		 1554 if (aiv >= 0) {
1555 left = aiv;
1556 left_neg = FALSE; /* effectively it's a UV now */
1557 } else {
1558 left = -aiv;
1559 }
1560 }
e2c88acc 1561 }
787eafbd 1562 else {
6f1401dc 1563 dleft = SvNV_nomg(svl);
787eafbd
IZ		 1564 left_neg = dleft < 0;
1565 if (left_neg)
1566 dleft = -dleft;
68dc0745 1567
e2c88acc
NC		 1568 /* This should be exactly the 5.6 behaviour - if left and right are
1569 both in range for UV then use U_V() rather than floor. */
1570 if (!use_double) {
1571 if (dleft < UV_MAX_P1) {
1572 /* right was in range, so is dleft, so use UVs not double.
1573 */
1574 left = U_V(dleft);
1575 }
1576 /* left is out of range for UV, right was in range, so promote
1577 right (back) to double. */
1578 else {
1579 /* The +0.5 is used in 5.6 even though it is not strictly
1580 consistent with the implicit +0 floor in the U_V()
1581 inside the #if 1. */
1582 dleft = Perl_floor(dleft + 0.5);
1583 use_double = TRUE;
1584 if (dright_valid)
1585 dright = Perl_floor(dright + 0.5);
1586 else
1587 dright = right;
1588 }
1589 }
1590 }
6f1401dc 1591 sp -= 2;
787eafbd 1592 if (use_double) {
65202027 1593 NV dans;
787eafbd 1594
659c4b96 1595 if (!dright)
cea2e8a9 1596 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1597
65202027 1598 dans = Perl_fmod(dleft, dright);
659c4b96 1599 if ((left_neg != right_neg) && dans)
787eafbd
IZ		 1600 dans = dright - dans;
1601 if (right_neg)
1602 dans = -dans;
1603 sv_setnv(TARG, dans);
1604 }
1605 else {
1606 UV ans;
1607
787eafbd 1608 if (!right)
cea2e8a9 1609 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ		 1610
1611 ans = left % right;
1612 if ((left_neg != right_neg) && ans)
1613 ans = right - ans;
1614 if (right_neg) {
1615 /* XXX may warn: unary minus operator applied to unsigned type */
1616 /* could change -foo to be (~foo)+1 instead */
1617 if (ans <= ~((UV)IV_MAX)+1)
1618 sv_setiv(TARG, ~ans+1);
1619 else
65202027 1620 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ		 1621 }
1622 else
1623 sv_setuv(TARG, ans);
1624 }
1625 PUSHTARG;
1626 RETURN;
79072805 1627 }
a0d0e21e 1628}
79072805 1629
a0d0e21e
LW		 1630PP(pp_repeat)
1631{
6f1401dc 1632 dVAR; dSP; dATARGET;
eb578fdb 1633 IV count;
6f1401dc
DM		 1634 SV *sv;
1635
1636 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1637 /* TODO: think of some way of doing list-repeat overloading ??? */
1638 sv = POPs;
1639 SvGETMAGIC(sv);
1640 }
1641 else {
1642 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1643 sv = POPs;
1644 }
1645
2b573ace
JH		 1646 if (SvIOKp(sv)) {
1647 if (SvUOK(sv)) {
6f1401dc 1648 const UV uv = SvUV_nomg(sv);
2b573ace
JH		 1649 if (uv > IV_MAX)
1650 count = IV_MAX; /* The best we can do? */
1651 else
1652 count = uv;
1653 } else {
6f1401dc 1654 const IV iv = SvIV_nomg(sv);
2b573ace
JH		 1655 if (iv < 0)
1656 count = 0;
1657 else
1658 count = iv;
1659 }
1660 }
1661 else if (SvNOKp(sv)) {
6f1401dc 1662 const NV nv = SvNV_nomg(sv);
2b573ace
JH		 1663 if (nv < 0.0)
1664 count = 0;
1665 else
1666 count = (IV)nv;
1667 }
1668 else
6f1401dc
DM		 1669 count = SvIV_nomg(sv);
1670
533c011a 1671 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e 1672 dMARK;
a1894d81 1673 static const char* const oom_list_extend = "Out of memory during list extend";
0bd48802
AL		 1674 const I32 items = SP - MARK;
1675 const I32 max = items * count;
da9e430b 1676 const U8 mod = PL_op->op_flags & OPf_MOD;
79072805 1677
2b573ace
JH		 1678 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1679 /* Did the max computation overflow? */
27d5b266 1680 if (items > 0 && max > 0 && (max < items || max < count))
0157ef98 1681 Perl_croak(aTHX_ "%s", oom_list_extend);
a0d0e21e
LW		 1682 MEXTEND(MARK, max);
1683 if (count > 1) {
1684 while (SP > MARK) {
976c8a39
JH		 1685#if 0
1686 /* This code was intended to fix 20010809.028:
1687
1688 $x = 'abcd';
1689 for (($x =~ /./g) x 2) {
1690 print chop; # "abcdabcd" expected as output.
1691 }
1692
1693 * but that change (#11635) broke this code:
1694
1695 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1696
1697 * I can't think of a better fix that doesn't introduce
1698 * an efficiency hit by copying the SVs. The stack isn't
1699 * refcounted, and mortalisation obviously doesn't
1700 * Do The Right Thing when the stack has more than
1701 * one pointer to the same mortal value.
1702 * .robin.
1703 */
e30acc16
RH		 1704 if (*SP) {
1705 *SP = sv_2mortal(newSVsv(*SP));
1706 SvREADONLY_on(*SP);
1707 }
976c8a39
JH		 1708#else
1709 if (*SP)
da9e430b
FC		 1710 {
1711 if (mod && SvPADTMP(*SP) && !IS_PADGV(*SP))
1712 *SP = sv_mortalcopy(*SP);
976c8a39 1713 SvTEMP_off((*SP));
da9e430b 1714 }
976c8a39 1715#endif
a0d0e21e 1716 SP--;
79072805 1717 }
a0d0e21e
LW		 1718 MARK++;
1719 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1720 items * sizeof(const SV *), count - 1);
a0d0e21e 1721 SP += max;
79072805 1722 }
a0d0e21e
LW		 1723 else if (count <= 0)
1724 SP -= items;
79072805 1725 }
a0d0e21e 1726 else { /* Note: mark already snarfed by pp_list */
0bd48802 1727 SV * const tmpstr = POPs;
a0d0e21e 1728 STRLEN len;
9b877dbb 1729 bool isutf;
a1894d81 1730 static const char* const oom_string_extend =
2b573ace 1731 "Out of memory during string extend";
a0d0e21e 1732
6f1401dc
DM		 1733 if (TARG != tmpstr)
1734 sv_setsv_nomg(TARG, tmpstr);
1735 SvPV_force_nomg(TARG, len);
9b877dbb 1736 isutf = DO_UTF8(TARG);
8ebc5c01 1737 if (count != 1) {
1738 if (count < 1)
1739 SvCUR_set(TARG, 0);
1740 else {
c445ea15 1741 const STRLEN max = (UV)count * len;
19a94d75 1742 if (len > MEM_SIZE_MAX / count)
0157ef98 1743 Perl_croak(aTHX_ "%s", oom_string_extend);
2b573ace 1744 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
8569b9dc 1745 SvGROW(TARG, max + 1);
a0d0e21e 1746 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1747 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1748 }
a0d0e21e 1749 *SvEND(TARG) = '\0';
a0d0e21e 1750 }
dfcb284a
GS		 1751 if (isutf)
1752 (void)SvPOK_only_UTF8(TARG);
1753 else
1754 (void)SvPOK_only(TARG);
b80b6069
RH		 1755
1756 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1757 /* The parser saw this as a list repeat, and there
1758 are probably several items on the stack. But we're
1759 in scalar context, and there's no pp_list to save us
1760 now. So drop the rest of the items -- robin@kitsite.com
1761 */
1762 dMARK;
1763 SP = MARK;
1764 }
a0d0e21e 1765 PUSHTARG;
79072805 1766 }
a0d0e21e
LW		 1767 RETURN;
1768}
79072805 1769
a0d0e21e
LW		 1770PP(pp_subtract)
1771{
800401ee 1772 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM		 1773 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1774 svr = TOPs;
1775 svl = TOPm1s;
800401ee 1776 useleft = USE_LEFT(svl);
28e5dec8 1777#ifdef PERL_PRESERVE_IVUV
7dca457a
NC		 1778 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1779 "bad things" happen if you rely on signed integers wrapping. */
01f91bf2 1780 if (SvIV_please_nomg(svr)) {
28e5dec8
JH		 1781 /* Unless the left argument is integer in range we are going to have to
1782 use NV maths. Hence only attempt to coerce the right argument if
1783 we know the left is integer. */
eb578fdb 1784 UV auv = 0;
9c5ffd7c 1785 bool auvok = FALSE;
7dca457a
NC		 1786 bool a_valid = 0;
1787
28e5dec8 1788 if (!useleft) {
7dca457a
NC		 1789 auv = 0;
1790 a_valid = auvok = 1;
1791 /* left operand is undef, treat as zero. */
28e5dec8
JH		 1792 } else {
1793 /* Left operand is defined, so is it IV? */
01f91bf2 1794 if (SvIV_please_nomg(svl)) {
800401ee
JH		 1795 if ((auvok = SvUOK(svl)))
1796 auv = SvUVX(svl);
7dca457a 1797 else {
eb578fdb 1798 const IV aiv = SvIVX(svl);
7dca457a
NC		 1799 if (aiv >= 0) {
1800 auv = aiv;
1801 auvok = 1; /* Now acting as a sign flag. */
1802 } else { /* 2s complement assumption for IV_MIN */
1803 auv = (UV)-aiv;
28e5dec8 1804 }
7dca457a
NC		 1805 }
1806 a_valid = 1;
1807 }
1808 }
1809 if (a_valid) {
1810 bool result_good = 0;
1811 UV result;
eb578fdb 1812 UV buv;
800401ee 1813 bool buvok = SvUOK(svr);
9041c2e3 1814
7dca457a 1815 if (buvok)
800401ee 1816 buv = SvUVX(svr);
7dca457a 1817 else {
eb578fdb 1818 const IV biv = SvIVX(svr);
7dca457a
NC		 1819 if (biv >= 0) {
1820 buv = biv;
1821 buvok = 1;
1822 } else
1823 buv = (UV)-biv;
1824 }
1825 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1826 else "IV" now, independent of how it came in.
7dca457a
NC		 1827 if a, b represents positive, A, B negative, a maps to -A etc
1828 a - b => (a - b)
1829 A - b => -(a + b)
1830 a - B => (a + b)
1831 A - B => -(a - b)
1832 all UV maths. negate result if A negative.
1833 subtract if signs same, add if signs differ. */
1834
1835 if (auvok ^ buvok) {
1836 /* Signs differ. */
1837 result = auv + buv;
1838 if (result >= auv)
1839 result_good = 1;
1840 } else {
1841 /* Signs same */
1842 if (auv >= buv) {
1843 result = auv - buv;
1844 /* Must get smaller */
1845 if (result <= auv)
1846 result_good = 1;
1847 } else {
1848 result = buv - auv;
1849 if (result <= buv) {
1850 /* result really should be -(auv-buv). as its negation
1851 of true value, need to swap our result flag */
1852 auvok = !auvok;
1853 result_good = 1;
28e5dec8 1854 }
28e5dec8
JH		 1855 }
1856 }
7dca457a
NC		 1857 if (result_good) {
1858 SP--;
1859 if (auvok)
1860 SETu( result );
1861 else {
1862 /* Negate result */
1863 if (result <= (UV)IV_MIN)
1864 SETi( -(IV)result );
1865 else {
1866 /* result valid, but out of range for IV. */
1867 SETn( -(NV)result );
1868 }
1869 }
1870 RETURN;
1871 } /* Overflow, drop through to NVs. */
28e5dec8
JH		 1872 }
1873 }
1874#endif
a0d0e21e 1875 {
6f1401dc 1876 NV value = SvNV_nomg(svr);
4efa5a16
RD		 1877 (void)POPs;
1878
28e5dec8
JH		 1879 if (!useleft) {
1880 /* left operand is undef, treat as zero - value */
1881 SETn(-value);
1882 RETURN;
1883 }
6f1401dc 1884 SETn( SvNV_nomg(svl) - value );
28e5dec8 1885 RETURN;
79072805 1886 }
a0d0e21e 1887}
79072805 1888
a0d0e21e
LW		 1889PP(pp_left_shift)
1890{
6f1401dc 1891 dVAR; dSP; dATARGET; SV *svl, *svr;
a42d0242 1892 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM		 1893 svr = POPs;
1894 svl = TOPs;
a0d0e21e 1895 {
6f1401dc 1896 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1897 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1898 const IV i = SvIV_nomg(svl);
972b05a9 1899 SETi(i << shift);
d0ba1bd2
JH		 1900 }
1901 else {
6f1401dc 1902 const UV u = SvUV_nomg(svl);
972b05a9 1903 SETu(u << shift);
d0ba1bd2 1904 }
55497cff 1905 RETURN;
79072805 1906 }
a0d0e21e 1907}
79072805 1908
a0d0e21e
LW		 1909PP(pp_right_shift)
1910{
6f1401dc 1911 dVAR; dSP; dATARGET; SV *svl, *svr;
a42d0242 1912 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM		 1913 svr = POPs;
1914 svl = TOPs;
a0d0e21e 1915 {
6f1401dc 1916 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1917 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1918 const IV i = SvIV_nomg(svl);
972b05a9 1919 SETi(i >> shift);
d0ba1bd2
JH		 1920 }
1921 else {
6f1401dc 1922 const UV u = SvUV_nomg(svl);
972b05a9 1923 SETu(u >> shift);
d0ba1bd2 1924 }
a0d0e21e 1925 RETURN;
93a17b20 1926 }
79072805
LW		 1927}
1928
a0d0e21e 1929PP(pp_lt)
79072805 1930{
6f1401dc 1931 dVAR; dSP;
33efebe6
DM		 1932 SV *left, *right;
1933
a42d0242 1934 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM		 1935 right = POPs;
1936 left = TOPs;
1937 SETs(boolSV(
1938 (SvIOK_notUV(left) && SvIOK_notUV(right))
1939 ? (SvIVX(left) < SvIVX(right))
1940 : (do_ncmp(left, right) == -1)
1941 ));
1942 RETURN;
a0d0e21e 1943}
79072805 1944
a0d0e21e
LW		 1945PP(pp_gt)
1946{
6f1401dc 1947 dVAR; dSP;
33efebe6 1948 SV *left, *right;
1b6737cc 1949
33efebe6
DM		 1950 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1951 right = POPs;
1952 left = TOPs;
1953 SETs(boolSV(
1954 (SvIOK_notUV(left) && SvIOK_notUV(right))
1955 ? (SvIVX(left) > SvIVX(right))
1956 : (do_ncmp(left, right) == 1)
1957 ));
1958 RETURN;
a0d0e21e
LW		 1959}
1960
1961PP(pp_le)
1962{
6f1401dc 1963 dVAR; dSP;
33efebe6 1964 SV *left, *right;
1b6737cc 1965
33efebe6
DM		 1966 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1967 right = POPs;
1968 left = TOPs;
1969 SETs(boolSV(
1970 (SvIOK_notUV(left) && SvIOK_notUV(right))
1971 ? (SvIVX(left) <= SvIVX(right))
1972 : (do_ncmp(left, right) <= 0)
1973 ));
1974 RETURN;
a0d0e21e
LW		 1975}
1976
1977PP(pp_ge)
1978{
6f1401dc 1979 dVAR; dSP;
33efebe6
DM		 1980 SV *left, *right;
1981
1982 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1983 right = POPs;
1984 left = TOPs;
1985 SETs(boolSV(
1986 (SvIOK_notUV(left) && SvIOK_notUV(right))
1987 ? (SvIVX(left) >= SvIVX(right))
1988 : ( (do_ncmp(left, right) & 2) == 0)
1989 ));
1990 RETURN;
1991}
1b6737cc 1992
33efebe6
DM		 1993PP(pp_ne)
1994{
1995 dVAR; dSP;
1996 SV *left, *right;
1997
1998 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
1999 right = POPs;
2000 left = TOPs;
2001 SETs(boolSV(
2002 (SvIOK_notUV(left) && SvIOK_notUV(right))
2003 ? (SvIVX(left) != SvIVX(right))
2004 : (do_ncmp(left, right) != 0)
2005 ));
2006 RETURN;
2007}
1b6737cc 2008
33efebe6
DM		 2009/* compare left and right SVs. Returns:
2010 * -1: <
2011 * 0: ==
2012 * 1: >
2013 * 2: left or right was a NaN
2014 */
2015I32
2016Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2017{
2018 dVAR;
1b6737cc 2019
33efebe6
DM		 2020 PERL_ARGS_ASSERT_DO_NCMP;
2021#ifdef PERL_PRESERVE_IVUV
33efebe6 2022 /* Fortunately it seems NaN isn't IOK */
01f91bf2 2023 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
33efebe6
DM		 2024 if (!SvUOK(left)) {
2025 const IV leftiv = SvIVX(left);
2026 if (!SvUOK(right)) {
2027 /* ## IV <=> IV ## */
2028 const IV rightiv = SvIVX(right);
2029 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2030 }
33efebe6
DM		 2031 /* ## IV <=> UV ## */
2032 if (leftiv < 0)
2033 /* As (b) is a UV, it's >=0, so it must be < */
2034 return -1;
2035 {
2036 const UV rightuv = SvUVX(right);
2037 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2038 }
28e5dec8 2039 }
79072805 2040
33efebe6
DM		 2041 if (SvUOK(right)) {
2042 /* ## UV <=> UV ## */
2043 const UV leftuv = SvUVX(left);
2044 const UV rightuv = SvUVX(right);
2045 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2046 }
33efebe6
DM		 2047 /* ## UV <=> IV ## */
2048 {
2049 const IV rightiv = SvIVX(right);
2050 if (rightiv < 0)
2051 /* As (a) is a UV, it's >=0, so it cannot be < */
2052 return 1;
2053 {
2054 const UV leftuv = SvUVX(left);
2055 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2056 }
28e5dec8 2057 }
118e2215 2058 assert(0); /* NOTREACHED */
28e5dec8
JH		 2059 }
2060#endif
a0d0e21e 2061 {
33efebe6
DM		 2062 NV const rnv = SvNV_nomg(right);
2063 NV const lnv = SvNV_nomg(left);
2064
cab190d4 2065#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM		 2066 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2067 return 2;
2068 }
2069 return (lnv > rnv) - (lnv < rnv);
cab190d4 2070#else
33efebe6
DM		 2071 if (lnv < rnv)
2072 return -1;
2073 if (lnv > rnv)
2074 return 1;
659c4b96 2075 if (lnv == rnv)
33efebe6
DM		 2076 return 0;
2077 return 2;
cab190d4 2078#endif
a0d0e21e 2079 }
79072805
LW		 2080}
2081
33efebe6 2082
a0d0e21e 2083PP(pp_ncmp)
79072805 2084{
33efebe6
DM		 2085 dVAR; dSP;
2086 SV *left, *right;
2087 I32 value;
a42d0242 2088 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM		 2089 right = POPs;
2090 left = TOPs;
2091 value = do_ncmp(left, right);
2092 if (value == 2) {
3280af22 2093 SETs(&PL_sv_undef);
79072805 2094 }
33efebe6
DM		 2095 else {
2096 dTARGET;
2097 SETi(value);
2098 }
2099 RETURN;
a0d0e21e 2100}
79072805 2101
afd9910b 2102PP(pp_sle)
a0d0e21e 2103{
97aff369 2104 dVAR; dSP;
79072805 2105
afd9910b
NC		 2106 int amg_type = sle_amg;
2107 int multiplier = 1;
2108 int rhs = 1;
79072805 2109
afd9910b
NC		 2110 switch (PL_op->op_type) {
2111 case OP_SLT:
2112 amg_type = slt_amg;
2113 /* cmp < 0 */
2114 rhs = 0;
2115 break;
2116 case OP_SGT:
2117 amg_type = sgt_amg;
2118 /* cmp > 0 */
2119 multiplier = -1;
2120 rhs = 0;
2121 break;
2122 case OP_SGE:
2123 amg_type = sge_amg;
2124 /* cmp >= 0 */
2125 multiplier = -1;
2126 break;
79072805 2127 }
79072805 2128
6f1401dc 2129 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW		 2130 {
2131 dPOPTOPssrl;
1b6737cc 2132 const int cmp = (IN_LOCALE_RUNTIME
078504b2
FC		 2133 ? sv_cmp_locale_flags(left, right, 0)
2134 : sv_cmp_flags(left, right, 0));
afd9910b 2135 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW		 2136 RETURN;
2137 }
2138}
79072805 2139
36477c24 2140PP(pp_seq)
2141{
6f1401dc
DM		 2142 dVAR; dSP;
2143 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24 2144 {
2145 dPOPTOPssrl;
078504b2 2146 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW		 2147 RETURN;
2148 }
2149}
79072805 2150
a0d0e21e 2151PP(pp_sne)
79072805 2152{
6f1401dc
DM		 2153 dVAR; dSP;
2154 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW		 2155 {
2156 dPOPTOPssrl;
078504b2 2157 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2158 RETURN;
463ee0b2 2159 }
79072805
LW		 2160}
2161
a0d0e21e 2162PP(pp_scmp)
79072805 2163{
6f1401dc
DM		 2164 dVAR; dSP; dTARGET;
2165 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW		 2166 {
2167 dPOPTOPssrl;
1b6737cc 2168 const int cmp = (IN_LOCALE_RUNTIME
078504b2
FC		 2169 ? sv_cmp_locale_flags(left, right, 0)
2170 : sv_cmp_flags(left, right, 0));
bbce6d69 2171 SETi( cmp );
a0d0e21e
LW		 2172 RETURN;
2173 }
2174}
79072805 2175
55497cff 2176PP(pp_bit_and)
2177{
6f1401dc
DM		 2178 dVAR; dSP; dATARGET;
2179 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW		 2180 {
2181 dPOPTOPssrl;
4633a7c4 2182 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC		 2183 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2184 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2185 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2186 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2187 SETi(i);
d0ba1bd2
JH		 2188 }
2189 else {
1b6737cc 2190 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2191 SETu(u);
d0ba1bd2 2192 }
5ee80e13 2193 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2194 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW		 2195 }
2196 else {
533c011a 2197 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 2198 SETTARG;
2199 }
2200 RETURN;
2201 }
2202}
79072805 2203
a0d0e21e
LW		 2204PP(pp_bit_or)
2205{
3658c1f1
NC		 2206 dVAR; dSP; dATARGET;
2207 const int op_type = PL_op->op_type;
2208
6f1401dc 2209 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW		 2210 {
2211 dPOPTOPssrl;
4633a7c4 2212 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC		 2213 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2214 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2215 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC		 2216 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2217 const IV r = SvIV_nomg(right);
2218 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2219 SETi(result);
d0ba1bd2
JH		 2220 }
2221 else {
3658c1f1
NC		 2222 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2223 const UV r = SvUV_nomg(right);
2224 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2225 SETu(result);
d0ba1bd2 2226 }
5ee80e13 2227 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2228 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW		 2229 }
2230 else {
3658c1f1 2231 do_vop(op_type, TARG, left, right);
a0d0e21e
LW		 2232 SETTARG;
2233 }
2234 RETURN;
79072805 2235 }
a0d0e21e 2236}
79072805 2237
1c2b3fd6
FC		 2238PERL_STATIC_INLINE bool
2239S_negate_string(pTHX)
2240{
2241 dTARGET; dSP;
2242 STRLEN len;
2243 const char *s;
2244 SV * const sv = TOPs;
2245 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2246 return FALSE;
2247 s = SvPV_nomg_const(sv, len);
2248 if (isIDFIRST(*s)) {
2249 sv_setpvs(TARG, "-");
2250 sv_catsv(TARG, sv);
2251 }
2252 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2253 sv_setsv_nomg(TARG, sv);
2254 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2255 }
2256 else return FALSE;
2257 SETTARG; PUTBACK;
2258 return TRUE;
2259}
2260
a0d0e21e
LW		 2261PP(pp_negate)
2262{
6f1401dc
DM		 2263 dVAR; dSP; dTARGET;
2264 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2265 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2266 {
6f1401dc 2267 SV * const sv = TOPs;
a5b92898 2268
d96ab1b5 2269 if (SvIOK(sv)) {
7dbe3150 2270 /* It's publicly an integer */
28e5dec8 2271 oops_its_an_int:
9b0e499b
GS		 2272 if (SvIsUV(sv)) {
2273 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2274 /* 2s complement assumption. */
d14578b8
KW		 2275 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2276 IV_MIN */
9b0e499b
GS		 2277 RETURN;
2278 }
2279 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2280 SETi(-SvIVX(sv));
9b0e499b
GS		 2281 RETURN;
2282 }
2283 }
2284 else if (SvIVX(sv) != IV_MIN) {
2285 SETi(-SvIVX(sv));
2286 RETURN;
2287 }
28e5dec8
JH		 2288#ifdef PERL_PRESERVE_IVUV
2289 else {
2290 SETu((UV)IV_MIN);
2291 RETURN;
2292 }
2293#endif
9b0e499b 2294 }
8a5decd8 2295 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2296 SETn(-SvNV_nomg(sv));
1c2b3fd6 2297 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2298 goto oops_its_an_int;
4633a7c4 2299 else
6f1401dc 2300 SETn(-SvNV_nomg(sv));
79072805 2301 }
a0d0e21e 2302 RETURN;
79072805
LW		 2303}
2304
a0d0e21e 2305PP(pp_not)
79072805 2306{
6f1401dc
DM		 2307 dVAR; dSP;
2308 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2309 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2310 return NORMAL;
79072805
LW		 2311}
2312
a0d0e21e 2313PP(pp_complement)
79072805 2314{
6f1401dc 2315 dVAR; dSP; dTARGET;
a42d0242 2316 tryAMAGICun_MG(compl_amg, AMGf_numeric);
a0d0e21e
LW		 2317 {
2318 dTOPss;
4633a7c4 2319 if (SvNIOKp(sv)) {
d0ba1bd2 2320 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2321 const IV i = ~SvIV_nomg(sv);
972b05a9 2322 SETi(i);
d0ba1bd2
JH		 2323 }
2324 else {
1b6737cc 2325 const UV u = ~SvUV_nomg(sv);
972b05a9 2326 SETu(u);
d0ba1bd2 2327 }
a0d0e21e
LW		 2328 }
2329 else {
eb578fdb
KW		 2330 U8 *tmps;
2331 I32 anum;
a0d0e21e
LW		 2332 STRLEN len;
2333
85b0ee6e
FC		 2334 sv_copypv_nomg(TARG, sv);
2335 tmps = (U8*)SvPV_nomg(TARG, len);
a0d0e21e 2336 anum = len;
1d68d6cd 2337 if (SvUTF8(TARG)) {
a1ca4561 2338 /* Calculate exact length, let's not estimate. */
1d68d6cd 2339 STRLEN targlen = 0;
ba210ebe 2340 STRLEN l;
a1ca4561
YST		 2341 UV nchar = 0;
2342 UV nwide = 0;
01f6e806 2343 U8 * const send = tmps + len;
74d49cd0
TS		 2344 U8 * const origtmps = tmps;
2345 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2346
1d68d6cd 2347 while (tmps < send) {
74d49cd0
TS		 2348 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2349 tmps += l;
5bbb0b5a 2350 targlen += UNISKIP(~c);
a1ca4561
YST		 2351 nchar++;
2352 if (c > 0xff)
2353 nwide++;
1d68d6cd
SC		 2354 }
2355
2356 /* Now rewind strings and write them. */
74d49cd0 2357 tmps = origtmps;
a1ca4561
YST		 2358
2359 if (nwide) {
01f6e806
AL		 2360 U8 *result;
2361 U8 *p;
2362
74d49cd0 2363 Newx(result, targlen + 1, U8);
01f6e806 2364 p = result;
a1ca4561 2365 while (tmps < send) {
74d49cd0
TS		 2366 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2367 tmps += l;
01f6e806 2368 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2369 }
01f6e806 2370 *p = '\0';
c1c21316
NC		 2371 sv_usepvn_flags(TARG, (char*)result, targlen,
2372 SV_HAS_TRAILING_NUL);
a1ca4561
YST		 2373 SvUTF8_on(TARG);
2374 }
2375 else {
01f6e806
AL		 2376 U8 *result;
2377 U8 *p;
2378
74d49cd0 2379 Newx(result, nchar + 1, U8);
01f6e806 2380 p = result;
a1ca4561 2381 while (tmps < send) {
74d49cd0
TS		 2382 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2383 tmps += l;
01f6e806 2384 *p++ = ~c;
a1ca4561 2385 }
01f6e806 2386 *p = '\0';
c1c21316 2387 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2388 SvUTF8_off(TARG);
1d68d6cd 2389 }
ec93b65f 2390 SETTARG;
1d68d6cd
SC		 2391 RETURN;
2392 }
a0d0e21e 2393#ifdef LIBERAL
51723571 2394 {
eb578fdb 2395 long *tmpl;
51723571
JH		 2396 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2397 *tmps = ~*tmps;
2398 tmpl = (long*)tmps;
bb7a0f54 2399 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH		 2400 *tmpl = ~*tmpl;
2401 tmps = (U8*)tmpl;
2402 }
a0d0e21e
LW		 2403#endif
2404 for ( ; anum > 0; anum--, tmps++)
2405 *tmps = ~*tmps;
ec93b65f 2406 SETTARG;
a0d0e21e
LW		 2407 }
2408 RETURN;
2409 }
79072805
LW		 2410}
2411
a0d0e21e
LW		 2412/* integer versions of some of the above */
2413
a0d0e21e 2414PP(pp_i_multiply)
79072805 2415{
6f1401dc
DM		 2416 dVAR; dSP; dATARGET;
2417 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2418 {
6f1401dc 2419 dPOPTOPiirl_nomg;
a0d0e21e
LW		 2420 SETi( left * right );
2421 RETURN;
2422 }
79072805
LW		 2423}
2424
a0d0e21e 2425PP(pp_i_divide)
79072805 2426{
85935d8e 2427 IV num;
6f1401dc
DM		 2428 dVAR; dSP; dATARGET;
2429 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2430 {
6f1401dc 2431 dPOPTOPssrl;
85935d8e 2432 IV value = SvIV_nomg(right);
a0d0e21e 2433 if (value == 0)
ece1bcef 2434 DIE(aTHX_ "Illegal division by zero");
85935d8e 2435 num = SvIV_nomg(left);
a0cec769
YST		 2436
2437 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2438 if (value == -1)
2439 value = - num;
2440 else
2441 value = num / value;
6f1401dc 2442 SETi(value);
a0d0e21e
LW		 2443 RETURN;
2444 }
79072805
LW		 2445}
2446
a5bd31f4 2447#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH		 2448STATIC
2449PP(pp_i_modulo_0)
befad5d1
NC		 2450#else
2451PP(pp_i_modulo)
2452#endif
224ec323
JH		 2453{
2454 /* This is the vanilla old i_modulo. */
6f1401dc
DM		 2455 dVAR; dSP; dATARGET;
2456 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2457 {
6f1401dc 2458 dPOPTOPiirl_nomg;
224ec323
JH		 2459 if (!right)
2460 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST		 2461 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2462 if (right == -1)
2463 SETi( 0 );
2464 else
2465 SETi( left % right );
224ec323
JH		 2466 RETURN;
2467 }
2468}
2469
a5bd31f4 2470#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH		 2471STATIC
2472PP(pp_i_modulo_1)
befad5d1 2473
224ec323 2474{
224ec323 2475 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2476 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2477 * See below for pp_i_modulo. */
6f1401dc
DM		 2478 dVAR; dSP; dATARGET;
2479 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2480 {
6f1401dc 2481 dPOPTOPiirl_nomg;
224ec323
JH		 2482 if (!right)
2483 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST		 2484 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2485 if (right == -1)
2486 SETi( 0 );
2487 else
2488 SETi( left % PERL_ABS(right) );
224ec323
JH		 2489 RETURN;
2490 }
224ec323
JH		 2491}
2492
a0d0e21e 2493PP(pp_i_modulo)
79072805 2494{
6f1401dc
DM		 2495 dVAR; dSP; dATARGET;
2496 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2497 {
6f1401dc 2498 dPOPTOPiirl_nomg;
224ec323
JH		 2499 if (!right)
2500 DIE(aTHX_ "Illegal modulus zero");
2501 /* The assumption is to use hereafter the old vanilla version... */
2502 PL_op->op_ppaddr =
2503 PL_ppaddr[OP_I_MODULO] =
1c127fab 2504 Perl_pp_i_modulo_0;
224ec323
JH		 2505 /* .. but if we have glibc, we might have a buggy _moddi3
2506 * (at least glicb 2.2.5 is known to have this bug), in other
2507 * words our integer modulus with negative quad as the second
2508 * argument might be broken. Test for this and re-patch the
2509 * opcode dispatch table if that is the case, remembering to
2510 * also apply the workaround so that this first round works
2511 * right, too. See [perl #9402] for more information. */
224ec323
JH		 2512 {
2513 IV l = 3;
2514 IV r = -10;
2515 /* Cannot do this check with inlined IV constants since
2516 * that seems to work correctly even with the buggy glibc. */
2517 if (l % r == -3) {
2518 /* Yikes, we have the bug.
2519 * Patch in the workaround version. */
2520 PL_op->op_ppaddr =
2521 PL_ppaddr[OP_I_MODULO] =
2522 &Perl_pp_i_modulo_1;
2523 /* Make certain we work right this time, too. */
32fdb065 2524 right = PERL_ABS(right);
224ec323
JH		 2525 }
2526 }
a0cec769
YST		 2527 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2528 if (right == -1)
2529 SETi( 0 );
2530 else
2531 SETi( left % right );
224ec323
JH		 2532 RETURN;
2533 }
79072805 2534}
befad5d1 2535#endif
79072805 2536
a0d0e21e 2537PP(pp_i_add)
79072805 2538{
6f1401dc
DM		 2539 dVAR; dSP; dATARGET;
2540 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2541 {
6f1401dc 2542 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW		 2543 SETi( left + right );
2544 RETURN;
79072805 2545 }
79072805
LW		 2546}
2547
a0d0e21e 2548PP(pp_i_subtract)
79072805 2549{
6f1401dc
DM		 2550 dVAR; dSP; dATARGET;
2551 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2552 {
6f1401dc 2553 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW		 2554 SETi( left - right );
2555 RETURN;
79072805 2556 }
79072805
LW		 2557}
2558
a0d0e21e 2559PP(pp_i_lt)
79072805 2560{
6f1401dc
DM		 2561 dVAR; dSP;
2562 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2563 {
96b6b87f 2564 dPOPTOPiirl_nomg;
54310121 2565 SETs(boolSV(left < right));
a0d0e21e
LW		 2566 RETURN;
2567 }
79072805
LW		 2568}
2569
a0d0e21e 2570PP(pp_i_gt)
79072805 2571{
6f1401dc
DM		 2572 dVAR; dSP;
2573 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2574 {
96b6b87f 2575 dPOPTOPiirl_nomg;
54310121 2576 SETs(boolSV(left > right));
a0d0e21e
LW		 2577 RETURN;
2578 }
79072805
LW		 2579}
2580
a0d0e21e 2581PP(pp_i_le)
79072805 2582{
6f1401dc
DM		 2583 dVAR; dSP;
2584 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2585 {
96b6b87f 2586 dPOPTOPiirl_nomg;
54310121 2587 SETs(boolSV(left <= right));
a0d0e21e 2588 RETURN;
85e6fe83 2589 }
79072805
LW		 2590}
2591
a0d0e21e 2592PP(pp_i_ge)
79072805 2593{
6f1401dc
DM		 2594 dVAR; dSP;
2595 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2596 {
96b6b87f 2597 dPOPTOPiirl_nomg;
54310121 2598 SETs(boolSV(left >= right));
a0d0e21e
LW		 2599 RETURN;
2600 }
79072805
LW		 2601}
2602
a0d0e21e 2603PP(pp_i_eq)
79072805 2604{
6f1401dc
DM		 2605 dVAR; dSP;
2606 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2607 {
96b6b87f 2608 dPOPTOPiirl_nomg;
54310121 2609 SETs(boolSV(left == right));
a0d0e21e
LW		 2610 RETURN;
2611 }
79072805
LW		 2612}
2613
a0d0e21e 2614PP(pp_i_ne)
79072805 2615{
6f1401dc
DM		 2616 dVAR; dSP;
2617 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2618 {
96b6b87f 2619 dPOPTOPiirl_nomg;
54310121 2620 SETs(boolSV(left != right));
a0d0e21e
LW		 2621 RETURN;
2622 }
79072805
LW		 2623}
2624
a0d0e21e 2625PP(pp_i_ncmp)
79072805 2626{
6f1401dc
DM		 2627 dVAR; dSP; dTARGET;
2628 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2629 {
96b6b87f 2630 dPOPTOPiirl_nomg;
a0d0e21e 2631 I32 value;
79072805 2632
a0d0e21e 2633 if (left > right)
79072805 2634 value = 1;
a0d0e21e 2635 else if (left < right)
79072805 2636 value = -1;
a0d0e21e 2637 else
79072805 2638 value = 0;
a0d0e21e
LW		 2639 SETi(value);
2640 RETURN;
79072805 2641 }
85e6fe83
LW		 2642}
2643
2644PP(pp_i_negate)
2645{
6f1401dc
DM		 2646 dVAR; dSP; dTARGET;
2647 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2648 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM		 2649 {
2650 SV * const sv = TOPs;
2651 IV const i = SvIV_nomg(sv);
2652 SETi(-i);
2653 RETURN;
2654 }
85e6fe83
LW		 2655}
2656
79072805
LW		 2657/* High falutin' math. */
2658
2659PP(pp_atan2)
2660{
6f1401dc
DM		 2661 dVAR; dSP; dTARGET;
2662 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2663 {
096c060c 2664 dPOPTOPnnrl_nomg;
a1021d57 2665 SETn(Perl_atan2(left, right));
a0d0e21e
LW		 2666 RETURN;
2667 }
79072805
LW		 2668}
2669
2670PP(pp_sin)
2671{
71302fe3
NC		 2672 dVAR; dSP; dTARGET;
2673 int amg_type = sin_amg;
2674 const char *neg_report = NULL;
bc81784a 2675 NV (*func)(NV) = Perl_sin;
71302fe3
NC		 2676 const int op_type = PL_op->op_type;
2677
2678 switch (op_type) {
2679 case OP_COS:
2680 amg_type = cos_amg;
bc81784a 2681 func = Perl_cos;
71302fe3
NC		 2682 break;
2683 case OP_EXP:
2684 amg_type = exp_amg;
bc81784a 2685 func = Perl_exp;
71302fe3
NC		 2686 break;
2687 case OP_LOG:
2688 amg_type = log_amg;
bc81784a 2689 func = Perl_log;
71302fe3
NC		 2690 neg_report = "log";
2691 break;
2692 case OP_SQRT:
2693 amg_type = sqrt_amg;
bc81784a 2694 func = Perl_sqrt;
71302fe3
NC		 2695 neg_report = "sqrt";
2696 break;
a0d0e21e 2697 }
79072805 2698
6f1401dc
DM		 2699
2700 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2701 {
6f1401dc
DM		 2702 SV * const arg = POPs;
2703 const NV value = SvNV_nomg(arg);
71302fe3
NC		 2704 if (neg_report) {
2705 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2706 SET_NUMERIC_STANDARD();
dcbac5bb 2707 /* diag_listed_as: Can't take log of %g */
71302fe3
NC		 2708 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2709 }
2710 }
2711 XPUSHn(func(value));
a0d0e21e
LW		 2712 RETURN;
2713 }
79072805
LW		 2714}
2715
56cb0a1c
AD		 2716/* Support Configure command-line overrides for rand() functions.
2717 After 5.005, perhaps we should replace this by Configure support
2718 for drand48(), random(), or rand(). For 5.005, though, maintain
2719 compatibility by calling rand() but allow the user to override it.
2720 See INSTALL for details. --Andy Dougherty 15 July 1998
2721*/
85ab1d1d
JH		 2722/* Now it's after 5.005, and Configure supports drand48() and random(),
2723 in addition to rand(). So the overrides should not be needed any more.
2724 --Jarkko Hietaniemi 27 September 1998
2725 */
2726
79072805
LW		 2727PP(pp_rand)
2728{
fdf4dddd 2729 dVAR;
80252599 2730 if (!PL_srand_called) {
85ab1d1d 2731 (void)seedDrand01((Rand_seed_t)seed());
80252599 2732 PL_srand_called = TRUE;
93dc8474 2733 }
fdf4dddd
DD		 2734 {
2735 dSP;
2736 NV value;
2737 EXTEND(SP, 1);
2738
2739 if (MAXARG < 1)
2740 value = 1.0;
2741 else {
2742 SV * const sv = POPs;
2743 if(!sv)
2744 value = 1.0;
2745 else
2746 value = SvNV(sv);
2747 }
2748 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
659c4b96 2749 if (value == 0.0)
fdf4dddd
DD		 2750 value = 1.0;
2751 {
2752 dTARGET;
2753 PUSHs(TARG);
2754 PUTBACK;
2755 value *= Drand01();
2756 sv_setnv_mg(TARG, value);
2757 }
2758 }
2759 return NORMAL;
79072805
LW		 2760}
2761
2762PP(pp_srand)
2763{
83832992 2764 dVAR; dSP; dTARGET;
f914a682
JL		 2765 UV anum;
2766
0a5f3363 2767 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL		 2768 SV *top;
2769 char *pv;
2770 STRLEN len;
2771 int flags;
2772
2773 top = POPs;
2774 pv = SvPV(top, len);
2775 flags = grok_number(pv, len, &anum);
2776
2777 if (!(flags & IS_NUMBER_IN_UV)) {
2778 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2779 "Integer overflow in srand");
2780 anum = UV_MAX;
2781 }
2782 }
2783 else {
2784 anum = seed();
2785 }
2786
85ab1d1d 2787 (void)seedDrand01((Rand_seed_t)anum);
80252599 2788 PL_srand_called = TRUE;
da1010ec
NC		 2789 if (anum)
2790 XPUSHu(anum);
2791 else {
2792 /* Historically srand always returned true. We can avoid breaking
2793 that like this: */
2794 sv_setpvs(TARG, "0 but true");
2795 XPUSHTARG;
2796 }
83832992 2797 RETURN;
79072805
LW		 2798}
2799
79072805
LW		 2800PP(pp_int)
2801{
6f1401dc
DM		 2802 dVAR; dSP; dTARGET;
2803 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2804 {
6f1401dc
DM		 2805 SV * const sv = TOPs;
2806 const IV iv = SvIV_nomg(sv);
28e5dec8
JH		 2807 /* XXX it's arguable that compiler casting to IV might be subtly
2808 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2809 else preferring IV has introduced a subtle behaviour change bug. OTOH
2810 relying on floating point to be accurate is a bug. */
2811
c781a409 2812 if (!SvOK(sv)) {
922c4365 2813 SETu(0);
c781a409
RD		 2814 }
2815 else if (SvIOK(sv)) {
2816 if (SvIsUV(sv))
6f1401dc 2817 SETu(SvUV_nomg(sv));
c781a409 2818 else
28e5dec8 2819 SETi(iv);
c781a409 2820 }
c781a409 2821 else {
6f1401dc 2822 const NV value = SvNV_nomg(sv);
1048ea30 2823 if (value >= 0.0) {
28e5dec8
JH		 2824 if (value < (NV)UV_MAX + 0.5) {
2825 SETu(U_V(value));
2826 } else {
059a1014 2827 SETn(Perl_floor(value));
28e5dec8 2828 }
1048ea30 2829 }
28e5dec8
JH		 2830 else {
2831 if (value > (NV)IV_MIN - 0.5) {
2832 SETi(I_V(value));
2833 } else {
1bbae031 2834 SETn(Perl_ceil(value));
28e5dec8
JH		 2835 }
2836 }
774d564b 2837 }
79072805 2838 }
79072805
LW		 2839 RETURN;
2840}
2841
463ee0b2
LW		 2842PP(pp_abs)
2843{
6f1401dc
DM		 2844 dVAR; dSP; dTARGET;
2845 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 2846 {
6f1401dc 2847 SV * const sv = TOPs;
28e5dec8 2848 /* This will cache the NV value if string isn't actually integer */
6f1401dc 2849 const IV iv = SvIV_nomg(sv);
a227d84d 2850
800401ee 2851 if (!SvOK(sv)) {
922c4365 2852 SETu(0);
800401ee
JH		 2853 }
2854 else if (SvIOK(sv)) {
28e5dec8 2855 /* IVX is precise */
800401ee 2856 if (SvIsUV(sv)) {
6f1401dc 2857 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH		 2858 } else {
2859 if (iv >= 0) {
2860 SETi(iv);
2861 } else {
2862 if (iv != IV_MIN) {
2863 SETi(-iv);
2864 } else {
2865 /* 2s complement assumption. Also, not really needed as
2866 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2867 SETu(IV_MIN);
2868 }
a227d84d 2869 }
28e5dec8
JH		 2870 }
2871 } else{
6f1401dc 2872 const NV value = SvNV_nomg(sv);
774d564b 2873 if (value < 0.0)
1b6737cc 2874 SETn(-value);
a4474c9e
DD		 2875 else
2876 SETn(value);
774d564b 2877 }
a0d0e21e 2878 }
774d564b 2879 RETURN;
463ee0b2
LW		 2880}
2881
79072805
LW		 2882PP(pp_oct)
2883{
97aff369 2884 dVAR; dSP; dTARGET;
5c144d81 2885 const char *tmps;
53305cf1 2886 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2887 STRLEN len;
53305cf1
NC		 2888 NV result_nv;
2889 UV result_uv;
1b6737cc 2890 SV* const sv = POPs;
79072805 2891
349d4f2f 2892 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS		 2893 if (DO_UTF8(sv)) {
2894 /* If Unicode, try to downgrade
2895 * If not possible, croak. */
1b6737cc 2896 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS		 2897
2898 SvUTF8_on(tsv);
2899 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2900 tmps = SvPV_const(tsv, len);
2bc69dc4 2901 }
daa2adfd
NC		 2902 if (PL_op->op_type == OP_HEX)
2903 goto hex;
2904
6f894ead 2905 while (*tmps && len && isSPACE(*tmps))
53305cf1 2906 tmps++, len--;
9e24b6e2 2907 if (*tmps == '0')
53305cf1 2908 tmps++, len--;
a674e8db 2909 if (*tmps == 'x' || *tmps == 'X') {
daa2adfd 2910 hex:
53305cf1 2911 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 2912 }
a674e8db 2913 else if (*tmps == 'b' || *tmps == 'B')
53305cf1 2914 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2915 else
53305cf1
NC		 2916 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2917
2918 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2919 XPUSHn(result_nv);
2920 }
2921 else {
2922 XPUSHu(result_uv);
2923 }
79072805
LW		 2924 RETURN;
2925}
2926
2927/* String stuff. */
2928
2929PP(pp_length)
2930{
97aff369 2931 dVAR; dSP; dTARGET;
0bd48802 2932 SV * const sv = TOPs;
a0ed51b3 2933
0f43fd57
FC		 2934 SvGETMAGIC(sv);
2935 if (SvOK(sv)) {
193059ca 2936 if (!IN_BYTES)
0f43fd57 2937 SETi(sv_len_utf8_nomg(sv));
9f621bb0 2938 else
0f43fd57
FC		 2939 {
2940 STRLEN len;
2941 (void)SvPV_nomg_const(sv,len);
2942 SETi(len);
2943 }
656266fc 2944 } else {
9407f9c1
DL		 2945 if (!SvPADTMP(TARG)) {
2946 sv_setsv_nomg(TARG, &PL_sv_undef);
2947 SETTARG;
2948 }
2949 SETs(&PL_sv_undef);
92331800 2950 }
79072805
LW		 2951 RETURN;
2952}
2953
83f78d1a
FC		 2954/* Returns false if substring is completely outside original string.
2955 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2956 always be true for an explicit 0.
2957*/
2958bool
2959Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2960 bool pos1_is_uv, IV len_iv,
2961 bool len_is_uv, STRLEN *posp,
2962 STRLEN *lenp)
2963{
2964 IV pos2_iv;
2965 int pos2_is_uv;
2966
2967 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2968
2969 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2970 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2971 pos1_iv += curlen;
2972 }
2973 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2974 return FALSE;
2975
2976 if (len_iv || len_is_uv) {
2977 if (!len_is_uv && len_iv < 0) {
2978 pos2_iv = curlen + len_iv;
2979 if (curlen)
2980 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2981 else
2982 pos2_is_uv = 0;
2983 } else { /* len_iv >= 0 */
2984 if (!pos1_is_uv && pos1_iv < 0) {
2985 pos2_iv = pos1_iv + len_iv;
2986 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2987 } else {
2988 if ((UV)len_iv > curlen-(UV)pos1_iv)
2989 pos2_iv = curlen;
2990 else
2991 pos2_iv = pos1_iv+len_iv;
2992 pos2_is_uv = 1;
2993 }
2994 }
2995 }
2996 else {
2997 pos2_iv = curlen;
2998 pos2_is_uv = 1;
2999 }
3000
3001 if (!pos2_is_uv && pos2_iv < 0) {
3002 if (!pos1_is_uv && pos1_iv < 0)
3003 return FALSE;
3004 pos2_iv = 0;
3005 }
3006 else if (!pos1_is_uv && pos1_iv < 0)
3007 pos1_iv = 0;
3008
3009 if ((UV)pos2_iv < (UV)pos1_iv)
3010 pos2_iv = pos1_iv;
3011 if ((UV)pos2_iv > curlen)
3012 pos2_iv = curlen;
3013
3014 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3015 *posp = (STRLEN)( (UV)pos1_iv );
3016 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3017
3018 return TRUE;
3019}
3020
79072805
LW		 3021PP(pp_substr)
3022{
97aff369 3023 dVAR; dSP; dTARGET;
79072805 3024 SV *sv;
463ee0b2 3025 STRLEN curlen;
9402d6ed 3026 STRLEN utf8_curlen;
777f7c56
EB		 3027 SV * pos_sv;
3028 IV pos1_iv;
3029 int pos1_is_uv;
777f7c56
EB		 3030 SV * len_sv;
3031 IV len_iv = 0;
83f78d1a 3032 int len_is_uv = 0;
24fcb59f 3033 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3034 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3035 const char *tmps;
9402d6ed 3036 SV *repl_sv = NULL;
cbbf8932 3037 const char *repl = NULL;
7b8d334a 3038 STRLEN repl_len;
7bc95ae1 3039 int num_args = PL_op->op_private & 7;
13e30c65 3040 bool repl_need_utf8_upgrade = FALSE;
79072805 3041
78f9721b
SM		 3042 if (num_args > 2) {
3043 if (num_args > 3) {
24fcb59f 3044 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC		 3045 }
3046 if ((len_sv = POPs)) {
3047 len_iv = SvIV(len_sv);
83f78d1a 3048 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3049 }
7bc95ae1 3050 else num_args--;
5d82c453 3051 }
777f7c56
EB		 3052 pos_sv = POPs;
3053 pos1_iv = SvIV(pos_sv);
3054 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3055 sv = POPs;
24fcb59f
FC		 3056 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3057 assert(!repl_sv);
3058 repl_sv = POPs;
3059 }
849ca7ee 3060 PUTBACK;
6582db62 3061 if (lvalue && !repl_sv) {
83f78d1a
FC		 3062 SV * ret;
3063 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3064 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3065 LvTYPE(ret) = 'x';
3066 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3067 LvTARGOFF(ret) =
3068 pos1_is_uv || pos1_iv >= 0
3069 ? (STRLEN)(UV)pos1_iv
3070 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3071 LvTARGLEN(ret) =
3072 len_is_uv || len_iv > 0
3073 ? (STRLEN)(UV)len_iv
3074 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3075
3076 SPAGAIN;
3077 PUSHs(ret); /* avoid SvSETMAGIC here */
3078 RETURN;
a74fb2cd 3079 }
6582db62
FC		 3080 if (repl_sv) {
3081 repl = SvPV_const(repl_sv, repl_len);
3082 SvGETMAGIC(sv);
3083 if (SvROK(sv))
3084 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3085 "Attempt to use reference as lvalue in substr"
3086 );
3087 tmps = SvPV_force_nomg(sv, curlen);
3088 if (DO_UTF8(repl_sv) && repl_len) {
3089 if (!DO_UTF8(sv)) {
01680ee9 3090 sv_utf8_upgrade_nomg(sv);
6582db62
FC		 3091 curlen = SvCUR(sv);
3092 }
3093 }
3094 else if (DO_UTF8(sv))
3095 repl_need_utf8_upgrade = TRUE;
3096 }
3097 else tmps = SvPV_const(sv, curlen);
7e2040f0 3098 if (DO_UTF8(sv)) {
0d788f38 3099 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH		 3100 if (utf8_curlen == curlen)
3101 utf8_curlen = 0;
a0ed51b3 3102 else
9402d6ed 3103 curlen = utf8_curlen;
a0ed51b3 3104 }
d1c2b58a 3105 else
9402d6ed 3106 utf8_curlen = 0;
a0ed51b3 3107
83f78d1a
FC		 3108 {
3109 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3110
83f78d1a
FC		 3111 if (!translate_substr_offsets(
3112 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3113 )) goto bound_fail;
777f7c56 3114
83f78d1a
FC		 3115 byte_len = len;
3116 byte_pos = utf8_curlen
0d788f38 3117 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3118
2154eca7 3119 tmps += byte_pos;
bbddc9e0
CS		 3120
3121 if (rvalue) {
3122 SvTAINTED_off(TARG); /* decontaminate */
3123 SvUTF8_off(TARG); /* decontaminate */
3124 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3125#ifdef USE_LOCALE_COLLATE
bbddc9e0 3126 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3127#endif
bbddc9e0
CS		 3128 if (utf8_curlen)
3129 SvUTF8_on(TARG);
3130 }
2154eca7 3131
f7928d6c 3132 if (repl) {
13e30c65
JH		 3133 SV* repl_sv_copy = NULL;
3134
3135 if (repl_need_utf8_upgrade) {
3136 repl_sv_copy = newSVsv(repl_sv);
3137 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3138 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3139 }
502d9230
VP		 3140 if (!SvOK(sv))
3141 sv_setpvs(sv, "");
777f7c56 3142 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3143 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3144 }
79072805 3145 }
849ca7ee 3146 SPAGAIN;
bbddc9e0
CS		 3147 if (rvalue) {
3148 SvSETMAGIC(TARG);
3149 PUSHs(TARG);
3150 }
79072805 3151 RETURN;
777f7c56 3152
1c900557 3153bound_fail:
83f78d1a 3154 if (repl)
777f7c56
EB		 3155 Perl_croak(aTHX_ "substr outside of string");
3156 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3157 RETPUSHUNDEF;
79072805
LW		 3158}
3159
3160PP(pp_vec)
3161{
2154eca7 3162 dVAR; dSP;
eb578fdb
KW		 3163 const IV size = POPi;
3164 const IV offset = POPi;
3165 SV * const src = POPs;
1b6737cc 3166 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3167 SV * ret;
a0d0e21e 3168
81e118e0 3169 if (lvalue) { /* it's an lvalue! */
2154eca7
EB		 3170 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3171 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3172 LvTYPE(ret) = 'v';
3173 LvTARG(ret) = SvREFCNT_inc_simple(src);
3174 LvTARGOFF(ret) = offset;
3175 LvTARGLEN(ret) = size;
3176 }
3177 else {
3178 dTARGET;
3179 SvTAINTED_off(TARG); /* decontaminate */
3180 ret = TARG;
79072805
LW		 3181 }
3182
2154eca7
EB		 3183 sv_setuv(ret, do_vecget(src, offset, size));
3184 PUSHs(ret);
79072805
LW		 3185 RETURN;
3186}
3187
3188PP(pp_index)
3189{
97aff369 3190 dVAR; dSP; dTARGET;
79072805
LW		 3191 SV *big;
3192 SV *little;
c445ea15 3193 SV *temp = NULL;
ad66a58c 3194 STRLEN biglen;
2723d216 3195 STRLEN llen = 0;
79072805
LW		 3196 I32 offset;
3197 I32 retval;
73ee8be2
NC		 3198 const char *big_p;
3199 const char *little_p;
2f040f7f
NC		 3200 bool big_utf8;
3201 bool little_utf8;
2723d216 3202 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3203 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3204
e1dccc0d
Z		 3205 if (threeargs)
3206 offset = POPi;
79072805
LW		 3207 little = POPs;
3208 big = POPs;
73ee8be2
NC		 3209 big_p = SvPV_const(big, biglen);
3210 little_p = SvPV_const(little, llen);
3211
e609e586
NC		 3212 big_utf8 = DO_UTF8(big);
3213 little_utf8 = DO_UTF8(little);
3214 if (big_utf8 ^ little_utf8) {
3215 /* One needs to be upgraded. */
2f040f7f
NC		 3216 if (little_utf8 && !PL_encoding) {
3217 /* Well, maybe instead we might be able to downgrade the small
3218 string? */
1eced8f8 3219 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC		 3220 &little_utf8);
3221 if (little_utf8) {
3222 /* If the large string is ISO-8859-1, and it's not possible to
3223 convert the small string to ISO-8859-1, then there is no
3224 way that it could be found anywhere by index. */
3225 retval = -1;
3226 goto fail;
3227 }
e609e586 3228
2f040f7f
NC		 3229 /* At this point, pv is a malloc()ed string. So donate it to temp
3230 to ensure it will get free()d */
3231 little = temp = newSV(0);
73ee8be2
NC		 3232 sv_usepvn(temp, pv, llen);
3233 little_p = SvPVX(little);
e609e586 3234 } else {
73ee8be2
NC		 3235 temp = little_utf8
3236 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f
NC		 3237
3238 if (PL_encoding) {
3239 sv_recode_to_utf8(temp, PL_encoding);
3240 } else {
3241 sv_utf8_upgrade(temp);
3242 }
3243 if (little_utf8) {
3244 big = temp;
3245 big_utf8 = TRUE;
73ee8be2 3246 big_p = SvPV_const(big, biglen);
2f040f7f
NC		 3247 } else {
3248 little = temp;
73ee8be2 3249 little_p = SvPV_const(little, llen);
2f040f7f 3250 }
e609e586
NC		 3251 }
3252 }
73ee8be2
NC		 3253 if (SvGAMAGIC(big)) {
3254 /* Life just becomes a lot easier if I use a temporary here.
3255 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3256 will trigger magic and overloading again, as will fbm_instr()
3257 */
59cd0e26
NC		 3258 big = newSVpvn_flags(big_p, biglen,
3259 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3260 big_p = SvPVX(big);
3261 }
e4e44778 3262 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC		 3263 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3264 warn on undef, and we've already triggered a warning with the
3265 SvPV_const some lines above. We can't remove that, as we need to
3266 call some SvPV to trigger overloading early and find out if the
3267 string is UTF-8.
3268 This is all getting to messy. The API isn't quite clean enough,
3269 because data access has side effects.
3270 */
59cd0e26
NC		 3271 little = newSVpvn_flags(little_p, llen,
3272 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC		 3273 little_p = SvPVX(little);
3274 }
e609e586 3275
d3e26383 3276 if (!threeargs)
2723d216 3277 offset = is_index ? 0 : biglen;
a0ed51b3 3278 else {
ad66a58c 3279 if (big_utf8 && offset > 0)
a0ed51b3 3280 sv_pos_u2b(big, &offset, 0);
73ee8be2
NC		 3281 if (!is_index)
3282 offset += llen;
a0ed51b3 3283 }
79072805
LW		 3284 if (offset < 0)
3285 offset = 0;
ad66a58c
NC		 3286 else if (offset > (I32)biglen)
3287 offset = biglen;
73ee8be2
NC		 3288 if (!(little_p = is_index
3289 ? fbm_instr((unsigned char*)big_p + offset,
3290 (unsigned char*)big_p + biglen, little, 0)
3291 : rninstr(big_p, big_p + offset,
3292 little_p, little_p + llen)))
a0ed51b3 3293 retval = -1;
ad66a58c 3294 else {
73ee8be2 3295 retval = little_p - big_p;
ad66a58c
NC		 3296 if (retval > 0 && big_utf8)
3297 sv_pos_b2u(big, &retval);
3298 }
ef8d46e8 3299 SvREFCNT_dec(temp);
2723d216 3300 fail:
e1dccc0d 3301 PUSHi(retval);
79072805
LW		 3302 RETURN;
3303}
3304
3305PP(pp_sprintf)
3306{
97aff369 3307 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3308 SvTAINTED_off(TARG);
79072805 3309 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3310 TAINT_IF(SvTAINTED(TARG));
79072805
LW		 3311 SP = ORIGMARK;
3312 PUSHTARG;
3313 RETURN;
3314}
3315
79072805
LW		 3316PP(pp_ord)
3317{
97aff369 3318 dVAR; dSP; dTARGET;
1eced8f8 3319
7df053ec 3320 SV *argsv = POPs;
ba210ebe 3321 STRLEN len;
349d4f2f 3322 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3323
799ef3cb 3324 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3325 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3326 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
4f6386b6 3327 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
121910a4
JH		 3328 argsv = tmpsv;
3329 }
79072805 3330
d8f42585 3331 XPUSHu(DO_UTF8(argsv)
4f6386b6 3332 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
f3943cf2 3333 : (UV)(*s));
68795e93 3334
79072805
LW		 3335 RETURN;
3336}
3337
463ee0b2
LW		 3338PP(pp_chr)
3339{
97aff369 3340 dVAR; dSP; dTARGET;
463ee0b2 3341 char *tmps;
8a064bd6 3342 UV value;
71739502 3343 SV *top = POPs;
8a064bd6 3344
71739502
FC		 3345 SvGETMAGIC(top);
3346 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3347 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
8a064bd6 3348 ||
71739502
FC		 3349 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3350 && SvNV_nomg(top) < 0.0))) {
b3fe8680
FC		 3351 if (ckWARN(WARN_UTF8)) {
3352 if (SvGMAGICAL(top)) {
3353 SV *top2 = sv_newmortal();
3354 sv_setsv_nomg(top2, top);
3355 top = top2;
3356 }
3357 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3358 "Invalid negative number (%"SVf") in chr", top);
3359 }
8a064bd6 3360 value = UNICODE_REPLACEMENT;
8a064bd6 3361 } else {
71739502 3362 value = SvUV_nomg(top);
8a064bd6 3363 }
463ee0b2 3364
862a34c6 3365 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3366
0064a8a9 3367 if (value > 255 && !IN_BYTES) {
eb160463 3368 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3369 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3370 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW		 3371 *tmps = '\0';
3372 (void)SvPOK_only(TARG);
aa6ffa16 3373 SvUTF8_on(TARG);
a0ed51b3
LW		 3374 XPUSHs(TARG);
3375 RETURN;
3376 }
3377
748a9306 3378 SvGROW(TARG,2);
463ee0b2
LW		 3379 SvCUR_set(TARG, 1);
3380 tmps = SvPVX(TARG);
eb160463 3381 *tmps++ = (char)value;
748a9306 3382 *tmps = '\0';
a0d0e21e 3383 (void)SvPOK_only(TARG);
4c5ed6e2 3384
88632417 3385 if (PL_encoding && !IN_BYTES) {
799ef3cb 3386 sv_recode_to_utf8(TARG, PL_encoding);
88632417 3387 tmps = SvPVX(TARG);
28936164
KW		 3388 if (SvCUR(TARG) == 0
3389 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3390 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3391 {
4c5ed6e2 3392 SvGROW(TARG, 2);
d5a15ac2 3393 tmps = SvPVX(TARG);
4c5ed6e2
TS		 3394 SvCUR_set(TARG, 1);
3395 *tmps++ = (char)value;
88632417 3396 *tmps = '\0';
4c5ed6e2 3397 SvUTF8_off(TARG);
88632417
JH		 3398 }
3399 }
4c5ed6e2 3400
463ee0b2
LW		 3401 XPUSHs(TARG);
3402 RETURN;
3403}
3404
79072805
LW		 3405PP(pp_crypt)
3406{
79072805 3407#ifdef HAS_CRYPT
97aff369 3408 dVAR; dSP; dTARGET;
5f74f29c 3409 dPOPTOPssrl;
85c16d83 3410 STRLEN len;
10516c54 3411 const char *tmps = SvPV_const(left, len);
2bc69dc4 3412
85c16d83 3413 if (DO_UTF8(left)) {
2bc69dc4 3414 /* If Unicode, try to downgrade.
f2791508
JH		 3415 * If not possible, croak.
3416 * Yes, we made this up. */
1b6737cc 3417 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3418
f2791508 3419 SvUTF8_on(tsv);
2bc69dc4 3420 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3421 tmps = SvPV_const(tsv, len);
85c16d83 3422 }
05404ffe
JH		 3423# ifdef USE_ITHREADS
3424# ifdef HAS_CRYPT_R
3425 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3426 /* This should be threadsafe because in ithreads there is only
3427 * one thread per interpreter. If this would not be true,
3428 * we would need a mutex to protect this malloc. */
3429 PL_reentrant_buffer->_crypt_struct_buffer =
3430 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3431#if defined(__GLIBC__) || defined(__EMX__)
3432 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3433 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3434 /* work around glibc-2.2.5 bug */
3435 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3436 }
05404ffe 3437#endif
6ab58e4d 3438 }
05404ffe
JH		 3439# endif /* HAS_CRYPT_R */
3440# endif /* USE_ITHREADS */
5f74f29c 3441# ifdef FCRYPT
83003860 3442 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3443# else
83003860 3444 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3445# endif
ec93b65f 3446 SETTARG;
4808266b 3447 RETURN;
79072805 3448#else
b13b2135 3449 DIE(aTHX_
79072805
LW		 3450 "The crypt() function is unimplemented due to excessive paranoia.");
3451#endif
79072805
LW		 3452}
3453
00f254e2
KW		 3454/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3455 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3456
79072805
LW		 3457PP(pp_ucfirst)
3458{
00f254e2
KW		 3459 /* Actually is both lcfirst() and ucfirst(). Only the first character
3460 * changes. This means that possibly we can change in-place, ie., just
3461 * take the source and change that one character and store it back, but not
3462 * if read-only etc, or if the length changes */
3463
97aff369 3464 dVAR;
39644a26 3465 dSP;
d54190f6 3466 SV *source = TOPs;
00f254e2 3467 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC		 3468 STRLEN need;
3469 SV *dest;
00f254e2
KW		 3470 bool inplace; /* ? Convert first char only, in-place */
3471 bool doing_utf8 = FALSE; /* ? using utf8 */
3472 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3473 const int op_type = PL_op->op_type;
d54190f6
NC		 3474 const U8 *s;
3475 U8 *d;
3476 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW		 3477 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3478 * stored as UTF-8 at s. */
3479 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3480 * lowercased) character stored in tmpbuf. May be either
3481 * UTF-8 or not, but in either case is the number of bytes */
094a2f8c 3482 bool tainted = FALSE;
d54190f6 3483
841a5e18 3484 s = (const U8*)SvPV_const(source, slen);
a0ed51b3 3485
00f254e2
KW		 3486 /* We may be able to get away with changing only the first character, in
3487 * place, but not if read-only, etc. Later we may discover more reasons to
3488 * not convert in-place. */
5cd5e2d6
FC		 3489 inplace = !SvREADONLY(source)
3490 && ( SvPADTMP(source)
3491 || ( SvTEMP(source) && !SvSMAGICAL(source)
3492 && SvREFCNT(source) == 1));
00f254e2
KW		 3493
3494 /* First calculate what the changed first character should be. This affects
3495 * whether we can just swap it out, leaving the rest of the string unchanged,
3496 * or even if have to convert the dest to UTF-8 when the source isn't */
3497
3498 if (! slen) { /* If empty */
3499 need = 1; /* still need a trailing NUL */
b7576bcb 3500 ulen = 0;
00f254e2
KW		 3501 }
3502 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3503 doing_utf8 = TRUE;
17e95c9d 3504 ulen = UTF8SKIP(s);
094a2f8c
KW		 3505 if (op_type == OP_UCFIRST) {
3506 _to_utf8_title_flags(s, tmpbuf, &tculen,
3507 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3508 }
3509 else {
3510 _to_utf8_lower_flags(s, tmpbuf, &tculen,
3511 cBOOL(IN_LOCALE_RUNTIME), &tainted);
3512 }
00f254e2 3513
17e95c9d
KW		 3514 /* we can't do in-place if the length changes. */
3515 if (ulen != tculen) inplace = FALSE;
3516 need = slen + 1 - ulen + tculen;
d54190f6 3517 }
00f254e2
KW		 3518 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3519 * latin1 is treated as caseless. Note that a locale takes
3520 * precedence */
167d19f2 3521 ulen = 1; /* Original character is 1 byte */
00f254e2
KW		 3522 tculen = 1; /* Most characters will require one byte, but this will
3523 * need to be overridden for the tricky ones */
3524 need = slen + 1;
3525
3526 if (op_type == OP_LCFIRST) {
d54190f6 3527
00f254e2
KW		 3528 /* lower case the first letter: no trickiness for any character */
3529 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3530 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3531 }
3532 /* is ucfirst() */
3533 else if (IN_LOCALE_RUNTIME) {
3534 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3535 * have upper and title case different
3536 */
3537 }
3538 else if (! IN_UNI_8_BIT) {
3539 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3540 * on EBCDIC machines whatever the
3541 * native function does */
3542 }
3543 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
167d19f2
KW		 3544 UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3545 if (tculen > 1) {
3546 assert(tculen == 2);
3547
3548 /* If the result is an upper Latin1-range character, it can
3549 * still be represented in one byte, which is its ordinal */
3550 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3551 *tmpbuf = (U8) title_ord;
3552 tculen = 1;
00f254e2
KW		 3553 }
3554 else {
167d19f2
KW		 3555 /* Otherwise it became more than one ASCII character (in
3556 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3557 * beyond Latin1, so the number of bytes changed, so can't
3558 * replace just the first character in place. */
3559 inplace = FALSE;
3560
d14578b8
KW		 3561 /* If the result won't fit in a byte, the entire result
3562 * will have to be in UTF-8. Assume worst case sizing in
3563 * conversion. (all latin1 characters occupy at most two
3564 * bytes in utf8) */
167d19f2
KW		 3565 if (title_ord > 255) {
3566 doing_utf8 = TRUE;
3567 convert_source_to_utf8 = TRUE;
3568 need = slen * 2 + 1;
3569
3570 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3571 * (both) characters whose title case is above 255 is
3572 * 2. */
3573 ulen = 2;
3574 }
3575 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3576 need = slen + 1 + 1;
3577 }
00f254e2 3578 }
167d19f2 3579 }
00f254e2
KW		 3580 } /* End of use Unicode (Latin1) semantics */
3581 } /* End of changing the case of the first character */
3582
3583 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3584 * generate the result */
3585 if (inplace) {
3586
3587 /* We can convert in place. This means we change just the first
3588 * character without disturbing the rest; no need to grow */
d54190f6
NC		 3589 dest = source;
3590 s = d = (U8*)SvPV_force_nomg(source, slen);
3591 } else {
3592 dTARGET;
3593
3594 dest = TARG;
3595
00f254e2
KW		 3596 /* Here, we can't convert in place; we earlier calculated how much
3597 * space we will need, so grow to accommodate that */
d54190f6 3598 SvUPGRADE(dest, SVt_PV);
3b416f41 3599 d = (U8*)SvGROW(dest, need);
d54190f6
NC		 3600 (void)SvPOK_only(dest);
3601
3602 SETs(dest);
d54190f6 3603 }
44bc797b 3604
d54190f6 3605 if (doing_utf8) {
00f254e2
KW		 3606 if (! inplace) {
3607 if (! convert_source_to_utf8) {
3608
3609 /* Here both source and dest are in UTF-8, but have to create
3610 * the entire output. We initialize the result to be the
3611 * title/lower cased first character, and then append the rest
3612 * of the string. */
3613 sv_setpvn(dest, (char*)tmpbuf, tculen);
3614 if (slen > ulen) {
3615 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3616 }
3617 }
3618 else {
3619 const U8 *const send = s + slen;
3620
3621 /* Here the dest needs to be in UTF-8, but the source isn't,
3622 * except we earlier UTF-8'd the first character of the source
3623 * into tmpbuf. First put that into dest, and then append the
3624 * rest of the source, converting it to UTF-8 as we go. */
3625
3626 /* Assert tculen is 2 here because the only two characters that
3627 * get to this part of the code have 2-byte UTF-8 equivalents */
3628 *d++ = *tmpbuf;
3629 *d++ = *(tmpbuf + 1);
3630 s++; /* We have just processed the 1st char */
3631
3632 for (; s < send; s++) {
3633 d = uvchr_to_utf8(d, *s);
3634 }
3635 *d = '\0';
3636 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3637 }
d54190f6 3638 SvUTF8_on(dest);
a0ed51b3 3639 }
00f254e2 3640 else { /* in-place UTF-8. Just overwrite the first character */
d54190f6
NC		 3641 Copy(tmpbuf, d, tculen, U8);
3642 SvCUR_set(dest, need - 1);
a0ed51b3 3643 }
094a2f8c
KW		 3644
3645 if (tainted) {
3646 TAINT;
3647 SvTAINTED_on(dest);
3648 }
a0ed51b3 3649 }
00f254e2
KW		 3650 else { /* Neither source nor dest are in or need to be UTF-8 */
3651 if (slen) {
2de3dbcc 3652 if (IN_LOCALE_RUNTIME) {
31351b04 3653 TAINT;
d54190f6 3654 SvTAINTED_on(dest);
31351b04 3655 }
00f254e2
KW		 3656 if (inplace) { /* in-place, only need to change the 1st char */
3657 *d = *tmpbuf;
3658 }
3659 else { /* Not in-place */
3660
3661 /* Copy the case-changed character(s) from tmpbuf */
3662 Copy(tmpbuf, d, tculen, U8);
3663 d += tculen - 1; /* Code below expects d to point to final
3664 * character stored */
3665 }
3666 }
3667 else { /* empty source */
3668 /* See bug #39028: Don't taint if empty */
d54190f6
NC		 3669 *d = *s;
3670 }
3671
00f254e2
KW		 3672 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3673 * the destination to retain that flag */
93e088e8 3674 if (SvUTF8(source) && ! IN_BYTES)
d54190f6
NC		 3675 SvUTF8_on(dest);
3676
00f254e2 3677 if (!inplace) { /* Finish the rest of the string, unchanged */
d54190f6
NC		 3678 /* This will copy the trailing NUL */
3679 Copy(s + 1, d + 1, slen, U8);
3680 SvCUR_set(dest, need - 1);
bbce6d69 3681 }
bbce6d69 3682 }
539689e7
FC		 3683 if (dest != source && SvTAINTED(source))
3684 SvTAINT(dest);
d54190f6 3685 SvSETMAGIC(dest);
79072805
LW		 3686 RETURN;
3687}
3688
67306194
NC		 3689/* There's so much setup/teardown code common between uc and lc, I wonder if
3690 it would be worth merging the two, and just having a switch outside each
00f254e2 3691 of the three tight loops. There is less and less commonality though */
79072805
LW		 3692PP(pp_uc)
3693{
97aff369 3694 dVAR;
39644a26 3695 dSP;
67306194 3696 SV *source = TOPs;
463ee0b2 3697 STRLEN len;
67306194
NC		 3698 STRLEN min;
3699 SV *dest;
3700 const U8 *s;
3701 U8 *d;
79072805 3702
67306194
NC		 3703 SvGETMAGIC(source);
3704
5cd5e2d6
FC		 3705 if ((SvPADTMP(source)
3706 ||
3707 (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3708 && !SvREADONLY(source) && SvPOK(source)
3709 && !DO_UTF8(source)
00f254e2
KW		 3710 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3711
3712 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3713 * make the loop tight, so we overwrite the source with the dest before
3714 * looking at it, and we need to look at the original source
3715 * afterwards. There would also need to be code added to handle
3716 * switching to not in-place in midstream if we run into characters
3717 * that change the length.
3718 */
67306194
NC		 3719 dest = source;
3720 s = d = (U8*)SvPV_force_nomg(source, len);
3721 min = len + 1;
3722 } else {
a0ed51b3 3723 dTARGET;
a0ed51b3 3724
67306194 3725 dest = TARG;
128c9517 3726
841a5e18 3727 s = (const U8*)SvPV_nomg_const(source, len);
67306194
NC		 3728 min = len + 1;
3729
3730 SvUPGRADE(dest, SVt_PV);
3b416f41 3731 d = (U8*)SvGROW(dest, min);
67306194
NC		 3732 (void)SvPOK_only(dest);
3733
3734 SETs(dest);
a0ed51b3 3735 }
31351b04 3736
67306194
NC		 3737 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3738 to check DO_UTF8 again here. */
3739
3740 if (DO_UTF8(source)) {
3741 const U8 *const send = s + len;
bfac13d4 3742 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
094a2f8c 3743 bool tainted = FALSE;
67306194 3744
4c8a458a
KW		 3745 /* All occurrences of these are to be moved to follow any other marks.
3746 * This is context-dependent. We may not be passed enough context to
3747 * move the iota subscript beyond all of them, but we do the best we can
3748 * with what we're given. The result is always better than if we
3749 * hadn't done this. And, the problem would only arise if we are
3750 * passed a character without all its combining marks, which would be
3751 * the caller's mistake. The information this is based on comes from a
3752 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3753 * itself) and so can't be checked properly to see if it ever gets
3754 * revised. But the likelihood of it changing is remote */
00f254e2 3755 bool in_iota_subscript = FALSE;
00f254e2 3756
67306194 3757 while (s < send) {
3e16b0e6
KW		 3758 STRLEN u;
3759 STRLEN ulen;
3760 UV uv;
7dbf68d2 3761 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3e16b0e6 3762
00f254e2 3763 /* A non-mark. Time to output the iota subscript */
a78bc3c6
KW		 3764 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3765 d += capital_iota_len;
00f254e2 3766 in_iota_subscript = FALSE;
8e058693 3767 }
00f254e2 3768
8e058693
KW		 3769 /* Then handle the current character. Get the changed case value
3770 * and copy it to the output buffer */
00f254e2 3771
8e058693 3772 u = UTF8SKIP(s);
094a2f8c
KW		 3773 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
3774 cBOOL(IN_LOCALE_RUNTIME), &tainted);
a78bc3c6
KW		 3775#define GREEK_CAPITAL_LETTER_IOTA 0x0399
3776#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
8e058693 3777 if (uv == GREEK_CAPITAL_LETTER_IOTA
4b88fb76 3778 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
8e058693
KW		 3779 {
3780 in_iota_subscript = TRUE;
3781 }
3782 else {
3783 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3784 /* If the eventually required minimum size outgrows the
3785 * available space, we need to grow. */
3786 const UV o = d - (U8*)SvPVX_const(dest);
3787
3788 /* If someone uppercases one million U+03B0s we SvGROW()
3789 * one million times. Or we could try guessing how much to
3790 * allocate without allocating too much. Such is life.
3791 * See corresponding comment in lc code for another option
3792 * */
3793 SvGROW(dest, min);
3794 d = (U8*)SvPVX(dest) + o;
3795 }
3796 Copy(tmpbuf, d, ulen, U8);
3797 d += ulen;
3798 }
3799 s += u;
67306194 3800 }
4c8a458a 3801 if (in_iota_subscript) {
a78bc3c6
KW		 3802 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3803 d += capital_iota_len;
4c8a458a 3804 }
67306194
NC		 3805 SvUTF8_on(dest);
3806 *d = '\0';
094a2f8c 3807
67306194 3808 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
094a2f8c
KW		 3809 if (tainted) {
3810 TAINT;
3811 SvTAINTED_on(dest);
3812 }
4c8a458a
KW		 3813 }
3814 else { /* Not UTF-8 */
67306194
NC		 3815 if (len) {
3816 const U8 *const send = s + len;
00f254e2
KW		 3817
3818 /* Use locale casing if in locale; regular style if not treating
3819 * latin1 as having case; otherwise the latin1 casing. Do the
3820 * whole thing in a tight loop, for speed, */
2de3dbcc 3821 if (IN_LOCALE_RUNTIME) {
31351b04 3822 TAINT;
67306194
NC		 3823 SvTAINTED_on(dest);
3824 for (; s < send; d++, s++)
3825 *d = toUPPER_LC(*s);
31351b04 3826 }
00f254e2
KW		 3827 else if (! IN_UNI_8_BIT) {
3828 for (; s < send; d++, s++) {
67306194 3829 *d = toUPPER(*s);
00f254e2 3830 }
31351b04 3831 }
00f254e2
KW		 3832 else {
3833 for (; s < send; d++, s++) {
3834 *d = toUPPER_LATIN1_MOD(*s);
d14578b8
KW		 3835 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3836 continue;
3837 }
00f254e2
KW		 3838
3839 /* The mainstream case is the tight loop above. To avoid
3840 * extra tests in that, all three characters that require
3841 * special handling are mapped by the MOD to the one tested
3842 * just above.
3843 * Use the source to distinguish between the three cases */
3844
3845 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3846
3847 /* uc() of this requires 2 characters, but they are
3848 * ASCII. If not enough room, grow the string */
3849 if (SvLEN(dest) < ++min) {
3850 const UV o = d - (U8*)SvPVX_const(dest);
3851 SvGROW(dest, min);
3852 d = (U8*)SvPVX(dest) + o;
3853 }
3854 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3855 continue; /* Back to the tight loop; still in ASCII */
3856 }
3857
3858 /* The other two special handling characters have their
3859 * upper cases outside the latin1 range, hence need to be
3860 * in UTF-8, so the whole result needs to be in UTF-8. So,
3861 * here we are somewhere in the middle of processing a
3862 * non-UTF-8 string, and realize that we will have to convert
3863 * the whole thing to UTF-8. What to do? There are
3864 * several possibilities. The simplest to code is to
3865 * convert what we have so far, set a flag, and continue on
3866 * in the loop. The flag would be tested each time through
3867 * the loop, and if set, the next character would be
3868 * converted to UTF-8 and stored. But, I (khw) didn't want
3869 * to slow down the mainstream case at all for this fairly
3870 * rare case, so I didn't want to add a test that didn't
3871 * absolutely have to be there in the loop, besides the
3872 * possibility that it would get too complicated for
3873 * optimizers to deal with. Another possibility is to just
3874 * give up, convert the source to UTF-8, and restart the
3875 * function that way. Another possibility is to convert
3876 * both what has already been processed and what is yet to
3877 * come separately to UTF-8, then jump into the loop that
3878 * handles UTF-8. But the most efficient time-wise of the
3879 * ones I could think of is what follows, and turned out to
3880 * not require much extra code. */
3881
3882 /* Convert what we have so far into UTF-8, telling the
3883 * function that we know it should be converted, and to
3884 * allow extra space for what we haven't processed yet.
3885 * Assume the worst case space requirements for converting
3886 * what we haven't processed so far: that it will require
3887 * two bytes for each remaining source character, plus the
3888 * NUL at the end. This may cause the string pointer to
3889 * move, so re-find it. */
3890
3891 len = d - (U8*)SvPVX_const(dest);
3892 SvCUR_set(dest, len);
3893 len = sv_utf8_upgrade_flags_grow(dest,
3894 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3895 (send -s) * 2 + 1);
3896 d = (U8*)SvPVX(dest) + len;
3897
00f254e2
KW		 3898 /* Now process the remainder of the source, converting to
3899 * upper and UTF-8. If a resulting byte is invariant in
3900 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3901 * append it to the output. */
00f254e2 3902 for (; s < send; s++) {
0ecfbd28
KW		 3903 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3904 d += len;
00f254e2
KW		 3905 }
3906
3907 /* Here have processed the whole source; no need to continue
3908 * with the outer loop. Each character has been converted
3909 * to upper case and converted to UTF-8 */
3910
3911 break;
3912 } /* End of processing all latin1-style chars */
3913 } /* End of processing all chars */
3914 } /* End of source is not empty */
3915
67306194 3916 if (source != dest) {
00f254e2 3917 *d = '\0'; /* Here d points to 1 after last char, add NUL */
67306194
NC		 3918 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3919 }
00f254e2 3920 } /* End of isn't utf8 */
539689e7
FC		 3921 if (dest != source && SvTAINTED(source))
3922 SvTAINT(dest);
67306194 3923 SvSETMAGIC(dest);
79072805
LW		 3924 RETURN;
3925}
3926
3927PP(pp_lc)
3928{
97aff369 3929 dVAR;
39644a26 3930 dSP;
ec9af7d4 3931 SV *source = TOPs;
463ee0b2 3932 STRLEN len;
ec9af7d4
NC		 3933 STRLEN min;
3934 SV *dest;
3935 const U8 *s;
3936 U8 *d;
79072805 3937
ec9af7d4
NC		 3938 SvGETMAGIC(source);
3939
5cd5e2d6
FC		 3940 if ( ( SvPADTMP(source)
3941 || ( SvTEMP(source) && !SvSMAGICAL(source)
3942 && SvREFCNT(source) == 1 )
3943 )
3944 && !SvREADONLY(source) && SvPOK(source)
3945 && !DO_UTF8(source)) {
ec9af7d4 3946
00f254e2
KW		 3947 /* We can convert in place, as lowercasing anything in the latin1 range
3948 * (or else DO_UTF8 would have been on) doesn't lengthen it */
ec9af7d4
NC		 3949 dest = source;
3950 s = d = (U8*)SvPV_force_nomg(source, len);
3951 min = len + 1;
3952 } else {
a0ed51b3 3953 dTARGET;
a0ed51b3 3954
ec9af7d4
NC		 3955 dest = TARG;
3956
841a5e18 3957 s = (const U8*)SvPV_nomg_const(source, len);
ec9af7d4 3958 min = len + 1;
128c9517 3959
ec9af7d4 3960 SvUPGRADE(dest, SVt_PV);
3b416f41 3961 d = (U8*)SvGROW(dest, min);
ec9af7d4
NC		 3962 (void)SvPOK_only(dest);
3963
3964 SETs(dest);
3965 }
3966
3967 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3968 to check DO_UTF8 again here. */
3969
3970 if (DO_UTF8(source)) {
3971 const U8 *const send = s + len;
3972 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
094a2f8c 3973 bool tainted = FALSE;
ec9af7d4
NC		 3974
3975 while (s < send) {
06b5486a
KW		 3976 const STRLEN u = UTF8SKIP(s);
3977 STRLEN ulen;
00f254e2 3978
094a2f8c
KW		 3979 _to_utf8_lower_flags(s, tmpbuf, &ulen,
3980 cBOOL(IN_LOCALE_RUNTIME), &tainted);
00f254e2 3981
06b5486a 3982 /* Here is where we would do context-sensitive actions. See the
6006ebd0 3983 * commit message for 86510fb15 for why there isn't any */
00f254e2 3984
06b5486a 3985 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
fdb34c52 3986
06b5486a
KW		 3987 /* If the eventually required minimum size outgrows the
3988 * available space, we need to grow. */
3989 const UV o = d - (U8*)SvPVX_const(dest);
fdb34c52 3990
06b5486a
KW		 3991 /* If someone lowercases one million U+0130s we SvGROW() one
3992 * million times. Or we could try guessing how much to
3993 * allocate without allocating too much. Such is life.
3994 * Another option would be to grow an extra byte or two more
3995 * each time we need to grow, which would cut down the million
3996 * to 500K, with little waste */
3997 SvGROW(dest, min);
3998 d = (U8*)SvPVX(dest) + o;
3999 }
86510fb1 4000
06b5486a
KW		 4001 /* Copy the newly lowercased letter to the output buffer we're
4002 * building */
4003 Copy(tmpbuf, d, ulen, U8);
4004 d += ulen;
4005 s += u;
00f254e2 4006 } /* End of looping through the source string */
ec9af7d4
NC		 4007 SvUTF8_on(dest);
4008 *d = '\0';
4009 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
094a2f8c
KW		 4010 if (tainted) {
4011 TAINT;
4012 SvTAINTED_on(dest);
4013 }
00f254e2 4014 } else { /* Not utf8 */
31351b04 4015 if (len) {
ec9af7d4 4016 const U8 *const send = s + len;
00f254e2
KW		 4017
4018 /* Use locale casing if in locale; regular style if not treating
4019 * latin1 as having case; otherwise the latin1 casing. Do the
4020 * whole thing in a tight loop, for speed, */
2de3dbcc 4021 if (IN_LOCALE_RUNTIME) {
31351b04 4022 TAINT;
ec9af7d4
NC		 4023 SvTAINTED_on(dest);
4024 for (; s < send; d++, s++)
4025 *d = toLOWER_LC(*s);
31351b04 4026 }
00f254e2
KW		 4027 else if (! IN_UNI_8_BIT) {
4028 for (; s < send; d++, s++) {
ec9af7d4 4029 *d = toLOWER(*s);
00f254e2
KW		 4030 }
4031 }
4032 else {
4033 for (; s < send; d++, s++) {
4034 *d = toLOWER_LATIN1(*s);
4035 }
31351b04 4036 }
bbce6d69 4037 }
ec9af7d4
NC		 4038 if (source != dest) {
4039 *d = '\0';
4040 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4041 }
79072805 4042 }
539689e7
FC		 4043 if (dest != source && SvTAINTED(source))
4044 SvTAINT(dest);
ec9af7d4 4045 SvSETMAGIC(dest);
79072805
LW		 4046 RETURN;
4047}
4048
a0d0e21e 4049PP(pp_quotemeta)
79072805 4050{
97aff369 4051 dVAR; dSP; dTARGET;
1b6737cc 4052 SV * const sv = TOPs;
a0d0e21e 4053 STRLEN len;
eb578fdb 4054 const char *s = SvPV_const(sv,len);
79072805 4055
7e2040f0 4056 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 4057 if (len) {
eb578fdb 4058 char *d;
862a34c6 4059 SvUPGRADE(TARG, SVt_PV);
c07a80fd 4060 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 4061 d = SvPVX(TARG);
7e2040f0 4062 if (DO_UTF8(sv)) {
0dd2cdef 4063 while (len) {
29050de5 4064 STRLEN ulen = UTF8SKIP(s);
2e2b2571
KW		 4065 bool to_quote = FALSE;
4066
4067 if (UTF8_IS_INVARIANT(*s)) {
4068 if (_isQUOTEMETA(*s)) {
4069 to_quote = TRUE;
4070 }
4071 }
4072 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
20adcf7c
KW		 4073
4074 /* In locale, we quote all non-ASCII Latin1 chars.
4075 * Otherwise use the quoting rules */
4076 if (IN_LOCALE_RUNTIME
94bb8c36 4077 || _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
2e2b2571
KW		 4078 {
4079 to_quote = TRUE;
4080 }
4081 }
685289b5 4082 else if (is_QUOTEMETA_high(s)) {
2e2b2571
KW		 4083 to_quote = TRUE;
4084 }
4085
4086 if (to_quote) {
4087 *d++ = '\\';
4088 }
29050de5
KW		 4089 if (ulen > len)
4090 ulen = len;
4091 len -= ulen;
4092 while (ulen--)
4093 *d++ = *s++;
0dd2cdef 4094 }
7e2040f0 4095 SvUTF8_on(TARG);
0dd2cdef 4096 }
2e2b2571
KW		 4097 else if (IN_UNI_8_BIT) {
4098 while (len--) {
4099 if (_isQUOTEMETA(*s))
4100 *d++ = '\\';
4101 *d++ = *s++;
4102 }
4103 }
0dd2cdef 4104 else {
2e2b2571
KW		 4105 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4106 * including everything above ASCII */
0dd2cdef 4107 while (len--) {
adfec831 4108 if (!isWORDCHAR_A(*s))
0dd2cdef
LW		 4109 *d++ = '\\';
4110 *d++ = *s++;
4111 }
79072805 4112 }
a0d0e21e 4113 *d = '\0';
349d4f2f 4114 SvCUR_set(TARG, d - SvPVX_const(TARG));
3aa33fe5 4115 (void)SvPOK_only_UTF8(TARG);
79072805 4116 }
a0d0e21e
LW		 4117 else
4118 sv_setpvn(TARG, s, len);
ec93b65f 4119 SETTARG;
79072805
LW		 4120 RETURN;
4121}
4122
838f2281
BF		 4123PP(pp_fc)
4124{
4125 dVAR;
4126 dTARGET;
4127 dSP;
4128 SV *source = TOPs;
4129 STRLEN len;
4130 STRLEN min;
4131 SV *dest;
4132 const U8 *s;
4133 const U8 *send;
4134 U8 *d;
bfac13d4 4135 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
838f2281
BF		 4136 const bool full_folding = TRUE;
4137 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4138 | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4139
4140 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4141 * You are welcome(?) -Hugmeir
4142 */
4143
4144 SvGETMAGIC(source);
4145
4146 dest = TARG;
4147
4148 if (SvOK(source)) {
4149 s = (const U8*)SvPV_nomg_const(source, len);
4150 } else {
4151 if (ckWARN(WARN_UNINITIALIZED))
4152 report_uninit(source);
4153 s = (const U8*)"";
4154 len = 0;
4155 }
4156
4157 min = len + 1;
4158
4159 SvUPGRADE(dest, SVt_PV);
4160 d = (U8*)SvGROW(dest, min);
4161 (void)SvPOK_only(dest);
4162
4163 SETs(dest);
4164
4165 send = s + len;
4166 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4167 bool tainted = FALSE;
4168 while (s < send) {
4169 const STRLEN u = UTF8SKIP(s);
4170 STRLEN ulen;
4171
4172 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
4173
4174 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4175 const UV o = d - (U8*)SvPVX_const(dest);
4176 SvGROW(dest, min);
4177 d = (U8*)SvPVX(dest) + o;
4178 }
4179
4180 Copy(tmpbuf, d, ulen, U8);
4181 d += ulen;
4182 s += u;
4183 }
4184 SvUTF8_on(dest);
4185 if (tainted) {
4186 TAINT;
4187 SvTAINTED_on(dest);
4188 }
4189 } /* Unflagged string */
0902dd32 4190 else if (len) {
838f2281
BF		 4191 if ( IN_LOCALE_RUNTIME ) { /* Under locale */
4192 TAINT;
4193 SvTAINTED_on(dest);
4194 for (; s < send; d++, s++)
d22b930b 4195 *d = toFOLD_LC(*s);
838f2281
BF		 4196 }
4197 else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4198 for (; s < send; d++, s++)
d22b930b 4199 *d = toFOLD(*s);
838f2281
BF		 4200 }
4201 else {
d14578b8
KW		 4202 /* For ASCII and the Latin-1 range, there's only two troublesome
4203 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
22e255cb 4204 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
d14578b8
KW		 4205 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4206 * For the rest, the casefold is their lowercase. */
838f2281
BF		 4207 for (; s < send; d++, s++) {
4208 if (*s == MICRO_SIGN) {
d14578b8
KW		 4209 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4210 * which is outside of the latin-1 range. There's a couple
4211 * of ways to deal with this -- khw discusses them in
4212 * pp_lc/uc, so go there :) What we do here is upgrade what
4213 * we had already casefolded, then enter an inner loop that
4214 * appends the rest of the characters as UTF-8. */
838f2281
BF		 4215 len = d - (U8*)SvPVX_const(dest);
4216 SvCUR_set(dest, len);
4217 len = sv_utf8_upgrade_flags_grow(dest,
4218 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
ea4d335b
KW		 4219 /* The max expansion for latin1
4220 * chars is 1 byte becomes 2 */
4221 (send -s) * 2 + 1);
838f2281
BF		 4222 d = (U8*)SvPVX(dest) + len;
4223
a78bc3c6
KW		 4224 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4225 d += small_mu_len;
838f2281
BF		 4226 s++;
4227 for (; s < send; s++) {
4228 STRLEN ulen;
4229 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
6f2d5cbc 4230 if UVCHR_IS_INVARIANT(fc) {
d14578b8
KW		 4231 if (full_folding
4232 && *s == LATIN_SMALL_LETTER_SHARP_S)
4233 {
838f2281
BF		 4234 *d++ = 's';
4235 *d++ = 's';
4236 }
4237 else
4238 *d++ = (U8)fc;
4239 }
4240 else {
4241 Copy(tmpbuf, d, ulen, U8);
4242 d += ulen;
4243 }
4244 }
4245 break;
4246 }
4247 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
d14578b8
KW		 4248 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4249 * becomes "ss", which may require growing the SV. */
838f2281
BF		 4250 if (SvLEN(dest) < ++min) {
4251 const UV o = d - (U8*)SvPVX_const(dest);
4252 SvGROW(dest, min);
4253 d = (U8*)SvPVX(dest) + o;
4254 }
4255 *(d)++ = 's';
4256 *d = 's';
4257 }
d14578b8
KW		 4258 else { /* If it's not one of those two, the fold is their lower
4259 case */
838f2281
BF		 4260 *d = toLOWER_LATIN1(*s);
4261 }
4262 }
4263 }
4264 }
4265 *d = '\0';
4266 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4267
4268 if (SvTAINTED(source))
4269 SvTAINT(dest);
4270 SvSETMAGIC(dest);
4271 RETURN;
4272}
4273
a0d0e21e 4274/* Arrays. */
79072805 4275
a0d0e21e 4276PP(pp_aslice)
79072805 4277{
97aff369 4278 dVAR; dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4279 AV *const av = MUTABLE_AV(POPs);
4280 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
79072805 4281
a0d0e21e 4282 if (SvTYPE(av) == SVt_PVAV) {
4ad10a0b
VP		 4283 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4284 bool can_preserve = FALSE;
4285
4286 if (localizing) {
4287 MAGIC *mg;
4288 HV *stash;
4289
4290 can_preserve = SvCANEXISTDELETE(av);
4291 }
4292
4293 if (lval && localizing) {
eb578fdb 4294 SV **svp;
c70927a6 4295 SSize_t max = -1;
924508f0 4296 for (svp = MARK + 1; svp <= SP; svp++) {
c70927a6 4297 const SSize_t elem = SvIV(*svp);
748a9306
LW		 4298 if (elem > max)
4299 max = elem;
4300 }
4301 if (max > AvMAX(av))
4302 av_extend(av, max);
4303 }
4ad10a0b 4304
a0d0e21e 4305 while (++MARK <= SP) {
eb578fdb 4306 SV **svp;
c70927a6 4307 SSize_t elem = SvIV(*MARK);
4ad10a0b 4308 bool preeminent = TRUE;
a0d0e21e 4309
4ad10a0b
VP		 4310 if (localizing && can_preserve) {
4311 /* If we can determine whether the element exist,
4312 * Try to preserve the existenceness of a tied array
4313 * element by using EXISTS and DELETE if possible.
4314 * Fallback to FETCH and STORE otherwise. */
4315 preeminent = av_exists(av, elem);
4316 }
4317
a0d0e21e
LW		 4318 svp = av_fetch(av, elem, lval);
4319 if (lval) {
ce0d59fd 4320 if (!svp || !*svp)
cea2e8a9 4321 DIE(aTHX_ PL_no_aelem, elem);
4ad10a0b
VP		 4322 if (localizing) {
4323 if (preeminent)
4324 save_aelem(av, elem, svp);
4325 else
4326 SAVEADELETE(av, elem);
4327 }
79072805 4328 }
3280af22 4329 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 4330 }
4331 }
748a9306 4332 if (GIMME != G_ARRAY) {
a0d0e21e 4333 MARK = ORIGMARK;
04ab2c87 4334 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e
LW		 4335 SP = MARK;
4336 }
79072805
LW		 4337 RETURN;
4338}
4339
6dd3e0f2
RZ		 4340PP(pp_kvaslice)
4341{
4342 dVAR; dSP; dMARK;
4343 AV *const av = MUTABLE_AV(POPs);
4344 I32 lval = (PL_op->op_flags & OPf_MOD);
adad97db 4345 SSize_t items = SP - MARK;
6dd3e0f2
RZ		 4346
4347 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4348 const I32 flags = is_lvalue_sub();
4349 if (flags) {
4350 if (!(flags & OPpENTERSUB_INARGS))
7aae0299 4351 /* diag_listed_as: Can't modify %s in %s */
6dd3e0f2
RZ		 4352 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4353 lval = flags;
4354 }
4355 }
4356
4357 MEXTEND(SP,items);
4358 while (items > 1) {
4359 *(MARK+items*2-1) = *(MARK+items);
4360 items--;
4361 }
4362 items = SP-MARK;
4363 SP += items;
4364
4365 while (++MARK <= SP) {
4366 SV **svp;
4367
4368 svp = av_fetch(av, SvIV(*MARK), lval);
4369 if (lval) {
4370 if (!svp || !*svp || *svp == &PL_sv_undef) {
4371 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4372 }
4373 *MARK = sv_mortalcopy(*MARK);
4374 }
4375 *++MARK = svp ? *svp : &PL_sv_undef;
4376 }
4377 if (GIMME != G_ARRAY) {
4378 MARK = SP - items*2;
4379 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4380 SP = MARK;
4381 }
4382 RETURN;
4383}
4384
cba5a3b0
DG		 4385/* Smart dereferencing for keys, values and each */
4386PP(pp_rkeys)
4387{
4388 dVAR;
4389 dSP;
4390 dPOPss;
4391
7ac5715b
FC		 4392 SvGETMAGIC(sv);
4393
4394 if (
4395 !SvROK(sv)
4396 || (sv = SvRV(sv),
4397 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4398 || SvOBJECT(sv)
4399 )
4400 ) {
4401 DIE(aTHX_
4402 "Type of argument to %s must be unblessed hashref or arrayref",
4c540399 4403 PL_op_desc[PL_op->op_type] );
cba5a3b0
DG		 4404 }
4405
d8065907
FC		 4406 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4407 DIE(aTHX_
4408 "Can't modify %s in %s",
4409 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4410 );
4411
cba5a3b0
DG		 4412 /* Delegate to correct function for op type */
4413 PUSHs(sv);
4414 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4415 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4416 }
4417 else {
d14578b8
KW		 4418 return (SvTYPE(sv) == SVt_PVHV)
4419 ? Perl_pp_each(aTHX)
4420 : Perl_pp_aeach(aTHX);
cba5a3b0
DG		 4421 }
4422}
4423
878d132a
NC		 4424PP(pp_aeach)
4425{
4426 dVAR;
4427 dSP;
502c6561 4428 AV *array = MUTABLE_AV(POPs);
878d132a 4429 const I32 gimme = GIMME_V;
453d94a9 4430 IV *iterp = Perl_av_iter_p(aTHX_ array);
878d132a
NC		 4431 const IV current = (*iterp)++;
4432
4433 if (current > av_len(array)) {
4434 *iterp = 0;
4435 if (gimme == G_SCALAR)
4436 RETPUSHUNDEF;
4437 else
4438 RETURN;
4439 }
4440
4441 EXTEND(SP, 2);
e1dccc0d 4442 mPUSHi(current);
878d132a
NC		 4443 if (gimme == G_ARRAY) {
4444 SV **const element = av_fetch(array, current, 0);
4445 PUSHs(element ? *element : &PL_sv_undef);
4446 }
4447 RETURN;
4448}
4449
4450PP(pp_akeys)
4451{
4452 dVAR;
4453 dSP;
502c6561 4454 AV *array = MUTABLE_AV(POPs);
878d132a
NC		 4455 const I32 gimme = GIMME_V;
4456
4457 *Perl_av_iter_p(aTHX_ array) = 0;
4458
4459 if (gimme == G_SCALAR) {
4460 dTARGET;
4461 PUSHi(av_len(array) + 1);
4462 }
4463 else if (gimme == G_ARRAY) {
4464 IV n = Perl_av_len(aTHX_ array);
e1dccc0d 4465 IV i;
878d132a
NC		 4466
4467 EXTEND(SP, n + 1);
4468
cba5a3b0 4469 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
e1dccc0d 4470 for (i = 0; i <= n; i++) {
878d132a
NC		 4471 mPUSHi(i);
4472 }
4473 }
4474 else {
4475 for (i = 0; i <= n; i++) {
4476 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4477 PUSHs(elem ? *elem : &PL_sv_undef);
4478 }
4479 }
4480 }
4481 RETURN;
4482}
4483
79072805
LW		 4484/* Associative arrays. */
4485
4486PP(pp_each)
4487{
97aff369 4488 dVAR;
39644a26 4489 dSP;
85fbaab2 4490 HV * hash = MUTABLE_HV(POPs);
c07a80fd 4491 HE *entry;
f54cb97a 4492 const I32 gimme = GIMME_V;
8ec5e241 4493
c07a80fd 4494 PUTBACK;
c750a3ec 4495 /* might clobber stack_sp */
6d822dc4 4496 entry = hv_iternext(hash);
c07a80fd 4497 SPAGAIN;
79072805 4498
79072805
LW		 4499 EXTEND(SP, 2);
4500 if (entry) {
1b6737cc 4501 SV* const sv = hv_iterkeysv(entry);
574c8022 4502 PUSHs(sv); /* won't clobber stack_sp */
54310121 4503 if (gimme == G_ARRAY) {
59af0135 4504 SV *val;
c07a80fd 4505 PUTBACK;
c750a3ec 4506 /* might clobber stack_sp */
6d822dc4 4507 val = hv_iterval(hash, entry);
c07a80fd 4508 SPAGAIN;
59af0135 4509 PUSHs(val);
79072805 4510 }
79072805 4511 }
54310121 4512 else if (gimme == G_SCALAR)
79072805
LW		 4513 RETPUSHUNDEF;
4514
4515 RETURN;
4516}
4517
7332a6c4
VP		 4518STATIC OP *
4519S_do_delete_local(pTHX)
79072805 4520{
97aff369 4521 dVAR;
39644a26 4522 dSP;
f54cb97a 4523 const I32 gimme = GIMME_V;
7332a6c4
VP		 4524 const MAGIC *mg;
4525 HV *stash;
ca3f996a
FC		 4526 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4527 SV *unsliced_keysv = sliced ? NULL : POPs;
4528 SV * const osv = POPs;
eb578fdb 4529 SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
ca3f996a
FC		 4530 dORIGMARK;
4531 const bool tied = SvRMAGICAL(osv)
7332a6c4 4532 && mg_find((const SV *)osv, PERL_MAGIC_tied);
ca3f996a
FC		 4533 const bool can_preserve = SvCANEXISTDELETE(osv);
4534 const U32 type = SvTYPE(osv);
4535 SV ** const end = sliced ? SP : &unsliced_keysv;
4536
4537 if (type == SVt_PVHV) { /* hash element */
7332a6c4 4538 HV * const hv = MUTABLE_HV(osv);
ca3f996a 4539 while (++MARK <= end) {
7332a6c4
VP		 4540 SV * const keysv = *MARK;
4541 SV *sv = NULL;
4542 bool preeminent = TRUE;
4543 if (can_preserve)
4544 preeminent = hv_exists_ent(hv, keysv, 0);
4545 if (tied) {
4546 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4547 if (he)
4548 sv = HeVAL(he);
4549 else
4550 preeminent = FALSE;
4551 }
4552 else {
4553 sv = hv_delete_ent(hv, keysv, 0, 0);
9332b95f
FC		 4554 if (preeminent)
4555 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4556 }
4557 if (preeminent) {
be6064fd 4558 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
7332a6c4
VP		 4559 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4560 if (tied) {
4561 *MARK = sv_mortalcopy(sv);
4562 mg_clear(sv);
4563 } else
4564 *MARK = sv;
4565 }
4566 else {
4567 SAVEHDELETE(hv, keysv);
4568 *MARK = &PL_sv_undef;
4569 }
4570 }
ca3f996a
FC		 4571 }
4572 else if (type == SVt_PVAV) { /* array element */
7332a6c4
VP		 4573 if (PL_op->op_flags & OPf_SPECIAL) {
4574 AV * const av = MUTABLE_AV(osv);
ca3f996a 4575 while (++MARK <= end) {
c70927a6 4576 SSize_t idx = SvIV(*MARK);
7332a6c4
VP		 4577 SV *sv = NULL;
4578 bool preeminent = TRUE;
4579 if (can_preserve)
4580 preeminent = av_exists(av, idx);
4581 if (tied) {
4582 SV **svp = av_fetch(av, idx, 1);
4583 if (svp)
4584 sv = *svp;
4585 else
4586 preeminent = FALSE;
4587 }
4588 else {
4589 sv = av_delete(av, idx, 0);
9332b95f
FC		 4590 if (preeminent)
4591 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
7332a6c4
VP		 4592 }
4593 if (preeminent) {
4594 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4595 if (tied) {
4596 *MARK = sv_mortalcopy(sv);
4597 mg_clear(sv);
4598 } else
4599 *MARK = sv;
4600 }
4601 else {
4602 SAVEADELETE(av, idx);
4603 *MARK = &PL_sv_undef;
4604 }
4605 }
4606 }
ca3f996a
FC		 4607 else
4608 DIE(aTHX_ "panic: avhv_delete no longer supported");
4609 }
4610 else
7332a6c4 4611 DIE(aTHX_ "Not a HASH reference");
ca3f996a 4612 if (sliced) {
7332a6c4
VP		 4613 if (gimme == G_VOID)
4614 SP = ORIGMARK;
4615 else if (gimme == G_SCALAR) {
4616 MARK = ORIGMARK;
4617 if (SP > MARK)
4618 *++MARK = *SP;
4619 else
4620 *++MARK = &PL_sv_undef;
4621 SP = MARK;
4622 }
4623 }
ca3f996a
FC		 4624 else if (gimme != G_VOID)
4625 PUSHs(unsliced_keysv);
7332a6c4
VP		 4626
4627 RETURN;
4628}
4629
4630PP(pp_delete)
4631{
4632 dVAR;
4633 dSP;
4634 I32 gimme;
4635 I32 discard;
4636
4637 if (PL_op->op_private & OPpLVAL_INTRO)
4638 return do_delete_local();
4639
4640 gimme = GIMME_V;
4641 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5f05dabc 4642
533c011a 4643 if (PL_op->op_private & OPpSLICE) {
5f05dabc 4644 dMARK; dORIGMARK;
85fbaab2 4645 HV * const hv = MUTABLE_HV(POPs);
1b6737cc 4646 const U32 hvtype = SvTYPE(hv);
01020589
GS		 4647 if (hvtype == SVt_PVHV) { /* hash element */
4648 while (++MARK <= SP) {
1b6737cc 4649 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 4650 *MARK = sv ? sv : &PL_sv_undef;
4651 }
5f05dabc 4652 }
6d822dc4
MS		 4653 else if (hvtype == SVt_PVAV) { /* array element */
4654 if (PL_op->op_flags & OPf_SPECIAL) {
4655 while (++MARK <= SP) {
502c6561 4656 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
6d822dc4
MS		 4657 *MARK = sv ? sv : &PL_sv_undef;
4658 }
4659 }
01020589
GS		 4660 }
4661 else
4662 DIE(aTHX_ "Not a HASH reference");
54310121 4663 if (discard)
4664 SP = ORIGMARK;
4665 else if (gimme == G_SCALAR) {
5f05dabc 4666 MARK = ORIGMARK;
9111c9c0
DM		 4667 if (SP > MARK)
4668 *++MARK = *SP;
4669 else
4670 *++MARK = &PL_sv_undef;
5f05dabc 4671 SP = MARK;
4672 }
4673 }
4674 else {
4675 SV *keysv = POPs;
85fbaab2 4676 HV * const hv = MUTABLE_HV(POPs);
295d248e 4677 SV *sv = NULL;
97fcbf96
MB		 4678 if (SvTYPE(hv) == SVt_PVHV)
4679 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 4680 else if (SvTYPE(hv) == SVt_PVAV) {
4681 if (PL_op->op_flags & OPf_SPECIAL)
502c6561 4682 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
af288a60
HS		 4683 else
4684 DIE(aTHX_ "panic: avhv_delete no longer supported");
01020589 4685 }
97fcbf96 4686 else
cea2e8a9 4687 DIE(aTHX_ "Not a HASH reference");
5f05dabc 4688 if (!sv)
3280af22 4689 sv = &PL_sv_undef;
54310121 4690 if (!discard)
4691 PUSHs(sv);
79072805 4692 }
79072805
LW		 4693 RETURN;
4694}
4695
a0d0e21e 4696PP(pp_exists)
79072805 4697{
97aff369 4698 dVAR;
39644a26 4699 dSP;
afebc493
GS		 4700 SV *tmpsv;
4701 HV *hv;
4702
c7e88ff3 4703 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
afebc493 4704 GV *gv;
0bd48802 4705 SV * const sv = POPs;
f2c0649b 4706 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
afebc493
GS		 4707 if (cv)
4708 RETPUSHYES;
4709 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4710 RETPUSHYES;
4711 RETPUSHNO;
4712 }
4713 tmpsv = POPs;
85fbaab2 4714 hv = MUTABLE_HV(POPs);
c7e88ff3 4715 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
ae77835f 4716 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 4717 RETPUSHYES;
ef54e1a4
JH		 4718 }
4719 else if (SvTYPE(hv) == SVt_PVAV) {
01020589 4720 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
502c6561 4721 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
01020589
GS		 4722 RETPUSHYES;
4723 }
ef54e1a4
JH		 4724 }
4725 else {
cea2e8a9 4726 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 4727 }
a0d0e21e
LW		 4728 RETPUSHNO;
4729}
79072805 4730
a0d0e21e
LW		 4731PP(pp_hslice)
4732{
97aff369 4733 dVAR; dSP; dMARK; dORIGMARK;
eb578fdb
KW		 4734 HV * const hv = MUTABLE_HV(POPs);
4735 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
1b6737cc 4736 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
d30e492c 4737 bool can_preserve = FALSE;
79072805 4738
eb85dfd3
DM		 4739 if (localizing) {
4740 MAGIC *mg;
4741 HV *stash;
4742
2c5f48c2 4743 if (SvCANEXISTDELETE(hv))
d30e492c 4744 can_preserve = TRUE;
eb85dfd3
DM		 4745 }
4746
6d822dc4 4747 while (++MARK <= SP) {
1b6737cc 4748 SV * const keysv = *MARK;
6d822dc4
MS		 4749 SV **svp;
4750 HE *he;
d30e492c
VP		 4751 bool preeminent = TRUE;
4752
4753 if (localizing && can_preserve) {
4754 /* If we can determine whether the element exist,
4755 * try to preserve the existenceness of a tied hash
4756 * element by using EXISTS and DELETE if possible.
4757 * Fallback to FETCH and STORE otherwise. */
4758 preeminent = hv_exists_ent(hv, keysv, 0);
6d822dc4 4759 }
eb85dfd3 4760
6d822dc4 4761 he = hv_fetch_ent(hv, keysv, lval, 0);
fe5bfecd 4762 svp = he ? &HeVAL(he) : NULL;
eb85dfd3 4763
6d822dc4 4764 if (lval) {
746f6409 4765 if (!svp || !*svp || *svp == &PL_sv_undef) {
be2597df 4766 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6d822dc4
MS		 4767 }
4768 if (localizing) {
7a2e501a 4769 if (HvNAME_get(hv) && isGV(*svp))
159b6efe 4770 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
47cfc530
VP		 4771 else if (preeminent)
4772 save_helem_flags(hv, keysv, svp,
4773 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4774 else
4775 SAVEHDELETE(hv, keysv);
6d822dc4
MS		 4776 }
4777 }
746f6409 4778 *MARK = svp && *svp ? *svp : &PL_sv_undef;
79072805 4779 }
a0d0e21e
LW		 4780 if (GIMME != G_ARRAY) {
4781 MARK = ORIGMARK;
04ab2c87 4782 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
a0d0e21e 4783 SP = MARK;
79072805 4784 }
a0d0e21e
LW		 4785 RETURN;
4786}
4787
5cae3edb
RZ		 4788PP(pp_kvhslice)
4789{
21671fea 4790 dVAR; dSP; dMARK;
5cae3edb
RZ		 4791 HV * const hv = MUTABLE_HV(POPs);
4792 I32 lval = (PL_op->op_flags & OPf_MOD);
adad97db 4793 SSize_t items = SP - MARK;
5cae3edb
RZ		 4794
4795 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4796 const I32 flags = is_lvalue_sub();
4797 if (flags) {
4798 if (!(flags & OPpENTERSUB_INARGS))
7aae0299 4799 /* diag_listed_as: Can't modify %s in %s */
5cae3edb
RZ		 4800 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
4801 lval = flags;
4802 }
4803 }
4804
4805 MEXTEND(SP,items);
4806 while (items > 1) {
4807 *(MARK+items*2-1) = *(MARK+items);
4808 items--;
4809 }
4810 items = SP-MARK;
4811 SP += items;
4812
4813 while (++MARK <= SP) {
4814 SV * const keysv = *MARK;
4815 SV **svp;
4816 HE *he;
4817
4818 he = hv_fetch_ent(hv, keysv, lval, 0);
4819 svp = he ? &HeVAL(he) : NULL;
4820
4821 if (lval) {
4822 if (!svp || !*svp || *svp == &PL_sv_undef) {
4823 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4824 }
4825 *MARK = sv_mortalcopy(*MARK);
4826 }
4827 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
4828 }
4829 if (GIMME != G_ARRAY) {
4830 MARK = SP - items*2;
4831 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4832 SP = MARK;
4833 }
4834 RETURN;
4835}
4836
a0d0e21e
LW		 4837/* List operators. */
4838
4839PP(pp_list)
4840{
97aff369 4841 dVAR; dSP; dMARK;
a0d0e21e
LW		 4842 if (GIMME != G_ARRAY) {
4843 if (++MARK <= SP)
4844 *MARK = *SP; /* unwanted list, return last item */
8990e307 4845 else
3280af22 4846 *MARK = &PL_sv_undef;
a0d0e21e 4847 SP = MARK;
79072805 4848 }
a0d0e21e 4849 RETURN;
79072805
LW		 4850}
4851
a0d0e21e 4852PP(pp_lslice)
79072805 4853{
97aff369 4854 dVAR;
39644a26 4855 dSP;
1b6737cc
AL		 4856 SV ** const lastrelem = PL_stack_sp;
4857 SV ** const lastlelem = PL_stack_base + POPMARK;
4858 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
eb578fdb 4859 SV ** const firstrelem = lastlelem + 1;
42e73ed0 4860 I32 is_something_there = FALSE;
706a6ebc 4861 const U8 mod = PL_op->op_flags & OPf_MOD;
1b6737cc 4862
eb578fdb
KW		 4863 const I32 max = lastrelem - lastlelem;
4864 SV **lelem;
a0d0e21e
LW		 4865
4866 if (GIMME != G_ARRAY) {
4ea561bc 4867 I32 ix = SvIV(*lastlelem);
748a9306
LW		 4868 if (ix < 0)
4869 ix += max;
a0d0e21e 4870 if (ix < 0 || ix >= max)
3280af22 4871 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 4872 else
4873 *firstlelem = firstrelem[ix];
4874 SP = firstlelem;
4875 RETURN;
4876 }
4877
4878 if (max == 0) {
4879 SP = firstlelem - 1;
4880 RETURN;
4881 }
4882
4883 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4ea561bc 4884 I32 ix = SvIV(*lelem);
c73bf8e3 4885 if (ix < 0)
a0d0e21e 4886 ix += max;
c73bf8e3
HS		 4887 if (ix < 0 || ix >= max)
4888 *lelem = &PL_sv_undef;
4889 else {
4890 is_something_there = TRUE;
4891 if (!(*lelem = firstrelem[ix]))
3280af22 4892 *lelem = &PL_sv_undef;
706a6ebc
FC		 4893 else if (mod && SvPADTMP(*lelem) && !IS_PADGV(*lelem))
4894 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
748a9306 4895 }
79072805 4896 }
4633a7c4
LW		 4897 if (is_something_there)
4898 SP = lastlelem;
4899 else
4900 SP = firstlelem - 1;
79072805
LW		 4901 RETURN;
4902}
4903
a0d0e21e
LW		 4904PP(pp_anonlist)
4905{
31476221 4906 dVAR; dSP; dMARK;
1b6737cc 4907 const I32 items = SP - MARK;
ad64d0ec 4908 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
31476221 4909 SP = MARK;
6e449a3a
MHM		 4910 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4911 ? newRV_noinc(av) : av);
a0d0e21e
LW		 4912 RETURN;
4913}
4914
4915PP(pp_anonhash)
79072805 4916{
97aff369 4917 dVAR; dSP; dMARK; dORIGMARK;
67e67fd7 4918 HV* const hv = newHV();
8d455b9f 4919 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
67e67fd7 4920 ? newRV_noinc(MUTABLE_SV(hv))
8d455b9f 4921 : MUTABLE_SV(hv) );
a0d0e21e
LW		 4922
4923 while (MARK < SP) {
3ed356df
FC		 4924 SV * const key =
4925 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
4926 SV *val;
a0d0e21e 4927 if (MARK < SP)
3ed356df
FC		 4928 {
4929 MARK++;
4930 SvGETMAGIC(*MARK);
4931 val = newSV(0);
4932 sv_setsv(val, *MARK);
4933 }
a2a5de95 4934 else
3ed356df 4935 {
a2a5de95 4936 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3ed356df
FC		 4937 val = newSV(0);
4938 }
f12c7020 4939 (void)hv_store_ent(hv,key,val,0);
79072805 4940 }
a0d0e21e 4941 SP = ORIGMARK;
8d455b9f 4942 XPUSHs(retval);
79072805
LW		 4943 RETURN;
4944}
4945
d4fc4415
FC		 4946static AV *
4947S_deref_plain_array(pTHX_ AV *ary)
4948{
4949 if (SvTYPE(ary) == SVt_PVAV) return ary;
d2d95e13 4950 SvGETMAGIC((SV *)ary);
d4fc4415
FC		 4951 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4952 Perl_die(aTHX_ "Not an ARRAY reference");
4953 else if (SvOBJECT(SvRV(ary)))
4954 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4955 return (AV *)SvRV(ary);
4956}
4957
4958#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4959# define DEREF_PLAIN_ARRAY(ary) \
4960 ({ \
4961 AV *aRrRay = ary; \
4962 SvTYPE(aRrRay) == SVt_PVAV \
4963 ? aRrRay \
4964 : S_deref_plain_array(aTHX_ aRrRay); \
4965 })
4966#else
4967# define DEREF_PLAIN_ARRAY(ary) \
4968 ( \
3b0f6d32 4969 PL_Sv = (SV *)(ary), \
d4fc4415
FC		 4970 SvTYPE(PL_Sv) == SVt_PVAV \
4971 ? (AV *)PL_Sv \
3b0f6d32 4972 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
d4fc4415
FC		 4973 )
4974#endif
4975
a0d0e21e 4976PP(pp_splice)
79072805 4977{
27da23d5 4978 dVAR; dSP; dMARK; dORIGMARK;
5cd408a2 4979 int num_args = (SP - MARK);
eb578fdb
KW		 4980 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4981 SV **src;
4982 SV **dst;
c70927a6
FC		 4983 SSize_t i;
4984 SSize_t offset;
4985 SSize_t length;
4986 SSize_t newlen;
4987 SSize_t after;
4988 SSize_t diff;
ad64d0ec 4989 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 4990
1b6737cc 4991 if (mg) {
3e0cb5de 4992 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
af71faff
NC		 4993 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4994 sp - mark);
93965878 4995 }
79072805 4996
a0d0e21e 4997 SP++;
79072805 4998
a0d0e21e 4999 if (++MARK < SP) {
4ea561bc 5000 offset = i = SvIV(*MARK);
a0d0e21e 5001 if (offset < 0)
93965878 5002 offset += AvFILLp(ary) + 1;
84902520 5003 if (offset < 0)
cea2e8a9 5004 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 5005 if (++MARK < SP) {
5006 length = SvIVx(*MARK++);
48cdf507
GA		 5007 if (length < 0) {
5008 length += AvFILLp(ary) - offset + 1;
5009 if (length < 0)
5010 length = 0;
5011 }
79072805
LW		 5012 }
5013 else
a0d0e21e 5014 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 5015 }
a0d0e21e
LW		 5016 else {
5017 offset = 0;
5018 length = AvMAX(ary) + 1;
5019 }
8cbc2e3b 5020 if (offset > AvFILLp(ary) + 1) {
5cd408a2
EB		 5021 if (num_args > 2)
5022 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
93965878 5023 offset = AvFILLp(ary) + 1;
8cbc2e3b 5024 }
93965878 5025 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 5026 if (after < 0) { /* not that much array */
5027 length += after; /* offset+length now in array */
5028 after = 0;
5029 if (!AvALLOC(ary))
5030 av_extend(ary, 0);
5031 }
5032
5033 /* At this point, MARK .. SP-1 is our new LIST */
5034
5035 newlen = SP - MARK;
5036 diff = newlen - length;
13d7cbc1
GS		 5037 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5038 av_reify(ary);
a0d0e21e 5039
50528de0
WL		 5040 /* make new elements SVs now: avoid problems if they're from the array */
5041 for (dst = MARK, i = newlen; i; i--) {
1b6737cc 5042 SV * const h = *dst;
f2b990bf 5043 *dst++ = newSVsv(h);
50528de0
WL		 5044 }
5045
a0d0e21e 5046 if (diff < 0) { /* shrinking the area */
95b63a38 5047 SV **tmparyval = NULL;
a0d0e21e 5048 if (newlen) {
a02a5408 5049 Newx(tmparyval, newlen, SV*); /* so remember insertion */
a0d0e21e 5050 Copy(MARK, tmparyval, newlen, SV*);
79072805 5051 }
a0d0e21e
LW		 5052
5053 MARK = ORIGMARK + 1;
5054 if (GIMME == G_ARRAY) { /* copy return vals to stack */
31c61add 5055 const bool real = cBOOL(AvREAL(ary));
a0d0e21e 5056 MEXTEND(MARK, length);
31c61add 5057 if (real)
bbce6d69 5058 EXTEND_MORTAL(length);
31c61add
FC		 5059 for (i = 0, dst = MARK; i < length; i++) {
5060 if ((*dst = AvARRAY(ary)[i+offset])) {
5061 if (real)
486ec47a 5062 sv_2mortal(*dst); /* free them eventually */
36477c24 5063 }
31c61add
FC		 5064 else
5065 *dst = &PL_sv_undef;
5066 dst++;
a0d0e21e
LW		 5067 }
5068 MARK += length - 1;
79072805 5069 }
a0d0e21e
LW		 5070 else {
5071 *MARK = AvARRAY(ary)[offset+length-1];
5072 if (AvREAL(ary)) {
d689ffdd 5073 sv_2mortal(*MARK);
a0d0e21e
LW		 5074 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5075 SvREFCNT_dec(*dst++); /* free them now */
79072805 5076 }
a0d0e21e 5077 }
93965878 5078 AvFILLp(ary) += diff;
a0d0e21e
LW		 5079
5080 /* pull up or down? */
5081
5082 if (offset < after) { /* easier to pull up */
5083 if (offset) { /* esp. if nothing to pull */
5084 src = &AvARRAY(ary)[offset-1];
5085 dst = src - diff; /* diff is negative */
5086 for (i = offset; i > 0; i--) /* can't trust Copy */
5087 *dst-- = *src--;
79072805 5088 }
a0d0e21e 5089 dst = AvARRAY(ary);
9c6bc640 5090 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
a0d0e21e
LW		 5091 AvMAX(ary) += diff;
5092 }
5093 else {
5094 if (after) { /* anything to pull down? */
5095 src = AvARRAY(ary) + offset + length;
5096 dst = src + diff; /* diff is negative */
5097 Move(src, dst, after, SV*);
79072805 5098 }
93965878 5099 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 5100 /* avoid later double free */
5101 }
5102 i = -diff;
5103 while (i)
ce0d59fd 5104 dst[--i] = NULL;
a0d0e21e
LW		 5105
5106 if (newlen) {
50528de0 5107 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e
LW		 5108 Safefree(tmparyval);
5109 }
5110 }
5111 else { /* no, expanding (or same) */
d3961450 5112 SV** tmparyval = NULL;
a0d0e21e 5113 if (length) {
a02a5408 5114 Newx(tmparyval, length, SV*); /* so remember deletion */
a0d0e21e
LW		 5115 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5116 }
5117
5118 if (diff > 0) { /* expanding */
a0d0e21e 5119 /* push up or down? */
a0d0e21e
LW		 5120 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5121 if (offset) {
5122 src = AvARRAY(ary);
5123 dst = src - diff;
5124 Move(src, dst, offset, SV*);
79072805 5125 }
9c6bc640 5126 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
a0d0e21e 5127 AvMAX(ary) += diff;
93965878 5128 AvFILLp(ary) += diff;
79072805
LW		 5129 }
5130 else {
93965878
NIS		 5131 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5132 av_extend(ary, AvFILLp(ary) + diff);
5133 AvFILLp(ary) += diff;
a0d0e21e
LW		 5134
5135 if (after) {
93965878 5136 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 5137 src = dst - diff;
5138 for (i = after; i; i--) {
5139 *dst-- = *src--;
5140 }
79072805
LW		 5141 }
5142 }
a0d0e21e
LW		 5143 }
5144
50528de0
WL		 5145 if (newlen) {
5146 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
a0d0e21e 5147 }
50528de0 5148
a0d0e21e
LW		 5149 MARK = ORIGMARK + 1;
5150 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5151 if (length) {
31c61add
FC		 5152 const bool real = cBOOL(AvREAL(ary));
5153 if (real)
bbce6d69 5154 EXTEND_MORTAL(length);
31c61add
FC		 5155 for (i = 0, dst = MARK; i < length; i++) {
5156 if ((*dst = tmparyval[i])) {
5157 if (real)
486ec47a 5158 sv_2mortal(*dst); /* free them eventually */
36477c24 5159 }
31c61add
FC		 5160 else *dst = &PL_sv_undef;
5161 dst++;
79072805
LW		 5162 }
5163 }
a0d0e21e
LW		 5164 MARK += length - 1;
5165 }
5166 else if (length--) {
5167 *MARK = tmparyval[length];
5168 if (AvREAL(ary)) {
d689ffdd 5169 sv_2mortal(*MARK);
a0d0e21e
LW		 5170 while (length-- > 0)
5171 SvREFCNT_dec(tmparyval[length]);
79072805 5172 }
79072805 5173 }
a0d0e21e 5174 else
3280af22 5175 *MARK = &PL_sv_undef;
d3961450 5176 Safefree(tmparyval);
79072805 5177 }
474af990
FR		 5178
5179 if (SvMAGICAL(ary))
5180 mg_set(MUTABLE_SV(ary));
5181
a0d0e21e 5182 SP = MARK;
79072805
LW		 5183 RETURN;
5184}
5185
a0d0e21e 5186PP(pp_push)
79072805 5187{
27da23d5 5188 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5189 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5190 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
79072805 5191
1b6737cc 5192 if (mg) {
ad64d0ec 5193 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
93965878
NIS		 5194 PUSHMARK(MARK);
5195 PUTBACK;
d343c3ef 5196 ENTER_with_name("call_PUSH");
3e0cb5de 5197 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5198 LEAVE_with_name("call_PUSH");
93965878 5199 SPAGAIN;
93965878 5200 }
a60c0954 5201 else {
cb077ed2 5202 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
89c14e2e 5203 PL_delaymagic = DM_DELAY;
a60c0954 5204 for (++MARK; MARK <= SP; MARK++) {
3ed356df
FC		 5205 SV *sv;
5206 if (*MARK) SvGETMAGIC(*MARK);
5207 sv = newSV(0);
a60c0954 5208 if (*MARK)
3ed356df 5209 sv_setsv_nomg(sv, *MARK);
0a75904b 5210 av_store(ary, AvFILLp(ary)+1, sv);
a60c0954 5211 }
354b0578 5212 if (PL_delaymagic & DM_ARRAY_ISA)
ad64d0ec 5213 mg_set(MUTABLE_SV(ary));
89c14e2e
BB		 5214
5215 PL_delaymagic = 0;
6eeabd23
VP		 5216 }
5217 SP = ORIGMARK;
5218 if (OP_GIMME(PL_op, 0) != G_VOID) {
5219 PUSHi( AvFILL(ary) + 1 );
79072805 5220 }
79072805
LW		 5221 RETURN;
5222}
5223
a0d0e21e 5224PP(pp_shift)
79072805 5225{
97aff369 5226 dVAR;
39644a26 5227 dSP;
538f5756 5228 AV * const av = PL_op->op_flags & OPf_SPECIAL
d4fc4415 5229 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
789b4bc9 5230 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
79072805 5231 EXTEND(SP, 1);
c2b4a044 5232 assert (sv);
d689ffdd 5233 if (AvREAL(av))
a0d0e21e
LW		 5234 (void)sv_2mortal(sv);
5235 PUSHs(sv);
79072805 5236 RETURN;
79072805
LW		 5237}
5238
a0d0e21e 5239PP(pp_unshift)
79072805 5240{
27da23d5 5241 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
eb578fdb 5242 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
ad64d0ec 5243 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
93965878 5244
1b6737cc 5245 if (mg) {
ad64d0ec 5246 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
7fd66d9d 5247 PUSHMARK(MARK);
93965878 5248 PUTBACK;
d343c3ef 5249 ENTER_with_name("call_UNSHIFT");
36925d9e 5250 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5251 LEAVE_with_name("call_UNSHIFT");
93965878 5252 SPAGAIN;
93965878 5253 }
a60c0954 5254 else {
c70927a6 5255 SSize_t i = 0;
a60c0954
NIS		 5256 av_unshift(ary, SP - MARK);
5257 while (MARK < SP) {
1b6737cc 5258 SV * const sv = newSVsv(*++MARK);
a60c0954
NIS		 5259 (void)av_store(ary, i++, sv);
5260 }
79072805 5261 }
a0d0e21e 5262 SP = ORIGMARK;
6eeabd23 5263 if (OP_GIMME(PL_op, 0) != G_VOID) {
5658d0a9
LR		 5264 PUSHi( AvFILL(ary) + 1 );
5265 }
79072805 5266 RETURN;
79072805
LW		 5267}
5268
a0d0e21e 5269PP(pp_reverse)
79072805 5270{
97aff369 5271 dVAR; dSP; dMARK;
79072805 5272
a0d0e21e 5273 if (GIMME == G_ARRAY) {
484c818f
VP		 5274 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5275 AV *av;
5276
5277 /* See pp_sort() */
5278 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5279 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5280 av = MUTABLE_AV((*SP));
5281 /* In-place reversing only happens in void context for the array
5282 * assignment. We don't need to push anything on the stack. */
5283 SP = MARK;
5284
5285 if (SvMAGICAL(av)) {
c70927a6 5286 SSize_t i, j;
eb578fdb 5287 SV *tmp = sv_newmortal();
484c818f
VP		 5288 /* For SvCANEXISTDELETE */
5289 HV *stash;
5290 const MAGIC *mg;
5291 bool can_preserve = SvCANEXISTDELETE(av);
5292
5293 for (i = 0, j = av_len(av); i < j; ++i, --j) {
eb578fdb 5294 SV *begin, *end;
484c818f
VP		 5295
5296 if (can_preserve) {
5297 if (!av_exists(av, i)) {
5298 if (av_exists(av, j)) {
eb578fdb 5299 SV *sv = av_delete(av, j, 0);
484c818f
VP		 5300 begin = *av_fetch(av, i, TRUE);
5301 sv_setsv_mg(begin, sv);
5302 }
5303 continue;
5304 }
5305 else if (!av_exists(av, j)) {
eb578fdb 5306 SV *sv = av_delete(av, i, 0);
484c818f
VP		 5307 end = *av_fetch(av, j, TRUE);
5308 sv_setsv_mg(end, sv);
5309 continue;
5310 }
5311 }
5312
5313 begin = *av_fetch(av, i, TRUE);
5314 end = *av_fetch(av, j, TRUE);
5315 sv_setsv(tmp, begin);
5316 sv_setsv_mg(begin, end);
5317 sv_setsv_mg(end, tmp);
5318 }
5319 }
5320 else {
5321 SV **begin = AvARRAY(av);
484c818f 5322
95a26d8e
VP		 5323 if (begin) {
5324 SV **end = begin + AvFILLp(av);
5325
5326 while (begin < end) {
eb578fdb 5327 SV * const tmp = *begin;
95a26d8e
VP		 5328 *begin++ = *end;
5329 *end-- = tmp;
5330 }
484c818f
VP		 5331 }
5332 }
5333 }
5334 else {
5335 SV **oldsp = SP;
5336 MARK++;
5337 while (MARK < SP) {
eb578fdb 5338 SV * const tmp = *MARK;
484c818f
VP		 5339 *MARK++ = *SP;
5340 *SP-- = tmp;
5341 }
5342 /* safe as long as stack cannot get extended in the above */
5343 SP = oldsp;
a0d0e21e 5344 }
79072805
LW		 5345 }
5346 else {
eb578fdb
KW		 5347 char *up;
5348 char *down;
5349 I32 tmp;
a0d0e21e
LW		 5350 dTARGET;
5351 STRLEN len;
79072805 5352
7e2040f0 5353 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 5354 if (SP - MARK > 1)
3280af22 5355 do_join(TARG, &PL_sv_no, MARK, SP);
1e21d011 5356 else {
789bd863 5357 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
1e21d011
B		 5358 }
5359
a0d0e21e
LW		 5360 up = SvPV_force(TARG, len);
5361 if (len > 1) {
7e2040f0 5362 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55 5363 U8* s = (U8*)SvPVX(TARG);
349d4f2f 5364 const U8* send = (U8*)(s + len);
a0ed51b3 5365 while (s < send) {
d742c382 5366 if (UTF8_IS_INVARIANT(*s)) {
a0ed51b3
LW		 5367 s++;
5368 continue;
5369 }
5370 else {
4b88fb76 5371 if (!utf8_to_uvchr_buf(s, send, 0))
a0dbb045 5372 break;
dfe13c55 5373 up = (char*)s;
a0ed51b3 5374 s += UTF8SKIP(s);
dfe13c55 5375 down = (char*)(s - 1);
a0dbb045 5376 /* reverse this character */
a0ed51b3
LW		 5377 while (down > up) {
5378 tmp = *up;
5379 *up++ = *down;
eb160463 5380 *down-- = (char)tmp;
a0ed51b3
LW		 5381 }
5382 }
5383 }
5384 up = SvPVX(TARG);
5385 }
a0d0e21e
LW		 5386 down = SvPVX(TARG) + len - 1;
5387 while (down > up) {
5388 tmp = *up;
5389 *up++ = *down;
eb160463 5390 *down-- = (char)tmp;
a0d0e21e 5391 }
3aa33fe5 5392 (void)SvPOK_only_UTF8(TARG);
79072805 5393 }
a0d0e21e
LW		 5394 SP = MARK + 1;
5395 SETTARG;
79072805 5396 }
a0d0e21e 5397 RETURN;
79072805
LW		 5398}
5399
a0d0e21e 5400PP(pp_split)
79072805 5401{
27da23d5 5402 dVAR; dSP; dTARG;
a0d0e21e 5403 AV *ary;
eb578fdb 5404 IV limit = POPi; /* note, negative is forever */
1b6737cc 5405 SV * const sv = POPs;
a0d0e21e 5406 STRLEN len;
eb578fdb 5407 const char *s = SvPV_const(sv, len);
1b6737cc 5408 const bool do_utf8 = DO_UTF8(sv);
727b7506 5409 const char *strend = s + len;
eb578fdb
KW		 5410 PMOP *pm;
5411 REGEXP *rx;
5412 SV *dstr;
5413 const char *m;
c70927a6 5414 SSize_t iters = 0;
d14578b8
KW		 5415 const STRLEN slen = do_utf8
5416 ? utf8_length((U8*)s, (U8*)strend)
5417 : (STRLEN)(strend - s);
c70927a6 5418 SSize_t maxiters = slen + 10;
c1a7495a 5419 I32 trailing_empty = 0;
727b7506 5420 const char *orig;
1b6737cc 5421 const I32 origlimit = limit;
a0d0e21e
LW		 5422 I32 realarray = 0;
5423 I32 base;
f54cb97a 5424 const I32 gimme = GIMME_V;
941446f6 5425 bool gimme_scalar;
f54cb97a 5426 const I32 oldsave = PL_savestack_ix;
437d3b4e 5427 U32 make_mortal = SVs_TEMP;
7fba1cd6 5428 bool multiline = 0;
b37c2d43 5429 MAGIC *mg = NULL;
79072805 5430
44a8e56a 5431#ifdef DEBUGGING
5432 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5433#else
5434 pm = (PMOP*)POPs;
5435#endif
a0d0e21e 5436 if (!pm || !s)
5637ef5b 5437 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
aaa362c4 5438 rx = PM_GETRE(pm);
bbce6d69 5439
a62b1201 5440 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
dbc200c5 5441 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
bbce6d69 5442
971a9dd3 5443#ifdef USE_ITHREADS
20e98b0f 5444 if (pm->op_pmreplrootu.op_pmtargetoff) {
159b6efe 5445 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
20e98b0f 5446 }
971a9dd3 5447#else
20e98b0f
NC		 5448 if (pm->op_pmreplrootu.op_pmtargetgv) {
5449 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
971a9dd3 5450 }
20e98b0f 5451#endif
79072805 5452 else
7d49f689 5453 ary = NULL;
bcea25a7 5454 if (ary) {
a0d0e21e 5455 realarray = 1;
8ec5e241 5456 PUTBACK;
a0d0e21e
LW		 5457 av_extend(ary,0);
5458 av_clear(ary);
8ec5e241 5459 SPAGAIN;
ad64d0ec 5460 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
8ec5e241 5461 PUSHMARK(SP);
ad64d0ec 5462 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
8ec5e241
NIS		 5463 }
5464 else {
1c0b011c 5465 if (!AvREAL(ary)) {
1b6737cc 5466 I32 i;
1c0b011c 5467 AvREAL_on(ary);
abff13bb 5468 AvREIFY_off(ary);
1c0b011c 5469 for (i = AvFILLp(ary); i >= 0; i--)
d14578b8 5470 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 5471 }
5472 /* temporarily switch stacks */
8b7059b1 5473 SAVESWITCHSTACK(PL_curstack, ary);
8ec5e241 5474 make_mortal = 0;
1c0b011c 5475 }
79072805 5476 }
3280af22 5477 base = SP - PL_stack_base;
a0d0e21e 5478 orig = s;
dbc200c5 5479 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
613f191e 5480 if (do_utf8) {
76a77b1b 5481 while (isSPACE_utf8(s))
613f191e
TS		 5482 s += UTF8SKIP(s);
5483 }
a62b1201 5484 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
bbce6d69 5485 while (isSPACE_LC(*s))
5486 s++;
5487 }
5488 else {
5489 while (isSPACE(*s))
5490 s++;
5491 }
a0d0e21e 5492 }
73134a2e 5493 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
7fba1cd6 5494 multiline = 1;
c07a80fd 5495 }
5496
941446f6
FC		 5497 gimme_scalar = gimme == G_SCALAR && !ary;
5498
a0d0e21e
LW		 5499 if (!limit)
5500 limit = maxiters + 2;
dbc200c5 5501 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
a0d0e21e 5502 while (--limit) {
bbce6d69 5503 m = s;
8727f688
YO		 5504 /* this one uses 'm' and is a negative test */
5505 if (do_utf8) {
76a77b1b 5506 while (m < strend && ! isSPACE_utf8(m) ) {
613f191e 5507 const int t = UTF8SKIP(m);
76a77b1b 5508 /* isSPACE_utf8 returns FALSE for malform utf8 */
613f191e
TS		 5509 if (strend - m < t)
5510 m = strend;
5511 else
5512 m += t;
5513 }
a62b1201 5514 }
d14578b8
KW		 5515 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5516 {
8727f688
YO		 5517 while (m < strend && !isSPACE_LC(*m))
5518 ++m;
5519 } else {
5520 while (m < strend && !isSPACE(*m))
5521 ++m;
5522 }
a0d0e21e
LW		 5523 if (m >= strend)
5524 break;
bbce6d69 5525
c1a7495a
BB		 5526 if (gimme_scalar) {
5527 iters++;
5528 if (m-s == 0)
5529 trailing_empty++;
5530 else
5531 trailing_empty = 0;
5532 } else {
5533 dstr = newSVpvn_flags(s, m-s,
5534 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5535 XPUSHs(dstr);
5536 }
bbce6d69 5537
613f191e
TS		 5538 /* skip the whitespace found last */
5539 if (do_utf8)
5540 s = m + UTF8SKIP(m);
5541 else
5542 s = m + 1;
5543
8727f688
YO		 5544 /* this one uses 's' and is a positive test */
5545 if (do_utf8) {
76a77b1b 5546 while (s < strend && isSPACE_utf8(s) )
8727f688 5547 s += UTF8SKIP(s);
a62b1201 5548 }
d14578b8
KW		 5549 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5550 {
8727f688
YO		 5551 while (s < strend && isSPACE_LC(*s))
5552 ++s;
5553 } else {
5554 while (s < strend && isSPACE(*s))
5555 ++s;
5556 }
79072805
LW		 5557 }
5558 }
07bc277f 5559 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
a0d0e21e 5560 while (--limit) {
a6e20a40
AL		 5561 for (m = s; m < strend && *m != '\n'; m++)
5562 ;
a0d0e21e
LW		 5563 m++;
5564 if (m >= strend)
5565 break;
c1a7495a
BB		 5566
5567 if (gimme_scalar) {
5568 iters++;
5569 if (m-s == 0)
5570 trailing_empty++;
5571 else
5572 trailing_empty = 0;
5573 } else {
5574 dstr = newSVpvn_flags(s, m-s,
5575 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5576 XPUSHs(dstr);
5577 }
a0d0e21e
LW		 5578 s = m;
5579 }
5580 }
07bc277f 5581 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
640f820d
AB		 5582 /*
5583 Pre-extend the stack, either the number of bytes or
5584 characters in the string or a limited amount, triggered by:
5585
5586 my ($x, $y) = split //, $str;
5587 or
5588 split //, $str, $i;
5589 */
c1a7495a
BB		 5590 if (!gimme_scalar) {
5591 const U32 items = limit - 1;
5592 if (items < slen)
5593 EXTEND(SP, items);
5594 else
5595 EXTEND(SP, slen);
5596 }
640f820d 5597
e9515b0f
AB		 5598 if (do_utf8) {
5599 while (--limit) {
5600 /* keep track of how many bytes we skip over */
5601 m = s;
640f820d 5602 s += UTF8SKIP(s);
c1a7495a
BB		 5603 if (gimme_scalar) {
5604 iters++;
5605 if (s-m == 0)
5606 trailing_empty++;
5607 else
5608 trailing_empty = 0;
5609 } else {
5610 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
640f820d 5611
c1a7495a
BB		 5612 PUSHs(dstr);
5613 }
640f820d 5614
e9515b0f
AB		 5615 if (s >= strend)
5616 break;
5617 }
5618 } else {
5619 while (--limit) {
c1a7495a
BB		 5620 if (gimme_scalar) {
5621 iters++;
5622 } else {
5623 dstr = newSVpvn(s, 1);
e9515b0f 5624
e9515b0f 5625
c1a7495a
BB		 5626 if (make_mortal)
5627 sv_2mortal(dstr);
640f820d 5628
c1a7495a
BB		 5629 PUSHs(dstr);
5630 }
5631
5632 s++;
e9515b0f
AB		 5633
5634 if (s >= strend)
5635 break;
5636 }
640f820d
AB		 5637 }
5638 }
3c8556c3 5639 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
07bc277f
NC		 5640 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5641 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5642 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5643 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
f9f4320a 5644 SV * const csv = CALLREG_INTUIT_STRING(rx);
cf93c79d 5645
07bc277f 5646 len = RX_MINLENRET(rx);
3c8556c3 5647 if (len == 1 && !RX_UTF8(rx) && !tail) {
1b6737cc 5648 const char c = *SvPV_nolen_const(csv);
a0d0e21e 5649 while (--limit) {
a6e20a40
AL		 5650 for (m = s; m < strend && *m != c; m++)
5651 ;
a0d0e21e
LW		 5652 if (m >= strend)
5653 break;
c1a7495a
BB		 5654 if (gimme_scalar) {
5655 iters++;
5656 if (m-s == 0)
5657 trailing_empty++;
5658 else
5659 trailing_empty = 0;
5660 } else {
5661 dstr = newSVpvn_flags(s, m-s,
d14578b8 5662 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5663 XPUSHs(dstr);
5664 }
93f04dac
JH		 5665 /* The rx->minlen is in characters but we want to step
5666 * s ahead by bytes. */
1aa99e6b
IH		 5667 if (do_utf8)
5668 s = (char*)utf8_hop((U8*)m, len);
5669 else
5670 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 5671 }
5672 }
5673 else {
a0d0e21e 5674 while (s < strend && --limit &&
f722798b 5675 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
7fba1cd6 5676 csv, multiline ? FBMrf_MULTILINE : 0)) )
a0d0e21e 5677 {
c1a7495a
BB		 5678 if (gimme_scalar) {
5679 iters++;
5680 if (m-s == 0)
5681 trailing_empty++;
5682 else
5683 trailing_empty = 0;
5684 } else {
5685 dstr = newSVpvn_flags(s, m-s,
d14578b8 5686 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
c1a7495a
BB		 5687 XPUSHs(dstr);
5688 }
93f04dac
JH		 5689 /* The rx->minlen is in characters but we want to step
5690 * s ahead by bytes. */
1aa99e6b
IH		 5691 if (do_utf8)
5692 s = (char*)utf8_hop((U8*)m, len);
5693 else
5694 s = m + len; /* Fake \n at the end */
a0d0e21e 5695 }
463ee0b2 5696 }
463ee0b2 5697 }
a0d0e21e 5698 else {
07bc277f 5699 maxiters += slen * RX_NPARENS(rx);
080c2dec 5700 while (s < strend && --limit)
bbce6d69 5701 {
1b6737cc 5702 I32 rex_return;
080c2dec 5703 PUTBACK;
d14578b8 5704 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
c33e64f0 5705 sv, NULL, 0);
080c2dec 5706 SPAGAIN;
1b6737cc 5707 if (rex_return == 0)
080c2dec 5708 break;
d9f97599 5709 TAINT_IF(RX_MATCH_TAINTED(rx));
6502e081
DM		 5710 /* we never pass the REXEC_COPY_STR flag, so it should
5711 * never get copied */
5712 assert(!RX_MATCH_COPIED(rx));
07bc277f 5713 m = RX_OFFS(rx)[0].start + orig;
c1a7495a
BB		 5714
5715 if (gimme_scalar) {
5716 iters++;
5717 if (m-s == 0)
5718 trailing_empty++;
5719 else
5720 trailing_empty = 0;
5721 } else {
5722 dstr = newSVpvn_flags(s, m-s,
5723 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5724 XPUSHs(dstr);
5725 }
07bc277f 5726 if (RX_NPARENS(rx)) {
1b6737cc 5727 I32 i;
07bc277f
NC		 5728 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5729 s = RX_OFFS(rx)[i].start + orig;
5730 m = RX_OFFS(rx)[i].end + orig;
6de67870
JP		 5731
5732 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5733 parens that didn't match -- they should be set to
5734 undef, not the empty string */
c1a7495a
BB		 5735 if (gimme_scalar) {
5736 iters++;
5737 if (m-s == 0)
5738 trailing_empty++;
5739 else
5740 trailing_empty = 0;
5741 } else {
5742 if (m >= orig && s >= orig) {
5743 dstr = newSVpvn_flags(s, m-s,
5744 (do_utf8 ? SVf_UTF8 : 0)
5745 | make_mortal);
5746 }
5747 else
5748 dstr = &PL_sv_undef; /* undef, not "" */
5749 XPUSHs(dstr);
748a9306 5750 }
c1a7495a 5751
a0d0e21e
LW		 5752 }
5753 }
07bc277f 5754 s = RX_OFFS(rx)[0].end + orig;
a0d0e21e 5755 }
79072805 5756 }
8ec5e241 5757
c1a7495a
BB		 5758 if (!gimme_scalar) {
5759 iters = (SP - PL_stack_base) - base;
5760 }
a0d0e21e 5761 if (iters > maxiters)
cea2e8a9 5762 DIE(aTHX_ "Split loop");
8ec5e241 5763
a0d0e21e
LW		 5764 /* keep field after final delim? */
5765 if (s < strend || (iters && origlimit)) {
c1a7495a
BB		 5766 if (!gimme_scalar) {
5767 const STRLEN l = strend - s;
5768 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5769 XPUSHs(dstr);
5770 }
a0d0e21e 5771 iters++;
79072805 5772 }
a0d0e21e 5773 else if (!origlimit) {
c1a7495a
BB		 5774 if (gimme_scalar) {
5775 iters -= trailing_empty;
5776 } else {
5777 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5778 if (TOPs && !make_mortal)
5779 sv_2mortal(TOPs);
5780 *SP-- = &PL_sv_undef;
5781 iters--;
5782 }
89900bd3 5783 }
a0d0e21e 5784 }
8ec5e241 5785
8b7059b1
DM		 5786 PUTBACK;
5787 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5788 SPAGAIN;
a0d0e21e 5789 if (realarray) {
8ec5e241 5790 if (!mg) {
1c0b011c
NIS		 5791 if (SvSMAGICAL(ary)) {
5792 PUTBACK;
ad64d0ec 5793 mg_set(MUTABLE_SV(ary));
1c0b011c
NIS		 5794 SPAGAIN;
5795 }
5796 if (gimme == G_ARRAY) {
5797 EXTEND(SP, iters);
5798 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5799 SP += iters;
5800 RETURN;
5801 }
8ec5e241 5802 }
1c0b011c 5803 else {
fb73857a 5804 PUTBACK;
d343c3ef 5805 ENTER_with_name("call_PUSH");
36925d9e 5806 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
d343c3ef 5807 LEAVE_with_name("call_PUSH");
fb73857a 5808 SPAGAIN;
8ec5e241 5809 if (gimme == G_ARRAY) {
c70927a6 5810 SSize_t i;
8ec5e241
NIS		 5811 /* EXTEND should not be needed - we just popped them */
5812 EXTEND(SP, iters);
5813 for (i=0; i < iters; i++) {
5814 SV **svp = av_fetch(ary, i, FALSE);
3280af22 5815 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 5816 }
1c0b011c
NIS		 5817 RETURN;
5818 }
a0d0e21e
LW		 5819 }
5820 }
5821 else {
5822 if (gimme == G_ARRAY)
5823 RETURN;
5824 }
7f18b612
YST		 5825
5826 GETTARGET;
5827 PUSHi(iters);
5828 RETURN;
79072805 5829}
85e6fe83 5830
c5917253
NC		 5831PP(pp_once)
5832{
5833 dSP;
5834 SV *const sv = PAD_SVl(PL_op->op_targ);
5835
5836 if (SvPADSTALE(sv)) {
5837 /* First time. */
5838 SvPADSTALE_off(sv);
5839 RETURNOP(cLOGOP->op_other);
5840 }
5841 RETURNOP(cLOGOP->op_next);
5842}
5843
c0329465
MB		 5844PP(pp_lock)
5845{
97aff369 5846 dVAR;
39644a26 5847 dSP;
c0329465 5848 dTOPss;
e55aaa0e 5849 SV *retsv = sv;
68795e93 5850 SvLOCK(sv);
f79aa60b
FC		 5851 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5852 || SvTYPE(retsv) == SVt_PVCV) {
e55aaa0e
MB		 5853 retsv = refto(retsv);
5854 }
5855 SETs(retsv);
c0329465
MB		 5856 RETURN;
5857}
a863c7d1 5858
65bca31a
NC		 5859
5860PP(unimplemented_op)
5861{
97aff369 5862 dVAR;
361ed549
NC		 5863 const Optype op_type = PL_op->op_type;
5864 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5865 with out of range op numbers - it only "special" cases op_custom.
5866 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5867 if we get here for a custom op then that means that the custom op didn't
5868 have an implementation. Given that OP_NAME() looks up the custom op
5869 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5870 registers &PL_unimplemented_op as the address of their custom op.
5871 NULL doesn't generate a useful error message. "custom" does. */
5872 const char *const name = op_type >= OP_max
5873 ? "[out of range]" : PL_op_name[PL_op->op_type];
7627e6d0
NC		 5874 if(OP_IS_SOCKET(op_type))
5875 DIE(aTHX_ PL_no_sock_func, name);
361ed549 5876 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
65bca31a
NC		 5877}
5878
deb8a388
FC		 5879/* For sorting out arguments passed to a &CORE:: subroutine */
5880PP(pp_coreargs)
5881{
5882 dSP;
7fa5bd9b 5883 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
498a02d8 5884 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
7fa5bd9b 5885 AV * const at_ = GvAV(PL_defgv);
0e80230d
FC		 5886 SV **svp = at_ ? AvARRAY(at_) : NULL;
5887 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
7fa5bd9b 5888 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
46e00a91 5889 bool seen_question = 0;
7fa5bd9b 5890 const char *err = NULL;
3e6568b4 5891 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
7fa5bd9b 5892
46e00a91
FC		 5893 /* Count how many args there are first, to get some idea how far to
5894 extend the stack. */
7fa5bd9b 5895 while (oa) {
bf0571fd 5896 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
7fa5bd9b 5897 maxargs++;
46e00a91
FC		 5898 if (oa & OA_OPTIONAL) seen_question = 1;
5899 if (!seen_question) minargs++;
7fa5bd9b
FC		 5900 oa >>= 4;
5901 }
5902
5903 if(numargs < minargs) err = "Not enough";
5904 else if(numargs > maxargs) err = "Too many";
5905 if (err)
5906 /* diag_listed_as: Too many arguments for %s */
5907 Perl_croak(aTHX_
5908 "%s arguments for %s", err,
2a90c7c6 5909 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
7fa5bd9b
FC		 5910 );
5911
5912 /* Reset the stack pointer. Without this, we end up returning our own
5913 arguments in list context, in addition to the values we are supposed
5914 to return. nextstate usually does this on sub entry, but we need
e1fa07e3 5915 to run the next op with the caller's hints, so we cannot have a
7fa5bd9b
FC		 5916 nextstate. */
5917 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5918
46e00a91
FC		 5919 if(!maxargs) RETURN;
5920
bf0571fd
FC		 5921 /* We do this here, rather than with a separate pushmark op, as it has
5922 to come in between two things this function does (stack reset and
5923 arg pushing). This seems the easiest way to do it. */
3e6568b4 5924 if (pushmark) {
bf0571fd
FC		 5925 PUTBACK;
5926 (void)Perl_pp_pushmark(aTHX);
5927 }
5928
5929 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
c931b036 5930 PUTBACK; /* The code below can die in various places. */
46e00a91
FC		 5931
5932 oa = PL_opargs[opnum] >> OASHIFT;
3e6568b4 5933 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
c931b036 5934 whicharg++;
46e00a91
FC		 5935 switch (oa & 7) {
5936 case OA_SCALAR:
1efec5ed 5937 try_defsv:
d6d78e19 5938 if (!numargs && defgv && whicharg == minargs + 1) {
d6d78e19 5939 PUSHs(find_rundefsv2(
db4cf31d 5940 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
b4b0692a 5941 cxstack[cxstack_ix].blk_oldcop->cop_seq
d6d78e19
FC		 5942 ));
5943 }
5944 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
46e00a91 5945 break;
bf0571fd
FC		 5946 case OA_LIST:
5947 while (numargs--) {
5948 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5949 svp++;
5950 }
5951 RETURN;
19c481f4
FC		 5952 case OA_HVREF:
5953 if (!svp || !*svp || !SvROK(*svp)
5954 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5955 DIE(aTHX_
5956 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5957 "Type of arg %d to &CORE::%s must be hash reference",
5958 whicharg, OP_DESC(PL_op->op_next)
5959 );
5960 PUSHs(SvRV(*svp));
5961 break;
c931b036 5962 case OA_FILEREF:
30901a8a
FC		 5963 if (!numargs) PUSHs(NULL);
5964 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
c931b036
FC		 5965 /* no magic here, as the prototype will have added an extra
5966 refgen and we just want what was there before that */
5967 PUSHs(SvRV(*svp));
5968 else {
5969 const bool constr = PL_op->op_private & whicharg;
5970 PUSHs(S_rv2gv(aTHX_
5971 svp && *svp ? *svp : &PL_sv_undef,
b54f893d 5972 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
c931b036
FC		 5973 !constr
5974 ));
5975 }
5976 break;
c72a5629 5977 case OA_SCALARREF:
1efec5ed
FC		 5978 if (!numargs) goto try_defsv;
5979 else {
17008668
FC		 5980 const bool wantscalar =
5981 PL_op->op_private & OPpCOREARGS_SCALARMOD;
c72a5629 5982 if (!svp || !*svp || !SvROK(*svp)
17008668
FC		 5983 /* We have to permit globrefs even for the \$ proto, as
5984 *foo is indistinguishable from ${\*foo}, and the proto-
5985 type permits the latter. */
5986 || SvTYPE(SvRV(*svp)) > (
efe889ae 5987 wantscalar ? SVt_PVLV
46bef06f
FC		 5988 : opnum == OP_LOCK || opnum == OP_UNDEF
5989 ? SVt_PVCV
efe889ae 5990 : SVt_PVHV
17008668 5991 )
c72a5629
FC		 5992 )
5993 DIE(aTHX_
17008668 5994 "Type of arg %d to &CORE::%s must be %s",
46bef06f 5995 whicharg, PL_op_name[opnum],
17008668
FC		 5996 wantscalar
5997 ? "scalar reference"
46bef06f 5998 : opnum == OP_LOCK || opnum == OP_UNDEF
efe889ae
FC		 5999 ? "reference to one of [$@%&*]"
6000 : "reference to one of [$@%*]"
c72a5629
FC		 6001 );
6002 PUSHs(SvRV(*svp));
88bb468b
FC		 6003 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6004 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6005 /* Undo @_ localisation, so that sub exit does not undo
6006 part of our undeffing. */
6007 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6008 POP_SAVEARRAY();
6009 cx->cx_type &= ~ CXp_HASARGS;
6010 assert(!AvREAL(cx->blk_sub.argarray));
6011 }
17008668 6012 }
1efec5ed 6013 break;
46e00a91 6014 default:
46e00a91
FC		 6015 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6016 }
6017 oa = oa >> 4;
6018 }
6019
deb8a388
FC		 6020 RETURN;
6021}
6022
84ed0108
FC		 6023PP(pp_runcv)
6024{
6025 dSP;
6026 CV *cv;
6027 if (PL_op->op_private & OPpOFFBYONE) {
db4cf31d 6028 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
84ed0108
FC		 6029 }
6030 else cv = find_runcv(NULL);
e157a82b 6031 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
84ed0108
FC		 6032 RETURN;
6033}
6034
6035
e609e586
NC		 6036/*
6037 * Local variables:
6038 * c-indentation-style: bsd
6039 * c-basic-offset: 4
14d04a33 6040 * indent-tabs-mode: nil
e609e586
NC		 6041 * End:
6042 *
14d04a33 6043 * ex: set ts=8 sts=4 sw=4 et:
37442d52 6044 */
Unnamed repository; edit this file 'description' to name the repository.