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