source: vendor/perl/5.8.8/pp.c

Last change on this file was 3181, checked in by bird, 18 years ago

perl 5.8.8
File size: 104.0 KB
RevLine 
[3181]1/* pp.c
2 *
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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 to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
14 */
15
16/* This file contains general pp ("push/pop") functions that execute the
17 * opcodes that make up a perl program. A typical pp function expects to
18 * find its arguments on the stack, and usually pushes its results onto
19 * the stack, hence the 'pp' terminology. Each OP structure contains
20 * a pointer to the relevant pp_foo() function.
21 */
22
23#include "EXTERN.h"
24#define PERL_IN_PP_C
25#include "perl.h"
26#include "keywords.h"
27
28#include "reentr.h"
29
30/* XXX I can't imagine anyone who doesn't have this actually _needs_
31 it, since pid_t is an integral type.
32 --AD 2/20/1998
33*/
34#ifdef NEED_GETPID_PROTO
35extern Pid_t getpid (void);
36#endif
37
38/*
39 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
40 * This switches them over to IEEE.
41 */
42#if defined(LIBM_LIB_VERSION)
43 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
44#endif
45
46/* variations on pp_null */
47
48PP(pp_stub)
49{
50 dSP;
51 if (GIMME_V == G_SCALAR)
52 XPUSHs(&PL_sv_undef);
53 RETURN;
54}
55
56PP(pp_scalar)
57{
58 return NORMAL;
59}
60
61/* Pushy stuff. */
62
63PP(pp_padav)
64{
65 dSP; dTARGET;
66 I32 gimme;
67 if (PL_op->op_private & OPpLVAL_INTRO)
68 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
69 EXTEND(SP, 1);
70 if (PL_op->op_flags & OPf_REF) {
71 PUSHs(TARG);
72 RETURN;
73 } else if (LVRET) {
74 if (GIMME == G_SCALAR)
75 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
76 PUSHs(TARG);
77 RETURN;
78 }
79 gimme = GIMME_V;
80 if (gimme == G_ARRAY) {
81 const I32 maxarg = AvFILL((AV*)TARG) + 1;
82 EXTEND(SP, maxarg);
83 if (SvMAGICAL(TARG)) {
84 U32 i;
85 for (i=0; i < (U32)maxarg; i++) {
86 SV ** const svp = av_fetch((AV*)TARG, i, FALSE);
87 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
88 }
89 }
90 else {
91 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
92 }
93 SP += maxarg;
94 }
95 else if (gimme == G_SCALAR) {
96 SV* const sv = sv_newmortal();
97 const I32 maxarg = AvFILL((AV*)TARG) + 1;
98 sv_setiv(sv, maxarg);
99 PUSHs(sv);
100 }
101 RETURN;
102}
103
104PP(pp_padhv)
105{
106 dSP; dTARGET;
107 I32 gimme;
108
109 XPUSHs(TARG);
110 if (PL_op->op_private & OPpLVAL_INTRO)
111 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
112 if (PL_op->op_flags & OPf_REF)
113 RETURN;
114 else if (LVRET) {
115 if (GIMME == G_SCALAR)
116 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
117 RETURN;
118 }
119 gimme = GIMME_V;
120 if (gimme == G_ARRAY) {
121 RETURNOP(do_kv());
122 }
123 else if (gimme == G_SCALAR) {
124 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
125 SETs(sv);
126 }
127 RETURN;
128}
129
130PP(pp_padany)
131{
132 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
133}
134
135/* Translations. */
136
137PP(pp_rv2gv)
138{
139 dSP; dTOPss;
140
141 if (SvROK(sv)) {
142 wasref:
143 tryAMAGICunDEREF(to_gv);
144
145 sv = SvRV(sv);
146 if (SvTYPE(sv) == SVt_PVIO) {
147 GV * const gv = (GV*) sv_newmortal();
148 gv_init(gv, 0, "", 0, 0);
149 GvIOp(gv) = (IO *)sv;
150 (void)SvREFCNT_inc(sv);
151 sv = (SV*) gv;
152 }
153 else if (SvTYPE(sv) != SVt_PVGV)
154 DIE(aTHX_ "Not a GLOB reference");
155 }
156 else {
157 if (SvTYPE(sv) != SVt_PVGV) {
158 char *sym;
159 STRLEN len;
160
161 if (SvGMAGICAL(sv)) {
162 mg_get(sv);
163 if (SvROK(sv))
164 goto wasref;
165 }
166 if (!SvOK(sv) && sv != &PL_sv_undef) {
167 /* If this is a 'my' scalar and flag is set then vivify
168 * NI-S 1999/05/07
169 */
170 if (SvREADONLY(sv))
171 Perl_croak(aTHX_ PL_no_modify);
172 if (PL_op->op_private & OPpDEREF) {
173 GV *gv;
174 if (cUNOP->op_targ) {
175 STRLEN len;
176 SV *namesv = PAD_SV(cUNOP->op_targ);
177 const char *name = SvPV(namesv, len);
178 gv = (GV*)NEWSV(0,0);
179 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
180 }
181 else {
182 const char *name = CopSTASHPV(PL_curcop);
183 gv = newGVgen((char *)name);
184 }
185 if (SvTYPE(sv) < SVt_RV)
186 sv_upgrade(sv, SVt_RV);
187 if (SvPVX_const(sv)) {
188 SvPV_free(sv);
189 SvLEN_set(sv, 0);
190 SvCUR_set(sv, 0);
191 }
192 SvRV_set(sv, (SV*)gv);
193 SvROK_on(sv);
194 SvSETMAGIC(sv);
195 goto wasref;
196 }
197 if (PL_op->op_flags & OPf_REF ||
198 PL_op->op_private & HINT_STRICT_REFS)
199 DIE(aTHX_ PL_no_usym, "a symbol");
200 if (ckWARN(WARN_UNINITIALIZED))
201 report_uninit();
202 RETSETUNDEF;
203 }
204 sym = SvPV(sv,len);
205 if ((PL_op->op_flags & OPf_SPECIAL) &&
206 !(PL_op->op_flags & OPf_MOD))
207 {
208 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
209 if (!sv
210 && (!is_gv_magical(sym,len,0)
211 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
212 {
213 RETSETUNDEF;
214 }
215 }
216 else {
217 if (PL_op->op_private & HINT_STRICT_REFS)
218 DIE(aTHX_ PL_no_symref, sym, "a symbol");
219 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
220 }
221 }
222 }
223 if (PL_op->op_private & OPpLVAL_INTRO)
224 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
225 SETs(sv);
226 RETURN;
227}
228
229PP(pp_rv2sv)
230{
231 GV *gv = Nullgv;
232 dSP; dTOPss;
233
234 if (SvROK(sv)) {
235 wasref:
236 tryAMAGICunDEREF(to_sv);
237
238 sv = SvRV(sv);
239 switch (SvTYPE(sv)) {
240 case SVt_PVAV:
241 case SVt_PVHV:
242 case SVt_PVCV:
243 DIE(aTHX_ "Not a SCALAR reference");
244 }
245 }
246 else {
247 char *sym;
248 STRLEN len;
249 gv = (GV*)sv;
250
251 if (SvTYPE(gv) != SVt_PVGV) {
252 if (SvGMAGICAL(sv)) {
253 mg_get(sv);
254 if (SvROK(sv))
255 goto wasref;
256 }
257 if (!SvOK(sv)) {
258 if (PL_op->op_flags & OPf_REF ||
259 PL_op->op_private & HINT_STRICT_REFS)
260 DIE(aTHX_ PL_no_usym, "a SCALAR");
261 if (ckWARN(WARN_UNINITIALIZED))
262 report_uninit();
263 RETSETUNDEF;
264 }
265 sym = SvPV(sv, len);
266 if ((PL_op->op_flags & OPf_SPECIAL) &&
267 !(PL_op->op_flags & OPf_MOD))
268 {
269 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
270 if (!gv
271 && (!is_gv_magical(sym,len,0)
272 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
273 {
274 RETSETUNDEF;
275 }
276 }
277 else {
278 if (PL_op->op_private & HINT_STRICT_REFS)
279 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
280 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
281 }
282 }
283 sv = GvSVn(gv);
284 }
285 if (PL_op->op_flags & OPf_MOD) {
286 if (PL_op->op_private & OPpLVAL_INTRO) {
287 if (cUNOP->op_first->op_type == OP_NULL)
288 sv = save_scalar((GV*)TOPs);
289 else if (gv)
290 sv = save_scalar(gv);
291 else
292 Perl_croak(aTHX_ PL_no_localize_ref);
293 }
294 else if (PL_op->op_private & OPpDEREF)
295 vivify_ref(sv, PL_op->op_private & OPpDEREF);
296 }
297 SETs(sv);
298 RETURN;
299}
300
301PP(pp_av2arylen)
302{
303 dSP;
304 AV *const av = (AV*)TOPs;
305 SV *sv = AvARYLEN(av);
306 if (!sv) {
307 AvARYLEN(av) = sv = NEWSV(0,0);
308 sv_upgrade(sv, SVt_IV);
309 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
310 }
311 SETs(sv);
312 RETURN;
313}
314
315PP(pp_pos)
316{
317 dSP; dTARGET; dPOPss;
318
319 if (PL_op->op_flags & OPf_MOD || LVRET) {
320 if (SvTYPE(TARG) < SVt_PVLV) {
321 sv_upgrade(TARG, SVt_PVLV);
322 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
323 }
324
325 LvTYPE(TARG) = '.';
326 if (LvTARG(TARG) != sv) {
327 if (LvTARG(TARG))
328 SvREFCNT_dec(LvTARG(TARG));
329 LvTARG(TARG) = SvREFCNT_inc(sv);
330 }
331 PUSHs(TARG); /* no SvSETMAGIC */
332 RETURN;
333 }
334 else {
335 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
336 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
337 if (mg && mg->mg_len >= 0) {
338 I32 i = mg->mg_len;
339 if (DO_UTF8(sv))
340 sv_pos_b2u(sv, &i);
341 PUSHi(i + PL_curcop->cop_arybase);
342 RETURN;
343 }
344 }
345 RETPUSHUNDEF;
346 }
347}
348
349PP(pp_rv2cv)
350{
351 dSP;
352 GV *gv;
353 HV *stash;
354
355 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
356 /* (But not in defined().) */
357 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
358 if (cv) {
359 if (CvCLONE(cv))
360 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
361 if ((PL_op->op_private & OPpLVAL_INTRO)) {
362 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
363 cv = GvCV(gv);
364 if (!CvLVALUE(cv))
365 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
366 }
367 }
368 else
369 cv = (CV*)&PL_sv_undef;
370 SETs((SV*)cv);
371 RETURN;
372}
373
374PP(pp_prototype)
375{
376 dSP;
377 CV *cv;
378 HV *stash;
379 GV *gv;
380 SV *ret;
381
382 ret = &PL_sv_undef;
383 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
384 const char *s = SvPVX_const(TOPs);
385 if (strnEQ(s, "CORE::", 6)) {
386 const int code = keyword((char *)s + 6, SvCUR(TOPs) - 6);
387 if (code < 0) { /* Overridable. */
388#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
389 int i = 0, n = 0, seen_question = 0;
390 I32 oa;
391 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
392
393 if (code == -KEY_chop || code == -KEY_chomp
394 || code == -KEY_exec || code == -KEY_system)
395 goto set;
396 while (i < MAXO) { /* The slow way. */
397 if (strEQ(s + 6, PL_op_name[i])
398 || strEQ(s + 6, PL_op_desc[i]))
399 {
400 goto found;
401 }
402 i++;
403 }
404 goto nonesuch; /* Should not happen... */
405 found:
406 oa = PL_opargs[i] >> OASHIFT;
407 while (oa) {
408 if (oa & OA_OPTIONAL && !seen_question) {
409 seen_question = 1;
410 str[n++] = ';';
411 }
412 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
413 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
414 /* But globs are already references (kinda) */
415 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
416 ) {
417 str[n++] = '\\';
418 }
419 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
420 oa = oa >> 4;
421 }
422 str[n++] = '\0';
423 ret = sv_2mortal(newSVpvn(str, n - 1));
424 }
425 else if (code) /* Non-Overridable */
426 goto set;
427 else { /* None such */
428 nonesuch:
429 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
430 }
431 }
432 }
433 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
434 if (cv && SvPOK(cv))
435 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
436 set:
437 SETs(ret);
438 RETURN;
439}
440
441PP(pp_anoncode)
442{
443 dSP;
444 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
445 if (CvCLONE(cv))
446 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
447 EXTEND(SP,1);
448 PUSHs((SV*)cv);
449 RETURN;
450}
451
452PP(pp_srefgen)
453{
454 dSP;
455 *SP = refto(*SP);
456 RETURN;
457}
458
459PP(pp_refgen)
460{
461 dSP; dMARK;
462 if (GIMME != G_ARRAY) {
463 if (++MARK <= SP)
464 *MARK = *SP;
465 else
466 *MARK = &PL_sv_undef;
467 *MARK = refto(*MARK);
468 SP = MARK;
469 RETURN;
470 }
471 EXTEND_MORTAL(SP - MARK);
472 while (++MARK <= SP)
473 *MARK = refto(*MARK);
474 RETURN;
475}
476
477STATIC SV*
478S_refto(pTHX_ SV *sv)
479{
480 SV* rv;
481
482 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
483 if (LvTARGLEN(sv))
484 vivify_defelem(sv);
485 if (!(sv = LvTARG(sv)))
486 sv = &PL_sv_undef;
487 else
488 (void)SvREFCNT_inc(sv);
489 }
490 else if (SvTYPE(sv) == SVt_PVAV) {
491 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
492 av_reify((AV*)sv);
493 SvTEMP_off(sv);
494 (void)SvREFCNT_inc(sv);
495 }
496 else if (SvPADTMP(sv) && !IS_PADGV(sv))
497 sv = newSVsv(sv);
498 else {
499 SvTEMP_off(sv);
500 (void)SvREFCNT_inc(sv);
501 }
502 rv = sv_newmortal();
503 sv_upgrade(rv, SVt_RV);
504 SvRV_set(rv, sv);
505 SvROK_on(rv);
506 return rv;
507}
508
509PP(pp_ref)
510{
511 dSP; dTARGET;
512 const char *pv;
513 SV * const sv = POPs;
514
515 if (sv && SvGMAGICAL(sv))
516 mg_get(sv);
517
518 if (!sv || !SvROK(sv))
519 RETPUSHNO;
520
521 pv = sv_reftype(SvRV(sv),TRUE);
522 PUSHp(pv, strlen(pv));
523 RETURN;
524}
525
526PP(pp_bless)
527{
528 dSP;
529 HV *stash;
530
531 if (MAXARG == 1)
532 stash = CopSTASH(PL_curcop);
533 else {
534 SV * const ssv = POPs;
535 STRLEN len;
536 const char *ptr;
537
538 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
539 Perl_croak(aTHX_ "Attempt to bless into a reference");
540 ptr = SvPV_const(ssv,len);
541 if (len == 0 && ckWARN(WARN_MISC))
542 Perl_warner(aTHX_ packWARN(WARN_MISC),
543 "Explicit blessing to '' (assuming package main)");
544 stash = gv_stashpvn(ptr, len, TRUE);
545 }
546
547 (void)sv_bless(TOPs, stash);
548 RETURN;
549}
550
551PP(pp_gelem)
552{
553 dSP;
554
555 SV *sv = POPs;
556 const char * const elem = SvPV_nolen_const(sv);
557 GV * const gv = (GV*)POPs;
558 SV * tmpRef = Nullsv;
559
560 sv = Nullsv;
561 if (elem) {
562 /* elem will always be NUL terminated. */
563 const char * const second_letter = elem + 1;
564 switch (*elem) {
565 case 'A':
566 if (strEQ(second_letter, "RRAY"))
567 tmpRef = (SV*)GvAV(gv);
568 break;
569 case 'C':
570 if (strEQ(second_letter, "ODE"))
571 tmpRef = (SV*)GvCVu(gv);
572 break;
573 case 'F':
574 if (strEQ(second_letter, "ILEHANDLE")) {
575 /* finally deprecated in 5.8.0 */
576 deprecate("*glob{FILEHANDLE}");
577 tmpRef = (SV*)GvIOp(gv);
578 }
579 else
580 if (strEQ(second_letter, "ORMAT"))
581 tmpRef = (SV*)GvFORM(gv);
582 break;
583 case 'G':
584 if (strEQ(second_letter, "LOB"))
585 tmpRef = (SV*)gv;
586 break;
587 case 'H':
588 if (strEQ(second_letter, "ASH"))
589 tmpRef = (SV*)GvHV(gv);
590 break;
591 case 'I':
592 if (*second_letter == 'O' && !elem[2])
593 tmpRef = (SV*)GvIOp(gv);
594 break;
595 case 'N':
596 if (strEQ(second_letter, "AME"))
597 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
598 break;
599 case 'P':
600 if (strEQ(second_letter, "ACKAGE")) {
601 const char *name = HvNAME_get(GvSTASH(gv));
602 sv = newSVpv(name ? name : "__ANON__", 0);
603 }
604 break;
605 case 'S':
606 if (strEQ(second_letter, "CALAR"))
607 tmpRef = GvSV(gv);
608 break;
609 }
610 }
611 if (tmpRef)
612 sv = newRV(tmpRef);
613 if (sv)
614 sv_2mortal(sv);
615 else
616 sv = &PL_sv_undef;
617 XPUSHs(sv);
618 RETURN;
619}
620
621/* Pattern matching */
622
623PP(pp_study)
624{
625 dSP; dPOPss;
626 register unsigned char *s;
627 register I32 pos;
628 register I32 ch;
629 register I32 *sfirst;
630 register I32 *snext;
631 STRLEN len;
632
633 if (sv == PL_lastscream) {
634 if (SvSCREAM(sv))
635 RETPUSHYES;
636 }
637 else {
638 if (PL_lastscream) {
639 SvSCREAM_off(PL_lastscream);
640 SvREFCNT_dec(PL_lastscream);
641 }
642 PL_lastscream = SvREFCNT_inc(sv);
643 }
644
645 s = (unsigned char*)(SvPV(sv, len));
646 pos = len;
647 if (pos <= 0)
648 RETPUSHNO;
649 if (pos > PL_maxscream) {
650 if (PL_maxscream < 0) {
651 PL_maxscream = pos + 80;
652 Newx(PL_screamfirst, 256, I32);
653 Newx(PL_screamnext, PL_maxscream, I32);
654 }
655 else {
656 PL_maxscream = pos + pos / 4;
657 Renew(PL_screamnext, PL_maxscream, I32);
658 }
659 }
660
661 sfirst = PL_screamfirst;
662 snext = PL_screamnext;
663
664 if (!sfirst || !snext)
665 DIE(aTHX_ "do_study: out of memory");
666
667 for (ch = 256; ch; --ch)
668 *sfirst++ = -1;
669 sfirst -= 256;
670
671 while (--pos >= 0) {
672 register const I32 ch = s[pos];
673 if (sfirst[ch] >= 0)
674 snext[pos] = sfirst[ch] - pos;
675 else
676 snext[pos] = -pos;
677 sfirst[ch] = pos;
678 }
679
680 SvSCREAM_on(sv);
681 /* piggyback on m//g magic */
682 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
683 RETPUSHYES;
684}
685
686PP(pp_trans)
687{
688 dSP; dTARG;
689 SV *sv;
690
691 if (PL_op->op_flags & OPf_STACKED)
692 sv = POPs;
693 else {
694 sv = DEFSV;
695 EXTEND(SP,1);
696 }
697 TARG = sv_newmortal();
698 PUSHi(do_trans(sv));
699 RETURN;
700}
701
702/* Lvalue operators. */
703
704PP(pp_schop)
705{
706 dSP; dTARGET;
707 do_chop(TARG, TOPs);
708 SETTARG;
709 RETURN;
710}
711
712PP(pp_chop)
713{
714 dSP; dMARK; dTARGET; dORIGMARK;
715 while (MARK < SP)
716 do_chop(TARG, *++MARK);
717 SP = ORIGMARK;
718 XPUSHTARG;
719 RETURN;
720}
721
722PP(pp_schomp)
723{
724 dSP; dTARGET;
725 SETi(do_chomp(TOPs));
726 RETURN;
727}
728
729PP(pp_chomp)
730{
731 dSP; dMARK; dTARGET;
732 register I32 count = 0;
733
734 while (SP > MARK)
735 count += do_chomp(POPs);
736 XPUSHi(count);
737 RETURN;
738}
739
740PP(pp_defined)
741{
742 dSP;
743 register SV* const sv = POPs;
744
745 if (!sv || !SvANY(sv))
746 RETPUSHNO;
747 switch (SvTYPE(sv)) {
748 case SVt_PVAV:
749 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
750 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
751 RETPUSHYES;
752 break;
753 case SVt_PVHV:
754 if (HvARRAY(sv) || SvGMAGICAL(sv)
755 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
756 RETPUSHYES;
757 break;
758 case SVt_PVCV:
759 if (CvROOT(sv) || CvXSUB(sv))
760 RETPUSHYES;
761 break;
762 default:
763 if (SvGMAGICAL(sv))
764 mg_get(sv);
765 if (SvOK(sv))
766 RETPUSHYES;
767 }
768 RETPUSHNO;
769}
770
771PP(pp_undef)
772{
773 dSP;
774 SV *sv;
775
776 if (!PL_op->op_private) {
777 EXTEND(SP, 1);
778 RETPUSHUNDEF;
779 }
780
781 sv = POPs;
782 if (!sv)
783 RETPUSHUNDEF;
784
785 if (SvTHINKFIRST(sv))
786 sv_force_normal(sv);
787
788 switch (SvTYPE(sv)) {
789 case SVt_NULL:
790 break;
791 case SVt_PVAV:
792 av_undef((AV*)sv);
793 break;
794 case SVt_PVHV:
795 hv_undef((HV*)sv);
796 break;
797 case SVt_PVCV:
798 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
799 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
800 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
801 /* FALL THROUGH */
802 case SVt_PVFM:
803 {
804 /* let user-undef'd sub keep its identity */
805 GV* gv = CvGV((CV*)sv);
806 cv_undef((CV*)sv);
807 CvGV((CV*)sv) = gv;
808 }
809 break;
810 case SVt_PVGV:
811 if (SvFAKE(sv))
812 SvSetMagicSV(sv, &PL_sv_undef);
813 else {
814 GP *gp;
815 gp_free((GV*)sv);
816 Newxz(gp, 1, GP);
817 GvGP(sv) = gp_ref(gp);
818 GvSV(sv) = NEWSV(72,0);
819 GvLINE(sv) = CopLINE(PL_curcop);
820 GvEGV(sv) = (GV*)sv;
821 GvMULTI_on(sv);
822 }
823 break;
824 default:
825 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
826 SvPV_free(sv);
827 SvPV_set(sv, Nullch);
828 SvLEN_set(sv, 0);
829 }
830 SvOK_off(sv);
831 SvSETMAGIC(sv);
832 }
833
834 RETPUSHUNDEF;
835}
836
837PP(pp_predec)
838{
839 dSP;
840 if (SvTYPE(TOPs) > SVt_PVLV)
841 DIE(aTHX_ PL_no_modify);
842 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
843 && SvIVX(TOPs) != IV_MIN)
844 {
845 SvIV_set(TOPs, SvIVX(TOPs) - 1);
846 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
847 }
848 else
849 sv_dec(TOPs);
850 SvSETMAGIC(TOPs);
851 return NORMAL;
852}
853
854PP(pp_postinc)
855{
856 dSP; dTARGET;
857 if (SvTYPE(TOPs) > SVt_PVLV)
858 DIE(aTHX_ PL_no_modify);
859 sv_setsv(TARG, TOPs);
860 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
861 && SvIVX(TOPs) != IV_MAX)
862 {
863 SvIV_set(TOPs, SvIVX(TOPs) + 1);
864 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
865 }
866 else
867 sv_inc(TOPs);
868 SvSETMAGIC(TOPs);
869 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
870 if (!SvOK(TARG))
871 sv_setiv(TARG, 0);
872 SETs(TARG);
873 return NORMAL;
874}
875
876PP(pp_postdec)
877{
878 dSP; dTARGET;
879 if (SvTYPE(TOPs) > SVt_PVLV)
880 DIE(aTHX_ PL_no_modify);
881 sv_setsv(TARG, TOPs);
882 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
883 && SvIVX(TOPs) != IV_MIN)
884 {
885 SvIV_set(TOPs, SvIVX(TOPs) - 1);
886 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
887 }
888 else
889 sv_dec(TOPs);
890 SvSETMAGIC(TOPs);
891 SETs(TARG);
892 return NORMAL;
893}
894
895/* Ordinary operators. */
896
897PP(pp_pow)
898{
899 dSP; dATARGET;
900#ifdef PERL_PRESERVE_IVUV
901 bool is_int = 0;
902#endif
903 tryAMAGICbin(pow,opASSIGN);
904#ifdef PERL_PRESERVE_IVUV
905 /* For integer to integer power, we do the calculation by hand wherever
906 we're sure it is safe; otherwise we call pow() and try to convert to
907 integer afterwards. */
908 {
909 SvIV_please(TOPs);
910 if (SvIOK(TOPs)) {
911 SvIV_please(TOPm1s);
912 if (SvIOK(TOPm1s)) {
913 UV power;
914 bool baseuok;
915 UV baseuv;
916
917 if (SvUOK(TOPs)) {
918 power = SvUVX(TOPs);
919 } else {
920 const IV iv = SvIVX(TOPs);
921 if (iv >= 0) {
922 power = iv;
923 } else {
924 goto float_it; /* Can't do negative powers this way. */
925 }
926 }
927
928 baseuok = SvUOK(TOPm1s);
929 if (baseuok) {
930 baseuv = SvUVX(TOPm1s);
931 } else {
932 const IV iv = SvIVX(TOPm1s);
933 if (iv >= 0) {
934 baseuv = iv;
935 baseuok = TRUE; /* effectively it's a UV now */
936 } else {
937 baseuv = -iv; /* abs, baseuok == false records sign */
938 }
939 }
940 /* now we have integer ** positive integer. */
941 is_int = 1;
942
943 /* foo & (foo - 1) is zero only for a power of 2. */
944 if (!(baseuv & (baseuv - 1))) {
945 /* We are raising power-of-2 to a positive integer.
946 The logic here will work for any base (even non-integer
947 bases) but it can be less accurate than
948 pow (base,power) or exp (power * log (base)) when the
949 intermediate values start to spill out of the mantissa.
950 With powers of 2 we know this can't happen.
951 And powers of 2 are the favourite thing for perl
952 programmers to notice ** not doing what they mean. */
953 NV result = 1.0;
954 NV base = baseuok ? baseuv : -(NV)baseuv;
955
956 if (power & 1) {
957 result *= base;
958 }
959 while (power >>= 1) {
960 base *= base;
961 if (power & 1) {
962 result *= base;
963 }
964 }
965 SP--;
966 SETn( result );
967 SvIV_please(TOPs);
968 RETURN;
969 } else {
970 register unsigned int highbit = 8 * sizeof(UV);
971 register unsigned int diff = 8 * sizeof(UV);
972 while (diff >>= 1) {
973 highbit -= diff;
974 if (baseuv >> highbit) {
975 highbit += diff;
976 }
977 }
978 /* we now have baseuv < 2 ** highbit */
979 if (power * highbit <= 8 * sizeof(UV)) {
980 /* result will definitely fit in UV, so use UV math
981 on same algorithm as above */
982 register UV result = 1;
983 register UV base = baseuv;
984 const bool odd_power = (bool)(power & 1);
985 if (odd_power) {
986 result *= base;
987 }
988 while (power >>= 1) {
989 base *= base;
990 if (power & 1) {
991 result *= base;
992 }
993 }
994 SP--;
995 if (baseuok || !odd_power)
996 /* answer is positive */
997 SETu( result );
998 else if (result <= (UV)IV_MAX)
999 /* answer negative, fits in IV */
1000 SETi( -(IV)result );
1001 else if (result == (UV)IV_MIN)
1002 /* 2's complement assumption: special case IV_MIN */
1003 SETi( IV_MIN );
1004 else
1005 /* answer negative, doesn't fit */
1006 SETn( -(NV)result );
1007 RETURN;
1008 }
1009 }
1010 }
1011 }
1012 }
1013 float_it:
1014#endif
1015 {
1016 dPOPTOPnnrl;
1017 SETn( Perl_pow( left, right) );
1018#ifdef PERL_PRESERVE_IVUV
1019 if (is_int)
1020 SvIV_please(TOPs);
1021#endif
1022 RETURN;
1023 }
1024}
1025
1026PP(pp_multiply)
1027{
1028 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1029#ifdef PERL_PRESERVE_IVUV
1030 SvIV_please(TOPs);
1031 if (SvIOK(TOPs)) {
1032 /* Unless the left argument is integer in range we are going to have to
1033 use NV maths. Hence only attempt to coerce the right argument if
1034 we know the left is integer. */
1035 /* Left operand is defined, so is it IV? */
1036 SvIV_please(TOPm1s);
1037 if (SvIOK(TOPm1s)) {
1038 bool auvok = SvUOK(TOPm1s);
1039 bool buvok = SvUOK(TOPs);
1040 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1041 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1042 UV alow;
1043 UV ahigh;
1044 UV blow;
1045 UV bhigh;
1046
1047 if (auvok) {
1048 alow = SvUVX(TOPm1s);
1049 } else {
1050 const IV aiv = SvIVX(TOPm1s);
1051 if (aiv >= 0) {
1052 alow = aiv;
1053 auvok = TRUE; /* effectively it's a UV now */
1054 } else {
1055 alow = -aiv; /* abs, auvok == false records sign */
1056 }
1057 }
1058 if (buvok) {
1059 blow = SvUVX(TOPs);
1060 } else {
1061 const IV biv = SvIVX(TOPs);
1062 if (biv >= 0) {
1063 blow = biv;
1064 buvok = TRUE; /* effectively it's a UV now */
1065 } else {
1066 blow = -biv; /* abs, buvok == false records sign */
1067 }
1068 }
1069
1070 /* If this does sign extension on unsigned it's time for plan B */
1071 ahigh = alow >> (4 * sizeof (UV));
1072 alow &= botmask;
1073 bhigh = blow >> (4 * sizeof (UV));
1074 blow &= botmask;
1075 if (ahigh && bhigh) {
1076 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1077 which is overflow. Drop to NVs below. */
1078 } else if (!ahigh && !bhigh) {
1079 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1080 so the unsigned multiply cannot overflow. */
1081 UV product = alow * blow;
1082 if (auvok == buvok) {
1083 /* -ve * -ve or +ve * +ve gives a +ve result. */
1084 SP--;
1085 SETu( product );
1086 RETURN;
1087 } else if (product <= (UV)IV_MIN) {
1088 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1089 /* -ve result, which could overflow an IV */
1090 SP--;
1091 SETi( -(IV)product );
1092 RETURN;
1093 } /* else drop to NVs below. */
1094 } else {
1095 /* One operand is large, 1 small */
1096 UV product_middle;
1097 if (bhigh) {
1098 /* swap the operands */
1099 ahigh = bhigh;
1100 bhigh = blow; /* bhigh now the temp var for the swap */
1101 blow = alow;
1102 alow = bhigh;
1103 }
1104 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1105 multiplies can't overflow. shift can, add can, -ve can. */
1106 product_middle = ahigh * blow;
1107 if (!(product_middle & topmask)) {
1108 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1109 UV product_low;
1110 product_middle <<= (4 * sizeof (UV));
1111 product_low = alow * blow;
1112
1113 /* as for pp_add, UV + something mustn't get smaller.
1114 IIRC ANSI mandates this wrapping *behaviour* for
1115 unsigned whatever the actual representation*/
1116 product_low += product_middle;
1117 if (product_low >= product_middle) {
1118 /* didn't overflow */
1119 if (auvok == buvok) {
1120 /* -ve * -ve or +ve * +ve gives a +ve result. */
1121 SP--;
1122 SETu( product_low );
1123 RETURN;
1124 } else if (product_low <= (UV)IV_MIN) {
1125 /* 2s complement assumption again */
1126 /* -ve result, which could overflow an IV */
1127 SP--;
1128 SETi( -(IV)product_low );
1129 RETURN;
1130 } /* else drop to NVs below. */
1131 }
1132 } /* product_middle too large */
1133 } /* ahigh && bhigh */
1134 } /* SvIOK(TOPm1s) */
1135 } /* SvIOK(TOPs) */
1136#endif
1137 {
1138 dPOPTOPnnrl;
1139 SETn( left * right );
1140 RETURN;
1141 }
1142}
1143
1144PP(pp_divide)
1145{
1146 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1147 /* Only try to do UV divide first
1148 if ((SLOPPYDIVIDE is true) or
1149 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1150 to preserve))
1151 The assumption is that it is better to use floating point divide
1152 whenever possible, only doing integer divide first if we can't be sure.
1153 If NV_PRESERVES_UV is true then we know at compile time that no UV
1154 can be too large to preserve, so don't need to compile the code to
1155 test the size of UVs. */
1156
1157#ifdef SLOPPYDIVIDE
1158# define PERL_TRY_UV_DIVIDE
1159 /* ensure that 20./5. == 4. */
1160#else
1161# ifdef PERL_PRESERVE_IVUV
1162# ifndef NV_PRESERVES_UV
1163# define PERL_TRY_UV_DIVIDE
1164# endif
1165# endif
1166#endif
1167
1168#ifdef PERL_TRY_UV_DIVIDE
1169 SvIV_please(TOPs);
1170 if (SvIOK(TOPs)) {
1171 SvIV_please(TOPm1s);
1172 if (SvIOK(TOPm1s)) {
1173 bool left_non_neg = SvUOK(TOPm1s);
1174 bool right_non_neg = SvUOK(TOPs);
1175 UV left;
1176 UV right;
1177
1178 if (right_non_neg) {
1179 right = SvUVX(TOPs);
1180 }
1181 else {
1182 const IV biv = SvIVX(TOPs);
1183 if (biv >= 0) {
1184 right = biv;
1185 right_non_neg = TRUE; /* effectively it's a UV now */
1186 }
1187 else {
1188 right = -biv;
1189 }
1190 }
1191 /* historically undef()/0 gives a "Use of uninitialized value"
1192 warning before dieing, hence this test goes here.
1193 If it were immediately before the second SvIV_please, then
1194 DIE() would be invoked before left was even inspected, so
1195 no inpsection would give no warning. */
1196 if (right == 0)
1197 DIE(aTHX_ "Illegal division by zero");
1198
1199 if (left_non_neg) {
1200 left = SvUVX(TOPm1s);
1201 }
1202 else {
1203 const IV aiv = SvIVX(TOPm1s);
1204 if (aiv >= 0) {
1205 left = aiv;
1206 left_non_neg = TRUE; /* effectively it's a UV now */
1207 }
1208 else {
1209 left = -aiv;
1210 }
1211 }
1212
1213 if (left >= right
1214#ifdef SLOPPYDIVIDE
1215 /* For sloppy divide we always attempt integer division. */
1216#else
1217 /* Otherwise we only attempt it if either or both operands
1218 would not be preserved by an NV. If both fit in NVs
1219 we fall through to the NV divide code below. However,
1220 as left >= right to ensure integer result here, we know that
1221 we can skip the test on the right operand - right big
1222 enough not to be preserved can't get here unless left is
1223 also too big. */
1224
1225 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1226#endif
1227 ) {
1228 /* Integer division can't overflow, but it can be imprecise. */
1229 const UV result = left / right;
1230 if (result * right == left) {
1231 SP--; /* result is valid */
1232 if (left_non_neg == right_non_neg) {
1233 /* signs identical, result is positive. */
1234 SETu( result );
1235 RETURN;
1236 }
1237 /* 2s complement assumption */
1238 if (result <= (UV)IV_MIN)
1239 SETi( -(IV)result );
1240 else {
1241 /* It's exact but too negative for IV. */
1242 SETn( -(NV)result );
1243 }
1244 RETURN;
1245 } /* tried integer divide but it was not an integer result */
1246 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1247 } /* left wasn't SvIOK */
1248 } /* right wasn't SvIOK */
1249#endif /* PERL_TRY_UV_DIVIDE */
1250 {
1251 dPOPPOPnnrl;
1252 if (right == 0.0)
1253 DIE(aTHX_ "Illegal division by zero");
1254 PUSHn( left / right );
1255 RETURN;
1256 }
1257}
1258
1259PP(pp_modulo)
1260{
1261 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1262 {
1263 UV left = 0;
1264 UV right = 0;
1265 bool left_neg = FALSE;
1266 bool right_neg = FALSE;
1267 bool use_double = FALSE;
1268 bool dright_valid = FALSE;
1269 NV dright = 0.0;
1270 NV dleft = 0.0;
1271
1272 SvIV_please(TOPs);
1273 if (SvIOK(TOPs)) {
1274 right_neg = !SvUOK(TOPs);
1275 if (!right_neg) {
1276 right = SvUVX(POPs);
1277 } else {
1278 const IV biv = SvIVX(POPs);
1279 if (biv >= 0) {
1280 right = biv;
1281 right_neg = FALSE; /* effectively it's a UV now */
1282 } else {
1283 right = -biv;
1284 }
1285 }
1286 }
1287 else {
1288 dright = POPn;
1289 right_neg = dright < 0;
1290 if (right_neg)
1291 dright = -dright;
1292 if (dright < UV_MAX_P1) {
1293 right = U_V(dright);
1294 dright_valid = TRUE; /* In case we need to use double below. */
1295 } else {
1296 use_double = TRUE;
1297 }
1298 }
1299
1300 /* At this point use_double is only true if right is out of range for
1301 a UV. In range NV has been rounded down to nearest UV and
1302 use_double false. */
1303 SvIV_please(TOPs);
1304 if (!use_double && SvIOK(TOPs)) {
1305 if (SvIOK(TOPs)) {
1306 left_neg = !SvUOK(TOPs);
1307 if (!left_neg) {
1308 left = SvUVX(POPs);
1309 } else {
1310 IV aiv = SvIVX(POPs);
1311 if (aiv >= 0) {
1312 left = aiv;
1313 left_neg = FALSE; /* effectively it's a UV now */
1314 } else {
1315 left = -aiv;
1316 }
1317 }
1318 }
1319 }
1320 else {
1321 dleft = POPn;
1322 left_neg = dleft < 0;
1323 if (left_neg)
1324 dleft = -dleft;
1325
1326 /* This should be exactly the 5.6 behaviour - if left and right are
1327 both in range for UV then use U_V() rather than floor. */
1328 if (!use_double) {
1329 if (dleft < UV_MAX_P1) {
1330 /* right was in range, so is dleft, so use UVs not double.
1331 */
1332 left = U_V(dleft);
1333 }
1334 /* left is out of range for UV, right was in range, so promote
1335 right (back) to double. */
1336 else {
1337 /* The +0.5 is used in 5.6 even though it is not strictly
1338 consistent with the implicit +0 floor in the U_V()
1339 inside the #if 1. */
1340 dleft = Perl_floor(dleft + 0.5);
1341 use_double = TRUE;
1342 if (dright_valid)
1343 dright = Perl_floor(dright + 0.5);
1344 else
1345 dright = right;
1346 }
1347 }
1348 }
1349 if (use_double) {
1350 NV dans;
1351
1352 if (!dright)
1353 DIE(aTHX_ "Illegal modulus zero");
1354
1355 dans = Perl_fmod(dleft, dright);
1356 if ((left_neg != right_neg) && dans)
1357 dans = dright - dans;
1358 if (right_neg)
1359 dans = -dans;
1360 sv_setnv(TARG, dans);
1361 }
1362 else {
1363 UV ans;
1364
1365 if (!right)
1366 DIE(aTHX_ "Illegal modulus zero");
1367
1368 ans = left % right;
1369 if ((left_neg != right_neg) && ans)
1370 ans = right - ans;
1371 if (right_neg) {
1372 /* XXX may warn: unary minus operator applied to unsigned type */
1373 /* could change -foo to be (~foo)+1 instead */
1374 if (ans <= ~((UV)IV_MAX)+1)
1375 sv_setiv(TARG, ~ans+1);
1376 else
1377 sv_setnv(TARG, -(NV)ans);
1378 }
1379 else
1380 sv_setuv(TARG, ans);
1381 }
1382 PUSHTARG;
1383 RETURN;
1384 }
1385}
1386
1387PP(pp_repeat)
1388{
1389 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1390 {
1391 register IV count;
1392 dPOPss;
1393 if (SvGMAGICAL(sv))
1394 mg_get(sv);
1395 if (SvIOKp(sv)) {
1396 if (SvUOK(sv)) {
1397 const UV uv = SvUV(sv);
1398 if (uv > IV_MAX)
1399 count = IV_MAX; /* The best we can do? */
1400 else
1401 count = uv;
1402 } else {
1403 IV iv = SvIV(sv);
1404 if (iv < 0)
1405 count = 0;
1406 else
1407 count = iv;
1408 }
1409 }
1410 else if (SvNOKp(sv)) {
1411 const NV nv = SvNV(sv);
1412 if (nv < 0.0)
1413 count = 0;
1414 else
1415 count = (IV)nv;
1416 }
1417 else
1418 count = SvIVx(sv);
1419 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1420 dMARK;
1421 I32 items = SP - MARK;
1422 I32 max;
1423 static const char oom_list_extend[] =
1424 "Out of memory during list extend";
1425
1426 max = items * count;
1427 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1428 /* Did the max computation overflow? */
1429 if (items > 0 && max > 0 && (max < items || max < count))
1430 Perl_croak(aTHX_ oom_list_extend);
1431 MEXTEND(MARK, max);
1432 if (count > 1) {
1433 while (SP > MARK) {
1434#if 0
1435 /* This code was intended to fix 20010809.028:
1436
1437 $x = 'abcd';
1438 for (($x =~ /./g) x 2) {
1439 print chop; # "abcdabcd" expected as output.
1440 }
1441
1442 * but that change (#11635) broke this code:
1443
1444 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1445
1446 * I can't think of a better fix that doesn't introduce
1447 * an efficiency hit by copying the SVs. The stack isn't
1448 * refcounted, and mortalisation obviously doesn't
1449 * Do The Right Thing when the stack has more than
1450 * one pointer to the same mortal value.
1451 * .robin.
1452 */
1453 if (*SP) {
1454 *SP = sv_2mortal(newSVsv(*SP));
1455 SvREADONLY_on(*SP);
1456 }
1457#else
1458 if (*SP)
1459 SvTEMP_off((*SP));
1460#endif
1461 SP--;
1462 }
1463 MARK++;
1464 repeatcpy((char*)(MARK + items), (char*)MARK,
1465 items * sizeof(SV*), count - 1);
1466 SP += max;
1467 }
1468 else if (count <= 0)
1469 SP -= items;
1470 }
1471 else { /* Note: mark already snarfed by pp_list */
1472 SV *tmpstr = POPs;
1473 STRLEN len;
1474 bool isutf;
1475 static const char oom_string_extend[] =
1476 "Out of memory during string extend";
1477
1478 SvSetSV(TARG, tmpstr);
1479 SvPV_force(TARG, len);
1480 isutf = DO_UTF8(TARG);
1481 if (count != 1) {
1482 if (count < 1)
1483 SvCUR_set(TARG, 0);
1484 else {
1485 STRLEN max = (UV)count * len;
1486 if (len > ((MEM_SIZE)~0)/count)
1487 Perl_croak(aTHX_ oom_string_extend);
1488 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1489 SvGROW(TARG, max + 1);
1490 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1491 SvCUR_set(TARG, SvCUR(TARG) * count);
1492 }
1493 *SvEND(TARG) = '\0';
1494 }
1495 if (isutf)
1496 (void)SvPOK_only_UTF8(TARG);
1497 else
1498 (void)SvPOK_only(TARG);
1499
1500 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1501 /* The parser saw this as a list repeat, and there
1502 are probably several items on the stack. But we're
1503 in scalar context, and there's no pp_list to save us
1504 now. So drop the rest of the items -- robin@kitsite.com
1505 */
1506 dMARK;
1507 SP = MARK;
1508 }
1509 PUSHTARG;
1510 }
1511 RETURN;
1512 }
1513}
1514
1515PP(pp_subtract)
1516{
1517 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1518 useleft = USE_LEFT(TOPm1s);
1519#ifdef PERL_PRESERVE_IVUV
1520 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1521 "bad things" happen if you rely on signed integers wrapping. */
1522 SvIV_please(TOPs);
1523 if (SvIOK(TOPs)) {
1524 /* Unless the left argument is integer in range we are going to have to
1525 use NV maths. Hence only attempt to coerce the right argument if
1526 we know the left is integer. */
1527 register UV auv = 0;
1528 bool auvok = FALSE;
1529 bool a_valid = 0;
1530
1531 if (!useleft) {
1532 auv = 0;
1533 a_valid = auvok = 1;
1534 /* left operand is undef, treat as zero. */
1535 } else {
1536 /* Left operand is defined, so is it IV? */
1537 SvIV_please(TOPm1s);
1538 if (SvIOK(TOPm1s)) {
1539 if ((auvok = SvUOK(TOPm1s)))
1540 auv = SvUVX(TOPm1s);
1541 else {
1542 register const IV aiv = SvIVX(TOPm1s);
1543 if (aiv >= 0) {
1544 auv = aiv;
1545 auvok = 1; /* Now acting as a sign flag. */
1546 } else { /* 2s complement assumption for IV_MIN */
1547 auv = (UV)-aiv;
1548 }
1549 }
1550 a_valid = 1;
1551 }
1552 }
1553 if (a_valid) {
1554 bool result_good = 0;
1555 UV result;
1556 register UV buv;
1557 bool buvok = SvUOK(TOPs);
1558
1559 if (buvok)
1560 buv = SvUVX(TOPs);
1561 else {
1562 register const IV biv = SvIVX(TOPs);
1563 if (biv >= 0) {
1564 buv = biv;
1565 buvok = 1;
1566 } else
1567 buv = (UV)-biv;
1568 }
1569 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1570 else "IV" now, independent of how it came in.
1571 if a, b represents positive, A, B negative, a maps to -A etc
1572 a - b => (a - b)
1573 A - b => -(a + b)
1574 a - B => (a + b)
1575 A - B => -(a - b)
1576 all UV maths. negate result if A negative.
1577 subtract if signs same, add if signs differ. */
1578
1579 if (auvok ^ buvok) {
1580 /* Signs differ. */
1581 result = auv + buv;
1582 if (result >= auv)
1583 result_good = 1;
1584 } else {
1585 /* Signs same */
1586 if (auv >= buv) {
1587 result = auv - buv;
1588 /* Must get smaller */
1589 if (result <= auv)
1590 result_good = 1;
1591 } else {
1592 result = buv - auv;
1593 if (result <= buv) {
1594 /* result really should be -(auv-buv). as its negation
1595 of true value, need to swap our result flag */
1596 auvok = !auvok;
1597 result_good = 1;
1598 }
1599 }
1600 }
1601 if (result_good) {
1602 SP--;
1603 if (auvok)
1604 SETu( result );
1605 else {
1606 /* Negate result */
1607 if (result <= (UV)IV_MIN)
1608 SETi( -(IV)result );
1609 else {
1610 /* result valid, but out of range for IV. */
1611 SETn( -(NV)result );
1612 }
1613 }
1614 RETURN;
1615 } /* Overflow, drop through to NVs. */
1616 }
1617 }
1618#endif
1619 useleft = USE_LEFT(TOPm1s);
1620 {
1621 dPOPnv;
1622 if (!useleft) {
1623 /* left operand is undef, treat as zero - value */
1624 SETn(-value);
1625 RETURN;
1626 }
1627 SETn( TOPn - value );
1628 RETURN;
1629 }
1630}
1631
1632PP(pp_left_shift)
1633{
1634 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1635 {
1636 const IV shift = POPi;
1637 if (PL_op->op_private & HINT_INTEGER) {
1638 IV i = TOPi;
1639 SETi(i << shift);
1640 }
1641 else {
1642 UV u = TOPu;
1643 SETu(u << shift);
1644 }
1645 RETURN;
1646 }
1647}
1648
1649PP(pp_right_shift)
1650{
1651 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1652 {
1653 const IV shift = POPi;
1654 if (PL_op->op_private & HINT_INTEGER) {
1655 IV i = TOPi;
1656 SETi(i >> shift);
1657 }
1658 else {
1659 UV u = TOPu;
1660 SETu(u >> shift);
1661 }
1662 RETURN;
1663 }
1664}
1665
1666PP(pp_lt)
1667{
1668 dSP; tryAMAGICbinSET(lt,0);
1669#ifdef PERL_PRESERVE_IVUV
1670 SvIV_please(TOPs);
1671 if (SvIOK(TOPs)) {
1672 SvIV_please(TOPm1s);
1673 if (SvIOK(TOPm1s)) {
1674 bool auvok = SvUOK(TOPm1s);
1675 bool buvok = SvUOK(TOPs);
1676
1677 if (!auvok && !buvok) { /* ## IV < IV ## */
1678 const IV aiv = SvIVX(TOPm1s);
1679 const IV biv = SvIVX(TOPs);
1680
1681 SP--;
1682 SETs(boolSV(aiv < biv));
1683 RETURN;
1684 }
1685 if (auvok && buvok) { /* ## UV < UV ## */
1686 const UV auv = SvUVX(TOPm1s);
1687 const UV buv = SvUVX(TOPs);
1688
1689 SP--;
1690 SETs(boolSV(auv < buv));
1691 RETURN;
1692 }
1693 if (auvok) { /* ## UV < IV ## */
1694 UV auv;
1695 const IV biv = SvIVX(TOPs);
1696 SP--;
1697 if (biv < 0) {
1698 /* As (a) is a UV, it's >=0, so it cannot be < */
1699 SETs(&PL_sv_no);
1700 RETURN;
1701 }
1702 auv = SvUVX(TOPs);
1703 SETs(boolSV(auv < (UV)biv));
1704 RETURN;
1705 }
1706 { /* ## IV < UV ## */
1707 const IV aiv = SvIVX(TOPm1s);
1708 UV buv;
1709
1710 if (aiv < 0) {
1711 /* As (b) is a UV, it's >=0, so it must be < */
1712 SP--;
1713 SETs(&PL_sv_yes);
1714 RETURN;
1715 }
1716 buv = SvUVX(TOPs);
1717 SP--;
1718 SETs(boolSV((UV)aiv < buv));
1719 RETURN;
1720 }
1721 }
1722 }
1723#endif
1724#ifndef NV_PRESERVES_UV
1725#ifdef PERL_PRESERVE_IVUV
1726 else
1727#endif
1728 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1729 SP--;
1730 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1731 RETURN;
1732 }
1733#endif
1734 {
1735 dPOPnv;
1736 SETs(boolSV(TOPn < value));
1737 RETURN;
1738 }
1739}
1740
1741PP(pp_gt)
1742{
1743 dSP; tryAMAGICbinSET(gt,0);
1744#ifdef PERL_PRESERVE_IVUV
1745 SvIV_please(TOPs);
1746 if (SvIOK(TOPs)) {
1747 SvIV_please(TOPm1s);
1748 if (SvIOK(TOPm1s)) {
1749 bool auvok = SvUOK(TOPm1s);
1750 bool buvok = SvUOK(TOPs);
1751
1752 if (!auvok && !buvok) { /* ## IV > IV ## */
1753 const IV aiv = SvIVX(TOPm1s);
1754 const IV biv = SvIVX(TOPs);
1755
1756 SP--;
1757 SETs(boolSV(aiv > biv));
1758 RETURN;
1759 }
1760 if (auvok && buvok) { /* ## UV > UV ## */
1761 const UV auv = SvUVX(TOPm1s);
1762 const UV buv = SvUVX(TOPs);
1763
1764 SP--;
1765 SETs(boolSV(auv > buv));
1766 RETURN;
1767 }
1768 if (auvok) { /* ## UV > IV ## */
1769 UV auv;
1770 const IV biv = SvIVX(TOPs);
1771
1772 SP--;
1773 if (biv < 0) {
1774 /* As (a) is a UV, it's >=0, so it must be > */
1775 SETs(&PL_sv_yes);
1776 RETURN;
1777 }
1778 auv = SvUVX(TOPs);
1779 SETs(boolSV(auv > (UV)biv));
1780 RETURN;
1781 }
1782 { /* ## IV > UV ## */
1783 const IV aiv = SvIVX(TOPm1s);
1784 UV buv;
1785
1786 if (aiv < 0) {
1787 /* As (b) is a UV, it's >=0, so it cannot be > */
1788 SP--;
1789 SETs(&PL_sv_no);
1790 RETURN;
1791 }
1792 buv = SvUVX(TOPs);
1793 SP--;
1794 SETs(boolSV((UV)aiv > buv));
1795 RETURN;
1796 }
1797 }
1798 }
1799#endif
1800#ifndef NV_PRESERVES_UV
1801#ifdef PERL_PRESERVE_IVUV
1802 else
1803#endif
1804 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1805 SP--;
1806 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1807 RETURN;
1808 }
1809#endif
1810 {
1811 dPOPnv;
1812 SETs(boolSV(TOPn > value));
1813 RETURN;
1814 }
1815}
1816
1817PP(pp_le)
1818{
1819 dSP; tryAMAGICbinSET(le,0);
1820#ifdef PERL_PRESERVE_IVUV
1821 SvIV_please(TOPs);
1822 if (SvIOK(TOPs)) {
1823 SvIV_please(TOPm1s);
1824 if (SvIOK(TOPm1s)) {
1825 bool auvok = SvUOK(TOPm1s);
1826 bool buvok = SvUOK(TOPs);
1827
1828 if (!auvok && !buvok) { /* ## IV <= IV ## */
1829 const IV aiv = SvIVX(TOPm1s);
1830 const IV biv = SvIVX(TOPs);
1831
1832 SP--;
1833 SETs(boolSV(aiv <= biv));
1834 RETURN;
1835 }
1836 if (auvok && buvok) { /* ## UV <= UV ## */
1837 UV auv = SvUVX(TOPm1s);
1838 UV buv = SvUVX(TOPs);
1839
1840 SP--;
1841 SETs(boolSV(auv <= buv));
1842 RETURN;
1843 }
1844 if (auvok) { /* ## UV <= IV ## */
1845 UV auv;
1846 const IV biv = SvIVX(TOPs);
1847
1848 SP--;
1849 if (biv < 0) {
1850 /* As (a) is a UV, it's >=0, so a cannot be <= */
1851 SETs(&PL_sv_no);
1852 RETURN;
1853 }
1854 auv = SvUVX(TOPs);
1855 SETs(boolSV(auv <= (UV)biv));
1856 RETURN;
1857 }
1858 { /* ## IV <= UV ## */
1859 const IV aiv = SvIVX(TOPm1s);
1860 UV buv;
1861
1862 if (aiv < 0) {
1863 /* As (b) is a UV, it's >=0, so a must be <= */
1864 SP--;
1865 SETs(&PL_sv_yes);
1866 RETURN;
1867 }
1868 buv = SvUVX(TOPs);
1869 SP--;
1870 SETs(boolSV((UV)aiv <= buv));
1871 RETURN;
1872 }
1873 }
1874 }
1875#endif
1876#ifndef NV_PRESERVES_UV
1877#ifdef PERL_PRESERVE_IVUV
1878 else
1879#endif
1880 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1881 SP--;
1882 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1883 RETURN;
1884 }
1885#endif
1886 {
1887 dPOPnv;
1888 SETs(boolSV(TOPn <= value));
1889 RETURN;
1890 }
1891}
1892
1893PP(pp_ge)
1894{
1895 dSP; tryAMAGICbinSET(ge,0);
1896#ifdef PERL_PRESERVE_IVUV
1897 SvIV_please(TOPs);
1898 if (SvIOK(TOPs)) {
1899 SvIV_please(TOPm1s);
1900 if (SvIOK(TOPm1s)) {
1901 bool auvok = SvUOK(TOPm1s);
1902 bool buvok = SvUOK(TOPs);
1903
1904 if (!auvok && !buvok) { /* ## IV >= IV ## */
1905 const IV aiv = SvIVX(TOPm1s);
1906 const IV biv = SvIVX(TOPs);
1907
1908 SP--;
1909 SETs(boolSV(aiv >= biv));
1910 RETURN;
1911 }
1912 if (auvok && buvok) { /* ## UV >= UV ## */
1913 const UV auv = SvUVX(TOPm1s);
1914 const UV buv = SvUVX(TOPs);
1915
1916 SP--;
1917 SETs(boolSV(auv >= buv));
1918 RETURN;
1919 }
1920 if (auvok) { /* ## UV >= IV ## */
1921 UV auv;
1922 const IV biv = SvIVX(TOPs);
1923
1924 SP--;
1925 if (biv < 0) {
1926 /* As (a) is a UV, it's >=0, so it must be >= */
1927 SETs(&PL_sv_yes);
1928 RETURN;
1929 }
1930 auv = SvUVX(TOPs);
1931 SETs(boolSV(auv >= (UV)biv));
1932 RETURN;
1933 }
1934 { /* ## IV >= UV ## */
1935 const IV aiv = SvIVX(TOPm1s);
1936 UV buv;
1937
1938 if (aiv < 0) {
1939 /* As (b) is a UV, it's >=0, so a cannot be >= */
1940 SP--;
1941 SETs(&PL_sv_no);
1942 RETURN;
1943 }
1944 buv = SvUVX(TOPs);
1945 SP--;
1946 SETs(boolSV((UV)aiv >= buv));
1947 RETURN;
1948 }
1949 }
1950 }
1951#endif
1952#ifndef NV_PRESERVES_UV
1953#ifdef PERL_PRESERVE_IVUV
1954 else
1955#endif
1956 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1957 SP--;
1958 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1959 RETURN;
1960 }
1961#endif
1962 {
1963 dPOPnv;
1964 SETs(boolSV(TOPn >= value));
1965 RETURN;
1966 }
1967}
1968
1969PP(pp_ne)
1970{
1971 dSP; tryAMAGICbinSET(ne,0);
1972#ifndef NV_PRESERVES_UV
1973 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1974 SP--;
1975 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1976 RETURN;
1977 }
1978#endif
1979#ifdef PERL_PRESERVE_IVUV
1980 SvIV_please(TOPs);
1981 if (SvIOK(TOPs)) {
1982 SvIV_please(TOPm1s);
1983 if (SvIOK(TOPm1s)) {
1984 bool auvok = SvUOK(TOPm1s);
1985 bool buvok = SvUOK(TOPs);
1986
1987 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1988 /* Casting IV to UV before comparison isn't going to matter
1989 on 2s complement. On 1s complement or sign&magnitude
1990 (if we have any of them) it could make negative zero
1991 differ from normal zero. As I understand it. (Need to
1992 check - is negative zero implementation defined behaviour
1993 anyway?). NWC */
1994 const UV buv = SvUVX(POPs);
1995 const UV auv = SvUVX(TOPs);
1996
1997 SETs(boolSV(auv != buv));
1998 RETURN;
1999 }
2000 { /* ## Mixed IV,UV ## */
2001 IV iv;
2002 UV uv;
2003
2004 /* != is commutative so swap if needed (save code) */
2005 if (auvok) {
2006 /* swap. top of stack (b) is the iv */
2007 iv = SvIVX(TOPs);
2008 SP--;
2009 if (iv < 0) {
2010 /* As (a) is a UV, it's >0, so it cannot be == */
2011 SETs(&PL_sv_yes);
2012 RETURN;
2013 }
2014 uv = SvUVX(TOPs);
2015 } else {
2016 iv = SvIVX(TOPm1s);
2017 SP--;
2018 if (iv < 0) {
2019 /* As (b) is a UV, it's >0, so it cannot be == */
2020 SETs(&PL_sv_yes);
2021 RETURN;
2022 }
2023 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2024 }
2025 SETs(boolSV((UV)iv != uv));
2026 RETURN;
2027 }
2028 }
2029 }
2030#endif
2031 {
2032 dPOPnv;
2033 SETs(boolSV(TOPn != value));
2034 RETURN;
2035 }
2036}
2037
2038PP(pp_ncmp)
2039{
2040 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2041#ifndef NV_PRESERVES_UV
2042 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2043 UV right = PTR2UV(SvRV(POPs));
2044 UV left = PTR2UV(SvRV(TOPs));
2045 SETi((left > right) - (left < right));
2046 RETURN;
2047 }
2048#endif
2049#ifdef PERL_PRESERVE_IVUV
2050 /* Fortunately it seems NaN isn't IOK */
2051 SvIV_please(TOPs);
2052 if (SvIOK(TOPs)) {
2053 SvIV_please(TOPm1s);
2054 if (SvIOK(TOPm1s)) {
2055 const bool leftuvok = SvUOK(TOPm1s);
2056 const bool rightuvok = SvUOK(TOPs);
2057 I32 value;
2058 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2059 const IV leftiv = SvIVX(TOPm1s);
2060 const IV rightiv = SvIVX(TOPs);
2061
2062 if (leftiv > rightiv)
2063 value = 1;
2064 else if (leftiv < rightiv)
2065 value = -1;
2066 else
2067 value = 0;
2068 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2069 const UV leftuv = SvUVX(TOPm1s);
2070 const UV rightuv = SvUVX(TOPs);
2071
2072 if (leftuv > rightuv)
2073 value = 1;
2074 else if (leftuv < rightuv)
2075 value = -1;
2076 else
2077 value = 0;
2078 } else if (leftuvok) { /* ## UV <=> IV ## */
2079 const IV rightiv = SvIVX(TOPs);
2080 if (rightiv < 0) {
2081 /* As (a) is a UV, it's >=0, so it cannot be < */
2082 value = 1;
2083 } else {
2084 const UV leftuv = SvUVX(TOPm1s);
2085 if (leftuv > (UV)rightiv) {
2086 value = 1;
2087 } else if (leftuv < (UV)rightiv) {
2088 value = -1;
2089 } else {
2090 value = 0;
2091 }
2092 }
2093 } else { /* ## IV <=> UV ## */
2094 const IV leftiv = SvIVX(TOPm1s);
2095 if (leftiv < 0) {
2096 /* As (b) is a UV, it's >=0, so it must be < */
2097 value = -1;
2098 } else {
2099 const UV rightuv = SvUVX(TOPs);
2100 if ((UV)leftiv > rightuv) {
2101 value = 1;
2102 } else if ((UV)leftiv < rightuv) {
2103 value = -1;
2104 } else {
2105 value = 0;
2106 }
2107 }
2108 }
2109 SP--;
2110 SETi(value);
2111 RETURN;
2112 }
2113 }
2114#endif
2115 {
2116 dPOPTOPnnrl;
2117 I32 value;
2118
2119#ifdef Perl_isnan
2120 if (Perl_isnan(left) || Perl_isnan(right)) {
2121 SETs(&PL_sv_undef);
2122 RETURN;
2123 }
2124 value = (left > right) - (left < right);
2125#else
2126 if (left == right)
2127 value = 0;
2128 else if (left < right)
2129 value = -1;
2130 else if (left > right)
2131 value = 1;
2132 else {
2133 SETs(&PL_sv_undef);
2134 RETURN;
2135 }
2136#endif
2137 SETi(value);
2138 RETURN;
2139 }
2140}
2141
2142PP(pp_slt)
2143{
2144 dSP; tryAMAGICbinSET(slt,0);
2145 {
2146 dPOPTOPssrl;
2147 const int cmp = (IN_LOCALE_RUNTIME
2148 ? sv_cmp_locale(left, right)
2149 : sv_cmp(left, right));
2150 SETs(boolSV(cmp < 0));
2151 RETURN;
2152 }
2153}
2154
2155PP(pp_sgt)
2156{
2157 dSP; tryAMAGICbinSET(sgt,0);
2158 {
2159 dPOPTOPssrl;
2160 const int cmp = (IN_LOCALE_RUNTIME
2161 ? sv_cmp_locale(left, right)
2162 : sv_cmp(left, right));
2163 SETs(boolSV(cmp > 0));
2164 RETURN;
2165 }
2166}
2167
2168PP(pp_sle)
2169{
2170 dSP; tryAMAGICbinSET(sle,0);
2171 {
2172 dPOPTOPssrl;
2173 const int cmp = (IN_LOCALE_RUNTIME
2174 ? sv_cmp_locale(left, right)
2175 : sv_cmp(left, right));
2176 SETs(boolSV(cmp <= 0));
2177 RETURN;
2178 }
2179}
2180
2181PP(pp_sge)
2182{
2183 dSP; tryAMAGICbinSET(sge,0);
2184 {
2185 dPOPTOPssrl;
2186 const int cmp = (IN_LOCALE_RUNTIME
2187 ? sv_cmp_locale(left, right)
2188 : sv_cmp(left, right));
2189 SETs(boolSV(cmp >= 0));
2190 RETURN;
2191 }
2192}
2193
2194PP(pp_seq)
2195{
2196 dSP; tryAMAGICbinSET(seq,0);
2197 {
2198 dPOPTOPssrl;
2199 SETs(boolSV(sv_eq(left, right)));
2200 RETURN;
2201 }
2202}
2203
2204PP(pp_sne)
2205{
2206 dSP; tryAMAGICbinSET(sne,0);
2207 {
2208 dPOPTOPssrl;
2209 SETs(boolSV(!sv_eq(left, right)));
2210 RETURN;
2211 }
2212}
2213
2214PP(pp_scmp)
2215{
2216 dSP; dTARGET; tryAMAGICbin(scmp,0);
2217 {
2218 dPOPTOPssrl;
2219 const int cmp = (IN_LOCALE_RUNTIME
2220 ? sv_cmp_locale(left, right)
2221 : sv_cmp(left, right));
2222 SETi( cmp );
2223 RETURN;
2224 }
2225}
2226
2227PP(pp_bit_and)
2228{
2229 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2230 {
2231 dPOPTOPssrl;
2232 if (SvNIOKp(left) || SvNIOKp(right)) {
2233 if (PL_op->op_private & HINT_INTEGER) {
2234 const IV i = SvIV(left) & SvIV(right);
2235 SETi(i);
2236 }
2237 else {
2238 const UV u = SvUV(left) & SvUV(right);
2239 SETu(u);
2240 }
2241 }
2242 else {
2243 do_vop(PL_op->op_type, TARG, left, right);
2244 SETTARG;
2245 }
2246 RETURN;
2247 }
2248}
2249
2250PP(pp_bit_xor)
2251{
2252 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2253 {
2254 dPOPTOPssrl;
2255 if (SvNIOKp(left) || SvNIOKp(right)) {
2256 if (PL_op->op_private & HINT_INTEGER) {
2257 const IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
2258 SETi(i);
2259 }
2260 else {
2261 const UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
2262 SETu(u);
2263 }
2264 }
2265 else {
2266 do_vop(PL_op->op_type, TARG, left, right);
2267 SETTARG;
2268 }
2269 RETURN;
2270 }
2271}
2272
2273PP(pp_bit_or)
2274{
2275 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2276 {
2277 dPOPTOPssrl;
2278 if (SvNIOKp(left) || SvNIOKp(right)) {
2279 if (PL_op->op_private & HINT_INTEGER) {
2280 const IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
2281 SETi(i);
2282 }
2283 else {
2284 const UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
2285 SETu(u);
2286 }
2287 }
2288 else {
2289 do_vop(PL_op->op_type, TARG, left, right);
2290 SETTARG;
2291 }
2292 RETURN;
2293 }
2294}
2295
2296PP(pp_negate)
2297{
2298 dSP; dTARGET; tryAMAGICun(neg);
2299 {
2300 dTOPss;
2301 const int flags = SvFLAGS(sv);
2302 if (SvGMAGICAL(sv))
2303 mg_get(sv);
2304 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2305 /* It's publicly an integer, or privately an integer-not-float */
2306 oops_its_an_int:
2307 if (SvIsUV(sv)) {
2308 if (SvIVX(sv) == IV_MIN) {
2309 /* 2s complement assumption. */
2310 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2311 RETURN;
2312 }
2313 else if (SvUVX(sv) <= IV_MAX) {
2314 SETi(-SvIVX(sv));
2315 RETURN;
2316 }
2317 }
2318 else if (SvIVX(sv) != IV_MIN) {
2319 SETi(-SvIVX(sv));
2320 RETURN;
2321 }
2322#ifdef PERL_PRESERVE_IVUV
2323 else {
2324 SETu((UV)IV_MIN);
2325 RETURN;
2326 }
2327#endif
2328 }
2329 if (SvNIOKp(sv))
2330 SETn(-SvNV(sv));
2331 else if (SvPOKp(sv)) {
2332 STRLEN len;
2333 const char *s = SvPV_const(sv, len);
2334 if (isIDFIRST(*s)) {
2335 sv_setpvn(TARG, "-", 1);
2336 sv_catsv(TARG, sv);
2337 }
2338 else if (*s == '+' || *s == '-') {
2339 sv_setsv(TARG, sv);
2340 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2341 }
2342 else if (DO_UTF8(sv)) {
2343 SvIV_please(sv);
2344 if (SvIOK(sv))
2345 goto oops_its_an_int;
2346 if (SvNOK(sv))
2347 sv_setnv(TARG, -SvNV(sv));
2348 else {
2349 sv_setpvn(TARG, "-", 1);
2350 sv_catsv(TARG, sv);
2351 }
2352 }
2353 else {
2354 SvIV_please(sv);
2355 if (SvIOK(sv))
2356 goto oops_its_an_int;
2357 sv_setnv(TARG, -SvNV(sv));
2358 }
2359 SETTARG;
2360 }
2361 else
2362 SETn(-SvNV(sv));
2363 }
2364 RETURN;
2365}
2366
2367PP(pp_not)
2368{
2369 dSP; tryAMAGICunSET(not);
2370 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2371 return NORMAL;
2372}
2373
2374PP(pp_complement)
2375{
2376 dSP; dTARGET; tryAMAGICun(compl);
2377 {
2378 dTOPss;
2379 if (SvNIOKp(sv)) {
2380 if (PL_op->op_private & HINT_INTEGER) {
2381 const IV i = ~SvIV(sv);
2382 SETi(i);
2383 }
2384 else {
2385 const UV u = ~SvUV(sv);
2386 SETu(u);
2387 }
2388 }
2389 else {
2390 register U8 *tmps;
2391 register I32 anum;
2392 STRLEN len;
2393
2394 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2395 SvSetSV(TARG, sv);
2396 tmps = (U8*)SvPV_force(TARG, len);
2397 anum = len;
2398 if (SvUTF8(TARG)) {
2399 /* Calculate exact length, let's not estimate. */
2400 STRLEN targlen = 0;
2401 U8 *result;
2402 U8 *send;
2403 STRLEN l;
2404 UV nchar = 0;
2405 UV nwide = 0;
2406
2407 send = tmps + len;
2408 while (tmps < send) {
2409 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2410 tmps += UTF8SKIP(tmps);
2411 targlen += UNISKIP(~c);
2412 nchar++;
2413 if (c > 0xff)
2414 nwide++;
2415 }
2416
2417 /* Now rewind strings and write them. */
2418 tmps -= len;
2419
2420 if (nwide) {
2421 Newxz(result, targlen + 1, U8);
2422 while (tmps < send) {
2423 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2424 tmps += UTF8SKIP(tmps);
2425 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2426 }
2427 *result = '\0';
2428 result -= targlen;
2429 sv_setpvn(TARG, (char*)result, targlen);
2430 SvUTF8_on(TARG);
2431 }
2432 else {
2433 Newxz(result, nchar + 1, U8);
2434 while (tmps < send) {
2435 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2436 tmps += UTF8SKIP(tmps);
2437 *result++ = ~c;
2438 }
2439 *result = '\0';
2440 result -= nchar;
2441 sv_setpvn(TARG, (char*)result, nchar);
2442 SvUTF8_off(TARG);
2443 }
2444 Safefree(result);
2445 SETs(TARG);
2446 RETURN;
2447 }
2448#ifdef LIBERAL
2449 {
2450 register long *tmpl;
2451 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2452 *tmps = ~*tmps;
2453 tmpl = (long*)tmps;
2454 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2455 *tmpl = ~*tmpl;
2456 tmps = (U8*)tmpl;
2457 }
2458#endif
2459 for ( ; anum > 0; anum--, tmps++)
2460 *tmps = ~*tmps;
2461
2462 SETs(TARG);
2463 }
2464 RETURN;
2465 }
2466}
2467
2468/* integer versions of some of the above */
2469
2470PP(pp_i_multiply)
2471{
2472 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2473 {
2474 dPOPTOPiirl;
2475 SETi( left * right );
2476 RETURN;
2477 }
2478}
2479
2480PP(pp_i_divide)
2481{
2482 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2483 {
2484 dPOPiv;
2485 if (value == 0)
2486 DIE(aTHX_ "Illegal division by zero");
2487 value = POPi / value;
2488 PUSHi( value );
2489 RETURN;
2490 }
2491}
2492
2493STATIC
2494PP(pp_i_modulo_0)
2495{
2496 /* This is the vanilla old i_modulo. */
2497 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2498 {
2499 dPOPTOPiirl;
2500 if (!right)
2501 DIE(aTHX_ "Illegal modulus zero");
2502 SETi( left % right );
2503 RETURN;
2504 }
2505}
2506
2507#if defined(__GLIBC__) && IVSIZE == 8
2508STATIC
2509PP(pp_i_modulo_1)
2510{
2511 /* This is the i_modulo with the workaround for the _moddi3 bug
2512 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2513 * See below for pp_i_modulo. */
2514 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2515 {
2516 dPOPTOPiirl;
2517 if (!right)
2518 DIE(aTHX_ "Illegal modulus zero");
2519 SETi( left % PERL_ABS(right) );
2520 RETURN;
2521 }
2522}
2523#endif
2524
2525PP(pp_i_modulo)
2526{
2527 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2528 {
2529 dPOPTOPiirl;
2530 if (!right)
2531 DIE(aTHX_ "Illegal modulus zero");
2532 /* The assumption is to use hereafter the old vanilla version... */
2533 PL_op->op_ppaddr =
2534 PL_ppaddr[OP_I_MODULO] =
2535 Perl_pp_i_modulo_0;
2536 /* .. but if we have glibc, we might have a buggy _moddi3
2537 * (at least glicb 2.2.5 is known to have this bug), in other
2538 * words our integer modulus with negative quad as the second
2539 * argument might be broken. Test for this and re-patch the
2540 * opcode dispatch table if that is the case, remembering to
2541 * also apply the workaround so that this first round works
2542 * right, too. See [perl #9402] for more information. */
2543#if defined(__GLIBC__) && IVSIZE == 8
2544 {
2545 IV l = 3;
2546 IV r = -10;
2547 /* Cannot do this check with inlined IV constants since
2548 * that seems to work correctly even with the buggy glibc. */
2549 if (l % r == -3) {
2550 /* Yikes, we have the bug.
2551 * Patch in the workaround version. */
2552 PL_op->op_ppaddr =
2553 PL_ppaddr[OP_I_MODULO] =
2554 &Perl_pp_i_modulo_1;
2555 /* Make certain we work right this time, too. */
2556 right = PERL_ABS(right);
2557 }
2558 }
2559#endif
2560 SETi( left % right );
2561 RETURN;
2562 }
2563}
2564
2565PP(pp_i_add)
2566{
2567 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2568 {
2569 dPOPTOPiirl_ul;
2570 SETi( left + right );
2571 RETURN;
2572 }
2573}
2574
2575PP(pp_i_subtract)
2576{
2577 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2578 {
2579 dPOPTOPiirl_ul;
2580 SETi( left - right );
2581 RETURN;
2582 }
2583}
2584
2585PP(pp_i_lt)
2586{
2587 dSP; tryAMAGICbinSET(lt,0);
2588 {
2589 dPOPTOPiirl;
2590 SETs(boolSV(left < right));
2591 RETURN;
2592 }
2593}
2594
2595PP(pp_i_gt)
2596{
2597 dSP; tryAMAGICbinSET(gt,0);
2598 {
2599 dPOPTOPiirl;
2600 SETs(boolSV(left > right));
2601 RETURN;
2602 }
2603}
2604
2605PP(pp_i_le)
2606{
2607 dSP; tryAMAGICbinSET(le,0);
2608 {
2609 dPOPTOPiirl;
2610 SETs(boolSV(left <= right));
2611 RETURN;
2612 }
2613}
2614
2615PP(pp_i_ge)
2616{
2617 dSP; tryAMAGICbinSET(ge,0);
2618 {
2619 dPOPTOPiirl;
2620 SETs(boolSV(left >= right));
2621 RETURN;
2622 }
2623}
2624
2625PP(pp_i_eq)
2626{
2627 dSP; tryAMAGICbinSET(eq,0);
2628 {
2629 dPOPTOPiirl;
2630 SETs(boolSV(left == right));
2631 RETURN;
2632 }
2633}
2634
2635PP(pp_i_ne)
2636{
2637 dSP; tryAMAGICbinSET(ne,0);
2638 {
2639 dPOPTOPiirl;
2640 SETs(boolSV(left != right));
2641 RETURN;
2642 }
2643}
2644
2645PP(pp_i_ncmp)
2646{
2647 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2648 {
2649 dPOPTOPiirl;
2650 I32 value;
2651
2652 if (left > right)
2653 value = 1;
2654 else if (left < right)
2655 value = -1;
2656 else
2657 value = 0;
2658 SETi(value);
2659 RETURN;
2660 }
2661}
2662
2663PP(pp_i_negate)
2664{
2665 dSP; dTARGET; tryAMAGICun(neg);
2666 SETi(-TOPi);
2667 RETURN;
2668}
2669
2670/* High falutin' math. */
2671
2672PP(pp_atan2)
2673{
2674 dSP; dTARGET; tryAMAGICbin(atan2,0);
2675 {
2676 dPOPTOPnnrl;
2677 SETn(Perl_atan2(left, right));
2678 RETURN;
2679 }
2680}
2681
2682PP(pp_sin)
2683{
2684 dSP; dTARGET; tryAMAGICun(sin);
2685 {
2686 const NV value = POPn;
2687 XPUSHn(Perl_sin(value));
2688 RETURN;
2689 }
2690}
2691
2692PP(pp_cos)
2693{
2694 dSP; dTARGET; tryAMAGICun(cos);
2695 {
2696 const NV value = POPn;
2697 XPUSHn(Perl_cos(value));
2698 RETURN;
2699 }
2700}
2701
2702/* Support Configure command-line overrides for rand() functions.
2703 After 5.005, perhaps we should replace this by Configure support
2704 for drand48(), random(), or rand(). For 5.005, though, maintain
2705 compatibility by calling rand() but allow the user to override it.
2706 See INSTALL for details. --Andy Dougherty 15 July 1998
2707*/
2708/* Now it's after 5.005, and Configure supports drand48() and random(),
2709 in addition to rand(). So the overrides should not be needed any more.
2710 --Jarkko Hietaniemi 27 September 1998
2711 */
2712
2713#ifndef HAS_DRAND48_PROTO
2714extern double drand48 (void);
2715#endif
2716
2717PP(pp_rand)
2718{
2719 dSP; dTARGET;
2720 NV value;
2721 if (MAXARG < 1)
2722 value = 1.0;
2723 else
2724 value = POPn;
2725 if (value == 0.0)
2726 value = 1.0;
2727 if (!PL_srand_called) {
2728 (void)seedDrand01((Rand_seed_t)seed());
2729 PL_srand_called = TRUE;
2730 }
2731 value *= Drand01();
2732 XPUSHn(value);
2733 RETURN;
2734}
2735
2736PP(pp_srand)
2737{
2738 dSP;
2739 UV anum;
2740 if (MAXARG < 1)
2741 anum = seed();
2742 else
2743 anum = POPu;
2744 (void)seedDrand01((Rand_seed_t)anum);
2745 PL_srand_called = TRUE;
2746 EXTEND(SP, 1);
2747 RETPUSHYES;
2748}
2749
2750PP(pp_exp)
2751{
2752 dSP; dTARGET; tryAMAGICun(exp);
2753 {
2754 NV value;
2755 value = POPn;
2756 value = Perl_exp(value);
2757 XPUSHn(value);
2758 RETURN;
2759 }
2760}
2761
2762PP(pp_log)
2763{
2764 dSP; dTARGET; tryAMAGICun(log);
2765 {
2766 const NV value = POPn;
2767 if (value <= 0.0) {
2768 SET_NUMERIC_STANDARD();
2769 DIE(aTHX_ "Can't take log of %"NVgf, value);
2770 }
2771 XPUSHn(Perl_log(value));
2772 RETURN;
2773 }
2774}
2775
2776PP(pp_sqrt)
2777{
2778 dSP; dTARGET; tryAMAGICun(sqrt);
2779 {
2780 const NV value = POPn;
2781 if (value < 0.0) {
2782 SET_NUMERIC_STANDARD();
2783 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2784 }
2785 XPUSHn(Perl_sqrt(value));
2786 RETURN;
2787 }
2788}
2789
2790PP(pp_int)
2791{
2792 dSP; dTARGET; tryAMAGICun(int);
2793 {
2794 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2795 /* XXX it's arguable that compiler casting to IV might be subtly
2796 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2797 else preferring IV has introduced a subtle behaviour change bug. OTOH
2798 relying on floating point to be accurate is a bug. */
2799
2800 if (!SvOK(TOPs))
2801 SETu(0);
2802 else if (SvIOK(TOPs)) {
2803 if (SvIsUV(TOPs)) {
2804 const UV uv = TOPu;
2805 SETu(uv);
2806 } else
2807 SETi(iv);
2808 } else {
2809 const NV value = TOPn;
2810 if (value >= 0.0) {
2811 if (value < (NV)UV_MAX + 0.5) {
2812 SETu(U_V(value));
2813 } else {
2814 SETn(Perl_floor(value));
2815 }
2816 }
2817 else {
2818 if (value > (NV)IV_MIN - 0.5) {
2819 SETi(I_V(value));
2820 } else {
2821 SETn(Perl_ceil(value));
2822 }
2823 }
2824 }
2825 }
2826 RETURN;
2827}
2828
2829PP(pp_abs)
2830{
2831 dSP; dTARGET; tryAMAGICun(abs);
2832 {
2833 /* This will cache the NV value if string isn't actually integer */
2834 const IV iv = TOPi;
2835
2836 if (!SvOK(TOPs))
2837 SETu(0);
2838 else if (SvIOK(TOPs)) {
2839 /* IVX is precise */
2840 if (SvIsUV(TOPs)) {
2841 SETu(TOPu); /* force it to be numeric only */
2842 } else {
2843 if (iv >= 0) {
2844 SETi(iv);
2845 } else {
2846 if (iv != IV_MIN) {
2847 SETi(-iv);
2848 } else {
2849 /* 2s complement assumption. Also, not really needed as
2850 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2851 SETu(IV_MIN);
2852 }
2853 }
2854 }
2855 } else{
2856 const NV value = TOPn;
2857 if (value < 0.0)
2858 SETn(-value);
2859 else
2860 SETn(value);
2861 }
2862 }
2863 RETURN;
2864}
2865
2866
2867PP(pp_hex)
2868{
2869 dSP; dTARGET;
2870 const char *tmps;
2871 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2872 STRLEN len;
2873 NV result_nv;
2874 UV result_uv;
2875 SV* const sv = POPs;
2876
2877 tmps = (SvPV_const(sv, len));
2878 if (DO_UTF8(sv)) {
2879 /* If Unicode, try to downgrade
2880 * If not possible, croak. */
2881 SV* const tsv = sv_2mortal(newSVsv(sv));
2882
2883 SvUTF8_on(tsv);
2884 sv_utf8_downgrade(tsv, FALSE);
2885 tmps = SvPV_const(tsv, len);
2886 }
2887 result_uv = grok_hex ((char *)tmps, &len, &flags, &result_nv);
2888 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2889 XPUSHn(result_nv);
2890 }
2891 else {
2892 XPUSHu(result_uv);
2893 }
2894 RETURN;
2895}
2896
2897PP(pp_oct)
2898{
2899 dSP; dTARGET;
2900 const char *tmps;
2901 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2902 STRLEN len;
2903 NV result_nv;
2904 UV result_uv;
2905 SV* const sv = POPs;
2906
2907 tmps = (SvPV_const(sv, len));
2908 if (DO_UTF8(sv)) {
2909 /* If Unicode, try to downgrade
2910 * If not possible, croak. */
2911 SV* const tsv = sv_2mortal(newSVsv(sv));
2912
2913 SvUTF8_on(tsv);
2914 sv_utf8_downgrade(tsv, FALSE);
2915 tmps = SvPV_const(tsv, len);
2916 }
2917 while (*tmps && len && isSPACE(*tmps))
2918 tmps++, len--;
2919 if (*tmps == '0')
2920 tmps++, len--;
2921 if (*tmps == 'x')
2922 result_uv = grok_hex ((char *)tmps, &len, &flags, &result_nv);
2923 else if (*tmps == 'b')
2924 result_uv = grok_bin ((char *)tmps, &len, &flags, &result_nv);
2925 else
2926 result_uv = grok_oct ((char *)tmps, &len, &flags, &result_nv);
2927
2928 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2929 XPUSHn(result_nv);
2930 }
2931 else {
2932 XPUSHu(result_uv);
2933 }
2934 RETURN;
2935}
2936
2937/* String stuff. */
2938
2939PP(pp_length)
2940{
2941 dSP; dTARGET;
2942 SV *sv = TOPs;
2943
2944 if (DO_UTF8(sv))
2945 SETi(sv_len_utf8(sv));
2946 else
2947 SETi(sv_len(sv));
2948 RETURN;
2949}
2950
2951PP(pp_substr)
2952{
2953 dSP; dTARGET;
2954 SV *sv;
2955 I32 len = 0;
2956 STRLEN curlen;
2957 STRLEN utf8_curlen;
2958 I32 pos;
2959 I32 rem;
2960 I32 fail;
2961 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2962 const char *tmps;
2963 const I32 arybase = PL_curcop->cop_arybase;
2964 SV *repl_sv = NULL;
2965 const char *repl = 0;
2966 STRLEN repl_len;
2967 const int num_args = PL_op->op_private & 7;
2968 bool repl_need_utf8_upgrade = FALSE;
2969 bool repl_is_utf8 = FALSE;
2970
2971 SvTAINTED_off(TARG); /* decontaminate */
2972 SvUTF8_off(TARG); /* decontaminate */
2973 if (num_args > 2) {
2974 if (num_args > 3) {
2975 repl_sv = POPs;
2976 repl = SvPV_const(repl_sv, repl_len);
2977 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2978 }
2979 len = POPi;
2980 }
2981 pos = POPi;
2982 sv = POPs;
2983 PUTBACK;
2984 if (repl_sv) {
2985 if (repl_is_utf8) {
2986 if (!DO_UTF8(sv))
2987 sv_utf8_upgrade(sv);
2988 }
2989 else if (DO_UTF8(sv))
2990 repl_need_utf8_upgrade = TRUE;
2991 }
2992 tmps = SvPV_const(sv, curlen);
2993 if (DO_UTF8(sv)) {
2994 utf8_curlen = sv_len_utf8(sv);
2995 if (utf8_curlen == curlen)
2996 utf8_curlen = 0;
2997 else
2998 curlen = utf8_curlen;
2999 }
3000 else
3001 utf8_curlen = 0;
3002
3003 if (pos >= arybase) {
3004 pos -= arybase;
3005 rem = curlen-pos;
3006 fail = rem;
3007 if (num_args > 2) {
3008 if (len < 0) {
3009 rem += len;
3010 if (rem < 0)
3011 rem = 0;
3012 }
3013 else if (rem > len)
3014 rem = len;
3015 }
3016 }
3017 else {
3018 pos += curlen;
3019 if (num_args < 3)
3020 rem = curlen;
3021 else if (len >= 0) {
3022 rem = pos+len;
3023 if (rem > (I32)curlen)
3024 rem = curlen;
3025 }
3026 else {
3027 rem = curlen+len;
3028 if (rem < pos)
3029 rem = pos;
3030 }
3031 if (pos < 0)
3032 pos = 0;
3033 fail = rem;
3034 rem -= pos;
3035 }
3036 if (fail < 0) {
3037 if (lvalue || repl)
3038 Perl_croak(aTHX_ "substr outside of string");
3039 if (ckWARN(WARN_SUBSTR))
3040 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3041 RETPUSHUNDEF;
3042 }
3043 else {
3044 const I32 upos = pos;
3045 const I32 urem = rem;
3046 if (utf8_curlen)
3047 sv_pos_u2b(sv, &pos, &rem);
3048 tmps += pos;
3049 /* we either return a PV or an LV. If the TARG hasn't been used
3050 * before, or is of that type, reuse it; otherwise use a mortal
3051 * instead. Note that LVs can have an extended lifetime, so also
3052 * dont reuse if refcount > 1 (bug #20933) */
3053 if (SvTYPE(TARG) > SVt_NULL) {
3054 if ( (SvTYPE(TARG) == SVt_PVLV)
3055 ? (!lvalue || SvREFCNT(TARG) > 1)
3056 : lvalue)
3057 {
3058 TARG = sv_newmortal();
3059 }
3060 }
3061
3062 sv_setpvn(TARG, tmps, rem);
3063#ifdef USE_LOCALE_COLLATE
3064 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3065#endif
3066 if (utf8_curlen)
3067 SvUTF8_on(TARG);
3068 if (repl) {
3069 SV* repl_sv_copy = NULL;
3070
3071 if (repl_need_utf8_upgrade) {
3072 repl_sv_copy = newSVsv(repl_sv);
3073 sv_utf8_upgrade(repl_sv_copy);
3074 repl = SvPV_const(repl_sv_copy, repl_len);
3075 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3076 }
3077 sv_insert(sv, pos, rem, (char *)repl, repl_len);
3078 if (repl_is_utf8)
3079 SvUTF8_on(sv);
3080 if (repl_sv_copy)
3081 SvREFCNT_dec(repl_sv_copy);
3082 }
3083 else if (lvalue) { /* it's an lvalue! */
3084 if (!SvGMAGICAL(sv)) {
3085 if (SvROK(sv)) {
3086 SvPV_force_nolen(sv);
3087 if (ckWARN(WARN_SUBSTR))
3088 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3089 "Attempt to use reference as lvalue in substr");
3090 }
3091 if (SvOK(sv)) /* is it defined ? */
3092 (void)SvPOK_only_UTF8(sv);
3093 else
3094 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3095 }
3096
3097 if (SvTYPE(TARG) < SVt_PVLV) {
3098 sv_upgrade(TARG, SVt_PVLV);
3099 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3100 }
3101 else
3102 SvOK_off(TARG);
3103
3104 LvTYPE(TARG) = 'x';
3105 if (LvTARG(TARG) != sv) {
3106 if (LvTARG(TARG))
3107 SvREFCNT_dec(LvTARG(TARG));
3108 LvTARG(TARG) = SvREFCNT_inc(sv);
3109 }
3110 LvTARGOFF(TARG) = upos;
3111 LvTARGLEN(TARG) = urem;
3112 }
3113 }
3114 SPAGAIN;
3115 PUSHs(TARG); /* avoid SvSETMAGIC here */
3116 RETURN;
3117}
3118
3119PP(pp_vec)
3120{
3121 dSP; dTARGET;
3122 register const IV size = POPi;
3123 register const IV offset = POPi;
3124 register SV * const src = POPs;
3125 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3126
3127 SvTAINTED_off(TARG); /* decontaminate */
3128 if (lvalue) { /* it's an lvalue! */
3129 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3130 TARG = sv_newmortal();
3131 if (SvTYPE(TARG) < SVt_PVLV) {
3132 sv_upgrade(TARG, SVt_PVLV);
3133 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3134 }
3135 LvTYPE(TARG) = 'v';
3136 if (LvTARG(TARG) != src) {
3137 if (LvTARG(TARG))
3138 SvREFCNT_dec(LvTARG(TARG));
3139 LvTARG(TARG) = SvREFCNT_inc(src);
3140 }
3141 LvTARGOFF(TARG) = offset;
3142 LvTARGLEN(TARG) = size;
3143 }
3144
3145 sv_setuv(TARG, do_vecget(src, offset, size));
3146 PUSHs(TARG);
3147 RETURN;
3148}
3149
3150PP(pp_index)
3151{
3152 dSP; dTARGET;
3153 SV *big;
3154 SV *little;
3155 SV *temp = Nullsv;
3156 I32 offset;
3157 I32 retval;
3158 const char *tmps;
3159 const char *tmps2;
3160 STRLEN biglen;
3161 const I32 arybase = PL_curcop->cop_arybase;
3162 int big_utf8;
3163 int little_utf8;
3164
3165 if (MAXARG < 3)
3166 offset = 0;
3167 else
3168 offset = POPi - arybase;
3169 little = POPs;
3170 big = POPs;
3171 big_utf8 = DO_UTF8(big);
3172 little_utf8 = DO_UTF8(little);
3173 if (big_utf8 ^ little_utf8) {
3174 /* One needs to be upgraded. */
3175 SV * const bytes = little_utf8 ? big : little;
3176 STRLEN len;
3177 const char * const p = SvPV_const(bytes, len);
3178
3179 temp = newSVpvn(p, len);
3180
3181 if (PL_encoding) {
3182 sv_recode_to_utf8(temp, PL_encoding);
3183 } else {
3184 sv_utf8_upgrade(temp);
3185 }
3186 if (little_utf8) {
3187 big = temp;
3188 big_utf8 = TRUE;
3189 } else {
3190 little = temp;
3191 }
3192 }
3193 if (big_utf8 && offset > 0)
3194 sv_pos_u2b(big, &offset, 0);
3195 tmps = SvPV_const(big, biglen);
3196 if (offset < 0)
3197 offset = 0;
3198 else if (offset > (I32)biglen)
3199 offset = biglen;
3200 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3201 (unsigned char*)tmps + biglen, little, 0)))
3202 retval = -1;
3203 else
3204 retval = tmps2 - tmps;
3205 if (retval > 0 && big_utf8)
3206 sv_pos_b2u(big, &retval);
3207 if (temp)
3208 SvREFCNT_dec(temp);
3209 PUSHi(retval + arybase);
3210 RETURN;
3211}
3212
3213PP(pp_rindex)
3214{
3215 dSP; dTARGET;
3216 SV *big;
3217 SV *little;
3218 SV *temp = Nullsv;
3219 STRLEN blen;
3220 STRLEN llen;
3221 I32 offset;
3222 I32 retval;
3223 const char *tmps;
3224 const char *tmps2;
3225 const I32 arybase = PL_curcop->cop_arybase;
3226 int big_utf8;
3227 int little_utf8;
3228
3229 if (MAXARG >= 3)
3230 offset = POPi;
3231 little = POPs;
3232 big = POPs;
3233 big_utf8 = DO_UTF8(big);
3234 little_utf8 = DO_UTF8(little);
3235 if (big_utf8 ^ little_utf8) {
3236 /* One needs to be upgraded. */
3237 SV * const bytes = little_utf8 ? big : little;
3238 STRLEN len;
3239 const char *p = SvPV_const(bytes, len);
3240
3241 temp = newSVpvn(p, len);
3242
3243 if (PL_encoding) {
3244 sv_recode_to_utf8(temp, PL_encoding);
3245 } else {
3246 sv_utf8_upgrade(temp);
3247 }
3248 if (little_utf8) {
3249 big = temp;
3250 big_utf8 = TRUE;
3251 } else {
3252 little = temp;
3253 }
3254 }
3255 tmps2 = SvPV_const(little, llen);
3256 tmps = SvPV_const(big, blen);
3257
3258 if (MAXARG < 3)
3259 offset = blen;
3260 else {
3261 if (offset > 0 && big_utf8)
3262 sv_pos_u2b(big, &offset, 0);
3263 offset = offset - arybase + llen;
3264 }
3265 if (offset < 0)
3266 offset = 0;
3267 else if (offset > (I32)blen)
3268 offset = blen;
3269 if (!(tmps2 = rninstr(tmps, tmps + offset,
3270 tmps2, tmps2 + llen)))
3271 retval = -1;
3272 else
3273 retval = tmps2 - tmps;
3274 if (retval > 0 && big_utf8)
3275 sv_pos_b2u(big, &retval);
3276 if (temp)
3277 SvREFCNT_dec(temp);
3278 PUSHi(retval + arybase);
3279 RETURN;
3280}
3281
3282PP(pp_sprintf)
3283{
3284 dSP; dMARK; dORIGMARK; dTARGET;
3285 do_sprintf(TARG, SP-MARK, MARK+1);
3286 TAINT_IF(SvTAINTED(TARG));
3287 if (DO_UTF8(*(MARK+1)))
3288 SvUTF8_on(TARG);
3289 SP = ORIGMARK;
3290 PUSHTARG;
3291 RETURN;
3292}
3293
3294PP(pp_ord)
3295{
3296 dSP; dTARGET;
3297 SV *argsv = POPs;
3298 STRLEN len;
3299 const U8 *s = (U8*)SvPV_const(argsv, len);
3300 SV *tmpsv;
3301
3302 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3303 tmpsv = sv_2mortal(newSVsv(argsv));
3304 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3305 argsv = tmpsv;
3306 }
3307
3308 XPUSHu(DO_UTF8(argsv) ?
3309 utf8n_to_uvchr((U8 *)s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3310 (*s & 0xff));
3311
3312 RETURN;
3313}
3314
3315PP(pp_chr)
3316{
3317 dSP; dTARGET;
3318 char *tmps;
3319 UV value = POPu;
3320
3321 (void)SvUPGRADE(TARG,SVt_PV);
3322
3323 if (value > 255 && !IN_BYTES) {
3324 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3325 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3326 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3327 *tmps = '\0';
3328 (void)SvPOK_only(TARG);
3329 SvUTF8_on(TARG);
3330 XPUSHs(TARG);
3331 RETURN;
3332 }
3333
3334 SvGROW(TARG,2);
3335 SvCUR_set(TARG, 1);
3336 tmps = SvPVX(TARG);
3337 *tmps++ = (char)value;
3338 *tmps = '\0';
3339 (void)SvPOK_only(TARG);
3340 if (PL_encoding && !IN_BYTES) {
3341 sv_recode_to_utf8(TARG, PL_encoding);
3342 tmps = SvPVX(TARG);
3343 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3344 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3345 SvGROW(TARG, 3);
3346 tmps = SvPVX(TARG);
3347 SvCUR_set(TARG, 2);
3348 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3349 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3350 *tmps = '\0';
3351 SvUTF8_on(TARG);
3352 }
3353 }
3354 XPUSHs(TARG);
3355 RETURN;
3356}
3357
3358PP(pp_crypt)
3359{
3360#ifdef HAS_CRYPT
3361 dSP; dTARGET;
3362 dPOPTOPssrl;
3363 STRLEN len;
3364 const char *tmps = SvPV_const(left, len);
3365
3366 if (DO_UTF8(left)) {
3367 /* If Unicode, try to downgrade.
3368 * If not possible, croak.
3369 * Yes, we made this up. */
3370 SV* const tsv = sv_2mortal(newSVsv(left));
3371
3372 SvUTF8_on(tsv);
3373 sv_utf8_downgrade(tsv, FALSE);
3374 tmps = SvPV_const(tsv, len);
3375 }
3376# ifdef USE_ITHREADS
3377# ifdef HAS_CRYPT_R
3378 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3379 /* This should be threadsafe because in ithreads there is only
3380 * one thread per interpreter. If this would not be true,
3381 * we would need a mutex to protect this malloc. */
3382 PL_reentrant_buffer->_crypt_struct_buffer =
3383 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3384#if defined(__GLIBC__) || defined(__EMX__)
3385 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3386 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3387 /* work around glibc-2.2.5 bug */
3388 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3389 }
3390#endif
3391 }
3392# endif /* HAS_CRYPT_R */
3393# endif /* USE_ITHREADS */
3394# ifdef FCRYPT
3395 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3396# else
3397 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3398# endif
3399 SETs(TARG);
3400 RETURN;
3401#else
3402 DIE(aTHX_
3403 "The crypt() function is unimplemented due to excessive paranoia.");
3404#endif
3405}
3406
3407PP(pp_ucfirst)
3408{
3409 dSP;
3410 SV *sv = TOPs;
3411 const U8 *s;
3412 STRLEN slen;
3413
3414 SvGETMAGIC(sv);
3415 if (DO_UTF8(sv) &&
3416 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3417 UTF8_IS_START(*s)) {
3418 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3419 STRLEN ulen;
3420 STRLEN tculen;
3421
3422 utf8_to_uvchr((U8 *)s, &ulen);
3423 toTITLE_utf8((U8 *)s, tmpbuf, &tculen);
3424
3425 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3426 dTARGET;
3427 /* slen is the byte length of the whole SV.
3428 * ulen is the byte length of the original Unicode character
3429 * stored as UTF-8 at s.
3430 * tculen is the byte length of the freshly titlecased
3431 * Unicode character stored as UTF-8 at tmpbuf.
3432 * We first set the result to be the titlecased character,
3433 * and then append the rest of the SV data. */
3434 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3435 if (slen > ulen)
3436 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3437 SvUTF8_on(TARG);
3438 SETs(TARG);
3439 }
3440 else {
3441 s = (U8*)SvPV_force_nomg(sv, slen);
3442 Copy(tmpbuf, s, tculen, U8);
3443 }
3444 }
3445 else {
3446 U8 *s1;
3447 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3448 dTARGET;
3449 SvUTF8_off(TARG); /* decontaminate */
3450 sv_setsv_nomg(TARG, sv);
3451 sv = TARG;
3452 SETs(sv);
3453 }
3454 s1 = (U8*)SvPV_force_nomg(sv, slen);
3455 if (*s1) {
3456 if (IN_LOCALE_RUNTIME) {
3457 TAINT;
3458 SvTAINTED_on(sv);
3459 *s1 = toUPPER_LC(*s1);
3460 }
3461 else
3462 *s1 = toUPPER(*s1);
3463 }
3464 }
3465 SvSETMAGIC(sv);
3466 RETURN;
3467}
3468
3469PP(pp_lcfirst)
3470{
3471 dSP;
3472 SV *sv = TOPs;
3473 const U8 *s;
3474 STRLEN slen;
3475
3476 SvGETMAGIC(sv);
3477 if (DO_UTF8(sv) &&
3478 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3479 UTF8_IS_START(*s)) {
3480 STRLEN ulen;
3481 STRLEN lculen;
3482 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3483
3484 utf8_to_uvchr((U8 *)s, &ulen);
3485 toLOWER_utf8((U8 *)s, tmpbuf, &lculen);
3486
3487 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != lculen) {
3488 dTARGET;
3489 sv_setpvn(TARG, (char*)tmpbuf, lculen);
3490 if (slen > ulen)
3491 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3492 SvUTF8_on(TARG);
3493 SETs(TARG);
3494 }
3495 else {
3496 s = (U8*)SvPV_force_nomg(sv, slen);
3497 Copy(tmpbuf, s, ulen, U8);
3498 }
3499 }
3500 else {
3501 U8 *s1;
3502 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3503 dTARGET;
3504 SvUTF8_off(TARG); /* decontaminate */
3505 sv_setsv_nomg(TARG, sv);
3506 sv = TARG;
3507 SETs(sv);
3508 }
3509 s1 = (U8*)SvPV_force_nomg(sv, slen);
3510 if (*s1) {
3511 if (IN_LOCALE_RUNTIME) {
3512 TAINT;
3513 SvTAINTED_on(sv);
3514 *s1 = toLOWER_LC(*s1);
3515 }
3516 else
3517 *s1 = toLOWER(*s1);
3518 }
3519 }
3520 SvSETMAGIC(sv);
3521 RETURN;
3522}
3523
3524PP(pp_uc)
3525{
3526 dSP;
3527 SV *sv = TOPs;
3528 STRLEN len;
3529
3530 SvGETMAGIC(sv);
3531 if (DO_UTF8(sv)) {
3532 dTARGET;
3533 STRLEN ulen;
3534 register U8 *d;
3535 const U8 *s;
3536 const U8 *send;
3537 U8 tmpbuf[UTF8_MAXBYTES+1];
3538
3539 s = (const U8*)SvPV_nomg_const(sv,len);
3540 if (!len) {
3541 SvUTF8_off(TARG); /* decontaminate */
3542 sv_setpvn(TARG, "", 0);
3543 SETs(TARG);
3544 }
3545 else {
3546 STRLEN min = len + 1;
3547
3548 (void)SvUPGRADE(TARG, SVt_PV);
3549 SvGROW(TARG, min);
3550 (void)SvPOK_only(TARG);
3551 d = (U8*)SvPVX(TARG);
3552 send = s + len;
3553 while (s < send) {
3554 STRLEN u = UTF8SKIP(s);
3555
3556 toUPPER_utf8((U8 *)s, tmpbuf, &ulen);
3557 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3558 /* If the eventually required minimum size outgrows
3559 * the available space, we need to grow. */
3560 UV o = d - (U8*)SvPVX_const(TARG);
3561
3562 /* If someone uppercases one million U+03B0s we
3563 * SvGROW() one million times. Or we could try
3564 * guessing how much to allocate without allocating
3565 * too much. Such is life. */
3566 SvGROW(TARG, min);
3567 d = (U8*)SvPVX(TARG) + o;
3568 }
3569 Copy(tmpbuf, d, ulen, U8);
3570 d += ulen;
3571 s += u;
3572 }
3573 *d = '\0';
3574 SvUTF8_on(TARG);
3575 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3576 SETs(TARG);
3577 }
3578 }
3579 else {
3580 U8 *s;
3581 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3582 dTARGET;
3583 SvUTF8_off(TARG); /* decontaminate */
3584 sv_setsv_nomg(TARG, sv);
3585 sv = TARG;
3586 SETs(sv);
3587 }
3588 s = (U8*)SvPV_force_nomg(sv, len);
3589 if (len) {
3590 register const U8 *send = s + len;
3591
3592 if (IN_LOCALE_RUNTIME) {
3593 TAINT;
3594 SvTAINTED_on(sv);
3595 for (; s < send; s++)
3596 *s = toUPPER_LC(*s);
3597 }
3598 else {
3599 for (; s < send; s++)
3600 *s = toUPPER(*s);
3601 }
3602 }
3603 }
3604 SvSETMAGIC(sv);
3605 RETURN;
3606}
3607
3608PP(pp_lc)
3609{
3610 dSP;
3611 SV *sv = TOPs;
3612 STRLEN len;
3613
3614 SvGETMAGIC(sv);
3615 if (DO_UTF8(sv)) {
3616 dTARGET;
3617 const U8 *s;
3618 STRLEN ulen;
3619 register U8 *d;
3620 const U8 *send;
3621 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3622
3623 s = (const U8*)SvPV_nomg_const(sv,len);
3624 if (!len) {
3625 SvUTF8_off(TARG); /* decontaminate */
3626 sv_setpvn(TARG, "", 0);
3627 SETs(TARG);
3628 }
3629 else {
3630 STRLEN min = len + 1;
3631
3632 (void)SvUPGRADE(TARG, SVt_PV);
3633 SvGROW(TARG, min);
3634 (void)SvPOK_only(TARG);
3635 d = (U8*)SvPVX(TARG);
3636 send = s + len;
3637 while (s < send) {
3638 const STRLEN u = UTF8SKIP(s);
3639 const UV uv = toLOWER_utf8((U8 *)s, tmpbuf, &ulen);
3640
3641#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3642 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3643 /*
3644 * Now if the sigma is NOT followed by
3645 * /$ignorable_sequence$cased_letter/;
3646 * and it IS preceded by
3647 * /$cased_letter$ignorable_sequence/;
3648 * where $ignorable_sequence is
3649 * [\x{2010}\x{AD}\p{Mn}]*
3650 * and $cased_letter is
3651 * [\p{Ll}\p{Lo}\p{Lt}]
3652 * then it should be mapped to 0x03C2,
3653 * (GREEK SMALL LETTER FINAL SIGMA),
3654 * instead of staying 0x03A3.
3655 * "should be": in other words,
3656 * this is not implemented yet.
3657 * See lib/unicore/SpecialCasing.txt.
3658 */
3659 }
3660 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3661 /* If the eventually required minimum size outgrows
3662 * the available space, we need to grow. */
3663 UV o = d - (U8*)SvPVX_const(TARG);
3664
3665 /* If someone lowercases one million U+0130s we
3666 * SvGROW() one million times. Or we could try
3667 * guessing how much to allocate without allocating.
3668 * too much. Such is life. */
3669 SvGROW(TARG, min);
3670 d = (U8*)SvPVX(TARG) + o;
3671 }
3672 Copy(tmpbuf, d, ulen, U8);
3673 d += ulen;
3674 s += u;
3675 }
3676 *d = '\0';
3677 SvUTF8_on(TARG);
3678 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3679 SETs(TARG);
3680 }
3681 }
3682 else {
3683 U8 *s;
3684 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3685 dTARGET;
3686 SvUTF8_off(TARG); /* decontaminate */
3687 sv_setsv_nomg(TARG, sv);
3688 sv = TARG;
3689 SETs(sv);
3690 }
3691
3692 s = (U8*)SvPV_force_nomg(sv, len);
3693 if (len) {
3694 register const U8 * const send = s + len;
3695
3696 if (IN_LOCALE_RUNTIME) {
3697 TAINT;
3698 SvTAINTED_on(sv);
3699 for (; s < send; s++)
3700 *s = toLOWER_LC(*s);
3701 }
3702 else {
3703 for (; s < send; s++)
3704 *s = toLOWER(*s);
3705 }
3706 }
3707 }
3708 SvSETMAGIC(sv);
3709 RETURN;
3710}
3711
3712PP(pp_quotemeta)
3713{
3714 dSP; dTARGET;
3715 SV * const sv = TOPs;
3716 STRLEN len;
3717 register const char *s = SvPV_const(sv,len);
3718
3719 SvUTF8_off(TARG); /* decontaminate */
3720 if (len) {
3721 register char *d;
3722 (void)SvUPGRADE(TARG, SVt_PV);
3723 SvGROW(TARG, (len * 2) + 1);
3724 d = SvPVX(TARG);
3725 if (DO_UTF8(sv)) {
3726 while (len) {
3727 if (UTF8_IS_CONTINUED(*s)) {
3728 STRLEN ulen = UTF8SKIP(s);
3729 if (ulen > len)
3730 ulen = len;
3731 len -= ulen;
3732 while (ulen--)
3733 *d++ = *s++;
3734 }
3735 else {
3736 if (!isALNUM(*s))
3737 *d++ = '\\';
3738 *d++ = *s++;
3739 len--;
3740 }
3741 }
3742 SvUTF8_on(TARG);
3743 }
3744 else {
3745 while (len--) {
3746 if (!isALNUM(*s))
3747 *d++ = '\\';
3748 *d++ = *s++;
3749 }
3750 }
3751 *d = '\0';
3752 SvCUR_set(TARG, d - SvPVX_const(TARG));
3753 (void)SvPOK_only_UTF8(TARG);
3754 }
3755 else
3756 sv_setpvn(TARG, s, len);
3757 SETs(TARG);
3758 if (SvSMAGICAL(TARG))
3759 mg_set(TARG);
3760 RETURN;
3761}
3762
3763/* Arrays. */
3764
3765PP(pp_aslice)
3766{
3767 dSP; dMARK; dORIGMARK;
3768 register AV* const av = (AV*)POPs;
3769 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3770
3771 if (SvTYPE(av) == SVt_PVAV) {
3772 const I32 arybase = PL_curcop->cop_arybase;
3773 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3774 register SV **svp;
3775 I32 max = -1;
3776 for (svp = MARK + 1; svp <= SP; svp++) {
3777 const I32 elem = SvIVx(*svp);
3778 if (elem > max)
3779 max = elem;
3780 }
3781 if (max > AvMAX(av))
3782 av_extend(av, max);
3783 }
3784 while (++MARK <= SP) {
3785 register SV **svp;
3786 I32 elem = SvIVx(*MARK);
3787
3788 if (elem > 0)
3789 elem -= arybase;
3790 svp = av_fetch(av, elem, lval);
3791 if (lval) {
3792 if (!svp || *svp == &PL_sv_undef)
3793 DIE(aTHX_ PL_no_aelem, elem);
3794 if (PL_op->op_private & OPpLVAL_INTRO)
3795 save_aelem(av, elem, svp);
3796 }
3797 *MARK = svp ? *svp : &PL_sv_undef;
3798 }
3799 }
3800 if (GIMME != G_ARRAY) {
3801 MARK = ORIGMARK;
3802 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3803 SP = MARK;
3804 }
3805 RETURN;
3806}
3807
3808/* Associative arrays. */
3809
3810PP(pp_each)
3811{
3812 dSP;
3813 HV * const hash = (HV*)POPs;
3814 HE *entry;
3815 const I32 gimme = GIMME_V;
3816 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
3817
3818 PUTBACK;
3819 /* might clobber stack_sp */
3820 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
3821 SPAGAIN;
3822
3823 EXTEND(SP, 2);
3824 if (entry) {
3825 SV* const sv = hv_iterkeysv(entry);
3826 PUSHs(sv); /* won't clobber stack_sp */
3827 if (gimme == G_ARRAY) {
3828 SV *val;
3829 PUTBACK;
3830 /* might clobber stack_sp */
3831 val = realhv ?
3832 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
3833 SPAGAIN;
3834 PUSHs(val);
3835 }
3836 }
3837 else if (gimme == G_SCALAR)
3838 RETPUSHUNDEF;
3839
3840 RETURN;
3841}
3842
3843PP(pp_values)
3844{
3845 return do_kv();
3846}
3847
3848PP(pp_keys)
3849{
3850 return do_kv();
3851}
3852
3853PP(pp_delete)
3854{
3855 dSP;
3856 const I32 gimme = GIMME_V;
3857 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3858
3859 if (PL_op->op_private & OPpSLICE) {
3860 dMARK; dORIGMARK;
3861 HV * const hv = (HV*)POPs;
3862 const U32 hvtype = SvTYPE(hv);
3863 if (hvtype == SVt_PVHV) { /* hash element */
3864 while (++MARK <= SP) {
3865 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3866 *MARK = sv ? sv : &PL_sv_undef;
3867 }
3868 }
3869 else if (hvtype == SVt_PVAV) {
3870 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3871 while (++MARK <= SP) {
3872 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3873 *MARK = sv ? sv : &PL_sv_undef;
3874 }
3875 }
3876 else { /* pseudo-hash element */
3877 while (++MARK <= SP) {
3878 SV * const sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
3879 *MARK = sv ? sv : &PL_sv_undef;
3880 }
3881 }
3882 }
3883 else
3884 DIE(aTHX_ "Not a HASH reference");
3885 if (discard)
3886 SP = ORIGMARK;
3887 else if (gimme == G_SCALAR) {
3888 MARK = ORIGMARK;
3889 if (SP > MARK)
3890 *++MARK = *SP;
3891 else
3892 *++MARK = &PL_sv_undef;
3893 SP = MARK;
3894 }
3895 }
3896 else {
3897 SV *keysv = POPs;
3898 HV * const hv = (HV*)POPs;
3899 SV *sv;
3900 if (SvTYPE(hv) == SVt_PVHV)
3901 sv = hv_delete_ent(hv, keysv, discard, 0);
3902 else if (SvTYPE(hv) == SVt_PVAV) {
3903 if (PL_op->op_flags & OPf_SPECIAL)
3904 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3905 else
3906 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
3907 }
3908 else
3909 DIE(aTHX_ "Not a HASH reference");
3910 if (!sv)
3911 sv = &PL_sv_undef;
3912 if (!discard)
3913 PUSHs(sv);
3914 }
3915 RETURN;
3916}
3917
3918PP(pp_exists)
3919{
3920 dSP;
3921 SV *tmpsv;
3922 HV *hv;
3923
3924 if (PL_op->op_private & OPpEXISTS_SUB) {
3925 GV *gv;
3926 SV *sv = POPs;
3927 CV * const cv = sv_2cv(sv, &hv, &gv, FALSE);
3928 if (cv)
3929 RETPUSHYES;
3930 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3931 RETPUSHYES;
3932 RETPUSHNO;
3933 }
3934 tmpsv = POPs;
3935 hv = (HV*)POPs;
3936 if (SvTYPE(hv) == SVt_PVHV) {
3937 if (hv_exists_ent(hv, tmpsv, 0))
3938 RETPUSHYES;
3939 }
3940 else if (SvTYPE(hv) == SVt_PVAV) {
3941 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3942 if (av_exists((AV*)hv, SvIV(tmpsv)))
3943 RETPUSHYES;
3944 }
3945 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
3946 RETPUSHYES;
3947 }
3948 else {
3949 DIE(aTHX_ "Not a HASH reference");
3950 }
3951 RETPUSHNO;
3952}
3953
3954PP(pp_hslice)
3955{
3956 dSP; dMARK; dORIGMARK;
3957 register HV * const hv = (HV*)POPs;
3958 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3959 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
3960 const bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3961 bool other_magic = FALSE;
3962
3963 if (localizing) {
3964 MAGIC *mg;
3965 HV *stash;
3966
3967 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3968 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3969 /* Try to preserve the existenceness of a tied hash
3970 * element by using EXISTS and DELETE if possible.
3971 * Fallback to FETCH and STORE otherwise */
3972 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3973 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3974 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3975 }
3976
3977 if (!realhv && localizing)
3978 DIE(aTHX_ "Can't localize pseudo-hash element");
3979
3980 if (realhv || SvTYPE(hv) == SVt_PVAV) {
3981 while (++MARK <= SP) {
3982 SV *keysv = *MARK;
3983 SV **svp;
3984 bool preeminent = FALSE;
3985
3986 if (localizing) {
3987 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3988 realhv ? hv_exists_ent(hv, keysv, 0)
3989 : avhv_exists_ent((AV*)hv, keysv, 0);
3990 }
3991
3992 if (realhv) {
3993 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
3994 svp = he ? &HeVAL(he) : 0;
3995 }
3996 else {
3997 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
3998 }
3999 if (lval) {
4000 if (!svp || *svp == &PL_sv_undef) {
4001 DIE(aTHX_ PL_no_helem_sv, keysv);
4002 }
4003 if (localizing) {
4004 if (preeminent)
4005 save_helem(hv, keysv, svp);
4006 else {
4007 STRLEN keylen;
4008 const char *key = SvPV_const(keysv, keylen);
4009 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4010 }
4011 }
4012 }
4013 *MARK = svp ? *svp : &PL_sv_undef;
4014 }
4015 }
4016 if (GIMME != G_ARRAY) {
4017 MARK = ORIGMARK;
4018 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4019 SP = MARK;
4020 }
4021 RETURN;
4022}
4023
4024/* List operators. */
4025
4026PP(pp_list)
4027{
4028 dSP; dMARK;
4029 if (GIMME != G_ARRAY) {
4030 if (++MARK <= SP)
4031 *MARK = *SP; /* unwanted list, return last item */
4032 else
4033 *MARK = &PL_sv_undef;
4034 SP = MARK;
4035 }
4036 RETURN;
4037}
4038
4039PP(pp_lslice)
4040{
4041 dSP;
4042 SV ** const lastrelem = PL_stack_sp;
4043 SV ** const lastlelem = PL_stack_base + POPMARK;
4044 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4045 register SV ** const firstrelem = lastlelem + 1;
4046 const I32 arybase = PL_curcop->cop_arybase;
4047 I32 is_something_there = PL_op->op_flags & OPf_MOD;
4048
4049 register const I32 max = lastrelem - lastlelem;
4050 register SV **lelem;
4051
4052 if (GIMME != G_ARRAY) {
4053 I32 ix = SvIVx(*lastlelem);
4054 if (ix < 0)
4055 ix += max;
4056 else
4057 ix -= arybase;
4058 if (ix < 0 || ix >= max)
4059 *firstlelem = &PL_sv_undef;
4060 else
4061 *firstlelem = firstrelem[ix];
4062 SP = firstlelem;
4063 RETURN;
4064 }
4065
4066 if (max == 0) {
4067 SP = firstlelem - 1;
4068 RETURN;
4069 }
4070
4071 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4072 I32 ix = SvIVx(*lelem);
4073 if (ix < 0)
4074 ix += max;
4075 else
4076 ix -= arybase;
4077 if (ix < 0 || ix >= max)
4078 *lelem = &PL_sv_undef;
4079 else {
4080 is_something_there = TRUE;
4081 if (!(*lelem = firstrelem[ix]))
4082 *lelem = &PL_sv_undef;
4083 }
4084 }
4085 if (is_something_there)
4086 SP = lastlelem;
4087 else
4088 SP = firstlelem - 1;
4089 RETURN;
4090}
4091
4092PP(pp_anonlist)
4093{
4094 dSP; dMARK; dORIGMARK;
4095 const I32 items = SP - MARK;
4096 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4097 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4098 XPUSHs(av);
4099 RETURN;
4100}
4101
4102PP(pp_anonhash)
4103{
4104 dSP; dMARK; dORIGMARK;
4105 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4106
4107 while (MARK < SP) {
4108 SV * const key = *++MARK;
4109 SV * const val = NEWSV(46, 0);
4110 if (MARK < SP)
4111 sv_setsv(val, *++MARK);
4112 else if (ckWARN(WARN_MISC))
4113 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4114 (void)hv_store_ent(hv,key,val,0);
4115 }
4116 SP = ORIGMARK;
4117 XPUSHs((SV*)hv);
4118 RETURN;
4119}
4120
4121PP(pp_splice)
4122{
4123 dSP; dMARK; dORIGMARK;
4124 register AV *ary = (AV*)*++MARK;
4125 register SV **src;
4126 register SV **dst;
4127 register I32 i;
4128 register I32 offset;
4129 register I32 length;
4130 I32 newlen;
4131 I32 after;
4132 I32 diff;
4133 SV **tmparyval = 0;
4134 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4135
4136 if (mg) {
4137 *MARK-- = SvTIED_obj((SV*)ary, mg);
4138 PUSHMARK(MARK);
4139 PUTBACK;
4140 ENTER;
4141 call_method("SPLICE",GIMME_V);
4142 LEAVE;
4143 SPAGAIN;
4144 RETURN;
4145 }
4146
4147 SP++;
4148
4149 if (++MARK < SP) {
4150 offset = i = SvIVx(*MARK);
4151 if (offset < 0)
4152 offset += AvFILLp(ary) + 1;
4153 else
4154 offset -= PL_curcop->cop_arybase;
4155 if (offset < 0)
4156 DIE(aTHX_ PL_no_aelem, i);
4157 if (++MARK < SP) {
4158 length = SvIVx(*MARK++);
4159 if (length < 0) {
4160 length += AvFILLp(ary) - offset + 1;
4161 if (length < 0)
4162 length = 0;
4163 }
4164 }
4165 else
4166 length = AvMAX(ary) + 1; /* close enough to infinity */
4167 }
4168 else {
4169 offset = 0;
4170 length = AvMAX(ary) + 1;
4171 }
4172 if (offset > AvFILLp(ary) + 1) {
4173 if (ckWARN(WARN_MISC))
4174 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4175 offset = AvFILLp(ary) + 1;
4176 }
4177 after = AvFILLp(ary) + 1 - (offset + length);
4178 if (after < 0) { /* not that much array */
4179 length += after; /* offset+length now in array */
4180 after = 0;
4181 if (!AvALLOC(ary))
4182 av_extend(ary, 0);
4183 }
4184
4185 /* At this point, MARK .. SP-1 is our new LIST */
4186
4187 newlen = SP - MARK;
4188 diff = newlen - length;
4189 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4190 av_reify(ary);
4191
4192 /* make new elements SVs now: avoid problems if they're from the array */
4193 for (dst = MARK, i = newlen; i; i--) {
4194 SV * const h = *dst;
4195 *dst++ = newSVsv(h);
4196 }
4197
4198 if (diff < 0) { /* shrinking the area */
4199 if (newlen) {
4200 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4201 Copy(MARK, tmparyval, newlen, SV*);
4202 }
4203
4204 MARK = ORIGMARK + 1;
4205 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4206 MEXTEND(MARK, length);
4207 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4208 if (AvREAL(ary)) {
4209 EXTEND_MORTAL(length);
4210 for (i = length, dst = MARK; i; i--) {
4211 sv_2mortal(*dst); /* free them eventualy */
4212 dst++;
4213 }
4214 }
4215 MARK += length - 1;
4216 }
4217 else {
4218 *MARK = AvARRAY(ary)[offset+length-1];
4219 if (AvREAL(ary)) {
4220 sv_2mortal(*MARK);
4221 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4222 SvREFCNT_dec(*dst++); /* free them now */
4223 }
4224 }
4225 AvFILLp(ary) += diff;
4226
4227 /* pull up or down? */
4228
4229 if (offset < after) { /* easier to pull up */
4230 if (offset) { /* esp. if nothing to pull */
4231 src = &AvARRAY(ary)[offset-1];
4232 dst = src - diff; /* diff is negative */
4233 for (i = offset; i > 0; i--) /* can't trust Copy */
4234 *dst-- = *src--;
4235 }
4236 dst = AvARRAY(ary);
4237 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4238 AvMAX(ary) += diff;
4239 }
4240 else {
4241 if (after) { /* anything to pull down? */
4242 src = AvARRAY(ary) + offset + length;
4243 dst = src + diff; /* diff is negative */
4244 Move(src, dst, after, SV*);
4245 }
4246 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4247 /* avoid later double free */
4248 }
4249 i = -diff;
4250 while (i)
4251 dst[--i] = &PL_sv_undef;
4252
4253 if (newlen) {
4254 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4255 Safefree(tmparyval);
4256 }
4257 }
4258 else { /* no, expanding (or same) */
4259 if (length) {
4260 Newx(tmparyval, length, SV*); /* so remember deletion */
4261 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4262 }
4263
4264 if (diff > 0) { /* expanding */
4265
4266 /* push up or down? */
4267
4268 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4269 if (offset) {
4270 src = AvARRAY(ary);
4271 dst = src - diff;
4272 Move(src, dst, offset, SV*);
4273 }
4274 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4275 AvMAX(ary) += diff;
4276 AvFILLp(ary) += diff;
4277 }
4278 else {
4279 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4280 av_extend(ary, AvFILLp(ary) + diff);
4281 AvFILLp(ary) += diff;
4282
4283 if (after) {
4284 dst = AvARRAY(ary) + AvFILLp(ary);
4285 src = dst - diff;
4286 for (i = after; i; i--) {
4287 *dst-- = *src--;
4288 }
4289 }
4290 }
4291 }
4292
4293 if (newlen) {
4294 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4295 }
4296
4297 MARK = ORIGMARK + 1;
4298 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4299 if (length) {
4300 Copy(tmparyval, MARK, length, SV*);
4301 if (AvREAL(ary)) {
4302 EXTEND_MORTAL(length);
4303 for (i = length, dst = MARK; i; i--) {
4304 sv_2mortal(*dst); /* free them eventualy */
4305 dst++;
4306 }
4307 }
4308 Safefree(tmparyval);
4309 }
4310 MARK += length - 1;
4311 }
4312 else if (length--) {
4313 *MARK = tmparyval[length];
4314 if (AvREAL(ary)) {
4315 sv_2mortal(*MARK);
4316 while (length-- > 0)
4317 SvREFCNT_dec(tmparyval[length]);
4318 }
4319 Safefree(tmparyval);
4320 }
4321 else
4322 *MARK = &PL_sv_undef;
4323 }
4324 SP = MARK;
4325 RETURN;
4326}
4327
4328PP(pp_push)
4329{
4330 dSP; dMARK; dORIGMARK; dTARGET;
4331 register AV *ary = (AV*)*++MARK;
4332 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4333
4334 if (mg) {
4335 *MARK-- = SvTIED_obj((SV*)ary, mg);
4336 PUSHMARK(MARK);
4337 PUTBACK;
4338 ENTER;
4339 call_method("PUSH",G_SCALAR|G_DISCARD);
4340 LEAVE;
4341 SPAGAIN;
4342 }
4343 else {
4344 /* Why no pre-extend of ary here ? */
4345 for (++MARK; MARK <= SP; MARK++) {
4346 SV * const sv = NEWSV(51, 0);
4347 if (*MARK)
4348 sv_setsv(sv, *MARK);
4349 av_push(ary, sv);
4350 }
4351 }
4352 SP = ORIGMARK;
4353 PUSHi( AvFILL(ary) + 1 );
4354 RETURN;
4355}
4356
4357PP(pp_pop)
4358{
4359 dSP;
4360 AV * const av = (AV*)POPs;
4361 SV * const sv = av_pop(av);
4362 if (AvREAL(av))
4363 (void)sv_2mortal(sv);
4364 PUSHs(sv);
4365 RETURN;
4366}
4367
4368PP(pp_shift)
4369{
4370 dSP;
4371 AV * const av = (AV*)POPs;
4372 SV * const sv = av_shift(av);
4373 EXTEND(SP, 1);
4374 if (!sv)
4375 RETPUSHUNDEF;
4376 if (AvREAL(av))
4377 (void)sv_2mortal(sv);
4378 PUSHs(sv);
4379 RETURN;
4380}
4381
4382PP(pp_unshift)
4383{
4384 dSP; dMARK; dORIGMARK; dTARGET;
4385 register AV *ary = (AV*)*++MARK;
4386 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4387
4388 if (mg) {
4389 *MARK-- = SvTIED_obj((SV*)ary, mg);
4390 PUSHMARK(MARK);
4391 PUTBACK;
4392 ENTER;
4393 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4394 LEAVE;
4395 SPAGAIN;
4396 }
4397 else {
4398 register I32 i = 0;
4399 av_unshift(ary, SP - MARK);
4400 while (MARK < SP) {
4401 SV * const sv = newSVsv(*++MARK);
4402 (void)av_store(ary, i++, sv);
4403 }
4404 }
4405 SP = ORIGMARK;
4406 PUSHi( AvFILL(ary) + 1 );
4407 RETURN;
4408}
4409
4410PP(pp_reverse)
4411{
4412 dSP; dMARK;
4413 SV ** const oldsp = SP;
4414
4415 if (GIMME == G_ARRAY) {
4416 MARK++;
4417 while (MARK < SP) {
4418 register SV * const tmp = *MARK;
4419 *MARK++ = *SP;
4420 *SP-- = tmp;
4421 }
4422 /* safe as long as stack cannot get extended in the above */
4423 SP = oldsp;
4424 }
4425 else {
4426 register char *up;
4427 register char *down;
4428 register I32 tmp;
4429 dTARGET;
4430 STRLEN len;
4431
4432 SvUTF8_off(TARG); /* decontaminate */
4433 if (SP - MARK > 1)
4434 do_join(TARG, &PL_sv_no, MARK, SP);
4435 else
4436 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
4437 up = SvPV_force(TARG, len);
4438 if (len > 1) {
4439 if (DO_UTF8(TARG)) { /* first reverse each character */
4440 U8* s = (U8*)SvPVX(TARG);
4441 const U8* send = (U8*)(s + len);
4442 while (s < send) {
4443 if (UTF8_IS_INVARIANT(*s)) {
4444 s++;
4445 continue;
4446 }
4447 else {
4448 if (!utf8_to_uvchr(s, 0))
4449 break;
4450 up = (char*)s;
4451 s += UTF8SKIP(s);
4452 down = (char*)(s - 1);
4453 /* reverse this character */
4454 while (down > up) {
4455 tmp = *up;
4456 *up++ = *down;
4457 *down-- = (char)tmp;
4458 }
4459 }
4460 }
4461 up = SvPVX(TARG);
4462 }
4463 down = SvPVX(TARG) + len - 1;
4464 while (down > up) {
4465 tmp = *up;
4466 *up++ = *down;
4467 *down-- = (char)tmp;
4468 }
4469 (void)SvPOK_only_UTF8(TARG);
4470 }
4471 SP = MARK + 1;
4472 SETTARG;
4473 }
4474 RETURN;
4475}
4476
4477PP(pp_split)
4478{
4479 dSP; dTARG;
4480 AV *ary;
4481 register IV limit = POPi; /* note, negative is forever */
4482 SV * const sv = POPs;
4483 STRLEN len;
4484 register const char *s = SvPV_const(sv, len);
4485 const bool do_utf8 = DO_UTF8(sv);
4486 const char *strend = s + len;
4487 register PMOP *pm;
4488 register REGEXP *rx;
4489 register SV *dstr;
4490 register const char *m;
4491 I32 iters = 0;
4492 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4493 I32 maxiters = slen + 10;
4494 const char *orig;
4495 const I32 origlimit = limit;
4496 I32 realarray = 0;
4497 I32 base;
4498 const I32 gimme = GIMME_V;
4499 const I32 oldsave = PL_savestack_ix;
4500 I32 make_mortal = 1;
4501 MAGIC *mg = (MAGIC *) NULL;
4502
4503#ifdef DEBUGGING
4504 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4505#else
4506 pm = (PMOP*)POPs;
4507#endif
4508 if (!pm || !s)
4509 DIE(aTHX_ "panic: pp_split");
4510 rx = PM_GETRE(pm);
4511
4512 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4513 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4514
4515 RX_MATCH_UTF8_set(rx, do_utf8);
4516
4517 if (pm->op_pmreplroot) {
4518#ifdef USE_ITHREADS
4519 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4520#else
4521 ary = GvAVn((GV*)pm->op_pmreplroot);
4522#endif
4523 }
4524 else if (gimme != G_ARRAY)
4525#ifdef USE_5005THREADS
4526 ary = (AV*)PAD_SVl(0);
4527#else
4528 ary = GvAVn(PL_defgv);
4529#endif /* USE_5005THREADS */
4530 else
4531 ary = Nullav;
4532 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4533 realarray = 1;
4534 PUTBACK;
4535 av_extend(ary,0);
4536 av_clear(ary);
4537 SPAGAIN;
4538 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4539 PUSHMARK(SP);
4540 XPUSHs(SvTIED_obj((SV*)ary, mg));
4541 }
4542 else {
4543 if (!AvREAL(ary)) {
4544 I32 i;
4545 AvREAL_on(ary);
4546 AvREIFY_off(ary);
4547 for (i = AvFILLp(ary); i >= 0; i--)
4548 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4549 }
4550 /* temporarily switch stacks */
4551 SAVESWITCHSTACK(PL_curstack, ary);
4552 make_mortal = 0;
4553 }
4554 }
4555 base = SP - PL_stack_base;
4556 orig = s;
4557 if (pm->op_pmflags & PMf_SKIPWHITE) {
4558 if (pm->op_pmflags & PMf_LOCALE) {
4559 while (isSPACE_LC(*s))
4560 s++;
4561 }
4562 else {
4563 while (isSPACE(*s))
4564 s++;
4565 }
4566 }
4567 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4568 SAVEINT(PL_multiline);
4569 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
4570 }
4571
4572 if (!limit)
4573 limit = maxiters + 2;
4574 if (pm->op_pmflags & PMf_WHITE) {
4575 while (--limit) {
4576 m = s;
4577 while (m < strend &&
4578 !((pm->op_pmflags & PMf_LOCALE)
4579 ? isSPACE_LC(*m) : isSPACE(*m)))
4580 ++m;
4581 if (m >= strend)
4582 break;
4583
4584 dstr = newSVpvn(s, m-s);
4585 if (make_mortal)
4586 sv_2mortal(dstr);
4587 if (do_utf8)
4588 (void)SvUTF8_on(dstr);
4589 XPUSHs(dstr);
4590
4591 s = m + 1;
4592 while (s < strend &&
4593 ((pm->op_pmflags & PMf_LOCALE)
4594 ? isSPACE_LC(*s) : isSPACE(*s)))
4595 ++s;
4596 }
4597 }
4598 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4599 while (--limit) {
4600 for (m = s; m < strend && *m != '\n'; m++)
4601 ;
4602 m++;
4603 if (m >= strend)
4604 break;
4605 dstr = newSVpvn(s, m-s);
4606 if (make_mortal)
4607 sv_2mortal(dstr);
4608 if (do_utf8)
4609 (void)SvUTF8_on(dstr);
4610 XPUSHs(dstr);
4611 s = m;
4612 }
4613 }
4614 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4615 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4616 && (rx->reganch & ROPT_CHECK_ALL)
4617 && !(rx->reganch & ROPT_ANCH)) {
4618 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4619 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4620
4621 len = rx->minlen;
4622 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4623 const char c = *SvPV_nolen_const(csv);
4624 while (--limit) {
4625 for (m = s; m < strend && *m != c; m++)
4626 ;
4627 if (m >= strend)
4628 break;
4629 dstr = newSVpvn(s, m-s);
4630 if (make_mortal)
4631 sv_2mortal(dstr);
4632 if (do_utf8)
4633 (void)SvUTF8_on(dstr);
4634 XPUSHs(dstr);
4635 /* The rx->minlen is in characters but we want to step
4636 * s ahead by bytes. */
4637 if (do_utf8)
4638 s = (char*)utf8_hop((U8*)m, len);
4639 else
4640 s = m + len; /* Fake \n at the end */
4641 }
4642 }
4643 else {
4644 while (s < strend && --limit &&
4645 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4646 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
4647 {
4648 dstr = newSVpvn(s, m-s);
4649 if (make_mortal)
4650 sv_2mortal(dstr);
4651 if (do_utf8)
4652 (void)SvUTF8_on(dstr);
4653 XPUSHs(dstr);
4654 /* The rx->minlen is in characters but we want to step
4655 * s ahead by bytes. */
4656 if (do_utf8)
4657 s = (char*)utf8_hop((U8*)m, len);
4658 else
4659 s = m + len; /* Fake \n at the end */
4660 }
4661 }
4662 }
4663 else {
4664 maxiters += slen * rx->nparens;
4665 while (s < strend && --limit)
4666 {
4667 I32 rex_return;
4668 PUTBACK;
4669 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4670 sv, NULL, 0);
4671 SPAGAIN;
4672 if (rex_return == 0)
4673 break;
4674 TAINT_IF(RX_MATCH_TAINTED(rx));
4675 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4676 m = s;
4677 s = orig;
4678 orig = rx->subbeg;
4679 s = orig + (m - s);
4680 strend = s + (strend - m);
4681 }
4682 m = rx->startp[0] + orig;
4683 dstr = newSVpvn(s, m-s);
4684 if (make_mortal)
4685 sv_2mortal(dstr);
4686 if (do_utf8)
4687 (void)SvUTF8_on(dstr);
4688 XPUSHs(dstr);
4689 if (rx->nparens) {
4690 I32 i;
4691 for (i = 1; i <= (I32)rx->nparens; i++) {
4692 s = rx->startp[i] + orig;
4693 m = rx->endp[i] + orig;
4694
4695 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4696 parens that didn't match -- they should be set to
4697 undef, not the empty string */
4698 if (m >= orig && s >= orig) {
4699 dstr = newSVpvn(s, m-s);
4700 }
4701 else
4702 dstr = &PL_sv_undef; /* undef, not "" */
4703 if (make_mortal)
4704 sv_2mortal(dstr);
4705 if (do_utf8)
4706 (void)SvUTF8_on(dstr);
4707 XPUSHs(dstr);
4708 }
4709 }
4710 s = rx->endp[0] + orig;
4711 }
4712 }
4713
4714 iters = (SP - PL_stack_base) - base;
4715 if (iters > maxiters)
4716 DIE(aTHX_ "Split loop");
4717
4718 /* keep field after final delim? */
4719 if (s < strend || (iters && origlimit)) {
4720 const STRLEN l = strend - s;
4721 dstr = newSVpvn(s, l);
4722 if (make_mortal)
4723 sv_2mortal(dstr);
4724 if (do_utf8)
4725 (void)SvUTF8_on(dstr);
4726 XPUSHs(dstr);
4727 iters++;
4728 }
4729 else if (!origlimit) {
4730 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4731 if (TOPs && !make_mortal)
4732 sv_2mortal(TOPs);
4733 iters--;
4734 *SP-- = &PL_sv_undef;
4735 }
4736 }
4737
4738 PUTBACK;
4739 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4740 SPAGAIN;
4741 if (realarray) {
4742 if (!mg) {
4743 if (SvSMAGICAL(ary)) {
4744 PUTBACK;
4745 mg_set((SV*)ary);
4746 SPAGAIN;
4747 }
4748 if (gimme == G_ARRAY) {
4749 EXTEND(SP, iters);
4750 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4751 SP += iters;
4752 RETURN;
4753 }
4754 }
4755 else {
4756 PUTBACK;
4757 ENTER;
4758 call_method("PUSH",G_SCALAR|G_DISCARD);
4759 LEAVE;
4760 SPAGAIN;
4761 if (gimme == G_ARRAY) {
4762 I32 i;
4763 /* EXTEND should not be needed - we just popped them */
4764 EXTEND(SP, iters);
4765 for (i=0; i < iters; i++) {
4766 SV **svp = av_fetch(ary, i, FALSE);
4767 PUSHs((svp) ? *svp : &PL_sv_undef);
4768 }
4769 RETURN;
4770 }
4771 }
4772 }
4773 else {
4774 if (gimme == G_ARRAY)
4775 RETURN;
4776 }
4777
4778 GETTARGET;
4779 PUSHi(iters);
4780 RETURN;
4781}
4782
4783#ifdef USE_5005THREADS
4784void
4785Perl_unlock_condpair(pTHX_ void *svv)
4786{
4787 MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
4788
4789 if (!mg)
4790 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
4791 MUTEX_LOCK(MgMUTEXP(mg));
4792 if (MgOWNER(mg) != thr)
4793 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
4794 MgOWNER(mg) = 0;
4795 COND_SIGNAL(MgOWNERCONDP(mg));
4796 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
4797 PTR2UV(thr), PTR2UV(svv)));
4798 MUTEX_UNLOCK(MgMUTEXP(mg));
4799}
4800#endif /* USE_5005THREADS */
4801
4802PP(pp_lock)
4803{
4804 dSP;
4805 dTOPss;
4806 SV *retsv = sv;
4807 SvLOCK(sv);
4808 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4809 || SvTYPE(retsv) == SVt_PVCV) {
4810 retsv = refto(retsv);
4811 }
4812 SETs(retsv);
4813 RETURN;
4814}
4815
4816PP(pp_threadsv)
4817{
4818#ifdef USE_5005THREADS
4819 dSP;
4820 EXTEND(SP, 1);
4821 if (PL_op->op_private & OPpLVAL_INTRO)
4822 PUSHs(*save_threadsv(PL_op->op_targ));
4823 else
4824 PUSHs(THREADSV(PL_op->op_targ));
4825 RETURN;
4826#else
4827 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4828#endif /* USE_5005THREADS */
4829}
4830
4831/*
4832 * Local variables:
4833 * c-indentation-style: bsd
4834 * c-basic-offset: 4
4835 * indent-tabs-mode: t
4836 * End:
4837 *
4838 * ex: set ts=8 sts=4 sw=4 noet:
4839 */
Note: See TracBrowser for help on using the repository browser.