File Coverage

pp.c
Criterion Covered Total %
statement 2741 2870 95.5
branch 3232 4092 79.0
condition n/a
subroutine n/a
total 5973 6962 85.8


line stmt bran cond sub time code
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 "reentr.h"
32           #include "regcharclass.h"
33            
34           /* XXX I can't imagine anyone who doesn't have this actually _needs_
35           it, since pid_t is an integral type.
36           --AD 2/20/1998
37           */
38           #ifdef NEED_GETPID_PROTO
39           extern Pid_t getpid (void);
40           #endif
41            
42           /*
43           * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44           * This switches them over to IEEE.
45           */
46           #if defined(LIBM_LIB_VERSION)
47           _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
48           #endif
49            
50           static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51           static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
52            
53           /* variations on pp_null */
54            
55 255711072         PP(pp_stub)
56           {
57           dVAR;
58 255711072         dSP;
59 255711072 100       if (GIMME_V == G_SCALAR)
    100        
60 44276 50       XPUSHs(&PL_sv_undef);
61 255711072         RETURN;
62           }
63            
64           /* Pushy stuff. */
65            
66 103353002         PP(pp_padav)
67 103353002 50       {
68 103353002         dVAR; dSP; dTARGET;
69           I32 gimme;
70           assert(SvTYPE(TARG) == SVt_PVAV);
71 103353002 100       if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
72 12610620 100       if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
73 12610616         SAVECLEARSV(PAD_SVl(PL_op->op_targ));
74 51610859         EXTEND(SP, 1);
75 103353002 100       if (PL_op->op_flags & OPf_REF) {
76 47129536         PUSHs(TARG);
77 47129536         RETURN;
78 56223466 100       } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
79 28         const I32 flags = is_lvalue_sub();
80 28 50       if (flags && !(flags & OPpENTERSUB_INARGS)) {
    100        
81 2 50       if (GIMME == G_SCALAR)
    50        
82           /* diag_listed_as: Can't return %s to lvalue scalar context */
83 0         Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
84 2         PUSHs(TARG);
85 2         RETURN;
86           }
87           }
88 56223464 100       gimme = GIMME_V;
89 70896673 100       if (gimme == G_ARRAY) {
    100        
90           /* XXX see also S_pushav in pp_hot.c */
91 14673211 100       const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
92 7318723         EXTEND(SP, maxarg);
93 14673209 100       if (SvMAGICAL(TARG)) {
94           Size_t i;
95 289772 100       for (i=0; i < maxarg; i++) {
96 275270         SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
97 275270 50       SP[i+1] = (svp) ? *svp : &PL_sv_undef;
98           }
99           }
100           else {
101           PADOFFSET i;
102 42918854 100       for (i=0; i < (PADOFFSET)maxarg; i++) {
103 35578816         SV * const sv = AvARRAY((const AV *)TARG)[i];
104 35578816 100       SP[i+1] = sv ? sv : &PL_sv_undef;
105           }
106           }
107 14673209         SP += maxarg;
108           }
109 41550253 100       else if (gimme == G_SCALAR) {
110 29093691         SV* const sv = sv_newmortal();
111 29093691 100       const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
112 29093691         sv_setiv(sv, maxarg);
113 29093691         PUSHs(sv);
114           }
115 79798480         RETURN;
116           }
117            
118 116251963         PP(pp_padhv)
119           {
120 116251963         dVAR; dSP; dTARGET;
121           I32 gimme;
122            
123           assert(SvTYPE(TARG) == SVt_PVHV);
124 116251963 50       XPUSHs(TARG);
125 116251963 100       if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
126 799165 100       if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
127 798153         SAVECLEARSV(PAD_SVl(PL_op->op_targ));
128 116251963 100       if (PL_op->op_flags & OPf_REF)
129 115120586         RETURN;
130 1131377 100       else if (PL_op->op_private & OPpMAYBE_LVSUB) {
131 4         const I32 flags = is_lvalue_sub();
132 4 50       if (flags && !(flags & OPpENTERSUB_INARGS)) {
    100        
133 2 50       if (GIMME == G_SCALAR)
    50        
134           /* diag_listed_as: Can't return %s to lvalue scalar context */
135 0         Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
136 2         RETURN;
137           }
138           }
139 1131375 100       gimme = GIMME_V;
140 1131375 100       if (gimme == G_ARRAY) {
141 326156         RETURNOP(Perl_do_kv(aTHX));
142           }
143 805219 100       else if ((PL_op->op_private & OPpTRUEBOOL
144 801865 50       || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
145 0 0       && block_gimme() == G_VOID ))
146 3354 100       && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
    50        
147 3344 50       SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
    100        
148 801875 100       else if (gimme == G_SCALAR) {
149 2720         SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
150 2720         SETs(sv);
151           }
152 58873395         RETURN;
153           }
154            
155 420         PP(pp_padcv)
156           {
157 420         dVAR; dSP; dTARGET;
158           assert(SvTYPE(TARG) == SVt_PVCV);
159 420 50       XPUSHs(TARG);
160 420         RETURN;
161           }
162            
163 118         PP(pp_introcv)
164           {
165 118         dVAR; dTARGET;
166           SvPADSTALE_off(TARG);
167 118         return NORMAL;
168           }
169            
170 118         PP(pp_clonecv)
171           {
172 118         dVAR; dTARGET;
173 118         MAGIC * const mg =
174 118         mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
175           PERL_MAGIC_proto);
176           assert(SvTYPE(TARG) == SVt_PVCV);
177           assert(mg);
178           assert(mg->mg_obj);
179 118 100       if (CvISXSUB(mg->mg_obj)) { /* constant */
180           /* XXX Should we clone it here? */
181           /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
182           to introcv and remove the SvPADSTALE_off. */
183 12         SAVEPADSVANDMORTALIZE(ARGTARG);
184 12         PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
185           }
186           else {
187           if (CvROOT(mg->mg_obj)) {
188           assert(CvCLONE(mg->mg_obj));
189           assert(!CvCLONED(mg->mg_obj));
190           }
191 106         cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
192 106         SAVECLEARSV(PAD_SVl(ARGTARG));
193           }
194 118         return NORMAL;
195           }
196            
197           /* Translations. */
198            
199           static const char S_no_symref_sv[] =
200           "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
201            
202           /* In some cases this function inspects PL_op. If this function is called
203           for new op types, more bool parameters may need to be added in place of
204           the checks.
205            
206           When noinit is true, the absence of a gv will cause a retval of undef.
207           This is unrelated to the cv-to-gv assignment case.
208           */
209            
210           static SV *
211 85232622         S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
212           const bool noinit)
213           {
214           dVAR;
215 85232622 100       if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
    100        
216 85232622 100       if (SvROK(sv)) {
217 43091155 50       if (SvAMAGIC(sv)) {
    100        
    100        
218 2452         sv = amagic_deref_call(sv, to_gv_amg);
219           }
220           wasref:
221 45564217         sv = SvRV(sv);
222 45564217 100       if (SvTYPE(sv) == SVt_PVIO) {
223 196944         GV * const gv = MUTABLE_GV(sv_newmortal());
224 196944         gv_init(gv, 0, "__ANONIO__", 10, 0);
225 196944         GvIOp(gv) = MUTABLE_IO(sv);
226 196944         SvREFCNT_inc_void_NN(sv);
227           sv = MUTABLE_SV(gv);
228           }
229 45367273 100       else if (!isGV_with_GP(sv))
    50        
230 12         return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
231           }
232           else {
233 42141467 100       if (!isGV_with_GP(sv)) {
    50        
234 35642828 100       if (!SvOK(sv)) {
    50        
    50        
235           /* If this is a 'my' scalar and flag is set then vivify
236           * NI-S 1999/05/07
237           */
238 2473108 100       if (vivify_sv && sv != &PL_sv_undef) {
    50        
239           GV *gv;
240 2473064 50       if (SvREADONLY(sv))
241 0         Perl_croak_no_modify();
242 2473064 100       if (cUNOP->op_targ) {
243 2473036         SV * const namesv = PAD_SV(cUNOP->op_targ);
244 2473036         HV *stash = CopSTASH(PL_curcop);
245 2473036 100       if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
246 2473036         gv = MUTABLE_GV(newSV(0));
247 2473036         gv_init_sv(gv, stash, namesv, 0);
248           }
249           else {
250 28 50       const char * const name = CopSTASHPV(PL_curcop);
    50        
    50        
    50        
    0        
    50        
    50        
251 28 50       gv = newGVgen_flags(name,
    50        
    50        
    0        
    50        
    50        
    50        
    50        
252           HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
253           }
254 2473064 100       prepare_SV_for_RV(sv);
    100        
    50        
    0        
    0        
    0        
255 2473064         SvRV_set(sv, MUTABLE_SV(gv));
256 2473064         SvROK_on(sv);
257 2473064 100       SvSETMAGIC(sv);
258           goto wasref;
259           }
260 44 100       if (PL_op->op_flags & OPf_REF || strict)
    100        
261 8         return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
262 36 100       if (ckWARN(WARN_UNINITIALIZED))
263 22         report_uninit(sv);
264           return &PL_sv_undef;
265           }
266 33169720 100       if (noinit)
267           {
268 12212 100       if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
269           sv, GV_ADDMG, SVt_PVGV
270           ))))
271           return &PL_sv_undef;
272           }
273           else {
274 33157508 100       if (strict)
275 8         return
276 8 100       (SV *)Perl_die(aTHX_
277           S_no_symref_sv,
278           sv,
279 11 100       (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
280           "a symbol"
281           );
282 33157500 100       if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
283           == OPpDONT_INIT_GV) {
284           /* We are the target of a coderef assignment. Return
285           the scalar unchanged, and let pp_sasssign deal with
286           things. */
287           return sv;
288           }
289 31490688         sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
290           }
291           /* FAKE globs in the symbol table cause weird bugs (#77810) */
292 31502566         SvFAKE_off(sv);
293           }
294           }
295 83565410 100       if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
    100        
296 166432         SV *newsv = sv_newmortal();
297 166432         sv_setsv_flags(newsv, sv, 0);
298 166432         SvFAKE_off(newsv);
299           sv = newsv;
300           }
301 84405783         return sv;
302           }
303            
304 85232560         PP(pp_rv2gv)
305           {
306 85232560         dVAR; dSP; dTOPss;
307            
308 170383430         sv = S_rv2gv(aTHX_
309 85232560         sv, PL_op->op_private & OPpDEREF,
310 85232560         PL_op->op_private & HINT_STRICT_REFS,
311 47037193 100       ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
312 128651537 100       || PL_op->op_type == OP_READLINE
    100        
313           );
314 85232420 100       if (PL_op->op_private & OPpLVAL_INTRO)
315 2701347         save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
316 85232420         SETs(sv);
317 85232420         RETURN;
318           }
319            
320           /* Helper function for pp_rv2sv and pp_rv2av */
321           GV *
322 5543774         Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
323           const svtype type, SV ***spp)
324           {
325           dVAR;
326           GV *gv;
327            
328           PERL_ARGS_ASSERT_SOFTREF2XV;
329            
330 5543774 100       if (PL_op->op_private & HINT_STRICT_REFS) {
331 78 100       if (SvOK(sv))
    50        
    50        
332 140 100       Perl_die(aTHX_ S_no_symref_sv, sv,
333 104 100       (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
334           else
335 8         Perl_die(aTHX_ PL_no_usym, what);
336           }
337 5543696 100       if (!SvOK(sv)) {
    50        
    50        
338 78 50       if (
339 78         PL_op->op_flags & OPf_REF
340           )
341 0         Perl_die(aTHX_ PL_no_usym, what);
342 78 100       if (ckWARN(WARN_UNINITIALIZED))
343 22         report_uninit(sv);
344 78 100       if (type != SVt_PV && GIMME_V == G_ARRAY) {
    50        
    100        
345 16         (*spp)--;
346 16         return NULL;
347           }
348 62         **spp = &PL_sv_undef;
349 62         return NULL;
350           }
351 5583384 100       if ((PL_op->op_flags & OPf_SPECIAL) &&
    100        
352 79532         !(PL_op->op_flags & OPf_MOD))
353           {
354 58870 100       if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
355           {
356 920         **spp = &PL_sv_undef;
357 920         return NULL;
358           }
359           }
360           else {
361 5484748         gv = gv_fetchsv_nomg(sv, GV_ADD, type);
362           }
363 5543197         return gv;
364           }
365            
366 146100059         PP(pp_rv2sv)
367 146100059 100       {
368 146100059         dVAR; dSP; dTOPss;
369           GV *gv = NULL;
370            
371 73040135         SvGETMAGIC(sv);
372 146100059 100       if (SvROK(sv)) {
373 134465894 50       if (SvAMAGIC(sv)) {
    100        
    100        
374 222684         sv = amagic_deref_call(sv, to_sv_amg);
375           }
376            
377 134465894         sv = SvRV(sv);
378 134465894 100       switch (SvTYPE(sv)) {
379           case SVt_PVAV:
380           case SVt_PVHV:
381           case SVt_PVCV:
382           case SVt_PVFM:
383           case SVt_PVIO:
384 4         DIE(aTHX_ "Not a SCALAR reference");
385           default: NOOP;
386           }
387           }
388           else {
389           gv = MUTABLE_GV(sv);
390            
391 11634165 100       if (!isGV_with_GP(gv)) {
    50        
392 2028339         gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
393 2028281 100       if (!gv)
394 928         RETURN;
395           }
396 11633179 100       sv = GvSVn(gv);
397           }
398 146099069 100       if (PL_op->op_flags & OPf_MOD) {
399 19350959 100       if (PL_op->op_private & OPpLVAL_INTRO) {
400 24 50       if (cUNOP->op_first->op_type == OP_NULL)
401 0         sv = save_scalar(MUTABLE_GV(TOPs));
402 24 100       else if (gv)
403 10         sv = save_scalar(gv);
404           else
405 14         Perl_croak(aTHX_ "%s", PL_no_localize_ref);
406           }
407 19350935 100       else if (PL_op->op_private & OPpDEREF)
408 9666736         sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
409           }
410 146099055         SETs(sv);
411 146099519         RETURN;
412           }
413            
414 7504518         PP(pp_av2arylen)
415           {
416 7504518         dVAR; dSP;
417 7504518         AV * const av = MUTABLE_AV(TOPs);
418 7504518 100       const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
    100        
    50        
419 7504518 100       if (lvalue) {
420 50398         SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
421 50398 100       if (!*sv) {
422 15484         *sv = newSV_type(SVt_PVMG);
423 15484         sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
424           }
425 50398         SETs(*sv);
426           } else {
427 7454120 100       SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
428           }
429 7504518         RETURN;
430           }
431            
432 2194580         PP(pp_pos)
433           {
434 2194580         dVAR; dSP; dPOPss;
435            
436 2194580 100       if (PL_op->op_flags & OPf_MOD || LVRET) {
    100        
    100        
437 78550         SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
438 78550         sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
439 78550         LvTYPE(ret) = '.';
440 157100         LvTARG(ret) = SvREFCNT_inc_simple(sv);
441 78550         PUSHs(ret); /* no SvSETMAGIC */
442 78550         RETURN;
443           }
444           else {
445 2116030         const MAGIC * const mg = mg_find_mglob(sv);
446 2116030 100       if (mg && mg->mg_len != -1) {
    100        
447 2115022         dTARGET;
448 2115022         STRLEN i = mg->mg_len;
449 2115022 100       if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
    100        
    50        
450 2018474         i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
451 2115022 50       PUSHu(i);
452 2115022         RETURN;
453           }
454 1097794         RETPUSHUNDEF;
455           }
456           }
457            
458 4636940         PP(pp_rv2cv)
459           {
460 4636940         dVAR; dSP;
461           GV *gv;
462           HV *stash_unused;
463 4636940         const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
464 4636940         ? GV_ADDMG
465 4636940 100       : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
466           == OPpMAY_RETURN_CONSTANT)
467           ? GV_ADD|GV_NOEXPAND
468 3395498 100       : GV_ADD;
469           /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
470           /* (But not in defined().) */
471            
472 4636940         CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
473 4636940 100       if (cv) NOOP;
474 1167494 100       else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
    50        
    50        
475 683758         cv = MUTABLE_CV(gv);
476           }
477           else
478           cv = MUTABLE_CV(&PL_sv_undef);
479 4636940         SETs(MUTABLE_SV(cv));
480 4636940         RETURN;
481           }
482            
483 1040638         PP(pp_prototype)
484           {
485 1040638         dVAR; dSP;
486           CV *cv;
487           HV *stash;
488           GV *gv;
489           SV *ret = &PL_sv_undef;
490            
491 1040638 100       if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
492 1040638 100       if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
    100        
493 1038386         const char * s = SvPVX_const(TOPs);
494 1038386 100       if (strnEQ(s, "CORE::", 6)) {
495 797824         const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
496 797824 100       if (!code || code == -KEY_CORE)
497 36         DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
498 36         UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
499           {
500 797806         SV * const sv = core_prototype(NULL, s + 6, code, NULL);
501 797806 100       if (sv) ret = sv;
502           }
503           goto set;
504           }
505           }
506 242814         cv = sv_2cv(TOPs, &stash, &gv, 0);
507 242814 100       if (cv && SvPOK(cv))
    100        
