{+--------------------------------------------------------------------------+
| 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.
+--------------------------------------------------------------------------+}
unit mwPasToRtf;
interface
uses
Windows,
SysUtils,
Messages,
Classes,
ComCtrls,
Graphics,
Dialogs,
Registry;
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;
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);
protected
public
constructor Create;
destructor Destroy; override;
procedure Init;
procedure UseDelphiHighlighting(Ver: Integer);
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;
published
end;
const
Keywords : array[0..98] 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', 'REPEAT', 'RESIDENT',
'RESOURCESTRING', 'SAFECALL', 'SET', 'SHL', 'SHR', 'STDCALL', 'STORED',
'STRING', 'STRINGRESOURCE', 'THEN', 'THREADVAR', 'TO', 'TRY', 'TYPE',
'UNIT', 'UNTIL', 'USES', 'VAR', '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);
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(Ver: Integer);
{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];
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: TRegIniFile;
Ed_Setting: String;
i: Integer;
Begin
if Ver=2 then
RegIni:=TRegIniFile.Create('Software\Borland\Delphi\2.0')
else if Ver=3 then
RegIni:=TRegIniFile.Create('Software\Borland\Delphi\3.0')
else
Raise Exception.Create('Only syntax highlighting from Delphi 2 and 3 are supported');
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;
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]:= '';
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;
FComment:= csNo;
end; { HandleAnsiC }
procedure TPasConversion.HandleBorC;
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;
'}': begin inc(Run); break; end;
end;
inc(Run);
end;
FTokenState:= tsComment;
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
ScanForRtf;
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
FComment:= csNo;
end; { HandleBorC }
procedure TPasConversion.HandleCRLF;
begin
if Run^ = #0 then exit;
inc(Run, 2);
FTokenState:= tsCRLF;
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
fComment:= csNo;
FTokenState:= tsUnKnown;
if Run^ = #13 then HandleCRLF;
end; { HandleCRLF }
procedure TPasConversion.HandleSlashesC;
begin
FTokenState:= tsComment;
while (Run^ <> #13) and (Run^ <> #0) do inc(Run);
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
ScanForRtf;
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
FComment:= csNo;
end; { HandleSlashesC }
procedure TPasConversion.HandleString;
begin
FTokenState:= tsSTring;
FComment:= csNo;
repeat
Case Run^ of
#0, #10, #13: raise exception.Create('Invalid string');
end;
inc(Run);
until Run^ = #39;
inc(Run);
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
ScanForRtf;
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
end; { HandleString }
function TPasConversion.IsKeyWord(aToken: String):Boolean;
var
First, Last, I, Compare: Integer;
Token: String;
begin
First := 0;
Last := 98;
Result := False;
Token:= UpperCase(aToken);
while First <= Last do
begin
I := (First + Last) shr 1;
Compare := CompareStr(Keywords[i],Token);
if Compare = 0 then
begin
Result:=True;
break;
end
else
if Compare < 0 then First := I + 1 else Last := I - 1;
end;
end; { IsKeyWord }
function TPasConversion.IsDiffKey(aToken: String):Boolean;
var
First, Last, I, Compare: Integer;
Token: String;
begin
First := 0;
Last := 6;
Result := False;
Token:= UpperCase(aToken);
while First <= Last do
begin
I := (First + Last) shr 1;
Compare := CompareStr(DiffKeys[i],Token);
if Compare = 0 then
begin
Result:=True;
break;
end
else
if Compare < 0 then First := I + 1 else Last := I - 1;
end;
end; { IsDiffKey }
function TPasConversion.IsDirective(aToken: String):Boolean;
var
First, Last, I, Compare: Integer;
Token: String;
begin
First := 0;
Last := 10;
Result := False;
Token:= UpperCase(aToken);
if CompareStr('PROPERTY', Token) = 0 then FDiffer:= True;
if IsDiffKey(Token) then FDiffer:= False;
while First <= Last do
begin
I := (First + Last) shr 1;
Compare := CompareStr(Directives[i],Token);
if Compare = 0 then
begin
Result:= True;
if FDiffer then
begin
Result:= False;
if CompareStr('NAME', Token) = 0 then Result:= True;
if CompareStr('RESIDENT', Token) = 0 then Result:= True;
if CompareStr('STRINGRESOURCE', Token) = 0 then Result:= True;
end;
break;
end
else
if Compare < 0 then First := I + 1 else Last := I - 1;
end;
end; { IsDirective }
procedure TPasConversion.SetRTF;
begin
prefix:=FPreFixList[FTokenState];
postfix:=FPostFixList[FTokenState];
Case FTokenState of
tsAssembler: FTokenState:= tsUnknown;
tsComment: FTokenState:= tsUnknown;
tsCRLF:
begin
PostFix:= '\par ';
FTokenState:= tsUnknown;
FComment:= csNo;
end;
tsDirective: FTokenState:= tsUnknown;
tsIdentifier: FTokenState:= tsUnknown;
tsNumber: FTokenState:= tsUnknown;
tsKeyWord: FTokenState:= tsUnknown;
tsSpace: FTokenState:= tsUnknown;
tsString: FTokenState:= tsUnknown;
tsSymbol: FTokenState:= tsUnknown;
end;
end; { SetRTF }
procedure TPasConversion.WriteToBuffer(aString: String);
var
Count, Pos: Longint;
begin
Count:= Length(aString);
if (FBuffPos >= 0) and (Count >= 0) then
begin
Pos := FBuffPos + Count;
if Pos > 0 then
begin
if Pos >= FOutBuffSize then
begin
Try
FOutBuffSize:= FOutBuffSize + 16384;
ReAllocMem(FOutBuff, FOutBuffSize);
except
raise exception.Create('conversions buffer to small');
end;
end;
{System.Write(aString);}
StrECopy((FOutBuff + FBuffPos), PChar(aString));
FBuffPos:= FBuffPos + Count;
FOutBuff[FBuffPos]:= #0;
end;
end;
end; { WriteToBuffer }
function TPasConversion.ConvertReadStream: Integer;
begin
FTokenState:= tsUnknown;
FOutBuffSize:= size+3;
ReAllocMem(FOutBuff, FOutBuffSize);
FComment:= csNo;
FBuffPos:= 0;
FReadBuff:= Memory;
{Write leading RTF}
WriteToBuffer('{\rtf1\ansi\deff0\deftab720{\fonttbl{\f0\fswiss MS SansSerif;}{\f1\froman\fcharset2 Symbol;}{\f2\fmodern Courier New;}}'+#13+#10);
WriteToBuffer('{\colortbl\red0\green0\blue0;}'+#13+#10);
WriteToBuffer('\deflang1033\pard\plain\f2\fs20 ');
Result:= Read(FReadBuff^, Size);
FReadBuff[Result]:= #0;
if Result > 0 then
begin
Run:= FReadBuff;
TokenPtr:= Run;
while Run^ <> #0 do
begin
Case Run^ of
#13:
begin
FComment:= csNo;
HandleCRLF;
end;
#1..#9, #11, #12, #14..#32:
begin
while Run^ in [#1..#9, #11, #12, #14..#32] do inc(Run);
FTokenState:= tsSpace;
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
end;
'A'..'Z', 'a'..'z', '_':
begin
FTokenState:= tsIdentifier;
inc(Run);
while Run^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do inc(Run);
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
if IsKeyWord(TokenStr) then
begin
if IsDirective(TokenStr) then FTokenState:= tsDirective
else FTokenState:= tsKeyWord;
end;
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
end;
'0'..'9':
begin
inc(Run);
FTokenState:= tsNumber;
while Run^ in ['0'..'9', '.', 'e', 'E'] do inc(Run);
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
end;
'{':
begin
FComment:= csBor;
HandleBorC;
end;
'!','"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~' :
begin
FTokenState:= tsSymbol;
while Run^ in ['!','"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~'] do
begin
Case Run^ of
'/': if (Run + 1)^ = '/' then
begin
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
FComment:= csSlashes;
HandleSlashesC;
break;
end;
'(': if (Run + 1)^ = '*' then
begin
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
FComment:= csAnsi;
HandleAnsiC;
break;
end;
end;
inc(Run);
end;
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
end;
#39: HandleString;
'#':
begin
FTokenState:= tsString;
while Run^ in ['#', '0'..'9'] do inc(Run);
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
end;
'$':
begin
FTokenState:= tsNumber;
while Run^ in ['$','0'..'9', 'A'..'F', 'a'..'f'] do inc(Run);
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
end;
else
begin
if Run^ <> #0 then
begin
inc(Run);
TokenLen:= Run - TokenPtr;
SetString(TokenStr, TokenPtr, TokenLen);
SetRTF;
WriteToBuffer(Prefix + TokenStr + Postfix);
TokenPtr:= Run;
end else break;
end;
end;
end;
WriteToBuffer(#13+#10+'\par }{'+#13+#10);
end;
Clear;
SetPointer(FOutBuff, fBuffPos-1) ;
end; { ConvertReadStream }
function TPasConversion.ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize:
Integer): Integer;
begin
{FBuffPos:= 0;
FOutBuffSize:= BufSize;
FOutBuff:= StrAlloc(FOutBuffSize);
Run:= Buffer;
while Run^ <> #0 do
begin
end;
Result := Stream.Write(FOutBuff^, BufSize);
StrDispose(FOutBuff);}
end; { ConvertWriteStream }
procedure TPasConversion.Init;
begin
end; { Initialize }
end.