tntsystem.pas

TNTUniCtrlsWithExceptions UniCode 国际化语言

        { base64 set, or }
        { 3) The directly encoded character is SHIFT_OUT. }
        { }
        if verbose or ((not done) and ((invbase64[r] >= 0) or (r =
          Integer('-')))) then
        begin
          if (target >= targetEnd) then
          begin
            Result := 2;
            Break;
          end { If };
          Target^ := '-';
          Inc(Target);
        end { If };
        shifted := False;
      end { If };
      { The character can be directly encoded as ASCII. }
    end { If };
    if (not needshift) and (not done) then
    begin
      if (target >= targetEnd) then
      begin
        Result := 2;
        break;
      end { If };
      Target^ := AnsiChar(r);
      Inc(Target);
    end { If };
  until (done);
  sourceStart := source;
  targetStart := target;
end; { ConvertUCS2toUTF7 }

function ConvertUTF7toUCS2(var sourceStart: PAnsiChar; sourceEnd: PAnsiChar;
  var targetStart: PWideChar; targetEnd: PWideChar): Integer;
var
  target: PWideChar { Register };
  source: PAnsiChar { Register };
  BITbuffer: Cardinal { & "Address Of" Used };
  bufferbits: Integer { & "Address Of" Used };
  shifted: Boolean { Used In Boolean Context };
  first: Boolean { Used In Boolean Context };
  wroteone: Boolean;
  base64EOF: Boolean;
  base64value: Integer;
  done: Boolean;
  c: UCS2;
  prevc: UCS2;
  junk: UCS2 { Used In Boolean Context };