508 103440 50       ret = newSVpvn_flags(
    50        
    100        
    50        
    50        
    100        
509           CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
510           );
511           set:
512 1040620         SETs(ret);
513 1040620         RETURN;
514           }
515            
516 3722334         PP(pp_anoncode)
517 3722334 50       {
518 3722334         dVAR; dSP;
519 3722334         CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
520 3722334 100       if (CvCLONE(cv))
521 3139126         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
522 1850010         EXTEND(SP,1);
523 3722334         PUSHs(MUTABLE_SV(cv));
524 3722334         RETURN;
525           }
526            
527 38173805         PP(pp_srefgen)
528           {
529 38173805         dVAR; dSP;
530 38173805         *SP = refto(*SP);
531 38173805         RETURN;
532           }
533            
534 13149025         PP(pp_refgen)
535           {
536 13149025         dVAR; dSP; dMARK;
537 13149025 100       if (GIMME != G_ARRAY) {
    100        
538 6784268 100       if (++MARK <= SP)
539 6784264         *MARK = *SP;
540           else
541 4         *MARK = &PL_sv_undef;
542 6784268         *MARK = refto(*MARK);
543           SP = MARK;
544 6784268         RETURN;
545           }
546 6364757 100       EXTEND_MORTAL(SP - MARK);
547 12729890 100       while (++MARK <= SP)
548 6365133         *MARK = refto(*MARK);
549 9803140         RETURN;
550           }
551            
552           STATIC SV*
553 51323306         S_refto(pTHX_ SV *sv)
554           {
555           dVAR;
556           SV* rv;
557            
558           PERL_ARGS_ASSERT_REFTO;
559            
560 51323306 100       if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
    100        
561 10 100       if (LvTARGLEN(sv))
562 8         vivify_defelem(sv);
563 10 50       if (!(sv = LvTARG(sv)))
564           sv = &PL_sv_undef;
565           else
566 10         SvREFCNT_inc_void_NN(sv);
567           }
568 51323296 100       else if (SvTYPE(sv) == SVt_PVAV) {
569 2622682 100       if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
    50        
570 5358         av_reify(MUTABLE_AV(sv));
571 2622682         SvTEMP_off(sv);
572 2622682         SvREFCNT_inc_void_NN(sv);
573           }
574 48700614 100       else if (SvPADTMP(sv) && !IS_PADGV(sv))
575 2618         sv = newSVsv(sv);
576           else {
577 48697996         SvTEMP_off(sv);
578 48697996         SvREFCNT_inc_void_NN(sv);
579           }
580 51323306         rv = sv_newmortal();
581 51323306         sv_upgrade(rv, SVt_IV);
582 51323306         SvRV_set(rv, sv);
583 51323306         SvROK_on(rv);
584 51323306         return rv;
585           }
586            
587 267207972         PP(pp_ref)
588 267207972 100       {
589 267207972         dVAR; dSP; dTARGET;
590 267207972         SV * const sv = POPs;
591            
592 133591075         SvGETMAGIC(sv);
593 267207972 100       if (!SvROK(sv))
594 9893884         RETPUSHNO;
595            
596 257314088         (void)sv_ref(TARG,SvRV(sv),TRUE);
597 257314088 50       PUSHTARG;
598 262274170         RETURN;
599           }
600            
601 7542645         PP(pp_bless)
602           {
603 7542645         dVAR; dSP;
604           HV *stash;
605            
606 7542645 100       if (MAXARG == 1)
607           {
608           curstash:
609 510804         stash = CopSTASH(PL_curcop);
610 510804 100       if (SvTYPE(stash) != SVt_PVHV)
611 2         Perl_croak(aTHX_ "Attempt to bless into a freed package");
612           }
613           else {
614 7031843         SV * const ssv = POPs;
615           STRLEN len;
616           const char *ptr;
617            
618 7031843 100       if (!ssv) goto curstash;
619 7031841 100       if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
    100        
    50        
    100        
    100        
620 4         Perl_croak(aTHX_ "Attempt to bless into a reference");
621 7031837 100       ptr = SvPV_const(ssv,len);
622 7031837 100       if (len == 0)
623 16         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
624           "Explicit blessing to '' (assuming package main)");
625 7031837         stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
626           }
627            
628 7542639         (void)sv_bless(TOPs, stash);
629 7542635         RETURN;
630           }
631            
632 506946         PP(pp_gelem)
633           {
634 506946         dVAR; dSP;
635            
636 506946         SV *sv = POPs;
637           STRLEN len;
638 506946 100       const char * const elem = SvPV_const(sv, len);
639 506946         GV * const gv = MUTABLE_GV(POPs);
640           SV * tmpRef = NULL;
641            
642           sv = NULL;
643 506946 50       if (elem) {
644           /* elem will always be NUL terminated. */
645 506946         const char * const second_letter = elem + 1;
646 506946         switch (*elem) {
647           case 'A':
648 22090 50       if (len == 5 && strEQ(second_letter, "RRAY"))
    50        
649           {
650 22090         tmpRef = MUTABLE_SV(GvAV(gv));
651 22090 100       if (tmpRef && !AvREAL((const AV *)tmpRef)
    100        
652 6 50       && AvREIFY((const AV *)tmpRef))
653 6         av_reify(MUTABLE_AV(tmpRef));
654           }
655           break;
656           case 'C':
657 321154 50       if (len == 4 && strEQ(second_letter, "ODE"))
    50        
    50        
    50        
    50        
658 321154 100       tmpRef = MUTABLE_SV(GvCVu(gv));
659           break;
660           case 'F':
661 3608 100       if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
    50        
662           /* finally deprecated in 5.8.0 */
663 4         deprecate("*glob{FILEHANDLE}");
664 4         tmpRef = MUTABLE_SV(GvIOp(gv));
665           }
666           else
667 3604 50       if (len == 6 && strEQ(second_letter, "ORMAT"))
    50        
668 3604         tmpRef = MUTABLE_SV(GvFORM(gv));
669           break;
670           case 'G':
671 4 50       if (len == 4 && strEQ(second_letter, "LOB"))
    50        
    50        
    50        
    50        
672           tmpRef = MUTABLE_SV(gv);
673           break;
674           case 'H':
675 117450 50       if (len == 4 && strEQ(second_letter, "ASH"))
    50        
    50        
    50        
    50        
676 117450         tmpRef = MUTABLE_SV(GvHV(gv));
677           break;
678           case 'I':
679 15100 50       if (*second_letter == 'O' && !elem[2] && len == 2)
    50        
    50        
680 15100         tmpRef = MUTABLE_SV(GvIOp(gv));
681           break;
682           case 'N':
683 80 50       if (len == 4 && strEQ(second_letter, "AME"))
    50        
    50        
    50        
    50        
684 80         sv = newSVhek(GvNAME_HEK(gv));
685           break;
686           case 'P':
687 18 50       if (len == 7 && strEQ(second_letter, "ACKAGE")) {
    50        
688 18         const HV * const stash = GvSTASH(gv);
689 18 50       const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
    50        
    50        
    100        
690 18 100       sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
691           }
692           break;
693           case 'S':
694 27440 50       if (len == 6 && strEQ(second_letter, "CALAR"))
    50        
695 27440 100       tmpRef = GvSVn(gv);
696           break;
697           }
698           }
699 506946 100       if (tmpRef)
700 439066         sv = newRV(tmpRef);
701 506946 100       if (sv)
702 439164         sv_2mortal(sv);
703           else
704           sv = &PL_sv_undef;
705 506946 50       XPUSHs(sv);
706 506946         RETURN;
707           }
708            
709           /* Pattern matching */
710            
711 37170         PP(pp_study)
712           {
713 37170         dVAR; dSP; dPOPss;
714           STRLEN len;
715            
716 37170 100       (void)SvPV(sv, len);
717 37170 100       if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
    100        
718           /* Historically, study was skipped in these cases. */
719 19594         RETPUSHNO;
720           }
721            
722           /* Make study a no-op. It's no longer useful and its existence
723           complicates matters elsewhere. */
724 27373         RETPUSHYES;
725           }
726            
727 895790         PP(pp_trans)
728           {
729 895790         dVAR; dSP; dTARG;
730           SV *sv;
731            
732 895790 100       if (PL_op->op_flags & OPf_STACKED)
733 626610         sv = POPs;
734 538354 100       else if (PL_op->op_private & OPpTARGET_MY)
    50        
735 6         sv = GETTARGET;
736           else {
737 269174 50       sv = DEFSV;
738 134587         EXTEND(SP,1);
739           }
740 895790 100       if(PL_op->op_type == OP_TRANSR) {
741           STRLEN len;
742 4204 100       const char * const pv = SvPV(sv,len);
743 4204         SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
744 4204         do_trans(newsv);
745 4204         PUSHs(newsv);
746           }
747           else {
748 891586         TARG = sv_newmortal();
749 891586 50       PUSHi(do_trans(sv));
750           }
751 895786         RETURN;
752           }
753            
754           /* Lvalue operators. */
755            
756           static void
757 2042604         S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
758           {
759           dVAR;
760           STRLEN len;
761           char *s;
762            
763           PERL_ARGS_ASSERT_DO_CHOMP;
764            
765 2042604 100       if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
    100        
    50        
    50        
    100        
    100        
    50        
    50        
766           return;
767 1846646 100       if (SvTYPE(sv) == SVt_PVAV) {
768           I32 i;
769           AV *const av = MUTABLE_AV(sv);
770 654 50       const I32 max = AvFILL(av);
771            
772 31878 100       for (i = 0; i <= max; i++) {
773 31224         sv = MUTABLE_SV(av_fetch(av, i, FALSE));
774 31224 50       if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
    50        
775 31224         do_chomp(retval, sv, chomping);
776           }
777           return;
778           }
779 1845992 50       else if (SvTYPE(sv) == SVt_PVHV) {
780           HV* const hv = MUTABLE_HV(sv);
781           HE* entry;
782 0         (void)hv_iterinit(hv);
783 0 0       while ((entry = hv_iternext(hv)))
784 0         do_chomp(retval, hv_iterval(hv,entry), chomping);
785           return;
786           }
787 1845992 100       else if (SvREADONLY(sv)) {
788 2         Perl_croak_no_modify();
789           }
790 1845990 100       else if (SvIsCOW(sv)) {
791 20090         sv_force_normal_flags(sv, 0);
792           }
793            
794 1845990 100       if (PL_encoding) {
795 420 100       if (!SvUTF8(sv)) {
796           /* XXX, here sv is utf8-ized as a side-effect!
797           If encoding.pm is used properly, almost string-generating
798           operations, including literal strings, chr(), input data, etc.
799           should have been utf8-ized already, right?
800           */
801 126         sv_recode_to_utf8(sv, PL_encoding);
802           }
803           }
804            
805 1845990 100       s = SvPV(sv, len);
806 1845952 100       if (chomping) {
807           char *temp_buffer = NULL;
808           SV *svrecode = NULL;
809            
810 1726336 50       if (s && len) {
    100        
811 1648282         s += --len;
812 1648282 100       if (RsPARA(PL_rs)) {
    100        
813 16 100       if (*s != '\n')
814           goto nope;
815 14         ++SvIVX(retval);
816 37 50       while (len && s[-1] == '\n') {
    100        
817 16         --len;
818 16         --s;
819 16         ++SvIVX(retval);
820           }
821           }
822           else {
823           STRLEN rslen, rs_charlen;
824 1648266 100       const char *rsptr = SvPV_const(PL_rs, rslen);
825            
826 1648266         rs_charlen = SvUTF8(PL_rs)
827 596         ? sv_len_utf8(PL_rs)
828 1648564 100       : rslen;
829            
830 1648266 100       if (SvUTF8(PL_rs) != SvUTF8(sv)) {
831           /* Assumption is that rs is shorter than the scalar. */
832 248 100       if (SvUTF8(PL_rs)) {
833           /* RS is utf8, scalar is 8 bit. */
834 20         bool is_utf8 = TRUE;
835 20         temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
836           &rslen, &is_utf8);
837 20 100       if (is_utf8) {
838           /* Cannot downgrade, therefore cannot possibly match
839           */
840           assert (temp_buffer == rsptr);
841           temp_buffer = NULL;
842           goto nope;
843           }
844           rsptr = temp_buffer;
845           }
846 228 100       else if (PL_encoding) {
847           /* RS is 8 bit, encoding.pm is used.
848           * Do not recode PL_rs as a side-effect. */
849 192         svrecode = newSVpvn(rsptr, rslen);
850 192         sv_recode_to_utf8(svrecode, PL_encoding);
851 192 50       rsptr = SvPV_const(svrecode, rslen);
852 192         rs_charlen = sv_len_utf8(svrecode);
853           }
854           else {
855           /* RS is 8 bit, scalar is utf8. */
856 36         temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
857           rsptr = temp_buffer;
858           }
859           }
860 1648252 100       if (rslen == 1) {
861 1647778 100       if (*s != *rsptr)
862           goto nope;
863 1638618         ++SvIVX(retval);
864           }
865           else {
866 474 100       if (len < rslen - 1)
867           goto nope;
868 450         len -= rslen - 1;
869 450         s -= rslen - 1;
870 450 100       if (memNE(s, rsptr, rslen))
871           goto nope;
872 262         SvIVX(retval) += rs_charlen;
873           }
874           }
875 1638894 100       s = SvPV_force_nomg_nolen(sv);
876 1638894         SvCUR_set(sv, len);
877 1638894         *SvEND(sv) = '\0';
878 1638894         SvNIOK_off(sv);
879 1638894 100       SvSETMAGIC(sv);
880           }
881           nope:
882            
883 1726336         SvREFCNT_dec(svrecode);
884            
885 1726336         Safefree(temp_buffer);
886           } else {
887 119616 100       if (len && !SvPOK(sv))
    100        
888 20 50       s = SvPV_force_nomg(sv, len);
889 119616 100       if (DO_UTF8(sv)) {
    50        
890 9320 50       if (s && len) {
    50        
891 9320         char * const send = s + len;
892           char * const start = s;
893 9320         s = send - 1;
894 23454 100       while (s > start && UTF8_IS_CONTINUATION(*s))
    100        
895 9474         s--;
896 9320 50       if (is_utf8_string((U8*)s, send - s)) {
897 9320         sv_setpvn(retval, s, send - s);
898 9320         *s = '\0';
899 9320         SvCUR_set(sv, s - start);
900 9320         SvNIOK_off(sv);
901 9320         SvUTF8_on(retval);
902           }
903           }
904           else
905 0         sv_setpvs(retval, "");
906           }
907 110296 50       else if (s && len) {
    100        
908 110050         s += --len;
909 110050         sv_setpvn(retval, s, 1);
910 110050         *s = '\0';
911 110050         SvCUR_set(sv, len);
912 110050         SvUTF8_off(sv);
913 110050         SvNIOK_off(sv);
914           }
915           else
916 246         sv_setpvs(retval, "");
917 1081090 100       SvSETMAGIC(sv);
918           }
919           }
920            
921 2009456         PP(pp_schop)
922           {
923 2009456         dVAR; dSP; dTARGET;
924 2009456         const bool chomping = PL_op->op_type == OP_SCHOMP;
925            
926 2009456 100       if (chomping)
927 1889956         sv_setiv(TARG, 0);
928 2009456         do_chomp(TARG, TOPs, chomping);
929 2009416 50       SETTARG;
930 2009416         RETURN;
931           }
932            
933 1416         PP(pp_chop)
934           {
935 1416         dVAR; dSP; dMARK; dTARGET; dORIGMARK;
936 1416         const bool chomping = PL_op->op_type == OP_CHOMP;
937            
938 1416 100       if (chomping)
939 1322         sv_setiv(TARG, 0);
940 3340 100       while (MARK < SP)
941 1924         do_chomp(TARG, *++MARK, chomping);
942 1416         SP = ORIGMARK;
943 1416 50       XPUSHTARG;
    50        
944 1416         RETURN;
945           }
946            
947 16660689         PP(pp_undef)
948           {
949 16660689         dVAR; dSP;
950           SV *sv;
951            
952 24905768 100       if (!PL_op->op_private) {
    50        
953 8245079         EXTEND(SP, 1);
954 16523996         RETPUSHUNDEF;
955           }
956            
957 136693         sv = POPs;
958 136693 100       if (!sv)
959 8         RETPUSHUNDEF;
960            
961 136685 100       SV_CHECK_THINKFIRST_COW_DROP(sv);
962            
963 136685         switch (SvTYPE(sv)) {
964           case SVt_NULL:
965           break;
966           case SVt_PVAV:
967 830         av_undef(MUTABLE_AV(sv));
968 830         break;
969           case SVt_PVHV:
970 3064         hv_undef(MUTABLE_HV(sv));
971 3064         break;
972           case SVt_PVCV:
973 8741 100       if (cv_const_sv((const CV *)sv))
974 28 100       Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
975           "Constant subroutine %"SVf" undefined",
976 46 100       SVfARG(CvANON((const CV *)sv)
    50        
977           ? newSVpvs_flags("(anonymous)", SVs_TEMP)
978           : sv_2mortal(newSVhek(
979           CvNAMED(sv)
980           ? CvNAME_HEK((CV *)sv)
981           : GvENAME_HEK(CvGV((const CV *)sv))
982           ))
983           ));
984           /* FALLTHROUGH */
985           case SVt_PVFM:
986           {
987           /* let user-undef'd sub keep its identity */
988           GV* const gv = CvGV((const CV *)sv);
989           HEK * const hek = CvNAME_HEK((CV *)sv);
990 8739 50       if (hek) share_hek_hek(hek);
991 8739         cv_undef(MUTABLE_CV(sv));
992 8733 50       if (gv) CvGV_set(MUTABLE_CV(sv), gv);
993 0 0       else if (hek) {
994 0         SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
995 0         CvNAMED_on(sv);
996           }
997           }
998           break;
999           case SVt_PVGV:
1000           assert(isGV_with_GP(sv));
1001           assert(!SvFAKE(sv));
1002           {
1003           GP *gp;
1004           HV *stash;
1005            
1006           /* undef *Pkg::meth_name ... */
1007 1802         bool method_changed
1008 2703 100       = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
    50        
1009 2745 50       && HvENAME_get(stash);
    50        
    50        
    50        
    100        
    50        
    50        
    50        
1010           /* undef *Foo:: */
1011 1802 100       if((stash = GvHV((const GV *)sv))) {
1012 32 100       if(HvENAME_get(stash))
    50        
    50        
    50        
    50        
    50        
    50        
1013 14         SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1014           else stash = NULL;
1015           }
1016            
1017 1802         gp_free(MUTABLE_GV(sv));
1018 1802         Newxz(gp, 1, GP);
1019 1802         GvGP_set(sv, gp_ref(gp));
1020 1802         GvSV(sv) = newSV(0);
1021 1802         GvLINE(sv) = CopLINE(PL_curcop);
1022 1802         GvEGV(sv) = MUTABLE_GV(sv);
1023 1802         GvMULTI_on(sv);
1024            
1025 1802 100       if(stash)
1026 14         mro_package_moved(NULL, stash, (const GV *)sv, 0);
1027           stash = NULL;
1028           /* undef *Foo::ISA */
1029 1802 100       if( strEQ(GvNAME((const GV *)sv), "ISA")
    50        
    50        
    100        
1030 10 50       && (stash = GvSTASH((const GV *)sv))
1031 10 50       && (method_changed || HvENAME(stash)) )
    50        
    50        
    50        
    50        
    50        
    50        
    50        
1032 10         mro_isa_changed_in(stash);
1033 1792 100       else if(method_changed)
1034 84         mro_method_changed_in(
1035           GvSTASH((const GV *)sv)
1036           );
1037            
1038           break;
1039           }
1040           default:
1041 92758 100       if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
    100        
    100        
1042 2962 50       SvPV_free(sv);
    50        
    0        
    0        
1043 2962         SvPV_set(sv, NULL);
1044 2962         SvLEN_set(sv, 0);
1045           }
1046 92758 50       SvOK_off(sv);
1047 92758 100       SvSETMAGIC(sv);
1048           }
1049            
1050 8415596         RETPUSHUNDEF;
1051           }
1052            
1053 29431892         PP(pp_postinc)
1054           {
1055 29431892         dVAR; dSP; dTARGET;
1056 29431892         const bool inc =
1057 29431892         PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1058 29431892 50       if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
    50        
    0        
    0        
1059 0         Perl_croak_no_modify();
1060 29431892 100       if (SvROK(TOPs))
1061 4         TARG = sv_newmortal();
1062 29431892         sv_setsv(TARG, TOPs);
1063 29431892 100       if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1064 16080786 100       && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
    100        
1065           {
1066 16080774 100       SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1067 16080774         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1068           }
1069 13351118 100       else if (inc)
1070 13273942         sv_inc_nomg(TOPs);
1071 77176         else sv_dec_nomg(TOPs);
1072 29431892 100       SvSETMAGIC(TOPs);
1073           /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1074 29431892 100       if (inc && !SvOK(TARG))
    100        
    50        
    50        
1075 10668988         sv_setiv(TARG, 0);
1076 29431892         SETs(TARG);
1077 29431892         return NORMAL;
1078           }
1079            
1080           /* Ordinary operators. */
1081            
1082 64954         PP(pp_pow)
1083           {
1084 64954 100       dVAR; dSP; dATARGET; SV *svl, *svr;
1085           #ifdef PERL_PRESERVE_IVUV
1086           bool is_int = 0;
1087           #endif
1088 64954 100       tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
    100        
1089 63782         svr = TOPs;
1090 63782         svl = TOPm1s;
1091           #ifdef PERL_PRESERVE_IVUV
1092           /* For integer to integer power, we do the calculation by hand wherever
1093           we're sure it is safe; otherwise we call pow() and try to convert to
1094           integer afterwards. */
1095 63782 100       if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
    100        
    50        
    100        
    100        
    100        
    50        
    100        
1096           UV power;
1097           bool baseuok;
1098           UV baseuv;
1099            
1100 63450 50       if (SvUOK(svr)) {
1101 0         power = SvUVX(svr);
1102           } else {
1103 63450         const IV iv = SvIVX(svr);
1104 63450 100       if (iv >= 0) {
1105 62452         power = iv;
1106           } else {
1107           goto float_it; /* Can't do negative powers this way. */
1108           }
1109           }
1110            
1111 62452         baseuok = SvUOK(svl);
1112 62452 100       if (baseuok) {
1113 2         baseuv = SvUVX(svl);
1114           } else {
1115 62450         const IV iv = SvIVX(svl);
1116 62450 100       if (iv >= 0) {
1117 62242         baseuv = iv;
1118           baseuok = TRUE; /* effectively it's a UV now */
1119           } else {
1120 208         baseuv = -iv; /* abs, baseuok == false records sign */
1121           }
1122           }
1123           /* now we have integer ** positive integer. */
1124           is_int = 1;
1125            
1126           /* foo & (foo - 1) is zero only for a power of 2. */
1127 62452 100       if (!(baseuv & (baseuv - 1))) {
1128           /* We are raising power-of-2 to a positive integer.
1129           The logic here will work for any base (even non-integer
1130           bases) but it can be less accurate than
1131           pow (base,power) or exp (power * log (base)) when the
1132           intermediate values start to spill out of the mantissa.
1133           With powers of 2 we know this can't happen.
1134           And powers of 2 are the favourite thing for perl
1135           programmers to notice ** not doing what they mean. */
1136           NV result = 1.0;
1137 43122 100       NV base = baseuok ? baseuv : -(NV)baseuv;
1138            
1139 43122 100       if (power & 1) {
1140           result *= base;
1141           }
1142 130382 100       while (power >>= 1) {
1143 87260         base *= base;
1144 87260 100       if (power & 1) {
1145 69761         result *= base;
1146           }
1147           }
1148 43122         SP--;
1149 43122 50       SETn( result );
1150 43122 50       SvIV_please_nomg(svr);
    0        
    0        
1151 43122         RETURN;
1152           } else {
1153           unsigned int highbit = 8 * sizeof(UV);
1154           unsigned int diff = 8 * sizeof(UV);
1155 135310 100       while (diff >>= 1) {
1156 115980         highbit -= diff;
1157 115980 100       if (baseuv >> highbit) {
1158           highbit += diff;
1159           }
1160           }
1161           /* we now have baseuv < 2 ** highbit */
1162 19330 100       if (power * highbit <= 8 * sizeof(UV)) {
1163           /* result will definitely fit in UV, so use UV math
1164           on same algorithm as above */
1165           UV result = 1;
1166           UV base = baseuv;
1167 9988         const bool odd_power = cBOOL(power & 1);
1168 9988 100       if (odd_power) {
1169           result *= base;
1170           }
1171 38544 100       while (power >>= 1) {
1172 28556         base *= base;
1173 28556 100       if (power & 1) {
1174 19120         result *= base;
1175           }
1176           }
1177 9988         SP--;
1178 9988 100       if (baseuok || !odd_power)
    100        
1179           /* answer is positive */
1180 9952 50       SETu( result );
1181 36 50       else if (result <= (UV)IV_MAX)
1182           /* answer negative, fits in IV */
1183 36 50       SETi( -(IV)result );
1184 0 0       else if (result == (UV)IV_MIN)
1185           /* 2's complement assumption: special case IV_MIN */
1186 0 0       SETi( IV_MIN );
1187           else
1188           /* answer negative, doesn't fit */
1189 0 0       SETn( -(NV)result );
1190 9988         RETURN;
1191           }
1192           }
1193           }
1194           float_it:
1195           #endif
1196           {
1197 10672 100       NV right = SvNV_nomg(svr);
1198 10672 100       NV left = SvNV_nomg(svl);
1199 10672         (void)POPs;
1200            
1201           #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1202           /*
1203           We are building perl with long double support and are on an AIX OS
1204           afflicted with a powl() function that wrongly returns NaNQ for any
1205           negative base. This was reported to IBM as PMR #23047-379 on
1206           03/06/2006. The problem exists in at least the following versions
1207           of AIX and the libm fileset, and no doubt others as well:
1208            
1209           AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1210           AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1211           AIX 5.2.0 bos.adt.libm 5.2.0.85
1212            
1213           So, until IBM fixes powl(), we provide the following workaround to
1214           handle the problem ourselves. Our logic is as follows: for
1215           negative bases (left), we use fmod(right, 2) to check if the
1216           exponent is an odd or even integer:
1217            
1218           - if odd, powl(left, right) == -powl(-left, right)
1219           - if even, powl(left, right) == powl(-left, right)
1220            
1221           If the exponent is not an integer, the result is rightly NaNQ, so
1222           we just return that (as NV_NAN).
1223           */
1224            
1225           if (left < 0.0) {
1226           NV mod2 = Perl_fmod( right, 2.0 );
1227           if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1228           SETn( -Perl_pow( -left, right) );
1229           } else if (mod2 == 0.0) { /* even integer */
1230           SETn( Perl_pow( -left, right) );
1231           } else { /* fractional power */
1232           SETn( NV_NAN );
1233           }
1234           } else {
1235           SETn( Perl_pow( left, right) );
1236           }
1237           #else
1238 10672 100       SETn( Perl_pow( left, right) );
1239           #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1240            
1241           #ifdef PERL_PRESERVE_IVUV
1242 10672 100       if (is_int)
1243 9342 50       SvIV_please_nomg(svr);
    0        
    0        
1244           #endif
1245 38713         RETURN;
1246           }
1247           }
1248            
1249 1498132         PP(pp_multiply)
1250           {
1251 1498132 100       dVAR; dSP; dATARGET; SV *svl, *svr;
1252 1498132 100       tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
    100        
1253 1476412         svr = TOPs;
1254 1476412         svl = TOPm1s;
1255           #ifdef PERL_PRESERVE_IVUV
1256 1476412 100       if (SvIV_please_nomg(svr)) {
    100        
    50        
    100        
1257           /* Unless the left argument is integer in range we are going to have to
1258           use NV maths. Hence only attempt to coerce the right argument if
1259           we know the left is integer. */
1260           /* Left operand is defined, so is it IV? */
1261 1308074 100       if (SvIV_please_nomg(svl)) {
    100        
    50        
    100        
1262 1261408         bool auvok = SvUOK(svl);
1263 1261408         bool buvok = SvUOK(svr);
1264           const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1265           const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1266           UV alow;
1267           UV ahigh;
1268           UV blow;
1269           UV bhigh;
1270            
1271 1261408 100       if (auvok) {
1272 2         alow = SvUVX(svl);
1273           } else {
1274 1261406         const IV aiv = SvIVX(svl);
1275 1261406 100       if (aiv >= 0) {
1276 1239110         alow = aiv;
1277           auvok = TRUE; /* effectively it's a UV now */
1278           } else {
1279 22296         alow = -aiv; /* abs, auvok == false records sign */
1280           }
1281           }
1282 1261408 100       if (buvok) {
1283 126         blow = SvUVX(svr);
1284           } else {
1285 1261282         const IV biv = SvIVX(svr);
1286 1261282 100       if (biv >= 0) {
1287 1260148         blow = biv;
1288           buvok = TRUE; /* effectively it's a UV now */
1289           } else {
1290 1134         blow = -biv; /* abs, buvok == false records sign */
1291           }
1292           }
1293            
1294           /* If this does sign extension on unsigned it's time for plan B */
1295 1261408         ahigh = alow >> (4 * sizeof (UV));
1296 1261408         alow &= botmask;
1297 1261408         bhigh = blow >> (4 * sizeof (UV));
1298 1261408         blow &= botmask;
1299 1261408 100       if (ahigh && bhigh) {
1300           NOOP;
1301           /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1302           which is overflow. Drop to NVs below. */
1303 1261232 100       } else if (!ahigh && !bhigh) {
1304           /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1305           so the unsigned multiply cannot overflow. */
1306 1241012         const UV product = alow * blow;
1307 1241012 100       if (auvok == buvok) {
1308           /* -ve * -ve or +ve * +ve gives a +ve result. */
1309 1219228         SP--;
1310 1219228 50       SETu( product );
1311 1219228         RETURN;
1312 21784 50       } else if (product <= (UV)IV_MIN) {
1313           /* 2s complement assumption that (UV)-IV_MIN is correct. */
1314           /* -ve result, which could overflow an IV */
1315 21784         SP--;
1316 21784 50       SETi( -(IV)product );
1317 21784         RETURN;
1318           } /* else drop to NVs below. */
1319           } else {
1320           /* One operand is large, 1 small */
1321           UV product_middle;
1322 20220 100       if (bhigh) {
1323           /* swap the operands */
1324           ahigh = bhigh;
1325           bhigh = blow; /* bhigh now the temp var for the swap */
1326           blow = alow;
1327           alow = bhigh;
1328           }
1329           /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1330           multiplies can't overflow. shift can, add can, -ve can. */
1331 20220         product_middle = ahigh * blow;
1332 20220 100       if (!(product_middle & topmask)) {
1333           /* OK, (ahigh * blow) won't lose bits when we shift it. */
1334           UV product_low;
1335 20206         product_middle <<= (4 * sizeof (UV));
1336 20206         product_low = alow * blow;
1337            
1338           /* as for pp_add, UV + something mustn't get smaller.
1339           IIRC ANSI mandates this wrapping *behaviour* for
1340           unsigned whatever the actual representation*/
1341 20206         product_low += product_middle;
1342 20206 50       if (product_low >= product_middle) {
1343           /* didn't overflow */
1344 20206 100       if (auvok == buvok) {
1345           /* -ve * -ve or +ve * +ve gives a +ve result. */
1346 20148         SP--;
1347 20148 50       SETu( product_low );
1348 20148         RETURN;
1349 58 50       } else if (product_low <= (UV)IV_MIN) {
1350           /* 2s complement assumption again */
1351           /* -ve result, which could overflow an IV */
1352 58         SP--;
1353 58 50       SETi( -(IV)product_low );
1354 58         RETURN;
1355           } /* else drop to NVs below. */
1356           }
1357           } /* product_middle too large */
1358           } /* ahigh && bhigh */
1359           } /* SvIOK(svl) */
1360           } /* SvIOK(svr) */
1361           #endif
1362           {
1363 215192 100       NV right = SvNV_nomg(svr);
1364 215192 100       NV left = SvNV_nomg(svl);
1365 215192         (void)POPs;
1366 215192 100       SETn( left * right );
1367 856829         RETURN;
1368           }
1369           }
1370            
1371 1799332         PP(pp_divide)
1372           {
1373 1799332 100       dVAR; dSP; dATARGET; SV *svl, *svr;
1374 1799332 100       tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
    100        
1375 1794858         svr = TOPs;
1376 1794858         svl = TOPm1s;
1377           /* Only try to do UV divide first
1378           if ((SLOPPYDIVIDE is true) or
1379           (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1380           to preserve))
1381           The assumption is that it is better to use floating point divide
1382           whenever possible, only doing integer divide first if we can't be sure.
1383           If NV_PRESERVES_UV is true then we know at compile time that no UV
1384           can be too large to preserve, so don't need to compile the code to
1385           test the size of UVs. */
1386            
1387           #ifdef SLOPPYDIVIDE
1388           # define PERL_TRY_UV_DIVIDE
1389           /* ensure that 20./5. == 4. */
1390           #else
1391           # ifdef PERL_PRESERVE_IVUV
1392           # ifndef NV_PRESERVES_UV
1393           # define PERL_TRY_UV_DIVIDE
1394           # endif
1395           # endif
1396           #endif
1397            
1398           #ifdef PERL_TRY_UV_DIVIDE
1399 1794858 100       if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
    100        
    50        
    100        
    100        
    100        
    50        
    100        
1400 1775548         bool left_non_neg = SvUOK(svl);
1401 1775548         bool right_non_neg = SvUOK(svr);
1402           UV left;
1403           UV right;
1404            
1405 1775548 100       if (right_non_neg) {
1406 120         right = SvUVX(svr);
1407           }
1408           else {
1409 1775428         const IV biv = SvIVX(svr);
1410 1775428 100       if (biv >= 0) {
1411 1775306         right = biv;
1412           right_non_neg = TRUE; /* effectively it's a UV now */
1413           }
1414           else {
1415 122         right = -biv;
1416           }
1417           }
1418           /* historically undef()/0 gives a "Use of uninitialized value"
1419           warning before dieing, hence this test goes here.
1420           If it were immediately before the second SvIV_please, then
1421           DIE() would be invoked before left was even inspected, so
1422           no inspection would give no warning. */
1423 1775548 100       if (right == 0)
1424 16         DIE(aTHX_ "Illegal division by zero");
1425            
1426 1775532 100       if (left_non_neg) {
1427 12         left = SvUVX(svl);
1428           }
1429           else {
1430 1775520         const IV aiv = SvIVX(svl);
1431 1775520 100       if (aiv >= 0) {
1432 1774094         left = aiv;
1433           left_non_neg = TRUE; /* effectively it's a UV now */
1434           }
1435           else {
1436 1426         left = -aiv;
1437           }
1438           }
1439            
1440 2663298 100       if (left >= right
1441           #ifdef SLOPPYDIVIDE
1442           /* For sloppy divide we always attempt integer division. */
1443           #else
1444           /* Otherwise we only attempt it if either or both operands
1445           would not be preserved by an NV. If both fit in NVs
1446           we fall through to the NV divide code below. However,
1447           as left >= right to ensure integer result here, we know that
1448           we can skip the test on the right operand - right big
1449           enough not to be preserved can't get here unless left is
1450           also too big. */
1451            
1452 1775532         && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1453           #endif
1454           ) {
1455           /* Integer division can't overflow, but it can be imprecise. */
1456 44         const UV result = left / right;
1457 44 100       if (result * right == left) {
1458 38         SP--; /* result is valid */
1459 38 100       if (left_non_neg == right_non_neg) {
1460           /* signs identical, result is positive. */
1461 34 50       SETu( result );
1462 34         RETURN;
1463           }
1464           /* 2s complement assumption */
1465 4 50       if (result <= (UV)IV_MIN)
1466 4 50       SETi( -(IV)result );
1467           else {
1468           /* It's exact but too negative for IV. */
1469 0 0       SETn( -(NV)result );
1470           }
1471 4         RETURN;
1472           } /* tried integer divide but it was not an integer result */
1473           } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1474           } /* one operand wasn't SvIOK */
1475           #endif /* PERL_TRY_UV_DIVIDE */
1476           {
1477 1794804 100       NV right = SvNV_nomg(svr);
1478 1794804 100       NV left = SvNV_nomg(svl);
1479           (void)POPs;(void)POPs;
1480           #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1481           if (! Perl_isnan(right) && right == 0.0)
1482           #else
1483 1794804 100       if (right == 0.0)
1484           #endif
1485 4         DIE(aTHX_ "Illegal division by zero");
1486 1794800 100       PUSHn( left / right );
1487 1797043         RETURN;
1488           }
1489           }
1490            
1491 1114354         PP(pp_modulo)
1492           {
1493 1114354 100       dVAR; dSP; dATARGET;
1494 1114354 100       tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
    100        
1495           {
1496           UV left = 0;
1497           UV right = 0;
1498           bool left_neg = FALSE;
1499           bool right_neg = FALSE;
1500           bool use_double = FALSE;
1501           bool dright_valid = FALSE;
1502           NV dright = 0.0;
1503           NV dleft = 0.0;
1504 1112764         SV * const svr = TOPs;
1505 1112764         SV * const svl = TOPm1s;
1506 1112764 100       if (SvIV_please_nomg(svr)) {
    100        
    50        
    100        
1507 1112752         right_neg = !SvUOK(svr);
1508 1112752 100       if (!right_neg) {
1509 2         right = SvUVX(svr);
1510           } else {
1511 1112750         const IV biv = SvIVX(svr);
1512 1112750 100       if (biv >= 0) {
1513 1112740         right = biv;
1514           right_neg = FALSE; /* effectively it's a UV now */
1515           } else {
1516 10         right = -biv;
1517           }
1518           }
1519           }
1520           else {
1521 12 100       dright = SvNV_nomg(svr);
1522 12         right_neg = dright < 0;
1523 12 100       if (right_neg)
1524 4         dright = -dright;
1525 12 100       if (dright < UV_MAX_P1) {
1526 4         right = U_V(dright);
1527           dright_valid = TRUE; /* In case we need to use double below. */
1528           } else {
1529           use_double = TRUE;
1530           }
1531           }
1532            
1533           /* At this point use_double is only true if right is out of range for
1534           a UV. In range NV has been rounded down to nearest UV and
1535           use_double false. */
1536 1112764 100       if (!use_double && SvIV_please_nomg(svl)) {
    100        
    100        
    50        
    50        
    100        
1537 1112752         left_neg = !SvUOK(svl);
1538 1112752 100       if (!left_neg) {
1539 8         left = SvUVX(svl);
1540           } else {
1541 1112744         const IV aiv = SvIVX(svl);
1542 1112744 100       if (aiv >= 0) {
1543 1112720         left = aiv;
1544           left_neg = FALSE; /* effectively it's a UV now */
1545           } else {
1546 24         left = -aiv;
1547           }
1548           }
1549           }
1550           else {
1551 12 100       dleft = SvNV_nomg(svl);
1552 12         left_neg = dleft < 0;
1553 12 100       if (left_neg)
1554 4         dleft = -dleft;
1555            
1556           /* This should be exactly the 5.6 behaviour - if left and right are
1557           both in range for UV then use U_V() rather than floor. */
1558 12 100       if (!use_double) {
1559 4 50       if (dleft < UV_MAX_P1) {
1560           /* right was in range, so is dleft, so use UVs not double.
1561           */
1562 4         left = U_V(dleft);
1563           }
1564           /* left is out of range for UV, right was in range, so promote
1565           right (back) to double. */
1566           else {
1567           /* The +0.5 is used in 5.6 even though it is not strictly
1568           consistent with the implicit +0 floor in the U_V()
1569           inside the #if 1. */
1570 0         dleft = Perl_floor(dleft + 0.5);
1571           use_double = TRUE;
1572 0 0       if (dright_valid)
1573 0         dright = Perl_floor(dright + 0.5);
1574           else
1575 0         dright = right;
1576           }
1577           }
1578           }
1579           sp -= 2;
1580 1112764 100       if (use_double) {
1581           NV dans;
1582            
1583 8 50       if (!dright)
1584 0         DIE(aTHX_ "Illegal modulus zero");
1585            
1586 8         dans = Perl_fmod(dleft, dright);
1587 8 100       if ((left_neg != right_neg) && dans)
    50        
1588 4         dans = dright - dans;
1589 8 100       if (right_neg)
1590 4         dans = -dans;
1591 8         sv_setnv(TARG, dans);
1592           }
1593           else {
1594           UV ans;
1595            
1596 1112756 100       if (!right)
1597 4         DIE(aTHX_ "Illegal modulus zero");
1598            
1599 1112752         ans = left % right;
1600 1112752 100       if ((left_neg != right_neg) && ans)
1601 20         ans = right - ans;
1602 1112752 100       if (right_neg) {
1603           /* XXX may warn: unary minus operator applied to unsigned type */
1604           /* could change -foo to be (~foo)+1 instead */
1605 10 50       if (ans <= ~((UV)IV_MAX)+1)
1606 10         sv_setiv(TARG, ~ans+1);
1607           else
1608 0         sv_setnv(TARG, -(NV)ans);
1609           }
1610           else
1611 1112742         sv_setuv(TARG, ans);
1612           }
1613 1112760 50       PUSHTARG;
1614 1113555         RETURN;
1615           }
1616           }
1617            
1618 640621         PP(pp_repeat)
1619           {
1620 640621 100       dVAR; dSP; dATARGET;
1621           IV count;
1622           SV *sv;
1623            
1624 682435 100       if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
    100        
    100        
    50        
    50        
1625           /* TODO: think of some way of doing list-repeat overloading ??? */
1626 83987         sv = POPs;
1627 41814         SvGETMAGIC(sv);
1628           }
1629           else {
1630 556634 100       tryAMAGICbin_MG(repeat_amg, AMGf_assign);
    50        
1631 556634         sv = POPs;
1632           }
1633            
1634 640621 100       if (SvIOKp(sv)) {
1635 601409 50       if (SvUOK(sv)) {
1636 0 0       const UV uv = SvUV_nomg(sv);
1637 0 0       if (uv > IV_MAX)
1638           count = IV_MAX; /* The best we can do? */
1639           else
1640 0         count = uv;
1641           } else {
1642 601409 100       const IV iv = SvIV_nomg(sv);
1643 601409 100       if (iv < 0)
1644           count = 0;
1645           else
1646           count = iv;
1647           }
1648           }
1649 39212 100       else if (SvNOKp(sv)) {
1650 37856 50       const NV nv = SvNV_nomg(sv);
1651 37856 100       if (nv < 0.0)
1652           count = 0;
1653           else
1654 37832         count = (IV)nv;
1655           }
1656           else
1657 1356 50       count = SvIV_nomg(sv);
1658            
1659 682435 100       if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
    100        
    100        
    50        
    50        
