source: trunk/third/perl/doop.c @ 20075

Revision 20075, 29.5 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.
Line 
1/*    doop.c
2 *
3 *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 *    2000, 2001, 2002, 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 * "'So that was the job I felt I had to do when I started,' thought Sam."
13 */
14
15#include "EXTERN.h"
16#define PERL_IN_DOOP_C
17#include "perl.h"
18
19#ifndef PERL_MICRO
20#include <signal.h>
21#endif
22
23STATIC I32
24S_do_trans_simple(pTHX_ SV *sv)
25{
26    U8 *s;
27    U8 *d;
28    U8 *send;
29    U8 *dstart;
30    I32 matches = 0;
31    I32 grows = PL_op->op_private & OPpTRANS_GROWS;
32    STRLEN len;
33    short *tbl;
34    I32 ch;
35
36    tbl = (short*)cPVOP->op_pv;
37    if (!tbl)
38        Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
39
40    s = (U8*)SvPV(sv, len);
41    send = s + len;
42
43    /* First, take care of non-UTF-8 input strings, because they're easy */
44    if (!SvUTF8(sv)) {
45        while (s < send) {
46            if ((ch = tbl[*s]) >= 0) {
47                matches++;
48                *s++ = (U8)ch;
49            }
50            else
51                s++;
52        }
53        SvSETMAGIC(sv);
54        return matches;
55    }
56
57    /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
58    if (grows)
59        New(0, d, len*2+1, U8);
60    else
61        d = s;
62    dstart = d;
63    while (s < send) {
64        STRLEN ulen;
65        UV c;
66
67        /* Need to check this, otherwise 128..255 won't match */
68        c = utf8n_to_uvchr(s, send - s, &ulen, 0);
69        if (c < 0x100 && (ch = tbl[c]) >= 0) {
70            matches++;
71            d = uvchr_to_utf8(d, ch);
72            s += ulen;
73        }
74        else { /* No match -> copy */
75            Move(s, d, ulen, U8);
76            d += ulen;
77            s += ulen;
78        }
79    }
80    if (grows) {
81        sv_setpvn(sv, (char*)dstart, d - dstart);
82        Safefree(dstart);
83    }
84    else {
85        *d = '\0';
86        SvCUR_set(sv, d - dstart);
87    }
88    SvUTF8_on(sv);
89    SvSETMAGIC(sv);
90    return matches;
91}
92
93STATIC I32
94S_do_trans_count(pTHX_ SV *sv)
95{
96    U8 *s;
97    U8 *send;
98    I32 matches = 0;
99    STRLEN len;
100    short *tbl;
101    I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
102
103    tbl = (short*)cPVOP->op_pv;
104    if (!tbl)
105        Perl_croak(aTHX_ "panic: do_trans_count line %d",__LINE__);
106
107    s = (U8*)SvPV(sv, len);
108    send = s + len;
109
110    if (!SvUTF8(sv))
111        while (s < send) {
112            if (tbl[*s++] >= 0)
113                matches++;
114        }
115    else
116        while (s < send) {
117            UV c;
118            STRLEN ulen;
119            c = utf8n_to_uvchr(s, send - s, &ulen, 0);
120            if (c < 0x100) {
121                if (tbl[c] >= 0)
122                    matches++;
123            } else if (complement)
124                matches++;
125            s += ulen;
126        }
127
128    return matches;
129}
130
131STATIC I32
132S_do_trans_complex(pTHX_ SV *sv)
133{
134    U8 *s;
135    U8 *send;
136    U8 *d;
137    U8 *dstart;
138    I32 isutf8;
139    I32 matches = 0;
140    I32 grows = PL_op->op_private & OPpTRANS_GROWS;
141    I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
142    I32 del = PL_op->op_private & OPpTRANS_DELETE;
143    STRLEN len, rlen = 0;
144    short *tbl;
145    I32 ch;
146
147    tbl = (short*)cPVOP->op_pv;
148    if (!tbl)
149        Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
150
151    s = (U8*)SvPV(sv, len);
152    isutf8 = SvUTF8(sv);
153    send = s + len;
154
155    if (!isutf8) {
156        dstart = d = s;
157        if (PL_op->op_private & OPpTRANS_SQUASH) {
158            U8* p = send;
159            while (s < send) {
160                if ((ch = tbl[*s]) >= 0) {
161                    *d = (U8)ch;
162                    matches++;
163                    if (p != d - 1 || *p != *d)
164                        p = d++;
165                }
166                else if (ch == -1)      /* -1 is unmapped character */
167                    *d++ = *s; 
168                else if (ch == -2)      /* -2 is delete character */
169                    matches++;
170                s++;
171            }
172        }
173        else {
174            while (s < send) {
175                if ((ch = tbl[*s]) >= 0) {
176                    matches++;
177                    *d++ = (U8)ch;
178                }
179                else if (ch == -1)      /* -1 is unmapped character */
180                    *d++ = *s;
181                else if (ch == -2)      /* -2 is delete character */
182                    matches++;
183                s++;
184            }
185        }
186        *d = '\0';
187        SvCUR_set(sv, d - dstart);
188    }
189    else { /* isutf8 */
190        if (grows)
191            New(0, d, len*2+1, U8);
192        else
193            d = s;
194        dstart = d;
195        if (complement && !del)
196            rlen = tbl[0x100];
197
198#ifdef MACOS_TRADITIONAL
199#define comp CoMP   /* "comp" is a keyword in some compilers ... */
200#endif
201
202        if (PL_op->op_private & OPpTRANS_SQUASH) {
203            UV pch = 0xfeedface;
204            while (s < send) {
205                STRLEN len;
206                UV comp = utf8_to_uvchr(s, &len);
207
208                if (comp > 0xff) {
209                    if (!complement) {
210                        Copy(s, d, len, U8);
211                        d += len;
212                    }
213                    else {
214                        matches++;
215                        if (!del) {
216                            ch = (rlen == 0) ? comp :
217                                (comp - 0x100 < rlen) ?
218                                tbl[comp+1] : tbl[0x100+rlen];
219                            if ((UV)ch != pch) {
220                                d = uvchr_to_utf8(d, ch);
221                                pch = (UV)ch;
222                            }
223                            s += len;
224                            continue;
225                        }
226                    }
227                }
228                else if ((ch = tbl[comp]) >= 0) {
229                    matches++;
230                    if ((UV)ch != pch) {
231                        d = uvchr_to_utf8(d, ch);
232                        pch = (UV)ch;
233                    }
234                    s += len;
235                    continue;
236                }
237                else if (ch == -1) {    /* -1 is unmapped character */
238                    Copy(s, d, len, U8);
239                    d += len;
240                }
241                else if (ch == -2)      /* -2 is delete character */
242                    matches++;
243                s += len;
244                pch = 0xfeedface;
245            }
246        }
247        else {
248            while (s < send) {
249                STRLEN len;
250                UV comp = utf8_to_uvchr(s, &len);
251                if (comp > 0xff) {
252                    if (!complement) {
253                        Move(s, d, len, U8);
254                        d += len;
255                    }
256                    else {
257                        matches++;
258                        if (!del) {
259                            if (comp - 0x100 < rlen)
260                                d = uvchr_to_utf8(d, tbl[comp+1]);
261                            else
262                                d = uvchr_to_utf8(d, tbl[0x100+rlen]);
263                        }
264                    }
265                }
266                else if ((ch = tbl[comp]) >= 0) {
267                    d = uvchr_to_utf8(d, ch);
268                    matches++;
269                }
270                else if (ch == -1) {    /* -1 is unmapped character */
271                    Copy(s, d, len, U8);
272                    d += len;
273                }
274                else if (ch == -2)      /* -2 is delete character */
275                    matches++;
276                s += len;
277            }
278        }
279        if (grows) {
280            sv_setpvn(sv, (char*)dstart, d - dstart);
281            Safefree(dstart);
282        }
283        else {
284            *d = '\0';
285            SvCUR_set(sv, d - dstart);
286        }
287        SvUTF8_on(sv);
288    }
289    SvSETMAGIC(sv);
290    return matches;
291}
292
293STATIC I32
294S_do_trans_simple_utf8(pTHX_ SV *sv)
295{
296    U8 *s;
297    U8 *send;
298    U8 *d;
299    U8 *start;
300    U8 *dstart, *dend;
301    I32 matches = 0;
302    I32 grows = PL_op->op_private & OPpTRANS_GROWS;
303    STRLEN len;
304
305    SV* rv = (SV*)cSVOP->op_sv;
306    HV* hv = (HV*)SvRV(rv);
307    SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
308    UV none = svp ? SvUV(*svp) : 0x7fffffff;
309    UV extra = none + 1;
310    UV final = 0;
311    UV uv;
312    I32 isutf8;
313    U8 hibit = 0;
314
315    s = (U8*)SvPV(sv, len);
316    isutf8 = SvUTF8(sv);
317    if (!isutf8) {
318        U8 *t = s, *e = s + len;
319        while (t < e) {
320            U8 ch = *t++;
321            if ((hibit = !NATIVE_IS_INVARIANT(ch)))
322                break;
323        }
324        if (hibit)
325            s = bytes_to_utf8(s, &len);
326    }
327    send = s + len;
328    start = s;
329
330    svp = hv_fetch(hv, "FINAL", 5, FALSE);
331    if (svp)
332        final = SvUV(*svp);
333
334    if (grows) {
335        /* d needs to be bigger than s, in case e.g. upgrading is required */
336        New(0, d, len*3+UTF8_MAXLEN, U8);
337        dend = d + len * 3;
338        dstart = d;
339    }
340    else {
341        dstart = d = s;
342        dend = d + len;
343    }
344
345    while (s < send) {
346        if ((uv = swash_fetch(rv, s, TRUE)) < none) {
347            s += UTF8SKIP(s);
348            matches++;
349            d = uvuni_to_utf8(d, uv);
350        }
351        else if (uv == none) {
352            int i = UTF8SKIP(s);
353            Move(s, d, i, U8);
354            d += i;
355            s += i;
356        }
357        else if (uv == extra) {
358            int i = UTF8SKIP(s);
359            s += i;
360            matches++;
361            d = uvuni_to_utf8(d, final);
362        }
363        else
364            s += UTF8SKIP(s);
365
366        if (d > dend) {
367            STRLEN clen = d - dstart;
368            STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
369            if (!grows)
370                Perl_croak(aTHX_ "panic: do_trans_simple_utf8 line %d",__LINE__);
371            Renew(dstart, nlen+UTF8_MAXLEN, U8);
372            d = dstart + clen;
373            dend = dstart + nlen;
374        }
375    }
376    if (grows || hibit) {
377        sv_setpvn(sv, (char*)dstart, d - dstart);
378        Safefree(dstart);
379        if (grows && hibit)
380            Safefree(start);
381    }
382    else {
383        *d = '\0';
384        SvCUR_set(sv, d - dstart);
385    }
386    SvSETMAGIC(sv);
387    SvUTF8_on(sv);
388
389    return matches;
390}
391
392STATIC I32
393S_do_trans_count_utf8(pTHX_ SV *sv)
394{
395    U8 *s;
396    U8 *start = 0, *send;
397    I32 matches = 0;
398    STRLEN len;
399
400    SV* rv = (SV*)cSVOP->op_sv;
401    HV* hv = (HV*)SvRV(rv);
402    SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
403    UV none = svp ? SvUV(*svp) : 0x7fffffff;
404    UV extra = none + 1;
405    UV uv;
406    U8 hibit = 0;
407
408    s = (U8*)SvPV(sv, len);
409    if (!SvUTF8(sv)) {
410        U8 *t = s, *e = s + len;
411        while (t < e) {
412            U8 ch = *t++;
413            if ((hibit = !NATIVE_IS_INVARIANT(ch)))
414                break;
415        }
416        if (hibit)
417            start = s = bytes_to_utf8(s, &len);
418    }
419    send = s + len;
420
421    while (s < send) {
422        if ((uv = swash_fetch(rv, s, TRUE)) < none || uv == extra)
423            matches++;
424        s += UTF8SKIP(s);
425    }
426    if (hibit)
427        Safefree(start);
428
429    return matches;
430}
431
432STATIC I32
433S_do_trans_complex_utf8(pTHX_ SV *sv)
434{
435    U8 *s;
436    U8 *start, *send;
437    U8 *d;
438    I32 matches = 0;
439    I32 squash   = PL_op->op_private & OPpTRANS_SQUASH;
440    I32 del      = PL_op->op_private & OPpTRANS_DELETE;
441    I32 grows    = PL_op->op_private & OPpTRANS_GROWS;
442    SV* rv = (SV*)cSVOP->op_sv;
443    HV* hv = (HV*)SvRV(rv);
444    SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
445    UV none = svp ? SvUV(*svp) : 0x7fffffff;
446    UV extra = none + 1;
447    UV final = 0;
448    bool havefinal = FALSE;
449    UV uv;
450    STRLEN len;
451    U8 *dstart, *dend;
452    I32 isutf8;
453    U8 hibit = 0;
454
455    s = (U8*)SvPV(sv, len);
456    isutf8 = SvUTF8(sv);
457    if (!isutf8) {
458        U8 *t = s, *e = s + len;
459        while (t < e) {
460            U8 ch = *t++;
461            if ((hibit = !NATIVE_IS_INVARIANT(ch)))
462                break;
463        }
464        if (hibit)
465            s = bytes_to_utf8(s, &len);
466    }
467    send = s + len;
468    start = s;
469
470    svp = hv_fetch(hv, "FINAL", 5, FALSE);
471    if (svp) {
472        final = SvUV(*svp);
473        havefinal = TRUE;
474    }
475
476    if (grows) {
477        /* d needs to be bigger than s, in case e.g. upgrading is required */
478        New(0, d, len*3+UTF8_MAXLEN, U8);
479        dend = d + len * 3;
480        dstart = d;
481    }
482    else {
483        dstart = d = s;
484        dend = d + len;
485    }
486
487    if (squash) {
488        UV puv = 0xfeedface;
489        while (s < send) {
490            uv = swash_fetch(rv, s, TRUE);
491       
492            if (d > dend) {
493                STRLEN clen = d - dstart;
494                STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
495                if (!grows)
496                    Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
497                Renew(dstart, nlen+UTF8_MAXLEN, U8);
498                d = dstart + clen;
499                dend = dstart + nlen;
500            }
501            if (uv < none) {
502                matches++;
503                s += UTF8SKIP(s);
504                if (uv != puv) {
505                    d = uvuni_to_utf8(d, uv);
506                    puv = uv;
507                }
508                continue;
509            }
510            else if (uv == none) {      /* "none" is unmapped character */
511                int i = UTF8SKIP(s);
512                Move(s, d, i, U8);
513                d += i;
514                s += i;
515                puv = 0xfeedface;
516                continue;
517            }
518            else if (uv == extra && !del) {
519                matches++;
520                if (havefinal) {
521                    s += UTF8SKIP(s);
522                    if (puv != final) {
523                        d = uvuni_to_utf8(d, final);
524                        puv = final;
525                    }
526                }
527                else {
528                    STRLEN len;
529                    uv = utf8_to_uvuni(s, &len);
530                    if (uv != puv) {
531                        Move(s, d, len, U8);
532                        d += len;
533                        puv = uv;
534                    }
535                    s += len;
536                }
537                continue;
538            }
539            matches++;                  /* "none+1" is delete character */
540            s += UTF8SKIP(s);
541        }
542    }
543    else {
544        while (s < send) {
545            uv = swash_fetch(rv, s, TRUE);
546            if (d > dend) {
547                STRLEN clen = d - dstart;
548                STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
549                if (!grows)
550                    Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
551                Renew(dstart, nlen+UTF8_MAXLEN, U8);
552                d = dstart + clen;
553                dend = dstart + nlen;
554            }
555            if (uv < none) {
556                matches++;
557                s += UTF8SKIP(s);
558                d = uvuni_to_utf8(d, uv);
559                continue;
560            }
561            else if (uv == none) {      /* "none" is unmapped character */
562                int i = UTF8SKIP(s);
563                Move(s, d, i, U8);
564                d += i;
565                s += i;
566                continue;
567            }
568            else if (uv == extra && !del) {
569                matches++;
570                s += UTF8SKIP(s);
571                d = uvuni_to_utf8(d, final);
572                continue;
573            }
574            matches++;                  /* "none+1" is delete character */
575            s += UTF8SKIP(s);
576        }
577    }
578    if (grows || hibit) {
579        sv_setpvn(sv, (char*)dstart, d - dstart);
580        Safefree(dstart);
581        if (grows && hibit)
582            Safefree(start);
583    }
584    else {
585        *d = '\0';
586        SvCUR_set(sv, d - dstart);
587    }
588    SvUTF8_on(sv);
589    SvSETMAGIC(sv);
590
591    return matches;
592}
593
594I32
595Perl_do_trans(pTHX_ SV *sv)
596{
597    STRLEN len;
598    I32 hasutf = (PL_op->op_private &
599                    (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
600
601    if (SvREADONLY(sv)) {
602        if (SvFAKE(sv))
603            sv_force_normal(sv);
604        if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
605            Perl_croak(aTHX_ PL_no_modify);
606    }
607    (void)SvPV(sv, len);
608    if (!len)
609        return 0;
610    if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
611        if (!SvPOKp(sv))
612            (void)SvPV_force(sv, len);
613        (void)SvPOK_only_UTF8(sv);
614    }
615
616    DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
617
618    switch (PL_op->op_private & ~hasutf & 63) {
619    case 0:
620        if (hasutf)
621            return do_trans_simple_utf8(sv);
622        else
623            return do_trans_simple(sv);
624
625    case OPpTRANS_IDENTICAL:
626    case OPpTRANS_IDENTICAL|OPpTRANS_COMPLEMENT:
627        if (hasutf)
628            return do_trans_count_utf8(sv);
629        else
630            return do_trans_count(sv);
631
632    default:
633        if (hasutf)
634            return do_trans_complex_utf8(sv);
635        else
636            return do_trans_complex(sv);
637    }
638}
639
640void
641Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **sp)
642{
643    SV **oldmark = mark;
644    register I32 items = sp - mark;
645    register STRLEN len;
646    STRLEN delimlen;
647    STRLEN tmplen;
648
649    (void) SvPV(del, delimlen); /* stringify and get the delimlen */
650    /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */
651
652    mark++;
653    len = (items > 0 ? (delimlen * (items - 1) ) : 0);
654    (void)SvUPGRADE(sv, SVt_PV);
655    if (SvLEN(sv) < len + items) {      /* current length is way too short */
656        while (items-- > 0) {
657            if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) {
658                SvPV(*mark, tmplen);
659                len += tmplen;
660            }
661            mark++;
662        }
663        SvGROW(sv, len + 1);            /* so try to pre-extend */
664
665        mark = oldmark;
666        items = sp - mark;
667        ++mark;
668    }
669
670    sv_setpv(sv, "");
671    /* sv_setpv retains old UTF8ness [perl #24846] */
672    if (SvUTF8(sv))
673        SvUTF8_off(sv);
674
675    if (PL_tainting && SvMAGICAL(sv))
676        SvTAINTED_off(sv);
677
678    if (items-- > 0) {
679        if (*mark)
680            sv_catsv(sv, *mark);
681        mark++;
682    }
683
684    if (delimlen) {
685        for (; items > 0; items--,mark++) {
686            sv_catsv(sv,del);
687            sv_catsv(sv,*mark);
688        }
689    }
690    else {
691        for (; items > 0; items--,mark++)
692            sv_catsv(sv,*mark);
693    }
694    SvSETMAGIC(sv);
695}
696
697void
698Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
699{
700    STRLEN patlen;
701    char *pat = SvPV(*sarg, patlen);
702    bool do_taint = FALSE;
703
704    SvUTF8_off(sv);
705    if (DO_UTF8(*sarg))
706        SvUTF8_on(sv);
707    sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
708    SvSETMAGIC(sv);
709    if (do_taint)
710        SvTAINTED_on(sv);
711}
712
713/* currently converts input to bytes if possible, but doesn't sweat failure */
714UV
715Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
716{
717    STRLEN srclen, len;
718    unsigned char *s = (unsigned char *) SvPV(sv, srclen);
719    UV retnum = 0;
720
721    if (offset < 0)
722        return retnum;
723    if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
724        Perl_croak(aTHX_ "Illegal number of bits in vec");
725
726    if (SvUTF8(sv))
727        (void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
728
729    offset *= size;     /* turn into bit offset */
730    len = (offset + size + 7) / 8;      /* required number of bytes */
731    if (len > srclen) {
732        if (size <= 8)
733            retnum = 0;
734        else {
735            offset >>= 3;       /* turn into byte offset */
736            if (size == 16) {
737                if ((STRLEN)offset >= srclen)
738                    retnum = 0;
739                else
740                    retnum = (UV) s[offset] <<  8;
741            }
742            else if (size == 32) {
743                if ((STRLEN)offset >= srclen)
744                    retnum = 0;
745                else if ((STRLEN)(offset + 1) >= srclen)
746                    retnum =
747                        ((UV) s[offset    ] << 24);
748                else if ((STRLEN)(offset + 2) >= srclen)
749                    retnum =
750                        ((UV) s[offset    ] << 24) +
751                        ((UV) s[offset + 1] << 16);
752                else
753                    retnum =
754                        ((UV) s[offset    ] << 24) +
755                        ((UV) s[offset + 1] << 16) +
756                        (     s[offset + 2] <<  8);
757            }
758#ifdef UV_IS_QUAD
759            else if (size == 64) {
760                if (ckWARN(WARN_PORTABLE))
761                    Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
762                                "Bit vector size > 32 non-portable");
763                if (offset >= srclen)
764                    retnum = 0;
765                else if (offset + 1 >= srclen)
766                    retnum =
767                        (UV) s[offset     ] << 56;
768                else if (offset + 2 >= srclen)
769                    retnum =
770                        ((UV) s[offset    ] << 56) +
771                        ((UV) s[offset + 1] << 48);
772                else if (offset + 3 >= srclen)
773                    retnum =
774                        ((UV) s[offset    ] << 56) +
775                        ((UV) s[offset + 1] << 48) +
776                        ((UV) s[offset + 2] << 40);
777                else if (offset + 4 >= srclen)
778                    retnum =
779                        ((UV) s[offset    ] << 56) +
780                        ((UV) s[offset + 1] << 48) +
781                        ((UV) s[offset + 2] << 40) +
782                        ((UV) s[offset + 3] << 32);
783                else if (offset + 5 >= srclen)
784                    retnum =
785                        ((UV) s[offset    ] << 56) +
786                        ((UV) s[offset + 1] << 48) +
787                        ((UV) s[offset + 2] << 40) +
788                        ((UV) s[offset + 3] << 32) +
789                        (     s[offset + 4] << 24);
790                else if (offset + 6 >= srclen)
791                    retnum =
792                        ((UV) s[offset    ] << 56) +
793                        ((UV) s[offset + 1] << 48) +
794                        ((UV) s[offset + 2] << 40) +
795                        ((UV) s[offset + 3] << 32) +
796                        ((UV) s[offset + 4] << 24) +
797                        ((UV) s[offset + 5] << 16);
798                else
799                    retnum =
800                        ((UV) s[offset    ] << 56) +
801                        ((UV) s[offset + 1] << 48) +
802                        ((UV) s[offset + 2] << 40) +
803                        ((UV) s[offset + 3] << 32) +
804                        ((UV) s[offset + 4] << 24) +
805                        ((UV) s[offset + 5] << 16) +
806                        (     s[offset + 6] <<  8);
807            }
808#endif
809        }
810    }
811    else if (size < 8)
812        retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
813    else {
814        offset >>= 3;   /* turn into byte offset */
815        if (size == 8)
816            retnum = s[offset];
817        else if (size == 16)
818            retnum =
819                ((UV) s[offset] <<      8) +
820                      s[offset + 1];
821        else if (size == 32)
822            retnum =
823                ((UV) s[offset    ] << 24) +
824                ((UV) s[offset + 1] << 16) +
825                (     s[offset + 2] <<  8) +
826                      s[offset + 3];
827#ifdef UV_IS_QUAD
828        else if (size == 64) {
829            if (ckWARN(WARN_PORTABLE))
830                Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
831                            "Bit vector size > 32 non-portable");
832            retnum =
833                ((UV) s[offset    ] << 56) +
834                ((UV) s[offset + 1] << 48) +
835                ((UV) s[offset + 2] << 40) +
836                ((UV) s[offset + 3] << 32) +
837                ((UV) s[offset + 4] << 24) +
838                ((UV) s[offset + 5] << 16) +
839                (     s[offset + 6] <<  8) +
840                      s[offset + 7];
841        }
842#endif
843    }
844
845    return retnum;
846}
847
848/* currently converts input to bytes if possible but doesn't sweat failures,
849 * although it does ensure that the string it clobbers is not marked as
850 * utf8-valid any more
851 */
852void
853Perl_do_vecset(pTHX_ SV *sv)
854{
855    SV *targ = LvTARG(sv);
856    register I32 offset;
857    register I32 size;
858    register unsigned char *s;
859    register UV lval;
860    I32 mask;
861    STRLEN targlen;
862    STRLEN len;
863
864    if (!targ)
865        return;
866    s = (unsigned char*)SvPV_force(targ, targlen);
867    if (SvUTF8(targ)) {
868        /* This is handled by the SvPOK_only below...
869        if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
870            SvUTF8_off(targ);
871         */
872        (void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
873    }
874
875    (void)SvPOK_only(targ);
876    lval = SvUV(sv);
877    offset = LvTARGOFF(sv);
878    if (offset < 0)
879        Perl_croak(aTHX_ "Negative offset to vec in lvalue context");
880    size = LvTARGLEN(sv);
881    if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
882        Perl_croak(aTHX_ "Illegal number of bits in vec");
883
884    offset *= size;                     /* turn into bit offset */
885    len = (offset + size + 7) / 8;      /* required number of bytes */
886    if (len > targlen) {
887        s = (unsigned char*)SvGROW(targ, len + 1);
888        (void)memzero((char *)(s + targlen), len - targlen + 1);
889        SvCUR_set(targ, len);
890    }
891
892    if (size < 8) {
893        mask = (1 << size) - 1;
894        size = offset & 7;
895        lval &= mask;
896        offset >>= 3;                   /* turn into byte offset */
897        s[offset] &= ~(mask << size);
898        s[offset] |= lval << size;
899    }
900    else {
901        offset >>= 3;                   /* turn into byte offset */
902        if (size == 8)
903            s[offset  ] = (U8)( lval        & 0xff);
904        else if (size == 16) {
905            s[offset  ] = (U8)((lval >>  8) & 0xff);
906            s[offset+1] = (U8)( lval        & 0xff);
907        }
908        else if (size == 32) {
909            s[offset  ] = (U8)((lval >> 24) & 0xff);
910            s[offset+1] = (U8)((lval >> 16) & 0xff);
911            s[offset+2] = (U8)((lval >>  8) & 0xff);
912            s[offset+3] = (U8)( lval        & 0xff);
913        }
914#ifdef UV_IS_QUAD
915        else if (size == 64) {
916            if (ckWARN(WARN_PORTABLE))
917                Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
918                            "Bit vector size > 32 non-portable");
919            s[offset  ] = (U8)((lval >> 56) & 0xff);
920            s[offset+1] = (U8)((lval >> 48) & 0xff);
921            s[offset+2] = (U8)((lval >> 40) & 0xff);
922            s[offset+3] = (U8)((lval >> 32) & 0xff);
923            s[offset+4] = (U8)((lval >> 24) & 0xff);
924            s[offset+5] = (U8)((lval >> 16) & 0xff);
925            s[offset+6] = (U8)((lval >>  8) & 0xff);
926            s[offset+7] = (U8)( lval        & 0xff);
927        }
928#endif
929    }
930    SvSETMAGIC(targ);
931}
932
933void
934Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
935{
936    STRLEN len;
937    char *s;
938
939    if (SvTYPE(sv) == SVt_PVAV) {
940        register I32 i;
941        I32 max;
942        AV* av = (AV*)sv;
943        max = AvFILL(av);
944        for (i = 0; i <= max; i++) {
945            sv = (SV*)av_fetch(av, i, FALSE);
946            if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
947                do_chop(astr, sv);
948        }
949        return;
950    }
951    else if (SvTYPE(sv) == SVt_PVHV) {
952        HV* hv = (HV*)sv;
953        HE* entry;
954        (void)hv_iterinit(hv);
955        /*SUPPRESS 560*/
956        while ((entry = hv_iternext(hv)))
957            do_chop(astr,hv_iterval(hv,entry));
958        return;
959    }
960    else if (SvREADONLY(sv)) {
961        if (SvFAKE(sv)) {
962            /* SV is copy-on-write */
963            sv_force_normal_flags(sv, 0);
964        }
965        if (SvREADONLY(sv))
966            Perl_croak(aTHX_ PL_no_modify);
967    }
968    s = SvPV(sv, len);
969    if (len && !SvPOK(sv))
970        s = SvPV_force(sv, len);
971    if (DO_UTF8(sv)) {
972        if (s && len) {
973            char *send = s + len;
974            char *start = s;
975            s = send - 1;
976            while (s > start && UTF8_IS_CONTINUATION(*s))
977                s--;
978            if (utf8_to_uvchr((U8*)s, 0)) {
979                sv_setpvn(astr, s, send - s);
980                *s = '\0';
981                SvCUR_set(sv, s - start);
982                SvNIOK_off(sv);
983                SvUTF8_on(astr);
984            }
985        }
986        else
987            sv_setpvn(astr, "", 0);
988    }
989    else if (s && len) {
990        s += --len;
991        sv_setpvn(astr, s, 1);
992        *s = '\0';
993        SvCUR_set(sv, len);
994        SvUTF8_off(sv);
995        SvNIOK_off(sv);
996    }
997    else
998        sv_setpvn(astr, "", 0);
999    SvSETMAGIC(sv);
1000}
1001
1002I32
1003Perl_do_chomp(pTHX_ register SV *sv)
1004{
1005    register I32 count;
1006    STRLEN len;
1007    STRLEN n_a;
1008    char *s;
1009
1010    if (RsSNARF(PL_rs))
1011        return 0;
1012    if (RsRECORD(PL_rs))
1013      return 0;
1014    count = 0;
1015    if (SvTYPE(sv) == SVt_PVAV) {
1016        register I32 i;
1017        I32 max;
1018        AV* av = (AV*)sv;
1019        max = AvFILL(av);
1020        for (i = 0; i <= max; i++) {
1021            sv = (SV*)av_fetch(av, i, FALSE);
1022            if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
1023                count += do_chomp(sv);
1024        }
1025        return count;
1026    }
1027    else if (SvTYPE(sv) == SVt_PVHV) {
1028        HV* hv = (HV*)sv;
1029        HE* entry;
1030        (void)hv_iterinit(hv);
1031        /*SUPPRESS 560*/
1032        while ((entry = hv_iternext(hv)))
1033            count += do_chomp(hv_iterval(hv,entry));
1034        return count;
1035    }
1036    else if (SvREADONLY(sv)) {
1037        if (SvFAKE(sv)) {
1038            /* SV is copy-on-write */
1039            sv_force_normal_flags(sv, 0);
1040        }
1041        if (SvREADONLY(sv))
1042            Perl_croak(aTHX_ PL_no_modify);
1043    }
1044    s = SvPV(sv, len);
1045    if (s && len) {
1046        s += --len;
1047        if (RsPARA(PL_rs)) {
1048            if (*s != '\n')
1049                goto nope;
1050            ++count;
1051            while (len && s[-1] == '\n') {
1052                --len;
1053                --s;
1054                ++count;
1055            }
1056        }
1057        else {
1058            STRLEN rslen;
1059            char *rsptr = SvPV(PL_rs, rslen);
1060            if (rslen == 1) {
1061                if (*s != *rsptr)
1062                    goto nope;
1063                ++count;
1064            }
1065            else {
1066                if (len < rslen - 1)
1067                    goto nope;
1068                len -= rslen - 1;
1069                s -= rslen - 1;
1070                if (memNE(s, rsptr, rslen))
1071                    goto nope;
1072                count += rslen;
1073            }
1074        }
1075        s = SvPV_force(sv, n_a);
1076        SvCUR_set(sv, len);
1077        *SvEND(sv) = '\0';
1078        SvNIOK_off(sv);
1079        SvSETMAGIC(sv);
1080    }
1081  nope:
1082    return count;
1083}
1084
1085void
1086Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
1087{
1088#ifdef LIBERAL
1089    register long *dl;
1090    register long *ll;
1091    register long *rl;
1092#endif
1093    register char *dc;
1094    STRLEN leftlen;
1095    STRLEN rightlen;
1096    register char *lc;
1097    register char *rc;
1098    register I32 len;
1099    I32 lensave;
1100    char *lsave;
1101    char *rsave;
1102    bool left_utf = DO_UTF8(left);
1103    bool right_utf = DO_UTF8(right);
1104    I32 needlen = 0;
1105
1106    if (left_utf && !right_utf)
1107        sv_utf8_upgrade(right);
1108    else if (!left_utf && right_utf)
1109        sv_utf8_upgrade(left);
1110
1111    if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
1112        sv_setpvn(sv, "", 0);   /* avoid undef warning on |= and ^= */
1113    lsave = lc = SvPV(left, leftlen);
1114    rsave = rc = SvPV(right, rightlen);
1115    len = leftlen < rightlen ? leftlen : rightlen;
1116    lensave = len;
1117    if ((left_utf || right_utf) && (sv == left || sv == right)) {
1118        needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
1119        Newz(801, dc, needlen + 1, char);
1120    }
1121    else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
1122        STRLEN n_a;
1123        dc = SvPV_force(sv, n_a);
1124        if (SvCUR(sv) < (STRLEN)len) {
1125            dc = SvGROW(sv, (STRLEN)(len + 1));
1126            (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
1127        }
1128        if (optype != OP_BIT_AND && (left_utf || right_utf))
1129            dc = SvGROW(sv, leftlen + rightlen + 1);
1130    }
1131    else {
1132        needlen = ((optype == OP_BIT_AND)
1133                    ? len : (leftlen > rightlen ? leftlen : rightlen));
1134        Newz(801, dc, needlen + 1, char);
1135        (void)sv_usepvn(sv, dc, needlen);
1136        dc = SvPVX(sv);         /* sv_usepvn() calls Renew() */
1137    }
1138    SvCUR_set(sv, len);
1139    (void)SvPOK_only(sv);
1140    if (left_utf || right_utf) {
1141        UV duc, luc, ruc;
1142        char *dcsave = dc;
1143        STRLEN lulen = leftlen;
1144        STRLEN rulen = rightlen;
1145        STRLEN ulen;
1146
1147        switch (optype) {
1148        case OP_BIT_AND:
1149            while (lulen && rulen) {
1150                luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1151                lc += ulen;
1152                lulen -= ulen;
1153                ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1154                rc += ulen;
1155                rulen -= ulen;
1156                duc = luc & ruc;
1157                dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1158            }
1159            if (sv == left || sv == right)
1160                (void)sv_usepvn(sv, dcsave, needlen);
1161            SvCUR_set(sv, dc - dcsave);
1162            break;
1163        case OP_BIT_XOR:
1164            while (lulen && rulen) {
1165                luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1166                lc += ulen;
1167                lulen -= ulen;
1168                ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1169                rc += ulen;
1170                rulen -= ulen;
1171                duc = luc ^ ruc;
1172                dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1173            }
1174            goto mop_up_utf;
1175        case OP_BIT_OR:
1176            while (lulen && rulen) {
1177                luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
1178                lc += ulen;
1179                lulen -= ulen;
1180                ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
1181                rc += ulen;
1182                rulen -= ulen;
1183                duc = luc | ruc;
1184                dc = (char*)uvchr_to_utf8((U8*)dc, duc);
1185            }
1186          mop_up_utf:
1187            if (sv == left || sv == right)
1188                (void)sv_usepvn(sv, dcsave, needlen);
1189            SvCUR_set(sv, dc - dcsave);
1190            if (rulen)
1191                sv_catpvn(sv, rc, rulen);
1192            else if (lulen)
1193                sv_catpvn(sv, lc, lulen);
1194            else
1195                *SvEND(sv) = '\0';
1196            break;
1197        }
1198        SvUTF8_on(sv);
1199        goto finish;
1200    }
1201    else
1202#ifdef LIBERAL
1203    if (len >= sizeof(long)*4 &&
1204        !((long)dc % sizeof(long)) &&
1205        !((long)lc % sizeof(long)) &&
1206        !((long)rc % sizeof(long)))     /* It's almost always aligned... */
1207    {
1208        I32 remainder = len % (sizeof(long)*4);
1209        len /= (sizeof(long)*4);
1210
1211        dl = (long*)dc;
1212        ll = (long*)lc;
1213        rl = (long*)rc;
1214
1215        switch (optype) {
1216        case OP_BIT_AND:
1217            while (len--) {
1218                *dl++ = *ll++ & *rl++;
1219                *dl++ = *ll++ & *rl++;
1220                *dl++ = *ll++ & *rl++;
1221                *dl++ = *ll++ & *rl++;
1222            }
1223            break;
1224        case OP_BIT_XOR:
1225            while (len--) {
1226                *dl++ = *ll++ ^ *rl++;
1227                *dl++ = *ll++ ^ *rl++;
1228                *dl++ = *ll++ ^ *rl++;
1229                *dl++ = *ll++ ^ *rl++;
1230            }
1231            break;
1232        case OP_BIT_OR:
1233            while (len--) {
1234                *dl++ = *ll++ | *rl++;
1235                *dl++ = *ll++ | *rl++;
1236                *dl++ = *ll++ | *rl++;
1237                *dl++ = *ll++ | *rl++;
1238            }
1239        }
1240
1241        dc = (char*)dl;
1242        lc = (char*)ll;
1243        rc = (char*)rl;
1244
1245        len = remainder;
1246    }
1247#endif
1248    {
1249        switch (optype) {
1250        case OP_BIT_AND:
1251            while (len--)
1252                *dc++ = *lc++ & *rc++;
1253            break;
1254        case OP_BIT_XOR:
1255            while (len--)
1256                *dc++ = *lc++ ^ *rc++;
1257            goto mop_up;
1258        case OP_BIT_OR:
1259            while (len--)
1260                *dc++ = *lc++ | *rc++;
1261          mop_up:
1262            len = lensave;
1263            if (rightlen > (STRLEN)len)
1264                sv_catpvn(sv, rsave + len, rightlen - len);
1265            else if (leftlen > (STRLEN)len)
1266                sv_catpvn(sv, lsave + len, leftlen - len);
1267            else
1268                *SvEND(sv) = '\0';
1269            break;
1270        }
1271    }
1272finish:
1273    SvTAINT(sv);
1274}
1275
1276OP *
1277Perl_do_kv(pTHX)
1278{
1279    dSP;
1280    HV *hv = (HV*)POPs;
1281    HV *keys;
1282    register HE *entry;
1283    SV *tmpstr;
1284    I32 gimme = GIMME_V;
1285    I32 dokeys =   (PL_op->op_type == OP_KEYS);
1286    I32 dovalues = (PL_op->op_type == OP_VALUES);
1287    I32 realhv = (SvTYPE(hv) == SVt_PVHV);
1288
1289    if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV)
1290        dokeys = dovalues = TRUE;
1291
1292    if (!hv) {
1293        if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
1294            dTARGET;            /* make sure to clear its target here */
1295            if (SvTYPE(TARG) == SVt_PVLV)
1296                LvTARG(TARG) = Nullsv;
1297            PUSHs(TARG);
1298        }
1299        RETURN;
1300    }
1301
1302    keys = realhv ? hv : avhv_keys((AV*)hv);
1303    (void)hv_iterinit(keys);    /* always reset iterator regardless */
1304
1305    if (gimme == G_VOID)
1306        RETURN;
1307
1308    if (gimme == G_SCALAR) {
1309        IV i;
1310        dTARGET;
1311
1312        if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
1313            if (SvTYPE(TARG) < SVt_PVLV) {
1314                sv_upgrade(TARG, SVt_PVLV);
1315                sv_magic(TARG, Nullsv, PERL_MAGIC_nkeys, Nullch, 0);
1316            }
1317            LvTYPE(TARG) = 'k';
1318            if (LvTARG(TARG) != (SV*)keys) {
1319                if (LvTARG(TARG))
1320                    SvREFCNT_dec(LvTARG(TARG));
1321                LvTARG(TARG) = SvREFCNT_inc(keys);
1322            }
1323            PUSHs(TARG);
1324            RETURN;
1325        }
1326
1327        if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied))
1328            i = HvKEYS(keys);
1329        else {
1330            i = 0;
1331            /*SUPPRESS 560*/
1332            while (hv_iternext(keys)) i++;
1333        }
1334        PUSHi( i );
1335        RETURN;
1336    }
1337
1338    EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
1339
1340    PUTBACK;    /* hv_iternext and hv_iterval might clobber stack_sp */
1341    while ((entry = hv_iternext(keys))) {
1342        SPAGAIN;
1343        if (dokeys) {
1344            SV* sv = hv_iterkeysv(entry);
1345            XPUSHs(sv); /* won't clobber stack_sp */
1346        }
1347        if (dovalues) {
1348            PUTBACK;
1349            tmpstr = realhv ?
1350                     hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry);
1351            DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
1352                            (unsigned long)HeHASH(entry),
1353                            HvMAX(keys)+1,
1354                            (unsigned long)(HeHASH(entry) & HvMAX(keys))));
1355            SPAGAIN;
1356            XPUSHs(tmpstr);
1357        }
1358        PUTBACK;
1359    }
1360    return NORMAL;
1361}
1362
Note: See TracBrowser for help on using the repository browser.