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