adtrmmap.pas

测试用例

(***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower Async Professional
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1991-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{*                   ADTRMMAP.PAS 4.06                   *}
{*********************************************************}
{* Terminal: keyboard and character set mapping classes  *}
{*********************************************************}

unit ADTrmMap;

interface

{ Notes: this hash table class has been designed for one narrow
         purpose: storing pairs of strings, the first string being the
         'key' and the second being the 'value' of that key. The
         strings are of type TAdKeyString (a 63 char string). The
         strings define keyboard mappings, either the name of a key
         on the DEC VT100 keyboard and its associated escape sequence,
         or a (shifted) virtual key code and its associated key name.

         Consequently there is no method to delete key/value pairs: it
         has been assumed that entries will be added en bloc, either
         from a resource or a specially formatted text file.

         To aid in the generation of a resource, the class has a
         special method for writing a binary file for inclusion in an
         RC file and subsequent compilation. The RC file should
         contain at least the following line for this to work:

           <ResourceName> RCDATA <BinaryFileName>

         where ResourceName is the unique name you want to call the
         resource, and BinaryFileName is the name of the binary file
         containing the 'compiled keyboard mapping created by the
         StoreToBinFile method. For example, if an RC file had the
         following line:

           APRO_VT100KeyMap RCDATA C:\APRO\VT100.MAP

         it will compile to a RES file with BRCC or BRCC32, and
         contain a single resource called APRO_VT100KeyMap, and the
         C:\APRO\VT100.MAP will be used in that compilation.
}

{$I AWDEFINE.INC}

{$IFOPT D+}
{$DEFINE CompileDebugCode}
{$ENDIF}

{$IFDEF Win32}
{$R ADTRMVT1.R32}
{$R ADCHSVT1.R32}
{$ELSE}
{$R ADTRMVT1.R16}
{$R ADCHSVT1.R16}
{$ENDIF}

uses
  SysUtils,
  {$IFDEF Win32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  Classes,
  OOMisc;

type
  PadKeyString = ^TAdKeyString;
  TAdKeyString = string[63];
  
const
  DefaultFontName : string[9] = '<Default>';

type
  TAdKeyboardMapping = class
    private
      FTable : TList;
      FCount : integer;
    protected
      function kbmFindPrim(const aKey  : TAdKeyString;
                             var aInx  : integer;
                             var aNode : pointer) : boolean;
    public
      constructor Create;
      destructor Destroy; override;

      function Add(const aKey   : TAdKeyString;
                   const aValue : TAdKeyString) : boolean;
      procedure Clear;
      function Get(const aKey : TAdKeyString) : TAdKeyString;

      procedure LoadFromFile(const aFileName : string);
      procedure LoadFromRes(aInstance : THandle;
                      const aResName  : string);
      procedure StoreToBinFile(const aFileName : string);

      {$IFDEF CompileDebugCode}
      procedure DebugPrint(const aFileName : string);
      {$ENDIF}

      property Count : integer read FCount;
  end;

type
  TAdCharSetMapping = class
    private
      FTable     : TList;
      FCharQueue : pointer;
      FCount     : integer;
      FScript    : pointer;
      FScriptEnd : pointer;
      FScriptFreeList : pointer;
    protected
      procedure csmAddScriptNode(aFont : PadKeyString);
      function csmFindPrim(const aCharSet : TAdKeyString;
                                 aChar    : AnsiChar;
                             var aInx     : integer;
                             var aNode    : pointer) : boolean;
      procedure csmFreeScript;

    public
      constructor Create;
      destructor Destroy; override;

      function Add(const aCharSet : TAdKeyString;
                         aFromCh  : AnsiChar;
                         aToCh    : AnsiChar;
                   const aFont    : TAdKeyString;
                         aGlyph   : AnsiChar) : boolean;
      procedure Clear;

      procedure GetFontNames(aList : TStrings);

      procedure GenerateDrawScript(const aCharSet : TAdKeyString;
                                         aText    : PAnsiChar);
      function GetNextDrawCommand(var aFont : TAdKeyString;
                                      aText : PAnsiChar) : boolean;

      procedure LoadFromFile(const aFileName : string);
      procedure LoadFromRes(aInstance : THandle;
                      const aResName  : string);
      procedure StoreToBinFile(const aFileName : string);

      {$IFDEF CompileDebugCode}
      procedure DebugPrint(const aFileName : string);
      {$ENDIF}

      property Count : integer read FCount;
  end;

implementation

const
  {The hash table sizes: these are prime numbers that suit these
   particular implementations}
  KBHashTableSize = 57;    {keyboard mapping hash table size}
  CSHashTableSize = 199;   {charset mapping hash table size}

  OurSignature : longint = $33544841;
    {Note: $33544841 = AHT3 = APRO Hash Table, version 3}


type
  PKBHashNode = ^TKBHashNode;   {hash table node for keyboard maps}
  TKBHashNode = packed record
    kbnNext  : PKBHashNode;
    kbnKey   : PadKeyString;
    kbnValue : PadKeyString;
  end;

type
  PCSHashNode = ^TCSHashNode;   {hash table node for charset maps}
  TCSHashNode = packed record
    csnNext    : PCSHashNode;
    csnCharSet : PadKeyString;
    csnFont    : PadKeyString;
    csnChar    : AnsiChar;
    csnGlyph   : AnsiChar;
  end;

  PScriptNode = ^TScriptNode;
  TScriptNode = packed record
    snNext : PScriptNode;
    snFont : PadKeyString;
    snText : PAnsiChar;
  end;


{===TCharQueue=======================================================}
const
  CharQueueDelta = 32;
type
  TCharQueue = class
    private
      FSize : longint;
      FLen  : longint;
      FText : PAnsiChar;
    protected
      function cqGetDupText : PAnsiChar;
    public
      constructor Create;
      destructor Destroy; override;

      procedure Add(aCh : AnsiChar);
      procedure Clear;

      property DupText : PAnsiChar read cqGetDupText;
  end;
{--------}
constructor TCharQueue.Create;
begin
  inherited Create;
  {allocate a starter character queue}
  GetMem(FText, CharQueueDelta);
  FSize := CharQueueDelta;
  FText[0] := #0;
end;
{--------}
destructor TCharQueue.Destroy;
begin
  if (FText <> nil) then
    FreeMem(FText, FSize);
  inherited Destroy;
end;
{--------}
procedure TCharQueue.Add(aCh : AnsiChar);
var
  NewQ : PAnsiChar;
begin
  if (FLen = FSize-1) then begin
    GetMem(NewQ, FSize + CharQueueDelta);
    StrCopy(NewQ, FText);
    FreeMem(FText, FSize);
    inc(FSize, CharQueueDelta);
    FText := NewQ;
  end;
  FText[FLen] := aCh;
  inc(FLen);
  FText[FLen] := #0;
end;
{--------}
procedure TCharQueue.Clear;
begin
  FLen := 0;
  FText[0] := #0;
end;
{--------}
function TCharQueue.cqGetDupText : PAnsiChar;
begin
  GetMem(Result, FLen+1);
  StrCopy(Result, FText);
end;
{====================================================================}

{===Helper routines==================================================}
{Note: The ELF hash functions are described in "Practical Algorithms
       For Programmers" by Andrew Binstock and John Rex, Addison
       Wesley, with modifications in Dr Dobbs Journal, April 1996.
       They're modified to suit this implementation.}
function HashELF(const S : TAdKeyString) : longint;
var
  G : longint;
  i : integer;
begin
  Result := 0;
  for i := 1 to length(S) do begin
    Result := (Result shl 4) + ord(S[i]);
    G := Result and longint($F0000000);
    if (G <> 0) then
      Result := Result xor (G shr 24);
    Result := Result and (not G);
  end;
end;
{--------}
function HashELFPlusChar(const S : TAdKeyString;
                               C : AnsiChar) : longint;
var
  G : longint;
  i : integer;
begin
  Result := ord(C);
  G := Result and longint($F0000000);
  if (G <> 0) then
    Result := Result xor (G shr 24);
  Result := Result and (not G);
  for i := 1 to length(S) do begin
    Result := (Result shl 4) + ord(S[i]);
    G := Result and longint($F0000000);
    if (G <> 0) then
      Result := Result xor (G shr 24);
    Result := Result and (not G);
  end;
end;
{--------}
function AllocKeyString(const aSt : TAdKeyString) : PadKeyString;
begin
  GetMem(Result, succ(length(aSt)));
  Result^ := aSt;
end;
{--------}
procedure FreeKeyString(aKS : PadKeyString);
begin
  if (aKS <> nil) then
    FreeMem(aKS, succ(length(aKS^)));
end;
{--------}
function ProcessCharSetLine(const aLine : ShortString;
                              var aCharSet : TAdKeyString;
                              var aFromCh  : AnsiChar;
                              var aToCh    : AnsiChar;
                              var aFontName: TAdKeyString;
                              var aGlyph   : AnsiChar) : boolean;
var
  InWord    : boolean;
  CharInx   : integer;
  StartCh   : integer;
  QuoteMark : AnsiChar;
  WordStart : array [0..4] of integer;
  WordEnd   : array [0..4] of integer;
  WordCount : integer;
  WordLen   : integer;
  Chars     : array [0..4] of AnsiChar;
  i         : integer;
  AsciiCh   : integer;
  ec        : integer;
  TestSt    : string[3];
begin
  {assumption: the line has had trailing spaces stripped, the line is
   not the empty string, the line starts with a ' ' character

  {assume we'll fail to parse the line properly}
  Result := false;

  {extract out the 5 words; if there are not at least 5 words, exit}
  QuoteMark := ' '; {needed to fool the compiler}
  StartCh := 0;     {needed to fool the compiler}
  InWord := false;
  WordCount := 0;
  CharInx := 1;
  while CharInx <= length(aLine) do begin
    if InWord then begin
      if (QuoteMark = ' ') then begin
        if (aLine[CharInx] = ' ') then begin
          InWord := false;
          WordStart[WordCount] := StartCh;
          WordEnd[WordCount] := pred(CharInx);
          inc(WordCount);
          if (WordCount = 5) then
            Break;
        end
      end
      else {the quotemark is active} begin
        if (aLine[CharInx] = QuoteMark) then
          QuoteMark := ' ';
      end;
    end
    else {not in a word} begin
      if (aLine[CharInx] <> ' ') then begin
        InWord := true;
        StartCh := CharInx;
        QuoteMark := aLine[CharInx];
        if (QuoteMark <> '''') and (QuoteMark <> '"') then
          QuoteMark := ' ';
      end;
    end;
    inc(CharInx);
  end;
  {when we reach this point we know where the last word ended}
  if InWord then begin
    if (QuoteMark <> ' ') then
      Exit; {the last word had no close quote}
    WordStart[WordCount] := StartCh;
    WordEnd[WordCount] := pred(CharInx);
    inc(WordCount);
  end;
  if (WordCount <> 5) then
    Exit;
  {fix the quoted strings}
  for i := 0 to 4 do begin
    if (aLine[WordStart[i]] = '''') or
       (aLine[WordStart[i]] = '"') then begin
      inc(WordStart[i]);
      dec(WordEnd[i]);
      if (WordEnd[i] < WordStart[i]) then