tntsystem.pas

TNTUniCtrlsWithExceptions UniCode 国际化语言

{*****************************************************************************}
{                                                                             }
{    Tnt Delphi Unicode Controls                                              }
{      http://www.tntware.com/delphicontrols/unicode/                         }
{        Version: 2.3.0                                                       }
{                                                                             }
{    Copyright (c) 2002-2007, Troy Wolbrink ([e-mail])       }
{                                                                             }
{*****************************************************************************}

unit TntSystem;

{$INCLUDE TntCompilers.inc}

{*****************************************************************************}
{  Special thanks go to Francisco Leong for originating the design for        }
{    WideString-enabled resourcestrings.                                      }
{*****************************************************************************}

interface

uses
  Windows;

// These functions should not be used by Delphi code since conversions are implicit.
{TNT-WARN WideCharToString}
{TNT-WARN WideCharLenToString}
{TNT-WARN WideCharToStrVar}
{TNT-WARN WideCharLenToStrVar}
{TNT-WARN StringToWideChar}

// ................ ANSI TYPES ................
{TNT-WARN Char}
{TNT-WARN PChar}
{TNT-WARN String}

{TNT-WARN CP_ACP} // <-- use DefaultSystemCodePage
function DefaultSystemCodePage: Cardinal; // implicitly used when converting AnsiString <--> WideString.

var
  WideCustomLoadResString: function(ResStringRec: PResStringRec; var Value: WideString): Boolean;

{TNT-WARN LoadResString}
function WideLoadResString(ResStringRec: PResStringRec): WideString;
{TNT-WARN ParamCount}
function WideParamCount: Integer;
{TNT-WARN ParamStr}
function WideParamStr(Index: Integer): WideString;

// ......... introduced .........

const
  { Each Unicode stream should begin with the code U+FEFF,  }
  {   which the standard defines as the *byte order mark*.  }
  UNICODE_BOM = WideChar($FEFF);
  UNICODE_BOM_SWAPPED = WideChar($FFFE);
  UTF8_BOM = AnsiString(#$EF#$BB#$BF);

function WideStringToUTF8(const S: WideString): AnsiString;
function UTF8ToWideString(const S: AnsiString): WideString;

function WideStringToUTF7(const W: WideString): AnsiString;
function UTF7ToWideString(const S: AnsiString): WideString;

function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString;
function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString;

function UCS2ToWideString(const Value: AnsiString): WideString;
function WideStringToUCS2(const Value: WideString): AnsiString;

function CharSetToCodePage(ciCharset: UINT): Cardinal;
function LCIDToCodePage(ALcid: LCID): Cardinal;
function KeyboardCodePage: Cardinal;
function KeyUnicode(CharCode: Word): WideChar;

procedure StrSwapByteOrder(Str: PWideChar);

type
  TTntSystemUpdate =
    (tsWideResourceStrings,
     {$IFNDEF COMPILER_9_UP}tsFixImplicitCodePage, tsFixWideStrConcat, tsFixWideFormat, {$ENDIF}
     tsWideExceptions
    );
  TTntSystemUpdateSet = set of TTntSystemUpdate;

const
  AllTntSystemUpdates = [Low(TTntSystemUpdate)..High(TTntSystemUpdate)];

procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates);

implementation

uses
  SysUtils, Variants, Forms, TntWindows, TntSysUtils, TntForms;

var
  GDefaultSystemCodePage: Cardinal;

function DefaultSystemCodePage: Cardinal;
begin
  Result := GDefaultSystemCodePage;
end;

var
  IsDebugging: Boolean;

function WideLoadResString(ResStringRec: PResStringRec): WideString;
const
  MAX_RES_STRING_SIZE = 4097; { MSDN documents this as the maximum size of a string in table. }
var
  Buffer: array [0..MAX_RES_STRING_SIZE] of WideChar; { Buffer leaves room for null terminator. }
  PCustom: PAnsiChar;
begin
  if Assigned(WideCustomLoadResString) and WideCustomLoadResString(ResStringRec, Result) then
    exit; { a custom resourcestring has been loaded. }

  if ResStringRec = nil then
    Result := ''
  else if ResStringRec.Identifier < 64*1024 then
    SetString(Result, Buffer,
      Tnt_LoadStringW(FindResourceHInstance(ResStringRec.Module^),
        ResStringRec.Identifier, Buffer, MAX_RES_STRING_SIZE))
  else begin
    // custom string pointer
    PCustom := PAnsiChar(ResStringRec.Identifier); { I would like to use PWideChar, but this would break legacy code. }
    if  (StrLen{TNT-ALLOW StrLen}(PCustom) > Cardinal(Length(UTF8_BOM)))
    and CompareMem(PCustom, PAnsiChar(UTF8_BOM), Length(UTF8_BOM)) then
      // detected UTF8
      Result := UTF8ToWideString(PAnsiChar(PCustom + Length(UTF8_BOM)))
    else
      // normal
      Result := PCustom;
  end;
end;

function WideGetParamStr(P: PWideChar; var Param: WideString): PWideChar;
var
  i, Len: Integer;
  Start, S, Q: PWideChar;
begin
  while True do
  begin
    while (P[0] <> #0) and (P[0] <= ' ') do
      Inc(P);
    if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
  end;
  Len := 0;
  Start := P;
  while P[0] > ' ' do
  begin
    if P[0] = '"' then
    begin
      Inc(P);
      while (P[0] <> #0) and (P[0] <> '"') do
      begin
        Q := P + 1;
        Inc(Len, Q - P);
        P := Q;
      end;
      if P[0] <> #0 then
        Inc(P);
    end
    else
    begin
      Q := P + 1;
      Inc(Len, Q - P);
      P := Q;
    end;
  end;

  SetLength(Param, Len);

  P := Start;
  S := PWideChar(Param);
  i := 0;
  while P[0] > ' ' do
  begin
    if P[0] = '"' then
    begin
      Inc(P);
      while (P[0] <> #0) and (P[0] <> '"') do
      begin
        Q := P + 1;
        while P < Q do
        begin
          S[i] := P^;
          Inc(P);
          Inc(i);
        end;
      end;
      if P[0] <> #0 then Inc(P);
    end
    else
    begin
      Q := P + 1;
      while P < Q do
      begin
        S[i] := P^;
        Inc(P);
        Inc(i);
      end;
    end;
  end;

  Result := P;
end;

function WideParamCount: Integer;
var
  P: PWideChar;
  S: WideString;
begin
  P := WideGetParamStr(GetCommandLineW, S);
  Result := 0;
  while True do
  begin
    P := WideGetParamStr(P, S);
    if S = '' then Break;
    Inc(Result);
  end;
end;

function WideParamStr(Index: Integer): WideString;
var
  P: PWideChar;
begin
  if Index = 0 then
    Result := WideGetModuleFileName(0)
  else
  begin
    P := GetCommandLineW;
    while True do
    begin
      P := WideGetParamStr(P, Result);
      if (Index = 0) or (Result = '') then Break;
      Dec(Index);
    end;
  end;
end;

function WideStringToUTF8(const S: WideString): AnsiString;
begin
  Result := UTF8Encode(S);
end;

function UTF8ToWideString(const S: AnsiString): WideString;
begin
  Result := UTF8Decode(S);
end;

  { ======================================================================= }
  { Original File:   ConvertUTF7.c                                          }
  { Author: David B. Goldsmith                                              }
  { Copyright (C) 1994, 1996 Taligent, Inc. All rights reserved.            }
  {                                                                         }
  { This code is copyrighted. Under the copyright laws, this code may not   }
  { be copied, in whole or part, without prior written consent of Taligent. }
  {                                                                         }
  { Taligent grants the right to use this code as long as this ENTIRE       }
  { copyright notice is reproduced in the code.  The code is provided       }
  { AS-IS, AND TALIGENT DISCLAIMS ALL WARRANTIES, EITHER EXPRESS OR         }
  { IMPLIED, INCLUDING, BUT NOT LIMITED TO IMPLIED WARRANTIES OF            }
  { MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  IN NO EVENT      }
  { WILL TALIGENT BE LIABLE FOR ANY DAMAGES WHATSOEVER (INCLUDING,          }
  { WITHOUT LIMITATION, DAMAGES FOR LOSS OF BUSINESS PROFITS, BUSINESS      }
  { INTERRUPTION, LOSS OF BUSINESS INFORMATION, OR OTHER PECUNIARY          }
  { LOSS) ARISING OUT OF THE USE OR INABILITY TO USE THIS CODE, EVEN        }
  { IF TALIGENT HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.        }
  { BECAUSE SOME STATES DO NOT ALLOW THE EXCLUSION OR LIMITATION OF         }
  { LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES, THE ABOVE            }
  { LIMITATION MAY NOT APPLY TO YOU.                                        }
  {                                                                         }
  { RESTRICTED RIGHTS LEGEND: Use, duplication, or disclosure by the        }
  { government is subject to restrictions as set forth in subparagraph      }
  { (c)(l)(ii) of the Rights in Technical Data and Computer Software        }
  { clause at DFARS 252.227-7013 and FAR 52.227-19.                         }
  {                                                                         }
  { This code may be protected by one or more U.S. and International        }
  { Patents.                                                                }
  {                                                                         }
  { TRADEMARKS: Taligent and the Taligent Design Mark are registered        }
  { trademarks of Taligent, Inc.                                            }
  { ======================================================================= }

type UCS2 = Word;

const
  _base64: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  _direct: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789''(),-./:?';
  _optional: AnsiString = '!"#$%&*;<=>@[]^_`{|}';
  _spaces: AnsiString = #9#13#10#32;

var
  base64: PAnsiChar;
  invbase64: array[0..127] of SmallInt;
  direct: PAnsiChar;
  optional: PAnsiChar;
  spaces: PAnsiChar;
  mustshiftsafe: array[0..127] of AnsiChar;
  mustshiftopt: array[0..127] of AnsiChar;

var
  needtables: Boolean = True;

procedure Initialize_UTF7_Data;
begin
  base64 := PAnsiChar(_base64);
  direct := PAnsiChar(_direct);
  optional := PAnsiChar(_optional);
  spaces := PAnsiChar(_spaces);
end;

procedure tabinit;
var
  i: Integer;
  limit: Integer;
begin
  i := 0;
  while (i < 128) do
  begin
    mustshiftopt[i] := #1;
    mustshiftsafe[i] := #1;
    invbase64[i] := -1;
    Inc(i);
  end { For };
  limit := Length(_Direct);
  i := 0;
  while (i < limit) do
  begin
    mustshiftopt[Integer(direct[i])] := #0;
    mustshiftsafe[Integer(direct[i])] := #0;
    Inc(i);
  end { For };
  limit := Length(_Spaces);
  i := 0;
  while (i < limit) do
  begin
    mustshiftopt[Integer(spaces[i])] := #0;
    mustshiftsafe[Integer(spaces[i])] := #0;
    Inc(i);
  end { For };
  limit := Length(_Optional);
  i := 0;
  while (i < limit) do
  begin
    mustshiftopt[Integer(optional[i])] := #0;
    Inc(i);
  end { For };
  limit := Length(_Base64);
  i := 0;
  while (i < limit) do
  begin
    invbase64[Integer(base64[i])] := i;
    Inc(i);
  end { For };
  needtables := False;
end; { tabinit }

function WRITE_N_BITS(x: UCS2; n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): Integer;
begin
  BITbuffer := BITbuffer or (x and (not (-1 shl n))) shl (32 - n - bufferbits);
  bufferbits := bufferbits + n;
  Result := bufferbits;
end; { WRITE_N_BITS }

function READ_N_BITS(n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): UCS2;
var
  buffertemp: Cardinal;
begin
  buffertemp := BITbuffer shr (32 - n);
  BITbuffer := BITbuffer shl n;
  bufferbits := bufferbits - n;
  Result := UCS2(buffertemp);
end; { READ_N_BITS }

function ConvertUCS2toUTF7(var sourceStart: PWideChar; sourceEnd: PWideChar;
  var targetStart: PAnsiChar; targetEnd: PAnsiChar; optional: Boolean;
    verbose: Boolean): Integer;
var
  r: UCS2;
  target: PAnsiChar;
  source: PWideChar;
  BITbuffer: Cardinal;
  bufferbits: Integer;
  shifted: Boolean;
  needshift: Boolean;
  done: Boolean;
  mustshift: PAnsiChar;
begin
  Initialize_UTF7_Data;
  Result := 0;
  BITbuffer := 0;
  bufferbits := 0;
  shifted := False;
  source := sourceStart;
  target := targetStart;
  r := 0;
  if needtables then
    tabinit;
  if optional then
    mustshift := @mustshiftopt[0]
  else
    mustshift := @mustshiftsafe[0];
  repeat
    done := source >= sourceEnd;
    if not Done then
    begin
      r := Word(source^);
      Inc(Source);
    end { If };
    needshift := (not done) and ((r > $7F) or (mustshift[r] <> #0));
    if needshift and (not shifted) then
    begin
      if (Target >= TargetEnd) then
      begin
        Result := 2;
        break;
      end { If };
      target^ := '+';
      Inc(target);
      { Special case handling of the SHIFT_IN character }
      if (r = UCS2('+')) then
      begin
        if (target >= targetEnd) then
        begin
          Result := 2;
          break;
        end;
        target^ := '-';
        Inc(target);
      end
      else
        shifted := True;
    end { If };
    if shifted then
    begin
      { Either write the character to the bit buffer, or pad }
      { the bit buffer out to a full base64 character. }
      { }
      if needshift then
        WRITE_N_BITS(r, 16, BITbuffer, bufferbits)
      else
        WRITE_N_BITS(0, (6 - (bufferbits mod 6)) mod 6, BITbuffer,
          bufferbits);
      { Flush out as many full base64 characters as possible }
      { from the bit buffer. }
      { }
      while (target < targetEnd) and (bufferbits >= 6) do
      begin
        Target^ := base64[READ_N_BITS(6, BITbuffer, bufferbits)];
        Inc(Target);
      end { While };
      if (bufferbits >= 6) then
      begin
        if (target >= targetEnd) then
        begin
          Result := 2;
          break;
        end { If };
      end { If };
      if (not needshift) then
      begin
        { Write the explicit shift out character if }
        { 1) The caller has requested we always do it, or }
        { 2) The directly encoded character is in the }