git.8kb.co.uk Git - dataflex/df32func/blob - src/df32/encode.inc

   1 //-------------------------------------------------------------------------\r
   2 // encode.inc\r
   3 //      This file contains some DataFlex 3.2 Console Mode functions\r
   4 //      to provide base64 and rc4 encoding/decoding.  More advanced \r
   5 //      encoding and encryption can be found in win32.inc.\r
   6 //\r
   7 // This file is to be included in df32func.mk\r
   8 //\r
   9 // Copyright (c) ????, ????@????.?? (unknown origin)\r
  10 // \r
  11 // df32func/encode.inc\r
  12 //-------------------------------------------------------------------------\r
  13 \r
  14 //-------------------------------------------------------------------------\r
  15 // Functions\r
  16 //-------------------------------------------------------------------------\r
  17 \r
  18 // Check if a string is base64\r
  19 function is_base64 global integer c returns integer\r
  20     if (c >= ascii('A') and c <= ascii('Z')) function_return true\r
  21     else if (c >= ascii('a') and c <= ascii('z')) function_return true\r
  22     else if (c >= ascii('0') and c <= ascii('9')) function_return true\r
  23     else if (c = ascii('+')) function_return true\r
  24     else if (c = ascii('/')) function_return true\r
  25     else if (c = ascii('=')) function_return true\r
  26     else function_return false\r
  27 end_function\r
  28 \r
  29 //encode integer to hex ascii code\r
  30 function int_encode64 global integer uc returns integer\r
  31     if (uc < 26) function_return (ascii('A')+uc)\r
  32     else if (uc < 52) function_return (ascii('a')+(uc-26))\r
  33     else if (uc < 62) function_return (ascii('0')+(uc-52))\r
  34     else if (uc = 62) function_return (ascii('+'))\r
  35     else function_return (ascii('/'))\r
  36 end_function\r
  37 \r
  38 //decode hex to integer ascii code\r
  39 function int_decode64 global integer c returns integer\r
  40     if (c >= ascii('A') and c <= ascii('Z')) function_return (c - ascii('A'))\r
  41     else if (c >= ascii('a') and c <= ascii('z')) function_return (c - ascii('a') + 26)\r
  42     else if (c >= ascii('0') and c <= ascii('9')) function_return (c - ascii('0') + 52)\r
  43     else if (c = ascii('+')) function_return 62\r
  44     else function_return 63\r
  45 end_function\r
  46 \r
  47 // encode to base64\r
  48 function encode64 global string sText returns string\r
  49     local integer iLen iPos iChar\r
  50     local integer by1 by2 by3 \r
  51     local integer by4 by5 by6 by7\r
  52     local string  sRet\r
  53     \r
  54     move (length(sText)) to iLen\r
  55     move 1 to iPos\r
  56     \r
  57     if iPos Lt 1 function_return \r
  58     \r
  59     while (iPos <= iLen)            \r
  60        move 0 to by1\r
  61        move 0 to by2\r
  62        move 0 to by3       \r
  63        move 0 to by4\r
  64        move 0 to by5\r
  65        move 0 to by6\r
  66        move 0 to by7\r
  67        \r
  68        if (iPos+0 <= iLen) move (ascii(mid(sText,1,iPos+0))) to by1 \r
  69        if (iPos+1 <= iLen) move (ascii(mid(sText,1,iPos+1))) to by2\r
  70        if (iPos+2 <= iLen) move (ascii(mid(sText,1,iPos+2))) to by3       \r
  71        move (rshift(by1,2)) to by4\r
  72        move (lshift((by1 iand 3),4)  ior rshift(by2,4)) to by5  \r
  73        move (lshift((by2 iand 15),2) ior rshift(by3,6)) to by6 \r
  74        move (by3 iand 63) to by7\r
  75        \r
  76        append sRet (character(int_encode64(by4)))\r
  77        append sRet (character(int_encode64(by5)))\r
  78        \r
  79        if (iPos+1<=iLen) append sRet (character(int_encode64(by6)))\r
  80        else append sRet "=" \r
  81        \r
  82        if (iPos+2<=iLen) append sRet (character(int_encode64(by7)))  \r
  83        else append sRet "="\r
  84        \r
  85        move (iPos+3) to iPos\r
  86     end\r
  87     function_return sRet\r
  88 end_function\r
  89 \r
  90 // decode from base64\r
  91 function decode64 global string sText returns string\r
  92     local integer iLen iPos iChar isOK\r
  93     local integer c1  c2  c3  c4 \r
  94     local integer cc1 cc2 cc3\r
  95     local integer by1 by2 by3 by4\r
  96     local string  sRet\r
  97     \r
  98     move (length(sText)) to iLen\r
  99     \r
 100     move 1 to isOK\r
 101     for iPos from 1 to iLen\r
 102        move (is_base64(ascii(mid(sText,1,iPos)))) to isOK \r
 103        if isOK eq 0 Break\r
 104     loop\r
 105 \r
 106     if (isOK) begin\r
 107       move 1 to iPos\r
 108       while (iPos<=iLen)\r
 109         move (ascii('A')) to c1\r
 110         move (ascii('A')) to c2\r
 111         move (ascii('A')) to c3\r
 112         move (ascii('A')) to c4\r
 113        \r
 114         if (iPos+0<=iLen) move (ascii(mid(sText,1,iPos+0))) to c1 \r
 115         if (iPos+1<=iLen) move (ascii(mid(sText,1,iPos+1))) to c2\r
 116         if (iPos+2<=iLen) move (ascii(mid(sText,1,iPos+2))) to c3\r
 117         if (iPos+3<=iLen) move (ascii(mid(sText,1,iPos+3))) to c4\r
 118        \r
 119         move (int_decode64(c1)) to by1\r
 120         move (int_decode64(c2)) to by2\r
 121         move (int_decode64(c3)) to by3\r
 122         move (int_decode64(c4)) to by4\r
 123        \r
 124         append sRet (character(lshift(by1,2) ior rshift(by2,4)))\r
 125         if (c3<>ascii('=')) append sRet (character(lshift((by2 iand 15),4) ior rshift(by3,2)))\r
 126         if (c4<>ascii('=')) append sRet (character(lshift((by3 iand 3) ,6) ior by4))\r
 127                                                                           \r
 128         move (iPos+4) to iPos\r
 129       end\r
 130     end\r
 131     function_return sRet\r
 132 end_function\r
 133 \r
 134 procedure set rc4_array_value integer iIndex integer iVal\r
 135     move (iIndex+1)  to iIndex\r
 136     if iIndex Le 128 ;\r
 137          move (Overstrike(character(iVal),rc4SBXA,iIndex))     to rc4SBXA\r
 138     else move (Overstrike(character(iVal),rc4SBXB,iIndex-128)) to rc4SBXB\r
 139 end_procedure\r
 140 \r
 141 function rc4_array_value integer iIndex returns integer\r
 142     local integer iRet\r
 143     move (iIndex+1)  to iIndex\r
 144     if iIndex Le 128 ;\r
 145          move (ascii(mid(rc4SBXA,1,iIndex)))     to iRet\r
 146     else move (ascii(mid(rc4SBXB,1,iIndex-128))) to iRet\r
 147     function_return iRet\r
 148 end_function\r
 149 \r
 150 procedure create_rc4_key string key\r
 151     local integer a b keylen idx\r
 152     local integer ikey atmp btmp\r
 153 \r
 154     move (length(key)) to keylen\r
 155     \r
 156     // initialise key array\r
 157     move rc4SBXA to rc4SBXA_TMP\r
 158     move rc4SBXA to rc4SBXB_TMP\r
 159     \r
 160     move "" to rc4SBXA\r
 161     move "" to rc4SBXB\r
 162     \r
 163     for idx from 0 to 255\r
 164        set rc4_array_value idx to idx\r
 165     loop                   \r
 166     \r
 167     // encode key array\r
 168     for a from 0 to 255\r
 169        move (ascii(mid(key,1,mod(a,keylen)+1))) to ikey\r
 170        get rc4_array_value a to atmp\r
 171        move (mod((b+atmp+ikey),256)) to b\r
 172 \r
 173        get rc4_array_value b to btmp\r
 174 \r
 175        set rc4_array_value a to btmp\r
 176        set rc4_array_value b to atmp\r
 177     loop\r
 178     \r
 179 end_procedure\r
 180 \r
 181 function rc4 global string key string text returns string\r
 182     local integer ix iy temp offset origlen cipherlen\r
 183     local integer ixtmp iytmp ixytmp ixc\r
 184     local string sRet\r
 185 \r
 186     send create_rc4_key key  \r
 187     move (length(text)) to origlen\r
 188     \r
 189     move "" to sRet\r
 190     for offset from 1 to origlen\r
 191         move (mod((offset-1),256)) to ix\r
 192         get rc4_array_value ix to ixtmp\r
 193         move (mod((iy+ixtmp),256)) to iy\r
 194         //\r
 195         get rc4_array_value ix to ixtmp\r
 196         get rc4_array_value iy to iytmp\r
 197         //\r
 198         set rc4_array_value ix to iytmp\r
 199         set rc4_array_value iy to ixtmp\r
 200         //\r
 201         move (ascii(mid(text,1,offset))) to ixc\r
 202         //\r
 203         get rc4_array_value ix to ixtmp\r
 204         get rc4_array_value iy to iytmp\r
 205         get rc4_array_value (mod((ixtmp+iytmp),256)) to ixytmp\r
 206         move ((ixc ior ixytmp) - (ixc iand ixytmp)) to ixc //XOR\r
 207         //\r
 208         move (sRet+(character(ixc))) to sRet\r
 209     loop\r
 210     function_return sRet\r
 211 end_function\r
 212 \r
 213 function rc4encode global string key string text returns string\r
 214     function_return (rc4(key,text))\r
 215 end_function\r
 216 \r
 217 function rc4decode global string key string text returns string\r
 218     function_return (rc4(key,text))\r
 219 end_function\r
 220 \r
 221 function rc4encode_base64 global string key string text returns string\r
 222     function_return (encode64(rc4encode(key,text)))\r
 223 end_function\r
 224 \r
 225 function rc4decode_base64 global string key string text returns string\r
 226     function_return (rc4decode(key,decode64(text)))\r
 227 end_function\r