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