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