mwpastortf.pas

script language

{+--------------------------------------------------------------------------+
 | Unit:   mwPasToRtf
 | Created:     09.97
 | Author:      Martin Waldenburg
 | Copyright    1997, all rights reserved.
 | Description: Pas to Rtf converter for syntax highlighting etc.
 | Version:     0.7 beta
 | Status:       FreeWare
 | DISCLAIMER:  This is provided as is, expressly without a warranty of any kind.
 |              You use it at your own risc.
 | Changes:     Matthias Ackermann
 +--------------------------------------------------------------------------+}

unit mwPasToRtf;


interface

uses
  Windows,
  SysUtils,
  Messages,
  Classes,
  Forms, 
  ComCtrls,
  Graphics,
  Dialogs,
  Inifiles;

type
  TTokenState = (tsAssembler, tsComment, tsCRLF, tsDirective, tsIdentifier,
                 tsKeyWord, tsNumber, tsSpace, tsString, tsSymbol, tsUnknown);

  TCommentState = (csAnsi, csBor, csNo, csSlashes);

type
  TPasConversion = class(TMemoryStream)
  private
    FDiffer: Boolean;
    FPreFixList, FPostFixList: array[tsAssembler..tsUnknown] of String;
    FComment: TCommentState;
    Prefix, TokenStr, Postfix: String;
    FBuffPos, TokenLen, FOutBuffSize, FStrBuffSize: Integer;
    FReadBuff, FOutBuff, FStrBuff, FStrBuffEnd, Run, RunStr, TokenPtr: PChar;
    FTokenState : TTokenState;
    FAssemblerFo: TFont;
    FCommentFo: TFont;
    FDirectiveFo: TFont;
    FIdentifierFo: TFont;
    FNumberFo: TFont;
    FKeyWordFo: TFont;
    FSpaceFo: TFont;
    FStringFo: TFont;
    FSymbolFo: TFont;
    FBgColor: TColor; // 11/11/98 HDN
    FontSize: String; // 11/13/98 HDN
    TokenColors: String; // 11/9/98 HDN
    function IsKeyWord(aToken: String):Boolean;
    function IsDirective(aToken: String):Boolean;
    function IsDiffKey(aToken: String):Boolean;
    procedure SetAssemblerFo(newValue: TFont);
    procedure SetCommentFo(newValue: TFont);
    procedure SetDirectiveFo(newValue: TFont);
    procedure SetIdentifierFo(newValue: TFont);
    procedure SetKeyWordFo(newValue: TFont);
    procedure SetNumberFo(newValue: TFont);
    procedure SetSpaceFo(newValue: TFont);
    procedure SetStringFo(newValue: TFont);
    procedure SetSymbolFo(newValue: TFont);
    procedure SetRTF;
    procedure WriteToBuffer(aString: String);
    procedure HandleAnsiC;
    procedure HandleBorC;
    procedure HandleCRLF;
    procedure HandleSlashesC;
    procedure HandleString;
    procedure ScanForRtf;
    procedure AllocStrBuff;
    procedure SetPreAndPosFix(aFont: TFont; aTokenState: TTokenState);
    procedure SetBgColor(aColor: TColor);// 11/11/98 HDN
  protected
  public
    constructor Create;
    destructor Destroy; override;
    procedure Init;
    procedure UseDelphiHighlighting(FileName: string);
    function ColorToRTF(aColor: TColor): String;
    function ConvertReadStream: Integer;
{    function ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer):Integer;}
    property AssemblerFo: TFont read FAssemblerFo write SetAssemblerFo;
    property CommentFo: TFont read FCommentFo write SetCommentFo;
    property DirectiveFo: TFont read FDirectiveFo write SetDirectiveFo;
    property IdentifierFo: TFont read FIdentifierFo write SetIdentifierFo;
    property KeyWordFo: TFont read FKeyWordFo write SetKeyWordFo;
    property NumberFo: TFont read FNumberFo write SetNumberFo;
    property SpaceFo: TFont read FSpaceFo write SetSpaceFo;
    property StringFo: TFont read FStringFo write SetStringFo;
    property SymbolFo: TFont read FSymbolFo write SetSymbolFo;
    property BgColor: TColor read FBgColor write SetBgColor;// 11/11/98 HDN
  published
  end;

