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