ispell.pas

拼写检查

    Insert(B,S,N);
    Result:=True;
end;

function ToUTF8 (const S: WideString): String;
 var b: byte;
     c: WChar;
     i: Integer;
begin
    result:='';
    for i:=1 to length(S) do
    begin
        c:=S[i];
        if ord(c)<128 then
            result:=result+char(c)
        else if ord(c)<2048 then
        begin
            b:=(ord(c) shr 6) and $1F or $C0;
            result:=result+char(b);
            b:=ord(c) and $3F or $80;
            result:=result+char(b);
        end
        else begin
            b:=(ord(c) shr 12) and $F or $E0;
            result:=result+char(b);
            b:=(ord(c) shr 6) and $3F or $80;
            result:=result+char(b);
            b:=ord(c) and $3F or $80;
            result:=result+char(b);
        end;
    end;
end; {ToUTF8}

function FromUTF8 (const S: String): WideString;
 var a,b,c: char;
     i,j: Integer;
begin
  i:=1; j:=1;
  SetLength(result,length(S));
  while i<=length(S) do
  begin
    a:=S[i]; Inc(i);
    if byte(a)<$80 then
    begin
        result[j]:=wchar(a);
        Inc(j);
        continue;
    end;
    if i>length(S) then break;
    b:=S[i]; Inc(i);
    if (byte(a)<$E0) or (i>length(S)) then
    begin
        result[j]:=wchar(((byte(a) and $1F) shl 6) or (byte(b) and $3F));
        Inc(j);
        continue;
    end;
    c:=S[i]; Inc(i);
    result[j]:=wchar(((byte(a) and $F) shl 12) or ((byte(b) and $3F) shl 6) or (byte(c) and $3F));
    Inc(j);
  end;
  SetLength(result,j-1);
end; {FromUTF8}

procedure StrSwapByteOrder(Str: PWideChar);
// exchanges in each character of the given string the low order and high order
// byte to go from LSB to MSB and vice versa.
// EAX contains address of string

asm
         PUSH ESI
         PUSH EDI
         MOV ESI, EAX
         MOV EDI, ESI
         XOR EAX, EAX  // clear high order byte to be able to use 32bit operand below
@@1:     LODSW
         OR EAX, EAX
         JZ @@2
         XCHG AL, AH
         STOSW
         JMP @@1
         
@@2:     POP EDI
         POP ESI
end;

//----------------------------------------------------------------------------------------------------------------------


function GetCvt (S: WideString; const Table: TConvTable): WideString;
 var i,j,m: integer;
     A,B: WideString;
begin
    i:=1;
    if (Table.InTbl.Count>0) then
    while i<=length(S) do
    begin
        m:=0;
        Table.InTbl.Find(S[i],j);
        while (j<Table.InTbl.Count) and (Table.InTbl.Get(j)[1]=S[i]) do
        begin
            A:=Table.InTbl.Get(j);
            if (Copy(S,i,length(A))=A) and (length(A)>m) then
            begin   
                m:=length(A);
                B:=Table.InTbl.GetObject(j);
            end;
            Inc(j);
        end;
        if m>0 then
        begin
            Delete(S,i,m);
            Insert(B,S,i);
            Inc(i,length(B)-1);
        end;
        Inc(i);
    end; {if, while}
    result:=S;
end; {GetCvt}

function PutCvt (S: WideString; const Table: TConvTable): WideString;
 var i,j,m: integer;
     A,B: WideString;
begin
    i:=1;
    while i<=length(S) do
    begin
        m:=0;
        Table.OutTbl.Find(S[i],j);
        while (j<Table.OutTbl.Count) and (Table.OutTbl.Get(j)[1]=S[i]) do
        begin
            A:=Table.OutTbl.Get(j);
            if (Copy(S,i,length(A))=A) and (length(A)>m) then
            begin
                m:=length(A);
                B:=Table.OutTbl.GetObject(j);
            end;
            Inc(j);
        end;
        if m>0 then
        begin
            Delete(S,i,m);
            Insert(B,S,i);
            Inc(i,length(B)-1);
        end;
         Inc(i);
    end;
    result:=S;
end; {PutCvt}

function GetCvtU (S: WideString; const Table: TConvTable): WideString;
begin
    if AnsiUpperCase(Table.Charset)=UTF8 then
        result:=FromUTF8(S)
    else
        result:=GetCvt(S,Table);
end;

function PutCvtU (S: WideString; const Table: TConvTable): WideString;
begin
    result:=PutCvt(S,Table);
    if AnsiUpperCase(Table.Charset)=UTF8 then
        result:=ToUTF8(result);
    if result='' then;
end; {PutCvtU}

function UtoXC (const S: WideString; const Table: TConvTable): WideString;
 label ok;
 var i,j: integer;
     A,B: WideString;
