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