const
  Keywords : array[0..100] of string =
            ('ABSOLUTE', 'ABSTRACT', 'AND', 'ARRAY', 'AS', 'ASM', 'ASSEMBLER',
             'AUTOMATED', 'BEGIN', 'CASE', 'CDECL', 'CLASS', 'CONST', 'CONSTRUCTOR',
             'DEFAULT', 'DESTRUCTOR', 'DISPID', 'DISPINTERFACE', 'DIV', 'DO',
             'DOWNTO', 'DYNAMIC', 'ELSE', 'END', 'EXCEPT', 'EXPORT', 'EXPORTS',
             'EXTERNAL', 'FAR', 'FILE', 'FINALIZATION', 'FINALLY', 'FOR', 'FORWARD',
             'FUNCTION', 'GOTO', 'IF', 'IMPLEMENTATION', 'IN', 'INDEX', 'INHERITED',
             'INITIALIZATION', 'INLINE', 'INTERFACE', 'IS', 'LABEL', 'LIBRARY',
             'MESSAGE', 'MOD', 'NAME', 'NEAR', 'NIL', 'NODEFAULT', 'NOT', 'OBJECT',
             'OF', 'OR', 'OUT', 'OVERRIDE', 'PACKED', 'PASCAL', 'PRIVATE', 'PROCEDURE',
             'PROGRAM', 'PROPERTY', 'PROTECTED', 'PUBLIC', 'PUBLISHED', 'RAISE',
             'READ', 'READONLY', 'RECORD', 'REGISTER', 'REINTRODUCE', 'REPEAT', 'RESIDENT',
             'RESOURCESTRING', 'SAFECALL', 'SET', 'SHL', 'SHR', 'STDCALL', 'STORED',
             'STRING', 'STRINGRESOURCE', 'THEN', 'THREADVAR', 'TO', 'TRY', 'TYPE',
             'UNIT', 'UNTIL', 'USES', 'VAR', 'VARIANT', 'VIRTUAL', 'WHILE', 'WITH', 'WRITE',
             'WRITEONLY', 'XOR');

  Directives : array[0..10] of string =
              ('AUTOMATED', 'INDEX', 'NAME', 'NODEFAULT', 'READ', 'READONLY',
               'RESIDENT', 'STORED', 'STRINGRECOURCE', 'WRITE', 'WRITEONLY');

  DiffKeys: array[0..6] of string =
           ('END', 'FUNCTION', 'PRIVATE', 'PROCEDURE', 'PRODECTED', 'PUBLIC', 'PUBLISHED');


implementation

destructor TPasConversion.Destroy;
begin
  FAssemblerFo.Free;
  FCommentFo.Free;
  FDirectiveFo.Free;
  FIdentifierFo.Free;
  FKeyWordFo.Free;
  FNumberFo.Free;
  FSpaceFo.Free;
  FStringFo.Free;
  FSymbolFo.Free;
  ReAllocMem(FStrBuff, 0);
  ReAllocMem(FOutBuff, 0);
  inherited Destroy;
end;  { Destroy }

constructor TPasConversion.Create;
begin
  inherited Create;
  FAssemblerFo := TFont.Create;
  FCommentFo := TFont.Create;
  FDirectiveFo := TFont.Create;
  FIdentifierFo := TFont.Create;
  FKeyWordFo := TFont.Create;
  FNumberFo := TFont.Create;
  FSpaceFo := TFont.Create;
  FStringFo := TFont.Create;
  FSymbolFo := TFont.Create;
  Prefix:='';
  PostFix:='';
  FStrBuffSize:= 0;
  AllocStrBuff;
  Init;
  FDiffer:= False;
end;  { Create }

procedure TPasConversion.AllocStrBuff;
begin
  FStrBuffSize:= FStrBuffSize + 1024;
  ReAllocMem(FStrBuff, FStrBuffSize);
  FStrBuffEnd:= FStrBuff + 1023;
end;  { AllocStrBuff }

