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