summaryrefslogtreecommitdiff
path: root/docview/components/richtext
diff options
context:
space:
mode:
authorGraeme Geldenhuys <graeme@mastermaths.co.za>2009-11-27 15:45:14 +0200
committerGraeme Geldenhuys <graeme@mastermaths.co.za>2009-11-27 15:45:14 +0200
commit441add90d3183e0f5e8020442a21c9b3bf62c6ab (patch)
tree6f648c4400c170d82ac7cbaa698329deafb4e1f8 /docview/components/richtext
parentab9a941d02281b95f00dd74f69a744ac302743e3 (diff)
parenta1f68b05ed682e9a3640684d99a6d228cec80a35 (diff)
downloadfpGUI-441add90d3183e0f5e8020442a21c9b3bf62c6ab.tar.xz
Merged separate DocView project as our subdirectory
Diffstat (limited to 'docview/components/richtext')
-rw-r--r--docview/components/richtext/ACLStringUtility.pas1769
-rw-r--r--docview/components/richtext/CanvasFontManager.pas1139
-rw-r--r--docview/components/richtext/RichTextDisplayUnit.pas416
-rw-r--r--docview/components/richtext/RichTextDocumentUnit.pas787
-rw-r--r--docview/components/richtext/RichTextLayoutUnit.pas1018
-rw-r--r--docview/components/richtext/RichTextPrintUnit.pas75
-rw-r--r--docview/components/richtext/RichTextStyleUnit.pas641
-rw-r--r--docview/components/richtext/RichTextView.pas2868
-rw-r--r--docview/components/richtext/fpgui_richtext.lpk82
-rw-r--r--docview/components/richtext/fpgui_richtext.pas15
10 files changed, 8810 insertions, 0 deletions
diff --git a/docview/components/richtext/ACLStringUtility.pas b/docview/components/richtext/ACLStringUtility.pas
new file mode 100644
index 00000000..f60aeed0
--- /dev/null
+++ b/docview/components/richtext/ACLStringUtility.pas
@@ -0,0 +1,1769 @@
+Unit ACLStringUtility;
+
+{$mode objfpc}{$H+}
+
+Interface
+
+Uses
+ Classes;
+
+const
+ CharTAB = chr(9);
+ CharCR = chr(13);
+ CharLF = chr(10);
+ CharSingleQuote = '''';
+ CharDoubleQuote = '"';
+
+ EndLine = CharCR + CharLF;
+
+ StrTAB = CharTAB;
+ StrCR = CharCR;
+ StrLF = CharLF;
+ StrCRLF = StrCR + StrLF;
+ StrSingleQuote = CharSingleQuote;
+ StrDoubleQuote = CharDoubleQuote;
+
+type
+ TSetOfChars = set of char;
+
+ TCharMatchFunction = function( const a: char ): boolean;
+
+
+ TSerializableStringList = class(TObject)
+ private
+ stringList: TStringList;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ function getCount : LongInt;
+ function get(const anIndex : LongInt) : String;
+ function getSerializedString : String;
+ procedure add(const aString : String);
+ procedure readValuesFromSerializedString(const aSerializedString : String);
+ end;
+
+
+// Returns true if c is a digit 0..9
+Function IsDigit( const c: char ): boolean;
+
+// Returns true if c is not a digit
+Function IsNonDigit( const c: char ): boolean;
+
+// Returns true if c is an alphabetic character a..z A..Z
+Function IsAlpha( const c: char ): boolean;
+
+// Returns true if s is only spaces (or empty)
+Function IsSpaces( const s: string ): boolean;
+
+// ---------------------- Numeric conversions ---------------------------------------
+
+// Converts a hex string to a longint
+// May be upper or lower case
+// Does not allow a sign
+// Is not forgiving as StrToInt: all characters
+// must be valid hex chars.
+function HexToInt( s: string ): longint;
+
+// Given a string with a number on the end, increments that
+// number by one.
+// If there is no number it adds a one.
+// If the number is left zero padded then the result is similarly
+// padded
+Function IncrementNumberedString( StartString: string ): string;
+
+// ---------------------- Pascal String Utilities ---------------------------------------
+
+Function CaseInsensitivePos( const a: string;
+ const b: string ): longint;
+
+// Looks for occurrences of QuoteChar and inserts a duplicate
+Function InsertDuplicateChars( const S: string;
+ const QuoteChar: char ): string;
+
+// Returns index of SubString in S, case-insensitve
+Function FindSubstring( const SubString: string;
+ const S: string ): integer;
+
+// Returns characters at the front of S that match according
+// to a given function... for example, IsDigit, IsNonDigit, IsAlpha
+Function MatchLeadingChars(
+ const S: string;
+ MatchFunction: TCharMatchFunction ): string;
+
+// Same as MatchLeadingChars, but removes the matching chars from S
+Function ExtractLeadingChars(
+ Var S: string;
+ MatchFunction: TCharMatchFunction ): string;
+
+// Case insensitive compare
+Function StringsSame( const a, b: string ): boolean;
+
+// Quoting
+
+// Note: these functions do not check for existing quotes within
+// the string, they only add or delete characters at the end.
+
+// Returns S in single quotes
+Function StrQuote( const s: string ): string;
+
+// Returns S without single quotes
+Function StrUnQuote( const s: string ): string;
+
+// Returns S in double quotes,
+// with any double quotes in S duplicated
+Function StrFullDoubleQuote( const s: string ): string;
+
+// Returns S without double quotes
+Function StrUnDoubleQuote( const s: string ): string;
+// Returns aString enclosed in single quotes
+Function StrInSingleQuotes(const aString : String) : String;
+// Returns aString enclosed in double quotes
+Function StrInDoubleQuotes(const aString : String) : String;
+
+
+//
+
+// Substitutes given character - placing all occurences of AFind char.
+Function SubstituteChar( const S: string; const Find: Char; const Replace: Char ): string;
+
+// Returns the count rightmost chars of S
+Function StrRight( const S:string; const count:integer ):string;
+
+// Returns the remainder of S starting at start
+Function StrRightFrom( const S:string; const start:integer ):string;
+
+// Returns the count leftmost chars of S
+Function StrLeft( const S:string; const count:integer ):string;
+
+// Returns S minus count characters from the right
+Function StrLeftWithout( const S:string; const count:integer ):string;
+
+// Returns S with leftCount chars removed from the left and
+// rightCount chars removed from the right.
+Function StrRemoveEnds( const S:string; const leftCount:integer; const rightCount:integer ):string;
+
+// Produces a string from n padded on the left with 0's
+// to width chars
+Function StrLeft0Pad( const n: integer; const width: integer ): string;
+
+// Returns true if s starts with start (case insensitive)
+Function StrStarts( const start: string; const s: string ): boolean;
+
+// Returns true if s ends with endstr (case insensitive)
+Function StrEnds( const endStr: string; const s: string ): boolean;
+
+// Returns first word from S
+Function StrFirstWord( const S: String ): string;
+
+// prefixes all occurences of one of the chars in aReceiver with
+// anEscape char if the escapeChar itself is found, then it is doubled
+Function StrEscapeAllCharsBy(Const aReceiver: String; const aSetOfChars: TSetOfChars; const anEscapeChar: char): String;
+
+// Trims punctuation characters from start and end of s
+// such as braces, periods, commas.
+procedure TrimPunctuation( var s: string );
+
+// Returns true if S contains a URL. MAY MODIFY CONTENTS OF S
+function CheckAndEncodeURL( var s: string ): boolean;
+
+// ------------ Seperated value utilities ---------------------
+
+// Returns the next item starting at Index. Spaces are the separator,
+// unless the item is quoted with QuoteChar, in which case it looks for
+// a closing quote. Occurrences of the QuoteChar in the item itself,
+// can be escaped with a duplicate, e.g. "He said ""bok"""
+Procedure GetNextQuotedValue(
+ const S: string;
+ var Index: longint;
+ var Value: string;
+ const QuoteChar: char );
+
+procedure GetNextValue(
+ const S: String;
+ var Index: longint;
+ var Value: string;
+ const Seperator: char );
+
+// Extract all fields in a String delimited by whitespace (blank or tab).
+// use double quotes if you need blanks in the strings
+Procedure StrExtractStringsQuoted(Var aResult: TStrings; const aReceiver: String);
+
+// Extract all fields in a String given a set of delimiter characters and
+// an optional escape character usable to escape field delimits.
+// Example:
+// StrExtractStrings('1x2x3\x4', 'x', '\') ->
+// returns 4 strings: '1', '', '2' and '3x4'
+procedure StrExtractStrings(var aResult : TStrings; const aReceiver: String; const aSetOfChars: TSetOfChars; const anEscapeChar: char);
+
+// Removes and returns the first value in a separated
+// value list (removes quotes if found)
+Function ExtractNextValue(
+ var S: string;
+ const Separator: string ): string;
+
+Function ExtractNextValueNoTrim(
+ var S: string;
+ const Separator: string ): string;
+
+
+// Parses a line of the form
+// key = value into it's components
+Procedure ParseConfigLine( const S: string;
+ var KeyName: string;
+ var KeyValue: string );
+
+// Removes spaces around the separator in the given string
+Procedure RemoveSeparatorSpaces( var S: string; const Separator:string );
+
+{$ifdef os2}
+// ------------ Ansi String utilities ------------------------
+
+// Right & left trim that works with AnsiStrings.
+Function AnsiTrim( const S: AnsiString ): AnsiString;
+
+Procedure AnsiParseConfigLine( const S: Ansistring;
+ var keyName: Ansistring;
+ var keyValue: Ansistring );
+
+Function AnsiExtractNextValue( var CSVString: AnsiString;
+ const Separator: AnsiString ): AnsiString;
+
+{$endif}
+
+// ------------- Lists of strings, and strings as lists -----------
+
+// Adds NewValue to S as a separated list
+Procedure AddToListString( Var S: string;
+ const NewValue: string;
+ const Separator: string );
+
+Function ListToString( List: TStrings;
+ const Separator: string ): string;
+
+procedure StringToList( S: String;
+ List: TStrings;
+ const Separator: string );
+
+// Reverse the given list. It must be set to not sorted
+Procedure ReverseList( TheList: TStrings );
+
+// Sort the given list into reverse alphabetical order
+//Procedure ReverseSortList( TheList: TStringList );
+
+// Find the given string in the given list, using
+// case insensitive searching (and trimming)
+// returns -1 if not found
+Function FindStringInList( const TheString: string;
+ TheList:TStrings ):longint;
+
+Procedure MergeStringLists( Dest: TStringList;
+ AdditionalList: TStringList );
+
+// ---------------------- PCHAR Utilities ---------------------------------------
+
+function StrNPas( const ps: PChar; const Length: integer ): String;
+
+// Returns a - b
+Function PCharDiff( const a: PChar; const b: Pchar ): longword;
+
+// trims spaces and carriage returns of the end of Text
+procedure TrimWhitespace( Text: PChar );
+
+
+function TrimChars( const s: string;
+ chars: TSetOfChars ): string;
+
+// Concatenates a pascal string onto a PCHar string
+// Resizes if needed
+procedure StrPCat( Var Dest: PChar;
+ const StringToAdd: string );
+
+// Trim endlines (#10 or #13) off the end of
+// the given string.
+Procedure TrimEndLines( const S: PChar );
+
+// Allocates enough memory for a copy of s as a PChar
+// and copies s to it.
+Function StrDupPas( const s: string ): PChar;
+
+// Returns a copy of the first n chars of s
+Function StrNDup( const s: PChar; const n: integer ): PChar;
+
+// Returns a copy of the first line starting at lineStart
+Function CopyFirstLine( const lineStart: PChar ): PChar;
+
+// Returns next line p points to
+Function NextLine( const p: PChar): PChar;
+
+// Concatentate AddText to Text. Reallocate and expand
+// Text if necessary. This is a size-safe StrCat
+Procedure AddAndResize( Var Text: PChar;
+ const AddText: PChar );
+
+// Copy Source to Dest. Reallocate and expand
+// Dest if necessary. This is a size-safe StrCopy
+Procedure StrCopyAndResize( Var Dest: PChar;
+ const Source: PChar );
+
+// Return "True" or "False"
+Function BoolToStr( const b: boolean ): string;
+
+// Return true if param matches the form
+// /Flag:value
+// dash (-) can be used instead of slash (/)
+// colon can be omitted
+function MatchValueParam( const Param: string;
+ const Flag: string;
+ var Value: string ): boolean;
+
+// Return true if param matches the form
+// /Flag
+// dash (-) can be used instead of slash (/)
+function MatchFlagParam( const Param: string; const Flag: string ): boolean;
+
+// returns true if the String starts with the provided one
+// this is case INsensitive
+function StrStartsWithIgnoringCase(const aReceiver: String; const aStartString: String): Boolean;
+
+// returns true if the String ends with the provided one
+// this is case INsensitive
+function StrEndsWithIgnoringCase(const aReceiver: String; const anEndString: String): Boolean;
+
+function StrIsEmptyOrSpaces(const AText: string): boolean;
+
+implementation
+
+Uses
+ SysUtils
+ ,nvUtilities
+ ;
+
+// ---------------------- Pascal String Utilities ---------------------------------------
+
+Procedure SkipChar( const S: string;
+ Var index: longint;
+ const C: Char );
+begin
+ while Index <= Length( S ) do
+ begin
+ if S[ Index ] <> C then
+ break;
+ inc( Index );
+ end;
+end;
+
+
+Procedure GetNextQuotedValue(
+ const S: string;
+ var Index: longint;
+ var Value: string;
+ const QuoteChar: char );
+begin
+ Value := '';
+ SkipChar( S, Index, ' ' );
+ if Index > Length( S ) then
+ exit;
+
+ if S[ Index ] <> QuoteChar then
+ begin
+ // not quoted, go to next space
+ while Index <= Length( S ) do
+ begin
+ if S[ Index ] = ' ' then
+ break;
+ Value := Value + S[ Index ];
+ inc( Index );
+ end;
+ // skip following spaces
+ SkipChar( S, Index, ' ' );
+ exit;
+ end;
+
+ // quoted string
+ inc( Index ); // skip opening quote
+
+ while Index <= Length( S ) do
+ begin
+ if S[ Index ] = QuoteChar then
+ begin
+ inc( index ); // skip closing quote
+ if Index > Length( S ) then
+ break; // done
+ if S[ Index ] <> QuoteChar then
+ break; // done
+
+ // escaped quote e.g "" so we do want it.
+ end;
+ Value := Value + S[ Index ];
+ inc( Index );
+ end;
+
+ SkipChar( S, Index, ' ' );
+
+end;
+
+Function InsertDuplicateChars( const S: string;
+ const QuoteChar: char ): string;
+var
+ i: integer;
+begin
+ Result := '';
+ for i := 1 to Length( S ) do
+ begin
+ Result := Result + S[ i ];
+ if S[ i ] = QuoteChar then
+ Result := Result + QuoteChar; // insert duplicate
+ end;
+end;
+
+Function FindSubstring( const SubString: string;
+ const S: string ): integer;
+begin
+ Result := Pos( Uppercase( SubString ),
+ Uppercase( S ) );
+end;
+
+Function MatchLeadingChars(
+ const S: string;
+ MatchFunction: TCharMatchFunction ): string;
+var
+ i: integer;
+ TheChar: char;
+begin
+ Result:= '';
+ i := 1;
+ while i <= Length( S ) do
+ begin
+ TheChar:= S[ i ];
+ if not MatchFunction( TheChar ) then
+ // found a non matching char. Stop looking
+ break;
+ Result:= Result + TheChar;
+ inc( i );
+ end;
+end;
+
+Function ExtractLeadingChars(
+ Var S: string;
+ MatchFunction: TCharMatchFunction ): string;
+begin
+ Result := MatchLeadingChars( s, MatchFunction );
+ if Length( Result ) > 0 then
+ // remove matching section from string
+ Delete( S, 1, Length( Result ) );
+end;
+
+// Hex conversion: sheer extravagance. Conversion from
+// a hex digit char to int is done by creating a lookup table
+// in advance.
+var
+ MapHexDigitToInt: array[ Chr( 0 ) .. Chr( 255 ) ] of longint;
+
+procedure InitHexDigitMap;
+var
+ c: char;
+ IntValue: longint;
+begin
+ for c := Chr( 0 ) to Chr( 255 ) do
+ begin
+ IntValue := -1;
+ if ( c >= '0' )
+ and ( c <= '9' ) then
+ IntValue := Ord( c ) - Ord( '0' );
+
+ if ( Upcase( c ) >= 'A' )
+ and ( Upcase( c ) <= 'F' ) then
+ IntValue := 10 + Ord( Upcase( c ) ) - Ord( 'A' );
+
+ MapHexDigitToInt[ c ] := IntValue;
+ end;
+end;
+
+function HexDigitToInt( c: char ): longint;
+begin
+ Result := MapHexDigitToInt[ c ];
+ if Result = -1 then
+ raise EConvertError.Create( 'Invalid hex char: ' + c );
+end;
+
+function HexToInt( s: string ): longint;
+var
+ i: integer;
+begin
+ if Length( s ) = 0 then
+ raise EConvertError.Create( 'No chars in hex string' );
+ Result := 0;
+ for i:= 1 to Length( s ) do
+ begin
+ Result := Result shl 4;
+ inc( Result, HexDigitToInt( s[ i ] ) );
+ end;
+end;
+
+Function StringsSame( const a, b: string ): boolean;
+begin
+ Result:= CompareText( a, b ) = 0;
+end;
+
+// Returns S in single quotes
+Function StrQuote( const s: string ): string;
+begin
+ Result := StrSingleQuote + s + StrSingleQuote;
+end;
+
+// Returns S without double quotes
+Function StrUnQuote( const s: string ): string;
+begin
+ Result := S;
+ if S = '' then
+ exit;
+
+ if Result[ 1 ] = StrSingleQuote then
+ Delete( Result, 1, 1 );
+
+ if Result = '' then
+ exit;
+
+ if Result[ Length( Result ) ] = StrSingleQuote then
+ Delete( Result, Length( Result ), 1 );
+end;
+
+Function StrFullDoubleQuote( const s: string ): string;
+begin
+ Result := StrDoubleQuote
+ + InsertDuplicateChars( s, '"' )
+ + StrDoubleQuote;
+end;
+
+// Returns S without double quotes
+Function StrUnDoubleQuote( const s: string ): string;
+begin
+ Result := S;
+ if S = '' then
+ exit;
+
+ if Result[ 1 ] = StrDoubleQuote then
+ Delete( Result, 1, 1 );
+
+ if Result = '' then
+ exit;
+
+ if Result[ Length( Result ) ] = StrDoubleQuote then
+ Delete( Result, Length( Result ), 1 );
+end;
+
+Function StrInSingleQuotes(const aString : String) : String;
+begin
+ Result := StrSingleQuote + aString + StrSingleQuote;
+end;
+
+Function StrInDoubleQuotes(const aString : String) : String;
+begin
+ Result := StrDoubleQuote + aString + StrDoubleQuote;
+end;
+
+Function SubstituteChar( const S: string; const Find: Char; const Replace: Char ): string;
+Var
+ i: longint;
+Begin
+ Result:= S;
+ for i:=1 to length( S ) do
+ if Result[ i ] = Find then
+ Result[ i ]:= Replace;
+End;
+
+Function StrRight( const S:string; const count:integer ):string;
+Begin
+ if count>=length(s) then
+ begin
+ Result:=S;
+ end
+ else
+ begin
+ Result:=copy( S, length( s )-count+1, count );
+ end;
+end;
+
+Function StrLeft( const S:string; const count:integer ):string;
+Begin
+ if count>=length(s) then
+ Result:=S
+ else
+ Result:=copy( S, 1, count );
+end;
+
+// Returns S minus count characters from the right
+Function StrLeftWithout( const S:string; const count:integer ):string;
+Begin
+ Result:= copy( S, 1, length( S )-count );
+End;
+
+Function StrRemoveEnds( const S:string; const leftCount:integer; const rightCount:integer ):string;
+Begin
+ Result:= S;
+ Delete( Result, 1, leftCount );
+ Delete( Result, length( S )-rightCount, rightCount );
+End;
+
+Function StrRightFrom( const S:string; const start:integer ):string;
+Begin
+ Result:= copy( S, start, length( S )-start+1 );
+end;
+
+Procedure ParseConfigLine( const S: string;
+ var keyName: string;
+ var keyValue: string );
+Var
+ line: String;
+ EqualsPos: longint;
+Begin
+ KeyName:= '';
+ KeyValue:= '';
+
+ line:= trim( S );
+ EqualsPos:= Pos( '=', line );
+
+ if ( EqualsPos>0 ) then
+ begin
+ KeyName:= line;
+ Delete( KeyName, EqualsPos, length( KeyName )-EqualsPos+1 );
+ KeyName:= Trim( KeyName );
+
+ KeyValue:= line;
+ Delete( KeyValue, 1, EqualsPos );
+ KeyValue:= Trim( KeyValue );
+ end;
+end;
+
+Function ExtractNextValueNoTrim( var S: string;
+ const Separator: string ): string;
+Var
+ SeparatorPos: integer;
+Begin
+ SeparatorPos := Pos( Separator, S );
+ if SeparatorPos > 0 then
+ begin
+ Result := Copy( S, 1, SeparatorPos-1 );
+ Delete( S, 1, SeparatorPos + length( Separator ) - 1 );
+ end
+ else
+ begin
+ Result := S;
+ S := '';
+ end;
+end;
+
+Function ExtractNextValue( var S: string;
+ const Separator: string ): string;
+begin
+ Result := ExtractNextValueNoTrim( S, Separator );
+ Result := trim( Result );
+
+ // Remove quotes if present
+ if Result <> '' then
+ if Result[ 1 ] = StrDoubleQuote then
+ Delete( Result, 1, 1 );
+
+ if Result <> '' then
+ if Result[ length( Result ) ] = StrDoubleQuote then
+ Delete( Result, length( Result ), 1 );
+end;
+
+procedure GetNextValue( const S: String;
+ Var Index: longint;
+ Var Value: String;
+ const Seperator: Char );
+var
+ NextSeperatorPosition: longint;
+ StringLen: longint;
+begin
+ Value := '';
+ StringLen := Length( S );
+ if Index > StringLen then
+ exit;
+ NextSeperatorPosition := Index;
+ while NextSeperatorPosition < StringLen do
+ begin
+ if S[ NextSeperatorPosition ] = Seperator then
+ break;
+ inc( NextSeperatorPosition );
+ end;
+
+ if NextSeperatorPosition < StringLen then
+ begin
+ Value := Copy( S,
+ Index,
+ NextSeperatorPosition - Index );
+ Index := NextSeperatorPosition + 1;
+ end
+ else
+ begin
+ Value := Copy( S,
+ Index,
+ StringLen - Index + 1 );
+ Index := StringLen + 1;
+ end;
+ TrimRight( Value );
+end;
+
+Procedure StrExtractStringsQuoted(Var aResult: TStrings; const aReceiver: String);
+Var
+ tmpState : (WHITESPACE, INSIDE, START_QUOTE, INSIDE_QUOTED, INSIDE_QUOTED_START_QUOTE);
+ tmpCurrentParsePosition : Integer;
+ tmpCurrentChar : Char;
+ tmpPart : String;
+
+Begin
+ if (length(aReceiver) < 1) then exit;
+
+ tmpState := WHITESPACE;
+ tmpPart := '';
+
+ tmpCurrentParsePosition := 1;
+
+ for tmpCurrentParsePosition:=1 to length(aReceiver) do
+ begin
+ tmpCurrentChar := aReceiver[tmpCurrentParsePosition];
+
+ Case tmpCurrentChar of
+ ' ', StrTAB :
+ begin
+
+ Case tmpState of
+
+ WHITESPACE :
+ begin
+ // nothing
+ end;
+
+ INSIDE :
+ begin
+ aResult.add(tmpPart);
+ tmpPart := '';
+ tmpState := WHITESPACE;
+ end;
+
+ INSIDE_QUOTED :
+ begin
+ tmpPart := tmpPart + tmpCurrentChar;
+ end;
+
+ START_QUOTE :
+ begin
+ tmpPart := tmpPart + tmpCurrentChar;
+ tmpState := INSIDE_QUOTED;
+ end;
+
+ INSIDE_QUOTED_START_QUOTE :
+ begin
+ aResult.add(tmpPart);
+ tmpPart := '';
+ tmpState := WHITESPACE;
+ end;
+ end;
+ end;
+
+ StrDoubleQuote :
+ begin
+
+ Case tmpState of
+
+ WHITESPACE :
+ begin
+ tmpState := START_QUOTE;
+ end;
+
+ INSIDE :
+ begin
+ aResult.add(tmpPart);
+ tmpPart := '';
+ tmpState := START_QUOTE;
+ end;
+
+ INSIDE_QUOTED :
+ begin
+ tmpState := INSIDE_QUOTED_START_QUOTE;
+ end;
+
+ START_QUOTE :
+ begin
+ tmpState := INSIDE_QUOTED_START_QUOTE;
+ end;
+
+ INSIDE_QUOTED_START_QUOTE :
+ begin
+ tmpPart := tmpPart + tmpCurrentChar;
+ tmpState := INSIDE_QUOTED;
+ end;
+ end;
+ end;
+
+ else
+ begin
+ Case tmpState of
+
+ WHITESPACE :
+ begin
+ tmpPart := tmpPart + tmpCurrentChar;
+ tmpState := INSIDE;
+ end;
+
+ INSIDE, INSIDE_QUOTED :
+ begin
+ tmpPart := tmpPart + tmpCurrentChar;
+ end;
+
+ START_QUOTE :
+ begin
+ tmpPart := tmpPart + tmpCurrentChar;
+ tmpState := INSIDE_QUOTED;
+ end;
+
+ INSIDE_QUOTED_START_QUOTE :
+ begin
+ aResult.add(tmpPart);
+ tmpPart := tmpCurrentChar;
+ tmpState := INSIDE;
+ end;
+ end;
+ end;
+
+ end;
+ end;
+
+ Case tmpState of
+ WHITESPACE, START_QUOTE : {nothing to do};
+
+ INSIDE, INSIDE_QUOTED, INSIDE_QUOTED_START_QUOTE :
+ begin
+ aResult.add(tmpPart);
+ end;
+ end;
+end;
+
+Procedure PrivateStrExtractStrings( Var aResult: TStrings;
+ const aReceiver: String;
+ const aSetOfChars: TSetOfChars;
+ const anEscapeChar: char;
+ const anIgnoreEmptyFlag : boolean);
+Var
+ i : Integer;
+ tmpChar,tmpNextChar : Char;
+ tmpPart: String;
+Begin
+ if (length(aReceiver) < 1) then exit;
+
+ tmpPart := '';
+
+ i := 1;
+ while i <= length(aReceiver) do
+ begin
+ tmpChar := aReceiver[i];
+ if i < length(aReceiver) then
+ tmpNextChar := aReceiver[i+1]
+ else
+ tmpNextChar := #0;
+
+ if (tmpChar = anEscapeChar) and (tmpNextChar = anEscapeChar) then
+ begin
+ tmpPart := tmpPart + anEscapeChar;
+ i := i + 2;
+ end
+ else
+ if (tmpChar = anEscapeChar) and (tmpNextChar in aSetOfChars) then
+ begin
+ tmpPart := tmpPart + tmpNextChar;
+ i := i + 2;
+ end
+ else
+ begin
+ if (tmpChar in aSetOfChars) then
+ begin
+ if (NOT anIgnoreEmptyFlag) OR ('' <> tmpPart) then
+ aResult.add(tmpPart);
+ tmpPart := '';
+ i := i + 1;
+ end
+ else
+ begin
+ tmpPart := tmpPart + tmpChar;
+ i := i + 1;
+ end;
+ end; { if/else }
+ end;
+
+ if (NOT anIgnoreEmptyFlag) OR ('' <> tmpPart) then
+ begin
+ aResult.add(tmpPart);
+ end;
+end;
+
+procedure StrExtractStrings(Var aResult: TStrings; Const aReceiver: String; const aSetOfChars: TSetOfChars; const anEscapeChar: char);
+begin
+ PrivateStrExtractStrings(aResult, aReceiver, aSetOfChars, anEscapeChar, false);
+end;
+
+
+Function IsDigit( const c: char ): boolean;
+Begin
+ Result:=( c>='0' ) and ( c<='9' );
+End;
+
+Function IsNonDigit( const c: char ): boolean;
+Begin
+ Result:=( c<'0' ) or ( c>'9' );
+End;
+
+Function IsAlpha( const c: char ): boolean;
+var
+ UppercaseC: char;
+Begin
+ UppercaseC := UpCase( c );
+ Result := ( UppercaseC >= 'A' ) and ( UppercaseC <= 'Z' );
+end;
+
+{$ifdef os2}
+// Returns true if s is only spaces (or empty)
+Function IsSpaces( const s: string ): boolean;
+Begin
+ Asm
+ MOV ESI,s // get address of s into ESI
+ MOV CL,[ESI] // get length of s
+ MOVZX ECX, CL // widen CL
+ INC ECX
+
+!IsSpacesLoop:
+ INC ESI // move to next char
+ DEC ECX
+ JE !IsSpacesTrue
+
+ MOV AL,[ESI] // load character
+ CMP AL,32 // is it a space?
+ JE !IsSpacesLoop // yes, go to next
+
+ // no, return false
+ MOV EAX, 0
+ JMP !IsSpacesDone
+
+!IsSpacesTrue:
+ MOV EAX, 1
+
+!IsSpacesDone:
+ LEAVE
+ RETN32 4
+ End;
+
+End;
+{$else}
+// Returns true if s is only spaces (or empty)
+Function IsSpaces( const s: string ): boolean;
+var
+ i: longint;
+Begin
+ for i := 1 to length( s ) do
+ begin
+ if s[ i ] <> ' ' then
+ begin
+ result := false;
+ exit;
+ end;
+ end;
+ result := true;
+end;
+{$endif}
+
+Function StrLeft0Pad( const n: integer; const width: integer ): string;
+Begin
+ Result:= IntToStr( n );
+ while length( Result )<width do
+ Result:= '0' +Result;
+End;
+
+// Returns true if s starts with start
+Function StrStarts( const start: string; const s: string ): boolean;
+Var
+ i: integer;
+Begin
+ Result:= false;
+ if length( start ) > length( s ) then
+ exit;
+ for i:= 1 to length( start ) do
+ if UpCase( s[ i ] ) <> UpCase( start[ i ] ) then
+ exit;
+ Result:= true;
+End;
+
+// Returns true if s ends with endstr (case insensitive)
+Function StrEnds( const endStr: string; const s: string ): boolean;
+Var
+ i, j: integer;
+Begin
+ Result:= false;
+ if Length( s ) < length( endStr ) then
+ exit;
+ j:= Length( s );
+ for i:= length( endstr ) downto 1 do
+ begin
+ if UpCase( s[ j ] ) <> UpCase( endStr[ i ] ) then
+ exit;
+ dec( j );
+ end;
+ Result:= true;
+End;
+
+Procedure RemoveSeparatorSpaces( var S: string;
+ const Separator:string );
+Var
+ SeparatorPos:integer;
+ NewString: string;
+Begin
+ NewString := '';
+ while S <> '' do
+ begin
+ SeparatorPos := pos( Separator, S );
+ if SeparatorPos > 0 then
+ begin
+ NewString := NewString
+ + trim( copy( S, 1, SeparatorPos - 1 ) )
+ + Separator;
+ Delete( S, 1, SeparatorPos );
+ end
+ else
+ begin
+ NewString := NewString + trim( S );
+ S := '';
+ end;
+ end;
+ S := NewString;
+End;
+
+Procedure AddToListString( Var S: string;
+ const NewValue: string;
+ const Separator: string );
+Begin
+ if trim( S )<>'' then
+ S:=S+Separator;
+ S:=S+NewValue;
+End;
+
+Function ListToString( List: TStrings;
+ const Separator: string ): string;
+Var
+ i: longint;
+Begin
+ Result:= '';
+ for i:= 0 to List.Count - 1 do
+ AddToListString( Result, List[ i ], Separator );
+End;
+
+procedure StringToList( S: String;
+ List: TStrings;
+ const Separator: string );
+var
+ Item: string;
+begin
+ List.Clear;
+ while S <> '' do
+ begin
+ Item:= ExtractNextValue( S, Separator );
+ List.Add( Item );
+ end;
+end;
+
+Function StrFirstWord( const S: String ): string;
+Var
+ SpacePos: longint;
+ temp: string;
+Begin
+ temp:= trimleft( S );
+ SpacePos:= pos( ' ', temp );
+ if SpacePos>0 then
+ Result:= Copy( temp, 1, SpacePos-1 )
+ else
+ Result:= temp;
+End;
+
+Function StrEscapeAllCharsBy(Const aReceiver: String; const aSetOfChars: TSetOfChars; const anEscapeChar: char): String;
+Var
+ i : Integer;
+ tmpChar : Char;
+Begin
+ Result := '';
+
+ for i := 1 To length(aReceiver) do
+ begin
+ tmpChar := aReceiver[i];
+
+ if (tmpChar = anEscapeChar) or (tmpChar IN aSetOfChars) then
+ result := result + anEscapeChar + tmpChar
+ else
+ result := result + tmpChar;
+ end;
+end;
+
+const
+ StartPunctuationChars: set of char =
+ [ '(', '[', '{', '<', '''', '"' ];
+
+ EndPunctuationChars: set of char =
+ [ ')', ']', '}', '>', '''', '"', '.', ',', ':', ';', '!', '?' ];
+
+procedure TrimPunctuation( var s: string );
+var
+ ChangesMade: boolean;
+ c: Char;
+begin
+ while Length(s) > 0 do
+ begin
+ ChangesMade := false;
+ c := s[1];
+ if c in StartPunctuationChars then
+ begin
+ ChangesMade := true;
+ Delete(s, 1, 1);
+ end;
+
+ if Length(s) = 0 then
+ exit;
+
+ c := s[Length(s)];
+ if c in EndPunctuationChars then
+ begin
+ ChangesMade := true;
+ Delete(s, Length(s), 1);
+ end;
+
+ if not ChangesMade then
+ exit; // done
+ end;
+end;
+
+function IsDomainName( const s: string; StartingAt: longint ): boolean;
+var
+ DotPos: longint;
+ t: string;
+begin
+ Result := false;
+ t := Copy(s, StartingAt+1, Length(s));
+
+ // must be a dot in the domain...
+ DotPos := pos('.', t);
+ if DotPos = 0 then
+ // nope
+ exit;
+
+ // must be some text between start and dot,
+ // and between dot and end
+ // ie. a.b not .b or a.
+
+ if DotPos = Length(t) then
+ // no b;
+ exit;
+
+ Result := true;
+end;
+
+function IsEmailAddress( const s: string ): boolean;
+var
+ AtPos: longint;
+ SecondAtPos: longint;
+begin
+ result := false;
+ // must be a @...
+ AtPos := pos('@', s);
+ if AtPos = 0 then
+ // no @
+ exit;
+ if AtPos = 1 then
+ // can't be the first char though
+ exit;
+
+ // there is? There must be only one though...
+ SecondAtPos := LastDelimiter('@', s);
+ if (SecondAtPos <> AtPos) then
+ // there's a second @
+ exit;
+
+ Result := IsDomainName( s, AtPos + 1 );
+end;
+
+function CheckAndEncodeURL( var s: string ): boolean;
+ // simple userfriendly routine
+ function StartsWith(const s:string; const text: string): boolean;
+ begin
+ Result := pos(text, s) = 1;
+ end;
+
+begin
+
+ if StartsWith(s, 'www.') then
+ begin
+ if not IsDomainName( s, 4 ) then
+ exit;
+ Insert('http://', s, 1);
+ Result := true;
+ exit;
+ end;
+
+ if StartsWith(s, 'ftp.') then
+ begin
+ if not IsDomainName( s, 4 ) then
+ exit;
+ Insert('ftp://', s, 1);
+ Result := true;
+ exit;
+ end;
+
+ if StartsWith(s, 'http://' )
+ or StartsWith(s, 'https://' )
+ or StartsWith(s, 'ftp://' )
+ or StartsWith(s, 'mailto:' )
+ or StartsWith(s, 'news:' ) then
+ begin
+ Result := true;
+ exit;
+ end;
+
+ if IsEmailAddress( s ) then
+ begin
+ Insert('mailto:', s, 1);
+ Result := true;
+ exit;
+ end;
+
+ Result := false;
+end;
+
+Function IncrementNumberedString( StartString: string ): string;
+Var
+ Number: string;
+ NewNumber: string;
+ i: integer;
+begin
+ // Extract any digits at the end of the string
+ i:= length( StartString );
+ Number:= '';
+ while i>0 do
+ begin
+ if isDigit( StartString[i] ) then
+ begin
+ Number:= StartString[i] + Number;
+ i:= i - 1;
+ end
+ else
+ break;
+ end;
+
+ if Number<>'' then
+ begin
+ // Found a numeric bit to play with
+ // Copy the first part
+ Result:= StrLeftWithout( StartString, length( Number ) );
+ NewNumber:= StrLeft0Pad( StrToInt( Number ) + 1,
+ length( Number ) );
+ Result:= Result + NewNumber;
+ end
+ else
+ // No build number, add a 1
+ Result:= StartString + '1';
+end;
+
+{$ifdef OS2}
+
+Function AnsiTrim( const S: AnsiString ): AnsiString;
+Var
+ i: longint;
+Begin
+ i:= 1;
+ while i<length( S) do
+ begin
+ if S[ i ]<>' ' then
+ break;
+ inc( i );
+ end;
+ Result:= S;
+ if i>1 then
+ AnsiDelete( Result, 1, i-1 );
+ i:= length( Result );
+ while i>=1 do
+ begin
+ if S[ i ]<>' ' then
+ break;
+ dec( i );
+ end;
+ AnsiSetLength( Result, i );
+End;
+
+Procedure AnsiParseConfigLine( const S: Ansistring;
+ var keyName: Ansistring;
+ var keyValue: Ansistring );
+Var
+ line: AnsiString;
+ EqualsPos: longint;
+Begin
+ KeyName:= '';
+ KeyValue:= '';
+
+ line:= AnsiTrim( S );
+ EqualsPos:= AnsiPos( '=', line );
+
+ if ( EqualsPos>0 ) then
+ begin
+ KeyName:= AnsiCopy( line, 1, EqualsPos-1 );
+ KeyName:= AnsiTrim( KeyName );
+
+ KeyValue:= AnsiCopy( line, EqualsPos+1, length( line )-EqualsPos );
+ KeyValue:= AnsiTrim( KeyValue );
+ end;
+end;
+
+Function AnsiExtractNextValue( var CSVString: AnsiString;
+ const Separator: AnsiString ): AnsiString;
+Var
+ SeparatorPos: integer;
+Begin
+ SeparatorPos:= AnsiPos( Separator, CSVString );
+ if SeparatorPos>0 then
+ begin
+ Result:= AnsiCopy( CSVString, 1, SeparatorPos-1 );
+ AnsiDelete( CSVString, 1, SeparatorPos + length( Separator ) - 1 );
+ end
+ else
+ begin
+ Result:= CSVString;
+ CSVString:= '';
+ end;
+ Result:= AnsiTrim( Result );
+ // Remove qyotes if present
+ if ( Result[1] = chr(34) )
+ and ( Result[ length(Result) ] = chr(34) ) then
+ begin
+ AnsiDelete( Result, 1, 1 );
+ AnsiDelete( Result, length( Result ), 1 );
+ Result:= AnsiTrim( Result );
+ end;
+end;
+{$Endif}
+
+Procedure ReverseList( TheList:TStrings );
+Var
+ TempList: TStringList;
+ i: integer;
+Begin
+ TempList:= TStringList.Create;
+ for i:=TheList.count-1 downto 0 do
+ begin
+ TempList.AddObject( TheList.Strings[i],
+ TheList.Objects[i] );
+ end;
+ TheList.Assign( TempList );
+ TempList.Destroy;
+end;
+
+Function FindStringInList( const TheString: string;
+ TheList:TStrings ): longint;
+Var
+ i: longint;
+Begin
+ for i:=0 to TheList.count-1 do
+ begin
+ if StringsSame( TheString, TheList[ i ] ) then
+ begin
+ // found
+ Result:=i;
+ exit;
+ end;
+ end;
+ Result:=-1;
+End;
+
+Procedure MergeStringLists( Dest: TStringList;
+ AdditionalList: TStringList );
+var
+ i: integer;
+ s: string;
+begin
+ for i:= 0 to AdditionalList.Count - 1 do
+ begin
+ s:= AdditionalList[ i ];
+ if FindStringInList( s, Dest ) = -1 then
+ Dest.AddObject( s, AdditionalList.Objects[ i ] );
+ end;
+end;
+
+// ---------------------- PCHAR Utilities ---------------------------------------
+
+function StrNPas( const Ps: PChar; const Length: integer ): String;
+var
+ i: integer;
+begin
+ Result:= '';
+ i:= 0;
+ while ( Ps[ i ] <> #0 ) and ( i < Length ) do
+ begin
+ Result:= Result + Ps[ i ];
+ inc( i );
+ end;
+end;
+
+Function PCharDiff( const a: PChar; const b: Pchar ): longword;
+begin
+ Result:= longword( a ) - longword( b );
+end;
+
+Procedure CheckPCharSize( Var Text: PChar;
+ const NeededSize: longword );
+var
+ temp: PChar;
+ NewBufferSize: longword;
+begin
+ if ( NeededSize + 1 ) // + 1 to allow for null terminator
+ > StrBufSize( Text ) then
+ begin
+ // allocate new buffer, double the size...
+ NewBufferSize:= StrBufSize( Text ) * 2;
+ // or if that's not enough...
+ if NewBufferSize < ( NeededSize + 1 ) then
+ // double what we are going to need
+ NewBufferSize:= NeededSize * 2;
+ temp:= StrAlloc( NewBufferSize );
+
+ // copy string to new buffer
+ StrCopy( temp, Text );
+ StrDispose( Text );
+ Text:= temp;
+ end;
+end;
+
+Procedure AddAndResize( Var Text: PChar; const AddText: PChar );
+var
+ s: string;
+ s1, s2: string;
+begin
+ //CheckPCharSize( Text,
+ // strlen( Text )
+ // + strlen( AddText ) );
+ //StrCat( Text, AddText );
+ s1 := Text;
+ s2 := AddText;
+ s := s1 + s2;
+ StrDispose(Text);
+ Text := StrAlloc(length(s) + 1);
+ StrPCopy(Text, s);
+end;
+
+Procedure StrCopyAndResize( Var Dest: PChar;
+ const Source: PChar );
+begin
+ CheckPCharSize( Dest, StrLen( Source ) );
+ StrCopy( Dest, Source );
+end;
+
+// trims spaces and carriage returns of the end of Text
+procedure TrimWhitespace( Text: PChar );
+var
+ P: PChar;
+ IsWhitespace: boolean;
+ TheChar: Char;
+begin
+ P:= Text + StrLen( Text );
+ while P > Text do
+ begin
+ dec( P );
+ TheChar:= P^;
+ IsWhitespace:= TheChar in [ ' ', #13, #10, #9 ];
+ if not IsWhiteSpace then
+ // done
+ break;
+ P[ 0 ]:= #0; // Do no use P^ :=
+ end;
+end;
+
+function TrimChars( const s: string;
+ chars: TSetOfChars ): string;
+var
+ i: longint;
+ j: longint;
+begin
+ i := 1;
+ while i < Length( s ) do
+ if s[ i ] in chars then
+ inc( i )
+ else
+ break;
+
+ j := Length( s );
+ while j > i do
+ if s[ j ] in chars then
+ dec( j )
+ else
+ break;
+
+ result := Copy( s, i, j - i + 1 );
+end;
+
+procedure StrPCat( Var Dest: PChar;
+ const StringToAdd: string );
+var
+ Index: longint;
+ DestP: PChar;
+begin
+ CheckPCharSize( Dest,
+ StrLen( Dest )
+ + longword( Length( StringToAdd ) ) );
+ DestP:= Dest + StrLen( Dest );
+ for Index:= 1 to Length( StringToAdd ) do
+ begin
+ DestP[ 0 ]:= StringToAdd[ Index ]; // do not use DestP^ :=
+ inc( DestP );
+ end;
+ DestP[ 0 ]:= #0; // Do not use DestP^ := #0; Under Sibyl at least, this writes *** 2 NULL BYTES!!! ***
+end;
+
+Procedure TrimEndLines( const S: PChar );
+var
+ StringIndex: integer;
+begin
+ StringIndex:= strlen( S );
+ while StringIndex > 0 do
+ begin
+ dec( StringIndex );
+ if S[ StringIndex ] in [ #10, #13 ] then
+ begin
+ S[ StringIndex ]:= #0
+ end
+ else
+ break;
+ end;
+end;
+
+Function StrDupPas( const s: string ): PChar;
+Begin
+ Result:=StrAlloc( length( s )+1 );
+ StrPCopy( Result, S );
+// Result^:=s;
+End;
+
+// Returns a copy of the first n chars of s
+Function StrNDup( const s: PChar; const n: integer ): PChar;
+Begin
+ Result:= StrAlloc( n+1 );
+ Result[ n ]:= '6';
+ StrLCopy( Result, s, n );
+End;
+
+// Returns a copy of the first line starting at lineStart
+Function CopyFirstLine( const lineStart: PChar ): PChar;
+Var
+ lineEnd: PChar;
+ lineLength: integer;
+Begin
+ // look for an end of line
+ lineEnd:= strpos( lineStart, EndLine );
+ if lineEnd <> nil then
+ begin
+ // found, line length is difference between line end position and start of line
+ lineLength:= longword( lineEnd )-longword( lineStart ); // ugly but how else can it be done?
+ Result:= StrNDup( lineStart, lineLength );
+ exit;
+ end;
+
+ // no eol found, return copy of remainder of string
+ Result:= StrNew( lineStart );
+end;
+
+// Returns next line p points to
+Function NextLine( const p: PChar): PChar;
+Var
+ lineEnd: PChar;
+Begin
+ // look for an end of line
+ lineEnd:=strpos( p, EndLine );
+ if lineEnd<>nil then
+ begin
+ // Advance the linestart over the eol
+ Result:=lineEnd+length( EndLine );
+ exit;
+ end;
+
+ // no eol found, return pointer to null term
+ Result:=p+strlen( p );
+end;
+
+Function CaseInsensitivePos( const a: string; const b: string ): longint;
+begin
+ Result := Pos( UpperCase( a ), Uppercase( b ) );
+end;
+
+
+Function BoolToStr( const b: boolean ): string;
+begin
+ if b then
+ Result := 'True'
+ else
+ Result := 'False';
+end;
+
+// Return true if param matches the form
+// /Flag:value
+// dash (-) can be used instead of slash (/)
+// colon can be omitted
+function MatchValueParam( const Param: string;
+ const Flag: string;
+ var Value: string ): boolean;
+begin
+ Result := false;
+
+ if Param = '' then
+ exit;
+
+ if ( Param[ 1 ] <> '/' )
+ and ( Param[ 1 ] <> '-' ) then
+ exit;
+
+ if not StringsSame( Copy( Param, 2, Length( Flag ) ),
+ Flag ) then
+ exit;
+
+ Result := true;
+
+ Value := StrRightFrom( Param, 2 + Length( Flag ) );
+ if Value <> '' then
+ if Value[ 1 ] = ':' then
+ Delete( Value, 1, 1 );
+end;
+
+// Return true if param matches the form
+// /Flag
+// dash (-) can be used instead of slash (/)
+function MatchFlagParam( const Param: string;
+ const Flag: string ): boolean;
+begin
+ Result := false;
+
+ if Param = '' then
+ exit;
+
+ if ( Param[ 1 ] <> '/' )
+ and ( Param[ 1 ] <> '-' ) then
+ exit;
+
+ Result := StringsSame( StrRightFrom( Param, 2 ),
+ Flag );
+end;
+
+function StrStartsWithIgnoringCase(const aReceiver: String; const aStartString: String): Boolean;
+var
+ tmpStringPos : integer;
+ tmpStartStringLength : integer;
+begin
+ tmpStartStringLength := Length(aStartString);
+
+ if Length(aReceiver) < tmpStartStringLength then
+ begin
+ result := false;
+ exit;
+ end;
+
+ for tmpStringPos := 1 to tmpStartStringLength do
+ begin
+ if UpCase(aReceiver[tmpStringPos]) <> UpCase(aStartString[tmpStringPos]) then
+ begin
+ result := false;
+ exit;
+ end;
+ end;
+
+ result := true;
+end;
+
+Function StrEndsWithIgnoringCase(const aReceiver: String; const anEndString: String): Boolean;
+Var
+ tmpStringPos : Longint;
+ tmpMatchPos : Longint;
+Begin
+ tmpStringPos := length(aReceiver);
+ tmpMatchPos := length(anEndString);
+
+ if tmpMatchPos > tmpStringPos then
+ begin
+ result := false;
+ exit;
+ end;
+
+ while tmpMatchPos > 0 do
+ begin
+ if upcase(aReceiver[tmpStringPos]) <> upcase(anEndString[tmpMatchPos]) then
+ begin
+ result := false;
+ exit;
+ end;
+ dec(tmpMatchPos);
+ dec(tmpStringPos);
+ end;
+
+ result := true;
+end;
+
+function StrIsEmptyOrSpaces(const AText: string): boolean;
+begin
+ Result := Trim(AText) = '';
+end;
+
+{ TSerializableStringList }
+
+constructor TSerializableStringList.Create;
+begin
+ LogEvent(LogObjConstDest, 'TSerializableStringList createdestroy');
+ inherited Create;
+ stringList := TStringList.Create;
+end;
+
+destructor TSerializableStringList.Destroy;
+begin
+ LogEvent(LogObjConstDest, 'TSerializableStringList destroy');
+ stringList.Free;
+ inherited Destroy;
+end;
+
+function TSerializableStringList.getCount: LongInt;
+begin
+ Result := stringlist.Count;
+end;
+
+function TSerializableStringList.get(const anIndex: LongInt): String;
+begin
+ Result := stringList[anIndex];
+end;
+
+function TSerializableStringList.getSerializedString: String;
+var
+ i: Integer;
+begin
+ Result := '';
+ for i := 0 to stringList.count-1 do
+ begin
+ if (i > 0) then result := result + '&';
+ Result := Result + StrEscapeAllCharsBy(stringList[i], ['&'], '\');
+ end;
+end;
+
+procedure TSerializableStringList.add(const aString: String);
+begin
+ stringList.add(aString);
+end;
+
+procedure TSerializableStringList.readValuesFromSerializedString(const aSerializedString: String);
+begin
+ if length(aSerializedString) < 1 then
+ exit;
+ LogEvent(LogObjConstDest, 'readValuesFromSerializedString');
+ stringList.Clear;
+ LogEvent(LogObjConstDest, 'readValuesFromSerializedString clear done');
+ StrExtractStrings(stringList, aSerializedString, ['&'], '\');
+end;
+
+initialization
+ InitHexDigitMap;
+
+End.
diff --git a/docview/components/richtext/CanvasFontManager.pas b/docview/components/richtext/CanvasFontManager.pas
new file mode 100644
index 00000000..86a52b9d
--- /dev/null
+++ b/docview/components/richtext/CanvasFontManager.pas
@@ -0,0 +1,1139 @@
+Unit CanvasFontManager;
+
+{$mode objfpc}{$H+}
+
+Interface
+
+Uses
+ Classes
+ ,fpg_base
+ ,fpg_main
+ ,fpg_widget
+ ;
+
+Const
+ // This defines the fraction of a pixel that
+ // font character widths will be given in
+ FontWidthPrecisionFactor = 1; // 256 seems to be specific to OS/2 API
+ DefaultTopicFont = 'Sans';
+ DefaultTopicFontSize = '10';
+ DefaultTopicFixedFont = 'Courier New';
+ DefaultTopicFixedFontSize = '10';
+
+
+Type
+ {Standard Font types}
+ TFontType=(ftBitmap,ftOutline);
+
+ {Standard Font Attributes}
+ TFontAttributes=Set Of(faItalic,faUnderScore,faOutline,faStrikeOut,faBold);
+
+ {Standard Font pitches}
+ TFontPitch=(fpFixed,fpProportional);
+
+ {Standard Font character Set}
+ TFontCharSet=(fcsSBCS,fcsDBCS,fcsMBCS); {Single,Double,mixed Byte}
+
+
+ // a user-oriented specification of a font; not an actual structure in the INF file
+ TFontSpec = record
+ FaceName: string[ 64 ];
+ PointSize: integer; // if 0 then use x/y size
+ XSize: integer;
+ YSize: integer;
+ Attributes: TFontAttributes; // set of faBold, faItalic etc
+ end;
+
+ // NOTE: Char widths are in 1/FontWidthPrecisionFactor units
+ TCharWidthArray = array[ #0..#255 ] of longint;
+ TPCharWidthArray = ^TCharWidthArray;
+
+ // Used internally for storing full info on font
+ TLogicalFont = class(TObject)
+ public
+ FaceName: string; // user-selected name
+ UseFaceName: string; // after substitutions.
+
+ // Selected bits of FONTMETRICS
+ fsSelection: word; //USHORT;
+
+ FontType: TFontType;
+ FixedWidth: boolean;
+ PointSize: integer;
+ ID: integer;
+ Attributes: TFontAttributes;
+
+ // this can be nil if not already fetched
+ pCharWidthArray: TPCharWidthArray;
+ lMaxbaselineExt: longint; //LONG;
+ lAveCharWidth: longint; //LONG;
+ lMaxCharInc: longint; //LONG;
+ lMaxDescender: longint; //LONG;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ end;
+
+
+ TFontFace = class(TObject)
+ public
+ Name: string;
+ FixedWidth: boolean;
+ FontType: TFontType;
+ Sizes: TList; // relevant for bitmap fonts only - contains TLogicalFont objects
+ constructor Create;
+ destructor Destroy; override;
+ end;
+
+
+ TCanvasFontManager = class(TObject)
+ private
+ FWidget: TfpgWidget;
+ protected
+ FCanvas: TfpgCanvas;
+ FLogicalFonts: TList;
+ FCurrentFontSpec: TFontSpec;
+ FDefaultFontSpec: TFontSpec;
+ FCurrentFont: TLogicalFont;
+ FAllowBitmapFonts: boolean;
+ function CreateFont( const FontSpec: TFontSpec ): TLogicalFont;
+ function GetFont( const FontSpec: TFontSpec ): TLogicalFont;
+ procedure RegisterFont( Font: TLogicalFont );
+ procedure SelectFont( Font: TLogicalFont; Scale: longint );
+ // Retrieve character widths for current font
+ procedure LoadMetrics;
+ // load metrics if needed
+ procedure EnsureMetricsLoaded;
+ public
+ constructor Create(Canvas: TfpgCanvas; AllowBitmapFonts: boolean; AWidget: TfpgWidget); reintroduce;
+ destructor Destroy; override;
+ // Set the font for the associated canvas.
+ procedure SetFont( const FontSpec: TFontSpec );
+ // Retrieve the width of the given char, in the current font
+ function CharWidth( const C: Char ): longint;
+ function AverageCharWidth: longint;
+ function MaximumCharWidth: longint;
+ function IsFixed: boolean;
+ function CharHeight: longint;
+ function CharDescender: longint;
+ procedure DrawString(var Point: TPoint; const Length: longint; const S: PChar);
+ property Canvas: TfpgCanvas read FCanvas;
+ property Widget: TfpgWidget read FWidget;
+ property DefaultFontSpec: TFontSpec read FDefaultFontSpec write FDefaultFontSpec;
+ end;
+
+
+// Convert a Sibyl font to a FontSpec (Color is left the same)
+procedure FPGuiFontToFontSpec( Font: TfpgFont; Var FontSpec: TFontSpec );
+
+ // Thoughts on how it works....
+
+ // SelectFont looks for an existing logical font that
+ // matches the request. If found selects that logical font
+ // onto the canvas.
+
+ // If not found it creates a logical font and selects that onto
+ // the canvas.
+
+ // For bitmap fonts the logical font definition includes pointsize
+ // For outline fonts the defn is only face+attr; in this case
+ // selectfont also ses the 'CharBox' according to the point size.
+
+implementation
+
+uses
+ SysUtils
+ ,ACLStringUtility
+ ,nvUtilities
+ ,fpg_stringutils
+ ;
+
+
+var
+ FontFaces: TList = nil; // of TFontface
+ DefaultOutlineFixedFace: TFontFace;
+ DefaultOutlineProportionalFace: TFontFace;
+
+// TFontFace
+//------------------------------------------------------------------------
+
+constructor TFontface.Create;
+begin
+ Sizes := TList.Create;
+ FontType := ftOutline; // in fpGUI we treat all fonts as scalable (preference)
+end;
+
+destructor TFontface.Destroy;
+begin
+ Sizes.Free;
+end;
+
+// TLogicalFont
+//------------------------------------------------------------------------
+
+constructor TLogicalFont.Create;
+begin
+ FontType := ftOutline;
+ PointSize := 10;
+ Attributes := [];
+ FixedWidth := False;
+end;
+
+// frees allocated memory, if any.
+// Note - does not delete the Gpi Logical Font
+destructor TLogicalFont.Destroy;
+begin
+ if pCharWidthArray <> nil then
+ FreeMem( pCharWidthArray,
+ sizeof( TCharWidthArray ) );
+
+ inherited Destroy;
+end;
+
+
+// Convert a fpGUI Toolkit font to a FontSpec
+//------------------------------------------------------------------------
+procedure FPGuiFontToFontSpec( Font: TfpgFont; Var FontSpec: TFontSpec );
+var
+ s: string;
+ facename: string;
+ cp: integer;
+ c: char;
+ token: string;
+ prop, propval: string;
+ desc: string;
+
+ function NextC: char;
+ begin
+ Inc(cp);
+ if cp > length(desc) then
+ c := #0
+ else
+ c := desc[cp];
+ Result := c;
+ end;
+
+ procedure NextToken;
+ begin
+ token := '';
+ while (c <> #0) and (c in [' ', 'a'..'z', 'A'..'Z', '_', '0'..'9']) do
+ begin
+ token := token + c;
+ NextC;
+ end;
+ end;
+
+begin
+ cp := 0;
+ desc := Font.FontDesc;
+ // find fontface
+ NextC;
+ NextToken;
+ FontSpec.FaceName := token;
+ FontSpec.Attributes := [];
+ FontSpec.XSize := Font.TextWidth('v');
+ FontSpec.YSize := Font.Height;
+
+ // find font size
+ if c = '-' then
+ begin
+ NextC;
+ NextToken;
+ FontSpec.PointSize := StrToIntDef(token, 10);
+ end;
+
+ // find font attributes
+ while c = ':' do
+ begin
+ NextC;
+ NextToken;
+ prop := UpperCase(token);
+ propval := '';
+
+ if c = '=' then
+ begin
+ NextC;
+ NextToken;
+ propval := UpperCase(token);
+ end;
+ // convert fontdesc attributes to fontspec attributes
+ if prop = 'BOLD' then
+ include(FontSpec.Attributes, faBold)
+ else if prop = 'ITALIC' then
+ include(FontSpec.Attributes, faItalic)
+ else if prop = 'UNDERLINE' then
+ include(FontSpec.Attributes, faUnderScore)
+ end;
+end;
+
+// Find a font face with the given name
+//------------------------------------------------------------------------
+function FindFaceName( const name: string ): TFontFace;
+Var
+ FaceIndex: LongInt;
+ Face: TFontFace;
+begin
+ for FaceIndex := 0 to FontFaces.Count - 1 do
+ begin
+ Face := TFontFace(FontFaces[ FaceIndex ]);
+
+ if pos(UpperCase(name), UpperCase(Face.Name)) > 0 then
+ begin
+ Result := Face;
+ exit;
+ end;
+ end;
+ Result := nil;
+end;
+
+// Return the first font face of type = Outline (scalable)
+//------------------------------------------------------------------------
+function GetFirstOutlineFace( FixedWidth: boolean ): TFontFace;
+Var
+ FaceIndex: LongInt;
+ Face: TFontFace;
+begin
+ for FaceIndex := 0 to FontFaces.Count - 1 do
+ begin
+ Face := TFontFace(FontFaces[ FaceIndex ]);
+
+ if ( Face.FixedWidth = FixedWidth )
+ and ( Face.FontType = ftOutline ) then
+ begin
+ Result := Face;
+ exit;
+ end;
+ end;
+ Result := nil;
+end;
+
+// Find the bitmap font which best matches the given pointsize.
+//------------------------------------------------------------------------
+function GetClosestBitmapFixedFont( const PointSize: longint ): TLogicalFont;
+Var
+ FaceIndex: Longint;
+ FontIndex: longint;
+ Face: TFontFace;
+ Font: TLogicalFont;
+begin
+ Result := nil;
+ for FaceIndex := 0 to FontFaces.Count - 1 do
+ begin
+ Face := TFontFace(FontFaces[ FaceIndex ]);
+
+ if Face.FontType = ftBitmap then
+ begin
+ for FontIndex := 0 to Face.Sizes.Count - 1 do
+ begin
+ Font := TLogicalFont(Face.Sizes[ FontIndex ]);
+ if Font.FixedWidth then
+ begin
+ if ( Result = nil )
+ or ( Abs( Font.PointSize - PointSize )
+ < Abs( Result.PointSize - PointSize ) ) then
+ Result := Font;
+ end;
+ end;
+ end;
+ end;
+end;
+
+// Pick some nice default fonts.
+//------------------------------------------------------------------------
+procedure GetDefaultFonts;
+begin
+ // courier new is common and reasonably nice
+ DefaultOutlineFixedFace := FindFaceName( 'Courier New' );
+ if DefaultOutlineFixedFace = nil then
+ begin
+ DefaultOutlineFixedFace := GetFirstOutlineFace( true ); // first fixed outline face
+ end;
+
+ DefaultOutlineProportionalFace := FindFaceName( DefaultTopicFont );
+ if DefaultOutlineProportionalFace = nil then
+ begin
+ DefaultOutlineProportionalFace := GetFirstOutlineFace( false ); // first prop outline face
+ end;
+end;
+
+// Fetch the global list of font faces and sizes
+//------------------------------------------------------------------------
+procedure GetFontList;
+Var
+ Count: LongInt;
+ T: LongInt;
+ Font: TLogicalFont;
+ Face: TFontFace;
+ FamilyName: string;
+ fl: TStringList;
+ f: TfpgFont;
+begin
+ fl := nil;
+ FontFaces := TList.Create;
+ fl := fpgApplication.GetFontFaceList;
+
+ // Get font count
+ Count := fl.Count;
+ If Count > 0 Then
+ Begin
+ For T := 0 To Count - 1 Do
+ Begin
+ Font := TLogicalFont.Create;
+ Font.FaceName := fl[T];
+ f := fpgGetFont(Font.FaceName + '-10');
+ if (pos('COURIER', UpperCase(Font.FaceName)) > 0) or (pos('MONO', UpperCase(Font.FaceName)) > 0) then
+ Font.FixedWidth := True;
+ Font.lAveCharWidth := f.TextWidth('g');
+ Font.lMaxbaselineExt := f.Height;
+ //Font.fsSelection := pfm^[ T ].fsSelection;
+ //Font.lMaxbaselineExt := pfm^[ T ].lMaxbaselineExt;
+ //Font.lAveCharWidth := pfm^[ T ].lAveCharWidth;
+ //Font.lMaxCharInc := pfm^[ T ].lMaxCharInc;
+ Font.ID := -1; // and always shall be so...
+ f.Free;
+
+ Face := FindFaceName( Font.FaceName );
+ if Face = nil then
+ begin
+ // new face found
+ Face := TFontFace.Create;
+ Face.Name := Font.FaceName; // point to the actual face name string!
+ Face.FixedWidth := Font.FixedWidth;
+ Face.FontType := Font.FontType;
+ FontFaces.Add( Face );
+ end;
+ Face.Sizes.Add( Font );
+ End;
+ End;
+
+ // pick some for defaults
+ GetDefaultFonts;
+end;
+
+// Add .subscript to font name for attributes
+//------------------------------------------------------------------------
+Function ModifyFontName( const FontName: string;
+ const Attrs: TFontAttributes ): String;
+Begin
+ Result := FontName;
+ If faItalic in Attrs Then
+ Result := Result + '.Italic';
+ If faBold in Attrs Then
+ Result := Result + '.Bold';
+ If faOutline in Attrs Then
+ Result := Result + '.Outline';
+ If faStrikeOut in Attrs Then
+ Result := Result + '.Strikeout';
+ If faUnderScore in Attrs Then
+ Result := Result + '.Underscore';
+End;
+
+// Create a font without attributes
+//------------------------------------------------------------------------
+function CreateFontBasic( const FaceName: string; const PointSize: integer ): TLogicalFont;
+var
+ PPString: string;
+begin
+ Result := TLogicalFont.Create;
+ if FindFaceName( FaceName ) = nil then
+ Exit; //==>
+ Result.PointSize := PointSize; // will use later if the result was an outline font...
+ Result.FaceName := FaceName;
+
+ // OK now we have found the font face...
+ PPString := IntToStr( PointSize) + '.' + FaceName;
+
+ PPString := ModifyFontName( PPString, [] );
+end;
+
+// Provide outline substitutes for some common bitmap fonts
+// From Mozilla/2 source.
+//------------------------------------------------------------------------
+function SubstituteBitmapFontToOutline( const FaceName: string ): string;
+begin
+ if StringsSame( FaceName, 'Helv' ) then
+ result := DefaultTopicFont
+ else if StringsSame( FaceName, 'Helvetica' ) then
+ result := DefaultTopicFont
+ else if StringsSame( FaceName, 'Tms Rmn' ) then
+ result := 'Times New Roman'
+ else if StringsSame( FaceName, 'System Proportional' ) then
+ result := DefaultTopicFont
+ else if StringsSame( FaceName, 'System Monospaced' ) then
+ result := DefaultTopicFixedFont
+ else if StringsSame( FaceName, 'System VIO' ) then
+ result := DefaultTopicFixedFont
+ else
+ result := FaceName; // no substitution
+end;
+
+// Ask OS/2 dummy font window to convert a font spec
+// into a FONTMETRICS.
+//------------------------------------------------------------------------
+//procedure AskOS2FontDetails( const FaceName: string;
+// const PointSize: longint;
+// const Attributes: TFontAttributes;
+// var FontInfo: FONTMETRICS );
+//var
+// PPString: string;
+// PresSpace: HPS;
+//begin
+// // Hack from Sibyl code - we don't know WTF the algorithm is
+// // for selecting between outline/bitmap and doing substitutions
+// // so send it to a dummy window and find out the resulting details
+// PPString := IntToStr( PointSize )
+// + '.'
+// + FaceName;
+//
+// PPString := ModifyFontName( PPString, Attributes );
+//
+// FontWindow.SetPPFontNameSize( PPString );
+//
+// PresSpace := WinGetPS( FontWindow.Handle );
+// GpiQueryFontMetrics( PresSpace,
+// SizeOf( FontInfo ),
+// FontInfo );
+// WinReleasePS( PresSpace );
+//end;
+
+// Look for the best match for the given face, size and attributes.
+// If FixedWidth is set then makes sure that the result is fixed
+// (if there is any fixed font on the system at all!)
+// This uses the OS/2 GPI and therefore makes some substitutions,
+// such as Helv 8 (bitmap) for Helvetica 8 (outline)
+//------------------------------------------------------------------------
+procedure FindBestFontMatch( const FaceName: string;
+ const PointSize: longint;
+ const Attributes: TFontAttributes;
+ const FixedWidth: boolean;
+ var FontInfo: string );
+var
+ BestBitmapFontMatch: TLogicalFont;
+ fl: TStringList;
+ i: integer;
+begin
+ { TODO -oGraeme -cfonts : This hack is very quick and dirty. Needs to be refined a lot }
+ fl := fpgApplication.GetFontFaceList;
+ for i := 0 to fl.Count-1 do
+ begin
+ if Pos(FaceName, fl[i]) > 0 then
+ FontInfo := fl[i] + '-' + IntToStr(PointSize);
+ end;
+
+ if Fontinfo = '' then
+ // nothing found se use default font of fpGUI
+ FontInfo := fpgApplication.DefaultFont.FontDesc;
+end;
+
+//------------------------------------------------------------------------
+// Font manager
+//------------------------------------------------------------------------
+
+// constructor
+//------------------------------------------------------------------------
+constructor TCanvasFontManager.Create(Canvas: TfpgCanvas; AllowBitmapFonts: boolean;
+ AWidget: TfpgWidget);
+begin
+ inherited Create;
+ if FontFaces = nil then
+ GetFontList;
+ FCanvas := Canvas;
+ FWidget := AWidget;
+ FLogicalFonts := TList.Create;
+ FCurrentFontSpec.FaceName := 'Arial';
+ FCurrentFont := nil;
+ FAllowBitmapFonts := AllowBitmapFonts;
+ // get system default font spec
+ // as default default ;)
+ FPGuiFontToFontSpec( fpgApplication.DefaultFont, FDefaultFontSpec );
+ if FDefaultFontSpec.FaceName = '' then
+ raise Exception.Create('For some reason we could not create a FDefaultFontSpec instance');
+end;
+
+// Destructor
+//------------------------------------------------------------------------
+destructor TCanvasFontManager.Destroy;
+var
+ i: integer;
+ Font: TLogicalFont;
+ face: TFontFace;
+begin
+ // select default font so none of our logical fonts are in use
+ FCanvas.Font := fpgApplication.DefaultFont;
+
+ // delete each logical font and our record of it
+ for i := 0 to FLogicalFonts.Count - 1 do
+ begin
+ Font := TLogicalFont(FLogicalFonts[ i ]);
+ Font.Free;
+ end;
+ FLogicalFonts.Clear;
+ FLogicalFonts.Free;
+
+ // TCanvasFontManager asked for FontFaces to be created, so lets take responsibility to destroy it.
+ for i := 0 to FontFaces.Count-1 do
+ begin
+ face := TFontFace(Fontfaces[i]);
+ face.Free;
+ end;
+ FontFaces.Clear;
+ FontFaces.Free;
+ inherited Destroy;
+end;
+
+// Create a logical font for the given spec
+//------------------------------------------------------------------------
+function TCanvasFontManager.CreateFont( const FontSpec: TFontSpec ): TLogicalFont;
+var
+ UseFaceName: string;
+ Face: TFontFace;
+ RemoveBoldFromSelection: boolean;
+ RemoveItalicFromSelection: boolean;
+ UseAttributes: TFontAttributes;
+ MatchAttributes: TFontAttributes;
+ BaseFont: TLogicalFont;
+ BaseFontIsBitmapFont: Boolean;
+ FontInfo: string;
+ FixedWidth: boolean;
+begin
+ProfileEvent('>>>> TCanvasFontManager.CreateFont >>>>');
+ Face := nil;
+ RemoveBoldFromSelection := false;
+ RemoveItalicFromSelection := false;
+
+ UseAttributes := FontSpec.Attributes;
+
+ // see if the originally specified font is a fixed width one.
+ FixedWidth := false;
+ Face := FindFaceName( FontSpec.FaceName );
+ if Face <> nil then
+ FixedWidth := Face.FixedWidth;
+
+ Face := nil;
+
+ if not FAllowBitmapFonts then
+ UseFaceName := SubstituteBitmapFontToOutline( FontSpec.FaceName )
+ else
+ UseFaceName := FontSpec.FaceName;
+ProfileEvent('UseFaceName=' + UseFaceName);
+
+ if FontSpec.Attributes <> [] then
+ begin
+profileevent('FontSpec.Attributes are not blank');
+ BaseFontIsBitmapFont := false;
+ if FAllowBitmapFonts then
+ begin
+ // First see if the base font (without attributes)
+ // would be a bitmap font...
+ BaseFont := CreateFontBasic( UseFaceName, FontSpec.PointSize );
+ if BaseFont <> nil then
+ begin
+ BaseFontIsBitmapFont := BaseFont.FontType = ftBitmap;
+ BaseFont.Destroy;
+ end;
+ end;
+
+ If not BaseFontIsBitmapFont Then
+ begin
+profileevent('we seem to be looking for a outline font');
+ // Result is an outline font so look for specific bold/italic fonts
+ if ( faBold in FontSpec.Attributes )
+ and ( faItalic in FontSpec.Attributes ) then
+ begin
+ Face := FindFaceName( UseFaceName + ' BOLD ITALIC' );
+ if Face <> nil then
+ begin
+ Exclude( UseAttributes, faBold );
+ Exclude( UseAttributes, faItalic );
+ RemoveBoldFromSelection := true;
+ RemoveItalicFromSelection := true;
+ end;
+ end;
+
+ if Face = nil then
+ if faBold in FontSpec.Attributes then
+ begin
+ Face := FindFaceName( UseFaceName + ' BOLD' );
+ if Face <> nil then
+ begin
+ Exclude( UseAttributes, faBold );
+ RemoveBoldFromSelection := true;
+ end;
+ end;
+
+ if Face = nil then
+ if faItalic in FontSpec.Attributes then
+ begin
+ Face := FindFaceName( UseFaceName + ' ITALIC' );
+ if Face <> nil then
+ begin
+ Exclude( UseAttributes, faItalic );
+ RemoveItalicFromSelection := true;
+ end;
+ end;
+ end;
+ end;
+
+ if Face <> nil then
+ // found a styled face, does it match fixed width?
+ if Face.FixedWidth <> FixedWidth then
+ // no so we don't want to use it.
+ Face := nil;
+
+ if Face = nil then
+ // didn't find a styled face (or no styles set)
+ // so find unmodified, we will use simulation bits
+ Face := FindFaceName( UseFaceName );
+
+ // Oh shit!
+ if Face = nil then
+ // didn't find a styled face (or no styles set)
+ // so find unmodified, we will use simulation bits
+ Face := FindFaceName( 'Sans' ); // something very generic
+
+ if not FAllowBitmapFonts then
+ if Assigned(Face) and (Face.FontType = ftBitmap) then
+ // we aren't allowed bitmaps, but that's what this
+ // face is. So use the default outline face of the
+ // appropriate width type
+ if FixedWidth then
+ Face := DefaultOutlineFixedFace
+ else
+ Face := DefaultOutlineProportionalFace;
+
+ if Face = nil then
+ begin
+profileevent('Could not find the specified font name. Bummer! + early exit');
+ // Could not find the specified font name. Bummer.
+ Result := nil;
+ exit;
+ end;
+
+profileevent('******* Now create the TLogicalFont instance');
+ // OK now we have found the font face...
+ Result := TLogicalFont.Create;
+ Result.PointSize := FontSpec.PointSize; // will use later if the result was an outline font...
+ Result.FaceName := FontSpec.FaceName;
+ Result.UseFaceName := Face.Name;
+ Result.Attributes := FontSpec.Attributes;
+ Result.fsSelection := 0;
+ Result.FixedWidth := Face.FixedWidth;
+
+ if FAllowBitmapFonts then
+ begin
+ if BaseFontIsBitmapFont then
+ MatchAttributes := []
+ else
+ MatchAttributes := UseAttributes;
+ FindBestFontMatch( Face.Name,
+ FontSpec.PointSize,
+ MatchAttributes,
+ FixedWidth,
+ FontInfo );
+
+ Result.UseFaceName := FontInfo;
+ end
+ else
+ begin
+ // no bitmap fonts please.
+ Result.FontType := ftOutline
+ end;
+
+ // store the baseline and average char width.
+ // For bitmap fonts, these tell GPI which font we really want
+ // For outline fonts, we are just storing them for later ref.
+ //Result.lMaxbaseLineExt := FontInfo.lMaxbaselineExt;
+ //Result.lAveCharWidth := FontInfo.lAveCharWidth;
+ //Result.lMaxCharInc := FontInfo.lMaxCharInc;
+ Result.lMaxBaseLineExt := FontSpec.YSize;
+ Result.lAveCharWidth := FontSpec.XSize;
+ Result.lMaxCharInc := FontSpec.XSize;
+
+ // Set style flags
+ with Result do
+ begin
+ //If faBold in UseAttributes Then
+ // fsSelection := fsSelection or FM_SEL_BOLD;
+ //If faItalic in UseAttributes Then
+ // fsSelection := fsSelection or FM_SEL_ITALIC;
+ //If faUnderScore in UseAttributes Then
+ // fsSelection := fsSelection or FM_SEl_UNDERSCORE;
+ //If faStrikeOut in UseAttributes Then
+ // fsSelection := fsSelection or FM_SEl_STRIKEOUT;
+ //If faOutline in UseAttributes Then
+ // fsSelection := fsSelection or FM_SEl_OUTlINE;
+ end;
+
+profileevent(' Result.FaceName=' + Result.FaceName);
+profileevent(' Result.PointSize=' + IntToStr(Result.PointSize));
+profileevent(' Result.UseFaceName=' + Result.UseFaceName);
+
+ Result.pCharWidthArray := Nil;
+ ProfileEvent('<<<< TCanvasFontManager.CreateFont');
+end;
+
+// Register the given logical font with GPI and store for later use
+//------------------------------------------------------------------------
+procedure TCanvasFontManager.RegisterFont( Font: TLogicalFont );
+var
+// fa: FATTRS;
+ rc: longint;
+begin
+ FLogicalFonts.Add( Font );
+ Font.ID := FLogicalFonts.Count + 1; // add 1 to stay out of Sibyl's way
+
+ //// Initialise GPI font attributes
+ //FillChar( fa, SizeOf( FATTRS ), 0 );
+ //fa.usRecordLength := SizeOf( FATTRS );
+ //
+ //// Copy facename and 'simulation' attributes from what we obtained
+ //// earlier
+ //fa.szFaceName := Font.pUseFaceName^;
+ //fa.fsSelection := Font.fsSelection;
+ //
+ //fa.lMatch := 0; // please Mr GPI be helpful and do clever stuff for us, we are ignorant
+ //
+ //fa.idRegistry := 0; // IBM magic number
+ //fa.usCodePage := 0; // use current codepage
+ //
+ //If Font.FontType = ftOutline then
+ // // Outline font wanted
+ // fa.fsFontUse := FATTR_FONTUSE_OUTLINE Or FATTR_FONTUSE_TRANSFORMABLE
+ //else
+ // // bitmap font
+ // fa.fsFontUse := 0;
+ //
+ //// don't need mixing with graphics (for now)
+ //fa.fsFontUse := fa.fsFontUse or FATTR_FONTUSE_NOMIX;
+ //
+ //// copy char cell width/height from the (valid) one we
+ //// found earlier in GetFont (will be zero for outline)
+ //fa.lMaxbaseLineExt := Font.lMaxbaselineExt;
+ //fa.lAveCharWidth := Font.lAveCharWidth;
+ //
+ //fa.fsType := 0;
+ //
+ //// create logical font
+ //rc := GpiCreateLogFont( FCanvas.Handle,
+ // nil,
+ // Font.ID,
+ // fa );
+end;
+
+// Select the given (existing) logical font
+//------------------------------------------------------------------------
+procedure TCanvasFontManager.SelectFont( Font: TLogicalFont;
+ Scale: longint );
+var
+ f: TfpgFont;
+ s: string;
+begin
+ // Select the logical font
+ if Font.FontType = ftOutline then
+ begin
+ s := Font.FaceName + '-' + IntToStr(Font.PointSize);
+ if faBold in Font.Attributes then
+ s := s + ':bold';
+ if faItalic in Font.Attributes then
+ s := s + ':italic';
+ if faUnderScore in Font.Attributes then
+ s := s + ':underline';
+
+ f := fpgGetFont(s);
+ FCanvas.Font := f;
+ end;
+end;
+
+// Get a font to match the given spec, creating or re-using an
+// existing font as needed.
+//------------------------------------------------------------------------
+function TCanvasFontManager.GetFont( const FontSpec: TFontSpec ): TLogicalFont;
+var
+ AFont: TLogicalFont;
+ FontIndex: integer;
+ sub: string;
+begin
+ProfileEvent('DEBUG: TCanvasFontManager.GetFont >>>');
+ProfileEvent('Received FontSpec: Facename=' + FontSpec.FaceName);
+ProfileEvent(' PointSize=' + IntToStr(FontSpec.PointSize));
+ProfileEvent('FLogicalFonts.Count=' + intToStr(FLogicalFonts.Count));
+try
+ for FontIndex := 0 to FLogicalFonts.Count - 1 do
+ begin
+ AFont := TLogicalFont(FLogicalFonts[ FontIndex ]);
+ if AFont.PointSize = FontSpec.PointSize then
+ begin
+ if ( AFont.PointSize > 0 )
+ or ( ( AFont.lAveCharWidth = FontSpec.XSize )
+ and ( AFont.lMaxbaselineExt = FontSpec.YSize ) ) then
+ begin
+ if AFont.Attributes = FontSpec.Attributes then
+ begin
+ // search name last since it's the slowest thing
+ProfileEvent(' AFont.UseFaceName=' + AFont.UseFaceName);
+ProfileEvent(' FontSpec.FaceName=' + FontSpec.FaceName);
+ if AFont.FaceName = FontSpec.FaceName then
+ begin
+ // Found a logical font already created
+ Result := AFont;
+ // done
+ exit;
+ end
+ else
+ begin
+ // Still nothing! Lets try known substitute font names
+ sub := SubstituteBitmapFontToOutline(FontSpec.FaceName);
+ProfileEvent(' substitute font=' + sub);
+ if AFont.FaceName = sub then
+ begin
+ // Found a logical font already created
+ Result := AFont;
+ // done
+ profileevent('TCanvasFontManager.GetFont <<<<< exit early we found a font');
+ exit;
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+except
+ { TODO -oGraeme -cknow bug : An Access Violation error occurs often here! No idea why? }
+ on E: Exception do
+ ProfileEvent('Unexpected error occured. Error: ' + E.Message);
+end;
+
+ ProfileEvent('Now we need to create a new logical font');
+ // Need to create new logical font
+ Result := CreateFont( FontSpec );
+ if Result <> nil then
+ begin
+ RegisterFont( Result );
+ end;
+ProfileEvent('DEBUG: TCanvasFontManager.GetFont <<<');
+end;
+
+// Set the current font for the canvas to match the given
+// spec, creating or re-using fonts as needed.
+//------------------------------------------------------------------------
+procedure TCanvasFontManager.SetFont( const FontSpec: TFontSpec );
+var
+ Font: TLogicalFont;
+ lDefaultFontSpec: TFontSpec;
+begin
+ProfileEvent('DEBUG: TCanvasFontManager.SetFont >>>>');
+ if (FCurrentFontSpec.FaceName = FontSpec.FaceName) and
+ (FCurrentFontSpec.PointSize = FontSpec.PointSize) and
+ (FCurrentFontSpec.Attributes = FontSpec.Attributes) then
+ // same font
+ exit;
+
+ Font := GetFont( FontSpec );
+
+ if Font = nil then
+ begin
+ // ack! Pfffbt! Couldn't find the font.
+
+ // Try to get the default font
+ writeln('---------- here goes nothing -------------');
+ Font := GetFont( FDefaultFontSpec );
+ if Font = nil then
+ begin
+ writeln('******* We should never get here!!!! Defaut font should always exist.');
+ writeln('FDefaultFontSpec:');
+ writeln(' FaceName=', FDefaultFontSpec.FaceName);
+ writeln(' Size=', FDefaultFontSpec.PointSize);
+ FPGuiFontToFontSpec( fpgApplication.DefaultFont, lDefaultFontSpec );
+ Font := GetFont( lDefaultFontSpec );
+ if Font = nil then
+ // Jimminy! We can't even get the default system font
+ raise Exception.Create( 'Could not access default font '
+ + 'in place of '
+ + FontSpec.FaceName
+ + ' '
+ + IntToStr( FontSpec.PointSize ) );
+ end;
+
+ end;
+
+ SelectFont( Font, 1 );
+ FCurrentFontSpec := FontSpec;
+ FCurrentFont.Free;
+ FCurrentFont := Font;
+ProfileEvent('DEBUG: TCanvasFontManager.SetFont <<<<');
+end;
+
+// Get the widths of all characters for current font
+// and other dimensions
+//------------------------------------------------------------------------
+procedure TCanvasFontManager.LoadMetrics;
+var
+ TheChar: Char;
+begin
+ // Retrieve all character widths
+ if FCurrentFont.FontType = ftOutline then
+ begin
+ SelectFont( FCurrentFont, FontWidthPrecisionFactor );
+ end;
+
+ // allocate memory for storing the char widths
+ GetMem( FCurrentFont.pCharWidthArray, sizeof( TCharWidthArray ) );
+ //if not GpiQueryWidthTable( FCanvas.Handle,
+ // 0, 256,
+ // FCurrentFont.pCharWidthArray^[ #0 ] ) then
+ //begin
+ // raise Exception.Create( 'Error getting character width table: '
+ // + 'GpiQueryWidthTable error '
+ // + IntToStr( WinGetLastError( AppHandle ) ) );
+ //end;
+
+ // Convert all widths to positive!
+ // For unknown reason, sometimes GPI returns negative values...
+ for TheChar := #0 to #255 do
+ begin
+ FCurrentFont.pCharWidthArray^[ TheChar ] := Abs( FCurrentFont.pCharWidthArray^[ TheChar ] );
+ end;
+
+ if FCurrentFont.FontType = ftOutline then
+ begin
+ SelectFont( FCurrentFont, 1 );
+ end
+ else
+ begin
+ // For bitmap fonts, multiply by 256 manually
+ for TheChar := #0 to #255 do
+ begin
+ FCurrentFont.pCharWidthArray^[ TheChar ] :=
+ FCurrentFont.pCharWidthArray^[ TheChar ]
+ * FontWidthPrecisionFactor;
+ end;
+ end;
+
+ //GpiQueryFontMetrics( FCanvas.Handle,
+ // sizeof( fm ),
+ // fm );
+ //FCurrentFont.lMaxbaseLineExt := fm.lMaxbaselineExt;
+ //FCurrentFont.lAveCharWidth := fm.lAveCharWidth;
+ //FCurrentFont.lMaxCharInc := fm.lMaxCharInc;
+ //FCurrentFont.lMaxDescender := fm.lMaxDescender;
+end;
+
+procedure TCanvasFontManager.EnsureMetricsLoaded;
+begin
+ if FCurrentFont = nil then
+ raise( Exception.Create( 'No font selected before getting font metrics' ) );
+
+ if FCurrentFont.pCharWidthArray = Nil then
+ LoadMetrics;
+end;
+
+function TCanvasFontManager.CharWidth( const C: Char ): longint;
+begin
+ EnsureMetricsLoaded;
+ Result := FCurrentFont.pCharWidthArray^[ C ];
+ { TODO -ograemeg -chard-coded result : This is a temporary hard-code }
+// result := fpgApplication.DefaultFont.TextWidth(C);
+ Result := FCurrentFont.lAveCharWidth;
+end;
+
+function TCanvasFontManager.AverageCharWidth: longint;
+begin
+ EnsureMetricsLoaded;
+ Result := FCurrentFont.lAveCharWidth;
+end;
+
+function TCanvasFontManager.MaximumCharWidth: longint;
+begin
+ EnsureMetricsLoaded;
+ Result := FCurrentFont.lMaxCharInc;
+end;
+
+function TCanvasFontManager.CharHeight: longint;
+begin
+ EnsureMetricsLoaded;
+ Result := FCurrentFont.lMaxBaseLineExt;
+end;
+
+function TCanvasFontManager.CharDescender: longint;
+begin
+ EnsureMetricsLoaded;
+ Result := FCurrentFont.lMaxDescender;
+end;
+
+function TCanvasFontManager.IsFixed: boolean;
+begin
+ Result := FCurrentFont.FixedWidth;
+end;
+
+procedure TCanvasFontManager.DrawString(var Point: TPoint; const Length: longint; const S: PChar);
+var
+ t: string;
+
+ // Seaches <AValue> and replaces <ADel> with <AIns>. Case sensitive.
+ function tiStrTran(AValue, ADel, AIns : string): string;
+ var
+ i : integer;
+ sToChange : string;
+ begin
+ result := '';
+ sToChange := AValue;
+ i := UTF8Pos(ADel, sToChange);
+ while i <> 0 do
+ begin
+ result := result + UTF8Copy(sToChange, 1, i-1) + AIns;
+ UTF8Delete(sToChange, 1, i+UTF8length(ADel)-1);
+ i := UTF8Pos(ADel, sToChange);
+ end;
+ result := result + sToChange;
+ end;
+
+begin
+ t := s;
+
+// Hack Alert #2: replace strange table chars with something we can actually see
+ //t := SubstituteChar(t, Chr(218), Char('+') ); // top-left corner
+ //t := SubstituteChar(t, Chr(196), Char('-') ); // horz row deviders
+ //t := SubstituteChar(t, Chr(194), Char('-') ); // centre top T connection
+ //t := SubstituteChar(t, Chr(191), Char('+') ); // top-right corner
+ //t := SubstituteChar(t, Chr(192), Char('+') ); // bot-left corner
+ //t := SubstituteChar(t, Chr(193), Char('-') ); // centre bottom inverted T
+ //t := SubstituteChar(t, Chr(197), Char('+') );
+ //t := SubstituteChar(t, Chr(179), Char('|') ); //
+ //t := SubstituteChar(t, Chr(195), Char('|') );
+ //t := SubstituteChar(t, Chr(180), Char('|') );
+ //t := SubstituteChar(t, Chr(217), Char('+') ); // bot-right corner
+
+ // it's cheaper to first check for the char than actually running full tiStrTran
+ // CodePage 437 (kind-of) to Unicode mapping
+ t := tiStrTran(t, Char(16), '>' );
+ t := tiStrTran(t, Char(17), '<' );
+ t := tiStrTran(t, Char($1f), '▼' );
+// if pos(t, Char(179)) > 0 then
+ t := tiStrTran(t, Char(179), '│' );
+// if pos(t, Char(180)) > 0 then
+ t := tiStrTran(t, Char(180), '┤' );
+// if pos(t, Char(191)) > 0 then
+ t := tiStrTran(t, Char(191), '┐' );
+// if pos(t, Char(192)) > 0 then
+ t := tiStrTran(t, Char(192), '└' );
+// if pos(t, Char(193)) > 0 then
+ t := tiStrTran(t, Char(193), '┴' );
+// if pos(t, Char(194)) > 0 then
+ t := tiStrTran(t, Char(194), '┬' );
+// if pos(t, Char(195)) > 0 then
+ t := tiStrTran(t, Char(195), '├' );
+// if pos(t, Char(196)) > 0 then
+ t := tiStrTran(t, Char(196), '─' );
+// if pos(t, Char(197)) > 0 then
+ t := tiStrTran(t, Char(197), '┼' );
+// if pos(t, Char(217)) > 0 then
+ t := tiStrTran(t, Char(217), '┘' );
+// if pos(t, Char(218)) > 0 then
+ t := tiStrTran(t, Char(218), '┌' );
+
+ FCanvas.DrawString(Point.X, Point.Y, t);
+ Point.x := Point.X + Canvas.Font.TextWidth(t);
+end;
+
+
+end.
diff --git a/docview/components/richtext/RichTextDisplayUnit.pas b/docview/components/richtext/RichTextDisplayUnit.pas
new file mode 100644
index 00000000..5d16ab54
--- /dev/null
+++ b/docview/components/richtext/RichTextDisplayUnit.pas
@@ -0,0 +1,416 @@
+Unit RichTextDisplayUnit;
+
+{$mode objfpc}{$H+}
+
+Interface
+
+uses
+ Classes
+ ,CanvasFontManager
+ ,RichTextStyleUnit
+ ,RichTextLayoutUnit
+ ;
+
+// Selection start and end should both be nil if no selection is to be applied
+Procedure DrawRichTextLayout( var FontManager: TCanvasFontManager;
+ Layout: TRichTextLayout;
+ const SelectionStart: PChar;
+ const SelectionEnd: PChar;
+ const StartLine: longint;
+ const EndLine: longint;
+ const StartPoint: TPoint );
+
+// Print as much of the given layout as will fit on the page,
+// starting at StartY and StartLine
+// EndY is set to the final Y output position used + 1.
+// EndLine is set to the last line printed + 1
+Procedure PrintRichTextLayout( var FontManager: TCanvasFontManager;
+ var Layout: TRichTextLayout;
+ const StartLine: longint;
+ var EndLine: longint;
+ const StartY: longint;
+ var EndY: longint );
+
+Implementation
+
+uses
+ SysUtils
+// ACLString, ACLUtility,
+ ,RichTextDocumentUnit
+ ,fpg_base
+ ,fpg_main
+ ,nvUtilities
+ ;
+
+// For the given point in the text, update selected if the point
+// is at start or end of selection
+// Returns true if changed
+function SelectionChange( P: PChar;
+ SelectionStart: PChar;
+ SelectionEnd: PChar;
+ var NextSelected: boolean ): boolean;
+begin
+ Result := false;
+ if P = SelectionStart then
+ begin
+ Result := true;
+ if SelectionStart < SelectionEnd then
+ // reached start of selection
+ NextSelected := true
+ else
+ // reached end
+ NextSelected := false;
+ end
+ else if P = SelectionEnd then
+ begin
+ Result := true;
+ if SelectionStart < SelectionEnd then
+ // reached end of selection
+ NextSelected := false
+ else
+ // reached start
+ NextSelected := true;
+ end;
+end;
+
+function InvertRGB( Arg: TfpgColor ): TfpgColor;
+begin
+ Result := fpgColorToRGB( Arg ); // in case it's a system color e.g. button face
+ Result := Result xor $ffffff; // now invert the RGB components
+end;
+
+// Draw a string at the given location with given color/selected state
+procedure DrawRichTextString( var FontManager: TCanvasFontManager; Layout: TRichTextLayout;
+ var X: longint; Y: longint; S: PChar; Len: longint; Selected: Boolean;
+ PenColor: TfpgColor; BackColor: TfpgColor );
+var
+ Point: TPoint;
+begin
+ProfileEvent('DEBUG: DrawRichTextString >>>');
+ if Len = 0 then
+ exit;
+
+ Point.X := X;
+ Point.Y := Y;
+
+ if Selected then
+ begin
+ FontManager.Canvas.Color := InvertRGB( BackColor );
+ FontManager.Canvas.TextColor := InvertRGB(PenColor);
+ end
+ else
+ begin
+ FontManager.Canvas.Color := BackColor;
+ FontManager.Canvas.TextColor := PenColor;
+ end;
+ if FontManager.Canvas.Color <> Layout.FRichTextSettings.DefaultBackgroundColor then
+ FontManager.Canvas.FillRectangle(x, y,
+ FontManager.Canvas.Font.TextWidth(s),
+ FontManager.Canvas.Font.Height);
+ FontManager.DrawString( Point, Len, S );
+ X := Point.X;
+ProfileEvent('DEBUG: DrawRichTextString <<<');
+end;
+
+var
+ // global, so that we don't reallocate every drawline
+ StringToDraw: String = '';
+
+// Draw the specified line at the specified
+// (physical) location
+Procedure DrawRichTextLine( var FontManager: TCanvasFontManager;
+ Layout: TRichTextLayout; SelectionStart: PChar; SelectionEnd: PChar;
+ Line: TLayoutLine; Start: TPoint );
+var
+ X, Y: longint;
+ Element: TTextElement;
+ StartedDrawing: boolean;
+ Style: TTextDrawStyle;
+ P: PChar;
+ NextP: PChar;
+ EndP: PChar;
+ BitmapIndex: longint;
+ Bitmap: TfpgImage;
+ BitmapRect: TRect;
+ TextBlockStart: PChar;
+ Selected: boolean;
+ NextSelected: boolean;
+ NewMarginX: longint;
+
+ procedure DrawTextBlock;
+ begin
+ DrawRichTextString( FontManager, Layout,
+ X, // value gets adjusted by the time it returns
+ Y, // value gets adjusted by the time it returns
+ PChar(StringToDraw),
+ Length(StringToDraw),
+ Selected,
+ Style.Color,
+ Style.BackgroundColor);
+ StringToDraw := '';
+ end;
+
+
+begin
+ProfileEvent('DEBUG: DrawRichTextLine >>>');
+ P := Line.Text;
+ EndP := Line.Text + Line.Length;
+
+ if P = EndP then
+ begin
+ // Empty line
+ exit;
+ end;
+
+ Selected := false;
+ if SelectionStart <= Line.Text then
+ // selection start is above.
+ Selected := true;
+ if SelectionEnd <= Line.Text then
+ // selection end is above.
+ Selected := not Selected;
+
+ StringToDraw := '';
+
+ Style := Line.Style;
+ FontManager.SetFont( Style.Font );
+ StartedDrawing := false;
+
+ TextBlockStart := P;
+
+ Y := Start.Y + Line.MaxDescender; // co-ordinates are from top/left, so do we need descender? [Graeme]
+
+ while P < EndP do
+ begin
+ Element := ExtractNextTextElement( P, NextP );
+
+ if SelectionChange( P,
+ SelectionStart,
+ SelectionEnd,
+ NextSelected ) then
+ begin
+ DrawTextBlock;
+ TextBlockStart := P;
+ Selected := NextSelected;
+ end;
+
+ case Element.ElementType of
+ teWordBreak,
+ teText,
+ teImage:
+ begin
+ if not StartedDrawing then
+ begin
+ // we haven't yet started drawing:
+ // so work out alignment
+ X := Start.X{ * FontWidthPrecisionFactor}
+ + Layout.GetStartX( Style, Line );
+ StartedDrawing := true;
+ end;
+
+ // Now do the drawing
+ if Element.ElementType = teImage then
+ begin
+ ProfileEvent('DEBUG: DrawRichTextLine - skipping image drawing (not implemented yet)');
+ DrawTextBlock;
+ TextBlockStart := NextP;
+
+ try
+ BitmapIndex := StrToInt( Element.Tag.Arguments );
+ except
+ BitmapIndex := -1;
+ end;
+ if Layout.IsValidBitmapIndex( BitmapIndex ) then
+ begin
+ Bitmap := Layout.Images.Item[BitmapIndex].Image;
+
+ BitmapRect.Left := X div FontWidthPrecisionFactor;
+ BitmapRect.Bottom := Start.Y;
+ BitmapRect.Right := Trunc(BitmapRect.Left
+ + Bitmap.Width
+ * Layout.HorizontalImageScale);
+ BitmapRect.Top := Trunc(BitmapRect.Bottom
+ + Bitmap.Height
+ * Layout.VerticalImageScale);
+
+ FontManager.Canvas.StretchDraw(BitmapRect.Left, BitMapRect.Top,
+ BitmapRect.Right-BitMapRect.Left, BitMapRect.Bottom-BitMapRect.Top, Bitmap);
+
+ inc( X, trunc( Bitmap.Width
+ * FontWidthPrecisionFactor
+ * Layout.HorizontalImageScale ) );
+ end;
+ end
+ else
+ begin
+ // character (or word break)
+ // build up the successive characters...
+ StringToDraw := StringToDraw + Element.Character;
+ end;
+ end;
+
+ teStyle:
+ begin
+ DrawTextBlock;
+ TextBlockStart := NextP;
+
+ if ( Element.Tag.TagType = ttItalicOff )
+ and ( faItalic in Style.Font.Attributes )
+ and ( not FontManager.IsFixed )
+ then
+ // end of italic; add a space
+ inc( X, FontManager.CharWidth( ' ' ) );
+
+ Layout.PerformStyleTag( Element.Tag, Style, X );
+ NewMarginX := ( Start.X + Style.LeftMargin ){ * FontWidthPrecisionFactor};
+ if NewMarginX > X then
+ begin
+ //skip across...
+ X := NewMarginX;
+ end;
+ end;
+ end;
+ P := NextP;
+ end;
+
+ DrawTextBlock;
+ProfileEvent('DEBUG: DrawRichTextLine <<<');
+end;
+
+Procedure DrawRichTextLayout( var FontManager: TCanvasFontManager;
+ Layout: TRichTextLayout;
+ const SelectionStart: PChar;
+ const SelectionEnd: PChar;
+ const StartLine: longint;
+ const EndLine: longint;
+ const StartPoint: TPoint );
+Var
+ Line: TLayoutLine;
+ LineIndex: longint;
+ Y: longint;
+ BottomOfLine: longint;
+begin
+ProfileEvent('DEBUG: DrawRichTextLayout >>>');
+ assert( StartLine >= 0 );
+ assert( StartLine <= Layout.FNumLines );
+ assert( EndLine >= 0 );
+ assert( EndLine <= Layout.FNumLines );
+ assert( StartLine <= EndLine );
+
+ if Layout.FNumLines = 0 then
+ // no text to draw
+ exit;
+
+ Y := StartPoint.Y + Layout.FRichTextSettings.Margins.Top;
+ LineIndex := 0;
+
+ repeat
+ Line := Layout.FLines^[ LineIndex ];
+ BottomOfLine := Y {+ Line.Height} + 1; // bottom pixel row is top + height + 1
+
+ if // the line is in the range to be drawn
+ ( LineIndex >= StartLine )
+ and ( LineIndex <= EndLine )
+
+ // and the line is within the cliprect
+ and ( BottomOfLine < FontManager.Canvas.GetClipRect.Bottom )
+ and ( Y >= FontManager.Canvas.GetClipRect.Top ) then
+ begin
+ // draw it. First decided whether selection is started or not.
+ DrawRichTextLine( FontManager,
+ Layout,
+ SelectionStart,
+ SelectionEnd,
+ Line,
+ Point( StartPoint.X, BottomOfLine ) );
+
+ end;
+ inc( Y, Line.Height );
+
+ { TODO 99 -oGraeme -cMUST FIX : Must remove this hard-coded value. It's just a test!!! }
+ // 4 is the Border Width of 2px times 2 borders.
+ if Y > (FontManager.Widget.Height-4) then
+ // past bottom of output canvas
+ break;
+
+ inc( LineIndex );
+
+ if LineIndex >= Layout.FNumLines then
+ // end of text
+ break;
+
+ until false;
+ProfileEvent('DEBUG: DrawRichTextLayout <<<');
+End;
+
+Procedure PrintRichTextLayout( var FontManager: TCanvasFontManager;
+ var Layout: TRichTextLayout;
+ const StartLine: longint;
+ var EndLine: longint;
+ const StartY: longint;
+ var EndY: longint );
+Var
+ Selected: boolean;
+ Line: TLayoutLine;
+ LineIndex: longint;
+
+ Y: longint;
+
+ BottomOfLine: longint;
+
+ LinesPrinted: longint;
+begin
+ assert( StartLine >= 0 );
+ assert( StartLine <= Layout.FNumLines );
+
+ if Layout.FNumLines = 0 then
+ // no text to draw
+ exit;
+
+ Y := StartY
+ - Layout.FRichTextSettings.Margins.Top;
+
+ Selected := false; // it's not going to change.
+
+ LinesPrinted := 0;
+
+ LineIndex := StartLine;
+
+ repeat
+ Line := TLayoutLine(Layout.FLines[ LineIndex ]);
+ BottomOfLine := Y - Line.Height + 1; // bottom pixel row is top - height + 1
+
+ if BottomOfLine < Layout.FRichTextSettings.Margins.Bottom then
+ // past bottom of page (less margin)
+ if LinesPrinted > 0 then
+ // stop, as long as we've printed at least 1 line
+ break;
+
+ // draw it
+ DrawRichTextLine( FontManager,
+ Layout,
+ nil,
+ nil,
+ Line,
+ Point( 0,
+ BottomOfLine ) );
+
+ dec( Y, Line.Height );
+
+ inc( LinesPrinted );
+
+ inc( LineIndex );
+
+ if LineIndex >= Layout.FNumLines then
+ // end of text
+ break;
+
+ until false;
+
+ EndY := Y;
+ EndLine := LineIndex;
+end;
+
+
+end.
+
diff --git a/docview/components/richtext/RichTextDocumentUnit.pas b/docview/components/richtext/RichTextDocumentUnit.pas
new file mode 100644
index 00000000..dd2f9a96
--- /dev/null
+++ b/docview/components/richtext/RichTextDocumentUnit.pas
@@ -0,0 +1,787 @@
+Unit RichTextDocumentUnit;
+
+{$mode objfpc}{$H+}
+// Declarations of tags, and parsing functions
+
+Interface
+
+uses
+ Classes
+ ,fpg_base
+ ;
+
+type
+ COUNTRYCODE = string[2];
+
+ TTagType = ( ttInvalid,
+ ttBold, ttBoldOff,
+ ttItalic, ttItalicOff,
+ ttUnderline, ttUnderlineOff,
+ ttFixedWidthOn, ttFixedWidthOff,
+ ttHeading1, ttHeading2, ttHeading3, ttHeadingOff,
+ ttColor, ttColorOff,
+ ttBackgroundColor, ttBackgroundColorOff,
+ ttRed, ttBlue, ttGreen, ttBlack,
+ ttWrap,
+ ttAlign,
+ ttBeginLink, ttEndLink,
+ ttSetLeftMargin, ttSetRightMargin,
+ ttImage,
+ ttFont, ttFontOff,
+ ttEnd );
+
+ TStandardColor = record
+ Name: string[ 32 ];
+ Color: TfpgColor;
+ end;
+
+ TTag = record
+ TagType: TTagType;
+ Arguments: string;
+ end;
+
+ TTextElementType = ( teText, // a character
+ teWordBreak,
+ teLineBreak, // end of para
+ teTextEnd,
+ teImage,
+ teStyle );
+
+ TTextElement = record
+ ElementType: TTextElementType;
+ Character: Char;
+ Tag: TTag;
+ end;
+
+ TTextAlignment = ( taLeft,
+ taRight,
+ taCenter );
+
+const
+ TagStr: array[ ttInvalid .. ttEnd ] of string =
+ (
+ '', //
+ 'b',
+ '/b',
+ 'i',
+ '/i',
+ 'u',
+ '/u',
+ 'tt',
+ '/tt',
+ 'h1',
+ 'h2',
+ 'h3',
+ '/h',
+ 'color',
+ '/color',
+ 'backcolor',
+ '/backcolor',
+ 'red',
+ 'blue',
+ 'green',
+ 'black',
+ 'wrap',
+ 'align',
+ 'link',
+ '/link',
+ 'leftmargin',
+ 'rightmargin',
+ 'image',
+ 'font',
+ '/font',
+ ''
+ );
+
+
+// Returns tag pointed to by TextPointer and
+// moves TextPointer to the first char after the tag.
+Function ExtractTag( Var TextPointer: PChar ): TTag;
+
+// Returns tag ending at TextPointer
+// (Expects textpointer is currently pointing at the >)
+// and moves TextPointer to the first char of the tag
+Function ExtractPreviousTag( const TextStart: PChar; Var TextPointer: PChar ): TTag;
+function ExtractNextTextElement( TextPointer: PChar; Var NextElement: PChar ): TTextElement;
+function ExtractPreviousTextElement( const TextStart: PChar; TextPointer: PChar; Var NextElement: PChar ): TTextElement;
+
+// Parse a color name or value (#hexval). Returns true if valid
+function GetTagColor( const ColorParam: string; var Color: TfpgColor ): boolean;
+
+function GetTagTextAlignment( const AlignParam: string;
+ const Default: TTextAlignment ): TTextAlignment;
+
+function GetTagTextWrap( const WrapParam: string ): boolean;
+
+// Search within a rich text document for the given text
+// if found, returns true, pMatch is set to the first match,
+// and MatchLength returns the length of the match
+// (which may be greater than the length of Text due to
+// to skipping tags)
+// if not found, returns false, pMatch is set to nil
+function RichTextFindString( pRichText: PChar;
+ const Text: string;
+ var pMatch: PChar;
+ var MatchLength: longint ): boolean;
+
+// Returns the start of the previous word,
+// or the current word if pStart is in the middle of the word
+function RichTextWordLeft( pRichText: PChar;
+ pStart: PChar ): PChar;
+
+// Returns the start of the next word.
+function RichTextWordRight( pStart: PChar ): PChar;
+
+// If pStart is in the middle of a word, then
+// returns true and sets the start and length of the word
+function RichTextWordAt( pRichText: PChar;
+ pStart: PChar;
+ Var pWordStart: PChar;
+ Var WordLength: longint ): boolean;
+
+// Copies plaintext of richtext starting at StartP
+// to the given buffer. Returns number of characters copied.
+// Buffer may be nil
+// If BufferLength is negative, it is effectively ignored
+function CopyPlainTextToBuffer( StartP: PChar;
+ EndP: PChar;
+ Buffer: PChar;
+ BufferLength: longint ): longint;
+
+Implementation
+
+uses
+// BseDOS, // for NLS/case mapping
+ SysUtils
+ ,ACLStringUtility
+ ;
+
+const
+ StandardColors: array[ 0..7 ] of TStandardColor =
+ (
+ ( Name : 'white' ; Color: clWhite ),
+ ( Name : 'black' ; Color: clBlack ),
+ ( Name : 'red' ; Color: clRed ),
+ ( Name : 'blue' ; Color: clBlue ),
+ ( Name : 'green' ; Color: clLime ),
+ ( Name : 'purple'; Color: clFuchsia ),
+ ( Name : 'yellow'; Color: clYellow ),
+ ( Name : 'cyan' ; Color: clAqua )
+ );
+
+Procedure ParseTag( const Text: string;
+ Var Tag: TTag );
+var
+ TagType: TTagType;
+ TagTypeText: string;
+ SpacePos: longint;
+begin
+ SpacePos := Pos( ' ', Text );
+ if SpacePos <> 0 then
+ begin
+ Tag.Arguments := trim( Copy( Text, SpacePos + 1, 255 ) );
+ TagTypeText := LowerCase( Copy( Text, 1, SpacePos - 1 ) );
+ end
+ else
+ begin
+ Tag.Arguments := ''; // to save time copying when not needed
+ TagTypeText := LowerCase( Text );
+ end;
+
+ for TagType := ttBold to ttEnd do
+ begin
+ if TagStr[ TagType ] = TagTypeText then
+ begin
+ Tag.TagType := TagType;
+ exit;
+ end;
+ end;
+
+ // not found
+ Tag.TagType := ttInvalid;
+end;
+
+var
+ TagText: string;
+ TagArgText: string;
+
+Function ExtractTag( Var TextPointer: PChar ): TTag;
+var
+ CurrentChar: Char;
+ TagTooLong: boolean;
+ InQuote: boolean;
+begin
+// assert( TextPointer[ 0 ] = '<' );
+ TagText := '';
+ TagTooLong := false;
+ InQuote := false;
+
+ repeat
+ CurrentChar := TextPointer^;
+
+ if ( CurrentChar = '>' )
+ and ( not InQuote ) then
+ begin
+ // found tag end.
+ if TagTooLong then
+ Result.TagType := ttInvalid
+ else
+ ParseTag( TagText, Result );
+ inc( TextPointer );
+ exit;
+ end;
+
+ if CurrentChar = #0 then
+ begin
+ // if we reach here we have reached the end of text
+ // during a tag. invalid tag.
+ Result.TagType := ttInvalid;
+ exit;
+ end;
+
+ if CurrentChar = CharDoubleQuote then
+ begin
+ if not InQuote then
+ begin
+ InQuote := true
+ end
+ else
+ begin
+ // Could be escaped quote ""
+// if (TextPointer + 1 )^ = DoubleQuote then
+ if ( TextPointer + 1 ) ^ = CharDoubleQuote then
+ begin
+ // yes it is
+ inc( TextPointer ); // skip second one
+ end
+ else
+ begin
+ // no, not an escaped quote
+ InQuote := false;
+ end;
+ end;
+
+ end;
+
+ if not TagTooLong then
+ if Length( TagText ) < 200 then
+ TagText := TagText + CurrentChar
+ else
+ TagTooLong := true; // but keep going until the end
+
+ inc( TextPointer );
+ until false;
+
+end;
+
+// Expects textpointer is currently pointing at the >
+Function ExtractPreviousTag( const TextStart: PChar;
+ Var TextPointer: PChar ): TTag;
+var
+ CurrentChar: Char;
+ TagTooLong: boolean;
+ InQuote: boolean;
+begin
+ TagText := '';
+ TagTooLong := false;
+ InQuote := false;
+
+ repeat
+ dec( TextPointer );
+ if TextPointer < TextStart then
+ begin
+ // if we reach here we have reached the end of text
+ // during a tag. invalid tag.
+ Result.TagType := ttInvalid;
+ exit;
+ end;
+ CurrentChar := TextPointer^;
+
+ if ( CurrentChar = '<' )
+ and ( not InQuote ) then
+ begin
+ // found tag end.
+ if TagTooLong then
+ Result.TagType := ttInvalid
+ else
+ ParseTag( TagText, Result );
+ exit;
+ end;
+
+ if CurrentChar = CharDoubleQuote then
+ begin
+ if not InQuote then
+ begin
+ InQuote := true
+ end
+ else
+ begin
+ // Could be escaped quote ""
+ if TextPointer <= TextStart then
+ begin
+ // start of text... somethin weird
+ InQuote := false;
+ end
+ else if ( TextPointer - 1 ) ^ = CharDoubleQuote then
+ begin
+ // yes it is
+ dec( TextPointer ); // skip second one
+ end
+ else
+ begin
+ // no, not an escaped quote
+ InQuote := false;
+ end;
+ end;
+
+ end;
+
+ if not TagTooLong then
+ if Length( TagText ) < 200 then
+ TagText := CurrentChar + TagText
+ else
+ TagTooLong := true; // but keep going until the end
+
+ until false;
+
+end;
+
+function ExtractNextTextElement( TextPointer: PChar; Var NextElement: PChar ): TTextElement;
+var
+ TheChar: Char;
+ NextChar: char;
+begin
+ with Result do
+ begin
+ TheChar := TextPointer^;
+ Character := TheChar;
+ inc( TextPointer );
+
+ case TheChar of
+ ' ': // ---- Space (word break) found ----
+ ElementType := teWordBreak;
+
+ #10, #13: // ---- End of line found ----
+ begin
+ ElementType := teLineBreak;
+ if TheChar = #13 then
+ begin
+ TheChar := TextPointer^;
+ if TheChar = #10 then
+ // skip CR following LF
+ inc( TextPointer );
+ end;
+ end;
+
+ #0: // ---- end of text found ----
+ ElementType := teTextEnd;
+
+ '<': // ---- tag found? ----
+ begin
+ NextChar := TextPointer^;
+ if NextChar = '<' then
+ begin
+ // no. just a literal <
+ ElementType := teText;
+ inc( TextPointer );
+ end
+ else
+ begin
+ Tag := ExtractTag( TextPointer );
+ if Tag.TagType = ttImage then
+ ElementType := teImage
+ else
+ ElementType := teStyle;
+ end;
+
+ end;
+
+ '>': // check - should be double
+ begin
+ ElementType := teText;
+ NextChar := TextPointer^;
+ if NextChar = '>' then
+ inc( TextPointer );
+ end;
+
+ else
+ ElementType := teText;
+ end;
+ end; // with
+ NextElement := TextPointer;
+end;
+
+function ExtractPreviousTextElement( const TextStart: PChar;
+ TextPointer: PChar;
+ Var NextElement: PChar ): TTextElement;
+var
+ TheChar: Char;
+ PreviousChar: Char;
+ FoundTag: boolean;
+begin
+ with Result do
+ begin
+ dec( TextPointer );
+ TheChar := TextPointer^;
+ Character := TheChar;
+ if TextPointer < TextStart then
+ begin
+ ElementType := teTextEnd;
+ exit;
+ end;
+
+ case TheChar of
+ ' ': // ---- Space (word break) found ----
+ ElementType := teWordBreak;
+
+ #10, #13: // ---- End of line found ----
+ begin
+ ElementType := teLineBreak;
+ if TheChar = #10 then
+ begin
+ dec( TextPointer );
+ TheChar := TextPointer^;
+ if TheChar = #13 then
+ begin
+ // skip CR preceeding LF
+ end
+ else
+ inc( TextPointer );
+ end;
+ end;
+
+ '>': // ---- tag found ----
+ begin
+ FoundTag := true;
+ if TextPointer > TextStart then
+ begin
+ PreviousChar := ( TextPointer - 1 )^;
+ if PreviousChar = '>' then
+ begin
+ // no. just a literal >
+ FoundTag := false;
+ ElementType := teText;
+ dec( TextPointer );
+ end
+ end;
+
+ if FoundTag then
+ begin
+ Tag := ExtractPreviousTag( TextStart, TextPointer );
+ if Tag.TagType = ttImage then
+ ElementType := teImage
+ else
+ ElementType := teStyle;
+ end;
+ end;
+
+ '<': // should be double
+ begin
+ ElementType := teText;
+ if TextPointer > TextStart then
+ begin
+ PreviousChar := TextPointer^;
+ if PreviousChar = '<' then
+ dec( TextPointer );
+ end;
+ end
+ else
+ ElementType := teText;
+ end;
+ end; // with
+ NextElement := TextPointer;
+end;
+
+function GetTagColor( const ColorParam: string;
+ var Color: TfpgColor ): boolean;
+var
+ ColorIndex: longint;
+begin
+ Result := false;
+ if ColorParam <> '' then
+ begin
+ if ColorParam[ 1 ] = '#' then
+ begin
+ try
+ Color := HexToInt( StrRightFrom( ColorParam, 2 ) );
+ Result := true;
+ except
+ end;
+ end
+ else
+ begin
+ for ColorIndex := 0 to High( StandardColors ) do
+ begin
+ if StringsSame( ColorParam, StandardColors[ ColorIndex ].Name ) then
+ begin
+ Color := StandardColors[ ColorIndex ].Color;
+ Result := true;
+ break;
+ end;
+ end;
+ end;
+ end;
+end;
+
+function GetTagTextAlignment( const AlignParam: string;
+ const Default: TTextAlignment ): TTextAlignment;
+begin
+ if StringsSame( AlignParam, 'left' ) then
+ Result := taLeft
+ else if StringsSame( AlignParam, 'center' ) then
+ Result := taCenter
+ else if StringsSame( AlignParam, 'right' ) then
+ Result := taRight
+ else
+ Result := Default;
+end;
+
+function GetTagTextWrap( const WrapParam: string ): boolean;
+begin
+ Result := StringsSame( WrapParam, 'yes' );
+end;
+
+function RichTextFindString( pRichText: PChar;
+ const Text: string;
+ var pMatch: PChar;
+ var MatchLength: longint ): boolean;
+var
+ P: PChar;
+ NextP: PChar;
+ Element: TTextElement;
+ pMatchStart: pchar;
+ pMatchStartNext: pchar;
+ MatchIndex: longint;
+ C: Char;
+begin
+ if Length( Text ) = 0 then
+ begin
+ // null string always matches
+ Result := true;
+ pMatch := pRichText;
+ MatchLength := 0;
+ exit;
+ end;
+
+ P := pRichText;
+ MatchIndex := 1;
+
+ // Now search, case insensitively
+ while true do
+ begin
+ Element := ExtractNextTextElement( P, NextP );
+
+ case Element.ElementType of
+ teTextEnd:
+ // end of text
+ break;
+
+ teImage,
+ teLineBreak:
+ // breaks a potential match
+ MatchIndex := 1;
+
+ teStyle:
+ ; // ignore, matches can continue
+
+ else
+ begin
+ if Uppercase(Element.Character) = UpperCase(Text[Matchindex]) then
+ begin
+ // found a match
+ if MatchIndex = 1 then
+ begin
+ pMatchStart := P; // store start of match
+ pMatchStartNext := NextP;
+ end;
+
+ inc( MatchIndex );
+ if MatchIndex > Length( Text ) then
+ begin
+ // found a complete match
+ Result := true;
+ pMatch := pMatchStart;
+ MatchLength := PCharDiff( P, pMatchStart )
+ + 1; // include this char
+ exit;
+ end;
+ end
+ else
+ begin
+ // not a match
+ if MatchIndex > 1 then
+ begin
+ // go back to start of match, + 1
+ NextP := pMatchStartNext;
+ MatchIndex := 1;
+ end;
+ end;
+ end;
+ end;
+
+ P := NextP;
+ end;
+
+ // no match found
+ Result := false;
+ pMatch := nil;
+ MatchLength := 0;
+end;
+
+function RichTextWordLeft( pRichText: PChar;
+ pStart: PChar ): PChar;
+Var
+ P: PChar;
+ NextP: PChar;
+ Element: TTextElement;
+begin
+ P := pStart;
+
+ // skip whitespace/tags...
+ Element := ExtractPreviousTextElement( pRichText, P, NextP );
+ P := NextP;
+ while Element.ElementType in [ teWordBreak, teLineBreak, teImage, teStyle ] do
+ begin
+ Element := ExtractPreviousTextElement( pRichText, P, NextP );
+ P := NextP;
+ end;
+ if Element.ElementType = teTextEnd then
+ begin
+ Result := P;
+ // out of text
+ exit;
+ end;
+
+ // back to start of word, skip text/tags
+ while true do
+ begin
+ Element := ExtractPreviousTextElement( pRichText, P, NextP );
+ if not ( Element.ElementType in [ teText, teStyle ] ) then
+ break;
+ P := NextP;
+ end;
+ Result := P;
+end;
+
+function RichTextWordRight( pStart: PChar ): PChar;
+Var
+ P: PChar;
+ NextP: PChar;
+ Element: TTextElement;
+begin
+ P := pStart;
+
+ // skip text/tags...
+ Element := ExtractNextTextElement( P, NextP );
+ while Element.ElementType in [ teStyle, teText ] do
+ begin
+ P := NextP;
+ Element := ExtractNextTextElement( P, NextP );
+ end;
+ if Element.ElementType <> teTextEnd then
+ begin
+ // skip whitespace
+ Element := ExtractNextTextElement( P, NextP );
+ while Element.ElementType in [ teWordBreak, teLineBreak, teImage, teStyle ] do
+ begin
+ P := NextP;
+ Element := ExtractNextTextElement( P, NextP );
+ end;
+ end;
+
+ Result := P;
+end;
+
+function RichTextWordAt( pRichText: PChar;
+ pStart: PChar;
+ Var pWordStart: PChar;
+ Var WordLength: longint ): boolean;
+Var
+ P: PChar;
+ NextP: PChar;
+ Element: TTextElement;
+ pWordEnd: PChar;
+begin
+ P := pStart;
+ Element := ExtractNextTextElement( P, NextP );
+ if not ( Element.ElementType in [ teStyle, teText ] ) then
+ begin
+ // not in a word.
+ result := false;
+ pWordStart := nil;
+ WordLength := 0;
+ exit;
+ end;
+ // find end of the word
+ while Element.ElementType in [ teStyle, teText ] do
+ begin
+ P := NextP;
+ Element := ExtractNextTextElement( P, NextP );
+ end;
+ pWordEnd := P;
+
+ P := pStart;
+ Element := ExtractPreviousTextElement( pRichText, P, NextP );
+ while Element.ElementType in [ teStyle, teText ] do
+ begin
+ P := NextP;
+ Element := ExtractPreviousTextElement( pRichText, P, NextP );
+ end;
+ pWordStart := P;
+ WordLength := PCharDiff( pWordEnd, pWordStart );
+ Result := true;
+end;
+
+function CopyPlainTextToBuffer( StartP: PChar;
+ EndP: PChar;
+ Buffer: PChar;
+ BufferLength: longint ): longint;
+var
+ Q: PChar;
+ EndQ: Pchar;
+ P: PChar;
+ NextP: PChar;
+ Element: TTextElement;
+begin
+ P := StartP;
+ Q := Buffer;
+ EndQ := Buffer + BufferLength;
+
+ while P < EndP do
+ begin
+ Element := ExtractNextTextElement( P, NextP );
+ case Element.ElementType of
+ teText, teWordBreak:
+ begin
+ // copy char
+ if Buffer <> nil then
+ Q[ 0 ] := Element.Character;
+ inc( Q );
+ end;
+
+ teLineBreak:
+ begin
+ if Buffer <> nil then
+ Q[ 0 ] := #13;
+ inc( Q );
+ if Q = EndQ then
+ // end of buffer
+ break;
+
+ if Buffer <> nil then
+ Q[ 0 ] := #10;
+ inc( Q );
+ end;
+ end;
+
+ if Q = EndQ then
+ // end of buffer
+ break;
+
+ P := NextP;
+ end;
+ result := PCharDiff( Q, Buffer );
+end;
+
+Initialization
+End.
diff --git a/docview/components/richtext/RichTextLayoutUnit.pas b/docview/components/richtext/RichTextLayoutUnit.pas
new file mode 100644
index 00000000..97ffa131
--- /dev/null
+++ b/docview/components/richtext/RichTextLayoutUnit.pas
@@ -0,0 +1,1018 @@
+Unit RichTextLayoutUnit;
+
+{$mode objfpc}{$H+}
+
+// Dynamically created layout class.
+// Represents a laid out rich text document
+
+Interface
+
+Uses
+ Classes,
+ CanvasFontManager,
+ RichTextDocumentUnit, RichTextStyleUnit,
+ fpg_imagelist;
+
+Type
+ TLayoutLine = record
+ Text: PChar;
+ Length: longint;
+ Height: longint;
+ Width: longint;
+ MaxDescender: longint;
+ MaxTextHeight: longint; // maximum height of text, doesn't include images
+ LinkIndex: longint; // link index at start of line, if any
+ Style: TTextDrawStyle;
+ Wrapped: boolean;
+ end;
+
+
+ TLinesArray = array[ 0..0 ] of TLayoutLine;
+
+
+ TTextPosition =
+ (
+ tpAboveTextArea,
+ tpAboveText,
+ tpWithinText,
+ tpBelowText,
+ tpBelowTextArea
+ );
+
+
+ // forward declaration
+ TRichTextLayout = class;
+
+
+// TLinkEvent = procedure( Sender: TRichTextLayout; Link: string ) of object;
+
+
+ TRichTextLayout = class(TObject)
+ Protected
+ FFontManager: TCanvasFontManager;
+ FText: PChar;
+ FImages: TfpgImageList;
+ FAllocatedNumLines: Longint;
+ FLayoutWidth: longint; // The target width for the layout. Used for centreing/right align
+ FWidth: longint; // The actual width of the text. May be wider due to unaligned
+ // parts or bitmaps or width so small individual characters don't fit.
+ FHeight: longint;
+ FLinks: TStringList;
+ FHorizontalImageScale: double;
+ FVerticalImageScale: double;
+ public
+ // Internal layout data
+ FLines: ^TLinesArray;
+ FNumLines: longint;
+ FRichTextSettings: TRichTextSettings;
+ // Drawing functions
+ Procedure PerformStyleTag( Const Tag: TTag;
+ Var Style: TTextDrawStyle;
+ const X: longint );
+ function GetElementWidth( Element: TTextElement ): longint;
+ // Queries
+ Function GetStartX( Style: TTextDrawStyle;
+ Line: TLayoutLine ): longint;
+ Procedure GetXFromOffset( const Offset: longint;
+ const LineIndex: longint;
+ Var X: longint );
+ Procedure GetOffsetFromX( const XToFind: longint;
+ const LineIndex: longint;
+ Var Offset: longint;
+ Var Link: string );
+ function FindPoint( XToFind, YToFind: longint;
+ Var LineIndex: longint;
+ Var Offset: longint;
+ Var Link: string ): TTextPosition;
+ function GetLineFromCharIndex( Index: longint ): longint;
+ function GetOffsetFromCharIndex( Index: longint;
+ Line: longint ): longint;
+ function GetLinePosition( Line: longint ): longint;
+ function GetLineFromPosition( YToFind: longint;
+ Var LineIndex: longint;
+ Var Remainder: longint ): TTextPosition;
+ // Layout functions
+ Procedure AddLineStart( Const Line: TLayoutLine );
+ Procedure CheckFontHeights( Var Line: TLayoutLine );
+ Procedure Layout;
+ function IsValidBitmapIndex( Index: longint ): boolean;
+ // property handlers
+ Function GetCharIndex( P: PChar ): longint;
+ Function GetTextEnd: longint;
+ Public
+ constructor Create( Text: PChar; Images: TfpgImageList; RichTextSettings: TRichTextSettings; FontManager: TCanvasFontManager; Width: longint );
+ Destructor Destroy; Override;
+ property TextEnd: longint read GetTextEnd;
+ function LinkFromIndex( const CharIndexToFind: longint): string;
+ property Images: TfpgImageList read FImages;
+ property Width: longint read FWidth;
+ property Height: longint read FHeight;
+ property HorizontalImageScale: double read FHorizontalImageScale;
+ property VerticalImageScale: double read FVerticalImageScale;
+ End;
+
+
+Implementation
+
+
+Uses
+ SysUtils
+// PMWin, BseDos, Dos, ClipBrd, Printers,
+// ACLUtility,
+ ,ACLStringUtility
+// ACLString,
+// ControlScrolling;
+ ,nvUtilities
+ ,fpg_main
+ ;
+
+Function TRichTextLayout.GetTextEnd: longint;
+begin
+ Result := StrLen( FText );
+end;
+
+// Create a layout of the specified rich text.
+constructor TRichTextLayout.Create(Text: PChar; Images: TfpgImageList;
+ RichTextSettings: TRichTextSettings; FontManager: TCanvasFontManager;
+ Width: longint);
+var
+ DefaultFontSpec: TFontSpec;
+Begin
+ProfileEvent('DEBUG: TRichTextLayout.Create >>>>');
+ Inherited Create;
+ FRichTextSettings := RichTextSettings;
+ FImages := Images;
+ FText := Text;
+ FAllocatedNumLines := 10;
+ProfileEvent('DEBUG: TRichTextLayout.Create 1 of 4');
+ GetMem( FLines, FAllocatedNumLines * sizeof( TLayoutLine ) );
+ FNumLines := 0;
+ FLinks := TStringList.Create;
+ FLinks.Duplicates := dupIgnore;
+ FFontManager := FontManager;
+ FLayoutWidth := Width;
+ProfileEvent('DEBUG: TRichTextLayout.Create 2');
+ FHorizontalImageScale := 1;
+ FVerticalImageScale := 1;
+ //FHorizontalImageScale := FFontManager.Canvas.HorizontalResolution
+ // / Screen.Canvas.HorizontalResolution;
+ //FVerticalImageScale := FFontManager.Canvas.VerticalResolution
+ // / Screen.Canvas.VerticalResolution;
+
+ // use normal font for default font when specified fonts can't be found
+ FPGuiFontToFontSpec( RichTextSettings.NormalFont, DefaultFontSpec );
+ProfileEvent('DEBUG: TRichTextLayout.Create 3');
+ FFontManager.DefaultFontSpec := DefaultFontSpec;
+ProfileEvent('DEBUG: TRichTextLayout.Create 4');
+ Layout;
+ProfileEvent('DEBUG: TRichTextLayout.Create <<<<');
+End;
+
+Destructor TRichTextLayout.Destroy;
+Begin
+ FreeMem( Flines, FAllocatedNumLines * sizeof( TLayoutLine ) );
+ FLines := nil;
+ FLinks.Free;
+ Inherited Destroy;
+End;
+
+Procedure TRichTextLayout.AddLineStart( Const Line: TLayoutLine );
+var
+ NewAllocation: longint;
+begin
+ if FNumLines >= FAllocatedNumLines then
+ begin
+ // reallocate the array twice the size
+ NewAllocation := FAllocatedNumLines * 2;
+ FLines := ReAllocMem( FLines,
+// FAllocatedNumLines * sizeof( TLayoutLine ),
+ NewAllocation * sizeof( TLayoutLine ) );
+ FAllocatedNumLines := NewAllocation;
+ end;
+ FLines^[ FNumLines ] := Line;
+ inc( FNumLines );
+ ProfileEvent(' DEBUG: TRichTextLayout.AddLineStart: FNumLines =' + intToStr(FNumLines));
+end;
+
+Procedure TRichTextLayout.PerformStyleTag( Const Tag: TTag;
+ Var Style: TTextDrawStyle;
+ const X: longint );
+begin
+ProfileEvent('DEBUG: TRichTextLayout.PerformStyleTag >>>');
+ ApplyStyleTag( Tag,
+ Style,
+ FFontManager,
+ FRichTextSettings,
+ X );
+ProfileEvent('DEBUG: TRichTextLayout.PerformStyleTag <<<');
+end;
+
+// Check the current font specifications and see if the
+// give line needs updating for max height/descender
+Procedure TRichTextLayout.CheckFontHeights( Var Line: TLayoutLine );
+var
+ FontHeight: longint;
+ Descender: longint;
+begin
+ FontHeight := FFontManager.CharHeight;
+ Descender := FFontManager.CharDescender;
+
+ if FontHeight > Line.Height then
+ Line.Height := FontHeight;
+
+ if FontHeight > Line.MaxTextHeight then
+ Line.MaxTextHeight := FontHeight;
+
+ if Descender > Line.MaxDescender then
+ Line.MaxDescender := Descender;
+end;
+
+function TRichTextLayout.IsValidBitmapIndex( Index: longint ): boolean;
+begin
+ if FImages = nil then
+ Result := false
+ else if FImages.Count = 0 then
+ Result := false
+ else
+ Result := Between( Index, 0, FImages.Count - 1 );
+end;
+
+// Main procedure: reads through the whole text currently stored
+// and breaks up into lines - each represented as a TLayoutLine in
+// the array FLines[ 0.. FNumLines ]
+Procedure TRichTextLayout.Layout;
+Var
+ CurrentLine: TLayoutLine;
+ CurrentLinkIndex: longint;
+ WrapX: longint; // X to wrap at
+ WordX: longint; // width of word so far
+ P: PChar;
+ NextP: PChar;
+ NextP2: PChar;
+ WordStart: PChar;
+ WordStarted: boolean; // if false, just skipping spaces..
+ WordStartX: longint; // X position of word start
+ LineWordsCompleted: longint; // how many words draw so far this line
+ CurrentElement: TTextElement;
+ NextElement: TTextElement;
+ CurrentCharWidth: longint;
+ Style: TTextDrawStyle;
+ DisplayedCharsSinceFontChange: boolean;
+ BitmapIndex: longint;
+ Bitmap: TfpgImage;
+ BitmapHeight: longint;
+ OnBreak: boolean;
+ DoWrap: boolean;
+
+ // Nested procedure
+ Procedure DoLine( EndPoint: PChar; NextLine: PChar; EndX: longint );
+ begin
+ // check if the max font
+ // height needs updating for the last string of the line
+ CheckFontHeights( CurrentLine );
+ inc( FHeight, CurrentLine.Height );
+ CurrentLine.Length := PCharDiff( EndPoint, CurrentLine.Text );
+ CurrentLine.Width := EndX;
+ if CurrentLine.Width > FWidth then
+ FWidth := CurrentLine.Width;
+ assert( CurrentLine.Height > 0 ); // we must have set the line height!
+ AddLineStart( CurrentLine );
+ CurrentLine.Text := NextLine;
+ CurrentLine.Style := Style;
+ CurrentLine.Height := 0;
+ CurrentLine.MaxDescender := 0;
+ CurrentLine.MaxTextHeight := 0;
+ CurrentLine.Width := 0;
+ CurrentLine.LinkIndex := CurrentLinkIndex;
+ CurrentLine.Wrapped := false;
+ assert( CurrentLinkIndex >= -1 );
+ assert( CurrentLinkIndex < FLinks.Count );
+ WordStartX := Style.LeftMargin{ * FontWidthPrecisionFactor};
+ // next line
+ // reset words completed count
+ LineWordsCompleted := 0;
+ WordStarted := false;
+ end;
+
+begin
+ProfileEvent('DEBUG: TRichTextLayout.Layout >>>>');
+ FNumLines := 0;
+ FWidth := FRichTextSettings.Margins.Left;
+ FHeight := FRichTextSettings.Margins.Top;
+ Style := GetDefaultStyle( FRichTextSettings );
+ ApplyStyle( Style, FFontManager );
+ CurrentLinkIndex := -1;
+ P := FText; // P is the current search position
+ CurrentLine.Text := P;
+ CurrentLine.Style := Style;
+ CurrentLine.Height := 0;
+ CurrentLine.MaxDescender := 0;
+ CurrentLine.MaxTextHeight := 0;
+ CurrentLine.Width := 0;
+ CurrentLine.LinkIndex := -1;
+ CurrentLine.Wrapped := false;
+ WordStartX := Style.LeftMargin{ * FontWidthPrecisionFactor};
+ WordX := 0;
+ WrapX := FLayoutWidth - (FRichTextSettings.Margins.Right{ * FontWidthPrecisionFactor});
+ LineWordsCompleted := 0;
+ WordStarted := false;
+ DisplayedCharsSinceFontChange := false;
+
+ repeat
+ CurrentElement := ExtractNextTextElement( P, NextP );
+ assert( NextP > P );
+ OnBreak := false;
+ case CurrentElement.ElementType of
+ teWordBreak:
+ begin
+ CurrentCharWidth := FFontManager.CharWidth( ' ' );
+ OnBreak := true;
+ end;
+
+ teLineBreak:
+ begin
+ DoLine( P, NextP, WordStartX + WordX );
+
+ // remember start of line
+ WordStart := NextP;
+ WordX := 0;
+
+ P := NextP;
+
+ continue;
+ end;
+
+ teTextEnd:
+ begin
+ DoLine( P, NextP, WordStartX + WordX );
+
+ // end of text, done
+ break;
+ end;
+
+ teImage:
+ begin
+ BitmapHeight := 0;
+ try
+ BitmapIndex := StrToInt( CurrentElement.Tag.Arguments );
+ except
+ BitmapIndex := -1;
+ end;
+ Bitmap := nil;
+ if IsValidBitmapIndex( BitmapIndex ) then
+ begin
+ Bitmap := FImages.Item[BitmapIndex].Image;
+ CurrentCharWidth := Trunc(Bitmap.Width * FontWidthPrecisionFactor * FHorizontalImageScale);
+ WordStarted := true;
+ BitmapHeight := Trunc(Bitmap.Height * FVerticalImageScale);
+ end;
+
+ end;
+
+ teText:
+ begin
+ // Normal (non-leading-space) character
+ CurrentCharWidth := FFontManager.CharWidth( CurrentElement.Character );
+ WordStarted := true;
+ end;
+
+ teStyle:
+ begin
+ case CurrentElement.Tag.TagType of
+ ttBeginLink:
+ begin
+ CurrentLinkIndex := FLinks.Add( CurrentElement.Tag.Arguments );
+ P := NextP;
+ continue;
+ end;
+
+ ttEndLink:
+ begin
+ CurrentLinkIndex := -1;
+ P := NextP;
+ continue;
+ end;
+
+ ttSetLeftMargin: // SPECIAL CASE... could affect display immediately
+ begin
+ PerformStyleTag( CurrentElement.Tag, Style, WordstartX + WordX );
+ if Style.LeftMargin {* FontWidthPrecisionFactor} < WordStartX then
+ begin
+ // we're already past the margin being set
+ if pos( 'breakifpast', CurrentElement.Tag.Arguments ) > 0 then
+ begin
+ // this argument means, do a line break
+ // if the margin is already past
+ // Seems unusual for most purposes, but needed for IPF rendering.
+ DoLine( P, NextP, WordStartX + WordX );
+
+ // remember start of line
+ WordStart := NextP;
+ WordX := 0;
+
+ P := NextP;
+
+ continue;
+ end;
+
+ // so ignore it for now.
+ P := NextP;
+ continue;
+ end;
+
+ // skip across to the new margin
+ CurrentCharWidth := (Style.LeftMargin {* FontWidthPrecisionFactor})
+ - WordStartX - WordX;
+ // BUT! Don't treat it as a space, because you would not
+ // expect wrapping to take place in a margin change...
+ // at least not for IPF :)
+
+ end; { teSetLeftMargin }
+
+ else
+ begin
+ // before processing the tag see if font height needs updating
+ if DisplayedCharsSinceFontChange then
+ CheckFontHeights( CurrentLine );
+
+ if ( CurrentElement.Tag.TagType = ttItalicOff )
+ and ( faItalic in Style.Font.Attributes ) then
+ begin
+ if not FFontManager.IsFixed then
+ begin
+ // end of italic; add a space
+ inc( WordX, FFontManager.CharWidth( ' ' ) );
+ end;
+ end;
+
+ PerformStyleTag( CurrentElement.Tag,
+ Style,
+ WordX );
+
+ DisplayedCharsSinceFontChange := false;
+ P := NextP;
+ continue; // continue loop
+ end;
+ end;
+
+ end
+
+ end;
+
+ if OnBreak then
+ begin
+ // we just processed a space
+ if WordStarted then
+ begin
+ DisplayedCharsSinceFontChange := true;
+ // remember that we have now completed a word on this line
+ inc( LineWordsCompleted );
+ WordStarted := false;
+
+ // Add the word width, and the space width,
+ // to get the start of the next word
+ inc( WordStartX, WordX + CurrentCharWidth );
+ WordX := 0;
+
+ // remember the start of the next word
+ WordStart := NextP;
+
+ P := NextP;
+
+ continue;
+ end;
+ // else - starting spaces - fall through like normal char
+ end;
+
+ // if we're still going here we have a normal char
+ // (or leading spaces)
+ if not Style.Wrap then
+ begin
+ // No alignment
+ // We don't care about how wide it gets
+ inc( WordX, CurrentCharWidth );
+ DisplayedCharsSinceFontChange := true;
+
+ if CurrentElement.ElementType = teImage then
+ if Bitmap <> nil then
+ if BitmapHeight > CurrentLine.Height then
+ CurrentLine.Height := BitmapHeight;
+
+ P := NextP;
+ continue;
+ end;
+
+ DoWrap := false;
+
+ // Calculate position of end of character
+ // see if char would exceed width
+ if (WordStartX + WordX + CurrentCharWidth) >= WrapX then
+ begin
+ // reached right hand side before finding end of word
+ if LineWordsCompleted > 0 then
+ // always wrap after at least one word displayed
+ DoWrap := true
+ else if not FRichTextSettings.AtLeastOneWordBeforeWrap then
+ // only wrap during the first word, if the "at least 1 word" flag is not set.
+ DoWrap := true;
+ end;
+
+ if DoWrap then
+ begin
+ if LineWordsCompleted = 0 then
+ begin
+ // the first word did not fit on the line. so draw
+ // as much as will fit
+ if WordX = 0 then
+ begin
+ // even the first char doesn't fit,
+ // but draw it anyway (otherwise, infinite loop)
+ NextElement := ExtractNextTextElement( NextP, NextP2 );
+ if NextElement.ElementType <> teLineBreak then
+ // there is still more on the line...
+ CurrentLine.Wrapped := true
+ else
+ // the line ends after this one char or image, we can skip the line end
+ NextP := NextP2;
+
+ if CurrentElement.ElementType = teImage then
+ begin
+ // the only thing on the line is the image. so check height
+ if Bitmap <> nil then
+ if BitmapHeight > CurrentLine.Height then
+ CurrentLine.Height := BitmapHeight;
+ end;
+
+ DoLine( NextP, NextP, WordStartX + WordX + CurrentCharWidth );
+ WordStart := NextP;
+ WordX := 0;
+ end
+ else
+ begin
+ CurrentLine.Wrapped := true;
+ // at least 1 char fits
+ // so draw up to, but not including this char
+ DoLine( P,
+ P,
+ WordStartX + WordX );
+ WordStart := P;
+ WordX := CurrentCharWidth;
+ end;
+ end
+ else
+ begin
+ // Normal wrap; at least one word fitted on the line
+ CurrentLine.Wrapped := true;
+
+ // take the width of the last space of the
+ // previous word off the line width
+ DoLine( WordStart, // current line ends at start of this word
+ WordStart, // next line starts at start of this word
+ WordStartX - FFontManager.CharWidth( ' ' ) );
+ if CurrentElement.ElementType = teImage then
+ if Bitmap <> nil then
+ if BitmapHeight > CurrentLine.Height then
+ CurrentLine.Height := BitmapHeight;
+
+ // do NOT reset WordX to zero; as we are continuing
+ // from partway thru the word on the next line.
+ inc( WordX, CurrentCharWidth );
+ end;
+ WordStarted := true; // by definition, for wrapping
+ end
+ else
+ begin
+ // Character fits.
+ inc( WordX, CurrentCharWidth );
+ DisplayedCharsSinceFontChange := true;
+ if CurrentElement.ElementType = teImage then
+ if Bitmap <> nil then
+ if BitmapHeight > CurrentLine.Height then
+ CurrentLine.Height := BitmapHeight;
+ end;
+
+ P := NextP;
+ until false; // loop is exited by finding end of text
+
+ inc( FHeight, FRichTextSettings.Margins.Bottom );
+ProfileEvent('DEBUG: TRichTextLayout.Layout <<<<');
+End;
+
+Function TRichTextLayout.GetStartX( Style: TTextDrawStyle;
+ Line: TLayoutLine ): longint;
+var
+ SpaceOnLine: longint;
+begin
+ case Style.Alignment of
+ taLeft:
+ Result := Style.LeftMargin * FontWidthPrecisionFactor;
+
+ taRight:
+ Result := Style.LeftMargin * FontWidthPrecisionFactor
+ + FLayoutWidth
+ - Style.RightMargin * FontWidthPrecisionFactor
+ - Line.Width;
+
+ taCenter:
+ begin
+ // |<------layout width------------------>|
+ // | |
+ // |<-lm->[aaaaaaaaaaaaaaa]<-space-><-rm->|
+ // |<-----line width------> |
+ // space = layoutw-rm-linew
+ SpaceOnLine := FLayoutWidth
+ - Style.RightMargin * FontWidthPrecisionFactor
+ - Line.Width; // Note: line width includes left margin
+ Result := Style.LeftMargin * FontWidthPrecisionFactor
+ + SpaceOnLine div 2;
+ end;
+ end;
+end;
+
+Procedure TRichTextLayout.GetOffsetFromX( const XToFind: longint;
+ const LineIndex: longint;
+ Var Offset: longint;
+ Var Link: string );
+Var
+ X: longint;
+ P: PChar;
+ NextP: PChar;
+ EndP: PChar;
+ Element: TTextElement;
+ CurrentLink: string;
+ Line: TLayoutLine;
+ Style: TTextDrawStyle;
+ NewMarginX: longint;
+ StartedDrawing: boolean;
+begin
+ Line := TLayoutLine(FLines[ LineIndex ]);
+ P := Line.Text;
+ EndP := Line.Text + Line.Length;
+
+ Style := Line.Style;
+ FFontManager.SetFont( Style.Font );
+
+ StartedDrawing := false;
+
+ Link := '';
+ if Line.LinkIndex <> -1 then
+ CurrentLink := FLinks[ Line.LinkIndex ]
+ else
+ CurrentLink := '';
+
+ while P < EndP do
+ begin
+ Element := ExtractNextTextElement( P, NextP );
+
+ case Element.ElementType of
+ teWordBreak,
+ teText,
+ teImage:
+ begin
+ if not StartedDrawing then
+ begin
+ // we haven't yet started drawing:
+ // so work out alignment
+ X := GetStartX( Style, Line );
+
+ if X div FontWidthPrecisionFactor
+ > XToFind then
+ begin
+ // found before the start of the line
+ // don't set link
+ Offset := 0;
+ exit;
+ end;
+
+ StartedDrawing := true;
+
+ end;
+
+ // Now find out how wide the thing is
+ inc( X, GetElementWidth( Element ) );
+
+ if X div FontWidthPrecisionFactor
+ > XToFind then
+ begin
+ // found
+ Offset := PCharDiff( P, Line.Text );
+ Link := CurrentLink;
+ exit;
+ end;
+
+ end;
+
+ teStyle:
+ case Element.Tag.TagType of
+ ttBeginLink:
+ CurrentLink := Element.Tag.Arguments;
+ ttEndLink:
+ CurrentLink := '';
+ else
+ begin
+ if ( Element.Tag.TagType = ttItalicOff )
+ and ( faItalic in Style.Font.Attributes )
+ and ( not FFontManager.IsFixed ) then
+ // end of italic; add a space
+ inc( X, FFontManager.CharWidth( ' ' ) );
+
+ PerformStyleTag( Element.Tag,
+ Style,
+ X );
+ NewMarginX := Style.LeftMargin * FontWidthPrecisionFactor;
+ if NewMarginX > X then
+ begin
+ //skip across...
+ X := NewMarginX;
+ end;
+ end;
+ end;
+ end;
+
+ P := NextP;
+ end;
+ Offset := Line.Length;
+end;
+
+Procedure TRichTextLayout.GetXFromOffset( const Offset: longint;
+ const LineIndex: longint;
+ Var X: longint );
+Var
+ P: PChar;
+ NextP: PChar;
+ EndP: PChar;
+ Element: TTextElement;
+ StartedDrawing: boolean;
+ Line: TLayoutLine;
+ Style: TTextDrawStyle;
+ NewMarginX: longint;
+begin
+ Line := TLayoutLine(FLines[ LineIndex ]);
+ P := Line.Text;
+ EndP := Line.Text + Line.Length;
+
+ Style := Line.Style;
+ FFontManager.SetFont( Style.Font );
+
+ StartedDrawing := false;
+
+ while P < EndP do
+ begin
+ Element := ExtractNextTextElement( P, NextP );
+
+ case Element.ElementType of
+ teWordBreak,
+ teText,
+ teImage:
+ begin
+ if not StartedDrawing then
+ begin
+ // we haven't yet started drawing:
+ // so work out alignment
+ X := GetStartX( Style, Line );
+ StartedDrawing := true;
+ end;
+
+ if GetCharIndex( P ) - GetCharIndex( Line.Text ) >= Offset then
+ begin
+ X := X div FontWidthPrecisionFactor;
+ // found
+ exit;
+ end;
+
+ // Now find out how wide the thing is
+ inc( X, GetElementWidth( Element ) );
+
+ end;
+
+ teStyle:
+ begin
+ if ( Element.Tag.TagType = ttItalicOff )
+ and ( faItalic in Style.Font.Attributes )
+ and ( not FFontManager.IsFixed ) then
+ // end of italic; add a space
+ inc( X, FFontManager.CharWidth( ' ' ) );
+
+ PerformStyleTag( Element.Tag,
+ Style,
+ X );
+
+ NewMarginX := Style.LeftMargin * FontWidthPrecisionFactor;
+ if NewMarginX > X then
+ begin
+ //skip across...
+ X := NewMarginX;
+ end;
+ end;
+ end;
+
+ P := NextP;
+ end;
+ // went thru the whole line without finding the point,
+ if not StartedDrawing then
+ X := GetStartX( Style, Line );
+
+ X := X div FontWidthPrecisionFactor;
+end;
+
+function TRichTextLayout.GetLineFromPosition( YToFind: longint;
+ Var LineIndex: longint;
+ Var Remainder: longint ): TTextPosition;
+var
+ Y: longint;
+ LineHeight: longint;
+begin
+ LineIndex := 0;
+ Remainder := 0;
+
+ Y := FRichTextSettings.Margins.Top;
+
+ if YToFind < Y then
+ begin
+ Result := tpAboveText;
+ exit;
+ end;
+
+ while LineIndex < FNumLines do
+ begin
+ LineHeight := TLayoutLine(FLines[ LineIndex ]).Height;
+ if ( YToFind >= Y )
+ and ( YToFind < Y + LineHeight ) then
+ begin
+ // YToFind is within the line
+ Result := tpWithinText;
+ Remainder := YToFind - Y;
+ exit;
+ end;
+
+ inc( Y, TLayoutLine(FLines[ LineIndex ]).Height );
+ inc( LineIndex );
+ end;
+
+ LineIndex := FNumLines - 1;
+ Remainder := TLayoutLine(FLines[ LineIndex ]).Height;
+
+ Result := tpBelowText;
+end;
+
+function TRichTextLayout.FindPoint( XToFind, YToFind: longint;
+ Var LineIndex: longint;
+ Var Offset: longint;
+ Var Link: string ): TTextPosition;
+var
+ Remainder: longint;
+begin
+ Link := '';
+ Result := GetLineFromPosition( YToFind,
+ LineIndex,
+ Remainder );
+ case Result of
+ tpAboveText:
+ begin
+ Offset := 0;
+ exit;
+ end;
+
+ tpBelowText:
+ begin
+ Offset := TLayoutLine(FLines[ LineIndex ]).Length;
+ exit;
+ end;
+ end;
+
+ // found the line
+ GetOffsetFromX( XToFind,
+ LineIndex,
+ Offset,
+ Link );
+end;
+
+function TRichTextLayout.GetLineFromCharIndex( Index: longint ): longint;
+var
+ LineCharIndex: longint;
+ LineLength: longint;
+begin
+ Result := 0;
+ if Index <= 0 then
+ exit;
+
+ while Result < FNumLines do
+ begin
+ LineCharIndex := GetCharIndex( TLayoutLine(FLines[ Result ]).Text );
+ LineLength := TLayoutLine(FLines[ Result ]).Length;
+ if LineCharIndex + LineLength
+ > Index then
+ begin
+ // found
+ exit;
+ end;
+ inc( Result );
+ end;
+ Result := FNumLines - 1;
+end;
+
+function TRichTextLayout.GetOffsetFromCharIndex( Index: longint;
+ Line: longint ): longint;
+begin
+ Result := Index - GetCharIndex( TLayoutLine( FLines[ Line ] ).Text );
+end;
+
+function TRichTextLayout.GetElementWidth( Element: TTextElement ): longint;
+var
+ Bitmap: TfpgImage;
+ BitmapIndex: longint;
+begin
+ // Now find out how wide the thing is
+ case Element.ElementType of
+ teImage:
+ begin
+ try
+ BitmapIndex := StrToInt( Element.Tag.Arguments );
+ except
+ BitmapIndex := -1;
+ end;
+ if IsValidBitmapIndex( BitmapIndex ) then
+ begin
+ Bitmap := FImages.Item[BitmapIndex].Image;
+ Result := Trunc(Bitmap.Width
+ * FontWidthPrecisionFactor
+ * FHorizontalImageScale);
+ end;
+ end;
+
+ teText, teWordBreak:
+ Result := FFontManager.CharWidth( Element.Character );
+
+ else
+ Assert( False ); // should never be trying to find the width of a style, etc
+
+ end;
+end;
+
+Function TRichTextLayout.GetCharIndex( P: PChar ): longint;
+begin
+ Result := PCharDiff( P, FText );
+end;
+
+function TRichTextLayout.GetLinePosition( Line: longint ): longint;
+begin
+ Result := FRichTextSettings.Margins.Top;
+ dec( line );
+ while line >= 0 do
+ begin
+ inc( Result,
+ TLayoutLine(Flines[ Line ]).Height );
+ dec( line );
+ end;
+end;
+
+function TRichTextLayout.LinkFromIndex( const CharIndexToFind: longint): string;
+Var
+ P: PChar;
+ NextP: PChar;
+ EndP: PChar;
+ Element: TTextElement;
+ LineIndex: longint;
+ Line: TLayoutLine;
+begin
+ if FNumLines = 0 then
+ begin
+ Result := '';
+ exit;
+ end;
+
+ LineIndex := GetLineFromCharIndex( CharIndexToFind );
+
+ Line := TLayoutLine(FLines[ LineIndex ]);
+ P := Line.Text;
+ EndP := Line.Text + Line.Length;
+
+ if Line.LinkIndex <> -1 then
+ Result := FLinks[ Line.LinkIndex ]
+ else
+ Result := '';
+
+ while P < EndP do
+ begin
+ if GetCharIndex( P ) >= CharIndexToFind then
+ exit;
+
+ Element := ExtractNextTextElement( P, NextP );
+
+ case Element.ElementType of
+ teStyle:
+ case Element.Tag.TagType of
+ ttBeginLink:
+ Result := Element.Tag.Arguments;
+ ttEndLink:
+ Result := '';
+ end;
+ end;
+
+ P := NextP;
+ end;
+end;
+
+Initialization
+End.
+
diff --git a/docview/components/richtext/RichTextPrintUnit.pas b/docview/components/richtext/RichTextPrintUnit.pas
new file mode 100644
index 00000000..01746c68
--- /dev/null
+++ b/docview/components/richtext/RichTextPrintUnit.pas
@@ -0,0 +1,75 @@
+Unit RichTextPrintUnit;
+
+Interface
+
+uses
+ Graphics,
+ RichTextStyleUnit;
+
+// Prints the specified rich text, starting at page position PageY.
+// Starts new pages as needed; when done, PageY is the final position used
+// on the final page.
+Procedure PrintRichText( Text: PChar;
+ Images: TImageList;
+ Settings: TRichTextSettings;
+ var PageY: longint );
+
+Implementation
+
+uses
+ Classes,
+ Printers,
+ CanvasFontManager,
+ RichTextLayoutUnit, RichTextDisplayUnit, Forms
+ ;
+
+Procedure PrintRichText( Text: PChar;
+ Images: TImageList;
+ Settings: TRichTextSettings;
+ var PageY: longint );
+var
+ Layout: TRichTextLayout;
+ FontManager: TCanvasFontManager;
+ LineIndex: longint;
+ Y: longint;
+ FinishLine: longint;
+ FinishY: longint;
+Begin
+ FontManager := TCanvasFontManager.Create( Printer.Canvas,
+ false // don't allow bitmap fonts
+ );
+
+ Layout := TRichTextLayout.Create( Text,
+ Images,
+ Settings,
+ FontManager,
+ Printer.PageWidth );
+
+ LineIndex := 0;
+ Y := PageY;
+ repeat
+ PrintRichTextLayout( FontManager,
+ Layout,
+ LineIndex,
+ FinishLine,
+ Y,
+ FinishY );
+ LineIndex := FinishLine;
+ Y := FinishY;
+
+ if LineIndex < Layout.FNumLines then
+ begin
+ // didn't all fit on page, so new page
+ Printer.NewPage;
+ Y := Printer.PageHeight - 1;
+ end;
+
+ until LineIndex >= Layout.FNumLines;
+
+ Layout.Destroy;
+ FontManager.Destroy;
+ PageY := Y;
+end;
+
+Initialization
+End.
diff --git a/docview/components/richtext/RichTextStyleUnit.pas b/docview/components/richtext/RichTextStyleUnit.pas
new file mode 100644
index 00000000..b3c2830e
--- /dev/null
+++ b/docview/components/richtext/RichTextStyleUnit.pas
@@ -0,0 +1,641 @@
+Unit RichTextStyleUnit;
+
+{$mode objfpc}{$H+}
+
+Interface
+
+uses
+ Classes, fpg_base, fpg_main, CanvasFontManager, RichTextDocumentUnit;
+
+type
+ TTextDrawStyle = record
+ Font: TFontSpec;
+ Color: TfpgColor;
+ BackgroundColor: TfpgColor;
+ Alignment: TTextAlignment;
+ Wrap: boolean;
+ LeftMargin: longint;
+ RightMargin: longint;
+ end;
+
+ TMarginSizeStyle = ( msAverageCharWidth, msMaximumCharWidth, msSpecifiedChar );
+
+ TRichTextSettings = class( TfpgComponent )
+ protected
+ FHeading1Font: TfpgFont;
+ FHeading2Font: TfpgFont;
+ FHeading3Font: TfpgFont;
+ FFixedFont: TfpgFont;
+ FNormalFont: TfpgFont;
+ FDefaultBackgroundColor: TfpgColor;
+ FDefaultColor: TfpgColor;
+ FDefaultAlignment: TTextAlignment;
+ FDefaultWrap: boolean;
+ FAtLeastOneWordBeforeWrap: boolean;
+ FMarginSizeStyle: TMarginSizeStyle;
+ FMarginChar: longint;
+ FOnChange: TNotifyEvent;
+ FMargins: TRect;
+ FUpdateCount: longint;
+ FChangesPending: boolean;
+ Procedure Change;
+ Procedure SetNormalFont( NewFont: TfpgFont );
+ Procedure SetFixedFont( NewFont: TfpgFont );
+ Procedure SetHeading1Font( NewFont: TfpgFont );
+ Procedure SetHeading2Font( NewFont: TfpgFont );
+ Procedure SetHeading3Font( NewFont: TfpgFont );
+ Procedure SetDefaultColor( NewColor: TfpgColor );
+ Procedure SetDefaultBackgroundColor( NewColor: TfpgColor );
+ Procedure SetDefaultAlignment( Alignment: TTextAlignment );
+ Procedure SetDefaultWrap( Wrap: boolean );
+ Procedure SetAtLeastOneWordBeforeWrap( NewValue: boolean );
+ Procedure SetMarginSizeStyle( NewValue: TMarginSizeStyle );
+ Procedure SetMarginChar( NewValue: longint );
+ Procedure SetMargins( const NewMargins: TRect );
+ function GetMargin_Left: longint;
+ Procedure SetMargin_Left( NewValue: longint );
+ function GetMargin_Bottom: longint;
+ Procedure SetMargin_Bottom( NewValue: longint );
+ function GetMargin_Right: longint;
+ Procedure SetMargin_Right( NewValue: longint );
+ function GetMargin_Top: longint;
+ Procedure SetMargin_Top( NewValue: longint );
+ Procedure SetupComponent;
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+ Procedure AssignFont( Var Font: TfpgFont;
+ NewFont: TfpgFont );
+
+ // Hide properties...
+ property Name;
+
+ public
+ property OnChange: TNotifyEvent read FOnChange write FOnChange;
+
+ procedure BeginUpdate;
+ procedure EndUpdate;
+
+ // Stream in/out
+ //Procedure ReadSCUResource( Const ResName: TResourceName;
+ // Var Data;
+ // DataLen: LongInt ); override;
+ //Function WriteSCUResource( Stream: TResourceStream ): boolean; override;
+
+ property Margins: TRect read FMargins write SetMargins;
+
+ property Heading1Font: TfpgFont read FHeading1Font write SetHeading1Font;
+ property Heading2Font: TfpgFont read FHeading2Font write SetHeading2Font;
+ property Heading3Font: TfpgFont read FHeading3Font write SetHeading3Font;
+ property FixedFont: TfpgFont read FFixedFont write SetFixedFont;
+ property NormalFont: TfpgFont read FNormalFont write SetNormalFont;
+
+ published
+
+ property DefaultBackgroundColor: TfpgColor read FDefaultBackgroundColor write SetDefaultBackgroundColor;
+ property DefaultColor: TfpgColor read FDefaultColor write SetDefaultColor;
+
+ property DefaultAlignment: TTextAlignment read FDefaultAlignment write SetDefaultAlignment;
+ property DefaultWrap: boolean read FDefaultWrap write SetDefaultWrap default True;
+ property AtLeastOneWordBeforeWrap: boolean read FAtLeastOneWordBeforeWrap write SetAtLeastOneWordBeforeWrap;
+
+ property MarginSizeStyle: TMarginSizeStyle read FMarginSizeStyle write SeTMarginSizeStyle;
+ property MarginChar: longint read FMarginChar write SetMarginChar;
+
+ // margins are exposed as individual properties here
+ // since the Sibyl IDE cannot cope with editing a record property
+ // within a class property (as in RichTextView)
+ property Margin_Left: longint read GetMargin_Left write SetMargin_Left;
+ property Margin_Bottom: longint read GetMargin_Bottom write SetMargin_Bottom;
+ property Margin_Right: longint read GetMargin_Right write SetMargin_Right;
+ property Margin_Top: longint read GetMargin_Top write SetMargin_Top;
+ end;
+
+// pRichTextSettings = ^TRichTextSettings;
+ Procedure ApplyStyle( var Style: TTextDrawStyle;
+ FontManager: TCanvasFontManager );
+
+ Procedure ApplyStyleTag( const Tag: TTag;
+ Var Style: TTextDrawStyle;
+ FontManager: TCanvasFontManager;
+ const Settings: TRichTextSettings;
+ const X: longint );
+
+ function GetDefaultStyle( const Settings: TRichTextSettings ): TTextDrawStyle;
+
+//Exports
+// TRichTextSettings,'User','';
+
+Implementation
+
+uses
+ SysUtils,
+ ACLStringUtility
+ ,nvUtilities
+// , ACLProfile
+ ;
+
+Procedure ApplyStyle( var Style: TTextDrawStyle; FontManager: TCanvasFontManager );
+begin
+ProfileEvent('DEBUG: ApplyStyle >>>');
+ assert(FontManager <> nil, 'FontManager should not have been nil');
+ FontManager.SetFont( Style.Font );
+ FontManager.Canvas.TextColor := Style.Color;
+ProfileEvent('DEBUG: ApplyStyle <<<');
+end;
+
+Procedure ApplyStyleTag( Const Tag: TTag;
+ var Style: TTextDrawStyle;
+ FontManager: TCanvasFontManager;
+ const Settings: TRichTextSettings;
+ const X: longint );
+var
+ MarginParam1: string;
+ MarginParam2: string;
+ NewMargin: longint;
+ FontFaceName: string;
+ FontSizeString: string;
+ NewStyle: TTextDrawStyle;
+ ParseIndex: longint;
+ XSizeStr: string;
+ YSizeStr: string;
+ tmpFontParts : TStringList;
+
+ MarginSize: longint;
+ ParsePoint: longint;
+begin
+ProfileEvent('DEBUG: ApplyStyleTag >>>');
+ case Tag.TagType of
+ ttBold:
+ Include( Style.Font.Attributes, faBold );
+ ttBoldOff:
+ Exclude( Style.Font.Attributes, faBold );
+ ttItalic:
+ Include( Style.Font.Attributes, faItalic );
+ ttItalicOff:
+ Exclude( Style.Font.Attributes, faItalic );
+ ttUnderline:
+ Include( Style.Font.Attributes, faUnderscore );
+ ttUnderlineOff:
+ Exclude( Style.Font.Attributes, faUnderscore );
+
+ ttFixedWidthOn:
+ FPGuiFontToFontSpec( Settings.FFixedFont, Style.Font );
+ ttFixedWidthOff:
+ FPGuiFontToFontSpec( Settings.FNormalFont, Style.Font );
+
+ ttHeading1:
+ FPGuiFontToFontSpec( Settings.FHeading1Font, Style.Font );
+ ttHeading2:
+ FPGuiFontToFontSpec( Settings.FHeading2Font, Style.Font );
+ ttHeading3:
+ FPGuiFontToFontSpec( Settings.FHeading3Font, Style.Font );
+ ttHeadingOff:
+ FPGuiFontToFontSpec( Settings.FNormalFont, Style.Font );
+
+ ttFont:
+ begin
+ tmpFontParts := TStringList.Create;
+ StrExtractStringsQuoted(tmpFontParts, Tag.Arguments);
+ FontFaceName := tmpFontParts[0];
+ FontSizeString := tmpFontParts[1];
+ tmpFontParts.Destroy;
+
+ NewStyle := Style;
+ try
+ NewStyle.Font.FaceName := FontFaceName;
+
+ if Pos( 'x', FontSizeString ) > 0 then
+ begin
+ tmpFontParts := TStringList.Create;
+ StrExtractStrings(tmpFontParts, FontSizeString, ['x'], #0);
+ XSizeStr := tmpFontParts[0];
+ YSizeStr := tmpFontParts[1];
+ tmpFontParts.Destroy;
+
+ NewStyle.Font.XSize := StrToInt( XSizeStr );
+ NewStyle.Font.YSize := StrToInt( YSizeStr );
+ NewStyle.Font.PointSize := 0;
+ end
+ else
+ begin
+ NewStyle.Font.PointSize := StrToInt( FontSizeString );
+ end;
+
+ if ( NewStyle.Font.FaceName <> '' )
+ and ( NewStyle.Font.PointSize >= 1 ) then
+ begin
+ Style := NewStyle;
+ end;
+
+ except
+ end;
+ end;
+
+ ttFontOff:
+ // restore default
+ FPGuiFontToFontSpec( Settings.FNormalFont, Style.Font );
+
+ ttColor:
+ GetTagColor( Tag.Arguments, Style.Color );
+ ttColorOff:
+ Style.Color := Settings.FDefaultColor;
+ ttBackgroundColor:
+ GetTagColor( Tag.Arguments, Style.BackgroundColor );
+ ttBackgroundColorOff:
+ Style.BackgroundColor := Settings.FDefaultBackgroundColor;
+
+ ttRed:
+ Style.Color := clRed;
+ ttBlue:
+ Style.Color := clBlue;
+ ttGreen:
+ Style.Color := clGreen;
+ ttBlack:
+ Style.Color := clBlack;
+
+ ttAlign:
+ Style.Alignment := GetTagTextAlignment( Tag.Arguments,
+ Settings.FDefaultAlignment );
+
+ ttWrap:
+ Style.Wrap := GetTagTextWrap( Tag.Arguments );
+
+ ttSetLeftMargin,
+ ttSetRightMargin:
+ begin
+ tmpFontParts := TStringList.Create;
+ StrExtractStrings(tmpFontParts, Tag.Arguments, [' '], #0);
+ MarginParam1 := tmpFontParts[0];
+
+ ParsePoint := 1;
+ if ( Tag.TagType = ttSetLeftMargin )
+ and ( MarginParam1 = 'here' ) then
+ begin
+ Style.LeftMargin := X {div FontWidthPrecisionFactor};
+ end
+ else
+ begin
+ try
+ MarginSize := StrToInt( MarginParam1 );
+ if tmpFontParts.Count > 1 then // do we have a second parameter
+ MarginParam2 := tmpFontParts[1]
+ else
+ MarginParam2 := '';
+ if MarginParam2 = 'pixels' then
+ NewMargin := MarginSize
+
+ else if MarginParam2 = 'deffont' then
+ NewMargin := MarginSize * Settings.NormalFont.TextWidth('w') // .Width
+
+ else
+ begin
+ case Settings.MarginSizeStyle of
+ msAverageCharWidth:
+ NewMargin := MarginSize * FontManager.AverageCharWidth;
+ msMaximumCharWidth:
+ NewMargin := MarginSize * FontManager.MaximumCharWidth;
+ msSpecifiedChar:
+ NewMargin := MarginSize
+ * FontManager.CharWidth( Chr( Settings.MarginChar ) )
+ div FontWidthPrecisionFactor;
+ end;
+ end;
+ except
+ NewMargin := 0;
+ end;
+
+ if Tag.TagType = ttSetLeftMargin then
+ Style.LeftMargin := Settings.Margins.Left
+ + NewMargin
+ else
+ Style.RightMargin := Settings.Margins.Right
+ + NewMargin;
+ end;
+ tmpFontParts.Free;
+ end; { teSet[left|right]margin }
+
+ end; { case Tag.TagType }
+
+ ApplyStyle( Style, FontManager );
+ProfileEvent('DEBUG: ApplyStyleTag <<<');
+end;
+
+function GetDefaultStyle( const Settings: TRichTextSettings ): TTextDrawStyle;
+begin
+ FillChar(Result, SizeOf(TTextDrawStyle), 0);
+ FPGuiFontToFontSpec( Settings.FNormalFont, Result.Font );
+ Result.Alignment := Settings.FDefaultAlignment;
+ Result.Wrap := Settings.FDefaultWrap;
+ Result.Color := Settings.FDefaultColor;
+ Result.BackgroundColor := Settings.FDefaultBackgroundColor;
+ Result.LeftMargin := Settings.Margins.Left;
+ Result.RightMargin := Settings.Margins.Right;
+end;
+
+
+Procedure TRichTextSettings.SetupComponent;
+begin
+ Name := 'RichTextSettings';
+
+ FNormalFont := fpgGetFont('Arial-10');
+ FFixedFont := fpgGetFont('Courier New-10');
+ FHeading1Font := fpgGetFont('Arial-20');
+ FHeading2Font := fpgGetFont('Arial-14');
+ FHeading3Font := fpgGetFont('Arial-10:bold');
+
+ FDefaultColor := clBlack;
+ FDefaultBackgroundColor := clWhite;
+
+ FDefaultAlignment := taLeft;
+ FDefaultWrap := true;
+ FAtLeastOneWordBeforeWrap := false;
+
+ FMarginSizeStyle := msMaximumCharWidth;
+ FMarginChar := Ord( ' ' );
+
+ FMargins.Left := 0;
+ FMargins.Right := 0;
+ FMargins.Top := 0;
+ FMargins.Bottom := 0;
+
+ FUpdateCount := 0;
+ FChangesPending := false;
+end;
+
+constructor TRichTextSettings.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ SetupComponent;
+end;
+
+destructor TRichTextSettings.Destroy;
+begin
+ FNormalFont.Free;
+ FFixedFont.Free;
+ FHeading1Font.Free;
+ FHeading2Font.Free;
+ FHeading3Font.Free;
+ Inherited Destroy;
+end;
+
+// Font read/write from SCU. I have NO IDEA why I have to do this manually. But
+// this way works and everything else I tried doesn't
+//Procedure TRichTextSettings.ReadSCUResource( Const ResName: TResourceName;
+// Var Data;
+// DataLen: LongInt );
+//Begin
+// If ResName = 'Heading1Font' Then
+// Begin
+// If DataLen <> 0 Then
+// FHeading1Font := ReadSCUFont( Data, DataLen );
+// End
+// Else If ResName = 'Heading2Font' Then
+// Begin
+// If DataLen <> 0 Then
+// FHeading2Font := ReadSCUFont( Data, DataLen );
+// End
+// Else If ResName = 'Heading3Font' Then
+// Begin
+// If DataLen <> 0 Then
+// FHeading3Font := ReadSCUFont( Data, DataLen );
+// End
+// Else If ResName = 'FixedFont' Then
+// Begin
+// If DataLen <> 0 Then
+// FFixedFont := ReadSCUFont( Data, DataLen );
+// End
+// Else if ResName = 'NormalFont' then
+// Begin
+// If DataLen <> 0 Then
+// FNormalFont := ReadSCUFont( Data, DataLen );
+// End
+// Else
+// Inherited ReadSCUResource( ResName, Data, DataLen );
+//End;
+
+//Function TRichTextSettings.WriteSCUResource( Stream: TResourceStream ): boolean;
+//begin
+// Result := Inherited WriteSCUResource( Stream );
+// If Not Result Then
+// Exit;
+//
+// If FHeading1Font <> Nil then
+// Result := FHeading1Font.WriteSCUResourceName( Stream, 'Heading1Font' );
+// If FHeading2Font <> Nil then
+// Result := FHeading2Font.WriteSCUResourceName( Stream, 'Heading2Font' );
+// If FHeading3Font <> Nil then
+// Result := FHeading3Font.WriteSCUResourceName( Stream, 'Heading3Font' );
+// If FFixedFont <> Nil then
+// Result := FFixedFont.WriteSCUResourceName( Stream, 'FixedFont' );
+// If FNormalFont <> Nil then
+// Result := FNormalFont.WriteSCUResourceName( Stream, 'NormalFont' );
+//
+//end;
+
+Procedure TRichTextSettings.Change;
+begin
+ if FUpdateCount > 0 then
+ begin
+ FChangesPending := true;
+ exit;
+ end;
+
+ if FOnChange <> nil then
+ FOnChange( self );
+end;
+
+Procedure TRichTextSettings.SetDefaultAlignment( Alignment: TTextAlignment );
+begin
+ if Alignment = FDefaultAlignment then
+ exit; // no change
+
+ FDefaultAlignment := Alignment;
+ Change;
+end;
+
+Procedure TRichTextSettings.SetDefaultWrap( Wrap: boolean );
+begin
+ if Wrap = FDefaultWrap then
+ exit; // no change
+
+ FDefaultWrap := Wrap;
+ Change;
+end;
+
+Procedure TRichTextSettings.SetAtLeastOneWordBeforeWrap( NewValue: boolean );
+begin
+ if NewValue = FAtLeastOneWordBeforeWrap then
+ exit; // no change
+
+ FAtLeastOneWordBeforeWrap := NewValue;
+ Change;
+end;
+
+Procedure TRichTextSettings.SetMarginChar( NewValue: longint );
+begin
+ if NewValue = FMarginChar then
+ exit; // no change
+
+ FMarginChar := NewValue;
+
+ if FMarginSizeStyle <> msSpecifiedChar then
+ // doesn't matter, will be ignored
+ exit;
+ Change;
+end;
+
+Procedure TRichTextSettings.SetMarginSizeStyle( NewValue: TMarginSizeStyle );
+begin
+ if NewValue = FMarginSizeStyle then
+ exit; // no change
+
+ FMarginSizeStyle := NewValue;
+ Change;
+end;
+
+Function FontSame( FontA: TfpgFont; FontB: TfpgFont ): boolean;
+begin
+ if ( FontA = nil )
+ or ( FontB = nil ) then
+ begin
+ Result := FontA = FontB;
+ exit;
+ end;
+
+ Result := FontA.FontDesc = FontB.FontDesc;
+end;
+
+Procedure TRichTextSettings.AssignFont( Var Font: TfpgFont;
+ NewFont: TfpgFont );
+begin
+ If NewFont = Nil Then
+ NewFont := fpgApplication.DefaultFont;
+
+ if FontSame( NewFont, Font ) then
+ exit; // no change
+
+ Font.Free;
+ Font := NewFont;
+// Font.Free;
+
+ Change;
+End;
+
+Procedure TRichTextSettings.SetHeading1Font( NewFont: TfpgFont );
+begin
+// ProfileEvent( 'TRichTextSettings.SetHeading1Font' );
+ AssignFont( FHeading1Font, NewFont );
+
+// if FHeading1FOnt = nil then
+// ProfileEvent( ' Set to nil' );
+
+end;
+
+Procedure TRichTextSettings.SetHeading2Font( NewFont: TfpgFont );
+begin
+ AssignFont( FHeading2Font, NewFont );
+End;
+
+Procedure TRichTextSettings.SetHeading3Font( NewFont: TfpgFont );
+begin
+ AssignFont( FHeading3Font, NewFont );
+End;
+
+Procedure TRichTextSettings.SetFixedFont( NewFont: TfpgFont );
+begin
+ AssignFont( FFixedFont, NewFont );
+end;
+
+Procedure TRichTextSettings.SetNormalFont( NewFont: TfpgFont );
+begin
+ AssignFont( FNormalFont, NewFont );
+end;
+
+Procedure TRichTextSettings.SetMargins( const NewMargins: TRect );
+begin
+ if NewMargins = FMargins then
+ exit; // no change
+ FMargins := NewMargins;
+ Change;
+end;
+
+function TRichTextSettings.GetMargin_Left: longint;
+begin
+ Result := FMargins.Left;
+end;
+
+Procedure TRichTextSettings.SetMargin_Left( NewValue: longint );
+begin
+ FMargins.Left := NewValue;
+end;
+
+function TRichTextSettings.GetMargin_Bottom: longint;
+begin
+ Result := FMargins.Bottom;
+end;
+
+Procedure TRichTextSettings.SetMargin_Bottom( NewValue: longint );
+begin
+ FMargins.Bottom := NewValue;
+end;
+
+function TRichTextSettings.GetMargin_Right: longint;
+begin
+ Result := FMargins.Right;
+end;
+
+Procedure TRichTextSettings.SetMargin_Right( NewValue: longint );
+begin
+ FMargins.Right := NewValue;
+end;
+
+function TRichTextSettings.GetMargin_Top: longint;
+begin
+ Result := FMargins.Top;
+end;
+
+Procedure TRichTextSettings.SetMargin_Top( NewValue: longint );
+begin
+ FMargins.Top := NewValue;
+end;
+
+Procedure TRichTextSettings.SetDefaultColor( NewColor: TfpgColor );
+begin
+ if NewColor = FDefaultColor then
+ exit;
+ FDefaultColor := NewColor;
+ Change;
+end;
+
+Procedure TRichTextSettings.SetDefaultBackgroundColor( NewColor: TfpgColor );
+begin
+ if NewColor = FDefaultBackgroundColor then
+ exit;
+ FDefaultBackgroundColor := NewColor;
+ Change;
+end;
+
+procedure TRichTextSettings.BeginUpdate;
+begin
+ inc( FUpdateCount );
+end;
+
+procedure TRichTextSettings.EndUpdate;
+begin
+ if FUpdateCount = 0 then
+ exit;
+
+ dec( FUpdateCount );
+ if FUpdateCount = 0 then
+ begin
+ if FChangesPending then
+ begin
+ Change;
+ FChangesPending := false;
+ end;
+ end;
+end;
+
+Initialization
+ RegisterClasses( [ TRichTextSettings ] );
+End.
diff --git a/docview/components/richtext/RichTextView.pas b/docview/components/richtext/RichTextView.pas
new file mode 100644
index 00000000..390ac376
--- /dev/null
+++ b/docview/components/richtext/RichTextView.pas
@@ -0,0 +1,2868 @@
+Unit RichTextView;
+
+{$mode objfpc}{$H+}
+
+Interface
+
+Uses
+ Classes,
+ fpg_base,
+ fpg_main,
+ fpg_widget,
+ fpg_scrollbar,
+ fpg_menu,
+ fpg_imagelist,
+ RichTextStyleUnit,
+ RichTextLayoutUnit,
+// RichTextDocumentUnit,
+ CanvasFontManager;
+
+{
+Remaining keyboard support
+- cursor down to go to end of line (this is tricky)
+ I don't understand what I mean here!
+- If scrolllock is on, then scroll the screen, not move cursor.
+ Really? So few things obey it...
+}
+
+const
+ // for dragtext support, primarily.
+ RT_QUERYTEXT = FPGM_USER + 500;
+ // Param1: pointer to buffer (may be nil)
+ // Param2: buffer size (-1 to ignore)
+ // Returns: number of bytes copied
+
+ RT_QUERYSELTEXT = FPGM_USER + 501;
+ // Param1: pointer to buffer (may be nil)
+ // Param2: buffer size (-1 to ignore)
+ // Returns: number of bytes copied
+
+Type
+ TFindOrigin = ( foFromStart, foFromCurrent );
+
+ TScrollingDirection = ( sdUp, sdDown );
+
+Type
+
+ TRichTextView = class;
+
+ // reimplement class
+ TLinkEvent = procedure( Sender: TRichTextView; Link: string ) of object;
+
+
+ TRichTextView = Class( TfpgWidget )
+ private
+ FPopupMenu: TfpgPopupMenu;
+ procedure FVScrollbarScroll(Sender: TObject; position: integer);
+ procedure FHScrollbarScroll(Sender: TObject; position: integer);
+ procedure ShowDefaultPopupMenu(const x, y: integer; const shiftstate: TShiftState); virtual;
+ Procedure CreateDefaultMenu;
+ Procedure SelectAllMIClick( Sender: TObject );
+ Procedure CopyMIClick( Sender: TObject );
+ Procedure RefreshMIClick( Sender: TObject );
+ Procedure WordWrapMIClick( Sender: TObject );
+ Procedure SmoothScrollMIClick( Sender: TObject );
+ Procedure DebugMIClick( Sender: TObject );
+ Procedure DefaultMenuPopup( Sender: TObject );
+ protected
+ FFontManager: TCanvasFontManager;
+ FRichTextSettings: TRichTextSettings;
+
+ // Properties
+// FBorderStyle:TfpgBorderStyle;
+ FScrollbarWidth: longint;
+ FSmoothScroll: boolean;
+ FUseDefaultMenu: boolean;
+ FDebug: boolean;
+
+ FOnOverLink: TLinkEvent;
+ FOnNotOverLink: TLinkEvent;
+ FOnClickLink: TLinkEvent;
+
+ FDefaultMenu: TfpgPopupMenu;
+ FSelectAllMI: TfpgMenuItem;
+ FCopyMI: TfpgMenuItem;
+ FRefreshMI: TfpgMenuItem;
+ FWordWrapMI: TfpgMenuItem;
+ FSmoothScrollMI: TfpgMenuItem;
+ FDebugMI: TfpgMenuItem;
+
+ // Internal layout data
+ FNeedVScroll, FNeedHScroll: boolean;
+
+ FLayoutRequired: boolean;
+ FLayout: TRichTextLayout;
+
+ // Child controls
+ FHScrollbar: TfpgScrollbar;
+ FVScrollbar: TfpgScrollbar;
+
+ // Text
+ FText: PChar;
+
+ FTopCharIndex: longint; // only applies until following flag set.
+ FVerticalPositionInitialised: boolean;
+
+ FCursorRow: longint;
+ FCursorOffset: longint;
+ FSelectionStart: longint;
+ FSelectionEnd: longint;
+ FImages: TfpgImageList;
+
+ // Selection scrolling
+ //FScrollTimer: TfpgTimer;
+ FOldMousePoint: TPoint;
+ FScrollingDirection: TScrollingDirection;
+
+ // Scroll information
+ // we use these rather than the scrollbar positions direct,
+ // since those are not updated during tracking
+ FXScroll: longint;
+ FYScroll: longint;
+
+ FLastXScroll: longint;
+ FLastYScroll: longint;
+
+ // Link
+ FLastLinkOver: string;
+ FClickedLink: string;
+
+ procedure DoAllocateWindowHandle(AParent: TfpgWindowBase); override;
+ Procedure CreateWnd;
+ procedure HandleResize(AWidth, AHeight: TfpgCoord); override;
+ procedure UpdateScrollBarCoords;
+ procedure HandlePaint; override;
+ procedure HandleHide; override;
+ procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override;
+ procedure HandleRMouseUp(x, y: integer; shiftstate: TShiftState); override;
+ procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override;
+ procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override;
+ procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override;
+
+ //procedure ScanEvent( Var KeyCode: TKeyCode;
+ // RepeatCount: Byte ); override;
+
+ //Procedure MouseDown( Button: TMouseButton;
+ // ShiftState: TShiftState;
+ // X, Y: Longint ); override;
+ //Procedure MouseUp( Button: TMouseButton;
+ // ShiftState: TShiftState;
+ // X, Y: Longint ); override;
+
+ //Procedure MouseDblClick( Button: TMouseButton;
+ // ShiftState: TShiftState;
+ // X, Y: Longint ); override;
+
+ //Procedure MouseMove( ShiftState: TShiftState;
+ // X, Y: Longint ); override;
+
+ //Procedure Scroll( Sender: TScrollbar;
+ // ScrollCode: TScrollCode;
+ // Var ScrollPos: Longint ); override;
+
+ //Procedure KillFocus; override;
+ //Procedure SetFocus; override;
+
+ // Messages for DragText
+ Procedure RTQueryText( Var Msg: TfpgMessageRec ); message RT_QUERYTEXT;
+ Procedure RTQuerySelText( Var Msg: TfpgMessageRec ); message RT_QUERYSELTEXT;
+
+ procedure Layout;
+
+ function FindPoint( XToFind: longint;
+ YToFind: longint;
+ Var LineIndex: longint;
+ Var Offset: longint;
+ Var Link: string ): TTextPosition;
+
+ // Scroll functions
+
+ // Scroll display to given positions (does NOT
+ // update scrollbars as this may be called during
+ // scrolling)
+ Procedure DoVerticalScroll( NewY: longint );
+ Procedure DoHorizontalScroll( NewX: longint );
+
+ // Set scrollbar position, and update display
+ Procedure SetVerticalPosition( NewY: longint );
+ Procedure SetHorizontalPosition( NewX: longint );
+
+ procedure OnScrollTimer( Sender: TObject );
+ Function GetLineDownPosition: longint;
+ Function GetLineUpPosition: longint;
+ Function GetSmallDownScrollPosition: longint;
+ Function GetSmallUpScrollPosition: longint;
+ Function GetSmallRightScrollPosition: longint;
+ Function GetSmallLeftScrollPosition: longint;
+
+ // Calculates line down position given the last line and displayed pixels
+ Function GetLineDownPositionFrom( LastLine: longint; PixelsDisplayed: longint ): longint;
+ Function GetLineUpPositionFrom( FirstVisibleLine: longint; Offset: longint ): longint;
+
+ // Drawing functions
+ Procedure DrawBorder;
+ Procedure Draw( StartLine, EndLine: longint );
+
+ // Rectangle (GetClientRect) minus scrollbars (if they are enabled)
+ Function GetDrawRect: TfpgRect;
+ // Rectangle minus scrollbars (GetDrawRect), minus extra 2px border all round
+ Function GetTextAreaRect: TfpgRect;
+ Function GetTextAreaHeight: longint;
+ Function GetTextAreaWidth: longint;
+
+ // Queries
+ procedure GetFirstVisibleLine( Var LineIndex: longint; Var Offset: longint );
+ procedure GetBottomLine( Var LineIndex: longint; Var PixelsDisplayed: longint );
+
+ // Layout functions
+ Procedure SetupScrollbars;
+ Procedure SetupCursor;
+ procedure RemoveCursor;
+
+ function GetTextEnd: longint;
+
+ // property handlers
+// procedure SetBorder( BorderStyle: TBorderStyle );
+ Procedure SetDebug( Debug: boolean );
+ Procedure SetScrollBarWidth( NewValue: longint );
+
+ Procedure OnRichTextSettingsChanged( Sender: TObject );
+
+ function GetCursorIndex: longint;
+
+ Function GetTopCharIndex: longint;
+ Procedure SetTopCharIndex( NewValue: longint );
+ Function GetTopCharIndexPosition( NewValue: longint ): longint;
+
+ // Update the cursor row/column for the selction start/end
+ procedure RefreshCursorPosition;
+
+ procedure SetCursorIndex( Index: longint;
+ PreserveSelection: boolean );
+ procedure SetCursorPosition( Offset: longint;
+ Row: longint;
+ PreserveSelection: boolean );
+
+ procedure MakeRowVisible( Row: longint );
+ procedure MakeRowAndColumnVisible( Row: longint;
+ Column: longint );
+
+ // These two methods set selection start and end,
+ // and redraw the screen, but do not set up cursor.
+ Procedure SetSelectionStartInternal( SelectionStart: longint );
+ Procedure SetSelectionEndInternal( SelectionEnd: longint );
+
+ // Property handlers. These are for programmatic access
+ // where a complete setup of selection is needed
+ Procedure SetSelectionStart( SelectionStart: longint );
+ Procedure SetSelectionEnd( SelectionEnd: longint );
+
+ Procedure SetImages( Images: TfpgImageList );
+ Procedure Notification( AComponent: TComponent;
+ Operation: TOperation ); override;
+ Public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; Override;
+ // rect (of component) minus frame borders - normally 2 pixels all round
+ function GetClientRect: TfpgRect; override;
+ procedure AddText( Text: PChar; ADelay: boolean = False );
+ procedure AddParagraph( Text: PChar );
+ procedure AddSelectedParagraph( Text: PChar );
+ procedure Clear(const ADestroying: boolean = False);
+ procedure InsertText( CharIndexToInsertAt: longword; TextToInsert: PChar );
+ property Text: PChar read FText;
+ property TextEnd: longint read GetTextEnd;
+ property SelectionStart: longint read FSelectionStart write SetSelectionStart;
+ property SelectionEnd: longint read FSelectionEnd write SetSelectionEnd;
+ property CursorIndex: longint read GetCursorIndex;
+
+ // Copy all text to buffer
+ // Buffer can be nil to simply get size.
+ // If BufferLength is negative, it is ignored
+ Function CopyTextToBuffer( Buffer: PChar; BufferLength: longint ): longint;
+
+ // Clipboard
+ Procedure CopySelectionToClipboard;
+
+ // returns number of chars (that would be) copied.
+ // Buffer can be nil to simply get size.
+ // If BufferLength is negative, it is ignored
+ Function CopySelectionToBuffer( Buffer: PChar;
+ BufferLength: longint ): longint;
+
+ Function GetSelectionAsString: string; // returns up to 255 chars obviously
+
+ // Selection queries
+ Function SelectionLength: longint; // Note: includes formatting
+ Function SelectionSet: boolean; // returns true if there is a selection
+
+ // Selection actions
+ Procedure ClearSelection;
+ Procedure SelectAll;
+
+ property CursorRow: longint read FCursorRow;
+
+ // Navigation
+ procedure GoToTop;
+ procedure GotoBottom;
+ Procedure UpLine;
+ Procedure DownLine;
+ Procedure UpPage;
+ Procedure DownPage;
+
+ Procedure SmallScrollUp;
+ Procedure SmallScrollDown;
+ Procedure SmallScrollLeft;
+ Procedure SmallScrollRight;
+
+ Procedure MakeCharVisible( CharIndex: longint );
+ Property TopCharIndex: longint read GetTopCharIndex write SetTopCharIndex;
+
+ Procedure CursorLeft( PreserveSelection: boolean );
+ Procedure CursorRight( PreserveSelection: boolean );
+ Procedure CursorDown( PreserveSelection: boolean );
+ Procedure CursorUp( PreserveSelection: boolean );
+ Procedure CursorPageDown( PreserveSelection: boolean );
+ Procedure CursorPageUp( PreserveSelection: boolean );
+
+ Procedure CursorToLineStart( PreserveSelection: boolean );
+ Procedure CursorToLineEnd( PreserveSelection: boolean );
+
+ Procedure CursorWordLeft( PreserveSelection: boolean );
+ Procedure CursorWordRight( PreserveSelection: boolean );
+
+ function HighlightNextLink: boolean;
+ function HighlightPreviousLink: boolean;
+
+ // Search for the given text
+ // if found, returns true, MatchIndex is set to the first match,
+ // and MatchLength returns the length of the match
+ // (which may be greater than the length of Text due to
+ // to skipping tags)
+ // if not found, returns false, pMatch is set to -1
+ function FindString( Origin: TFindOrigin;
+ const AText: string;
+ var MatchIndex: longint;
+ var MatchLength: longint ): boolean;
+
+ // Searches for text and selects it found
+ // returns true if found, false if not
+ function Find( Origin: TFindOrigin;
+ const AText: string ): boolean;
+
+ function LinkFromIndex( const CharIndexToFind: longint): string;
+
+ Published
+ property Align;
+ property BackgroundColor default clBoxColor;
+ //property ParentColor;
+ //property ParentFont;
+ //property ParentPenColor;
+ property ParentShowHint;
+ property PopupMenu: TfpgPopupMenu read FPopupMenu write FPopupMenu;
+ property ShowHint;
+ Property TabOrder;
+ Property Focusable;
+ property Visible;
+ property RichTextSettings: TRichTextSettings read FRichTextSettings;
+ property ScrollBarWidth: longint read FScrollBarWidth write SetScrollBarWidth default 15;
+ property SmoothScroll: boolean read FSmoothScroll write FSmoothScroll;
+ property UseDefaultMenu: boolean read FUseDefaultMenu write FUseDefaultMenu default True;
+ property Debug: boolean read FDebug write SetDebug default False;
+ property Images: TfpgImageList read FImages write SetImages;
+
+ // ------- EVENTS ----------
+
+ // Called with the name of the link when the mouse first moves over it
+ property OnOverLink: TLinkEvent read FOnOverLink write FOnOverLink;
+
+ // Called with the name of the link when the mouse leaves it
+ property OnNotOverLink: TLinkEvent read FOnNotOverLink write FOnNotOverLink;
+
+ // Called when the link is clicked.
+ property OnClickLink: TLinkEvent read FOnClickLink write FOnClickLink;
+
+ Property OnClick;
+ Property OnDoubleClick;
+ //property OnDragOver;
+ //property OnDragDrop;
+ //property OnEndDrag;
+ Property OnEnter;
+ Property OnExit;
+ //Property OnFontChange;
+ //Property OnMouseClick;
+ //Property OnMouseDblClick;
+ //Property OnSetupShow;
+
+ //Property OnScan;
+ Protected
+ //Property Font;
+
+ End;
+
+
+implementation
+
+uses
+ SysUtils
+ ,ACLStringUtility
+ ,nvUtilities
+// ControlScrolling, ControlsUtility,
+ ,RichTextDocumentUnit
+ ,RichTextDisplayUnit
+ ;
+
+Procedure TRichTextView.SetSelectionStart( SelectionStart: longint );
+begin
+ RemoveCursor;
+ SetSelectionStartInternal( SelectionStart );
+ RefreshCursorPosition;
+ SetupCursor;
+end;
+
+Procedure TRichTextView.SetSelectionEnd( SelectionEnd: longint );
+begin
+ RemoveCursor;
+ SetSelectionEndInternal( SelectionEnd );
+ RefreshCursorPosition;
+ SetupCursor;
+end;
+
+Procedure TRichTextView.SetSelectionStartInternal( SelectionStart: longint );
+begin
+ if SelectionStart = FSelectionStart then
+ exit;
+
+ if SelectionSet then
+ if SelectionStart = -1 then
+ // small side effect here - also sets selectionend to -1
+ ClearSelection;
+
+ FSelectionStart := SelectionStart;
+ if FSelectionEnd = -1 then
+ // still no selection
+ exit;
+ RePaint;
+end;
+
+Procedure TRichTextView.SetSelectionEndInternal( SelectionEnd: longint );
+var
+ StartRedrawLine: longint;
+ EndRedrawLine: longint;
+ OldClip: TfpgRect;
+begin
+ if SelectionEnd = FSelectionEnd then
+ exit;
+
+ if FSelectionStart = -1 then
+ begin
+ FSelectionEnd := SelectionEnd;
+ // still not a valid selection, no need to redraw
+ exit;
+ end;
+
+ if SelectionEnd = FSelectionStart then
+ SelectionEnd := -1;
+
+ if ( FSelectionEnd = -1 ) then
+ begin
+ // there is currently no selection,
+ // and we are setting one: need to draw it all
+ StartRedrawLine := FLayout.GetLineFromCharIndex( FSelectionStart );
+ EndRedrawLine := FLayout.GetLineFromCharIndex( SelectionEnd );
+ end
+ else
+ begin
+ // there is already a selection
+ if SelectionEnd = -1 then
+ begin
+ // and we're clearing it
+ StartRedrawLine := FLayout.GetLineFromCharIndex( FSelectionStart );
+ EndRedrawLine := FLayout.GetLineFromCharIndex( FSelectionEnd );
+ end
+ else
+ begin
+ // and we're setting a new one, so draw from the old end to the new
+ StartRedrawLine := FLayout.GetLineFromCharIndex( FSelectionEnd );
+ EndRedrawLine := FLayout.GetLineFromCharIndex( SelectionEnd );
+ end;
+ end;
+
+ FSelectionEnd := SelectionEnd;
+
+ OldClip := Canvas.GetClipRect;
+ Canvas.SetClipRect(GetTextAreaRect);
+
+ // (re)draw selection
+ { TODO -ograeme : Draw must not be called here }
+// Draw( StartRedrawLine, EndRedrawLine );
+ Canvas.SetClipRect(OldClip);
+end;
+
+Procedure TRichTextView.ClearSelection;
+var
+ OldClip: TfpgRect;
+ StartLine: longint;
+ EndLine: longint;
+begin
+
+ if SelectionSet then
+ begin
+ OldClip := Canvas.GetClipRect;
+ Canvas.SetClipRect(GetTextAreaRect);
+
+ StartLine := FLayout.GetLineFromCharIndex( FSelectionStart );
+ EndLine := FLayout.GetLineFromCharIndex( FSelectionEnd );
+
+ FSelectionEnd := -1;
+ FSelectionStart := -1;
+
+ // clear display of selection
+ { TODO -oGraeme : Draw must not be called here }
+// Draw( StartLine, EndLine );
+
+ Canvas.SetClipRect(OldClip);
+ end;
+
+ FSelectionEnd := -1;
+ FSelectionStart := -1;
+end;
+
+Function TRichTextView.GetTextEnd: longint;
+begin
+ Result := StrLen( FText );
+end;
+
+Procedure TRichTextView.CreateDefaultMenu;
+begin
+ FDefaultMenu := TfpgPopupMenu.Create(nil);
+ FDefaultMenu.OnShow := @DefaultMenuPopup;
+
+ FSelectAllMI := FDefaultMenu.AddMenuItem('Select &All', '', @SelectAllMIClick);
+ FCopyMI := FDefaultMenu.AddMenuItem('&Copy', '', @CopyMIClick);
+ FDefaultMenu.AddMenuItem('-', '', nil);
+ FRefreshMI := FDefaultMenu.AddMenuItem('&Refresh', '', @RefreshMIClick);
+ FDefaultMenu.AddMenuItem('-', '', nil);
+ FSmoothScrollMI := FDefaultMenu.AddMenuItem('&Smooth Scrolling', '', @SmoothScrollMIClick);
+ FWordWrapMI := FDefaultMenu.AddMenuItem('&Word Wrap', '', @WordWrapMIClick);
+ FDebugMI := FDefaultMenu.AddMenuItem('&Debug', '', @DebugMIClick);
+end;
+
+Procedure TRichTextView.SelectAllMIClick( Sender: TObject );
+begin
+ SelectAll;
+end;
+
+Procedure TRichTextView.CopyMIClick( Sender: TObject );
+begin
+ CopySelectionToClipBoard;
+end;
+
+Procedure TRichTextView.RefreshMIClick( Sender: TObject );
+begin
+ RePaint;
+end;
+
+Procedure TRichTextView.WordWrapMIClick( Sender: TObject );
+begin
+ FRichTextSettings.DefaultWrap := not FRichTextSettings.DefaultWrap;
+end;
+
+Procedure TRichTextView.SmoothScrollMIClick( Sender: TObject );
+begin
+ SmoothScroll := not SmoothScroll;
+end;
+
+Procedure TRichTextView.DebugMIClick( Sender: TObject );
+begin
+ Debug := not Debug;
+// writeln('VScrollbar.Position=', FVScrollbar.Position, ' min/max=', FVScrollbar.Min, '/', FVScrollbar.Max);
+// writeln('FNeedHScroll=', FNeedHScroll, ' FNeedVScroll=', FNeedVScroll);
+ RePaint;
+end;
+
+Procedure TRichTextView.DefaultMenuPopup( Sender: TObject );
+begin
+ FWordWrapMI.Checked := FRichTextSettings.DefaultWrap;
+ FSmoothScrollMI.Checked := SmoothScroll;
+ FDebugMI.Checked := Debug;
+end;
+
+constructor TRichTextView.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ Name := 'RichTextView';
+ FWidth := 150;
+ FHeight := 70;
+ FFocusable := True;
+
+ FNeedVScroll := False;
+ FNeedHScroll := False;
+ FSmoothScroll := True;
+ FScrollbarWidth := 15;
+ FUseDefaultMenu := True;
+ FDebug := False;
+ FLayoutRequired := True;
+
+ FTextColor := Parent.TextColor;
+ FBackgroundColor := clBoxColor;
+
+ FRichTextSettings := TRichTextSettings.Create( self );
+ FRichTextSettings.Margins := Rect( 5, 5, 5, 5 );
+ FRichTextSettings.OnChange := @OnRichTextSettingsChanged;
+
+ FImages := nil;
+
+ if not InDesigner then
+ begin
+ FFontManager := nil;
+
+ FText := StrAlloc( 100 );
+ FText[ 0 ] := #0;
+
+ FTopCharIndex := 0;
+ FVerticalPositionInitialised := false;
+ end;
+end;
+
+procedure TRichTextView.HandlePaint;
+Var
+ CornerRect: TfpgRect;
+ TextRect: TfpgRect;
+ DrawRect: TfpgRect;
+ x: integer;
+
+ // Just for fun! :-)
+ procedure DesignerPainting(const AText: string; AColor: TfpgColor; AFontDesc: TfpgString = '');
+ var
+ oldf: TfpgString;
+ begin
+ oldf := '';
+ if AFontDesc <> '' then
+ begin
+ oldf := Canvas.Font.FontDesc; // save original font
+ Canvas.Font := fpgGetFont(AFontDesc); // set new font
+ end;
+ Canvas.TextColor := AColor; // set new color
+ Canvas.DrawString(x, 10, AText);
+ x := x + Canvas.Font.TextWidth(AText); // calc x offset for next text
+ if oldf <> '' then
+ Canvas.Font := fpgGetFont(oldf); // restore original font
+ end;
+
+begin
+ ProfileEvent('TRichTextView.HandlePaint >>>');
+ Canvas.ClearClipRect;
+ DrawBorder;
+ProfileEvent('DEBUG: TRichTextView.HandlePaint 1');
+ DrawRect := GetDrawRect;
+ Canvas.Color := BackgroundColor;
+ Canvas.FillRectangle(DrawRect);
+
+ProfileEvent('DEBUG: TRichTextView.HandlePaint 2');
+ TextRect := GetTextAreaRect;
+ Canvas.SetClipRect(TextRect);
+
+ProfileEvent('DEBUG: TRichTextView.HandlePaint 3');
+ if InDesigner then
+ begin
+ Canvas.TextColor := clInactiveWgFrame;
+ x := 10;
+ DesignerPainting('<', clInactiveWgFrame);
+ DesignerPainting('rich', clBlack, 'Sans-10:bold');
+ DesignerPainting(' text', clRed, 'Sans-10:italic');
+ DesignerPainting(' ', clInactiveWgFrame);
+ DesignerPainting('will', clBlue, 'Sans-10:underline');
+ DesignerPainting(' appear here>', clInactiveWgFrame);
+// Canvas.DrawString(10, 10, '<rich text will appear here>');
+ Canvas.ClearClipRect;
+ Exit; //==>
+ end;
+
+ if Length(FText) = 0 then
+ exit; // no need to paint anything further.
+
+ProfileEvent('DEBUG: TRichTextView.HandlePaint 4');
+ Assert(FLayout <> nil, 'FLayout may not be nil at this point!');
+ if not Debug then
+ Draw( 0, FLayout.FNumLines )
+ else
+ Canvas.DrawText(8, 8, GetTextAreaWidth-FScrollbarWidth, 1000, FText, [txtLeft, txtTop, txtWrap]);
+ProfileEvent('DEBUG: TRichTextView.HandlePaint 5');
+ Canvas.ClearClipRect;
+
+ if FHScrollbar.Visible and FVScrollbar.Visible then
+ begin
+ // blank out corner between scrollbars
+ CornerRect.Left := Width - 2 - FScrollBarWidth;
+ CornerRect.Top := Height - 2 - FScrollBarWidth;
+ CornerRect.Width := FScrollBarWidth;
+ CornerRect.Height := FScrollBarWidth;
+ Canvas.Color := clButtonFace;
+ Canvas.FillRectangle(CornerRect);
+ end;
+ProfileEvent('DEBUG: TRichTextView.HandlePaint <<<');
+end;
+
+procedure TRichTextView.HandleHide;
+begin
+// fpgCaret.UnSetCaret (Canvas);
+ inherited HandleHide;
+end;
+
+procedure TRichTextView.HandleKeyPress(var keycode: word; var shiftstate: TShiftState;
+ var consumed: boolean);
+begin
+ProfileEvent('HandleKeyPress');
+ case keycode of
+ keyPageDown:
+ begin
+ consumed := True;
+ UpPage;
+ end;
+ keyPageUp:
+ begin
+ consumed := True;
+ DownPage;
+ end;
+
+ end;
+ inherited HandleKeyPress(keycode, shiftstate, consumed);
+end;
+
+procedure TRichTextView.HandleRMouseUp(x, y: integer; shiftstate: TShiftState);
+begin
+ inherited HandleRMouseUp(x, y, shiftstate);
+ if Assigned(PopupMenu) then
+ PopupMenu.ShowAt(self, x, y)
+ else
+ ShowDefaultPopupMenu(x, y, ShiftState);
+end;
+
+procedure TRichTextView.HandleMouseScroll(x, y: integer; shiftstate: TShiftState;
+ delta: smallint);
+begin
+ inherited HandleMouseScroll(x, y, shiftstate, delta);
+ if delta < 0 then
+ // scroll up
+ SetVerticalPosition(FVScrollbar.Position - FVScrollbar.ScrollStep)
+ else
+ // scroll down
+ SetVerticalPosition(FVScrollbar.Position + FVScrollbar.ScrollStep);
+end;
+
+procedure TRichTextView.HandleLMouseDown(x, y: integer; shiftstate: TShiftState);
+var
+ Line: longint;
+ Offset: longint;
+ Link: string;
+ Position: TTextPosition;
+ Shift: boolean;
+begin
+ inherited HandleLMouseDown(x, y, shiftstate);
+ Position := FindPoint( X, Y, Line, Offset, Link );
+ FClickedLink := Link;
+// writeln('Pos=', Ord(Position), ' link=', Link);
+end;
+
+procedure TRichTextView.HandleLMouseUp(x, y: integer; shiftstate: TShiftState);
+begin
+ inherited HandleLMouseUp(x, y, shiftstate);
+ if FClickedLink <> '' then
+ if Assigned( FOnClickLink ) then
+ FOnClickLink( Self, FClickedLink );
+ FClickedLink := ''; // reset link
+end;
+
+Destructor TRichTextView.Destroy;
+Begin
+ FDefaultMenu.Free;
+ // destroy the font manager NOW
+ // while the canvas is still valid
+ // (it will be freed in TControl.DisposeWnd)
+ // in order to release logical fonts
+ if FFontManager <> nil then
+ FFontManager.Free;
+ if Assigned(FLayout) then
+ FreeAndNil(FLayout);
+
+ //FScrollTimer.Free;
+ if not InDesigner then
+ begin
+ RemoveCursor;
+ StrDispose( FText );
+ end;
+ Inherited Destroy;
+End;
+
+//Procedure TRichTextView.KillFocus;
+//begin
+// RemoveCursor;
+// inherited KillFocus;
+//end;
+
+//Procedure TRichTextView.SetFocus;
+//begin
+// inherited SetFocus;
+// SetupCursor;
+//end;
+
+// Custom window messages for DragText support
+Procedure TRichTextView.RTQueryText( Var Msg: TfpgMessageRec );
+begin
+ //Msg.Handled := true;
+ //Msg.Result :=
+ // CopyPlainTextToBuffer( FText,
+ // FText + strlen( FText ),
+ // PChar( Msg.Param1 ),
+ // Msg.Param2 );
+end;
+
+Procedure TRichTextView.RTQuerySelText( Var Msg: TfpgMessageRec );
+begin
+ //Msg.Handled := true;
+ //Msg.Result :=
+ // CopySelectionToBuffer( PChar( Msg.Param1 ),
+ // Msg.Param2 );
+end;
+
+Procedure TRichTextView.SetDebug( Debug: boolean );
+begin
+ if Debug = FDebug then
+ exit;
+ FDebug := Debug;
+ RePaint;
+end;
+
+Procedure TRichTextView.SetScrollBarWidth( NewValue: longint );
+begin
+ if ( NewValue < 0 )
+ or ( NewValue = FScrollBarWidth ) then
+ exit;
+ FScrollBarWidth := NewValue;
+ Layout;
+ RePaint;
+end;
+
+procedure TRichTextView.FVScrollbarScroll(Sender: TObject; position: integer);
+begin
+ SetVerticalPosition(position);
+end;
+
+procedure TRichTextView.FHScrollbarScroll(Sender: TObject; position: integer);
+begin
+ SetHorizontalPosition(position);
+end;
+
+procedure TRichTextView.ShowDefaultPopupMenu(const x, y: integer;
+ const shiftstate: TShiftState);
+begin
+ if not Assigned(FDefaultMenu) then
+ CreateDefaultMenu;
+ FDefaultMenu.ShowAt(x, y);
+end;
+
+procedure TRichTextView.DoAllocateWindowHandle(AParent: TfpgWindowBase);
+begin
+ inherited DoAllocateWindowHandle(AParent);
+ CreateWnd;
+end;
+
+Procedure TRichTextView.CreateWnd;
+begin
+ProfileEvent('DEBUG: TRichTextView.CreateWnd >>>>');
+ if InDesigner then
+ exit;
+
+ { TODO -ograeme : I disabled bitmap fonts }
+ FFontManager := TCanvasFontManager.Create( Canvas,
+ False, // allow bitmap fonts
+ Self
+ );
+
+ FLastLinkOver := '';
+ FSelectionStart := -1;
+ FSelectionEnd := -1;
+
+ if FUseDefaultMenu then
+ begin
+ CreateDefaultMenu;
+ FPopupMenu := FDefaultMenu;
+ end;
+
+ FHScrollbar := TfpgScrollBar.Create( self );
+ FHScrollbar.Visible := False;
+ FHScrollbar.Orientation := orHorizontal;
+ FHScrollBar.SetPosition(2, Height-2-FScrollbarWidth, Width-4-FScrollbarWidth, FScrollbarWidth);
+
+ FVScrollbar := TfpgScrollBar.Create( self );
+ FVScrollBar.Visible := False;
+ FVScrollBar.Orientation := orVertical;
+ FVScrollbar.SetPosition(Width-2-FScrollbarWidth, 2, FScrollbarWidth, Height-4-FScrollbarWidth);
+
+// FScrollTimer := TfpgTimer.Create( 100 );
+// FScrollTimer.OnTimer := @OnScrollTimer;
+
+// FLinkCursor := GetLinkCursor;
+
+ if FLayoutRequired then
+ // we haven't yet done a layout
+ Layout;
+ProfileEvent('DEBUG: TRichTextView.CreateWnd <<<<');
+end;
+
+procedure TRichTextView.HandleResize(AWidth, AHeight: TfpgCoord);
+begin
+ inherited HandleResize(AWidth, AHeight);
+ if InDesigner then
+ exit;
+
+ if WinHandle = 0 then
+ exit;
+
+ RemoveCursor;
+ UpdateScrollbarCoords;
+
+ if FVerticalPositionInitialised then
+ begin
+ // Preserve current position
+ if FLayout.FNumLines > 0 then
+ FTopCharIndex := GetTopCharIndex
+ else
+ FTopCharIndex := 0;
+ end;
+
+ Layout;
+
+ // This is the point at which vertical position
+ // is initialised during first window show
+ FVScrollBar.Position := GetTopCharIndexPosition( FTopCharIndex );
+
+ FYScroll := FVScrollBar.Position;
+ FLastYScroll := FYScroll;
+ FVerticalPositionInitialised := true;
+
+ SetupCursor;
+end;
+
+procedure TRichTextView.UpdateScrollBarCoords;
+var
+ HWidth: integer;
+ VHeight: integer;
+begin
+ VHeight := Height - 4;
+ HWidth := Width - 4;
+
+ if FVScrollBar.Visible then
+ Dec(HWidth, FScrollbarWidth);
+ if FHScrollBar.Visible then
+ Dec(VHeight, FScrollbarWidth);
+
+ FHScrollBar.Top := Height -FHScrollBar.Height - 2;
+ FHScrollBar.Left := 2;
+ FHScrollBar.Width := HWidth;
+
+ FVScrollBar.Top := 2;
+ FVScrollBar.Left := Width - FVScrollBar.Width - 2;
+ FVScrollBar.Height := VHeight;
+
+ FVScrollBar.UpdateWindowPosition;
+ FHScrollBar.UpdateWindowPosition;
+end;
+
+
+// Main procedure: reads through the whole text currently stored
+// and breaks up into lines - each represented as a TLayoutLine in
+// the array FLines[ 0.. FNumLines ]
+Procedure TRichTextView.Layout;
+Var
+ DrawWidth: longint;
+begin
+ProfileEvent('DEBUG: TRichTextView.Layout >>>>');
+ FLayoutRequired := true;
+
+ if InDesigner then
+ exit;
+ if WinHandle = 0 then
+ exit;
+ProfileEvent('DEBUG: TRichTextView.Layout 1 of 6');
+ FSelectionEnd := -1;
+ FSelectionStart := -1;
+ RemoveCursor;
+
+ProfileEvent('DEBUG: TRichTextView.Layout 2');
+ DrawWidth := GetTextAreaRect.Width;
+
+ try
+ if Assigned(FLayout) then
+ begin
+ProfileEvent('DEBUG: TRichTextView.Layout 3');
+ FLayout.Free;
+ FLayout := nil;
+ end;
+ except
+ // this is only every a issue under 64bit. FLayout can suddenly not be referenced anymore
+ on E: Exception do
+ ProfileEvent('ERROR: Failed to free FLayout. Error Msg: ' + E.Message);
+// raise Exception.Create('Failed to free FLayout. Error msg: ' + E.Message);
+ end;
+
+ProfileEvent('DEBUG: TRichTextView.Layout 4');
+ FLayout := TRichTextLayout.Create( FText,
+ FImages,
+ FRichTextSettings,
+ FFontManager,
+ DrawWidth-(FScrollbarWidth*6) );
+
+ProfileEvent('DEBUG: TRichTextView.Layout 5');
+
+ SetupScrollBars;
+ProfileEvent('DEBUG: TRichTextView.Layout 6');
+ RefreshCursorPosition;
+
+ FLayoutRequired := false;
+ProfileEvent('DEBUG: TRichTextView.Layout <<<<');
+End;
+
+procedure TRichTextView.GetFirstVisibleLine( Var LineIndex: longint;
+ Var Offset: longint );
+begin
+ FLayout.GetLineFromPosition( FYScroll,
+ LineIndex,
+ Offset );
+end;
+
+procedure TRichTextView.GetBottomLine( Var LineIndex: longint;
+ Var PixelsDisplayed: longint );
+begin
+ FLayout.GetLineFromPosition( FYScroll + GetTextAreaHeight,
+ LineIndex,
+ PixelsDisplayed );
+end;
+
+function TRichTextView.FindPoint( XToFind: longint;
+ YToFind: longint;
+ Var LineIndex: longint;
+ Var Offset: longint;
+ Var Link: string ): TTextPosition;
+var
+ TextHeight: longint;
+begin
+ LineIndex := 0;
+ Offset := 0;
+ Link := '';
+
+ TextHeight := GetTextAreaHeight;
+
+// YToFind := Height - YToFind;
+
+ //if FBorderStyle = bsSingle then
+ //begin
+ // dec( YToFind, 2 );
+ // dec( XToFind, 2 );
+ //end;
+
+ if YToFind < 3 then
+ begin
+ // above the top
+ Result := tpAboveTextArea;
+ exit;
+ end;
+
+ if YToFind >= TextHeight then
+ begin
+ // below the bottom
+ Result := tpBelowTextArea;
+ LineIndex := FLayout.FNumLines;
+ Offset := FLayout.FLines^[ FLayout.FNumLines - 1 ].Length - 1;
+ exit;
+ end;
+
+ Result := FLayout.FindPoint( XToFind + FXScroll,
+ YToFind + FYScroll,
+ LineIndex,
+ Offset,
+ Link );
+end;
+
+Procedure TRichTextView.DrawBorder;
+var
+ Rect: TfpgRect;
+begin
+ Canvas.GetWinRect(Rect);
+ Canvas.DrawControlFrame(Rect);
+end;
+
+Procedure TRichTextView.Draw( StartLine, EndLine: longint );
+Var
+ DrawRect: TfpgRect;
+ X: longint;
+ Y: longint;
+ SelectionStartP: PChar;
+ SelectionEndP: PChar;
+ Temp: longint;
+begin
+ProfileEvent('DEBUG: TRichTextView.Draw >>>');
+ DrawRect := GetTextAreaRect;
+ if StartLine > EndLine then
+ begin
+ // swap
+ Temp := EndLine;
+ EndLine := StartLine;
+ StartLine := Temp;
+ end;
+ // calculate selection ptrs
+ if SelectionSet then
+ begin
+ SelectionStartP := FText + FSelectionStart;
+ SelectionEndP := FText + FSelectionEnd;
+ end
+ else
+ begin
+ SelectionStartP := nil;
+ SelectionEndP := nil;
+ end;
+ // calculate destination point
+ Y := DrawRect.Top + FYScroll;
+ X := DrawRect.Left - FXScroll;
+ DrawRichTextLayout( FFontManager,
+ FLayout,
+ SelectionStartP,
+ SelectionEndP,
+ StartLine,
+ EndLine,
+ Point(X, Y)
+ );
+ProfileEvent('DEBUG: TRichTextView.Draw <<<');
+End;
+
+// This gets the area of the control that we can draw on
+// (not taken up by vertical scroll bar)
+Function TRichTextView.GetDrawRect: TfpgRect;
+begin
+ Result := GetClientRect;
+ if InDesigner then
+ exit;
+
+ if FNeedHScroll then
+ dec( Result.Height, FScrollbarWidth );
+
+ if FNeedVScroll then
+ dec( Result.Width, FScrollbarWidth );
+end;
+
+// Gets the area that we are drawing text on, which is the
+// draw rect minus borders
+Function TRichTextView.GetTextAreaRect: TfpgRect;
+begin
+ Result := GetDrawRect;
+ InflateRect(Result, -2, -2);
+end;
+
+Function TRichTextView.GetTextAreaHeight: longint;
+var
+ TextArea: TfpgRect;
+begin
+ TextArea := GetTextAreaRect;
+ Result := TextArea.Height;
+end;
+
+Function TRichTextView.GetTextAreaWidth: longint;
+begin
+ Result := Width;
+ //if FBorderStyle <> bsNone then
+ dec( Result, 4 ); // borders of component
+ dec( Result, FScrollBarWidth ); // always allow space for vscrollbar
+end;
+
+Procedure TRichTextView.SetupScrollbars;
+var
+ AvailableWidth: longint;
+ MaxDisplayWidth: longint;
+ AvailableHeight: longint;
+Begin
+ // Calculate used and available width
+ AvailableWidth := GetTextAreaWidth;
+ MaxDisplayWidth := FLayout.Width;
+
+ // Defaults
+ FNeedVScroll := false;
+ FNeedHScroll := false;
+
+ // Horizontal scroll setup
+ if MaxDisplayWidth > AvailableWidth then
+ FNeedHScroll := true;
+
+// FHScrollbar.SliderSize := AvailableWidth div 2;
+ FHScrollbar.Min := 0;
+ if FNeedHScroll then
+ FHScrollbar.Max := MaxDisplayWidth
+ else
+ begin
+ FHScrollBar.Position := 0;
+ FHScrollbar.Max := 0;
+ end;
+
+ // Calculate available height.
+ // Note: this depends on whether a h scroll bar is needed.
+ AvailableHeight := GetTextAreaHeight; // this includes borders and scrollbars and small margin
+ if FLayout.Height > AvailableHeight then
+ FNeedVScroll := true;
+ FVScrollBar.Min := 0;
+ if FNeedVScroll then
+ FVScrollBar.Max := (FLayout.Height - AvailableHeight) + FScrollbarWidth
+ else
+ begin
+ FVScrollBar.Position := 0;
+ FVScrollBar.Max := 0;
+ end;
+
+ FHScrollBar.ScrollStep := 25; // pixels
+ FHScrollBar.PageSize := AvailableWidth div 2;
+ FVScrollBar.ScrollStep := 25; // not used (line up/down calculated explicitly)
+ FVScrollBar.PageSize := AvailableHeight div 2;
+
+ // Physical horizontal scroll setup
+ FHScrollbar.Visible := FNeedHScroll;
+ FHScrollbar.Enabled := FNeedHScroll;
+ FHScrollbar.Left := 2;
+ FHScrollbar.Top := Height - 2 - FScrollBarWidth;
+ FHScrollbar.Height := FScrollbarWidth;
+ if FNeedVScroll then
+ FHScrollbar.Width := Width - 4 - FScrollBarWidth
+ else
+ FHScrollbar.Width := Width - 4;
+
+ // Physical vertical scroll setup
+ FVScrollbar.Visible := FNeedVScroll;
+ FVScrollbar.Enabled := FNeedVScroll;
+ FVScrollbar.Left := Width - 2 - FScrollbarWidth;
+ FVScrollbar.Top := 2;
+ FVScrollbar.Width := FScrollbarWidth;
+ if FNeedHScroll then
+ FVScrollbar.Height := Height - 4 - FScrollbarWidth
+ else
+ FVScrollbar.Height := Height - 4;
+
+ // Initialise scroll
+ FYScroll := FVScrollBar.Position;
+ FLastYScroll := FYScroll;
+ FXScroll := FHScrollBar.Position;
+ FLastXScroll := FXScroll;
+
+ FVScrollbar.OnScroll := @FVScrollbarScroll;
+ FHScrollbar.OnScroll := @FHScrollbarScroll;
+End;
+
+Procedure TRichTextView.SetupCursor;
+var
+ Line: TLayoutLine;
+ X, Y: longint;
+ TextRect: TfpgRect;
+ DrawHeight: longint;
+ DrawWidth: longint;
+ CursorHeight: longint;
+ TextHeight: longint;
+ LineHeight: longint;
+ Descender: longint;
+ MaxDescender: longint;
+begin
+ RemoveCursor;
+ if FSelectionStart = -1 then
+ exit;
+
+ TextRect := GetTextAreaRect;
+ DrawHeight := TextRect.Top - TextRect.Bottom;
+ DrawWidth := TextRect.Right - TextRect.Left;
+
+ Line := FLayout.FLines^[ CursorRow ];
+ LineHeight := Line.Height;
+
+ Y := DrawHeight
+ - ( FLayout.GetLinePosition( CursorRow )
+ - FVScrollbar.Position );
+ // Now Y is the top of the line
+ if Y < 0 then
+ // off bottom
+ exit;
+ if ( Y - LineHeight ) > DrawHeight then
+ // off top
+ exit;
+
+ FLayout.GetXFromOffset( FCursorOffset, CursorRow, X );
+
+ X := X - FHScrollBar.Position;
+
+ if X < 0 then
+ // offscreen to left
+ exit;
+
+ if X > DrawWidth then
+ // offscreen to right
+ exit;
+
+ TextHeight := FFontManager.CharHeight;
+ Descender := FFontManager.CharDescender;
+ MaxDescender := FLayout.FLines^[ CursorRow ].MaxDescender;
+ CursorHeight := TextHeight;
+
+ dec( Y, LineHeight - 1 );
+ // now Y is the BOTTOM of the line
+
+ // move Y up to the bottom of the cursor;
+ // since the current text may be smaller than the highest in the line
+ inc( Y, MaxDescender - Descender );
+
+ if Y < 0 then
+ begin
+ // bottom of line will be below bottom of display.
+ dec( CursorHeight, 1 - Y );
+ Y := 0;
+ end;
+
+ if Y + CursorHeight - 1 > DrawHeight then
+ begin
+ // top of cursor will be above top of display
+ CursorHeight := DrawHeight - Y + 1;
+ end;
+
+// fpgCaret.SetCaret(Canvas, TextRect.Left + X, TextRect.Bottom + Y, 2, CursorHeight);
+end;
+
+procedure TRichTextView.RemoveCursor;
+begin
+// fpgCaret.UnSetCaret(Canvas);
+end;
+
+Function TRichTextView.GetLineDownPosition: longint;
+var
+ LastLine: longint;
+ PixelsDisplayed: longint;
+begin
+ GetBottomLine( LastLine,
+ PixelsDisplayed );
+
+ Result := GetLineDownPositionFrom( LastLine, PixelsDisplayed );
+end;
+
+Function TRichTextView.GetLineDownPositionFrom( LastLine: longint;
+ PixelsDisplayed: longint ): longint;
+var
+ LineHeight: longint;
+begin
+ if LastLine = -1 then
+ exit;
+
+ LineHeight := FLayout.FLines^[ LastLine ].Height;
+
+ if LastLine = FLayout.FNumLines - 1 then
+ begin
+ // last line
+ if PixelsDisplayed >= LineHeight then
+ begin
+ // and it's fully displayed, so scroll to show margin
+ Result := FLayout.Height - GetTextAreaHeight;
+ exit;
+ end;
+ end;
+
+ // Scroll to make last line fully visible...
+ Result := FVScrollBar.Position
+ + LineHeight
+ - PixelsDisplayed;
+ if PixelsDisplayed > LineHeight div 2 then
+ // more than half line already displayed so
+ if LastLine < FLayout.FNumLines - 1 then
+ // AND to make next line fully visible
+ inc( Result, FLayout.FLines^[ LastLine + 1 ].Height );
+end;
+
+Function TRichTextView.GetSmallDownScrollPosition: longint;
+var
+ LastLine: longint;
+ PixelsDisplayed: longint;
+ LineTextHeight: longint;
+ Diff: longint;
+begin
+ GetBottomLine( LastLine,
+ PixelsDisplayed );
+
+ Result := GetLineDownPositionFrom( LastLine, PixelsDisplayed );
+
+ // Now limit the scrolling to max text height for the bottom line
+ Diff := Result - FVScrollBar.Position;
+
+ LineTextHeight := FLayout.FLines^[ LastLine ].MaxTextHeight;
+ if Diff > LineTextHeight then
+ Diff := LineTextHeight;
+ Result := FVScrollBar.Position + Diff;
+end;
+
+Function TRichTextView.GetSmallUpScrollPosition: longint;
+var
+ FirstVisibleLine: longint;
+ Offset: longint;
+ LineTextHeight: longint;
+ Diff: longint;
+begin
+ GetFirstVisibleLine( FirstVisibleLine,
+ Offset );
+ Result := GetLineUpPositionFrom( FirstVisibleLine,
+ Offset );
+ // Now limit the scrolling to max text height for the bottom line
+ Diff := FVScrollBar.Position - Result;
+
+ LineTextHeight := FLayout.FLines^[ FirstVisibleLine ].MaxTextHeight;
+ if Diff > LineTextHeight then
+ Diff := LineTextHeight;
+ Result := FVScrollBar.Position - Diff;
+end;
+
+Function TRichTextView.GetSmallRightScrollPosition: longint;
+begin
+ Result := FHScrollBar.Position + FHScrollBar.ScrollStep;
+ if Result > FHScrollBar.Max then
+ Result := FHScrollBar.Max;
+end;
+
+Function TRichTextView.GetSmallLeftScrollPosition: longint;
+begin
+ Result := FHScrollBar.Position - FHScrollBar.ScrollStep;
+ if Result < 0 then
+ Result := 0;
+end;
+
+Function TRichTextView.GetLineUpPosition: longint;
+var
+ FirstVisibleLine: longint;
+ Offset: longint;
+begin
+ GetFirstVisibleLine( FirstVisibleLine, Offset );
+ Result := GetLineUpPositionFrom( FirstVisibleLine, Offset );
+end;
+
+Function TRichTextView.GetLineUpPositionFrom( FirstVisibleLine: longint;
+ Offset: longint ): longint;
+begin
+ // we should never have scrolled all lines off the top!!
+ assert( FirstVisibleLine <> -1 );
+
+ if FirstVisibleLine = 0 then
+ begin
+ // first line
+ if Offset = 0 then
+ begin
+ // and it's already fully visible, so scroll to show margin
+ Result := 0;
+ exit;
+ end;
+ end;
+
+ // scroll so that top line is fully visible...
+ Result := FVScrollBar.Position
+ - Offset;
+
+ if Offset < (FLayout.FLines^[ FirstVisibleLine ].Height div 2) then
+ // more than half the line was already displayed so
+ if FirstVisibleLine > 0 then
+ // AND to make next line up visible
+ dec( Result, FLayout.FLines^[ FirstVisibleLine - 1 ].Height );
+
+end;
+
+Function Sign( arg: longint ): longint;
+begin
+ if arg>0 then
+ Result := 1
+ else if arg<0 then
+ Result := -1
+ else
+ Result := 0;
+end;
+
+Function FSign( arg: double ): double;
+begin
+ if arg>0 then
+ Result := 1
+ else if arg<0 then
+ Result := -1
+ else
+ Result := 0;
+end;
+
+Procedure ExactDelay( MS: Cardinal );
+begin
+ Sleep(MS);
+end;
+
+(*
+Procedure TRichTextView.Scroll( Sender: TScrollbar;
+ ScrollCode: TScrollCode;
+ Var ScrollPos: Longint );
+
+begin
+ case ScrollCode of
+// scVertEndScroll,
+// scVertPosition,
+ scPageUp,
+ scPageDown,
+ scVertTrack:
+ DoVerticalScroll( ScrollPos );
+
+ // Line up and down positions are calculated for each case
+ scLineDown:
+ begin
+ ScrollPos := GetSmallDownScrollPosition;
+ DoVerticalScroll( ScrollPos );
+ end;
+
+ scLineUp:
+ begin
+ ScrollPos := GetSmallUpScrollPosition;
+ DoVerticalScroll( ScrollPos );
+ end;
+
+ scHorzPosition,
+ scPageRight,
+ scPageLeft,
+ scHorzTrack,
+ scColumnRight,
+ scColumnLeft:
+ begin
+ DoHorizontalScroll( ScrollPos );
+ end;
+ end;
+end;
+*)
+
+Procedure TRichTextView.DoVerticalScroll( NewY: longint );
+//var
+// ScrollDistance: longint;
+begin
+ FYScroll := 0 - NewY;
+
+ if not Visible then
+ begin
+ FLastYScroll := FYScroll;
+ exit;
+ end;
+
+// ScrollDistance := FYScroll - FLastYScroll;
+
+ { TODO -ograeme -cscrolling : Implement vertical scrolling here }
+ //ScrollControlRect( Self,
+ // GetTextAreaRect,
+ // 0,
+ // ScrollDistance,
+ // Color,
+ // FSmoothScroll );
+
+ FLastYScroll := FYScroll;
+ RePaint;
+ SetupCursor;
+end;
+
+Procedure TRichTextView.DoHorizontalScroll( NewX: longint );
+var
+ ScrollDistance: longint;
+begin
+ FXScroll := NewX;
+
+ if not Visible then
+ begin
+ FLastXScroll := FXScroll;
+ exit;
+ end;
+
+// ScrollDistance := FXScroll - FLastXScroll;
+
+ { TODO -ograemeg -cscrolling : Implement horizontal scrolling }
+ //ScrollControlRect( Self,
+ // GetTextAreaRect,
+ // - ScrollDistance,
+ // 0,
+ // Color,
+ // FSmoothScroll );
+
+ FLastXScroll := FXScroll;
+ RePaint;
+ SetupCursor;
+end;
+
+Procedure TRichTextView.SetVerticalPosition( NewY: longint );
+begin
+ FVScrollbar.Position := NewY;
+ FVScrollbar.RepaintSlider;
+ DoVerticalScroll( FVScrollbar.Position );
+end;
+
+Procedure TRichTextView.SetHorizontalPosition( NewX: longint );
+begin
+ FHScrollbar.Position := NewX;
+ FHScrollbar.RepaintSlider;
+ DoHorizontalScroll( FHScrollbar.Position );
+end;
+
+Procedure TRichTextView.AddParagraph( Text: PChar );
+begin
+ if GetTextEnd > 0 then
+ begin
+ AddText( #13, True );
+ AddText( #10, True );
+ end;
+ AddText( Text );
+end;
+
+Procedure TRichTextView.AddSelectedParagraph( Text: PChar );
+begin
+ if GetTextEnd > 0 then
+ begin
+ AddText( #13, True);
+ AddText( #10, True);
+ end;
+ SelectionStart := GetTextEnd;
+ AddText( Text );
+ SelectionEnd := GetTextEnd;
+ MakeCharVisible( SelectionStart );
+end;
+
+// ADelay = True means that we hold off on redoing the Layout and Painting.
+Procedure TRichTextView.AddText( Text: PChar; ADelay: boolean );
+var
+ s: string;
+begin
+ s := Text;
+ // Warning: Hack Alert! replace some strange Bell character found in some INF files
+// s := SubstituteChar(s, Chr($07), Chr($20) );
+ s := StringReplace(s, Chr($07), '•', [rfReplaceAll, rfIgnoreCase]);
+
+//// Hack Alert #2: replace strange table chars with something we can actually see
+// s := SubstituteChar(s, Chr(218), Char('+') ); // top-left corner
+// s := SubstituteChar(s, Chr(196), Char('-') ); // horz row deviders
+// s := SubstituteChar(s, Chr(194), Char('-') ); // centre top T connection
+// s := SubstituteChar(s, Chr(191), Char('+') ); // top-right corner
+// s := SubstituteChar(s, Chr(192), Char('+') ); // bot-left corner
+// s := SubstituteChar(s, Chr(193), Char('-') ); // centre bottom inverted T
+// s := SubstituteChar(s, Chr(197), Char('+') );
+// s := SubstituteChar(s, Chr(179), Char('|') ); //
+// s := SubstituteChar(s, Chr(195), Char('|') );
+// s := SubstituteChar(s, Chr(180), Char('|') );
+// s := SubstituteChar(s, Chr(217), Char('+') ); // bot-right corner
+
+
+
+
+ AddAndResize( FText, PChar(s) );
+ if not ADelay then
+ begin
+ Layout;
+ RePaint;
+ end;
+end;
+
+// Insert at current point
+Procedure TRichTextView.InsertText( CharIndexToInsertAt: longword;
+ TextToInsert: PChar );
+var
+ NewText: PChar;
+begin
+ if CharIndexToInsertAt < 0 then
+ exit;
+
+ NewText := StrAlloc( StrLen( FText ) + StrLen( TextToInsert ) + 1 );
+ StrLCopy( NewText, FText, CharIndexToInsertAt );
+ StrCat( NewText, TextToInsert );
+ StrCat( NewText, FText + CharIndexToInsertAt );
+
+ Clear;
+ AddText( NewText );
+ StrDispose( NewText );
+end;
+
+Procedure TRichTextView.Clear(const ADestroying: boolean = False);
+begin
+ ClearSelection;
+ FText[ 0 ] := #0;
+ FTopCharIndex := 0;
+ if not ADestroying then
+ begin
+ Layout;
+ if FLayout.FNumLines > 1 then
+ raise Exception.Create('FLayout.FNumLines should have been 0 but it was ' + IntToStr(FLayout.FNumLines));
+ RePaint;
+ end;
+end;
+
+//procedure TRichTextView.SetBorder( BorderStyle: TBorderStyle );
+//begin
+// FBorderStyle := BorderStyle;
+// Refresh;
+//end;
+
+Procedure TRichTextView.SetImages( Images: TfpgImageList );
+begin
+ if Images = FImages then
+ exit; // no change
+
+ { TODO -oGraeme : TfpgImageList is not a TComponent descendant. Maybe it should be? }
+ //if FImages <> nil then
+ // // Tell the old imagelist not to inform us any more
+ // FImages.Notification( Self, opRemove );
+
+ FImages := Images;
+ //if FImages <> nil then
+ // // request notification when other is freed
+ // FImages.FreeNotification( Self );
+
+ if GetTextEnd = 0 then
+ // no text - can't be any image references - no need to layout
+ exit;
+
+ Layout;
+ RePaint;
+end;
+
+Procedure TRichTextView.OnRichTextSettingsChanged( Sender: TObject );
+begin
+ if not InDesigner then
+ begin
+ Layout;
+ RePaint;
+ end;
+end;
+
+Procedure TRichTextView.Notification( AComponent: TComponent;
+ Operation: TOperation );
+begin
+ inherited Notification( AComponent, Operation );
+ { TODO -oGraeme : TfpgImageList is not a TComponent descendant. Maybe it should be? }
+ //if AComponent = FImages then
+ // if Operation = opRemove then
+ // FImages := nil;
+end;
+
+(*
+Procedure TRichTextView.MouseDown( Button: TMouseButton;
+ ShiftState: TShiftState;
+ X, Y: Longint );
+var
+ Line: longint;
+ Offset: longint;
+ Link: string;
+ Position: TTextPosition;
+ Shift: boolean;
+begin
+ Focus;
+
+ inherited MouseDown( Button, ShiftState, X, Y );
+
+ if Button <> mbLeft then
+ begin
+ if Button = mbRight then
+ begin
+ if MouseCapture then
+ begin
+ // this is a shortcut - left mouse drag to select, right mouse to copy
+ CopySelectionToClipboard;
+ end;
+ end;
+ exit;
+ end;
+
+// if FText[ 0 ] = #0 then
+// exit;
+
+ Position := FindPoint( X, Y, Line, Offset, Link );
+ FClickedLink := Link;
+
+ if Position in [ tpAboveTextArea,
+ tpBelowTextArea ] then
+ // not on the control (this probably won't happen)
+ exit;
+
+ // if shift is pressed then keep the same selection start.
+
+ Shift := ssShift in ShiftState;
+ RemoveCursor;
+
+ if not Shift then
+ ClearSelection;
+
+ SetCursorPosition( Offset, Line, Shift );
+ MouseCapture := true;
+
+end;
+*)
+
+(*
+Procedure TRichTextView.MouseUp( Button: TMouseButton;
+ ShiftState: TShiftState;
+ X, Y: Longint );
+begin
+ if Button = mbRight then
+ if MouseCapture then
+ // don't popup menu for shortcut - left mouse drag to select, right mouse to copy
+ exit;
+
+ inherited MouseUp( Button, ShiftState, X, Y );
+
+ if Button <> mbLeft then
+ exit;
+
+ if not MouseCapture then
+ // not a mouse up from a link click
+ exit;
+
+ if FScrollTimer.Running then
+ FScrollTimer.Stop;
+
+ MouseCapture := false;
+
+ SetupCursor;
+
+ if FClickedLink <> '' then
+ if Assigned( FOnClickLink ) then
+ FOnClickLink( Self, FClickedLink );
+
+end;
+*)
+
+(*
+Procedure TRichTextView.MouseDblClick( Button: TMouseButton;
+ ShiftState: TShiftState;
+ X, Y: Longint );
+var
+ Row: longint;
+ Offset: longint;
+ Link: string;
+ Position: TTextPosition;
+ P: PChar;
+ pWordStart: PChar;
+ WordLength: longint;
+begin
+ inherited MouseDblClick( Button, ShiftState, X, Y );
+
+ if Button <> mbLeft then
+ exit;
+
+// if FText[ 0 ] = #0 then
+// exit;
+
+ Position := FindPoint( X, Y, Row, Offset, Link );
+
+ if Position in [ tpAboveTextArea,
+ tpBelowTextArea ] then
+ // not on the control (this probably won't happen)
+ exit;
+
+ Assert( Row >= 0 );
+ Assert( Row < FLayout.FNumLines );
+
+ P := FLayout.FLines[ Row ].Text + Offset;
+
+ RemoveCursor;
+
+ if not RichTextWordAt( FText,
+ P,
+ pWordStart,
+ WordLength ) then
+ begin
+ // not in a word
+ SetCursorPosition( Offset, Row, false );
+ SetupCursor;
+ exit;
+ end;
+
+ SetSelectionStartInternal( FLayout.GetCharIndex( pWordStart ) );
+ SetSelectionEndInternal( FLayout.GetCharIndex( pWordStart )
+ + WordLength );
+ RefreshCursorPosition;
+ SetupCursor;
+end;
+*)
+
+(*
+Procedure TRichTextView.MouseMove( ShiftState: TShiftState;
+ X, Y: Longint );
+var
+ Line: longint;
+ Offset: longint;
+ Link: string;
+ Position: TTextPosition;
+begin
+ inherited MouseMove( ShiftState, X, Y );
+
+ Position := FindPoint( X, Y, Line, Offset, Link );
+
+ if not MouseCapture then
+ begin
+ if Link <> FLastLinkOver then
+ begin
+ if Link <> '' then
+ begin
+ if Assigned( FOnOverLink ) then
+ FOnOverLink( Self, Link )
+ end
+ else
+ begin
+ if Assigned( FOnNotOverLink ) then
+ FOnNotOverLink( Self, FLastLinkOver );
+ end;
+
+ FLastLinkOver := Link;
+ end;
+
+ if Link <> '' then
+ Cursor := FLinkCursor
+ else
+ Cursor := crIBeam;
+ exit;
+ end;
+
+ // We are holding mouse down and dragging to set a selection:
+
+ if Position in [ tpAboveTextArea,
+ tpBelowTextArea ] then
+ begin
+ // above top or below bottom of control
+ FOldMousePoint := Point( X, Y );
+
+ if Position = tpAboveTextArea then
+ FScrollingDirection := sdUp
+ else
+ FScrollingDirection := sdDown;
+
+ if not FScrollTimer.Running then
+ begin
+ FScrollTimer.Start;
+ OnScrollTimer( self );
+ end;
+ exit;
+ end;
+
+ // Normal selection, cursor within text rect
+ if FScrollTimer.Running then
+ FScrollTimer.Stop;
+
+ SetCursorPosition( Offset,
+ Line,
+ true );
+
+ if SelectionSet then
+ begin
+ FClickedLink := ''; // if they move while on a link we don't want to follow it.
+ Cursor := crIBeam;
+ end;
+
+end;
+*)
+
+procedure TRichTextView.OnScrollTimer( Sender: TObject );
+var
+ Line, Offset: longint;
+ MousePoint: TPoint;
+ TextRect: TRect;
+begin
+ exit;
+ //MousePoint := Screen.MousePos;
+ //MousePoint := ScreenToClient( MousePoint );
+ //TextRect := GetTextAreaRect;
+ //
+ //if FScrollingDirection = sdDown then
+ // // scrolling down
+ // if FVScrollbar.Position = FVScrollbar.Max then
+ // exit
+ // else
+ // begin
+ // if ( TextRect.Bottom - MousePoint.Y ) < 20 then
+ // DownLine
+ // else
+ // DownPage;
+ //
+ // GetBottomLine( Line, Offset );
+ // SetSelectionEndInternal( FLayout.GetCharIndex( FLayout.Flines[ Line ].Text )
+ // + FLayout.FLines[ Line ].Length );
+ // end
+ //else
+ // // scrolling up
+ // if FVScrollbar.Position = FVScrollbar.Min then
+ // exit
+ // else
+ // begin
+ // if ( MousePoint.Y - TextRect.Top ) < 20 then
+ // UpLine
+ // else
+ // UpPage;
+ // GetFirstVisibleLine( Line, Offset );
+ // SetSelectionEndInternal( FLayout.GetCharIndex( FLayout.FLines[ Line ].Text ) );
+ // end;
+
+end;
+
+Procedure TRichTextView.UpLine;
+begin
+ SetVerticalPosition( GetLineUpPosition );
+end;
+
+Procedure TRichTextView.DownLine;
+begin
+ SetVerticalPosition( GetLineDownPosition );
+end;
+
+Procedure TRichTextView.UpPage;
+begin
+ SetVerticalPosition( FVScrollbar.Position - FVScrollbar.PageSize );
+end;
+
+Procedure TRichTextView.DownPage;
+begin
+ SetVerticalPosition( FVScrollbar.Position + FVScrollbar.PageSize );
+end;
+
+Procedure TRichTextView.SmallScrollUp;
+begin
+ SetVerticalPosition( GetSmallUpScrollPosition );
+end;
+
+Procedure TRichTextView.SmallScrollDown;
+begin
+ SetVerticalPosition( GetSmallDownScrollPosition );
+end;
+
+Procedure TRichTextView.SmallScrollRight;
+begin
+ SetHorizontalPosition( GetSmallRightScrollPosition );
+end;
+
+Procedure TRichTextView.SmallScrollLeft;
+begin
+ SetHorizontalPosition( GetSmallLeftScrollPosition );
+end;
+
+function TRichTextView.GetCursorIndex: longint;
+begin
+ if FCursorRow = -1 then
+ begin
+ Result := -1;
+ exit;
+ end;
+ Result := FLayout.GetCharIndex( FLayout.FLines^[ FCursorRow ].Text ) + FCursorOffset;
+end;
+
+procedure TRichTextView.RefreshCursorPosition;
+var
+ Index: longint;
+ Row: longint;
+begin
+ if SelectionSet then
+ begin
+ Index := FSelectionEnd
+ end
+ else
+ begin
+ Index := FSelectionStart;
+ end;
+
+ if Index = -1 then
+ begin
+ FCursorRow := -1;
+ FCursorOffset := 0;
+ RemoveCursor;
+ exit;
+ end;
+
+ Row := FLayout.GetLineFromCharIndex( Index );
+ SetCursorPosition( Index - FLayout.GetCharIndex( FLayout.FLines^[ Row ].Text ),
+ Row,
+ true );
+end;
+
+procedure TRichTextView.SetCursorIndex( Index: longint;
+ PreserveSelection: boolean );
+var
+ Row: longint;
+begin
+ Row := FLayout.GetLineFromCharIndex( Index );
+ SetCursorPosition( Index - FLayout.GetCharIndex( FLayout.FLines^[ Row ].Text ),
+ Row,
+ PreserveSelection );
+ SetupCursor;
+end;
+
+procedure TRichTextView.SetCursorPosition( Offset: longint;
+ Row: longint;
+ PreserveSelection: boolean );
+var
+ Index: longint;
+begin
+ RemoveCursor;
+ FCursorOffset := Offset;
+ FCursorRow := Row;
+ Index := FLayout.GetCharIndex( FLayout.FLines^[ Row ].Text ) + Offset;
+ if PreserveSelection then
+ begin
+ SetSelectionEndInternal( Index )
+ end
+ else
+ begin
+ SetSelectionEndInternal( -1 );
+ SetSelectionStartInternal( Index );
+ end;
+ MakeRowAndColumnVisible( FCursorRow, Offset );
+end;
+
+Procedure TRichTextView.CursorRight( PreserveSelection: boolean );
+Var
+ P: PChar;
+ NextP: PChar;
+ Element: TTextElement;
+ NewOffset: longint;
+ Line: TLayoutLine;
+begin
+ P := FText + CursorIndex;
+
+ Element := ExtractNextTextElement( P, NextP );
+ P := NextP;
+ while Element.ElementType = teStyle do
+ begin
+ Element := ExtractNextTextElement( P, NextP );
+ P := NextP;
+ end;
+
+// if Element.ElementType = teTextEnd then
+// exit;
+
+// SetCursorIndex( GetCharIndex( P ), PreserveSelection );
+ Line := FLayout.FLines^[ CursorRow ];
+ NewOffset := PCharDiff( P, Line.Text );
+ if NewOffset < Line.Length then
+ begin
+ SetCursorPosition( NewOffset, FCursorRow, PreserveSelection )
+ end
+ else if ( NewOffset = Line.Length )
+ and not Line.Wrapped then
+ begin
+ SetCursorPosition( NewOffset, FCursorRow, PreserveSelection )
+ end
+ else
+ begin
+ if FCursorRow >= FLayout.FNumLines - 1 then
+ exit;
+ SetCursorPosition( 0, FCursorRow + 1, PreserveSelection );
+ end;
+ SetupCursor;
+end;
+
+Procedure TRichTextView.CursorLeft( PreserveSelection: boolean );
+Var
+ P: PChar;
+ NextP: PChar;
+ Element: TTextElement;
+ Line: TLayoutLine;
+ NewOffset: longint;
+begin
+ P := FText + CursorIndex;
+
+ Element := ExtractPreviousTextElement( FText, P, NextP );
+ P := NextP;
+ while Element.ElementType = teStyle do
+ begin
+ Element := ExtractPreviousTextElement( FText, P, NextP );
+ P := NextP;
+ end;
+
+// if Element.ElementType = teTextEnd then
+// exit;
+ Line := FLayout.FLines^[ CursorRow ];
+ NewOffset := PCharDiff( P, Line.Text );
+ if NewOffset >= 0 then
+ begin
+ SetCursorPosition( NewOffset, FCursorRow, PreserveSelection )
+ end
+ else
+ begin
+ if FCursorRow <= 0 then
+ exit;
+ Line := FLayout.FLines^[ CursorRow - 1 ];
+ if Line.Wrapped then
+ SetCursorPosition( Line.Length - 1, FCursorRow - 1, PreserveSelection )
+ else
+ SetCursorPosition( Line.Length, FCursorRow - 1, PreserveSelection )
+ end;
+ SetupCursor;
+
+end;
+
+Procedure TRichTextView.CursorWordLeft( PreserveSelection: boolean );
+Var
+ P: PChar;
+begin
+ P := FText + CursorIndex;
+
+ P := RichTextWordLeft( FText, P );
+
+ SetCursorIndex( FLayout.GetCharIndex( P ),
+ PreserveSelection );
+end;
+
+Procedure TRichTextView.CursorWordRight( PreserveSelection: boolean );
+Var
+ P: PChar;
+begin
+ P := FText + CursorIndex;
+
+ P := RichTextWordRight( P );
+
+ SetCursorIndex( FLayout.GetCharIndex( P ),
+ PreserveSelection );
+end;
+
+Procedure TRichTextView.CursorToLineStart( PreserveSelection: boolean );
+Var
+ Line: TLayoutLine;
+begin
+ Line := FLayout.FLines^[ FCursorRow ];
+ SetCursorPosition( 0, FCursorRow, PreserveSelection );
+ SetupCursor;
+end;
+
+Procedure TRichTextView.CursorToLineEnd( PreserveSelection: boolean );
+Var
+ Line: TLayoutLine;
+begin
+ Line := FLayout.FLines^[ FCursorRow ];
+ SetCursorPosition( Line.Length, FCursorRow, PreserveSelection );
+ SetupCursor;
+end;
+
+Procedure TRichTextView.CursorDown( PreserveSelection: boolean );
+var
+ X: longint;
+ Link: string;
+ Offset: longint;
+begin
+ if CursorRow >= FLayout.FNumLines - 1 then
+ exit;
+
+ FLayout.GetXFromOffset( FCursorOffset, FCursorRow, X );
+ FLayout.GetOffsetFromX( X,
+ FCursorRow + 1,
+ Offset,
+ Link );
+
+ SetCursorPosition( Offset, FCursorRow + 1, PreserveSelection );
+ SetupCursor;
+end;
+
+Procedure TRichTextView.CursorUp( PreserveSelection: boolean );
+var
+ X: longint;
+ Link: string;
+ Offset: longint;
+begin
+ if CursorRow <= 0 then
+ exit;
+
+ FLayout.GetXFromOffset( FCursorOffset,
+ FCursorRow,
+ X );
+ FLayout.GetOffsetFromX( X,
+ FCursorRow - 1,
+ Offset,
+ Link );
+
+ SetCursorPosition( Offset, FCursorRow - 1, PreserveSelection );
+ SetupCursor;
+
+end;
+
+Procedure TRichTextView.CursorPageDown( PreserveSelection: boolean );
+var
+ X: longint;
+ Link: string;
+ Offset: longint;
+ Distance: longint;
+ NewRow: longint;
+begin
+ NewRow := CursorRow;
+ Distance := 0;
+ while ( Distance < GetTextAreaHeight ) do
+ begin
+ if NewRow >= FLayout.FNumLines - 1 then
+ break;
+
+ Distance := Distance + FLayout.FLines^[ NewRow ].Height;
+ inc( NewRow );
+ end;
+
+ FLayout.GetXFromOffset( FCursorOffset, FCursorRow, X );
+ FLayout.GetOffsetFromX( X, NewRow, Offset, Link );
+ SetCursorPosition( Offset, NewRow, PreserveSelection );
+ SetupCursor;
+end;
+
+Procedure TRichTextView.CursorPageUp( PreserveSelection: boolean );
+var
+ X: longint;
+ Link: string;
+ Offset: longint;
+ Distance: longint;
+ NewRow: longint;
+begin
+ NewRow := CursorRow;
+ Distance := 0;
+ while ( Distance < GetTextAreaHeight ) do
+ begin
+ if NewRow <= 0 then
+ break;
+ dec( NewRow );
+ Distance := Distance + FLayout.FLines^[ NewRow ].Height;
+ end;
+
+ FLayout.GetXFromOffset( FCursorOffset, FCursorRow, X );
+ FLayout.GetOffsetFromX( X, NewRow, Offset, Link );
+ SetCursorPosition( Offset, NewRow, PreserveSelection );
+ SetupCursor;
+end;
+
+Function TRichTextView.GetSelectionAsString: string; // returns up to 255 chars obviously
+var
+ Buffer: array[ 0..255 ] of char;
+ Length: longint;
+begin
+ Length := CopySelectionToBuffer( Addr( Buffer ), 255 );
+
+ Result := StrNPas( Buffer, Length );
+end;
+
+Procedure TRichTextView.CopySelectionToClipboard;
+var
+ SelLength: Longint;
+ Buffer: PChar;
+begin
+ SelLength := SelectionLength;
+ if SelectionLength = 0 then
+ exit;
+
+ Buffer := StrAlloc( SelLength + 1 );
+
+ CopySelectionToBuffer( Buffer, SelLength + 1 );
+
+ fpgClipboard.Text := Buffer;
+
+ StrDispose( Buffer );
+end;
+
+function TRichTextView.CopySelectionToBuffer( Buffer: PChar;
+ BufferLength: longint ): longint;
+var
+ P, EndP: PChar;
+begin
+ Result := 0;
+ if ( FSelectionStart = -1 )
+ or ( FSelectionEnd = -1 ) then
+ exit;
+
+ if FSelectionStart < FSelectionEnd then
+ begin
+ P := FText + FSelectionStart;
+ EndP := FText + FSelectionEnd;
+ end
+ else
+ begin
+ P := FText + FSelectionEnd;
+ EndP := FText + FSelectionStart;
+ end;
+
+ Result := CopyPlainTextToBuffer( P,
+ EndP,
+ Buffer,
+ BufferLength );
+end;
+
+function TRichTextView.CopyTextToBuffer( Buffer: PChar;
+ BufferLength: longint ): longint;
+begin
+ Result := CopyPlainTextToBuffer( FText,
+ FText + strlen( FText ),
+ Buffer,
+ BufferLength );
+end;
+
+Function TRichTextView.SelectionLength: longint;
+begin
+ Result := 0;
+ if ( FSelectionStart = -1 )
+ or ( FSelectionEnd = -1 ) then
+ exit;
+
+ Result := FSelectionEnd - FSelectionStart;
+ if Result < 0 then
+ Result := FSelectionStart - FSelectionEnd;
+end;
+
+Function TRichTextView.SelectionSet: boolean;
+begin
+ Result := ( FSelectionStart <> -1 )
+ and ( FSelectionEnd <> - 1 )
+ and ( FSelectionStart <> FSelectionEnd );
+end;
+
+Procedure TRichTextView.SelectAll;
+begin
+ ClearSelection;
+ SelectionStart := FLayout.GetCharIndex( FText );
+ SelectionEnd := FLayout.GetTextEnd;
+end;
+
+(*
+procedure TRichTextView.ScanEvent( Var KeyCode: TKeyCode;
+ RepeatCount: Byte );
+var
+ CursorVisible: boolean;
+ Shift: boolean;
+ Key: TKeyCode;
+begin
+ CursorVisible := FSelectionStart <> -1;
+
+ Case KeyCode of
+ kbTab:
+ begin
+ if HighlightNextLink then
+ begin
+ KeyCode := kbNull;
+ exit;
+ end;
+ end;
+
+ kbShiftTab:
+ begin
+ if HighlightPreviousLink then
+ begin
+ KeyCode := kbNull;
+ exit;
+ end;
+ end;
+
+ kbEnter:
+ begin
+
+ end;
+ end;
+
+ Shift := KeyCode and kb_Shift > 0 ;
+ Key := KeyCode and ( not kb_Shift );
+
+ // Keys which work the same regardless of whether
+ // cursor is present or not
+ case Key of
+ kbCtrlC, kbCtrlIns:
+ CopySelectionToClipboard;
+ kbCtrlA:
+ SelectAll;
+
+ kbAltCUp:
+ SmallScrollUp;
+ kbAltCDown:
+ SmallScrollDown;
+ kbAltCLeft:
+ SmallScrollLeft;
+ kbAltCRight:
+ SmallScrollRight;
+ end;
+
+ // Keys which change behaviour if cursor is present
+ if CursorVisible then
+ begin
+ case Key of
+ kbCUp:
+ CursorUp( Shift );
+ kbCDown:
+ CursorDown( Shift );
+
+ // these next two are not exactly orthogonal or required,
+ // but better match other text editors.
+ kbCtrlCUp:
+ if Shift then
+ CursorUp( Shift )
+ else
+ SmallScrollUp;
+ kbCtrlCDown:
+ if Shift then
+ CursorDown( Shift )
+ else
+ SmallScrollDown;
+
+ kbCRight:
+ CursorRight( Shift );
+ kbCLeft:
+ CursorLeft( Shift );
+
+ kbCtrlCLeft:
+ CursorWordLeft( Shift );
+ kbCtrlCRight:
+ CursorWordRight( Shift );
+
+ kbCtrlHome, kbCtrlPageUp:
+ SetCursorIndex( 0, Shift );
+ kbCtrlEnd, kbCtrlPageDown:
+ SetCursorIndex( GetTextEnd, Shift );
+
+ kbPageUp:
+ CursorPageUp( Shift );
+ kbPageDown:
+ CursorPageDown( Shift );
+
+ kbHome:
+ CursorToLineStart( Shift );
+ kbEnd:
+ CursorToLineEnd( Shift );
+ end
+ end
+ else // no cursor visible
+ begin
+ case Key of
+ kbCUp, kbCtrlCUp:
+ SmallScrollUp;
+ kbCDown, kbCtrlCDown:
+ SmallScrollDown;
+
+ kbCLeft, kbCtrlCLeft:
+ SmallScrollLeft;
+ kbCRight, kbCtrlCRight:
+ SmallScrollRight;
+
+ kbPageUp:
+ UpPage;
+ kbPageDown:
+ DownPage;
+
+ kbHome, kbCtrlHome, kbCtrlPageUp:
+ GotoTop;
+ kbEnd, kbCtrlEnd, kbCtrlPageDown:
+ GotoBottom;
+ end;
+ end;
+
+ inherited ScanEvent( KeyCode, RepeatCount );
+
+end;
+*)
+
+function TRichTextView.HighlightNextLink: boolean;
+Var
+ P: PChar;
+ NextP: PChar;
+ T: TTextElement;
+ StartP: PChar;
+begin
+ if CursorIndex = -1 then
+ P := FText // no cursor yet
+ else
+ P := FText + CursorIndex;
+
+ result := false;
+
+ // if we're sitting on a begin-link, skip it...
+ T := ExtractNextTextElement( P, NextP );
+ if T.ElementType = teStyle then
+ if T.Tag.TagType = ttBeginLink then
+ P := NextP;
+
+ while true do
+ begin
+ T := ExtractNextTextElement( P, NextP );
+ if T.ElementType = teTextEnd then
+ // no link found
+ exit;
+
+ if T.ElementType = teStyle then
+ if T.Tag.TagType = ttBeginLink then
+ break;
+
+ p := NextP;
+
+ end;
+
+ StartP := P;
+ p := NextP; // skip begin link
+
+ while true do
+ begin
+ T := ExtractNextTextElement( P, NextP );
+ if T.ElementType = teTextEnd then
+ break; // no explicit link end...
+
+ if T.ElementType = teStyle then
+ if T.Tag.TagType = ttEndLink then
+ break;
+
+ p := NextP;
+ end;
+
+ SetSelectionStart( FLayout.GetCharIndex( StartP ) );
+ SetSelectionEnd( FLayout.GetCharIndex( NextP ) );
+
+ result := true;
+end;
+
+function TRichTextView.HighlightPreviousLink: boolean;
+Var
+ P: PChar;
+ PreviousP: PChar;
+ T: TTextElement;
+ EndP: PChar;
+begin
+ result := false;
+ if CursorIndex = -1 then
+ exit; // no cursor yet
+
+ P := FText + CursorIndex;
+
+ // if we're sitting on an end-of-link, skip it...
+ T := ExtractPreviousTextElement( FText, P, PreviousP );
+ if T.ElementType = teStyle then
+ if T.Tag.TagType = ttEndLink then
+ P := PreviousP;
+
+ while true do
+ begin
+ T := ExtractPreviousTextElement( FText, P, PreviousP );
+ if T.ElementType = teTextEnd then
+ // no link found
+ exit;
+
+ if T.ElementType = teStyle then
+ if T.Tag.TagType = ttEndLink then
+ break;
+
+ p := PreviousP;
+
+ end;
+
+ EndP := P;
+ p := PreviousP; // skip end link
+
+ while true do
+ begin
+ T := ExtractPreviousTextElement( FText, P, PreviousP );
+ if T.ElementType = teTextEnd then
+ break; // no explicit link end...
+
+ if T.ElementType = teStyle then
+ if T.Tag.TagType = ttBeginLink then
+ break;
+
+ p := PreviousP;
+ end;
+
+ SetSelectionStart( FLayout.GetCharIndex( EndP ) );
+ SetSelectionEnd( FLayout.GetCharIndex( PreviousP ) );
+
+ result := true;
+end;
+
+procedure TRichTextView.GoToTop;
+begin
+ SetVerticalPosition( 0 );
+end;
+
+procedure TRichTextView.GotoBottom;
+begin
+ SetVerticalPosition( FVScrollBar.Max );
+end;
+
+Function TRichTextView.GetTopCharIndex: longint;
+var
+ LineIndex: longint;
+ Y: longint;
+begin
+ if not FVerticalPositionInitialised then
+ begin
+ Result := FTopCharIndex;
+ exit;
+ end;
+ GetFirstVisibleLine( LineIndex,
+ Y );
+ if LineIndex >= 0 then
+ Result := FLayout.GetCharIndex( FLayout.FLines^[ LineIndex ].Text )
+ else
+ Result := 0;
+end;
+
+Function TRichTextView.GetTopCharIndexPosition( NewValue: longint ): longint;
+var
+ Line: longint;
+ lHeight: longint;
+begin
+ if NewValue > GetTextEnd then
+ begin
+ Result := FVScrollBar.Max;
+ exit;
+ end;
+ Line := FLayout.GetLineFromCharIndex( NewValue );
+ if Line = 0 then
+ begin
+ Result := 0; // include top margin
+ exit;
+ end;
+
+ if Line < 0 then
+ begin
+ Result := FVScrollBar.Position;
+ exit;
+ end;
+ lHeight := FLayout.GetLinePosition( Line );
+ Result := lHeight;
+end;
+
+Procedure TRichTextView.SetTopCharIndex( NewValue: longint );
+var
+ NewPosition: longint;
+begin
+ if not FVerticalPositionInitialised then
+ begin
+ if ( NewValue >= 0 )
+ and ( NewValue < GetTextEnd ) then
+ begin
+ FTopCharIndex := NewValue;
+ end;
+ exit;
+ end;
+ NewPosition := GetTopCharIndexPosition( NewValue );
+ SetVerticalPosition( NewPosition );
+end;
+
+procedure TRichTextView.MakeCharVisible( CharIndex: longint );
+var
+ Line: longint;
+begin
+ Line := FLayout.GetLineFromCharIndex( CharIndex );
+
+ MakeRowAndColumnVisible( Line,
+ FLayout.GetOffsetFromCharIndex( CharIndex, Line ) );
+end;
+
+procedure TRichTextView.MakeRowVisible( Row: longint );
+var
+ TopLine: longint;
+ BottomLine: longint;
+ Offset: longint;
+ NewPosition: longint;
+begin
+ GetFirstVisibleLine( TopLine, Offset );
+ GetBottomLine( BottomLine, Offset );
+
+ if ( Row > TopLine )
+ and ( Row < BottomLine ) then
+ // already visible
+ exit;
+
+ if ( Row = BottomLine )
+ and ( Offset >= FLayout.FLines^[ BottomLine ].Height - 1 ) then
+ // bottom row already entirely visible
+ exit;
+
+ if Row <= TopLine then
+ begin
+ // need to scroll up, desird row above top line
+ if Row = 0 then
+ NewPosition := 0 // include margins
+ else
+ NewPosition := FLayout.GetLinePosition( Row );
+
+ if NewPosition > FVScrollbar.Position then
+ // no need to scroll
+ exit;
+ SetVerticalPosition( NewPosition );
+ end
+ else
+ begin
+ // need to scroll down, desired row below bottom line
+ if ( BottomLine <> -1 )
+ and ( Row >= BottomLine ) then
+ SetVerticalPosition( FLayout.GetLinePosition( Row )
+ + FLayout.FLines^[ Row ].Height
+ - GetTextAreaHeight );
+ end;
+end;
+
+procedure TRichTextView.MakeRowAndColumnVisible( Row: longint;
+ Column: longint );
+var
+ X: Longint;
+begin
+ MakeRowVisible( Row );
+ FLayout.GetXFromOffset( Column, Row, X );
+
+ if X > FXScroll + GetTextAreaWidth then
+ // off the right
+ SetHorizontalPosition( X - GetTextAreaWidth + 5 )
+ else if X < FXScroll then
+ // off to left
+ SetHorizontalPosition( X );
+
+end;
+
+function TRichTextView.LinkFromIndex( const CharIndexToFind: longint): string;
+begin
+ Result := FLayout.LinkFromIndex( CharIndexToFind );
+end;
+
+function TRichTextView.FindString( Origin: TFindOrigin;
+ const AText: string;
+ var MatchIndex: longint;
+ var MatchLength: longint ): boolean;
+var
+ P: PChar;
+ pMatch: pchar;
+begin
+ if ( Origin = foFromCurrent )
+ and ( FSelectionStart <> -1 ) then
+ begin
+ // start at current cursor position
+ P := FText + GetCursorIndex;
+ end
+ else
+ begin
+ P := FText;
+ end;
+
+ Result := RichTextFindString( P, AText, pMatch, MatchLength );
+
+ if Result then
+ // found
+ MatchIndex := FLayout.GetCharIndex( pMatch )
+ else
+ MatchIndex := -1;
+
+end;
+
+function TRichTextView.Find( Origin: TFindOrigin;
+ const AText: string ): boolean;
+var
+ MatchIndex: longint;
+ MatchLength: longint;
+begin
+ Result := FindString( Origin,
+ AText,
+ MatchIndex,
+ MatchLength );
+ if Result then
+ begin
+ MakeCharVisible( MatchIndex );
+ FSelectionStart := MatchIndex;
+ SelectionEnd := MatchIndex + MatchLength;
+ end;
+end;
+
+function TRichTextView.GetClientRect: TfpgRect;
+begin
+ // Standard border of 2px on all sides
+ Result.SetRect(0, 0, Width, Height);
+ InflateRect(Result, -2, -2);
+end;
+
+
+end.
+
diff --git a/docview/components/richtext/fpgui_richtext.lpk b/docview/components/richtext/fpgui_richtext.lpk
new file mode 100644
index 00000000..4a39379e
--- /dev/null
+++ b/docview/components/richtext/fpgui_richtext.lpk
@@ -0,0 +1,82 @@
+<?xml version="1.0"?>
+<CONFIG>
+ <Package Version="3">
+ <Name Value="fpgui_richtext"/>
+ <AddToProjectUsesSection Value="False"/>
+ <Author Value="Graeme Geldenhuys"/>
+ <CompilerOptions>
+ <Version Value="8"/>
+ <SearchPaths>
+ <OtherUnitFiles Value="../../src/"/>
+ <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+ </SearchPaths>
+ <Parsing>
+ <Style Value="1"/>
+ <SyntaxOptions>
+ <CStyleOperator Value="False"/>
+ <AllowLabel Value="False"/>
+ <CPPInline Value="False"/>
+ </SyntaxOptions>
+ </Parsing>
+ <CodeGeneration>
+ <TargetCPU Value="i386"/>
+ <TargetOS Value="Linux"/>
+ <Optimizations>
+ <OptimizationLevel Value="0"/>
+ </Optimizations>
+ </CodeGeneration>
+ <Other>
+ <CompilerPath Value="$(CompPath)"/>
+ </Other>
+ </CompilerOptions>
+ <Description Value="RichTextView component"/>
+ <License Value="LGPL2 with static linking exception."/>
+ <Version Minor="1"/>
+ <Files Count="7">
+ <Item1>
+ <Filename Value="RichTextDocumentUnit.pas"/>
+ <UnitName Value="RichTextDocumentUnit"/>
+ </Item1>
+ <Item2>
+ <Filename Value="ACLStringUtility.pas"/>
+ <UnitName Value="ACLStringUtility"/>
+ </Item2>
+ <Item3>
+ <Filename Value="CanvasFontManager.pas"/>
+ <UnitName Value="CanvasFontManager"/>
+ </Item3>
+ <Item4>
+ <Filename Value="RichTextStyleUnit.pas"/>
+ <UnitName Value="RichTextStyleUnit"/>
+ </Item4>
+ <Item5>
+ <Filename Value="RichTextLayoutUnit.pas"/>
+ <UnitName Value="RichTextLayoutUnit"/>
+ </Item5>
+ <Item6>
+ <Filename Value="RichTextDisplayUnit.pas"/>
+ <UnitName Value="RichTextDisplayUnit"/>
+ </Item6>
+ <Item7>
+ <Filename Value="RichTextView.pas"/>
+ <UnitName Value="RichTextView"/>
+ </Item7>
+ </Files>
+ <RequiredPkgs Count="2">
+ <Item1>
+ <PackageName Value="fpgui_toolkit"/>
+ </Item1>
+ <Item2>
+ <PackageName Value="FCL"/>
+ <MinVersion Major="1" Valid="True"/>
+ </Item2>
+ </RequiredPkgs>
+ <UsageOptions>
+ <UnitPath Value="$(PkgOutDir)/"/>
+ </UsageOptions>
+ <PublishOptions>
+ <Version Value="2"/>
+ <IgnoreBinaries Value="False"/>
+ </PublishOptions>
+ </Package>
+</CONFIG>
diff --git a/docview/components/richtext/fpgui_richtext.pas b/docview/components/richtext/fpgui_richtext.pas
new file mode 100644
index 00000000..221e749c
--- /dev/null
+++ b/docview/components/richtext/fpgui_richtext.pas
@@ -0,0 +1,15 @@
+{ This file was automatically created by Lazarus. do not edit!
+ This source is only used to compile and install the package.
+ }
+
+unit fpgui_richtext;
+
+interface
+
+uses
+ RichTextDocumentUnit, ACLStringUtility, CanvasFontManager,
+ RichTextStyleUnit, RichTextLayoutUnit, RichTextDisplayUnit, RichTextView;
+
+implementation
+
+end.