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