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