1660 83987         dMARK;
1661           static const char* const oom_list_extend = "Out of memory during list extend";
1662 83987         const I32 items = SP - MARK;
1663 83987         const I32 max = items * count;
1664 83987         const U8 mod = PL_op->op_flags & OPf_MOD;
1665            
1666 41814         MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1667           /* Did the max computation overflow? */
1668 83987 100       if (items > 0 && max > 0 && (max < items || max < count))
    50        
    50        
1669 0         Perl_croak(aTHX_ "%s", oom_list_extend);
1670 83987 100       MEXTEND(MARK, max);
1671 83987 100       if (count > 1) {
1672 106082 100       while (SP > MARK) {
1673           #if 0
1674           /* This code was intended to fix 20010809.028:
1675            
1676           $x = 'abcd';
1677           for (($x =~ /./g) x 2) {
1678           print chop; # "abcdabcd" expected as output.
1679           }
1680            
1681           * but that change (#11635) broke this code:
1682            
1683           $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1684            
1685           * I can't think of a better fix that doesn't introduce
1686           * an efficiency hit by copying the SVs. The stack isn't
1687           * refcounted, and mortalisation obviously doesn't
1688           * Do The Right Thing when the stack has more than
1689           * one pointer to the same mortal value.
1690           * .robin.
1691           */
1692           if (*SP) {
1693           *SP = sv_2mortal(newSVsv(*SP));
1694           SvREADONLY_on(*SP);
1695           }
1696           #else
1697 54769 50       if (*SP)
1698           {
1699 54769 100       if (mod && SvPADTMP(*SP) && !IS_PADGV(*SP))
    100        
1700 2         *SP = sv_mortalcopy(*SP);
1701 54769         SvTEMP_off((*SP));
1702           }
1703           #endif
1704 54769         SP--;
1705           }
1706 51313         MARK++;
1707 51313         repeatcpy((char*)(MARK + items), (char*)MARK,
1708           items * sizeof(const SV *), count - 1);
1709 51313         SP += max;
1710           }
1711 32674 100       else if (count <= 0)
1712 16328         SP -= items;
1713           }
1714           else { /* Note: mark already snarfed by pp_list */
1715 556634         SV * const tmpstr = POPs;
1716           STRLEN len;
1717           bool isutf;
1718           static const char* const oom_string_extend =
1719           "Out of memory during string extend";
1720            
1721 556634 100       if (TARG != tmpstr)
1722 556618         sv_setsv_nomg(TARG, tmpstr);
1723 556634 100       SvPV_force_nomg(TARG, len);
1724 556634 100       isutf = DO_UTF8(TARG);
    50        
1725 556634 100       if (count != 1) {
1726 506516 100       if (count < 1)
1727 34570         SvCUR_set(TARG, 0);
1728           else {
1729 471946         const STRLEN max = (UV)count * len;
1730 471946 50       if (len > MEM_SIZE_MAX / count)
1731 0         Perl_croak(aTHX_ "%s", oom_string_extend);
1732           MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1733 471946 50       SvGROW(TARG, max + 1);
    100        
1734 471946         repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1735 471946         SvCUR_set(TARG, SvCUR(TARG) * count);
1736           }
1737 506516         *SvEND(TARG) = '\0';
1738           }
1739 556634 100       if (isutf)
1740 564         (void)SvPOK_only_UTF8(TARG);
1741           else
1742 556070         (void)SvPOK_only(TARG);
1743            
1744 556634 100       if (PL_op->op_private & OPpREPEAT_DOLIST) {
1745           /* The parser saw this as a list repeat, and there
1746           are probably several items on the stack. But we're
1747           in scalar context, and there's no pp_list to save us
1748           now. So drop the rest of the items -- robin@kitsite.com
1749           */
1750 16         dMARK;
1751           SP = MARK;
1752           }
1753 556634 100       PUSHTARG;
1754           }
1755 640621         RETURN;
1756           }
1757            
1758 43791878         PP(pp_subtract)
1759           {
1760 43791878 100       dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1761 43791878 100       tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
    100        
1762 43787022         svr = TOPs;
1763 43787022         svl = TOPm1s;
1764 43787022 100       useleft = USE_LEFT(svl);
    50        
    50        
    100        
1765           #ifdef PERL_PRESERVE_IVUV
1766           /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1767           "bad things" happen if you rely on signed integers wrapping. */
1768 43787022 100       if (SvIV_please_nomg(svr)) {
    100        
    50        
    100        
1769           /* Unless the left argument is integer in range we are going to have to
1770           use NV maths. Hence only attempt to coerce the right argument if
1771           we know the left is integer. */
1772           UV auv = 0;
1773           bool auvok = FALSE;
1774           bool a_valid = 0;
1775            
1776 37137222 100       if (!useleft) {
1777           auv = 0;
1778           a_valid = auvok = 1;
1779           /* left operand is undef, treat as zero. */
1780           } else {
1781           /* Left operand is defined, so is it IV? */
1782 37137206 100       if (SvIV_please_nomg(svl)) {
    100        
    50        
    100        
1783 37134208 100       if ((auvok = SvUOK(svl)))
1784 338         auv = SvUVX(svl);
1785           else {
1786 37133870         const IV aiv = SvIVX(svl);
1787 37133870 100       if (aiv >= 0) {
1788 37081716         auv = aiv;
1789           auvok = 1; /* Now acting as a sign flag. */
1790           } else { /* 2s complement assumption for IV_MIN */
1791 52154         auv = (UV)-aiv;
1792           }
1793           }
1794           a_valid = 1;
1795           }
1796           }
1797 37137222 100       if (a_valid) {
1798           bool result_good = 0;
1799           UV result;
1800           UV buv;
1801 37134224         bool buvok = SvUOK(svr);
1802          
1803 37134224 50       if (buvok)
1804 0         buv = SvUVX(svr);
1805           else {
1806 37134224         const IV biv = SvIVX(svr);
1807 37134224 100       if (biv >= 0) {
1808 37123980         buv = biv;
1809           buvok = 1;
1810           } else
1811 10244         buv = (UV)-biv;
1812           }
1813           /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1814           else "IV" now, independent of how it came in.
1815           if a, b represents positive, A, B negative, a maps to -A etc
1816           a - b => (a - b)
1817           A - b => -(a + b)
1818           a - B => (a + b)
1819           A - B => -(a - b)
1820           all UV maths. negate result if A negative.
1821           subtract if signs same, add if signs differ. */
1822            
1823 37134224 100       if (auvok ^ buvok) {
1824           /* Signs differ. */
1825 46506         result = auv + buv;
1826 46506 50       if (result >= auv)
1827           result_good = 1;
1828           } else {
1829           /* Signs same */
1830 37087718 100       if (auv >= buv) {
1831 36997092         result = auv - buv;
1832           /* Must get smaller */
1833 36997092 50       if (result <= auv)
1834           result_good = 1;
1835           } else {
1836 90626         result = buv - auv;
1837 90626 50       if (result <= buv) {
1838           /* result really should be -(auv-buv). as its negation
1839           of true value, need to swap our result flag */
1840 90626         auvok = !auvok;
1841           result_good = 1;
1842           }
1843           }
1844           }
1845 37134224 50       if (result_good) {
1846 37134224         SP--;
1847 37134224 100       if (auvok)
1848 37006076 100       SETu( result );
1849           else {
1850           /* Negate result */
1851 128148 100       if (result <= (UV)IV_MIN)
1852 128136 100       SETi( -(IV)result );
1853           else {
1854           /* result valid, but out of range for IV. */
1855 12 50       SETn( -(NV)result );
1856           }
1857           }
1858 37134224         RETURN;
1859           } /* Overflow, drop through to NVs. */
1860           }
1861           }
1862           #endif
1863           {
1864 6652798 100       NV value = SvNV_nomg(svr);
1865 6652798         (void)POPs;
1866            
1867 6652798 50       if (!useleft) {
1868           /* left operand is undef, treat as zero - value */
1869 0 0       SETn(-value);
1870 0         RETURN;
1871           }
1872 6652798 100       SETn( SvNV_nomg(svl) - value );
    50        
1873 25222516         RETURN;
1874           }
1875           }
1876            
1877 114201         PP(pp_left_shift)
1878           {
1879 114201 100       dVAR; dSP; dATARGET; SV *svl, *svr;
1880 114201 100       tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
    100        
1881 114087         svr = POPs;
1882 114087         svl = TOPs;
1883           {
1884 114087 100       const IV shift = SvIV_nomg(svr);
1885 114087 100       if (PL_op->op_private & HINT_INTEGER) {
1886 782 50       const IV i = SvIV_nomg(svl);
1887 782 50       SETi(i << shift);
1888           }
1889           else {
1890 113305 100       const UV u = SvUV_nomg(svl);
1891 113305 100       SETu(u << shift);
1892           }
1893 114142         RETURN;
1894           }
1895           }
1896            
1897 487410         PP(pp_right_shift)
1898           {
1899 487410 100       dVAR; dSP; dATARGET; SV *svl, *svr;
1900 487410 100       tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
    100        
1901 487288         svr = POPs;
1902 487288         svl = TOPs;
1903           {
1904 487288 50       const IV shift = SvIV_nomg(svr);
1905 487288 100       if (PL_op->op_private & HINT_INTEGER) {
1906 6 50       const IV i = SvIV_nomg(svl);
1907 6 50       SETi(i >> shift);
1908           }
1909           else {
1910 487282 100       const UV u = SvUV_nomg(svl);
1911 487282 100       SETu(u >> shift);
1912           }
1913 487345         RETURN;
1914           }
1915           }
1916            
1917 59516739         PP(pp_lt)
1918           {
1919 59516739         dVAR; dSP;
1920           SV *left, *right;
1921            
1922 59516739 100       tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
    100        
1923 59516067         right = POPs;
1924 59516067         left = TOPs;
1925 59516067 100       SETs(boolSV(
    100        
    100        
1926           (SvIOK_notUV(left) && SvIOK_notUV(right))
1927           ? (SvIVX(left) < SvIVX(right))
1928           : (do_ncmp(left, right) == -1)
1929           ));
1930 59516393         RETURN;
1931           }
1932            
1933 41955958         PP(pp_gt)
1934           {
1935 41955958         dVAR; dSP;
1936           SV *left, *right;
1937            
1938 41955958 100       tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
    100        
1939 41952766         right = POPs;
1940 41952766         left = TOPs;
1941 41952766 100       SETs(boolSV(
    100        
    100        
1942           (SvIOK_notUV(left) && SvIOK_notUV(right))
1943           ? (SvIVX(left) > SvIVX(right))
1944           : (do_ncmp(left, right) == 1)
1945           ));
1946 41954361         RETURN;
1947           }
1948            
1949 12836538         PP(pp_le)
1950           {
1951 12836538         dVAR; dSP;
1952           SV *left, *right;
1953            
1954 12836538 100       tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
    100        
1955 12836378         right = POPs;
1956 12836378         left = TOPs;
1957 12836378 100       SETs(boolSV(
    100        
    100        
1958           (SvIOK_notUV(left) && SvIOK_notUV(right))
1959           ? (SvIVX(left) <= SvIVX(right))
1960           : (do_ncmp(left, right) <= 0)
1961           ));
1962 12836456         RETURN;
1963           }
1964            
1965 15640982         PP(pp_ge)
1966           {
1967 15640982         dVAR; dSP;
1968           SV *left, *right;
1969            
1970 15640982 100       tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
    100        
1971 15640110         right = POPs;
1972 15640110         left = TOPs;
1973 15640110 100       SETs(boolSV(
    100        
    100        
1974           (SvIOK_notUV(left) && SvIOK_notUV(right))
1975           ? (SvIVX(left) >= SvIVX(right))
1976           : ( (do_ncmp(left, right) & 2) == 0)
1977           ));
1978 15640546         RETURN;
1979           }
1980            
1981 11032968         PP(pp_ne)
1982           {
1983 11032968         dVAR; dSP;
1984           SV *left, *right;
1985            
1986 11032968 100       tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
    100        
1987 10974036         right = POPs;
1988 10974036         left = TOPs;
1989 10974036 100       SETs(boolSV(
    100        
    100        
1990           (SvIOK_notUV(left) && SvIOK_notUV(right))
1991           ? (SvIVX(left) != SvIVX(right))
1992           : (do_ncmp(left, right) != 0)
1993           ));
1994 11003502         RETURN;
1995           }
1996            
1997           /* compare left and right SVs. Returns:
1998           * -1: <
1999           * 0: ==
2000           * 1: >
2001           * 2: left or right was a NaN
2002           */
2003           I32
2004 26778684         Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2005           {
2006           dVAR;
2007            
2008           PERL_ARGS_ASSERT_DO_NCMP;
2009           #ifdef PERL_PRESERVE_IVUV
2010           /* Fortunately it seems NaN isn't IOK */
2011 26778684 100       if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
    100        
    50        
    100        
    100        
    100        
    50        
    100        
2012 9313418 100       if (!SvUOK(left)) {
2013 9312134         const IV leftiv = SvIVX(left);
2014 9312134 100       if (!SvUOK(right)) {
2015           /* ## IV <=> IV ## */
2016 9307392         const IV rightiv = SvIVX(right);
2017 9307392         return (leftiv > rightiv) - (leftiv < rightiv);
2018           }
2019           /* ## IV <=> UV ## */
2020 4742 100       if (leftiv < 0)
2021           /* As (b) is a UV, it's >=0, so it must be < */
2022           return -1;
2023           {
2024 4680         const UV rightuv = SvUVX(right);
2025 4680         return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2026           }
2027           }
2028            
2029 1284 100       if (SvUOK(right)) {
2030           /* ## UV <=> UV ## */
2031 500         const UV leftuv = SvUVX(left);
2032 500         const UV rightuv = SvUVX(right);
2033 500         return (leftuv > rightuv) - (leftuv < rightuv);
2034           }
2035           /* ## UV <=> IV ## */
2036           {
2037 784         const IV rightiv = SvIVX(right);
2038 784 100       if (rightiv < 0)
2039           /* As (a) is a UV, it's >=0, so it cannot be < */
2040           return 1;
2041           {
2042 652         const UV leftuv = SvUVX(left);
2043 652         return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2044           }
2045           }
2046           assert(0); /* NOTREACHED */
2047           }
2048           #endif
2049           {
2050 17465266 100       NV const rnv = SvNV_nomg(right);
2051 17465266 100       NV const lnv = SvNV_nomg(left);
2052            
2053           #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2054           if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2055           return 2;
2056           }
2057           return (lnv > rnv) - (lnv < rnv);
2058           #else
2059 17465264 100       if (lnv < rnv)
2060           return -1;
2061 10205180 100       if (lnv > rnv)
2062           return 1;
2063 485174 100       if (lnv == rnv)
2064           return 0;
2065 13440256         return 2;
2066           #endif
2067           }
2068           }
2069            
2070            
2071 6906586         PP(pp_ncmp)
2072           {
2073 6906586         dVAR; dSP;
2074           SV *left, *right;
2075           I32 value;
2076 6906586 100       tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
    100        
2077 6906564         right = POPs;
2078 6906564         left = TOPs;
2079 6906564         value = do_ncmp(left, right);
2080 6906564 100       if (value == 2) {
2081 168         SETs(&PL_sv_undef);
2082           }
2083           else {
2084 6906396         dTARGET;
2085 6906396 50       SETi(value);
2086           }
2087 6906575         RETURN;
2088           }
2089            
2090 976502         PP(pp_sle)
2091           {
2092 976502         dVAR; dSP;
2093            
2094           int amg_type = sle_amg;
2095           int multiplier = 1;
2096           int rhs = 1;
2097            
2098 976502 50       switch (PL_op->op_type) {
2099           case OP_SLT:
2100           amg_type = slt_amg;
2101           /* cmp < 0 */
2102           rhs = 0;
2103           break;
2104           case OP_SGT:
2105           amg_type = sgt_amg;
2106           /* cmp > 0 */
2107           multiplier = -1;
2108           rhs = 0;
2109           break;
2110           case OP_SGE:
2111           amg_type = sge_amg;
2112           /* cmp >= 0 */
2113           multiplier = -1;
2114           break;
2115           }
2116            
2117 976502 100       tryAMAGICbin_MG(amg_type, AMGf_set);
    100        
2118           {
2119 900422         dPOPTOPssrl;
2120 900422         const int cmp = (IN_LOCALE_RUNTIME
2121           ? sv_cmp_locale_flags(left, right, 0)
2122 900422 50       : sv_cmp_flags(left, right, 0));
2123 900422 100       SETs(boolSV(cmp * multiplier < rhs));
2124 938462         RETURN;
2125           }
2126           }
2127            
2128 397053330         PP(pp_seq)
2129           {
2130 397053330         dVAR; dSP;
2131 397053330 100       tryAMAGICbin_MG(seq_amg, AMGf_set);
    100        
2132           {
2133 397015756         dPOPTOPssrl;
2134 397015756 100       SETs(boolSV(sv_eq_flags(left, right, 0)));
2135 397034721         RETURN;
2136           }
2137           }
2138            
2139 11417492         PP(pp_sne)
2140           {
2141 11417492         dVAR; dSP;
2142 11417492 100       tryAMAGICbin_MG(sne_amg, AMGf_set);
    100        
2143           {
2144 11417468         dPOPTOPssrl;
2145 11417468 100       SETs(boolSV(!sv_eq_flags(left, right, 0)));
2146 11417480         RETURN;
2147           }
2148           }
2149            
2150 5293562         PP(pp_scmp)
2151           {
2152 5293562         dVAR; dSP; dTARGET;
2153 5293562 100       tryAMAGICbin_MG(scmp_amg, 0);
    100        
2154           {
2155 5293366         dPOPTOPssrl;
2156 5293366         const int cmp = (IN_LOCALE_RUNTIME
2157           ? sv_cmp_locale_flags(left, right, 0)
2158 5293366 50       : sv_cmp_flags(left, right, 0));
2159 5293366 50       SETi( cmp );
2160 5293464         RETURN;
2161           }
2162           }
2163            
2164 51114500         PP(pp_bit_and)
2165           {
2166 51114500 100       dVAR; dSP; dATARGET;
2167 51114500 100       tryAMAGICbin_MG(band_amg, AMGf_assign);
    100        
2168           {
2169 51114138         dPOPTOPssrl;
2170 51114138 100       if (SvNIOKp(left) || SvNIOKp(right)) {
    100        
2171 50782202         const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2172 50782202         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2173 50782202 100       if (PL_op->op_private & HINT_INTEGER) {
2174 3544 100       const IV i = SvIV_nomg(left) & SvIV_nomg(right);
    100        
2175 3544 100       SETi(i);
2176           }
2177           else {
2178 50778658 100       const UV u = SvUV_nomg(left) & SvUV_nomg(right);
    100        
2179 50778656 100       SETu(u);
2180           }
2181 50782200 50       if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
    0        
2182 50782200 100       if (right_ro_nonnum) SvNIOK_off(right);
2183           }
2184           else {
2185 331936         do_vop(PL_op->op_type, TARG, left, right);
2186 331936 100       SETTARG;
2187           }
2188 51114315         RETURN;
2189           }
2190           }
2191            
2192 5467640         PP(pp_bit_or)
2193           {
2194 5467640 100       dVAR; dSP; dATARGET;
2195 5467640         const int op_type = PL_op->op_type;
2196            
2197 5467640 100       tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
    100        
    100        
2198           {
2199 5466814         dPOPTOPssrl;
2200 5466814 100       if (SvNIOKp(left) || SvNIOKp(right)) {
    100        
2201 4787666         const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2202 4787666         const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2203 4787666 100       if (PL_op->op_private & HINT_INTEGER) {
2204 5638 100       const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
    50        
    50        
    50        
    100        
2205 5638 100       const IV r = SvIV_nomg(right);
2206 5638 100       const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2207 5638 100       SETi(result);
2208           }
2209           else {
2210 4782028 100       const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
    50        
    50        
    100        
    100        
2211 4782028 100       const UV r = SvUV_nomg(right);
2212 4782028 100       const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2213 4782028 100       SETu(result);
2214           }
2215 4787664 50       if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
    0        
2216 4787664 100       if (right_ro_nonnum) SvNIOK_off(right);
2217           }
2218           else {
2219 679148         do_vop(op_type, TARG, left, right);
2220 679148 100       SETTARG;
2221           }
2222 5467219         RETURN;
2223           }
2224           }
2225            
2226           PERL_STATIC_INLINE bool
2227 4474648         S_negate_string(pTHX)
2228           {
2229 4474648         dTARGET; dSP;
2230           STRLEN len;
2231           const char *s;
2232 4474648         SV * const sv = TOPs;
2233 4474648 100       if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
    50        
    0        
2234           return FALSE;
2235 73970 100       s = SvPV_nomg_const(sv, len);
2236 73970 100       if (isIDFIRST(*s)) {
2237 73888         sv_setpvs(TARG, "-");
2238 73888         sv_catsv(TARG, sv);
2239           }
2240 82 100       else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
    100        
    100        
2241 16         sv_setsv_nomg(TARG, sv);
2242 16 50       *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
    100        
2243           }
2244           else return FALSE;
2245 73904 50       SETTARG; PUTBACK;
2246 2296415         return TRUE;
2247           }
2248            
2249 4407378         PP(pp_negate)
2250           {
2251 4407378         dVAR; dSP; dTARGET;
2252 4407378 100       tryAMAGICun_MG(neg_amg, AMGf_numeric);
    100        
2253 4406986 100       if (S_negate_string(aTHX)) return NORMAL;
2254           {
2255 4333098         SV * const sv = TOPs;
2256            
2257 4333098 100       if (SvIOK(sv)) {
2258           /* It's publicly an integer */
2259           oops_its_an_int:
2260 4326244 100       if (SvIsUV(sv)) {
2261 84 100       if (SvIVX(sv) == IV_MIN) {
2262           /* 2s complement assumption. */
2263 62 50       SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2264           IV_MIN */
2265 62         RETURN;
2266           }
2267 22 50       else if (SvUVX(sv) <= IV_MAX) {
2268 0 0       SETi(-SvIVX(sv));
2269 0         RETURN;
2270           }
2271           }
2272 4326160 50       else if (SvIVX(sv) != IV_MIN) {
2273 4326160 50       SETi(-SvIVX(sv));
2274 4326160         RETURN;
2275           }
2276           #ifdef PERL_PRESERVE_IVUV
2277           else {
2278 0 0       SETu((UV)IV_MIN);
2279 0         RETURN;
2280           }
2281           #endif
2282           }
2283 6894 100       if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
    50        
2284 6824 100       SETn(-SvNV_nomg(sv));
    50        
2285 70 100       else if (SvPOKp(sv) && SvIV_please_nomg(sv))
    50        
    50        
    50        
    100        
    0        
2286           goto oops_its_an_int;
2287           else
2288 52 100       SETn(-SvNV_nomg(sv));
    50        
2289           }
2290 2212706         RETURN;
2291           }
2292            
2293 70470816         PP(pp_not)
2294           {
2295 70470816         dVAR; dSP;
2296 70470816 100       tryAMAGICun_MG(not_amg, AMGf_set);
    100        
2297 70470774 50       *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
    100        
    100        
    50        
    100        
    50        
    100        
    100        
    100        
    100        
    100        
    100        
    100        
    100        
    100        
    100        
    50        
2298 70470795         return NORMAL;
2299           }
2300            
2301 1194166         PP(pp_complement)
2302           {
2303 1194166         dVAR; dSP; dTARGET;
2304 1194166 100       tryAMAGICun_MG(compl_amg, AMGf_numeric);
    100        
2305           {
2306 1189610         dTOPss;
2307 1189610 100       if (SvNIOKp(sv)) {
2308 973740 100       if (PL_op->op_private & HINT_INTEGER) {
2309 14 50       const IV i = ~SvIV_nomg(sv);
2310 14 50       SETi(i);
2311           }
2312           else {
2313 973726 100       const UV u = ~SvUV_nomg(sv);
2314 973726 50       SETu(u);
2315           }
2316           }
2317           else {
2318           U8 *tmps;
2319           I32 anum;
2320           STRLEN len;
2321            
2322 215870         sv_copypv_nomg(TARG, sv);
2323 215870 50       tmps = (U8*)SvPV_nomg(TARG, len);
2324 215870         anum = len;
2325 215870 100       if (SvUTF8(TARG)) {
2326           /* Calculate exact length, let's not estimate. */
2327           STRLEN targlen = 0;
2328           STRLEN l;
2329           UV nchar = 0;
2330           UV nwide = 0;
2331 50408         U8 * const send = tmps + len;
2332           U8 * const origtmps = tmps;
2333           const UV utf8flags = UTF8_ALLOW_ANYUV;
2334            
2335 148008 100       while (tmps < send) {
2336 72396         const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2337 72396         tmps += l;
2338 72396 100       targlen += UNISKIP(~c);
    100        
    100        
    100        
    50        
    50        
    50        
2339 72396         nchar++;
2340 72396 100       if (c > 0xff)
2341 67522         nwide++;
2342           }
2343            
2344           /* Now rewind strings and write them. */
2345           tmps = origtmps;
2346            
2347 50408 100       if (nwide) {
2348           U8 *result;
2349           U8 *p;
2350            
2351 50402         Newx(result, targlen + 1, U8);
2352           p = result;
2353 147989 100       while (tmps < send) {
2354 72386         const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2355 72386         tmps += l;
2356 72386         p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2357           }
2358 50402         *p = '\0';
2359 50402         sv_usepvn_flags(TARG, (char*)result, targlen,
2360           SV_HAS_TRAILING_NUL);
2361 50402         SvUTF8_on(TARG);
2362           }
2363           else {
2364           U8 *result;
2365           U8 *p;
2366            
2367 6         Newx(result, nchar + 1, U8);
2368           p = result;
2369 19 100       while (tmps < send) {
2370 10         const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2371 10         tmps += l;
2372 10         *p++ = ~c;
2373           }
2374 6         *p = '\0';
2375 6         sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2376 6         SvUTF8_off(TARG);
2377           }
2378 50408 50       SETTARG;
2379 50408         RETURN;
2380           }
2381           #ifdef LIBERAL
2382           {
2383           long *tmpl;
2384 84711 100       for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
    50        
2385 0         *tmps = ~*tmps;
2386           tmpl = (long*)tmps;
2387 261919 100       for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2388 177208         *tmpl = ~*tmpl;
2389           tmps = (U8*)tmpl;
2390           }
2391           #endif
2392 1093119 100       for ( ; anum > 0; anum--, tmps++)
2393 1008408         *tmps = ~*tmps;
2394 165462 50       SETTARG;
2395           }
2396 1166683         RETURN;
2397           }
2398           }
2399            
2400           /* integer versions of some of the above */
2401            
2402 11359894         PP(pp_i_multiply)
2403           {
2404 11359894 100       dVAR; dSP; dATARGET;
2405 11359894 100       tryAMAGICbin_MG(mult_amg, AMGf_assign);
    50        
2406           {
2407 11359894 100       dPOPTOPiirl_nomg;
    100        
2408 11359894 100       SETi( left * right );
2409 11359894         RETURN;
2410           }
2411           }
2412            
2413 6070240         PP(pp_i_divide)
2414           {
2415           IV num;
2416 6070240 100       dVAR; dSP; dATARGET;
2417 6070240 100       tryAMAGICbin_MG(div_amg, AMGf_assign);
    50        
2418           {
2419 6070240         dPOPTOPssrl;
2420 6070240 100       IV value = SvIV_nomg(right);
2421 6070240 100       if (value == 0)
2422 2         DIE(aTHX_ "Illegal division by zero");
2423 6070238 100       num = SvIV_nomg(left);
2424            
2425           /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2426 6070238 100       if (value == -1)
2427 2         value = - num;
2428           else
2429 6070236         value = num / value;
2430 6070238 100       SETi(value);
2431 6070238         RETURN;
2432           }
2433           }
2434            
2435           #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2436           STATIC
2437 43728         PP(pp_i_modulo_0)
2438           #else
2439           PP(pp_i_modulo)
2440           #endif
2441           {
2442           /* This is the vanilla old i_modulo. */
2443 43728 50       dVAR; dSP; dATARGET;
2444 43728 100       tryAMAGICbin_MG(modulo_amg, AMGf_assign);
    50        
2445           {
2446 43728 100       dPOPTOPiirl_nomg;
    100        
2447 43728 50       if (!right)
2448 0         DIE(aTHX_ "Illegal modulus zero");
2449           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2450 43728 50       if (right == -1)
2451 0 0       SETi( 0 );
2452           else
2453 43728 50       SETi( left % right );
2454 43728         RETURN;
2455           }
2456           }
2457            
2458           #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2459           STATIC
2460 0         PP(pp_i_modulo_1)
2461            
2462           {
2463           /* This is the i_modulo with the workaround for the _moddi3 bug
2464           * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2465           * See below for pp_i_modulo. */
2466 0 0       dVAR; dSP; dATARGET;
2467 0 0       tryAMAGICbin_MG(modulo_amg, AMGf_assign);
    0        
2468           {
2469 0 0       dPOPTOPiirl_nomg;
    0        
2470 0 0       if (!right)
2471 0         DIE(aTHX_ "Illegal modulus zero");
2472           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2473 0 0       if (right == -1)
2474 0 0       SETi( 0 );
2475           else
2476 0 0       SETi( left % PERL_ABS(right) );
2477 0         RETURN;
2478           }
2479           }
2480            
2481 194         PP(pp_i_modulo)
2482           {
2483 194 100       dVAR; dSP; dATARGET;
2484 194 50       tryAMAGICbin_MG(modulo_amg, AMGf_assign);
    0        
2485           {
2486 194 100       dPOPTOPiirl_nomg;
    100        
2487 194 100       if (!right)
2488 2         DIE(aTHX_ "Illegal modulus zero");
2489           /* The assumption is to use hereafter the old vanilla version... */
2490 384         PL_op->op_ppaddr =
2491 192         PL_ppaddr[OP_I_MODULO] =
2492           Perl_pp_i_modulo_0;
2493           /* .. but if we have glibc, we might have a buggy _moddi3
2494           * (at least glicb 2.2.5 is known to have this bug), in other
2495           * words our integer modulus with negative quad as the second
2496           * argument might be broken. Test for this and re-patch the
2497           * opcode dispatch table if that is the case, remembering to
2498           * also apply the workaround so that this first round works
2499           * right, too. See [perl #9402] for more information. */
2500           {
2501           IV l = 3;
2502           IV r = -10;
2503           /* Cannot do this check with inlined IV constants since
2504           * that seems to work correctly even with the buggy glibc. */
2505           if (l % r == -3) {
2506           /* Yikes, we have the bug.
2507           * Patch in the workaround version. */
2508           PL_op->op_ppaddr =
2509           PL_ppaddr[OP_I_MODULO] =
2510           &Perl_pp_i_modulo_1;
2511           /* Make certain we work right this time, too. */
2512           right = PERL_ABS(right);
2513           }
2514           }
2515           /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2516 192 100       if (right == -1)
2517 2 50       SETi( 0 );
2518           else
2519 190 50       SETi( left % right );
2520 192         RETURN;
2521           }
2522           }
2523           #endif
2524            
2525 12238222         PP(pp_i_add)
2526           {
2527 12238222 100       dVAR; dSP; dATARGET;
2528 12238222 100       tryAMAGICbin_MG(add_amg, AMGf_assign);
    50        
2529           {
2530 12238222 100       dPOPTOPiirl_ul_nomg;
    100        
    50        
    50        
    100        
    100        
2531 12238222 100       SETi( left + right );
2532 12238222         RETURN;
2533           }
2534           }
2535            
2536 7237312         PP(pp_i_subtract)
2537           {
2538 7237312 100       dVAR; dSP; dATARGET;
2539 7237312 100       tryAMAGICbin_MG(subtr_amg, AMGf_assign);
    50        
2540           {
2541 7237312 100       dPOPTOPiirl_ul_nomg;
    100        
    50        
    50        
    100        
    100        
2542 7237312 100       SETi( left - right );
2543 7237312         RETURN;
2544           }
2545           }
2546            
2547 2629724         PP(pp_i_lt)
2548           {
2549 2629724         dVAR; dSP;
2550 2629724 100       tryAMAGICbin_MG(lt_amg, AMGf_set);
    50        
2551           {
2552 2629724 100       dPOPTOPiirl_nomg;
    100        
2553 2629724 100       SETs(boolSV(left < right));
2554 2629724         RETURN;
2555           }
2556           }
2557            
2558 513928         PP(pp_i_gt)
2559           {
2560 513928         dVAR; dSP;
2561 513928 100       tryAMAGICbin_MG(gt_amg, AMGf_set);
    50        
2562           {
2563 513928 100       dPOPTOPiirl_nomg;
    100        
2564 513928 100       SETs(boolSV(left > right));
2565 513928         RETURN;
2566           }
2567           }
2568            
2569 1763652         PP(pp_i_le)
2570           {
2571 1763652         dVAR; dSP;
2572 1763652 100       tryAMAGICbin_MG(le_amg, AMGf_set);
    50        
2573           {
2574 1763652 100       dPOPTOPiirl_nomg;
    100        
2575 1763652 100       SETs(boolSV(left <= right));
2576 1763652         RETURN;
2577           }
2578           }
2579            
2580 583634         PP(pp_i_ge)
2581           {
2582 583634         dVAR; dSP;
2583 583634 100       tryAMAGICbin_MG(ge_amg, AMGf_set);
    50        
2584           {
2585 583634 100       dPOPTOPiirl_nomg;
    100        
2586 583634 100       SETs(boolSV(left >= right));
2587 583634         RETURN;
2588           }
2589           }
2590            
2591 2020828         PP(pp_i_eq)
2592           {
2593 2020828         dVAR; dSP;
2594 2020828 100       tryAMAGICbin_MG(eq_amg, AMGf_set);
    50        
2595           {
2596 2020828 100       dPOPTOPiirl_nomg;
    100        
2597 2020828 100       SETs(boolSV(left == right));
2598 2020828         RETURN;
2599           }
2600           }
2601            
2602 92002         PP(pp_i_ne)
2603           {
2604 92002         dVAR; dSP;
2605 92002 100       tryAMAGICbin_MG(ne_amg, AMGf_set);
    50        
2606           {
2607 92002 100       dPOPTOPiirl_nomg;
    100        
2608 92002 100       SETs(boolSV(left != right));
2609 92002         RETURN;
2610           }
2611           }
2612            
2613 84         PP(pp_i_ncmp)
2614           {
2615 84         dVAR; dSP; dTARGET;
2616 84 100       tryAMAGICbin_MG(ncmp_amg, 0);
    50        
2617           {
2618 84 100       dPOPTOPiirl_nomg;
    100        
2619           I32 value;
2620            
2621 84 100       if (left > right)
2622           value = 1;
2623 46 100       else if (left < right)
2624           value = -1;
2625           else
2626           value = 0;
2627 84 50       SETi(value);
2628 84         RETURN;
2629           }
2630           }
2631            
2632 67662         PP(pp_i_negate)
2633           {
2634 67662         dVAR; dSP; dTARGET;
2635 67662 100       tryAMAGICun_MG(neg_amg, 0);
    50        
2636 67662 100       if (S_negate_string(aTHX)) return NORMAL;
2637           {
2638 67646         SV * const sv = TOPs;
2639 67646 100       IV const i = SvIV_nomg(sv);
2640 67646 50       SETi(-i);
2641 67654         RETURN;
2642           }
2643           }
2644            
2645           /* High falutin' math. */
2646            
2647 2204         PP(pp_atan2)
2648           {
2649 2204         dVAR; dSP; dTARGET;
2650 2204 50       tryAMAGICbin_MG(atan2_amg, 0);
    0        
2651           {
2652 2204 100       dPOPTOPnnrl_nomg;
    100        
2653 2204 50       SETn(Perl_atan2(left, right));
2654 2204         RETURN;
2655           }
2656           }
2657            
2658 2603310         PP(pp_sin)
2659           {
2660 2603310         dVAR; dSP; dTARGET;
2661           int amg_type = sin_amg;
2662           const char *neg_report = NULL;
2663           NV (*func)(NV) = Perl_sin;
2664 2603310         const int op_type = PL_op->op_type;
2665            
2666 2603310 100       switch (op_type) {
2667           case OP_COS:
2668           amg_type = cos_amg;
2669           func = Perl_cos;
2670           break;
2671           case OP_EXP:
2672           amg_type = exp_amg;
2673           func = Perl_exp;
2674           break;
2675           case OP_LOG:
2676           amg_type = log_amg;
2677           func = Perl_log;
2678           neg_report = "log";
2679           break;
2680           case OP_SQRT:
2681           amg_type = sqrt_amg;
2682           func = Perl_sqrt;
2683           neg_report = "sqrt";
2684           break;
2685           }
2686            
2687            
2688 2603310 100       tryAMAGICun_MG(amg_type, 0);
    100        
2689           {
2690 2602888         SV * const arg = POPs;
2691 2602888 100       const NV value = SvNV_nomg(arg);
2692 2602888 100       if (neg_report) {
2693 2584900 100       if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
    100        
2694 10         SET_NUMERIC_STANDARD();
2695           /* diag_listed_as: Can't take log of %g */
2696 10         DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2697           }
2698           }
2699 2602878 50       XPUSHn(func(value));
    50        
2700 2603089         RETURN;
2701           }
2702           }
2703            
2704           /* Support Configure command-line overrides for rand() functions.
2705           After 5.005, perhaps we should replace this by Configure support
2706           for drand48(), random(), or rand(). For 5.005, though, maintain
2707           compatibility by calling rand() but allow the user to override it.
2708           See INSTALL for details. --Andy Dougherty 15 July 1998
2709           */
2710           /* Now it's after 5.005, and Configure supports drand48() and random(),
2711           in addition to rand(). So the overrides should not be needed any more.
2712           --Jarkko Hietaniemi 27 September 1998
2713           */
2714            
2715           #ifndef HAS_DRAND48_PROTO
2716           extern double drand48 (void);
2717           #endif
2718            
2719 1536619         PP(pp_rand)
2720           {
2721           dVAR;
2722 1536619 100       if (!PL_srand_called) {
2723 5081         (void)seedDrand01((Rand_seed_t)seed());
2724 5081         PL_srand_called = TRUE;
2725           }
2726 1536619 50       {
2727 1536619         dSP;
2728           NV value;
2729 768130         EXTEND(SP, 1);
2730          
2731 1536619 100       if (MAXARG < 1)
2732           value = 1.0;
2733           else {
2734 1329787         SV * const sv = POPs;
2735 1329787 100       if(!sv)
2736           value = 1.0;
2737           else
2738 1329783 100       value = SvNV(sv);
2739           }
2740           /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2741 1536619 100       if (value == 0.0)
2742           value = 1.0;
2743           {
2744 1536619         dTARGET;
2745 1536619         PUSHs(TARG);
2746 1536619         PUTBACK;
2747 1536619         value *= Drand01();
2748 1536619         sv_setnv_mg(TARG, value);
2749           }
2750           }
2751 1536619         return NORMAL;
2752           }
2753            
2754 60         PP(pp_srand)
2755           {
2756 60         dVAR; dSP; dTARGET;
2757           UV anum;
2758            
2759 60 100       if (MAXARG >= 1 && (TOPs || POPs)) {
    100        
    50        
2760           SV *top;
2761           char *pv;
2762           STRLEN len;
2763           int flags;
2764            
2765 44         top = POPs;
2766 44 100       pv = SvPV(top, len);
2767 44         flags = grok_number(pv, len, &anum);
2768            
2769 44 100       if (!(flags & IS_NUMBER_IN_UV)) {
2770 4         Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2771           "Integer overflow in srand");
2772 4         anum = UV_MAX;
2773           }
2774           }
2775           else {
2776 16         anum = seed();
2777           }
2778            
2779 60         (void)seedDrand01((Rand_seed_t)anum);
2780 60         PL_srand_called = TRUE;
2781 60 100       if (anum)
2782 54 50       XPUSHu(anum);
    50        
