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