procedure TPasConversion.SetAssemblerFo(newValue: TFont);
begin
  FAssemblerFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsAssembler);
end;  { SetAssemblerFo }

procedure TPasConversion.SetCommentFo(newValue: TFont);
begin
  FCommentFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsComment);
end;  { SetCommentFo }

procedure TPasConversion.SetDirectiveFo(newValue: TFont);
begin
  FDirectiveFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsDirective);
end;  { SetDirectiveFo }

procedure TPasConversion.SetIdentifierFo(newValue: TFont);
begin
  FIdentifierFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsIdentifier);
end;  { SetIdentifierFo }

procedure TPasConversion.SetKeyWordFo(newValue: TFont);
begin
  FKeyWordFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsKeyWord);
end;  { SetKeyWordFo }

procedure TPasConversion.SetNumberFo(newValue: TFont);
begin
  FNumberFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsNumber);
end;  { SetNumberFo }

procedure TPasConversion.SetSpaceFo(newValue: TFont);
begin
  FSpaceFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsSpace);
end;  { SetSpaceFo }

procedure TPasConversion.SetStringFo(newValue: TFont);
begin
  FStringFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsString);
end;  { SetStringFo }

procedure TPasConversion.SetSymbolFo(newValue: TFont);
begin
  FSymbolFo.Assign(newValue);
  SetPreAndPosFix(newValue, tsSymbol);
end;  { SetSymbolFo }

function TPasConversion.ColorToRTF(aColor: TColor): String;
begin
  aColor:=ColorToRGB(aColor);
  Result:='\red'+IntToStr(GetRValue(aColor))+
          '\green'+IntToStr(GetGValue(aColor))+
          '\blue'+IntToStr(GetBValue(aColor))+';';
end; { ColorToRTF }

procedure TPasConversion.UseDelphiHighlighting;
  {Delphi Editor settings are a comma delimited list of seven
   values as follows:

   0 - Foreground color
   1 - Background color
   2 - font style
   3 - Foreground Default
   4 - Background Default
   6 - Unknown
   7 - Unknown

   Currently this routine only handles setting the Bold, Italic, Underline}

  procedure SetDelphiRTF(S: String; aTokenState: TTokenState);
  var
    Ed_List: TStringList;
    Font: TFont;
  Begin
    Font:=TFont.Create;
    Ed_List:=TStringList.Create;
    Try
      Ed_List.CommaText:=S;
      if pos('B',Ed_List[2])>0 then
        Font.Style:=Font.Style+[fsBold];
      if pos('I',Ed_List[2])>0 then
        Font.Style:=Font.Style+[fsItalic];
      if pos('U',Ed_List[2])>0 then
        Font.Style:=Font.Style+[fsUnderLine];
  // add Delphi's color settings for each TokenState to the TokenColors string
  // that is added to the RTF Colortbl in the ConvertReadStream procedure 11/9/98 HDN
      TokenColors := TokenColors + ColorToRTF(StrToInt(Ed_List[0]));
  // Use the background color from Delphi's Whitespace setting as the overall
  // background color.  This should be acceptable in most cases! 11/11/98 HDN
      if aTokenState = tsSpace then FBgColor := StrToInt(Ed_List[1]);

      SetPreAndPosFix(Font,aTokenState);
    finally
    Ed_List.Free;
    Font.Free;
    End;
  End;

const Delphi_Editor: array[0..10] of string=('Assembler','Comment','IGNORE',
           'IGNORE','Identifier','Reserved_Word','Number','Whitespace','String',
           'Symbol','Plain_Text');
var
  RegIni: TIniFile;
  Ed_Setting: String;
  i: Integer;
begin
  RegIni := TIniFile.Create(FileName);

  try
    for i := 0 to 10 do
      if Delphi_Editor[i]<>'IGNORE' then
      begin
        Ed_Setting:=RegIni.ReadString('HighLight',Delphi_Editor[i],'0,0,,0,0,0,0');
        SetDelphiRTF(Ed_Setting,TTokenState(i));
      end;

    // Use the font size from Delphi's Editor 11/13/98 HDN
    FontSize := 
      '\fs' +  IntToStr(StrToInt(RegIni.ReadString('Editor','FontSize', '8'))*2);
  finally
    RegIni.Free;
  end;