begin
  Initialize_UTF7_Data;
  Result := 0;
  BITbuffer := 0;
  bufferbits := 0;
  shifted := False;
  first := False;
  wroteone := False;
  source := sourceStart;
  target := targetStart;
  c := 0;
  if needtables then
    tabinit;
  repeat
    { read an ASCII character c }
    done := Source >= SourceEnd;
    if (not done) then
    begin
      c := Word(Source^);
      Inc(Source);
    end { If };
    if shifted then
    begin
      { We're done with a base64 string if we hit EOF, it's not a valid }
      { ASCII character, or it's not in the base64 set. }
      { }
      base64value := invbase64[c];
      base64EOF := (done or (c > $7F)) or (base64value < 0);
      if base64EOF then
      begin
        shifted := False;
        { If the character causing us to drop out was SHIFT_IN or }
        { SHIFT_OUT, it may be a special escape for SHIFT_IN. The }
        { test for SHIFT_IN is not necessary, but allows an alternate }
        { form of UTF-7 where SHIFT_IN is escaped by SHIFT_IN. This }
        { only works for some values of SHIFT_IN. }
        { }
        if ((not done) and ((c = Integer('+')) or (c = Integer('-')))) then
        begin
          { get another character c }
          prevc := c;
          Done := Source >= SourceEnd;
          if (not Done) then
          begin
            c := Word(Source^);
            Inc(Source);
            { If no base64 characters were encountered, and the }
            { character terminating the shift sequence was }
            { SHIFT_OUT, then it's a special escape for SHIFT_IN. }
            { }
          end;
          if first and (prevc = Integer('-')) then
          begin
            { write SHIFT_IN unicode }
            if (target >= targetEnd) then
            begin
              Result := 2;
              break;
            end { If };
            Target^ := WideChar('+');
            Inc(Target);
          end
          else
          begin
            if (not wroteone) then
            begin
              Result := 1;
            end { If };
          end { Else };
          ;
        end { If }
        else
        begin
          if (not wroteone) then
          begin
            Result := 1;
          end { If };
        end { Else };
      end { If }
      else
      begin
        { Add another 6 bits of base64 to the bit buffer. }
        WRITE_N_BITS(base64value, 6, BITbuffer,
          bufferbits);
        first := False;
      end { Else };
      { Extract as many full 16 bit characters as possible from the }
      { bit buffer. }
      { }
      while (bufferbits >= 16) and (target < targetEnd) do
      begin
        { write a unicode }
        Target^ := WideChar(READ_N_BITS(16, BITbuffer, bufferbits));
        Inc(Target);
        wroteone := True;
      end { While };
      if (bufferbits >= 16) then
      begin
        if (target >= targetEnd) then
        begin
          Result := 2;
          Break;
        end;
      end { If };
      if (base64EOF) then
      begin
        junk := READ_N_BITS(bufferbits, BITbuffer, bufferbits);
        if (junk <> 0) then
        begin
          Result := 1;
        end { If };
      end { If };
    end { If };
    if (not shifted) and (not done) then
    begin
      if (c = Integer('+')) then
      begin
        shifted := True;
        first := True;
        wroteone := False;
      end { If }
      else
      begin
        { It must be a directly encoded character. }
        if (c > $7F) then
        begin
          Result := 1;
        end { If };
        if (target >= targetEnd) then
        begin
          Result := 2;
          break;
        end { If };
        Target^ := WideChar(c);
        Inc(Target);
      end { Else };
    end { If };
  until (done);
  sourceStart := source;
  targetStart := target;
end; { ConvertUTF7toUCS2 }

  {*****************************************************************************}
  { Thanks to Francisco Leong for providing the Pascal conversion of            }
  {   ConvertUTF7.c (by David B. Goldsmith)                                     }
  {*****************************************************************************}

resourcestring
  SBufferOverflow = 'Buffer overflow';
  SInvalidUTF7 = 'Invalid UTF7';

function WideStringToUTF7(const W: WideString): AnsiString;
var
  SourceStart, SourceEnd: PWideChar;
  TargetStart, TargetEnd: PAnsiChar;
begin
  if W = '' then
    Result := ''
  else
  begin
    SetLength(Result, Length(W) * 7); // Assume worst case
    SourceStart := PWideChar(@W[1]);
    SourceEnd := PWideChar(@W[Length(W)]) + 1;
    TargetStart := PAnsiChar(@Result[1]);
    TargetEnd := PAnsiChar(@Result[Length(Result)]) + 1;
    if ConvertUCS2toUTF7(SourceStart, SourceEnd, TargetStart,
      TargetEnd, True, False) <> 0
    then
      raise ETntInternalError.Create(SBufferOverflow);
    SetLength(Result, TargetStart - PAnsiChar(@Result[1]));
  end;
end;

function UTF7ToWideString(const S: AnsiString): WideString;
var
  SourceStart, SourceEnd: PAnsiChar;
  TargetStart, TargetEnd: PWideChar;
begin
  if (S = '') then
    Result := ''
  else
  begin
    SetLength(Result, Length(S)); // Assume Worst case
    SourceStart := PAnsiChar(@S[1]);
    SourceEnd := PAnsiChar(@S[Length(S)]) + 1;
    TargetStart := PWideChar(@Result[1]);
    TargetEnd := PWideChar(@Result[Length(Result)]) + 1;
    case ConvertUTF7toUCS2(SourceStart, SourceEnd, TargetStart,
      TargetEnd) of
      1: raise ETntGeneralError.Create(SInvalidUTF7);
      2: raise ETntInternalError.Create(SBufferOverflow);
    end;
    SetLength(Result, TargetStart - PWideChar(@Result[1]));
  end;
end;

function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString;
var
  InputLength,
  OutputLength: Integer;
begin
  if CodePage = CP_UTF7 then
    Result := UTF7ToWideString(S) // CP_UTF7 not supported on Windows 95
  else if CodePage = CP_UTF8 then
    Result := UTF8ToWideString(S) // CP_UTF8 not supported on Windows 95
  else begin
    InputLength := Length(S);
    OutputLength := MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, nil, 0);
    SetLength(Result, OutputLength);
    MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, PWideChar(Result), OutputLength);
  end;
end;

function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString;
var
  InputLength,
  OutputLength: Integer;