2783           else {
2784           /* Historically srand always returned true. We can avoid breaking
2785           that like this: */
2786 6         sv_setpvs(TARG, "0 but true");
2787 6 50       XPUSHTARG;
    50        
2788           }
2789 60         RETURN;
2790           }
2791            
2792 3798464         PP(pp_int)
2793           {
2794 3798464         dVAR; dSP; dTARGET;
2795 3798464 100       tryAMAGICun_MG(int_amg, AMGf_numeric);
    100        
2796           {
2797 3798364         SV * const sv = TOPs;
2798 3798364 100       const IV iv = SvIV_nomg(sv);
2799           /* XXX it's arguable that compiler casting to IV might be subtly
2800           different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2801           else preferring IV has introduced a subtle behaviour change bug. OTOH
2802           relying on floating point to be accurate is a bug. */
2803            
2804 3798364 100       if (!SvOK(sv)) {
    100        
    50        
2805 2 50       SETu(0);
2806           }
2807 3798362 100       else if (SvIOK(sv)) {
2808 2800364 50       if (SvIsUV(sv))
2809 0 0       SETu(SvUV_nomg(sv));
    0        
2810           else
2811 2800364 50       SETi(iv);
2812           }
2813           else {
2814 997998 100       const NV value = SvNV_nomg(sv);
2815 997998 100       if (value >= 0.0) {
2816 997112 100       if (value < (NV)UV_MAX + 0.5) {
2817 996982 50       SETu(U_V(value));
2818           } else {
2819 130 50       SETn(Perl_floor(value));
2820           }
2821           }
2822           else {
2823 886 50       if (value > (NV)IV_MIN - 0.5) {
2824 886 50       SETi(I_V(value));
2825           } else {
2826 0 0       SETn(Perl_ceil(value));
2827           }
2828           }
2829           }
2830           }
2831 3798414         RETURN;
2832           }
2833            
2834 56210         PP(pp_abs)
2835           {
2836 56210         dVAR; dSP; dTARGET;
2837 56210 100       tryAMAGICun_MG(abs_amg, AMGf_numeric);
    100        
2838           {
2839 54562         SV * const sv = TOPs;
2840           /* This will cache the NV value if string isn't actually integer */
2841 54562 100       const IV iv = SvIV_nomg(sv);
2842            
2843 54562 100       if (!SvOK(sv)) {
    50        
    50        
2844 4 50       SETu(0);
2845           }
2846 54558 100       else if (SvIOK(sv)) {
2847           /* IVX is precise */
2848 24366 100       if (SvIsUV(sv)) {
2849 54 50       SETu(SvUV_nomg(sv)); /* force it to be numeric only */
    50        
2850           } else {
2851 24312 100       if (iv >= 0) {
2852 19510 50       SETi(iv);
2853           } else {
2854 4802 50       if (iv != IV_MIN) {
2855 4802 50       SETi(-iv);
2856           } else {
2857           /* 2s complement assumption. Also, not really needed as
2858           IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2859 0 0       SETu(IV_MIN);
2860           }
2861           }
2862           }
2863           } else{
2864 30192 100       const NV value = SvNV_nomg(sv);
2865 30192 100       if (value < 0.0)
2866 18564 50       SETn(-value);
2867           else
2868 11628 50       SETn(value);
2869           }
2870           }
2871 55375         RETURN;
2872           }
2873            
2874 5307920         PP(pp_oct)
2875           {
2876 5307920         dVAR; dSP; dTARGET;
2877           const char *tmps;
2878 5307920         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2879           STRLEN len;
2880           NV result_nv;
2881           UV result_uv;
2882 5307920         SV* const sv = POPs;
2883            
2884 5307920 100       tmps = (SvPV_const(sv, len));
2885 5307920 100       if (DO_UTF8(sv)) {
    50        
2886           /* If Unicode, try to downgrade
2887           * If not possible, croak. */
2888 4922         SV* const tsv = sv_2mortal(newSVsv(sv));
2889          
2890 4922         SvUTF8_on(tsv);
2891 4922         sv_utf8_downgrade(tsv, FALSE);
2892 4914 50       tmps = SvPV_const(tsv, len);
2893           }
2894 5307912 100       if (PL_op->op_type == OP_HEX)
2895           goto hex;
2896            
2897 19834 100       while (*tmps && len && isSPACE(*tmps))
    50        
    100        
2898 1832         tmps++, len--;
2899 18002 100       if (*tmps == '0')
2900 11084         tmps++, len--;
2901 18002 100       if (*tmps == 'x' || *tmps == 'X') {
2902           hex:
2903 5289982         result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2904           }
2905 17930 100       else if (*tmps == 'b' || *tmps == 'B')
2906 7998         result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2907           else
2908 9932         result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2909            
2910 5307878 100       if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2911 42 50       XPUSHn(result_nv);
    50        
2912           }
2913           else {
2914 5307836 100       XPUSHu(result_uv);
    50        
2915           }
2916 5307878         RETURN;
2917           }
2918            
2919           /* String stuff. */
2920            
2921 32707653         PP(pp_length)
2922 32707653 100       {
2923 32707653         dVAR; dSP; dTARGET;
2924 32707653         SV * const sv = TOPs;
2925            
2926 16482506         SvGETMAGIC(sv);
2927 32707653 100       if (SvOK(sv)) {
    50        
    50        
2928 32707485 100       if (!IN_BYTES)
2929 30269781 100       SETi(sv_len_utf8_nomg(sv));
2930           else
2931           {
2932           STRLEN len;
2933 2437704 100       (void)SvPV_nomg_const(sv,len);
2934 2437704 50       SETi(len);
2935           }
2936           } else {
2937 168 100       if (!SvPADTMP(TARG)) {
2938 6         sv_setsv_nomg(TARG, &PL_sv_undef);
2939 6 50       SETTARG;
2940           }
2941 168         SETs(&PL_sv_undef);
2942           }
2943 32707653         RETURN;
2944           }
2945            
2946           /* Returns false if substring is completely outside original string.
2947           No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
2948           always be true for an explicit 0.
2949           */
2950           bool
2951 23225328         Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
2952           bool pos1_is_uv, IV len_iv,
2953           bool len_is_uv, STRLEN *posp,
2954           STRLEN *lenp)
2955           {
2956           IV pos2_iv;
2957           int pos2_is_uv;
2958            
2959           PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
2960            
2961 23225328 100       if (!pos1_is_uv && pos1_iv < 0 && curlen) {
    100        
2962 4387374         pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
2963 4387374         pos1_iv += curlen;
2964           }
2965 23225328 100       if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
    100        
    100        
2966           return FALSE;
2967            
2968 23225258 100       if (len_iv || len_is_uv) {
    100        
2969 17178360 100       if (!len_is_uv && len_iv < 0) {
    100        
2970 996         pos2_iv = curlen + len_iv;
2971 996 100       if (curlen)
2972 982         pos2_is_uv = curlen-1 > ~(UV)len_iv;
2973           else
2974           pos2_is_uv = 0;
2975           } else { /* len_iv >= 0 */
2976 17177364 100       if (!pos1_is_uv && pos1_iv < 0) {
    100        
2977 2178         pos2_iv = pos1_iv + len_iv;
2978 2178         pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
2979           } else {
2980 17175186 100       if ((UV)len_iv > curlen-(UV)pos1_iv)
2981 129954         pos2_iv = curlen;
2982           else
2983 17045232         pos2_iv = pos1_iv+len_iv;
2984           pos2_is_uv = 1;
2985           }
2986           }
2987           }
2988           else {
2989 6046898         pos2_iv = curlen;
2990           pos2_is_uv = 1;
2991           }
2992            
2993 23225258 100       if (!pos2_is_uv && pos2_iv < 0) {
2994 40 100       if (!pos1_is_uv && pos1_iv < 0)
    100        
2995           return FALSE;
2996           pos2_iv = 0;
2997           }
2998 23225218 100       else if (!pos1_is_uv && pos1_iv < 0)
    100        
2999           pos1_iv = 0;
3000            
3001 23225228 100       if ((UV)pos2_iv < (UV)pos1_iv)
3002           pos2_iv = pos1_iv;
3003 23225228 100       if ((UV)pos2_iv > curlen)
3004 4         pos2_iv = curlen;
3005            
3006           /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3007 23225228         *posp = (STRLEN)( (UV)pos1_iv );
3008 23225228         *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3009            
3010 23225278         return TRUE;
3011           }
3012            
3013 23214320         PP(pp_substr)
3014           {
3015 23214320         dVAR; dSP; dTARGET;
3016           SV *sv;
3017           STRLEN curlen;
3018           STRLEN utf8_curlen;
3019           SV * pos_sv;
3020           IV pos1_iv;
3021           int pos1_is_uv;
3022           SV * len_sv;
3023           IV len_iv = 0;
3024           int len_is_uv = 0;
3025 23214320 100       I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
    100        
    50        
3026 23214320 50       const bool rvalue = (GIMME_V != G_VOID);
3027           const char *tmps;
3028           SV *repl_sv = NULL;
3029           const char *repl = NULL;
3030           STRLEN repl_len;
3031 23214320         int num_args = PL_op->op_private & 7;
3032           bool repl_need_utf8_upgrade = FALSE;
3033            
3034 23214320 100       if (num_args > 2) {
3035 17175918 100       if (num_args > 3) {
3036 22722         if(!(repl_sv = POPs)) num_args--;
3037           }
3038 17175918 100       if ((len_sv = POPs)) {
3039 17175914 100       len_iv = SvIV(len_sv);
3040 17175914 100       len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
    50        
3041           }
3042           else num_args--;
3043           }
3044 23214320         pos_sv = POPs;
3045 23214320 100       pos1_iv = SvIV(pos_sv);
3046 23214320         pos1_is_uv = SvIOK_UV(pos_sv);
3047 23214320         sv = POPs;
3048 23214320 100       if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3049           assert(!repl_sv);
3050 2790112         repl_sv = POPs;
3051           }
3052 23214320         PUTBACK;
3053 23214320 100       if (lvalue && !repl_sv) {
3054           SV * ret;
3055 58176         ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3056 58176         sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3057 58176         LvTYPE(ret) = 'x';
3058 116352         LvTARG(ret) = SvREFCNT_inc_simple(sv);
3059 116352         LvTARGOFF(ret) =
3060 58176         pos1_is_uv || pos1_iv >= 0
3061           ? (STRLEN)(UV)pos1_iv
3062 58176 100       : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3063 116352         LvTARGLEN(ret) =
3064 58176         len_is_uv || len_iv > 0
3065           ? (STRLEN)(UV)len_iv
3066 58176 100       : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3067            
3068 58176         SPAGAIN;
3069 58176         PUSHs(ret); /* avoid SvSETMAGIC here */
3070 58176         RETURN;
3071           }
3072 25968972 100       if (repl_sv) {
    100        
3073 2812828 100       repl = SvPV_const(repl_sv, repl_len);
3074 1407620         SvGETMAGIC(sv);
3075 2812828 100       if (SvROK(sv))
3076 16         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3077           "Attempt to use reference as lvalue in substr"
3078           );
3079 2812828 100       tmps = SvPV_force_nomg(sv, curlen);
3080 2812828 100       if (DO_UTF8(repl_sv) && repl_len) {
    50        
    100        
3081 600 100       if (!DO_UTF8(sv)) {
    50        
3082 242         sv_utf8_upgrade_nomg(sv);
3083 242         curlen = SvCUR(sv);
3084           }
3085           }
3086 2812228 100       else if (DO_UTF8(sv))
    50        
3087           repl_need_utf8_upgrade = TRUE;
3088           }
3089 20343316 100       else tmps = SvPV_const(sv, curlen);
3090 23156144 100       if (DO_UTF8(sv)) {
    100        
3091 1166528 100       utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
    100        
    50        
    100        
3092 1166528 100       if (utf8_curlen == curlen)
3093           utf8_curlen = 0;
3094           else
3095 147768         curlen = utf8_curlen;
3096           }
3097           else
3098           utf8_curlen = 0;
3099            
3100           {
3101           STRLEN pos, len, byte_len, byte_pos;
3102            
3103 23156144 100       if (!translate_substr_offsets(
3104           curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3105           )) goto bound_fail;
3106            
3107 23156046         byte_len = len;
3108           byte_pos = utf8_curlen
3109 34660005 100       ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3110            
3111 23156046         tmps += byte_pos;
3112            
3113 23156046 100       if (rvalue) {
3114 20356252 100       SvTAINTED_off(TARG); /* decontaminate */
3115 20356252         SvUTF8_off(TARG); /* decontaminate */
3116 20356252         sv_setpvn(TARG, tmps, byte_len);
3117           #ifdef USE_LOCALE_COLLATE
3118 20356252         sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3119           #endif
3120 20356252 100       if (utf8_curlen)
3121 145374         SvUTF8_on(TARG);
3122           }
3123            
3124 23156046 100       if (repl) {
3125           SV* repl_sv_copy = NULL;
3126            
3127 2812782 100       if (repl_need_utf8_upgrade) {
3128 4288         repl_sv_copy = newSVsv(repl_sv);
3129 4288         sv_utf8_upgrade(repl_sv_copy);
3130 4288 50       repl = SvPV_const(repl_sv_copy, repl_len);
3131           }
3132 2812782 50       if (!SvOK(sv))
    0        
    0        
3133 0         sv_setpvs(sv, "");
3134 2812782         sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3135 2812782         SvREFCNT_dec(repl_sv_copy);
3136           }
3137           }
3138 23156046         SPAGAIN;
3139 23156046 100       if (rvalue) {
3140 20356252 100       SvSETMAGIC(TARG);
3141 20356252         PUSHs(TARG);
3142           }
3143 23156046         RETURN;
3144            
3145           bound_fail:
3146 98 100       if (repl)
3147 46         Perl_croak(aTHX_ "substr outside of string");
3148 52         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3149 11607343         RETPUSHUNDEF;
3150           }
3151            
3152 5552080         PP(pp_vec)
3153           {
3154 5552080         dVAR; dSP;
3155 5552080 100       const IV size = POPi;
3156 5552080 100       const IV offset = POPi;
3157 5552080         SV * const src = POPs;
3158 5552080 100       const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
    100        
    100        
3159           SV * ret;
3160            
3161 5552080 100       if (lvalue) { /* it's an lvalue! */
3162 5038420         ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3163 5038420         sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3164 5038420         LvTYPE(ret) = 'v';
3165 10076840         LvTARG(ret) = SvREFCNT_inc_simple(src);
3166 5038420         LvTARGOFF(ret) = offset;
3167 5038420         LvTARGLEN(ret) = size;
3168           }
3169           else {
3170 513660         dTARGET;
3171 513660 100       SvTAINTED_off(TARG); /* decontaminate */
3172           ret = TARG;
3173           }
3174            
3175 5552080         sv_setuv(ret, do_vecget(src, offset, size));
3176 5552070         PUSHs(ret);
3177 5552070         RETURN;
3178           }
3179            
3180 5104836         PP(pp_index)
3181           {
3182 5104836         dVAR; dSP; dTARGET;
3183           SV *big;
3184           SV *little;
3185           SV *temp = NULL;
3186           STRLEN biglen;
3187 5104836         STRLEN llen = 0;
3188           I32 offset;
3189           I32 retval;
3190           const char *big_p;
3191           const char *little_p;
3192           bool big_utf8;
3193           bool little_utf8;
3194 5104836         const bool is_index = PL_op->op_type == OP_INDEX;
3195 5104836 100       const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
    100        
3196            
3197 5104836 100       if (threeargs)
3198 3149648 100       offset = POPi;
3199 5104836         little = POPs;
3200 5104836         big = POPs;
3201 5104836 100       big_p = SvPV_const(big, biglen);
3202 5104836 100       little_p = SvPV_const(little, llen);
3203            
3204 5104836 100       big_utf8 = DO_UTF8(big);
    100        
3205 5104836 100       little_utf8 = DO_UTF8(little);
    50        
3206 5104836 100       if (big_utf8 ^ little_utf8) {
3207           /* One needs to be upgraded. */
3208 52266 100       if (little_utf8 && !PL_encoding) {
    50        
3209           /* Well, maybe instead we might be able to downgrade the small
3210           string? */
3211 44         char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3212           &little_utf8);
3213 44 50       if (little_utf8) {
3214           /* If the large string is ISO-8859-1, and it's not possible to
3215           convert the small string to ISO-8859-1, then there is no
3216           way that it could be found anywhere by index. */
3217 0         retval = -1;
3218 0         goto fail;
3219           }
3220            
3221           /* At this point, pv is a malloc()ed string. So donate it to temp
3222           to ensure it will get free()d */
3223 44         little = temp = newSV(0);
3224 44         sv_usepvn(temp, pv, llen);
3225 44         little_p = SvPVX(little);
3226           } else {
3227           temp = little_utf8
3228 52178 50       ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3229            
3230 52178 100       if (PL_encoding) {
3231 1710         sv_recode_to_utf8(temp, PL_encoding);
3232           } else {
3233 50468         sv_utf8_upgrade(temp);
3234           }
3235 52178 50       if (little_utf8) {
3236           big = temp;
3237           big_utf8 = TRUE;
3238 0 0       big_p = SvPV_const(big, biglen);
3239           } else {
3240           little = temp;
3241 52178 50       little_p = SvPV_const(little, llen);
3242           }
3243           }
3244           }
3245 5104836 100       if (SvGAMAGIC(big)) {
    100        
    50        
    50        
3246           /* Life just becomes a lot easier if I use a temporary here.
3247           Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3248           will trigger magic and overloading again, as will fbm_instr()
3249           */
3250 529992 100       big = newSVpvn_flags(big_p, biglen,
3251           SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3252 529992         big_p = SvPVX(big);
3253           }
3254 5104836 100       if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
    100        
    100        
    50        
    100        
    100        
    50        
    50        
3255           /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3256           warn on undef, and we've already triggered a warning with the
3257           SvPV_const some lines above. We can't remove that, as we need to
3258           call some SvPV to trigger overloading early and find out if the
3259           string is UTF-8.
3260           This is all getting to messy. The API isn't quite clean enough,
3261           because data access has side effects.
3262           */
3263 13324 100       little = newSVpvn_flags(little_p, llen,
3264           SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3265 13324         little_p = SvPVX(little);
3266           }
3267            
3268 5104836 100       if (!threeargs)
3269 1955188 100       offset = is_index ? 0 : biglen;
3270           else {
3271 3149648 100       if (big_utf8 && offset > 0)
    50        
3272 58         sv_pos_u2b(big, &offset, 0);
3273 3149648 100       if (!is_index)
3274 1794         offset += llen;
3275           }
3276 5104836 100       if (offset < 0)
3277 6         offset = 0;
3278 5104830 100       else if (offset > (I32)biglen)
3279 14         offset = biglen;
3280 7657074 100       if (!(little_p = is_index
    100        
3281 5101772         ? fbm_instr((unsigned char*)big_p + offset,
3282           (unsigned char*)big_p + biglen, little, 0)
3283 3064         : rninstr(big_p, big_p + offset,
3284           little_p, little_p + llen)))
3285 1734156         retval = -1;
3286           else {
3287 3370680         retval = little_p - big_p;
3288 3370680 100       if (retval > 0 && big_utf8)
    100        
3289 254         sv_pos_b2u(big, &retval);
3290           }
3291 5104836         SvREFCNT_dec(temp);
3292           fail:
3293 5104836 50       PUSHi(retval);
3294 5104836         RETURN;
3295           }
3296            
3297 4517283         PP(pp_sprintf)
3298           {
3299 4517283         dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3300 4517283 100       SvTAINTED_off(TARG);
3301 4517283         do_sprintf(TARG, SP-MARK, MARK+1);
3302 4517257 100       TAINT_IF(SvTAINTED(TARG));
    50        
3303 4517257         SP = ORIGMARK;
3304 4517257 100       PUSHTARG;
3305 4517257         RETURN;
3306           }
3307            
3308 14464826         PP(pp_ord)
3309           {
3310 14464826         dVAR; dSP; dTARGET;
3311            
3312 14464826         SV *argsv = POPs;
3313           STRLEN len;
3314 14464826 100       const U8 *s = (U8*)SvPV_const(argsv, len);
3315            
3316 14464826 100       if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
    100        
    100        
    50        
3317 96644         SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3318 96644         s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3319           argsv = tmpsv;
3320           }
3321            
3322 14464826 100       XPUSHu(DO_UTF8(argsv)
    100        
    50        
    50        
3323           ? utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV)
3324           : (UV)(*s & 0xff));
3325            
3326 14464826         RETURN;
3327           }
3328            
3329 6049936         PP(pp_chr)
3330 12099870 100       {
    100        
3331 6049936         dVAR; dSP; dTARGET;
3332           char *tmps;
3333           UV value;
3334 6049936         SV *top = POPs;
3335            
3336 2960904         SvGETMAGIC(top);
3337 17302402 100       if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
    50        
    100        
3338 11282146 100       && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
    100        
    100        
    0        
3339 5696824 100       ||
3340 8379626 100       ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
    50        
    50        
    100        
3341 5717929 100       && SvNV_nomg(top) < 0.0))) {
    100        
3342 44 100       if (ckWARN(WARN_UTF8)) {
3343 4 50       if (SvGMAGICAL(top)) {
3344 0         SV *top2 = sv_newmortal();
3345 0         sv_setsv_nomg(top2, top);
3346           top = top2;
3347           }
3348 4         Perl_warner(aTHX_ packWARN(WARN_UTF8),
3349           "Invalid negative number (%"SVf") in chr", top);
3350           }
3351           value = UNICODE_REPLACEMENT;
3352           } else {
3353 6049892 100       value = SvUV_nomg(top);
3354           }
3355            
3356 2974151         SvUPGRADE(TARG,SVt_PV);
3357            
3358 6049934 100       if (value > 255 && !IN_BYTES) {
    100        
3359 1129056 100       SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
    50        
    100        
    100        
    100        
    100        
    100        
    100        
    100        
    50        
    100        
    100        
    100        
    100        
    100        
    100        
3360 1129056         tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3361 1129056         SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3362 1129056         *tmps = '\0';
3363 1129056         (void)SvPOK_only(TARG);
3364 1129056         SvUTF8_on(TARG);
3365 1129056 50       XPUSHs(TARG);
3366 1129056         RETURN;
3367           }
3368            
3369 4920878 100       SvGROW(TARG,2);
    100        