end;

procedure TPasConversion.SetPreAndPosFix(aFont: TFont; aTokenState: TTokenState);
begin
   { Here you need to set the Pre - and PostFix
     accordingly to the aFont value }
  FPreFixList[aTokenState]:= '';
  // This case statement adds a "\cf" RTF token to the FPreFixList according to
  // the aTokenState.  The order is the same order that they are added to the
  // Colortbl with TokenColors string.  Note that things don't work right
  // if the space is not at the end of the "\cf" token. 11/9/98 HDN
  case aTokenState of
    tsAssembler:  FPreFixList[aTokenState]:= FPreFixList[aTokenState] + '\cf1 ';
    tsComment:    FPreFixList[aTokenState]:= FPreFixList[aTokenState] + '\cf2 ';
    tsCRLF:       {IGNORE};
    tsDirective:  {IGNORE};
    tsIdentifier: FPreFixList[aTokenState]:= FPreFixList[aTokenState] + '\cf3 ';
    tsKeyWord:    FPreFixList[aTokenState]:= FPreFixList[aTokenState] + '\cf4 ';
    tsNumber:     FPreFixList[aTokenState]:= FPreFixList[aTokenState] + '\cf5 ';
    tsSpace:      FPreFixList[aTokenState]:= FPreFixList[aTokenState] + '\cf6 ';
    tsString:     FPreFixList[aTokenState]:= FPreFixList[aTokenState] + '\cf7 ';
    tsSymbol:     FPreFixList[aTokenState]:= FPreFixList[aTokenState] + '\cf8 ';
    tsUnknown:    FPreFixList[aTokenState]:= FPreFixList[aTokenState] + '\cf9 ';
  end;

  FPostFixList[aTokenState]:= '';
  if (fsBold in aFont.Style) then
    FPreFixList[aTokenState]:=FPreFixList[aTokenState]+'\b ';
  if (fsItalic in aFont.Style) then
    FPreFixList[aTokenState]:=FPreFixList[aTokenState]+'\i ';
  if (fsUnderline in aFont.Style) then
    FPreFixList[aTokenState]:=FPreFixList[aTokenState]+'\u ';

  if FPreFixList[aTokenState]<>'' then
    FPreFixList[aTokenState]:='{'+FPreFixList[aTokenState];

  if FPreFixList[aTokenState]<>'' then
    FPostFixList[aTokenState]:='}'
end;  { SetPreAndPosFix }

procedure TPasConversion.ScanForRtf;
var
  i: Integer;
begin
  RunStr:= FStrBuff;
  FStrBuffEnd:= FStrBuff + 1023;
  for i:=1 to TokenLen do
  begin
    Case TokenStr[i] of
      '\', '{', '}':
        begin
          RunStr^:= '\';
          inc(RunStr);
        end
    end;
    if RunStr >= FStrBuffEnd then AllocStrBuff;
    RunStr^:= TokenStr[i];
    inc(RunStr);
  end;
  RunStr^:= #0;
  TokenStr:= FStrBuff;
end;  { ScanForRtf }

procedure TPasConversion.HandleAnsiC;
begin
  while Run^ <> #0 do
  begin
    Case Run^ of
      #13:
        begin
          if TokenPtr <> Run then
          begin
            FTokenState:= tsComment;
            TokenLen:= Run - TokenPtr;
            SetString(TokenStr, TokenPtr, TokenLen);
            ScanForRtf;
            SetRTF;
            WriteToBuffer(Prefix + TokenStr + Postfix);
            TokenPtr:= Run;
          end;
          HandleCRLF;
          dec(Run);
        end;

      '*': if (Run +1 )^ = ')' then begin  inc(Run, 2); break; end;
    end;
    inc(Run);
  end;
  FTokenState:= tsComment;
  TokenLen:= Run - TokenPtr;
  SetString(TokenStr, TokenPtr, TokenLen);
  ScanForRtf;
  SetRTF;
  WriteToBuffer(Prefix + TokenStr + Postfix);
  TokenPtr:= Run;