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