This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regen podcheck.t db
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
1129b882
NC
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805 5 *
a0d0e21e
LW
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
79072805 8 *
a0d0e21e
LW
9 */
10
11/*
4ac71550
TC
12 * 'It's a big house this, and very peculiar. Always a bit more
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
15 *
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
a0d0e21e 17 */
79072805 18
166f8a29
DM
19/* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
24 */
25
79072805 26#include "EXTERN.h"
864dbfa3 27#define PERL_IN_PP_C
79072805 28#include "perl.h"
77bc9082 29#include "keywords.h"
79072805 30
a4af207c 31#include "reentr.h"
685289b5 32#include "regcharclass.h"
a4af207c 33
dfe9444c
AD
34/* XXX I can't imagine anyone who doesn't have this actually _needs_
35 it, since pid_t is an integral type.
36 --AD 2/20/1998
37*/
38#ifdef NEED_GETPID_PROTO
39extern Pid_t getpid (void);
8ac85365
NIS
40#endif
41
0630166f
SP
42/*
43 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44 * This switches them over to IEEE.
45 */
46#if defined(LIBM_LIB_VERSION)
47 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
48#endif
49
a78bc3c6
KW
50static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
52
13017935
SM
53/* variations on pp_null */
54
93a17b20
LW
55PP(pp_stub)
56{
97aff369 57 dVAR;
39644a26 58 dSP;
54310121 59 if (GIMME_V == G_SCALAR)
3280af22 60 XPUSHs(&PL_sv_undef);
93a17b20
LW
61 RETURN;
62}
63
79072805
LW
64/* Pushy stuff. */
65
93a17b20
LW
66PP(pp_padav)
67{
97aff369 68 dVAR; dSP; dTARGET;
13017935 69 I32 gimme;
e190e9b4 70 assert(SvTYPE(TARG) == SVt_PVAV);
3dbcc5e0
SM
71 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
a5911867 73 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
85e6fe83 74 EXTEND(SP, 1);
533c011a 75 if (PL_op->op_flags & OPf_REF) {
85e6fe83 76 PUSHs(TARG);
93a17b20 77 RETURN;
40c94d11
FC
78 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
79 const I32 flags = is_lvalue_sub();
80 if (flags && !(flags & OPpENTERSUB_INARGS)) {
78f9721b 81 if (GIMME == G_SCALAR)
a84828f3 82 /* diag_listed_as: Can't return %s to lvalue scalar context */
78f9721b
SM
83 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
84 PUSHs(TARG);
85 RETURN;
40c94d11 86 }
85e6fe83 87 }
13017935
SM
88 gimme = GIMME_V;
89 if (gimme == G_ARRAY) {
d5524600 90 /* XXX see also S_pushav in pp_hot.c */
c70927a6 91 const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
85e6fe83 92 EXTEND(SP, maxarg);
93965878 93 if (SvMAGICAL(TARG)) {
c70927a6
FC
94 Size_t i;
95 for (i=0; i < maxarg; i++) {
502c6561 96 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
3280af22 97 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878
NIS
98 }
99 }
100 else {
428ccf1e
FC
101 PADOFFSET i;
102 for (i=0; i < (PADOFFSET)maxarg; i++) {
103 SV * const sv = AvARRAY((const AV *)TARG)[i];
104 SP[i+1] = sv ? sv : &PL_sv_undef;
105 }
93965878 106 }
85e6fe83
LW
107 SP += maxarg;
108 }
13017935 109 else if (gimme == G_SCALAR) {
1b6737cc 110 SV* const sv = sv_newmortal();
c70927a6 111 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
85e6fe83
LW
112 sv_setiv(sv, maxarg);
113 PUSHs(sv);
114 }
115 RETURN;
93a17b20
LW
116}
117
118PP(pp_padhv)
119{
97aff369 120 dVAR; dSP; dTARGET;
54310121
PP
121 I32 gimme;
122
e190e9b4 123 assert(SvTYPE(TARG) == SVt_PVHV);
93a17b20 124 XPUSHs(TARG);
3dbcc5e0
SM
125 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
126 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
a5911867 127 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
533c011a 128 if (PL_op->op_flags & OPf_REF)
93a17b20 129 RETURN;
40c94d11
FC
130 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
131 const I32 flags = is_lvalue_sub();
132 if (flags && !(flags & OPpENTERSUB_INARGS)) {
78f9721b 133 if (GIMME == G_SCALAR)
a84828f3 134 /* diag_listed_as: Can't return %s to lvalue scalar context */
78f9721b
SM
135 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
136 RETURN;
40c94d11 137 }
78f9721b 138 }
54310121
PP
139 gimme = GIMME_V;
140 if (gimme == G_ARRAY) {
981b7185 141 RETURNOP(Perl_do_kv(aTHX));
85e6fe83 142 }
c8fe3bdf 143 else if ((PL_op->op_private & OPpTRUEBOOL
adc42c31 144 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
c8fe3bdf
FC
145 && block_gimme() == G_VOID ))
146 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
147 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
54310121 148 else if (gimme == G_SCALAR) {
85fbaab2 149 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
85e6fe83 150 SETs(sv);
85e6fe83 151 }
54310121 152 RETURN;
93a17b20
LW
153}
154
ac217057
FC
155PP(pp_padcv)
156{
97b03d64
FC
157 dVAR; dSP; dTARGET;
158 assert(SvTYPE(TARG) == SVt_PVCV);
159 XPUSHs(TARG);
160 RETURN;
ac217057
FC
161}
162
ecf9c8b7
FC
163PP(pp_introcv)
164{
6d5c2147
FC
165 dVAR; dTARGET;
166 SvPADSTALE_off(TARG);
167 return NORMAL;
ecf9c8b7
FC
168}
169
13f89586
FC
170PP(pp_clonecv)
171{
6d5c2147 172 dVAR; dTARGET;
81df9f6f 173 MAGIC * const mg =
62698e04
FC
174 mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
175 PERL_MAGIC_proto);
6d5c2147
FC
176 assert(SvTYPE(TARG) == SVt_PVCV);
177 assert(mg);
178 assert(mg->mg_obj);
179 if (CvISXSUB(mg->mg_obj)) { /* constant */
180 /* XXX Should we clone it here? */
6d5c2147
FC
181 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
182 to introcv and remove the SvPADSTALE_off. */
183 SAVEPADSVANDMORTALIZE(ARGTARG);
4ded55f3 184 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
6d5c2147
FC
185 }
186 else {
187 if (CvROOT(mg->mg_obj)) {
188 assert(CvCLONE(mg->mg_obj));
189 assert(!CvCLONED(mg->mg_obj));
190 }
191 cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
192 SAVECLEARSV(PAD_SVl(ARGTARG));
193 }
194 return NORMAL;
13f89586
FC
195}
196
79072805
LW
197/* Translations. */
198
4bdf8368 199static const char S_no_symref_sv[] =
def89bff
NC
200 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
201
6f7909da
FC
202/* In some cases this function inspects PL_op. If this function is called
203 for new op types, more bool parameters may need to be added in place of
204 the checks.
205
206 When noinit is true, the absence of a gv will cause a retval of undef.
207 This is unrelated to the cv-to-gv assignment case.
6f7909da
FC
208*/
209
210static SV *
211S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
212 const bool noinit)
213{
14f0f125 214 dVAR;
f64c9ac5 215 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
ed6116ce 216 if (SvROK(sv)) {
93d7320b
DM
217 if (SvAMAGIC(sv)) {
218 sv = amagic_deref_call(sv, to_gv_amg);
93d7320b 219 }
e4a1664f 220 wasref:
ed6116ce 221 sv = SvRV(sv);
b1dadf13 222 if (SvTYPE(sv) == SVt_PVIO) {
159b6efe 223 GV * const gv = MUTABLE_GV(sv_newmortal());
885f468a 224 gv_init(gv, 0, "__ANONIO__", 10, 0);
a45c7426 225 GvIOp(gv) = MUTABLE_IO(sv);
b37c2d43 226 SvREFCNT_inc_void_NN(sv);
ad64d0ec 227 sv = MUTABLE_SV(gv);
ef54e1a4 228 }
6e592b3a 229 else if (!isGV_with_GP(sv))
6f7909da 230 return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
79072805
LW
231 }
232 else {
6e592b3a 233 if (!isGV_with_GP(sv)) {
f132ae69 234 if (!SvOK(sv)) {
b13b2135 235 /* If this is a 'my' scalar and flag is set then vivify
853846ea 236 * NI-S 1999/05/07
b13b2135 237 */
f132ae69 238 if (vivify_sv && sv != &PL_sv_undef) {
2c8ac474 239 GV *gv;
ce74145d 240 if (SvREADONLY(sv))
cb077ed2 241 Perl_croak_no_modify();
2c8ac474 242 if (cUNOP->op_targ) {
0bd48802 243 SV * const namesv = PAD_SV(cUNOP->op_targ);
94e7eb6f
FC
244 HV *stash = CopSTASH(PL_curcop);
245 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
159b6efe 246 gv = MUTABLE_GV(newSV(0));
94e7eb6f 247 gv_init_sv(gv, stash, namesv, 0);
2c8ac474
GS
248 }
249 else {
0bd48802 250 const char * const name = CopSTASHPV(PL_curcop);
6b10071b 251 gv = newGVgen_flags(name,
d14578b8 252 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
1d8d4d2a 253 }
43230e26 254 prepare_SV_for_RV(sv);
ad64d0ec 255 SvRV_set(sv, MUTABLE_SV(gv));
853846ea 256 SvROK_on(sv);
1d8d4d2a 257 SvSETMAGIC(sv);
853846ea 258 goto wasref;
2c8ac474 259 }
6f7909da
FC
260 if (PL_op->op_flags & OPf_REF || strict)
261 return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
599cee73 262 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 263 report_uninit(sv);
6f7909da 264 return &PL_sv_undef;
a0d0e21e 265 }
6f7909da 266 if (noinit)
35cd451c 267 {
77cb3b01
FC
268 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
269 sv, GV_ADDMG, SVt_PVGV
23496c6e 270 ))))
6f7909da 271 return &PL_sv_undef;
35cd451c
GS
272 }
273 else {
6f7909da
FC
274 if (strict)
275 return
276 (SV *)Perl_die(aTHX_
277 S_no_symref_sv,
278 sv,
bf3d870f 279 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
6f7909da
FC
280 "a symbol"
281 );
e26df76a
NC
282 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
283 == OPpDONT_INIT_GV) {
284 /* We are the target of a coderef assignment. Return
285 the scalar unchanged, and let pp_sasssign deal with
286 things. */
6f7909da 287 return sv;
e26df76a 288 }
77cb3b01 289 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
35cd451c 290 }
2acc3314 291 /* FAKE globs in the symbol table cause weird bugs (#77810) */
96293f45 292 SvFAKE_off(sv);
93a17b20 293 }
79072805 294 }
8dc99089 295 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
2acc3314 296 SV *newsv = sv_newmortal();
5cf4b255 297 sv_setsv_flags(newsv, sv, 0);
2acc3314 298 SvFAKE_off(newsv);
d8906c05 299 sv = newsv;
2acc3314 300 }
6f7909da
FC
301 return sv;
302}
303
304PP(pp_rv2gv)
305{
306 dVAR; dSP; dTOPss;
307
308 sv = S_rv2gv(aTHX_
309 sv, PL_op->op_private & OPpDEREF,
310 PL_op->op_private & HINT_STRICT_REFS,
311 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
312 || PL_op->op_type == OP_READLINE
313 );
d8906c05
FC
314 if (PL_op->op_private & OPpLVAL_INTRO)
315 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
316 SETs(sv);
79072805
LW
317 RETURN;
318}
319
dc3c76f8
NC
320/* Helper function for pp_rv2sv and pp_rv2av */
321GV *
fe9845cc
RB
322Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
323 const svtype type, SV ***spp)
dc3c76f8
NC
324{
325 dVAR;
326 GV *gv;
327
7918f24d
NC
328 PERL_ARGS_ASSERT_SOFTREF2XV;
329
dc3c76f8
NC
330 if (PL_op->op_private & HINT_STRICT_REFS) {
331 if (SvOK(sv))
bf3d870f
FC
332 Perl_die(aTHX_ S_no_symref_sv, sv,
333 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
dc3c76f8
NC
334 else
335 Perl_die(aTHX_ PL_no_usym, what);
336 }
337 if (!SvOK(sv)) {
fd1d9b5c 338 if (
c8fe3bdf 339 PL_op->op_flags & OPf_REF
fd1d9b5c 340 )
dc3c76f8
NC
341 Perl_die(aTHX_ PL_no_usym, what);
342 if (ckWARN(WARN_UNINITIALIZED))
343 report_uninit(sv);
344 if (type != SVt_PV && GIMME_V == G_ARRAY) {
345 (*spp)--;
346 return NULL;
347 }
348 **spp = &PL_sv_undef;
349 return NULL;
350 }
351 if ((PL_op->op_flags & OPf_SPECIAL) &&
352 !(PL_op->op_flags & OPf_MOD))
353 {
77cb3b01 354 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
dc3c76f8
NC
355 {
356 **spp = &PL_sv_undef;
357 return NULL;
358 }
359 }
360 else {
77cb3b01 361 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
dc3c76f8
NC
362 }
363 return gv;
364}
365
79072805
LW
366PP(pp_rv2sv)
367{
97aff369 368 dVAR; dSP; dTOPss;
c445ea15 369 GV *gv = NULL;
79072805 370
9026059d 371 SvGETMAGIC(sv);
ed6116ce 372 if (SvROK(sv)) {
93d7320b
DM
373 if (SvAMAGIC(sv)) {
374 sv = amagic_deref_call(sv, to_sv_amg);
93d7320b 375 }
f5284f61 376
ed6116ce 377 sv = SvRV(sv);
79072805
LW
378 switch (SvTYPE(sv)) {
379 case SVt_PVAV:
380 case SVt_PVHV:
381 case SVt_PVCV:
cbae9b9f
YST
382 case SVt_PVFM:
383 case SVt_PVIO:
cea2e8a9 384 DIE(aTHX_ "Not a SCALAR reference");
42d0e0b7 385 default: NOOP;
79072805
LW
386 }
387 }
388 else {
159b6efe 389 gv = MUTABLE_GV(sv);
748a9306 390
6e592b3a 391 if (!isGV_with_GP(gv)) {
dc3c76f8
NC
392 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
393 if (!gv)
394 RETURN;
463ee0b2 395 }
29c711a3 396 sv = GvSVn(gv);
a0d0e21e 397 }
533c011a 398 if (PL_op->op_flags & OPf_MOD) {
82d03984
RGS
399 if (PL_op->op_private & OPpLVAL_INTRO) {
400 if (cUNOP->op_first->op_type == OP_NULL)
159b6efe 401 sv = save_scalar(MUTABLE_GV(TOPs));
82d03984
RGS
402 else if (gv)
403 sv = save_scalar(gv);
404 else
f1f66076 405 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
82d03984 406 }
533c011a 407 else if (PL_op->op_private & OPpDEREF)
9026059d 408 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 409 }
a0d0e21e 410 SETs(sv);
79072805
LW
411 RETURN;
412}
413
414PP(pp_av2arylen)
415{
97aff369 416 dVAR; dSP;
502c6561 417 AV * const av = MUTABLE_AV(TOPs);
02d85cc3
EB
418 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
419 if (lvalue) {
420 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
421 if (!*sv) {
422 *sv = newSV_type(SVt_PVMG);
423 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
424 }
425 SETs(*sv);
426 } else {
e1dccc0d 427 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
79072805 428 }
79072805
LW
429 RETURN;
430}
431
a0d0e21e
LW
432PP(pp_pos)
433{
2154eca7 434 dVAR; dSP; dPOPss;
8ec5e241 435
78f9721b 436 if (PL_op->op_flags & OPf_MOD || LVRET) {
d14578b8 437 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
16eb5365
FC
438 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
439 LvTYPE(ret) = '.';
440 LvTARG(ret) = SvREFCNT_inc_simple(sv);
2154eca7 441 PUSHs(ret); /* no SvSETMAGIC */
a0d0e21e
LW
442 RETURN;
443 }
444 else {
96c2a8ff 445 const MAGIC * const mg = mg_find_mglob(sv);
6174b39a 446 if (mg && mg->mg_len != -1) {
2154eca7 447 dTARGET;
6174b39a 448 STRLEN i = mg->mg_len;
25fdce4a 449 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
6174b39a
FC
450 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
451 PUSHu(i);
a0d0e21e
LW
452 RETURN;
453 }
96c2a8ff 454 RETPUSHUNDEF;
a0d0e21e
LW
455 }
456}
457
79072805
LW
458PP(pp_rv2cv)
459{
97aff369 460 dVAR; dSP;
79072805 461 GV *gv;
1eced8f8 462 HV *stash_unused;
c445ea15 463 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
9da346da 464 ? GV_ADDMG
d14578b8
KW
465 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
466 == OPpMAY_RETURN_CONSTANT)
c445ea15
AL
467 ? GV_ADD|GV_NOEXPAND
468 : GV_ADD;
4633a7c4
LW
469 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
470 /* (But not in defined().) */
e26df76a 471
1eced8f8 472 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
5a20ba3d 473 if (cv) NOOP;
e26df76a 474 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
ea726b52 475 cv = MUTABLE_CV(gv);
e26df76a 476 }
07055b4c 477 else
ea726b52 478 cv = MUTABLE_CV(&PL_sv_undef);
ad64d0ec 479 SETs(MUTABLE_SV(cv));
79072805
LW
480 RETURN;
481}
482
c07a80fd
PP
483PP(pp_prototype)
484{
97aff369 485 dVAR; dSP;
c07a80fd
PP
486 CV *cv;
487 HV *stash;
488 GV *gv;
fabdb6c0 489 SV *ret = &PL_sv_undef;
c07a80fd 490
6954f42f 491 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
b6c543e3 492 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
e3f73d4e 493 const char * s = SvPVX_const(TOPs);
b6c543e3 494 if (strnEQ(s, "CORE::", 6)) {
be1b855b 495 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
a96df643 496 if (!code)
b17a0679
FC
497 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
498 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
4e338c21 499 {
b66130dd
FC
500 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
501 if (sv) ret = sv;
502 }
b8c38f0a 503 goto set;
b6c543e3
IZ
504 }
505 }
f2c0649b 506 cv = sv_2cv(TOPs, &stash, &gv, 0);
5f05dabc 507 if (cv && SvPOK(cv))
8fa6a409
FC
508 ret = newSVpvn_flags(
509 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
510 );
b6c543e3 511 set:
c07a80fd
PP
512 SETs(ret);
513 RETURN;
514}
515
a0d0e21e
LW
516PP(pp_anoncode)
517{
97aff369 518 dVAR; dSP;
ea726b52 519 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
a5f75d66 520 if (CvCLONE(cv))
ad64d0ec 521 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
5f05dabc 522 EXTEND(SP,1);
ad64d0ec 523 PUSHs(MUTABLE_SV(cv));
a0d0e21e
LW
524 RETURN;
525}
526
527PP(pp_srefgen)
79072805 528{
97aff369 529 dVAR; dSP;
71be2cbc 530 *SP = refto(*SP);
79072805 531 RETURN;
8ec5e241 532}
a0d0e21e
LW
533
534PP(pp_refgen)
535{
97aff369 536 dVAR; dSP; dMARK;
a0d0e21e 537 if (GIMME != G_ARRAY) {
5f0b1d4e
GS
538 if (++MARK <= SP)
539 *MARK = *SP;
540 else
3280af22 541 *MARK = &PL_sv_undef;
5f0b1d4e
GS
542 *MARK = refto(*MARK);
543 SP = MARK;
544 RETURN;
a0d0e21e 545 }
bbce6d69 546 EXTEND_MORTAL(SP - MARK);
71be2cbc
PP
547 while (++MARK <= SP)
548 *MARK = refto(*MARK);
a0d0e21e 549 RETURN;
79072805
LW
550}
551
76e3520e 552STATIC SV*
cea2e8a9 553S_refto(pTHX_ SV *sv)
71be2cbc 554{
97aff369 555 dVAR;
71be2cbc
PP
556 SV* rv;
557
7918f24d
NC
558 PERL_ARGS_ASSERT_REFTO;
559
71be2cbc
PP
560 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
561 if (LvTARGLEN(sv))
68dc0745
PP
562 vivify_defelem(sv);
563 if (!(sv = LvTARG(sv)))
3280af22 564 sv = &PL_sv_undef;
0dd88869 565 else
b37c2d43 566 SvREFCNT_inc_void_NN(sv);
71be2cbc 567 }
d8b46c1b 568 else if (SvTYPE(sv) == SVt_PVAV) {
502c6561
NC
569 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
570 av_reify(MUTABLE_AV(sv));
d8b46c1b 571 SvTEMP_off(sv);
b37c2d43 572 SvREFCNT_inc_void_NN(sv);
d8b46c1b 573 }
60779a30
DM
574 else if (SvPADTMP(sv)) {
575 assert(!IS_PADGV(sv));
f2933f5f 576 sv = newSVsv(sv);
60779a30 577 }
71be2cbc
PP
578 else {
579 SvTEMP_off(sv);
b37c2d43 580 SvREFCNT_inc_void_NN(sv);
71be2cbc
PP
581 }
582 rv = sv_newmortal();
4df7f6af 583 sv_upgrade(rv, SVt_IV);
b162af07 584 SvRV_set(rv, sv);
71be2cbc
PP
585 SvROK_on(rv);
586 return rv;
587}
588
79072805
LW
589PP(pp_ref)
590{
97aff369 591 dVAR; dSP; dTARGET;
1b6737cc 592 SV * const sv = POPs;
f12c7020 593
511ddbdf
FC
594 SvGETMAGIC(sv);
595 if (!SvROK(sv))
4633a7c4 596 RETPUSHNO;
79072805 597
a15456de
BF
598 (void)sv_ref(TARG,SvRV(sv),TRUE);
599 PUSHTARG;
79072805
LW
600 RETURN;
601}
602
603PP(pp_bless)
604{
97aff369 605 dVAR; dSP;
463ee0b2 606 HV *stash;
79072805 607
463ee0b2 608 if (MAXARG == 1)
dcdfe746 609 {
c2f922f1 610 curstash:
11faa288 611 stash = CopSTASH(PL_curcop);
dcdfe746
FC
612 if (SvTYPE(stash) != SVt_PVHV)
613 Perl_croak(aTHX_ "Attempt to bless into a freed package");
614 }
7b8d334a 615 else {
1b6737cc 616 SV * const ssv = POPs;
7b8d334a 617 STRLEN len;
e1ec3a88 618 const char *ptr;
81689caa 619
c2f922f1 620 if (!ssv) goto curstash;
8d9dd4b9 621 SvGETMAGIC(ssv);
c7ea825d
FC
622 if (SvROK(ssv)) {
623 if (!SvAMAGIC(ssv)) {
624 frog:
81689caa 625 Perl_croak(aTHX_ "Attempt to bless into a reference");
c7ea825d
FC
626 }
627 /* SvAMAGIC is on here, but it only means potentially overloaded,
628 so after stringification: */
629 ptr = SvPV_nomg_const(ssv,len);
630 /* We need to check the flag again: */
631 if (!SvAMAGIC(ssv)) goto frog;
632 }
633 else ptr = SvPV_nomg_const(ssv,len);
a2a5de95
NC
634 if (len == 0)
635 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
636 "Explicit blessing to '' (assuming package main)");
e69c50fe 637 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
7b8d334a 638 }
a0d0e21e 639
5d3fdfeb 640 (void)sv_bless(TOPs, stash);
79072805
LW
641 RETURN;
642}
643
fb73857a
PP
644PP(pp_gelem)
645{
97aff369 646 dVAR; dSP;
b13b2135 647
1b6737cc 648 SV *sv = POPs;
a180b31a
BF
649 STRLEN len;
650 const char * const elem = SvPV_const(sv, len);
159b6efe 651 GV * const gv = MUTABLE_GV(POPs);
c445ea15 652 SV * tmpRef = NULL;
1b6737cc 653
c445ea15 654 sv = NULL;
c4ba80c3
NC
655 if (elem) {
656 /* elem will always be NUL terminated. */
1b6737cc 657 const char * const second_letter = elem + 1;
c4ba80c3
NC
658 switch (*elem) {
659 case 'A':
a180b31a 660 if (len == 5 && strEQ(second_letter, "RRAY"))
e14698d8 661 {
ad64d0ec 662 tmpRef = MUTABLE_SV(GvAV(gv));
e14698d8
FC
663 if (tmpRef && !AvREAL((const AV *)tmpRef)
664 && AvREIFY((const AV *)tmpRef))
665 av_reify(MUTABLE_AV(tmpRef));
666 }
c4ba80c3
NC
667 break;
668 case 'C':
a180b31a 669 if (len == 4 && strEQ(second_letter, "ODE"))
ad64d0ec 670 tmpRef = MUTABLE_SV(GvCVu(gv));
c4ba80c3
NC
671 break;
672 case 'F':
a180b31a 673 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
c4ba80c3
NC
674 /* finally deprecated in 5.8.0 */
675 deprecate("*glob{FILEHANDLE}");
ad64d0ec 676 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC
677 }
678 else
a180b31a 679 if (len == 6 && strEQ(second_letter, "ORMAT"))
ad64d0ec 680 tmpRef = MUTABLE_SV(GvFORM(gv));
c4ba80c3
NC
681 break;
682 case 'G':
a180b31a 683 if (len == 4 && strEQ(second_letter, "LOB"))
ad64d0ec 684 tmpRef = MUTABLE_SV(gv);
c4ba80c3
NC
685 break;
686 case 'H':
a180b31a 687 if (len == 4 && strEQ(second_letter, "ASH"))
ad64d0ec 688 tmpRef = MUTABLE_SV(GvHV(gv));
c4ba80c3
NC
689 break;
690 case 'I':
a180b31a 691 if (*second_letter == 'O' && !elem[2] && len == 2)
ad64d0ec 692 tmpRef = MUTABLE_SV(GvIOp(gv));
c4ba80c3
NC
693 break;
694 case 'N':
a180b31a 695 if (len == 4 && strEQ(second_letter, "AME"))
a663657d 696 sv = newSVhek(GvNAME_HEK(gv));
c4ba80c3
NC
697 break;
698 case 'P':
a180b31a 699 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
7fa3a4ab
NC
700 const HV * const stash = GvSTASH(gv);
701 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
396482e1 702 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
c4ba80c3
NC
703 }
704 break;
705 case 'S':
a180b31a 706 if (len == 6 && strEQ(second_letter, "CALAR"))
f9d52e31 707 tmpRef = GvSVn(gv);
c4ba80c3 708 break;
39b99f21 709 }
fb73857a 710 }
76e3520e
GS
711 if (tmpRef)
712 sv = newRV(tmpRef);
fb73857a
PP
713 if (sv)
714 sv_2mortal(sv);
715 else
3280af22 716 sv = &PL_sv_undef;
fb73857a
PP
717 XPUSHs(sv);
718 RETURN;
719}
720
a0d0e21e 721/* Pattern matching */
79072805 722
a0d0e21e 723PP(pp_study)
79072805 724{
97aff369 725 dVAR; dSP; dPOPss;
a0d0e21e
LW
726 STRLEN len;
727
1fa930f2 728 (void)SvPV(sv, len);
bc9a5256 729 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
32f0ea87 730 /* Historically, study was skipped in these cases. */
a4f4e906
NC
731 RETPUSHNO;
732 }
733
a58a85fa 734 /* Make study a no-op. It's no longer useful and its existence
32f0ea87 735 complicates matters elsewhere. */
1e422769 736 RETPUSHYES;
79072805
LW
737}
738
a0d0e21e 739PP(pp_trans)
79072805 740{
97aff369 741 dVAR; dSP; dTARG;
a0d0e21e
LW
742 SV *sv;
743
533c011a 744 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 745 sv = POPs;
59f00321
RGS
746 else if (PL_op->op_private & OPpTARGET_MY)
747 sv = GETTARGET;
79072805 748 else {
54b9620d 749 sv = DEFSV;
a0d0e21e 750 EXTEND(SP,1);
79072805 751 }
bb16bae8 752 if(PL_op->op_type == OP_TRANSR) {
290797f7
FC
753 STRLEN len;
754 const char * const pv = SvPV(sv,len);
755 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
bb16bae8 756 do_trans(newsv);
290797f7 757 PUSHs(newsv);
bb16bae8 758 }
5bbe7184
FC
759 else {
760 TARG = sv_newmortal();
761 PUSHi(do_trans(sv));
762 }
a0d0e21e 763 RETURN;
79072805
LW
764}
765
a0d0e21e 766/* Lvalue operators. */
79072805 767
81745e4e
NC
768static void
769S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
770{
771 dVAR;
772 STRLEN len;
773 char *s;
774
775 PERL_ARGS_ASSERT_DO_CHOMP;
776
777 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
778 return;
779 if (SvTYPE(sv) == SVt_PVAV) {
780 I32 i;
781 AV *const av = MUTABLE_AV(sv);
782 const I32 max = AvFILL(av);
783
784 for (i = 0; i <= max; i++) {
785 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
786 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
787 do_chomp(retval, sv, chomping);
788 }
789 return;
790 }
791 else if (SvTYPE(sv) == SVt_PVHV) {
792 HV* const hv = MUTABLE_HV(sv);
793 HE* entry;
794 (void)hv_iterinit(hv);
795 while ((entry = hv_iternext(hv)))
796 do_chomp(retval, hv_iterval(hv,entry), chomping);
797 return;
798 }
799 else if (SvREADONLY(sv)) {
cb077ed2 800 Perl_croak_no_modify();
81745e4e 801 }
e3918bb7
FC
802 else if (SvIsCOW(sv)) {
803 sv_force_normal_flags(sv, 0);
804 }
81745e4e
NC
805
806 if (PL_encoding) {
807 if (!SvUTF8(sv)) {
808 /* XXX, here sv is utf8-ized as a side-effect!
809 If encoding.pm is used properly, almost string-generating
810 operations, including literal strings, chr(), input data, etc.
811 should have been utf8-ized already, right?
812 */
813 sv_recode_to_utf8(sv, PL_encoding);
814 }
815 }
816
817 s = SvPV(sv, len);
818 if (chomping) {
819 char *temp_buffer = NULL;
820 SV *svrecode = NULL;
821
822 if (s && len) {
823 s += --len;
824 if (RsPARA(PL_rs)) {
825 if (*s != '\n')
826 goto nope;
827 ++SvIVX(retval);
828 while (len && s[-1] == '\n') {
829 --len;
830 --s;
831 ++SvIVX(retval);
832 }
833 }
834 else {
835 STRLEN rslen, rs_charlen;
836 const char *rsptr = SvPV_const(PL_rs, rslen);
837
838 rs_charlen = SvUTF8(PL_rs)
839 ? sv_len_utf8(PL_rs)
840 : rslen;
841
842 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
843 /* Assumption is that rs is shorter than the scalar. */
844 if (SvUTF8(PL_rs)) {
845 /* RS is utf8, scalar is 8 bit. */
846 bool is_utf8 = TRUE;
847 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
848 &rslen, &is_utf8);
849 if (is_utf8) {
850 /* Cannot downgrade, therefore cannot possibly match
851 */
852 assert (temp_buffer == rsptr);
853 temp_buffer = NULL;
854 goto nope;
855 }
856 rsptr = temp_buffer;
857 }
858 else if (PL_encoding) {
859 /* RS is 8 bit, encoding.pm is used.
860 * Do not recode PL_rs as a side-effect. */
861 svrecode = newSVpvn(rsptr, rslen);
862 sv_recode_to_utf8(svrecode, PL_encoding);
863 rsptr = SvPV_const(svrecode, rslen);
864 rs_charlen = sv_len_utf8(svrecode);
865 }
866 else {
867 /* RS is 8 bit, scalar is utf8. */
868 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
869 rsptr = temp_buffer;
870 }
871 }
872 if (rslen == 1) {
873 if (*s != *rsptr)
874 goto nope;
875 ++SvIVX(retval);
876 }
877 else {
878 if (len < rslen - 1)
879 goto nope;
880 len -= rslen - 1;
881 s -= rslen - 1;
882 if (memNE(s, rsptr, rslen))
883 goto nope;
884 SvIVX(retval) += rs_charlen;
885 }
886 }
fbac7ddf 887 s = SvPV_force_nomg_nolen(sv);
81745e4e
NC
888 SvCUR_set(sv, len);
889 *SvEND(sv) = '\0';
890 SvNIOK_off(sv);
891 SvSETMAGIC(sv);
892 }
893 nope:
894
895 SvREFCNT_dec(svrecode);
896
897 Safefree(temp_buffer);
898 } else {
899 if (len && !SvPOK(sv))
900 s = SvPV_force_nomg(sv, len);
901 if (DO_UTF8(sv)) {
902 if (s && len) {
903 char * const send = s + len;
904 char * const start = s;
905 s = send - 1;
906 while (s > start && UTF8_IS_CONTINUATION(*s))
907 s--;
908 if (is_utf8_string((U8*)s, send - s)) {
909 sv_setpvn(retval, s, send - s);
910 *s = '\0';
911 SvCUR_set(sv, s - start);
912 SvNIOK_off(sv);
913 SvUTF8_on(retval);
914 }
915 }
916 else
917 sv_setpvs(retval, "");
918 }
919 else if (s && len) {
920 s += --len;
921 sv_setpvn(retval, s, 1);
922 *s = '\0';
923 SvCUR_set(sv, len);
924 SvUTF8_off(sv);
925 SvNIOK_off(sv);
926 }
927 else
928 sv_setpvs(retval, "");
929 SvSETMAGIC(sv);
930 }
931}
932
a0d0e21e
LW
933PP(pp_schop)
934{
97aff369 935 dVAR; dSP; dTARGET;
fa54efae
NC
936 const bool chomping = PL_op->op_type == OP_SCHOMP;
937
938 if (chomping)
939 sv_setiv(TARG, 0);
940 do_chomp(TARG, TOPs, chomping);
a0d0e21e
LW
941 SETTARG;
942 RETURN;
79072805
LW
943}
944
a0d0e21e 945PP(pp_chop)
79072805 946{
97aff369 947 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
fa54efae 948 const bool chomping = PL_op->op_type == OP_CHOMP;
8ec5e241 949
fa54efae
NC
950 if (chomping)
951 sv_setiv(TARG, 0);
20cf1f79 952 while (MARK < SP)
fa54efae 953 do_chomp(TARG, *++MARK, chomping);
20cf1f79
NC
954 SP = ORIGMARK;
955 XPUSHTARG;
a0d0e21e 956 RETURN;
79072805
LW
957}
958
a0d0e21e
LW
959PP(pp_undef)
960{
97aff369 961 dVAR; dSP;
a0d0e21e
LW
962 SV *sv;
963
533c011a 964 if (!PL_op->op_private) {
774d564b 965 EXTEND(SP, 1);
a0d0e21e 966 RETPUSHUNDEF;
774d564b 967 }
79072805 968
a0d0e21e
LW
969 sv = POPs;
970 if (!sv)
971 RETPUSHUNDEF;
85e6fe83 972
765f542d 973 SV_CHECK_THINKFIRST_COW_DROP(sv);
85e6fe83 974
a0d0e21e
LW
975 switch (SvTYPE(sv)) {
976 case SVt_NULL:
977 break;
978 case SVt_PVAV:
60edcf09 979 av_undef(MUTABLE_AV(sv));
a0d0e21e
LW
980 break;
981 case SVt_PVHV:
60edcf09 982 hv_undef(MUTABLE_HV(sv));
a0d0e21e
LW
983 break;
984 case SVt_PVCV:
a2a5de95 985 if (cv_const_sv((const CV *)sv))
714cd18f
BF
986 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
987 "Constant subroutine %"SVf" undefined",
988 SVfARG(CvANON((const CV *)sv)
989 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
bdbfc51a
FC
990 : sv_2mortal(newSVhek(
991 CvNAMED(sv)
992 ? CvNAME_HEK((CV *)sv)
993 : GvENAME_HEK(CvGV((const CV *)sv))
994 ))
995 ));
5f66b61c 996 /* FALLTHROUGH */
9607fc9c 997 case SVt_PVFM:
6fc92669
GS
998 {
999 /* let user-undef'd sub keep its identity */
ea726b52 1000 GV* const gv = CvGV((const CV *)sv);
b290562e
FC
1001 HEK * const hek = CvNAME_HEK((CV *)sv);
1002 if (hek) share_hek_hek(hek);
ea726b52 1003 cv_undef(MUTABLE_CV(sv));
b290562e
FC
1004 if (gv) CvGV_set(MUTABLE_CV(sv), gv);
1005 else if (hek) {
1006 SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
1007 CvNAMED_on(sv);
1008 }
6fc92669 1009 }
a0d0e21e 1010 break;
8e07c86e 1011 case SVt_PVGV:
bc1df6c2
FC
1012 assert(isGV_with_GP(sv));
1013 assert(!SvFAKE(sv));
1014 {
20408e3c 1015 GP *gp;
dd69841b
BB
1016 HV *stash;
1017
dd69841b 1018 /* undef *Pkg::meth_name ... */
e530fb81
FC
1019 bool method_changed
1020 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1021 && HvENAME_get(stash);
1022 /* undef *Foo:: */
1023 if((stash = GvHV((const GV *)sv))) {
1024 if(HvENAME_get(stash))
1025 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1026 else stash = NULL;
1027 }
dd69841b 1028
795eb8c8 1029 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
159b6efe 1030 gp_free(MUTABLE_GV(sv));
a02a5408 1031 Newxz(gp, 1, GP);
c43ae56f 1032 GvGP_set(sv, gp_ref(gp));
2e3295e3 1033#ifndef PERL_DONT_CREATE_GVSV
561b68a9 1034 GvSV(sv) = newSV(0);
2e3295e3 1035#endif
57843af0 1036 GvLINE(sv) = CopLINE(PL_curcop);
159b6efe 1037 GvEGV(sv) = MUTABLE_GV(sv);
20408e3c 1038 GvMULTI_on(sv);
e530fb81
FC
1039
1040 if(stash)
afdbe55d 1041 mro_package_moved(NULL, stash, (const GV *)sv, 0);
e530fb81
FC
1042 stash = NULL;
1043 /* undef *Foo::ISA */
1044 if( strEQ(GvNAME((const GV *)sv), "ISA")
1045 && (stash = GvSTASH((const GV *)sv))
1046 && (method_changed || HvENAME(stash)) )
1047 mro_isa_changed_in(stash);
1048 else if(method_changed)
1049 mro_method_changed_in(
da9043f5 1050 GvSTASH((const GV *)sv)
e530fb81
FC
1051 );
1052
6e592b3a 1053 break;
20408e3c 1054 }
a0d0e21e 1055 default:
b15aece3 1056 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
8bd4d4c5 1057 SvPV_free(sv);
c445ea15 1058 SvPV_set(sv, NULL);
4633a7c4 1059 SvLEN_set(sv, 0);
a0d0e21e 1060 }
0c34ef67 1061 SvOK_off(sv);
4633a7c4 1062 SvSETMAGIC(sv);
79072805 1063 }
a0d0e21e
LW
1064
1065 RETPUSHUNDEF;
79072805
LW
1066}
1067
a0d0e21e
LW
1068PP(pp_postinc)
1069{
97aff369 1070 dVAR; dSP; dTARGET;
c22c99bc
FC
1071 const bool inc =
1072 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
60092ce4 1073 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
cb077ed2 1074 Perl_croak_no_modify();
7dcb9b98
DM
1075 if (SvROK(TOPs))
1076 TARG = sv_newmortal();
a0d0e21e 1077 sv_setsv(TARG, TOPs);
4bac9ae4 1078 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
c22c99bc 1079 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
55497cff 1080 {
c22c99bc 1081 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
55497cff 1082 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306 1083 }
c22c99bc 1084 else if (inc)
6f1401dc 1085 sv_inc_nomg(TOPs);
c22c99bc 1086 else sv_dec_nomg(TOPs);
a0d0e21e 1087 SvSETMAGIC(TOPs);
1e54a23f 1088 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
c22c99bc 1089 if (inc && !SvOK(TARG))
a0d0e21e
LW
1090 sv_setiv(TARG, 0);
1091 SETs(TARG);
1092 return NORMAL;
1093}
79072805 1094
a0d0e21e
LW
1095/* Ordinary operators. */
1096
1097PP(pp_pow)
1098{
800401ee 1099 dVAR; dSP; dATARGET; SV *svl, *svr;
58d76dfd 1100#ifdef PERL_PRESERVE_IVUV
52a96ae6
HS
1101 bool is_int = 0;
1102#endif
6f1401dc
DM
1103 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1104 svr = TOPs;
1105 svl = TOPm1s;
52a96ae6
HS
1106#ifdef PERL_PRESERVE_IVUV
1107 /* For integer to integer power, we do the calculation by hand wherever
1108 we're sure it is safe; otherwise we call pow() and try to convert to
1109 integer afterwards. */
01f91bf2 1110 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
900658e3
PF
1111 UV power;
1112 bool baseuok;
1113 UV baseuv;
1114
800401ee
JH
1115 if (SvUOK(svr)) {
1116 power = SvUVX(svr);
900658e3 1117 } else {
800401ee 1118 const IV iv = SvIVX(svr);
900658e3
PF
1119 if (iv >= 0) {
1120 power = iv;
1121 } else {
1122 goto float_it; /* Can't do negative powers this way. */
1123 }
1124 }
1125
800401ee 1126 baseuok = SvUOK(svl);
900658e3 1127 if (baseuok) {
800401ee 1128 baseuv = SvUVX(svl);
900658e3 1129 } else {
800401ee 1130 const IV iv = SvIVX(svl);
900658e3
PF
1131 if (iv >= 0) {
1132 baseuv = iv;
1133 baseuok = TRUE; /* effectively it's a UV now */
1134 } else {
1135 baseuv = -iv; /* abs, baseuok == false records sign */
1136 }
1137 }
52a96ae6
HS
1138 /* now we have integer ** positive integer. */
1139 is_int = 1;
1140
1141 /* foo & (foo - 1) is zero only for a power of 2. */
58d76dfd 1142 if (!(baseuv & (baseuv - 1))) {
52a96ae6 1143 /* We are raising power-of-2 to a positive integer.
58d76dfd
JH
1144 The logic here will work for any base (even non-integer
1145 bases) but it can be less accurate than
1146 pow (base,power) or exp (power * log (base)) when the
1147 intermediate values start to spill out of the mantissa.
1148 With powers of 2 we know this can't happen.
1149 And powers of 2 are the favourite thing for perl
1150 programmers to notice ** not doing what they mean. */
1151 NV result = 1.0;
1152 NV base = baseuok ? baseuv : -(NV)baseuv;
900658e3
PF
1153
1154 if (power & 1) {
1155 result *= base;
1156 }
1157 while (power >>= 1) {
1158 base *= base;
1159 if (power & 1) {
1160 result *= base;
1161 }
1162 }
58d76dfd
JH
1163 SP--;
1164 SETn( result );
6f1401dc 1165 SvIV_please_nomg(svr);
58d76dfd 1166 RETURN;
52a96ae6 1167 } else {
eb578fdb
KW
1168 unsigned int highbit = 8 * sizeof(UV);
1169 unsigned int diff = 8 * sizeof(UV);
900658e3
PF
1170 while (diff >>= 1) {
1171 highbit -= diff;
1172 if (baseuv >> highbit) {
1173 highbit += diff;
1174 }
52a96ae6
HS
1175 }
1176 /* we now have baseuv < 2 ** highbit */
1177 if (power * highbit <= 8 * sizeof(UV)) {
1178 /* result will definitely fit in UV, so use UV math
1179 on same algorithm as above */
eb578fdb
KW
1180 UV result = 1;
1181 UV base = baseuv;
f2338a2e 1182 const bool odd_power = cBOOL(power & 1);
900658e3
PF
1183 if (odd_power) {
1184 result *= base;
1185 }
1186 while (power >>= 1) {
1187 base *= base;
1188 if (power & 1) {
52a96ae6 1189 result *= base;
52a96ae6
HS
1190 }
1191 }
1192 SP--;
0615a994 1193 if (baseuok || !odd_power)
52a96ae6
HS
1194 /* answer is positive */
1195 SETu( result );
1196 else if (result <= (UV)IV_MAX)
1197 /* answer negative, fits in IV */
1198 SETi( -(IV)result );
1199 else if (result == (UV)IV_MIN)
1200 /* 2's complement assumption: special case IV_MIN */
1201 SETi( IV_MIN );
1202 else
1203 /* answer negative, doesn't fit */
1204 SETn( -(NV)result );
1205 RETURN;
1206 }
1207 }
58d76dfd 1208 }
52a96ae6 1209 float_it:
58d76dfd 1210#endif
a0d0e21e 1211 {
6f1401dc
DM
1212 NV right = SvNV_nomg(svr);
1213 NV left = SvNV_nomg(svl);
4efa5a16 1214 (void)POPs;
3aaeb624
JA
1215
1216#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1217 /*
1218 We are building perl with long double support and are on an AIX OS
1219 afflicted with a powl() function that wrongly returns NaNQ for any
1220 negative base. This was reported to IBM as PMR #23047-379 on
1221 03/06/2006. The problem exists in at least the following versions
1222 of AIX and the libm fileset, and no doubt others as well:
1223
1224 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1225 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1226 AIX 5.2.0 bos.adt.libm 5.2.0.85
1227
1228 So, until IBM fixes powl(), we provide the following workaround to
1229 handle the problem ourselves. Our logic is as follows: for
1230 negative bases (left), we use fmod(right, 2) to check if the
1231 exponent is an odd or even integer:
1232
1233 - if odd, powl(left, right) == -powl(-left, right)
1234 - if even, powl(left, right) == powl(-left, right)
1235
1236 If the exponent is not an integer, the result is rightly NaNQ, so
1237 we just return that (as NV_NAN).
1238 */
1239
1240 if (left < 0.0) {
1241 NV mod2 = Perl_fmod( right, 2.0 );
1242 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1243 SETn( -Perl_pow( -left, right) );
1244 } else if (mod2 == 0.0) { /* even integer */
1245 SETn( Perl_pow( -left, right) );
1246 } else { /* fractional power */
1247 SETn( NV_NAN );
1248 }
1249 } else {
1250 SETn( Perl_pow( left, right) );
1251 }
1252#else
52a96ae6 1253 SETn( Perl_pow( left, right) );
3aaeb624
JA
1254#endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1255
52a96ae6
HS
1256#ifdef PERL_PRESERVE_IVUV
1257 if (is_int)
6f1401dc 1258 SvIV_please_nomg(svr);
52a96ae6
HS
1259#endif
1260 RETURN;
93a17b20 1261 }
a0d0e21e
LW
1262}
1263
1264PP(pp_multiply)
1265{
800401ee 1266 dVAR; dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM
1267 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1268 svr = TOPs;
1269 svl = TOPm1s;
28e5dec8 1270#ifdef PERL_PRESERVE_IVUV
01f91bf2 1271 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1272 /* Unless the left argument is integer in range we are going to have to
1273 use NV maths. Hence only attempt to coerce the right argument if
1274 we know the left is integer. */
1275 /* Left operand is defined, so is it IV? */
01f91bf2 1276 if (SvIV_please_nomg(svl)) {
800401ee
JH
1277 bool auvok = SvUOK(svl);
1278 bool buvok = SvUOK(svr);
28e5dec8
JH
1279 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1280 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1281 UV alow;
1282 UV ahigh;
1283 UV blow;
1284 UV bhigh;
1285
1286 if (auvok) {
800401ee 1287 alow = SvUVX(svl);
28e5dec8 1288 } else {
800401ee 1289 const IV aiv = SvIVX(svl);
28e5dec8
JH
1290 if (aiv >= 0) {
1291 alow = aiv;
1292 auvok = TRUE; /* effectively it's a UV now */
1293 } else {
1294 alow = -aiv; /* abs, auvok == false records sign */
1295 }
1296 }
1297 if (buvok) {
800401ee 1298 blow = SvUVX(svr);
28e5dec8 1299 } else {
800401ee 1300 const IV biv = SvIVX(svr);
28e5dec8
JH
1301 if (biv >= 0) {
1302 blow = biv;
1303 buvok = TRUE; /* effectively it's a UV now */
1304 } else {
1305 blow = -biv; /* abs, buvok == false records sign */
1306 }
1307 }
1308
1309 /* If this does sign extension on unsigned it's time for plan B */
1310 ahigh = alow >> (4 * sizeof (UV));
1311 alow &= botmask;
1312 bhigh = blow >> (4 * sizeof (UV));
1313 blow &= botmask;
1314 if (ahigh && bhigh) {
6f207bd3 1315 NOOP;
28e5dec8
JH
1316 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1317 which is overflow. Drop to NVs below. */
1318 } else if (!ahigh && !bhigh) {
1319 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1320 so the unsigned multiply cannot overflow. */
c445ea15 1321 const UV product = alow * blow;
28e5dec8
JH
1322 if (auvok == buvok) {
1323 /* -ve * -ve or +ve * +ve gives a +ve result. */
1324 SP--;
1325 SETu( product );
1326 RETURN;
1327 } else if (product <= (UV)IV_MIN) {
1328 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1329 /* -ve result, which could overflow an IV */
1330 SP--;
25716404 1331 SETi( -(IV)product );
28e5dec8
JH
1332 RETURN;
1333 } /* else drop to NVs below. */
1334 } else {
1335 /* One operand is large, 1 small */
1336 UV product_middle;
1337 if (bhigh) {
1338 /* swap the operands */
1339 ahigh = bhigh;
1340 bhigh = blow; /* bhigh now the temp var for the swap */
1341 blow = alow;
1342 alow = bhigh;
1343 }
1344 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1345 multiplies can't overflow. shift can, add can, -ve can. */
1346 product_middle = ahigh * blow;
1347 if (!(product_middle & topmask)) {
1348 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1349 UV product_low;
1350 product_middle <<= (4 * sizeof (UV));
1351 product_low = alow * blow;
1352
1353 /* as for pp_add, UV + something mustn't get smaller.
1354 IIRC ANSI mandates this wrapping *behaviour* for
1355 unsigned whatever the actual representation*/
1356 product_low += product_middle;
1357 if (product_low >= product_middle) {
1358 /* didn't overflow */
1359 if (auvok == buvok) {
1360 /* -ve * -ve or +ve * +ve gives a +ve result. */
1361 SP--;
1362 SETu( product_low );
1363 RETURN;
1364 } else if (product_low <= (UV)IV_MIN) {
1365 /* 2s complement assumption again */
1366 /* -ve result, which could overflow an IV */
1367 SP--;
25716404 1368 SETi( -(IV)product_low );
28e5dec8
JH
1369 RETURN;
1370 } /* else drop to NVs below. */
1371 }
1372 } /* product_middle too large */
1373 } /* ahigh && bhigh */
800401ee
JH
1374 } /* SvIOK(svl) */
1375 } /* SvIOK(svr) */
28e5dec8 1376#endif
a0d0e21e 1377 {
6f1401dc
DM
1378 NV right = SvNV_nomg(svr);
1379 NV left = SvNV_nomg(svl);
4efa5a16 1380 (void)POPs;
a0d0e21e
LW
1381 SETn( left * right );
1382 RETURN;
79072805 1383 }
a0d0e21e
LW
1384}
1385
1386PP(pp_divide)
1387{
800401ee 1388 dVAR; dSP; dATARGET; SV *svl, *svr;
6f1401dc
DM
1389 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1390 svr = TOPs;
1391 svl = TOPm1s;
5479d192 1392 /* Only try to do UV divide first
68795e93 1393 if ((SLOPPYDIVIDE is true) or
5479d192
NC
1394 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1395 to preserve))
1396 The assumption is that it is better to use floating point divide
1397 whenever possible, only doing integer divide first if we can't be sure.
1398 If NV_PRESERVES_UV is true then we know at compile time that no UV
1399 can be too large to preserve, so don't need to compile the code to
1400 test the size of UVs. */
1401
a0d0e21e 1402#ifdef SLOPPYDIVIDE
5479d192
NC
1403# define PERL_TRY_UV_DIVIDE
1404 /* ensure that 20./5. == 4. */
a0d0e21e 1405#else
5479d192
NC
1406# ifdef PERL_PRESERVE_IVUV
1407# ifndef NV_PRESERVES_UV
1408# define PERL_TRY_UV_DIVIDE
1409# endif
1410# endif
a0d0e21e 1411#endif
5479d192
NC
1412
1413#ifdef PERL_TRY_UV_DIVIDE
01f91bf2 1414 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
800401ee
JH
1415 bool left_non_neg = SvUOK(svl);
1416 bool right_non_neg = SvUOK(svr);
5479d192
NC
1417 UV left;
1418 UV right;
1419
1420 if (right_non_neg) {
800401ee 1421 right = SvUVX(svr);
5479d192
NC
1422 }
1423 else {
800401ee 1424 const IV biv = SvIVX(svr);
5479d192
NC
1425 if (biv >= 0) {
1426 right = biv;
1427 right_non_neg = TRUE; /* effectively it's a UV now */
1428 }
1429 else {
1430 right = -biv;
1431 }
1432 }
1433 /* historically undef()/0 gives a "Use of uninitialized value"
1434 warning before dieing, hence this test goes here.
1435 If it were immediately before the second SvIV_please, then
1436 DIE() would be invoked before left was even inspected, so
486ec47a 1437 no inspection would give no warning. */
5479d192
NC
1438 if (right == 0)
1439 DIE(aTHX_ "Illegal division by zero");
1440
1441 if (left_non_neg) {
800401ee 1442 left = SvUVX(svl);
5479d192
NC
1443 }
1444 else {
800401ee 1445 const IV aiv = SvIVX(svl);
5479d192
NC
1446 if (aiv >= 0) {
1447 left = aiv;
1448 left_non_neg = TRUE; /* effectively it's a UV now */
1449 }
1450 else {
1451 left = -aiv;
1452 }
1453 }
1454
1455 if (left >= right
1456#ifdef SLOPPYDIVIDE
1457 /* For sloppy divide we always attempt integer division. */
1458#else
1459 /* Otherwise we only attempt it if either or both operands
1460 would not be preserved by an NV. If both fit in NVs
0c2ee62a
NC
1461 we fall through to the NV divide code below. However,
1462 as left >= right to ensure integer result here, we know that
1463 we can skip the test on the right operand - right big
1464 enough not to be preserved can't get here unless left is
1465 also too big. */
1466
1467 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
5479d192
NC
1468#endif
1469 ) {
1470 /* Integer division can't overflow, but it can be imprecise. */
1b6737cc 1471 const UV result = left / right;
5479d192
NC
1472 if (result * right == left) {
1473 SP--; /* result is valid */
1474 if (left_non_neg == right_non_neg) {
1475 /* signs identical, result is positive. */
1476 SETu( result );
1477 RETURN;
1478 }
1479 /* 2s complement assumption */
1480 if (result <= (UV)IV_MIN)
91f3b821 1481 SETi( -(IV)result );
5479d192
NC
1482 else {
1483 /* It's exact but too negative for IV. */
1484 SETn( -(NV)result );
1485 }
1486 RETURN;
1487 } /* tried integer divide but it was not an integer result */
32fdb065 1488 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
01f91bf2 1489 } /* one operand wasn't SvIOK */
5479d192
NC
1490#endif /* PERL_TRY_UV_DIVIDE */
1491 {
6f1401dc
DM
1492 NV right = SvNV_nomg(svr);
1493 NV left = SvNV_nomg(svl);
4efa5a16 1494 (void)POPs;(void)POPs;
ebc6a117
PD
1495#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1496 if (! Perl_isnan(right) && right == 0.0)
1497#else
659c4b96 1498 if (right == 0.0)
ebc6a117 1499#endif
5479d192
NC
1500 DIE(aTHX_ "Illegal division by zero");
1501 PUSHn( left / right );
1502 RETURN;
79072805 1503 }
a0d0e21e
LW
1504}
1505
1506PP(pp_modulo)
1507{
6f1401dc
DM
1508 dVAR; dSP; dATARGET;
1509 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
a0d0e21e 1510 {
9c5ffd7c
JH
1511 UV left = 0;
1512 UV right = 0;
dc656993
JH
1513 bool left_neg = FALSE;
1514 bool right_neg = FALSE;
e2c88acc
NC
1515 bool use_double = FALSE;
1516 bool dright_valid = FALSE;
9c5ffd7c
JH
1517 NV dright = 0.0;
1518 NV dleft = 0.0;
6f1401dc
DM
1519 SV * const svr = TOPs;
1520 SV * const svl = TOPm1s;
01f91bf2 1521 if (SvIV_please_nomg(svr)) {
800401ee 1522 right_neg = !SvUOK(svr);
e2c88acc 1523 if (!right_neg) {
800401ee 1524 right = SvUVX(svr);
e2c88acc 1525 } else {
800401ee 1526 const IV biv = SvIVX(svr);
e2c88acc
NC
1527 if (biv >= 0) {
1528 right = biv;
1529 right_neg = FALSE; /* effectively it's a UV now */
1530 } else {
1531 right = -biv;
1532 }
1533 }
1534 }
1535 else {
6f1401dc 1536 dright = SvNV_nomg(svr);
787eafbd
IZ
1537 right_neg = dright < 0;
1538 if (right_neg)
1539 dright = -dright;
e2c88acc
NC
1540 if (dright < UV_MAX_P1) {
1541 right = U_V(dright);
1542 dright_valid = TRUE; /* In case we need to use double below. */
1543 } else {
1544 use_double = TRUE;
1545 }
787eafbd 1546 }
a0d0e21e 1547
e2c88acc
NC
1548 /* At this point use_double is only true if right is out of range for
1549 a UV. In range NV has been rounded down to nearest UV and
1550 use_double false. */
01f91bf2 1551 if (!use_double && SvIV_please_nomg(svl)) {
800401ee 1552 left_neg = !SvUOK(svl);
e2c88acc 1553 if (!left_neg) {
800401ee 1554 left = SvUVX(svl);
e2c88acc 1555 } else {
800401ee 1556 const IV aiv = SvIVX(svl);
e2c88acc
NC
1557 if (aiv >= 0) {
1558 left = aiv;
1559 left_neg = FALSE; /* effectively it's a UV now */
1560 } else {
1561 left = -aiv;
1562 }
1563 }
e2c88acc 1564 }
787eafbd 1565 else {
6f1401dc 1566 dleft = SvNV_nomg(svl);
787eafbd
IZ
1567 left_neg = dleft < 0;
1568 if (left_neg)
1569 dleft = -dleft;
68dc0745 1570
e2c88acc
NC
1571 /* This should be exactly the 5.6 behaviour - if left and right are
1572 both in range for UV then use U_V() rather than floor. */
1573 if (!use_double) {
1574 if (dleft < UV_MAX_P1) {
1575 /* right was in range, so is dleft, so use UVs not double.
1576 */
1577 left = U_V(dleft);
1578 }
1579 /* left is out of range for UV, right was in range, so promote
1580 right (back) to double. */
1581 else {
1582 /* The +0.5 is used in 5.6 even though it is not strictly
1583 consistent with the implicit +0 floor in the U_V()
1584 inside the #if 1. */
1585 dleft = Perl_floor(dleft + 0.5);
1586 use_double = TRUE;
1587 if (dright_valid)
1588 dright = Perl_floor(dright + 0.5);
1589 else
1590 dright = right;
1591 }
1592 }
1593 }
6f1401dc 1594 sp -= 2;
787eafbd 1595 if (use_double) {
65202027 1596 NV dans;
787eafbd 1597
659c4b96 1598 if (!dright)
cea2e8a9 1599 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1600
65202027 1601 dans = Perl_fmod(dleft, dright);
659c4b96 1602 if ((left_neg != right_neg) && dans)
787eafbd
IZ
1603 dans = dright - dans;
1604 if (right_neg)
1605 dans = -dans;
1606 sv_setnv(TARG, dans);
1607 }
1608 else {
1609 UV ans;
1610
787eafbd 1611 if (!right)
cea2e8a9 1612 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ
1613
1614 ans = left % right;
1615 if ((left_neg != right_neg) && ans)
1616 ans = right - ans;
1617 if (right_neg) {
1618 /* XXX may warn: unary minus operator applied to unsigned type */
1619 /* could change -foo to be (~foo)+1 instead */
1620 if (ans <= ~((UV)IV_MAX)+1)
1621 sv_setiv(TARG, ~ans+1);
1622 else
65202027 1623 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ
1624 }
1625 else
1626 sv_setuv(TARG, ans);
1627 }
1628 PUSHTARG;
1629 RETURN;
79072805 1630 }
a0d0e21e 1631}
79072805 1632
a0d0e21e
LW
1633PP(pp_repeat)
1634{
6f1401dc 1635 dVAR; dSP; dATARGET;
eb578fdb 1636 IV count;
6f1401dc
DM
1637 SV *sv;
1638
1639 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1640 /* TODO: think of some way of doing list-repeat overloading ??? */
1641 sv = POPs;
1642 SvGETMAGIC(sv);
1643 }
1644 else {
1645 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1646 sv = POPs;
1647 }
1648
2b573ace
JH
1649 if (SvIOKp(sv)) {
1650 if (SvUOK(sv)) {
6f1401dc 1651 const UV uv = SvUV_nomg(sv);
2b573ace
JH
1652 if (uv > IV_MAX)
1653 count = IV_MAX; /* The best we can do? */
1654 else
1655 count = uv;
1656 } else {
6f1401dc 1657 const IV iv = SvIV_nomg(sv);
2b573ace
JH
1658 if (iv < 0)
1659 count = 0;
1660 else
1661 count = iv;
1662 }
1663 }
1664 else if (SvNOKp(sv)) {
6f1401dc 1665 const NV nv = SvNV_nomg(sv);
2b573ace
JH
1666 if (nv < 0.0)
1667 count = 0;
1668 else
1669 count = (IV)nv;
1670 }
1671 else
6f1401dc
DM
1672 count = SvIV_nomg(sv);
1673
533c011a 1674 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e 1675 dMARK;
a1894d81 1676 static const char* const oom_list_extend = "Out of memory during list extend";
0bd48802
AL
1677 const I32 items = SP - MARK;
1678 const I32 max = items * count;
da9e430b 1679 const U8 mod = PL_op->op_flags & OPf_MOD;
79072805 1680
2b573ace
JH
1681 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1682 /* Did the max computation overflow? */
27d5b266 1683 if (items > 0 && max > 0 && (max < items || max < count))
0157ef98 1684 Perl_croak(aTHX_ "%s", oom_list_extend);
a0d0e21e
LW
1685 MEXTEND(MARK, max);
1686 if (count > 1) {
1687 while (SP > MARK) {
976c8a39
JH
1688#if 0
1689 /* This code was intended to fix 20010809.028:
1690
1691 $x = 'abcd';
1692 for (($x =~ /./g) x 2) {
1693 print chop; # "abcdabcd" expected as output.
1694 }
1695
1696 * but that change (#11635) broke this code:
1697
1698 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1699
1700 * I can't think of a better fix that doesn't introduce
1701 * an efficiency hit by copying the SVs. The stack isn't
1702 * refcounted, and mortalisation obviously doesn't
1703 * Do The Right Thing when the stack has more than
1704 * one pointer to the same mortal value.
1705 * .robin.
1706 */
e30acc16
RH
1707 if (*SP) {
1708 *SP = sv_2mortal(newSVsv(*SP));
1709 SvREADONLY_on(*SP);
1710 }
976c8a39 1711#else
60779a30
DM
1712 if (*SP) {
1713 if (mod && SvPADTMP(*SP)) {
1714 assert(!IS_PADGV(*SP));
da9e430b 1715 *SP = sv_mortalcopy(*SP);
60779a30 1716 }
976c8a39 1717 SvTEMP_off((*SP));
da9e430b 1718 }
976c8a39 1719#endif
a0d0e21e 1720 SP--;
79072805 1721 }
a0d0e21e
LW
1722 MARK++;
1723 repeatcpy((char*)(MARK + items), (char*)MARK,
ad64d0ec 1724 items * sizeof(const SV *), count - 1);
a0d0e21e 1725 SP += max;
79072805 1726 }
a0d0e21e
LW
1727 else if (count <= 0)
1728 SP -= items;
79072805 1729 }
a0d0e21e 1730 else { /* Note: mark already snarfed by pp_list */
0bd48802 1731 SV * const tmpstr = POPs;
a0d0e21e 1732 STRLEN len;
9b877dbb 1733 bool isutf;
a1894d81 1734 static const char* const oom_string_extend =
2b573ace 1735 "Out of memory during string extend";
a0d0e21e 1736
6f1401dc
DM
1737 if (TARG != tmpstr)
1738 sv_setsv_nomg(TARG, tmpstr);
1739 SvPV_force_nomg(TARG, len);
9b877dbb 1740 isutf = DO_UTF8(TARG);
8ebc5c01
PP
1741 if (count != 1) {
1742 if (count < 1)
1743 SvCUR_set(TARG, 0);
1744 else {
c445ea15 1745 const STRLEN max = (UV)count * len;
19a94d75 1746 if (len > MEM_SIZE_MAX / count)
0157ef98 1747 Perl_croak(aTHX_ "%s", oom_string_extend);
2b573ace 1748 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
8569b9dc 1749 SvGROW(TARG, max + 1);
a0d0e21e 1750 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
b162af07 1751 SvCUR_set(TARG, SvCUR(TARG) * count);
7a4c00b4 1752 }
a0d0e21e 1753 *SvEND(TARG) = '\0';
a0d0e21e 1754 }
dfcb284a
GS
1755 if (isutf)
1756 (void)SvPOK_only_UTF8(TARG);
1757 else
1758 (void)SvPOK_only(TARG);
b80b6069
RH
1759
1760 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1761 /* The parser saw this as a list repeat, and there
1762 are probably several items on the stack. But we're
1763 in scalar context, and there's no pp_list to save us
1764 now. So drop the rest of the items -- robin@kitsite.com
1765 */
1766 dMARK;
1767 SP = MARK;
1768 }
a0d0e21e 1769 PUSHTARG;
79072805 1770 }
a0d0e21e
LW
1771 RETURN;
1772}
79072805 1773
a0d0e21e
LW
1774PP(pp_subtract)
1775{
800401ee 1776 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
6f1401dc
DM
1777 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1778 svr = TOPs;
1779 svl = TOPm1s;
800401ee 1780 useleft = USE_LEFT(svl);
28e5dec8 1781#ifdef PERL_PRESERVE_IVUV
7dca457a
NC
1782 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1783 "bad things" happen if you rely on signed integers wrapping. */
01f91bf2 1784 if (SvIV_please_nomg(svr)) {
28e5dec8
JH
1785 /* Unless the left argument is integer in range we are going to have to
1786 use NV maths. Hence only attempt to coerce the right argument if
1787 we know the left is integer. */
eb578fdb 1788 UV auv = 0;
9c5ffd7c 1789 bool auvok = FALSE;
7dca457a
NC
1790 bool a_valid = 0;
1791
28e5dec8 1792 if (!useleft) {
7dca457a
NC
1793 auv = 0;
1794 a_valid = auvok = 1;
1795 /* left operand is undef, treat as zero. */
28e5dec8
JH
1796 } else {
1797 /* Left operand is defined, so is it IV? */
01f91bf2 1798 if (SvIV_please_nomg(svl)) {
800401ee
JH
1799 if ((auvok = SvUOK(svl)))
1800 auv = SvUVX(svl);
7dca457a 1801 else {
eb578fdb 1802 const IV aiv = SvIVX(svl);
7dca457a
NC
1803 if (aiv >= 0) {
1804 auv = aiv;
1805 auvok = 1; /* Now acting as a sign flag. */
1806 } else { /* 2s complement assumption for IV_MIN */
1807 auv = (UV)-aiv;
28e5dec8 1808 }
7dca457a
NC
1809 }
1810 a_valid = 1;
1811 }
1812 }
1813 if (a_valid) {
1814 bool result_good = 0;
1815 UV result;
eb578fdb 1816 UV buv;
800401ee 1817 bool buvok = SvUOK(svr);
9041c2e3 1818
7dca457a 1819 if (buvok)
800401ee 1820 buv = SvUVX(svr);
7dca457a 1821 else {
eb578fdb 1822 const IV biv = SvIVX(svr);
7dca457a
NC
1823 if (biv >= 0) {
1824 buv = biv;
1825 buvok = 1;
1826 } else
1827 buv = (UV)-biv;
1828 }
1829 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602f51c4 1830 else "IV" now, independent of how it came in.
7dca457a
NC
1831 if a, b represents positive, A, B negative, a maps to -A etc
1832 a - b => (a - b)
1833 A - b => -(a + b)
1834 a - B => (a + b)
1835 A - B => -(a - b)
1836 all UV maths. negate result if A negative.
1837 subtract if signs same, add if signs differ. */
1838
1839 if (auvok ^ buvok) {
1840 /* Signs differ. */
1841 result = auv + buv;
1842 if (result >= auv)
1843 result_good = 1;
1844 } else {
1845 /* Signs same */
1846 if (auv >= buv) {
1847 result = auv - buv;
1848 /* Must get smaller */
1849 if (result <= auv)
1850 result_good = 1;
1851 } else {
1852 result = buv - auv;
1853 if (result <= buv) {
1854 /* result really should be -(auv-buv). as its negation
1855 of true value, need to swap our result flag */
1856 auvok = !auvok;
1857 result_good = 1;
28e5dec8 1858 }
28e5dec8
JH
1859 }
1860 }
7dca457a
NC
1861 if (result_good) {
1862 SP--;
1863 if (auvok)
1864 SETu( result );
1865 else {
1866 /* Negate result */
1867 if (result <= (UV)IV_MIN)
1868 SETi( -(IV)result );
1869 else {
1870 /* result valid, but out of range for IV. */
1871 SETn( -(NV)result );
1872 }
1873 }
1874 RETURN;
1875 } /* Overflow, drop through to NVs. */
28e5dec8
JH
1876 }
1877 }
1878#endif
a0d0e21e 1879 {
6f1401dc 1880 NV value = SvNV_nomg(svr);
4efa5a16
RD
1881 (void)POPs;
1882
28e5dec8
JH
1883 if (!useleft) {
1884 /* left operand is undef, treat as zero - value */
1885 SETn(-value);
1886 RETURN;
1887 }
6f1401dc 1888 SETn( SvNV_nomg(svl) - value );
28e5dec8 1889 RETURN;
79072805 1890 }
a0d0e21e 1891}
79072805 1892
a0d0e21e
LW
1893PP(pp_left_shift)
1894{
6f1401dc 1895 dVAR; dSP; dATARGET; SV *svl, *svr;
a42d0242 1896 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1897 svr = POPs;
1898 svl = TOPs;
a0d0e21e 1899 {
6f1401dc 1900 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1901 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1902 const IV i = SvIV_nomg(svl);
972b05a9 1903 SETi(i << shift);
d0ba1bd2
JH
1904 }
1905 else {
6f1401dc 1906 const UV u = SvUV_nomg(svl);
972b05a9 1907 SETu(u << shift);
d0ba1bd2 1908 }
55497cff 1909 RETURN;
79072805 1910 }
a0d0e21e 1911}
79072805 1912
a0d0e21e
LW
1913PP(pp_right_shift)
1914{
6f1401dc 1915 dVAR; dSP; dATARGET; SV *svl, *svr;
a42d0242 1916 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
6f1401dc
DM
1917 svr = POPs;
1918 svl = TOPs;
a0d0e21e 1919 {
6f1401dc 1920 const IV shift = SvIV_nomg(svr);
d0ba1bd2 1921 if (PL_op->op_private & HINT_INTEGER) {
6f1401dc 1922 const IV i = SvIV_nomg(svl);
972b05a9 1923 SETi(i >> shift);
d0ba1bd2
JH
1924 }
1925 else {
6f1401dc 1926 const UV u = SvUV_nomg(svl);
972b05a9 1927 SETu(u >> shift);
d0ba1bd2 1928 }
a0d0e21e 1929 RETURN;
93a17b20 1930 }
79072805
LW
1931}
1932
a0d0e21e 1933PP(pp_lt)
79072805 1934{
6f1401dc 1935 dVAR; dSP;
33efebe6
DM
1936 SV *left, *right;
1937
a42d0242 1938 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
33efebe6
DM
1939 right = POPs;
1940 left = TOPs;
1941 SETs(boolSV(
1942 (SvIOK_notUV(left) && SvIOK_notUV(right))
1943 ? (SvIVX(left) < SvIVX(right))
1944 : (do_ncmp(left, right) == -1)
1945 ));
1946 RETURN;
a0d0e21e 1947}
79072805 1948
a0d0e21e
LW
1949PP(pp_gt)
1950{
6f1401dc 1951 dVAR; dSP;
33efebe6 1952 SV *left, *right;
1b6737cc 1953
33efebe6
DM
1954 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1955 right = POPs;
1956 left = TOPs;
1957 SETs(boolSV(
1958 (SvIOK_notUV(left) && SvIOK_notUV(right))
1959 ? (SvIVX(left) > SvIVX(right))
1960 : (do_ncmp(left, right) == 1)
1961 ));
1962 RETURN;
a0d0e21e
LW
1963}
1964
1965PP(pp_le)
1966{
6f1401dc 1967 dVAR; dSP;
33efebe6 1968 SV *left, *right;
1b6737cc 1969
33efebe6
DM
1970 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1971 right = POPs;
1972 left = TOPs;
1973 SETs(boolSV(
1974 (SvIOK_notUV(left) && SvIOK_notUV(right))
1975 ? (SvIVX(left) <= SvIVX(right))
1976 : (do_ncmp(left, right) <= 0)
1977 ));
1978 RETURN;
a0d0e21e
LW
1979}
1980
1981PP(pp_ge)
1982{
6f1401dc 1983 dVAR; dSP;
33efebe6
DM
1984 SV *left, *right;
1985
1986 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1987 right = POPs;
1988 left = TOPs;
1989 SETs(boolSV(
1990 (SvIOK_notUV(left) && SvIOK_notUV(right))
1991 ? (SvIVX(left) >= SvIVX(right))
1992 : ( (do_ncmp(left, right) & 2) == 0)
1993 ));
1994 RETURN;
1995}
1b6737cc 1996
33efebe6
DM
1997PP(pp_ne)
1998{
1999 dVAR; dSP;
2000 SV *left, *right;
2001
2002 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2003 right = POPs;
2004 left = TOPs;
2005 SETs(boolSV(
2006 (SvIOK_notUV(left) && SvIOK_notUV(right))
2007 ? (SvIVX(left) != SvIVX(right))
2008 : (do_ncmp(left, right) != 0)
2009 ));
2010 RETURN;
2011}
1b6737cc 2012
33efebe6
DM
2013/* compare left and right SVs. Returns:
2014 * -1: <
2015 * 0: ==
2016 * 1: >
2017 * 2: left or right was a NaN
2018 */
2019I32
2020Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2021{
2022 dVAR;
1b6737cc 2023
33efebe6
DM
2024 PERL_ARGS_ASSERT_DO_NCMP;
2025#ifdef PERL_PRESERVE_IVUV
33efebe6 2026 /* Fortunately it seems NaN isn't IOK */
01f91bf2 2027 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
33efebe6
DM
2028 if (!SvUOK(left)) {
2029 const IV leftiv = SvIVX(left);
2030 if (!SvUOK(right)) {
2031 /* ## IV <=> IV ## */
2032 const IV rightiv = SvIVX(right);
2033 return (leftiv > rightiv) - (leftiv < rightiv);
28e5dec8 2034 }
33efebe6
DM
2035 /* ## IV <=> UV ## */
2036 if (leftiv < 0)
2037 /* As (b) is a UV, it's >=0, so it must be < */
2038 return -1;
2039 {
2040 const UV rightuv = SvUVX(right);
2041 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
28e5dec8 2042 }
28e5dec8 2043 }
79072805 2044
33efebe6
DM
2045 if (SvUOK(right)) {
2046 /* ## UV <=> UV ## */
2047 const UV leftuv = SvUVX(left);
2048 const UV rightuv = SvUVX(right);
2049 return (leftuv > rightuv) - (leftuv < rightuv);
28e5dec8 2050 }
33efebe6
DM
2051 /* ## UV <=> IV ## */
2052 {
2053 const IV rightiv = SvIVX(right);
2054 if (rightiv < 0)
2055 /* As (a) is a UV, it's >=0, so it cannot be < */
2056 return 1;
2057 {
2058 const UV leftuv = SvUVX(left);
2059 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
28e5dec8 2060 }
28e5dec8 2061 }
118e2215 2062 assert(0); /* NOTREACHED */
28e5dec8
JH
2063 }
2064#endif
a0d0e21e 2065 {
33efebe6
DM
2066 NV const rnv = SvNV_nomg(right);
2067 NV const lnv = SvNV_nomg(left);
2068
cab190d4 2069#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
33efebe6
DM
2070 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2071 return 2;
2072 }
2073 return (lnv > rnv) - (lnv < rnv);
cab190d4 2074#else
33efebe6
DM
2075 if (lnv < rnv)
2076 return -1;
2077 if (lnv > rnv)
2078 return 1;
659c4b96 2079 if (lnv == rnv)
33efebe6
DM
2080 return 0;
2081 return 2;
cab190d4 2082#endif
a0d0e21e 2083 }
79072805
LW
2084}
2085
33efebe6 2086
a0d0e21e 2087PP(pp_ncmp)
79072805 2088{
33efebe6
DM
2089 dVAR; dSP;
2090 SV *left, *right;
2091 I32 value;
a42d0242 2092 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
33efebe6
DM
2093 right = POPs;
2094 left = TOPs;
2095 value = do_ncmp(left, right);
2096 if (value == 2) {
3280af22 2097 SETs(&PL_sv_undef);
79072805 2098 }
33efebe6
DM
2099 else {
2100 dTARGET;
2101 SETi(value);
2102 }
2103 RETURN;
a0d0e21e 2104}
79072805 2105
afd9910b 2106PP(pp_sle)
a0d0e21e 2107{
97aff369 2108 dVAR; dSP;
79072805 2109
afd9910b
NC
2110 int amg_type = sle_amg;
2111 int multiplier = 1;
2112 int rhs = 1;
79072805 2113
afd9910b
NC
2114 switch (PL_op->op_type) {
2115 case OP_SLT:
2116 amg_type = slt_amg;
2117 /* cmp < 0 */
2118 rhs = 0;
2119 break;
2120 case OP_SGT:
2121 amg_type = sgt_amg;
2122 /* cmp > 0 */
2123 multiplier = -1;
2124 rhs = 0;
2125 break;
2126 case OP_SGE:
2127 amg_type = sge_amg;
2128 /* cmp >= 0 */
2129 multiplier = -1;
2130 break;
79072805 2131 }
79072805 2132
6f1401dc 2133 tryAMAGICbin_MG(amg_type, AMGf_set);
a0d0e21e
LW
2134 {
2135 dPOPTOPssrl;
d6ded950 2136 const int cmp = (IN_LC_RUNTIME(LC_COLLATE)
078504b2
FC
2137 ? sv_cmp_locale_flags(left, right, 0)
2138 : sv_cmp_flags(left, right, 0));
afd9910b 2139 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW
2140 RETURN;
2141 }
2142}
79072805 2143
36477c24
PP
2144PP(pp_seq)
2145{
6f1401dc
DM
2146 dVAR; dSP;
2147 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24
PP
2148 {
2149 dPOPTOPssrl;
078504b2 2150 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW
2151 RETURN;
2152 }
2153}
79072805 2154
a0d0e21e 2155PP(pp_sne)
79072805 2156{
6f1401dc
DM
2157 dVAR; dSP;
2158 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW
2159 {
2160 dPOPTOPssrl;
078504b2 2161 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2162 RETURN;
463ee0b2 2163 }
79072805
LW
2164}
2165
a0d0e21e 2166PP(pp_scmp)
79072805 2167{
6f1401dc
DM
2168 dVAR; dSP; dTARGET;
2169 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW
2170 {
2171 dPOPTOPssrl;
d6ded950 2172 const int cmp = (IN_LC_RUNTIME(LC_COLLATE)
078504b2
FC
2173 ? sv_cmp_locale_flags(left, right, 0)
2174 : sv_cmp_flags(left, right, 0));
bbce6d69 2175 SETi( cmp );
a0d0e21e
LW
2176 RETURN;
2177 }
2178}
79072805 2179
55497cff
PP
2180PP(pp_bit_and)
2181{
6f1401dc
DM
2182 dVAR; dSP; dATARGET;
2183 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW
2184 {
2185 dPOPTOPssrl;
4633a7c4 2186 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2187 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2188 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2189 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2190 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2191 SETi(i);
d0ba1bd2
JH
2192 }
2193 else {
1b6737cc 2194 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2195 SETu(u);
d0ba1bd2 2196 }
5ee80e13 2197 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2198 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2199 }
2200 else {
533c011a 2201 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2202 SETTARG;
2203 }
2204 RETURN;
2205 }
2206}
79072805 2207
a0d0e21e
LW
2208PP(pp_bit_or)
2209{
3658c1f1
NC
2210 dVAR; dSP; dATARGET;
2211 const int op_type = PL_op->op_type;
2212
6f1401dc 2213 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW
2214 {
2215 dPOPTOPssrl;
4633a7c4 2216 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2217 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2218 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2219 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC
2220 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2221 const IV r = SvIV_nomg(right);
2222 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2223 SETi(result);
d0ba1bd2
JH
2224 }
2225 else {
3658c1f1
NC
2226 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2227 const UV r = SvUV_nomg(right);
2228 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2229 SETu(result);
d0ba1bd2 2230 }
5ee80e13 2231 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2232 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2233 }
2234 else {
3658c1f1 2235 do_vop(op_type, TARG, left, right);
a0d0e21e
LW
2236 SETTARG;
2237 }
2238 RETURN;
79072805 2239 }
a0d0e21e 2240}
79072805 2241
1c2b3fd6
FC
2242PERL_STATIC_INLINE bool
2243S_negate_string(pTHX)
2244{
2245 dTARGET; dSP;
2246 STRLEN len;
2247 const char *s;
2248 SV * const sv = TOPs;
2249 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2250 return FALSE;
2251 s = SvPV_nomg_const(sv, len);
2252 if (isIDFIRST(*s)) {
2253 sv_setpvs(TARG, "-");
2254 sv_catsv(TARG, sv);
2255 }
2256 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2257 sv_setsv_nomg(TARG, sv);
2258 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2259 }
2260 else return FALSE;
2261 SETTARG; PUTBACK;
2262 return TRUE;
2263}
2264
a0d0e21e
LW
2265PP(pp_negate)
2266{
6f1401dc
DM
2267 dVAR; dSP; dTARGET;
2268 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2269 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2270 {
6f1401dc 2271 SV * const sv = TOPs;
a5b92898 2272
d96ab1b5 2273 if (SvIOK(sv)) {
7dbe3150 2274 /* It's publicly an integer */
28e5dec8 2275 oops_its_an_int:
9b0e499b
GS
2276 if (SvIsUV(sv)) {
2277 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2278 /* 2s complement assumption. */
d14578b8
KW
2279 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2280 IV_MIN */
9b0e499b
GS
2281 RETURN;
2282 }
2283 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2284 SETi(-SvIVX(sv));
9b0e499b
GS
2285 RETURN;
2286 }
2287 }
2288 else if (SvIVX(sv) != IV_MIN) {
2289 SETi(-SvIVX(sv));
2290 RETURN;
2291 }
28e5dec8
JH
2292#ifdef PERL_PRESERVE_IVUV
2293 else {
2294 SETu((UV)IV_MIN);
2295 RETURN;
2296 }
2297#endif
9b0e499b 2298 }
8a5decd8 2299 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2300 SETn(-SvNV_nomg(sv));
1c2b3fd6 2301 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2302 goto oops_its_an_int;
4633a7c4 2303 else
6f1401dc 2304 SETn(-SvNV_nomg(sv));
79072805 2305 }
a0d0e21e 2306 RETURN;
79072805
LW
2307}
2308
a0d0e21e 2309PP(pp_not)
79072805 2310{
6f1401dc
DM
2311 dVAR; dSP;
2312 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2313 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2314 return NORMAL;
79072805
LW
2315}
2316
a0d0e21e 2317PP(pp_complement)
79072805 2318{
6f1401dc 2319 dVAR; dSP; dTARGET;
a42d0242 2320 tryAMAGICun_MG(compl_amg, AMGf_numeric);
a0d0e21e
LW
2321 {
2322 dTOPss;
4633a7c4 2323 if (SvNIOKp(sv)) {
d0ba1bd2 2324 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2325 const IV i = ~SvIV_nomg(sv);
972b05a9 2326 SETi(i);
d0ba1bd2
JH
2327 }
2328 else {
1b6737cc 2329 const UV u = ~SvUV_nomg(sv);
972b05a9 2330 SETu(u);
d0ba1bd2 2331 }
a0d0e21e
LW
2332 }
2333 else {
eb578fdb
KW
2334 U8 *tmps;
2335 I32 anum;
a0d0e21e
LW
2336 STRLEN len;
2337
85b0ee6e
FC
2338 sv_copypv_nomg(TARG, sv);
2339 tmps = (U8*)SvPV_nomg(TARG, len);
a0d0e21e 2340 anum = len;
1d68d6cd 2341 if (SvUTF8(TARG)) {
a1ca4561 2342 /* Calculate exact length, let's not estimate. */
1d68d6cd 2343 STRLEN targlen = 0;
ba210ebe 2344 STRLEN l;
a1ca4561
YST
2345 UV nchar = 0;
2346 UV nwide = 0;
01f6e806 2347 U8 * const send = tmps + len;
74d49cd0
ST
2348 U8 * const origtmps = tmps;
2349 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2350
1d68d6cd 2351 while (tmps < send) {
74d49cd0
ST
2352 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2353 tmps += l;
5bbb0b5a 2354 targlen += UNISKIP(~c);
a1ca4561
YST
2355 nchar++;
2356 if (c > 0xff)
2357 nwide++;
1d68d6cd
SC
2358 }
2359
2360 /* Now rewind strings and write them. */
74d49cd0 2361 tmps = origtmps;
a1ca4561
YST
2362
2363 if (nwide) {
01f6e806
AL
2364 U8 *result;
2365 U8 *p;
2366
74d49cd0 2367 Newx(result, targlen + 1, U8);
01f6e806 2368 p = result;
a1ca4561 2369 while (tmps < send) {
74d49cd0
ST
2370 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2371 tmps += l;
01f6e806 2372 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2373 }
01f6e806 2374 *p = '\0';
c1c21316
NC
2375 sv_usepvn_flags(TARG, (char*)result, targlen,
2376 SV_HAS_TRAILING_NUL);
a1ca4561
YST
2377 SvUTF8_on(TARG);
2378 }
2379 else {
01f6e806
AL
2380 U8 *result;
2381 U8 *p;
2382
74d49cd0 2383 Newx(result, nchar + 1, U8);
01f6e806 2384 p = result;
a1ca4561 2385 while (tmps < send) {
74d49cd0
ST
2386 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2387 tmps += l;
01f6e806 2388 *p++ = ~c;
a1ca4561 2389 }
01f6e806 2390 *p = '\0';
c1c21316 2391 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2392 SvUTF8_off(TARG);
1d68d6cd 2393 }
ec93b65f 2394 SETTARG;
1d68d6cd
SC
2395 RETURN;
2396 }
a0d0e21e 2397#ifdef LIBERAL
51723571 2398 {
eb578fdb 2399 long *tmpl;
51723571
JH
2400 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2401 *tmps = ~*tmps;
2402 tmpl = (long*)tmps;
bb7a0f54 2403 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH
2404 *tmpl = ~*tmpl;
2405 tmps = (U8*)tmpl;
2406 }
a0d0e21e
LW
2407#endif
2408 for ( ; anum > 0; anum--, tmps++)
2409 *tmps = ~*tmps;
ec93b65f 2410 SETTARG;
a0d0e21e
LW
2411 }
2412 RETURN;
2413 }
79072805
LW
2414}
2415
a0d0e21e
LW
2416/* integer versions of some of the above */
2417
a0d0e21e 2418PP(pp_i_multiply)
79072805 2419{
6f1401dc
DM
2420 dVAR; dSP; dATARGET;
2421 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2422 {
6f1401dc 2423 dPOPTOPiirl_nomg;
a0d0e21e
LW
2424 SETi( left * right );
2425 RETURN;
2426 }
79072805
LW
2427}
2428
a0d0e21e 2429PP(pp_i_divide)
79072805 2430{
85935d8e 2431 IV num;
6f1401dc
DM
2432 dVAR; dSP; dATARGET;
2433 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2434 {
6f1401dc 2435 dPOPTOPssrl;
85935d8e 2436 IV value = SvIV_nomg(right);
a0d0e21e 2437 if (value == 0)
ece1bcef 2438 DIE(aTHX_ "Illegal division by zero");
85935d8e 2439 num = SvIV_nomg(left);
a0cec769
YST
2440
2441 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2442 if (value == -1)
2443 value = - num;
2444 else
2445 value = num / value;
6f1401dc 2446 SETi(value);
a0d0e21e
LW
2447 RETURN;
2448 }
79072805
LW
2449}
2450
a5bd31f4 2451#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH
2452STATIC
2453PP(pp_i_modulo_0)
befad5d1
NC
2454#else
2455PP(pp_i_modulo)
2456#endif
224ec323
JH
2457{
2458 /* This is the vanilla old i_modulo. */
6f1401dc
DM
2459 dVAR; dSP; dATARGET;
2460 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2461 {
6f1401dc 2462 dPOPTOPiirl_nomg;
224ec323
JH
2463 if (!right)
2464 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2465 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2466 if (right == -1)
2467 SETi( 0 );
2468 else
2469 SETi( left % right );
224ec323
JH
2470 RETURN;
2471 }
2472}
2473
a5bd31f4 2474#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH
2475STATIC
2476PP(pp_i_modulo_1)
befad5d1 2477
224ec323 2478{
224ec323 2479 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2480 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2481 * See below for pp_i_modulo. */
6f1401dc
DM
2482 dVAR; dSP; dATARGET;
2483 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2484 {
6f1401dc 2485 dPOPTOPiirl_nomg;
224ec323
JH
2486 if (!right)
2487 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2488 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2489 if (right == -1)
2490 SETi( 0 );
2491 else
2492 SETi( left % PERL_ABS(right) );
224ec323
JH
2493 RETURN;
2494 }
224ec323
JH
2495}
2496
a0d0e21e 2497PP(pp_i_modulo)
79072805 2498{
6f1401dc
DM
2499 dVAR; dSP; dATARGET;
2500 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2501 {
6f1401dc 2502 dPOPTOPiirl_nomg;
224ec323
JH
2503 if (!right)
2504 DIE(aTHX_ "Illegal modulus zero");
2505 /* The assumption is to use hereafter the old vanilla version... */
2506 PL_op->op_ppaddr =
2507 PL_ppaddr[OP_I_MODULO] =
1c127fab 2508 Perl_pp_i_modulo_0;
224ec323
JH
2509 /* .. but if we have glibc, we might have a buggy _moddi3
2510 * (at least glicb 2.2.5 is known to have this bug), in other
2511 * words our integer modulus with negative quad as the second
2512 * argument might be broken. Test for this and re-patch the
2513 * opcode dispatch table if that is the case, remembering to
2514 * also apply the workaround so that this first round works
2515 * right, too. See [perl #9402] for more information. */
224ec323
JH
2516 {
2517 IV l = 3;
2518 IV r = -10;
2519 /* Cannot do this check with inlined IV constants since
2520 * that seems to work correctly even with the buggy glibc. */
2521 if (l % r == -3) {
2522 /* Yikes, we have the bug.
2523 * Patch in the workaround version. */
2524 PL_op->op_ppaddr =
2525 PL_ppaddr[OP_I_MODULO] =
2526 &Perl_pp_i_modulo_1;
2527 /* Make certain we work right this time, too. */
32fdb065 2528 right = PERL_ABS(right);
224ec323
JH
2529 }
2530 }
a0cec769
YST
2531 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2532 if (right == -1)
2533 SETi( 0 );
2534 else
2535 SETi( left % right );
224ec323
JH
2536 RETURN;
2537 }
79072805 2538}
befad5d1 2539#endif
79072805 2540
a0d0e21e 2541PP(pp_i_add)
79072805 2542{
6f1401dc
DM
2543 dVAR; dSP; dATARGET;
2544 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2545 {
6f1401dc 2546 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2547 SETi( left + right );
2548 RETURN;
79072805 2549 }
79072805
LW
2550}
2551
a0d0e21e 2552PP(pp_i_subtract)
79072805 2553{
6f1401dc
DM
2554 dVAR; dSP; dATARGET;
2555 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2556 {
6f1401dc 2557 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2558 SETi( left - right );
2559 RETURN;
79072805 2560 }
79072805
LW
2561}
2562
a0d0e21e 2563PP(pp_i_lt)
79072805 2564{
6f1401dc
DM
2565 dVAR; dSP;
2566 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2567 {
96b6b87f 2568 dPOPTOPiirl_nomg;
54310121 2569 SETs(boolSV(left < right));
a0d0e21e
LW
2570 RETURN;
2571 }
79072805
LW
2572}
2573
a0d0e21e 2574PP(pp_i_gt)
79072805 2575{
6f1401dc
DM
2576 dVAR; dSP;
2577 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2578 {
96b6b87f 2579 dPOPTOPiirl_nomg;
54310121 2580 SETs(boolSV(left > right));
a0d0e21e
LW
2581 RETURN;
2582 }
79072805
LW
2583}
2584
a0d0e21e 2585PP(pp_i_le)
79072805 2586{
6f1401dc
DM
2587 dVAR; dSP;
2588 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2589 {
96b6b87f 2590 dPOPTOPiirl_nomg;
54310121 2591 SETs(boolSV(left <= right));
a0d0e21e 2592 RETURN;
85e6fe83 2593 }
79072805
LW
2594}
2595
a0d0e21e 2596PP(pp_i_ge)
79072805 2597{
6f1401dc
DM
2598 dVAR; dSP;
2599 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2600 {
96b6b87f 2601 dPOPTOPiirl_nomg;
54310121 2602 SETs(boolSV(left >= right));
a0d0e21e
LW
2603 RETURN;
2604 }
79072805
LW
2605}
2606
a0d0e21e 2607PP(pp_i_eq)
79072805 2608{
6f1401dc
DM
2609 dVAR; dSP;
2610 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2611 {
96b6b87f 2612 dPOPTOPiirl_nomg;
54310121 2613 SETs(boolSV(left == right));
a0d0e21e
LW
2614 RETURN;
2615 }
79072805
LW
2616}
2617
a0d0e21e 2618PP(pp_i_ne)
79072805 2619{
6f1401dc
DM
2620 dVAR; dSP;
2621 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2622 {
96b6b87f 2623 dPOPTOPiirl_nomg;
54310121 2624 SETs(boolSV(left != right));
a0d0e21e
LW
2625 RETURN;
2626 }
79072805
LW
2627}
2628
a0d0e21e 2629PP(pp_i_ncmp)
79072805 2630{
6f1401dc
DM
2631 dVAR; dSP; dTARGET;
2632 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2633 {
96b6b87f 2634 dPOPTOPiirl_nomg;
a0d0e21e 2635 I32 value;
79072805 2636
a0d0e21e 2637 if (left > right)
79072805 2638 value = 1;
a0d0e21e 2639 else if (left < right)
79072805 2640 value = -1;
a0d0e21e 2641 else
79072805 2642 value = 0;
a0d0e21e
LW
2643 SETi(value);
2644 RETURN;
79072805 2645 }
85e6fe83
LW
2646}
2647
2648PP(pp_i_negate)
2649{
6f1401dc
DM
2650 dVAR; dSP; dTARGET;
2651 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2652 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM
2653 {
2654 SV * const sv = TOPs;
2655 IV const i = SvIV_nomg(sv);
2656 SETi(-i);
2657 RETURN;
2658 }
85e6fe83
LW
2659}
2660
79072805
LW
2661/* High falutin' math. */
2662
2663PP(pp_atan2)
2664{
6f1401dc
DM
2665 dVAR; dSP; dTARGET;
2666 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2667 {
096c060c 2668 dPOPTOPnnrl_nomg;
a1021d57 2669 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2670 RETURN;
2671 }
79072805
LW
2672}
2673
2674PP(pp_sin)
2675{
71302fe3
NC
2676 dVAR; dSP; dTARGET;
2677 int amg_type = sin_amg;
2678 const char *neg_report = NULL;
bc81784a 2679 NV (*func)(NV) = Perl_sin;
71302fe3
NC
2680 const int op_type = PL_op->op_type;
2681
2682 switch (op_type) {
2683 case OP_COS:
2684 amg_type = cos_amg;
bc81784a 2685 func = Perl_cos;
71302fe3
NC
2686 break;
2687 case OP_EXP:
2688 amg_type = exp_amg;
bc81784a 2689 func = Perl_exp;
71302fe3
NC
2690 break;
2691 case OP_LOG:
2692 amg_type = log_amg;
bc81784a 2693 func = Perl_log;
71302fe3
NC
2694 neg_report = "log";
2695 break;
2696 case OP_SQRT:
2697 amg_type = sqrt_amg;
bc81784a 2698 func = Perl_sqrt;
71302fe3
NC
2699 neg_report = "sqrt";
2700 break;
a0d0e21e 2701 }
79072805 2702
6f1401dc
DM
2703
2704 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2705 {
6f1401dc
DM
2706 SV * const arg = POPs;
2707 const NV value = SvNV_nomg(arg);
71302fe3
NC
2708 if (neg_report) {
2709 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2710 SET_NUMERIC_STANDARD();
dcbac5bb 2711 /* diag_listed_as: Can't take log of %g */
71302fe3
NC
2712 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2713 }
2714 }
2715 XPUSHn(func(value));
a0d0e21e
LW
2716 RETURN;
2717 }
79072805
LW
2718}
2719
56cb0a1c
AD
2720/* Support Configure command-line overrides for rand() functions.
2721 After 5.005, perhaps we should replace this by Configure support
2722 for drand48(), random(), or rand(). For 5.005, though, maintain
2723 compatibility by calling rand() but allow the user to override it.
2724 See INSTALL for details. --Andy Dougherty 15 July 1998
2725*/
85ab1d1d
JH
2726/* Now it's after 5.005, and Configure supports drand48() and random(),
2727 in addition to rand(). So the overrides should not be needed any more.
2728 --Jarkko Hietaniemi 27 September 1998
2729 */
2730
79072805
LW
2731PP(pp_rand)
2732{
fdf4dddd 2733 dVAR;
80252599 2734 if (!PL_srand_called) {
85ab1d1d 2735 (void)seedDrand01((Rand_seed_t)seed());
80252599 2736 PL_srand_called = TRUE;
93dc8474 2737 }
fdf4dddd
DD
2738 {
2739 dSP;
2740 NV value;
2741 EXTEND(SP, 1);
2742
2743 if (MAXARG < 1)
2744 value = 1.0;
2745 else {
2746 SV * const sv = POPs;
2747 if(!sv)
2748 value = 1.0;
2749 else
2750 value = SvNV(sv);
2751 }
2752 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
659c4b96 2753 if (value == 0.0)
fdf4dddd
DD
2754 value = 1.0;
2755 {
2756 dTARGET;
2757 PUSHs(TARG);
2758 PUTBACK;
2759 value *= Drand01();
2760 sv_setnv_mg(TARG, value);
2761 }
2762 }
2763 return NORMAL;
79072805
LW
2764}
2765
2766PP(pp_srand)
2767{
83832992 2768 dVAR; dSP; dTARGET;
f914a682
JL
2769 UV anum;
2770
0a5f3363 2771 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL
2772 SV *top;
2773 char *pv;
2774 STRLEN len;
2775 int flags;
2776
2777 top = POPs;
2778 pv = SvPV(top, len);
2779 flags = grok_number(pv, len, &anum);
2780
2781 if (!(flags & IS_NUMBER_IN_UV)) {
2782 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2783 "Integer overflow in srand");
2784 anum = UV_MAX;
2785 }
2786 }
2787 else {
2788 anum = seed();
2789 }
2790
85ab1d1d 2791 (void)seedDrand01((Rand_seed_t)anum);
80252599 2792 PL_srand_called = TRUE;
da1010ec
NC
2793 if (anum)
2794 XPUSHu(anum);
2795 else {
2796 /* Historically srand always returned true. We can avoid breaking
2797 that like this: */
2798 sv_setpvs(TARG, "0 but true");
2799 XPUSHTARG;
2800 }
83832992 2801 RETURN;
79072805
LW
2802}
2803
79072805
LW
2804PP(pp_int)
2805{
6f1401dc
DM
2806 dVAR; dSP; dTARGET;
2807 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2808 {
6f1401dc
DM
2809 SV * const sv = TOPs;
2810 const IV iv = SvIV_nomg(sv);
28e5dec8
JH
2811 /* XXX it's arguable that compiler casting to IV might be subtly
2812 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2813 else preferring IV has introduced a subtle behaviour change bug. OTOH
2814 relying on floating point to be accurate is a bug. */
2815
c781a409 2816 if (!SvOK(sv)) {
922c4365 2817 SETu(0);
c781a409
RD
2818 }
2819 else if (SvIOK(sv)) {
2820 if (SvIsUV(sv))
6f1401dc 2821 SETu(SvUV_nomg(sv));
c781a409 2822 else
28e5dec8 2823 SETi(iv);
c781a409 2824 }
c781a409 2825 else {
6f1401dc 2826 const NV value = SvNV_nomg(sv);
1048ea30 2827 if (value >= 0.0) {
28e5dec8
JH
2828 if (value < (NV)UV_MAX + 0.5) {
2829 SETu(U_V(value));
2830 } else {
059a1014 2831 SETn(Perl_floor(value));
28e5dec8 2832 }
1048ea30 2833 }
28e5dec8
JH
2834 else {
2835 if (value > (NV)IV_MIN - 0.5) {
2836 SETi(I_V(value));
2837 } else {
1bbae031 2838 SETn(Perl_ceil(value));
28e5dec8
JH
2839 }
2840 }
774d564b 2841 }
79072805 2842 }
79072805
LW
2843 RETURN;
2844}
2845
463ee0b2
LW
2846PP(pp_abs)
2847{
6f1401dc
DM
2848 dVAR; dSP; dTARGET;
2849 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 2850 {
6f1401dc 2851 SV * const sv = TOPs;
28e5dec8 2852 /* This will cache the NV value if string isn't actually integer */
6f1401dc 2853 const IV iv = SvIV_nomg(sv);
a227d84d 2854
800401ee 2855 if (!SvOK(sv)) {
922c4365 2856 SETu(0);
800401ee
JH
2857 }
2858 else if (SvIOK(sv)) {
28e5dec8 2859 /* IVX is precise */
800401ee 2860 if (SvIsUV(sv)) {
6f1401dc 2861 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH
2862 } else {
2863 if (iv >= 0) {
2864 SETi(iv);
2865 } else {
2866 if (iv != IV_MIN) {
2867 SETi(-iv);
2868 } else {
2869 /* 2s complement assumption. Also, not really needed as
2870 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2871 SETu(IV_MIN);
2872 }
a227d84d 2873 }
28e5dec8
JH
2874 }
2875 } else{
6f1401dc 2876 const NV value = SvNV_nomg(sv);
774d564b 2877 if (value < 0.0)
1b6737cc 2878 SETn(-value);
a4474c9e
DD
2879 else
2880 SETn(value);
774d564b 2881 }
a0d0e21e 2882 }
774d564b 2883 RETURN;
463ee0b2
LW
2884}
2885
79072805
LW
2886PP(pp_oct)
2887{
97aff369 2888 dVAR; dSP; dTARGET;
5c144d81 2889 const char *tmps;
53305cf1 2890 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2891 STRLEN len;
53305cf1
NC
2892 NV result_nv;
2893 UV result_uv;
1b6737cc 2894 SV* const sv = POPs;
79072805 2895
349d4f2f 2896 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
2897 if (DO_UTF8(sv)) {
2898 /* If Unicode, try to downgrade
2899 * If not possible, croak. */
1b6737cc 2900 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
2901
2902 SvUTF8_on(tsv);
2903 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2904 tmps = SvPV_const(tsv, len);
2bc69dc4 2905 }
daa2adfd
NC
2906 if (PL_op->op_type == OP_HEX)
2907 goto hex;
2908
6f894ead 2909 while (*tmps && len && isSPACE(*tmps))
53305cf1 2910 tmps++, len--;
9e24b6e2 2911 if (*tmps == '0')
53305cf1 2912 tmps++, len--;
a674e8db 2913 if (*tmps == 'x' || *tmps == 'X') {
daa2adfd 2914 hex:
53305cf1 2915 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 2916 }
a674e8db 2917 else if (*tmps == 'b' || *tmps == 'B')
53305cf1 2918 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2919 else
53305cf1
NC
2920 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2921
2922 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2923 XPUSHn(result_nv);
2924 }
2925 else {
2926 XPUSHu(result_uv);
2927 }
79072805
LW
2928 RETURN;
2929}
2930
2931/* String stuff. */
2932
2933PP(pp_length)
2934{
97aff369 2935 dVAR; dSP; dTARGET;
0bd48802 2936 SV * const sv = TOPs;
a0ed51b3 2937
0f43fd57
FC
2938 SvGETMAGIC(sv);
2939 if (SvOK(sv)) {
193059ca 2940 if (!IN_BYTES)
0f43fd57 2941 SETi(sv_len_utf8_nomg(sv));
9f621bb0 2942 else
0f43fd57
FC
2943 {
2944 STRLEN len;
2945 (void)SvPV_nomg_const(sv,len);
2946 SETi(len);
2947 }
656266fc 2948 } else {
9407f9c1
DL
2949 if (!SvPADTMP(TARG)) {
2950 sv_setsv_nomg(TARG, &PL_sv_undef);
2951 SETTARG;
2952 }
2953 SETs(&PL_sv_undef);
92331800 2954 }
79072805
LW
2955 RETURN;
2956}
2957
83f78d1a
FC
2958/* Returns false if substring is completely outside original string.
2959 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2960 always be true for an explicit 0.
2961*/
2962bool
2963Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2964 bool pos1_is_uv, IV len_iv,
2965 bool len_is_uv, STRLEN *posp,
2966 STRLEN *lenp)
2967{
2968 IV pos2_iv;
2969 int pos2_is_uv;
2970
2971 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2972
2973 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2974 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2975 pos1_iv += curlen;
2976 }
2977 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2978 return FALSE;
2979
2980 if (len_iv || len_is_uv) {
2981 if (!len_is_uv && len_iv < 0) {
2982 pos2_iv = curlen + len_iv;
2983 if (curlen)
2984 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2985 else
2986 pos2_is_uv = 0;
2987 } else { /* len_iv >= 0 */
2988 if (!pos1_is_uv && pos1_iv < 0) {
2989 pos2_iv = pos1_iv + len_iv;
2990 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2991 } else {
2992 if ((UV)len_iv > curlen-(UV)pos1_iv)
2993 pos2_iv = curlen;
2994 else
2995 pos2_iv = pos1_iv+len_iv;
2996 pos2_is_uv = 1;
2997 }
2998 }
2999 }
3000 else {
3001 pos2_iv = curlen;
3002 pos2_is_uv = 1;
3003 }
3004
3005 if (!pos2_is_uv && pos2_iv < 0) {
3006 if (!pos1_is_uv && pos1_iv < 0)
3007 return FALSE;
3008 pos2_iv = 0;
3009 }
3010 else if (!pos1_is_uv && pos1_iv < 0)
3011 pos1_iv = 0;
3012
3013 if ((UV)pos2_iv < (UV)pos1_iv)
3014 pos2_iv = pos1_iv;
3015 if ((UV)pos2_iv > curlen)
3016 pos2_iv = curlen;
3017
3018 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3019 *posp = (STRLEN)( (UV)pos1_iv );
3020 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3021
3022 return TRUE;
3023}
3024
79072805
LW
3025PP(pp_substr)
3026{
97aff369 3027 dVAR; dSP; dTARGET;
79072805 3028 SV *sv;
463ee0b2 3029 STRLEN curlen;
9402d6ed 3030 STRLEN utf8_curlen;
777f7c56
EB
3031 SV * pos_sv;
3032 IV pos1_iv;
3033 int pos1_is_uv;
777f7c56
EB
3034 SV * len_sv;
3035 IV len_iv = 0;
83f78d1a 3036 int len_is_uv = 0;
24fcb59f 3037 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3038 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3039 const char *tmps;
9402d6ed 3040 SV *repl_sv = NULL;
cbbf8932 3041 const char *repl = NULL;
7b8d334a 3042 STRLEN repl_len;
7bc95ae1 3043 int num_args = PL_op->op_private & 7;
13e30c65 3044 bool repl_need_utf8_upgrade = FALSE;
79072805 3045
78f9721b
SM
3046 if (num_args > 2) {
3047 if (num_args > 3) {
24fcb59f 3048 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC
3049 }
3050 if ((len_sv = POPs)) {
3051 len_iv = SvIV(len_sv);
83f78d1a 3052 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3053 }
7bc95ae1 3054 else num_args--;
5d82c453 3055 }
777f7c56
EB
3056 pos_sv = POPs;
3057 pos1_iv = SvIV(pos_sv);
3058 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3059 sv = POPs;
24fcb59f
FC
3060 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3061 assert(!repl_sv);
3062 repl_sv = POPs;
3063 }
849ca7ee 3064 PUTBACK;
6582db62 3065 if (lvalue && !repl_sv) {
83f78d1a
FC
3066 SV * ret;
3067 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3068 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3069 LvTYPE(ret) = 'x';
3070 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3071 LvTARGOFF(ret) =
3072 pos1_is_uv || pos1_iv >= 0
3073 ? (STRLEN)(UV)pos1_iv
3074 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3075 LvTARGLEN(ret) =
3076 len_is_uv || len_iv > 0
3077 ? (STRLEN)(UV)len_iv
3078 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3079
3080 SPAGAIN;
3081 PUSHs(ret); /* avoid SvSETMAGIC here */
3082 RETURN;
a74fb2cd 3083 }
6582db62
FC
3084 if (repl_sv) {
3085 repl = SvPV_const(repl_sv, repl_len);
3086 SvGETMAGIC(sv);
3087 if (SvROK(sv))
3088 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3089 "Attempt to use reference as lvalue in substr"
3090 );
3091 tmps = SvPV_force_nomg(sv, curlen);
3092 if (DO_UTF8(repl_sv) && repl_len) {
3093 if (!DO_UTF8(sv)) {
01680ee9 3094 sv_utf8_upgrade_nomg(sv);
6582db62
FC
3095 curlen = SvCUR(sv);
3096 }
3097 }
3098 else if (DO_UTF8(sv))
3099 repl_need_utf8_upgrade = TRUE;
3100 }
3101 else tmps = SvPV_const(sv, curlen);
7e2040f0 3102 if (DO_UTF8(sv)) {
0d788f38 3103 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH
3104 if (utf8_curlen == curlen)
3105 utf8_curlen = 0;
a0ed51b3 3106 else
9402d6ed 3107 curlen = utf8_curlen;
a0ed51b3 3108 }
d1c2b58a 3109 else
9402d6ed 3110 utf8_curlen = 0;
a0ed51b3 3111
83f78d1a
FC
3112 {
3113 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3114
83f78d1a
FC
3115 if (!translate_substr_offsets(
3116 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3117 )) goto bound_fail;
777f7c56 3118
83f78d1a
FC
3119 byte_len = len;
3120 byte_pos = utf8_curlen
0d788f38 3121 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3122
2154eca7 3123 tmps += byte_pos;
bbddc9e0
CS
3124
3125 if (rvalue) {
3126 SvTAINTED_off(TARG); /* decontaminate */
3127 SvUTF8_off(TARG); /* decontaminate */
3128 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3129#ifdef USE_LOCALE_COLLATE
bbddc9e0 3130 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3131#endif
bbddc9e0
CS
3132 if (utf8_curlen)
3133 SvUTF8_on(TARG);
3134 }
2154eca7 3135
f7928d6c 3136 if (repl) {
13e30c65
JH
3137 SV* repl_sv_copy = NULL;
3138
3139 if (repl_need_utf8_upgrade) {
3140 repl_sv_copy = newSVsv(repl_sv);
3141 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3142 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3143 }
502d9230
VP
3144 if (!SvOK(sv))
3145 sv_setpvs(sv, "");
777f7c56 3146 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3147 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3148 }
79072805 3149 }
849ca7ee 3150 SPAGAIN;
bbddc9e0
CS
3151 if (rvalue) {
3152 SvSETMAGIC(TARG);
3153 PUSHs(TARG);
3154 }
79072805 3155 RETURN;
777f7c56 3156
1c900557 3157bound_fail:
83f78d1a 3158 if (repl)
777f7c56
EB
3159 Perl_croak(aTHX_ "substr outside of string");
3160 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3161 RETPUSHUNDEF;
79072805
LW
3162}
3163
3164PP(pp_vec)
3165{
2154eca7 3166 dVAR; dSP;
eb578fdb
KW
3167 const IV size = POPi;
3168 const IV offset = POPi;
3169 SV * const src = POPs;
1b6737cc 3170 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3171 SV * ret;
a0d0e21e 3172
81e118e0 3173 if (lvalue) { /* it's an lvalue! */
2154eca7
EB
3174 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3175 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3176 LvTYPE(ret) = 'v';
3177 LvTARG(ret) = SvREFCNT_inc_simple(src);
3178 LvTARGOFF(ret) = offset;
3179 LvTARGLEN(ret) = size;
3180 }
3181 else {
3182 dTARGET;
3183 SvTAINTED_off(TARG); /* decontaminate */
3184 ret = TARG;
79072805
LW
3185 }
3186
2154eca7
EB
3187 sv_setuv(ret, do_vecget(src, offset, size));
3188 PUSHs(ret);
79072805
LW
3189 RETURN;
3190}
3191
3192PP(pp_index)
3193{
97aff369 3194 dVAR; dSP; dTARGET;
79072805
LW
3195 SV *big;
3196 SV *little;
c445ea15 3197 SV *temp = NULL;
ad66a58c 3198 STRLEN biglen;
2723d216 3199 STRLEN llen = 0;
b464e2b7
TC
3200 SSize_t offset = 0;
3201 SSize_t retval;
73ee8be2
NC
3202 const char *big_p;
3203 const char *little_p;
2f040f7f
NC
3204 bool big_utf8;
3205 bool little_utf8;
2723d216 3206 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3207 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3208
e1dccc0d
Z
3209 if (threeargs)
3210 offset = POPi;
79072805
LW
3211 little = POPs;
3212 big = POPs;
73ee8be2
NC
3213 big_p = SvPV_const(big, biglen);
3214 little_p = SvPV_const(little, llen);
3215
e609e586
NC
3216 big_utf8 = DO_UTF8(big);
3217 little_utf8 = DO_UTF8(little);
3218 if (big_utf8 ^ little_utf8) {
3219 /* One needs to be upgraded. */
2f040f7f
NC
3220 if (little_utf8 && !PL_encoding) {
3221 /* Well, maybe instead we might be able to downgrade the small
3222 string? */
1eced8f8 3223 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC
3224 &little_utf8);
3225 if (little_utf8) {
3226 /* If the large string is ISO-8859-1, and it's not possible to
3227 convert the small string to ISO-8859-1, then there is no
3228 way that it could be found anywhere by index. */
3229 retval = -1;
3230 goto fail;
3231 }
e609e586 3232
2f040f7f
NC
3233 /* At this point, pv is a malloc()ed string. So donate it to temp
3234 to ensure it will get free()d */
3235 little = temp = newSV(0);
73ee8be2
NC
3236 sv_usepvn(temp, pv, llen);
3237 little_p = SvPVX(little);
e609e586 3238 } else {
73ee8be2
NC
3239 temp = little_utf8
3240 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f
NC
3241
3242 if (PL_encoding) {
3243 sv_recode_to_utf8(temp, PL_encoding);
3244 } else {
3245 sv_utf8_upgrade(temp);
3246 }
3247 if (little_utf8) {
3248 big = temp;
3249 big_utf8 = TRUE;
73ee8be2 3250 big_p = SvPV_const(big, biglen);
2f040f7f
NC
3251 } else {
3252 little = temp;
73ee8be2 3253 little_p = SvPV_const(little, llen);
2f040f7f 3254 }
e609e586
NC
3255 }
3256 }
73ee8be2
NC
3257 if (SvGAMAGIC(big)) {
3258 /* Life just becomes a lot easier if I use a temporary here.
3259 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3260 will trigger magic and overloading again, as will fbm_instr()
3261 */
59cd0e26
NC
3262 big = newSVpvn_flags(big_p, biglen,
3263 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3264 big_p = SvPVX(big);
3265 }
e4e44778 3266 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC
3267 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3268 warn on undef, and we've already triggered a warning with the
3269 SvPV_const some lines above. We can't remove that, as we need to
3270 call some SvPV to trigger overloading early and find out if the
3271 string is UTF-8.
3272 This is all getting to messy. The API isn't quite clean enough,
3273 because data access has side effects.
3274 */
59cd0e26
NC
3275 little = newSVpvn_flags(little_p, llen,
3276 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3277 little_p = SvPVX(little);
3278 }
e609e586 3279
d3e26383 3280 if (!threeargs)
2723d216 3281 offset = is_index ? 0 : biglen;
a0ed51b3 3282 else {
ad66a58c 3283 if (big_utf8 && offset > 0)
b464e2b7 3284 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
73ee8be2
NC
3285 if (!is_index)
3286 offset += llen;
a0ed51b3 3287 }
79072805
LW
3288 if (offset < 0)
3289 offset = 0;
b464e2b7 3290 else if (offset > (SSize_t)biglen)
ad66a58c 3291 offset = biglen;
73ee8be2
NC
3292 if (!(little_p = is_index
3293 ? fbm_instr((unsigned char*)big_p + offset,
3294 (unsigned char*)big_p + biglen, little, 0)
3295 : rninstr(big_p, big_p + offset,
3296 little_p, little_p + llen)))
a0ed51b3 3297 retval = -1;
ad66a58c 3298 else {
73ee8be2 3299 retval = little_p - big_p;
ad66a58c 3300 if (retval > 0 && big_utf8)
b464e2b7 3301 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
ad66a58c 3302 }
ef8d46e8 3303 SvREFCNT_dec(temp);
2723d216 3304 fail:
e1dccc0d 3305 PUSHi(retval);
79072805
LW
3306 RETURN;
3307}
3308
3309PP(pp_sprintf)
3310{
97aff369 3311 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3312 SvTAINTED_off(TARG);
79072805 3313 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3314 TAINT_IF(SvTAINTED(TARG));
79072805
LW
3315 SP = ORIGMARK;
3316 PUSHTARG;
3317 RETURN;
3318}
3319
79072805
LW
3320PP(pp_ord)
3321{
97aff369 3322 dVAR; dSP; dTARGET;
1eced8f8 3323
7df053ec 3324 SV *argsv = POPs;
ba210ebe 3325 STRLEN len;
349d4f2f 3326 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3327
799ef3cb 3328 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3329 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3330 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
4f6386b6 3331 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
121910a4
JH
3332 argsv = tmpsv;
3333 }
79072805 3334
d8f42585 3335 XPUSHu(DO_UTF8(argsv)
4f6386b6 3336 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
f3943cf2 3337 : (UV)(*s));
68795e93 3338
79072805
LW
3339 RETURN;
3340}
3341
463ee0b2
LW
3342PP(pp_chr)
3343{
97aff369 3344 dVAR; dSP; dTARGET;
463ee0b2 3345 char *tmps;
8a064bd6 3346 UV value;
71739502 3347 SV *top = POPs;
8a064bd6 3348
71739502
FC
3349 SvGETMAGIC(top);
3350 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3351 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
8a064bd6 3352 ||
71739502
FC
3353 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3354 && SvNV_nomg(top) < 0.0))) {
b3fe8680
FC
3355 if (ckWARN(WARN_UTF8)) {
3356 if (SvGMAGICAL(top)) {
3357 SV *top2 = sv_newmortal();
3358 sv_setsv_nomg(top2, top);
3359 top = top2;
3360 }
3361 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3362 "Invalid negative number (%"SVf") in chr", top);
3363 }
8a064bd6 3364 value = UNICODE_REPLACEMENT;
8a064bd6 3365 } else {
71739502 3366 value = SvUV_nomg(top);
8a064bd6 3367 }
463ee0b2 3368
862a34c6 3369 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3370
0064a8a9 3371 if (value > 255 && !IN_BYTES) {
eb160463 3372 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3373 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3374 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW
3375 *tmps = '\0';
3376 (void)SvPOK_only(TARG);
aa6ffa16 3377 SvUTF8_on(TARG);
a0ed51b3
LW
3378 XPUSHs(TARG);
3379 RETURN;
3380 }
3381
748a9306 3382 SvGROW(TARG,2);
463ee0b2
LW
3383 SvCUR_set(TARG, 1);
3384 tmps = SvPVX(TARG);
eb160463 3385 *tmps++ = (char)value;
748a9306 3386 *tmps = '\0';
a0d0e21e 3387 (void)SvPOK_only(TARG);
4c5ed6e2 3388
88632417 3389 if (PL_encoding && !IN_BYTES) {
799ef3cb 3390 sv_recode_to_utf8(TARG, PL_encoding);
88632417 3391 tmps = SvPVX(TARG);
28936164
KW
3392 if (SvCUR(TARG) == 0
3393 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3394 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3395 {
4c5ed6e2 3396 SvGROW(TARG, 2);
d5a15ac2 3397 tmps = SvPVX(TARG);
4c5ed6e2
ST
3398 SvCUR_set(TARG, 1);
3399 *tmps++ = (char)value;
88632417 3400 *tmps = '\0';
4c5ed6e2 3401 SvUTF8_off(TARG);
88632417
JH
3402 }
3403 }
4c5ed6e2 3404
463ee0b2
LW
3405 XPUSHs(TARG);
3406 RETURN;
3407}
3408
79072805
LW
3409PP(pp_crypt)
3410{
79072805 3411#ifdef HAS_CRYPT
97aff369 3412 dVAR; dSP; dTARGET;
5f74f29c 3413 dPOPTOPssrl;
85c16d83 3414 STRLEN len;
10516c54 3415 const char *tmps = SvPV_const(left, len);
2bc69dc4 3416
85c16d83 3417 if (DO_UTF8(left)) {
2bc69dc4 3418 /* If Unicode, try to downgrade.
f2791508
JH
3419 * If not possible, croak.
3420 * Yes, we made this up. */
1b6737cc 3421 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3422
f2791508 3423 SvUTF8_on(tsv);
2bc69dc4 3424 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3425 tmps = SvPV_const(tsv, len);
85c16d83 3426 }
05404ffe
JH
3427# ifdef USE_ITHREADS
3428# ifdef HAS_CRYPT_R
3429 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3430 /* This should be threadsafe because in ithreads there is only
3431 * one thread per interpreter. If this would not be true,
3432 * we would need a mutex to protect this malloc. */
3433 PL_reentrant_buffer->_crypt_struct_buffer =
3434 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3435#if defined(__GLIBC__) || defined(__EMX__)
3436 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3437 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3438 /* work around glibc-2.2.5 bug */
3439 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3440 }
05404ffe 3441#endif
6ab58e4d 3442 }
05404ffe
JH
3443# endif /* HAS_CRYPT_R */
3444# endif /* USE_ITHREADS */
5f74f29c 3445# ifdef FCRYPT
83003860 3446 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3447# else
83003860 3448 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3449# endif
ec93b65f 3450 SETTARG;
4808266b 3451 RETURN;
79072805 3452#else
b13b2135 3453 DIE(aTHX_
79072805
LW
3454 "The crypt() function is unimplemented due to excessive paranoia.");
3455#endif
79072805
LW
3456}
3457
00f254e2
KW
3458/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3459 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3460
79072805
LW
3461PP(pp_ucfirst)
3462{
00f254e2
KW
3463 /* Actually is both lcfirst() and ucfirst(). Only the first character
3464 * changes. This means that possibly we can change in-place, ie., just
3465 * take the source and change that one character and store it back, but not
3466 * if read-only etc, or if the length changes */
3467
97aff369 3468 dVAR;
39644a26 3469 dSP;
d54190f6 3470 SV *source = TOPs;
00f254e2 3471 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC
3472 STRLEN need;
3473 SV *dest;
00f254e2
KW
3474 bool inplace; /* ? Convert first char only, in-place */
3475 bool doing_utf8 = FALSE; /* ? using utf8 */
3476 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3477 const int op_type = PL_op->op_type;
d54190f6
NC
3478 const U8 *s;
3479 U8 *d;
3480 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW
3481 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3482 * stored as UTF-8 at s. */
3483 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3484 * lowercased) character stored in tmpbuf. May be either
3485 * UTF-8 or not, but in either case is the number of bytes */
d54190f6 3486
841a5e18 3487 s = (const U8*)SvPV_const(source, slen);
a0ed51b3 3488
00f254e2
KW
3489 /* We may be able to get away with changing only the first character, in
3490 * place, but not if read-only, etc. Later we may discover more reasons to
3491 * not convert in-place. */
5cd5e2d6
FC
3492 inplace = !SvREADONLY(source)
3493 && ( SvPADTMP(source)
3494 || ( SvTEMP(source) && !SvSMAGICAL(source)
3495 && SvREFCNT(source) == 1));
00f254e2
KW
3496
3497 /* First calculate what the changed first character should be. This affects
3498 * whether we can just swap it out, leaving the rest of the string unchanged,
3499 * or even if have to convert the dest to UTF-8 when the source isn't */
3500
3501 if (! slen) { /* If empty */
3502 need = 1; /* still need a trailing NUL */
b7576bcb 3503 ulen = 0;
00f254e2
KW
3504 }
3505 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3506 doing_utf8 = TRUE;
17e95c9d 3507 ulen = UTF8SKIP(s);
094a2f8c 3508 if (op_type == OP_UCFIRST) {
d6ded950 3509 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
094a2f8c
KW
3510 }
3511 else {
d6ded950 3512 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
094a2f8c 3513 }
00f254e2 3514
17e95c9d
KW
3515 /* we can't do in-place if the length changes. */
3516 if (ulen != tculen) inplace = FALSE;
3517 need = slen + 1 - ulen + tculen;
d54190f6 3518 }
00f254e2
KW
3519 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3520 * latin1 is treated as caseless. Note that a locale takes
3521 * precedence */
167d19f2 3522 ulen = 1; /* Original character is 1 byte */
00f254e2
KW
3523 tculen = 1; /* Most characters will require one byte, but this will
3524 * need to be overridden for the tricky ones */
3525 need = slen + 1;
3526
3527 if (op_type == OP_LCFIRST) {
d54190f6 3528
00f254e2 3529 /* lower case the first letter: no trickiness for any character */
86a1f7fd
KW
3530 *tmpbuf = (IN_LC_RUNTIME(LC_CTYPE))
3531 ? toLOWER_LC(*s)
3532 : (IN_UNI_8_BIT)
3533 ? toLOWER_LATIN1(*s)
3534 : toLOWER(*s);
00f254e2
KW
3535 }
3536 /* is ucfirst() */
d6ded950 3537 else if (IN_LC_RUNTIME(LC_CTYPE)) {
31f05a37
KW
3538 if (IN_UTF8_CTYPE_LOCALE) {
3539 goto do_uni_rules;
3540 }
3541
3542 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3543 locales have upper and title case
3544 different */
00f254e2
KW
3545 }
3546 else if (! IN_UNI_8_BIT) {
3547 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3548 * on EBCDIC machines whatever the
3549 * native function does */
3550 }
31f05a37
KW
3551 else {
3552 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3553 * UTF-8, which we treat as not in locale), and cased latin1 */
3554 UV title_ord;
3555
3556 do_uni_rules:
3557
3558 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
167d19f2
KW
3559 if (tculen > 1) {
3560 assert(tculen == 2);
3561
3562 /* If the result is an upper Latin1-range character, it can
3563 * still be represented in one byte, which is its ordinal */
3564 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3565 *tmpbuf = (U8) title_ord;
3566 tculen = 1;
00f254e2
KW
3567 }
3568 else {
167d19f2
KW
3569 /* Otherwise it became more than one ASCII character (in
3570 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3571 * beyond Latin1, so the number of bytes changed, so can't
3572 * replace just the first character in place. */
3573 inplace = FALSE;
3574
d14578b8
KW
3575 /* If the result won't fit in a byte, the entire result
3576 * will have to be in UTF-8. Assume worst case sizing in
3577 * conversion. (all latin1 characters occupy at most two
3578 * bytes in utf8) */
167d19f2
KW
3579 if (title_ord > 255) {
3580 doing_utf8 = TRUE;
3581 convert_source_to_utf8 = TRUE;
3582 need = slen * 2 + 1;
3583
3584 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3585 * (both) characters whose title case is above 255 is
3586 * 2. */
3587 ulen = 2;
3588 }
3589 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3590 need = slen + 1 + 1;
3591 }
00f254e2 3592 }
167d19f2 3593 }
00f254e2
KW
3594 } /* End of use Unicode (Latin1) semantics */
3595 } /* End of changing the case of the first character */
3596
3597 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3598 * generate the result */
3599 if (inplace) {
3600
3601 /* We can convert in place. This means we change just the first
3602 * character without disturbing the rest; no need to grow */
d54190f6
NC
3603 dest = source;
3604 s = d = (U8*)SvPV_force_nomg(source, slen);
3605 } else {
3606 dTARGET;
3607
3608 dest = TARG;
3609
00f254e2
KW
3610 /* Here, we can't convert in place; we earlier calculated how much
3611 * space we will need, so grow to accommodate that */
d54190f6 3612 SvUPGRADE(dest, SVt_PV);
3b416f41 3613 d = (U8*)SvGROW(dest, need);
d54190f6
NC
3614 (void)SvPOK_only(dest);
3615
3616 SETs(dest);
d54190f6 3617 }
44bc797b 3618
d54190f6 3619 if (doing_utf8) {
00f254e2
KW
3620 if (! inplace) {
3621 if (! convert_source_to_utf8) {
3622
3623 /* Here both source and dest are in UTF-8, but have to create
3624 * the entire output. We initialize the result to be the
3625 * title/lower cased first character, and then append the rest
3626 * of the string. */