3370 4920878         SvCUR_set(TARG, 1);
3371 4920878         tmps = SvPVX(TARG);
3372 4920878         *tmps++ = (char)value;
3373 4920878         *tmps = '\0';
3374 4920878         (void)SvPOK_only(TARG);
3375            
3376 4920878 100       if (PL_encoding && !IN_BYTES) {
    50        
3377 2772         sv_recode_to_utf8(TARG, PL_encoding);
3378 2772         tmps = SvPVX(TARG);
3379 2772 50       if (SvCUR(TARG) == 0
3380 2772 50       || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3381 2772 100       || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
    50        
    50        
    50        
3382           {
3383 66 50       SvGROW(TARG, 2);
    50        
3384 66         tmps = SvPVX(TARG);
3385 66         SvCUR_set(TARG, 1);
3386 66         *tmps++ = (char)value;
3387 66         *tmps = '\0';
3388 66         SvUTF8_off(TARG);
3389           }
3390           }
3391            
3392 4920878 50       XPUSHs(TARG);
3393 5512766         RETURN;
3394           }
3395            
3396 16         PP(pp_crypt)
3397           {
3398           #ifdef HAS_CRYPT
3399 16         dVAR; dSP; dTARGET;
3400 16         dPOPTOPssrl;
3401           STRLEN len;
3402 16 100       const char *tmps = SvPV_const(left, len);
3403            
3404 16 100       if (DO_UTF8(left)) {
    50        
3405           /* If Unicode, try to downgrade.
3406           * If not possible, croak.
3407           * Yes, we made this up. */
3408 4         SV* const tsv = sv_2mortal(newSVsv(left));
3409            
3410 4         SvUTF8_on(tsv);
3411 4         sv_utf8_downgrade(tsv, FALSE);
3412 2 50       tmps = SvPV_const(tsv, len);
3413           }
3414           # ifdef USE_ITHREADS
3415           # ifdef HAS_CRYPT_R
3416           if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3417           /* This should be threadsafe because in ithreads there is only
3418           * one thread per interpreter. If this would not be true,
3419           * we would need a mutex to protect this malloc. */
3420           PL_reentrant_buffer->_crypt_struct_buffer =
3421           (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3422           #if defined(__GLIBC__) || defined(__EMX__)
3423           if (PL_reentrant_buffer->_crypt_struct_buffer) {
3424           PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3425           /* work around glibc-2.2.5 bug */
3426           PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3427           }
3428           #endif
3429           }
3430           # endif /* HAS_CRYPT_R */
3431           # endif /* USE_ITHREADS */
3432           # ifdef FCRYPT
3433           sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3434           # else
3435 14 100       sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3436           # endif
3437 14 50       SETTARG;
3438 14         RETURN;
3439           #else
3440           DIE(aTHX_
3441           "The crypt() function is unimplemented due to excessive paranoia.");
3442           #endif
3443           }
3444            
3445           /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3446           * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3447            
3448 403454         PP(pp_ucfirst)
3449 403454 100       {
3450           /* Actually is both lcfirst() and ucfirst(). Only the first character
3451           * changes. This means that possibly we can change in-place, ie., just
3452           * take the source and change that one character and store it back, but not
3453           * if read-only etc, or if the length changes */
3454            
3455           dVAR;
3456 403454         dSP;
3457 403454         SV *source = TOPs;
3458           STRLEN slen; /* slen is the byte length of the whole SV. */
3459           STRLEN need;
3460           SV *dest;
3461           bool inplace; /* ? Convert first char only, in-place */
3462           bool doing_utf8 = FALSE; /* ? using utf8 */
3463           bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3464 403454         const int op_type = PL_op->op_type;
3465           const U8 *s;
3466           U8 *d;
3467           U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3468           STRLEN ulen; /* ulen is the byte length of the original Unicode character
3469           * stored as UTF-8 at s. */
3470           STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3471           * lowercased) character stored in tmpbuf. May be either
3472           * UTF-8 or not, but in either case is the number of bytes */
3473 403454         bool tainted = FALSE;
3474            
3475 259193         SvGETMAGIC(source);
3476 403454 100       if (SvOK(source)) {
    50        
    50        
3477 403442 100       s = (const U8*)SvPV_nomg_const(source, slen);
3478           } else {
3479 12 100       if (ckWARN(WARN_UNINITIALIZED))
3480 8         report_uninit(source);
3481           s = (const U8*)"";
3482 12         slen = 0;
3483           }
3484            
3485           /* We may be able to get away with changing only the first character, in
3486           * place, but not if read-only, etc. Later we may discover more reasons to
3487           * not convert in-place. */
3488 403454         inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3489            
3490           /* First calculate what the changed first character should be. This affects
3491           * whether we can just swap it out, leaving the rest of the string unchanged,
3492           * or even if have to convert the dest to UTF-8 when the source isn't */
3493            
3494 403454 100       if (! slen) { /* If empty */
3495           need = 1; /* still need a trailing NUL */
3496           ulen = 0;
3497           }
3498 397298 100       else if (DO_UTF8(source)) { /* Is the source utf8? */
    100        
3499           doing_utf8 = TRUE;
3500 18778         ulen = UTF8SKIP(s);
3501 18778 100       if (op_type == OP_UCFIRST) {
3502 9650         _to_utf8_title_flags(s, tmpbuf, &tculen,
3503           cBOOL(IN_LOCALE_RUNTIME), &tainted);
3504           }
3505           else {
3506 9128         _to_utf8_lower_flags(s, tmpbuf, &tculen,
3507           cBOOL(IN_LOCALE_RUNTIME), &tainted);
3508           }
3509            
3510           /* we can't do in-place if the length changes. */
3511 18772 100       if (ulen != tculen) inplace = FALSE;
3512 18772         need = slen + 1 - ulen + tculen;
3513           }
3514           else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3515           * latin1 is treated as caseless. Note that a locale takes
3516           * precedence */
3517           ulen = 1; /* Original character is 1 byte */
3518 378520         tculen = 1; /* Most characters will require one byte, but this will
3519           * need to be overridden for the tricky ones */
3520 378520         need = slen + 1;
3521            
3522 378520 100       if (op_type == OP_LCFIRST) {
3523            
3524           /* lower case the first letter: no trickiness for any character */
3525 7086 100       *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
    100        
    100        
3526 4023 100       ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3527           }
3528           /* is ucfirst() */
3529 375456 100       else if (IN_LOCALE_RUNTIME) {
3530 6         *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3531           * have upper and title case different
3532           */
3533           }
3534 375450 100       else if (! IN_UNI_8_BIT) {
    100        
3535 373914 100       *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3536           * on EBCDIC machines whatever the
3537           * native function does */
3538           }
3539           else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3540 1536         UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3541 1536 100       if (tculen > 1) {
3542           assert(tculen == 2);
3543            
3544           /* If the result is an upper Latin1-range character, it can
3545           * still be represented in one byte, which is its ordinal */
3546 768 100       if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3547 750         *tmpbuf = (U8) title_ord;
3548 750         tculen = 1;
3549           }
3550           else {
3551           /* Otherwise it became more than one ASCII character (in
3552           * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3553           * beyond Latin1, so the number of bytes changed, so can't
3554           * replace just the first character in place. */
3555           inplace = FALSE;
3556            
3557           /* If the result won't fit in a byte, the entire result
3558           * will have to be in UTF-8. Assume worst case sizing in
3559           * conversion. (all latin1 characters occupy at most two
3560           * bytes in utf8) */
3561 18 100       if (title_ord > 255) {
3562           doing_utf8 = TRUE;
3563           convert_source_to_utf8 = TRUE;
3564 12         need = slen * 2 + 1;
3565            
3566           /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3567           * (both) characters whose title case is above 255 is
3568           * 2. */
3569           ulen = 2;
3570           }
3571           else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3572 6         need = slen + 1 + 1;
3573           }
3574           }
3575           }
3576           } /* End of use Unicode (Latin1) semantics */
3577           } /* End of changing the case of the first character */
3578            
3579           /* Here, have the first character's changed case stored in tmpbuf. Ready to
3580           * generate the result */
3581 403448 50       if (inplace) {
3582            
3583           /* We can convert in place. This means we change just the first
3584           * character without disturbing the rest; no need to grow */
3585           dest = source;
3586 0 0       s = d = (U8*)SvPV_force_nomg(source, slen);
3587 403448 100       } else {
3588 403448         dTARGET;
3589            
3590           dest = TARG;
3591            
3592           /* Here, we can't convert in place; we earlier calculated how much
3593           * space we will need, so grow to accommodate that */
3594 202010         SvUPGRADE(dest, SVt_PV);
3595 403448 100       d = (U8*)SvGROW(dest, need);
    100        
3596 403448         (void)SvPOK_only(dest);
3597            
3598 403448         SETs(dest);
3599           }
3600            
3601 403448 100       if (doing_utf8) {
3602 18784 50       if (! inplace) {
3603 18784 100       if (! convert_source_to_utf8) {
3604            
3605           /* Here both source and dest are in UTF-8, but have to create
3606           * the entire output. We initialize the result to be the
3607           * title/lower cased first character, and then append the rest
3608           * of the string. */
3609 18772         sv_setpvn(dest, (char*)tmpbuf, tculen);
3610 18772 100       if (slen > ulen) {
3611 9880         sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3612           }
3613           }
3614           else {
3615 12         const U8 *const send = s + slen;
3616            
3617           /* Here the dest needs to be in UTF-8, but the source isn't,
3618           * except we earlier UTF-8'd the first character of the source
3619           * into tmpbuf. First put that into dest, and then append the
3620           * rest of the source, converting it to UTF-8 as we go. */
3621            
3622           /* Assert tculen is 2 here because the only two characters that
3623           * get to this part of the code have 2-byte UTF-8 equivalents */
3624 12         *d++ = *tmpbuf;
3625 12         *d++ = *(tmpbuf + 1);
3626 12         s++; /* We have just processed the 1st char */
3627            
3628 212 100       for (; s < send; s++) {
3629 200         d = uvchr_to_utf8(d, *s);
3630           }
3631 12         *d = '\0';
3632 12         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3633           }
3634 18784         SvUTF8_on(dest);
3635           }
3636           else { /* in-place UTF-8. Just overwrite the first character */
3637 0         Copy(tmpbuf, d, tculen, U8);
3638 0         SvCUR_set(dest, need - 1);
3639           }
3640            
3641 18784 100       if (tainted) {
3642 4         TAINT;
3643 4 50       SvTAINTED_on(dest);
3644           }
3645           }
3646           else { /* Neither source nor dest are in or need to be UTF-8 */
3647 384664 100       if (slen) {
3648 378508 100       if (IN_LOCALE_RUNTIME) {
3649 12         TAINT;
3650 12 50       SvTAINTED_on(dest);
3651           }
3652 378508 50       if (inplace) { /* in-place, only need to change the 1st char */
3653 0         *d = *tmpbuf;
3654           }
3655           else { /* Not in-place */
3656            
3657           /* Copy the case-changed character(s) from tmpbuf */
3658 378508         Copy(tmpbuf, d, tculen, U8);
3659 378508         d += tculen - 1; /* Code below expects d to point to final
3660           * character stored */
3661           }
3662           }
3663           else { /* empty source */
3664           /* See bug #39028: Don't taint if empty */
3665 6156         *d = *s;
3666           }
3667            
3668           /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3669           * the destination to retain that flag */
3670 384664 100       if (SvUTF8(source) && ! IN_BYTES)
    100        
3671 4         SvUTF8_on(dest);
3672            
3673 384664 50       if (!inplace) { /* Finish the rest of the string, unchanged */
3674           /* This will copy the trailing NUL */
3675 384664         Copy(s + 1, d + 1, slen, U8);
3676 384664         SvCUR_set(dest, need - 1);
3677           }
3678           }
3679 403448 50       if (dest != source && SvTAINTED(source))
    100        
    50        
3680 0 0       SvTAINT(dest);
    0        
    0        
