Перевод из кодировки UTF-8 в CP866

{$mode objfpc}{$H+}
 
type
  TUnicodeToCharID = function(Unicode: cardinal): integer;
 
function UnicodeToCP866(Unicode: cardinal): integer;
begin
  case Unicode of
  0..127: Result:=Unicode;
  1040..1087 : Result := Unicode-912;
  9617..9619 : Result := Unicode-9441;
  9474 : Result := 179;
  9508 : Result := 180;
  9569 : Result := 181;
  9570 : Result := 182;
  9558 : Result := 183;
  9557 : Result := 184;
  9571 : Result := 185;
  9553 : Result := 186;
  9559 : Result := 187;
  9565 : Result := 188;
  9564 : Result := 189;
  9563 : Result := 190;
  9488 : Result := 191;
  9492 : Result := 192;
  9524 : Result := 193;
  9516 : Result := 194;
  9500 : Result := 195;
  9472 : Result := 196;
  9532 : Result := 197;
  9566 : Result := 198;
  9567 : Result := 199;
  9562 : Result := 200;
  9556 : Result := 201;
  9577 : Result := 202;
  9574 : Result := 203;
  9568 : Result := 204;
  9552 : Result := 205;
  9580 : Result := 206;
  9575 : Result := 207;
  9576 : Result := 208;
  9572 : Result := 209;
  9573 : Result := 210;
  9561 : Result := 211;
  9560 : Result := 212;
  9554 : Result := 213;
  9555 : Result := 214;
  9579 : Result := 215;
  9578 : Result := 216;
  9496 : Result := 217;
  9484 : Result := 218;
  9608 : Result := 219;
  9604 : Result := 220;
  9612 : Result := 221;
  9616 : Result := 222;
  9600 : Result := 223;
  1088..1103 : Result := Unicode-864;
  1025 : Result := 240;
  1105 : Result := 241;
  1028 : Result := 242;
  1108 : Result := 243;
  1031 : Result := 244;
  1111 : Result := 245;
  1038 : Result := 246;
  1118 : Result := 247;
  176  : Result := 248;
  8729 : Result := 249;
  183  : Result := 250;
  8730 : Result := 251;
  8470 : Result := 252;
  164  : Result := 253;
  9632 : Result := 254;
  160  : Result := 255;
  else Result:=-1;
  end;
end;
 
function UTF8CharacterToUnicode(p: PChar; out CharLen: integer): Cardinal;
{ if p=nil then CharLen=0 otherwise CharLen>0
  If there is an encoding error the Result is 0 and CharLen=1.
  Use UTF8FixBroken to fix UTF-8 encoding.
  It does not check if the codepoint is defined in the Unicode tables.
}
begin
  if p<>nil then begin
    if ord(p^)<%11000000 then begin
      // regular single byte character (#0 is a normal char, this is pascal ;)
      Result:=ord(p^);
      CharLen:=1;
    end
    else if ((ord(p^) and %11100000) = %11000000) then begin
      // starts with %110 => could be double byte character
      if (ord(p[1]) and %11000000) = %10000000 then begin
        CharLen:=2;
        Result:=((ord(p^) and %00011111) shl 6)
                or (ord(p[1]) and %00111111);
        if Result<(1 shl 7) then begin
          // wrong encoded, could be an XSS attack
          Result:=0;
        end;
      end else begin
        Result:=ord(p^);
        CharLen:=1;
      end;
    end
    else if ((ord(p^) and %11110000) = %11100000) then begin
      // starts with %1110 => could be triple byte character
      if ((ord(p[1]) and %11000000) = %10000000)
      and ((ord(p[2]) and %11000000) = %10000000) then begin
        CharLen:=3;
        Result:=((ord(p^) and %00011111) shl 12)
                or ((ord(p[1]) and %00111111) shl 6)
                or (ord(p[2]) and %00111111);
        if Result<(1 shl 11) then begin
          // wrong encoded, could be an XSS attack
          Result:=0;
        end;
      end else begin
        Result:=ord(p^);
        CharLen:=1;
      end;
    end
    else if ((ord(p^) and %11111000) = %11110000) then begin
      // starts with %11110 => could be 4 byte character
      if ((ord(p[1]) and %11000000) = %10000000)
      and ((ord(p[2]) and %11000000) = %10000000)
      and ((ord(p[3]) and %11000000) = %10000000) then begin
        CharLen:=4;
        Result:=((ord(p^) and %00001111) shl 18)
                or ((ord(p[1]) and %00111111) shl 12)
                or ((ord(p[2]) and %00111111) shl 6)
                or (ord(p[3]) and %00111111);
        if Result<(1 shl 16) then begin
          // wrong encoded, could be an XSS attack
          Result:=0;
        end;
      end else begin
        Result:=ord(p^);
        CharLen:=1;
      end;
    end
    else begin
      // invalid character
      Result:=ord(p^);
      CharLen:=1;
    end;
  end else begin
    Result:=0;
    CharLen:=0;
  end;
end;
 
function UTF8ToSingleByte(const s: string;
  const UTF8CharConvFunc: TUnicodeToCharID): string;
var
  len: Integer;
  Src: PChar;
  Dest: PChar;
  c: Char;
  Unicode: LongWord;
  CharLen: integer;
  i: integer;
begin
  if s='' then begin
    Result:='';
    exit;
  end;
  len:=length(s);
  SetLength(Result,len);
  Src:=PChar(s);
  Dest:=PChar(Result);
  while len>0 do begin
    c:=Src^;
    if c<#128 then begin
      Dest^:=c;
      inc(Dest);
      inc(Src);
      dec(len);
    end else begin
      Unicode:=UTF8CharacterToUnicode(Src,CharLen);
      inc(Src,CharLen);
      dec(len,CharLen);
      i:=UTF8CharConvFunc(Unicode);
      if i>=0 then begin
        Dest^:=chr(i);
        inc(Dest);
      end;
    end;
  end;
  SetLength(Result,Dest-PChar(Result));
end;
 
function UTF8ToCP866(const s: string): string;
begin
  Result:=UTF8ToSingleByte(s,@UnicodeToCP866);
end;
 
begin
  // вызов UTF8ToCP866
end.