This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp.c: Add comment
[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;
130c5df3
KW
2136 const int cmp =
2137#ifdef USE_LC_COLLATE
2138 (IN_LC_RUNTIME(LC_COLLATE))
2139 ? sv_cmp_locale_flags(left, right, 0)
2140 :
2141#endif
2142 sv_cmp_flags(left, right, 0);
afd9910b 2143 SETs(boolSV(cmp * multiplier < rhs));
a0d0e21e
LW
2144 RETURN;
2145 }
2146}
79072805 2147
36477c24
PP
2148PP(pp_seq)
2149{
6f1401dc
DM
2150 dVAR; dSP;
2151 tryAMAGICbin_MG(seq_amg, AMGf_set);
36477c24
PP
2152 {
2153 dPOPTOPssrl;
078504b2 2154 SETs(boolSV(sv_eq_flags(left, right, 0)));
a0d0e21e
LW
2155 RETURN;
2156 }
2157}
79072805 2158
a0d0e21e 2159PP(pp_sne)
79072805 2160{
6f1401dc
DM
2161 dVAR; dSP;
2162 tryAMAGICbin_MG(sne_amg, AMGf_set);
a0d0e21e
LW
2163 {
2164 dPOPTOPssrl;
078504b2 2165 SETs(boolSV(!sv_eq_flags(left, right, 0)));
a0d0e21e 2166 RETURN;
463ee0b2 2167 }
79072805
LW
2168}
2169
a0d0e21e 2170PP(pp_scmp)
79072805 2171{
6f1401dc
DM
2172 dVAR; dSP; dTARGET;
2173 tryAMAGICbin_MG(scmp_amg, 0);
a0d0e21e
LW
2174 {
2175 dPOPTOPssrl;
130c5df3
KW
2176 const int cmp =
2177#ifdef USE_LC_COLLATE
2178 (IN_LC_RUNTIME(LC_COLLATE))
2179 ? sv_cmp_locale_flags(left, right, 0)
2180 :
2181#endif
2182 sv_cmp_flags(left, right, 0);
bbce6d69 2183 SETi( cmp );
a0d0e21e
LW
2184 RETURN;
2185 }
2186}
79072805 2187
55497cff
PP
2188PP(pp_bit_and)
2189{
6f1401dc
DM
2190 dVAR; dSP; dATARGET;
2191 tryAMAGICbin_MG(band_amg, AMGf_assign);
a0d0e21e
LW
2192 {
2193 dPOPTOPssrl;
4633a7c4 2194 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2195 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2196 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2197 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2198 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
972b05a9 2199 SETi(i);
d0ba1bd2
JH
2200 }
2201 else {
1b6737cc 2202 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
972b05a9 2203 SETu(u);
d0ba1bd2 2204 }
5ee80e13 2205 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2206 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2207 }
2208 else {
533c011a 2209 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
2210 SETTARG;
2211 }
2212 RETURN;
2213 }
2214}
79072805 2215
a0d0e21e
LW
2216PP(pp_bit_or)
2217{
3658c1f1
NC
2218 dVAR; dSP; dATARGET;
2219 const int op_type = PL_op->op_type;
2220
6f1401dc 2221 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
a0d0e21e
LW
2222 {
2223 dPOPTOPssrl;
4633a7c4 2224 if (SvNIOKp(left) || SvNIOKp(right)) {
b20c4ee1
FC
2225 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2226 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
d0ba1bd2 2227 if (PL_op->op_private & HINT_INTEGER) {
3658c1f1
NC
2228 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2229 const IV r = SvIV_nomg(right);
2230 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2231 SETi(result);
d0ba1bd2
JH
2232 }
2233 else {
3658c1f1
NC
2234 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2235 const UV r = SvUV_nomg(right);
2236 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2237 SETu(result);
d0ba1bd2 2238 }
5ee80e13 2239 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
b20c4ee1 2240 if (right_ro_nonnum) SvNIOK_off(right);
a0d0e21e
LW
2241 }
2242 else {
3658c1f1 2243 do_vop(op_type, TARG, left, right);
a0d0e21e
LW
2244 SETTARG;
2245 }
2246 RETURN;
79072805 2247 }
a0d0e21e 2248}
79072805 2249
1c2b3fd6
FC
2250PERL_STATIC_INLINE bool
2251S_negate_string(pTHX)
2252{
2253 dTARGET; dSP;
2254 STRLEN len;
2255 const char *s;
2256 SV * const sv = TOPs;
2257 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2258 return FALSE;
2259 s = SvPV_nomg_const(sv, len);
2260 if (isIDFIRST(*s)) {
2261 sv_setpvs(TARG, "-");
2262 sv_catsv(TARG, sv);
2263 }
2264 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2265 sv_setsv_nomg(TARG, sv);
2266 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2267 }
2268 else return FALSE;
2269 SETTARG; PUTBACK;
2270 return TRUE;
2271}
2272
a0d0e21e
LW
2273PP(pp_negate)
2274{
6f1401dc
DM
2275 dVAR; dSP; dTARGET;
2276 tryAMAGICun_MG(neg_amg, AMGf_numeric);
1c2b3fd6 2277 if (S_negate_string(aTHX)) return NORMAL;
a0d0e21e 2278 {
6f1401dc 2279 SV * const sv = TOPs;
a5b92898 2280
d96ab1b5 2281 if (SvIOK(sv)) {
7dbe3150 2282 /* It's publicly an integer */
28e5dec8 2283 oops_its_an_int:
9b0e499b
GS
2284 if (SvIsUV(sv)) {
2285 if (SvIVX(sv) == IV_MIN) {
28e5dec8 2286 /* 2s complement assumption. */
d14578b8
KW
2287 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2288 IV_MIN */
9b0e499b
GS
2289 RETURN;
2290 }
2291 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 2292 SETi(-SvIVX(sv));
9b0e499b
GS
2293 RETURN;
2294 }
2295 }
2296 else if (SvIVX(sv) != IV_MIN) {
2297 SETi(-SvIVX(sv));
2298 RETURN;
2299 }
28e5dec8
JH
2300#ifdef PERL_PRESERVE_IVUV
2301 else {
2302 SETu((UV)IV_MIN);
2303 RETURN;
2304 }
2305#endif
9b0e499b 2306 }
8a5decd8 2307 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
6f1401dc 2308 SETn(-SvNV_nomg(sv));
1c2b3fd6 2309 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
8eb28a70 2310 goto oops_its_an_int;
4633a7c4 2311 else
6f1401dc 2312 SETn(-SvNV_nomg(sv));
79072805 2313 }
a0d0e21e 2314 RETURN;
79072805
LW
2315}
2316
a0d0e21e 2317PP(pp_not)
79072805 2318{
6f1401dc
DM
2319 dVAR; dSP;
2320 tryAMAGICun_MG(not_amg, AMGf_set);
06c841cf 2321 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
a0d0e21e 2322 return NORMAL;
79072805
LW
2323}
2324
a0d0e21e 2325PP(pp_complement)
79072805 2326{
6f1401dc 2327 dVAR; dSP; dTARGET;
a42d0242 2328 tryAMAGICun_MG(compl_amg, AMGf_numeric);
a0d0e21e
LW
2329 {
2330 dTOPss;
4633a7c4 2331 if (SvNIOKp(sv)) {
d0ba1bd2 2332 if (PL_op->op_private & HINT_INTEGER) {
1b6737cc 2333 const IV i = ~SvIV_nomg(sv);
972b05a9 2334 SETi(i);
d0ba1bd2
JH
2335 }
2336 else {
1b6737cc 2337 const UV u = ~SvUV_nomg(sv);
972b05a9 2338 SETu(u);
d0ba1bd2 2339 }
a0d0e21e
LW
2340 }
2341 else {
eb578fdb
KW
2342 U8 *tmps;
2343 I32 anum;
a0d0e21e
LW
2344 STRLEN len;
2345
85b0ee6e
FC
2346 sv_copypv_nomg(TARG, sv);
2347 tmps = (U8*)SvPV_nomg(TARG, len);
a0d0e21e 2348 anum = len;
1d68d6cd 2349 if (SvUTF8(TARG)) {
a1ca4561 2350 /* Calculate exact length, let's not estimate. */
1d68d6cd 2351 STRLEN targlen = 0;
ba210ebe 2352 STRLEN l;
a1ca4561
YST
2353 UV nchar = 0;
2354 UV nwide = 0;
01f6e806 2355 U8 * const send = tmps + len;
74d49cd0
ST
2356 U8 * const origtmps = tmps;
2357 const UV utf8flags = UTF8_ALLOW_ANYUV;
1d68d6cd 2358
1d68d6cd 2359 while (tmps < send) {
74d49cd0
ST
2360 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2361 tmps += l;
5bbb0b5a 2362 targlen += UNISKIP(~c);
a1ca4561
YST
2363 nchar++;
2364 if (c > 0xff)
2365 nwide++;
1d68d6cd
SC
2366 }
2367
2368 /* Now rewind strings and write them. */
74d49cd0 2369 tmps = origtmps;
a1ca4561
YST
2370
2371 if (nwide) {
01f6e806
AL
2372 U8 *result;
2373 U8 *p;
2374
74d49cd0 2375 Newx(result, targlen + 1, U8);
01f6e806 2376 p = result;
a1ca4561 2377 while (tmps < send) {
74d49cd0
ST
2378 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2379 tmps += l;
01f6e806 2380 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
a1ca4561 2381 }
01f6e806 2382 *p = '\0';
c1c21316
NC
2383 sv_usepvn_flags(TARG, (char*)result, targlen,
2384 SV_HAS_TRAILING_NUL);
a1ca4561
YST
2385 SvUTF8_on(TARG);
2386 }
2387 else {
01f6e806
AL
2388 U8 *result;
2389 U8 *p;
2390
74d49cd0 2391 Newx(result, nchar + 1, U8);
01f6e806 2392 p = result;
a1ca4561 2393 while (tmps < send) {
74d49cd0
ST
2394 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2395 tmps += l;
01f6e806 2396 *p++ = ~c;
a1ca4561 2397 }
01f6e806 2398 *p = '\0';
c1c21316 2399 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
d0a21e00 2400 SvUTF8_off(TARG);
1d68d6cd 2401 }
ec93b65f 2402 SETTARG;
1d68d6cd
SC
2403 RETURN;
2404 }
a0d0e21e 2405#ifdef LIBERAL
51723571 2406 {
eb578fdb 2407 long *tmpl;
51723571
JH
2408 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2409 *tmps = ~*tmps;
2410 tmpl = (long*)tmps;
bb7a0f54 2411 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
51723571
JH
2412 *tmpl = ~*tmpl;
2413 tmps = (U8*)tmpl;
2414 }
a0d0e21e
LW
2415#endif
2416 for ( ; anum > 0; anum--, tmps++)
2417 *tmps = ~*tmps;
ec93b65f 2418 SETTARG;
a0d0e21e
LW
2419 }
2420 RETURN;
2421 }
79072805
LW
2422}
2423
a0d0e21e
LW
2424/* integer versions of some of the above */
2425
a0d0e21e 2426PP(pp_i_multiply)
79072805 2427{
6f1401dc
DM
2428 dVAR; dSP; dATARGET;
2429 tryAMAGICbin_MG(mult_amg, AMGf_assign);
a0d0e21e 2430 {
6f1401dc 2431 dPOPTOPiirl_nomg;
a0d0e21e
LW
2432 SETi( left * right );
2433 RETURN;
2434 }
79072805
LW
2435}
2436
a0d0e21e 2437PP(pp_i_divide)
79072805 2438{
85935d8e 2439 IV num;
6f1401dc
DM
2440 dVAR; dSP; dATARGET;
2441 tryAMAGICbin_MG(div_amg, AMGf_assign);
a0d0e21e 2442 {
6f1401dc 2443 dPOPTOPssrl;
85935d8e 2444 IV value = SvIV_nomg(right);
a0d0e21e 2445 if (value == 0)
ece1bcef 2446 DIE(aTHX_ "Illegal division by zero");
85935d8e 2447 num = SvIV_nomg(left);
a0cec769
YST
2448
2449 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2450 if (value == -1)
2451 value = - num;
2452 else
2453 value = num / value;
6f1401dc 2454 SETi(value);
a0d0e21e
LW
2455 RETURN;
2456 }
79072805
LW
2457}
2458
a5bd31f4 2459#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH
2460STATIC
2461PP(pp_i_modulo_0)
befad5d1
NC
2462#else
2463PP(pp_i_modulo)
2464#endif
224ec323
JH
2465{
2466 /* This is the vanilla old i_modulo. */
6f1401dc
DM
2467 dVAR; dSP; dATARGET;
2468 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2469 {
6f1401dc 2470 dPOPTOPiirl_nomg;
224ec323
JH
2471 if (!right)
2472 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2473 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2474 if (right == -1)
2475 SETi( 0 );
2476 else
2477 SETi( left % right );
224ec323
JH
2478 RETURN;
2479 }
2480}
2481
a5bd31f4 2482#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
224ec323
JH
2483STATIC
2484PP(pp_i_modulo_1)
befad5d1 2485
224ec323 2486{
224ec323 2487 /* This is the i_modulo with the workaround for the _moddi3 bug
fce2b89e 2488 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
224ec323 2489 * See below for pp_i_modulo. */
6f1401dc
DM
2490 dVAR; dSP; dATARGET;
2491 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2492 {
6f1401dc 2493 dPOPTOPiirl_nomg;
224ec323
JH
2494 if (!right)
2495 DIE(aTHX_ "Illegal modulus zero");
a0cec769
YST
2496 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2497 if (right == -1)
2498 SETi( 0 );
2499 else
2500 SETi( left % PERL_ABS(right) );
224ec323
JH
2501 RETURN;
2502 }
224ec323
JH
2503}
2504
a0d0e21e 2505PP(pp_i_modulo)
79072805 2506{
6f1401dc
DM
2507 dVAR; dSP; dATARGET;
2508 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
224ec323 2509 {
6f1401dc 2510 dPOPTOPiirl_nomg;
224ec323
JH
2511 if (!right)
2512 DIE(aTHX_ "Illegal modulus zero");
2513 /* The assumption is to use hereafter the old vanilla version... */
2514 PL_op->op_ppaddr =
2515 PL_ppaddr[OP_I_MODULO] =
1c127fab 2516 Perl_pp_i_modulo_0;
224ec323
JH
2517 /* .. but if we have glibc, we might have a buggy _moddi3
2518 * (at least glicb 2.2.5 is known to have this bug), in other
2519 * words our integer modulus with negative quad as the second
2520 * argument might be broken. Test for this and re-patch the
2521 * opcode dispatch table if that is the case, remembering to
2522 * also apply the workaround so that this first round works
2523 * right, too. See [perl #9402] for more information. */
224ec323
JH
2524 {
2525 IV l = 3;
2526 IV r = -10;
2527 /* Cannot do this check with inlined IV constants since
2528 * that seems to work correctly even with the buggy glibc. */
2529 if (l % r == -3) {
2530 /* Yikes, we have the bug.
2531 * Patch in the workaround version. */
2532 PL_op->op_ppaddr =
2533 PL_ppaddr[OP_I_MODULO] =
2534 &Perl_pp_i_modulo_1;
2535 /* Make certain we work right this time, too. */
32fdb065 2536 right = PERL_ABS(right);
224ec323
JH
2537 }
2538 }
a0cec769
YST
2539 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2540 if (right == -1)
2541 SETi( 0 );
2542 else
2543 SETi( left % right );
224ec323
JH
2544 RETURN;
2545 }
79072805 2546}
befad5d1 2547#endif
79072805 2548
a0d0e21e 2549PP(pp_i_add)
79072805 2550{
6f1401dc
DM
2551 dVAR; dSP; dATARGET;
2552 tryAMAGICbin_MG(add_amg, AMGf_assign);
a0d0e21e 2553 {
6f1401dc 2554 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2555 SETi( left + right );
2556 RETURN;
79072805 2557 }
79072805
LW
2558}
2559
a0d0e21e 2560PP(pp_i_subtract)
79072805 2561{
6f1401dc
DM
2562 dVAR; dSP; dATARGET;
2563 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
a0d0e21e 2564 {
6f1401dc 2565 dPOPTOPiirl_ul_nomg;
a0d0e21e
LW
2566 SETi( left - right );
2567 RETURN;
79072805 2568 }
79072805
LW
2569}
2570
a0d0e21e 2571PP(pp_i_lt)
79072805 2572{
6f1401dc
DM
2573 dVAR; dSP;
2574 tryAMAGICbin_MG(lt_amg, AMGf_set);
a0d0e21e 2575 {
96b6b87f 2576 dPOPTOPiirl_nomg;
54310121 2577 SETs(boolSV(left < right));
a0d0e21e
LW
2578 RETURN;
2579 }
79072805
LW
2580}
2581
a0d0e21e 2582PP(pp_i_gt)
79072805 2583{
6f1401dc
DM
2584 dVAR; dSP;
2585 tryAMAGICbin_MG(gt_amg, AMGf_set);
a0d0e21e 2586 {
96b6b87f 2587 dPOPTOPiirl_nomg;
54310121 2588 SETs(boolSV(left > right));
a0d0e21e
LW
2589 RETURN;
2590 }
79072805
LW
2591}
2592
a0d0e21e 2593PP(pp_i_le)
79072805 2594{
6f1401dc
DM
2595 dVAR; dSP;
2596 tryAMAGICbin_MG(le_amg, AMGf_set);
a0d0e21e 2597 {
96b6b87f 2598 dPOPTOPiirl_nomg;
54310121 2599 SETs(boolSV(left <= right));
a0d0e21e 2600 RETURN;
85e6fe83 2601 }
79072805
LW
2602}
2603
a0d0e21e 2604PP(pp_i_ge)
79072805 2605{
6f1401dc
DM
2606 dVAR; dSP;
2607 tryAMAGICbin_MG(ge_amg, AMGf_set);
a0d0e21e 2608 {
96b6b87f 2609 dPOPTOPiirl_nomg;
54310121 2610 SETs(boolSV(left >= right));
a0d0e21e
LW
2611 RETURN;
2612 }
79072805
LW
2613}
2614
a0d0e21e 2615PP(pp_i_eq)
79072805 2616{
6f1401dc
DM
2617 dVAR; dSP;
2618 tryAMAGICbin_MG(eq_amg, AMGf_set);
a0d0e21e 2619 {
96b6b87f 2620 dPOPTOPiirl_nomg;
54310121 2621 SETs(boolSV(left == right));
a0d0e21e
LW
2622 RETURN;
2623 }
79072805
LW
2624}
2625
a0d0e21e 2626PP(pp_i_ne)
79072805 2627{
6f1401dc
DM
2628 dVAR; dSP;
2629 tryAMAGICbin_MG(ne_amg, AMGf_set);
a0d0e21e 2630 {
96b6b87f 2631 dPOPTOPiirl_nomg;
54310121 2632 SETs(boolSV(left != right));
a0d0e21e
LW
2633 RETURN;
2634 }
79072805
LW
2635}
2636
a0d0e21e 2637PP(pp_i_ncmp)
79072805 2638{
6f1401dc
DM
2639 dVAR; dSP; dTARGET;
2640 tryAMAGICbin_MG(ncmp_amg, 0);
a0d0e21e 2641 {
96b6b87f 2642 dPOPTOPiirl_nomg;
a0d0e21e 2643 I32 value;
79072805 2644
a0d0e21e 2645 if (left > right)
79072805 2646 value = 1;
a0d0e21e 2647 else if (left < right)
79072805 2648 value = -1;
a0d0e21e 2649 else
79072805 2650 value = 0;
a0d0e21e
LW
2651 SETi(value);
2652 RETURN;
79072805 2653 }
85e6fe83
LW
2654}
2655
2656PP(pp_i_negate)
2657{
6f1401dc
DM
2658 dVAR; dSP; dTARGET;
2659 tryAMAGICun_MG(neg_amg, 0);
1c2b3fd6 2660 if (S_negate_string(aTHX)) return NORMAL;
6f1401dc
DM
2661 {
2662 SV * const sv = TOPs;
2663 IV const i = SvIV_nomg(sv);
2664 SETi(-i);
2665 RETURN;
2666 }
85e6fe83
LW
2667}
2668
79072805
LW
2669/* High falutin' math. */
2670
2671PP(pp_atan2)
2672{
6f1401dc
DM
2673 dVAR; dSP; dTARGET;
2674 tryAMAGICbin_MG(atan2_amg, 0);
a0d0e21e 2675 {
096c060c 2676 dPOPTOPnnrl_nomg;
a1021d57 2677 SETn(Perl_atan2(left, right));
a0d0e21e
LW
2678 RETURN;
2679 }
79072805
LW
2680}
2681
2682PP(pp_sin)
2683{
71302fe3
NC
2684 dVAR; dSP; dTARGET;
2685 int amg_type = sin_amg;
2686 const char *neg_report = NULL;
bc81784a 2687 NV (*func)(NV) = Perl_sin;
71302fe3
NC
2688 const int op_type = PL_op->op_type;
2689
2690 switch (op_type) {
2691 case OP_COS:
2692 amg_type = cos_amg;
bc81784a 2693 func = Perl_cos;
71302fe3
NC
2694 break;
2695 case OP_EXP:
2696 amg_type = exp_amg;
bc81784a 2697 func = Perl_exp;
71302fe3
NC
2698 break;
2699 case OP_LOG:
2700 amg_type = log_amg;
bc81784a 2701 func = Perl_log;
71302fe3
NC
2702 neg_report = "log";
2703 break;
2704 case OP_SQRT:
2705 amg_type = sqrt_amg;
bc81784a 2706 func = Perl_sqrt;
71302fe3
NC
2707 neg_report = "sqrt";
2708 break;
a0d0e21e 2709 }
79072805 2710
6f1401dc
DM
2711
2712 tryAMAGICun_MG(amg_type, 0);
a0d0e21e 2713 {
6f1401dc
DM
2714 SV * const arg = POPs;
2715 const NV value = SvNV_nomg(arg);
71302fe3
NC
2716 if (neg_report) {
2717 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2718 SET_NUMERIC_STANDARD();
dcbac5bb 2719 /* diag_listed_as: Can't take log of %g */
71302fe3
NC
2720 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2721 }
2722 }
2723 XPUSHn(func(value));
a0d0e21e
LW
2724 RETURN;
2725 }
79072805
LW
2726}
2727
56cb0a1c
AD
2728/* Support Configure command-line overrides for rand() functions.
2729 After 5.005, perhaps we should replace this by Configure support
2730 for drand48(), random(), or rand(). For 5.005, though, maintain
2731 compatibility by calling rand() but allow the user to override it.
2732 See INSTALL for details. --Andy Dougherty 15 July 1998
2733*/
85ab1d1d
JH
2734/* Now it's after 5.005, and Configure supports drand48() and random(),
2735 in addition to rand(). So the overrides should not be needed any more.
2736 --Jarkko Hietaniemi 27 September 1998
2737 */
2738
79072805
LW
2739PP(pp_rand)
2740{
fdf4dddd 2741 dVAR;
80252599 2742 if (!PL_srand_called) {
85ab1d1d 2743 (void)seedDrand01((Rand_seed_t)seed());
80252599 2744 PL_srand_called = TRUE;
93dc8474 2745 }
fdf4dddd
DD
2746 {
2747 dSP;
2748 NV value;
2749 EXTEND(SP, 1);
2750
2751 if (MAXARG < 1)
2752 value = 1.0;
2753 else {
2754 SV * const sv = POPs;
2755 if(!sv)
2756 value = 1.0;
2757 else
2758 value = SvNV(sv);
2759 }
2760 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
659c4b96 2761 if (value == 0.0)
fdf4dddd
DD
2762 value = 1.0;
2763 {
2764 dTARGET;
2765 PUSHs(TARG);
2766 PUTBACK;
2767 value *= Drand01();
2768 sv_setnv_mg(TARG, value);
2769 }
2770 }
2771 return NORMAL;
79072805
LW
2772}
2773
2774PP(pp_srand)
2775{
83832992 2776 dVAR; dSP; dTARGET;
f914a682
JL
2777 UV anum;
2778
0a5f3363 2779 if (MAXARG >= 1 && (TOPs || POPs)) {
f914a682
JL
2780 SV *top;
2781 char *pv;
2782 STRLEN len;
2783 int flags;
2784
2785 top = POPs;
2786 pv = SvPV(top, len);
2787 flags = grok_number(pv, len, &anum);
2788
2789 if (!(flags & IS_NUMBER_IN_UV)) {
2790 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2791 "Integer overflow in srand");
2792 anum = UV_MAX;
2793 }
2794 }
2795 else {
2796 anum = seed();
2797 }
2798
85ab1d1d 2799 (void)seedDrand01((Rand_seed_t)anum);
80252599 2800 PL_srand_called = TRUE;
da1010ec
NC
2801 if (anum)
2802 XPUSHu(anum);
2803 else {
2804 /* Historically srand always returned true. We can avoid breaking
2805 that like this: */
2806 sv_setpvs(TARG, "0 but true");
2807 XPUSHTARG;
2808 }
83832992 2809 RETURN;
79072805
LW
2810}
2811
79072805
LW
2812PP(pp_int)
2813{
6f1401dc
DM
2814 dVAR; dSP; dTARGET;
2815 tryAMAGICun_MG(int_amg, AMGf_numeric);
774d564b 2816 {
6f1401dc
DM
2817 SV * const sv = TOPs;
2818 const IV iv = SvIV_nomg(sv);
28e5dec8
JH
2819 /* XXX it's arguable that compiler casting to IV might be subtly
2820 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2821 else preferring IV has introduced a subtle behaviour change bug. OTOH
2822 relying on floating point to be accurate is a bug. */
2823
c781a409 2824 if (!SvOK(sv)) {
922c4365 2825 SETu(0);
c781a409
RD
2826 }
2827 else if (SvIOK(sv)) {
2828 if (SvIsUV(sv))
6f1401dc 2829 SETu(SvUV_nomg(sv));
c781a409 2830 else
28e5dec8 2831 SETi(iv);
c781a409 2832 }
c781a409 2833 else {
6f1401dc 2834 const NV value = SvNV_nomg(sv);
1048ea30 2835 if (value >= 0.0) {
28e5dec8
JH
2836 if (value < (NV)UV_MAX + 0.5) {
2837 SETu(U_V(value));
2838 } else {
059a1014 2839 SETn(Perl_floor(value));
28e5dec8 2840 }
1048ea30 2841 }
28e5dec8
JH
2842 else {
2843 if (value > (NV)IV_MIN - 0.5) {
2844 SETi(I_V(value));
2845 } else {
1bbae031 2846 SETn(Perl_ceil(value));
28e5dec8
JH
2847 }
2848 }
774d564b 2849 }
79072805 2850 }
79072805
LW
2851 RETURN;
2852}
2853
463ee0b2
LW
2854PP(pp_abs)
2855{
6f1401dc
DM
2856 dVAR; dSP; dTARGET;
2857 tryAMAGICun_MG(abs_amg, AMGf_numeric);
a0d0e21e 2858 {
6f1401dc 2859 SV * const sv = TOPs;
28e5dec8 2860 /* This will cache the NV value if string isn't actually integer */
6f1401dc 2861 const IV iv = SvIV_nomg(sv);
a227d84d 2862
800401ee 2863 if (!SvOK(sv)) {
922c4365 2864 SETu(0);
800401ee
JH
2865 }
2866 else if (SvIOK(sv)) {
28e5dec8 2867 /* IVX is precise */
800401ee 2868 if (SvIsUV(sv)) {
6f1401dc 2869 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
28e5dec8
JH
2870 } else {
2871 if (iv >= 0) {
2872 SETi(iv);
2873 } else {
2874 if (iv != IV_MIN) {
2875 SETi(-iv);
2876 } else {
2877 /* 2s complement assumption. Also, not really needed as
2878 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2879 SETu(IV_MIN);
2880 }
a227d84d 2881 }
28e5dec8
JH
2882 }
2883 } else{
6f1401dc 2884 const NV value = SvNV_nomg(sv);
774d564b 2885 if (value < 0.0)
1b6737cc 2886 SETn(-value);
a4474c9e
DD
2887 else
2888 SETn(value);
774d564b 2889 }
a0d0e21e 2890 }
774d564b 2891 RETURN;
463ee0b2
LW
2892}
2893
79072805
LW
2894PP(pp_oct)
2895{
97aff369 2896 dVAR; dSP; dTARGET;
5c144d81 2897 const char *tmps;
53305cf1 2898 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
6f894ead 2899 STRLEN len;
53305cf1
NC
2900 NV result_nv;
2901 UV result_uv;
1b6737cc 2902 SV* const sv = POPs;
79072805 2903
349d4f2f 2904 tmps = (SvPV_const(sv, len));
2bc69dc4
NIS
2905 if (DO_UTF8(sv)) {
2906 /* If Unicode, try to downgrade
2907 * If not possible, croak. */
1b6737cc 2908 SV* const tsv = sv_2mortal(newSVsv(sv));
2bc69dc4
NIS
2909
2910 SvUTF8_on(tsv);
2911 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 2912 tmps = SvPV_const(tsv, len);
2bc69dc4 2913 }
daa2adfd
NC
2914 if (PL_op->op_type == OP_HEX)
2915 goto hex;
2916
6f894ead 2917 while (*tmps && len && isSPACE(*tmps))
53305cf1 2918 tmps++, len--;
9e24b6e2 2919 if (*tmps == '0')
53305cf1 2920 tmps++, len--;
a674e8db 2921 if (*tmps == 'x' || *tmps == 'X') {
daa2adfd 2922 hex:
53305cf1 2923 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
daa2adfd 2924 }
a674e8db 2925 else if (*tmps == 'b' || *tmps == 'B')
53305cf1 2926 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
464e2e8a 2927 else
53305cf1
NC
2928 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2929
2930 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2931 XPUSHn(result_nv);
2932 }
2933 else {
2934 XPUSHu(result_uv);
2935 }
79072805
LW
2936 RETURN;
2937}
2938
2939/* String stuff. */
2940
2941PP(pp_length)
2942{
97aff369 2943 dVAR; dSP; dTARGET;
0bd48802 2944 SV * const sv = TOPs;
a0ed51b3 2945
0f43fd57
FC
2946 SvGETMAGIC(sv);
2947 if (SvOK(sv)) {
193059ca 2948 if (!IN_BYTES)
0f43fd57 2949 SETi(sv_len_utf8_nomg(sv));
9f621bb0 2950 else
0f43fd57
FC
2951 {
2952 STRLEN len;
2953 (void)SvPV_nomg_const(sv,len);
2954 SETi(len);
2955 }
656266fc 2956 } else {
9407f9c1
DL
2957 if (!SvPADTMP(TARG)) {
2958 sv_setsv_nomg(TARG, &PL_sv_undef);
2959 SETTARG;
2960 }
2961 SETs(&PL_sv_undef);
92331800 2962 }
79072805
LW
2963 RETURN;
2964}
2965
83f78d1a
FC
2966/* Returns false if substring is completely outside original string.
2967 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2968 always be true for an explicit 0.
2969*/
2970bool
2971Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2972 bool pos1_is_uv, IV len_iv,
2973 bool len_is_uv, STRLEN *posp,
2974 STRLEN *lenp)
2975{
2976 IV pos2_iv;
2977 int pos2_is_uv;
2978
2979 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
dc3bf405 2980 PERL_UNUSED_CONTEXT;
83f78d1a
FC
2981
2982 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
2983 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2984 pos1_iv += curlen;
2985 }
2986 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
2987 return FALSE;
2988
2989 if (len_iv || len_is_uv) {
2990 if (!len_is_uv && len_iv < 0) {
2991 pos2_iv = curlen + len_iv;
2992 if (curlen)
2993 pos2_is_uv = curlen-1 > ~(UV)len_iv;
2994 else
2995 pos2_is_uv = 0;
2996 } else { /* len_iv >= 0 */
2997 if (!pos1_is_uv && pos1_iv < 0) {
2998 pos2_iv = pos1_iv + len_iv;
2999 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3000 } else {
3001 if ((UV)len_iv > curlen-(UV)pos1_iv)
3002 pos2_iv = curlen;
3003 else
3004 pos2_iv = pos1_iv+len_iv;
3005 pos2_is_uv = 1;
3006 }
3007 }
3008 }
3009 else {
3010 pos2_iv = curlen;
3011 pos2_is_uv = 1;
3012 }
3013
3014 if (!pos2_is_uv && pos2_iv < 0) {
3015 if (!pos1_is_uv && pos1_iv < 0)
3016 return FALSE;
3017 pos2_iv = 0;
3018 }
3019 else if (!pos1_is_uv && pos1_iv < 0)
3020 pos1_iv = 0;
3021
3022 if ((UV)pos2_iv < (UV)pos1_iv)
3023 pos2_iv = pos1_iv;
3024 if ((UV)pos2_iv > curlen)
3025 pos2_iv = curlen;
3026
3027 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3028 *posp = (STRLEN)( (UV)pos1_iv );
3029 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3030
3031 return TRUE;
3032}
3033
79072805
LW
3034PP(pp_substr)
3035{
97aff369 3036 dVAR; dSP; dTARGET;
79072805 3037 SV *sv;
463ee0b2 3038 STRLEN curlen;
9402d6ed 3039 STRLEN utf8_curlen;
777f7c56
EB
3040 SV * pos_sv;
3041 IV pos1_iv;
3042 int pos1_is_uv;
777f7c56
EB
3043 SV * len_sv;
3044 IV len_iv = 0;
83f78d1a 3045 int len_is_uv = 0;
24fcb59f 3046 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
bbddc9e0 3047 const bool rvalue = (GIMME_V != G_VOID);
e1ec3a88 3048 const char *tmps;
9402d6ed 3049 SV *repl_sv = NULL;
cbbf8932 3050 const char *repl = NULL;
7b8d334a 3051 STRLEN repl_len;
7bc95ae1 3052 int num_args = PL_op->op_private & 7;
13e30c65 3053 bool repl_need_utf8_upgrade = FALSE;
79072805 3054
78f9721b
SM
3055 if (num_args > 2) {
3056 if (num_args > 3) {
24fcb59f 3057 if(!(repl_sv = POPs)) num_args--;
7bc95ae1
FC
3058 }
3059 if ((len_sv = POPs)) {
3060 len_iv = SvIV(len_sv);
83f78d1a 3061 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
7b8d334a 3062 }
7bc95ae1 3063 else num_args--;
5d82c453 3064 }
777f7c56
EB
3065 pos_sv = POPs;
3066 pos1_iv = SvIV(pos_sv);
3067 pos1_is_uv = SvIOK_UV(pos_sv);
79072805 3068 sv = POPs;
24fcb59f
FC
3069 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3070 assert(!repl_sv);
3071 repl_sv = POPs;
3072 }
849ca7ee 3073 PUTBACK;
6582db62 3074 if (lvalue && !repl_sv) {
83f78d1a
FC
3075 SV * ret;
3076 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3077 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3078 LvTYPE(ret) = 'x';
3079 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3080 LvTARGOFF(ret) =
3081 pos1_is_uv || pos1_iv >= 0
3082 ? (STRLEN)(UV)pos1_iv
3083 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3084 LvTARGLEN(ret) =
3085 len_is_uv || len_iv > 0
3086 ? (STRLEN)(UV)len_iv
3087 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3088
3089 SPAGAIN;
3090 PUSHs(ret); /* avoid SvSETMAGIC here */
3091 RETURN;
a74fb2cd 3092 }
6582db62
FC
3093 if (repl_sv) {
3094 repl = SvPV_const(repl_sv, repl_len);
3095 SvGETMAGIC(sv);
3096 if (SvROK(sv))
3097 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3098 "Attempt to use reference as lvalue in substr"
3099 );
3100 tmps = SvPV_force_nomg(sv, curlen);
3101 if (DO_UTF8(repl_sv) && repl_len) {
3102 if (!DO_UTF8(sv)) {
01680ee9 3103 sv_utf8_upgrade_nomg(sv);
6582db62
FC
3104 curlen = SvCUR(sv);
3105 }
3106 }
3107 else if (DO_UTF8(sv))
3108 repl_need_utf8_upgrade = TRUE;
3109 }
3110 else tmps = SvPV_const(sv, curlen);
7e2040f0 3111 if (DO_UTF8(sv)) {
0d788f38 3112 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
9402d6ed
JH
3113 if (utf8_curlen == curlen)
3114 utf8_curlen = 0;
a0ed51b3 3115 else
9402d6ed 3116 curlen = utf8_curlen;
a0ed51b3 3117 }
d1c2b58a 3118 else
9402d6ed 3119 utf8_curlen = 0;
a0ed51b3 3120
83f78d1a
FC
3121 {
3122 STRLEN pos, len, byte_len, byte_pos;
777f7c56 3123
83f78d1a
FC
3124 if (!translate_substr_offsets(
3125 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3126 )) goto bound_fail;
777f7c56 3127
83f78d1a
FC
3128 byte_len = len;
3129 byte_pos = utf8_curlen
0d788f38 3130 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
d931b1be 3131
2154eca7 3132 tmps += byte_pos;
bbddc9e0
CS
3133
3134 if (rvalue) {
3135 SvTAINTED_off(TARG); /* decontaminate */
3136 SvUTF8_off(TARG); /* decontaminate */
3137 sv_setpvn(TARG, tmps, byte_len);
12aa1545 3138#ifdef USE_LOCALE_COLLATE
bbddc9e0 3139 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
12aa1545 3140#endif
bbddc9e0
CS
3141 if (utf8_curlen)
3142 SvUTF8_on(TARG);
3143 }
2154eca7 3144
f7928d6c 3145 if (repl) {
13e30c65
JH
3146 SV* repl_sv_copy = NULL;
3147
3148 if (repl_need_utf8_upgrade) {
3149 repl_sv_copy = newSVsv(repl_sv);
3150 sv_utf8_upgrade(repl_sv_copy);
349d4f2f 3151 repl = SvPV_const(repl_sv_copy, repl_len);
13e30c65 3152 }
502d9230
VP
3153 if (!SvOK(sv))
3154 sv_setpvs(sv, "");
777f7c56 3155 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
ef8d46e8 3156 SvREFCNT_dec(repl_sv_copy);
f7928d6c 3157 }
79072805 3158 }
849ca7ee 3159 SPAGAIN;
bbddc9e0
CS
3160 if (rvalue) {
3161 SvSETMAGIC(TARG);
3162 PUSHs(TARG);
3163 }
79072805 3164 RETURN;
777f7c56 3165
1c900557 3166bound_fail:
83f78d1a 3167 if (repl)
777f7c56
EB
3168 Perl_croak(aTHX_ "substr outside of string");
3169 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3170 RETPUSHUNDEF;
79072805
LW
3171}
3172
3173PP(pp_vec)
3174{
2154eca7 3175 dVAR; dSP;
eb578fdb
KW
3176 const IV size = POPi;
3177 const IV offset = POPi;
3178 SV * const src = POPs;
1b6737cc 3179 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2154eca7 3180 SV * ret;
a0d0e21e 3181
81e118e0 3182 if (lvalue) { /* it's an lvalue! */
2154eca7
EB
3183 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3184 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3185 LvTYPE(ret) = 'v';
3186 LvTARG(ret) = SvREFCNT_inc_simple(src);
3187 LvTARGOFF(ret) = offset;
3188 LvTARGLEN(ret) = size;
3189 }
3190 else {
3191 dTARGET;
3192 SvTAINTED_off(TARG); /* decontaminate */
3193 ret = TARG;
79072805
LW
3194 }
3195
2154eca7
EB
3196 sv_setuv(ret, do_vecget(src, offset, size));
3197 PUSHs(ret);
79072805
LW
3198 RETURN;
3199}
3200
3201PP(pp_index)
3202{
97aff369 3203 dVAR; dSP; dTARGET;
79072805
LW
3204 SV *big;
3205 SV *little;
c445ea15 3206 SV *temp = NULL;
ad66a58c 3207 STRLEN biglen;
2723d216 3208 STRLEN llen = 0;
b464e2b7
TC
3209 SSize_t offset = 0;
3210 SSize_t retval;
73ee8be2
NC
3211 const char *big_p;
3212 const char *little_p;
2f040f7f
NC
3213 bool big_utf8;
3214 bool little_utf8;
2723d216 3215 const bool is_index = PL_op->op_type == OP_INDEX;
d3e26383 3216 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
79072805 3217
e1dccc0d
Z
3218 if (threeargs)
3219 offset = POPi;
79072805
LW
3220 little = POPs;
3221 big = POPs;
73ee8be2
NC
3222 big_p = SvPV_const(big, biglen);
3223 little_p = SvPV_const(little, llen);
3224
e609e586
NC
3225 big_utf8 = DO_UTF8(big);
3226 little_utf8 = DO_UTF8(little);
3227 if (big_utf8 ^ little_utf8) {
3228 /* One needs to be upgraded. */
2f040f7f
NC
3229 if (little_utf8 && !PL_encoding) {
3230 /* Well, maybe instead we might be able to downgrade the small
3231 string? */
1eced8f8 3232 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
2f040f7f
NC
3233 &little_utf8);
3234 if (little_utf8) {
3235 /* If the large string is ISO-8859-1, and it's not possible to
3236 convert the small string to ISO-8859-1, then there is no
3237 way that it could be found anywhere by index. */
3238 retval = -1;
3239 goto fail;
3240 }
e609e586 3241
2f040f7f
NC
3242 /* At this point, pv is a malloc()ed string. So donate it to temp
3243 to ensure it will get free()d */
3244 little = temp = newSV(0);
73ee8be2
NC
3245 sv_usepvn(temp, pv, llen);
3246 little_p = SvPVX(little);
e609e586 3247 } else {
73ee8be2
NC
3248 temp = little_utf8
3249 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
2f040f7f
NC
3250
3251 if (PL_encoding) {
3252 sv_recode_to_utf8(temp, PL_encoding);
3253 } else {
3254 sv_utf8_upgrade(temp);
3255 }
3256 if (little_utf8) {
3257 big = temp;
3258 big_utf8 = TRUE;
73ee8be2 3259 big_p = SvPV_const(big, biglen);
2f040f7f
NC
3260 } else {
3261 little = temp;
73ee8be2 3262 little_p = SvPV_const(little, llen);
2f040f7f 3263 }
e609e586
NC
3264 }
3265 }
73ee8be2
NC
3266 if (SvGAMAGIC(big)) {
3267 /* Life just becomes a lot easier if I use a temporary here.
3268 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3269 will trigger magic and overloading again, as will fbm_instr()
3270 */
59cd0e26
NC
3271 big = newSVpvn_flags(big_p, biglen,
3272 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3273 big_p = SvPVX(big);
3274 }
e4e44778 3275 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
73ee8be2
NC
3276 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3277 warn on undef, and we've already triggered a warning with the
3278 SvPV_const some lines above. We can't remove that, as we need to
3279 call some SvPV to trigger overloading early and find out if the
3280 string is UTF-8.
3281 This is all getting to messy. The API isn't quite clean enough,
3282 because data access has side effects.
3283 */
59cd0e26
NC
3284 little = newSVpvn_flags(little_p, llen,
3285 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
73ee8be2
NC
3286 little_p = SvPVX(little);
3287 }
e609e586 3288
d3e26383 3289 if (!threeargs)
2723d216 3290 offset = is_index ? 0 : biglen;
a0ed51b3 3291 else {
ad66a58c 3292 if (big_utf8 && offset > 0)
b464e2b7 3293 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
73ee8be2
NC
3294 if (!is_index)
3295 offset += llen;
a0ed51b3 3296 }
79072805
LW
3297 if (offset < 0)
3298 offset = 0;
b464e2b7 3299 else if (offset > (SSize_t)biglen)
ad66a58c 3300 offset = biglen;
73ee8be2
NC
3301 if (!(little_p = is_index
3302 ? fbm_instr((unsigned char*)big_p + offset,
3303 (unsigned char*)big_p + biglen, little, 0)
3304 : rninstr(big_p, big_p + offset,
3305 little_p, little_p + llen)))
a0ed51b3 3306 retval = -1;
ad66a58c 3307 else {
73ee8be2 3308 retval = little_p - big_p;
ad66a58c 3309 if (retval > 0 && big_utf8)
b464e2b7 3310 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
ad66a58c 3311 }
ef8d46e8 3312 SvREFCNT_dec(temp);
2723d216 3313 fail:
e1dccc0d 3314 PUSHi(retval);
79072805
LW
3315 RETURN;
3316}
3317
3318PP(pp_sprintf)
3319{
97aff369 3320 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3e6bd4bf 3321 SvTAINTED_off(TARG);
79072805 3322 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 3323 TAINT_IF(SvTAINTED(TARG));
79072805
LW
3324 SP = ORIGMARK;
3325 PUSHTARG;
3326 RETURN;
3327}
3328
79072805
LW
3329PP(pp_ord)
3330{
97aff369 3331 dVAR; dSP; dTARGET;
1eced8f8 3332
7df053ec 3333 SV *argsv = POPs;
ba210ebe 3334 STRLEN len;
349d4f2f 3335 const U8 *s = (U8*)SvPV_const(argsv, len);
121910a4 3336
799ef3cb 3337 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
1eced8f8 3338 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
799ef3cb 3339 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
4f6386b6 3340 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
121910a4
JH
3341 argsv = tmpsv;
3342 }
79072805 3343
d8f42585 3344 XPUSHu(DO_UTF8(argsv)
4f6386b6 3345 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
f3943cf2 3346 : (UV)(*s));
68795e93 3347
79072805
LW
3348 RETURN;
3349}
3350
463ee0b2
LW
3351PP(pp_chr)
3352{
97aff369 3353 dVAR; dSP; dTARGET;
463ee0b2 3354 char *tmps;
8a064bd6 3355 UV value;
71739502 3356 SV *top = POPs;
8a064bd6 3357
71739502
FC
3358 SvGETMAGIC(top);
3359 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3360 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
8a064bd6 3361 ||
71739502
FC
3362 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3363 && SvNV_nomg(top) < 0.0))) {
b3fe8680
FC
3364 if (ckWARN(WARN_UTF8)) {
3365 if (SvGMAGICAL(top)) {
3366 SV *top2 = sv_newmortal();
3367 sv_setsv_nomg(top2, top);
3368 top = top2;
3369 }
3370 Perl_warner(aTHX_ packWARN(WARN_UTF8),
c1f6cd39 3371 "Invalid negative number (%"SVf") in chr", SVfARG(top));
b3fe8680 3372 }
8a064bd6 3373 value = UNICODE_REPLACEMENT;
8a064bd6 3374 } else {
71739502 3375 value = SvUV_nomg(top);
8a064bd6 3376 }
463ee0b2 3377
862a34c6 3378 SvUPGRADE(TARG,SVt_PV);
a0ed51b3 3379
0064a8a9 3380 if (value > 255 && !IN_BYTES) {
eb160463 3381 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
62961d2e 3382 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
349d4f2f 3383 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
a0ed51b3
LW
3384 *tmps = '\0';
3385 (void)SvPOK_only(TARG);
aa6ffa16 3386 SvUTF8_on(TARG);
a0ed51b3
LW
3387 XPUSHs(TARG);
3388 RETURN;
3389 }
3390
748a9306 3391 SvGROW(TARG,2);
463ee0b2
LW
3392 SvCUR_set(TARG, 1);
3393 tmps = SvPVX(TARG);
eb160463 3394 *tmps++ = (char)value;
748a9306 3395 *tmps = '\0';
a0d0e21e 3396 (void)SvPOK_only(TARG);
4c5ed6e2 3397
88632417 3398 if (PL_encoding && !IN_BYTES) {
799ef3cb 3399 sv_recode_to_utf8(TARG, PL_encoding);
88632417 3400 tmps = SvPVX(TARG);
28936164
KW
3401 if (SvCUR(TARG) == 0
3402 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3403 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3404 {
4c5ed6e2 3405 SvGROW(TARG, 2);
d5a15ac2 3406 tmps = SvPVX(TARG);
4c5ed6e2
ST
3407 SvCUR_set(TARG, 1);
3408 *tmps++ = (char)value;
88632417 3409 *tmps = '\0';
4c5ed6e2 3410 SvUTF8_off(TARG);
88632417
JH
3411 }
3412 }
4c5ed6e2 3413
463ee0b2
LW
3414 XPUSHs(TARG);
3415 RETURN;
3416}
3417
79072805
LW
3418PP(pp_crypt)
3419{
79072805 3420#ifdef HAS_CRYPT
97aff369 3421 dVAR; dSP; dTARGET;
5f74f29c 3422 dPOPTOPssrl;
85c16d83 3423 STRLEN len;
10516c54 3424 const char *tmps = SvPV_const(left, len);
2bc69dc4 3425
85c16d83 3426 if (DO_UTF8(left)) {
2bc69dc4 3427 /* If Unicode, try to downgrade.
f2791508
JH
3428 * If not possible, croak.
3429 * Yes, we made this up. */
1b6737cc 3430 SV* const tsv = sv_2mortal(newSVsv(left));
2bc69dc4 3431
f2791508 3432 SvUTF8_on(tsv);
2bc69dc4 3433 sv_utf8_downgrade(tsv, FALSE);
349d4f2f 3434 tmps = SvPV_const(tsv, len);
85c16d83 3435 }
05404ffe
JH
3436# ifdef USE_ITHREADS
3437# ifdef HAS_CRYPT_R
3438 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3439 /* This should be threadsafe because in ithreads there is only
3440 * one thread per interpreter. If this would not be true,
3441 * we would need a mutex to protect this malloc. */
3442 PL_reentrant_buffer->_crypt_struct_buffer =
3443 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3444#if defined(__GLIBC__) || defined(__EMX__)
3445 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3446 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3447 /* work around glibc-2.2.5 bug */
3448 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3449 }
05404ffe 3450#endif
6ab58e4d 3451 }
05404ffe
JH
3452# endif /* HAS_CRYPT_R */
3453# endif /* USE_ITHREADS */
5f74f29c 3454# ifdef FCRYPT
83003860 3455 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3456# else
83003860 3457 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
5f74f29c 3458# endif
ec93b65f 3459 SETTARG;
4808266b 3460 RETURN;
79072805 3461#else
b13b2135 3462 DIE(aTHX_
79072805
LW
3463 "The crypt() function is unimplemented due to excessive paranoia.");
3464#endif
79072805
LW
3465}
3466
00f254e2
KW
3467/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3468 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3469
79072805
LW
3470PP(pp_ucfirst)
3471{
00f254e2
KW
3472 /* Actually is both lcfirst() and ucfirst(). Only the first character
3473 * changes. This means that possibly we can change in-place, ie., just
3474 * take the source and change that one character and store it back, but not
3475 * if read-only etc, or if the length changes */
3476
97aff369 3477 dVAR;
39644a26 3478 dSP;
d54190f6 3479 SV *source = TOPs;
00f254e2 3480 STRLEN slen; /* slen is the byte length of the whole SV. */
d54190f6
NC
3481 STRLEN need;
3482 SV *dest;
00f254e2
KW
3483 bool inplace; /* ? Convert first char only, in-place */
3484 bool doing_utf8 = FALSE; /* ? using utf8 */
3485 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
12e9c124 3486 const int op_type = PL_op->op_type;
d54190f6
NC
3487 const U8 *s;
3488 U8 *d;
3489 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
00f254e2
KW
3490 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3491 * stored as UTF-8 at s. */
3492 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3493 * lowercased) character stored in tmpbuf. May be either
3494 * UTF-8 or not, but in either case is the number of bytes */
d54190f6 3495
841a5e18 3496 s = (const U8*)SvPV_const(source, slen);
a0ed51b3 3497
00f254e2
KW
3498 /* We may be able to get away with changing only the first character, in
3499 * place, but not if read-only, etc. Later we may discover more reasons to
3500 * not convert in-place. */
5cd5e2d6
FC
3501 inplace = !SvREADONLY(source)
3502 && ( SvPADTMP(source)
3503 || ( SvTEMP(source) && !SvSMAGICAL(source)
3504 && SvREFCNT(source) == 1));
00f254e2
KW
3505
3506 /* First calculate what the changed first character should be. This affects
3507 * whether we can just swap it out, leaving the rest of the string unchanged,
3508 * or even if have to convert the dest to UTF-8 when the source isn't */
3509
3510 if (! slen) { /* If empty */
3511 need = 1; /* still need a trailing NUL */
b7576bcb 3512 ulen = 0;
00f254e2
KW
3513 }
3514 else if (DO_UTF8(source)) { /* Is the source utf8? */
d54190f6 3515 doing_utf8 = TRUE;
17e95c9d 3516 ulen = UTF8SKIP(s);
094a2f8c 3517 if (op_type == OP_UCFIRST) {
130c5df3 3518#ifdef USE_LOCALE_CTYPE
5a6bb681 3519 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3520#else
5a6bb681 3521 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
130c5df3 3522#endif
094a2f8c
KW
3523 }
3524 else {
130c5df3 3525#ifdef USE_LOCALE_CTYPE
5a6bb681 3526 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
130c5df3 3527#else
5a6bb681 3528 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
130c5df3 3529#endif
094a2f8c 3530 }
00f254e2 3531
17e95c9d
KW
3532 /* we can't do in-place if the length changes. */
3533 if (ulen != tculen) inplace = FALSE;
3534 need = slen + 1 - ulen + tculen;
d54190f6 3535 }
00f254e2
KW
3536 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3537 * latin1 is treated as caseless. Note that a locale takes
3538 * precedence */
167d19f2 3539 ulen = 1; /* Original character is 1 byte */
00f254e2
KW
3540 tculen = 1; /* Most characters will require one byte, but this will
3541 * need to be overridden for the tricky ones */
3542 need = slen + 1;
3543
3544 if (op_type == OP_LCFIRST) {
d54190f6 3545
00f254e2 3546 /* lower case the first letter: no trickiness for any character */
130c5df3
KW
3547 *tmpbuf =
3548#ifdef USE_LOCALE_CTYPE
3549 (IN_LC_RUNTIME(LC_CTYPE))
86a1f7fd 3550 ? toLOWER_LC(*s)
130c5df3
KW
3551 :
3552#endif
3553 (IN_UNI_8_BIT)
86a1f7fd
KW
3554 ? toLOWER_LATIN1(*s)
3555 : toLOWER(*s);
00f254e2
KW
3556 }
3557 /* is ucfirst() */
130c5df3 3558#ifdef USE_LOCALE_CTYPE
d6ded950 3559 else if (IN_LC_RUNTIME(LC_CTYPE)) {
31f05a37
KW
3560 if (IN_UTF8_CTYPE_LOCALE) {
3561 goto do_uni_rules;
3562 }
3563
3564 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3565 locales have upper and title case
3566 different */
00f254e2 3567 }
130c5df3 3568#endif
00f254e2
KW
3569 else if (! IN_UNI_8_BIT) {
3570 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3571 * on EBCDIC machines whatever the
3572 * native function does */
3573 }
31f05a37
KW
3574 else {
3575 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3576 * UTF-8, which we treat as not in locale), and cased latin1 */
3577 UV title_ord;
91191cf7 3578#ifdef USE_LOCALE_CTYPE
31f05a37 3579 do_uni_rules:
91191cf7 3580#endif
31f05a37
KW
3581
3582 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
167d19f2
KW
3583 if (tculen > 1) {
3584 assert(tculen == 2);
3585
3586 /* If the result is an upper Latin1-range character, it can
3587 * still be represented in one byte, which is its ordinal */
3588 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3589 *tmpbuf = (U8) title_ord;
3590 tculen = 1;
00f254e2
KW
3591 }
3592 else {
167d19f2
KW
3593 /* Otherwise it became more than one ASCII character (in
3594 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3595 * beyond Latin1, so the number of bytes changed, so can't
3596 * replace just the first character in place. */
3597 inplace = FALSE;
3598
d14578b8
KW
3599 /* If the result won't fit in a byte, the entire result
3600 * will have to be in UTF-8. Assume worst case sizing in
3601 * conversion. (all latin1 characters occupy at most two
3602 * bytes in utf8) */
167d19f2
KW
3603 if (title_ord > 255) {
3604 doing_utf8 = TRUE;
3605 convert_source_to_utf8 = TRUE;
3606 need = slen * 2 + 1;
3607
3608 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3609 * (both) characters whose title case is above 255 is
3610 * 2. */
3611 ulen = 2;
3612 }
3613 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3614 need = slen + 1 + 1;
3615 }
00f254e2 3616 }
167d19f2 3617 }
00f254e2
KW
3618 } /* End of use Unicode (Latin1) semantics */