| CARVIEW |
Select Language
HTTP/2 302
server: nginx
date: Thu, 31 Jul 2025 07:48:53 GMT
content-type: text/plain; charset=utf-8
content-length: 0
x-archive-redirect-reason: found capture at 20220126213829
location: https://web.archive.org/web/20220126213829/https://perl5.git.perl.org/perl5.git/blob/HEAD:/pp.c
server-timing: captures_list;dur=0.794915, exclusion.robots;dur=0.028851, exclusion.robots.policy;dur=0.013735, esindex;dur=0.017373, cdx.remote;dur=11.323497, LoadShardBlock;dur=325.079344, PetaboxLoader3.datanode;dur=87.259328, PetaboxLoader3.resolve;dur=115.688905
x-app-server: wwwb-app210
x-ts: 302
x-tr: 374
server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0
set-cookie: SERVER=wwwb-app210; path=/
x-location: All
x-rl: 0
x-na: 0
x-page-cache: MISS
server-timing: MISS
x-nid: DigitalOcean
referrer-policy: no-referrer-when-downgrade
permissions-policy: interest-cohort=()
HTTP/2 200
server: nginx
date: Thu, 31 Jul 2025 07:48:55 GMT
content-type: application/xhtml+xml; charset=utf-8
x-archive-orig-date: Wed, 26 Jan 2022 21:38:28 GMT
x-archive-orig-server: Apache/2.4.6 (CentOS) OpenSSL/1.0.2k-fips
x-archive-orig-keep-alive: timeout=5, max=100
x-archive-orig-connection: Keep-Alive
x-archive-orig-x-crawler-transfer-encoding: chunked
x-archive-orig-content-length: 1048576
x-archive-guessed-content-type: text/html
x-archive-guessed-charset: utf-8
memento-datetime: Wed, 26 Jan 2022 21:38:29 GMT
link: ; rel="original", ; rel="timemap"; type="application/link-format", ; rel="timegate", ; rel="first memento"; datetime="Tue, 19 Jan 2021 16:06:45 GMT", ; rel="prev memento"; datetime="Tue, 19 Jan 2021 16:06:45 GMT", ; rel="memento"; datetime="Wed, 26 Jan 2022 21:38:29 GMT", ; rel="next memento"; datetime="Mon, 10 Jun 2024 18:45:25 GMT", ; rel="last memento"; datetime="Mon, 10 Jun 2024 18:45:25 GMT"
content-security-policy: default-src 'self' 'unsafe-eval' 'unsafe-inline' data: blob: archive.org web.archive.org web-static.archive.org wayback-api.archive.org athena.archive.org analytics.archive.org pragma.archivelab.org wwwb-events.archive.org
x-archive-src: CC-MAIN-2022-05-1642320304961.89-0023/CC-MAIN-20220126192506-20220126222506-00465.warc.gz
server-timing: captures_list;dur=0.617085, exclusion.robots;dur=0.029715, exclusion.robots.policy;dur=0.015393, esindex;dur=0.014735, cdx.remote;dur=31.534348, LoadShardBlock;dur=282.017687, PetaboxLoader3.resolve;dur=258.086668, PetaboxLoader3.datanode;dur=158.377320, load_resource;dur=244.512428
x-app-server: wwwb-app210
x-ts: 200
x-tr: 1931
server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0
x-location: All
x-rl: 0
x-na: 0
x-page-cache: MISS
server-timing: MISS
x-nid: DigitalOcean
referrer-policy: no-referrer-when-downgrade
permissions-policy: interest-cohort=()
perl5.git.perl.org Git - perl5.git/blob - pp.c
1 /* pp.c
2 *
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
5 *
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.
8 *
9 */
11 /*
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"]
17 */
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 */
26 #include "EXTERN.h"
27 #define PERL_IN_PP_C
28 #include "perl.h"
29 #include "keywords.h"
31 #include "invlist_inline.h"
32 #include "reentr.h"
33 #include "regcharclass.h"
35 /* variations on pp_null */
37 PP(pp_stub)
38 {
39 dSP;
40 if (GIMME_V == G_SCALAR)
41 XPUSHs(&PL_sv_undef);
42 RETURN;
43 }
45 /* Pushy stuff. */
49 PP(pp_padcv)
50 {
51 dSP; dTARGET;
52 assert(SvTYPE(TARG) == SVt_PVCV);
53 XPUSHs(TARG);
54 RETURN;
55 }
57 PP(pp_introcv)
58 {
59 dTARGET;
60 SvPADSTALE_off(TARG);
61 return NORMAL;
62 }
64 PP(pp_clonecv)
65 {
66 dTARGET;
67 CV * const protocv = PadnamePROTOCV(
68 PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG]
69 );
70 assert(SvTYPE(TARG) == SVt_PVCV);
71 assert(protocv);
72 if (CvISXSUB(protocv)) { /* constant */
73 /* XXX Should we clone it here? */
74 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
75 to introcv and remove the SvPADSTALE_off. */
76 SAVEPADSVANDMORTALIZE(ARGTARG);
77 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(protocv);
78 }
79 else {
80 if (CvROOT(protocv)) {
81 assert(CvCLONE(protocv));
82 assert(!CvCLONED(protocv));
83 }
84 cv_clone_into(protocv,(CV *)TARG);
85 SAVECLEARSV(PAD_SVl(ARGTARG));
86 }
87 return NORMAL;
88 }
90 /* Translations. */
92 /* In some cases this function inspects PL_op. If this function is called
93 for new op types, more bool parameters may need to be added in place of
94 the checks.
96 When noinit is true, the absence of a gv will cause a retval of undef.
97 This is unrelated to the cv-to-gv assignment case.
98 */
100 static SV *
101 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
102 const bool noinit)
103 {
104 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
105 if (SvROK(sv)) {
106 if (SvAMAGIC(sv)) {
107 sv = amagic_deref_call(sv, to_gv_amg);
108 }
109 wasref:
110 sv = SvRV(sv);
111 if (SvTYPE(sv) == SVt_PVIO) {
112 GV * const gv = MUTABLE_GV(sv_newmortal());
113 gv_init(gv, 0, "__ANONIO__", 10, 0);
114 GvIOp(gv) = MUTABLE_IO(sv);
115 SvREFCNT_inc_void_NN(sv);
116 sv = MUTABLE_SV(gv);
117 }
118 else if (!isGV_with_GP(sv)) {
119 Perl_die(aTHX_ "Not a GLOB reference");
120 }
121 }
122 else {
123 if (!isGV_with_GP(sv)) {
124 if (!SvOK(sv)) {
125 /* If this is a 'my' scalar and flag is set then vivify
126 * NI-S 1999/05/07
127 */
128 if (vivify_sv && sv != &PL_sv_undef) {
129 GV *gv;
130 HV *stash;
131 if (SvREADONLY(sv))
132 Perl_croak_no_modify();
133 gv = MUTABLE_GV(newSV(0));
134 stash = CopSTASH(PL_curcop);
135 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
136 if (cUNOP->op_targ) {
137 SV * const namesv = PAD_SV(cUNOP->op_targ);
138 gv_init_sv(gv, stash, namesv, 0);
139 }
140 else {
141 gv_init_pv(gv, stash, "__ANONIO__", 0);
142 }
143 sv_setrv_noinc_mg(sv, MUTABLE_SV(gv));
144 goto wasref;
145 }
146 if (PL_op->op_flags & OPf_REF || strict) {
147 Perl_die(aTHX_ PL_no_usym, "a symbol");
148 }
149 if (ckWARN(WARN_UNINITIALIZED))
150 report_uninit(sv);
151 return &PL_sv_undef;
152 }
153 if (noinit)
154 {
155 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
156 sv, GV_ADDMG, SVt_PVGV
157 ))))
158 return &PL_sv_undef;
159 }
160 else {
161 if (strict) {
162 Perl_die(aTHX_
163 PL_no_symref_sv,
164 sv,
165 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
166 "a symbol"
167 );
168 }
169 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
170 == OPpDONT_INIT_GV) {
171 /* We are the target of a coderef assignment. Return
172 the scalar unchanged, and let pp_sasssign deal with
173 things. */
174 return sv;
175 }
176 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
177 }
178 /* FAKE globs in the symbol table cause weird bugs (#77810) */
179 SvFAKE_off(sv);
180 }
181 }
182 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
183 SV *newsv = sv_mortalcopy_flags(sv, 0);
184 SvFAKE_off(newsv);
185 sv = newsv;
186 }
187 return sv;
188 }
190 PP(pp_rv2gv)
191 {
192 dSP; dTOPss;
194 sv = S_rv2gv(aTHX_
195 sv, PL_op->op_private & OPpDEREF,
196 PL_op->op_private & HINT_STRICT_REFS,
197 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
198 || PL_op->op_type == OP_READLINE
199 );
200 if (PL_op->op_private & OPpLVAL_INTRO)
201 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
202 SETs(sv);
203 RETURN;
204 }
206 /* Helper function for pp_rv2sv and pp_rv2av */
207 GV *
208 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
209 const svtype type, SV ***spp)
210 {
211 GV *gv;
213 PERL_ARGS_ASSERT_SOFTREF2XV;
215 if (PL_op->op_private & HINT_STRICT_REFS) {
216 if (SvOK(sv))
217 Perl_die(aTHX_ PL_no_symref_sv, sv,
218 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
219 else
220 Perl_die(aTHX_ PL_no_usym, what);
221 }
222 if (!SvOK(sv)) {
223 if (
224 PL_op->op_flags & OPf_REF
225 )
226 Perl_die(aTHX_ PL_no_usym, what);
227 if (ckWARN(WARN_UNINITIALIZED))
228 report_uninit(sv);
229 if (type != SVt_PV && GIMME_V == G_LIST) {
230 (*spp)--;
231 return NULL;
232 }
233 **spp = &PL_sv_undef;
234 return NULL;
235 }
236 if ((PL_op->op_flags & OPf_SPECIAL) &&
237 !(PL_op->op_flags & OPf_MOD))
238 {
239 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
240 {
241 **spp = &PL_sv_undef;
242 return NULL;
243 }
244 }
245 else {
246 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
247 }
248 return gv;
249 }
251 PP(pp_rv2sv)
252 {
253 dSP; dTOPss;
254 GV *gv = NULL;
256 SvGETMAGIC(sv);
257 if (SvROK(sv)) {
258 if (SvAMAGIC(sv)) {
259 sv = amagic_deref_call(sv, to_sv_amg);
260 }
262 sv = SvRV(sv);
263 if (SvTYPE(sv) >= SVt_PVAV)
264 DIE(aTHX_ "Not a SCALAR reference");
265 }
266 else {
267 gv = MUTABLE_GV(sv);
269 if (!isGV_with_GP(gv)) {
270 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
271 if (!gv)
272 RETURN;
273 }
274 sv = GvSVn(gv);
275 }
276 if (PL_op->op_flags & OPf_MOD) {
277 if (PL_op->op_private & OPpLVAL_INTRO) {
278 if (cUNOP->op_first->op_type == OP_NULL)
279 sv = save_scalar(MUTABLE_GV(TOPs));
280 else if (gv)
281 sv = save_scalar(gv);
282 else
283 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
284 }
285 else if (PL_op->op_private & OPpDEREF)
286 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
287 }
288 SPAGAIN; /* in case chasing soft refs reallocated the stack */
289 SETs(sv);
290 RETURN;
291 }
293 PP(pp_av2arylen)
294 {
295 dSP;
296 AV * const av = MUTABLE_AV(TOPs);
297 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
298 if (lvalue) {
299 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
300 if (!*svp) {
301 *svp = newSV_type(SVt_PVMG);
302 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
303 }
304 SETs(*svp);
305 } else {
306 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
307 }
308 RETURN;
309 }
311 PP(pp_pos)
312 {
313 dSP; dTOPss;
315 if (PL_op->op_flags & OPf_MOD || LVRET) {
316 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
317 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
318 LvTYPE(ret) = '.';
319 LvTARG(ret) = SvREFCNT_inc_simple(sv);
320 SETs(ret); /* no SvSETMAGIC */
321 }
322 else {
323 const MAGIC * const mg = mg_find_mglob(sv);
324 if (mg && mg->mg_len != -1) {
325 STRLEN i = mg->mg_len;
326 if (PL_op->op_private & OPpTRUEBOOL)
327 SETs(i ? &PL_sv_yes : &PL_sv_zero);
328 else {
329 dTARGET;
330 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
331 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
332 SETu(i);
333 }
334 return NORMAL;
335 }
336 SETs(&PL_sv_undef);
337 }
338 return NORMAL;
339 }
341 PP(pp_rv2cv)
342 {
343 dSP;
344 GV *gv;
345 HV *stash_unused;
346 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
347 ? GV_ADDMG
348 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
349 == OPpMAY_RETURN_CONSTANT)
350 ? GV_ADD|GV_NOEXPAND
351 : GV_ADD;
352 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
353 /* (But not in defined().) */
355 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
356 if (cv) NOOP;
357 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
358 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
359 ? MUTABLE_CV(SvRV(gv))
360 : MUTABLE_CV(gv);
361 }
362 else
363 cv = MUTABLE_CV(&PL_sv_undef);
364 SETs(MUTABLE_SV(cv));
365 return NORMAL;
366 }
368 PP(pp_prototype)
369 {
370 dSP;
371 CV *cv;
372 HV *stash;
373 GV *gv;
374 SV *ret = &PL_sv_undef;
376 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
377 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
378 const char * s = SvPVX_const(TOPs);
379 if (memBEGINs(s, SvCUR(TOPs), "CORE::")) {
380 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
381 if (!code)
382 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
383 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
384 {
385 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
386 if (sv) ret = sv;
387 }
388 goto set;
389 }
390 }
391 cv = sv_2cv(TOPs, &stash, &gv, 0);
392 if (cv && SvPOK(cv))
393 ret = newSVpvn_flags(
394 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
395 );
396 set:
397 SETs(ret);
398 RETURN;
399 }
401 PP(pp_anoncode)
402 {
403 dSP;
404 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
405 if (CvCLONE(cv))
406 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
407 EXTEND(SP,1);
408 PUSHs(MUTABLE_SV(cv));
409 RETURN;
410 }
412 PP(pp_srefgen)
413 {
414 dSP;
415 *SP = refto(*SP);
416 return NORMAL;
417 }
419 PP(pp_refgen)
420 {
421 dSP; dMARK;
422 if (GIMME_V != G_LIST) {
423 if (++MARK <= SP)
424 *MARK = *SP;
425 else
426 {
427 MEXTEND(SP, 1);
428 *MARK = &PL_sv_undef;
429 }
430 *MARK = refto(*MARK);
431 SP = MARK;
432 RETURN;
433 }
434 EXTEND_MORTAL(SP - MARK);
435 while (++MARK <= SP)
436 *MARK = refto(*MARK);
437 RETURN;
438 }
440 STATIC SV*
441 S_refto(pTHX_ SV *sv)
442 {
443 SV* rv;
445 PERL_ARGS_ASSERT_REFTO;
447 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
448 if (LvTARGLEN(sv))
449 vivify_defelem(sv);
450 if (!(sv = LvTARG(sv)))
451 sv = &PL_sv_undef;
452 else
453 SvREFCNT_inc_void_NN(sv);
454 }
455 else if (SvTYPE(sv) == SVt_PVAV) {
456 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
457 av_reify(MUTABLE_AV(sv));
458 SvTEMP_off(sv);
459 SvREFCNT_inc_void_NN(sv);
460 }
461 else if (SvPADTMP(sv)) {
462 sv = newSVsv(sv);
463 }
464 else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem)))
465 sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem);
466 else {
467 SvTEMP_off(sv);
468 SvREFCNT_inc_void_NN(sv);
469 }
470 rv = sv_newmortal();
471 sv_setrv_noinc(rv, sv);
472 return rv;
473 }
475 PP(pp_ref)
476 {
477 dSP;
478 SV * const sv = TOPs;
480 SvGETMAGIC(sv);
481 if (!SvROK(sv)) {
482 SETs(&PL_sv_no);
483 return NORMAL;
484 }
486 /* op is in boolean context? */
487 if ( (PL_op->op_private & OPpTRUEBOOL)
488 || ( (PL_op->op_private & OPpMAYBE_TRUEBOOL)
489 && block_gimme() == G_VOID))
490 {
491 /* refs are always true - unless it's to an object blessed into a
492 * class with a false name, i.e. "0". So we have to check for
493 * that remote possibility. The following is is basically an
494 * unrolled SvTRUE(sv_reftype(rv)) */
495 SV * const rv = SvRV(sv);
496 if (SvOBJECT(rv)) {
497 HV *stash = SvSTASH(rv);
498 HEK *hek = HvNAME_HEK(stash);
499 if (hek) {
500 I32 len = HEK_LEN(hek);
501 /* bail out and do it the hard way? */
502 if (UNLIKELY(
503 len == HEf_SVKEY
504 || (len == 1 && HEK_KEY(hek)[0] == '0')
505 ))
506 goto do_sv_ref;
507 }
508 }
509 SETs(&PL_sv_yes);
510 return NORMAL;
511 }
513 do_sv_ref:
514 {
515 dTARGET;
516 SETs(TARG);
517 sv_ref(TARG, SvRV(sv), TRUE);
518 SvSETMAGIC(TARG);
519 return NORMAL;
520 }
522 }
525 PP(pp_bless)
526 {
527 dSP;
528 HV *stash;
530 if (MAXARG == 1)
531 {
532 curstash:
533 stash = CopSTASH(PL_curcop);
534 if (SvTYPE(stash) != SVt_PVHV)
535 Perl_croak(aTHX_ "Attempt to bless into a freed package");
536 }
537 else {
538 SV * const ssv = POPs;
539 STRLEN len;
540 const char *ptr;
542 if (!ssv) goto curstash;
543 SvGETMAGIC(ssv);
544 if (SvROK(ssv)) {
545 if (!SvAMAGIC(ssv)) {
546 frog:
547 Perl_croak(aTHX_ "Attempt to bless into a reference");
548 }
549 /* SvAMAGIC is on here, but it only means potentially overloaded,
550 so after stringification: */
551 ptr = SvPV_nomg_const(ssv,len);
552 /* We need to check the flag again: */
553 if (!SvAMAGIC(ssv)) goto frog;
554 }
555 else ptr = SvPV_nomg_const(ssv,len);
556 if (len == 0)
557 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
558 "Explicit blessing to '' (assuming package main)");
559 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
560 }
562 (void)sv_bless(TOPs, stash);
563 RETURN;
564 }
566 PP(pp_gelem)
567 {
568 dSP;
570 SV *sv = POPs;
571 STRLEN len;
572 const char * const elem = SvPV_const(sv, len);
573 GV * const gv = MUTABLE_GV(TOPs);
574 SV * tmpRef = NULL;
576 sv = NULL;
577 if (elem) {
578 /* elem will always be NUL terminated. */
579 switch (*elem) {
580 case 'A':
581 if (memEQs(elem, len, "ARRAY"))
582 {
583 tmpRef = MUTABLE_SV(GvAV(gv));
584 if (tmpRef && !AvREAL((const AV *)tmpRef)
585 && AvREIFY((const AV *)tmpRef))
586 av_reify(MUTABLE_AV(tmpRef));
587 }
588 break;
589 case 'C':
590 if (memEQs(elem, len, "CODE"))
591 tmpRef = MUTABLE_SV(GvCVu(gv));
592 break;
593 case 'F':
594 if (memEQs(elem, len, "FILEHANDLE")) {
595 tmpRef = MUTABLE_SV(GvIOp(gv));
596 }
597 else
598 if (memEQs(elem, len, "FORMAT"))
599 tmpRef = MUTABLE_SV(GvFORM(gv));
600 break;
601 case 'G':
602 if (memEQs(elem, len, "GLOB"))
603 tmpRef = MUTABLE_SV(gv);
604 break;
605 case 'H':
606 if (memEQs(elem, len, "HASH"))
607 tmpRef = MUTABLE_SV(GvHV(gv));
608 break;
609 case 'I':
610 if (memEQs(elem, len, "IO"))
611 tmpRef = MUTABLE_SV(GvIOp(gv));
612 break;
613 case 'N':
614 if (memEQs(elem, len, "NAME"))
615 sv = newSVhek(GvNAME_HEK(gv));
616 break;
617 case 'P':
618 if (memEQs(elem, len, "PACKAGE")) {
619 const HV * const stash = GvSTASH(gv);
620 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
621 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
622 }
623 break;
624 case 'S':
625 if (memEQs(elem, len, "SCALAR"))
626 tmpRef = GvSVn(gv);
627 break;
628 }
629 }
630 if (tmpRef)
631 sv = newRV(tmpRef);
632 if (sv)
633 sv_2mortal(sv);
634 else
635 sv = &PL_sv_undef;
636 SETs(sv);
637 RETURN;
638 }
640 /* Pattern matching */
642 PP(pp_study)
643 {
644 dSP; dTOPss;
645 STRLEN len;
647 (void)SvPV(sv, len);
648 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
649 /* Historically, study was skipped in these cases. */
650 SETs(&PL_sv_no);
651 return NORMAL;
652 }
654 /* Make study a no-op. It's no longer useful and its existence
655 complicates matters elsewhere. */
656 SETs(&PL_sv_yes);
657 return NORMAL;
658 }
661 /* also used for: pp_transr() */
663 PP(pp_trans)
664 {
665 dSP;
666 SV *sv;
668 if (PL_op->op_flags & OPf_STACKED)
669 sv = POPs;
670 else {
671 EXTEND(SP,1);
672 if (ARGTARG)
673 sv = PAD_SV(ARGTARG);
674 else {
675 sv = DEFSV;
676 }
677 }
678 if(PL_op->op_type == OP_TRANSR) {
679 STRLEN len;
680 const char * const pv = SvPV(sv,len);
681 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
682 do_trans(newsv);
683 PUSHs(newsv);
684 }
685 else {
686 Size_t i = do_trans(sv);
687 mPUSHi((UV)i);
688 }
689 RETURN;
690 }
692 /* Lvalue operators. */
694 static size_t
695 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
696 {
697 STRLEN len;
698 char *s;
699 size_t count = 0;
701 PERL_ARGS_ASSERT_DO_CHOMP;
703 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
704 return 0;
705 if (SvTYPE(sv) == SVt_PVAV) {
706 I32 i;
707 AV *const av = MUTABLE_AV(sv);
708 const I32 max = AvFILL(av);
710 for (i = 0; i <= max; i++) {
711 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
712 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
713 count += do_chomp(retval, sv, chomping);
714 }
715 return count;
716 }
717 else if (SvTYPE(sv) == SVt_PVHV) {
718 HV* const hv = MUTABLE_HV(sv);
719 HE* entry;
720 (void)hv_iterinit(hv);
721 while ((entry = hv_iternext(hv)))
722 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
723 return count;
724 }
725 else if (SvREADONLY(sv)) {
726 Perl_croak_no_modify();
727 }
729 s = SvPV(sv, len);
730 if (chomping) {
731 if (s && len) {
732 char *temp_buffer = NULL;
733 SV *svrecode = NULL;
734 s += --len;
735 if (RsPARA(PL_rs)) {
736 if (*s != '\n')
737 goto nope_free_nothing;
738 ++count;
739 while (len && s[-1] == '\n') {
740 --len;
741 --s;
742 ++count;
743 }
744 }
745 else {
746 STRLEN rslen, rs_charlen;
747 const char *rsptr = SvPV_const(PL_rs, rslen);
749 rs_charlen = SvUTF8(PL_rs)
750 ? sv_len_utf8(PL_rs)
751 : rslen;
753 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
754 /* Assumption is that rs is shorter than the scalar. */
755 if (SvUTF8(PL_rs)) {
756 /* RS is utf8, scalar is 8 bit. */
757 bool is_utf8 = TRUE;
758 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
759 &rslen, &is_utf8);
760 if (is_utf8) {
761 /* Cannot downgrade, therefore cannot possibly match.
762 At this point, temp_buffer is not alloced, and
763 is the buffer inside PL_rs, so dont free it.
764 */
765 assert (temp_buffer == rsptr);
766 goto nope_free_sv;
767 }
768 rsptr = temp_buffer;
769 }
770 else {
771 /* RS is 8 bit, scalar is utf8. */
772 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
773 rsptr = temp_buffer;
774 }
775 }
776 if (rslen == 1) {
777 if (*s != *rsptr)
778 goto nope_free_all;
779 ++count;
780 }
781 else {
782 if (len < rslen - 1)
783 goto nope_free_all;
784 len -= rslen - 1;
785 s -= rslen - 1;
786 if (memNE(s, rsptr, rslen))
787 goto nope_free_all;
788 count += rs_charlen;
789 }
790 }
791 SvPV_force_nomg_nolen(sv);
792 SvCUR_set(sv, len);
793 *SvEND(sv) = '\0';
794 SvNIOK_off(sv);
795 SvSETMAGIC(sv);
797 nope_free_all:
798 Safefree(temp_buffer);
799 nope_free_sv:
800 SvREFCNT_dec(svrecode);
801 nope_free_nothing: ;
802 }
803 } else {
804 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
805 s = SvPV_force_nomg(sv, len);
806 if (DO_UTF8(sv)) {
807 if (s && len) {
808 char * const send = s + len;
809 char * const start = s;
810 s = send - 1;
811 while (s > start && UTF8_IS_CONTINUATION(*s))
812 s--;
813 if (is_utf8_string((U8*)s, send - s)) {
814 sv_setpvn(retval, s, send - s);
815 *s = '\0';
816 SvCUR_set(sv, s - start);
817 SvNIOK_off(sv);
818 SvUTF8_on(retval);
819 }
820 }
821 else
822 SvPVCLEAR(retval);
823 }
824 else if (s && len) {
825 s += --len;
826 sv_setpvn(retval, s, 1);
827 *s = '\0';
828 SvCUR_set(sv, len);
829 SvUTF8_off(sv);
830 SvNIOK_off(sv);
831 }
832 else
833 SvPVCLEAR(retval);
834 SvSETMAGIC(sv);
835 }
836 return count;
837 }
840 /* also used for: pp_schomp() */
842 PP(pp_schop)
843 {
844 dSP; dTARGET;
845 const bool chomping = PL_op->op_type == OP_SCHOMP;
847 const size_t count = do_chomp(TARG, TOPs, chomping);
848 if (chomping)
849 sv_setiv(TARG, count);
850 SETTARG;
851 return NORMAL;
852 }
855 /* also used for: pp_chomp() */
857 PP(pp_chop)
858 {
859 dSP; dMARK; dTARGET; dORIGMARK;
860 const bool chomping = PL_op->op_type == OP_CHOMP;
861 size_t count = 0;
863 while (MARK < SP)
864 count += do_chomp(TARG, *++MARK, chomping);
865 if (chomping)
866 sv_setiv(TARG, count);
867 SP = ORIGMARK;
868 XPUSHTARG;
869 RETURN;
870 }
872 PP(pp_undef)
873 {
874 dSP;
875 SV *sv;
877 if (!PL_op->op_private) {
878 EXTEND(SP, 1);
879 RETPUSHUNDEF;
880 }
882 sv = TOPs;
883 if (!sv)
884 {
885 SETs(&PL_sv_undef);
886 return NORMAL;
887 }
889 if (SvTHINKFIRST(sv))
890 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
892 switch (SvTYPE(sv)) {
893 case SVt_NULL:
894 break;
895 case SVt_PVAV:
896 av_undef(MUTABLE_AV(sv));
897 break;
898 case SVt_PVHV:
899 hv_undef(MUTABLE_HV(sv));
900 break;
901 case SVt_PVCV:
902 if (cv_const_sv((const CV *)sv))
903 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
904 "Constant subroutine %" SVf " undefined",
905 SVfARG(CvANON((const CV *)sv)
906 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
907 : sv_2mortal(newSVhek(
908 CvNAMED(sv)
909 ? CvNAME_HEK((CV *)sv)
910 : GvENAME_HEK(CvGV((const CV *)sv))
911 ))
912 ));
913 /* FALLTHROUGH */
914 case SVt_PVFM:
915 /* let user-undef'd sub keep its identity */
916 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
917 break;
918 case SVt_PVGV:
919 assert(isGV_with_GP(sv));
920 assert(!SvFAKE(sv));
921 {
922 GP *gp;
923 HV *stash;
925 /* undef *Pkg::meth_name ... */
926 bool method_changed
927 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
928 && HvENAME_get(stash);
929 /* undef *Foo:: */
930 if((stash = GvHV((const GV *)sv))) {
931 if(HvENAME_get(stash))
932 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
933 else stash = NULL;
934 }
936 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
937 gp_free(MUTABLE_GV(sv));
938 Newxz(gp, 1, GP);
939 GvGP_set(sv, gp_ref(gp));
940 #ifndef PERL_DONT_CREATE_GVSV
941 GvSV(sv) = newSV(0);
942 #endif
943 GvLINE(sv) = CopLINE(PL_curcop);
944 GvEGV(sv) = MUTABLE_GV(sv);
945 GvMULTI_on(sv);
947 if(stash)
948 mro_package_moved(NULL, stash, (const GV *)sv, 0);
949 stash = NULL;
950 /* undef *Foo::ISA */
951 if( strEQ(GvNAME((const GV *)sv), "ISA")
952 && (stash = GvSTASH((const GV *)sv))
953 && (method_changed || HvENAME(stash)) )
954 mro_isa_changed_in(stash);
955 else if(method_changed)
956 mro_method_changed_in(
957 GvSTASH((const GV *)sv)
958 );
960 break;
961 }
962 default:
963 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
964 SvPV_free(sv);
965 SvPV_set(sv, NULL);
966 SvLEN_set(sv, 0);
967 }
968 SvOK_off(sv);
969 SvSETMAGIC(sv);
970 }
972 SETs(&PL_sv_undef);
973 return NORMAL;
974 }
977 /* common "slow" code for pp_postinc and pp_postdec */
979 static OP *
980 S_postincdec_common(pTHX_ SV *sv, SV *targ)
981 {
982 dSP;
983 const bool inc =
984 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
986 if (SvROK(sv))
987 TARG = sv_newmortal();
988 sv_setsv(TARG, sv);
989 if (inc)
990 sv_inc_nomg(sv);
991 else
992 sv_dec_nomg(sv);
993 SvSETMAGIC(sv);
994 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
995 if (inc && !SvOK(TARG))
996 sv_setiv(TARG, 0);
997 SETTARG;
998 return NORMAL;
999 }
1002 /* also used for: pp_i_postinc() */
1004 PP(pp_postinc)
1005 {
1006 dSP; dTARGET;
1007 SV *sv = TOPs;
1009 /* special-case sv being a simple integer */
1010 if (LIKELY(((sv->sv_flags &
1011 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1012 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1013 == SVf_IOK))
1014 && SvIVX(sv) != IV_MAX)
1015 {
1016 IV iv = SvIVX(sv);
1017 SvIV_set(sv, iv + 1);
1018 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1019 SETs(TARG);
1020 return NORMAL;
1021 }
1023 return S_postincdec_common(aTHX_ sv, TARG);
1024 }
1027 /* also used for: pp_i_postdec() */
1029 PP(pp_postdec)
1030 {
1031 dSP; dTARGET;
1032 SV *sv = TOPs;
1034 /* special-case sv being a simple integer */
1035 if (LIKELY(((sv->sv_flags &
1036 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1037 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1038 == SVf_IOK))
1039 && SvIVX(sv) != IV_MIN)
1040 {
1041 IV iv = SvIVX(sv);
1042 SvIV_set(sv, iv - 1);
1043 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1044 SETs(TARG);
1045 return NORMAL;
1046 }
1048 return S_postincdec_common(aTHX_ sv, TARG);
1049 }
1052 /* Ordinary operators. */
1054 PP(pp_pow)
1055 {
1056 dSP; dATARGET; SV *svl, *svr;
1057 #ifdef PERL_PRESERVE_IVUV
1058 bool is_int = 0;
1059 #endif
1060 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1061 svr = TOPs;
1062 svl = TOPm1s;
1063 #ifdef PERL_PRESERVE_IVUV
1064 /* For integer to integer power, we do the calculation by hand wherever
1065 we're sure it is safe; otherwise we call pow() and try to convert to
1066 integer afterwards. */
1067 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1068 UV power;
1069 bool baseuok;
1070 UV baseuv;
1072 if (SvUOK(svr)) {
1073 power = SvUVX(svr);
1074 } else {
1075 const IV iv = SvIVX(svr);
1076 if (iv >= 0) {
1077 power = iv;
1078 } else {
1079 goto float_it; /* Can't do negative powers this way. */
1080 }
1081 }
1083 baseuok = SvUOK(svl);
1084 if (baseuok) {
1085 baseuv = SvUVX(svl);
1086 } else {
1087 const IV iv = SvIVX(svl);
1088 if (iv >= 0) {
1089 baseuv = iv;
1090 baseuok = TRUE; /* effectively it's a UV now */
1091 } else {
1092 baseuv = -iv; /* abs, baseuok == false records sign */
1093 }
1094 }
1095 /* now we have integer ** positive integer. */
1096 is_int = 1;
1098 /* foo & (foo - 1) is zero only for a power of 2. */
1099 if (!(baseuv & (baseuv - 1))) {
1100 /* We are raising power-of-2 to a positive integer.
1101 The logic here will work for any base (even non-integer
1102 bases) but it can be less accurate than
1103 pow (base,power) or exp (power * log (base)) when the
1104 intermediate values start to spill out of the mantissa.
1105 With powers of 2 we know this can't happen.
1106 And powers of 2 are the favourite thing for perl
1107 programmers to notice ** not doing what they mean. */
1108 NV result = 1.0;
1109 NV base = baseuok ? baseuv : -(NV)baseuv;
1111 if (power & 1) {
1112 result *= base;
1113 }
1114 while (power >>= 1) {
1115 base *= base;
1116 if (power & 1) {
1117 result *= base;
1118 }
1119 }
1120 SP--;
1121 SETn( result );
1122 SvIV_please_nomg(svr);
1123 RETURN;
1124 } else {
1125 unsigned int highbit = 8 * sizeof(UV);
1126 unsigned int diff = 8 * sizeof(UV);
1127 while (diff >>= 1) {
1128 highbit -= diff;
1129 if (baseuv >> highbit) {
1130 highbit += diff;
1131 }
1132 }
1133 /* we now have baseuv < 2 ** highbit */
1134 if (power * highbit <= 8 * sizeof(UV)) {
1135 /* result will definitely fit in UV, so use UV math
1136 on same algorithm as above */
1137 UV result = 1;
1138 UV base = baseuv;
1139 const bool odd_power = cBOOL(power & 1);
1140 if (odd_power) {
1141 result *= base;
1142 }
1143 while (power >>= 1) {
1144 base *= base;
1145 if (power & 1) {
1146 result *= base;
1147 }
1148 }
1149 SP--;
1150 if (baseuok || !odd_power)
1151 /* answer is positive */
1152 SETu( result );
1153 else if (result <= (UV)IV_MAX)
1154 /* answer negative, fits in IV */
1155 SETi( -(IV)result );
1156 else if (result == (UV)IV_MIN)
1157 /* 2's complement assumption: special case IV_MIN */
1158 SETi( IV_MIN );
1159 else
1160 /* answer negative, doesn't fit */
1161 SETn( -(NV)result );
1162 RETURN;
1163 }
1164 }
1165 }
1166 float_it:
1167 #endif
1168 {
1169 NV right = SvNV_nomg(svr);
1170 NV left = SvNV_nomg(svl);
1171 (void)POPs;
1173 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1174 /*
1175 We are building perl with long double support and are on an AIX OS
1176 afflicted with a powl() function that wrongly returns NaNQ for any
1177 negative base. This was reported to IBM as PMR #23047-379 on
1178 03/06/2006. The problem exists in at least the following versions
1179 of AIX and the libm fileset, and no doubt others as well:
1181 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1182 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1183 AIX 5.2.0 bos.adt.libm 5.2.0.85
1185 So, until IBM fixes powl(), we provide the following workaround to
1186 handle the problem ourselves. Our logic is as follows: for
1187 negative bases (left), we use fmod(right, 2) to check if the
1188 exponent is an odd or even integer:
1190 - if odd, powl(left, right) == -powl(-left, right)
1191 - if even, powl(left, right) == powl(-left, right)
1193 If the exponent is not an integer, the result is rightly NaNQ, so
1194 we just return that (as NV_NAN).
1195 */
1197 if (left < 0.0) {
1198 NV mod2 = Perl_fmod( right, 2.0 );
1199 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1200 SETn( -Perl_pow( -left, right) );
1201 } else if (mod2 == 0.0) { /* even integer */
1202 SETn( Perl_pow( -left, right) );
1203 } else { /* fractional power */
1204 SETn( NV_NAN );
1205 }
1206 } else {
1207 SETn( Perl_pow( left, right) );
1208 }
1209 #else
1210 SETn( Perl_pow( left, right) );
1211 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1213 #ifdef PERL_PRESERVE_IVUV
1214 if (is_int)
1215 SvIV_please_nomg(svr);
1216 #endif
1217 RETURN;
1218 }
1219 }
1221 PP(pp_multiply)
1222 {
1223 dSP; dATARGET; SV *svl, *svr;
1224 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1225 svr = TOPs;
1226 svl = TOPm1s;
1228 #ifdef PERL_PRESERVE_IVUV
1230 /* special-case some simple common cases */
1231 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1232 IV il, ir;
1233 U32 flags = (svl->sv_flags & svr->sv_flags);
1234 if (flags & SVf_IOK) {
1235 /* both args are simple IVs */
1236 UV topl, topr;
1237 il = SvIVX(svl);
1238 ir = SvIVX(svr);
1239 do_iv:
1240 topl = ((UV)il) >> (UVSIZE * 4 - 1);
1241 topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1243 /* if both are in a range that can't under/overflow, do a
1244 * simple integer multiply: if the top halves(*) of both numbers
1245 * are 00...00 or 11...11, then it's safe.
1246 * (*) for 32-bits, the "top half" is the top 17 bits,
1247 * for 64-bits, its 33 bits */
1248 if (!(
1249 ((topl+1) | (topr+1))
1250 & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1251 )) {
1252 SP--;
1253 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1254 SETs(TARG);
1255 RETURN;
1256 }
1257 goto generic;
1258 }
1259 else if (flags & SVf_NOK) {
1260 /* both args are NVs */
1261 NV nl = SvNVX(svl);
1262 NV nr = SvNVX(svr);
1263 NV result;
1265 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1266 /* nothing was lost by converting to IVs */
1267 goto do_iv;
1268 }
1269 SP--;
1270 result = nl * nr;
1271 # if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1272 if (Perl_isinf(result)) {
1273 Zero((U8*)&result + 8, 8, U8);
1274 }
1275 # endif
1276 TARGn(result, 0); /* args not GMG, so can't be tainted */
1277 SETs(TARG);
1278 RETURN;
1279 }
1280 }
1282 generic:
1284 if (SvIV_please_nomg(svr)) {
1285 /* Unless the left argument is integer in range we are going to have to
1286 use NV maths. Hence only attempt to coerce the right argument if
1287 we know the left is integer. */
1288 /* Left operand is defined, so is it IV? */
1289 if (SvIV_please_nomg(svl)) {
1290 bool auvok = SvUOK(svl);
1291 bool buvok = SvUOK(svr);
1292 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1293 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1294 UV alow;
1295 UV ahigh;
1296 UV blow;
1297 UV bhigh;
1299 if (auvok) {
1300 alow = SvUVX(svl);
1301 } else {
1302 const IV aiv = SvIVX(svl);
1303 if (aiv >= 0) {
1304 alow = aiv;
1305 auvok = TRUE; /* effectively it's a UV now */
1306 } else {
1307 /* abs, auvok == false records sign; Using 0- here and
1308 * later to silence bogus warning from MS VC */
1309 alow = (UV) (0 - (UV) aiv);
1310 }
1311 }
1312 if (buvok) {
1313 blow = SvUVX(svr);
1314 } else {
1315 const IV biv = SvIVX(svr);
1316 if (biv >= 0) {
1317 blow = biv;
1318 buvok = TRUE; /* effectively it's a UV now */
1319 } else {
1320 /* abs, buvok == false records sign */
1321 blow = (UV) (0 - (UV) biv);
1322 }
1323 }
1325 /* If this does sign extension on unsigned it's time for plan B */
1326 ahigh = alow >> (4 * sizeof (UV));
1327 alow &= botmask;
1328 bhigh = blow >> (4 * sizeof (UV));
1329 blow &= botmask;
1330 if (ahigh && bhigh) {
1331 NOOP;
1332 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1333 which is overflow. Drop to NVs below. */
1334 } else if (!ahigh && !bhigh) {
1335 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1336 so the unsigned multiply cannot overflow. */
1337 const UV product = alow * blow;
1338 if (auvok == buvok) {
1339 /* -ve * -ve or +ve * +ve gives a +ve result. */
1340 SP--;
1341 SETu( product );
1342 RETURN;
1343 } else if (product <= (UV)IV_MIN) {
1344 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1345 /* -ve result, which could overflow an IV */
1346 SP--;
1347 /* can't negate IV_MIN, but there are aren't two
1348 * integers such that !ahigh && !bhigh, where the
1349 * product equals 0x800....000 */
1350 assert(product != (UV)IV_MIN);
1351 SETi( -(IV)product );
1352 RETURN;
1353 } /* else drop to NVs below. */
1354 } else {
1355 /* One operand is large, 1 small */
1356 UV product_middle;
1357 if (bhigh) {
1358 /* swap the operands */
1359 ahigh = bhigh;
1360 bhigh = blow; /* bhigh now the temp var for the swap */
1361 blow = alow;
1362 alow = bhigh;
1363 }
1364 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1365 multiplies can't overflow. shift can, add can, -ve can. */
1366 product_middle = ahigh * blow;
1367 if (!(product_middle & topmask)) {
1368 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1369 UV product_low;
1370 product_middle <<= (4 * sizeof (UV));
1371 product_low = alow * blow;
1373 /* as for pp_add, UV + something mustn't get smaller.
1374 IIRC ANSI mandates this wrapping *behaviour* for
1375 unsigned whatever the actual representation*/
1376 product_low += product_middle;
1377 if (product_low >= product_middle) {
1378 /* didn't overflow */
1379 if (auvok == buvok) {
1380 /* -ve * -ve or +ve * +ve gives a +ve result. */
1381 SP--;
1382 SETu( product_low );
1383 RETURN;
1384 } else if (product_low <= (UV)IV_MIN) {
1385 /* 2s complement assumption again */
1386 /* -ve result, which could overflow an IV */
1387 SP--;
1388 SETi(product_low == (UV)IV_MIN
1389 ? IV_MIN : -(IV)product_low);
1390 RETURN;
1391 } /* else drop to NVs below. */
1392 }
1393 } /* product_middle too large */
1394 } /* ahigh && bhigh */
1395 } /* SvIOK(svl) */
1396 } /* SvIOK(svr) */
1397 #endif
1398 {
1399 NV right = SvNV_nomg(svr);
1400 NV left = SvNV_nomg(svl);
1401 NV result = left * right;
1403 (void)POPs;
1404 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1405 if (Perl_isinf(result)) {
1406 Zero((U8*)&result + 8, 8, U8);
1407 }
1408 #endif
1409 SETn(result);
1410 RETURN;
1411 }
1412 }
1414 PP(pp_divide)
1415 {
1416 dSP; dATARGET; SV *svl, *svr;
1417 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1418 svr = TOPs;
1419 svl = TOPm1s;
1420 /* Only try to do UV divide first
1421 if ((SLOPPYDIVIDE is true) or
1422 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1423 to preserve))
1424 The assumption is that it is better to use floating point divide
1425 whenever possible, only doing integer divide first if we can't be sure.
1426 If NV_PRESERVES_UV is true then we know at compile time that no UV
1427 can be too large to preserve, so don't need to compile the code to
1428 test the size of UVs. */
1430 #if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
1431 # define PERL_TRY_UV_DIVIDE
1432 /* ensure that 20./5. == 4. */
1433 #endif
1435 #ifdef PERL_TRY_UV_DIVIDE
1436 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1437 bool left_non_neg = SvUOK(svl);
1438 bool right_non_neg = SvUOK(svr);
1439 UV left;
1440 UV right;
1442 if (right_non_neg) {
1443 right = SvUVX(svr);
1444 }
1445 else {
1446 const IV biv = SvIVX(svr);
1447 if (biv >= 0) {
1448 right = biv;
1449 right_non_neg = TRUE; /* effectively it's a UV now */
1450 }
1451 else {
1452 right = -(UV)biv;
1453 }
1454 }
1455 /* historically undef()/0 gives a "Use of uninitialized value"
1456 warning before dieing, hence this test goes here.
1457 If it were immediately before the second SvIV_please, then
1458 DIE() would be invoked before left was even inspected, so
1459 no inspection would give no warning. */
1460 if (right == 0)
1461 DIE(aTHX_ "Illegal division by zero");
1463 if (left_non_neg) {
1464 left = SvUVX(svl);
1465 }
1466 else {
1467 const IV aiv = SvIVX(svl);
1468 if (aiv >= 0) {
1469 left = aiv;
1470 left_non_neg = TRUE; /* effectively it's a UV now */
1471 }
1472 else {
1473 left = -(UV)aiv;
1474 }
1475 }
1477 if (left >= right
1478 #ifdef SLOPPYDIVIDE
1479 /* For sloppy divide we always attempt integer division. */
1480 #else
1481 /* Otherwise we only attempt it if either or both operands
1482 would not be preserved by an NV. If both fit in NVs
1483 we fall through to the NV divide code below. However,
1484 as left >= right to ensure integer result here, we know that
1485 we can skip the test on the right operand - right big
1486 enough not to be preserved can't get here unless left is
1487 also too big. */
1489 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1490 #endif
1491 ) {
1492 /* Integer division can't overflow, but it can be imprecise. */
1494 /* Modern compilers optimize division followed by
1495 * modulo into a single div instruction */
1496 const UV result = left / right;
1497 if (left % right == 0) {
1498 SP--; /* result is valid */
1499 if (left_non_neg == right_non_neg) {
1500 /* signs identical, result is positive. */
1501 SETu( result );
1502 RETURN;
1503 }
1504 /* 2s complement assumption */
1505 if (result <= (UV)IV_MIN)
1506 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1507 else {
1508 /* It's exact but too negative for IV. */
1509 SETn( -(NV)result );
1510 }
1511 RETURN;
1512 } /* tried integer divide but it was not an integer result */
1513 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1514 } /* one operand wasn't SvIOK */
1515 #endif /* PERL_TRY_UV_DIVIDE */
1516 {
1517 NV right = SvNV_nomg(svr);
1518 NV left = SvNV_nomg(svl);
1519 (void)POPs;(void)POPs;
1520 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1521 if (! Perl_isnan(right) && right == 0.0)
1522 #else
1523 if (right == 0.0)
1524 #endif
1525 DIE(aTHX_ "Illegal division by zero");
1526 PUSHn( left / right );
1527 RETURN;
1528 }
1529 }
1531 PP(pp_modulo)
1532 {
1533 dSP; dATARGET;
1534 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1535 {
1536 UV left = 0;
1537 UV right = 0;
1538 bool left_neg = FALSE;
1539 bool right_neg = FALSE;
1540 bool use_double = FALSE;
1541 bool dright_valid = FALSE;
1542 NV dright = 0.0;
1543 NV dleft = 0.0;
1544 SV * const svr = TOPs;
1545 SV * const svl = TOPm1s;
1546 if (SvIV_please_nomg(svr)) {
1547 right_neg = !SvUOK(svr);
1548 if (!right_neg) {
1549 right = SvUVX(svr);
1550 } else {
1551 const IV biv = SvIVX(svr);
1552 if (biv >= 0) {
1553 right = biv;
1554 right_neg = FALSE; /* effectively it's a UV now */
1555 } else {
1556 right = (UV) (0 - (UV) biv);
1557 }
1558 }
1559 }
1560 else {
1561 dright = SvNV_nomg(svr);
1562 right_neg = dright < 0;
1563 if (right_neg)
1564 dright = -dright;
1565 if (dright < UV_MAX_P1) {
1566 right = U_V(dright);
1567 dright_valid = TRUE; /* In case we need to use double below. */
1568 } else {
1569 use_double = TRUE;
1570 }
1571 }
1573 /* At this point use_double is only true if right is out of range for
1574 a UV. In range NV has been rounded down to nearest UV and
1575 use_double false. */
1576 if (!use_double && SvIV_please_nomg(svl)) {
1577 left_neg = !SvUOK(svl);
1578 if (!left_neg) {
1579 left = SvUVX(svl);
1580 } else {
1581 const IV aiv = SvIVX(svl);
1582 if (aiv >= 0) {
1583 left = aiv;
1584 left_neg = FALSE; /* effectively it's a UV now */
1585 } else {
1586 left = (UV) (0 - (UV) aiv);
1587 }
1588 }
1589 }
1590 else {
1591 dleft = SvNV_nomg(svl);
1592 left_neg = dleft < 0;
1593 if (left_neg)
1594 dleft = -dleft;
1596 /* This should be exactly the 5.6 behaviour - if left and right are
1597 both in range for UV then use U_V() rather than floor. */
1598 if (!use_double) {
1599 if (dleft < UV_MAX_P1) {
1600 /* right was in range, so is dleft, so use UVs not double.
1601 */
1602 left = U_V(dleft);
1603 }
1604 /* left is out of range for UV, right was in range, so promote
1605 right (back) to double. */
1606 else {
1607 /* The +0.5 is used in 5.6 even though it is not strictly
1608 consistent with the implicit +0 floor in the U_V()
1609 inside the #if 1. */
1610 dleft = Perl_floor(dleft + 0.5);
1611 use_double = TRUE;
1612 if (dright_valid)
1613 dright = Perl_floor(dright + 0.5);
1614 else
1615 dright = right;
1616 }
1617 }
1618 }
1619 sp -= 2;
1620 if (use_double) {
1621 NV dans;
1623 if (!dright)
1624 DIE(aTHX_ "Illegal modulus zero");
1626 dans = Perl_fmod(dleft, dright);
1627 if ((left_neg != right_neg) && dans)
1628 dans = dright - dans;
1629 if (right_neg)
1630 dans = -dans;
1631 sv_setnv(TARG, dans);
1632 }
1633 else {
1634 UV ans;
1636 if (!right)
1637 DIE(aTHX_ "Illegal modulus zero");
1639 ans = left % right;
1640 if ((left_neg != right_neg) && ans)
1641 ans = right - ans;
1642 if (right_neg) {
1643 /* XXX may warn: unary minus operator applied to unsigned type */
1644 /* could change -foo to be (~foo)+1 instead */
1645 if (ans <= ~((UV)IV_MAX)+1)
1646 sv_setiv(TARG, ~ans+1);
1647 else
1648 sv_setnv(TARG, -(NV)ans);
1649 }
1650 else
1651 sv_setuv(TARG, ans);
1652 }
1653 PUSHTARG;
1654 RETURN;
1655 }
1656 }
1658 PP(pp_repeat)
1659 {
1660 dSP; dATARGET;
1661 IV count;
1662 SV *sv;
1663 bool infnan = FALSE;
1664 const U8 gimme = GIMME_V;
1666 if (gimme == G_LIST && PL_op->op_private & OPpREPEAT_DOLIST) {
1667 /* TODO: think of some way of doing list-repeat overloading ??? */
1668 sv = POPs;
1669 SvGETMAGIC(sv);
1670 }
1671 else {
1672 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1673 /* The parser saw this as a list repeat, and there
1674 are probably several items on the stack. But we're
1675 in scalar/void context, and there's no pp_list to save us
1676 now. So drop the rest of the items -- robin@kitsite.com
1677 */
1678 dMARK;
1679 if (MARK + 1 < SP) {
1680 MARK[1] = TOPm1s;
1681 MARK[2] = TOPs;
1682 }
1683 else {
1684 dTOPss;
1685 ASSUME(MARK + 1 == SP);
1686 MEXTEND(SP, 1);
1687 PUSHs(sv);
1688 MARK[1] = &PL_sv_undef;
1689 }
1690 SP = MARK + 2;
1691 }
1692 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1693 sv = POPs;
1694 }
1696 if (SvIOKp(sv)) {
1697 if (SvUOK(sv)) {
1698 const UV uv = SvUV_nomg(sv);
1699 if (uv > IV_MAX)
1700 count = IV_MAX; /* The best we can do? */
1701 else
1702 count = uv;
1703 } else {
1704 count = SvIV_nomg(sv);
1705 }
1706 }
1707 else if (SvNOKp(sv)) {
1708 const NV nv = SvNV_nomg(sv);
1709 infnan = Perl_isinfnan(nv);
1710 if (UNLIKELY(infnan)) {
1711 count = 0;
1712 } else {
1713 if (nv < 0.0)
1714 count = -1; /* An arbitrary negative integer */
1715 else
1716 count = (IV)nv;
1717 }
1718 }
1719 else
1720 count = SvIV_nomg(sv);
1722 if (infnan) {
1723 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1724 "Non-finite repeat count does nothing");
1725 } else if (count < 0) {
1726 count = 0;
1727 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1728 "Negative repeat count does nothing");
1729 }
1731 if (gimme == G_LIST && PL_op->op_private & OPpREPEAT_DOLIST) {
1732 dMARK;
1733 const SSize_t items = SP - MARK;
1734 const U8 mod = PL_op->op_flags & OPf_MOD;
1736 if (count > 1) {
1737 SSize_t max;
1739 if ( items > SSize_t_MAX / count /* max would overflow */
1740 /* repeatcpy would overflow */
1741 || items > I32_MAX / (I32)sizeof(SV *)
1742 )
1743 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1744 max = items * count;
1745 MEXTEND(MARK, max);
1747 while (SP > MARK) {
1748 if (*SP) {
1749 if (mod && SvPADTMP(*SP)) {
1750 *SP = sv_mortalcopy(*SP);
1751 }
1752 SvTEMP_off((*SP));
1753 }
1754 SP--;
1755 }
1756 MARK++;
1757 repeatcpy((char*)(MARK + items), (char*)MARK,
1758 items * sizeof(const SV *), count - 1);
1759 SP += max;
1760 }
1761 else if (count <= 0)
1762 SP = MARK;
1763 }
1764 else { /* Note: mark already snarfed by pp_list */
1765 SV * const tmpstr = POPs;
1766 STRLEN len;
1767 bool isutf;
1769 if (TARG != tmpstr)
1770 sv_setsv_nomg(TARG, tmpstr);
1771 SvPV_force_nomg(TARG, len);
1772 isutf = DO_UTF8(TARG);
1773 if (count != 1) {
1774 if (count < 1)
1775 SvCUR_set(TARG, 0);
1776 else {
1777 STRLEN max;
1779 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1780 || len > (U32)I32_MAX /* repeatcpy would overflow */
1781 )
1782 Perl_croak(aTHX_ "%s",
1783 "Out of memory during string extend");
1784 max = (UV)count * len + 1;
1785 SvGROW(TARG, max);
1787 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1788 SvCUR_set(TARG, SvCUR(TARG) * count);
1789 }
1790 *SvEND(TARG) = '\0';
1791 }
1792 if (isutf)
1793 (void)SvPOK_only_UTF8(TARG);
1794 else
1795 (void)SvPOK_only(TARG);
1797 PUSHTARG;
1798 }
1799 RETURN;
1800 }
1802 PP(pp_subtract)
1803 {
1804 dSP; dATARGET; bool useleft; SV *svl, *svr;
1805 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1806 svr = TOPs;
1807 svl = TOPm1s;
1809 #ifdef PERL_PRESERVE_IVUV
1811 /* special-case some simple common cases */
1812 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1813 IV il, ir;
1814 U32 flags = (svl->sv_flags & svr->sv_flags);
1815 if (flags & SVf_IOK) {
1816 /* both args are simple IVs */
1817 UV topl, topr;
1818 il = SvIVX(svl);
1819 ir = SvIVX(svr);
1820 do_iv:
1821 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1822 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1824 /* if both are in a range that can't under/overflow, do a
1825 * simple integer subtract: if the top of both numbers
1826 * are 00 or 11, then it's safe */
1827 if (!( ((topl+1) | (topr+1)) & 2)) {
1828 SP--;
1829 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1830 SETs(TARG);
1831 RETURN;
1832 }
1833 goto generic;
1834 }
1835 else if (flags & SVf_NOK) {
1836 /* both args are NVs */
1837 NV nl = SvNVX(svl);
1838 NV nr = SvNVX(svr);
1840 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1841 /* nothing was lost by converting to IVs */
1842 goto do_iv;
1843 }
1844 SP--;
1845 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1846 SETs(TARG);
1847 RETURN;
1848 }
1849 }
1851 generic:
1853 useleft = USE_LEFT(svl);
1854 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1855 "bad things" happen if you rely on signed integers wrapping. */
1856 if (SvIV_please_nomg(svr)) {
1857 /* Unless the left argument is integer in range we are going to have to
1858 use NV maths. Hence only attempt to coerce the right argument if
1859 we know the left is integer. */
1860 UV auv = 0;
1861 bool auvok = FALSE;
1862 bool a_valid = 0;
1864 if (!useleft) {
1865 auv = 0;
1866 a_valid = auvok = 1;
1867 /* left operand is undef, treat as zero. */
1868 } else {
1869 /* Left operand is defined, so is it IV? */
1870 if (SvIV_please_nomg(svl)) {
1871 if ((auvok = SvUOK(svl)))
1872 auv = SvUVX(svl);
1873 else {
1874 const IV aiv = SvIVX(svl);
1875 if (aiv >= 0) {
1876 auv = aiv;
1877 auvok = 1; /* Now acting as a sign flag. */
1878 } else {
1879 auv = (UV) (0 - (UV) aiv);
1880 }
1881 }
1882 a_valid = 1;
1883 }
1884 }
1885 if (a_valid) {
1886 bool result_good = 0;
1887 UV result;
1888 UV buv;
1889 bool buvok = SvUOK(svr);
1891 if (buvok)
1892 buv = SvUVX(svr);
1893 else {
1894 const IV biv = SvIVX(svr);
1895 if (biv >= 0) {
1896 buv = biv;
1897 buvok = 1;
1898 } else
1899 buv = (UV) (0 - (UV) biv);
1900 }
1901 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1902 else "IV" now, independent of how it came in.
1903 if a, b represents positive, A, B negative, a maps to -A etc
1904 a - b => (a - b)
1905 A - b => -(a + b)
1906 a - B => (a + b)
1907 A - B => -(a - b)
1908 all UV maths. negate result if A negative.
1909 subtract if signs same, add if signs differ. */
1911 if (auvok ^ buvok) {
1912 /* Signs differ. */
1913 result = auv + buv;
1914 if (result >= auv)
1915 result_good = 1;
1916 } else {
1917 /* Signs same */
1918 if (auv >= buv) {
1919 result = auv - buv;
1920 /* Must get smaller */
1921 if (result <= auv)
1922 result_good = 1;
1923 } else {
1924 result = buv - auv;
1925 if (result <= buv) {
1926 /* result really should be -(auv-buv). as its negation
1927 of true value, need to swap our result flag */
1928 auvok = !auvok;
1929 result_good = 1;
1930 }
1931 }
1932 }
1933 if (result_good) {
1934 SP--;
1935 if (auvok)
1936 SETu( result );
1937 else {
1938 /* Negate result */
1939 if (result <= (UV)IV_MIN)
1940 SETi(result == (UV)IV_MIN
1941 ? IV_MIN : -(IV)result);
1942 else {
1943 /* result valid, but out of range for IV. */
1944 SETn( -(NV)result );
1945 }
1946 }
1947 RETURN;
1948 } /* Overflow, drop through to NVs. */
1949 }
1950 }
1951 #else
1952 useleft = USE_LEFT(svl);
1953 #endif
1954 {
1955 NV value = SvNV_nomg(svr);
1956 (void)POPs;
1958 if (!useleft) {
1959 /* left operand is undef, treat as zero - value */
1960 SETn(-value);
1961 RETURN;
1962 }
1963 SETn( SvNV_nomg(svl) - value );
1964 RETURN;
1965 }
1966 }
1968 #define IV_BITS (IVSIZE * 8)
1970 /* Taking the right operand of bitwise shift operators, returns an int
1971 * indicating the shift amount clipped to the range [-IV_BITS, +IV_BITS].
1972 */
1973 static int
1974 S_shift_amount(pTHX_ SV *const svr)
1975 {
1976 const IV iv = SvIV_nomg(svr);
1978 /* Note that [INT_MIN, INT_MAX] cannot be used as the clipping bound;
1979 * INT_MIN will cause overflow in "shift = -shift;" in S_{iv,uv}_shift.
1980 */
1981 if (SvIsUV(svr))
1982 return SvUVX(svr) > IV_BITS ? IV_BITS : (int)SvUVX(svr);
1983 return iv < -IV_BITS ? -IV_BITS : iv > IV_BITS ? IV_BITS : (int)iv;
1984 }
1986 static UV S_uv_shift(UV uv, int shift, bool left)
1987 {
1988 if (shift < 0) {
1989 shift = -shift;
1990 left = !left;
1991 }
1992 if (UNLIKELY(shift >= IV_BITS)) {
1993 return 0;
1994 }
1995 return left ? uv << shift : uv >> shift;
1996 }
1998 static IV S_iv_shift(IV iv, int shift, bool left)
1999 {
2000 if (shift < 0) {
2001 shift = -shift;
2002 left = !left;
2003 }
2005 if (UNLIKELY(shift >= IV_BITS)) {
2006 return iv < 0 && !left ? -1 : 0;
2007 }
2009 /* For left shifts, perl 5 has chosen to treat the value as unsigned for
2010 * the purposes of shifting, then cast back to signed. This is very
2011 * different from Raku:
2012 *
2013 * $ raku -e 'say -2 +< 5'
2014 * -64
2015 *
2016 * $ ./perl -le 'print -2 << 5'
2017 * 18446744073709551552
2018 * */
2019 if (left) {
2020 return (IV) (((UV) iv) << shift);
2021 }
2023 /* Here is right shift */
2024 return iv >> shift;
2025 }
2027 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2028 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2029 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2030 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2032 PP(pp_left_shift)
2033 {
2034 dSP; dATARGET; SV *svl, *svr;
2035 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2036 svr = POPs;
2037 svl = TOPs;
2038 {
2039 const int shift = S_shift_amount(aTHX_ svr);
2040 if (PL_op->op_private & OPpUSEINT) {
2041 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2042 }
2043 else {
2044 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2045 }
2046 RETURN;
2047 }
2048 }
2050 PP(pp_right_shift)
2051 {
2052 dSP; dATARGET; SV *svl, *svr;
2053 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2054 svr = POPs;
2055 svl = TOPs;
2056 {
2057 const int shift = S_shift_amount(aTHX_ svr);
2058 if (PL_op->op_private & OPpUSEINT) {
2059 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2060 }
2061 else {
2062 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2063 }
2064 RETURN;
2065 }
2066 }
2068 PP(pp_lt)
2069 {
2070 dSP;
2071 SV *left, *right;
2072 U32 flags_and, flags_or;
2074 tryAMAGICbin_MG(lt_amg, AMGf_numeric);
2075 right = POPs;
2076 left = TOPs;
2077 flags_and = SvFLAGS(left) & SvFLAGS(right);
2078 flags_or = SvFLAGS(left) | SvFLAGS(right);
2080 SETs(boolSV(
2081 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2082 ? (SvIVX(left) < SvIVX(right))
2083 : (flags_and & SVf_NOK)
2084 ? (SvNVX(left) < SvNVX(right))
2085 : (do_ncmp(left, right) == -1)
2086 ));
2087 RETURN;
2088 }
2090 PP(pp_gt)
2091 {
2092 dSP;
2093 SV *left, *right;
2094 U32 flags_and, flags_or;
2096 tryAMAGICbin_MG(gt_amg, AMGf_numeric);
2097 right = POPs;
2098 left = TOPs;
2099 flags_and = SvFLAGS(left) & SvFLAGS(right);
2100 flags_or = SvFLAGS(left) | SvFLAGS(right);
2102 SETs(boolSV(
2103 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2104 ? (SvIVX(left) > SvIVX(right))
2105 : (flags_and & SVf_NOK)
2106 ? (SvNVX(left) > SvNVX(right))
2107 : (do_ncmp(left, right) == 1)
2108 ));
2109 RETURN;
2110 }
2112 PP(pp_le)
2113 {
2114 dSP;
2115 SV *left, *right;
2116 U32 flags_and, flags_or;
2118 tryAMAGICbin_MG(le_amg, AMGf_numeric);
2119 right = POPs;
2120 left = TOPs;
2121 flags_and = SvFLAGS(left) & SvFLAGS(right);
2122 flags_or = SvFLAGS(left) | SvFLAGS(right);
2124 SETs(boolSV(
2125 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2126 ? (SvIVX(left) <= SvIVX(right))
2127 : (flags_and & SVf_NOK)
2128 ? (SvNVX(left) <= SvNVX(right))
2129 : (do_ncmp(left, right) <= 0)
2130 ));
2131 RETURN;
2132 }
2134 PP(pp_ge)
2135 {
2136 dSP;
2137 SV *left, *right;
2138 U32 flags_and, flags_or;
2140 tryAMAGICbin_MG(ge_amg, AMGf_numeric);
2141 right = POPs;
2142 left = TOPs;
2143 flags_and = SvFLAGS(left) & SvFLAGS(right);
2144 flags_or = SvFLAGS(left) | SvFLAGS(right);
2146 SETs(boolSV(
2147 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2148 ? (SvIVX(left) >= SvIVX(right))
2149 : (flags_and & SVf_NOK)
2150 ? (SvNVX(left) >= SvNVX(right))
2151 : ( (do_ncmp(left, right) & 2) == 0)
2152 ));
2153 RETURN;
2154 }
2156 PP(pp_ne)
2157 {
2158 dSP;
2159 SV *left, *right;
2160 U32 flags_and, flags_or;
2162 tryAMAGICbin_MG(ne_amg, AMGf_numeric);
2163 right = POPs;
2164 left = TOPs;
2165 flags_and = SvFLAGS(left) & SvFLAGS(right);
2166 flags_or = SvFLAGS(left) | SvFLAGS(right);
2168 SETs(boolSV(
2169 ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
2170 ? (SvIVX(left) != SvIVX(right))
2171 : (flags_and & SVf_NOK)
2172 ? (SvNVX(left) != SvNVX(right))
2173 : (do_ncmp(left, right) != 0)
2174 ));
2175 RETURN;
2176 }
2178 /* compare left and right SVs. Returns:
2179 * -1: <
2180 * 0: ==
2181 * 1: >
2182 * 2: left or right was a NaN
2183 */
2184 I32
2185 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2186 {
2187 PERL_ARGS_ASSERT_DO_NCMP;
2188 #ifdef PERL_PRESERVE_IVUV
2189 /* Fortunately it seems NaN isn't IOK */
2190 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2191 if (!SvUOK(left)) {
2192 const IV leftiv = SvIVX(left);
2193 if (!SvUOK(right)) {
2194 /* ## IV <=> IV ## */
2195 const IV rightiv = SvIVX(right);
2196 return (leftiv > rightiv) - (leftiv < rightiv);
2197 }
2198 /* ## IV <=> UV ## */
2199 if (leftiv < 0)
2200 /* As (b) is a UV, it's >=0, so it must be < */
2201 return -1;
2202 {
2203 const UV rightuv = SvUVX(right);
2204 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2205 }
2206 }
2208 if (SvUOK(right)) {
2209 /* ## UV <=> UV ## */
2210 const UV leftuv = SvUVX(left);
2211 const UV rightuv = SvUVX(right);
2212 return (leftuv > rightuv) - (leftuv < rightuv);
2213 }
2214 /* ## UV <=> IV ## */
2215 {
2216 const IV rightiv = SvIVX(right);
2217 if (rightiv < 0)
2218 /* As (a) is a UV, it's >=0, so it cannot be < */
2219 return 1;
2220 {
2221 const UV leftuv = SvUVX(left);
2222 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2223 }
2224 }
2225 NOT_REACHED; /* NOTREACHED */
2226 }
2227 #endif
2228 {
2229 NV const rnv = SvNV_nomg(right);
2230 NV const lnv = SvNV_nomg(left);
2232 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2233 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2234 return 2;
2235 }
2236 return (lnv > rnv) - (lnv < rnv);
2237 #else
2238 if (lnv < rnv)
2239 return -1;
2240 if (lnv > rnv)
2241 return 1;
2242 if (lnv == rnv)
2243 return 0;
2244 return 2;
2245 #endif
2246 }
2247 }
2250 PP(pp_ncmp)
2251 {
2252 dSP;
2253 SV *left, *right;
2254 I32 value;
2255 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2256 right = POPs;
2257 left = TOPs;
2258 value = do_ncmp(left, right);
2259 if (value == 2) {
2260 SETs(&PL_sv_undef);
2261 }
2262 else {
2263 dTARGET;
2264 SETi(value);
2265 }
2266 RETURN;
2267 }
2270 /* also used for: pp_sge() pp_sgt() pp_slt() */
2272 PP(pp_sle)
2273 {
2274 dSP;
2276 int amg_type = sle_amg;
2277 int multiplier = 1;
2278 int rhs = 1;
2280 switch (PL_op->op_type) {
2281 case OP_SLT:
2282 amg_type = slt_amg;
2283 /* cmp < 0 */
2284 rhs = 0;
2285 break;
2286 case OP_SGT:
2287 amg_type = sgt_amg;
2288 /* cmp > 0 */
2289 multiplier = -1;
2290 rhs = 0;
2291 break;
2292 case OP_SGE:
2293 amg_type = sge_amg;
2294 /* cmp >= 0 */
2295 multiplier = -1;
2296 break;
2297 }
2299 tryAMAGICbin_MG(amg_type, 0);
2300 {
2301 dPOPTOPssrl;
2302 const int cmp =
2303 #ifdef USE_LOCALE_COLLATE
2304 (IN_LC_RUNTIME(LC_COLLATE))
2305 ? sv_cmp_locale_flags(left, right, 0)
2306 :
2307 #endif
2308 sv_cmp_flags(left, right, 0);
2309 SETs(boolSV(cmp * multiplier < rhs));
2310 RETURN;
2311 }
2312 }
2314 PP(pp_seq)
2315 {
2316 dSP;
2317 tryAMAGICbin_MG(seq_amg, 0);
2318 {
2319 dPOPTOPssrl;
2320 SETs(boolSV(sv_eq_flags(left, right, 0)));
2321 RETURN;
2322 }
2323 }
2325 PP(pp_sne)
2326 {
2327 dSP;
2328 tryAMAGICbin_MG(sne_amg, 0);
2329 {
2330 dPOPTOPssrl;
2331 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2332 RETURN;
2333 }
2334 }
2336 PP(pp_scmp)
2337 {
2338 dSP; dTARGET;
2339 tryAMAGICbin_MG(scmp_amg, 0);
2340 {
2341 dPOPTOPssrl;
2342 const int cmp =
2343 #ifdef USE_LOCALE_COLLATE
2344 (IN_LC_RUNTIME(LC_COLLATE))
2345 ? sv_cmp_locale_flags(left, right, 0)
2346 :
2347 #endif
2348 sv_cmp_flags(left, right, 0);
2349 SETi( cmp );
2350 RETURN;
2351 }
2352 }
2354 PP(pp_bit_and)
2355 {
2356 dSP; dATARGET;
2357 tryAMAGICbin_MG(band_amg, AMGf_assign);
2358 {
2359 dPOPTOPssrl;
2360 if (SvNIOKp(left) || SvNIOKp(right)) {
2361 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2362 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2363 if (PL_op->op_private & OPpUSEINT) {
2364 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2365 SETi(i);
2366 }
2367 else {
2368 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2369 SETu(u);
2370 }
2371 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2372 if (right_ro_nonnum) SvNIOK_off(right);
2373 }
2374 else {
2375 do_vop(PL_op->op_type, TARG, left, right);
2376 SETTARG;
2377 }
2378 RETURN;
2379 }
2380 }
2382 PP(pp_nbit_and)
2383 {
2384 dSP;
2385 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2386 {
2387 dATARGET; dPOPTOPssrl;
2388 if (PL_op->op_private & OPpUSEINT) {
2389 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2390 SETi(i);
2391 }
2392 else {
2393 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2394 SETu(u);
2395 }
2396 }
2397 RETURN;
2398 }
2400 PP(pp_sbit_and)
2401 {
2402 dSP;
2403 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2404 {
2405 dATARGET; dPOPTOPssrl;
2406 do_vop(OP_BIT_AND, TARG, left, right);
2407 RETSETTARG;
2408 }
2409 }
2411 /* also used for: pp_bit_xor() */
2413 PP(pp_bit_or)
2414 {
2415 dSP; dATARGET;
2416 const int op_type = PL_op->op_type;
2418 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2419 {
2420 dPOPTOPssrl;
2421 if (SvNIOKp(left) || SvNIOKp(right)) {
2422 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2423 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2424 if (PL_op->op_private & OPpUSEINT) {
2425 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2426 const IV r = SvIV_nomg(right);
2427 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2428 SETi(result);
2429 }
2430 else {
2431 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2432 const UV r = SvUV_nomg(right);
2433 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2434 SETu(result);
2435 }
2436 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2437 if (right_ro_nonnum) SvNIOK_off(right);
2438 }
2439 else {
2440 do_vop(op_type, TARG, left, right);
2441 SETTARG;
2442 }
2443 RETURN;
2444 }
2445 }
2447 /* also used for: pp_nbit_xor() */
2449 PP(pp_nbit_or)
2450 {
2451 dSP;
2452 const int op_type = PL_op->op_type;
2454 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2455 AMGf_assign|AMGf_numarg);
2456 {
2457 dATARGET; dPOPTOPssrl;
2458 if (PL_op->op_private & OPpUSEINT) {
2459 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2460 const IV r = SvIV_nomg(right);
2461 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2462 SETi(result);
2463 }
2464 else {
2465 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2466 const UV r = SvUV_nomg(right);
2467 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2468 SETu(result);
2469 }
2470 }
2471 RETURN;
2472 }
2474 /* also used for: pp_sbit_xor() */
2476 PP(pp_sbit_or)
2477 {
2478 dSP;
2479 const int op_type = PL_op->op_type;
2481 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2482 AMGf_assign);
2483 {
2484 dATARGET; dPOPTOPssrl;
2485 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2486 right);
2487 RETSETTARG;
2488 }
2489 }
2491 PERL_STATIC_INLINE bool
2492 S_negate_string(pTHX)
2493 {
2494 dTARGET; dSP;
2495 STRLEN len;
2496 const char *s;
2497 SV * const sv = TOPs;
2498 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2499 return FALSE;
2500 s = SvPV_nomg_const(sv, len);
2501 if (isIDFIRST(*s)) {
2502 sv_setpvs(TARG, "-");
2503 sv_catsv(TARG, sv);
2504 }
2505 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2506 sv_setsv_nomg(TARG, sv);
2507 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2508 }
2509 else return FALSE;
2510 SETTARG;
2511 return TRUE;
2512 }
2514 PP(pp_negate)
2515 {
2516 dSP; dTARGET;
2517 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2518 if (S_negate_string(aTHX)) return NORMAL;
2519 {
2520 SV * const sv = TOPs;
2522 if (SvIOK(sv)) {
2523 /* It's publicly an integer */
2524 oops_its_an_int:
2525 if (SvIsUV(sv)) {
2526 if (SvIVX(sv) == IV_MIN) {
2527 /* 2s complement assumption. */
2528 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2529 IV_MIN */
2530 return NORMAL;
2531 }
2532 else if (SvUVX(sv) <= IV_MAX) {
2533 SETi(-SvIVX(sv));
2534 return NORMAL;
2535 }
2536 }
2537 else if (SvIVX(sv) != IV_MIN) {
2538 SETi(-SvIVX(sv));
2539 return NORMAL;
2540 }
2541 #ifdef PERL_PRESERVE_IVUV
2542 else {
2543 SETu((UV)IV_MIN);
2544 return NORMAL;
2545 }
2546 #endif
2547 }
2548 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2549 SETn(-SvNV_nomg(sv));
2550 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2551 goto oops_its_an_int;
2552 else
2553 SETn(-SvNV_nomg(sv));
2554 }
2555 return NORMAL;
2556 }
2558 PP(pp_not)
2559 {
2560 dSP;
2561 SV *sv;
2563 tryAMAGICun_MG(not_amg, 0);
2564 sv = *PL_stack_sp;
2565 *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2566 return NORMAL;
2567 }
2569 static void
2570 S_scomplement(pTHX_ SV *targ, SV *sv)
2571 {
2572 U8 *tmps;
2573 I32 anum;
2574 STRLEN len;
2576 sv_copypv_nomg(TARG, sv);
2577 tmps = (U8*)SvPV_nomg(TARG, len);
2579 if (SvUTF8(TARG)) {
2580 if (len && ! utf8_to_bytes(tmps, &len)) {
2581 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
2582 }
2583 SvCUR_set(TARG, len);
2584 SvUTF8_off(TARG);
2585 }
2587 anum = len;
2589 {
2590 long *tmpl;
2591 for ( ; anum && PTR2nat(tmps) % sizeof(long); anum--, tmps++)
2592 *tmps = ~*tmps;
2593 tmpl = (long*)tmps;
2594 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2595 *tmpl = ~*tmpl;
2596 tmps = (U8*)tmpl;
2597 }
2599 for ( ; anum > 0; anum--, tmps++)
2600 *tmps = ~*tmps;
2601 }
2603 PP(pp_complement)
2604 {
2605 dSP; dTARGET;
2606 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2607 {
2608 dTOPss;
2609 if (SvNIOKp(sv)) {
2610 if (PL_op->op_private & OPpUSEINT) {
2611 const IV i = ~SvIV_nomg(sv);
2612 SETi(i);
2613 }
2614 else {
2615 const UV u = ~SvUV_nomg(sv);
2616 SETu(u);
2617 }
2618 }
2619 else {
2620 S_scomplement(aTHX_ TARG, sv);
2621 SETTARG;
2622 }
2623 return NORMAL;
2624 }
2625 }
2627 PP(pp_ncomplement)
2628 {
2629 dSP;
2630 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2631 {
2632 dTARGET; dTOPss;
2633 if (PL_op->op_private & OPpUSEINT) {
2634 const IV i = ~SvIV_nomg(sv);
2635 SETi(i);
2636 }
2637 else {
2638 const UV u = ~SvUV_nomg(sv);
2639 SETu(u);
2640 }
2641 }
2642 return NORMAL;
2643 }
2645 PP(pp_scomplement)
2646 {
2647 dSP;
2648 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2649 {
2650 dTARGET; dTOPss;
2651 S_scomplement(aTHX_ TARG, sv);
2652 SETTARG;
2653 return NORMAL;
2654 }
2655 }
2657 /* integer versions of some of the above */
2659 PP(pp_i_multiply)
2660 {
2661 dSP; dATARGET;
2662 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2663 {
2664 dPOPTOPiirl_nomg;
2665 SETi( left * right );
2666 RETURN;
2667 }
2668 }
2670 PP(pp_i_divide)
2671 {
2672 IV num;
2673 dSP; dATARGET;
2674 tryAMAGICbin_MG(div_amg, AMGf_assign);
2675 {
2676 dPOPTOPssrl;
2677 IV value = SvIV_nomg(right);
2678 if (value == 0)
2679 DIE(aTHX_ "Illegal division by zero");
2680 num = SvIV_nomg(left);
2682 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2683 if (value == -1)
2684 value = - num;
2685 else
2686 value = num / value;
2687 SETi(value);
2688 RETURN;
2689 }
2690 }
2692 PP(pp_i_modulo)
2693 {
2694 dSP; dATARGET;
2695 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2696 {
2697 dPOPTOPiirl_nomg;
2698 if (!right)
2699 DIE(aTHX_ "Illegal modulus zero");
2700 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2701 if (right == -1)
2702 SETi( 0 );
2703 else
2704 SETi( left % right );
2705 RETURN;
2706 }
2707 }
2709 PP(pp_i_add)
2710 {
2711 dSP; dATARGET;
2712 tryAMAGICbin_MG(add_amg, AMGf_assign);
2713 {
2714 dPOPTOPiirl_ul_nomg;
2715 SETi( left + right );
2716 RETURN;
2717 }
2718 }
2720 PP(pp_i_subtract)
2721 {
2722 dSP; dATARGET;
2723 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2724 {
2725 dPOPTOPiirl_ul_nomg;
2726 SETi( left - right );
2727 RETURN;
2728 }
2729 }
2731 PP(pp_i_lt)
2732 {
2733 dSP;
2734 tryAMAGICbin_MG(lt_amg, 0);
2735 {
2736 dPOPTOPiirl_nomg;
2737 SETs(boolSV(left < right));
2738 RETURN;
2739 }
2740 }
2742 PP(pp_i_gt)
2743 {
2744 dSP;
2745 tryAMAGICbin_MG(gt_amg, 0);
2746 {
2747 dPOPTOPiirl_nomg;
2748 SETs(boolSV(left > right));
2749 RETURN;
2750 }
2751 }
2753 PP(pp_i_le)
2754 {
2755 dSP;
2756 tryAMAGICbin_MG(le_amg, 0);
2757 {
2758 dPOPTOPiirl_nomg;
2759 SETs(boolSV(left <= right));
2760 RETURN;
2761 }
2762 }
2764 PP(pp_i_ge)
2765 {
2766 dSP;
2767 tryAMAGICbin_MG(ge_amg, 0);
2768 {
2769 dPOPTOPiirl_nomg;
2770 SETs(boolSV(left >= right));
2771 RETURN;
2772 }
2773 }
2775 PP(pp_i_eq)
2776 {
2777 dSP;
2778 tryAMAGICbin_MG(eq_amg, 0);
2779 {
2780 dPOPTOPiirl_nomg;
2781 SETs(boolSV(left == right));
2782 RETURN;
2783 }
2784 }
2786 PP(pp_i_ne)
2787 {
2788 dSP;
2789 tryAMAGICbin_MG(ne_amg, 0);
2790 {
2791 dPOPTOPiirl_nomg;
2792 SETs(boolSV(left != right));
2793 RETURN;
2794 }
2795 }
2797 PP(pp_i_ncmp)
2798 {
2799 dSP; dTARGET;
2800 tryAMAGICbin_MG(ncmp_amg, 0);
2801 {
2802 dPOPTOPiirl_nomg;
2803 I32 value;
2805 if (left > right)
2806 value = 1;
2807 else if (left < right)
2808 value = -1;
2809 else
2810 value = 0;
2811 SETi(value);
2812 RETURN;
2813 }
2814 }
2816 PP(pp_i_negate)
2817 {
2818 dSP; dTARGET;
2819 tryAMAGICun_MG(neg_amg, 0);
2820 if (S_negate_string(aTHX)) return NORMAL;
2821 {
2822 SV * const sv = TOPs;
2823 IV const i = SvIV_nomg(sv);
2824 SETi(-i);
2825 return NORMAL;
2826 }
2827 }
2829 /* High falutin' math. */
2831 PP(pp_atan2)
2832 {
2833 dSP; dTARGET;
2834 tryAMAGICbin_MG(atan2_amg, 0);
2835 {
2836 dPOPTOPnnrl_nomg;
2837 SETn(Perl_atan2(left, right));
2838 RETURN;
2839 }
2840 }
2843 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2845 PP(pp_sin)
2846 {
2847 dSP; dTARGET;
2848 int amg_type = fallback_amg;
2849 const char *neg_report = NULL;
2850 const int op_type = PL_op->op_type;
2852 switch (op_type) {
2853 case OP_SIN: amg_type = sin_amg; break;
2854 case OP_COS: amg_type = cos_amg; break;
2855 case OP_EXP: amg_type = exp_amg; break;
2856 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2857 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2858 }
2860 assert(amg_type != fallback_amg);
2862 tryAMAGICun_MG(amg_type, 0);
2863 {
2864 SV * const arg = TOPs;
2865 const NV value = SvNV_nomg(arg);
2866 #ifdef NV_NAN
2867 NV result = NV_NAN;
2868 #else
2869 NV result = 0.0;
2870 #endif
2871 if (neg_report) { /* log or sqrt */
2872 if (
2873 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2874 ! Perl_isnan(value) &&
2875 #endif
2876 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2877 SET_NUMERIC_STANDARD();
2878 /* diag_listed_as: Can't take log of %g */
2879 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2880 }
2881 }
2882 switch (op_type) {
2883 default:
2884 case OP_SIN: result = Perl_sin(value); break;
2885 case OP_COS: result = Perl_cos(value); break;
2886 case OP_EXP: result = Perl_exp(value); break;
2887 case OP_LOG: result = Perl_log(value); break;
2888 case OP_SQRT: result = Perl_sqrt(value); break;
2889 }
2890 SETn(result);
2891 return NORMAL;
2892 }
2893 }
2895 /* Support Configure command-line overrides for rand() functions.
2896 After 5.005, perhaps we should replace this by Configure support
2897 for drand48(), random(), or rand(). For 5.005, though, maintain
2898 compatibility by calling rand() but allow the user to override it.
2899 See INSTALL for details. --Andy Dougherty 15 July 1998
2900 */
2901 /* Now it's after 5.005, and Configure supports drand48() and random(),
2902 in addition to rand(). So the overrides should not be needed any more.
2903 --Jarkko Hietaniemi 27 September 1998
2904 */
2906 PP(pp_rand)
2907 {
2908 if (!PL_srand_called) {
2909 (void)seedDrand01((Rand_seed_t)seed());
2910 PL_srand_called = TRUE;
2911 }
2912 {
2913 dSP;
2914 NV value;
2916 if (MAXARG < 1)
2917 {
2918 EXTEND(SP, 1);
2919 value = 1.0;
2920 }
2921 else {
2922 SV * const sv = POPs;
2923 if(!sv)
2924 value = 1.0;
2925 else
2926 value = SvNV(sv);
2927 }
2928 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2929 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2930 if (! Perl_isnan(value) && value == 0.0)
2931 #else
2932 if (value == 0.0)
2933 #endif
2934 value = 1.0;
2935 {
2936 dTARGET;
2937 PUSHs(TARG);
2938 PUTBACK;
2939 value *= Drand01();
2940 sv_setnv_mg(TARG, value);
2941 }
2942 }
2943 return NORMAL;
2944 }
2946 PP(pp_srand)
2947 {
2948 dSP; dTARGET;
2949 UV anum;
2951 if (MAXARG >= 1 && (TOPs || POPs)) {
2952 SV *top;
2953 char *pv;
2954 STRLEN len;
2955 int flags;
2957 top = POPs;
2958 pv = SvPV(top, len);
2959 flags = grok_number(pv, len, &anum);
2961 if (!(flags & IS_NUMBER_IN_UV)) {
2962 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2963 "Integer overflow in srand");
2964 anum = UV_MAX;
2965 }
2966 }
2967 else {
2968 anum = seed();
2969 }
2971 (void)seedDrand01((Rand_seed_t)anum);
2972 PL_srand_called = TRUE;
2973 if (anum)
2974 XPUSHu(anum);
2975 else {
2976 /* Historically srand always returned true. We can avoid breaking
2977 that like this: */
2978 sv_setpvs(TARG, "0 but true");
2979 XPUSHTARG;
2980 }
2981 RETURN;
2982 }
2984 PP(pp_int)
2985 {
2986 dSP; dTARGET;
2987 tryAMAGICun_MG(int_amg, AMGf_numeric);
2988 {
2989 SV * const sv = TOPs;
2990 const IV iv = SvIV_nomg(sv);
2991 /* XXX it's arguable that compiler casting to IV might be subtly
2992 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2993 else preferring IV has introduced a subtle behaviour change bug. OTOH
2994 relying on floating point to be accurate is a bug. */
2996 if (!SvOK(sv)) {
2997 SETu(0);
2998 }
2999 else if (SvIOK(sv)) {
3000 if (SvIsUV(sv))
3001 SETu(SvUV_nomg(sv));
3002 else
3003 SETi(iv);
3004 }
3005 else {
3006 const NV value = SvNV_nomg(sv);
3007 if (UNLIKELY(Perl_isinfnan(value)))
3008 SETn(value);
3009 else if (value >= 0.0) {
3010 if (value < (NV)UV_MAX + 0.5) {
3011 SETu(U_V(value));
3012 } else {
3013 SETn(Perl_floor(value));
3014 }
3015 }
3016 else {
3017 if (value > (NV)IV_MIN - 0.5) {
3018 SETi(I_V(value));
3019 } else {
3020 SETn(Perl_ceil(value));
3021 }
3022 }
3023 }
3024 }
3025 return NORMAL;
3026 }
3028 PP(pp_abs)
3029 {
3030 dSP; dTARGET;
3031 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3032 {
3033 SV * const sv = TOPs;
3034 /* This will cache the NV value if string isn't actually integer */
3035 const IV iv = SvIV_nomg(sv);
3036 UV uv;
3038 if (!SvOK(sv)) {
3039 uv = 0;
3040 goto set_uv;
3041 }
3042 else if (SvIOK(sv)) {
3043 /* IVX is precise */
3044 if (SvIsUV(sv)) {
3045 uv = SvUVX(sv); /* force it to be numeric only */
3046 } else {
3047 if (iv >= 0) {
3048 uv = (UV)iv;
3049 } else {
3050 /* "(UV)-(iv + 1) + 1" below is mathematically "-iv", but
3051 transformed so that every subexpression will never trigger
3052 overflows even on 2's complement representation (note that
3053 iv is always < 0 here), and modern compilers could optimize
3054 this to a single negation. */
3055 uv = (UV)-(iv + 1) + 1;
3056 }
3057 }
3058 set_uv:
3059 SETu(uv);
3060 } else{
3061 const NV value = SvNV_nomg(sv);
3062 SETn(Perl_fabs(value));
3063 }
3064 }
3065 return NORMAL;
3066 }
3069 /* also used for: pp_hex() */
3071 PP(pp_oct)
3072 {
3073 dSP; dTARGET;
3074 const char *tmps;
3075 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3076 STRLEN len;
3077 NV result_nv;
3078 UV result_uv;
3079 SV* const sv = TOPs;
3081 tmps = (SvPV_const(sv, len));
3082 if (DO_UTF8(sv)) {
3083 /* If Unicode, try to downgrade
3084 * If not possible, croak. */
3085 SV* const tsv = sv_2mortal(newSVsv(sv));
3087 SvUTF8_on(tsv);
3088 sv_utf8_downgrade(tsv, FALSE);
3089 tmps = SvPV_const(tsv, len);
3090 }
3091 if (PL_op->op_type == OP_HEX)
3092 goto hex;
3094 while (*tmps && len && isSPACE(*tmps))
3095 tmps++, len--;
3096 if (*tmps == '0')
3097 tmps++, len--;
3098 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3099 tmps++, len--;
3100 flags |= PERL_SCAN_DISALLOW_PREFIX;
3101 hex:
3102 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3103 }
3104 else if (isALPHA_FOLD_EQ(*tmps, 'b')) {
3105 tmps++, len--;
3106 flags |= PERL_SCAN_DISALLOW_PREFIX;
3107 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3108 }
3109 else {
3110 if (isALPHA_FOLD_EQ(*tmps, 'o')) {
3111 tmps++, len--;
3112 }
3113 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3114 }
3116 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3117 SETn(result_nv);
3118 }
3119 else {
3120 SETu(result_uv);
3121 }
3122 return NORMAL;
3123 }
3125 /* String stuff. */
3128 PP(pp_length)
3129 {
3130 dSP; dTARGET;
3131 SV * const sv = TOPs;
3133 U32 in_bytes = IN_BYTES;
3134 /* Simplest case shortcut:
3135 * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3136 * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3137 * set)
3138 */
3139 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3141 STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3142 SETs(TARG);
3144 if (LIKELY(svflags == SVf_POK))
3145 goto simple_pv;
3147 if (svflags & SVs_GMG)
3148 mg_get(sv);
3150 if (SvOK(sv)) {
3151 STRLEN len;
3152 if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3153 if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3154 goto simple_pv;
3155 if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3156 /* no need to convert from bytes to chars */
3157 len = SvCUR(sv);
3158 goto return_bool;
3159 }
3160 len = sv_len_utf8_nomg(sv);
3161 }
3162 else {
3163 /* unrolled SvPV_nomg_const(sv,len) */
3164 if (SvPOK_nog(sv)) {
3165 simple_pv:
3166 len = SvCUR(sv);
3167 if (PL_op->op_private & OPpTRUEBOOL) {
3168 return_bool:
3169 SETs(len ? &PL_sv_yes : &PL_sv_zero);
3170 return NORMAL;
3171 }
3172 }
3173 else {
3174 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3175 }
3176 }
3177 TARGi((IV)(len), 1);
3178 }
3179 else {
3180 if (!SvPADTMP(TARG)) {
3181 /* OPpTARGET_MY: targ is var in '$lex = length()' */
3182 sv_set_undef(TARG);
3183 SvSETMAGIC(TARG);
3184 }
3185 else
3186 /* TARG is on stack at this point and is overwriten by SETs.
3187 * This branch is the odd one out, so put TARG by default on
3188 * stack earlier to let local SP go out of liveness sooner */
3189 SETs(&PL_sv_undef);
3190 }
3191 return NORMAL; /* no putback, SP didn't move in this opcode */
3192 }
3195 /* Returns false if substring is completely outside original string.
3196 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3197 always be true for an explicit 0.
3198 */
3199 bool
3200 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3201 bool pos1_is_uv, IV len_iv,
3202 bool len_is_uv, STRLEN *posp,
3203 STRLEN *lenp)
3204 {
3205 IV pos2_iv;
3206 int pos2_is_uv;
3208 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3210 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3211 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3212 pos1_iv += curlen;
3213 }
3214 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3215 return FALSE;
3217 if (len_iv || len_is_uv) {
3218 if (!len_is_uv && len_iv < 0) {
3219 pos2_iv = curlen + len_iv;
3220 if (curlen)
3221 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3222 else
3223 pos2_is_uv = 0;
3224 } else { /* len_iv >= 0 */
3225 if (!pos1_is_uv && pos1_iv < 0) {
3226 pos2_iv = pos1_iv + len_iv;
3227 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3228 } else {
3229 if ((UV)len_iv > curlen-(UV)pos1_iv)
3230 pos2_iv = curlen;
3231 else
3232 pos2_iv = pos1_iv+len_iv;
3233 pos2_is_uv = 1;
3234 }
3235 }
3236 }
3237 else {
3238 pos2_iv = curlen;
3239 pos2_is_uv = 1;
3240 }
3242 if (!pos2_is_uv && pos2_iv < 0) {
3243 if (!pos1_is_uv && pos1_iv < 0)
3244 return FALSE;
3245 pos2_iv = 0;
3246 }
3247 else if (!pos1_is_uv && pos1_iv < 0)
3248 pos1_iv = 0;
3250 if ((UV)pos2_iv < (UV)pos1_iv)
3251 pos2_iv = pos1_iv;
3252 if ((UV)pos2_iv > curlen)
3253 pos2_iv = curlen;
3255 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3256 *posp = (STRLEN)( (UV)pos1_iv );
3257 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3259 return TRUE;
3260 }
3262 PP(pp_substr)
3263 {
3264 dSP; dTARGET;
3265 SV *sv;
3266 STRLEN curlen;
3267 STRLEN utf8_curlen;
3268 SV * pos_sv;
3269 IV pos1_iv;
3270 int pos1_is_uv;
3271 SV * len_sv;
3272 IV len_iv = 0;
3273 int len_is_uv = 0;
3274 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3275 const bool rvalue = (GIMME_V != G_VOID);
3276 const char *tmps;
3277 SV *repl_sv = NULL;
3278 const char *repl = NULL;
3279 STRLEN repl_len;
3280 int num_args = PL_op->op_private & 7;
3281 bool repl_need_utf8_upgrade = FALSE;
3283 if (num_args > 2) {
3284 if (num_args > 3) {
3285 if(!(repl_sv = POPs)) num_args--;
3286 }
3287 if ((len_sv = POPs)) {
3288 len_iv = SvIV(len_sv);
3289 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3290 }
3291 else num_args--;
3292 }
3293 pos_sv = POPs;
3294 pos1_iv = SvIV(pos_sv);
3295 pos1_is_uv = SvIOK_UV(pos_sv);
3296 sv = POPs;
3297 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3298 assert(!repl_sv);
3299 repl_sv = POPs;
3300 }
3301 if (lvalue && !repl_sv) {
3302 SV * ret;
3303 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3304 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3305 LvTYPE(ret) = 'x';
3306 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3307 LvTARGOFF(ret) =
3308 pos1_is_uv || pos1_iv >= 0
3309 ? (STRLEN)(UV)pos1_iv
3310 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3311 LvTARGLEN(ret) =
3312 len_is_uv || len_iv > 0
3313 ? (STRLEN)(UV)len_iv
3314 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3316 PUSHs(ret); /* avoid SvSETMAGIC here */
3317 RETURN;
3318 }
3319 if (repl_sv) {
3320 repl = SvPV_const(repl_sv, repl_len);
3321 SvGETMAGIC(sv);
3322 if (SvROK(sv))
3323 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3324 "Attempt to use reference as lvalue in substr"
3325 );
3326 tmps = SvPV_force_nomg(sv, curlen);
3327 if (DO_UTF8(repl_sv) && repl_len) {
3328 if (!DO_UTF8(sv)) {
3329 /* Upgrade the dest, and recalculate tmps in case the buffer
3330 * got reallocated; curlen may also have been changed */
3331 sv_utf8_upgrade_nomg(sv);
3332 tmps = SvPV_nomg(sv, curlen);
3333 }
3334 }
3335 else if (DO_UTF8(sv))
3336 repl_need_utf8_upgrade = TRUE;
3337 }
3338 else tmps = SvPV_const(sv, curlen);
3339 if (DO_UTF8(sv)) {
3340 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3341 if (utf8_curlen == curlen)
3342 utf8_curlen = 0;
3343 else
3344 curlen = utf8_curlen;
3345 }
3346 else
3347 utf8_curlen = 0;
3349 {
3350 STRLEN pos, len, byte_len, byte_pos;
3352 if (!translate_substr_offsets(
3353 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3354 )) goto bound_fail;
3356 byte_len = len;
3357 byte_pos = utf8_curlen
3358 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3360 tmps += byte_pos;
3362 if (rvalue) {
3363 SvTAINTED_off(TARG); /* decontaminate */
3364 SvUTF8_off(TARG); /* decontaminate */
3365 sv_setpvn(TARG, tmps, byte_len);
3366 #ifdef USE_LOCALE_COLLATE
3367 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3368 #endif
3369 if (utf8_curlen)
3370 SvUTF8_on(TARG);
3371 }
3373 if (repl) {
3374 SV* repl_sv_copy = NULL;
3376 if (repl_need_utf8_upgrade) {
3377 repl_sv_copy = newSVsv(repl_sv);
3378 sv_utf8_upgrade(repl_sv_copy);
3379 repl = SvPV_const(repl_sv_copy, repl_len);
3380 }
3381 if (!SvOK(sv))
3382 SvPVCLEAR(sv);
3383 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3384 SvREFCNT_dec(repl_sv_copy);
3385 }
3386 }
3387 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3388 SP++;
3389 else if (rvalue) {
3390 SvSETMAGIC(TARG);
3391 PUSHs(TARG);
3392 }
3393 RETURN;
3395 bound_fail:
3396 if (repl)
3397 Perl_croak(aTHX_ "substr outside of string");
3398 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3399 RETPUSHUNDEF;
3400 }
3402 PP(pp_vec)
3403 {
3404 dSP;
3405 const IV size = POPi;
3406 SV* offsetsv = POPs;
3407 SV * const src = POPs;
3408 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3409 SV * ret;
3410 UV retuv;
3411 STRLEN offset = 0;
3412 char errflags = 0;
3414 /* extract a STRLEN-ranged integer value from offsetsv into offset,
3415 * or flag that its out of range */
3416 {
3417 IV iv = SvIV(offsetsv);
3419 /* avoid a large UV being wrapped to a negative value */
3420 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3421 errflags = LVf_OUT_OF_RANGE;
3422 else if (iv < 0)
3423 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3424 #if PTRSIZE < IVSIZE
3425 else if (iv > Size_t_MAX)
3426 errflags = LVf_OUT_OF_RANGE;
3427 #endif
3428 else
3429 offset = (STRLEN)iv;
3430 }
3432 retuv = errflags ? 0 : do_vecget(src, offset, size);
3434 if (lvalue) { /* it's an lvalue! */
3435 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3436 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3437 LvTYPE(ret) = 'v';
3438 LvTARG(ret) = SvREFCNT_inc_simple(src);
3439 LvTARGOFF(ret) = offset;
3440 LvTARGLEN(ret) = size;
3441 LvFLAGS(ret) = errflags;
3442 }
3443 else {
3444 dTARGET;
3445 SvTAINTED_off(TARG); /* decontaminate */
3446 ret = TARG;
3447 }
3449 sv_setuv(ret, retuv);
3450 if (!lvalue)
3451 SvSETMAGIC(ret);
3452 PUSHs(ret);
3453 RETURN;
3454 }
3457 /* also used for: pp_rindex() */
3459 PP(pp_index)
3460 {
3461 dSP; dTARGET;
3462 SV *big;
3463 SV *little;
3464 SV *temp = NULL;
3465 STRLEN biglen;
3466 STRLEN llen = 0;
3467 SSize_t offset = 0;
3468 SSize_t retval;
3469 const char *big_p;
3470 const char *little_p;
3471 bool big_utf8;
3472 bool little_utf8;
3473 const bool is_index = PL_op->op_type == OP_INDEX;
3474 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3476 if (threeargs)
3477 offset = POPi;
3478 little = POPs;
3479 big = POPs;
3480 big_p = SvPV_const(big, biglen);
3481 little_p = SvPV_const(little, llen);
3483 big_utf8 = DO_UTF8(big);
3484 little_utf8 = DO_UTF8(little);
3485 if (big_utf8 ^ little_utf8) {
3486 /* One needs to be upgraded. */
3487 if (little_utf8) {
3488 /* Well, maybe instead we might be able to downgrade the small
3489 string? */
3490 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3491 &little_utf8);
3492 if (little_utf8) {
3493 /* If the large string is ISO-8859-1, and it's not possible to
3494 convert the small string to ISO-8859-1, then there is no
3495 way that it could be found anywhere by index. */
3496 retval = -1;
3497 goto push_result;
3498 }
3500 /* At this point, pv is a malloc()ed string. So donate it to temp
3501 to ensure it will get free()d */
3502 little = temp = newSV(0);
3503 sv_usepvn(temp, pv, llen);
3504 little_p = SvPVX(little);
3505 } else {
3506 temp = newSVpvn(little_p, llen);
3508 sv_utf8_upgrade(temp);
3509 little = temp;
3510 little_p = SvPV_const(little, llen);
3511 }
3512 }
3513 if (SvGAMAGIC(big)) {
3514 /* Life just becomes a lot easier if I use a temporary here.
3515 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3516 will trigger magic and overloading again, as will fbm_instr()
3517 */
3518 big = newSVpvn_flags(big_p, biglen,
3519 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3520 big_p = SvPVX(big);
3521 }
3522 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3523 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3524 warn on undef, and we've already triggered a warning with the
3525 SvPV_const some lines above. We can't remove that, as we need to
3526 call some SvPV to trigger overloading early and find out if the
3527 string is UTF-8.
3528 This is all getting too messy. The API isn't quite clean enough,
3529 because data access has side effects.
3530 */
3531 little = newSVpvn_flags(little_p, llen,
3532 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3533 little_p = SvPVX(little);
3534 }
3536 if (!threeargs)
3537 offset = is_index ? 0 : biglen;
3538 else {
3539 if (big_utf8 && offset > 0)
3540 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3541 if (!is_index)
3542 offset += llen;
3543 }
3544 if (offset < 0)
3545 offset = 0;
3546 else if (offset > (SSize_t)biglen)
3547 offset = biglen;
3548 if (!(little_p = is_index
3549 ? fbm_instr((unsigned char*)big_p + offset,
3550 (unsigned char*)big_p + biglen, little, 0)
3551 : rninstr(big_p, big_p + offset,
3552 little_p, little_p + llen)))
3553 retval = -1;
3554 else {
3555 retval = little_p - big_p;
3556 if (retval > 1 && big_utf8)
3557 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3558 }
3559 SvREFCNT_dec(temp);
3561 push_result:
3562 /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3563 if (PL_op->op_private & OPpTRUEBOOL) {
3564 SV *result = ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3565 ? &PL_sv_yes : &PL_sv_no;
3566 if (PL_op->op_private & OPpTARGET_MY) {
3567 /* $lex = (index() == -1) */
3568 sv_setsv_mg(TARG, result);
3569 PUSHs(TARG);
3570 }
3571 else {
3572 PUSHs(result);
3573 }
3574 }
3575 else
3576 PUSHi(retval);
3577 RETURN;
3578 }
3580 PP(pp_sprintf)
3581 {
3582 dSP; dMARK; dORIGMARK; dTARGET;
3583 SvTAINTED_off(TARG);
3584 do_sprintf(TARG, SP-MARK, MARK+1);
3585 TAINT_IF(SvTAINTED(TARG));
3586 SP = ORIGMARK;
3587 PUSHTARG;
3588 RETURN;
3589 }
3591 PP(pp_ord)
3592 {
3593 dSP; dTARGET;
3595 SV *argsv = TOPs;
3596 STRLEN len;
3597 const U8 *s = (U8*)SvPV_const(argsv, len);
3599 SETu(DO_UTF8(argsv)
3600 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3601 : (UV)(*s));
3603 return NORMAL;
3604 }
3606 PP(pp_chr)
3607 {
3608 dSP; dTARGET;
3609 char *tmps;
3610 UV value;
3611 SV *top = TOPs;
3613 SvGETMAGIC(top);
3614 if (UNLIKELY(SvAMAGIC(top)))
3615 top = sv_2num(top);
3616 if (UNLIKELY(isinfnansv(top)))
3617 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3618 else {
3619 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3620 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3621 ||
3622 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3623 && SvNV_nomg(top) < 0.0)))
3624 {
3625 if (ckWARN(WARN_UTF8)) {
3626 if (SvGMAGICAL(top)) {
3627 SV *top2 = sv_newmortal();
3628 sv_setsv_nomg(top2, top);
3629 top = top2;
3630 }
3631 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3632 "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3633 }
3634 value = UNICODE_REPLACEMENT;
3635 } else {
3636 value = SvUV_nomg(top);
3637 }
3638 }
3640 SvUPGRADE(TARG,SVt_PV);
3642 if (value > 255 && !IN_BYTES) {
3643 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3644 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3645 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3646 *tmps = '\0';
3647 (void)SvPOK_only(TARG);
3648 SvUTF8_on(TARG);
3649 SETTARG;
3650 return NORMAL;
3651 }
3653 SvGROW(TARG,2);
3654 SvCUR_set(TARG, 1);
3655 tmps = SvPVX(TARG);
3656 *tmps++ = (char)value;
3657 *tmps = '\0';
3658 (void)SvPOK_only(TARG);
3660 SETTARG;
3661 return NORMAL;
3662 }
3664 PP(pp_crypt)
3665 {
3666 #ifdef HAS_CRYPT
3667 dSP; dTARGET;
3668 dPOPTOPssrl;
3669 STRLEN len;
3670 const char *tmps = SvPV_const(left, len);
3672 if (DO_UTF8(left)) {
3673 /* If Unicode, try to downgrade.
3674 * If not possible, croak.
3675 * Yes, we made this up. */
3676 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3678 sv_utf8_downgrade(tsv, FALSE);
3679 tmps = SvPV_const(tsv, len);
3680 }
3681 # ifdef USE_ITHREADS
3682 # ifdef HAS_CRYPT_R
3683 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3684 /* This should be threadsafe because in ithreads there is only
3685 * one thread per interpreter. If this would not be true,
3686 * we would need a mutex to protect this malloc. */
3687 PL_reentrant_buffer->_crypt_struct_buffer =
3688 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3689 # if defined(__GLIBC__) || defined(__EMX__)
3690 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3691 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3692 }
3693 # endif
3694 }
3695 # endif /* HAS_CRYPT_R */
3696 # endif /* USE_ITHREADS */
3698 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3700 SvUTF8_off(TARG);
3701 SETTARG;
3702 RETURN;
3703 #else
3704 DIE(aTHX_
3705 "The crypt() function is unimplemented due to excessive paranoia.");
3706 #endif
3707 }
3709 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3710 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3713 /* also used for: pp_lcfirst() */
3715 PP(pp_ucfirst)
3716 {
3717 /* Actually is both lcfirst() and ucfirst(). Only the first character
3718 * changes. This means that possibly we can change in-place, ie., just
3719 * take the source and change that one character and store it back, but not
3720 * if read-only etc, or if the length changes */
3722 dSP;
3723 SV *source = TOPs;
3724 STRLEN slen; /* slen is the byte length of the whole SV. */
3725 STRLEN need;
3726 SV *dest;
3727 bool inplace; /* ? Convert first char only, in-place */
3728 bool doing_utf8 = FALSE; /* ? using utf8 */
3729 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3730 const int op_type = PL_op->op_type;
3731 const U8 *s;
3732 U8 *d;
3733 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3734 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3735 * stored as UTF-8 at s. */
3736 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3737 * lowercased) character stored in tmpbuf. May be either
3738 * UTF-8 or not, but in either case is the number of bytes */
3739 bool remove_dot_above = FALSE;
3741 s = (const U8*)SvPV_const(source, slen);
3743 /* We may be able to get away with changing only the first character, in
3744 * place, but not if read-only, etc. Later we may discover more reasons to
3745 * not convert in-place. */
3746 inplace = !SvREADONLY(source) && SvPADTMP(source);
3748 #ifdef USE_LOCALE_CTYPE
3750 if (IN_LC_RUNTIME(LC_CTYPE)) {
3751 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3752 }
3754 #endif
3756 /* First calculate what the changed first character should be. This affects
3757 * whether we can just swap it out, leaving the rest of the string unchanged,
3758 * or even if have to convert the dest to UTF-8 when the source isn't */
3760 if (! slen) { /* If empty */
3761 need = 1; /* still need a trailing NUL */
3762 ulen = 0;
3763 *tmpbuf = '\0';
3764 }
3765 else if (DO_UTF8(source)) { /* Is the source utf8? */
3766 doing_utf8 = TRUE;
3767 ulen = UTF8SKIP(s);
3769 if (op_type == OP_UCFIRST) {
3770 #ifdef USE_LOCALE_CTYPE
3771 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3772 #else
3773 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3774 #endif
3775 }
3776 else {
3778 #ifdef USE_LOCALE_CTYPE
3780 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3782 /* In turkic locales, lower casing an 'I' normally yields U+0131,
3783 * LATIN SMALL LETTER DOTLESS I, but not if the grapheme also
3784 * contains a COMBINING DOT ABOVE. Instead it is treated like
3785 * LATIN CAPITAL LETTER I WITH DOT ABOVE lowercased to 'i'. The
3786 * call to lowercase above has handled this. But SpecialCasing.txt
3787 * says we are supposed to remove the COMBINING DOT ABOVE. We can
3788 * tell if we have this situation if I ==> i in a turkic locale. */
3789 if ( UNLIKELY(PL_in_utf8_turkic_locale)
3790 && IN_LC_RUNTIME(LC_CTYPE)
3791 && (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')))
3792 {
3793 /* Here, we know there was a COMBINING DOT ABOVE. We won't be
3794 * able to handle this in-place. */
3795 inplace = FALSE;
3797 /* It seems likely that the DOT will immediately follow the
3798 * 'I'. If so, we can remove it simply by indicating to the
3799 * code below to start copying the source just beyond the DOT.
3800 * We know its length is 2 */
3801 if (LIKELY(memBEGINs(s + 1, s + slen, COMBINING_DOT_ABOVE_UTF8))) {
3802 ulen += 2;
3803 }
3804 else { /* But if it doesn't follow immediately, set a flag for
3805 the code below */
3806 remove_dot_above = TRUE;
3807 }
3808 }
3809 #else
3810 PERL_UNUSED_VAR(remove_dot_above);
3812 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3813 #endif
3815 }
3817 /* we can't do in-place if the length changes. */
3818 if (ulen != tculen) inplace = FALSE;
3819 need = slen + 1 - ulen + tculen;
3820 }
3821 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3822 * latin1 is treated as caseless. Note that a locale takes
3823 * precedence */
3824 ulen = 1; /* Original character is 1 byte */
3825 tculen = 1; /* Most characters will require one byte, but this will
3826 * need to be overridden for the tricky ones */
3827 need = slen + 1;
3830 #ifdef USE_LOCALE_CTYPE
3832 if (IN_LC_RUNTIME(LC_CTYPE)) {
3833 if ( UNLIKELY(PL_in_utf8_turkic_locale)
3834 && ( (op_type == OP_LCFIRST && UNLIKELY(*s == 'I'))
3835 || (op_type == OP_UCFIRST && UNLIKELY(*s == 'i'))))
3836 {
3837 if (*s == 'I') { /* lcfirst('I') */
3838 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
3839 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
3840 }
3841 else { /* ucfirst('i') */
3842 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3843 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3844 }
3845 tculen = 2;
3846 inplace = FALSE;
3847 doing_utf8 = TRUE;
3848 convert_source_to_utf8 = TRUE;
3849 need += variant_under_utf8_count(s, s + slen);
3850 }
3851 else if (op_type == OP_LCFIRST) {
3853 /* For lc, there are no gotchas for UTF-8 locales (other than
3854 * the turkish ones already handled above) */
3855 *tmpbuf = toLOWER_LC(*s);
3856 }
3857 else { /* ucfirst */
3859 /* But for uc, some characters require special handling */
3860 if (IN_UTF8_CTYPE_LOCALE) {
3861 goto do_uni_rules;
3862 }
3864 /* This would be a bug if any locales have upper and title case
3865 * different */
3866 *tmpbuf = (U8) toUPPER_LC(*s);
3867 }
3868 }
3869 else
3870 #endif
3871 /* Here, not in locale. If not using Unicode rules, is a simple
3872 * lower/upper, depending */
3873 if (! IN_UNI_8_BIT) {
3874 *tmpbuf = (op_type == OP_LCFIRST)
3875 ? toLOWER(*s)
3876 : toUPPER(*s);
3877 }
3878 else if (op_type == OP_LCFIRST) {
3879 /* lower case the first letter: no trickiness for any character */
3880 *tmpbuf = toLOWER_LATIN1(*s);
3881 }
3882 else {
3883 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3884 * non-turkic UTF-8, which we treat as not in locale), and cased
3885 * latin1 */
3886 UV title_ord;
3887 #ifdef USE_LOCALE_CTYPE
3888 do_uni_rules:
3889 #endif
3891 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3892 if (tculen > 1) {
3893 assert(tculen == 2);
3895 /* If the result is an upper Latin1-range character, it can
3896 * still be represented in one byte, which is its ordinal */
3897 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3898 *tmpbuf = (U8) title_ord;
3899 tculen = 1;
3900 }
3901 else {
3902 /* Otherwise it became more than one ASCII character (in
3903 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3904 * beyond Latin1, so the number of bytes changed, so can't
3905 * replace just the first character in place. */
3906 inplace = FALSE;
3908 /* If the result won't fit in a byte, the entire result
3909 * will have to be in UTF-8. Allocate enough space for the
3910 * expanded first byte, and if UTF-8, the rest of the input
3911 * string, some or all of which may also expand to two
3912 * bytes, plus the terminating NUL. */
3913 if (title_ord > 255) {
3914 doing_utf8 = TRUE;
3915 convert_source_to_utf8 = TRUE;
3916 need = slen
3917 + variant_under_utf8_count(s, s + slen)
3918 + 1;
3920 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3921 * characters whose title case is above 255 is
3922 * 2. */
3923 ulen = 2;
3924 }
3925 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3926 need = slen + 1 + 1;
3927 }
3928 }
3929 }
3930 } /* End of use Unicode (Latin1) semantics */
3931 } /* End of changing the case of the first character */
3933 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3934 * generate the result */
3935 if (inplace) {
3937 /* We can convert in place. This means we change just the first
3938 * character without disturbing the rest; no need to grow */
3939 dest = source;
3940 s = d = (U8*)SvPV_force_nomg(source, slen);
3941 } else {
3942 dTARGET;
3944 dest = TARG;
3946 /* Here, we can't convert in place; we earlier calculated how much
3947 * space we will need, so grow to accommodate that */
3948 SvUPGRADE(dest, SVt_PV);
3949 d = (U8*)SvGROW(dest, need);
3950 (void)SvPOK_only(dest);
3952 SETs(dest);
3953 }
3955 if (doing_utf8) {
3956 if (! inplace) {
3957 if (! convert_source_to_utf8) {
3959 /* Here both source and dest are in UTF-8, but have to create
3960 * the entire output. We initialize the result to be the
3961 * title/lower cased first character, and then append the rest
3962 * of the string. */
3963 sv_setpvn(dest, (char*)tmpbuf, tculen);
3964 if (slen > ulen) {
3966 /* But this boolean being set means we are in a turkic
3967 * locale, and there is a DOT character that needs to be
3968 * removed, and it isn't immediately after the current
3969 * character. Keep concatenating characters to the output
3970 * one at a time, until we find the DOT, which we simply
3971 * skip */
3972 if (UNLIKELY(remove_dot_above)) {
3973 do {
3974 Size_t this_len = UTF8SKIP(s + ulen);
3976 sv_catpvn(dest, (char*)(s + ulen), this_len);
3978 ulen += this_len;
3979 if (memBEGINs(s + ulen, s + slen, COMBINING_DOT_ABOVE_UTF8)) {
3980 ulen += 2;
3981 break;
3982 }
3983 } while (s + ulen < s + slen);
3984 }
3986 /* The rest of the string can be concatenated unchanged,
3987 * all at once */
3988 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3989 }
3990 }
3991 else {
3992 const U8 *const send = s + slen;
3994 /* Here the dest needs to be in UTF-8, but the source isn't,
3995 * except we earlier UTF-8'd the first character of the source
3996 * into tmpbuf. First put that into dest, and then append the
3997 * rest of the source, converting it to UTF-8 as we go. */
3999 /* Assert tculen is 2 here because the only characters that
4000 * get to this part of the code have 2-byte UTF-8 equivalents */
4001 assert(tculen == 2);
4002 *d++ = *tmpbuf;
4003 *d++ = *(tmpbuf + 1);
4004 s++; /* We have just processed the 1st char */
4006 while (s < send) {
4007 append_utf8_from_native_byte(*s, &d);
4008 s++;
4009 }
4011 *d = '\0';
4012 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4013 }
4014 SvUTF8_on(dest);
4015 }
4016 else { /* in-place UTF-8. Just overwrite the first character */
4017 Copy(tmpbuf, d, tculen, U8);
4018 SvCUR_set(dest, need - 1);
4019 }
4021 }
4022 else { /* Neither source nor dest are, nor need to be UTF-8 */
4023 if (slen) {
4024 if (inplace) { /* in-place, only need to change the 1st char */
4025 *d = *tmpbuf;
4026 }
4027 else { /* Not in-place */
4029 /* Copy the case-changed character(s) from tmpbuf */
4030 Copy(tmpbuf, d, tculen, U8);
4031 d += tculen - 1; /* Code below expects d to point to final
4032 * character stored */
4033 }
4034 }
4035 else { /* empty source */
4036 /* See bug #39028: Don't taint if empty */
4037 *d = *s;
4038 }
4040 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4041 * the destination to retain that flag */
4042 if (DO_UTF8(source))
4043 SvUTF8_on(dest);
4045 if (!inplace) { /* Finish the rest of the string, unchanged */
4046 /* This will copy the trailing NUL */
4047 Copy(s + 1, d + 1, slen, U8);
4048 SvCUR_set(dest, need - 1);
4049 }
4050 }
4051 #ifdef USE_LOCALE_CTYPE
4052 if (IN_LC_RUNTIME(LC_CTYPE)) {
4053 TAINT;
4054 SvTAINTED_on(dest);
4055 }
4056 #endif
4057 if (dest != source && SvTAINTED(source))
4058 SvTAINT(dest);
4059 SvSETMAGIC(dest);
4060 return NORMAL;
4061 }
4063 PP(pp_uc)
4064 {
4065 dSP;
4066 SV *source = TOPs;
4067 STRLEN len;
4068 STRLEN min;
4069 SV *dest;
4070 const U8 *s;
4071 U8 *d;
4073 SvGETMAGIC(source);
4075 if ( SvPADTMP(source)
4076 && !SvREADONLY(source) && SvPOK(source)
4077 && !DO_UTF8(source)
4078 && (
4079 #ifdef USE_LOCALE_CTYPE
4080 (IN_LC_RUNTIME(LC_CTYPE))
4081 ? ! IN_UTF8_CTYPE_LOCALE
4082 :
4083 #endif
4084 ! IN_UNI_8_BIT))
4085 {
4087 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4088 * make the loop tight, so we overwrite the source with the dest before
4089 * looking at it, and we need to look at the original source
4090 * afterwards. There would also need to be code added to handle
4091 * switching to not in-place in midstream if we run into characters
4092 * that change the length. Since being in locale overrides UNI_8_BIT,
4093 * that latter becomes irrelevant in the above test; instead for
4094 * locale, the size can't normally change, except if the locale is a
4095 * UTF-8 one */
4096 dest = source;
4097 s = d = (U8*)SvPV_force_nomg(source, len);
4098 min = len + 1;
4099 } else {
4100 dTARGET;
4102 dest = TARG;
4104 s = (const U8*)SvPV_nomg_const(source, len);
4105 min = len + 1;
4107 SvUPGRADE(dest, SVt_PV);
4108 d = (U8*)SvGROW(dest, min);
4109 (void)SvPOK_only(dest);
4111 SETs(dest);
4112 }
4114 #ifdef USE_LOCALE_CTYPE
4116 if (IN_LC_RUNTIME(LC_CTYPE)) {
4117 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4118 }
4120 #endif
4122 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4123 to check DO_UTF8 again here. */
4125 if (DO_UTF8(source)) {
4126 const U8 *const send = s + len;
4127 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4129 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4130 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4131 /* All occurrences of these are to be moved to follow any other marks.
4132 * This is context-dependent. We may not be passed enough context to
4133 * move the iota subscript beyond all of them, but we do the best we can
4134 * with what we're given. The result is always better than if we
4135 * hadn't done this. And, the problem would only arise if we are
4136 * passed a character without all its combining marks, which would be
4137 * the caller's mistake. The information this is based on comes from a
4138 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4139 * itself) and so can't be checked properly to see if it ever gets
4140 * revised. But the likelihood of it changing is remote */
4141 bool in_iota_subscript = FALSE;
4143 while (s < send) {
4144 STRLEN u;
4145 STRLEN ulen;
4146 UV uv;
4147 if (UNLIKELY(in_iota_subscript)) {
4148 UV cp = utf8_to_uvchr_buf(s, send, NULL);
4150 if (! _invlist_contains_cp(PL_utf8_mark, cp)) {
4152 /* A non-mark. Time to output the iota subscript */
4153 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4154 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4155 in_iota_subscript = FALSE;
4156 }
4157 }
4159 /* Then handle the current character. Get the changed case value
4160 * and copy it to the output buffer */
4162 u = UTF8SKIP(s);
4163 #ifdef USE_LOCALE_CTYPE
4164 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4165 #else
4166 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4167 #endif
4168 if (uv == GREEK_CAPITAL_LETTER_IOTA
4169 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4170 {
4171 in_iota_subscript = TRUE;
4172 }
4173 else {
4174 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4175 /* If the eventually required minimum size outgrows the
4176 * available space, we need to grow. */
4177 const UV o = d - (U8*)SvPVX_const(dest);
4179 /* If someone uppercases one million U+03B0s we SvGROW()
4180 * one million times. Or we could try guessing how much to
4181 * allocate without allocating too much. But we can't
4182 * really guess without examining the rest of the string.
4183 * Such is life. See corresponding comment in lc code for
4184 * another option */
4185 d = o + (U8*) SvGROW(dest, min);
4186 }
4187 Copy(tmpbuf, d, ulen, U8);
4188 d += ulen;
4189 }
4190 s += u;
4191 }
4192 if (in_iota_subscript) {
4193 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4194 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4195 }
4196 SvUTF8_on(dest);
4197 *d = '\0';
4199 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4200 }
4201 else { /* Not UTF-8 */
4202 if (len) {
4203 const U8 *const send = s + len;
4205 /* Use locale casing if in locale; regular style if not treating
4206 * latin1 as having case; otherwise the latin1 casing. Do the
4207 * whole thing in a tight loop, for speed, */
4208 #ifdef USE_LOCALE_CTYPE
4209 if (IN_LC_RUNTIME(LC_CTYPE)) {
4210 if (IN_UTF8_CTYPE_LOCALE) {
4211 goto do_uni_rules;
4212 }
4213 for (; s < send; d++, s++)
4214 *d = (U8) toUPPER_LC(*s);
4215 }
4216 else
4217 #endif
4218 if (! IN_UNI_8_BIT) {
4219 for (; s < send; d++, s++) {
4220 *d = toUPPER(*s);
4221 }
4222 }
4223 else {
4224 #ifdef USE_LOCALE_CTYPE
4225 do_uni_rules:
4226 #endif
4227 for (; s < send; d++, s++) {
4228 Size_t extra;
4230 *d = toUPPER_LATIN1_MOD(*s);
4231 if ( LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)
4233 #ifdef USE_LOCALE_CTYPE
4235 && (LIKELY( ! PL_in_utf8_turkic_locale
4236 || ! IN_LC_RUNTIME(LC_CTYPE))
4237 || *s != 'i')
4238 #endif
4240 ) {
4241 continue;
4242 }
4244 /* The mainstream case is the tight loop above. To avoid
4245 * extra tests in that, all three characters that always
4246 * require special handling are mapped by the MOD to the
4247 * one tested just above. Use the source to distinguish
4248 * between those cases */
4250 #if UNICODE_MAJOR_VERSION > 2 \
4251 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4252 && UNICODE_DOT_DOT_VERSION >= 8)
4253 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4255 /* uc() of this requires 2 characters, but they are
4256 * ASCII. If not enough room, grow the string */
4257 if (SvLEN(dest) < ++min) {
4258 const UV o = d - (U8*)SvPVX_const(dest);
4259 d = o + (U8*) SvGROW(dest, min);
4260 }
4261 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4262 continue; /* Back to the tight loop; still in ASCII */
4263 }
4264 #endif
4266 /* The other special handling characters have their
4267 * upper cases outside the latin1 range, hence need to be
4268 * in UTF-8, so the whole result needs to be in UTF-8.
4269 *
4270 * So, here we are somewhere in the middle of processing a
4271 * non-UTF-8 string, and realize that we will have to
4272 * convert the whole thing to UTF-8. What to do? There
4273 * are several possibilities. The simplest to code is to
4274 * convert what we have so far, set a flag, and continue on
4275 * in the loop. The flag would be tested each time through
4276 * the loop, and if set, the next character would be
4277 * converted to UTF-8 and stored. But, I (khw) didn't want
4278 * to slow down the mainstream case at all for this fairly
4279 * rare case, so I didn't want to add a test that didn't
4280 * absolutely have to be there in the loop, besides the
4281 * possibility that it would get too complicated for
4282 * optimizers to deal with. Another possibility is to just
4283 * give up, convert the source to UTF-8, and restart the
4284 * function that way. Another possibility is to convert
4285 * both what has already been processed and what is yet to
4286 * come separately to UTF-8, then jump into the loop that
4287 * handles UTF-8. But the most efficient time-wise of the
4288 * ones I could think of is what follows, and turned out to
4289 * not require much extra code.
4290 *
4291 * First, calculate the extra space needed for the
4292 * remainder of the source needing to be in UTF-8. Except
4293 * for the 'i' in Turkic locales, in UTF-8 strings, the
4294 * uppercase of a character below 256 occupies the same
4295 * number of bytes as the original. Therefore, the space
4296 * needed is the that number plus the number of characters
4297 * that become two bytes when converted to UTF-8, plus, in
4298 * turkish locales, the number of 'i's. */
4300 extra = send - s + variant_under_utf8_count(s, send);
4302 #ifdef USE_LOCALE_CTYPE
4304 if (UNLIKELY(*s == 'i')) { /* We wouldn't get an 'i' here
4305 unless are in a Turkic
4306 locale */
4307 const U8 * s_peek = s;
4309 do {
4310 extra++;
4312 s_peek = (U8 *) memchr(s_peek + 1, 'i',
4313 send - (s_peek + 1));
4314 } while (s_peek != NULL);
4315 }
4316 #endif
4318 /* Convert what we have so far into UTF-8, telling the
4319 * function that we know it should be converted, and to
4320 * allow extra space for what we haven't processed yet.
4321 *
4322 * This may cause the string pointer to move, so need to
4323 * save and re-find it. */
4325 len = d - (U8*)SvPVX_const(dest);
4326 SvCUR_set(dest, len);
4327 len = sv_utf8_upgrade_flags_grow(dest,
4328 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4329 extra
4330 + 1 /* trailing NUL */ );
4331 d = (U8*)SvPVX(dest) + len;
4333 /* Now process the remainder of the source, simultaneously
4334 * converting to upper and UTF-8.
4335 *
4336 * To avoid extra tests in the loop body, and since the
4337 * loop is so simple, split out the rare Turkic case into
4338 * its own loop */
4340 #ifdef USE_LOCALE_CTYPE
4341 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4342 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE)))
4343 {
4344 for (; s < send; s++) {
4345 if (*s == 'i') {
4346 *d++ = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4347 *d++ = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4348 }
4349 else {
4350 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4351 d += len;
4352 }
4353 }
4354 }
4355 else
4356 #endif
4357 for (; s < send; s++) {
4358 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4359 d += len;
4360 }
4362 /* Here have processed the whole source; no need to
4363 * continue with the outer loop. Each character has been
4364 * converted to upper case and converted to UTF-8. */
4365 break;
4366 } /* End of processing all latin1-style chars */
4367 } /* End of processing all chars */
4368 } /* End of source is not empty */
4370 if (source != dest) {
4371 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4372 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4373 }
4374 } /* End of isn't utf8 */
4375 #ifdef USE_LOCALE_CTYPE
4376 if (IN_LC_RUNTIME(LC_CTYPE)) {
4377 TAINT;
4378 SvTAINTED_on(dest);
4379 }
4380 #endif
4381 if (dest != source && SvTAINTED(source))
4382 SvTAINT(dest);
4383 SvSETMAGIC(dest);
4384 return NORMAL;
4385 }
4387 PP(pp_lc)
4388 {
4389 dSP;
4390 SV *source = TOPs;
4391 STRLEN len;
4392 STRLEN min;
4393 SV *dest;
4394 const U8 *s;
4395 U8 *d;
4396 bool has_turkic_I = FALSE;
4398 SvGETMAGIC(source);
4400 if ( SvPADTMP(source)
4401 && !SvREADONLY(source) && SvPOK(source)
4402 && !DO_UTF8(source)
4404 #ifdef USE_LOCALE_CTYPE
4406 && ( LIKELY(! IN_LC_RUNTIME(LC_CTYPE))
4407 || LIKELY(! PL_in_utf8_turkic_locale))
4409 #endif
4411 ) {
4413 /* We can convert in place, as, outside of Turkic UTF-8 locales,
4414 * lowercasing anything in the latin1 range (or else DO_UTF8 would have
4415 * been on) doesn't lengthen it. */
4416 dest = source;
4417 s = d = (U8*)SvPV_force_nomg(source, len);
4418 min = len + 1;
4419 } else {
4420 dTARGET;
4422 dest = TARG;
4424 s = (const U8*)SvPV_nomg_const(source, len);
4425 min = len + 1;
4427 SvUPGRADE(dest, SVt_PV);
4428 d = (U8*)SvGROW(dest, min);
4429 (void)SvPOK_only(dest);
4431 SETs(dest);
4432 }
4434 #ifdef USE_LOCALE_CTYPE
4436 if (IN_LC_RUNTIME(LC_CTYPE)) {
4437 const U8 * next_I;
4439 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4441 /* Lowercasing in a Turkic locale can cause non-UTF-8 to need to become
4442 * UTF-8 for the single case of the character 'I' */
4443 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4444 && ! DO_UTF8(source)
4445 && (next_I = (U8 *) memchr(s, 'I', len)))
4446 {
4447 Size_t I_count = 0;
4448 const U8 *const send = s + len;
4450 do {
4451 I_count++;
4453 next_I = (U8 *) memchr(next_I + 1, 'I',
4454 send - (next_I + 1));
4455 } while (next_I != NULL);
4457 /* Except for the 'I', in UTF-8 strings, the lower case of a
4458 * character below 256 occupies the same number of bytes as the
4459 * original. Therefore, the space needed is the original length
4460 * plus I_count plus the number of characters that become two bytes
4461 * when converted to UTF-8 */
4462 sv_utf8_upgrade_flags_grow(dest, 0, len
4463 + I_count
4464 + variant_under_utf8_count(s, send)
4465 + 1 /* Trailing NUL */ );
4466 d = (U8*)SvPVX(dest);
4467 has_turkic_I = TRUE;
4468 }
4469 }
4471 #else
4472 PERL_UNUSED_VAR(has_turkic_I);
4473 #endif
4475 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4476 to check DO_UTF8 again here. */
4478 if (DO_UTF8(source)) {
4479 const U8 *const send = s + len;
4480 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4481 bool remove_dot_above = FALSE;
4483 while (s < send) {
4484 const STRLEN u = UTF8SKIP(s);
4485 STRLEN ulen;
4487 #ifdef USE_LOCALE_CTYPE
4489 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4491 /* If we are in a Turkic locale, we have to do more work. As noted
4492 * in the comments for lcfirst, there is a special case if a 'I'
4493 * is in a grapheme with COMBINING DOT ABOVE UTF8. It turns into a
4494 * 'i', and the DOT must be removed. We check for that situation,
4495 * and set a flag if the DOT is there. Then each time through the
4496 * loop, we have to see if we need to remove the next DOT above,
4497 * and if so, do it. We know that there is a DOT because
4498 * _toLOWER_utf8_flags() wouldn't have returned 'i' unless there
4499 * was one in a proper position. */
4500 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4501 && IN_LC_RUNTIME(LC_CTYPE))
4502 {
4503 if ( UNLIKELY(remove_dot_above)
4504 && memBEGINs(tmpbuf, sizeof(tmpbuf), COMBINING_DOT_ABOVE_UTF8))
4505 {
4506 s += u;
4507 remove_dot_above = FALSE;
4508 continue;
4509 }
4510 else if (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')) {
4511 remove_dot_above = TRUE;
4512 }
4513 }
4514 #else
4515 PERL_UNUSED_VAR(remove_dot_above);
4517 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4518 #endif
4520 /* Here is where we would do context-sensitive actions for the
4521 * Greek final sigma. See the commit message for 86510fb15 for why
4522 * there isn't any */
4524 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4526 /* If the eventually required minimum size outgrows the
4527 * available space, we need to grow. */
4528 const UV o = d - (U8*)SvPVX_const(dest);
4530 /* If someone lowercases one million U+0130s we SvGROW() one
4531 * million times. Or we could try guessing how much to
4532 * allocate without allocating too much. Such is life.
4533 * Another option would be to grow an extra byte or two more
4534 * each time we need to grow, which would cut down the million
4535 * to 500K, with little waste */
4536 d = o + (U8*) SvGROW(dest, min);
4537 }
4539 /* Copy the newly lowercased letter to the output buffer we're
4540 * building */
4541 Copy(tmpbuf, d, ulen, U8);
4542 d += ulen;
4543 s += u;
4544 } /* End of looping through the source string */
4545 SvUTF8_on(dest);
4546 *d = '\0';
4547 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4548 } else { /* 'source' not utf8 */
4549 if (len) {
4550 const U8 *const send = s + len;
4552 /* Use locale casing if in locale; regular style if not treating
4553 * latin1 as having case; otherwise the latin1 casing. Do the
4554 * whole thing in a tight loop, for speed, */
4555 #ifdef USE_LOCALE_CTYPE
4556 if (IN_LC_RUNTIME(LC_CTYPE)) {
4557 if (LIKELY( ! has_turkic_I)) {
4558 for (; s < send; d++, s++)
4559 *d = toLOWER_LC(*s);
4560 }
4561 else { /* This is the only case where lc() converts 'dest'
4562 into UTF-8 from a non-UTF-8 'source' */
4563 for (; s < send; s++) {
4564 if (*s == 'I') {
4565 *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4566 *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4567 }
4568 else {
4569 append_utf8_from_native_byte(toLOWER_LATIN1(*s), &d);
4570 }
4571 }
4572 }
4573 }
4574 else
4575 #endif
4576 if (! IN_UNI_8_BIT) {
4577 for (; s < send; d++, s++) {
4578 *d = toLOWER(*s);
4579 }
4580 }
4581 else {
4582 for (; s < send; d++, s++) {
4583 *d = toLOWER_LATIN1(*s);
4584 }
4585 }
4586 }
4587 if (source != dest) {
4588 *d = '\0';
4589 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4590 }
4591 }
4592 #ifdef USE_LOCALE_CTYPE
4593 if (IN_LC_RUNTIME(LC_CTYPE)) {
4594 TAINT;
4595 SvTAINTED_on(dest);
4596 }
4597 #endif
4598 if (dest != source && SvTAINTED(source))
4599 SvTAINT(dest);
4600 SvSETMAGIC(dest);
4601 return NORMAL;
4602 }
4604 PP(pp_quotemeta)
4605 {
4606 dSP; dTARGET;
4607 SV * const sv = TOPs;
4608 STRLEN len;
4609 const char *s = SvPV_const(sv,len);
4611 SvUTF8_off(TARG); /* decontaminate */
4612 if (len) {
4613 char *d;
4614 SvUPGRADE(TARG, SVt_PV);
4615 SvGROW(TARG, (len * 2) + 1);
4616 d = SvPVX(TARG);
4617 if (DO_UTF8(sv)) {
4618 while (len) {
4619 STRLEN ulen = UTF8SKIP(s);
4620 bool to_quote = FALSE;
4622 if (UTF8_IS_INVARIANT(*s)) {
4623 if (_isQUOTEMETA(*s)) {
4624 to_quote = TRUE;
4625 }
4626 }
4627 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4628 if (
4629 #ifdef USE_LOCALE_CTYPE
4630 /* In locale, we quote all non-ASCII Latin1 chars.
4631 * Otherwise use the quoting rules */
4633 IN_LC_RUNTIME(LC_CTYPE)
4634 ||
4635 #endif
4636 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4637 {
4638 to_quote = TRUE;
4639 }
4640 }
4641 else if (is_QUOTEMETA_high(s)) {
4642 to_quote = TRUE;
4643 }
4645 if (to_quote) {
4646 *d++ = '\\';
4647 }
4648 if (ulen > len)
4649 ulen = len;
4650 len -= ulen;
4651 while (ulen--)
4652 *d++ = *s++;
4653 }
4654 SvUTF8_on(TARG);
4655 }
4656 else if (IN_UNI_8_BIT) {
4657 while (len--) {
4658 if (_isQUOTEMETA(*s))
4659 *d++ = '\\';
4660 *d++ = *s++;
4661 }
4662 }
4663 else {
4664 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4665 * including everything above ASCII */
4666 while (len--) {
4667 if (!isWORDCHAR_A(*s))
4668 *d++ = '\\';
4669 *d++ = *s++;
4670 }
4671 }
4672 *d = '\0';
4673 SvCUR_set(TARG, d - SvPVX_const(TARG));
4674 (void)SvPOK_only_UTF8(TARG);
4675 }
4676 else
4677 sv_setpvn(TARG, s, len);
4678 SETTARG;
4679 return NORMAL;
4680 }
4682 PP(pp_fc)
4683 {
4684 dTARGET;
4685 dSP;
4686 SV *source = TOPs;
4687 STRLEN len;
4688 STRLEN min;
4689 SV *dest;
4690 const U8 *s;
4691 const U8 *send;
4692 U8 *d;
4693 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4694 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4695 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4696 || UNICODE_DOT_DOT_VERSION > 0)
4697 const bool full_folding = TRUE; /* This variable is here so we can easily
4698 move to more generality later */
4699 #else
4700 const bool full_folding = FALSE;
4701 #endif
4702 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4703 #ifdef USE_LOCALE_CTYPE
4704 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4705 #endif
4706 ;
4708 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4709 * You are welcome(?) -Hugmeir
4710 */
4712 SvGETMAGIC(source);
4714 dest = TARG;
4716 if (SvOK(source)) {
4717 s = (const U8*)SvPV_nomg_const(source, len);
4718 } else {
4719 if (ckWARN(WARN_UNINITIALIZED))
4720 report_uninit(source);
4721 s = (const U8*)"";
4722 len = 0;
4723 }
4725 min = len + 1;
4727 SvUPGRADE(dest, SVt_PV);
4728 d = (U8*)SvGROW(dest, min);
4729 (void)SvPOK_only(dest);
4731 SETs(dest);
4733 send = s + len;
4735 #ifdef USE_LOCALE_CTYPE
4737 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4738 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4739 }
4741 #endif
4743 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4744 while (s < send) {
4745 const STRLEN u = UTF8SKIP(s);
4746 STRLEN ulen;
4748 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4750 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4751 const UV o = d - (U8*)SvPVX_const(dest);
4752 d = o + (U8*) SvGROW(dest, min);
4753 }
4755 Copy(tmpbuf, d, ulen, U8);
4756 d += ulen;
4757 s += u;
4758 }
4759 SvUTF8_on(dest);
4760 } /* Unflagged string */
4761 else if (len) {
4762 #ifdef USE_LOCALE_CTYPE
4763 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4764 if (IN_UTF8_CTYPE_LOCALE) {
4765 goto do_uni_folding;
4766 }
4767 for (; s < send; d++, s++)
4768 *d = (U8) toFOLD_LC(*s);
4769 }
4770 else
4771 #endif
4772 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4773 for (; s < send; d++, s++)
4774 *d = toFOLD(*s);
4775 }
4776 else {
4777 #ifdef USE_LOCALE_CTYPE
4778 do_uni_folding:
4779 #endif
4780 /* For ASCII and the Latin-1 range, there's potentially three
4781 * troublesome folds:
4782 * \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4783 * casefolding becomes 'ss';
4784 * \x{B5} (\N{MICRO SIGN}), which under any fold becomes
4785 * \x{3BC} (\N{GREEK SMALL LETTER MU})
4786 * I only in Turkic locales, this folds to \x{131}
4787 * \N{LATIN SMALL LETTER DOTLESS I}
4788 * For the rest, the casefold is their lowercase. */
4789 for (; s < send; d++, s++) {
4790 if ( UNLIKELY(*s == MICRO_SIGN)
4791 #ifdef USE_LOCALE_CTYPE
4792 || ( UNLIKELY(PL_in_utf8_turkic_locale)
4793 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE))
4794 && UNLIKELY(*s == 'I'))
4795 #endif
4796 ) {
4797 Size_t extra = send - s
4798 + variant_under_utf8_count(s, send);
4800 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4801 * and 'I' in Turkic locales is \N{LATIN SMALL LETTER
4802 * DOTLESS I} both of which are outside of the latin-1
4803 * range. There's a couple of ways to deal with this -- khw
4804 * discusses them in pp_lc/uc, so go there :) What we do
4805 * here is upgrade what we had already casefolded, then
4806 * enter an inner loop that appends the rest of the
4807 * characters as UTF-8.
4808 *
4809 * First we calculate the needed size of the upgraded dest
4810 * beyond what's been processed already (the upgrade
4811 * function figures that out). Except for the 'I' in
4812 * Turkic locales, in UTF-8 strings, the fold case of a
4813 * character below 256 occupies the same number of bytes as
4814 * the original (even the Sharp S). Therefore, the space
4815 * needed is the number of bytes remaining plus the number
4816 * of characters that become two bytes when converted to
4817 * UTF-8 plus, in turkish locales, the number of 'I's */
4819 if (UNLIKELY(*s == 'I')) {
4820 const U8 * s_peek = s;
4822 do {
4823 extra++;
4825 s_peek = (U8 *) memchr(s_peek + 1, 'I',
4826 send - (s_peek + 1));
4827 } while (s_peek != NULL);
4828 }
4830 /* Growing may move things, so have to save and recalculate
4831 * 'd' */
4832 len = d - (U8*)SvPVX_const(dest);
4833 SvCUR_set(dest, len);
4834 len = sv_utf8_upgrade_flags_grow(dest,
4835 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4836 extra
4837 + 1 /* Trailing NUL */ );
4838 d = (U8*)SvPVX(dest) + len;
4840 if (*s == 'I') {
4841 *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4842 *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4843 }
4844 else {
4845 *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
4846 *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
4847 }
4848 s++;
4850 for (; s < send; s++) {
4851 STRLEN ulen;
4852 _to_uni_fold_flags(*s, d, &ulen, flags);
4853 d += ulen;
4854 }
4855 break;
4856 }
4857 else if ( UNLIKELY(*s == LATIN_SMALL_LETTER_SHARP_S)
4858 && full_folding)
4859 {
4860 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4861 * becomes "ss", which may require growing the SV. */
4862 if (SvLEN(dest) < ++min) {
4863 const UV o = d - (U8*)SvPVX_const(dest);
4864 d = o + (U8*) SvGROW(dest, min);
4865 }
4866 *(d)++ = 's';
4867 *d = 's';
4868 }
4869 else { /* Else, the fold is the lower case */
4870 *d = toLOWER_LATIN1(*s);
4871 }
4872 }
4873 }
4874 }
4875 *d = '\0';
4876 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4878 #ifdef USE_LOCALE_CTYPE
4879 if (IN_LC_RUNTIME(LC_CTYPE)) {
4880 TAINT;
4881 SvTAINTED_on(dest);
4882 }
4883 #endif
4884 if (SvTAINTED(source))
4885 SvTAINT(dest);
4886 SvSETMAGIC(dest);
4887 RETURN;
4888 }
4890 /* Arrays. */
4892 PP(pp_aslice)
4893 {
4894 dSP; dMARK; dORIGMARK;
4895 AV *const av = MUTABLE_AV(POPs);
4896 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4898 if (SvTYPE(av) == SVt_PVAV) {
4899 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4900 bool can_preserve = FALSE;
4902 if (localizing) {
4903 MAGIC *mg;
4904 HV *stash;
4906 can_preserve = SvCANEXISTDELETE(av);
4907 }
4909 if (lval && localizing) {
4910 SV **svp;
4911 SSize_t max = -1;
4912 for (svp = MARK + 1; svp <= SP; svp++) {
4913 const SSize_t elem = SvIV(*svp);
4914 if (elem > max)
4915 max = elem;
4916 }
4917 if (max > AvMAX(av))
4918 av_extend(av, max);
4919 }
4921 while (++MARK <= SP) {
4922 SV **svp;
4923 SSize_t elem = SvIV(*MARK);
4924 bool preeminent = TRUE;
4926 if (localizing && can_preserve) {
4927 /* If we can determine whether the element exist,
4928 * Try to preserve the existenceness of a tied array
4929 * element by using EXISTS and DELETE if possible.
4930 * Fallback to FETCH and STORE otherwise. */
4931 preeminent = av_exists(av, elem);
4932 }
4934 svp = av_fetch(av, elem, lval);
4935 if (lval) {
4936 if (!svp || !*svp)
4937 DIE(aTHX_ PL_no_aelem, elem);
4938 if (localizing) {
4939 if (preeminent)
4940 save_aelem(av, elem, svp);
4941 else
4942 SAVEADELETE(av, elem);
4943 }
4944 }
4945 *MARK = svp ? *svp : &PL_sv_undef;
4946 }
4947 }
4948 if (GIMME_V != G_LIST) {
4949 MARK = ORIGMARK;
4950 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4951 SP = MARK;
4952 }
4953 RETURN;
4954 }
4956 PP(pp_kvaslice)
4957 {
4958 dSP; dMARK;
4959 AV *const av = MUTABLE_AV(POPs);
4960 I32 lval = (PL_op->op_flags & OPf_MOD);
4961 SSize_t items = SP - MARK;
4963 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4964 const I32 flags = is_lvalue_sub();
4965 if (flags) {
4966 if (!(flags & OPpENTERSUB_INARGS))
4967 /* diag_listed_as: Can't modify %s in %s */
4968 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4969 lval = flags;
4970 }
4971 }
4973 MEXTEND(SP,items);
4974 while (items > 1) {
4975 *(MARK+items*2-1) = *(MARK+items);
4976 items--;
4977 }
4978 items = SP-MARK;
4979 SP += items;
4981 while (++MARK <= SP) {
4982 SV **svp;
4984 svp = av_fetch(av, SvIV(*MARK), lval);
4985 if (lval) {
4986 if (!svp || !*svp || *svp == &PL_sv_undef) {
4987 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4988 }
4989 *MARK = sv_mortalcopy(*MARK);
4990 }
4991 *++MARK = svp ? *svp : &PL_sv_undef;
4992 }
4993 if (GIMME_V != G_LIST) {
4994 MARK = SP - items*2;
4995 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4996 SP = MARK;
4997 }
4998 RETURN;
4999 }
5002 PP(pp_aeach)
5003 {
5004 dSP;
5005 AV *array = MUTABLE_AV(POPs);
5006 const U8 gimme = GIMME_V;
5007 IV *iterp = Perl_av_iter_p(aTHX_ array);
5008 const IV current = (*iterp)++;
5010 if (current > av_top_index(array)) {
5011 *iterp = 0;
5012 if (gimme == G_SCALAR)
5013 RETPUSHUNDEF;
5014 else
5015 RETURN;
5016 }
5018 EXTEND(SP, 2);
5019 mPUSHi(current);
5020 if (gimme == G_LIST) {
5021 SV **const element = av_fetch(array, current, 0);
5022 PUSHs(element ? *element : &PL_sv_undef);
5023 }
5024 RETURN;
5025 }
5027 /* also used for: pp_avalues()*/
5028 PP(pp_akeys)
5029 {
5030 dSP;
5031 AV *array = MUTABLE_AV(POPs);
5032 const U8 gimme = GIMME_V;
5034 *Perl_av_iter_p(aTHX_ array) = 0;
5036 if (gimme == G_SCALAR) {
5037 dTARGET;
5038 PUSHi(av_count(array));
5039 }
5040 else if (gimme == G_LIST) {
5041 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
5042 const I32 flags = is_lvalue_sub();
5043 if (flags && !(flags & OPpENTERSUB_INARGS))
5044 /* diag_listed_as: Can't modify %s in %s */
5045 Perl_croak(aTHX_
5046 "Can't modify keys on array in list assignment");
5047 }
5048 {
5049 IV n = av_top_index(array);
5050 IV i;
5052 EXTEND(SP, n + 1);
5054 if ( PL_op->op_type == OP_AKEYS
5055 || ( PL_op->op_type == OP_AVHVSWITCH
5056 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
5057 {
5058 for (i = 0; i <= n; i++) {
5059 mPUSHi(i);
5060 }
5061 }
5062 else {
5063 for (i = 0; i <= n; i++) {
5064 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
5065 PUSHs(elem ? *elem : &PL_sv_undef);
5066 }
5067 }
5068 }
5069 }
5070 RETURN;
5071 }
5073 /* Associative arrays. */
5075 PP(pp_each)
5076 {
5077 dSP;
5078 HV * hash = MUTABLE_HV(POPs);
5079 HE *entry;
5080 const U8 gimme = GIMME_V;
5082 entry = hv_iternext(hash);
5084 EXTEND(SP, 2);
5085 if (entry) {
5086 SV* const sv = hv_iterkeysv(entry);
5087 PUSHs(sv);
5088 if (gimme == G_LIST) {
5089 SV *val;
5090 val = hv_iterval(hash, entry);
5091 PUSHs(val);
5092 }
5093 }
5094 else if (gimme == G_SCALAR)
5095 RETPUSHUNDEF;
5097 RETURN;
5098 }
5100 STATIC OP *
5101 S_do_delete_local(pTHX)
5102 {
5103 dSP;
5104 const U8 gimme = GIMME_V;
5105 const MAGIC *mg;
5106 HV *stash;
5107 const bool sliced = !!(PL_op->op_private & OPpSLICE);
5108 SV **unsliced_keysv = sliced ? NULL : sp--;
5109 SV * const osv = POPs;
5110 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
5111 dORIGMARK;
5112 const bool tied = SvRMAGICAL(osv)
5113 && mg_find((const SV *)osv, PERL_MAGIC_tied);
5114 const bool can_preserve = SvCANEXISTDELETE(osv);
5115 const U32 type = SvTYPE(osv);
5116 SV ** const end = sliced ? SP : unsliced_keysv;
5118 if (type == SVt_PVHV) { /* hash element */
5119 HV * const hv = MUTABLE_HV(osv);
5120 while (++MARK <= end) {
5121 SV * const keysv = *MARK;
5122 SV *sv = NULL;
5123 bool preeminent = TRUE;
5124 if (can_preserve)
5125 preeminent = hv_exists_ent(hv, keysv, 0);
5126 if (tied) {
5127 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5128 if (he)
5129 sv = HeVAL(he);
5130 else
5131 preeminent = FALSE;
5132 }
5133 else {
5134 sv = hv_delete_ent(hv, keysv, 0, 0);
5135 if (preeminent)
5136 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5137 }
5138 if (preeminent) {
5139 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5140 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5141 if (tied) {
5142 *MARK = sv_mortalcopy(sv);
5143 mg_clear(sv);
5144 } else
5145 *MARK = sv;
5146 }
5147 else {
5148 SAVEHDELETE(hv, keysv);
5149 *MARK = &PL_sv_undef;
5150 }
5151 }
5152 }
5153 else if (type == SVt_PVAV) { /* array element */
5154 if (PL_op->op_flags & OPf_SPECIAL) {
5155 AV * const av = MUTABLE_AV(osv);
5156 while (++MARK <= end) {
5157 SSize_t idx = SvIV(*MARK);
5158 SV *sv = NULL;
5159 bool preeminent = TRUE;
5160 if (can_preserve)
5161 preeminent = av_exists(av, idx);
5162 if (tied) {
5163 SV **svp = av_fetch(av, idx, 1);
5164 if (svp)
5165 sv = *svp;
5166 else
5167 preeminent = FALSE;
5168 }
5169 else {
5170 sv = av_delete(av, idx, 0);
5171 if (preeminent)
5172 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5173 }
5174 if (preeminent) {
5175 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5176 if (tied) {
5177 *MARK = sv_mortalcopy(sv);
5178 mg_clear(sv);
5179 } else
5180 *MARK = sv;
5181 }
5182 else {
5183 SAVEADELETE(av, idx);
5184 *MARK = &PL_sv_undef;
5185 }
5186 }
5187 }
5188 else
5189 DIE(aTHX_ "panic: avhv_delete no longer supported");
5190 }
5191 else
5192 DIE(aTHX_ "Not a HASH reference");
5193 if (sliced) {
5194 if (gimme == G_VOID)
5195 SP = ORIGMARK;
5196 else if (gimme == G_SCALAR) {
5197 MARK = ORIGMARK;
5198 if (SP > MARK)
5199 *++MARK = *SP;
5200 else
5201 *++MARK = &PL_sv_undef;
5202 SP = MARK;
5203 }
5204 }
5205 else if (gimme != G_VOID)
5206 PUSHs(*unsliced_keysv);
5208 RETURN;
5209 }
5211 PP(pp_delete)
5212 {
5213 dSP;
5214 U8 gimme;
5215 I32 discard;
5217 if (PL_op->op_private & OPpLVAL_INTRO)
5218 return do_delete_local();
5220 gimme = GIMME_V;
5221 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5223 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
5224 dMARK; dORIGMARK;
5225 HV * const hv = MUTABLE_HV(POPs);
5226 const U32 hvtype = SvTYPE(hv);
5227 int skip = 0;
5228 if (PL_op->op_private & OPpKVSLICE) {
5229 SSize_t items = SP - MARK;
5231 MEXTEND(SP,items);
5232 while (items > 1) {
5233 *(MARK+items*2-1) = *(MARK+items);
5234 items--;
5235 }
5236 items = SP - MARK;
5237 SP += items;
5238 skip = 1;
5239 }
5240 if (hvtype == SVt_PVHV) { /* hash element */
5241 while ((MARK += (1+skip)) <= SP) {
5242 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
5243 *MARK = sv ? sv : &PL_sv_undef;
5244 }
5245 }
5246 else if (hvtype == SVt_PVAV) { /* array element */
5247 if (PL_op->op_flags & OPf_SPECIAL) {
5248 while ((MARK += (1+skip)) <= SP) {
5249 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5250 *MARK = sv ? sv : &PL_sv_undef;
5251 }
5252 }
5253 }
5254 else
5255 DIE(aTHX_ "Not a HASH reference");
5256 if (discard)
5257 SP = ORIGMARK;
5258 else if (gimme == G_SCALAR) {
5259 MARK = ORIGMARK;
5260 if (SP > MARK)
5261 *++MARK = *SP;
5262 else
5263 *++MARK = &PL_sv_undef;
5264 SP = MARK;
5265 }
5266 }
5267 else {
5268 SV *keysv = POPs;
5269 HV * const hv = MUTABLE_HV(POPs);
5270 SV *sv = NULL;
5271 if (SvTYPE(hv) == SVt_PVHV)
5272 sv = hv_delete_ent(hv, keysv, discard, 0);
5273 else if (SvTYPE(hv) == SVt_PVAV) {
5274 if (PL_op->op_flags & OPf_SPECIAL)
5275 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5276 else
5277 DIE(aTHX_ "panic: avhv_delete no longer supported");
5278 }
5279 else
5280 DIE(aTHX_ "Not a HASH reference");
5281 if (!sv)
5282 sv = &PL_sv_undef;
5283 if (!discard)
5284 PUSHs(sv);
5285 }
5286 RETURN;
5287 }
5289 PP(pp_exists)
5290 {
5291 dSP;
5292 SV *tmpsv;
5293 HV *hv;
5295 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5296 GV *gv;
5297 SV * const sv = POPs;
5298 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5299 if (cv)
5300 RETPUSHYES;
5301 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5302 RETPUSHYES;
5303 RETPUSHNO;
5304 }
5305 tmpsv = POPs;
5306 hv = MUTABLE_HV(POPs);
5307 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5308 if (hv_exists_ent(hv, tmpsv, 0))
5309 RETPUSHYES;
5310 }
5311 else if (SvTYPE(hv) == SVt_PVAV) {
5312 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5313 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5314 RETPUSHYES;
5315 }
5316 }
5317 else {
5318 DIE(aTHX_ "Not a HASH reference");
5319 }
5320 RETPUSHNO;
5321 }
5323 PP(pp_hslice)
5324 {
5325 dSP; dMARK; dORIGMARK;
5326 HV * const hv = MUTABLE_HV(POPs);
5327 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5328 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5329 bool can_preserve = FALSE;
5331 if (localizing) {
5332 MAGIC *mg;
5333 HV *stash;
5335 if (SvCANEXISTDELETE(hv))
5336 can_preserve = TRUE;
5337 }
5339 while (++MARK <= SP) {
5340 SV * const keysv = *MARK;
5341 SV **svp;
5342 HE *he;
5343 bool preeminent = TRUE;
5345 if (localizing && can_preserve) {
5346 /* If we can determine whether the element exist,
5347 * try to preserve the existenceness of a tied hash
5348 * element by using EXISTS and DELETE if possible.
5349 * Fallback to FETCH and STORE otherwise. */
5350 preeminent = hv_exists_ent(hv, keysv, 0);
5351 }
5353 he = hv_fetch_ent(hv, keysv, lval, 0);
5354 svp = he ? &HeVAL(he) : NULL;
5356 if (lval) {
5357 if (!svp || !*svp || *svp == &PL_sv_undef) {
5358 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5359 }
5360 if (localizing) {
5361 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5362 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5363 else if (preeminent)
5364 save_helem_flags(hv, keysv, svp,
5365 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5366 else
5367 SAVEHDELETE(hv, keysv);
5368 }
5369 }
5370 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5371 }
5372 if (GIMME_V != G_LIST) {
5373 MARK = ORIGMARK;
5374 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5375 SP = MARK;
5376 }
5377 RETURN;
5378 }
5380 PP(pp_kvhslice)
5381 {
5382 dSP; dMARK;
5383 HV * const hv = MUTABLE_HV(POPs);
5384 I32 lval = (PL_op->op_flags & OPf_MOD);
5385 SSize_t items = SP - MARK;
5387 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5388 const I32 flags = is_lvalue_sub();
5389 if (flags) {
5390 if (!(flags & OPpENTERSUB_INARGS))
5391 /* diag_listed_as: Can't modify %s in %s */
5392 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5393 GIMME_V == G_LIST ? "list" : "scalar");
5394 lval = flags;
5395 }
5396 }
5398 MEXTEND(SP,items);
5399 while (items > 1) {
5400 *(MARK+items*2-1) = *(MARK+items);
5401 items--;
5402 }
5403 items = SP-MARK;
5404 SP += items;
5406 while (++MARK <= SP) {
5407 SV * const keysv = *MARK;
5408 SV **svp;
5409 HE *he;
5411 he = hv_fetch_ent(hv, keysv, lval, 0);
5412 svp = he ? &HeVAL(he) : NULL;
5414 if (lval) {
5415 if (!svp || !*svp || *svp == &PL_sv_undef) {
5416 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5417 }
5418 *MARK = sv_mortalcopy(*MARK);
5419 }
5420 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5421 }
5422 if (GIMME_V != G_LIST) {
5423 MARK = SP - items*2;
5424 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5425 SP = MARK;
5426 }
5427 RETURN;
5428 }
5430 /* List operators. */
5432 PP(pp_list)
5433 {
5434 I32 markidx = POPMARK;
5435 if (GIMME_V != G_LIST) {
5436 /* don't initialize mark here, EXTEND() may move the stack */
5437 SV **mark;
5438 dSP;
5439 EXTEND(SP, 1); /* in case no arguments, as in @empty */
5440 mark = PL_stack_base + markidx;
5441 if (++MARK <= SP)
5442 *MARK = *SP; /* unwanted list, return last item */
5443 else
5444 *MARK = &PL_sv_undef;
5445 SP = MARK;
5446 PUTBACK;
5447 }
5448 return NORMAL;
5449 }
5451 PP(pp_lslice)
5452 {
5453 dSP;
5454 SV ** const lastrelem = PL_stack_sp;
5455 SV ** const lastlelem = PL_stack_base + POPMARK;
5456 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5457 SV ** const firstrelem = lastlelem + 1;
5458 const U8 mod = PL_op->op_flags & OPf_MOD;
5460 const I32 max = lastrelem - lastlelem;
5461 SV **lelem;
5463 if (GIMME_V != G_LIST) {
5464 if (lastlelem < firstlelem) {
5465 EXTEND(SP, 1);
5466 *firstlelem = &PL_sv_undef;
5467 }
5468 else {
5469 I32 ix = SvIV(*lastlelem);
5470 if (ix < 0)
5471 ix += max;
5472 if (ix < 0 || ix >= max)
5473 *firstlelem = &PL_sv_undef;
5474 else
5475 *firstlelem = firstrelem[ix];
5476 }
5477 SP = firstlelem;
5478 RETURN;
5479 }
5481 if (max == 0) {
5482 SP = firstlelem - 1;
5483 RETURN;
5484 }
5486 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5487 I32 ix = SvIV(*lelem);
5488 if (ix < 0)
5489 ix += max;
5490 if (ix < 0 || ix >= max)
5491 *lelem = &PL_sv_undef;
5492 else {
5493 if (!(*lelem = firstrelem[ix]))
5494 *lelem = &PL_sv_undef;
5495 else if (mod && SvPADTMP(*lelem)) {
5496 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5497 }
5498 }
5499 }
5500 SP = lastlelem;
5501 RETURN;
5502 }
5504 PP(pp_anonlist)
5505 {
5506 dSP; dMARK;
5507 const I32 items = SP - MARK;
5508 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5509 SP = MARK;
5510 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5511 ? newRV_noinc(av) : av);
5512 RETURN;
5513 }
5515 PP(pp_anonhash)
5516 {
5517 dSP; dMARK; dORIGMARK;
5518 HV* const hv = newHV();
5519 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5520 ? newRV_noinc(MUTABLE_SV(hv))
5521 : MUTABLE_SV(hv) );
5522 /* This isn't quite true for an odd sized list (it's one too few) but it's
5523 not worth the runtime +1 just to optimise for the warning case. */
5524 SSize_t pairs = (SP - MARK) >> 1;
<a id="l5525" href="/perl5.git/blob/HEAD:/pp.c