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