diff options
author | Graeme Geldenhuys <graeme@mastermaths.co.za> | 2009-11-27 15:45:14 +0200 |
---|---|---|
committer | Graeme Geldenhuys <graeme@mastermaths.co.za> | 2009-11-27 15:45:14 +0200 |
commit | 441add90d3183e0f5e8020442a21c9b3bf62c6ab (patch) | |
tree | 6f648c4400c170d82ac7cbaa698329deafb4e1f8 /docview/components | |
parent | ab9a941d02281b95f00dd74f69a744ac302743e3 (diff) | |
parent | a1f68b05ed682e9a3640684d99a6d228cec80a35 (diff) | |
download | fpGUI-441add90d3183e0f5e8020442a21c9b3bf62c6ab.tar.xz |
Merged separate DocView project as our subdirectory
Diffstat (limited to 'docview/components')
-rw-r--r-- | docview/components/richtext/ACLStringUtility.pas | 1769 | ||||
-rw-r--r-- | docview/components/richtext/CanvasFontManager.pas | 1139 | ||||
-rw-r--r-- | docview/components/richtext/RichTextDisplayUnit.pas | 416 | ||||
-rw-r--r-- | docview/components/richtext/RichTextDocumentUnit.pas | 787 | ||||
-rw-r--r-- | docview/components/richtext/RichTextLayoutUnit.pas | 1018 | ||||
-rw-r--r-- | docview/components/richtext/RichTextPrintUnit.pas | 75 | ||||
-rw-r--r-- | docview/components/richtext/RichTextStyleUnit.pas | 641 | ||||
-rw-r--r-- | docview/components/richtext/RichTextView.pas | 2868 | ||||
-rw-r--r-- | docview/components/richtext/fpgui_richtext.lpk | 82 | ||||
-rw-r--r-- | docview/components/richtext/fpgui_richtext.pas | 15 |
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. |