begin
    result:='';
    i:=1;
    while i<=length(S) do
    begin
        Table.OutTbl.Find(S[i],j);
        while (j<Table.OutTbl.Count) and (Table.OutTbl.Get(j)[1]=S[i]) do
        begin
            A:=Table.OutTbl.Get(j);
            if Copy(S,i,length(A))=A then
            begin
                B:=Table.OutTbl.GetObject(j);
                result:=result+B;
                Inc(i,length(A)-1);
                goto ok;
            end;
            Inc(j);
        end;
        if S[i]<#128 then
            result:=result+S[i]
        else
            result:=result+Format('&#%d;',[ord(S[i])]);
ok:     Inc(i);
    end;
end; {UtoXC}

procedure ParseSetup (S: WideString; var Left,Right: WideString);
 var n: Integer;
begin
    Left:=''; Right:='';
    if S='' then exit;
    if Pos(';',S)=1 then exit;
    while (S<>'') and (S[length(S)]=' ') do
        Delete(S,length(S),1);
    if S='' then exit;
    n:=Pos('=',S);
    if n=0 then
        n:=Pos(' ',S);
    if n=0 then exit;
    Left:=Copy(S,1,n-1);
    while (Left<>'') and (Left[length(Left)]=' ') do
        Delete(Left,length(Left),1);
    Right:=Copy(S,n+1,length(S));
    while (Right<>'') and (Right[1]=' ') do
        Delete(Right,1,1);
end; {ParseSetup}