3681 403448 100       SvSETMAGIC(dest);
3682 403448         RETURN;
3683           }
3684            
3685           /* There's so much setup/teardown code common between uc and lc, I wonder if
3686           it would be worth merging the two, and just having a switch outside each
3687           of the three tight loops. There is less and less commonality though */
3688 481026         PP(pp_uc)
3689 481026 100       {
3690           dVAR;
3691 481026         dSP;
3692 481026         SV *source = TOPs;
3693           STRLEN len;
3694           STRLEN min;
3695           SV *dest;
3696           const U8 *s;
3697           U8 *d;
3698            
3699 237507         SvGETMAGIC(source);
3700            
3701 481026 100       if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
    50        
    0        
    0        
3702 36778 50       && SvTEMP(source) && !DO_UTF8(source)
    0        
    0        
3703 0 0       && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
    0        
    0        
3704            
3705           /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3706           * make the loop tight, so we overwrite the source with the dest before
3707           * looking at it, and we need to look at the original source
3708           * afterwards. There would also need to be code added to handle
3709           * switching to not in-place in midstream if we run into characters
3710           * that change the length.
3711           */
3712           dest = source;
3713 0 0       s = d = (U8*)SvPV_force_nomg(source, len);
3714 0         min = len + 1;
3715 481026 100       } else {
3716 481026         dTARGET;
3717            
3718           dest = TARG;
3719            
3720           /* The old implementation would copy source into TARG at this point.
3721           This had the side effect that if source was undef, TARG was now
3722           an undefined SV with PADTMP set, and they don't warn inside
3723           sv_2pv_flags(). However, we're now getting the PV direct from
3724           source, which doesn't have PADTMP set, so it would warn. Hence the
3725           little games. */
3726            
3727 481026 100       if (SvOK(source)) {
    50        
    50        
3728 480926 100       s = (const U8*)SvPV_nomg_const(source, len);
3729           } else {
3730 100 100       if (ckWARN(WARN_UNINITIALIZED))
3731 4         report_uninit(source);
3732           s = (const U8*)"";
3733 100         len = 0;
3734           }
3735 481026         min = len + 1;
3736            
3737 256209         SvUPGRADE(dest, SVt_PV);
3738 481026 100       d = (U8*)SvGROW(dest, min);
    100        
3739 481026         (void)SvPOK_only(dest);
3740            
3741 481026         SETs(dest);
3742           }
3743            
3744           /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3745           to check DO_UTF8 again here. */
3746            
3747 481026 100       if (DO_UTF8(source)) {
    100        
3748 13466         const U8 *const send = s + len;
3749           U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3750 13466         bool tainted = FALSE;
3751            
3752           /* All occurrences of these are to be moved to follow any other marks.
3753           * This is context-dependent. We may not be passed enough context to
3754           * move the iota subscript beyond all of them, but we do the best we can
3755           * with what we're given. The result is always better than if we
3756           * hadn't done this. And, the problem would only arise if we are
3757           * passed a character without all its combining marks, which would be
3758           * the caller's mistake. The information this is based on comes from a
3759           * comment in Unicode SpecialCasing.txt, (and the Standard's text
3760           * itself) and so can't be checked properly to see if it ever gets
3761           * revised. But the likelihood of it changing is remote */
3762           bool in_iota_subscript = FALSE;
3763            
3764 203405 100       while (s < send) {
3765           STRLEN u;
3766           STRLEN ulen;
3767           UV uv;
3768 183226 100       if (in_iota_subscript && ! _is_utf8_mark(s)) {
    100        
3769            
3770           /* A non-mark. Time to output the iota subscript */
3771 12         Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3772 12         d += capital_iota_len;
3773           in_iota_subscript = FALSE;
3774           }
3775            
3776           /* Then handle the current character. Get the changed case value
3777           * and copy it to the output buffer */
3778            
3779 183226         u = UTF8SKIP(s);
3780 183226         uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
3781           cBOOL(IN_LOCALE_RUNTIME), &tainted);
3782           #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3783           #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3784 183206 100       if (uv == GREEK_CAPITAL_LETTER_IOTA
3785 158 50       && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
    100        
3786           {
3787           in_iota_subscript = TRUE;
3788           }
3789           else {
3790 183168 100       if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
    100        
3791           /* If the eventually required minimum size outgrows the
3792           * available space, we need to grow. */
3793 24         const UV o = d - (U8*)SvPVX_const(dest);
3794            
3795           /* If someone uppercases one million U+03B0s we SvGROW()
3796           * one million times. Or we could try guessing how much to
3797           * allocate without allocating too much. Such is life.
3798           * See corresponding comment in lc code for another option
3799           * */
3800 24 50       SvGROW(dest, min);
    50        
3801 24         d = (U8*)SvPVX(dest) + o;
3802           }
3803 183168         Copy(tmpbuf, d, ulen, U8);
3804 183168         d += ulen;
3805           }
3806 183206         s += u;
3807           }
3808 13446 100       if (in_iota_subscript) {
3809 26         Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3810 26         d += capital_iota_len;
3811           }
3812 13446         SvUTF8_on(dest);
3813 13446         *d = '\0';
3814            
3815 13446         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3816 13446 100       if (tainted) {
3817 2         TAINT;
3818 2 50       SvTAINTED_on(dest);
3819           }
3820           }
3821           else { /* Not UTF-8 */
3822 467560 100       if (len) {
3823 466944         const U8 *const send = s + len;
3824            
3825           /* Use locale casing if in locale; regular style if not treating
3826           * latin1 as having case; otherwise the latin1 casing. Do the
3827           * whole thing in a tight loop, for speed, */
3828 466944 100       if (IN_LOCALE_RUNTIME) {
3829 6         TAINT;
3830 6 50       SvTAINTED_on(dest);
3831 53 100       for (; s < send; d++, s++)
3832 50         *d = toUPPER_LC(*s);
3833           }
3834 466938 100       else if (! IN_UNI_8_BIT) {
    100        
3835 5444354 100       for (; s < send; d++, s++) {
3836 5209802 100       *d = toUPPER(*s);
3837           }
3838           }
3839           else {
3840 160039 100       for (; s < send; d++, s++) {
3841 157742         *d = toUPPER_LATIN1_MOD(*s);
3842 157742 100       if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3843 157684         continue;
3844           }
3845            
3846           /* The mainstream case is the tight loop above. To avoid
3847           * extra tests in that, all three characters that require
3848           * special handling are mapped by the MOD to the one tested
3849           * just above.
3850           * Use the source to distinguish between the three cases */
3851            
3852 58 100       if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3853            
3854           /* uc() of this requires 2 characters, but they are
3855           * ASCII. If not enough room, grow the string */
3856 18 50       if (SvLEN(dest) < ++min) {
3857 0         const UV o = d - (U8*)SvPVX_const(dest);
3858 0 0       SvGROW(dest, min);
    0        
3859 0         d = (U8*)SvPVX(dest) + o;
3860           }
3861 18         *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3862 18         continue; /* Back to the tight loop; still in ASCII */
3863           }
3864            
3865           /* The other two special handling characters have their
3866           * upper cases outside the latin1 range, hence need to be
3867           * in UTF-8, so the whole result needs to be in UTF-8. So,
3868           * here we are somewhere in the middle of processing a
3869           * non-UTF-8 string, and realize that we will have to convert
3870           * the whole thing to UTF-8. What to do? There are
3871           * several possibilities. The simplest to code is to
3872           * convert what we have so far, set a flag, and continue on
3873           * in the loop. The flag would be tested each time through
3874           * the loop, and if set, the next character would be
3875           * converted to UTF-8 and stored. But, I (khw) didn't want
3876           * to slow down the mainstream case at all for this fairly
3877           * rare case, so I didn't want to add a test that didn't
3878           * absolutely have to be there in the loop, besides the
3879           * possibility that it would get too complicated for
3880           * optimizers to deal with. Another possibility is to just
3881           * give up, convert the source to UTF-8, and restart the
3882           * function that way. Another possibility is to convert
3883           * both what has already been processed and what is yet to
3884           * come separately to UTF-8, then jump into the loop that
3885           * handles UTF-8. But the most efficient time-wise of the
3886           * ones I could think of is what follows, and turned out to
3887           * not require much extra code. */
3888            
3889           /* Convert what we have so far into UTF-8, telling the
3890           * function that we know it should be converted, and to
3891           * allow extra space for what we haven't processed yet.
3892           * Assume the worst case space requirements for converting
3893           * what we haven't processed so far: that it will require
3894           * two bytes for each remaining source character, plus the
3895           * NUL at the end. This may cause the string pointer to
3896           * move, so re-find it. */
3897            
3898 40         len = d - (U8*)SvPVX_const(dest);
3899 40         SvCUR_set(dest, len);
3900 40         len = sv_utf8_upgrade_flags_grow(dest,
3901           SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3902           (send -s) * 2 + 1);
3903 40         d = (U8*)SvPVX(dest) + len;
3904            
3905           /* Now process the remainder of the source, converting to
3906           * upper and UTF-8. If a resulting byte is invariant in
3907           * UTF-8, output it as-is, otherwise convert to UTF-8 and
3908           * append it to the output. */
3909 680 100       for (; s < send; s++) {
3910 640         (void) _to_upper_title_latin1(*s, d, &len, 'S');
3911 640         d += len;
3912           }
3913            
3914           /* Here have processed the whole source; no need to continue
3915           * with the outer loop. Each character has been converted
3916           * to upper case and converted to UTF-8 */
3917            
3918           break;
3919           } /* End of processing all latin1-style chars */
3920           } /* End of processing all chars */
3921           } /* End of source is not empty */
3922            
3923 467560 50       if (source != dest) {
3924 467560         *d = '\0'; /* Here d points to 1 after last char, add NUL */
3925 467560         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3926           }
3927           } /* End of isn't utf8 */
3928 481006 50       if (dest != source && SvTAINTED(source))
    100        
    50        
3929 0 0       SvTAINT(dest);
    0        
    0        
3930 481006 100       SvSETMAGIC(dest);
3931 481006         RETURN;
3932           }
3933            
3934 4993920         PP(pp_lc)
3935 4993920 100       {
3936           dVAR;
3937 4993920         dSP;
3938 4993920         SV *source = TOPs;
3939           STRLEN len;
3940           STRLEN min;
3941           SV *dest;
3942           const U8 *s;
3943           U8 *d;
3944            
3945 2498702         SvGETMAGIC(source);
3946            
3947 4993920 100       if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
    50        
    0        
    0        
3948 12044 50       && SvTEMP(source) && !DO_UTF8(source)) {
    0        
    0        
3949            
3950           /* We can convert in place, as lowercasing anything in the latin1 range
3951           * (or else DO_UTF8 would have been on) doesn't lengthen it */
3952           dest = source;
3953 0 0       s = d = (U8*)SvPV_force_nomg(source, len);
3954 0         min = len + 1;
3955 4993920 100       } else {
3956 4993920         dTARGET;
3957            
3958           dest = TARG;
3959            
3960           /* The old implementation would copy source into TARG at this point.
3961           This had the side effect that if source was undef, TARG was now
3962           an undefined SV with PADTMP set, and they don't warn inside
3963           sv_2pv_flags(). However, we're now getting the PV direct from
3964           source, which doesn't have PADTMP set, so it would warn. Hence the
3965           little games. */
3966            
3967 4993920 100       if (SvOK(source)) {
    50        
    50        
3968 4993914 100       s = (const U8*)SvPV_nomg_const(source, len);
3969           } else {
3970 6 100       if (ckWARN(WARN_UNINITIALIZED))
3971 4         report_uninit(source);
3972           s = (const U8*)"";
3973 6         len = 0;
3974           }
3975 4993920         min = len + 1;
3976            
3977 2511710         SvUPGRADE(dest, SVt_PV);
3978 4993920 100       d = (U8*)SvGROW(dest, min);
    100        
3979 4993920         (void)SvPOK_only(dest);
3980            
3981 4993920         SETs(dest);
3982           }
3983            
3984           /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3985           to check DO_UTF8 again here. */
3986            
3987 4993920 100       if (DO_UTF8(source)) {
    100        
3988 13364         const U8 *const send = s + len;
3989           U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3990 13364         bool tainted = FALSE;
3991            
3992 202838 100       while (s < send) {
3993 182798         const STRLEN u = UTF8SKIP(s);
3994           STRLEN ulen;
3995            
3996 182798         _to_utf8_lower_flags(s, tmpbuf, &ulen,
3997           cBOOL(IN_LOCALE_RUNTIME), &tainted);
3998            
3999           /* Here is where we would do context-sensitive actions. See the
4000           * commit message for this comment for why there isn't any */
4001            
4002 182792 100       if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
    100        
4003            
4004           /* If the eventually required minimum size outgrows the
4005           * available space, we need to grow. */
4006 6         const UV o = d - (U8*)SvPVX_const(dest);
4007            
4008           /* If someone lowercases one million U+0130s we SvGROW() one
4009           * million times. Or we could try guessing how much to
4010           * allocate without allocating too much. Such is life.
4011           * Another option would be to grow an extra byte or two more
4012           * each time we need to grow, which would cut down the million
4013           * to 500K, with little waste */
4014 6 50       SvGROW(dest, min);
    50        
4015 6         d = (U8*)SvPVX(dest) + o;
4016           }
4017            
4018           /* Copy the newly lowercased letter to the output buffer we're
4019           * building */
4020 182792         Copy(tmpbuf, d, ulen, U8);
4021 182792         d += ulen;
4022 182792         s += u;
4023           } /* End of looping through the source string */
4024 13358         SvUTF8_on(dest);
4025 13358         *d = '\0';
4026 13358         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4027 13358 100       if (tainted) {
4028 514         TAINT;
4029 514 50       SvTAINTED_on(dest);
4030           }
4031           } else { /* Not utf8 */
4032 4980556 100       if (len) {
4033 4973922         const U8 *const send = s + len;
4034            
4035           /* Use locale casing if in locale; regular style if not treating
4036           * latin1 as having case; otherwise the latin1 casing. Do the
4037           * whole thing in a tight loop, for speed, */
4038 4973922 100       if (IN_LOCALE_RUNTIME) {
4039 542         TAINT;
4040 542 50       SvTAINTED_on(dest);
4041 1155 100       for (; s < send; d++, s++)
4042 884         *d = toLOWER_LC(*s);
4043           }
4044 4973380 100       else if (! IN_UNI_8_BIT) {
    100        
4045 73783468 100       for (; s < send; d++, s++) {
4046 71297022 100       *d = toLOWER(*s);
4047           }
4048           }
4049           else {
4050 161766 100       for (; s < send; d++, s++) {
4051 159362         *d = toLOWER_LATIN1(*s);
4052           }
4053           }
4054           }
4055 4980556 50       if (source != dest) {
4056 4980556         *d = '\0';
4057 4980556         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4058           }
4059           }
4060 4993914 50       if (dest != source && SvTAINTED(source))
    100        
    50        
4061 0 0       SvTAINT(dest);
    0        
    0        
4062 4993914 100       SvSETMAGIC(dest);
4063 4993914         RETURN;
4064           }
4065            
4066 649042         PP(pp_quotemeta)
4067           {
4068 649042         dVAR; dSP; dTARGET;
4069 649042         SV * const sv = TOPs;
4070           STRLEN len;
4071 649042 100       const char *s = SvPV_const(sv,len);
4072            
4073 649042         SvUTF8_off(TARG); /* decontaminate */
4074 972082 100       if (len) {
    100        
4075           char *d;
4076 378158         SvUPGRADE(TARG, SVt_PV);
4077 647160 100       SvGROW(TARG, (len * 2) + 1);
    100        
4078 647160         d = SvPVX(TARG);
4079 647160 100       if (DO_UTF8(sv)) {
    50        
4080 6230 100       while (len) {
4081 3930         STRLEN ulen = UTF8SKIP(s);
4082           bool to_quote = FALSE;
4083            
4084 3930 100       if (UTF8_IS_INVARIANT(*s)) {
4085 2720 100       if (_isQUOTEMETA(*s)) {
4086           to_quote = TRUE;
4087           }
4088           }
4089 1210 100       else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4090            
4091           /* In locale, we quote all non-ASCII Latin1 chars.
4092           * Otherwise use the quoting rules */
4093 1040 100       if (IN_LOCALE_RUNTIME
4094 1036 50       || _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
    100        
4095           {
4096           to_quote = TRUE;
4097           }
4098           }
4099 170 50       else if (is_QUOTEMETA_high(s)) {
    100        
    50        
    50        
    50        
    50        
    0        
    100        
    50        
    50        
    50        
    50        
    0        
    0        
    0        
    0        
    0        
    0        
    100        
    50        
    0        
    0        
    50        
    0        
    100        
    50        
    50        
    50        
    50        
    50        
    50        
    0        
    50        
    0        
    0        
    0        
    50        
    0        
    100        
4100           to_quote = TRUE;
4101           }
4102            
4103 3930 100       if (to_quote) {
4104 1390         *d++ = '\\';
4105           }
4106 3930 50       if (ulen > len)
4107 0         ulen = len;
4108 3930         len -= ulen;
4109 12325 100       while (ulen--)
4110 5280         *d++ = *s++;
4111           }
4112 2300         SvUTF8_on(TARG);
4113           }
4114 644860 100       else if (IN_UNI_8_BIT) {
    50        
4115 1308290 100       while (len--) {
4116 1247266 100       if (_isQUOTEMETA(*s))
4117 203232         *d++ = '\\';
4118 1247266         *d++ = *s++;
4119           }
4120           }
4121           else {
4122           /* For non UNI_8_BIT (and hence in locale) just quote all \W
4123           * including everything above ASCII */
4124 26894936 100       while (len--) {
4125 26311100 100       if (!isWORDCHAR_A(*s))
4126 5152050         *d++ = '\\';
4127 26311100         *d++ = *s++;
4128           }
4129           }
4130 647160         *d = '\0';
4131 647160         SvCUR_set(TARG, d - SvPVX_const(TARG));
4132 647160         (void)SvPOK_only_UTF8(TARG);
4133           }
4134           else
4135 1882         sv_setpvn(TARG, s, len);
4136 649042 50       SETTARG;
4137 649042         RETURN;
4138           }
4139            
4140 10016         PP(pp_fc)
4141 20032 100       {
    100        
4142           dVAR;
4143 10016         dTARGET;
4144 10016         dSP;
4145 10016         SV *source = TOPs;
4146           STRLEN len;
4147           STRLEN min;
4148           SV *dest;
4149           const U8 *s;
4150           const U8 *send;
4151           U8 *d;
4152           U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4153           const bool full_folding = TRUE;
4154 10016 100       const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4155 10016         | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
4156            
4157           /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4158           * You are welcome(?) -Hugmeir
4159           */
4160            
4161 5014         SvGETMAGIC(source);
4162            
4163           dest = TARG;
4164            
4165 10016 100       if (SvOK(source)) {
    50        
    50        
4166 10012 100       s = (const U8*)SvPV_nomg_const(source, len);
4167           } else {
4168 4 100       if (ckWARN(WARN_UNINITIALIZED))
4169 2         report_uninit(source);
4170           s = (const U8*)"";
4171 4         len = 0;
4172           }
4173            
4174 10016         min = len + 1;
4175            
4176 5140         SvUPGRADE(dest, SVt_PV);
4177 10016 100       d = (U8*)SvGROW(dest, min);
    100        
4178 10016         (void)SvPOK_only(dest);
4179            
4180 10016         SETs(dest);
4181            
4182 10016         send = s + len;
4183 10016 100       if (DO_UTF8(source)) { /* UTF-8 flagged string. */
    100        
4184 6154         bool tainted = FALSE;
4185 17773 100       while (s < send) {
4186 8542         const STRLEN u = UTF8SKIP(s);
4187           STRLEN ulen;
4188            
4189 8542         _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
4190            
4191 8542 100       if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
    100        
4192 24         const UV o = d - (U8*)SvPVX_const(dest);
4193 24 50       SvGROW(dest, min);
    50        
4194 24         d = (U8*)SvPVX(dest) + o;
4195           }
4196            
4197 8542         Copy(tmpbuf, d, ulen, U8);
4198 8542         d += ulen;
4199 8542         s += u;
4200           }
4201 6154         SvUTF8_on(dest);
4202 6154 100       if (tainted) {
4203 512         TAINT;
4204 512 50       SvTAINTED_on(dest);
4205           }
4206           } /* Unflagged string */
4207 3862 100       else if (len) {
4208 3854 100       if ( IN_LOCALE_RUNTIME ) { /* Under locale */
4209 512         TAINT;
4210 512 50       SvTAINTED_on(dest);
4211 768 100       for (; s < send; d++, s++)
4212 512         *d = toFOLD_LC(*s);
4213           }
4214 3342 100       else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
    100        
4215 7962 100       for (; s < send; d++, s++)
4216 6562 100       *d = toFOLD(*s);
4217           }
4218           else {
4219           /* For ASCII and the Latin-1 range, there's only two troublesome
4220           * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4221           * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4222           * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4223           * For the rest, the casefold is their lowercase. */
4224 961 100       for (; s < send; d++, s++) {
4225 696 100       if (*s == MICRO_SIGN) {
4226           /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4227           * which is outside of the latin-1 range. There's a couple
4228           * of ways to deal with this -- khw discusses them in
4229           * pp_lc/uc, so go there :) What we do here is upgrade what
4230           * we had already casefolded, then enter an inner loop that
4231           * appends the rest of the characters as UTF-8. */
4232 6         len = d - (U8*)SvPVX_const(dest);
4233 6         SvCUR_set(dest, len);
4234 6         len = sv_utf8_upgrade_flags_grow(dest,
4235           SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4236           /* The max expansion for latin1
4237           * chars is 1 byte becomes 2 */
4238           (send -s) * 2 + 1);
4239 6         d = (U8*)SvPVX(dest) + len;
4240            
4241 6         Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4242 6         d += small_mu_len;
4243 6         s++;
4244 14 100       for (; s < send; s++) {
4245           STRLEN ulen;
4246 8         UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4247 8 100       if NATIVE_IS_INVARIANT(fc) {
4248 6 50       if (full_folding
4249 6         && *s == LATIN_SMALL_LETTER_SHARP_S)
4250           {
4251 0         *d++ = 's';
4252 0         *d++ = 's';
4253           }
4254           else
4255 6         *d++ = (U8)fc;
4256           }
4257           else {
4258 2         Copy(tmpbuf, d, ulen, U8);
4259 2         d += ulen;
4260           }
4261           }
4262           break;
4263           }
4264 690 100       else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4265           /* Under full casefolding, LATIN SMALL LETTER SHARP S
4266           * becomes "ss", which may require growing the SV. */
4267 36 100       if (SvLEN(dest) < ++min) {
4268 2         const UV o = d - (U8*)SvPVX_const(dest);
4269 2 50       SvGROW(dest, min);
    50        
4270 2         d = (U8*)SvPVX(dest) + o;
4271           }
4272 36         *(d)++ = 's';
4273 36         *d = 's';
4274           }
4275           else { /* If it's not one of those two, the fold is their lower
4276           case */
4277 654         *d = toLOWER_LATIN1(*s);
4278           }
4279           }
4280           }
4281           }
4282 10016         *d = '\0';
4283 10016         SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4284            
4285 10016 100       if (SvTAINTED(source))
    50        
4286 0 0       SvTAINT(dest);
    0        
    0        
