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