{Convert &#xxx; to Unicode}
function XtoU (const S: WideString): WideString;
 var W: WChar;
     i,j,n,code: Integer;
begin
  SetLength(result,length(S));
  i:=1; j:=1;
  while i<=length(S) do
  begin
        W:=WChar(S[i]);
        if Copy(S,i,2)='&#' then
        begin
            val(Copy(S,i+2,10),n,code);
            i:=i+code;
            if S[i+2]=';' then Inc(i);
            Inc(i);
            W:=WChar(n);
        end;
        result[j]:=W;
        Inc(j);
        Inc(i);
  end;
  SetLength(result,j-1);
end; {XtoU}

function UntoX (const S: WideString; MaxOrd: Integer): WideString;
 var i,j,n: Integer;
     SS: WideString;
     c: WideChar;
begin
    n:=length(S);
    SetLength(result,n);
    j:=1;
    for i:=1 to length(S) do
    begin
        c:=S[i];
        if ord(c)<MaxOrd then
        begin
            result[j]:=c;
            Inc(j);
        end
        else begin
            SS:='&#'+intToStr(ord(c))+';';
            Inc(n,length(SS));
            SetLength(result,j-1);
            Inc(j,length(SS));
            result:=result+SS;
            SetLength(result,n);
        end;
    end;
    SetLength(result,j-1);
end; {UntoX}

function UtoX (const S: WideString): WideString;
begin
 Result := UnToX(S, 128);
end; {UtoX}

function myReadChar (var F: TextFile): Char;
begin
    with TTextRec(F) do
    begin
        if UserData[1]<>0 then
        begin
            result:=char(UserData[1]);
            UserData[1]:=0;
        end
        else if BufPos<BufEnd then
        begin
            result:=BufPtr[BufPos];
            Inc(BufPos);
        end
        else begin
            BufPos:=0;
            ReadBuf(F);
            result:=BufPtr[BufPos];
            Inc(BufPos);
        end;
    end;
end; {myReadChar}

function myReadLn (var F: TextFile; var S: String; Max: Integer=8192): Boolean;
 var c: Char;
     n: Integer;
begin
    S:=''; n:=0;
    result:=False;
    with TTextRec(F) do
    while not myEof(F) do
    begin
        c:=myReadChar(F);
        if c=^J then
        begin
            if CurLineSeparator=NoLS then
                CurLineSeparator:=LF;
            result:=True;
            break;
        end;
        if c=^M then
        begin
            result:=True;
            if myEof(F) then
            begin
                if CurLineSeparator=NoLS then
                    CurLineSeparator:=CR;
                break;
            end;
            UserData[1]:=byte(myReadChar(F));
            if char(UserData[1])=^J then
            begin
                if CurLineSeparator=NoLS then
                    CurLineSeparator:=CRLF;
                UserData[1]:=0;
            end
            else
                if CurLineSeparator=NoLS then
                    CurLineSeparator:=CR;
            break;
        end;
        Inc(n);
        if n>length(S) then
            SetLength(S,n+BufStep);
        S[n]:=c;    //S:=S+c;
        if n>Max then
        begin
            result:=True;
            break;
        end;
    end;
    SetLength(S,n);
    if (S<>'') and (S[length(S)]=^M) then Delete(S,length(S),1);
end; {myReadLn}

function myEof (var F: TextFile): Boolean;
begin
    with TTextRec(F) do
    begin
        if (UserData[2]=0) and (BufPos>=BufEnd) then
            ReadBuf(F);
        result:=(UserData[2]<>0) and (UserData[1]=0);
    end;
end; {myEof}

procedure myClose (var F: TextFile);
begin
    with TTextRec(F) do
    begin
        //Mode:=Mode and not $F00;
        UserData[2]:=0;
        UserData[1]:=0;
    end;
    CloseFile(F);
end; {myClose}

procedure myReset (var F: TextFile);
begin
    with TTextRec(F) do
    begin
        //Mode:=Mode and not $F00;
        UserData[2]:=0;
        UserData[1]:=0;
    end;
    Reset(F);
end; {myReset}

{Convert tabs to spaces}
function ExpandTabs (const S: WideString): WideString;
 var i,j,n: Integer;
begin
    if Pos(#9,S)=0 then
    begin
        result:=S;
        exit;
    end;
    result:='';
    SetLength(result,length(S));
    n:=1;
    for i:=1 to length(S) do
    begin
        if n>length(result) then
            SetLength(result,n);
        if ord(S[i])<>9 then
        begin
            result[n]:=S[i];
            Inc(n);
        end
        else begin
            for j:=1 to 4- ((n-1) mod 4) do
            begin
                if n>length(result) then
                    SetLength(result,n);
                result[n]:=' ';
                inc(n);
            end;
        end; {if}
    end; {for i}
end; {ExpandTabs}

//Convert a Internet message Charset to TFontCharset
function GetTFontCharset(Charset: String): TFontCharset;
begin
  Result := DEFAULT_CHARSET;
  if AnsiCompareText(Charset, 'koi8-r') = 0 then Result := RUSSIAN_CHARSET;
  if AnsiCompareText(Charset, 'iso-ir-111') = 0 then Result := RUSSIAN_CHARSET;
  if AnsiCompareText(Charset, 'macroman') = 0 then Result := MAC_CHARSET;
  if AnsiCompareText(Charset, 'iso-8859-1') = 0 then Result := ANSI_CHARSET;
  if AnsiCompareText(Charset, 'iso-8859-2') = 0 then Result := EASTEUROPE_CharSet;
  if AnsiCompareText(Charset, 'iso-8859-3') = 0 then Result := TURKISH_CharSet;
  if AnsiCompareText(Charset, 'iso-8859-4') = 0 then Result := Baltic_CharSet;
  if AnsiCompareText(Charset, 'iso-8859-5') = 0 then Result := RUSSIAN_CharSet;
  if AnsiCompareText(Charset, 'iso-8859-6') = 0 then Result := ARABIC_CharSet;
  if AnsiCompareText(Charset, 'iso-8859-7') = 0 then Result := GREEK_CHARSET;
  if AnsiCompareText(Charset, 'iso-8859-8') = 0 then Result := HEBREW_CharSet;
  if AnsiCompareText(Charset, 'iso-8859-9') = 0 then Result := TURKISH_CharSet;
  if AnsiCompareText(Charset, 'iso-8859-10') = 0 then Result := Baltic_CharSet;
  if AnsiCompareText(Charset, 'iso-8859-13') = 0 then Result := Baltic_CharSet;
end;

//Convert a Internet message Charset to CodePage
function GetICodePage(Charset: String): Integer;
begin
  Result := GetAcp();
  if AnsiCompareText(Charset, 'koi8-r') = 0 then Result := 1251;
  if AnsiCompareText(Charset, 'iso-ir-111') = 0 then Result := 1251;
  if AnsiCompareText(Charset, 'UTF-8') = 0 then Result := 1200;
  if AnsiCompareText(Charset, 'macroman') = 0 then Result := CP_MACCP;
  if AnsiCompareText(Charset, 'iso-8859-1') = 0 then Result := 1252;
  if AnsiCompareText(Charset, 'iso-8859-2') = 0 then Result := 1250;
  if AnsiCompareText(Charset, 'iso-8859-3') = 0 then Result := 1254;
  if AnsiCompareText(Charset, 'iso-8859-4') = 0 then Result := 1257;
  if AnsiCompareText(Charset, 'iso-8859-5') = 0 then Result := 1251;
  if AnsiCompareText(Charset, 'iso-8859-6') = 0 then Result := 1256;
  if AnsiCompareText(Charset, 'iso-8859-7') = 0 then Result := 1253;
  if AnsiCompareText(Charset, 'iso-8859-8') = 0 then Result := 1255;
  if AnsiCompareText(Charset, 'iso-8859-9') = 0 then Result := 1254;
  if AnsiCompareText(Charset, 'iso-8859-10') = 0 then Result := 1257;
  if AnsiCompareText(Charset, 'iso-8859-13') = 0 then Result := 1257;
end;

end.