4287 10016 100       SvSETMAGIC(dest);
4288 10016         RETURN;
4289           }
4290            
4291           /* Arrays. */
4292            
4293 687912         PP(pp_aslice)
4294           {
4295 687912         dVAR; dSP; dMARK; dORIGMARK;
4296 687912         AV *const av = MUTABLE_AV(POPs);
4297 687912 100       const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
    100        
    50        
4298            
4299 687912 50       if (SvTYPE(av) == SVt_PVAV) {
4300 687912         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4301           bool can_preserve = FALSE;
4302            
4303 687912 100       if (localizing) {
4304           MAGIC *mg;
4305           HV *stash;
4306            
4307 12 100       can_preserve = SvCANEXISTDELETE(av);
    100        
    50        
    50        
    50        
    50        
4308           }
4309            
4310 687912 100       if (lval && localizing) {
    100        
4311           SV **svp;
4312           SSize_t max = -1;
4313 36 100       for (svp = MARK + 1; svp <= SP; svp++) {
4314 24 50       const SSize_t elem = SvIV(*svp);
4315 24 50       if (elem > max)
4316           max = elem;
4317           }
4318 12 100       if (max > AvMAX(av))
4319 343958         av_extend(av, max);
4320           }
4321            
4322 2696648 100       while (++MARK <= SP) {
4323           SV **svp;
4324 2008736 100       SSize_t elem = SvIV(*MARK);
4325           bool preeminent = TRUE;
4326            
4327 2008736 100       if (localizing && can_preserve) {
    50        
4328           /* If we can determine whether the element exist,
4329           * Try to preserve the existenceness of a tied array
4330           * element by using EXISTS and DELETE if possible.
4331           * Fallback to FETCH and STORE otherwise. */
4332 24         preeminent = av_exists(av, elem);
4333           }
4334            
4335 2008736         svp = av_fetch(av, elem, lval);
4336 2008736 100       if (lval) {
4337 944722 50       if (!svp || !*svp)
    50        
4338 0         DIE(aTHX_ PL_no_aelem, elem);
4339 944722 100       if (localizing) {
4340 24 50       if (preeminent)
4341 0         save_aelem(av, elem, svp);
4342           else
4343 24         SAVEADELETE(av, elem);
4344           }
4345           }
4346 2008736 100       *MARK = svp ? *svp : &PL_sv_undef;
4347           }
4348           }
4349 687912 100       if (GIMME != G_ARRAY) {
    100        
4350 176358         MARK = ORIGMARK;
4351 176358 100       *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4352           SP = MARK;
4353           }
4354 687912         RETURN;
4355           }
4356            
4357           /* Smart dereferencing for keys, values and each */
4358 2016         PP(pp_rkeys)
4359 2016 50       {
4360           dVAR;
4361 2016         dSP;
4362 2016         dPOPss;
4363            
4364 1008         SvGETMAGIC(sv);
4365            
4366 2016 100       if (
4367 2016         !SvROK(sv)
4368 4992 100       || (sv = SvRV(sv),
    100        
4369 1998         (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4370 1992 100       || SvOBJECT(sv)
4371           )
4372           ) {
4373 34         DIE(aTHX_
4374           "Type of argument to %s must be unblessed hashref or arrayref",
4375 34         PL_op_desc[PL_op->op_type] );
4376           }
4377            
4378 1982 100       if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
    100        
4379 3         DIE(aTHX_
4380           "Can't modify %s in %s",
4381 4         PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4382           );
4383            
4384           /* Delegate to correct function for op type */
4385 1980         PUSHs(sv);
4386 1980 100       if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4387 1728 100       return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4388           }
4389           else {
4390 1242         return (SvTYPE(sv) == SVt_PVHV)
4391           ? Perl_pp_each(aTHX)
4392 252 100       : Perl_pp_aeach(aTHX);
4393           }
4394           }
4395            
4396 270         PP(pp_aeach)
4397 206 50       {
4398           dVAR;
4399 270         dSP;
4400 270         AV *array = MUTABLE_AV(POPs);
4401 270 50       const I32 gimme = GIMME_V;
4402 270         IV *iterp = Perl_av_iter_p(aTHX_ array);
4403 270         const IV current = (*iterp)++;
4404            
4405 270 100       if (current > av_len(array)) {
4406 64         *iterp = 0;
4407 64 100       if (gimme == G_SCALAR)
4408 32         RETPUSHUNDEF;
4409           else
4410 32         RETURN;
4411           }
4412            
4413 103         EXTEND(SP, 2);
4414 206         mPUSHi(current);
4415 206 100       if (gimme == G_ARRAY) {
4416 116         SV **const element = av_fetch(array, current, 0);
4417 116 50       PUSHs(element ? *element : &PL_sv_undef);
4418           }
4419 238         RETURN;
4420           }
4421            
4422 172         PP(pp_akeys)
4423           {
4424           dVAR;
4425 172         dSP;
4426 172         AV *array = MUTABLE_AV(POPs);
4427 172 50       const I32 gimme = GIMME_V;
4428            
4429 172         *Perl_av_iter_p(aTHX_ array) = 0;
4430            
4431 172 100       if (gimme == G_SCALAR) {
4432 36         dTARGET;
4433 36 50       PUSHi(av_len(array) + 1);
4434           }
4435 230         else if (gimme == G_ARRAY) {
4436 94         IV n = Perl_av_len(aTHX_ array);
4437           IV i;
4438            
4439 47         EXTEND(SP, n + 1);
4440            
4441 94 100       if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4442 203 100       for (i = 0; i <= n; i++) {
4443 174         mPUSHi(i);
4444           }
4445           }
4446           else {
4447 126 100       for (i = 0; i <= n; i++) {
4448 108         SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4449 108 50       PUSHs(elem ? *elem : &PL_sv_undef);
4450           }
4451           }
4452           }
4453 172         RETURN;
4454           }
4455            
4456           /* Associative arrays. */
4457            
4458 2056792         PP(pp_each)
4459 2056792 50       {
4460           dVAR;
4461 2056792         dSP;
4462 2056792         HV * hash = MUTABLE_HV(POPs);
4463           HE *entry;
4464 2056792 100       const I32 gimme = GIMME_V;
4465            
4466 2056792         PUTBACK;
4467           /* might clobber stack_sp */
4468 2056792         entry = hv_iternext(hash);
4469 2056792         SPAGAIN;
4470            
4471 943076         EXTEND(SP, 2);
4472 2056792 100       if (entry) {
4473 1996110         SV* const sv = hv_iterkeysv(entry);
4474 1996110         PUSHs(sv); /* won't clobber stack_sp */
4475 1996110 100       if (gimme == G_ARRAY) {
4476           SV *val;
4477 1550566         PUTBACK;
4478           /* might clobber stack_sp */
4479 1550566         val = hv_iterval(hash, entry);
4480 1550566         SPAGAIN;
4481 1550566         PUSHs(val);
4482           }
4483           }
4484 60682 100       else if (gimme == G_SCALAR)
4485 958         RETPUSHUNDEF;
4486            
4487 2056313         RETURN;
4488           }
4489            
4490           STATIC OP *
4491 50         S_do_delete_local(pTHX)
4492           {
4493           dVAR;
4494 50         dSP;
4495 50 100       const I32 gimme = GIMME_V;
4496           const MAGIC *mg;
4497           HV *stash;
4498 50         const bool sliced = !!(PL_op->op_private & OPpSLICE);
4499 50 100       SV *unsliced_keysv = sliced ? NULL : POPs;
4500 50         SV * const osv = POPs;
4501 50 100       SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
4502 50         dORIGMARK;
4503 100         const bool tied = SvRMAGICAL(osv)
4504 50 100       && mg_find((const SV *)osv, PERL_MAGIC_tied);
    100        
4505 50 100       const bool can_preserve = SvCANEXISTDELETE(osv);
    100        
    50        
    50        
    50        
    50        
4506 50         const U32 type = SvTYPE(osv);
4507 50 100       SV ** const end = sliced ? SP : &unsliced_keysv;
4508            
4509 50 100       if (type == SVt_PVHV) { /* hash element */
4510           HV * const hv = MUTABLE_HV(osv);
4511 66 100       while (++MARK <= end) {
4512 36         SV * const keysv = *MARK;
4513 36         SV *sv = NULL;
4514           bool preeminent = TRUE;
4515 36 50       if (can_preserve)
4516 36         preeminent = hv_exists_ent(hv, keysv, 0);
4517 36 100       if (tied) {
4518 10         HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4519 10 50       if (he)
4520 10         sv = HeVAL(he);
4521           else
4522           preeminent = FALSE;
4523           }
4524           else {
4525 26         sv = hv_delete_ent(hv, keysv, 0, 0);
4526 26 100       if (preeminent)
4527 10 50       SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4528           }
4529 36 100       if (preeminent) {
4530 16 50       if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4531 16         save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4532 16 100       if (tied) {
4533 6         *MARK = sv_mortalcopy(sv);
4534 6         mg_clear(sv);
4535           } else
4536 10         *MARK = sv;
4537           }
4538           else {
4539 20         SAVEHDELETE(hv, keysv);
4540 28         *MARK = &PL_sv_undef;
4541           }
4542           }
4543           }
4544 20 50       else if (type == SVt_PVAV) { /* array element */
4545 20 50       if (PL_op->op_flags & OPf_SPECIAL) {
4546           AV * const av = MUTABLE_AV(osv);
4547 62 100       while (++MARK <= end) {
4548 42 50       SSize_t idx = SvIV(*MARK);
4549 42         SV *sv = NULL;
4550           bool preeminent = TRUE;
4551 42 50       if (can_preserve)
4552 42         preeminent = av_exists(av, idx);
4553 42 100       if (tied) {
4554 10         SV **svp = av_fetch(av, idx, 1);
4555 10 50       if (svp)
4556 10         sv = *svp;
4557           else
4558           preeminent = FALSE;
4559           }
4560           else {
4561 32         sv = av_delete(av, idx, 0);
4562 32 100       if (preeminent)
4563 6 50       SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4564           }
4565 42 100       if (preeminent) {
4566 12         save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4567 12 100       if (tied) {
4568 6         *MARK = sv_mortalcopy(sv);
4569 6         mg_clear(sv);
4570           } else
4571 6         *MARK = sv;
4572           }
4573           else {
4574 30         SAVEADELETE(av, idx);
4575 36         *MARK = &PL_sv_undef;
4576           }
4577           }
4578           }
4579           else
4580 0         DIE(aTHX_ "panic: avhv_delete no longer supported");
4581           }
4582           else
4583 0         DIE(aTHX_ "Not a HASH reference");
4584 50 100       if (sliced) {
4585 12 100       if (gimme == G_VOID)
4586 4         SP = ORIGMARK;
4587 8 50       else if (gimme == G_SCALAR) {
4588 0         MARK = ORIGMARK;
4589 0 0       if (SP > MARK)
4590 0         *++MARK = *SP;
4591           else
4592 0         *++MARK = &PL_sv_undef;
4593           SP = MARK;
4594           }
4595           }
4596 38 100       else if (gimme != G_VOID)
4597 12         PUSHs(unsliced_keysv);
4598            
4599 50         RETURN;
4600           }
4601            
4602 11475060         PP(pp_delete)
4603           {
4604           dVAR;
4605 11475060         dSP;
4606           I32 gimme;
4607           I32 discard;
4608            
4609 11475060 100       if (PL_op->op_private & OPpLVAL_INTRO)
4610 50         return do_delete_local();
4611            
4612 11475010 100       gimme = GIMME_V;
4613 11475010 100       discard = (gimme == G_VOID) ? G_DISCARD : 0;
4614            
4615 11475010 100       if (PL_op->op_private & OPpSLICE) {
4616 20278         dMARK; dORIGMARK;
4617 20278         HV * const hv = MUTABLE_HV(POPs);
4618 20278         const U32 hvtype = SvTYPE(hv);
4619 20278 100       if (hvtype == SVt_PVHV) { /* hash element */
4620 85922 100       while (++MARK <= SP) {
4621 65648         SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4622 65648 100       *MARK = sv ? sv : &PL_sv_undef;
4623           }
4624           }
4625 4 50       else if (hvtype == SVt_PVAV) { /* array element */
4626 4 50       if (PL_op->op_flags & OPf_SPECIAL) {
4627 12 100       while (++MARK <= SP) {
4628 8 100       SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4629 8 100       *MARK = sv ? sv : &PL_sv_undef;
4630           }
4631           }
4632           }
4633           else
4634 0         DIE(aTHX_ "Not a HASH reference");
4635 20278 100       if (discard)
4636 19136         SP = ORIGMARK;
4637 1142 100       else if (gimme == G_SCALAR) {
4638 2         MARK = ORIGMARK;
4639 2 50       if (SP > MARK)
4640 0         *++MARK = *SP;
4641           else
4642 2         *++MARK = &PL_sv_undef;
4643           SP = MARK;
4644           }
4645           }
4646           else {
4647 11454732         SV *keysv = POPs;
4648 11454732         HV * const hv = MUTABLE_HV(POPs);
4649           SV *sv = NULL;
4650 11454732 100       if (SvTYPE(hv) == SVt_PVHV)
4651 11454626         sv = hv_delete_ent(hv, keysv, discard, 0);
4652 106 50       else if (SvTYPE(hv) == SVt_PVAV) {
4653 106 50       if (PL_op->op_flags & OPf_SPECIAL)
4654 106 100       sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4655           else
4656 0         DIE(aTHX_ "panic: avhv_delete no longer supported");
4657           }
4658           else
4659 0         DIE(aTHX_ "Not a HASH reference");
4660 11454722 100       if (!sv)
4661           sv = &PL_sv_undef;
4662 11454722 100       if (!discard)
4663 3918434         PUSHs(sv);
4664           }
4665 11475025         RETURN;
4666           }
4667            
4668 44576605         PP(pp_exists)
4669           {
4670           dVAR;
4671 44576605         dSP;
4672           SV *tmpsv;
4673           HV *hv;
4674            
4675 44576605 100       if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4676           GV *gv;
4677 247536         SV * const sv = POPs;
4678 247536         CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4679 247536 100       if (cv)
4680 9156         RETPUSHYES;
4681 238380 100       if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
    50        
    100        
    50        
4682 0         RETPUSHYES;
4683 238380         RETPUSHNO;
4684           }
4685 44329069         tmpsv = POPs;
4686 44329069         hv = MUTABLE_HV(POPs);
4687 44329069 100       if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
4688 43885775 100       if (hv_exists_ent(hv, tmpsv, 0))
4689 32478562         RETPUSHYES;
4690           }
4691 443294 50       else if (SvTYPE(hv) == SVt_PVAV) {
4692 443294 50       if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4693 443294 100       if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
    100        
4694 73890         RETPUSHYES;
4695           }
4696           }
4697           else {
4698 0         DIE(aTHX_ "Not a HASH reference");
4699           }
4700 28209544         RETPUSHNO;
4701           }
4702            
4703 2291829         PP(pp_hslice)
4704           {
4705 2291829         dVAR; dSP; dMARK; dORIGMARK;
4706 2291829         HV * const hv = MUTABLE_HV(POPs);
4707 2291829 100       const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
    100        
    50        
4708 2291829         const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4709           bool can_preserve = FALSE;
4710            
4711 2291829 100       if (localizing) {
4712           MAGIC *mg;
4713           HV *stash;
4714            
4715 1363839 100       if (SvCANEXISTDELETE(hv))
    50        
    0        
    0        
    0        
    0        
4716           can_preserve = TRUE;
4717           }
4718            
4719 16912221 100       while (++MARK <= SP) {
4720 14620392         SV * const keysv = *MARK;
4721           SV **svp;
4722           HE *he;
4723           bool preeminent = TRUE;
4724            
4725 14620392 100       if (localizing && can_preserve) {
    50        
4726           /* If we can determine whether the element exist,
4727           * try to preserve the existenceness of a tied hash
4728           * element by using EXISTS and DELETE if possible.
4729           * Fallback to FETCH and STORE otherwise. */
4730 1719084         preeminent = hv_exists_ent(hv, keysv, 0);
4731           }
4732            
4733 14620392 100       he = hv_fetch_ent(hv, keysv, lval, 0);
4734 14620392 100       svp = he ? &HeVAL(he) : NULL;
4735            
4736 14620392 100       if (lval) {
4737 12578912 50       if (!svp || !*svp || *svp == &PL_sv_undef) {
    50        
    50        
4738 0         DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4739           }
4740 12578912 100       if (localizing) {
4741 1719084 100       if (HvNAME_get(hv) && isGV(*svp))
    100        
    50        
    0        
    50        
    50        
    50        
    100        
4742 4         save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4743 1719080 100       else if (preeminent)
4744 1709870         save_helem_flags(hv, keysv, svp,
4745           (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4746           else
4747 9210         SAVEHDELETE(hv, keysv);
4748           }
4749           }
4750 14620392 100       *MARK = svp && *svp ? *svp : &PL_sv_undef;
    50        
4751           }
4752 2291829 100       if (GIMME != G_ARRAY) {
    100        
4753 7272         MARK = ORIGMARK;
4754 7272 100       *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4755           SP = MARK;
4756           }
4757 2291829         RETURN;
4758           }
4759            
4760           /* List operators. */
4761            
4762 32271180         PP(pp_list)
4763           {
4764 32271180         dVAR; dSP; dMARK;
4765 32271180 100       if (GIMME != G_ARRAY) {
    100        
4766 21206548 100       if (++MARK <= SP)
4767 21206530         *MARK = *SP; /* unwanted list, return last item */
4768           else
4769 10639569         *MARK = &PL_sv_undef;
4770           SP = MARK;
4771           }
4772 32271180         RETURN;
4773           }
4774            
4775 1975811         PP(pp_lslice)
4776           {
4777           dVAR;
4778           dSP;
4779 1975811         SV ** const lastrelem = PL_stack_sp;
4780 1975811         SV ** const lastlelem = PL_stack_base + POPMARK;
4781 1975811         SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4782 1975811         SV ** const firstrelem = lastlelem + 1;
4783           I32 is_something_there = FALSE;
4784 1975811         const U8 mod = PL_op->op_flags & OPf_MOD;
4785            
4786 1975811         const I32 max = lastrelem - lastlelem;
4787           SV **lelem;
4788            
4789 1975811 100       if (GIMME != G_ARRAY) {
    100        
4790 1938461 100       I32 ix = SvIV(*lastlelem);
4791 1938461 100       if (ix < 0)
4792 4704         ix += max;
4793 1938461 100       if (ix < 0 || ix >= max)
4794 1252         *firstlelem = &PL_sv_undef;
4795           else
4796 1937209         *firstlelem = firstrelem[ix];
4797           SP = firstlelem;
4798 1938461         RETURN;
4799           }
4800            
4801 37350 100       if (max == 0) {
4802 224         SP = firstlelem - 1;
4803 224         RETURN;
4804           }
4805            
4806 102019 100       for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4807 83456 100       I32 ix = SvIV(*lelem);
4808 83456 100       if (ix < 0)
4809 8         ix += max;
4810 83456 100       if (ix < 0 || ix >= max)
4811 36         *lelem = &PL_sv_undef;
4812           else {
4813           is_something_there = TRUE;
4814 83420 50       if (!(*lelem = firstrelem[ix]))
4815 0         *lelem = &PL_sv_undef;
4816 83420 100       else if (mod && SvPADTMP(*lelem) && !IS_PADGV(*lelem))
    100        
4817 2384         *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
4818           }
4819           }
4820 37126 100       if (is_something_there)
4821           SP = lastlelem;
4822           else
4823 16         SP = firstlelem - 1;
4824 1008567         RETURN;
4825           }
4826            
4827 10282641         PP(pp_anonlist)
4828           {
4829 10282641         dVAR; dSP; dMARK;
4830 10282641         const I32 items = SP - MARK;
4831 10282641         SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4832           SP = MARK;
4833 10282637 50       mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
    100        
4834           ? newRV_noinc(av) : av);
4835 10282637         RETURN;
4836           }
4837            
4838 12556088         PP(pp_anonhash)
4839           {
4840 12556088         dVAR; dSP; dMARK; dORIGMARK;
4841 12556088         HV* const hv = newHV();
4842 12556088 50       SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
4843           ? newRV_noinc(MUTABLE_SV(hv))
4844           : MUTABLE_SV(hv) );
4845            
4846 30970021 100       while (MARK < SP) {
4847           SV * const key =
4848 12142188 50       (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
4849           SV *val;
4850 18199243 100       if (MARK < SP)
    100        
4851           {
4852 12142178         MARK++;
4853 6207111         SvGETMAGIC(*MARK);
4854 12142174         val = newSV(0);
4855 12142174         sv_setsv(val, *MARK);
4856           }
4857           else
4858           {
4859 10         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4860 10         val = newSV(0);
4861           }
4862 12142184         (void)hv_store_ent(hv,key,val,0);
4863           }
4864 12556084         SP = ORIGMARK;
4865 12556084 50       XPUSHs(retval);
4866 12556084         RETURN;
4867           }
4868            
4869           static AV *
4870 136         S_deref_plain_array(pTHX_ AV *ary)
4871 136 50       {
4872 136 50       if (SvTYPE(ary) == SVt_PVAV) return ary;
4873 68         SvGETMAGIC((SV *)ary);
4874 136 100       if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
    100        
4875 16         Perl_die(aTHX_ "Not an ARRAY reference");
4876 120 100       else if (SvOBJECT(SvRV(ary)))
4877 6         Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4878 114         return (AV *)SvRV(ary);
4879           }
4880            
4881           #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4882           # define DEREF_PLAIN_ARRAY(ary) \
4883           ({ \
4884           AV *aRrRay = ary; \
4885           SvTYPE(aRrRay) == SVt_PVAV \
4886           ? aRrRay \
4887           : S_deref_plain_array(aTHX_ aRrRay); \
4888           })
4889           #else
4890           # define DEREF_PLAIN_ARRAY(ary) \
4891           ( \
4892           PL_Sv = (SV *)(ary), \
4893           SvTYPE(PL_Sv) == SVt_PVAV \
4894           ? (AV *)PL_Sv \
4895           : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
4896           )
4897           #endif
4898            
4899 651486         PP(pp_splice)
4900           {
4901 651486         dVAR; dSP; dMARK; dORIGMARK;
4902 651486         int num_args = (SP - MARK);
4903 651486 100       AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4904           SV **src;
4905           SV **dst;
4906           SSize_t i;
4907           SSize_t offset;
4908           SSize_t length;
4909           SSize_t newlen;
4910           SSize_t after;
4911           SSize_t diff;
4912 651482 100       const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4913            
4914 651482 100       if (mg) {
4915 1672 50       return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
    100        
4916 836         GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4917 836         sp - mark);
4918           }
4919            
4920 650646         SP++;
4921            
4922 650646 100       if (++MARK < SP) {
4923 635682 100       offset = i = SvIV(*MARK);
4924 635682 100       if (offset < 0)
4925 152914         offset += AvFILLp(ary) + 1;
4926 635682 50       if (offset < 0)
4927 0         DIE(aTHX_ PL_no_aelem, i);
4928 635682 100       if (++MARK < SP) {
4929 519478 100       length = SvIVx(*MARK++);
4930 519478 100       if (length < 0) {
4931 4         length += AvFILLp(ary) - offset + 1;
4932 4 50       if (length < 0)
4933           length = 0;
4934           }
4935           }
4936           else
4937 116204         length = AvMAX(ary) + 1; /* close enough to infinity */
4938           }
4939           else {
4940           offset = 0;
4941 14964         length = AvMAX(ary) + 1;
4942           }
4943 650646 100       if (offset > AvFILLp(ary) + 1) {
4944 12 100       if (num_args > 2)
4945 8         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4946 12         offset = AvFILLp(ary) + 1;
4947           }
4948 650646         after = AvFILLp(ary) + 1 - (offset + length);
4949 650646 100       if (after < 0) { /* not that much array */
4950 143056         length += after; /* offset+length now in array */
4951           after = 0;
4952 143056 50       if (!AvALLOC(ary))
4953 0         av_extend(ary, 0);
4954           }
4955            
4956           /* At this point, MARK .. SP-1 is our new LIST */
4957            
4958 650646         newlen = SP - MARK;
4959 650646         diff = newlen - length;
4960 650646 100       if (newlen && !AvREAL(ary) && AvREIFY(ary))
    100        
    50        
