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