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