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