4961 244         av_reify(ary);
4962            
4963           /* make new elements SVs now: avoid problems if they're from the array */
4964 816752 100       for (dst = MARK, i = newlen; i; i--) {
4965 166106         SV * const h = *dst;
4966 166106         *dst++ = newSVsv(h);
4967           }
4968            
4969 650646 100       if (diff < 0) { /* shrinking the area */
4970           SV **tmparyval = NULL;
4971 472572 100       if (newlen) {
4972 5544 50       Newx(tmparyval, newlen, SV*); /* so remember insertion */
4973 5544 50       Copy(MARK, tmparyval, newlen, SV*);
4974           }
4975            
4976 472572         MARK = ORIGMARK + 1;
4977 472572 100       if (GIMME == G_ARRAY) { /* copy return vals to stack */
    100        
4978 184256 50       MEXTEND(MARK, length);
4979 184256 50       Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4980 184256 100       if (AvREAL(ary)) {
4981 80834 50       EXTEND_MORTAL(length);
4982 264206 100       for (i = length, dst = MARK; i; i--) {
4983 183372         sv_2mortal(*dst); /* free them eventually */
4984 183372         dst++;
4985           }
4986           }
4987 184256         MARK += length - 1;
4988           }
4989           else {
4990 288316         *MARK = AvARRAY(ary)[offset+length-1];
4991 288316 50       if (AvREAL(ary)) {
4992 288316         sv_2mortal(*MARK);
4993 831182 100       for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4994 542866         SvREFCNT_dec(*dst++); /* free them now */
4995           }
4996           }
4997 472572         AvFILLp(ary) += diff;
4998            
4999           /* pull up or down? */
5000            
5001 472572 100       if (offset < after) { /* easier to pull up */
5002 152918 100       if (offset) { /* esp. if nothing to pull */
5003 7336         src = &AvARRAY(ary)[offset-1];
5004 7336         dst = src - diff; /* diff is negative */
5005 582422 100       for (i = offset; i > 0; i--) /* can't trust Copy */
5006 575086         *dst-- = *src--;
5007           }
5008 152918         dst = AvARRAY(ary);
5009 152918         AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5010 152918         AvMAX(ary) += diff;
5011           }
5012           else {
5013 319654 100       if (after) { /* anything to pull down? */
5014 3858         src = AvARRAY(ary) + offset + length;
5015 3858         dst = src + diff; /* diff is negative */
5016 3858 50       Move(src, dst, after, SV*);
5017           }
5018 319654         dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5019           /* avoid later double free */
5020           }
5021 472572         i = -diff;
5022 1925982 100       while (i)
5023 1226844         dst[--i] = NULL;
5024          
5025 472572 100       if (newlen) {
5026 5544 50       Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5027 5544         Safefree(tmparyval);
5028           }
5029           }
5030           else { /* no, expanding (or same) */
5031           SV** tmparyval = NULL;
5032 178074 100       if (length) {
5033 4732 50       Newx(tmparyval, length, SV*); /* so remember deletion */
5034 4732 50       Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5035           }
5036            
5037 178074 100       if (diff > 0) { /* expanding */
5038           /* push up or down? */
5039 153858 100       if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
    100        
5040 200 100       if (offset) {
5041 194         src = AvARRAY(ary);
5042 194         dst = src - diff;
5043 194 50       Move(src, dst, offset, SV*);
5044           }
5045 200         AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5046 200         AvMAX(ary) += diff;
5047 200         AvFILLp(ary) += diff;
5048           }
5049           else {
5050 153658 100       if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5051 8448         av_extend(ary, AvFILLp(ary) + diff);
5052 153658         AvFILLp(ary) += diff;
5053            
5054 153658 100       if (after) {
5055 133188         dst = AvARRAY(ary) + AvFILLp(ary);
5056 133188         src = dst - diff;
5057 163809128 100       for (i = after; i; i--) {
5058 163675940         *dst-- = *src--;
5059           }
5060           }
5061           }
5062           }
5063            
5064 178074 100       if (newlen) {
5065 158038 50       Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5066           }
5067            
5068 178074         MARK = ORIGMARK + 1;
5069 178074 100       if (GIMME == G_ARRAY) { /* copy return vals to stack */
    100        
5070 53532 100       if (length) {
5071 822 50       Copy(tmparyval, MARK, length, SV*);
5072 822 50       if (AvREAL(ary)) {
5073 822 50       EXTEND_MORTAL(length);
5074 1718 100       for (i = length, dst = MARK; i; i--) {
5075 896         sv_2mortal(*dst); /* free them eventually */
5076 896         dst++;
5077           }
5078           }
5079           }
5080 53532         MARK += length - 1;
5081           }
5082 124542 100       else if (length--) {
5083 3910         *MARK = tmparyval[length];
5084 3910 50       if (AvREAL(ary)) {
5085 3910         sv_2mortal(*MARK);
5086 6809 100       while (length-- > 0)
5087 944         SvREFCNT_dec(tmparyval[length]);
5088           }
5089           }
5090           else
5091 120632         *MARK = &PL_sv_undef;
5092 178074         Safefree(tmparyval);
5093           }
5094            
5095 650646 100       if (SvMAGICAL(ary))
5096 32         mg_set(MUTABLE_SV(ary));
5097            
5098           SP = MARK;
5099 651061         RETURN;
5100           }
5101            
5102 23315781         PP(pp_push)
5103           {
5104 23315781         dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5105 23315781 100       AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5106 23315763 100       const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5107            
5108 23315763 100       if (mg) {
5109 62 50       *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5110 62 50       PUSHMARK(MARK);
5111 62         PUTBACK;
5112 62         ENTER_with_name("call_PUSH");
5113 62 100       call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5114 62         LEAVE_with_name("call_PUSH");
5115           SPAGAIN;
5116           }
5117           else {
5118 23315701 100       if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5119 23315697         PL_delaymagic = DM_DELAY;
5120 47784166 100       for (++MARK; MARK <= SP; MARK++) {
5121           SV *sv;
5122 24468473 50       if (*MARK) SvGETMAGIC(*MARK);
    100        
5123 24468469         sv = newSV(0);
5124 24468469 50       if (*MARK)
5125 24468469         sv_setsv_nomg(sv, *MARK);
5126 24468469         av_store(ary, AvFILLp(ary)+1, sv);
5127           }
5128 23315693 100       if (PL_delaymagic & DM_ARRAY_ISA)
5129 77440         mg_set(MUTABLE_SV(ary));
5130            
5131 23315685         PL_delaymagic = 0;
5132           }
5133 23315747         SP = ORIGMARK;
5134 23315747 100       if (OP_GIMME(PL_op, 0) != G_VOID) {
5135 1723163 100       PUSHi( AvFILL(ary) + 1 );
    50        
5136           }
5137 23315747         RETURN;
5138           }
5139            
5140 220768739         PP(pp_shift)
5141 220768739 50       {
5142           dVAR;
5143 220768739         dSP;
5144 220768739         AV * const av = PL_op->op_flags & OPf_SPECIAL
5145 220768739 100       ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
    100        
5146 220768739 100       SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5147 110238690         EXTEND(SP, 1);
5148           assert (sv);
5149 220768739 100       if (AvREAL(av))
5150 7684562         (void)sv_2mortal(sv);
5151 220768739         PUSHs(sv);
5152 220768739         RETURN;
5153           }
5154            
5155 3819867         PP(pp_unshift)
5156           {
5157 3819867         dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5158 3819867 100       AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5159 3819867 100       const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5160            
5161 3819867 100       if (mg) {
5162 20 50       *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5163 20 50       PUSHMARK(MARK);
5164 20         PUTBACK;
5165 20         ENTER_with_name("call_UNSHIFT");
5166 20 100       call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5167 20         LEAVE_with_name("call_UNSHIFT");
5168           SPAGAIN;
5169           }
5170           else {
5171           SSize_t i = 0;
5172 3819847         av_unshift(ary, SP - MARK);
5173 9690149 100       while (MARK < SP) {
5174 3970907         SV * const sv = newSVsv(*++MARK);
5175 3970907         (void)av_store(ary, i++, sv);
5176           }
5177           }
5178 3819867         SP = ORIGMARK;
5179 3819867 100       if (OP_GIMME(PL_op, 0) != G_VOID) {
5180 4502 100       PUSHi( AvFILL(ary) + 1 );
    100        
5181           }
5182 3819867         RETURN;
5183           }
5184            
5185 207184         PP(pp_reverse)
5186           {
5187 207184         dVAR; dSP; dMARK;
5188            
5189 207184 100       if (GIMME == G_ARRAY) {
    100        
5190 37642 100       if (PL_op->op_private & OPpREVERSE_INPLACE) {
5191           AV *av;
5192            
5193           /* See pp_sort() */
5194           assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5195 36         (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5196 36         av = MUTABLE_AV((*SP));
5197           /* In-place reversing only happens in void context for the array
5198           * assignment. We don't need to push anything on the stack. */
5199           SP = MARK;
5200            
5201 36 100       if (SvMAGICAL(av)) {
5202           SSize_t i, j;
5203 16         SV *tmp = sv_newmortal();
5204           /* For SvCANEXISTDELETE */
5205           HV *stash;
5206           const MAGIC *mg;
5207 16 50       bool can_preserve = SvCANEXISTDELETE(av);
    100        
    50        
    50        
    50        
    50        
5208            
5209 40 100       for (i = 0, j = av_len(av); i < j; ++i, --j) {
5210           SV *begin, *end;
5211            
5212 24 50       if (can_preserve) {
5213 24 100       if (!av_exists(av, i)) {
5214 4 50       if (av_exists(av, j)) {
5215 4         SV *sv = av_delete(av, j, 0);
5216 4         begin = *av_fetch(av, i, TRUE);
5217 4         sv_setsv_mg(begin, sv);
5218           }
5219 4         continue;
5220           }
5221 20 100       else if (!av_exists(av, j)) {
5222 2         SV *sv = av_delete(av, i, 0);
5223 2         end = *av_fetch(av, j, TRUE);
5224 2         sv_setsv_mg(end, sv);
5225 2         continue;
5226           }
5227           }
5228            
5229 18         begin = *av_fetch(av, i, TRUE);
5230 18         end = *av_fetch(av, j, TRUE);
5231 18         sv_setsv(tmp, begin);
5232 18         sv_setsv_mg(begin, end);
5233 18         sv_setsv_mg(end, tmp);
5234           }
5235           }
5236           else {
5237 20         SV **begin = AvARRAY(av);
5238            
5239 20 100       if (begin) {
5240 18         SV **end = begin + AvFILLp(av);
5241            
5242 53 100       while (begin < end) {
5243 26         SV * const tmp = *begin;
5244 26         *begin++ = *end;
5245 26         *end-- = tmp;
5246           }
5247           }
5248           }
5249           }
5250           else {
5251           SV **oldsp = SP;
5252 37606         MARK++;
5253 289471 100       while (MARK < SP) {
5254 233062         SV * const tmp = *MARK;
5255 233062         *MARK++ = *SP;
5256 233062         *SP-- = tmp;
5257           }
5258           /* safe as long as stack cannot get extended in the above */
5259           SP = oldsp;
5260           }
5261           }
5262           else {
5263           char *up;
5264           char *down;
5265           I32 tmp;
5266 169542         dTARGET;
5267           STRLEN len;
5268            
5269 169542         SvUTF8_off(TARG); /* decontaminate */
5270 169542 100       if (SP - MARK > 1)
5271 46         do_join(TARG, &PL_sv_no, MARK, SP);
5272           else {
5273 169496 100       sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5274           }
5275            
5276 169542 100       up = SvPV_force(TARG, len);
5277 169542 100       if (len > 1) {
5278 106790 100       if (DO_UTF8(TARG)) { /* first reverse each character */
    50        
5279 14         U8* s = (U8*)SvPVX(TARG);
5280 14         const U8* send = (U8*)(s + len);
5281 103 100       while (s < send) {
5282 82 100       if (UTF8_IS_INVARIANT(*s)) {
5283 58         s++;
5284 58         continue;
5285           }
5286           else {
5287 24 50       if (!utf8_to_uvchr_buf(s, send, 0))
    50        
5288           break;
5289           up = (char*)s;
5290 24         s += UTF8SKIP(s);
5291 24         down = (char*)(s - 1);
5292           /* reverse this character */
5293 89 100       while (down > up) {
5294 24         tmp = *up;
5295 24         *up++ = *down;
5296 24         *down-- = (char)tmp;
5297           }
5298           }
5299           }
5300 14         up = SvPVX(TARG);
5301           }
5302 106790         down = SvPVX(TARG) + len - 1;
5303 269397 100       while (down > up) {
5304 109212         tmp = *up;
5305 109212         *up++ = *down;
5306 109212         *down-- = (char)tmp;
5307           }
5308 106790         (void)SvPOK_only_UTF8(TARG);
5309           }
5310 169542         SP = MARK + 1;
5311 169542 50       SETTARG;
5312           }
5313 207184         RETURN;
5314           }
5315            
5316 4476822         PP(pp_split)
5317           {
5318 4476822         dVAR; dSP; dTARG;
5319           AV *ary;
5320 4476822 100       IV limit = POPi; /* note, negative is forever */
5321 4476822         SV * const sv = POPs;
5322           STRLEN len;
5323 4476822 100       const char *s = SvPV_const(sv, len);
5324 4476822 100       const bool do_utf8 = DO_UTF8(sv);
    50        
5325 4476822         const char *strend = s + len;
5326           PMOP *pm;
5327           REGEXP *rx;
5328           SV *dstr;
5329           const char *m;
5330           SSize_t iters = 0;
5331           const STRLEN slen = do_utf8
5332           ? utf8_length((U8*)s, (U8*)strend)
5333 4476822 100       : (STRLEN)(strend - s);
5334 4476822         SSize_t maxiters = slen + 10;
5335           I32 trailing_empty = 0;
5336           const char *orig;
5337 4476822         const I32 origlimit = limit;
5338           I32 realarray = 0;
5339           I32 base;
5340 4476822 100       const I32 gimme = GIMME_V;
5341           bool gimme_scalar;
5342 4476822         const I32 oldsave = PL_savestack_ix;
5343           U32 make_mortal = SVs_TEMP;
5344           bool multiline = 0;
5345           MAGIC *mg = NULL;
5346            
5347           #ifdef DEBUGGING
5348           Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5349           #else
5350 4476822         pm = (PMOP*)POPs;
5351           #endif
5352 4476822 50       if (!pm || !s)
5353 0         DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5354 4476822         rx = PM_GETRE(pm);
5355            
5356 6709937 100       TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
    50        
5357           (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5358            
5359           #ifdef USE_ITHREADS
5360           if (pm->op_pmreplrootu.op_pmtargetoff) {
5361           ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5362           }
5363           #else
5364 4476822 100       if (pm->op_pmreplrootu.op_pmtargetgv) {
5365 572 50       ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5366           }
5367           #endif
5368           else
5369           ary = NULL;
5370 4476822 100       if (ary) {
5371           realarray = 1;
5372 572         PUTBACK;
5373 572         av_extend(ary,0);
5374 572         av_clear(ary);
5375 572         SPAGAIN;
5376 572 100       if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
    100        
5377 2 50       PUSHMARK(SP);
5378 2 50       XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
    50        
5379           }
5380           else {
5381 570 50       if (!AvREAL(ary)) {
5382           I32 i;
5383 0         AvREAL_on(ary);
5384 0         AvREIFY_off(ary);
5385 0 0       for (i = AvFILLp(ary); i >= 0; i--)
5386 0         AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5387           }
5388           /* temporarily switch stacks */
5389 570         SAVESWITCHSTACK(PL_curstack, ary);
5390           make_mortal = 0;
5391           }
5392           }
5393 4476822         base = SP - PL_stack_base;
5394           orig = s;
5395 4476822 100       if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5396 182528 100       if (do_utf8) {
5397 308 100       while (isSPACE_utf8(s))
    100        
    50        
    50        
    100        
    100        
    50        
    50        
    100        
    100        
    100        
    100        
    50        
    50        
    50        
    50        
    50        
    50        
    100        
5398 200         s += UTF8SKIP(s);
5399           }
5400 273630 50       else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5401 0 0       while (isSPACE_LC(*s))
5402 0         s++;
5403           }
5404           else {
5405 196874 100       while (isSPACE(*s))
5406 14454         s++;
5407           }
5408           }
5409 4476822 100       if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5410           multiline = 1;
5411           }
5412            
5413 4476822         gimme_scalar = gimme == G_SCALAR && !ary;
5414            
5415 4476822 100       if (!limit)
5416 1882612         limit = maxiters + 2;
5417 4476822 100       if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5418 1845070 100       while (--limit) {
5419           m = s;
5420           /* this one uses 'm' and is a negative test */
5421 1844422 100       if (do_utf8) {
5422 2156 100       while (m < strend && ! isSPACE_utf8(m) ) {
    100        
    100        
    100        
    50        
    50        
    50        
    100        
    100        
    50        
    50        
    50        
    50        
    100        
    100        
    100        
    100        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
5423 1440         const int t = UTF8SKIP(m);
5424           /* isSPACE_utf8 returns FALSE for malform utf8 */
5425 1440 50       if (strend - m < t)
5426           m = strend;
5427           else
5428 1440         m += t;
5429           }
5430           }
5431 2753319 50       else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5432           {
5433 0 0       while (m < strend && !isSPACE_LC(*m))
    0        
5434 0         ++m;
5435           } else {
5436 8632722 100       while (m < strend && !isSPACE(*m))
    100        
5437 6789016         ++m;
5438           }
5439 1844422 100       if (m >= strend)
5440           break;
5441            
5442 1484416 100       if (gimme_scalar) {
5443 218         iters++;
5444 218 100       if (m-s == 0)
5445 50         trailing_empty++;
5446           else
5447           trailing_empty = 0;
5448           } else {
5449 1484198 100       dstr = newSVpvn_flags(s, m-s,
5450           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5451 1484198 50       XPUSHs(dstr);
5452           }
5453            
5454           /* skip the whitespace found last */
5455 1484416 100       if (do_utf8)
5456 416         s = m + UTF8SKIP(m);
5457           else
5458 1484000         s = m + 1;
5459            
5460           /* this one uses 's' and is a positive test */
5461 1484416 100       if (do_utf8) {
5462 716 100       while (s < strend && isSPACE_utf8(s) )
    100        
    100        
    100        
    50        
    50        
    50        
    100        
    100        
    50        
    50        
    50        
    50        
    100        
    100        
    100        
    100        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
5463 300         s += UTF8SKIP(s);
5464           }
5465 2216460 50       else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5466           {
5467 0 0       while (s < strend && isSPACE_LC(*s))
    0        
5468 0         ++s;
5469           } else {
5470 1510710 100       while (s < strend && isSPACE(*s))
    100        
5471 26502         ++s;
5472           }
5473           }
5474           }
5475 4116168 100       else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5476 235860 50       while (--limit) {
5477 5341012 100       for (m = s; m < strend && *m != '\n'; m++)
    100        
5478           ;
5479 235860         m++;
5480 235860 100       if (m >= strend)
5481           break;
5482            
5483 66438 50       if (gimme_scalar) {
5484 0         iters++;
5485 0 0       if (m-s == 0)
5486 0         trailing_empty++;
5487           else
5488           trailing_empty = 0;
5489           } else {
5490 66438 100       dstr = newSVpvn_flags(s, m-s,
5491           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5492 66438 100       XPUSHs(dstr);
5493           }
5494           s = m;
5495           }
5496           }
5497 3946746 100       else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
    100        
5498           /*
5499           Pre-extend the stack, either the number of bytes or
5500           characters in the string or a limited amount, triggered by:
5501            
5502           my ($x, $y) = split //, $str;
5503           or
5504           split //, $str, $i;
5505           */
5506 502832 100       if (!gimme_scalar) {
5507 502810         const U32 items = limit - 1;
5508 754215 100       if (items < slen)
    50        
    100        
5509 1         EXTEND(SP, items);
5510           else
5511 251426         EXTEND(SP, slen);
5512           }
5513            
5514 502832 100       if (do_utf8) {
5515 84472 50       while (--limit) {
5516           /* keep track of how many bytes we skip over */
5517           m = s;
5518 84472         s += UTF8SKIP(s);
5519 84472 100       if (gimme_scalar) {
5520 42         iters++;
5521 42 50       if (s-m == 0)
5522 0         trailing_empty++;
5523           else
5524           trailing_empty = 0;
5525           } else {
5526 84430         dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5527            
5528 84430         PUSHs(dstr);
5529           }
5530            
5531 117192 100       if (s >= strend)
5532           break;
5533           }
5534           } else {
5535 3738038 100       while (--limit) {
5536 3738036 100       if (gimme_scalar) {
5537 44         iters++;
5538           } else {
5539 3737992         dstr = newSVpvn(s, 1);
5540            
5541            
5542 3737992 50       if (make_mortal)
5543 3737992         sv_2mortal(dstr);
5544            
5545 3737992         PUSHs(dstr);
5546           }
5547            
5548 3738036         s++;
5549            
5550 3956732 100       if (s >= strend)
5551           break;
5552           }
5553           }
5554           }
5555 5160541 100       else if (do_utf8 == (RX_UTF8(rx) != 0) &&
    100        
5556 4699595 100       (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5557 2982684 100       && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5558 2532792 50       && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5559 2532792         const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5560 2532792         SV * const csv = CALLREG_INTUIT_STRING(rx);
5561            
5562 2532792         len = RX_MINLENRET(rx);
5563 2532792 100       if (len == 1 && !RX_UTF8(rx) && !tail) {
    100        
5564 2436098 50       const char c = *SvPV_nolen_const(csv);
5565 7469568 100       while (--limit) {
5566 69120382 100       for (m = s; m < strend && *m != c; m++)
    100        
5567           ;
5568 6202304 100       if (m >= strend)
5569           break;
5570 3816620 100       if (gimme_scalar) {
5571 80         iters++;
5572 80 100       if (m-s == 0)
5573 16         trailing_empty++;
5574           else
5575           trailing_empty = 0;
5576           } else {
5577 3816540 50       dstr = newSVpvn_flags(s, m-s,
5578           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5579 3816540 100       XPUSHs(dstr);
5580           }
5581           /* The rx->minlen is in characters but we want to step
5582           * s ahead by bytes. */
5583 3816620 50       if (do_utf8)
5584 0         s = (char*)utf8_hop((U8*)m, len);
5585           else
5586 3816620         s = m + len; /* Fake \n at the end */
5587           }
5588           }
5589           else {
5590 228131 100       while (s < strend && --limit &&
    100        
    100        
5591 135640         (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5592           csv, multiline ? FBMrf_MULTILINE : 0)) )
5593           {
5594 65596 100       if (gimme_scalar) {
5595 10         iters++;
5596 10 50       if (m-s == 0)
5597 0         trailing_empty++;
5598           else
5599           trailing_empty = 0;
5600           } else {
5601 65586 100       dstr = newSVpvn_flags(s, m-s,
5602           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5603 65586 100       XPUSHs(dstr);
5604           }
5605           /* The rx->minlen is in characters but we want to step
5606           * s ahead by bytes. */
5607 65596 100       if (do_utf8)
5608 4         s = (char*)utf8_hop((U8*)m, len);
5609           else
5610 65594         s = m + len; /* Fake \n at the end */
5611           }
5612           }
5613           }
5614           else {
5615 911122         maxiters += slen * RX_NPARENS(rx);
5616 3564289 100       while (s < strend && --limit)
    100        
5617           {
5618           I32 rex_return;
5619 2912460         PUTBACK;
5620 2912460         rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5621           sv, NULL, 0);
5622 2912460         SPAGAIN;
5623 2912460 100       if (rex_return == 0)
5624           break;
5625 2197606 50       TAINT_IF(RX_MATCH_TAINTED(rx));
5626           /* we never pass the REXEC_COPY_STR flag, so it should
5627           * never get copied */
5628           assert(!RX_MATCH_COPIED(rx));
5629 2197606         m = RX_OFFS(rx)[0].start + orig;
5630            
5631 2197606 100       if (gimme_scalar) {
5632 92         iters++;
5633 92 100       if (m-s == 0)
5634 12         trailing_empty++;
5635           else
5636           trailing_empty = 0;
5637           } else {
5638 2197514 100       dstr = newSVpvn_flags(s, m-s,
5639           (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5640 2197514 100       XPUSHs(dstr);
5641           }
5642 2197606 100       if (RX_NPARENS(rx)) {
5643           I32 i;
5644 582110 100       for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5645 232844         s = RX_OFFS(rx)[i].start + orig;
5646 232844         m = RX_OFFS(rx)[i].end + orig;
5647            
5648           /* japhy (07/27/01) -- the (m && s) test doesn't catch
5649           parens that didn't match -- they should be set to
5650           undef, not the empty string */
5651 232844 100       if (gimme_scalar) {
5652 24         iters++;
5653 24 100       if (m-s == 0)
5654 18         trailing_empty++;
5655           else
5656           trailing_empty = 0;
5657           } else {
5658 232820 100       if (m >= orig && s >= orig) {
5659 232786 100       dstr = newSVpvn_flags(s, m-s,
5660           (do_utf8 ? SVf_UTF8 : 0)
5661           | make_mortal);
5662           }
5663           else
5664           dstr = &PL_sv_undef; /* undef, not "" */
5665 232820 50       XPUSHs(dstr);
5666           }
5667            
5668           }
5669           }
5670 2197606         s = RX_OFFS(rx)[0].end + orig;
5671           }
5672           }
5673            
5674 4476822 100       if (!gimme_scalar) {
5675 4476570         iters = (SP - PL_stack_base) - base;
5676           }
5677 4476822 50       if (iters > maxiters)
5678 0         DIE(aTHX_ "Split loop");
5679            
5680           /* keep field after final delim? */
5681 4476822 100       if (s < strend || (iters && origlimit)) {
    100        
5682 3563724 100       if (!gimme_scalar) {
5683 3563516         const STRLEN l = strend - s;
5684 3563516 100       dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5685 3563516 50       XPUSHs(dstr);
5686           }
5687 3563724         iters++;
5688           }
5689 913098 100       else if (!origlimit) {
5690 817802 100       if (gimme_scalar) {
5691 36         iters -= trailing_empty;
5692           } else {
5693 918288 100       while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
    50        
    100        
    100        
5694 100522 100       if (TOPs && !make_mortal)
5695 20         sv_2mortal(TOPs);
5696 100522         *SP-- = &PL_sv_undef;
5697 100522         iters--;
5698           }
5699           }
5700           }
5701            
5702 4476822         PUTBACK;
5703 4476822 100       LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5704 4476822         SPAGAIN;
5705 4476822 100       if (realarray) {
5706 572 100       if (!mg) {
5707 570 50       if (SvSMAGICAL(ary)) {
5708 0         PUTBACK;
5709 0         mg_set(MUTABLE_SV(ary));
5710 0         SPAGAIN;
5711           }
5712 571 100       if (gimme == G_ARRAY) {
    50        
5713 1         EXTEND(SP, iters);
5714 2 50       Copy(AvARRAY(ary), SP + 1, iters, SV*);
5715 2         SP += iters;
5716 2         RETURN;
5717           }
5718           }
5719           else {
5720 2         PUTBACK;
5721 2         ENTER_with_name("call_PUSH");
5722 2 50       call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5723 2         LEAVE_with_name("call_PUSH");
5724 2         SPAGAIN;
5725 2 50       if (gimme == G_ARRAY) {
    0        
5726           SSize_t i;
5727           /* EXTEND should not be needed - we just popped them */
5728 0         EXTEND(SP, iters);
5729 0 0       for (i=0; i < iters; i++) {
5730 0         SV **svp = av_fetch(ary, i, FALSE);
5731 0 0       PUSHs((svp) ? *svp : &PL_sv_undef);
5732           }
5733 0         RETURN;
5734           }
5735           }
5736           }
5737           else {
5738 4476250 100       if (gimme == G_ARRAY)
5739 4475990         RETURN;
5740           }
5741            
5742 830         GETTARGET;
5743 830 50       PUSHi(iters);
5744 2244164         RETURN;
5745           }
5746            
5747 550         PP(pp_once)
5748           {
5749 550         dSP;
5750 550         SV *const sv = PAD_SVl(PL_op->op_targ);
5751            
5752 550 100       if (SvPADSTALE(sv)) {
5753           /* First time. */
5754           SvPADSTALE_off(sv);
5755 64         RETURNOP(cLOGOP->op_other);
5756           }
5757 518         RETURNOP(cLOGOP->op_next);
5758           }
5759            
5760 33568         PP(pp_lock)
5761           {
5762           dVAR;
5763 33568         dSP;
5764 33568         dTOPss;
5765           SV *retsv = sv;
5766 33568         SvLOCK(sv);
5767 50352 100       if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5768 33568         || SvTYPE(retsv) == SVt_PVCV) {
5769 100         retsv = refto(retsv);
5770           }
5771 33568         SETs(retsv);
5772 33568         RETURN;
5773           }
5774            
5775            
5776 0         PP(unimplemented_op)
5777           {
5778           dVAR;
5779 0         const Optype op_type = PL_op->op_type;
5780           /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5781           with out of range op numbers - it only "special" cases op_custom.
5782           Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5783           if we get here for a custom op then that means that the custom op didn't
5784           have an implementation. Given that OP_NAME() looks up the custom op
5785           by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5786           registers &PL_unimplemented_op as the address of their custom op.
5787           NULL doesn't generate a useful error message. "custom" does. */
5788           const char *const name = op_type >= OP_max
5789 0 0       ? "[out of range]" : PL_op_name[PL_op->op_type];
5790 0 0       if(OP_IS_SOCKET(op_type))
5791 0         DIE(aTHX_ PL_no_sock_func, name);
5792 0         DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
5793           }
5794            
5795           /* For sorting out arguments passed to a &CORE:: subroutine */
5796 1066         PP(pp_coreargs)
5797 1138 50       {
    100        
5798           dSP;
5799 1066 100       int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
    50        
5800 1066         int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
5801 1066         AV * const at_ = GvAV(PL_defgv);
5802 1066 100       SV **svp = at_ ? AvARRAY(at_) : NULL;
5803 1066 100       I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
5804 1066 100       I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5805           bool seen_question = 0;
5806           const char *err = NULL;
5807 1066         const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5808            
5809           /* Count how many args there are first, to get some idea how far to
5810           extend the stack. */
5811 3191 100       while (oa) {
5812 1668 100       if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5813 1592         maxargs++;
5814 1592 100       if (oa & OA_OPTIONAL) seen_question = 1;
5815 1592 100       if (!seen_question) minargs++;
5816 1592         oa >>= 4;
5817           }
5818            
5819 1066 100       if(numargs < minargs) err = "Not enough";
5820 888 100       else if(numargs > maxargs) err = "Too many";
5821 1066 100       if (err)
5822           /* diag_listed_as: Too many arguments for %s */
5823 494 100       Perl_croak(aTHX_
    50        
5824           "%s arguments for %s", err,
5825 12         opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
5826           );
5827            
5828           /* Reset the stack pointer. Without this, we end up returning our own
5829           arguments in list context, in addition to the values we are supposed
5830           to return. nextstate usually does this on sub entry, but we need
5831           to run the next op with the caller's hints, so we cannot have a
5832           nextstate. */
5833 578         SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5834            
5835 578 100       if(!maxargs) RETURN;
5836            
5837           /* We do this here, rather than with a separate pushmark op, as it has
5838           to come in between two things this function does (stack reset and
5839           arg pushing). This seems the easiest way to do it. */
5840 536 100       if (pushmark) {
5841 90         PUTBACK;
5842 90         (void)Perl_pp_pushmark(aTHX);
5843           }
5844            
5845 536 100       EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
    0        
5846 536         PUTBACK; /* The code below can die in various places. */
5847            
5848 536         oa = PL_opargs[opnum] >> OASHIFT;
5849 1040 100       for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
    100        
    100        
5850 714         whicharg++;
5851 714         switch (oa & 7) {
5852           case OA_SCALAR:
5853           try_defsv:
5854 448 100       if (!numargs && defgv && whicharg == minargs + 1) {
    100        
5855 122         PUSHs(find_rundefsv2(
5856           find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
5857           cxstack[cxstack_ix].blk_oldcop->cop_seq
5858           ));
5859           }
5860 326 100       else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
    50        
    50        
5861           break;
5862           case OA_LIST:
5863 100 100       while (numargs--) {
5864 60 50       PUSHs(svp && *svp ? *svp : &PL_sv_undef);
    50        
5865 60         svp++;
5866           }
5867 40         RETURN;
5868           case OA_HVREF:
5869 16 50       if (!svp || !*svp || !SvROK(*svp)
    50        
    100        
5870 12 100       || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5871 18 50       DIE(aTHX_
5872           /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5873           "Type of arg %d to &CORE::%s must be hash reference",
5874 6 0       whicharg, OP_DESC(PL_op->op_next)
5875           );
5876 4         PUSHs(SvRV(*svp));
5877 4         break;
5878           case OA_FILEREF:
5879 104 100       if (!numargs) PUSHs(NULL);
5880 90 50       else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
    50        
    100        
    50        
    50        
5881           /* no magic here, as the prototype will have added an extra
5882           refgen and we just want what was there before that */
5883 28         PUSHs(SvRV(*svp));
5884           else {
5885 62         const bool constr = PL_op->op_private & whicharg;
5886 62 50       PUSHs(S_rv2gv(aTHX_
    50        
5887           svp && *svp ? *svp : &PL_sv_undef,
5888           constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5889           !constr
5890           ));
5891           }
5892           break;
5893           case OA_SCALARREF:
5894 118 100       if (!numargs) goto try_defsv;
5895           else {
5896 106         const bool wantscalar =
5897 106         PL_op->op_private & OPpCOREARGS_SCALARMOD;
5898 106 50       if (!svp || !*svp || !SvROK(*svp)
    50        
    100        
5899           /* We have to permit globrefs even for the \$ proto, as
5900           *foo is indistinguishable from ${\*foo}, and the proto-
5901           type permits the latter. */
5902 117 100       || SvTYPE(SvRV(*svp)) > (
    100        
    100        
5903           wantscalar ? SVt_PVLV
5904 58         : opnum == OP_LOCK || opnum == OP_UNDEF
5905           ? SVt_PVCV
5906           : SVt_PVHV
5907           )
5908           )
5909 108 100       DIE(aTHX_
5910           /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5911           "Type of arg %d to &CORE::%s must be %s",
5912           whicharg, PL_op_name[opnum],
5913           wantscalar
5914           ? "scalar reference"
5915 36         : opnum == OP_LOCK || opnum == OP_UNDEF
5916           ? "reference to one of [$@%&*]"
5917 36 100       : "reference to one of [$@%*]"
5918           );
5919 46         PUSHs(SvRV(*svp));
5920 46 100       if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
    100        
5921 4 100       && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
5922           /* Undo @_ localisation, so that sub exit does not undo
5923           part of our undeffing. */
5924 2         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
5925 2         POP_SAVEARRAY();
5926 2         cx->cx_type &= ~ CXp_HASARGS;
5927           assert(!AvREAL(cx->blk_sub.argarray));
5928           }
5929           }
5930           break;
5931           default:
5932 0         DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5933           }
5934 602         oa = oa >> 4;
5935           }
5936            
5937 465         RETURN;
5938           }
5939            
5940 26         PP(pp_runcv)
5941           {
5942 26         dSP;
5943           CV *cv;
5944 26 100       if (PL_op->op_private & OPpOFFBYONE) {
5945 8         cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
5946           }
5947 18         else cv = find_runcv(NULL);
5948 26 50       XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
    100        
    50        
5949 26         RETURN;
5950 62578644         }
5951            
5952            
5953           /*
5954           * Local variables:
5955           * c-indentation-style: bsd
5956           * c-basic-offset: 4
5957           * indent-tabs-mode: nil
5958           * End:
5959           *
5960           * ex: set ts=8 sts=4 sw=4 et:
5961           */