| CARVIEW |
Select Language
HTTP/2 302
server: nginx
date: Thu, 31 Jul 2025 03:43:15 GMT
content-type: text/plain; charset=utf-8
content-length: 0
x-archive-redirect-reason: found capture at 20190618232609
location: https://web.archive.org/web/20190618232609/https://perl5.git.perl.org/perl.git/blob/HEAD:/pp.c
server-timing: captures_list;dur=0.619080, exclusion.robots;dur=0.019133, exclusion.robots.policy;dur=0.008864, esindex;dur=0.010833, cdx.remote;dur=31.356664, LoadShardBlock;dur=93.619835, PetaboxLoader3.datanode;dur=91.199063
x-app-server: wwwb-app214
x-ts: 302
x-tr: 154
server-timing: TR;dur=0,Tw;dur=0,Tc;dur=0
set-cookie: SERVER=wwwb-app214; 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 302
server: nginx
date: Thu, 31 Jul 2025 03:43:16 GMT
content-type: text/plain; charset=utf-8
content-length: 0
x-archive-redirect-reason: found capture at 20190618232610
location: https://web.archive.org/web/20190618232610/https://perl5.git.perl.org/perl.git/blob/HEAD:/pp.c
server-timing: captures_list;dur=0.532258, exclusion.robots;dur=0.020329, exclusion.robots.policy;dur=0.010572, esindex;dur=0.012884, cdx.remote;dur=26.455471, LoadShardBlock;dur=297.127053, PetaboxLoader3.resolve;dur=399.295462, PetaboxLoader3.datanode;dur=289.595712, load_resource;dur=642.609039
x-app-server: wwwb-app214
x-ts: 302
x-tr: 1011
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=()
HTTP/2 200
server: nginx
date: Thu, 31 Jul 2025 03:43:19 GMT
content-type: text/html; charset=utf-8
x-archive-orig-date: Tue, 18 Jun 2019 23:26:10 GMT
x-archive-orig-server: Apache/2.4.6 (CentOS) OpenSSL/1.0.2k-fips
x-archive-orig-connection: close
x-archive-orig-content-length: 1357311
x-archive-guessed-content-type: text/html
x-archive-guessed-charset: utf-8
memento-datetime: Tue, 18 Jun 2019 23:26:10 GMT
link: ; rel="original", ; rel="timemap"; type="application/link-format", ; rel="timegate", ; rel="first memento"; datetime="Tue, 18 Jun 2019 23:26:09 GMT", ; rel="prev memento"; datetime="Tue, 18 Jun 2019 23:26:09 GMT", ; rel="memento"; datetime="Tue, 18 Jun 2019 23:26:10 GMT", ; rel="next memento"; datetime="Tue, 25 Jun 2019 20:34:18 GMT", ; rel="last memento"; datetime="Wed, 30 Oct 2024 11:37:55 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: liveweb-20190618234701/live-20190618232521-wwwb-app53.us.archive.org.warc.gz
server-timing: captures_list;dur=0.706557, exclusion.robots;dur=0.025386, exclusion.robots.policy;dur=0.012374, esindex;dur=0.016870, cdx.remote;dur=59.954392, LoadShardBlock;dur=168.877719, PetaboxLoader3.datanode;dur=123.987379, PetaboxLoader3.resolve;dur=270.997176, load_resource;dur=259.353815
x-app-server: wwwb-app214
x-ts: 200
x-tr: 2494
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=()
content-encoding: gzip
Perl 5 - perl.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 prepare_SV_for_RV(sv);
144 SvRV_set(sv, MUTABLE_SV(gv));
145 SvROK_on(sv);
146 SvSETMAGIC(sv);
147 goto wasref;
148 }
149 if (PL_op->op_flags & OPf_REF || strict) {
150 Perl_die(aTHX_ PL_no_usym, "a symbol");
151 }
152 if (ckWARN(WARN_UNINITIALIZED))
153 report_uninit(sv);
154 return &PL_sv_undef;
155 }
156 if (noinit)
157 {
158 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
159 sv, GV_ADDMG, SVt_PVGV
160 ))))
161 return &PL_sv_undef;
162 }
163 else {
164 if (strict) {
165 Perl_die(aTHX_
166 PL_no_symref_sv,
167 sv,
168 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
169 "a symbol"
170 );
171 }
172 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
173 == OPpDONT_INIT_GV) {
174 /* We are the target of a coderef assignment. Return
175 the scalar unchanged, and let pp_sasssign deal with
176 things. */
177 return sv;
178 }
179 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
180 }
181 /* FAKE globs in the symbol table cause weird bugs (#77810) */
182 SvFAKE_off(sv);
183 }
184 }
185 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
186 SV *newsv = sv_newmortal();
187 sv_setsv_flags(newsv, sv, 0);
188 SvFAKE_off(newsv);
189 sv = newsv;
190 }
191 return sv;
192 }
194 PP(pp_rv2gv)
195 {
196 dSP; dTOPss;
198 sv = S_rv2gv(aTHX_
199 sv, PL_op->op_private & OPpDEREF,
200 PL_op->op_private & HINT_STRICT_REFS,
201 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
202 || PL_op->op_type == OP_READLINE
203 );
204 if (PL_op->op_private & OPpLVAL_INTRO)
205 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
206 SETs(sv);
207 RETURN;
208 }
210 /* Helper function for pp_rv2sv and pp_rv2av */
211 GV *
212 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
213 const svtype type, SV ***spp)
214 {
215 GV *gv;
217 PERL_ARGS_ASSERT_SOFTREF2XV;
219 if (PL_op->op_private & HINT_STRICT_REFS) {
220 if (SvOK(sv))
221 Perl_die(aTHX_ PL_no_symref_sv, sv,
222 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
223 else
224 Perl_die(aTHX_ PL_no_usym, what);
225 }
226 if (!SvOK(sv)) {
227 if (
228 PL_op->op_flags & OPf_REF
229 )
230 Perl_die(aTHX_ PL_no_usym, what);
231 if (ckWARN(WARN_UNINITIALIZED))
232 report_uninit(sv);
233 if (type != SVt_PV && GIMME_V == G_ARRAY) {
234 (*spp)--;
235 return NULL;
236 }
237 **spp = &PL_sv_undef;
238 return NULL;
239 }
240 if ((PL_op->op_flags & OPf_SPECIAL) &&
241 !(PL_op->op_flags & OPf_MOD))
242 {
243 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
244 {
245 **spp = &PL_sv_undef;
246 return NULL;
247 }
248 }
249 else {
250 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
251 }
252 return gv;
253 }
255 PP(pp_rv2sv)
256 {
257 dSP; dTOPss;
258 GV *gv = NULL;
260 SvGETMAGIC(sv);
261 if (SvROK(sv)) {
262 if (SvAMAGIC(sv)) {
263 sv = amagic_deref_call(sv, to_sv_amg);
264 }
266 sv = SvRV(sv);
267 if (SvTYPE(sv) >= SVt_PVAV)
268 DIE(aTHX_ "Not a SCALAR reference");
269 }
270 else {
271 gv = MUTABLE_GV(sv);
273 if (!isGV_with_GP(gv)) {
274 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
275 if (!gv)
276 RETURN;
277 }
278 sv = GvSVn(gv);
279 }
280 if (PL_op->op_flags & OPf_MOD) {
281 if (PL_op->op_private & OPpLVAL_INTRO) {
282 if (cUNOP->op_first->op_type == OP_NULL)
283 sv = save_scalar(MUTABLE_GV(TOPs));
284 else if (gv)
285 sv = save_scalar(gv);
286 else
287 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
288 }
289 else if (PL_op->op_private & OPpDEREF)
290 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
291 }
292 SPAGAIN; /* in case chasing soft refs reallocated the stack */
293 SETs(sv);
294 RETURN;
295 }
297 PP(pp_av2arylen)
298 {
299 dSP;
300 AV * const av = MUTABLE_AV(TOPs);
301 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
302 if (lvalue) {
303 SV ** const svp = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
304 if (!*svp) {
305 *svp = newSV_type(SVt_PVMG);
306 sv_magic(*svp, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
307 }
308 SETs(*svp);
309 } else {
310 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
311 }
312 RETURN;
313 }
315 PP(pp_pos)
316 {
317 dSP; dTOPss;
319 if (PL_op->op_flags & OPf_MOD || LVRET) {
320 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
321 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
322 LvTYPE(ret) = '.';
323 LvTARG(ret) = SvREFCNT_inc_simple(sv);
324 SETs(ret); /* no SvSETMAGIC */
325 }
326 else {
327 const MAGIC * const mg = mg_find_mglob(sv);
328 if (mg && mg->mg_len != -1) {
329 STRLEN i = mg->mg_len;
330 if (PL_op->op_private & OPpTRUEBOOL)
331 SETs(i ? &PL_sv_yes : &PL_sv_zero);
332 else {
333 dTARGET;
334 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
335 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
336 SETu(i);
337 }
338 return NORMAL;
339 }
340 SETs(&PL_sv_undef);
341 }
342 return NORMAL;
343 }
345 PP(pp_rv2cv)
346 {
347 dSP;
348 GV *gv;
349 HV *stash_unused;
350 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
351 ? GV_ADDMG
352 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
353 == OPpMAY_RETURN_CONSTANT)
354 ? GV_ADD|GV_NOEXPAND
355 : GV_ADD;
356 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
357 /* (But not in defined().) */
359 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
360 if (cv) NOOP;
361 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
362 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
363 ? MUTABLE_CV(SvRV(gv))
364 : MUTABLE_CV(gv);
365 }
366 else
367 cv = MUTABLE_CV(&PL_sv_undef);
368 SETs(MUTABLE_SV(cv));
369 return NORMAL;
370 }
372 PP(pp_prototype)
373 {
374 dSP;
375 CV *cv;
376 HV *stash;
377 GV *gv;
378 SV *ret = &PL_sv_undef;
380 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
381 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
382 const char * s = SvPVX_const(TOPs);
383 if (memBEGINs(s, SvCUR(TOPs), "CORE::")) {
384 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
385 if (!code)
386 DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
387 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
388 {
389 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
390 if (sv) ret = sv;
391 }
392 goto set;
393 }
394 }
395 cv = sv_2cv(TOPs, &stash, &gv, 0);
396 if (cv && SvPOK(cv))
397 ret = newSVpvn_flags(
398 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
399 );
400 set:
401 SETs(ret);
402 RETURN;
403 }
405 PP(pp_anoncode)
406 {
407 dSP;
408 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
409 if (CvCLONE(cv))
410 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
411 EXTEND(SP,1);
412 PUSHs(MUTABLE_SV(cv));
413 RETURN;
414 }
416 PP(pp_srefgen)
417 {
418 dSP;
419 *SP = refto(*SP);
420 return NORMAL;
421 }
423 PP(pp_refgen)
424 {
425 dSP; dMARK;
426 if (GIMME_V != G_ARRAY) {
427 if (++MARK <= SP)
428 *MARK = *SP;
429 else
430 {
431 MEXTEND(SP, 1);
432 *MARK = &PL_sv_undef;
433 }
434 *MARK = refto(*MARK);
435 SP = MARK;
436 RETURN;
437 }
438 EXTEND_MORTAL(SP - MARK);
439 while (++MARK <= SP)
440 *MARK = refto(*MARK);
441 RETURN;
442 }
444 STATIC SV*
445 S_refto(pTHX_ SV *sv)
446 {
447 SV* rv;
449 PERL_ARGS_ASSERT_REFTO;
451 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
452 if (LvTARGLEN(sv))
453 vivify_defelem(sv);
454 if (!(sv = LvTARG(sv)))
455 sv = &PL_sv_undef;
456 else
457 SvREFCNT_inc_void_NN(sv);
458 }
459 else if (SvTYPE(sv) == SVt_PVAV) {
460 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
461 av_reify(MUTABLE_AV(sv));
462 SvTEMP_off(sv);
463 SvREFCNT_inc_void_NN(sv);
464 }
465 else if (SvPADTMP(sv)) {
466 sv = newSVsv(sv);
467 }
468 else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem)))
469 sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem);
470 else {
471 SvTEMP_off(sv);
472 SvREFCNT_inc_void_NN(sv);
473 }
474 rv = sv_newmortal();
475 sv_upgrade(rv, SVt_IV);
476 SvRV_set(rv, sv);
477 SvROK_on(rv);
478 return rv;
479 }
481 PP(pp_ref)
482 {
483 dSP;
484 SV * const sv = TOPs;
486 SvGETMAGIC(sv);
487 if (!SvROK(sv)) {
488 SETs(&PL_sv_no);
489 return NORMAL;
490 }
492 /* op is in boolean context? */
493 if ( (PL_op->op_private & OPpTRUEBOOL)
494 || ( (PL_op->op_private & OPpMAYBE_TRUEBOOL)
495 && block_gimme() == G_VOID))
496 {
497 /* refs are always true - unless it's to an object blessed into a
498 * class with a false name, i.e. "0". So we have to check for
499 * that remote possibility. The following is is basically an
500 * unrolled SvTRUE(sv_reftype(rv)) */
501 SV * const rv = SvRV(sv);
502 if (SvOBJECT(rv)) {
503 HV *stash = SvSTASH(rv);
504 HEK *hek = HvNAME_HEK(stash);
505 if (hek) {
506 I32 len = HEK_LEN(hek);
507 /* bail out and do it the hard way? */
508 if (UNLIKELY(
509 len == HEf_SVKEY
510 || (len == 1 && HEK_KEY(hek)[0] == '0')
511 ))
512 goto do_sv_ref;
513 }
514 }
515 SETs(&PL_sv_yes);
516 return NORMAL;
517 }
519 do_sv_ref:
520 {
521 dTARGET;
522 SETs(TARG);
523 sv_ref(TARG, SvRV(sv), TRUE);
524 SvSETMAGIC(TARG);
525 return NORMAL;
526 }
528 }
531 PP(pp_bless)
532 {
533 dSP;
534 HV *stash;
536 if (MAXARG == 1)
537 {
538 curstash:
539 stash = CopSTASH(PL_curcop);
540 if (SvTYPE(stash) != SVt_PVHV)
541 Perl_croak(aTHX_ "Attempt to bless into a freed package");
542 }
543 else {
544 SV * const ssv = POPs;
545 STRLEN len;
546 const char *ptr;
548 if (!ssv) goto curstash;
549 SvGETMAGIC(ssv);
550 if (SvROK(ssv)) {
551 if (!SvAMAGIC(ssv)) {
552 frog:
553 Perl_croak(aTHX_ "Attempt to bless into a reference");
554 }
555 /* SvAMAGIC is on here, but it only means potentially overloaded,
556 so after stringification: */
557 ptr = SvPV_nomg_const(ssv,len);
558 /* We need to check the flag again: */
559 if (!SvAMAGIC(ssv)) goto frog;
560 }
561 else ptr = SvPV_nomg_const(ssv,len);
562 if (len == 0)
563 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
564 "Explicit blessing to '' (assuming package main)");
565 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
566 }
568 (void)sv_bless(TOPs, stash);
569 RETURN;
570 }
572 PP(pp_gelem)
573 {
574 dSP;
576 SV *sv = POPs;
577 STRLEN len;
578 const char * const elem = SvPV_const(sv, len);
579 GV * const gv = MUTABLE_GV(TOPs);
580 SV * tmpRef = NULL;
582 sv = NULL;
583 if (elem) {
584 /* elem will always be NUL terminated. */
585 switch (*elem) {
586 case 'A':
587 if (memEQs(elem, len, "ARRAY"))
588 {
589 tmpRef = MUTABLE_SV(GvAV(gv));
590 if (tmpRef && !AvREAL((const AV *)tmpRef)
591 && AvREIFY((const AV *)tmpRef))
592 av_reify(MUTABLE_AV(tmpRef));
593 }
594 break;
595 case 'C':
596 if (memEQs(elem, len, "CODE"))
597 tmpRef = MUTABLE_SV(GvCVu(gv));
598 break;
599 case 'F':
600 if (memEQs(elem, len, "FILEHANDLE")) {
601 tmpRef = MUTABLE_SV(GvIOp(gv));
602 }
603 else
604 if (memEQs(elem, len, "FORMAT"))
605 tmpRef = MUTABLE_SV(GvFORM(gv));
606 break;
607 case 'G':
608 if (memEQs(elem, len, "GLOB"))
609 tmpRef = MUTABLE_SV(gv);
610 break;
611 case 'H':
612 if (memEQs(elem, len, "HASH"))
613 tmpRef = MUTABLE_SV(GvHV(gv));
614 break;
615 case 'I':
616 if (memEQs(elem, len, "IO"))
617 tmpRef = MUTABLE_SV(GvIOp(gv));
618 break;
619 case 'N':
620 if (memEQs(elem, len, "NAME"))
621 sv = newSVhek(GvNAME_HEK(gv));
622 break;
623 case 'P':
624 if (memEQs(elem, len, "PACKAGE")) {
625 const HV * const stash = GvSTASH(gv);
626 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
627 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
628 }
629 break;
630 case 'S':
631 if (memEQs(elem, len, "SCALAR"))
632 tmpRef = GvSVn(gv);
633 break;
634 }
635 }
636 if (tmpRef)
637 sv = newRV(tmpRef);
638 if (sv)
639 sv_2mortal(sv);
640 else
641 sv = &PL_sv_undef;
642 SETs(sv);
643 RETURN;
644 }
646 /* Pattern matching */
648 PP(pp_study)
649 {
650 dSP; dTOPss;
651 STRLEN len;
653 (void)SvPV(sv, len);
654 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
655 /* Historically, study was skipped in these cases. */
656 SETs(&PL_sv_no);
657 return NORMAL;
658 }
660 /* Make study a no-op. It's no longer useful and its existence
661 complicates matters elsewhere. */
662 SETs(&PL_sv_yes);
663 return NORMAL;
664 }
667 /* also used for: pp_transr() */
669 PP(pp_trans)
670 {
671 dSP;
672 SV *sv;
674 if (PL_op->op_flags & OPf_STACKED)
675 sv = POPs;
676 else {
677 EXTEND(SP,1);
678 if (ARGTARG)
679 sv = PAD_SV(ARGTARG);
680 else {
681 sv = DEFSV;
682 }
683 }
684 if(PL_op->op_type == OP_TRANSR) {
685 STRLEN len;
686 const char * const pv = SvPV(sv,len);
687 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
688 do_trans(newsv);
689 PUSHs(newsv);
690 }
691 else {
692 Size_t i = do_trans(sv);
693 mPUSHi((UV)i);
694 }
695 RETURN;
696 }
698 /* Lvalue operators. */
700 static size_t
701 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
702 {
703 STRLEN len;
704 char *s;
705 size_t count = 0;
707 PERL_ARGS_ASSERT_DO_CHOMP;
709 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
710 return 0;
711 if (SvTYPE(sv) == SVt_PVAV) {
712 I32 i;
713 AV *const av = MUTABLE_AV(sv);
714 const I32 max = AvFILL(av);
716 for (i = 0; i <= max; i++) {
717 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
718 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
719 count += do_chomp(retval, sv, chomping);
720 }
721 return count;
722 }
723 else if (SvTYPE(sv) == SVt_PVHV) {
724 HV* const hv = MUTABLE_HV(sv);
725 HE* entry;
726 (void)hv_iterinit(hv);
727 while ((entry = hv_iternext(hv)))
728 count += do_chomp(retval, hv_iterval(hv,entry), chomping);
729 return count;
730 }
731 else if (SvREADONLY(sv)) {
732 Perl_croak_no_modify();
733 }
735 s = SvPV(sv, len);
736 if (chomping) {
737 if (s && len) {
738 char *temp_buffer = NULL;
739 SV *svrecode = NULL;
740 s += --len;
741 if (RsPARA(PL_rs)) {
742 if (*s != '\n')
743 goto nope_free_nothing;
744 ++count;
745 while (len && s[-1] == '\n') {
746 --len;
747 --s;
748 ++count;
749 }
750 }
751 else {
752 STRLEN rslen, rs_charlen;
753 const char *rsptr = SvPV_const(PL_rs, rslen);
755 rs_charlen = SvUTF8(PL_rs)
756 ? sv_len_utf8(PL_rs)
757 : rslen;
759 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
760 /* Assumption is that rs is shorter than the scalar. */
761 if (SvUTF8(PL_rs)) {
762 /* RS is utf8, scalar is 8 bit. */
763 bool is_utf8 = TRUE;
764 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
765 &rslen, &is_utf8);
766 if (is_utf8) {
767 /* Cannot downgrade, therefore cannot possibly match.
768 At this point, temp_buffer is not alloced, and
769 is the buffer inside PL_rs, so dont free it.
770 */
771 assert (temp_buffer == rsptr);
772 goto nope_free_sv;
773 }
774 rsptr = temp_buffer;
775 }
776 else {
777 /* RS is 8 bit, scalar is utf8. */
778 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
779 rsptr = temp_buffer;
780 }
781 }
782 if (rslen == 1) {
783 if (*s != *rsptr)
784 goto nope_free_all;
785 ++count;
786 }
787 else {
788 if (len < rslen - 1)
789 goto nope_free_all;
790 len -= rslen - 1;
791 s -= rslen - 1;
792 if (memNE(s, rsptr, rslen))
793 goto nope_free_all;
794 count += rs_charlen;
795 }
796 }
797 SvPV_force_nomg_nolen(sv);
798 SvCUR_set(sv, len);
799 *SvEND(sv) = '\0';
800 SvNIOK_off(sv);
801 SvSETMAGIC(sv);
803 nope_free_all:
804 Safefree(temp_buffer);
805 nope_free_sv:
806 SvREFCNT_dec(svrecode);
807 nope_free_nothing: ;
808 }
809 } else {
810 if (len && (!SvPOK(sv) || SvIsCOW(sv)))
811 s = SvPV_force_nomg(sv, len);
812 if (DO_UTF8(sv)) {
813 if (s && len) {
814 char * const send = s + len;
815 char * const start = s;
816 s = send - 1;
817 while (s > start && UTF8_IS_CONTINUATION(*s))
818 s--;
819 if (is_utf8_string((U8*)s, send - s)) {
820 sv_setpvn(retval, s, send - s);
821 *s = '\0';
822 SvCUR_set(sv, s - start);
823 SvNIOK_off(sv);
824 SvUTF8_on(retval);
825 }
826 }
827 else
828 SvPVCLEAR(retval);
829 }
830 else if (s && len) {
831 s += --len;
832 sv_setpvn(retval, s, 1);
833 *s = '\0';
834 SvCUR_set(sv, len);
835 SvUTF8_off(sv);
836 SvNIOK_off(sv);
837 }
838 else
839 SvPVCLEAR(retval);
840 SvSETMAGIC(sv);
841 }
842 return count;
843 }
846 /* also used for: pp_schomp() */
848 PP(pp_schop)
849 {
850 dSP; dTARGET;
851 const bool chomping = PL_op->op_type == OP_SCHOMP;
853 const size_t count = do_chomp(TARG, TOPs, chomping);
854 if (chomping)
855 sv_setiv(TARG, count);
856 SETTARG;
857 return NORMAL;
858 }
861 /* also used for: pp_chomp() */
863 PP(pp_chop)
864 {
865 dSP; dMARK; dTARGET; dORIGMARK;
866 const bool chomping = PL_op->op_type == OP_CHOMP;
867 size_t count = 0;
869 while (MARK < SP)
870 count += do_chomp(TARG, *++MARK, chomping);
871 if (chomping)
872 sv_setiv(TARG, count);
873 SP = ORIGMARK;
874 XPUSHTARG;
875 RETURN;
876 }
878 PP(pp_undef)
879 {
880 dSP;
881 SV *sv;
883 if (!PL_op->op_private) {
884 EXTEND(SP, 1);
885 RETPUSHUNDEF;
886 }
888 sv = TOPs;
889 if (!sv)
890 {
891 SETs(&PL_sv_undef);
892 return NORMAL;
893 }
895 if (SvTHINKFIRST(sv))
896 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
898 switch (SvTYPE(sv)) {
899 case SVt_NULL:
900 break;
901 case SVt_PVAV:
902 av_undef(MUTABLE_AV(sv));
903 break;
904 case SVt_PVHV:
905 hv_undef(MUTABLE_HV(sv));
906 break;
907 case SVt_PVCV:
908 if (cv_const_sv((const CV *)sv))
909 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
910 "Constant subroutine %" SVf " undefined",
911 SVfARG(CvANON((const CV *)sv)
912 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
913 : sv_2mortal(newSVhek(
914 CvNAMED(sv)
915 ? CvNAME_HEK((CV *)sv)
916 : GvENAME_HEK(CvGV((const CV *)sv))
917 ))
918 ));
919 /* FALLTHROUGH */
920 case SVt_PVFM:
921 /* let user-undef'd sub keep its identity */
922 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
923 break;
924 case SVt_PVGV:
925 assert(isGV_with_GP(sv));
926 assert(!SvFAKE(sv));
927 {
928 GP *gp;
929 HV *stash;
931 /* undef *Pkg::meth_name ... */
932 bool method_changed
933 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
934 && HvENAME_get(stash);
935 /* undef *Foo:: */
936 if((stash = GvHV((const GV *)sv))) {
937 if(HvENAME_get(stash))
938 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
939 else stash = NULL;
940 }
942 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
943 gp_free(MUTABLE_GV(sv));
944 Newxz(gp, 1, GP);
945 GvGP_set(sv, gp_ref(gp));
946 #ifndef PERL_DONT_CREATE_GVSV
947 GvSV(sv) = newSV(0);
948 #endif
949 GvLINE(sv) = CopLINE(PL_curcop);
950 GvEGV(sv) = MUTABLE_GV(sv);
951 GvMULTI_on(sv);
953 if(stash)
954 mro_package_moved(NULL, stash, (const GV *)sv, 0);
955 stash = NULL;
956 /* undef *Foo::ISA */
957 if( strEQ(GvNAME((const GV *)sv), "ISA")
958 && (stash = GvSTASH((const GV *)sv))
959 && (method_changed || HvENAME(stash)) )
960 mro_isa_changed_in(stash);
961 else if(method_changed)
962 mro_method_changed_in(
963 GvSTASH((const GV *)sv)
964 );
966 break;
967 }
968 default:
969 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
970 SvPV_free(sv);
971 SvPV_set(sv, NULL);
972 SvLEN_set(sv, 0);
973 }
974 SvOK_off(sv);
975 SvSETMAGIC(sv);
976 }
978 SETs(&PL_sv_undef);
979 return NORMAL;
980 }
983 /* common "slow" code for pp_postinc and pp_postdec */
985 static OP *
986 S_postincdec_common(pTHX_ SV *sv, SV *targ)
987 {
988 dSP;
989 const bool inc =
990 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
992 if (SvROK(sv))
993 TARG = sv_newmortal();
994 sv_setsv(TARG, sv);
995 if (inc)
996 sv_inc_nomg(sv);
997 else
998 sv_dec_nomg(sv);
999 SvSETMAGIC(sv);
1000 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1001 if (inc && !SvOK(TARG))
1002 sv_setiv(TARG, 0);
1003 SETTARG;
1004 return NORMAL;
1005 }
1008 /* also used for: pp_i_postinc() */
1010 PP(pp_postinc)
1011 {
1012 dSP; dTARGET;
1013 SV *sv = TOPs;
1015 /* special-case sv being a simple integer */
1016 if (LIKELY(((sv->sv_flags &
1017 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1018 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1019 == SVf_IOK))
1020 && SvIVX(sv) != IV_MAX)
1021 {
1022 IV iv = SvIVX(sv);
1023 SvIV_set(sv, iv + 1);
1024 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1025 SETs(TARG);
1026 return NORMAL;
1027 }
1029 return S_postincdec_common(aTHX_ sv, TARG);
1030 }
1033 /* also used for: pp_i_postdec() */
1035 PP(pp_postdec)
1036 {
1037 dSP; dTARGET;
1038 SV *sv = TOPs;
1040 /* special-case sv being a simple integer */
1041 if (LIKELY(((sv->sv_flags &
1042 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
1043 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
1044 == SVf_IOK))
1045 && SvIVX(sv) != IV_MIN)
1046 {
1047 IV iv = SvIVX(sv);
1048 SvIV_set(sv, iv - 1);
1049 TARGi(iv, 0); /* arg not GMG, so can't be tainted */
1050 SETs(TARG);
1051 return NORMAL;
1052 }
1054 return S_postincdec_common(aTHX_ sv, TARG);
1055 }
1058 /* Ordinary operators. */
1060 PP(pp_pow)
1061 {
1062 dSP; dATARGET; SV *svl, *svr;
1063 #ifdef PERL_PRESERVE_IVUV
1064 bool is_int = 0;
1065 #endif
1066 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1067 svr = TOPs;
1068 svl = TOPm1s;
1069 #ifdef PERL_PRESERVE_IVUV
1070 /* For integer to integer power, we do the calculation by hand wherever
1071 we're sure it is safe; otherwise we call pow() and try to convert to
1072 integer afterwards. */
1073 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1074 UV power;
1075 bool baseuok;
1076 UV baseuv;
1078 if (SvUOK(svr)) {
1079 power = SvUVX(svr);
1080 } else {
1081 const IV iv = SvIVX(svr);
1082 if (iv >= 0) {
1083 power = iv;
1084 } else {
1085 goto float_it; /* Can't do negative powers this way. */
1086 }
1087 }
1089 baseuok = SvUOK(svl);
1090 if (baseuok) {
1091 baseuv = SvUVX(svl);
1092 } else {
1093 const IV iv = SvIVX(svl);
1094 if (iv >= 0) {
1095 baseuv = iv;
1096 baseuok = TRUE; /* effectively it's a UV now */
1097 } else {
1098 baseuv = -iv; /* abs, baseuok == false records sign */
1099 }
1100 }
1101 /* now we have integer ** positive integer. */
1102 is_int = 1;
1104 /* foo & (foo - 1) is zero only for a power of 2. */
1105 if (!(baseuv & (baseuv - 1))) {
1106 /* We are raising power-of-2 to a positive integer.
1107 The logic here will work for any base (even non-integer
1108 bases) but it can be less accurate than
1109 pow (base,power) or exp (power * log (base)) when the
1110 intermediate values start to spill out of the mantissa.
1111 With powers of 2 we know this can't happen.
1112 And powers of 2 are the favourite thing for perl
1113 programmers to notice ** not doing what they mean. */
1114 NV result = 1.0;
1115 NV base = baseuok ? baseuv : -(NV)baseuv;
1117 if (power & 1) {
1118 result *= base;
1119 }
1120 while (power >>= 1) {
1121 base *= base;
1122 if (power & 1) {
1123 result *= base;
1124 }
1125 }
1126 SP--;
1127 SETn( result );
1128 SvIV_please_nomg(svr);
1129 RETURN;
1130 } else {
1131 unsigned int highbit = 8 * sizeof(UV);
1132 unsigned int diff = 8 * sizeof(UV);
1133 while (diff >>= 1) {
1134 highbit -= diff;
1135 if (baseuv >> highbit) {
1136 highbit += diff;
1137 }
1138 }
1139 /* we now have baseuv < 2 ** highbit */
1140 if (power * highbit <= 8 * sizeof(UV)) {
1141 /* result will definitely fit in UV, so use UV math
1142 on same algorithm as above */
1143 UV result = 1;
1144 UV base = baseuv;
1145 const bool odd_power = cBOOL(power & 1);
1146 if (odd_power) {
1147 result *= base;
1148 }
1149 while (power >>= 1) {
1150 base *= base;
1151 if (power & 1) {
1152 result *= base;
1153 }
1154 }
1155 SP--;
1156 if (baseuok || !odd_power)
1157 /* answer is positive */
1158 SETu( result );
1159 else if (result <= (UV)IV_MAX)
1160 /* answer negative, fits in IV */
1161 SETi( -(IV)result );
1162 else if (result == (UV)IV_MIN)
1163 /* 2's complement assumption: special case IV_MIN */
1164 SETi( IV_MIN );
1165 else
1166 /* answer negative, doesn't fit */
1167 SETn( -(NV)result );
1168 RETURN;
1169 }
1170 }
1171 }
1172 float_it:
1173 #endif
1174 {
1175 NV right = SvNV_nomg(svr);
1176 NV left = SvNV_nomg(svl);
1177 (void)POPs;
1179 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1180 /*
1181 We are building perl with long double support and are on an AIX OS
1182 afflicted with a powl() function that wrongly returns NaNQ for any
1183 negative base. This was reported to IBM as PMR #23047-379 on
1184 03/06/2006. The problem exists in at least the following versions
1185 of AIX and the libm fileset, and no doubt others as well:
1187 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1188 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1189 AIX 5.2.0 bos.adt.libm 5.2.0.85
1191 So, until IBM fixes powl(), we provide the following workaround to
1192 handle the problem ourselves. Our logic is as follows: for
1193 negative bases (left), we use fmod(right, 2) to check if the
1194 exponent is an odd or even integer:
1196 - if odd, powl(left, right) == -powl(-left, right)
1197 - if even, powl(left, right) == powl(-left, right)
1199 If the exponent is not an integer, the result is rightly NaNQ, so
1200 we just return that (as NV_NAN).
1201 */
1203 if (left < 0.0) {
1204 NV mod2 = Perl_fmod( right, 2.0 );
1205 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1206 SETn( -Perl_pow( -left, right) );
1207 } else if (mod2 == 0.0) { /* even integer */
1208 SETn( Perl_pow( -left, right) );
1209 } else { /* fractional power */
1210 SETn( NV_NAN );
1211 }
1212 } else {
1213 SETn( Perl_pow( left, right) );
1214 }
1215 #else
1216 SETn( Perl_pow( left, right) );
1217 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1219 #ifdef PERL_PRESERVE_IVUV
1220 if (is_int)
1221 SvIV_please_nomg(svr);
1222 #endif
1223 RETURN;
1224 }
1225 }
1227 PP(pp_multiply)
1228 {
1229 dSP; dATARGET; SV *svl, *svr;
1230 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1231 svr = TOPs;
1232 svl = TOPm1s;
1234 #ifdef PERL_PRESERVE_IVUV
1236 /* special-case some simple common cases */
1237 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1238 IV il, ir;
1239 U32 flags = (svl->sv_flags & svr->sv_flags);
1240 if (flags & SVf_IOK) {
1241 /* both args are simple IVs */
1242 UV topl, topr;
1243 il = SvIVX(svl);
1244 ir = SvIVX(svr);
1245 do_iv:
1246 topl = ((UV)il) >> (UVSIZE * 4 - 1);
1247 topr = ((UV)ir) >> (UVSIZE * 4 - 1);
1249 /* if both are in a range that can't under/overflow, do a
1250 * simple integer multiply: if the top halves(*) of both numbers
1251 * are 00...00 or 11...11, then it's safe.
1252 * (*) for 32-bits, the "top half" is the top 17 bits,
1253 * for 64-bits, its 33 bits */
1254 if (!(
1255 ((topl+1) | (topr+1))
1256 & ( (((UV)1) << (UVSIZE * 4 + 1)) - 2) /* 11..110 */
1257 )) {
1258 SP--;
1259 TARGi(il * ir, 0); /* args not GMG, so can't be tainted */
1260 SETs(TARG);
1261 RETURN;
1262 }
1263 goto generic;
1264 }
1265 else if (flags & SVf_NOK) {
1266 /* both args are NVs */
1267 NV nl = SvNVX(svl);
1268 NV nr = SvNVX(svr);
1269 NV result;
1271 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1272 /* nothing was lost by converting to IVs */
1273 goto do_iv;
1274 }
1275 SP--;
1276 result = nl * nr;
1277 # if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1278 if (Perl_isinf(result)) {
1279 Zero((U8*)&result + 8, 8, U8);
1280 }
1281 # endif
1282 TARGn(result, 0); /* args not GMG, so can't be tainted */
1283 SETs(TARG);
1284 RETURN;
1285 }
1286 }
1288 generic:
1290 if (SvIV_please_nomg(svr)) {
1291 /* Unless the left argument is integer in range we are going to have to
1292 use NV maths. Hence only attempt to coerce the right argument if
1293 we know the left is integer. */
1294 /* Left operand is defined, so is it IV? */
1295 if (SvIV_please_nomg(svl)) {
1296 bool auvok = SvUOK(svl);
1297 bool buvok = SvUOK(svr);
1298 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1299 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1300 UV alow;
1301 UV ahigh;
1302 UV blow;
1303 UV bhigh;
1305 if (auvok) {
1306 alow = SvUVX(svl);
1307 } else {
1308 const IV aiv = SvIVX(svl);
1309 if (aiv >= 0) {
1310 alow = aiv;
1311 auvok = TRUE; /* effectively it's a UV now */
1312 } else {
1313 /* abs, auvok == false records sign; Using 0- here and
1314 * later to silence bogus warning from MS VC */
1315 alow = (UV) (0 - (UV) aiv);
1316 }
1317 }
1318 if (buvok) {
1319 blow = SvUVX(svr);
1320 } else {
1321 const IV biv = SvIVX(svr);
1322 if (biv >= 0) {
1323 blow = biv;
1324 buvok = TRUE; /* effectively it's a UV now */
1325 } else {
1326 /* abs, buvok == false records sign */
1327 blow = (UV) (0 - (UV) biv);
1328 }
1329 }
1331 /* If this does sign extension on unsigned it's time for plan B */
1332 ahigh = alow >> (4 * sizeof (UV));
1333 alow &= botmask;
1334 bhigh = blow >> (4 * sizeof (UV));
1335 blow &= botmask;
1336 if (ahigh && bhigh) {
1337 NOOP;
1338 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1339 which is overflow. Drop to NVs below. */
1340 } else if (!ahigh && !bhigh) {
1341 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1342 so the unsigned multiply cannot overflow. */
1343 const UV product = alow * blow;
1344 if (auvok == buvok) {
1345 /* -ve * -ve or +ve * +ve gives a +ve result. */
1346 SP--;
1347 SETu( product );
1348 RETURN;
1349 } else if (product <= (UV)IV_MIN) {
1350 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1351 /* -ve result, which could overflow an IV */
1352 SP--;
1353 /* can't negate IV_MIN, but there are aren't two
1354 * integers such that !ahigh && !bhigh, where the
1355 * product equals 0x800....000 */
1356 assert(product != (UV)IV_MIN);
1357 SETi( -(IV)product );
1358 RETURN;
1359 } /* else drop to NVs below. */
1360 } else {
1361 /* One operand is large, 1 small */
1362 UV product_middle;
1363 if (bhigh) {
1364 /* swap the operands */
1365 ahigh = bhigh;
1366 bhigh = blow; /* bhigh now the temp var for the swap */
1367 blow = alow;
1368 alow = bhigh;
1369 }
1370 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1371 multiplies can't overflow. shift can, add can, -ve can. */
1372 product_middle = ahigh * blow;
1373 if (!(product_middle & topmask)) {
1374 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1375 UV product_low;
1376 product_middle <<= (4 * sizeof (UV));
1377 product_low = alow * blow;
1379 /* as for pp_add, UV + something mustn't get smaller.
1380 IIRC ANSI mandates this wrapping *behaviour* for
1381 unsigned whatever the actual representation*/
1382 product_low += product_middle;
1383 if (product_low >= product_middle) {
1384 /* didn't overflow */
1385 if (auvok == buvok) {
1386 /* -ve * -ve or +ve * +ve gives a +ve result. */
1387 SP--;
1388 SETu( product_low );
1389 RETURN;
1390 } else if (product_low <= (UV)IV_MIN) {
1391 /* 2s complement assumption again */
1392 /* -ve result, which could overflow an IV */
1393 SP--;
1394 SETi(product_low == (UV)IV_MIN
1395 ? IV_MIN : -(IV)product_low);
1396 RETURN;
1397 } /* else drop to NVs below. */
1398 }
1399 } /* product_middle too large */
1400 } /* ahigh && bhigh */
1401 } /* SvIOK(svl) */
1402 } /* SvIOK(svr) */
1403 #endif
1404 {
1405 NV right = SvNV_nomg(svr);
1406 NV left = SvNV_nomg(svl);
1407 NV result = left * right;
1409 (void)POPs;
1410 #if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BE_BE && NVSIZE == 16
1411 if (Perl_isinf(result)) {
1412 Zero((U8*)&result + 8, 8, U8);
1413 }
1414 #endif
1415 SETn(result);
1416 RETURN;
1417 }
1418 }
1420 PP(pp_divide)
1421 {
1422 dSP; dATARGET; SV *svl, *svr;
1423 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1424 svr = TOPs;
1425 svl = TOPm1s;
1426 /* Only try to do UV divide first
1427 if ((SLOPPYDIVIDE is true) or
1428 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1429 to preserve))
1430 The assumption is that it is better to use floating point divide
1431 whenever possible, only doing integer divide first if we can't be sure.
1432 If NV_PRESERVES_UV is true then we know at compile time that no UV
1433 can be too large to preserve, so don't need to compile the code to
1434 test the size of UVs. */
1436 #if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
1437 # define PERL_TRY_UV_DIVIDE
1438 /* ensure that 20./5. == 4. */
1439 #endif
1441 #ifdef PERL_TRY_UV_DIVIDE
1442 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1443 bool left_non_neg = SvUOK(svl);
1444 bool right_non_neg = SvUOK(svr);
1445 UV left;
1446 UV right;
1448 if (right_non_neg) {
1449 right = SvUVX(svr);
1450 }
1451 else {
1452 const IV biv = SvIVX(svr);
1453 if (biv >= 0) {
1454 right = biv;
1455 right_non_neg = TRUE; /* effectively it's a UV now */
1456 }
1457 else {
1458 right = -(UV)biv;
1459 }
1460 }
1461 /* historically undef()/0 gives a "Use of uninitialized value"
1462 warning before dieing, hence this test goes here.
1463 If it were immediately before the second SvIV_please, then
1464 DIE() would be invoked before left was even inspected, so
1465 no inspection would give no warning. */
1466 if (right == 0)
1467 DIE(aTHX_ "Illegal division by zero");
1469 if (left_non_neg) {
1470 left = SvUVX(svl);
1471 }
1472 else {
1473 const IV aiv = SvIVX(svl);
1474 if (aiv >= 0) {
1475 left = aiv;
1476 left_non_neg = TRUE; /* effectively it's a UV now */
1477 }
1478 else {
1479 left = -(UV)aiv;
1480 }
1481 }
1483 if (left >= right
1484 #ifdef SLOPPYDIVIDE
1485 /* For sloppy divide we always attempt integer division. */
1486 #else
1487 /* Otherwise we only attempt it if either or both operands
1488 would not be preserved by an NV. If both fit in NVs
1489 we fall through to the NV divide code below. However,
1490 as left >= right to ensure integer result here, we know that
1491 we can skip the test on the right operand - right big
1492 enough not to be preserved can't get here unless left is
1493 also too big. */
1495 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1496 #endif
1497 ) {
1498 /* Integer division can't overflow, but it can be imprecise. */
1500 /* Modern compilers optimize division followed by
1501 * modulo into a single div instruction */
1502 const UV result = left / right;
1503 if (left % right == 0) {
1504 SP--; /* result is valid */
1505 if (left_non_neg == right_non_neg) {
1506 /* signs identical, result is positive. */
1507 SETu( result );
1508 RETURN;
1509 }
1510 /* 2s complement assumption */
1511 if (result <= (UV)IV_MIN)
1512 SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result);
1513 else {
1514 /* It's exact but too negative for IV. */
1515 SETn( -(NV)result );
1516 }
1517 RETURN;
1518 } /* tried integer divide but it was not an integer result */
1519 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1520 } /* one operand wasn't SvIOK */
1521 #endif /* PERL_TRY_UV_DIVIDE */
1522 {
1523 NV right = SvNV_nomg(svr);
1524 NV left = SvNV_nomg(svl);
1525 (void)POPs;(void)POPs;
1526 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1527 if (! Perl_isnan(right) && right == 0.0)
1528 #else
1529 if (right == 0.0)
1530 #endif
1531 DIE(aTHX_ "Illegal division by zero");
1532 PUSHn( left / right );
1533 RETURN;
1534 }
1535 }
1537 PP(pp_modulo)
1538 {
1539 dSP; dATARGET;
1540 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1541 {
1542 UV left = 0;
1543 UV right = 0;
1544 bool left_neg = FALSE;
1545 bool right_neg = FALSE;
1546 bool use_double = FALSE;
1547 bool dright_valid = FALSE;
1548 NV dright = 0.0;
1549 NV dleft = 0.0;
1550 SV * const svr = TOPs;
1551 SV * const svl = TOPm1s;
1552 if (SvIV_please_nomg(svr)) {
1553 right_neg = !SvUOK(svr);
1554 if (!right_neg) {
1555 right = SvUVX(svr);
1556 } else {
1557 const IV biv = SvIVX(svr);
1558 if (biv >= 0) {
1559 right = biv;
1560 right_neg = FALSE; /* effectively it's a UV now */
1561 } else {
1562 right = (UV) (0 - (UV) biv);
1563 }
1564 }
1565 }
1566 else {
1567 dright = SvNV_nomg(svr);
1568 right_neg = dright < 0;
1569 if (right_neg)
1570 dright = -dright;
1571 if (dright < UV_MAX_P1) {
1572 right = U_V(dright);
1573 dright_valid = TRUE; /* In case we need to use double below. */
1574 } else {
1575 use_double = TRUE;
1576 }
1577 }
1579 /* At this point use_double is only true if right is out of range for
1580 a UV. In range NV has been rounded down to nearest UV and
1581 use_double false. */
1582 if (!use_double && SvIV_please_nomg(svl)) {
1583 left_neg = !SvUOK(svl);
1584 if (!left_neg) {
1585 left = SvUVX(svl);
1586 } else {
1587 const IV aiv = SvIVX(svl);
1588 if (aiv >= 0) {
1589 left = aiv;
1590 left_neg = FALSE; /* effectively it's a UV now */
1591 } else {
1592 left = (UV) (0 - (UV) aiv);
1593 }
1594 }
1595 }
1596 else {
1597 dleft = SvNV_nomg(svl);
1598 left_neg = dleft < 0;
1599 if (left_neg)
1600 dleft = -dleft;
1602 /* This should be exactly the 5.6 behaviour - if left and right are
1603 both in range for UV then use U_V() rather than floor. */
1604 if (!use_double) {
1605 if (dleft < UV_MAX_P1) {
1606 /* right was in range, so is dleft, so use UVs not double.
1607 */
1608 left = U_V(dleft);
1609 }
1610 /* left is out of range for UV, right was in range, so promote
1611 right (back) to double. */
1612 else {
1613 /* The +0.5 is used in 5.6 even though it is not strictly
1614 consistent with the implicit +0 floor in the U_V()
1615 inside the #if 1. */
1616 dleft = Perl_floor(dleft + 0.5);
1617 use_double = TRUE;
1618 if (dright_valid)
1619 dright = Perl_floor(dright + 0.5);
1620 else
1621 dright = right;
1622 }
1623 }
1624 }
1625 sp -= 2;
1626 if (use_double) {
1627 NV dans;
1629 if (!dright)
1630 DIE(aTHX_ "Illegal modulus zero");
1632 dans = Perl_fmod(dleft, dright);
1633 if ((left_neg != right_neg) && dans)
1634 dans = dright - dans;
1635 if (right_neg)
1636 dans = -dans;
1637 sv_setnv(TARG, dans);
1638 }
1639 else {
1640 UV ans;
1642 if (!right)
1643 DIE(aTHX_ "Illegal modulus zero");
1645 ans = left % right;
1646 if ((left_neg != right_neg) && ans)
1647 ans = right - ans;
1648 if (right_neg) {
1649 /* XXX may warn: unary minus operator applied to unsigned type */
1650 /* could change -foo to be (~foo)+1 instead */
1651 if (ans <= ~((UV)IV_MAX)+1)
1652 sv_setiv(TARG, ~ans+1);
1653 else
1654 sv_setnv(TARG, -(NV)ans);
1655 }
1656 else
1657 sv_setuv(TARG, ans);
1658 }
1659 PUSHTARG;
1660 RETURN;
1661 }
1662 }
1664 PP(pp_repeat)
1665 {
1666 dSP; dATARGET;
1667 IV count;
1668 SV *sv;
1669 bool infnan = FALSE;
1670 const U8 gimme = GIMME_V;
1672 if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1673 /* TODO: think of some way of doing list-repeat overloading ??? */
1674 sv = POPs;
1675 SvGETMAGIC(sv);
1676 }
1677 else {
1678 if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
1679 /* The parser saw this as a list repeat, and there
1680 are probably several items on the stack. But we're
1681 in scalar/void context, and there's no pp_list to save us
1682 now. So drop the rest of the items -- robin@kitsite.com
1683 */
1684 dMARK;
1685 if (MARK + 1 < SP) {
1686 MARK[1] = TOPm1s;
1687 MARK[2] = TOPs;
1688 }
1689 else {
1690 dTOPss;
1691 ASSUME(MARK + 1 == SP);
1692 MEXTEND(SP, 1);
1693 PUSHs(sv);
1694 MARK[1] = &PL_sv_undef;
1695 }
1696 SP = MARK + 2;
1697 }
1698 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1699 sv = POPs;
1700 }
1702 if (SvIOKp(sv)) {
1703 if (SvUOK(sv)) {
1704 const UV uv = SvUV_nomg(sv);
1705 if (uv > IV_MAX)
1706 count = IV_MAX; /* The best we can do? */
1707 else
1708 count = uv;
1709 } else {
1710 count = SvIV_nomg(sv);
1711 }
1712 }
1713 else if (SvNOKp(sv)) {
1714 const NV nv = SvNV_nomg(sv);
1715 infnan = Perl_isinfnan(nv);
1716 if (UNLIKELY(infnan)) {
1717 count = 0;
1718 } else {
1719 if (nv < 0.0)
1720 count = -1; /* An arbitrary negative integer */
1721 else
1722 count = (IV)nv;
1723 }
1724 }
1725 else
1726 count = SvIV_nomg(sv);
1728 if (infnan) {
1729 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1730 "Non-finite repeat count does nothing");
1731 } else if (count < 0) {
1732 count = 0;
1733 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1734 "Negative repeat count does nothing");
1735 }
1737 if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1738 dMARK;
1739 const SSize_t items = SP - MARK;
1740 const U8 mod = PL_op->op_flags & OPf_MOD;
1742 if (count > 1) {
1743 SSize_t max;
1745 if ( items > SSize_t_MAX / count /* max would overflow */
1746 /* repeatcpy would overflow */
1747 || items > I32_MAX / (I32)sizeof(SV *)
1748 )
1749 Perl_croak(aTHX_ "%s","Out of memory during list extend");
1750 max = items * count;
1751 MEXTEND(MARK, max);
1753 while (SP > MARK) {
1754 if (*SP) {
1755 if (mod && SvPADTMP(*SP)) {
1756 *SP = sv_mortalcopy(*SP);
1757 }
1758 SvTEMP_off((*SP));
1759 }
1760 SP--;
1761 }
1762 MARK++;
1763 repeatcpy((char*)(MARK + items), (char*)MARK,
1764 items * sizeof(const SV *), count - 1);
1765 SP += max;
1766 }
1767 else if (count <= 0)
1768 SP = MARK;
1769 }
1770 else { /* Note: mark already snarfed by pp_list */
1771 SV * const tmpstr = POPs;
1772 STRLEN len;
1773 bool isutf;
1775 if (TARG != tmpstr)
1776 sv_setsv_nomg(TARG, tmpstr);
1777 SvPV_force_nomg(TARG, len);
1778 isutf = DO_UTF8(TARG);
1779 if (count != 1) {
1780 if (count < 1)
1781 SvCUR_set(TARG, 0);
1782 else {
1783 STRLEN max;
1785 if ( len > (MEM_SIZE_MAX-1) / (UV)count /* max would overflow */
1786 || len > (U32)I32_MAX /* repeatcpy would overflow */
1787 )
1788 Perl_croak(aTHX_ "%s",
1789 "Out of memory during string extend");
1790 max = (UV)count * len + 1;
1791 SvGROW(TARG, max);
1793 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1794 SvCUR_set(TARG, SvCUR(TARG) * count);
1795 }
1796 *SvEND(TARG) = '\0';
1797 }
1798 if (isutf)
1799 (void)SvPOK_only_UTF8(TARG);
1800 else
1801 (void)SvPOK_only(TARG);
1803 PUSHTARG;
1804 }
1805 RETURN;
1806 }
1808 PP(pp_subtract)
1809 {
1810 dSP; dATARGET; bool useleft; SV *svl, *svr;
1811 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1812 svr = TOPs;
1813 svl = TOPm1s;
1815 #ifdef PERL_PRESERVE_IVUV
1817 /* special-case some simple common cases */
1818 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
1819 IV il, ir;
1820 U32 flags = (svl->sv_flags & svr->sv_flags);
1821 if (flags & SVf_IOK) {
1822 /* both args are simple IVs */
1823 UV topl, topr;
1824 il = SvIVX(svl);
1825 ir = SvIVX(svr);
1826 do_iv:
1827 topl = ((UV)il) >> (UVSIZE * 8 - 2);
1828 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
1830 /* if both are in a range that can't under/overflow, do a
1831 * simple integer subtract: if the top of both numbers
1832 * are 00 or 11, then it's safe */
1833 if (!( ((topl+1) | (topr+1)) & 2)) {
1834 SP--;
1835 TARGi(il - ir, 0); /* args not GMG, so can't be tainted */
1836 SETs(TARG);
1837 RETURN;
1838 }
1839 goto generic;
1840 }
1841 else if (flags & SVf_NOK) {
1842 /* both args are NVs */
1843 NV nl = SvNVX(svl);
1844 NV nr = SvNVX(svr);
1846 if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {
1847 /* nothing was lost by converting to IVs */
1848 goto do_iv;
1849 }
1850 SP--;
1851 TARGn(nl - nr, 0); /* args not GMG, so can't be tainted */
1852 SETs(TARG);
1853 RETURN;
1854 }
1855 }
1857 generic:
1859 useleft = USE_LEFT(svl);
1860 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1861 "bad things" happen if you rely on signed integers wrapping. */
1862 if (SvIV_please_nomg(svr)) {
1863 /* Unless the left argument is integer in range we are going to have to
1864 use NV maths. Hence only attempt to coerce the right argument if
1865 we know the left is integer. */
1866 UV auv = 0;
1867 bool auvok = FALSE;
1868 bool a_valid = 0;
1870 if (!useleft) {
1871 auv = 0;
1872 a_valid = auvok = 1;
1873 /* left operand is undef, treat as zero. */
1874 } else {
1875 /* Left operand is defined, so is it IV? */
1876 if (SvIV_please_nomg(svl)) {
1877 if ((auvok = SvUOK(svl)))
1878 auv = SvUVX(svl);
1879 else {
1880 const IV aiv = SvIVX(svl);
1881 if (aiv >= 0) {
1882 auv = aiv;
1883 auvok = 1; /* Now acting as a sign flag. */
1884 } else {
1885 auv = (UV) (0 - (UV) aiv);
1886 }
1887 }
1888 a_valid = 1;
1889 }
1890 }
1891 if (a_valid) {
1892 bool result_good = 0;
1893 UV result;
1894 UV buv;
1895 bool buvok = SvUOK(svr);
1897 if (buvok)
1898 buv = SvUVX(svr);
1899 else {
1900 const IV biv = SvIVX(svr);
1901 if (biv >= 0) {
1902 buv = biv;
1903 buvok = 1;
1904 } else
1905 buv = (UV) (0 - (UV) biv);
1906 }
1907 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1908 else "IV" now, independent of how it came in.
1909 if a, b represents positive, A, B negative, a maps to -A etc
1910 a - b => (a - b)
1911 A - b => -(a + b)
1912 a - B => (a + b)
1913 A - B => -(a - b)
1914 all UV maths. negate result if A negative.
1915 subtract if signs same, add if signs differ. */
1917 if (auvok ^ buvok) {
1918 /* Signs differ. */
1919 result = auv + buv;
1920 if (result >= auv)
1921 result_good = 1;
1922 } else {
1923 /* Signs same */
1924 if (auv >= buv) {
1925 result = auv - buv;
1926 /* Must get smaller */
1927 if (result <= auv)
1928 result_good = 1;
1929 } else {
1930 result = buv - auv;
1931 if (result <= buv) {
1932 /* result really should be -(auv-buv). as its negation
1933 of true value, need to swap our result flag */
1934 auvok = !auvok;
1935 result_good = 1;
1936 }
1937 }
1938 }
1939 if (result_good) {
1940 SP--;
1941 if (auvok)
1942 SETu( result );
1943 else {
1944 /* Negate result */
1945 if (result <= (UV)IV_MIN)
1946 SETi(result == (UV)IV_MIN
1947 ? IV_MIN : -(IV)result);
1948 else {
1949 /* result valid, but out of range for IV. */
1950 SETn( -(NV)result );
1951 }
1952 }
1953 RETURN;
1954 } /* Overflow, drop through to NVs. */
1955 }
1956 }
1957 #else
1958 useleft = USE_LEFT(svl);
1959 #endif
1960 {
1961 NV value = SvNV_nomg(svr);
1962 (void)POPs;
1964 if (!useleft) {
1965 /* left operand is undef, treat as zero - value */
1966 SETn(-value);
1967 RETURN;
1968 }
1969 SETn( SvNV_nomg(svl) - value );
1970 RETURN;
1971 }
1972 }
1974 #define IV_BITS (IVSIZE * 8)
1976 static UV S_uv_shift(UV uv, int shift, bool left)
1977 {
1978 if (shift < 0) {
1979 shift = -shift;
1980 left = !left;
1981 }
1982 if (UNLIKELY(shift >= IV_BITS)) {
1983 return 0;
1984 }
1985 return left ? uv << shift : uv >> shift;
1986 }
1988 static IV S_iv_shift(IV iv, int shift, bool left)
1989 {
1990 if (shift < 0) {
1991 shift = -shift;
1992 left = !left;
1993 }
1995 if (UNLIKELY(shift >= IV_BITS)) {
1996 return iv < 0 && !left ? -1 : 0;
1997 }
1999 /* For left shifts, perl 5 has chosen to treat the value as unsigned for
2000 * the * purposes of shifting, then cast back to signed. This is very
2001 * different from perl 6:
2002 *
2003 * $ perl6 -e 'say -2 +< 5'
2004 * -64
2005 *
2006 * $ ./perl -le 'print -2 << 5'
2007 * 18446744073709551552
2008 * */
2009 if (left) {
2010 if (iv == IV_MIN) { /* Casting this to a UV is undefined behavior */
2011 return 0;
2012 }
2013 return (IV) (((UV) iv) << shift);
2014 }
2016 /* Here is right shift */
2017 return iv >> shift;
2018 }
2020 #define UV_LEFT_SHIFT(uv, shift) S_uv_shift(uv, shift, TRUE)
2021 #define UV_RIGHT_SHIFT(uv, shift) S_uv_shift(uv, shift, FALSE)
2022 #define IV_LEFT_SHIFT(iv, shift) S_iv_shift(iv, shift, TRUE)
2023 #define IV_RIGHT_SHIFT(iv, shift) S_iv_shift(iv, shift, FALSE)
2025 PP(pp_left_shift)
2026 {
2027 dSP; dATARGET; SV *svl, *svr;
2028 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
2029 svr = POPs;
2030 svl = TOPs;
2031 {
2032 const IV shift = SvIV_nomg(svr);
2033 if (PL_op->op_private & HINT_INTEGER) {
2034 SETi(IV_LEFT_SHIFT(SvIV_nomg(svl), shift));
2035 }
2036 else {
2037 SETu(UV_LEFT_SHIFT(SvUV_nomg(svl), shift));
2038 }
2039 RETURN;
2040 }
2041 }
2043 PP(pp_right_shift)
2044 {
2045 dSP; dATARGET; SV *svl, *svr;
2046 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
2047 svr = POPs;
2048 svl = TOPs;
2049 {
2050 const IV shift = SvIV_nomg(svr);
2051 if (PL_op->op_private & HINT_INTEGER) {
2052 SETi(IV_RIGHT_SHIFT(SvIV_nomg(svl), shift));
2053 }
2054 else {
2055 SETu(UV_RIGHT_SHIFT(SvUV_nomg(svl), shift));
2056 }
2057 RETURN;
2058 }
2059 }
2061 PP(pp_lt)
2062 {
2063 dSP;
2064 SV *left, *right;
2066 tryAMAGICbin_MG(lt_amg, AMGf_numeric);
2067 right = POPs;
2068 left = TOPs;
2069 SETs(boolSV(
2070 (SvIOK_notUV(left) && SvIOK_notUV(right))
2071 ? (SvIVX(left) < SvIVX(right))
2072 : (do_ncmp(left, right) == -1)
2073 ));
2074 RETURN;
2075 }
2077 PP(pp_gt)
2078 {
2079 dSP;
2080 SV *left, *right;
2082 tryAMAGICbin_MG(gt_amg, AMGf_numeric);
2083 right = POPs;
2084 left = TOPs;
2085 SETs(boolSV(
2086 (SvIOK_notUV(left) && SvIOK_notUV(right))
2087 ? (SvIVX(left) > SvIVX(right))
2088 : (do_ncmp(left, right) == 1)
2089 ));
2090 RETURN;
2091 }
2093 PP(pp_le)
2094 {
2095 dSP;
2096 SV *left, *right;
2098 tryAMAGICbin_MG(le_amg, AMGf_numeric);
2099 right = POPs;
2100 left = TOPs;
2101 SETs(boolSV(
2102 (SvIOK_notUV(left) && SvIOK_notUV(right))
2103 ? (SvIVX(left) <= SvIVX(right))
2104 : (do_ncmp(left, right) <= 0)
2105 ));
2106 RETURN;
2107 }
2109 PP(pp_ge)
2110 {
2111 dSP;
2112 SV *left, *right;
2114 tryAMAGICbin_MG(ge_amg, AMGf_numeric);
2115 right = POPs;
2116 left = TOPs;
2117 SETs(boolSV(
2118 (SvIOK_notUV(left) && SvIOK_notUV(right))
2119 ? (SvIVX(left) >= SvIVX(right))
2120 : ( (do_ncmp(left, right) & 2) == 0)
2121 ));
2122 RETURN;
2123 }
2125 PP(pp_ne)
2126 {
2127 dSP;
2128 SV *left, *right;
2130 tryAMAGICbin_MG(ne_amg, AMGf_numeric);
2131 right = POPs;
2132 left = TOPs;
2133 SETs(boolSV(
2134 (SvIOK_notUV(left) && SvIOK_notUV(right))
2135 ? (SvIVX(left) != SvIVX(right))
2136 : (do_ncmp(left, right) != 0)
2137 ));
2138 RETURN;
2139 }
2141 /* compare left and right SVs. Returns:
2142 * -1: <
2143 * 0: ==
2144 * 1: >
2145 * 2: left or right was a NaN
2146 */
2147 I32
2148 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2149 {
2150 PERL_ARGS_ASSERT_DO_NCMP;
2151 #ifdef PERL_PRESERVE_IVUV
2152 /* Fortunately it seems NaN isn't IOK */
2153 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2154 if (!SvUOK(left)) {
2155 const IV leftiv = SvIVX(left);
2156 if (!SvUOK(right)) {
2157 /* ## IV <=> IV ## */
2158 const IV rightiv = SvIVX(right);
2159 return (leftiv > rightiv) - (leftiv < rightiv);
2160 }
2161 /* ## IV <=> UV ## */
2162 if (leftiv < 0)
2163 /* As (b) is a UV, it's >=0, so it must be < */
2164 return -1;
2165 {
2166 const UV rightuv = SvUVX(right);
2167 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2168 }
2169 }
2171 if (SvUOK(right)) {
2172 /* ## UV <=> UV ## */
2173 const UV leftuv = SvUVX(left);
2174 const UV rightuv = SvUVX(right);
2175 return (leftuv > rightuv) - (leftuv < rightuv);
2176 }
2177 /* ## UV <=> IV ## */
2178 {
2179 const IV rightiv = SvIVX(right);
2180 if (rightiv < 0)
2181 /* As (a) is a UV, it's >=0, so it cannot be < */
2182 return 1;
2183 {
2184 const UV leftuv = SvUVX(left);
2185 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2186 }
2187 }
2188 NOT_REACHED; /* NOTREACHED */
2189 }
2190 #endif
2191 {
2192 NV const rnv = SvNV_nomg(right);
2193 NV const lnv = SvNV_nomg(left);
2195 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2196 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2197 return 2;
2198 }
2199 return (lnv > rnv) - (lnv < rnv);
2200 #else
2201 if (lnv < rnv)
2202 return -1;
2203 if (lnv > rnv)
2204 return 1;
2205 if (lnv == rnv)
2206 return 0;
2207 return 2;
2208 #endif
2209 }
2210 }
2213 PP(pp_ncmp)
2214 {
2215 dSP;
2216 SV *left, *right;
2217 I32 value;
2218 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2219 right = POPs;
2220 left = TOPs;
2221 value = do_ncmp(left, right);
2222 if (value == 2) {
2223 SETs(&PL_sv_undef);
2224 }
2225 else {
2226 dTARGET;
2227 SETi(value);
2228 }
2229 RETURN;
2230 }
2233 /* also used for: pp_sge() pp_sgt() pp_slt() */
2235 PP(pp_sle)
2236 {
2237 dSP;
2239 int amg_type = sle_amg;
2240 int multiplier = 1;
2241 int rhs = 1;
2243 switch (PL_op->op_type) {
2244 case OP_SLT:
2245 amg_type = slt_amg;
2246 /* cmp < 0 */
2247 rhs = 0;
2248 break;
2249 case OP_SGT:
2250 amg_type = sgt_amg;
2251 /* cmp > 0 */
2252 multiplier = -1;
2253 rhs = 0;
2254 break;
2255 case OP_SGE:
2256 amg_type = sge_amg;
2257 /* cmp >= 0 */
2258 multiplier = -1;
2259 break;
2260 }
2262 tryAMAGICbin_MG(amg_type, 0);
2263 {
2264 dPOPTOPssrl;
2265 const int cmp =
2266 #ifdef USE_LOCALE_COLLATE
2267 (IN_LC_RUNTIME(LC_COLLATE))
2268 ? sv_cmp_locale_flags(left, right, 0)
2269 :
2270 #endif
2271 sv_cmp_flags(left, right, 0);
2272 SETs(boolSV(cmp * multiplier < rhs));
2273 RETURN;
2274 }
2275 }
2277 PP(pp_seq)
2278 {
2279 dSP;
2280 tryAMAGICbin_MG(seq_amg, 0);
2281 {
2282 dPOPTOPssrl;
2283 SETs(boolSV(sv_eq_flags(left, right, 0)));
2284 RETURN;
2285 }
2286 }
2288 PP(pp_sne)
2289 {
2290 dSP;
2291 tryAMAGICbin_MG(sne_amg, 0);
2292 {
2293 dPOPTOPssrl;
2294 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2295 RETURN;
2296 }
2297 }
2299 PP(pp_scmp)
2300 {
2301 dSP; dTARGET;
2302 tryAMAGICbin_MG(scmp_amg, 0);
2303 {
2304 dPOPTOPssrl;
2305 const int cmp =
2306 #ifdef USE_LOCALE_COLLATE
2307 (IN_LC_RUNTIME(LC_COLLATE))
2308 ? sv_cmp_locale_flags(left, right, 0)
2309 :
2310 #endif
2311 sv_cmp_flags(left, right, 0);
2312 SETi( cmp );
2313 RETURN;
2314 }
2315 }
2317 PP(pp_bit_and)
2318 {
2319 dSP; dATARGET;
2320 tryAMAGICbin_MG(band_amg, AMGf_assign);
2321 {
2322 dPOPTOPssrl;
2323 if (SvNIOKp(left) || SvNIOKp(right)) {
2324 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2325 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2326 if (PL_op->op_private & HINT_INTEGER) {
2327 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2328 SETi(i);
2329 }
2330 else {
2331 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2332 SETu(u);
2333 }
2334 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2335 if (right_ro_nonnum) SvNIOK_off(right);
2336 }
2337 else {
2338 do_vop(PL_op->op_type, TARG, left, right);
2339 SETTARG;
2340 }
2341 RETURN;
2342 }
2343 }
2345 PP(pp_nbit_and)
2346 {
2347 dSP;
2348 tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg);
2349 {
2350 dATARGET; dPOPTOPssrl;
2351 if (PL_op->op_private & HINT_INTEGER) {
2352 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2353 SETi(i);
2354 }
2355 else {
2356 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2357 SETu(u);
2358 }
2359 }
2360 RETURN;
2361 }
2363 PP(pp_sbit_and)
2364 {
2365 dSP;
2366 tryAMAGICbin_MG(sband_amg, AMGf_assign);
2367 {
2368 dATARGET; dPOPTOPssrl;
2369 do_vop(OP_BIT_AND, TARG, left, right);
2370 RETSETTARG;
2371 }
2372 }
2374 /* also used for: pp_bit_xor() */
2376 PP(pp_bit_or)
2377 {
2378 dSP; dATARGET;
2379 const int op_type = PL_op->op_type;
2381 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2382 {
2383 dPOPTOPssrl;
2384 if (SvNIOKp(left) || SvNIOKp(right)) {
2385 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2386 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2387 if (PL_op->op_private & HINT_INTEGER) {
2388 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2389 const IV r = SvIV_nomg(right);
2390 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2391 SETi(result);
2392 }
2393 else {
2394 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2395 const UV r = SvUV_nomg(right);
2396 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2397 SETu(result);
2398 }
2399 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2400 if (right_ro_nonnum) SvNIOK_off(right);
2401 }
2402 else {
2403 do_vop(op_type, TARG, left, right);
2404 SETTARG;
2405 }
2406 RETURN;
2407 }
2408 }
2410 /* also used for: pp_nbit_xor() */
2412 PP(pp_nbit_or)
2413 {
2414 dSP;
2415 const int op_type = PL_op->op_type;
2417 tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg),
2418 AMGf_assign|AMGf_numarg);
2419 {
2420 dATARGET; dPOPTOPssrl;
2421 if (PL_op->op_private & HINT_INTEGER) {
2422 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2423 const IV r = SvIV_nomg(right);
2424 const IV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2425 SETi(result);
2426 }
2427 else {
2428 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2429 const UV r = SvUV_nomg(right);
2430 const UV result = op_type == OP_NBIT_OR ? (l | r) : (l ^ r);
2431 SETu(result);
2432 }
2433 }
2434 RETURN;
2435 }
2437 /* also used for: pp_sbit_xor() */
2439 PP(pp_sbit_or)
2440 {
2441 dSP;
2442 const int op_type = PL_op->op_type;
2444 tryAMAGICbin_MG((op_type == OP_SBIT_OR ? sbor_amg : sbxor_amg),
2445 AMGf_assign);
2446 {
2447 dATARGET; dPOPTOPssrl;
2448 do_vop(op_type == OP_SBIT_OR ? OP_BIT_OR : OP_BIT_XOR, TARG, left,
2449 right);
2450 RETSETTARG;
2451 }
2452 }
2454 PERL_STATIC_INLINE bool
2455 S_negate_string(pTHX)
2456 {
2457 dTARGET; dSP;
2458 STRLEN len;
2459 const char *s;
2460 SV * const sv = TOPs;
2461 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2462 return FALSE;
2463 s = SvPV_nomg_const(sv, len);
2464 if (isIDFIRST(*s)) {
2465 sv_setpvs(TARG, "-");
2466 sv_catsv(TARG, sv);
2467 }
2468 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2469 sv_setsv_nomg(TARG, sv);
2470 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2471 }
2472 else return FALSE;
2473 SETTARG;
2474 return TRUE;
2475 }
2477 PP(pp_negate)
2478 {
2479 dSP; dTARGET;
2480 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2481 if (S_negate_string(aTHX)) return NORMAL;
2482 {
2483 SV * const sv = TOPs;
2485 if (SvIOK(sv)) {
2486 /* It's publicly an integer */
2487 oops_its_an_int:
2488 if (SvIsUV(sv)) {
2489 if (SvIVX(sv) == IV_MIN) {
2490 /* 2s complement assumption. */
2491 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2492 IV_MIN */
2493 return NORMAL;
2494 }
2495 else if (SvUVX(sv) <= IV_MAX) {
2496 SETi(-SvIVX(sv));
2497 return NORMAL;
2498 }
2499 }
2500 else if (SvIVX(sv) != IV_MIN) {
2501 SETi(-SvIVX(sv));
2502 return NORMAL;
2503 }
2504 #ifdef PERL_PRESERVE_IVUV
2505 else {
2506 SETu((UV)IV_MIN);
2507 return NORMAL;
2508 }
2509 #endif
2510 }
2511 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2512 SETn(-SvNV_nomg(sv));
2513 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2514 goto oops_its_an_int;
2515 else
2516 SETn(-SvNV_nomg(sv));
2517 }
2518 return NORMAL;
2519 }
2521 PP(pp_not)
2522 {
2523 dSP;
2524 SV *sv;
2526 tryAMAGICun_MG(not_amg, 0);
2527 sv = *PL_stack_sp;
2528 *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
2529 return NORMAL;
2530 }
2532 static void
2533 S_scomplement(pTHX_ SV *targ, SV *sv)
2534 {
2535 U8 *tmps;
2536 I32 anum;
2537 STRLEN len;
2539 sv_copypv_nomg(TARG, sv);
2540 tmps = (U8*)SvPV_nomg(TARG, len);
2542 if (SvUTF8(TARG)) {
2543 if (len && ! utf8_to_bytes(tmps, &len)) {
2544 Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]);
2545 }
2546 SvCUR_set(TARG, len);
2547 SvUTF8_off(TARG);
2548 }
2550 anum = len;
2552 #ifdef LIBERAL
2553 {
2554 long *tmpl;
2555 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2556 *tmps = ~*tmps;
2557 tmpl = (long*)tmps;
2558 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2559 *tmpl = ~*tmpl;
2560 tmps = (U8*)tmpl;
2561 }
2562 #endif
2563 for ( ; anum > 0; anum--, tmps++)
2564 *tmps = ~*tmps;
2565 }
2567 PP(pp_complement)
2568 {
2569 dSP; dTARGET;
2570 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2571 {
2572 dTOPss;
2573 if (SvNIOKp(sv)) {
2574 if (PL_op->op_private & HINT_INTEGER) {
2575 const IV i = ~SvIV_nomg(sv);
2576 SETi(i);
2577 }
2578 else {
2579 const UV u = ~SvUV_nomg(sv);
2580 SETu(u);
2581 }
2582 }
2583 else {
2584 S_scomplement(aTHX_ TARG, sv);
2585 SETTARG;
2586 }
2587 return NORMAL;
2588 }
2589 }
2591 PP(pp_ncomplement)
2592 {
2593 dSP;
2594 tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg);
2595 {
2596 dTARGET; dTOPss;
2597 if (PL_op->op_private & HINT_INTEGER) {
2598 const IV i = ~SvIV_nomg(sv);
2599 SETi(i);
2600 }
2601 else {
2602 const UV u = ~SvUV_nomg(sv);
2603 SETu(u);
2604 }
2605 }
2606 return NORMAL;
2607 }
2609 PP(pp_scomplement)
2610 {
2611 dSP;
2612 tryAMAGICun_MG(scompl_amg, AMGf_numeric);
2613 {
2614 dTARGET; dTOPss;
2615 S_scomplement(aTHX_ TARG, sv);
2616 SETTARG;
2617 return NORMAL;
2618 }
2619 }
2621 /* integer versions of some of the above */
2623 PP(pp_i_multiply)
2624 {
2625 dSP; dATARGET;
2626 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2627 {
2628 dPOPTOPiirl_nomg;
2629 SETi( left * right );
2630 RETURN;
2631 }
2632 }
2634 PP(pp_i_divide)
2635 {
2636 IV num;
2637 dSP; dATARGET;
2638 tryAMAGICbin_MG(div_amg, AMGf_assign);
2639 {
2640 dPOPTOPssrl;
2641 IV value = SvIV_nomg(right);
2642 if (value == 0)
2643 DIE(aTHX_ "Illegal division by zero");
2644 num = SvIV_nomg(left);
2646 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2647 if (value == -1)
2648 value = - num;
2649 else
2650 value = num / value;
2651 SETi(value);
2652 RETURN;
2653 }
2654 }
2656 PP(pp_i_modulo)
2657 {
2658 /* This is the vanilla old i_modulo. */
2659 dSP; dATARGET;
2660 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2661 {
2662 dPOPTOPiirl_nomg;
2663 if (!right)
2664 DIE(aTHX_ "Illegal modulus zero");
2665 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2666 if (right == -1)
2667 SETi( 0 );
2668 else
2669 SETi( left % right );
2670 RETURN;
2671 }
2672 }
2674 #if defined(__GLIBC__) && IVSIZE == 8 \
2675 && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
2677 PP(pp_i_modulo_glibc_bugfix)
2678 {
2679 /* This is the i_modulo with the workaround for the _moddi3 bug
2680 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2681 * See below for pp_i_modulo. */
2682 dSP; dATARGET;
2683 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2684 {
2685 dPOPTOPiirl_nomg;
2686 if (!right)
2687 DIE(aTHX_ "Illegal modulus zero");
2688 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2689 if (right == -1)
2690 SETi( 0 );
2691 else
2692 SETi( left % PERL_ABS(right) );
2693 RETURN;
2694 }
2695 }
2696 #endif
2698 PP(pp_i_add)
2699 {
2700 dSP; dATARGET;
2701 tryAMAGICbin_MG(add_amg, AMGf_assign);
2702 {
2703 dPOPTOPiirl_ul_nomg;
2704 SETi( left + right );
2705 RETURN;
2706 }
2707 }
2709 PP(pp_i_subtract)
2710 {
2711 dSP; dATARGET;
2712 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2713 {
2714 dPOPTOPiirl_ul_nomg;
2715 SETi( left - right );
2716 RETURN;
2717 }
2718 }
2720 PP(pp_i_lt)
2721 {
2722 dSP;
2723 tryAMAGICbin_MG(lt_amg, 0);
2724 {
2725 dPOPTOPiirl_nomg;
2726 SETs(boolSV(left < right));
2727 RETURN;
2728 }
2729 }
2731 PP(pp_i_gt)
2732 {
2733 dSP;
2734 tryAMAGICbin_MG(gt_amg, 0);
2735 {
2736 dPOPTOPiirl_nomg;
2737 SETs(boolSV(left > right));
2738 RETURN;
2739 }
2740 }
2742 PP(pp_i_le)
2743 {
2744 dSP;
2745 tryAMAGICbin_MG(le_amg, 0);
2746 {
2747 dPOPTOPiirl_nomg;
2748 SETs(boolSV(left <= right));
2749 RETURN;
2750 }
2751 }
2753 PP(pp_i_ge)
2754 {
2755 dSP;
2756 tryAMAGICbin_MG(ge_amg, 0);
2757 {
2758 dPOPTOPiirl_nomg;
2759 SETs(boolSV(left >= right));
2760 RETURN;
2761 }
2762 }
2764 PP(pp_i_eq)
2765 {
2766 dSP;
2767 tryAMAGICbin_MG(eq_amg, 0);
2768 {
2769 dPOPTOPiirl_nomg;
2770 SETs(boolSV(left == right));
2771 RETURN;
2772 }
2773 }
2775 PP(pp_i_ne)
2776 {
2777 dSP;
2778 tryAMAGICbin_MG(ne_amg, 0);
2779 {
2780 dPOPTOPiirl_nomg;
2781 SETs(boolSV(left != right));
2782 RETURN;
2783 }
2784 }
2786 PP(pp_i_ncmp)
2787 {
2788 dSP; dTARGET;
2789 tryAMAGICbin_MG(ncmp_amg, 0);
2790 {
2791 dPOPTOPiirl_nomg;
2792 I32 value;
2794 if (left > right)
2795 value = 1;
2796 else if (left < right)
2797 value = -1;
2798 else
2799 value = 0;
2800 SETi(value);
2801 RETURN;
2802 }
2803 }
2805 PP(pp_i_negate)
2806 {
2807 dSP; dTARGET;
2808 tryAMAGICun_MG(neg_amg, 0);
2809 if (S_negate_string(aTHX)) return NORMAL;
2810 {
2811 SV * const sv = TOPs;
2812 IV const i = SvIV_nomg(sv);
2813 SETi(-i);
2814 return NORMAL;
2815 }
2816 }
2818 /* High falutin' math. */
2820 PP(pp_atan2)
2821 {
2822 dSP; dTARGET;
2823 tryAMAGICbin_MG(atan2_amg, 0);
2824 {
2825 dPOPTOPnnrl_nomg;
2826 SETn(Perl_atan2(left, right));
2827 RETURN;
2828 }
2829 }
2832 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2834 PP(pp_sin)
2835 {
2836 dSP; dTARGET;
2837 int amg_type = fallback_amg;
2838 const char *neg_report = NULL;
2839 const int op_type = PL_op->op_type;
2841 switch (op_type) {
2842 case OP_SIN: amg_type = sin_amg; break;
2843 case OP_COS: amg_type = cos_amg; break;
2844 case OP_EXP: amg_type = exp_amg; break;
2845 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2846 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2847 }
2849 assert(amg_type != fallback_amg);
2851 tryAMAGICun_MG(amg_type, 0);
2852 {
2853 SV * const arg = TOPs;
2854 const NV value = SvNV_nomg(arg);
2855 #ifdef NV_NAN
2856 NV result = NV_NAN;
2857 #else
2858 NV result = 0.0;
2859 #endif
2860 if (neg_report) { /* log or sqrt */
2861 if (
2862 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2863 ! Perl_isnan(value) &&
2864 #endif
2865 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2866 SET_NUMERIC_STANDARD();
2867 /* diag_listed_as: Can't take log of %g */
2868 DIE(aTHX_ "Can't take %s of %" NVgf, neg_report, value);
2869 }
2870 }
2871 switch (op_type) {
2872 default:
2873 case OP_SIN: result = Perl_sin(value); break;
2874 case OP_COS: result = Perl_cos(value); break;
2875 case OP_EXP: result = Perl_exp(value); break;
2876 case OP_LOG: result = Perl_log(value); break;
2877 case OP_SQRT: result = Perl_sqrt(value); break;
2878 }
2879 SETn(result);
2880 return NORMAL;
2881 }
2882 }
2884 /* Support Configure command-line overrides for rand() functions.
2885 After 5.005, perhaps we should replace this by Configure support
2886 for drand48(), random(), or rand(). For 5.005, though, maintain
2887 compatibility by calling rand() but allow the user to override it.
2888 See INSTALL for details. --Andy Dougherty 15 July 1998
2889 */
2890 /* Now it's after 5.005, and Configure supports drand48() and random(),
2891 in addition to rand(). So the overrides should not be needed any more.
2892 --Jarkko Hietaniemi 27 September 1998
2893 */
2895 PP(pp_rand)
2896 {
2897 if (!PL_srand_called) {
2898 (void)seedDrand01((Rand_seed_t)seed());
2899 PL_srand_called = TRUE;
2900 }
2901 {
2902 dSP;
2903 NV value;
2905 if (MAXARG < 1)
2906 {
2907 EXTEND(SP, 1);
2908 value = 1.0;
2909 }
2910 else {
2911 SV * const sv = POPs;
2912 if(!sv)
2913 value = 1.0;
2914 else
2915 value = SvNV(sv);
2916 }
2917 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2918 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2919 if (! Perl_isnan(value) && value == 0.0)
2920 #else
2921 if (value == 0.0)
2922 #endif
2923 value = 1.0;
2924 {
2925 dTARGET;
2926 PUSHs(TARG);
2927 PUTBACK;
2928 value *= Drand01();
2929 sv_setnv_mg(TARG, value);
2930 }
2931 }
2932 return NORMAL;
2933 }
2935 PP(pp_srand)
2936 {
2937 dSP; dTARGET;
2938 UV anum;
2940 if (MAXARG >= 1 && (TOPs || POPs)) {
2941 SV *top;
2942 char *pv;
2943 STRLEN len;
2944 int flags;
2946 top = POPs;
2947 pv = SvPV(top, len);
2948 flags = grok_number(pv, len, &anum);
2950 if (!(flags & IS_NUMBER_IN_UV)) {
2951 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2952 "Integer overflow in srand");
2953 anum = UV_MAX;
2954 }
2955 }
2956 else {
2957 anum = seed();
2958 }
2960 (void)seedDrand01((Rand_seed_t)anum);
2961 PL_srand_called = TRUE;
2962 if (anum)
2963 XPUSHu(anum);
2964 else {
2965 /* Historically srand always returned true. We can avoid breaking
2966 that like this: */
2967 sv_setpvs(TARG, "0 but true");
2968 XPUSHTARG;
2969 }
2970 RETURN;
2971 }
2973 PP(pp_int)
2974 {
2975 dSP; dTARGET;
2976 tryAMAGICun_MG(int_amg, AMGf_numeric);
2977 {
2978 SV * const sv = TOPs;
2979 const IV iv = SvIV_nomg(sv);
2980 /* XXX it's arguable that compiler casting to IV might be subtly
2981 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2982 else preferring IV has introduced a subtle behaviour change bug. OTOH
2983 relying on floating point to be accurate is a bug. */
2985 if (!SvOK(sv)) {
2986 SETu(0);
2987 }
2988 else if (SvIOK(sv)) {
2989 if (SvIsUV(sv))
2990 SETu(SvUV_nomg(sv));
2991 else
2992 SETi(iv);
2993 }
2994 else {
2995 const NV value = SvNV_nomg(sv);
2996 if (UNLIKELY(Perl_isinfnan(value)))
2997 SETn(value);
2998 else if (value >= 0.0) {
2999 if (value < (NV)UV_MAX + 0.5) {
3000 SETu(U_V(value));
3001 } else {
3002 SETn(Perl_floor(value));
3003 }
3004 }
3005 else {
3006 if (value > (NV)IV_MIN - 0.5) {
3007 SETi(I_V(value));
3008 } else {
3009 SETn(Perl_ceil(value));
3010 }
3011 }
3012 }
3013 }
3014 return NORMAL;
3015 }
3017 PP(pp_abs)
3018 {
3019 dSP; dTARGET;
3020 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3021 {
3022 SV * const sv = TOPs;
3023 /* This will cache the NV value if string isn't actually integer */
3024 const IV iv = SvIV_nomg(sv);
3026 if (!SvOK(sv)) {
3027 SETu(0);
3028 }
3029 else if (SvIOK(sv)) {
3030 /* IVX is precise */
3031 if (SvIsUV(sv)) {
3032 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3033 } else {
3034 if (iv >= 0) {
3035 SETi(iv);
3036 } else {
3037 if (iv != IV_MIN) {
3038 SETi(-iv);
3039 } else {
3040 /* 2s complement assumption. Also, not really needed as
3041 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3042 SETu((UV)IV_MIN);
3043 }
3044 }
3045 }
3046 } else{
3047 const NV value = SvNV_nomg(sv);
3048 if (value < 0.0)
3049 SETn(-value);
3050 else
3051 SETn(value);
3052 }
3053 }
3054 return NORMAL;
3055 }
3058 /* also used for: pp_hex() */
3060 PP(pp_oct)
3061 {
3062 dSP; dTARGET;
3063 const char *tmps;
3064 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3065 STRLEN len;
3066 NV result_nv;
3067 UV result_uv;
3068 SV* const sv = TOPs;
3070 tmps = (SvPV_const(sv, len));
3071 if (DO_UTF8(sv)) {
3072 /* If Unicode, try to downgrade
3073 * If not possible, croak. */
3074 SV* const tsv = sv_2mortal(newSVsv(sv));
3076 SvUTF8_on(tsv);
3077 sv_utf8_downgrade(tsv, FALSE);
3078 tmps = SvPV_const(tsv, len);
3079 }
3080 if (PL_op->op_type == OP_HEX)
3081 goto hex;
3083 while (*tmps && len && isSPACE(*tmps))
3084 tmps++, len--;
3085 if (*tmps == '0')
3086 tmps++, len--;
3087 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
3088 hex:
3089 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3090 }
3091 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
3092 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3093 else
3094 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3096 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3097 SETn(result_nv);
3098 }
3099 else {
3100 SETu(result_uv);
3101 }
3102 return NORMAL;
3103 }
3105 /* String stuff. */
3108 PP(pp_length)
3109 {
3110 dSP; dTARGET;
3111 SV * const sv = TOPs;
3113 U32 in_bytes = IN_BYTES;
3114 /* Simplest case shortcut:
3115 * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
3116 * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
3117 * set)
3118 */
3119 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
3121 STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
3122 SETs(TARG);
3124 if (LIKELY(svflags == SVf_POK))
3125 goto simple_pv;
3127 if (svflags & SVs_GMG)
3128 mg_get(sv);
3130 if (SvOK(sv)) {
3131 STRLEN len;
3132 if (!IN_BYTES) { /* reread to avoid using an C auto/register */
3133 if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
3134 goto simple_pv;
3135 if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
3136 /* no need to convert from bytes to chars */
3137 len = SvCUR(sv);
3138 goto return_bool;
3139 }
3140 len = sv_len_utf8_nomg(sv);
3141 }
3142 else {
3143 /* unrolled SvPV_nomg_const(sv,len) */
3144 if (SvPOK_nog(sv)) {
3145 simple_pv:
3146 len = SvCUR(sv);
3147 if (PL_op->op_private & OPpTRUEBOOL) {
3148 return_bool:
3149 SETs(len ? &PL_sv_yes : &PL_sv_zero);
3150 return NORMAL;
3151 }
3152 }
3153 else {
3154 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
3155 }
3156 }
3157 TARGi((IV)(len), 1);
3158 }
3159 else {
3160 if (!SvPADTMP(TARG)) {
3161 /* OPpTARGET_MY: targ is var in '$lex = length()' */
3162 sv_set_undef(TARG);
3163 SvSETMAGIC(TARG);
3164 }
3165 else
3166 /* TARG is on stack at this point and is overwriten by SETs.
3167 * This branch is the odd one out, so put TARG by default on
3168 * stack earlier to let local SP go out of liveness sooner */
3169 SETs(&PL_sv_undef);
3170 }
3171 return NORMAL; /* no putback, SP didn't move in this opcode */
3172 }
3175 /* Returns false if substring is completely outside original string.
3176 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3177 always be true for an explicit 0.
3178 */
3179 bool
3180 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3181 bool pos1_is_uv, IV len_iv,
3182 bool len_is_uv, STRLEN *posp,
3183 STRLEN *lenp)
3184 {
3185 IV pos2_iv;
3186 int pos2_is_uv;
3188 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3190 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3191 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3192 pos1_iv += curlen;
3193 }
3194 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3195 return FALSE;
3197 if (len_iv || len_is_uv) {
3198 if (!len_is_uv && len_iv < 0) {
3199 pos2_iv = curlen + len_iv;
3200 if (curlen)
3201 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3202 else
3203 pos2_is_uv = 0;
3204 } else { /* len_iv >= 0 */
3205 if (!pos1_is_uv && pos1_iv < 0) {
3206 pos2_iv = pos1_iv + len_iv;
3207 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3208 } else {
3209 if ((UV)len_iv > curlen-(UV)pos1_iv)
3210 pos2_iv = curlen;
3211 else
3212 pos2_iv = pos1_iv+len_iv;
3213 pos2_is_uv = 1;
3214 }
3215 }
3216 }
3217 else {
3218 pos2_iv = curlen;
3219 pos2_is_uv = 1;
3220 }
3222 if (!pos2_is_uv && pos2_iv < 0) {
3223 if (!pos1_is_uv && pos1_iv < 0)
3224 return FALSE;
3225 pos2_iv = 0;
3226 }
3227 else if (!pos1_is_uv && pos1_iv < 0)
3228 pos1_iv = 0;
3230 if ((UV)pos2_iv < (UV)pos1_iv)
3231 pos2_iv = pos1_iv;
3232 if ((UV)pos2_iv > curlen)
3233 pos2_iv = curlen;
3235 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3236 *posp = (STRLEN)( (UV)pos1_iv );
3237 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3239 return TRUE;
3240 }
3242 PP(pp_substr)
3243 {
3244 dSP; dTARGET;
3245 SV *sv;
3246 STRLEN curlen;
3247 STRLEN utf8_curlen;
3248 SV * pos_sv;
3249 IV pos1_iv;
3250 int pos1_is_uv;
3251 SV * len_sv;
3252 IV len_iv = 0;
3253 int len_is_uv = 0;
3254 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3255 const bool rvalue = (GIMME_V != G_VOID);
3256 const char *tmps;
3257 SV *repl_sv = NULL;
3258 const char *repl = NULL;
3259 STRLEN repl_len;
3260 int num_args = PL_op->op_private & 7;
3261 bool repl_need_utf8_upgrade = FALSE;
3263 if (num_args > 2) {
3264 if (num_args > 3) {
3265 if(!(repl_sv = POPs)) num_args--;
3266 }
3267 if ((len_sv = POPs)) {
3268 len_iv = SvIV(len_sv);
3269 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3270 }
3271 else num_args--;
3272 }
3273 pos_sv = POPs;
3274 pos1_iv = SvIV(pos_sv);
3275 pos1_is_uv = SvIOK_UV(pos_sv);
3276 sv = POPs;
3277 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3278 assert(!repl_sv);
3279 repl_sv = POPs;
3280 }
3281 if (lvalue && !repl_sv) {
3282 SV * ret;
3283 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3284 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3285 LvTYPE(ret) = 'x';
3286 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3287 LvTARGOFF(ret) =
3288 pos1_is_uv || pos1_iv >= 0
3289 ? (STRLEN)(UV)pos1_iv
3290 : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
3291 LvTARGLEN(ret) =
3292 len_is_uv || len_iv > 0
3293 ? (STRLEN)(UV)len_iv
3294 : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
3296 PUSHs(ret); /* avoid SvSETMAGIC here */
3297 RETURN;
3298 }
3299 if (repl_sv) {
3300 repl = SvPV_const(repl_sv, repl_len);
3301 SvGETMAGIC(sv);
3302 if (SvROK(sv))
3303 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3304 "Attempt to use reference as lvalue in substr"
3305 );
3306 tmps = SvPV_force_nomg(sv, curlen);
3307 if (DO_UTF8(repl_sv) && repl_len) {
3308 if (!DO_UTF8(sv)) {
3309 /* Upgrade the dest, and recalculate tmps in case the buffer
3310 * got reallocated; curlen may also have been changed */
3311 sv_utf8_upgrade_nomg(sv);
3312 tmps = SvPV_nomg(sv, curlen);
3313 }
3314 }
3315 else if (DO_UTF8(sv))
3316 repl_need_utf8_upgrade = TRUE;
3317 }
3318 else tmps = SvPV_const(sv, curlen);
3319 if (DO_UTF8(sv)) {
3320 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3321 if (utf8_curlen == curlen)
3322 utf8_curlen = 0;
3323 else
3324 curlen = utf8_curlen;
3325 }
3326 else
3327 utf8_curlen = 0;
3329 {
3330 STRLEN pos, len, byte_len, byte_pos;
3332 if (!translate_substr_offsets(
3333 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3334 )) goto bound_fail;
3336 byte_len = len;
3337 byte_pos = utf8_curlen
3338 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3340 tmps += byte_pos;
3342 if (rvalue) {
3343 SvTAINTED_off(TARG); /* decontaminate */
3344 SvUTF8_off(TARG); /* decontaminate */
3345 sv_setpvn(TARG, tmps, byte_len);
3346 #ifdef USE_LOCALE_COLLATE
3347 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3348 #endif
3349 if (utf8_curlen)
3350 SvUTF8_on(TARG);
3351 }
3353 if (repl) {
3354 SV* repl_sv_copy = NULL;
3356 if (repl_need_utf8_upgrade) {
3357 repl_sv_copy = newSVsv(repl_sv);
3358 sv_utf8_upgrade(repl_sv_copy);
3359 repl = SvPV_const(repl_sv_copy, repl_len);
3360 }
3361 if (!SvOK(sv))
3362 SvPVCLEAR(sv);
3363 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3364 SvREFCNT_dec(repl_sv_copy);
3365 }
3366 }
3367 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
3368 SP++;
3369 else if (rvalue) {
3370 SvSETMAGIC(TARG);
3371 PUSHs(TARG);
3372 }
3373 RETURN;
3375 bound_fail:
3376 if (repl)
3377 Perl_croak(aTHX_ "substr outside of string");
3378 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3379 RETPUSHUNDEF;
3380 }
3382 PP(pp_vec)
3383 {
3384 dSP;
3385 const IV size = POPi;
3386 SV* offsetsv = POPs;
3387 SV * const src = POPs;
3388 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3389 SV * ret;
3390 UV retuv;
3391 STRLEN offset = 0;
3392 char errflags = 0;
3394 /* extract a STRLEN-ranged integer value from offsetsv into offset,
3395 * or flag that its out of range */
3396 {
3397 IV iv = SvIV(offsetsv);
3399 /* avoid a large UV being wrapped to a negative value */
3400 if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
3401 errflags = LVf_OUT_OF_RANGE;
3402 else if (iv < 0)
3403 errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
3404 #if PTRSIZE < IVSIZE
3405 else if (iv > Size_t_MAX)
3406 errflags = LVf_OUT_OF_RANGE;
3407 #endif
3408 else
3409 offset = (STRLEN)iv;
3410 }
3412 retuv = errflags ? 0 : do_vecget(src, offset, size);
3414 if (lvalue) { /* it's an lvalue! */
3415 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3416 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3417 LvTYPE(ret) = 'v';
3418 LvTARG(ret) = SvREFCNT_inc_simple(src);
3419 LvTARGOFF(ret) = offset;
3420 LvTARGLEN(ret) = size;
3421 LvFLAGS(ret) = errflags;
3422 }
3423 else {
3424 dTARGET;
3425 SvTAINTED_off(TARG); /* decontaminate */
3426 ret = TARG;
3427 }
3429 sv_setuv(ret, retuv);
3430 if (!lvalue)
3431 SvSETMAGIC(ret);
3432 PUSHs(ret);
3433 RETURN;
3434 }
3437 /* also used for: pp_rindex() */
3439 PP(pp_index)
3440 {
3441 dSP; dTARGET;
3442 SV *big;
3443 SV *little;
3444 SV *temp = NULL;
3445 STRLEN biglen;
3446 STRLEN llen = 0;
3447 SSize_t offset = 0;
3448 SSize_t retval;
3449 const char *big_p;
3450 const char *little_p;
3451 bool big_utf8;
3452 bool little_utf8;
3453 const bool is_index = PL_op->op_type == OP_INDEX;
3454 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3456 if (threeargs)
3457 offset = POPi;
3458 little = POPs;
3459 big = POPs;
3460 big_p = SvPV_const(big, biglen);
3461 little_p = SvPV_const(little, llen);
3463 big_utf8 = DO_UTF8(big);
3464 little_utf8 = DO_UTF8(little);
3465 if (big_utf8 ^ little_utf8) {
3466 /* One needs to be upgraded. */
3467 if (little_utf8) {
3468 /* Well, maybe instead we might be able to downgrade the small
3469 string? */
3470 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3471 &little_utf8);
3472 if (little_utf8) {
3473 /* If the large string is ISO-8859-1, and it's not possible to
3474 convert the small string to ISO-8859-1, then there is no
3475 way that it could be found anywhere by index. */
3476 retval = -1;
3477 goto push_result;
3478 }
3480 /* At this point, pv is a malloc()ed string. So donate it to temp
3481 to ensure it will get free()d */
3482 little = temp = newSV(0);
3483 sv_usepvn(temp, pv, llen);
3484 little_p = SvPVX(little);
3485 } else {
3486 temp = newSVpvn(little_p, llen);
3488 sv_utf8_upgrade(temp);
3489 little = temp;
3490 little_p = SvPV_const(little, llen);
3491 }
3492 }
3493 if (SvGAMAGIC(big)) {
3494 /* Life just becomes a lot easier if I use a temporary here.
3495 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3496 will trigger magic and overloading again, as will fbm_instr()
3497 */
3498 big = newSVpvn_flags(big_p, biglen,
3499 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3500 big_p = SvPVX(big);
3501 }
3502 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3503 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3504 warn on undef, and we've already triggered a warning with the
3505 SvPV_const some lines above. We can't remove that, as we need to
3506 call some SvPV to trigger overloading early and find out if the
3507 string is UTF-8.
3508 This is all getting too messy. The API isn't quite clean enough,
3509 because data access has side effects.
3510 */
3511 little = newSVpvn_flags(little_p, llen,
3512 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3513 little_p = SvPVX(little);
3514 }
3516 if (!threeargs)
3517 offset = is_index ? 0 : biglen;
3518 else {
3519 if (big_utf8 && offset > 0)
3520 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3521 if (!is_index)
3522 offset += llen;
3523 }
3524 if (offset < 0)
3525 offset = 0;
3526 else if (offset > (SSize_t)biglen)
3527 offset = biglen;
3528 if (!(little_p = is_index
3529 ? fbm_instr((unsigned char*)big_p + offset,
3530 (unsigned char*)big_p + biglen, little, 0)
3531 : rninstr(big_p, big_p + offset,
3532 little_p, little_p + llen)))
3533 retval = -1;
3534 else {
3535 retval = little_p - big_p;
3536 if (retval > 1 && big_utf8)
3537 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3538 }
3539 SvREFCNT_dec(temp);
3541 push_result:
3542 /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
3543 if (PL_op->op_private & OPpTRUEBOOL) {
3544 PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
3545 ? &PL_sv_yes : &PL_sv_no);
3546 if (PL_op->op_private & OPpTARGET_MY)
3547 /* $lex = (index() == -1) */
3548 sv_setsv(TARG, TOPs);
3549 }
3550 else
3551 PUSHi(retval);
3552 RETURN;
3553 }
3555 PP(pp_sprintf)
3556 {
3557 dSP; dMARK; dORIGMARK; dTARGET;
3558 SvTAINTED_off(TARG);
3559 do_sprintf(TARG, SP-MARK, MARK+1);
3560 TAINT_IF(SvTAINTED(TARG));
3561 SP = ORIGMARK;
3562 PUSHTARG;
3563 RETURN;
3564 }
3566 PP(pp_ord)
3567 {
3568 dSP; dTARGET;
3570 SV *argsv = TOPs;
3571 STRLEN len;
3572 const U8 *s = (U8*)SvPV_const(argsv, len);
3574 SETu(DO_UTF8(argsv)
3575 ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
3576 : (UV)(*s));
3578 return NORMAL;
3579 }
3581 PP(pp_chr)
3582 {
3583 dSP; dTARGET;
3584 char *tmps;
3585 UV value;
3586 SV *top = TOPs;
3588 SvGETMAGIC(top);
3589 if (UNLIKELY(SvAMAGIC(top)))
3590 top = sv_2num(top);
3591 if (UNLIKELY(isinfnansv(top)))
3592 Perl_croak(aTHX_ "Cannot chr %" NVgf, SvNV(top));
3593 else {
3594 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3595 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3596 ||
3597 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3598 && SvNV_nomg(top) < 0.0)))
3599 {
3600 if (ckWARN(WARN_UTF8)) {
3601 if (SvGMAGICAL(top)) {
3602 SV *top2 = sv_newmortal();
3603 sv_setsv_nomg(top2, top);
3604 top = top2;
3605 }
3606 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3607 "Invalid negative number (%" SVf ") in chr", SVfARG(top));
3608 }
3609 value = UNICODE_REPLACEMENT;
3610 } else {
3611 value = SvUV_nomg(top);
3612 }
3613 }
3615 SvUPGRADE(TARG,SVt_PV);
3617 if (value > 255 && !IN_BYTES) {
3618 SvGROW(TARG, (STRLEN)UVCHR_SKIP(value)+1);
3619 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3620 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3621 *tmps = '\0';
3622 (void)SvPOK_only(TARG);
3623 SvUTF8_on(TARG);
3624 SETTARG;
3625 return NORMAL;
3626 }
3628 SvGROW(TARG,2);
3629 SvCUR_set(TARG, 1);
3630 tmps = SvPVX(TARG);
3631 *tmps++ = (char)value;
3632 *tmps = '\0';
3633 (void)SvPOK_only(TARG);
3635 SETTARG;
3636 return NORMAL;
3637 }
3639 PP(pp_crypt)
3640 {
3641 #ifdef HAS_CRYPT
3642 dSP; dTARGET;
3643 dPOPTOPssrl;
3644 STRLEN len;
3645 const char *tmps = SvPV_const(left, len);
3647 if (DO_UTF8(left)) {
3648 /* If Unicode, try to downgrade.
3649 * If not possible, croak.
3650 * Yes, we made this up. */
3651 SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
3653 sv_utf8_downgrade(tsv, FALSE);
3654 tmps = SvPV_const(tsv, len);
3655 }
3656 # ifdef USE_ITHREADS
3657 # ifdef HAS_CRYPT_R
3658 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3659 /* This should be threadsafe because in ithreads there is only
3660 * one thread per interpreter. If this would not be true,
3661 * we would need a mutex to protect this malloc. */
3662 PL_reentrant_buffer->_crypt_struct_buffer =
3663 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3664 #if defined(__GLIBC__) || defined(__EMX__)
3665 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3666 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3667 #if (defined(__GLIBC__) && __GLIBC__ == 2) && \
3668 (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4)
3669 /* work around glibc-2.2.5 bug, has been fixed at some
3670 * time in glibc-2.3.X */
3671 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3672 #endif
3673 }
3674 #endif
3675 }
3676 # endif /* HAS_CRYPT_R */
3677 # endif /* USE_ITHREADS */
3678 # ifdef FCRYPT
3679 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3680 # else
3681 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3682 # endif
3683 SvUTF8_off(TARG);
3684 SETTARG;
3685 RETURN;
3686 #else
3687 DIE(aTHX_
3688 "The crypt() function is unimplemented due to excessive paranoia.");
3689 #endif
3690 }
3692 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3693 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3696 /* also used for: pp_lcfirst() */
3698 PP(pp_ucfirst)
3699 {
3700 /* Actually is both lcfirst() and ucfirst(). Only the first character
3701 * changes. This means that possibly we can change in-place, ie., just
3702 * take the source and change that one character and store it back, but not
3703 * if read-only etc, or if the length changes */
3705 dSP;
3706 SV *source = TOPs;
3707 STRLEN slen; /* slen is the byte length of the whole SV. */
3708 STRLEN need;
3709 SV *dest;
3710 bool inplace; /* ? Convert first char only, in-place */
3711 bool doing_utf8 = FALSE; /* ? using utf8 */
3712 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3713 const int op_type = PL_op->op_type;
3714 const U8 *s;
3715 U8 *d;
3716 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3717 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3718 * stored as UTF-8 at s. */
3719 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3720 * lowercased) character stored in tmpbuf. May be either
3721 * UTF-8 or not, but in either case is the number of bytes */
3722 bool remove_dot_above = FALSE;
3724 s = (const U8*)SvPV_const(source, slen);
3726 /* We may be able to get away with changing only the first character, in
3727 * place, but not if read-only, etc. Later we may discover more reasons to
3728 * not convert in-place. */
3729 inplace = !SvREADONLY(source) && SvPADTMP(source);
3731 #ifdef USE_LOCALE_CTYPE
3733 if (IN_LC_RUNTIME(LC_CTYPE)) {
3734 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
3735 }
3737 #endif
3739 /* First calculate what the changed first character should be. This affects
3740 * whether we can just swap it out, leaving the rest of the string unchanged,
3741 * or even if have to convert the dest to UTF-8 when the source isn't */
3743 if (! slen) { /* If empty */
3744 need = 1; /* still need a trailing NUL */
3745 ulen = 0;
3746 *tmpbuf = '\0';
3747 }
3748 else if (DO_UTF8(source)) { /* Is the source utf8? */
3749 doing_utf8 = TRUE;
3750 ulen = UTF8SKIP(s);
3752 if (op_type == OP_UCFIRST) {
3753 #ifdef USE_LOCALE_CTYPE
3754 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3755 #else
3756 _toTITLE_utf8_flags(s, s +slen, tmpbuf, &tculen, 0);
3757 #endif
3758 }
3759 else {
3761 #ifdef USE_LOCALE_CTYPE
3763 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3765 /* In turkic locales, lower casing an 'I' normally yields U+0131,
3766 * LATIN SMALL LETTER DOTLESS I, but not if the grapheme also
3767 * contains a COMBINING DOT ABOVE. Instead it is treated like
3768 * LATIN CAPITAL LETTER I WITH DOT ABOVE lowercased to 'i'. The
3769 * call to lowercase above has handled this. But SpecialCasing.txt
3770 * says we are supposed to remove the COMBINING DOT ABOVE. We can
3771 * tell if we have this situation if I ==> i in a turkic locale. */
3772 if ( UNLIKELY(PL_in_utf8_turkic_locale)
3773 && IN_LC_RUNTIME(LC_CTYPE)
3774 && (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')))
3775 {
3776 /* Here, we know there was a COMBINING DOT ABOVE. We won't be
3777 * able to handle this in-place. */
3778 inplace = FALSE;
3780 /* It seems likely that the DOT will immediately follow the
3781 * 'I'. If so, we can remove it simply by indicating to the
3782 * code below to start copying the source just beyond the DOT.
3783 * We know its length is 2 */
3784 if (LIKELY(memBEGINs(s + 1, s + slen, COMBINING_DOT_ABOVE_UTF8))) {
3785 ulen += 2;
3786 }
3787 else { /* But if it doesn't follow immediately, set a flag for
3788 the code below */
3789 remove_dot_above = TRUE;
3790 }
3791 }
3792 #else
3793 PERL_UNUSED_VAR(remove_dot_above);
3795 _toLOWER_utf8_flags(s, s + slen, tmpbuf, &tculen, 0);
3796 #endif
3798 }
3800 /* we can't do in-place if the length changes. */
3801 if (ulen != tculen) inplace = FALSE;
3802 need = slen + 1 - ulen + tculen;
3803 }
3804 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3805 * latin1 is treated as caseless. Note that a locale takes
3806 * precedence */
3807 ulen = 1; /* Original character is 1 byte */
3808 tculen = 1; /* Most characters will require one byte, but this will
3809 * need to be overridden for the tricky ones */
3810 need = slen + 1;
3813 #ifdef USE_LOCALE_CTYPE
3815 if (IN_LC_RUNTIME(LC_CTYPE)) {
3816 if ( UNLIKELY(PL_in_utf8_turkic_locale)
3817 && ( (op_type == OP_LCFIRST && UNLIKELY(*s == 'I'))
3818 || (op_type == OP_UCFIRST && UNLIKELY(*s == 'i'))))
3819 {
3820 if (*s == 'I') { /* lcfirst('I') */
3821 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
3822 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
3823 }
3824 else { /* ucfirst('i') */
3825 tmpbuf[0] = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3826 tmpbuf[1] = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
3827 }
3828 tculen = 2;
3829 inplace = FALSE;
3830 doing_utf8 = TRUE;
3831 convert_source_to_utf8 = TRUE;
3832 need += variant_under_utf8_count(s, s + slen);
3833 }
3834 else if (op_type == OP_LCFIRST) {
3836 /* For lc, there are no gotchas for UTF-8 locales (other than
3837 * the turkish ones already handled above) */
3838 *tmpbuf = toLOWER_LC(*s);
3839 }
3840 else { /* ucfirst */
3842 /* But for uc, some characters require special handling */
3843 if (IN_UTF8_CTYPE_LOCALE) {
3844 goto do_uni_rules;
3845 }
3847 /* This would be a bug if any locales have upper and title case
3848 * different */
3849 *tmpbuf = (U8) toUPPER_LC(*s);
3850 }
3851 }
3852 else
3853 #endif
3854 /* Here, not in locale. If not using Unicode rules, is a simple
3855 * lower/upper, depending */
3856 if (! IN_UNI_8_BIT) {
3857 *tmpbuf = (op_type == OP_LCFIRST)
3858 ? toLOWER(*s)
3859 : toUPPER(*s);
3860 }
3861 else if (op_type == OP_LCFIRST) {
3862 /* lower case the first letter: no trickiness for any character */
3863 *tmpbuf = toLOWER_LATIN1(*s);
3864 }
3865 else {
3866 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3867 * non-turkic UTF-8, which we treat as not in locale), and cased
3868 * latin1 */
3869 UV title_ord;
3870 #ifdef USE_LOCALE_CTYPE
3871 do_uni_rules:
3872 #endif
3874 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3875 if (tculen > 1) {
3876 assert(tculen == 2);
3878 /* If the result is an upper Latin1-range character, it can
3879 * still be represented in one byte, which is its ordinal */
3880 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3881 *tmpbuf = (U8) title_ord;
3882 tculen = 1;
3883 }
3884 else {
3885 /* Otherwise it became more than one ASCII character (in
3886 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3887 * beyond Latin1, so the number of bytes changed, so can't
3888 * replace just the first character in place. */
3889 inplace = FALSE;
3891 /* If the result won't fit in a byte, the entire result
3892 * will have to be in UTF-8. Allocate enough space for the
3893 * expanded first byte, and if UTF-8, the rest of the input
3894 * string, some or all of which may also expand to two
3895 * bytes, plus the terminating NUL. */
3896 if (title_ord > 255) {
3897 doing_utf8 = TRUE;
3898 convert_source_to_utf8 = TRUE;
3899 need = slen
3900 + variant_under_utf8_count(s, s + slen)
3901 + 1;
3903 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3904 * characters whose title case is above 255 is
3905 * 2. */
3906 ulen = 2;
3907 }
3908 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3909 need = slen + 1 + 1;
3910 }
3911 }
3912 }
3913 } /* End of use Unicode (Latin1) semantics */
3914 } /* End of changing the case of the first character */
3916 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3917 * generate the result */
3918 if (inplace) {
3920 /* We can convert in place. This means we change just the first
3921 * character without disturbing the rest; no need to grow */
3922 dest = source;
3923 s = d = (U8*)SvPV_force_nomg(source, slen);
3924 } else {
3925 dTARGET;
3927 dest = TARG;
3929 /* Here, we can't convert in place; we earlier calculated how much
3930 * space we will need, so grow to accommodate that */
3931 SvUPGRADE(dest, SVt_PV);
3932 d = (U8*)SvGROW(dest, need);
3933 (void)SvPOK_only(dest);
3935 SETs(dest);
3936 }
3938 if (doing_utf8) {
3939 if (! inplace) {
3940 if (! convert_source_to_utf8) {
3942 /* Here both source and dest are in UTF-8, but have to create
3943 * the entire output. We initialize the result to be the
3944 * title/lower cased first character, and then append the rest
3945 * of the string. */
3946 sv_setpvn(dest, (char*)tmpbuf, tculen);
3947 if (slen > ulen) {
3949 /* But this boolean being set means we are in a turkic
3950 * locale, and there is a DOT character that needs to be
3951 * removed, and it isn't immediately after the current
3952 * character. Keep concatenating characters to the output
3953 * one at a time, until we find the DOT, which we simply
3954 * skip */
3955 if (UNLIKELY(remove_dot_above)) {
3956 do {
3957 Size_t this_len = UTF8SKIP(s + ulen);
3959 sv_catpvn(dest, (char*)(s + ulen), this_len);
3961 ulen += this_len;
3962 if (memBEGINs(s + ulen, s + slen, COMBINING_DOT_ABOVE_UTF8)) {
3963 ulen += 2;
3964 break;
3965 }
3966 } while (s + ulen < s + slen);
3967 }
3969 /* The rest of the string can be concatenated unchanged,
3970 * all at once */
3971 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3972 }
3973 }
3974 else {
3975 const U8 *const send = s + slen;
3977 /* Here the dest needs to be in UTF-8, but the source isn't,
3978 * except we earlier UTF-8'd the first character of the source
3979 * into tmpbuf. First put that into dest, and then append the
3980 * rest of the source, converting it to UTF-8 as we go. */
3982 /* Assert tculen is 2 here because the only characters that
3983 * get to this part of the code have 2-byte UTF-8 equivalents */
3984 assert(tculen == 2);
3985 *d++ = *tmpbuf;
3986 *d++ = *(tmpbuf + 1);
3987 s++; /* We have just processed the 1st char */
3989 while (s < send) {
3990 append_utf8_from_native_byte(*s, &d);
3991 s++;
3992 }
3994 *d = '\0';
3995 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3996 }
3997 SvUTF8_on(dest);
3998 }
3999 else { /* in-place UTF-8. Just overwrite the first character */
4000 Copy(tmpbuf, d, tculen, U8);
4001 SvCUR_set(dest, need - 1);
4002 }
4004 }
4005 else { /* Neither source nor dest are, nor need to be UTF-8 */
4006 if (slen) {
4007 if (inplace) { /* in-place, only need to change the 1st char */
4008 *d = *tmpbuf;
4009 }
4010 else { /* Not in-place */
4012 /* Copy the case-changed character(s) from tmpbuf */
4013 Copy(tmpbuf, d, tculen, U8);
4014 d += tculen - 1; /* Code below expects d to point to final
4015 * character stored */
4016 }
4017 }
4018 else { /* empty source */
4019 /* See bug #39028: Don't taint if empty */
4020 *d = *s;
4021 }
4023 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4024 * the destination to retain that flag */
4025 if (DO_UTF8(source))
4026 SvUTF8_on(dest);
4028 if (!inplace) { /* Finish the rest of the string, unchanged */
4029 /* This will copy the trailing NUL */
4030 Copy(s + 1, d + 1, slen, U8);
4031 SvCUR_set(dest, need - 1);
4032 }
4033 }
4034 #ifdef USE_LOCALE_CTYPE
4035 if (IN_LC_RUNTIME(LC_CTYPE)) {
4036 TAINT;
4037 SvTAINTED_on(dest);
4038 }
4039 #endif
4040 if (dest != source && SvTAINTED(source))
4041 SvTAINT(dest);
4042 SvSETMAGIC(dest);
4043 return NORMAL;
4044 }
4046 PP(pp_uc)
4047 {
4048 dVAR;
4049 dSP;
4050 SV *source = TOPs;
4051 STRLEN len;
4052 STRLEN min;
4053 SV *dest;
4054 const U8 *s;
4055 U8 *d;
4057 SvGETMAGIC(source);
4059 if ( SvPADTMP(source)
4060 && !SvREADONLY(source) && SvPOK(source)
4061 && !DO_UTF8(source)
4062 && (
4063 #ifdef USE_LOCALE_CTYPE
4064 (IN_LC_RUNTIME(LC_CTYPE))
4065 ? ! IN_UTF8_CTYPE_LOCALE
4066 :
4067 #endif
4068 ! IN_UNI_8_BIT))
4069 {
4071 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4072 * make the loop tight, so we overwrite the source with the dest before
4073 * looking at it, and we need to look at the original source
4074 * afterwards. There would also need to be code added to handle
4075 * switching to not in-place in midstream if we run into characters
4076 * that change the length. Since being in locale overrides UNI_8_BIT,
4077 * that latter becomes irrelevant in the above test; instead for
4078 * locale, the size can't normally change, except if the locale is a
4079 * UTF-8 one */
4080 dest = source;
4081 s = d = (U8*)SvPV_force_nomg(source, len);
4082 min = len + 1;
4083 } else {
4084 dTARGET;
4086 dest = TARG;
4088 s = (const U8*)SvPV_nomg_const(source, len);
4089 min = len + 1;
4091 SvUPGRADE(dest, SVt_PV);
4092 d = (U8*)SvGROW(dest, min);
4093 (void)SvPOK_only(dest);
4095 SETs(dest);
4096 }
4098 #ifdef USE_LOCALE_CTYPE
4100 if (IN_LC_RUNTIME(LC_CTYPE)) {
4101 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4102 }
4104 #endif
4106 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4107 to check DO_UTF8 again here. */
4109 if (DO_UTF8(source)) {
4110 const U8 *const send = s + len;
4111 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4113 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4114 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4115 /* All occurrences of these are to be moved to follow any other marks.
4116 * This is context-dependent. We may not be passed enough context to
4117 * move the iota subscript beyond all of them, but we do the best we can
4118 * with what we're given. The result is always better than if we
4119 * hadn't done this. And, the problem would only arise if we are
4120 * passed a character without all its combining marks, which would be
4121 * the caller's mistake. The information this is based on comes from a
4122 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4123 * itself) and so can't be checked properly to see if it ever gets
4124 * revised. But the likelihood of it changing is remote */
4125 bool in_iota_subscript = FALSE;
4127 while (s < send) {
4128 STRLEN u;
4129 STRLEN ulen;
4130 UV uv;
4131 if (UNLIKELY(in_iota_subscript)) {
4132 UV cp = utf8_to_uvchr_buf(s, send, NULL);
4134 if (! _invlist_contains_cp(PL_utf8_mark, cp)) {
4136 /* A non-mark. Time to output the iota subscript */
4137 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4138 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4139 in_iota_subscript = FALSE;
4140 }
4141 }
4143 /* Then handle the current character. Get the changed case value
4144 * and copy it to the output buffer */
4146 u = UTF8SKIP(s);
4147 #ifdef USE_LOCALE_CTYPE
4148 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4149 #else
4150 uv = _toUPPER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4151 #endif
4152 if (uv == GREEK_CAPITAL_LETTER_IOTA
4153 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4154 {
4155 in_iota_subscript = TRUE;
4156 }
4157 else {
4158 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4159 /* If the eventually required minimum size outgrows the
4160 * available space, we need to grow. */
4161 const UV o = d - (U8*)SvPVX_const(dest);
4163 /* If someone uppercases one million U+03B0s we SvGROW()
4164 * one million times. Or we could try guessing how much to
4165 * allocate without allocating too much. But we can't
4166 * really guess without examining the rest of the string.
4167 * Such is life. See corresponding comment in lc code for
4168 * another option */
4169 d = o + (U8*) SvGROW(dest, min);
4170 }
4171 Copy(tmpbuf, d, ulen, U8);
4172 d += ulen;
4173 }
4174 s += u;
4175 }
4176 if (in_iota_subscript) {
4177 *d++ = UTF8_TWO_BYTE_HI(GREEK_CAPITAL_LETTER_IOTA);
4178 *d++ = UTF8_TWO_BYTE_LO(GREEK_CAPITAL_LETTER_IOTA);
4179 }
4180 SvUTF8_on(dest);
4181 *d = '\0';
4183 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4184 }
4185 else { /* Not UTF-8 */
4186 if (len) {
4187 const U8 *const send = s + len;
4189 /* Use locale casing if in locale; regular style if not treating
4190 * latin1 as having case; otherwise the latin1 casing. Do the
4191 * whole thing in a tight loop, for speed, */
4192 #ifdef USE_LOCALE_CTYPE
4193 if (IN_LC_RUNTIME(LC_CTYPE)) {
4194 if (IN_UTF8_CTYPE_LOCALE) {
4195 goto do_uni_rules;
4196 }
4197 for (; s < send; d++, s++)
4198 *d = (U8) toUPPER_LC(*s);
4199 }
4200 else
4201 #endif
4202 if (! IN_UNI_8_BIT) {
4203 for (; s < send; d++, s++) {
4204 *d = toUPPER(*s);
4205 }
4206 }
4207 else {
4208 #ifdef USE_LOCALE_CTYPE
4209 do_uni_rules:
4210 #endif
4211 for (; s < send; d++, s++) {
4212 Size_t extra;
4214 *d = toUPPER_LATIN1_MOD(*s);
4215 if ( LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)
4217 #ifdef USE_LOCALE_CTYPE
4219 && (LIKELY( ! PL_in_utf8_turkic_locale
4220 || ! IN_LC_RUNTIME(LC_CTYPE))
4221 || *s != 'i')
4222 #endif
4224 ) {
4225 continue;
4226 }
4228 /* The mainstream case is the tight loop above. To avoid
4229 * extra tests in that, all three characters that always
4230 * require special handling are mapped by the MOD to the
4231 * one tested just above. Use the source to distinguish
4232 * between those cases */
4234 #if UNICODE_MAJOR_VERSION > 2 \
4235 || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \
4236 && UNICODE_DOT_DOT_VERSION >= 8)
4237 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4239 /* uc() of this requires 2 characters, but they are
4240 * ASCII. If not enough room, grow the string */
4241 if (SvLEN(dest) < ++min) {
4242 const UV o = d - (U8*)SvPVX_const(dest);
4243 d = o + (U8*) SvGROW(dest, min);
4244 }
4245 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4246 continue; /* Back to the tight loop; still in ASCII */
4247 }
4248 #endif
4250 /* The other special handling characters have their
4251 * upper cases outside the latin1 range, hence need to be
4252 * in UTF-8, so the whole result needs to be in UTF-8.
4253 *
4254 * So, here we are somewhere in the middle of processing a
4255 * non-UTF-8 string, and realize that we will have to
4256 * convert the whole thing to UTF-8. What to do? There
4257 * are several possibilities. The simplest to code is to
4258 * convert what we have so far, set a flag, and continue on
4259 * in the loop. The flag would be tested each time through
4260 * the loop, and if set, the next character would be
4261 * converted to UTF-8 and stored. But, I (khw) didn't want
4262 * to slow down the mainstream case at all for this fairly
4263 * rare case, so I didn't want to add a test that didn't
4264 * absolutely have to be there in the loop, besides the
4265 * possibility that it would get too complicated for
4266 * optimizers to deal with. Another possibility is to just
4267 * give up, convert the source to UTF-8, and restart the
4268 * function that way. Another possibility is to convert
4269 * both what has already been processed and what is yet to
4270 * come separately to UTF-8, then jump into the loop that
4271 * handles UTF-8. But the most efficient time-wise of the
4272 * ones I could think of is what follows, and turned out to
4273 * not require much extra code.
4274 *
4275 * First, calculate the extra space needed for the
4276 * remainder of the source needing to be in UTF-8. Except
4277 * for the 'i' in Turkic locales, in UTF-8 strings, the
4278 * uppercase of a character below 256 occupies the same
4279 * number of bytes as the original. Therefore, the space
4280 * needed is the that number plus the number of characters
4281 * that become two bytes when converted to UTF-8, plus, in
4282 * turkish locales, the number of 'i's. */
4284 extra = send - s + variant_under_utf8_count(s, send);
4286 #ifdef USE_LOCALE_CTYPE
4288 if (UNLIKELY(*s == 'i')) { /* We wouldn't get an 'i' here
4289 unless are in a Turkic
4290 locale */
4291 const U8 * s_peek = s;
4293 do {
4294 extra++;
4296 s_peek = (U8 *) memchr(s_peek + 1, 'i',
4297 send - (s_peek + 1));
4298 } while (s_peek != NULL);
4299 }
4300 #endif
4302 /* Convert what we have so far into UTF-8, telling the
4303 * function that we know it should be converted, and to
4304 * allow extra space for what we haven't processed yet.
4305 *
4306 * This may cause the string pointer to move, so need to
4307 * save and re-find it. */
4309 len = d - (U8*)SvPVX_const(dest);
4310 SvCUR_set(dest, len);
4311 len = sv_utf8_upgrade_flags_grow(dest,
4312 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4313 extra
4314 + 1 /* trailing NUL */ );
4315 d = (U8*)SvPVX(dest) + len;
4317 /* Now process the remainder of the source, simultaneously
4318 * converting to upper and UTF-8.
4319 *
4320 * To avoid extra tests in the loop body, and since the
4321 * loop is so simple, split out the rare Turkic case into
4322 * its own loop */
4324 #ifdef USE_LOCALE_CTYPE
4325 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4326 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE)))
4327 {
4328 for (; s < send; s++) {
4329 if (*s == 'i') {
4330 *d++ = UTF8_TWO_BYTE_HI(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4331 *d++ = UTF8_TWO_BYTE_LO(LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
4332 }
4333 else {
4334 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4335 d += len;
4336 }
4337 }
4338 }
4339 else
4340 #endif
4341 for (; s < send; s++) {
4342 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4343 d += len;
4344 }
4346 /* Here have processed the whole source; no need to
4347 * continue with the outer loop. Each character has been
4348 * converted to upper case and converted to UTF-8. */
4349 break;
4350 } /* End of processing all latin1-style chars */
4351 } /* End of processing all chars */
4352 } /* End of source is not empty */
4354 if (source != dest) {
4355 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4356 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4357 }
4358 } /* End of isn't utf8 */
4359 #ifdef USE_LOCALE_CTYPE
4360 if (IN_LC_RUNTIME(LC_CTYPE)) {
4361 TAINT;
4362 SvTAINTED_on(dest);
4363 }
4364 #endif
4365 if (dest != source && SvTAINTED(source))
4366 SvTAINT(dest);
4367 SvSETMAGIC(dest);
4368 return NORMAL;
4369 }
4371 PP(pp_lc)
4372 {
4373 dSP;
4374 SV *source = TOPs;
4375 STRLEN len;
4376 STRLEN min;
4377 SV *dest;
4378 const U8 *s;
4379 U8 *d;
4380 bool has_turkic_I = FALSE;
4382 SvGETMAGIC(source);
4384 if ( SvPADTMP(source)
4385 && !SvREADONLY(source) && SvPOK(source)
4386 && !DO_UTF8(source)
4388 #ifdef USE_LOCALE_CTYPE
4390 && ( LIKELY(! IN_LC_RUNTIME(LC_CTYPE))
4391 || LIKELY(! PL_in_utf8_turkic_locale))
4393 #endif
4395 ) {
4397 /* We can convert in place, as, outside of Turkic UTF-8 locales,
4398 * lowercasing anything in the latin1 range (or else DO_UTF8 would have
4399 * been on) doesn't lengthen it. */
4400 dest = source;
4401 s = d = (U8*)SvPV_force_nomg(source, len);
4402 min = len + 1;
4403 } else {
4404 dTARGET;
4406 dest = TARG;
4408 s = (const U8*)SvPV_nomg_const(source, len);
4409 min = len + 1;
4411 SvUPGRADE(dest, SVt_PV);
4412 d = (U8*)SvGROW(dest, min);
4413 (void)SvPOK_only(dest);
4415 SETs(dest);
4416 }
4418 #ifdef USE_LOCALE_CTYPE
4420 if (IN_LC_RUNTIME(LC_CTYPE)) {
4421 const U8 * next_I;
4423 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4425 /* Lowercasing in a Turkic locale can cause non-UTF-8 to need to become
4426 * UTF-8 for the single case of the character 'I' */
4427 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4428 && ! DO_UTF8(source)
4429 && (next_I = (U8 *) memchr(s, 'I', len)))
4430 {
4431 Size_t I_count = 0;
4432 const U8 *const send = s + len;
4434 do {
4435 I_count++;
4437 next_I = (U8 *) memchr(next_I + 1, 'I',
4438 send - (next_I + 1));
4439 } while (next_I != NULL);
4441 /* Except for the 'I', in UTF-8 strings, the lower case of a
4442 * character below 256 occupies the same number of bytes as the
4443 * original. Therefore, the space needed is the original length
4444 * plus I_count plus the number of characters that become two bytes
4445 * when converted to UTF-8 */
4446 sv_utf8_upgrade_flags_grow(dest, 0, len
4447 + I_count
4448 + variant_under_utf8_count(s, send)
4449 + 1 /* Trailing NUL */ );
4450 d = (U8*)SvPVX(dest);
4451 has_turkic_I = TRUE;
4452 }
4453 }
4455 #endif
4457 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4458 to check DO_UTF8 again here. */
4460 if (DO_UTF8(source)) {
4461 const U8 *const send = s + len;
4462 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4463 bool remove_dot_above = FALSE;
4465 while (s < send) {
4466 const STRLEN u = UTF8SKIP(s);
4467 STRLEN ulen;
4469 #ifdef USE_LOCALE_CTYPE
4471 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4473 /* If we are in a Turkic locale, we have to do more work. As noted
4474 * in the comments for lcfirst, there is a special case if a 'I'
4475 * is in a grapheme with COMBINING DOT ABOVE UTF8. It turns into a
4476 * 'i', and the DOT must be removed. We check for that situation,
4477 * and set a flag if the DOT is there. Then each time through the
4478 * loop, we have to see if we need to remove the next DOT above,
4479 * and if so, do it. We know that there is a DOT because
4480 * _toLOWER_utf8_flags() wouldn't have returned 'i' unless there
4481 * was one in a proper position. */
4482 if ( UNLIKELY(PL_in_utf8_turkic_locale)
4483 && IN_LC_RUNTIME(LC_CTYPE))
4484 {
4485 if ( UNLIKELY(remove_dot_above)
4486 && memBEGINs(tmpbuf, sizeof(tmpbuf), COMBINING_DOT_ABOVE_UTF8))
4487 {
4488 s += u;
4489 remove_dot_above = FALSE;
4490 continue;
4491 }
4492 else if (UNLIKELY(*s == 'I' && tmpbuf[0] == 'i')) {
4493 remove_dot_above = TRUE;
4494 }
4495 }
4496 #else
4497 PERL_UNUSED_VAR(remove_dot_above);
4499 _toLOWER_utf8_flags(s, send, tmpbuf, &ulen, 0);
4500 #endif
4502 /* Here is where we would do context-sensitive actions for the
4503 * Greek final sigma. See the commit message for 86510fb15 for why
4504 * there isn't any */
4506 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4508 /* If the eventually required minimum size outgrows the
4509 * available space, we need to grow. */
4510 const UV o = d - (U8*)SvPVX_const(dest);
4512 /* If someone lowercases one million U+0130s we SvGROW() one
4513 * million times. Or we could try guessing how much to
4514 * allocate without allocating too much. Such is life.
4515 * Another option would be to grow an extra byte or two more
4516 * each time we need to grow, which would cut down the million
4517 * to 500K, with little waste */
4518 d = o + (U8*) SvGROW(dest, min);
4519 }
4521 /* Copy the newly lowercased letter to the output buffer we're
4522 * building */
4523 Copy(tmpbuf, d, ulen, U8);
4524 d += ulen;
4525 s += u;
4526 } /* End of looping through the source string */
4527 SvUTF8_on(dest);
4528 *d = '\0';
4529 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4530 } else { /* 'source' not utf8 */
4531 if (len) {
4532 const U8 *const send = s + len;
4534 /* Use locale casing if in locale; regular style if not treating
4535 * latin1 as having case; otherwise the latin1 casing. Do the
4536 * whole thing in a tight loop, for speed, */
4537 #ifdef USE_LOCALE_CTYPE
4538 if (IN_LC_RUNTIME(LC_CTYPE)) {
4539 if (LIKELY( ! has_turkic_I)) {
4540 for (; s < send; d++, s++)
4541 *d = toLOWER_LC(*s);
4542 }
4543 else { /* This is the only case where lc() converts 'dest'
4544 into UTF-8 from a non-UTF-8 'source' */
4545 for (; s < send; s++) {
4546 if (*s == 'I') {
4547 *d++ = UTF8_TWO_BYTE_HI(LATIN_SMALL_LETTER_DOTLESS_I);
4548 *d++ = UTF8_TWO_BYTE_LO(LATIN_SMALL_LETTER_DOTLESS_I);
4549 }
4550 else {
4551 append_utf8_from_native_byte(toLOWER_LATIN1(*s), &d);
4552 }
4553 }
4554 }
4555 }
4556 else
4557 #endif
4558 if (! IN_UNI_8_BIT) {
4559 for (; s < send; d++, s++) {
4560 *d = toLOWER(*s);
4561 }
4562 }
4563 else {
4564 for (; s < send; d++, s++) {
4565 *d = toLOWER_LATIN1(*s);
4566 }
4567 }
4568 }
4569 if (source != dest) {
4570 *d = '\0';
4571 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4572 }
4573 }
4574 #ifdef USE_LOCALE_CTYPE
4575 if (IN_LC_RUNTIME(LC_CTYPE)) {
4576 TAINT;
4577 SvTAINTED_on(dest);
4578 }
4579 #endif
4580 if (dest != source && SvTAINTED(source))
4581 SvTAINT(dest);
4582 SvSETMAGIC(dest);
4583 return NORMAL;
4584 }
4586 PP(pp_quotemeta)
4587 {
4588 dSP; dTARGET;
4589 SV * const sv = TOPs;
4590 STRLEN len;
4591 const char *s = SvPV_const(sv,len);
4593 SvUTF8_off(TARG); /* decontaminate */
4594 if (len) {
4595 char *d;
4596 SvUPGRADE(TARG, SVt_PV);
4597 SvGROW(TARG, (len * 2) + 1);
4598 d = SvPVX(TARG);
4599 if (DO_UTF8(sv)) {
4600 while (len) {
4601 STRLEN ulen = UTF8SKIP(s);
4602 bool to_quote = FALSE;
4604 if (UTF8_IS_INVARIANT(*s)) {
4605 if (_isQUOTEMETA(*s)) {
4606 to_quote = TRUE;
4607 }
4608 }
4609 else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, s + len)) {
4610 if (
4611 #ifdef USE_LOCALE_CTYPE
4612 /* In locale, we quote all non-ASCII Latin1 chars.
4613 * Otherwise use the quoting rules */
4615 IN_LC_RUNTIME(LC_CTYPE)
4616 ||
4617 #endif
4618 _isQUOTEMETA(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1))))
4619 {
4620 to_quote = TRUE;
4621 }
4622 }
4623 else if (is_QUOTEMETA_high(s)) {
4624 to_quote = TRUE;
4625 }
4627 if (to_quote) {
4628 *d++ = '\\';
4629 }
4630 if (ulen > len)
4631 ulen = len;
4632 len -= ulen;
4633 while (ulen--)
4634 *d++ = *s++;
4635 }
4636 SvUTF8_on(TARG);
4637 }
4638 else if (IN_UNI_8_BIT) {
4639 while (len--) {
4640 if (_isQUOTEMETA(*s))
4641 *d++ = '\\';
4642 *d++ = *s++;
4643 }
4644 }
4645 else {
4646 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4647 * including everything above ASCII */
4648 while (len--) {
4649 if (!isWORDCHAR_A(*s))
4650 *d++ = '\\';
4651 *d++ = *s++;
4652 }
4653 }
4654 *d = '\0';
4655 SvCUR_set(TARG, d - SvPVX_const(TARG));
4656 (void)SvPOK_only_UTF8(TARG);
4657 }
4658 else
4659 sv_setpvn(TARG, s, len);
4660 SETTARG;
4661 return NORMAL;
4662 }
4664 PP(pp_fc)
4665 {
4666 dTARGET;
4667 dSP;
4668 SV *source = TOPs;
4669 STRLEN len;
4670 STRLEN min;
4671 SV *dest;
4672 const U8 *s;
4673 const U8 *send;
4674 U8 *d;
4675 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4676 #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
4677 || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
4678 || UNICODE_DOT_DOT_VERSION > 0)
4679 const bool full_folding = TRUE; /* This variable is here so we can easily
4680 move to more generality later */
4681 #else
4682 const bool full_folding = FALSE;
4683 #endif
4684 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4685 #ifdef USE_LOCALE_CTYPE
4686 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4687 #endif
4688 ;
4690 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4691 * You are welcome(?) -Hugmeir
4692 */
4694 SvGETMAGIC(source);
4696 dest = TARG;
4698 if (SvOK(source)) {
4699 s = (const U8*)SvPV_nomg_const(source, len);
4700 } else {
4701 if (ckWARN(WARN_UNINITIALIZED))
4702 report_uninit(source);
4703 s = (const U8*)"";
4704 len = 0;
4705 }
4707 min = len + 1;
4709 SvUPGRADE(dest, SVt_PV);
4710 d = (U8*)SvGROW(dest, min);
4711 (void)SvPOK_only(dest);
4713 SETs(dest);
4715 send = s + len;
4717 #ifdef USE_LOCALE_CTYPE
4719 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4720 _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
4721 }
4723 #endif
4725 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4726 while (s < send) {
4727 const STRLEN u = UTF8SKIP(s);
4728 STRLEN ulen;
4730 _toFOLD_utf8_flags(s, send, tmpbuf, &ulen, flags);
4732 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4733 const UV o = d - (U8*)SvPVX_const(dest);
4734 d = o + (U8*) SvGROW(dest, min);
4735 }
4737 Copy(tmpbuf, d, ulen, U8);
4738 d += ulen;
4739 s += u;
4740 }
4741 SvUTF8_on(dest);
4742 } /* Unflagged string */
4743 else if (len) {
4744 #ifdef USE_LOCALE_CTYPE
4745 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4746 if (IN_UTF8_CTYPE_LOCALE) {
4747 goto do_uni_folding;
4748 }
4749 for (; s < send; d++, s++)
4750 *d = (U8) toFOLD_LC(*s);
4751 }
4752 else
4753 #endif
4754 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4755 for (; s < send; d++, s++)
4756 *d = toFOLD(*s);
4757 }
4758 else {
4759 #ifdef USE_LOCALE_CTYPE
4760 do_uni_folding:
4761 #endif
4762 /* For ASCII and the Latin-1 range, there's potentially three
4763 * troublesome folds:
4764 * \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4765 * casefolding becomes 'ss';
4766 * \x{B5} (\N{MICRO SIGN}), which under any fold becomes
4767 * \x{3BC} (\N{GREEK SMALL LETTER MU})
4768 * I only in Turkic locales, this folds to \x{131}
4769 * \N{LATIN SMALL LETTER DOTLESS I}
4770 * For the rest, the casefold is their lowercase. */
4771 for (; s < send; d++, s++) {
4772 if ( UNLIKELY(*s == MICRO_SIGN)
4773 #ifdef USE_LOCALE_CTYPE
4774 || ( UNLIKELY(PL_in_utf8_turkic_locale)
4775 && UNLIKELY(IN_LC_RUNTIME(LC_CTYPE))
4776 && UNLIKELY(*s == 'I'))
4777 #endif
4778 ) {
4779 Size_t extra = send - s
4780 + variant_under_utf8_count(s, send);
4782 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4783 * and 'I' in Turkic locales is \N{LATIN SMALL LETTER
4784 * DOTLESS I} both of which are outside of the latin-1
4785 * range. There's a couple of ways to deal with this -- khw
4786 * discusses them in pp_lc/uc, so go there :) What we do
4787 * here is upgrade what we had already casefolded, then
4788 * enter an inner loop that appends the rest of the
4789 * characters as UTF-8.
4790 *
4791 * First we calculate the needed size of the upgraded dest
4792 * beyond what's been processed already (the upgrade
4793 * function figures that out). Except for the 'I' in
4794 * Turkic locales, in UTF-8 strings, the fold case of a
4795 * character below 256 occupies the same number of bytes as
4796 * the original (even the Sharp S). Therefore, the space
4797 * needed is the number of bytes remaining plus the number
4798 * of characters that become two bytes when converted to
4799 * UTF-8 plus, in turkish locales, the number of 'I's */
4801 if (UNLIKELY(*s == 'I')) {
4802 const U8 * s_peek = s;
4804 do {
4805 extra++;
4807 s_peek = (U8 *) memchr(s_peek + 1, 'i',
4808 send - (s_peek + 1));
4809 } while (s_peek != NULL);
4810 }
4812 /* Growing may move things, so have to save and recalculate
4813 * 'd' */
4814 len = d - (U8*)SvPVX_const(dest);
4815 SvCUR_set(dest, len);
4816 len = sv_utf8_upgrade_flags_grow(dest,
4817 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4818 extra
4819 + 1 /* Trailing NUL */ );
4820 d = (U8*)SvPVX(dest) + len;
4822 *d++ = UTF8_TWO_BYTE_HI(GREEK_SMALL_LETTER_MU);
4823 *d++ = UTF8_TWO_BYTE_LO(GREEK_SMALL_LETTER_MU);
4824 s++;
4826 for (; s < send; s++) {
4827 STRLEN ulen;
4828 _to_uni_fold_flags(*s, d, &ulen, flags);
4829 d += ulen;
4830 }
4831 break;
4832 }
4833 else if ( UNLIKELY(*s == LATIN_SMALL_LETTER_SHARP_S)
4834 && full_folding)
4835 {
4836 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4837 * becomes "ss", which may require growing the SV. */
4838 if (SvLEN(dest) < ++min) {
4839 const UV o = d - (U8*)SvPVX_const(dest);
4840 d = o + (U8*) SvGROW(dest, min);
4841 }
4842 *(d)++ = 's';
4843 *d = 's';
4844 }
4845 else { /* Else, the fold is the lower case */
4846 *d = toLOWER_LATIN1(*s);
4847 }
4848 }
4849 }
4850 }
4851 *d = '\0';
4852 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4854 #ifdef USE_LOCALE_CTYPE
4855 if (IN_LC_RUNTIME(LC_CTYPE)) {
4856 TAINT;
4857 SvTAINTED_on(dest);
4858 }
4859 #endif
4860 if (SvTAINTED(source))
4861 SvTAINT(dest);
4862 SvSETMAGIC(dest);
4863 RETURN;
4864 }
4866 /* Arrays. */
4868 PP(pp_aslice)
4869 {
4870 dSP; dMARK; dORIGMARK;
4871 AV *const av = MUTABLE_AV(POPs);
4872 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4874 if (SvTYPE(av) == SVt_PVAV) {
4875 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4876 bool can_preserve = FALSE;
4878 if (localizing) {
4879 MAGIC *mg;
4880 HV *stash;
4882 can_preserve = SvCANEXISTDELETE(av);
4883 }
4885 if (lval && localizing) {
4886 SV **svp;
4887 SSize_t max = -1;
4888 for (svp = MARK + 1; svp <= SP; svp++) {
4889 const SSize_t elem = SvIV(*svp);
4890 if (elem > max)
4891 max = elem;
4892 }
4893 if (max > AvMAX(av))
4894 av_extend(av, max);
4895 }
4897 while (++MARK <= SP) {
4898 SV **svp;
4899 SSize_t elem = SvIV(*MARK);
4900 bool preeminent = TRUE;
4902 if (localizing && can_preserve) {
4903 /* If we can determine whether the element exist,
4904 * Try to preserve the existenceness of a tied array
4905 * element by using EXISTS and DELETE if possible.
4906 * Fallback to FETCH and STORE otherwise. */
4907 preeminent = av_exists(av, elem);
4908 }
4910 svp = av_fetch(av, elem, lval);
4911 if (lval) {
4912 if (!svp || !*svp)
4913 DIE(aTHX_ PL_no_aelem, elem);
4914 if (localizing) {
4915 if (preeminent)
4916 save_aelem(av, elem, svp);
4917 else
4918 SAVEADELETE(av, elem);
4919 }
4920 }
4921 *MARK = svp ? *svp : &PL_sv_undef;
4922 }
4923 }
4924 if (GIMME_V != G_ARRAY) {
4925 MARK = ORIGMARK;
4926 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4927 SP = MARK;
4928 }
4929 RETURN;
4930 }
4932 PP(pp_kvaslice)
4933 {
4934 dSP; dMARK;
4935 AV *const av = MUTABLE_AV(POPs);
4936 I32 lval = (PL_op->op_flags & OPf_MOD);
4937 SSize_t items = SP - MARK;
4939 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4940 const I32 flags = is_lvalue_sub();
4941 if (flags) {
4942 if (!(flags & OPpENTERSUB_INARGS))
4943 /* diag_listed_as: Can't modify %s in %s */
4944 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4945 lval = flags;
4946 }
4947 }
4949 MEXTEND(SP,items);
4950 while (items > 1) {
4951 *(MARK+items*2-1) = *(MARK+items);
4952 items--;
4953 }
4954 items = SP-MARK;
4955 SP += items;
4957 while (++MARK <= SP) {
4958 SV **svp;
4960 svp = av_fetch(av, SvIV(*MARK), lval);
4961 if (lval) {
4962 if (!svp || !*svp || *svp == &PL_sv_undef) {
4963 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4964 }
4965 *MARK = sv_mortalcopy(*MARK);
4966 }
4967 *++MARK = svp ? *svp : &PL_sv_undef;
4968 }
4969 if (GIMME_V != G_ARRAY) {
4970 MARK = SP - items*2;
4971 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4972 SP = MARK;
4973 }
4974 RETURN;
4975 }
4978 PP(pp_aeach)
4979 {
4980 dSP;
4981 AV *array = MUTABLE_AV(POPs);
4982 const U8 gimme = GIMME_V;
4983 IV *iterp = Perl_av_iter_p(aTHX_ array);
4984 const IV current = (*iterp)++;
4986 if (current > av_tindex(array)) {
4987 *iterp = 0;
4988 if (gimme == G_SCALAR)
4989 RETPUSHUNDEF;
4990 else
4991 RETURN;
4992 }
4994 EXTEND(SP, 2);
4995 mPUSHi(current);
4996 if (gimme == G_ARRAY) {
4997 SV **const element = av_fetch(array, current, 0);
4998 PUSHs(element ? *element : &PL_sv_undef);
4999 }
5000 RETURN;
5001 }
5003 /* also used for: pp_avalues()*/
5004 PP(pp_akeys)
5005 {
5006 dSP;
5007 AV *array = MUTABLE_AV(POPs);
5008 const U8 gimme = GIMME_V;
5010 *Perl_av_iter_p(aTHX_ array) = 0;
5012 if (gimme == G_SCALAR) {
5013 dTARGET;
5014 PUSHi(av_tindex(array) + 1);
5015 }
5016 else if (gimme == G_ARRAY) {
5017 if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
5018 const I32 flags = is_lvalue_sub();
5019 if (flags && !(flags & OPpENTERSUB_INARGS))
5020 /* diag_listed_as: Can't modify %s in %s */
5021 Perl_croak(aTHX_
5022 "Can't modify keys on array in list assignment");
5023 }
5024 {
5025 IV n = Perl_av_len(aTHX_ array);
5026 IV i;
5028 EXTEND(SP, n + 1);
5030 if ( PL_op->op_type == OP_AKEYS
5031 || ( PL_op->op_type == OP_AVHVSWITCH
5032 && (PL_op->op_private & 3) + OP_AEACH == OP_AKEYS ))
5033 {
5034 for (i = 0; i <= n; i++) {
5035 mPUSHi(i);
5036 }
5037 }
5038 else {
5039 for (i = 0; i <= n; i++) {
5040 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
5041 PUSHs(elem ? *elem : &PL_sv_undef);
5042 }
5043 }
5044 }
5045 }
5046 RETURN;
5047 }
5049 /* Associative arrays. */
5051 PP(pp_each)
5052 {
5053 dSP;
5054 HV * hash = MUTABLE_HV(POPs);
5055 HE *entry;
5056 const U8 gimme = GIMME_V;
5058 entry = hv_iternext(hash);
5060 EXTEND(SP, 2);
5061 if (entry) {
5062 SV* const sv = hv_iterkeysv(entry);
5063 PUSHs(sv);
5064 if (gimme == G_ARRAY) {
5065 SV *val;
5066 val = hv_iterval(hash, entry);
5067 PUSHs(val);
5068 }
5069 }
5070 else if (gimme == G_SCALAR)
5071 RETPUSHUNDEF;
5073 RETURN;
5074 }
5076 STATIC OP *
5077 S_do_delete_local(pTHX)
5078 {
5079 dSP;
5080 const U8 gimme = GIMME_V;
5081 const MAGIC *mg;
5082 HV *stash;
5083 const bool sliced = !!(PL_op->op_private & OPpSLICE);
5084 SV **unsliced_keysv = sliced ? NULL : sp--;
5085 SV * const osv = POPs;
5086 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
5087 dORIGMARK;
5088 const bool tied = SvRMAGICAL(osv)
5089 && mg_find((const SV *)osv, PERL_MAGIC_tied);
5090 const bool can_preserve = SvCANEXISTDELETE(osv);
5091 const U32 type = SvTYPE(osv);
5092 SV ** const end = sliced ? SP : unsliced_keysv;
5094 if (type == SVt_PVHV) { /* hash element */
5095 HV * const hv = MUTABLE_HV(osv);
5096 while (++MARK <= end) {
5097 SV * const keysv = *MARK;
5098 SV *sv = NULL;
5099 bool preeminent = TRUE;
5100 if (can_preserve)
5101 preeminent = hv_exists_ent(hv, keysv, 0);
5102 if (tied) {
5103 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
5104 if (he)
5105 sv = HeVAL(he);
5106 else
5107 preeminent = FALSE;
5108 }
5109 else {
5110 sv = hv_delete_ent(hv, keysv, 0, 0);
5111 if (preeminent)
5112 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5113 }
5114 if (preeminent) {
5115 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5116 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
5117 if (tied) {
5118 *MARK = sv_mortalcopy(sv);
5119 mg_clear(sv);
5120 } else
5121 *MARK = sv;
5122 }
5123 else {
5124 SAVEHDELETE(hv, keysv);
5125 *MARK = &PL_sv_undef;
5126 }
5127 }
5128 }
5129 else if (type == SVt_PVAV) { /* array element */
5130 if (PL_op->op_flags & OPf_SPECIAL) {
5131 AV * const av = MUTABLE_AV(osv);
5132 while (++MARK <= end) {
5133 SSize_t idx = SvIV(*MARK);
5134 SV *sv = NULL;
5135 bool preeminent = TRUE;
5136 if (can_preserve)
5137 preeminent = av_exists(av, idx);
5138 if (tied) {
5139 SV **svp = av_fetch(av, idx, 1);
5140 if (svp)
5141 sv = *svp;
5142 else
5143 preeminent = FALSE;
5144 }
5145 else {
5146 sv = av_delete(av, idx, 0);
5147 if (preeminent)
5148 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
5149 }
5150 if (preeminent) {
5151 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
5152 if (tied) {
5153 *MARK = sv_mortalcopy(sv);
5154 mg_clear(sv);
5155 } else
5156 *MARK = sv;
5157 }
5158 else {
5159 SAVEADELETE(av, idx);
5160 *MARK = &PL_sv_undef;
5161 }
5162 }
5163 }
5164 else
5165 DIE(aTHX_ "panic: avhv_delete no longer supported");
5166 }
5167 else
5168 DIE(aTHX_ "Not a HASH reference");
5169 if (sliced) {
5170 if (gimme == G_VOID)
5171 SP = ORIGMARK;
5172 else if (gimme == G_SCALAR) {
5173 MARK = ORIGMARK;
5174 if (SP > MARK)
5175 *++MARK = *SP;
5176 else
5177 *++MARK = &PL_sv_undef;
5178 SP = MARK;
5179 }
5180 }
5181 else if (gimme != G_VOID)
5182 PUSHs(*unsliced_keysv);
5184 RETURN;
5185 }
5187 PP(pp_delete)
5188 {
5189 dSP;
5190 U8 gimme;
5191 I32 discard;
5193 if (PL_op->op_private & OPpLVAL_INTRO)
5194 return do_delete_local();
5196 gimme = GIMME_V;
5197 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5199 if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
5200 dMARK; dORIGMARK;
5201 HV * const hv = MUTABLE_HV(POPs);
5202 const U32 hvtype = SvTYPE(hv);
5203 int skip = 0;
5204 if (PL_op->op_private & OPpKVSLICE) {
5205 SSize_t items = SP - MARK;
5207 MEXTEND(SP,items);
5208 while (items > 1) {
5209 *(MARK+items*2-1) = *(MARK+items);
5210 items--;
5211 }
5212 items = SP - MARK;
5213 SP += items;
5214 skip = 1;
5215 }
5216 if (hvtype == SVt_PVHV) { /* hash element */
5217 while ((MARK += (1+skip)) <= SP) {
5218 SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
5219 *MARK = sv ? sv : &PL_sv_undef;
5220 }
5221 }
5222 else if (hvtype == SVt_PVAV) { /* array element */
5223 if (PL_op->op_flags & OPf_SPECIAL) {
5224 while ((MARK += (1+skip)) <= SP) {
5225 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
5226 *MARK = sv ? sv : &PL_sv_undef;
5227 }
5228 }
5229 }
5230 else
5231 DIE(aTHX_ "Not a HASH reference");
5232 if (discard)
5233 SP = ORIGMARK;
5234 else if (gimme == G_SCALAR) {
5235 MARK = ORIGMARK;
5236 if (SP > MARK)
5237 *++MARK = *SP;
5238 else
5239 *++MARK = &PL_sv_undef;
5240 SP = MARK;
5241 }
5242 }
5243 else {
5244 SV *keysv = POPs;
5245 HV * const hv = MUTABLE_HV(POPs);
5246 SV *sv = NULL;
5247 if (SvTYPE(hv) == SVt_PVHV)
5248 sv = hv_delete_ent(hv, keysv, discard, 0);
5249 else if (SvTYPE(hv) == SVt_PVAV) {
5250 if (PL_op->op_flags & OPf_SPECIAL)
5251 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5252 else
5253 DIE(aTHX_ "panic: avhv_delete no longer supported");
5254 }
5255 else
5256 DIE(aTHX_ "Not a HASH reference");
5257 if (!sv)
5258 sv = &PL_sv_undef;
5259 if (!discard)
5260 PUSHs(sv);
5261 }
5262 RETURN;
5263 }
5265 PP(pp_exists)
5266 {
5267 dSP;
5268 SV *tmpsv;
5269 HV *hv;
5271 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
5272 GV *gv;
5273 SV * const sv = POPs;
5274 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5275 if (cv)
5276 RETPUSHYES;
5277 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5278 RETPUSHYES;
5279 RETPUSHNO;
5280 }
5281 tmpsv = POPs;
5282 hv = MUTABLE_HV(POPs);
5283 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
5284 if (hv_exists_ent(hv, tmpsv, 0))
5285 RETPUSHYES;
5286 }
5287 else if (SvTYPE(hv) == SVt_PVAV) {
5288 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5289 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5290 RETPUSHYES;
5291 }
5292 }
5293 else {
5294 DIE(aTHX_ "Not a HASH reference");
5295 }
5296 RETPUSHNO;
5297 }
5299 PP(pp_hslice)
5300 {
5301 dSP; dMARK; dORIGMARK;
5302 HV * const hv = MUTABLE_HV(POPs);
5303 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5304 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5305 bool can_preserve = FALSE;
5307 if (localizing) {
5308 MAGIC *mg;
5309 HV *stash;
5311 if (SvCANEXISTDELETE(hv))
5312 can_preserve = TRUE;
5313 }
5315 while (++MARK <= SP) {
5316 SV * const keysv = *MARK;
5317 SV **svp;
5318 HE *he;
5319 bool preeminent = TRUE;
5321 if (localizing && can_preserve) {
5322 /* If we can determine whether the element exist,
5323 * try to preserve the existenceness of a tied hash
5324 * element by using EXISTS and DELETE if possible.
5325 * Fallback to FETCH and STORE otherwise. */
5326 preeminent = hv_exists_ent(hv, keysv, 0);
5327 }
5329 he = hv_fetch_ent(hv, keysv, lval, 0);
5330 svp = he ? &HeVAL(he) : NULL;
5332 if (lval) {
5333 if (!svp || !*svp || *svp == &PL_sv_undef) {
5334 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5335 }
5336 if (localizing) {
5337 if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
5338 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5339 else if (preeminent)
5340 save_helem_flags(hv, keysv, svp,
5341 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5342 else
5343 SAVEHDELETE(hv, keysv);
5344 }
5345 }
5346 *MARK = svp && *svp ? *svp : &PL_sv_undef;
5347 }
5348 if (GIMME_V != G_ARRAY) {
5349 MARK = ORIGMARK;
5350 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5351 SP = MARK;
5352 }
5353 RETURN;
5354 }
5356 PP(pp_kvhslice)
5357 {
5358 dSP; dMARK;
5359 HV * const hv = MUTABLE_HV(POPs);
5360 I32 lval = (PL_op->op_flags & OPf_MOD);
5361 SSize_t items = SP - MARK;
5363 if (PL_op->op_private & OPpMAYBE_LVSUB) {
5364 const I32 flags = is_lvalue_sub();
5365 if (flags) {
5366 if (!(flags & OPpENTERSUB_INARGS))
5367 /* diag_listed_as: Can't modify %s in %s */
5368 Perl_croak(aTHX_ "Can't modify key/value hash slice in %s assignment",
5369 GIMME_V == G_ARRAY ? "list" : "scalar");
5370 lval = flags;
5371 }
5372 }
5374 MEXTEND(SP,items);
5375 while (items > 1) {
5376 *(MARK+items*2-1) = *(MARK+items);
5377 items--;
5378 }
5379 items = SP-MARK;
5380 SP += items;
5382 while (++MARK <= SP) {
5383 SV * const keysv = *MARK;
5384 SV **svp;
5385 HE *he;
5387 he = hv_fetch_ent(hv, keysv, lval, 0);
5388 svp = he ? &HeVAL(he) : NULL;
5390 if (lval) {
5391 if (!svp || !*svp || *svp == &PL_sv_undef) {
5392 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5393 }
5394 *MARK = sv_mortalcopy(*MARK);
5395 }
5396 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
5397 }
5398 if (GIMME_V != G_ARRAY) {
5399 MARK = SP - items*2;
5400 *++MARK = items > 0 ? *SP : &PL_sv_undef;
5401 SP = MARK;
5402 }
5403 RETURN;
5404 }
5406 /* List operators. */
5408 PP(pp_list)
5409 {
5410 I32 markidx = POPMARK;
5411 if (GIMME_V != G_ARRAY) {
5412 /* don't initialize mark here, EXTEND() may move the stack */
5413 SV **mark;
5414 dSP;
5415 EXTEND(SP, 1); /* in case no arguments, as in @empty */
5416 mark = PL_stack_base + markidx;
5417 if (++MARK <= SP)
5418 *MARK = *SP; /* unwanted list, return last item */
5419 else
5420 *MARK = &PL_sv_undef;
5421 SP = MARK;
5422 PUTBACK;
5423 }
5424 return NORMAL;
5425 }
5427 PP(pp_lslice)
5428 {
5429 dSP;
5430 SV ** const lastrelem = PL_stack_sp;
5431 SV ** const lastlelem = PL_stack_base + POPMARK;
5432 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5433 SV ** const firstrelem = lastlelem + 1;
5434 const U8 mod = PL_op->op_flags & OPf_MOD;
5436 const I32 max = lastrelem - lastlelem;
5437 SV **lelem;
5439 if (GIMME_V != G_ARRAY) {
5440 if (lastlelem < firstlelem) {
5441 EXTEND(SP, 1);
5442 *firstlelem = &PL_sv_undef;
5443 }
5444 else {
5445 I32 ix = SvIV(*lastlelem);
5446 if (ix < 0)
5447 ix += max;
5448 if (ix < 0 || ix >= max)
5449 *firstlelem = &PL_sv_undef;
5450 else
5451 *firstlelem = firstrelem[ix];
5452 }
5453 SP = firstlelem;
5454 RETURN;
5455 }
5457 if (max == 0) {
5458 SP = firstlelem - 1;
5459 RETURN;
5460 }
5462 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5463 I32 ix = SvIV(*lelem);
5464 if (ix < 0)
5465 ix += max;
5466 if (ix < 0 || ix >= max)
5467 *lelem = &PL_sv_undef;
5468 else {
5469 if (!(*lelem = firstrelem[ix]))
5470 *lelem = &PL_sv_undef;
5471 else if (mod && SvPADTMP(*lelem)) {
5472 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5473 }
5474 }
5475 }
5476 SP = lastlelem;
5477 RETURN;
5478 }
5480 PP(pp_anonlist)
5481 {
5482 dSP; dMARK;
5483 const I32 items = SP - MARK;
5484 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5485 SP = MARK;
5486 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5487 ? newRV_noinc(av) : av);
5488 RETURN;
5489 }
5491 PP(pp_anonhash)
5492 {
5493 dSP; dMARK; dORIGMARK;
5494 HV* const hv = newHV();
5495 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5496 ? newRV_noinc(MUTABLE_SV(hv))
5497 : MUTABLE_SV(hv) );
5499 while (MARK < SP) {
5500 SV * const key =
5501 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5502 SV *val;
5503 if (MARK < SP)
5504 {
5505 MARK++;
5506 SvGETMAGIC(*MARK);
5507 val = newSV(0);
5508 sv_setsv_nomg(val, *MARK);
5509 }
5510 else
5511 {
5512 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5513 val = newSV(0);
5514 }
5515 (void)hv_store_ent(hv,key,val,0);
5516 }
5517 SP = ORIGMARK;
5518 XPUSHs(retval);
5519 RETURN;
5520 }
5522 PP(pp_splice)
5523 {
5524 dSP; dMARK; dORIGMARK;
5525 int num_args = (SP - MARK);
5526 AV *ary = MUTABLE_AV(*++MARK);
5527 SV **src;
5528 SV **dst;
5529 SSize_t i;
5530 SSize_t offset;
5531 SSize_t length;
5532 SSize_t newlen;
5533 SSize_t after;
5534 SSize_t diff;
5535 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5537 if (mg) {
5538 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5539 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5540 sp - mark);
5541 }
5543 if (SvREADONLY(ary))
5544 Perl_croak_no_modify();
5546 SP++;
5548 if (++MARK < SP) {
5549 offset = i = SvIV(*MARK);
5550 if (offset < 0)
5551 offset += AvFILLp(ary) + 1;
5552 if (offset < 0)
5553 DIE(aTHX_ PL_no_aelem, i);
5554 if (++MARK < SP) {
5555 length = SvIVx(*MARK++);
5556 if (length < 0) {
5557 length += AvFILLp(ary) - offset + 1;
5558 if (length < 0)
5559 length = 0;
5560 }
5561 }
5562 else
5563 length = AvMAX(ary) + 1; /* close enough to infinity */
5564 }
5565 else {
5566 offset = 0;
5567 length = AvMAX(ary) + 1;
5568 }
5569 if (offset > AvFILLp(ary) + 1) {
5570 if (num_args > 2)
5571 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5572 offset = AvFILLp(ary) + 1;
5573 }
5574 after = AvFILLp(ary) + 1 - (offset + length);
5575 if (after < 0) { /* not that much array */
5576 length += after; /* offset+length now in array */
5577 after = 0;
5578 if (!AvALLOC(ary))
5579 av_extend(ary, 0);
5580 }
5582 /* At this point, MARK .. SP-1 is our new LIST */
5584 newlen = SP - MARK;
5585 diff = newlen - length;
5586 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5587 av_reify(ary);
5589 /* make new elements SVs now: avoid problems if they're from the array */
5590 for (dst = MARK, i = newlen; i; i--) {
5591 SV * const h = *dst;
5592 *dst++ = newSVsv(h);
5593 }
5595 if (diff < 0) { /* shrinking the area */
5596 SV **tmparyval = NULL;
5597 if (newlen) {
5598 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5599 Copy(MARK, tmparyval, newlen, SV*);
5600 }
5602 MARK = ORIGMARK + 1;
5603 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5604 const bool real = cBOOL(AvREAL(ary));
5605 MEXTEND(MARK, length);
5606 if (real)
5607 EXTEND_MORTAL(length);
5608 for (i = 0, dst = MARK; i < length; i++) {
5609 if ((*dst = AvARRAY(ary)[i+offset])) {
5610 if (real)
5611 sv_2mortal(*dst); /* free them eventually */
5612 }
5613 else
5614 *dst = &PL_sv_undef;
5615 dst++;
5616 }
5617 MARK += length - 1;
5618 }
5619 else {
5620 *MARK = AvARRAY(ary)[offset+length-1];
5621 if (AvREAL(ary)) {
5622 sv_2mortal(*MARK);
5623 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5624 SvREFCNT_dec(*dst++); /* free them now */
5625 }
5626 if (!*MARK)
5627 *MARK = &PL_sv_undef;
5628 }
5629 AvFILLp(ary) += diff;
5631 /* pull up or down? */
5633 if (offset < after) { /* easier to pull up */
5634 if (offset) { /* esp. if nothing to pull */
5635 src = &AvARRAY(ary)[offset-1];
5636 dst = src - diff; /* diff is negative */
5637 for (i = offset; i > 0; i--) /* can't trust Copy */
5638 *dst-- = *src--;
5639 }
5640 dst = AvARRAY(ary);
5641 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5642 AvMAX(ary) += diff;
5643 }
5644 else {
5645 if (after) { /* anything to pull down? */
5646 src = AvARRAY(ary) + offset + length;
5647 dst = src + diff; /* diff is negative */
5648 Move(src, dst, after, SV*);
5649 }
5650 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5651 /* avoid later double free */
5652 }
5653 i = -diff;
5654 while (i)
5655 dst[--i] = NULL;
5657 if (newlen) {
5658 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5659 Safefree(tmparyval);
5660 }
5661 }
5662 else { /* no, expanding (or same) */
5663 SV** tmparyval = NULL;
5664 if (length) {
5665 Newx(tmparyval, length, SV*); /* so remember deletion */
5666 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5667 }
5669 if (diff > 0) { /* expanding */
5670 /* push up or down? */
5671 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5672 if (offset) {
5673 src = AvARRAY(ary);
5674 dst = src - diff;
5675 Move(src, dst, offset, SV*);
5676 }
5677 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5678 AvMAX(ary) += diff;
5679 AvFILLp(ary) += diff;
5680 }
5681 else {
5682 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5683 av_extend(ary, AvFILLp(ary) + diff);
5684 AvFILLp(ary) += diff;
5686 if (after) {
5687 dst = AvARRAY(ary) + AvFILLp(ary);
5688 src = dst - diff;
5689 for (i = after; i; i--) {
5690 *dst-- = *src--;
5691 }
5692 }
5693 }
5694 }
5696 if (newlen) {
5697 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5698 }
5700 MARK = ORIGMARK + 1;
5701 if (GIMME_V == G_ARRAY) { /* copy return vals to stack */
5702 if (length) {
5703 const bool real = cBOOL(AvREAL(ary));
5704 if (real)
5705 EXTEND_MORTAL(length);
5706 for (i = 0, dst = MARK; i < length; i++) {
5707 if ((*dst = tmparyval[i])) {
5708 if (real)
5709 sv_2mortal(*dst); /* free them eventually */
5710 }
5711 else *dst = &PL_sv_undef;
5712 dst++;
5713 }
5714 }
5715 MARK += length - 1;
5716 }
5717 else if (length--) {
5718 *MARK = tmparyval[length];
5719 if (AvREAL(ary)) {
5720 sv_2mortal(*MARK);
5721 while (length-- > 0)
5722 SvREFCNT_dec(tmparyval[length]);
5723 }
5724 if (!*MARK)
5725 *MARK = &PL_sv_undef;
5726 }
5727 else
5728 *MARK = &PL_sv_undef;
5729 Safefree(tmparyval);
5730 }
5732 if (SvMAGICAL(ary))
5733 mg_set(MUTABLE_SV(ary));
5735 SP = MARK;
5736 RETURN;
5737 }
5739 PP(pp_push)
5740 {
5741 dSP; dMARK; dORIGMARK; dTARGET;
5742 AV * const ary = MUTABLE_AV(*++MARK);
5743 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5745 if (mg) {
5746 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5747 PUSHMARK(MARK);
5748 PUTBACK;
5749 ENTER_with_name("call_PUSH");
5750 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5751 LEAVE_with_name("call_PUSH");
5752 /* SPAGAIN; not needed: SP is assigned to immediately below */
5753 }
5754 else {
5755 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5756 * only need to save locally, not on the save stack */
5757 U16 old_delaymagic = PL_delaymagic;
5759 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5760 PL_delaymagic = DM_DELAY;
5761 for (++MARK; MARK <= SP; MARK++) {
5762 SV *sv;
5763 if (*MARK) SvGETMAGIC(*MARK);
5764 sv = newSV(0);
5765 if (*MARK)
5766 sv_setsv_nomg(sv, *MARK);
5767 av_store(ary, AvFILLp(ary)+1, sv);
5768 }
5769 if (PL_delaymagic & DM_ARRAY_ISA)
5770 mg_set(MUTABLE_SV(ary));
5771 PL_delaymagic = old_delaymagic;
5772 }
5773 SP = ORIGMARK;
5774 if (OP_GIMME(PL_op, 0) != G_VOID) {
5775 PUSHi( AvFILL(ary) + 1 );
5776 }
5777 RETURN;
5778 }
5780 /* also used for: pp_pop()*/
5781 PP(pp_shift)
5782 {
5783 dSP;
5784 AV * const av = PL_op->op_flags & OPf_SPECIAL
5785 ? MUTABLE_AV(GvAVn(PL_defgv)) : MUTABLE_AV(POPs);
5786 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5787 EXTEND(SP, 1);
5788 assert (sv);
5789 if (AvREAL(av))
5790 (void)sv_2mortal(sv);
5791 PUSHs(sv);
5792 RETURN;
5793 }
5795 PP(pp_unshift)
5796 {
5797 dSP; dMARK; dORIGMARK; dTARGET;
5798 AV *ary = MUTABLE_AV(*++MARK);
5799 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5801 if (mg) {
5802 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5803 PUSHMARK(MARK);
5804 PUTBACK;
5805 ENTER_with_name("call_UNSHIFT");
5806 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5807 LEAVE_with_name("call_UNSHIFT");
5808 /* SPAGAIN; not needed: SP is assigned to immediately below */
5809 }
5810 else {
5811 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
5812 * only need to save locally, not on the save stack */
5813 U16 old_delaymagic = PL_delaymagic;
5814 SSize_t i = 0;
5816 av_unshift(ary, SP - MARK);
5817 PL_delaymagic = DM_DELAY;
5818 while (MARK < SP) {
5819 SV * const sv = newSVsv(*++MARK);
5820 (void)av_store(ary, i++, sv);
5821 }
5822 if (PL_delaymagic & DM_ARRAY_ISA)
5823 mg_set(MUTABLE_SV(ary));
5824 PL_delaymagic = old_delaymagic;
5825 }
5826 SP = ORIGMARK;
5827 if (OP_GIMME(PL_op, 0) != G_VOID) {
5828 PUSHi( AvFILL(ary) + 1 );
5829 }
5830 RETURN;
5831 }
5833 PP(pp_reverse)
5834 {
5835 dSP; dMARK;
5837 if (GIMME_V == G_ARRAY) {
5838 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5839 AV *av;
5841 /* See pp_sort() */
5842 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5843 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5844 av = MUTABLE_AV((*SP));
5845 /* In-place reversing only happens in void context for the array
5846 * assignment. We don't need to push anything on the stack. */
5847 SP = MARK;
5849 if (SvMAGICAL(av)) {
5850 SSize_t i, j;
5851 SV *tmp = sv_newmortal();
5852 /* For SvCANEXISTDELETE */
5853 HV *stash;
5854 const MAGIC *mg;
5855 bool can_preserve = SvCANEXISTDELETE(av);
5857 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5858 SV *begin, *end;
5860 if (can_preserve) {
5861 if (!av_exists(av, i)) {
5862 if (av_exists(av, j)) {
5863 SV *sv = av_delete(av, j, 0);
5864 begin = *av_fetch(av, i, TRUE);
5865 sv_setsv_mg(begin, sv);
5866 }
5867 continue;
5868 }
5869 else if (!av_exists(av, j)) {
5870 SV *sv = av_delete(av, i, 0);
5871 end = *av_fetch(av, j, TRUE);
5872 sv_setsv_mg(end, sv);
5873 continue;
5874 }
5875 }
5877 begin = *av_fetch(av, i, TRUE);
5878 end = *av_fetch(av, j, TRUE);
5879 sv_setsv(tmp, begin);
5880 sv_setsv_mg(begin, end);
5881 sv_setsv_mg(end, tmp);
5882 }
5883 }
5884 else {
5885 SV **begin = AvARRAY(av);
5887 if (begin) {
5888 SV **end = begin + AvFILLp(av);
5890 while (begin < end) {
5891 SV * const tmp = *begin;
5892 *begin++ = *end;
5893 *end-- = tmp;
5894 }
5895 }
5896 }
5897 }
5898 else {
5899 SV **oldsp = SP;
5900 MARK++;
5901 while (MARK < SP) {
5902 SV * const tmp = *MARK;
5903 *MARK++ = *SP;
5904 *SP-- = tmp;
5905 }
5906 /* safe as long as stack cannot get extended in the above */
5907 SP = oldsp;
5908 }
5909 }
5910 else {
5911 char *up;
5912 dTARGET;
5913 STRLEN len;
5915 SvUTF8_off(TARG); /* decontaminate */
5916 if (SP - MARK > 1) {
5917 do_join(TARG, &PL_sv_no, MARK, SP);
5918 SP = MARK + 1;
5919 SETs(TARG);
5920 } else if (SP > MARK) {
5921 sv_setsv(TARG, *SP);
5922 SETs(TARG);
5923 } else {
5924 sv_setsv(TARG, DEFSV);
5925 XPUSHs(TARG);
5926 }
5928 up = SvPV_force(TARG, len);
5929 if (len > 1) {
5930 char *down;
5931 if (DO_UTF8(TARG)) { /* first reverse each character */
5932 U8* s = (U8*)SvPVX(TARG);
5933 const U8* send = (U8*)(s + len);
5934 while (s < send) {
5935 if (UTF8_IS_INVARIANT(*s)) {
5936 s++;
5937 continue;
5938 }
5939 else {
5940 if (!utf8_to_uvchr_buf(s, send, 0))
5941 break;
5942 up = (char*)s;
5943 s += UTF8SKIP(s);
5944 down = (char*)(s - 1);
5945 /* reverse this character */
5946 while (down > up) {
5947 const char tmp = *up;
5948 *up++ = *down;
5949 *down-- = tmp;
5950 }
5951 }
5952 }
5953 up = SvPVX(TARG);
5954 }
5955 down = SvPVX(TARG) + len - 1;
5956 while (down > up) {
5957 const char tmp = *up;
5958 *up++ = *down;
5959 *down-- = tmp;
5960 }
5961 (void)SvPOK_only_UTF8(TARG);
5962 }
5963 }
5964 RETURN;
5965 }
5967 PP(pp_split)
5968 {
5969 dSP; dTARG;
5970 AV *ary = ( (PL_op->op_private & OPpSPLIT_ASSIGN) /* @a = split */
5971 && (PL_op->op_flags & OPf_STACKED)) /* @{expr} = split */
5972 ? (AV *)POPs : NULL;
5973 IV limit = POPi; /* note, negative is forever */
5974 SV * const sv = POPs;
5975 STRLEN len;
5976 const char *s = SvPV_const(sv, len);
5977 const bool do_utf8 = DO_UTF8(sv);
5978 const bool in_uni_8_bit = IN_UNI_8_BIT;
5979 const char *strend = s + len;
5980 PMOP *pm = cPMOPx(PL_op);
5981 REGEXP *rx;
5982 SV *dstr;
5983 const char *m;
5984 SSize_t iters = 0;
5985 const STRLEN slen = do_utf8
5986 ? utf8_length((U8*)s, (U8*)strend)
5987 : (STRLEN)(strend - s);
5988 SSize_t maxiters = slen + 10;
5989 I32 trailing_empty = 0;
5990 const char *orig;
5991 const IV origlimit = limit;
5992 I32 realarray = 0;
5993 I32 base;
5994 const U8 gimme = GIMME_V;
5995 bool gimme_scalar;
5996 I32 oldsave = PL_savestack_ix;
5997 U32 make_mortal = SVs_TEMP;
5998 bool multiline = 0;
5999 MAGIC *mg = NULL;
6001 rx = PM_GETRE(pm);
6003 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
6004 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
6006 /* handle @ary = split(...) optimisation */
6007 if (PL_op->op_private & OPpSPLIT_ASSIGN) {
6008 if (!(PL_op->op_flags & OPf_STACKED)) {
6009 if (PL_op->op_private & OPpSPLIT_LEX) {
6010 if (PL_op->op_private & OPpLVAL_INTRO)
6011 SAVECLEARSV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6012 ary = (AV *)PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff);
6013 }
6014 else {
6015 GV *gv =
6016 #ifdef USE_ITHREADS
6017 MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff));
6018 #else
6019 pm->op_pmreplrootu.op_pmtargetgv;
6020 #endif
6021 if (PL_op->op_private & OPpLVAL_INTRO)
6022 ary = save_ary(gv);
6023 else
6024 ary = GvAVn(gv);
6025 }
6026 /* skip anything pushed by OPpLVAL_INTRO above */
6027 oldsave = PL_savestack_ix;
6028 }
6030 realarray = 1;
6031 PUTBACK;
6032 av_extend(ary,0);
6033 (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
6034 av_clear(ary);
6035 SPAGAIN;
6036 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
6037 PUSHMARK(SP);
6038 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
6039 }
6040 else {
6041 if (!AvREAL(ary)) {
6042 I32 i;
6043 AvREAL_on(ary);
6044 AvREIFY_off(ary);
6045 for (i = AvFILLp(ary); i >= 0; i--)
6046 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
6047 }
6048 /* temporarily switch stacks */
6049 SAVESWITCHSTACK(PL_curstack, ary);
6050 make_mortal = 0;
6051 }
6052 }
6054 base = SP - PL_stack_base;
6055 orig = s;
6056 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
6057 if (do_utf8) {
6058 while (s < strend && isSPACE_utf8_safe(s, strend))
6059 s += UTF8SKIP(s);
6060 }
6061 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
6062 while (s < strend && isSPACE_LC(*s))
6063 s++;
6064 }
6065 else if (in_uni_8_bit) {
6066 while (s < strend && isSPACE_L1(*s))
6067 s++;
6068 }
6069 else {
6070 while (s < strend && isSPACE(*s))
6071 s++;
6072 }
6073 }
6074 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
6075 multiline = 1;
6076 }
6078 gimme_scalar = gimme == G_SCALAR && !ary;
6080 if (!limit)
6081 limit = maxiters + 2;
6082 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
6083 while (--limit) {
6084 m = s;
6085 /* this one uses 'm' and is a negative test */
6086 if (do_utf8) {
6087 while (m < strend && ! isSPACE_utf8_safe(m, strend) ) {
6088 const int t = UTF8SKIP(m);
6089 /* isSPACE_utf8_safe returns FALSE for malform utf8 */
6090 if (strend - m < t)
6091 m = strend;
6092 else
6093 m += t;
6094 }
6095 }
6096 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6097 {
6098 while (m < strend && !isSPACE_LC(*m))
6099 ++m;
6100 }
6101 else if (in_uni_8_bit) {
6102 while (m < strend && !isSPACE_L1(*m))
6103 ++m;
6104 } else {
6105 while (m < strend && !isSPACE(*m))
6106 ++m;
6107 }
6108 if (m >= strend)
6109 break;
6111 if (gimme_scalar) {
6112 iters++;
6113 if (m-s == 0)
6114 trailing_empty++;
6115 else
6116 trailing_empty = 0;
6117 } else {
6118 dstr = newSVpvn_flags(s, m-s,
6119 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6120 XPUSHs(dstr);
6121 }
6123 /* skip the whitespace found last */
6124 if (do_utf8)
6125 s = m + UTF8SKIP(m);
6126 else
6127 s = m + 1;
6129 /* this one uses 's' and is a positive test */
6130 if (do_utf8) {
6131 while (s < strend && isSPACE_utf8_safe(s, strend) )
6132 s += UTF8SKIP(s);
6133 }
6134 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
6135 {
6136 while (s < strend && isSPACE_LC(*s))
6137 ++s;
6138 }
6139 else if (in_uni_8_bit) {
6140 while (s < strend && isSPACE_L1(*s))
6141 ++s;
6142 } else {
6143 while (s < strend && isSPACE(*s))
6144 ++s;
6145 }
6146 }
6147 }
6148 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
6149 while (--limit) {
6150 for (m = s; m < strend && *m != '\n'; m++)
6151 ;
6152 m++;
6153 if (m >= strend)
6154 break;
6156 if (gimme_scalar) {
6157 iters++;
6158 if (m-s == 0)
6159 trailing_empty++;
6160 else
6161 trailing_empty = 0;
6162 } else {
6163 dstr = newSVpvn_flags(s, m-s,
6164 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6165 XPUSHs(dstr);
6166 }
6167 s = m;
6168 }
6169 }
6170 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
6171 /*
6172 Pre-extend the stack, either the number of bytes or
6173 characters in the string or a limited amount, triggered by:
6175 my ($x, $y) = split //, $str;
6176 or
6177 split //, $str, $i;
6178 */
6179 if (!gimme_scalar) {
6180 const IV items = limit - 1;
6181 /* setting it to -1 will trigger a panic in EXTEND() */
6182 const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
6183 if (items >=0 && items < sslen)
6184 EXTEND(SP, items);
6185 else
6186 EXTEND(SP, sslen);
6187 }
6189 if (do_utf8) {
6190 while (--limit) {
6191 /* keep track of how many bytes we skip over */
6192 m = s;
6193 s += UTF8SKIP(s);
6194 if (gimme_scalar) {
6195 iters++;
6196 if (s-m == 0)
6197 trailing_empty++;
6198 else
6199 trailing_empty = 0;
6200 } else {
6201 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
6203 PUSHs(dstr);
6204 }
6206 if (s >= strend)
6207 break;
6208 }
6209 } else {
6210 while (--limit) {
6211 if (gimme_scalar) {
6212 iters++;
6213 } else {
6214 dstr = newSVpvn(s, 1);
6217 if (make_mortal)
6218 sv_2mortal(dstr);
6220 PUSHs(dstr);
6221 }
6223 s++;
6225 if (s >= strend)
6226 break;
6227 }
6228 }
6229 }
6230 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
6231 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
6232 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
6233 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
6234 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
6235 SV * const csv = CALLREG_INTUIT_STRING(rx);
6237 len = RX_MINLENRET(rx);
6238 if (len == 1 && !RX_UTF8(rx) && !tail) {
6239 const char c = *SvPV_nolen_const(csv);
6240 while (--limit) {
6241 for (m = s; m < strend && *m != c; m++)
6242 ;
6243 if (m >= strend)
6244 break;
6245 if (gimme_scalar) {
6246 iters++;
6247 if (m-s == 0)
6248 trailing_empty++;
6249 else
6250 trailing_empty = 0;
6251 } else {
6252 dstr = newSVpvn_flags(s, m-s,
6253 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6254 XPUSHs(dstr);
6255 }
6256 /* The rx->minlen is in characters but we want to step
6257 * s ahead by bytes. */
6258 if (do_utf8)
6259 s = (char*)utf8_hop_forward((U8*) m, len, (U8*) strend);
6260 else
6261 s = m + len; /* Fake \n at the end */
6262 }
6263 }
6264 else {
6265 while (s < strend && --limit &&
6266 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
6267 csv, multiline ? FBMrf_MULTILINE : 0)) )
6268 {
6269 if (gimme_scalar) {
6270 iters++;
6271 if (m-s == 0)
6272 trailing_empty++;
6273 else
6274 trailing_empty = 0;
6275 } else {
6276 dstr = newSVpvn_flags(s, m-s,
6277 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6278 XPUSHs(dstr);
6279 }
6280 /* The rx->minlen is in characters but we want to step
6281 * s ahead by bytes. */
6282 if (do_utf8)
6283 s = (char*)utf8_hop_forward((U8*)m, len, (U8 *) strend);
6284 else
6285 s = m + len; /* Fake \n at the end */
6286 }
6287 }
6288 }
6289 else {
6290 maxiters += slen * RX_NPARENS(rx);
6291 while (s < strend && --limit)
6292 {
6293 I32 rex_return;
6294 PUTBACK;
6295 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
6296 sv, NULL, 0);
6297 SPAGAIN;
6298 if (rex_return == 0)
6299 break;
6300 TAINT_IF(RX_MATCH_TAINTED(rx));
6301 /* we never pass the REXEC_COPY_STR flag, so it should
6302 * never get copied */
6303 assert(!RX_MATCH_COPIED(rx));
6304 m = RX_OFFS(rx)[0].start + orig;
6306 if (gimme_scalar) {
6307 iters++;
6308 if (m-s == 0)
6309 trailing_empty++;
6310 else
6311 trailing_empty = 0;
6312 } else {
6313 dstr = newSVpvn_flags(s, m-s,
6314 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6315 XPUSHs(dstr);
6316 }
6317 if (RX_NPARENS(rx)) {
6318 I32 i;
6319 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6320 s = RX_OFFS(rx)[i].start + orig;
6321 m = RX_OFFS(rx)[i].end + orig;
6323 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6324 parens that didn't match -- they should be set to
6325 undef, not the empty string */
6326 if (gimme_scalar) {
6327 iters++;
6328 if (m-s == 0)
6329 trailing_empty++;
6330 else
6331 trailing_empty = 0;
6332 } else {
6333 if (m >= orig && s >= orig) {
6334 dstr = newSVpvn_flags(s, m-s,
6335 (do_utf8 ? SVf_UTF8 : 0)
6336 | make_mortal);
6337 }
6338 else
6339 dstr = &PL_sv_undef; /* undef, not "" */
6340 XPUSHs(dstr);
6341 }
6343 }
6344 }
6345 s = RX_OFFS(rx)[0].end + orig;
6346 }
6347 }
6349 if (!gimme_scalar) {
6350 iters = (SP - PL_stack_base) - base;
6351 }
6352 if (iters > maxiters)
6353 DIE(aTHX_ "Split loop");
6355 /* keep field after final delim? */
6356 if (s < strend || (iters && origlimit)) {
6357 if (!gimme_scalar) {
6358 const STRLEN l = strend - s;
6359 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6360 XPUSHs(dstr);
6361 }
6362 iters++;
6363 }
6364 else if (!origlimit) {
6365 if (gimme_scalar) {
6366 iters -= trailing_empty;
6367 } else {
6368 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6369 if (TOPs && !make_mortal)
6370 sv_2mortal(TOPs);
6371 *SP-- = NULL;
6372 iters--;
6373 }
6374 }
6375 }
6377 PUTBACK;
6378 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6379 SPAGAIN;
6380 if (realarray) {
6381 if (!mg) {
6382 if (SvSMAGICAL(ary)) {
6383 PUTBACK;
6384 mg_set(MUTABLE_SV(ary));
6385 SPAGAIN;
6386 }
6387 if (gimme == G_ARRAY) {
6388 EXTEND(SP, iters);
6389 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6390 SP += iters;
6391 RETURN;
6392 }
6393 }
6394 else {
6395 PUTBACK;
6396 ENTER_with_name("call_PUSH");
6397 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
6398 LEAVE_with_name("call_PUSH");
6399 SPAGAIN;
6400 if (gimme == G_ARRAY) {
6401 SSize_t i;
6402 /* EXTEND should not be needed - we just popped them */
6403 EXTEND(SP, iters);
6404 for (i=0; i < iters; i++) {
6405 SV **svp = av_fetch(ary, i, FALSE);
6406 PUSHs((svp) ? *svp : &PL_sv_undef);
6407 }
6408 RETURN;
6409 }
6410 }
6411 }
6412 else {
6413 if (gimme == G_ARRAY)
6414 RETURN;
6415 }
6417 GETTARGET;
6418 XPUSHi(iters);
6419 RETURN;
6420 }
6422 PP(pp_once)
6423 {
6424 dSP;
6425 SV *const sv = PAD_SVl(PL_op->op_targ);
6427 if (SvPADSTALE(sv)) {
6428 /* First time. */
6429 SvPADSTALE_off(sv);
6430 RETURNOP(cLOGOP->op_other);
6431 }
6432 RETURNOP(cLOGOP->op_next);
6433 }
6435 PP(pp_lock)
6436 {
6437 dSP;
6438 dTOPss;
6439 SV *retsv = sv;
6440 SvLOCK(sv);
6441 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
6442 || SvTYPE(retsv) == SVt_PVCV) {
6443 retsv = refto(retsv);
6444 }
6445 SETs(retsv);
6446 RETURN;
6447 }
6450 /* used for: pp_padany(), pp_custom(); plus any system ops
6451 * that aren't implemented on a particular platform */
6453 PP(unimplemented_op)
6454 {
6455 const Optype op_type = PL_op->op_type;
6456 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
6457 with out of range op numbers - it only "special" cases op_custom.
6458 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
6459 if we get here for a custom op then that means that the custom op didn't
6460 have an implementation. Given that OP_NAME() looks up the custom op
6461 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
6462 registers &PL_unimplemented_op as the address of their custom op.
6463 NULL doesn't generate a useful error message. "custom" does. */
6464 const char *const name = op_type >= OP_max
6465 ? "[out of range]" : PL_op_name[PL_op->op_type];
6466 if(OP_IS_SOCKET(op_type))
6467 DIE(aTHX_ PL_no_sock_func, name);
6468 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6469 }
6471 static void
6472 S_maybe_unwind_defav(pTHX)
6473 {
6474 if (CX_CUR()->cx_type & CXp_HASARGS) {
6475 PERL_CONTEXT *cx = CX_CUR();
6477 assert(CxHASARGS(cx));
6478 cx_popsub_args(cx);
6479 cx->cx_type &= ~CXp_HASARGS;
6480 }
6481 }
6483 /* For sorting out arguments passed to a &CORE:: subroutine */
6484 PP(pp_coreargs)
6485 {
6486 dSP;
6487 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6488 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6489 AV * const at_ = GvAV(PL_defgv);
6490 SV **svp = at_ ? AvARRAY(at_) : NULL;
6491 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6492 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6493 bool seen_question = 0;
6494 const char *err = NULL;
6495 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6497 /* Count how many args there are first, to get some idea how far to
6498 extend the stack. */
6499 while (oa) {
6500 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6501 maxargs++;
6502 if (oa & OA_OPTIONAL) seen_question = 1;
6503 if (!seen_question) minargs++;
6504 oa >>= 4;
6505 }
6507 if(numargs < minargs) err = "Not enough";
6508 else if(numargs > maxargs) err = "Too many";
6509 if (err)
6510 /* diag_listed_as: Too many arguments for %s */
6511 Perl_croak(aTHX_
6512 "%s arguments for %s", err,
6513 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6514 );
6516 /* Reset the stack pointer. Without this, we end up returning our own
6517 arguments in list context, in addition to the values we are supposed
6518 to return. nextstate usually does this on sub entry, but we need
6519 to run the next op with the caller's hints, so we cannot have a
6520 nextstate. */
6521 SP = PL_stack_base + CX_CUR()->blk_oldsp;
6523 if(!maxargs) RETURN;
6525 /* We do this here, rather than with a separate pushmark op, as it has
6526 to come in between two things this function does (stack reset and
6527 arg pushing). This seems the easiest way to do it. */
6528 if (pushmark) {
6529 PUTBACK;
6530 (void)Perl_pp_pushmark(aTHX);
6531 }
6533 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6534 PUTBACK; /* The code below can die in various places. */
6536 oa = PL_opargs[opnum] >> OASHIFT;
6537 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6538 whicharg++;
6539 switch (oa & 7) {
6540 case OA_SCALAR:
6541 try_defsv:
6542 if (!numargs && defgv && whicharg == minargs + 1) {
6543 PUSHs(DEFSV);
6544 }
6545 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6546 break;
6547 case OA_LIST:
6548 while (numargs--) {
6549 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6550 svp++;
6551 }
6552 RETURN;
6553 case OA_AVREF:
6554 if (!numargs) {
6555 GV *gv;
6556 if (CvUNIQUE(find_runcv_where(FIND_RUNCV_level_eq,1,NULL)))
6557 gv = PL_argvgv;
6558 else {
6559 S_maybe_unwind_defav(aTHX);
6560 gv = PL_defgv;
6561 }
6562 PUSHs((SV *)GvAVn(gv));
6563 break;
6564 }
6565 if (!svp || !*svp || !SvROK(*svp)
6566 || SvTYPE(SvRV(*svp)) != SVt_PVAV)
6567 DIE(aTHX_
6568 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6569 "Type of arg %d to &CORE::%s must be array reference",
6570 whicharg, PL_op_desc[opnum]
6571 );
6572 PUSHs(SvRV(*svp));
6573 break;
6574 case OA_HVREF:
6575 if (!svp || !*svp || !SvROK(*svp)
6576 || ( SvTYPE(SvRV(*svp)) != SVt_PVHV
6577 && ( opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6578 || SvTYPE(SvRV(*svp)) != SVt_PVAV )))
6579 DIE(aTHX_
6580 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6581 "Type of arg %d to &CORE::%s must be hash%s reference",
6582 whicharg, PL_op_desc[opnum],
6583 opnum == OP_DBMCLOSE || opnum == OP_DBMOPEN
6584 ? ""
6585 : " or array"
6586 );
6587 PUSHs(SvRV(*svp));
6588 break;
6589 case OA_FILEREF:
6590 if (!numargs) PUSHs(NULL);
6591 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6592 /* no magic here, as the prototype will have added an extra
6593 refgen and we just want what was there before that */
6594 PUSHs(SvRV(*svp));
6595 else {
6596 const bool constr = PL_op->op_private & whicharg;
6597 PUSHs(S_rv2gv(aTHX_
6598 svp && *svp ? *svp : &PL_sv_undef,
6599 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6600 !constr
6601 ));
6602 }
6603 break;
6604 case OA_SCALARREF:
6605 if (!numargs) goto try_defsv;
6606 else {
6607 const bool wantscalar =
6608 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6609 if (!svp || !*svp || !SvROK(*svp)
6610 /* We have to permit globrefs even for the \$ proto, as
6611 *foo is indistinguishable from ${\*foo}, and the proto-
6612 type permits the latter. */
6613 || SvTYPE(SvRV(*svp)) > (
6614 wantscalar ? SVt_PVLV
6615 : opnum == OP_LOCK || opnum == OP_UNDEF
6616 ? SVt_PVCV
6617 : SVt_PVHV
6618 )
6619 )
6620 DIE(aTHX_
6621 "Type of arg %d to &CORE::%s must be %s",
6622 whicharg, PL_op_name[opnum],
6623 wantscalar
6624 ? "scalar reference"
6625 : opnum == OP_LOCK || opnum == OP_UNDEF
6626 ? "reference to one of [$@%&*]"
6627 : "reference to one of [$@%*]"
6628 );
6629 PUSHs(SvRV(*svp));
6630 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv) {
6631 /* Undo @_ localisation, so that sub exit does not undo
6632 part of our undeffing. */
6633 S_maybe_unwind_defav(aTHX);
6634 }
6635 }
6636 break;
6637 default:
6638 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6639 }
6640 oa = oa >> 4;
6641 }
6643 RETURN;
6644 }
6646 /* Implement CORE::keys(),values(),each().
6647 *
6648 * We won't know until run-time whether the arg is an array or hash,
6649 * so this op calls
6650 *
6651 * pp_keys/pp_values/pp_each
6652 * or
6653 * pp_akeys/pp_avalues/pp_aeach
6654 *
6655 * as appropriate (or whatever pp function actually implements the OP_FOO
6656 * functionality for each FOO).
6657 */
6659 PP(pp_avhvswitch)
6660 {
6661 dVAR; dSP;
6662 return PL_ppaddr[
6663 (SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
6664 + (PL_op->op_private & OPpAVHVSWITCH_MASK)
6665 ](aTHX);
6666 }
6668 PP(pp_runcv)
6669 {
6670 dSP;
6671 CV *cv;
6672 if (PL_op->op_private & OPpOFFBYONE) {
6673 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6674 }
6675 else cv = find_runcv(NULL);
6676 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6677 RETURN;
6678 }
6680 static void
6681 S_localise_aelem_lval(pTHX_ AV * const av, SV * const keysv,
6682 const bool can_preserve)
6683 {
6684 const SSize_t ix = SvIV(keysv);
6685 if (can_preserve ? av_exists(av, ix) : TRUE) {
6686 SV ** const svp = av_fetch(av, ix, 1);
6687 if (!svp || !*svp)
6688 Perl_croak(aTHX_ PL_no_aelem, ix);
6689 save_aelem(av, ix, svp);
6690 }
6691 else
6692 SAVEADELETE(av, ix);
6693 }
6695 static void
6696 S_localise_helem_lval(pTHX_ HV * const hv, SV * const keysv,
6697 const bool can_preserve)
6698 {
6699 if (can_preserve ? hv_exists_ent(hv, keysv, 0) : TRUE) {
6700 HE * const he = hv_fetch_ent(hv, keysv, 1, 0);
6701 SV ** const svp = he ? &HeVAL(he) : NULL;
6702 if (!svp || !*svp)
6703 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(keysv));
6704 save_helem_flags(hv, keysv, svp, 0);
6705 }
6706 else
6707 SAVEHDELETE(hv, keysv);
6708 }
6710 static void
6711 S_localise_gv_slot(pTHX_ GV *gv, U8 type)
6712 {
6713 if (type == OPpLVREF_SV) {
6714 save_pushptrptr(gv, SvREFCNT_inc_simple(GvSV(gv)), SAVEt_GVSV);
6715 GvSV(gv) = 0;
6716 }
6717 else if (type == OPpLVREF_AV)
6718 /* XXX Inefficient, as it creates a new AV, which we are
6719 about to clobber. */
6720 save_ary(gv);
6721 else {
6722 assert(type == OPpLVREF_HV);
6723 /* XXX Likewise inefficient. */
6724 save_hash(gv);
6725 }
6726 }
6729 PP(pp_refassign)
6730 {
6731 dSP;
6732 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6733 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6734 dTOPss;
6735 const char *bad = NULL;
6736 const U8 type = PL_op->op_private & OPpLVREF_TYPE;
6737 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6738 switch (type) {
6739 case OPpLVREF_SV:
6740 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6741 bad = " SCALAR";
6742 break;
6743 case OPpLVREF_AV:
6744 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
6745 bad = "n ARRAY";
6746 break;
6747 case OPpLVREF_HV:
6748 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
6749 bad = " HASH";
6750 break;
6751 case OPpLVREF_CV:
6752 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
6753 bad = " CODE";
6754 }
6755 if (bad)
6756 /* diag_listed_as: Assigned value is not %s reference */
6757 DIE(aTHX_ "Assigned value is not a%s reference", bad);
6758 {
6759 MAGIC *mg;
6760 HV *stash;
6761 switch (left ? SvTYPE(left) : 0) {
6762 case 0:
6763 {
6764 SV * const old = PAD_SV(ARGTARG);
6765 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6766 SvREFCNT_dec(old);
6767 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
6768 == OPpLVAL_INTRO)
6769 SAVECLEARSV(PAD_SVl(ARGTARG));
6770 break;
6771 }
6772 case SVt_PVGV:
6773 if (PL_op->op_private & OPpLVAL_INTRO) {
6774 S_localise_gv_slot(aTHX_ (GV *)left, type);
6775 }
6776 gv_setref(left, sv);
6777 SvSETMAGIC(left);
6778 break;
6779 case SVt_PVAV:
6780 assert(key);
6781 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6782 S_localise_aelem_lval(aTHX_ (AV *)left, key,
6783 SvCANEXISTDELETE(left));
6784 }
6785 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6786 break;
6787 case SVt_PVHV:
6788 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6789 assert(key);
6790 S_localise_helem_lval(aTHX_ (HV *)left, key,
6791 SvCANEXISTDELETE(left));
6792 }
6793 (void)hv_store_ent((HV *)left, key, SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
6794 }
6795 if (PL_op->op_flags & OPf_MOD)
6796 SETs(sv_2mortal(newSVsv(sv)));
6797 /* XXX else can weak references go stale before they are read, e.g.,
6798 in leavesub? */
6799 RETURN;
6800 }
6801 }
6803 PP(pp_lvref)
6804 {
6805 dSP;
6806 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6807 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6808 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6809 MAGIC * const mg = sv_magicext(ret, arg, PERL_MAGIC_lvref,
6810 &PL_vtbl_lvref, (char *)elem,
6811 elem ? HEf_SVKEY : (I32)ARGTARG);
6812 mg->mg_private = PL_op->op_private;
6813 if (PL_op->op_private & OPpLVREF_ITER)
6814 mg->mg_flags |= MGf_PERSIST;
6815 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) {
6816 if (elem) {
6817 MAGIC *mg;
6818 HV *stash;
6819 assert(arg);
6820 {
6821 const bool can_preserve = SvCANEXISTDELETE(arg);
6822 if (SvTYPE(arg) == SVt_PVAV)
6823 S_localise_aelem_lval(aTHX_ (AV *)arg, elem, can_preserve);
6824 else
6825 S_localise_helem_lval(aTHX_ (HV *)arg, elem, can_preserve);
6826 }
6827 }
6828 else if (arg) {
6829 S_localise_gv_slot(aTHX_ (GV *)arg,
6830 PL_op->op_private & OPpLVREF_TYPE);
6831 }
6832 else if (!(PL_op->op_private & OPpPAD_STATE))
6833 SAVECLEARSV(PAD_SVl(ARGTARG));
6834 }
6835 XPUSHs(ret);
6836 RETURN;
6837 }
6839 PP(pp_lvrefslice)
6840 {
6841 dSP; dMARK;
6842 AV * const av = (AV *)POPs;
6843 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
6844 bool can_preserve = FALSE;
6846 if (UNLIKELY(localizing)) {
6847 MAGIC *mg;
6848 HV *stash;
6849 SV **svp;
6851 can_preserve = SvCANEXISTDELETE(av);
6853 if (SvTYPE(av) == SVt_PVAV) {
6854 SSize_t max = -1;
6856 for (svp = MARK + 1; svp <= SP; svp++) {
6857 const SSize_t elem = SvIV(*svp);
6858 if (elem > max)
6859 max = elem;
6860 }
6861 if (max > AvMAX(av))
6862 av_extend(av, max);
6863 }
6864 }
6866 while (++MARK <= SP) {
6867 SV * const elemsv = *MARK;
6868 if (UNLIKELY(localizing)) {
6869 if (SvTYPE(av) == SVt_PVAV)
6870 S_localise_aelem_lval(aTHX_ av, elemsv, can_preserve);
6871 else
6872 S_localise_helem_lval(aTHX_ (HV *)av, elemsv, can_preserve);
6873 }
6874 *MARK = sv_2mortal(newSV_type(SVt_PVMG));
6875 sv_magic(*MARK,(SV *)av,PERL_MAGIC_lvref,(char *)elemsv,HEf_SVKEY);
6876 }
6877 RETURN;
6878 }
6880 PP(pp_lvavref)
6881 {
6882 if (PL_op->op_flags & OPf_STACKED)
6883 Perl_pp_rv2av(aTHX);
6884 else
6885 Perl_pp_padav(aTHX);
6886 {
6887 dSP;
6888 dTOPss;
6889 SETs(0); /* special alias marker that aassign recognises */
6890 XPUSHs(sv);
6891 RETURN;
6892 }
6893 }
6895 PP(pp_anonconst)
6896 {
6897 dSP;
6898 dTOPss;
6899 SETs(sv_2mortal((SV *)newCONSTSUB(SvTYPE(CopSTASH(PL_curcop))==SVt_PVHV
6900 ? CopSTASH(PL_curcop)
6901 : NULL,
6902 NULL, SvREFCNT_inc_simple_NN(sv))));
6903 RETURN;
6904 }
6907 /* process one subroutine argument - typically when the sub has a signature:
6908 * introduce PL_curpad[op_targ] and assign to it the value
6909 * for $: (OPf_STACKED ? *sp : $_[N])
6910 * for @/%: @_[N..$#_]
6911 *
6912 * It's equivalent to
6913 * my $foo = $_[N];
6914 * or
6915 * my $foo = (value-on-stack)
6916 * or
6917 * my @foo = @_[N..$#_]
6918 * etc
6919 */
6921 PP(pp_argelem)
6922 {
6923 dTARG;
6924 SV *val;
6925 SV ** padentry;
6926 OP *o = PL_op;
6927 AV *defav = GvAV(PL_defgv); /* @_ */
6928 IV ix = PTR2IV(cUNOP_AUXo->op_aux);
6929 IV argc;
6931 /* do 'my $var, @var or %var' action */
6932 padentry = &(PAD_SVl(o->op_targ));
6933 save_clearsv(padentry);
6934 targ = *padentry;
6936 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_SV) {
6937 if (o->op_flags & OPf_STACKED) {
6938 dSP;
6939 val = POPs;
6940 PUTBACK;
6941 }
6942 else {
6943 SV **svp;
6944 /* should already have been checked */
6945 assert(ix >= 0);
6946 #if IVSIZE > PTRSIZE
6947 assert(ix <= SSize_t_MAX);
6948 #endif
6950 svp = av_fetch(defav, ix, FALSE);
6951 val = svp ? *svp : &PL_sv_undef;
6952 }
6954 /* $var = $val */
6956 /* cargo-culted from pp_sassign */
6957 assert(TAINTING_get || !TAINT_get);
6958 if (UNLIKELY(TAINT_get) && !SvTAINTED(val))
6959 TAINT_NOT;
6961 SvSetMagicSV(targ, val);
6962 return o->op_next;
6963 }
6965 /* must be AV or HV */
6967 assert(!(o->op_flags & OPf_STACKED));
6968 argc = ((IV)AvFILL(defav) + 1) - ix;
6970 /* This is a copy of the relevant parts of pp_aassign().
6971 */
6972 if ((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_AV) {
6973 IV i;
6975 if (AvFILL((AV*)targ) > -1) {
6976 /* target should usually be empty. If we get get
6977 * here, someone's been doing some weird closure tricks.
6978 * Make a copy of all args before clearing the array,
6979 * to avoid the equivalent of @a = ($a[0]) prematurely freeing
6980 * elements. See similar code in pp_aassign.
6981 */
6982 for (i = 0; i < argc; i++) {
6983 SV **svp = av_fetch(defav, ix + i, FALSE);
6984 SV *newsv = newSV(0);
6985 sv_setsv_flags(newsv,
6986 svp ? *svp : &PL_sv_undef,
6987 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
6988 if (!av_store(defav, ix + i, newsv))
6989 SvREFCNT_dec_NN(newsv);
6990 }
6991 av_clear((AV*)targ);
6992 }
6994 if (argc <= 0)
6995 return o->op_next;
6997 av_extend((AV*)targ, argc);
6999 i = 0;
7000 while (argc--) {
7001 SV *tmpsv;
7002 SV **svp = av_fetch(defav, ix + i, FALSE);
7003 SV *val = svp ? *svp : &PL_sv_undef;
7004 tmpsv = newSV(0);
7005 sv_setsv(tmpsv, val);
7006 av_store((AV*)targ, i++, tmpsv);
7007 TAINT_NOT;
7008 }
7010 }
7011 else {
7012 IV i;
7014 assert((o->op_private & OPpARGELEM_MASK) == OPpARGELEM_HV);
7016 if (SvRMAGICAL(targ) || HvUSEDKEYS((HV*)targ)) {
7017 /* see "target should usually be empty" comment above */
7018 for (i = 0; i < argc; i++) {
7019 SV **svp = av_fetch(defav, ix + i, FALSE);
7020 SV *newsv = newSV(0);
7021 sv_setsv_flags(newsv,
7022 svp ? *svp : &PL_sv_undef,
7023 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
7024 if (!av_store(defav, ix + i, newsv))
7025 SvREFCNT_dec_NN(newsv);
7026 }
7027 hv_clear((HV*)targ);
7028 }
7030 if (argc <= 0)
7031 return o->op_next;
7032 assert(argc % 2 == 0);
7034 i = 0;
7035 while (argc) {
7036 SV *tmpsv;
7037 SV **svp;
7038 SV *key;
7039 SV *val;
7041 svp = av_fetch(defav, ix + i++, FALSE);
7042 key = svp ? *svp : &PL_sv_undef;
7043 svp = av_fetch(defav, ix + i++, FALSE);
7044 val = svp ? *svp : &PL_sv_undef;
7046 argc -= 2;
7047 if (UNLIKELY(SvGMAGICAL(key)))
7048 key = sv_mortalcopy(key);
7049 tmpsv = newSV(0);
7050 sv_setsv(tmpsv, val);
7051 hv_store_ent((HV*)targ, key, tmpsv, 0);
7052 TAINT_NOT;
7053 }
7054 }
7056 return o->op_next;
7057 }
7059 /* Handle a default value for one subroutine argument (typically as part
7060 * of a subroutine signature).
7061 * It's equivalent to
7062 * @_ > op_targ ? $_[op_targ] : result_of(op_other)
7063 *
7064 * Intended to be used where op_next is an OP_ARGELEM
7065 *
7066 * We abuse the op_targ field slightly: it's an index into @_ rather than
7067 * into PL_curpad.
7068 */
7070 PP(pp_argdefelem)
7071 {
7072 OP * const o = PL_op;
7073 AV *defav = GvAV(PL_defgv); /* @_ */
7074 IV ix = (IV)o->op_targ;
7076 assert(ix >= 0);
7077 #if IVSIZE > PTRSIZE
7078 assert(ix <= SSize_t_MAX);
7079 #endif
7081 if (AvFILL(defav) >= ix) {
7082 dSP;
7083 SV **svp = av_fetch(defav, ix, FALSE);
7084 SV *val = svp ? *svp : &PL_sv_undef;
7085 XPUSHs(val);
7086 RETURN;
7087 }
7088 return cLOGOPo->op_other;
7089 }
7092 static SV *
7093 S_find_runcv_name(void)
7094 {
7095 dTHX;
7096 CV *cv;
7097 GV *gv;
7098 SV *sv;
7100 cv = find_runcv(0);
7101 if (!cv)
7102 return &PL_sv_no;
7104 gv = CvGV(cv);
7105 if (!gv)
7106 return &PL_sv_no;
7108 sv = sv_2mortal(newSV(0));
7109 gv_fullname4(sv, gv, NULL, TRUE);
7110 return sv;
7111 }
7113 /* Check a a subs arguments - i.e. that it has the correct number of args
7114 * (and anything else we might think of in future). Typically used with
7115 * signatured subs.
7116 */
7118 PP(pp_argcheck)
7119 {
7120 OP * const o = PL_op;
7121 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
7122 IV params = aux[0].iv;
7123 IV opt_params = aux[1].iv;
7124 char slurpy = (char)(aux[2].iv);
7125 AV *defav = GvAV(PL_defgv); /* @_ */
7126 IV argc;
7127 bool too_few;
7129 assert(!SvMAGICAL(defav));
7130 argc = (AvFILLp(defav) + 1);
7131 too_few = (argc < (params - opt_params));
7133 if (UNLIKELY(too_few || (!slurpy && argc > params)))
7134 /* diag_listed_as: Too few arguments for subroutine '%s' */
7135 /* diag_listed_as: Too many arguments for subroutine '%s' */
7136 Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
7137 too_few ? "few" : "many", S_find_runcv_name());
7139 if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
7140 /* diag_listed_as: Odd name/value argument for subroutine '%s' */
7141 Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
7142 S_find_runcv_name());
7144 return NORMAL;
7145 }
7147 /*
7148 * ex: set ts=8 sts=4 sw=4 et:
7149 */