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