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