begin
  if CodePage = CP_UTF7 then
    Result := WideStringToUTF7(WS) // CP_UTF7 not supported on Windows 95
  else if CodePage = CP_UTF8 then
    Result := WideStringToUTF8(WS) // CP_UTF8 not supported on Windows 95
  else begin
    InputLength := Length(WS);
    OutputLength := WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, nil, 0, nil, nil);
    SetLength(Result, OutputLength);
    WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, PAnsiChar(Result), OutputLength, nil, nil);
  end;
end;

function UCS2ToWideString(const Value: AnsiString): WideString;
begin
  if Length(Value) = 0 then
    Result := ''
  else
    SetString(Result, PWideChar(@Value[1]), Length(Value) div SizeOf(WideChar))
end;

function WideStringToUCS2(const Value: WideString): AnsiString;
begin
  if Length(Value) = 0 then
    Result := ''
  else
    SetString(Result, PAnsiChar(@Value[1]), Length(Value) * SizeOf(WideChar))
end;

{ Windows.pas doesn't declare TranslateCharsetInfo() correctly. }
function TranslateCharsetInfo(lpSrc: PDWORD; var lpCs: TCharsetInfo; dwFlags: DWORD): BOOL; stdcall; external gdi32 name 'TranslateCharsetInfo';

function CharSetToCodePage(ciCharset: UINT): Cardinal;
var
  C: TCharsetInfo;
begin
  Win32Check(TranslateCharsetInfo(PDWORD(ciCharset), C, TCI_SRCCHARSET));
  Result := C.ciACP
end;

function LCIDToCodePage(ALcid: LCID): Cardinal;
var
  Buf: array[0..6] of AnsiChar;
begin
  GetLocaleInfo(ALcid, LOCALE_IDefaultAnsiCodePage, Buf, 6);
  Result := StrToIntDef(Buf, GetACP);
end;

function KeyboardCodePage: Cardinal;
begin
  Result := LCIDToCodePage(GetKeyboardLayout(0) and $FFFF);
end;

function KeyUnicode(CharCode: Word): WideChar;
var
  AChar: AnsiChar;
begin
  // converts the given character (as it comes with a WM_CHAR message) into its
  // corresponding Unicode character depending on the active keyboard layout
  if CharCode <= Word(High(AnsiChar)) then begin
    AChar := AnsiChar(CharCode);
    MultiByteToWideChar(KeyboardCodePage, MB_USEGLYPHCHARS, @AChar, 1, @Result, 1);
  end else
    Result := WideChar(CharCode);
end;

procedure StrSwapByteOrder(Str: PWideChar);
var
  P: PWord;
begin
  P := PWord(Str);
  While (P^ <> 0) do begin
    P^ := MakeWord(HiByte(P^), LoByte(P^));
    Inc(P);
  end;
end;

//--------------------------------------------------------------------
//                LoadResString()
//
//  This system function is used to retrieve a resourcestring and
//   return the result as an AnsiString.  If we believe that the result
//    is only a temporary value, and that it will be immediately
//     assigned to a WideString or a Variant, then we will save the
//      Unicode result as well as a reference to the original Ansi string.
//       WStrFromPCharLen() or VarFromLStr() will return this saved
//        Unicode string if it appears to receive the most recent result
//         of LoadResString.
//--------------------------------------------------------------------


  //===========================================================================================
  //
  //    function CodeMatchesPatternForUnicode(...);
  //
  //    GIVEN:  SomeWideString := SSomeResString;  { WideString := resourcestring }
  //
  //    Delphi will compile this statement into the following:
  //    -------------------------------------------------
  //    TempAnsiString := LoadResString(@SSomeResString);
  //      LINE 1:  lea edx,[SomeTempAnsiString]
  //      LINE 2:  mov eax,[@SomeResString]
  //      LINE 3:  call LoadResString
  //
  //    WStrFromLStr(SomeWideString, TempAnsiString);  { SomeWideString := TempAnsiString }
  //      LINE 4:  mov edx,[SomeTempAnsiString]
  //      LINE 5:  mov/lea eax [@SomeWideString]
  //      LINE 6:  call @WStrFromLStr
  //    -------------------------------------------------
  //
  //    The order in which the parameters are prepared for WStrFromLStr (ie LINE 4 & 5) is
  //      reversed when assigning a non-temporary AnsiString to a WideString.
  //
  //    This code, for example, results in LINE 4 and LINE 5 being swapped.
  //
  //      SomeAnsiString := SSomeResString;
  //      SomeWideString := SomeAnsiString;
  //
  //    Since we know the "signature" used by the compiler, we can detect this pattern.
  //     If we believe it is only temporary, we can save the Unicode results for later
  //      retrieval from WStrFromLStr.
  //
  //    One final note:  When assigning a resourcestring to a Variant, the same patterns exist.
  //===========================================================================================

function CodeMatchesPatternForUnicode(PLine4: PAnsiChar): Boolean;
const
  SIZEOF_OPCODE = 1 {byte};
  MOV_16_OPCODE = AnsiChar($8B); { we'll assume operand size is 16 bits }
  MOV_32_OPCODE = AnsiChar($B8); { we'll assume operand size is 32 bits }
  LEA_OPCODE    = AnsiChar($8D); { operand size can be 16 or 40 bits }
  CALL_OPCODE   = AnsiChar($E8); { assumed operand size is 32 bits }
  BREAK_OPCODE  = AnsiChar($CC); {in a breakpoint}
var
  PLine1: PAnsiChar;
  PLine2: PAnsiChar;
  PLine3: PAnsiChar;
  DataSize: Integer; // bytes in first LEA operand
begin
  Result := False;

  PLine3 := PLine4 - SizeOf(CALL_OPCODE) - 4;
  PLine2 := PLine3 - SizeOf(MOV_32_OPCODE) - 4;

  // figure PLine1 and operand size
  DataSize := 2; { try 16 bit operand for line 1 }
  PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE);
  if (PLine1^ <> LEA_OPCODE) and (not (IsDebugging and (PLine1^ = BREAK_OPCODE))) then
  begin
    DataSize := 5; { try 40 bit operand for line 1 }
    PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE);
  end;
  if (PLine1^ = LEA_OPCODE) or (IsDebugging and (PLine1^ = BREAK_OPCODE)) then
  begin
    if CompareMem(PLine1 + SIZEOF_OPCODE, PLine4 + SIZEOF_OPCODE, DataSize) then
    begin
      // After this check, it seems to match the WideString <- (temp) AnsiString pattern
      Result := True; // It is probably OK. (The side effects of being wrong aren't very bad.)
    end;
  end;
end;

threadvar
  PLastResString: PAnsiChar;
  LastResStringValue: AnsiString;
  LastWideResString: WideString;

procedure FreeTntSystemThreadVars;
begin
  LastResStringValue := '';
  LastWideResString := '';
end;

procedure Custom_System_EndThread(ExitCode: Integer);
begin
  FreeTntSystemThreadVars;
  {$IFDEF COMPILER_10_UP}
  if Assigned(SystemThreadEndProc) then
    SystemThreadEndProc(ExitCode);
  {$ENDIF}
  ExitThread(ExitCode);
end;

function Custom_System_LoadResString(ResStringRec: PResStringRec): AnsiString;
var
  ReturnAddr: Pointer;
begin
  // get return address
  asm
    PUSH   ECX
    MOV    ECX, [EBP + 4]
    MOV    ReturnAddr, ECX
    POP    ECX
  end;
  // check calling code pattern
  if CodeMatchesPatternForUnicode(ReturnAddr) then begin
    // result will probably be assigned to an intermediate AnsiString
    //   on its way to either a WideString or Variant.
    LastWideResString := WideLoadResString(ResStringRec);
    Result := LastWideResString;