diff options
53 files changed, 20398 insertions, 0 deletions
diff --git a/docview/.gitignore b/docview/.gitignore new file mode 100644 index 00000000..c15616d1 --- /dev/null +++ b/docview/.gitignore @@ -0,0 +1,4 @@ +*.[oa] +*.ppu +*.lps +units
\ No newline at end of file diff --git a/docview/TODO.txt b/docview/TODO.txt new file mode 100644 index 00000000..38e2b3d5 --- /dev/null +++ b/docview/TODO.txt @@ -0,0 +1,51 @@ + + DocView todo list. + +Legend +====== +[ ] - not started yet +[o] - started but not complete +[x] - completed task. + + +Todo list +========= +[o] - Fixes suggish scrolling. I think it's a recursive position event on the + vertical scrollbar causing the problem. + (*** It's much better already ***) +[ ] - Text wrapping in RichTextView is not 100% correct +[ ] - Access Violation when the application terminates. +[ ] - Ever growing list of fonts used while loading new topics. +[ ] - Settings / Customization dialog is needed. +[ ] - Open Recent Files doesn't always get populated, or gets cleared for some + reason. +[ ] - Change mouse cursor when over hyperlinks in RichTextView +[o] - Implement a ipfdump program. Already started work on this and is called + docdump in the src directory. +[ ] - Implement a IPF Compiler in Object Pascal +[ ] - Text is not selectable in RichTextView. I imagine people want to + copy & paste examples. Although "Save current Topic" already exists. +[ ] - Communication between application and docview. Both directions. Possible + solutions is Pipes or IPC unit. +[ ] - Create help file for DocView listing all supported features etc.. +[ ] - + +[x] - Display topic by ID via command line parameters +[x] - 'Could not load topic slots' message when trying to view some topics. +[x] - Extend compiler or INF file format for larged Word Index list. Currently + LCL documentation needs to be split in two, to compile. (this was an issue + with the Open Watcom WIPFC - limit is now set to 65000 entries) +[x] - Clicking in index list should set the text in the index search edit box. + + +fpdoc IPF todo list +=================== +[ ] - Class declaration in overview page is missing. Like HTML output. +[ ] - Class inheritance tree must be shown in overview page. Like HTML output. +[ ] - +[ ] - +[ ] - + + + + 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. diff --git a/docview/docs/inf04.txt b/docview/docs/inf04.txt new file mode 100644 index 00000000..8bd70083 --- /dev/null +++ b/docview/docs/inf04.txt @@ -0,0 +1,635 @@ + OS/2 2.0 Information Presentation Facility (IPF) Data Format - version 2 + ----------------------------------------------------------------------- - + + *** introduction to version 1 *** + + Having become extremely frustrated by VIEW.EXE's penchant for windows + that come and go, without even opening large enough to see everything + in them, I thought I'd try to turn .INF files into something more + conventional. While I don't have code to offer, I can tell you what I + learned about .INF format--it was enough to produce more-or-less + readable more-or-less plaintext from .INFs. + + I offer this in the hope that somebody will give the community a + really nice, tasteful, convenient, doesn't-use-too-much-screen-real-estate + .INF browser to replace VIEW.EXE. + + All of this was developed by looking at .INF files without any + documentation of the format except what VIEW.EXE showed for a + particular feature. + + I don't have a lot of personal interest in refining this document with + additional escape sequences, etc., but I would be happy to correspond + with someone who wanted to fill in the details, or to clarify anything + that may be confusing. If someone could point us to an official document + describing the format that would be most helpful. + + -- Carl Hauser (chauser.parc@xerox.com) + + + *** introduction to version 2 *** + + The original document contained most of the real tricky stuff in the file + format (especially the compression algorithm) so going on from there was + mainly a task of creating lots of help files using the IPFC and the + decompiling them again to see what came out. + + I fixed a few minor bugs in the description of the header which was + extended to describe the entire structure I believe to be the header + (because variable data starts afterwards). + + A number of escape codes have also been added and the descriptions of + others have been refined. There are still a lot of question marks about + the format, but this description already allows disassembling the text + into ASCII form in a fairly true-to-life format (including indentations + etc.). + + Further research should go into the way multiple windows are handled + (I didn't work on that because I have never required multiple window + displays in my help files and therefore am not familiar with the concepts). + Font usage and graphics linking could also use some more fiddling around. + + -- Marcus Groeber (marcusg@ph-cip.uni-koeln.de - Fidonet 2:243/8605.1) + + *** introduction to version 3 *** + + Just a bit of an update and flesh out ;-) + + -- Peter Childs (pjchilds@apanix.apana.org.au) + + *** Version 4 **** + + Further additions as found while writing NewView + + -- Aaron Lawrence + + **** Types **** + + All numeric quantities are least-significant-byte first in the file + (little-endian). + + bit1 1 bit boolean \ used only for explaining + int4 4 bit unsigned integer / packed structures + char8 8 bit character (ASCII more-or-less) + int8 8 bit unsigned integer + int16 16 bit unsigned integer + int32 32 bit unsigned integer + + **** The File Header **** + + Starting at file offset 0 the following structure can overlay the file + to provide some starting values: + { + int16 ID; // ID magic word (5348h = "HS") + int8 unknown1; // unknown purpose, could be third letter of ID + int8 flags; // probably a flag word... + // bit 0: set if INF style file + // bit 4: set if HLP style file + // patching this byte allows reading HLP files + // using the VIEW command, while help files + // seem to work with INF settings here as well. + int16 hdrsize; // total size of header + int16 unknown2; // unknown purpose + int16 ntoc; // 16 bit number of entries in the tocarray + int32 tocstrtablestart; // 32 bit file offset of the start of the + // toc entries (this is redundant info; + // the individual offsets are stored starting + // at tocstart) + int32 tocstrlen; // number of bytes in file occupied by the + // table-of-contents entries + int32 tocstart; // 32 bit file offset of the start of tocarray + int16 nres; // number of panels with ressource numbers + int32 resstart; // 32 bit file offset of ressource number table + int16 nname; // number of panels with textual name + int32 namestart; // 32 bit file offset to panel name table + int16 nindex; // number of index entries + int32 indexstart; // 32 bit file offset to index table + int32 indexlen; // size of index table + int8 unknown3[10]; // unknown purpose + int32 searchstart; // 32 bit file offset of full text search table + int32 searchlen; // size of full text search table + int16 nslots; // number of "slots" + int32 slotsstart; // file offset of the slots array + int32 dictlen; // number of bytes occupied by the "dictionary" + int16 ndict; // number of entries in the dictionary + int32 dictstart; // file offset of the start of the dictionary + int32 imgstart; // file offset of image data + int8 unknown4; // unknown purpose + int32 nlsstart; // 32 bit file offset of NLS table + int32 nlslen; // size of NLS table + int32 extstart; // 32 bit file offset of extended data block + int8 unknown5[12]; // unknown purpose + char8 title[48]; // ASCII title of database + } + + **** The table of contents entries **** + + Beginning at each file offset, tocentrystart[i]: + { + int8 len; // length of the entry including this byte (but not including extended data?) + int8 flags; // flag byte, description folows (MSB first) + // bit7 haschildren; // following nodes are a higher level + // bit6 hidden; // this entry doesn't appear in VIEW.EXE's + // presentation of the toc + // bit5 extended; // extended entry format + // bit4 // ?? + // int4 level; // nesting level + int8 ntocslots; // number of "slots" occupied by the text for + // this toc entry + } + + if the "extended" bit is not 1, this is immediately followed by + + { + int16 tocslots[ntocslots]; // indices of the slots that make up + // the article for this entry + char8 title[]; // the remainder of the tocentry + // until len bytes have been used [not + // zero terminated] + } + + if extended is 1 there are intervening bytes that describe + the kind, size and position of the window in which to display the + article. First, there are two flag bytes: + { + int8 w1; + // bit 3: Window controls are specified + // bit 2: Viewport + // bit 1: Size is specified. + // bit 0: Position is specified. + int8 w2; + // bit 3: + // bit 2: Group is specified. + // bit 1 + // bit 0: Clear (all windows before display) + } + Then the following optional fields may appear, as specified by w1: + + Origin ( 5 bytes ) + { + int8 Flags; + // bits 4-7: X position type + // bits 0-3: Y position type + int16 XPosition; // meaning depends on type + int16 YPosition; + } + + Position types are: + 0 = absolute character + 1 = relative % + 2 = absolute pixel + 3 = absolute points + For these types, the position is simply a number. + If one of the positions is not specified then the type will be 0 + and the value will be -1 (65535) + + 4 = dynamic + For this type the position is one of the following values: + 1: left + 2: right + 4: top; + 8: bottom + 16: center. + + Size ( 5 bytes ) + { + int8 Flags; + // bits 4-7: Width type + // bits 0-3: Height type + int16 Width; + int16 Height; + } + + Width/height type are same as position types, above, except that dynamic is not used. + + Window controls ( 2 bytes ) + 0, 112 means everything is turned off. + 8, 103 means no scroll bars IIRC + + Group ( 2 bytes ) + { + int16 GroupNumber; + } + GroupNumber is basically a 'frame' or window number. + + + Here's a C code fragment for computing the number of bytes to skip + int bytestoskip = 0; + if (w1 & 0x8) { bytestoskip += 2 }; + if (w1 & 0x1) { bytestoskip += 5 }; + if (w1 & 0x2) { bytestoskip += 5 }; + if (w2 & 0x4) { bytestoskip += 2 }; + + skip over bytestoskip bytes (after w2) and find the tocslots and title + as in the non-extended case. + + **** The table of contents array **** + + Beginning at file offset tocstart, this structure can overlay the + file: + { + int32 tocentrystart[ntoc]; // array of file offsets of + // tocentries (above) + } + + **** The Slots array **** + + Beginning at file offset slotsstart (provided by the file header) find + { + int32 slots[nslots]; // file offset of the article + // corresponding to this slot + } + + **** The Dictionary **** + + Beginning at file offset dictstart (provided by the file header) and + continuing until ndict entries have been read (and dictlen bytes have + been consumed from the file) find a sequence of length-preceeded + strings. Note that the length includes the length byte (not Pascal + compatible!). Build a table mapping i to the ith string. + { + char8* strings[ndict]; + } + + **** The Article entries **** + + Beginning at file offset slots[i] the following structure can overlay + the file: + { + int8 stuff; // ?? [always seen 0] + int32 localdictpos; // file offset of the local dictionary + int8 nlocaldict; // number of entries in the local dict + int16 ntext; // number of bytes in the text + int8 text[ntext]; // encoded text of the article + } + + **** The Local dictionary **** + + Beginning at file position localdictpos (for each article) there is an + array: + { + int16 localwords[nlocaldict]; + } + + **** The Text **** + + The text for an article then consists of words obtained by referencing + strings[localwords[text[i]]] for i in (0..ntext), with the following + exceptions. If text[i] is greater than nlocaldict it means + + 0xfa => end-of-paragraph, sets spacing to TRUE if not in monospace + 0xfb => [unknown] + 0xfc => spacing = !spacing + 0xfd => line break (outside an example: ".br", + sets spacing to TRUE if not in a + monospace example) + 0xfe => space + 0xff => escape sequence // see below + + When spacing is true, each word needs a space put after it. When + false, the words are abutted and spaces are supplied using 0xfe or the + dictionary. Examples are entered and left with 0xff escape sequences. + The variable "spacing" is initially (start of every article slot) TRUE. + + **** 0xff escape sequences **** + + These are used to change fonts, make cross references, enter and leave + examples, etc. The general format is + { + int8 FF; // always equals 0xff + int8 esclen; // length of the sequence (including + // esclen but excluding FF) + int8 escCode; // which escape function + } + + escCodes I have partially deciphered are + + 0x01 => unknown + + 0x02 or 0x11 => (esclen==3) set left margin. + or 0x12 0x11 always starts a new line. Arguments + { + int8 margin; // in spaces, 0=no margin + } + note: in an IPF source, you must code + :lm margin=256. to reset the left margin. + + 0x03 => (esclen==3) set right margin. Arguments + { + int8 margin; // in spaces, 1=no margin + } + + 0x04 => (esclen==3) change style. Arguments + { + int8 style; // 1,2,3: same as :hp#. + // 4,5,6: same as :hp5,6,7. + // 0 returns to plain text + } + + 0x05 => (esclen varies) beginning of cross + reference. The next two bytes of the + escape sequence are an int16 index of + the tocentrystart array. The + remaining bytes (if any) describe the size, + position and characteristics of the + window created when the + cross-reference is followed by VIEW. + Flag1 bit 7: 'split' window + + bit 6: autolink + bit 3: window controls specified + bit 2: viewport + bit 1: target size supplied + bit 0: target position supplied + Flag2 bit 0: ? + bit 1: dependent + bit 2: group supplied + + + 0x06 => unknown + + 0x07 => (esclen==4) footnote start (:fn. tag). Arguments: + { + int16 toc; // toc entry number of text + } + footnotes end with 0x08 + + 0x08 => (escLen==2) end of cross reference + introduced by escape code 0x05 or 0x07 + + 0x09 => unknown + + 0x0A => unknown + + 0x0B => (escLen==2) begin monosp. example. set + spacing to FALSE + + 0x0C => (escLen==2) end monosp. example. set + spacing to TRUE + + 0x0D => (escLen==2) special text colors. Arguments: + { + int8 color; // 1,2,3: same as :hp4,8,9. + // 0: default color + } + + 0x0E => Bitmap. + { + int8 flags; + 4: runin flag + 3: fit (scale) to window + 2: align center + 1: align right + 0: always set? + int32 bitmapStartOffset; + } + e.g. first bitmap always has offset 0 + + 0x0F => if esclen==5 an inlined cross + reference: the title of the referenced + article becomes part of the text. + This is probably the case even if + esclen is not 5, but I don't know the + decoding. In the case that esclen is + 5, I don't know the purpose of the + byte following the escCode, but the + two bytes after that are an int16 + index of the tocentrystart array. + + 0x10 => [special link, reftype=launch] + { + int8 unknown; ? + char launch_string[ esclen - 3 ]; + } + + + 0x13 or 0x14 => (esclen==2) Set foreground (0x13) + and background (0x14) color. Arguments: + { + int8 color; + \\ 0 - default + \\ 1 - blue + \\ 2 - red + \\ 3 - ?? + \\ 4 - green + \\ 5 - cyan + \\ 6 - yellow + \\ 7 - neutral + } + + 0x15 => unknown + + 0x16 => [special link, reftype=inform] + + 0x17 => hide text (:hide. tag). Arguments: + { + char8 key[]; // key required to show text + } + + 0x18 => end of hidden text (:ehide.) + + 0x19 => (esclen==3) change font. Arguments + { + int8 fontTableIndex (?); + } + + 0x1A => (escLen==3) begin :lines. sequence. set + spacing to FALSE. Arguments + { + int8 alignment; // 1,2,4=left,right,center + } + + 0x1B => (escLen==2) end :lines. sequence. set + spacing to TRUE + + 0x1C => (escLen==2) Set left margin to current + position. Margin is reset at end of + paragraph. + + 0x1F => [special link, reftype=hd database=...] + + 0x20 => (esclen==4) :ddf. tag. Arguments: + { + int16 res; // value of res attribute + } + + The font used in the text is the normal IBM extended character set, + including line graphics and some of the characters below 32. + + **** The ressource number array **** + + Beginning at file offset resstart, this structure can overlay the + file: + { + int16 res[nres]; // ressource number of panels + int16 toc[nres]; // toc entry number of panel + } + + **** The text name array **** + + Beginning at file offset namestart, this structure can overlay the + file: + { + int16 name[nres]; // index to panel name in dictionary + int16 toc[nres]; // toc entry number of panel + } + + **** The index table **** + + Beginning at file offset indexstart, a structure like the following + is stored for each of the nindex words (in alphabetical order). + { + int8 nword; // size of name + int8 level; // ? indent level + // bit 6 set: global entry + // bit 1 set: indent (:i2.) + bit 0 always set? + int8 number of roots; // number of root references following + int16 toc; // toc entry number of panel + char8 word[nword]; // index word [not zero-terminated] + + there are n roots following: + int32 synonyms; // 32 bit file offset to start of synonyms referencing this word + } + + **** The extended data block **** + + Not yet decoded. This block has a size of 64 bytes and contains various + pointers to font names, names of externel databases etc. + + **** The full text search table **** + + Not yet decoded. This table is supressed when "/S" is specified on + the IPFC command line. + + In addition to data in... + + RLE: + + byte RLEType; // ? always 1? + + Then a sequence of blocks, until all data used: + + byte Header; + // bits 0-6 are N + // bit 7: + // 0: there are N + 1 repeats of next byte. + // 1: N + 1 blocks of 'as is' data follow. + // except + // value $80 means (?) the next byte contains the data byte, + // and the next 2 bytes after that contain a 16 bit repeat number. + + + e.g. 04 00 means 5 repeats of 0 + 83 12 34 56 78 means the literal data 12 34 56 78 + 80 00 62 01 means $162 repeats of 0 + byte DataByte; // with escapes + // bit 7 set means there are actually N+1 (=bits0-6) bytes of data to follow + // 0 means there is a single byte of data to follow (e.g. when the byte > 80) + ( optionally ) byte[ N+1 ] data + int16 Number of zeroes to follow + **** Image data **** + + Beginning at file offset imgstart, this data is a series of compressed + OS/2 bitmaps. + Each starts with a BITMAPFILEHEADER: + { + int16 usType; // 'bM' for bitmap + int32 cbSize; // total bitmap size including header + // BEFORE compression: not correct in this context + int16 xHotspot; // only for icons/pointers, not relevant here? + int16 yHotspot; + int16 offBits; // offset to the actual bitmap data bits + BITMAPINFOHEADER bmp; // further bitmap data: + int32 cbFix; // length of bitmapinfo header structure (12) + // (including this field) + int16 cx; // bitmap width + int16 cy; // bitmap height + int16 cPlanes; // num bitplanes - always 1 AFAIK + int16 bitCount; // bits per pixel e.g. 4 = 16 colors + + RGB palette[ N ]; // 2 ^ bitCount * 3 bytes + + bitmapData; // in a special IPF format: + int32 totalLength; // not including this field, but including the next + int16 bitmapSize; // total size of memory required + // for uncompressed bitmap i.e. + // bytes per line rounded up to longword (4byte) + // x rows + // (This info is redundant) + + Followed by a series of blocks each up to 64k uncompressed. + Blocks: + int16 dataLength; // length of data following (including data type field) + + int8 dataType; // 0 = uncompressed + 2 = compressed + data... + Compression is LZW (Lempel Ziv XX?) + + } + + **** NLS table **** + + Not yet decoded. This table contains informations specific to the + language and codepage the document was prepared in. It seems to contain + some bitfields as well that might be used for character classification. + +Appendix 1: Some useful translations from IBM Extended ASCII to normal ASCII + + One other transformation I had to make was of the character box + characters of the IBM extended ASCII set. These characters appear in strings + in the dicitonary. They are given here in octal together with their translation. + + 020, 021 => blank seems satisfactory + 037 => solid down arrow: used to give direction to + a line in the syntax diagrams + 0263 => vertical bar + 0264 => left connector: vertical bar with short + horizontal bar extending left from the + center + 0277, 0300 => top right or bottom left corner; one is + one, the other is the other and I + can't tell which from my translation + 0301 => up connector: horizontal line with vertical + line extending up from the center + 0302 => down connector: horizontal line with + vertical line extending down from the + center + 0303 => right connector: vertical bar with short + horizontal bar extending right from + the center + 0304 => horizontal bar + 0305 => cross connector, i.e. looks like + only + slightly larger to connect with + adjacent chars + 0331, 0332 => top left or bottom right corner; one is + one, the other is the other and I + can't tell which from my translation + + +Appendix 2: Style codes for escCode 0x04 and 0x0D + + escCode 0x04 implements font changes associated with the :hp# IPF source tag. + + :hp1 is italic font + :hp2 is bold font + :hp3 is bold italic font + :hp5 is normal underlined font + :hp6 is italic underlined font + :hp7 is bold underlined font + + tags :hp4, :hp8, and :hp9 introduce different colored text which is encoded in + the .inf or .hlp file using escCode 0x0D. On my monitor normal text is dark blue. + + :hp4 text is light blue + :hp8 text is red + :hp9 text is magenta + + + +History: +October 22, 1992: version for initial posting (inf01.doc) +July 12, 1993: second version (refer to introduction for changes) (inf02.doc) +July 18, 1993: added appendices to the second version (inf02a.doc) + diff --git a/docview/images/docview-48x48.png b/docview/images/docview-48x48.png Binary files differnew file mode 100644 index 00000000..50758936 --- /dev/null +++ b/docview/images/docview-48x48.png diff --git a/docview/images/docview-48x48.xcf b/docview/images/docview-48x48.xcf Binary files differnew file mode 100644 index 00000000..80e925c1 --- /dev/null +++ b/docview/images/docview-48x48.xcf diff --git a/docview/images/inf-book-48x48.png b/docview/images/inf-book-48x48.png Binary files differnew file mode 100644 index 00000000..cb4b1761 --- /dev/null +++ b/docview/images/inf-book-48x48.png diff --git a/docview/install/docview-mime.xml b/docview/install/docview-mime.xml new file mode 100644 index 00000000..bb948753 --- /dev/null +++ b/docview/install/docview-mime.xml @@ -0,0 +1,12 @@ +<?xml version="1.0" encoding="utf-8"?> +<mime-info xmlns="http://www.freedesktop.org/standards/shared-mime-info"> + <mime-type type="application/inf"> + <comment>Compiled INF Help File</comment> + <acronym>INF</acronym> + <expanded-acronym>Information Help File</expanded-acronym> + <magic priority="50"> + <match type="string" offset="0" value="HSP"/> + </magic> + <alias type="application/x-inf"/> + </mime-type> +</mime-info> diff --git a/docview/install/docview.desktop b/docview/install/docview.desktop new file mode 100644 index 00000000..5f4100c9 --- /dev/null +++ b/docview/install/docview.desktop @@ -0,0 +1,13 @@ +[Desktop Entry] +Encoding=UTF-8 +Name=fpGUI DocView +Comment=A INF Documentation Viewer +Exec=docview %f +Terminal=false +Type=Application +Icon=docview.png +Categories=Utility;Application; +StartupWMClass=docview +MimeType=application/x-inf; + + diff --git a/docview/install/linux.readme.txt b/docview/install/linux.readme.txt new file mode 100644 index 00000000..48cccfd2 --- /dev/null +++ b/docview/install/linux.readme.txt @@ -0,0 +1,31 @@ + +Registering the INF file format and fpGUI Documentation Viewer +with Linux is pretty straight forward. Simply execute the following +commands for a console window. + +Steps: +------ +1 $ cd <fpgui> <-- replace <fpgui> the the appropriate + directory location on you system. + +2. $ cp images/docview-48x48.png ~/.icons/docview.png + +3. $ cp images/inf-book-28x48.png ~/.icons/inf-help.png + +4. $ cp install/docview.desktop ~/.local/share/applications/ + +5. $ cp docview-mime.xml ~/.local/share/mime/packages + +6. $ update-mime-database + +Gnome now knows the mime type for *.inf files. Now to setup the new default +icon Nautilus will show for *.inf files, you need to do these two steps. + + +7. $ mkdir ~/.icons/gnome/48x48/mimetypes + +8. $ ln -s ~/.icons/inf-help.png ~/.icons/gnome/48x48/mimetypes/gnome-mime-application-inf.png + +Now you are all done! + + diff --git a/docview/src/CompareWordUnit.pas b/docview/src/CompareWordUnit.pas new file mode 100644 index 00000000..49c2ea26 --- /dev/null +++ b/docview/src/CompareWordUnit.pas @@ -0,0 +1,107 @@ +Unit CompareWordUnit; + +{$mode objfpc}{$H+} + +// NewView - a new OS/2 Help Viewer +// Copyright 2001 Aaron Lawrence (aaronl at consultant dot com) +// This software is released under the Gnu Public License - see readme.txt + +Interface + +// Compares words and produces a match level (relevance) based +// on the relative sizes etc. Used in searching help files +// to sort by relevance. + +const + // word weightings + mwExactWord = 20; + mwWordStart = 10; + mwWordWithin = 5; + +// Compares the given search word against the given +// reference word. Returns a value indicating how well the +// search word matches, 0 = not at all. +function CompareWord( const SearchWord: string; + const ReferenceWord: string ): longint; + +Implementation + +uses + SysUtils; + +// LOoks for string a within string b, case insensitively +function CaseInsensitivePos( const a, b: string ): longint; +begin + // Budget implementation to begin with. + Result := Pos( UpperCase( a ), UpperCase( b ) ); +end; + +function CompareWord( const SearchWord: string; + const ReferenceWord: string ): longint; +var + OccurrencePos: longint; +begin + Result := 0; + // First up, if the word we're searching for is longer than + // this word, then it can't match at all. + if Length( SearchWord ) > Length( ReferenceWord ) then + exit; + + OccurrencePos := CaseInsensitivePos( SearchWord, ReferenceWord ); + if OccurrencePos = 0 then + // no match. + exit; + + if Length( SearchWord ) = Length( ReferenceWord ) then + begin + // exact word match (except case) + Result := mwExactWord; + exit; + end; + + // partial word match + if OccurrencePos = 1 then + begin + // word starts with searchword + Result := mwWordStart + * Length( SearchWord ) + div Length( ReferenceWord ); + if Result = 0 then + Result := 1; + exit; + end; + + // Matched searchword somewhere within word + Result := mwWordWithin + * Length( SearchWord ) + div Length( ReferenceWord ); + if Result = 0 then + Result := 1; + +end; + +{// Note: searchstring must be uppercase, +function IsMatching( const SearchString: string; + const SearchType: TSearchType; + const Item: string ): boolean; +var + temp: string; +begin + case SearchType of + stStarts: + Result:= StrStarts( SearchString, Item ); + + stContains: + begin + temp:= UpperCase( Item ); + Result:= Pos( SearchString, temp ) <> 0; + end; + + stMatches: + Result:= CompareText( SearchString, + Item )= 0; + end; +end; +} +Initialization +End. diff --git a/docview/src/HelpFile.pas b/docview/src/HelpFile.pas new file mode 100644 index 00000000..b3ee7317 --- /dev/null +++ b/docview/src/HelpFile.pas @@ -0,0 +1,1252 @@ +Unit HelpFile; + +{$mode objfpc}{$H+} + +// NewView - a new OS/2 Help Viewer +// Copyright 2003 Aaron Lawrence (aaronl at consultant dot com) +// This software is released under the Gnu Public License - see readme.txt + +Interface + +// Encapsulates the basic reading of a help file's structure. + +uses + Classes + ,SysUtils + ,IPFFileFormatUnit + ,HelpTopic +// ,HelpBitmap + ,SearchTable + ,nvNullObjects // Fake various classes like TImageList + ; + +type + + TIndexEntry = class(TObject) + private + name: String; + topic: TTopic; + flags: uint8; + public + constructor Create(aName: String; aTopic: TTopic; aFlags: uint8); + destructor Destroy; override; + property getTopic: TTopic read topic; + function getLabel: String; + function isGlobal: boolean; + function getLevel: integer; + end; + + + TIndex = class(TObject) + private + entries: TStringList; + public + constructor Create; + destructor Destroy; override; + function Count: longint; + function GetLabels: TStringList; + function GetTopic(aPos: longint): TTopic; + procedure Add(anIndexEntry: TIndexEntry); + end; + + + THelpFile = class(TObject) + private + function GetStringResourceIDCount: integer; + function GetNumericResourceIDCount: integer; + protected + _Filename : string; + _FileSize : longint; + _Handle: TFileStream; + + _pSlotData: pUInt16; + _SlotDataSize: longint; + + _Title: string; + + _Topics: TList; // of TTopics + + _Dictionary: TStringList; // pointers to strings. + + _Index: TIndex; + + _SearchTable: TSearchTable; + + _ReferencedFiles: TStringList; + + _FontTable: TList; + + _pHeader: TPHelpFileHeader; + _pExtendedHeader: TPExtendedHelpFileHeader; + _pContentsData: pointer; + _pResourceData: pointer; + _pSearchData: pointer; + _pHighlightWords: UInt32ArrayPointer; + _pSlotOffsets: Uint32ArrayPointer; + _pDictionaryData: pointer; + _pFontTableData: pointer; + _pTopicNameData: pointer; + _pTopicGlobalNamesData: pointer; + + procedure InitMembers; + procedure Open; + procedure Close; + procedure ReadFileBlock( Var Dest: pointer; + const StartPosition: LongWord; + const Length: LongWord); + + procedure ReadHeader; + procedure ReadContents; + procedure ReadDictionary; + procedure ReadSearchTable; + + procedure ReadIndex; + + procedure ReadReferencedFilesTable; + procedure ReadFontTableData; + procedure ParseFontTable; + + function GetTopic( Index: longint ): TTopic; + function GetTopicCount: longint; + + function GetDictionaryCount: longint; + function GetDictionaryWord( Index: longint ): string; + + function GetHighlightWords: UInt32ArrayPointer; + + function GetSearchTable: TSearchTable; + + // Lookup global or local panel name list + function FindTopicByName( const Name: string; + Var pData: pointer; + Count: longint; + Offset: longint ): TTopic; + + public + constructor Create( const aFileName: string ); + + destructor Destroy; override; + + function GetIndex: TIndex; + + property Title: string read _Title; + property Topics[ Index: longint ]: TTopic read GetTopic; + property TopicList: TList read _Topics; + property TopicCount: longint read GetTopicCount; + property StringResourceIDCount: integer read GetStringResourceIDCount; + property NumericResourceIDCount: integer read GetNumericResourceIDCount; + property Index: TIndex read GetIndex; + property Filename: string read _FileName; + + property ReferencedFiles: TStringList read _ReferencedFiles; + + procedure GetImages( ImageOffsets: TList; + Images: TImageList ); + + function GetImage( ImageOffset: longint ): THelpBitmap; + + property DictionaryCount: longint read GetDictionaryCount; + property DictionaryWords[ Index: longint ]: string read GetDictionaryWord; + + function IndexOfTopic( Topic: TTopic ): longint; + + property SearchTable: TSearchTable read GetSearchTable; + + function FindTopicByResourceID( ID: uint16 ): TTopic; + + function FindTopicByLocalName( const Name: string ): TTopic; + function FindTopicByGlobalName( const Name: string ): TTopic; + + function FindTopicByTitleStartsWith( const SearchText: string ): TTopic; + function FindTopicByTitleContains( const SearchText: string ): TTopic; + + function FindTopicByIndexStartsWith( const SearchText: string ): TTopic; + function FindTopicByIndexContains( const SearchText: string ): TTopic; + + procedure FindResourceIDsForTopic( Topic: TTopic; + ResourceIDs: TList ); + + property HighlightWords: UInt32ArrayPointer read GetHighlightWords; + + property FileSize: longint read _FileSize; + + procedure SetupFontSubstitutes( Substitutions: string ); + public + NotesLoaded: boolean; // used externally + + end; + +// Returns helpfile that the given topic is within +Function TopicFile( Topic: TTopic ): THelpFile; + +function GetHelpFileTitle( const Filename: string ): string; + +Implementation + +uses +// BseErr, +// StringUtilsUnit, +// CharUtilsUnit, +// DebugUnit, +// ACLFileIOUtility, +// ACLLanguageUnit; + nvUtilities + ,ACLStringUtility + ; + +// Load "missing" bitmap +{ TODO -oGraeme -cbitmap : Create and load a "missing image" image } +{.$R Images} + +const + FileErrorNotFound = 'File not found '; + FileErrorAccessDenied = 'File access denied'; + FileErrorInUse = 'File in use'; + FileErrorInvalidHeader = 'Invalid file header'; + + + // ----------- + // TIndexEntry + // ----------- + + CONSTRUCTOR TIndexEntry.Create(aName: String; aTopic: TTopic; aFlags: uint8); + begin + LogEvent(LogObjConstDest, 'TIndexEntry.Create'); + name := aName; + topic := aTopic; + flags := aFlags; + end; + + + DESTRUCTOR TIndexEntry.Destroy; + begin + LogEvent(LogObjConstDest, 'TIndexEntry.Destroy'); + topic := nil; + inherited Destroy; + end; + + + FUNCTION TIndexEntry.getLabel: String; + begin + result := name; + + // index level check (level 1 or 2) + if (getLevel) > 1 then + begin + result := '- ' + result; + end; + + if isGlobal then + begin + result := result + ' (g)'; + end; + end; + + + FUNCTION TIndexEntry.isGlobal: boolean; + begin + result := (flags and 64) > 0 + end; + + + FUNCTION TIndexEntry.getLevel: integer; + begin + result := 1; + + // index level check (level 1 or 2) + if (flags and 2 ) > 0 then + begin + result := 2; + end; + end; + + + + + // ----------- + // TIndex + // ----------- + CONSTRUCTOR TIndex.Create; + begin + inherited Create; + + entries := TStringList.Create; + // labels := nil; // lazy + end; + + + DESTRUCTOR TIndex.Destroy; + var + i : longint; + tmpEntry : TIndexEntry; + begin + LogEvent(LogObjConstDest, 'TIndex.Destroy (size:' + IntToStr(entries.Count) + ')'); + + for i := 0 to entries.Count - 1 do + begin + tmpEntry := TIndexEntry(entries.Objects[i]); + if tmpEntry <> nil then + begin + tmpEntry.Free; + entries.Objects[i] := nil; + end; + end; + entries.Free; + + inherited Destroy; + end; + + + FUNCTION TIndex.Count: longint; + begin + result := entries.Count; + end; + + + FUNCTION TIndex.GetLabels: TStringList; + begin + result := entries; + end; + + + FUNCTION TIndex.GetTopic(aPos: longint): TTopic; + begin + result := TIndexEntry(entries.Objects[aPos]).getTopic; + end; + + + PROCEDURE TIndex.add(anIndexEntry: TIndexEntry); + begin +// LogEvent(LogDebug, 'TIndex.add(' + anIndexEntry.getLabel + ', ' + anIndexEntry.ClassName + ')'); + entries.AddObject(anIndexEntry.getLabel, anIndexEntry); + end; + + + + +//Procedure OnLanguageEvent( Language: TLanguageFile; +// const Apply: boolean ); +//var +// tmpPrefix : String; +//begin +// tmpPrefix := 'HelpFile' + LANGUAGE_LABEL_DELIMITER; +// +// Language.LL( Apply, FileErrorNotFound, tmpPrefix + 'FileErrorNotFound', 'File not found' ); +// Language.LL( Apply, FileErrorAccessDenied, tmpPrefix + 'FileErrorAccessDenied', 'Access denied' ); +// Language.LL( Apply, FileErrorInUse, tmpPrefix + 'FileErrorInUse', 'File in use by another program' ); +// Language.LL( Apply, +// FileErrorInvalidHeader, +// tmpPrefix + 'FileErrorInvalidHeader', +// 'File doesn''t appear to be an OS/2 Help document (header ID not correct)' ); +// Language.LL( Apply, +// ErrorCorruptHelpFile, +// tmpPrefix + 'ErrorCorruptHelpFile', +// 'File is corrupt' ); +//end; + +Function TopicFile( Topic: TTopic ): THelpFile; +Begin + Result := Topic.HelpFile as THelpFile; +end; + +function THelpFile.GetStringResourceIDCount: integer; +begin + Result := _pHeader^.nname; +end; + +function THelpFile.GetNumericResourceIDCount: integer; +begin + Result := _pHeader^.nres; +end; + +procedure THelpFile.InitMembers; +begin + _SlotDataSize := 0; + + _pHeader := nil; + _pExtendedHeader := nil; + _pContentsData := nil; + _pSlotOffsets := nil; + _pResourceData := nil; + _pSearchData := nil; + _pDictionaryData := nil; +// _pIndexData := nil; + _pFontTableData := nil; + + _pHighlightWords := nil; + + _Dictionary:= TStringList.Create; + _Topics := TList.Create; +// _Index := TStringList.Create; + _ReferencedFiles := TStringList.Create; + _FontTable := TList.Create; + + NotesLoaded := false; +end; + + +constructor THelpFile.Create(const aFileName: string); +begin + LogEvent(LogObjConstDest, 'THelpFile.Create (file:' + aFileName + ')'); + LogEvent(LogParse, 'Helpfile Load: ' + aFileName); + + _FileName := aFileName; + + InitMembers; + + Open; + + // we always need these basics: + try + ReadHeader; + ReadContents; + ReadDictionary; + ReadFontTableData; + ParseFontTable; + ReadReferencedFilesTable; + except + Close; + raise; + end; + + // the rest is loaded on demand +end; + + +destructor THelpFile.Destroy; +begin + LogEvent(LogObjConstDest, 'THelpFile.Destroy'); + Dispose( _pHeader ); + Dispose( _pExtendedHeader ); + FreeMem( _pContentsData ); + FreeMem( _pSlotOffsets ); + FreeMem( _pResourceData ); + FreeMem( _pSearchData ); + FreeMem( _pDictionaryData ); +// DeallocateMemory( _pIndexData ); + FreeMem( _pFontTableData ); + + FreeMem( _pHighlightWords ); + + // index entries are pointing to topics + // so let us clean them first + if Assigned( _Index ) then + _Index.Free; + + if Assigned( _Topics ) then + DestroyListAndObjects( _Topics ); + + _Dictionary.Free; + _SearchTable.Free; + _ReferencedFiles.Free; + _FontTable.Free; + + _Handle.Free; +end; + +procedure THelpFile.Open; +begin + if not FileExists( _Filename ) then + raise EHelpFileException.Create( FileErrorNotFound ); + + try + _Handle := TFileStream.Create(_FileName, fmOpenRead); + + except + on E: Exception do + raise EHelpFileException.Create(E.Message); + end; + //case rc of + // ERROR_FILE_NOT_FOUND: // crap, this doesn't actually occur! + // raise EHelpFileException.Create( FileErrorNotFound ); + // + // ERROR_ACCESS_DENIED: + // raise EHelpFileException.Create( FileErrorAccessDenied ); + // + // ERROR_SHARING_VIOLATION: + // raise EHelpFileException.Create( FileErrorInUse ); + // + // else + // raise EHelpFileException.Create( SysErrorMessage( rc ) ); + //end; + + _FileSize := GetFileSize(_Filename); +end; + +procedure THelpFile.Close; +begin + _Handle.Free; + _Handle := nil; +end; + +procedure THelpFile.ReadFileBlock(var Dest: pointer; + const StartPosition: LongWord; const Length: LongWord); +var + bytes: LongWord; +begin + if Length = 0 then + exit; // nothing to read - go home! + + _Handle.Seek(StartPosition, soBeginning); + + // we allocate early so this should never happen + if Dest = nil then + Dest := GetMem(Length); + + bytes := _Handle.Read(Dest^, Length); + if bytes <> Length then + raise EHelpFileException.Create(ErrorCorruptHelpFile); +end; + +procedure THelpFile.ReadHeader; +begin + LogEvent(LogParse, 'Read header'); + New(_pHeader); + ReadFileBlock( _pHeader, + 0, + sizeof( THelpFileHeader ) ); + if _pHeader^.ID <> INF_HEADER_ID then + begin + // not an OS/2 help file. + if (Byte(_pHeader^.ID[0]) = $5f) and (Byte(_pHeader^.ID[1]) = $3f) then + raise EWindowsHelpFormatException.Create( 'It seems we have a Win16 help file!' ); + + raise EHelpFileException.Create( FileErrorInvalidHeader ); + end; + + _Title := _pHeader^.Title; + + if _pHeader^.extstart > 0 then + begin + New(_pExtendedHeader); + // read extended header + ReadFileBlock( _pExtendedHeader, + _pHeader^.extstart, + sizeof( _pExtendedHeader^ ) ); + end; +end; + +procedure THelpFile.ReadContents; +var + Topic: TTopic; + EntryIndex: longint; + pEntry: pTTOCEntryStart; + pEnd: pbyte; + tocarray: UInt32ArrayPointer; + pData: Pointer; + p: PByte; +begin + LogEvent(LogParse, 'Read contents'); + + if _pHeader^.ntoc = 0 then + exit; // explicit check required since ntoc is unsigned + + // Presize the topics list to save reallocation time + _Topics.Capacity := _pHeader^.ntoc; + + // read toc offsets array + //ReadFileBlock( tocarray, + // _pHeader^.tocoffsetsstart, + // _pHeader^.ntoc * SizeOf(uint32) ); + + // read slots first so that Topics can refer to it. + ReadFileBlock( _pSlotOffsets, + _pHeader^.slotsstart, + _pHeader^.nslots * sizeof( uint32 ) ); + + ReadFileBlock( _pContentsData, + _pHeader^.tocstart, + _pHeader^.toclen ); + + pEntry := _pContentsData; + pEnd := _pContentsData + _pHeader^.toclen; + p := PByte(pEntry); + + for EntryIndex := 0 to _pHeader^.ntoc - 1 do + begin +// pEntry := _Handle.Seek(tocarray[EntryIndex], soBeginning); +// pEntry := tocarray[EntryIndex]; + if p >= pEnd then + // runs off end of data! + raise EHelpFileException.Create( ErrorCorruptHelpFile ); + + Topic := TTopic.Create( _Handle, + _pSlotOffsets, + _Dictionary, + pEntry, + _FontTable, + _ReferencedFiles ); + + Topic.HelpFile := Self; + Topic.Index := EntryIndex; + + _Topics.Add( Topic ); + p := PByte(pEntry); + inc(p, pEntry^.Length); + pEntry := pTTOCentryStart(p); + end; +end; + +procedure THelpFile.ReadDictionary; +var + i: longint; + Len: uint8; + p: pbyte; + pEnd: pbyte; + s: string; + c: array[0..255] of char; +begin + LogEvent(LogParse, 'Read dictionary'); + + if _pHeader^.ndict = 0 then + exit; // explicit check required since ndict is unsigned + + ReadFileBlock( _pDictionaryData, + _pHeader^.dictstart, + _pHeader^.dictlen ); + + P := _pDictionaryData; + pEnd := _pDictionaryData + _pHeader^.dictlen; + + // Presize the dictionary to save reallocation + _Dictionary.Capacity := _pHeader^.ndict; + for i := 0 to _pHeader^.ndict - 1 do + begin + // adjust length so we can use as a Pascal string + // (file uses length including length byte, + // Pascal string have length excluding length byte) + if p >= pEnd then + // ran off end of data + raise EHelpFileException.Create( 'Error reading help file dictionary' ); + + + FillChar(c, sizeof(c), 0); // fill string with NUL chars + Len := p^ - 1; // read string length value (corrected length) + Inc(p, sizeof(byte)); // move pointer + Move(p^, c, Len); // read string of dictionary + s := c; // convert PChar to String type + + _Dictionary.Add( s ); + Inc(p, Len); // move pointer to next item + end; +end; + + +function THelpFile.GetIndex: TIndex; +begin + if _Index = nil then + begin + ReadIndex; + end; + Result := _Index; +end; + +type + TIndexEntryHeader = packed record + TextLength: uint8; + Flags: uint8; + NumberOfRoots: uint8; + TOCIndex: uint16; + end; + pTIndexEntryHeader = ^TIndexEntryHeader; + +procedure THelpFile.ReadIndex; +var + IndexIndex: longint; // I can't resist :-) + pEntryHeader: pTIndexEntryHeader; + EntryText: string; + IndexTitleLen: longint; + p: pByte; + pEnd: pByte; + pIndexData: pointer; + tmpIndexEntry: TIndexEntry; +begin + LogEvent(LogParse, 'Read index'); + _Index := TIndex.Create; + if _pHeader^.nindex = 0 then + exit; // explicit check required since ndict is unsigned + + pIndexData := nil; + ReadFileBlock( pIndexData, + _pHeader^.indexstart, + _pHeader^.indexlen ); + + P := pIndexData; + pEnd := pIndexData + _pHeader^.indexlen; + + for IndexIndex := 0 to _pHeader^.nindex - 1 do + begin + if p >= pEnd then + // ran off end of data + raise EHelpFileException.Create( 'Error reading help file index' ); + + pEntryHeader := pTIndexEntryHeader(p); + IndexTitleLen := pEntryHeader^.TextLength; + inc( p, sizeof( TIndexEntryHeader ) ); + + EntryText := ''; + SetString(EntryText, PChar(p), IndexTitleLen); + + if pEntryHeader^.TOCIndex < _Topics.Count then + begin + tmpIndexEntry := TIndexEntry.Create(EntryText, TTopic(_Topics[pEntryHeader^.TOCIndex]), pEntryHeader^.flags); + _Index.Add(tmpIndexEntry); + end + else +// raise EHelpFileException.Create( 'Error reading help file index - out of range topic reference' ); + ; // pass! something special + + inc( p, IndexTitleLen + + pEntryHeader^.NumberOfRoots + * sizeof( uint32 ) ); // skip 'roots' for index search + end; + + FreeMem( pIndexData ); +end; + +function THelpFile.GetSearchTable: TSearchTable; +begin + if _SearchTable = nil then + ReadSearchTable; + Result := _SearchTable; +end; + +procedure THelpFile.ReadSearchTable; +var + SearchTableOffset: longint; + SearchTableRecordLengthIs16Bit: boolean; +begin + LogEvent(LogParse, 'Read search table'); + + if _pHeader^.SearchLen = 0 then + begin + LogEvent(LogParse, 'Read search table (len = 0'); + exit; + end; + + SearchTableOffset := _pHeader^.SearchStart and $7fffffff; + SearchTableRecordLengthIs16Bit := _pHeader^.SearchStart and $80000000 > 0; + ReadFileBlock( _pSearchData, + SearchTableOffset, + _pHeader^.SearchLen ); + + _SearchTable := TSearchTable.Create( _pSearchData, + SearchTableRecordLengthIs16Bit, + _Dictionary.Count, + _Topics.Count ); +end; + +function THelpFile.GetHighlightWords: UInt32ArrayPointer; +begin + if _pHighlightWords = nil then + _pHighlightWords := GetMem( _Dictionary.Count * sizeof( UInt32 ) ); + Result := _pHighlightWords; +end; + +function THelpFile.FindTopicByResourceID( ID: uint16 ): TTopic; +var + i: longint; + pResourceIDs: UInt16ArrayPointer; + pTopicIndices: UInt16ArrayPointer; + FileResourceID: uint16; + TopicIndex: uint16; +begin + Result := nil; + + if _pHeader^.nres = 0 then + // since nres is unsigned + exit; + + if _pResourceData = nil then + begin + ReadFileBlock( _pResourceData, + _pHeader^.resstart, + (_pHeader^.nres * sizeof( uint16 )) * 2 ); // list of IDs, list of topics + end; + + pResourceIDs := _pResourceData; + pTopicIndices := _pResourceData + + _pHeader^.nres * sizeof( uint16 ); + + for i := 0 to _pHeader^.nres - 1 do + begin + FileResourceID := pResourceIDs^[ i ]; + if FileResourceID = ID then + begin + // found + TopicIndex := pTopicIndices^[ i ]; + Result := TTopic(_Topics[ TopicIndex ]); + exit; + end; + end; +end; + +// Look up a local "panel name" and return associated topic, if any. +function THelpFile.FindTopicByLocalName( const Name: string ): TTopic; +begin + Result := FindTopicByName( Name, + _pTopicNameData, + _pHeader^.nname, + _pHeader^.namestart ); +end; + +function THelpFile.FindTopicByGlobalName( const Name: string ): TTopic; +begin + Result := nil; + + if _pExtendedHeader = nil then + // no extended header - no global list to lookup + exit; + + Result := FindTopicByName( Name, + _pTopicGlobalNamesData, + _pExtendedHeader ^. EntryInGNameTable, + _pExtendedHeader ^. HelpPanelGNameTblOffset ); + +end; + +// The text of the names are stored in the (global) dictionary +// with a table referencing them. +// We could use a binary search here... but whatever... +function THelpFile.FindTopicByName( const Name: string; + Var pData: pointer; + Count: longint; + Offset: longint ): TTopic; +var + i: longint; + pNameTable: UInt16ArrayPointer; + pTopicIndices: UInt16ArrayPointer; + TopicIndex: uint16; + + TopicNameWordIndex: uint16; + TopicName: string; +begin + Result := nil; + + if Count = 0 then + // since it's unsigned + exit; + + if pData = nil then + ReadFileBlock( pData, + Offset, + Count * sizeof( uint16 ) * 2 ); // list of name words, list of topics + + // get pointers to the two parts of the table + pNameTable := pData; + pTopicIndices := pData + + Count * sizeof( uint16 ); + + for i := 0 to Count - 1 do + begin + TopicNameWordIndex := pNameTable^[ i ]; + TopicName := DictionaryWords[ TopicNameWordIndex ]; + + if CompareText( TopicName, Name ) = 0 then + begin + // found + TopicIndex := pTopicIndices^[ i ]; + Result := TTopic(_Topics[ TopicIndex ]); + exit; + end; + end; +end; + + +// TODO move to index class +function THelpFile.FindTopicByIndexStartsWith( const SearchText: string ): TTopic; +var + i: longint; + tmpLabel: String; +begin + result := nil; + GetIndex; // make sure it's read + + for i := 0 to _Index.Count - 1 do + begin + tmpLabel := _Index.GetLabels[i]; + if SameText(tmpLabel, SearchText) then + begin + // found + result := Index.getTopic(i); + exit; + end; + end; +end; + + +function THelpFile.FindTopicByIndexContains(const SearchText: string): TTopic; +var + i: longint; + tmpLabel: String; +begin + result := nil; + GetIndex; // make sure it's read + + for i := 0 to _Index.Count - 1 do + begin + tmpLabel := _Index.GetLabels[i]; + if Pos(UpperCase(SearchText), UpperCase(tmpLabel)) > 0 then + begin + // found + result := Index.getTopic(i); + exit; + end; + end; +end; + + +function THelpFile.FindTopicByTitleStartsWith( const SearchText: string ): TTopic; +var + i: longint; + tmpTopic: TTopic; + tmpLevel : integer; + tmpMore : boolean; +begin + result := nil; + + tmpLevel := 0; + repeat + tmpMore := false; + inc(tmpLevel); + for i := 0 to _Topics.Count - 1 do + begin + tmpTopic := TTopic(_Topics[i]); + if tmpLevel = tmpTopic.ContentsLevel then + begin + if StrStartsWithIgnoringCase(tmpTopic.Title, SearchText) then + begin + result := tmpTopic; + exit; + end; + end; + if tmpLevel < tmpTopic.ContentsLevel then + begin + tmpMore := True; + end; + end; + until NOT tmpMore; +end; + +function THelpFile.FindTopicByTitleContains( const SearchText: string ): TTopic; +var + i: longint; + tmpTopic: TTopic; + tmpLevel : integer; + tmpMore : boolean; +begin + result := nil; + + tmpLevel := 0; + repeat + tmpMore := false; + inc(tmpLevel); + for i := 0 to _Topics.Count - 1 do + begin + tmpTopic := TTopic(_Topics[i]); + if tmpLevel = tmpTopic.ContentsLevel then + begin + if CaseInsensitivePos( SearchText, tmpTopic.Title) > 0 then + begin + result := tmpTopic; + exit; + end; + end; + if tmpLevel < tmpTopic.ContentsLevel then + begin + tmpMore := True; + end; + end; + until NOT tmpMore; +end; + +procedure THelpFile.FindResourceIDsForTopic( Topic: TTopic; + ResourceIDs: TList ); +var + i: longint; + pResourceIDs: UInt16ArrayPointer; + pTopicIndices: UInt16ArrayPointer; +begin + ResourceIDs.Clear; + + if _pHeader^.nres = 0 then + // since nres is unsigned + exit; + + if _pResourceData = nil then + ReadFileBlock( _pResourceData, + _pHeader^.resstart, + _pHeader^.nres * sizeof( uint16 ) * 2 ); // list of IDs, list of topics + + pResourceIDs := _pResourceData; + pTopicIndices := _pResourceData + + _pHeader^.nres * sizeof( uint16 ); + + for i := 0 to _pHeader^.nres - 1 do + begin + if pTopicIndices^[ i ] = Topic.Index then + begin + // found + ResourceIDs.Add( pointer( pResourceIDs^[ i ] ) ); + end; + end; +end; + +procedure THelpFile.ReadReferencedFilesTable; +var + i: longint; + p: pointer; + pData: pointer; + DatabaseName: string; + pLength: pByte; +begin + if _pExtendedHeader = nil then + // no extended header -> no referenced files table + exit; + + if _pExtendedHeader^.Numdatabase = 0 then + exit; + + pData := nil; // please allocate... + ReadFileBlock( pData, + _pExtendedHeader^.DatabaseOffset, + _pExtendedHeader^.DatabaseSize ); + + p := pData; + for i := 0 to _pExtendedHeader^.Numdatabase - 1 do + begin + pLength := p; // length byte, including itself + SetString(DatabaseName, p+1, pLength^-1); // use length value minus the length byte to get the string length + _ReferencedFiles.Add( DatabaseName ); + inc( p, pLength^ ); // skip to next entry using full length (including length byte) + end; + FreeMem( pData ); +end; + +procedure THelpFile.ReadFontTableData; +begin + if _pExtendedHeader = nil then + // no extended header -> no font table + exit; + + if _pExtendedHeader^.NumFontEntry = 0 then + exit; + + ReadFileBlock( _pFontTableData, + _pExtendedHeader^.FontTableOffset, + _pExtendedHeader^.NumFontEntry * sizeof( THelpFontSpec ) ); +end; + +procedure THelpFile.ParseFontTable; +var + i: longint; + p: pointer; + pFontSpec: pTHelpFontSpec; +begin + _FontTable.Clear; + + p := _pFontTableData; + if p = nil then + exit; // no data + + for i := 0 to _pExtendedHeader^.NumFontEntry - 1 do + begin + pFontSpec := p + i * sizeof( THelpFontSpec ); + _FontTable.Add( pFontSpec ); + end; +end; + +procedure THelpFile.GetImages( ImageOffsets: TList; + Images: TImageList ); +var + ListIndex: longint; + ImageOffset: longint; + Bitmap: THelpBitmap; +begin + Images.Clear; + + for ListIndex := 0 to ImageOffsets.Count - 1 do + begin + ImageOffset := longint( ImageOffsets[ ListIndex ] ); + try + Bitmap := THelpBitmap.CreateFromHelpFile( _Handle, + _pHeader^.imgstart + + ImageOffset ); + except + on e: EHelpBitmapException do +{ raise EHelpFileException.Create( 'Error loading help bitmap at' + + IntToStr( ImageOffset ) + + ': ' + + e.Message );} + begin + Bitmap := THelpBitmap.Create; + Bitmap.LoadFromResourceName( 'MissingBitmap' ); + end; + end; + + Images.Add( Bitmap, nil ); + Bitmap.Destroy; + + end; +end; + +function THelpFile.GetImage( ImageOffset: longint ): THelpBitmap; +begin + try + Result := THelpBitmap.CreateFromHelpFile( _Handle, + _pHeader^.imgstart + + ImageOffset ); + except + on e: EHelpBitmapException do +{ raise EHelpFileException.Create( 'Error loading help bitmap at' + + IntToStr( ImageOffset ) + + ': ' + + e.Message );} + begin + result := nil; + end; + end; +end; + +function THelpFile.GetTopic( Index: longint ): TTopic; +begin + if ( Index < 0 ) + or ( Index > _Topics.Count - 1 ) then + Result := nil + else + Result := TTopic(_Topics[ Index ]); +end; + +function THelpFile.GetTopicCount: longint; +begin + Result := _Topics.Count; +end; + +function THelpFile.IndexOfTopic( Topic: TTopic ): longint; +begin + Result := _Topics.IndexOf( Topic ); +end; + +function THelpFile.GetDictionaryCount: longint; +begin + Result := _Dictionary.Count; +end; + +function THelpFile.GetDictionaryWord( Index: longint ): string; +begin + Result := _Dictionary[ Index ]; +end; + + +// Looks for fonts that should be substitued to the +// users selected fixed font +// doesn't make a lot of sense for this to be here... +procedure THelpFile.SetupFontSubstitutes( Substitutions: string ); +var + Item: string; + FontName: string; + SpacePos: longint; + W: longint; + H: longint; + i: longint; + pFontSpec: pTHelpFontSpec; + tmpSubstitutionItems : TStringList; + tmpCounter : integer; + tmpDimensionParts : TStringList; + s: string; + PointSize: word; + cp: integer; +begin + ParseFontTable; // (re)load table from raw data + + tmpSubstitutionItems := TStringList.Create; + StrExtractStrings(tmpSubstitutionItems, Substitutions, [';'], #0); + + for tmpCounter := 0 to tmpSubstitutionItems.Count - 1 do + begin + Item := tmpSubstitutionItems[tmpCounter]; + try + if Item <> '' then + begin + // Look for space in xxxx WxH + SpacePos := LastDelimiter(' ', Item); + if SpacePos > 0 then + begin + // fontname comes before + FontName := StrLeft( Item, SpacePos - 1 ); + Delete( Item, 1, SpacePos ); + + // width and height after, with an X between + tmpDimensionParts := TStringList.Create; + StrExtractStrings(tmpDimensionParts, Item, ['x'], #0); + W := StrToInt(tmpDimensionParts[0]); + H := StrToInt(tmpDimensionParts[1]); + tmpDimensionParts.Destroy; + if ( W > 0 ) and ( H > 0 ) then + begin + // Now look through the font table for matches + for i := 0 to _FontTable.Count - 1 do + begin + pFontSpec := _FontTable[ i ]; + cp := pFontSpec^.Codepage; + s := StrNPas( pFontSpec^.FaceName, sizeof( pFontSpec^.FaceName ) ); + if s = FontName then + begin + // same face name... + // this formula seems to give a simulated pointsize compared to + // what the original VIEW program intended. + PointSize := (pFontSpec^.Height * 2) div 3; + if ( H = PointSize ) then + begin + // match + pFontSpec^.Codepage := High(word); // font substitute marker added +// _FontTable[ i ] := SubstituteFixedFont; + end; + end; + end; + end; + end; + end; + except + end; + end; + + tmpSubstitutionItems.Free; +end; + + +// ------------------------------------------------------------- +// Get the title only from specific help file (if possible) + +function GetHelpFileTitle( const Filename: string ): string; +var + Header: THelpFileHeader; + fstream: TFileStream; + Ext: string; +begin + Ext := ExtractFileExt( Filename ); + Result := ''; + + if SameText( Ext, '.inf' ) + or SameText( Ext, '.hlp' ) then + begin + try + try + fstream := TFileStream.Create(Filename, fmOpenRead); + fstream.Position := 0; + FillChar( Header, sizeof( Header ), 0 ); + fstream.Read(Header, SizeOf(Header)); + if Header.ID = INF_HEADER_ID then + Result := StrPas(Header.title); + except + // silently ignore errors - it's not to critical at this point. + end; + finally + fstream.Free; + end; + end; +end; + + +end. + diff --git a/docview/src/HelpTopic.pas b/docview/src/HelpTopic.pas new file mode 100644 index 00000000..ea32080b --- /dev/null +++ b/docview/src/HelpTopic.pas @@ -0,0 +1,2698 @@ +Unit HelpTopic; + +{$mode objfpc}{$H+} + +// NewView - a new OS/2 Help Viewer +// Copyright 2003 Aaron Lawrence (aaronl at consultant dot com) +// This software is released under the Gnu Public License - see readme.txt + +Interface + +// This is it - the monster which decodes IPF data. +// It's created with a reference to the contents data defining it. +// It gets relevant pointers out of that. When GetText is called +// it decodes the data and spits out formatted text to suit +// RichTextView. + +uses + Classes, + HelpWindowDimensions, + IPFFileFormatUnit; + +const + DefaultGroupIndex = 0; + + RTF_NewLine = #10; + +var + { TODO -oGraeme -cPointers : I don't like this - double check alternatives later } + // placeholder for font table entry, indiciating user fixed font should be substituted + SubstituteFixedFont: pointer = Pointer(1); + +type + THelpLink = class(TObject) + public + HelpFile: TObject; // file this link is within + // Even though it doesn't do anything, + // we have to have a constructor to allow + // virtual constructors to work + constructor Create; virtual; + end; + + + THelpTopicSlot = class(TObject) + public + pData: pUInt8; // Pointer to actual Slot structure in INF file. + Size: longint; // Number of bytes in the text for this Slot (slotheader.ntext) + pLocalDictionary: UInt16ArrayPointer; // Pointer to Slot's local dictionary + LocalDictSize: uint8; // Number of entries in the local dictionary + destructor Destroy; override; + end; + + + THelpLinkClass = class of THelpLink; + + + TFootnoteHelpLink = class(THelpLink) + public + TopicIndex: longint; + Title: string; // from text within link + end; + + + TWindowedHelpLink = class(THelpLink) + public + GroupIndex: longint; // DefaultGroupIndex if not specified. + // Note: Overrides contents group index of topic + Automatic: boolean; // link should be automatically followed on topic display + Split: boolean; // link should open the window within the parent + ViewPort: boolean; // link should always open a new window + Dependent: boolean; // window opened by link should be closed + // when current topic is closed + Rect: THelpWindowRect; // Display window with this rectangle. + // Note: overrides contents rect + constructor Create; override; + destructor Destroy; override; + end; + + + TInternalHelpLink = class(TWindowedHelpLink) + public + TopicIndex: longint; + end; + + + THelpLinkByResourceID = class(TWindowedHelpLink) + public + ResourceID: longint; + end; + + + SlotArray = array[0..0] of THelpTopicSlot; + pSlotArray = ^SlotArray; + + + TFontState = (fsNormal, fsFixed, fsCustom); + TIPFTextAlignment = (itaLeft, itaRight, itaCenter, itaCenterOnePara); + + + TParseState = record + Alignment: TIPFTextAlignment; + ForegroundColorTag: string; + BackgroundColorTag: string; + Spacing: boolean; + FontState: TFontState; + InCharGraphics: boolean; + LinkIndex: longint; + StartOfTextBlock: longint; + TextBlock: string; + FootnoteLink: TFootnoteHelpLink; + StyleCode: longint; + end; + + + TTopic = class(TObject) + protected + _FileHandle: TFileStream; + _pTOCEntry: pTTOCEntryStart; + _pSlotOffsets: UInt32ArrayPointer; + _Slots: TList; + _pSlotNumbers: puint16; + _NumSlots: longint; + _Title: string; + _GlobalDictionary: TStringList; + _ShowInContents: boolean; + _ContentsLevel: integer; + _ContentsGroupIndex: longint; + _FontTable: TList; + _ReferencedFiles: TStrings; + procedure SetTitle( const NewValue: string ); + function GetTitle: string; + + // Returns the tag texts for the given bitmap ref + function GetImageText( CurrentAlignment: TIPFTextAlignment; + BitmapOffset: longint; + BitmapFlags: longint; + ImageOffsets: TList ): string; + + Procedure ProcessLinkedImage( Var State: TParseState; + Var pData: pByte; + Var OutputString: string; + ImageOffsets: TList ); + procedure TranslateIPFEscapeCode( Var State: TParseState; + Var pData: pUInt8; + var AText: String; + Var WordsOnLine: longint; + ImageOffsets: TList ); + + function CreateLink( Var LinkIndex: longint; + Var Link: THelpLink; + LinkClass: THelpLinkClass ): boolean; + + procedure EnsureSlotsLoaded; + + // returns true if the escape code at pData results in whitespace. + function IPFEscapeCodeSpace( Var State: TParseState; Var pData: pUInt8 ): boolean; + + function GetNextIPFTextItem( Var SlotIndex: longint; + Var pData: pUInt8; + Var State: TParseState ): longint; + + function CheckForSequence( WordSequences: TList; + SlotIndex: longint; + pData: pUint8; + State: TParseState; + GlobalDictIndex: longint + ): longint; + + public + HelpFile: TObject; + Index: longint; + SearchRelevance: longint; + Links: TList; // only valid after GetText + constructor Create( var FileHandle: TFileStream; + pSlotOffsets: UInt32ArrayPointer; + Dictionary: TStringList; + var pTOCEntry: pTTOCEntryStart; + FontTable: TList; + ReferencedFiles: TStrings ); + destructor Destroy; override; + property Title: string read GetTitle write SetTitle; + procedure SetTitleFromMem( const p: pointer; const Len: byte ); + // Main function for retrieving text for topic. + // HighlightSequences: list of sequences to highlight + // if nil then ignored. + // ShowCodes: indicates debugging: hex output of escape + // codes will be included + // ShowWordSeparators: | will be included after each dictionary + // word inserted + // Text: The output is written to here. IS NOT CLEARED FIRST. + // ImageOffsets: For each image that occurs in the text, + // the help file offset will be written to this list. + // HighlightMatches: if not nil, and HighlightSequences is not nil, + // will return offsets to each highlight match + procedure GetText( HighlightSequences: TList; + ShowCodes: boolean; + ShowWordSeparators: boolean; + var Text: String; + ImageOffsets: TList; + HighlightMatches: TList ); + // if StopAtFirstOccurrence true, returns 0 or 1 + // if false, returns count of occurrences of word + function SearchForWord( DictIndex: integer; + StopAtFirstOccurrence: boolean ): longint; + // searches for sequences out of those listed in WordSequence + // Each element of WordSequence contains a pointer to an array + // of flags for each dictionary word, indicating whether that word + // is to be a possible match. + function SearchForWordSequences( WordSequence: TList; StopAtFirstOccurrence: boolean ): longint; + procedure GetContentsWindowRect( ContentsRect: THelpWindowRect ); + // search for binary data including codes + function SearchForData( Data: pbyte; DataLen: integer ): boolean; + procedure SaveIPFEscapeCode( Var State: TParseState; + Var pData: pUInt8; + Var F: TextFile; + ImageOffsets: TList ); + procedure SaveToIPF( Var f: TextFile; ImageOffsets: TList ); + property ShowInContents: boolean read _ShowInContents; + property ContentsLevel: integer read _ContentsLevel; + property ContentsGroupIndex: longint read _ContentsGroupIndex; + function CountWord( DictIndex: integer ): longint; + function ContainsWord( DictIndex: integer ): boolean; + end; + + +// Compares two topics for purposes of sorting by +// search match relevance +function TopicRelevanceCompare( Item1, Item2: pointer ): longint; + +// Compares two topics for purposes of sorting by title +function TopicTitleCompare( Item1, Item2: pointer ): longint; + + +implementation + + +uses + SysUtils + ,NewViewConstantsUnit + ,nvUtilities + ,ACLStringUtility + ,SettingsUnit + ; + +const + IPFColors: array[ 0..15 ] of string = + ( + //rrggbb + '', // default + '#0000ff', // blue + '#ff0000', // red + '#ff00ff', // pink (purple) + '#00ff00', // green + '#00ffff', // cyan + '#ffff00', // yellow + '#808000', // neutral = brown + '#404040', // dark gray + '#000080', // dark blue + '#800000', // dark red + '#800080', // dark pink (purple) + '#008000', // dark green + '#008080', // dark cyan + '#000000', // black + '#c0c0c0' // pale gray + ); + + // for ecHighlight1 + IPFHighlight1Tags : array [ 0..6 ] of string = + ( + '</i></b></u></color>', // normal + '<i>', // hp1 italitc + '<b>', // hp2 bold + '<b><i>', // hp3 bold italic + '<u>', // hp5 underline + '<u><i>', // hp6 underline italic + '<u><b>' // hp7 underline bold + ); + + // for ecHighlight2 + IPFHighlight2Tags : array [ 0..3 ] of string = + ( + '</i></b></u></color>', // normal + '<color blue>', // hp4 blue + '<color red>', // hp8 red + '<color purple>' // hp9 purple + ); + + BlankString: string = ''; + +var + DefaultTitle: string; + + +function GetBeginLink( LinkIndex: longint ): string; +begin + Result := '<link ' + IntToStr( LinkIndex ) + '>' +end; + +function GetEndLinkTags( const State: TParseState ): string; +begin + Result := '</link>' + State.ForegroundColorTag; +end; + +// Even though it doesn't do anything, +// we have to have a constructor to allow +// virtual constructors to work +constructor THelpLink.Create; +begin + // do nothing +end; + +constructor TWindowedHelpLink.Create; +begin + GroupIndex := DefaultGroupIndex; + Automatic := false; + ViewPort := false; + Dependent := false; + Rect := THelpWindowRect.Create; +end; + +destructor TWindowedHelpLink.Destroy; +begin + Rect.Destroy; +end; + +destructor THelpTopicSlot.Destroy; +begin + { TODO -ograeme -ccleanup memory : Double check this } + FreeMem(pData);// DeallocateMemory( pData ); + FreeMem(pLocalDictionary); // DeallocateMemory( pLocalDictionary ); +end; + +constructor TTopic.Create( var FileHandle: TFileStream; + pSlotOffsets: UInt32ArrayPointer; + Dictionary: TStringList; + var pTOCEntry: pTTOCEntryStart; + FontTable: TList; + ReferencedFiles: TStrings ); +var + pExtendedInfo: pExtendedTOCEntry; + titleLen: integer; + XY: THelpXYPair; + p: pbyte; + Flags: byte; +begin + _FileHandle := FileHandle; + _pSlotOffsets := pSlotOffsets; + + _Title := ''; + _GlobalDictionary := Dictionary; + _ContentsGroupIndex := 0; + + _pTOCEntry := pTOCEntry; + _NumSlots := pTOCEntry^.numslots; + + Flags := _pTOCEntry^.flags; + p := pByte( _pTOCEntry ) + sizeof( TTOCEntryStart ); + + if ( Flags and TOCEntryExtended ) = TOCEntryExtended then + begin + pExtendedInfo := pExtendedTOCEntry( p ); + inc( p, sizeof( TExtendedTOCEntry ) ); + + if ( pExtendedInfo^.w1 and 1 ) > 0 then + // skip position + inc( p, sizeof( XY ) ); + + if ( pExtendedInfo^.w1 and 2 ) > 0 then + // skip size + inc( p, sizeof( XY ) ); + + if ( pExtendedInfo^.w1 and 8 ) > 0 then + // skip window controls + inc( p, sizeof(word) ); // increment by 2 + + if ( pExtendedInfo^.w1 and $40 ) > 0 then + // skip something else, unknown... style? 2 bytes + inc( p, sizeof(word) ); // increment by 2 + + if ( pExtendedInfo^.w2 and 4 ) > 0 then + begin + _ContentsGroupIndex := pUInt16(p)^; + // read group + inc( p, sizeof( uint16 ) ); + end; + end; + + // skip slot numbers for now. + _pSlotNumbers := pUInt16(p); + inc( p, _NumSlots * sizeof( uint16 ) ); + + // Calculate the remainder of the tocentry length - that is the bytes used for TOC topic (title) text + titleLen := _pTOCEntry^.length - ( longword( p ) - longword( _pTOCEntry ) ); + + // Read title + if TitleLen > 0 then + SetTitleFromMem( p, TitleLen ) + else + Title := DefaultTitle; + + _ContentsLevel := ( Flags and TOCEntryLevelMask ); + _ShowInContents := Flags and TOCEntryHidden = 0; + if _ContentsLevel = 0 then + _ShowInContents := false; // hmmm.... + + _FontTable := FontTable; + _ReferencedFiles := ReferencedFiles; +end; + +destructor TTopic.Destroy; +begin + LogEvent(LogObjConstDest, 'TTopic.Destroy'); + DestroyListAndObjects( Links ); + DestroyListAndObjects( _Slots ); + inherited Destroy; +end; + +procedure TTopic.SetTitle( const NewValue: string ); +begin + _Title := NewValue; +end; + +procedure TTopic.SetTitleFromMem( const p: pointer; const Len: byte ); +begin + //FreePString( _Title ); + //GetMem( _Title, Len + 1 ); + //_Title^[ 0 ] := char( Len ); + //MemCopy( p, _Title + 1, Len ); + SetString(_Title, p, Len); +end; + +function TTopic.GetTitle: string; +begin + Result := _Title; +end; + +// Replace < and > characters with doubles << and >> +// for compatibility with richtextview. +// This works in place, assuming that instances of > or < are +// actually rare. In practice, IPF normally would insert these +// two characters as distinct words, but I don't want to assume that. +procedure SubstituteAngleBrackets( Var s: string ); +var + i: integer; +begin + i := 1; + while i <= Length( S ) do + begin + case S[ i ] of + '<': + begin + Insert( '<', s, i ); + inc( i ); + end; + + '>': + begin + Insert( '>', s, i ); + inc( i ); + end; + end; + inc( i ); + end; +end; + +function TTopic.GetImageText( CurrentAlignment: TIPFTextAlignment; + BitmapOffset: longint; + BitmapFlags: longint; + ImageOffsets: TList ): string; +var + BitmapIndex: longint; + OriginalAlignTag: string; + ImageTag: string; + AlignTag: string; +begin + BitmapIndex := ImageOffsets.IndexOf( pointer( BitmapOffset ) ); + if BitmapIndex = -1 then + BitmapIndex := ImageOffsets.Add( pointer( BitmapOffset ) ); + + ImageTag := '<image ' + + IntToStr( BitmapIndex ) + + '>'; + + if ( BitmapFlags and $08 ) > 0 then + begin + // stretch to fit - not implemented + end; + + // aligned + case CurrentAlignment of + itaLeft: + OriginalAlignTag := '<align left>'; + itaRight: + OriginalAlignTag := '<align right>'; + itaCenter, + itaCenterOnePara: + OriginalAlignTag := '<align center>'; + end; + + case BitmapFlags and 7 of + 0, // curious - should not occur? does in dbexpert.hlp + 1: // left + AlignTag := '<align left>'; + 2: // right + AlignTag := '<align right>'; + 4,5: // centre (4 is official, 5 seems to occur too) + AlignTag := '<align center>'; + end; + + Result := AlignTag + + ImageTag + + OriginalAlignTag; + + if ( BitmapFlags and $10 ) = 0 then + begin + // NOT runin, new lines before and after + Result := RTF_NewLine + Result + RTF_NewLine; + end; + +end; + +Procedure SaveImageText( BitmapOffset: longint; + BitmapFlags: longint; + Var F: TextFile; + ImageOffsets: TList ); +var + ImageIndex: longint; +begin + ImageIndex := ImageOffsets.IndexOf( pointer( BitmapOffset ) ); + if ImageIndex = -1 then + ImageIndex := ImageOffsets.Add( pointer( BitmapOffset ) ); + + Write( F, ':artwork name=' ); + Write( F, StrInSingleQuotes('img' + IntToStr(ImageIndex) + '.bmp') ); + + case BitmapFlags and 7 of + 2: // right + Write( F, ' align=right' ); + 4,5: // centre (4 is official, 5 seems to occur too) + Write( F, ' align=center' ); + end; + + if ( BitmapFlags and $10 ) > 0 then + begin + // runin + Write( F, ' runin' ); + end; + + // fit ... + Write( F, '.' ); +end; + +Procedure TTopic.ProcessLinkedImage( Var State: TParseState; + Var pData: pByte; + Var OutputString: string; + ImageOffsets: TList ); +var + EscapeLen: uint8; + EscapeCode: uint8; + SubEscapeCode: uint8; + BitmapOffset: longword; + BitmapFlags: uint8; + Link: TInternalHelpLink; + LinkTopicIndex: uint16; +begin + LinkTopicIndex := -1; + while true do + begin + EscapeLen := pData^; + SubEscapeCode := ( pData + 2 )^; + case SubEscapeCode of + HPART_DEFINE: + begin + BitmapFlags := ( pData + 3 )^; + BitmapOffset := pUInt32( pData + 4 )^; + end; + + HPART_HDREF: // define whole bitmap topic link? + begin + LinkTopicIndex := pUInt16( pData + 3 )^; + end; + end; + inc( pData, EscapeLen ); + + // Now pData points at next code or item + if pData^ <> IPF_ESC then + // not an escape code, done + break; + EscapeCode := (pData + 2) ^; + if EscapeCode <> ecLinkedImage then + // not a hyperlink code, done + break; + // another linked image code is coming up. + SubEscapeCode := ( pData + 3 )^; + if SubEscapeCode = HPART_DEFINE then + // started another linked image. + break; + inc( pData ); // move pointer to escape code len. + end; + + OutputString := GetImageText( State.Alignment, + BitmapOffset, + BitmapFlags, + ImageOffsets ); + + // Don't make it a link if we didn't find a + // overall link code, i.e. degrade gracefully. + if LinkTopicIndex > -1 then + begin + if CreateLink( State.LinkIndex, Link, TInternalHelpLink ) then + begin + Link.TopicIndex := LinkTopicIndex; + end; + + OutputString := GetBeginLink( State.LinkIndex ) + + OutputString + + GetEndLinkTags( State ); + + inc( State.LinkIndex ); + end; + +end; + +Procedure SaveLinkedImage( Var pData: pByte; + Var F: TextFile; + ImageOffsets: TList ); +var + EscapeLen: uint8; + EscapeCode: uint8; + SubEscapeCode: uint8; + BitmapOffset: longword; + BitmapFlags: uint8; + LinkTopicIndex: uint16; +begin + LinkTopicIndex := -1; + while true do + begin + EscapeLen := pData^; + SubEscapeCode := ( pData + 2 )^; + case SubEscapeCode of + HPART_DEFINE: + begin + BitmapFlags := ( pData + 3 )^; + BitmapOffset := pUInt32( pData + 4 )^; + end; + + HPART_HDREF: // define whole bitmap topic link? + begin + LinkTopicIndex := pUInt16( pData + 3 )^; + end; + end; + inc( pData, EscapeLen ); + + // Now pData points at next code or item + if pData^ <> IPF_ESC then + // not an escape code, done + break; + EscapeCode := (pData + 2) ^; + if EscapeCode <> ecLinkedImage then + // not a hyperlink code, done + break; + // another linked image code is coming up. + SubEscapeCode := ( pData + 3 )^; + if SubEscapeCode = HPART_DEFINE then + // started another linked image. + break; + inc( pData ); // move pointer to escape code len. + end; + + SaveImageText( BitmapOffset, + BitmapFlags, + F, + ImageOffsets ); + + // Don't make it a link if we didn't find a + // overall link code, i.e. degrade gracefully. + if LinkTopicIndex > -1 then + begin + WriteLn( F, '' ); + WriteLn( F, ':artlink.' ); + Write( F, ':link reftype=hd' ); + Write( F, ' refid=' + IntToStr( LinkTopicIndex ) ); + WriteLn( F, '.' ); + WriteLn( F, ':eartlink.' ); + end; + +end; + +Procedure GetExtraLinkData( Link: TWindowedHelpLink; + pData: pUInt8 ); +var + LinkFlags1: uint8; + LinkFlags2: uint8; + LinkDataIndex: longint; + pLinkXY: pHelpXYPair; + pLinkData: pUInt8; +begin + LinkFlags1 := ( pData + 0 ) ^; + LinkFlags2 := ( pData + 1 ) ^; + + pLinkData := pData + 2; + + if ( LinkFlags1 and 1 ) > 0 then + begin + // position specified + pLinkXY := pHelpXYPair( pLinkData ); + ReadHelpPosition( pLinkXY^, Link.Rect ); + inc( pLinkData, sizeof( THelpXYPair ) ); + end; + + if ( LinkFlags1 and 2 ) > 0 then + begin + // size specified + pLinkXY := pHelpXYPair( pLinkData ); + ReadHelpSize( pLinkXY^, Link.Rect ); + inc( pLinkData, sizeof( THelpXYPair ) ); + end; + + if ( LinkFlags1 and 8 ) > 0 then + begin + // window controls specified - skip + inc( pLinkData, 2 ); + end; + + if ( LinkFlags2 and 4 ) > 0 then + begin + // group specified + Link.GroupIndex := pUInt16( pLinkData )^; + inc( LinkDataIndex, sizeof( uint16 ) ); + end; + + if ( LinkFlags1 and 64 ) > 0 then + begin + Link.Automatic := true; + end; + + if ( LinkFlags1 and 4 ) > 0 then + Link.ViewPort := true; + + if ( LinkFlags2 and 2 ) > 0 then + Link.Dependent := true; + + if ( LinkFlags1 and 128 ) > 0 then + Link.Split := true; + + // cant be bothered with the others. +end; + +// If the given link has already been decoded +// ie. the topic has been displayed before, +// then return the already decoded link & return false +// Otherwise, create a new link object & return true +function TTopic.CreateLink( Var LinkIndex: longint; + Var Link: THelpLink; + LinkClass: THelpLinkClass ): boolean; +begin + if LinkIndex >= Links.Count then + begin + Link := LinkClass.Create; + Link.HelpFile := HelpFile; + Links.Add( Link ); + Result := true; + end + else + begin + Link := THelpLink(Links[ LinkIndex ]); + Result := false; + end; +end; + +const + // size of the original View's default font + AverageViewCharWidth = 8; + +procedure GetMarginTag( const Margin: longint; + FontState: TFontState; + Var MarginString: string; + BreakIfPast: boolean ); +begin + MarginString := '<leftmargin '; + if FontState <> fsCustom then + // for standard fonts, scale margins to match font + MarginString := MarginString + IntToStr( Margin ) + else + // for custom fonts, since the IPF margins were always in + // terms of the standard font size, set the margin to a width based on that. + MarginString := MarginString + IntToStr( Margin * AverageViewCharWidth ) + ' pixels'; + + if BreakIfPast then + MarginString := MarginString + ' breakifpast'; + + MarginString := MarginString + '>'; +end; + +// TODO +function FullDoubleQuote( const s: string ): string; +begin + Result := StrDoubleQuote + + StrEscapeAllCharsBy(s, [], CharDoubleQuote) + + StrDoubleQuote; +end; + +// End URL, if it has been started. Go back and insert the start tag, +// and add the end tag. +procedure CheckForAutoURL( var Text: string; var State: TParseState ); +var + T: string; +begin + if State.StartOfTextBlock = -1 then + // haven't got any text yet + exit; + + TrimPunctuation( State.TextBlock ); + + if not CheckAndEncodeURL( State.TextBlock ) then + begin + // not a URL we know + State.TextBlock := ''; + exit; + end; + + // It's a URL. Insert link at start of URL + T := '<blue><link ' + PARAM_LINK_URL + ' "'; + T := T + State.TextBlock; + T := T + '">'; + Insert(T, Text, State.StartOfTextBlock); + Text := Text + GetEndLinkTags(State); + + State.TextBlock := ''; + State.StartOfTextBlock := -1; +end; + +procedure TTopic.TranslateIPFEscapeCode( Var State: TParseState; + Var pData: pUInt8; + var AText: String; + Var WordsOnLine: longint; + ImageOffsets: TList ); +var + EscapeLen: uint8; + EscapeCode: uint8; + + Link: TInternalHelpLink; + FootnoteLink: TFootnoteHelpLink; + LinkByResourceID: THelpLinkByResourceID; + + Margin: integer; + + BitmapOffset: longword; + BitmapFlags: uint8; + + ColorCode: uint8; + StyleCode: uint8; + + FontIndex: uint8; + pFontSpec: pTHelpFontSpec; + + FaceName: string; + PointSize: longint; + QuotedFaceName: string; + + ExternalLinkFileIndex: uint8; + ExternalLinkTopicID: string; + + ProgramLink: string; + ProgramPath: string; + ProgramFilename: string; + ProgramInfo : TSerializableStringList; + tmpProgramLinkParts : TStringList; + + OutputString: string; +begin + EscapeLen := pData^; + EscapeCode := (pData + 1)^; + OutputString := ''; + + case EscapeCode of + + ecSetLeftMargin: + begin + CheckForAutoURL( AText, State ); + Margin := integer( ( pData + 2 )^ ); + GetMarginTag( Margin, State.FontState, OutputString, false ); + end; + + ecSetLeftMarginNewLine: + begin + CheckForAutoURL( AText, State ); + Margin := integer( ( pData + 2 )^ ); + GetMarginTag( Margin, State.FontState, OutputString, false ); + OutputString := OutputString + + RTF_NewLine; + end; + + ecSetLeftMarginFit: + begin + CheckForAutoURL( AText, State ); + Margin := integer( ( pData + 2 )^ ); + GetMarginTag( Margin, State.FontState, OutputString, true ); + // note that this will cause following tex to be "tabbed" across to the + // new margin position, if not yet there. + // if we are already past this margin then a new line should be started. + + end; + + ecSetLeftMarginHere: + begin + OutputString := '<leftmargin here>'; + end; + + ecHighlight1: + begin + StyleCode := ( pData + 2 )^; + if StyleCode <= High( IPFHighlight1Tags ) then + OutputString := IPFHighlight1Tags[ StyleCode ]; + if StyleCode = 0 then + State.ForegroundColorTag := '</color>'; + end; + + ecHighlight2: + begin + StyleCode := ( pData + 2 )^; + if StyleCode <= High( IPFHighlight2Tags ) then + OutputString := IPFHighlight2Tags[ StyleCode ]; + + if StyleCode = 0 then + State.ForegroundColorTag := '</color>' + else + State.ForegroundColorTag := OutputString; // only colours + end; + + ecLinkStart: + begin + CheckForAutoURL( AText, State ); + if CreateLink( State.LinkIndex, Link, TInternalHelpLink ) then + begin + Link.TopicIndex := pUInt16( pData + 2 )^; + + if EscapeLen >= 6 then + begin + GetExtraLinkData( Link, pData + 4 ); + end; + end; + + // If it's not an automatic link + // then put code in to show it. + if not Link.Automatic then + begin + OutputString := '<blue>' + + GetBeginLink( State.LinkIndex ); + end; + + inc( State.LinkIndex ); + end; + + ecFootnoteLinkStart: + begin + CheckForAutoURL( AText, State ); + if CreateLink( State.LinkIndex, FootnoteLink, TFootnoteHelpLink ) then + begin + FootnoteLink.TopicIndex := pUInt16( pData + 2 )^; + State.FootnoteLink := FootnoteLink; + end; + + OutputString := '<blue>' + GetBeginLink( State.LinkIndex ); + + inc( State.LinkIndex ); + end; + + ecStartLinkByResourceID: + begin + CheckForAutoURL( AText, State ); + if CreateLink( State.LinkIndex, LinkByResourceID, THelpLinkByResourceID ) then + begin + LinkByResourceID.ResourceID := pUInt16( pData + 2 )^; + + if EscapeLen >= 6 then + begin + GetExtraLinkData( LinkByResourceID, pData + 4 ); + end; + end; + + OutputString := '<blue>' + GetBeginLink( State.LinkIndex ); + + inc( State.LinkIndex ); + end; + + ecExternalLink: + begin + CheckForAutoURL( AText, State ); + // :link reftype=hd refid=... database=<filename> + ExternalLinkFileIndex := ( pData + 2 )^; + ExternalLinkTopicID := StrNPas( pchar(pData + 4), (pData + 3)^ ); + OutputString := '<blue><link ' + PARAM_LINK_EXTERNAL + ' ' + + IntToStr( ExternalLinkFileIndex ) + + ' ' + + ExternalLinkTopicID + + '>' + + end; + + ecProgramLink: + begin + CheckForAutoURL( AText, State ); + ProgramLink := StrNPas( pchar(pData + 3), EscapeLen-3 ); + + tmpProgramLinkParts := TStringList.Create; + StrExtractStrings(tmpProgramLinkParts, ProgramLink, [' '], #0); + ProgramPath := tmpProgramLinkParts[0]; + tmpProgramLinkParts.Destroy; + + ProgramFilename := ExtractFilename( ProgramPath ); + + if StrStartsWithIgnoringCase(ProgramFilename, PRGM_EXPLORER) + or StrStartsWithIgnoringCase(ProgramFilename, PRGM_NETSCAPE) + or StrStartsWithIgnoringCase(ProgramFilename, PRGM_MOZILLA) + or StrStartsWithIgnoringCase(ProgramFilename, PRGM_FIREFOX) + then + begin + OutputString := '<blue><link ' + PARAM_LINK_URL + ' ' + + FullDoubleQuote( ProgramLink ) + + '>'; + end + else + begin + ProgramInfo := TSerializableStringList.create; + ProgramInfo.add(ProgramPath); + ProgramInfo.add(ProgramLink); + OutputString := '<blue><link ' + PARAM_LINK_PROGRAM + ' ' + + ProgramInfo.getSerializedString + + '>'; + ProgramInfo.destroy; + end; + end; + + ecLinkEnd: + begin + OutputString := GetEndLinkTags( State ); + if State.FootnoteLink <> nil then + State.FootnoteLink := nil; + end; + + ecStartCharGraphics: + begin + State.FontState := fsFixed; + State.InCharGraphics := true; + OutputString := RTF_NewLine + RTF_NewLine + '<tt><wrap no>'; + State.Spacing := false; + WordsOnLine := 0; + end; + + ecEndCharGraphics: + begin + State.FontState := fsNormal; + State.InCharGraphics := false; + OutputString := '</tt><wrap yes>' + RTF_NewLine; + State.Spacing := true; + end; + + ecImage: + begin + CheckForAutoURL( AText, State ); + BitmapFlags := ( pData + 2 )^; + BitmapOffset := pUInt32( pData + 3 )^; + + OutputString := GetImageText( State.Alignment, + BitmapOffset, + BitmapFlags, + ImageOffsets ); + if State.Spacing + AND (OutputString[Length(OutputString)] <> RTF_NewLine) // no space after a line break + then + OutputString := OutputString + ' '; + end; + + ecLinkedImage: + begin + CheckForAutoURL( AText, State ); + ProcessLinkedImage( State, + pData, + OutputString, + ImageOffsets ); + if State.Spacing then + OutputString := OutputString + ' '; + + // Note! Early exit, since the procedure + // will update pData. + AText := AText + OutputString; + exit; + end; + + ecStartLines: + begin + CheckForAutoURL( AText, State ); + // aligned text + case ( pData + 2 )^ of + 0, // just in case - to match image alignment oddities + 1: + begin + OutputString := RTF_NewLine + '<align left>'; + State.Alignment := itaLeft; + end; + + 2: + begin + OutputString := RTF_NewLine + '<align right>'; + State.Alignment := itaRight; + end; + + 4: + begin + OutputString := RTF_NewLine + '<align center>'; + State.Alignment := itaCenter; + end; + end; + OutputString := OutputString + '<wrap no>'; + WordsOnLine := 0; + end; + + ecEndLines: + begin + CheckForAutoURL( AText, State ); + // supposed to turn word wrap on, default font + OutputString := '<align left><wrap yes>'; // I guess... + State.Alignment := itaLeft; + end; + + ecForegroundColor: + begin + ColorCode := ( pData + 2 )^; + if ColorCode = 0 then + State.ForegroundColorTag := '</color>' + else if ColorCode <= High( IPFColors ) then + State.ForegroundColorTag := '<color ' + IPFColors[ ColorCode ] + '>'; + OutputString := State.ForegroundColorTag; + end; + + ecBackgroundColor: + begin + ColorCode := ( pData + 2 )^; + if ColorCode = 0 then + State.BackgroundColorTag := '</backcolor>' + else if ColorCode <= High( IPFColors ) then + State.BackgroundColorTag := '<backcolor ' + IPFColors[ ColorCode ] + '>'; + OutputString := State.BackgroundColorTag; + end; + + ecFontChange: + begin + FontIndex := ( pData + 2 )^; + if FontIndex = 0 then + begin + // back to default font + OutputString := '</font>'; + State.FontState := fsNormal; + end + else if FontIndex < _FontTable.Count then + begin + // valid font index + pFontSpec := _FontTable[ FontIndex ]; + +// if pFontSpec = SubstituteFixedFont then + if pFontSpec^.Codepage = High(word) then // Substitute Fixed Font detected + begin + OutputString := '<tt>'; + State.FontState := fsFixed; + end + else + begin +// pFontSpec := _FontTable[ FontIndex ]; + FaceName := StrNPas( pFontSpec^.FaceName, sizeof(pFontSpec^.FaceName) ); + // arbitrarily and capriciously use specified height * 2/3 + // as the point size - seems to correspond to what original + // view wanted... note this doesn't necessarily scale + // correctly, since default font could be different. whatever. + PointSize := (pFontSpec^.Height * 2) div 3; + + if PointSize < 8 then + PointSize := 8; + // quote font name, escape double quotes with duplicates + // e.g. Bob's "Big" Font would become + // "Bob's ""Big"" Font" + QuotedFaceName := FullDoubleQuote( FaceName ); + OutputString := '<font ' + + QuotedFaceName + + ' ' + + IntToStr( PointSize ) + + '>'; + { + // for when (if ever) RTV allows setting font + // by precise dimensions + + '[' + + IntToStr( pFontSpec ^. Width ) + + 'x' + + IntToStr( pFontSpec ^. Height ) + + ']'; + } + State.FontState := fsCustom; + end; + end; + end + end; // case escape code of... + + AText := AText + OutputString; + inc( pData, EscapeLen ); +end; + +// returns true if the escape code results in whitespace +// also updates the bits of State that relate to spacing +// ie. .Spacing, and .InCharGraphics (which affects whether +// spacing is reset at paragraph ends etc) +function TTopic.IPFEscapeCodeSpace( Var State: TParseState; + Var pData: pUInt8 ): boolean; +var + EscapeLen: uint8; + EscapeCode: uint8; + +begin + EscapeLen := pData^; + EscapeCode := (pData + 1) ^; + + result := false; // for most + case EscapeCode of + ecSetLeftMargin, + ecSetLeftMarginNewLine, + ecSetLeftMarginFit: + result := true; + + ecStartCharGraphics: + begin + result := true; + State.InCharGraphics := true; + State.Spacing := false; + end; + + ecEndCharGraphics: + begin + result := true; + State.InCharGraphics := false; + State.Spacing := true; + end; + + ecImage: + result := State.Spacing; + + ecLinkedImage: + result := State.Spacing; + + ecStartLines: + begin + result := true; + State.Spacing := false; + end; + + ecEndLines: + begin + result := true; + // supposed to turn word wrap on, default font + State.Spacing := true; + end; + end; // case escape code of... + + inc( pData, EscapeLen ); +end; + +procedure TTopic.EnsureSlotsLoaded; +var + i: longint; + pSlotNumber: puint16; + SlotNumber: uint16; + SlotHeader: TSlotHeader; + Slot: THelpTopicSlot; + bytes: integer; + expected: integer; +begin + if _Slots = nil then + begin + try + _Slots := TList.Create; + + // Read slot data + pSlotNumber := _pSlotNumbers; + + for i := 1 to _NumSlots do + begin + SlotNumber := pSlotNumber^; + + // Seek to start of slot + try + _FileHandle.Seek(_pSlotOffsets^[SlotNumber], soBeginning); + except + // not a valid offset + raise EHelpFileException.Create( ErrorCorruptHelpFile ); + end; + + // Read header + bytes := _FileHandle.Read(SlotHeader, SizeOf(TSlotHeader)); + if bytes <> SizeOf(TSlotHeader) then + // couldn't read slot header + raise EHelpFileException.Create( 'Failed to load Topic Slots.' ); + + // Create slot object + Slot := THelpTopicSlot.Create; + + Slot.LocalDictSize := SlotHeader.nLocalDict; + Slot.Size := SlotHeader.ntext; + + // Allocate and read slot dictionary + _FileHandle.Seek(SlotHeader.localDictPos, soBeginning); + expected := uint32(Slot.LocalDictSize) * sizeof(uint16); // size we need + if Slot.pLocalDictionary = nil then + // allocate memory + Slot.pLocalDictionary := GetMem(expected); + bytes := _FileHandle.Read(Slot.pLocalDictionary^, expected); + if bytes <> expected then + raise EHelpFileException.Create('Failed to read complete slot dictionary'); + + // Allocate and read slot data (text) + _FileHandle.Seek(_pSlotOffsets^[SlotNumber] + sizeof(TSlotHeader), soBeginning); + expected := Slot.Size; // size we need + if Slot.pData = nil then + // allocate memory + Slot.pData := GetMem(expected); + bytes := _FileHandle.Read(Slot.pData^, expected); + if bytes <> expected then + raise EHelpFileException.Create('Failed to read complete slot data (text)'); + + _Slots.Add( Slot ); + inc( pByte(pSlotNumber), sizeof( UInt16 ) ); + end; + except + on E: EHelpFileException do + begin + DestroyListAndObjects( _Slots ); + raise; + end; + end; + end; +end; + +// returns a global dict index. +// or, -1 for a whitespace item. +// or, -2 for end of text. +function TTopic.GetNextIPFTextItem( Var SlotIndex: longint; + Var pData: pUInt8; + Var State: TParseState ): longint; +var + Slot: THelpTopicSlot; + pSlotEnd: pUInt8; + + LocalDictIndex: uint8; +begin + while SlotIndex < _NumSlots do + begin + Slot := THelpTopicSlot(_Slots[ SlotIndex ]); + pSlotEnd := Slot.pData + Slot.Size; + + while pData < pSlotEnd do + begin + LocalDictIndex := pData^; + inc( pData ); + + if LocalDictIndex < Slot.LocalDictSize then + begin + // Normal word lookup + result := Slot.pLocalDictionary^[ LocalDictIndex ]; + exit; + end; + + // special code + case LocalDictIndex of + IPF_END_PARA: + begin + result := -1; + if not State.InCharGraphics then + State.Spacing := true; + exit; + end; + + IPF_CENTER: + begin + result := -1; + exit; + end; + + IPF_INVERT_SPACING: + begin + State.Spacing := not State.Spacing; + end; + + IPF_LINEBREAK: + begin + result := -1; + if not State.InCharGraphics then + State.Spacing := true; + exit; + end; + + IPF_SPACE: + begin + result := -1; + exit; + end; + + IPF_ESC: + begin + // escape sequence + if IPFEscapeCodeSpace( State, pData ) then + result := -1; + end; + end; + end; // while in slot... + inc( SlotIndex ); + end; + Result := -2; +end; + +// Checks to see if the given word (at pData) +// starts one of the given sequences, by looking forward +// If found, returns the length of the sequence. +function TTopic.CheckForSequence( WordSequences: TList; + SlotIndex: longint; + pData: pUint8; + State: TParseState; + GlobalDictIndex: longint + ): longint; +var + WordSequence: TList; + SequenceStepIndex: longint; + pSequenceStepWords: Uint32ArrayPointer; + + SequenceIndex: longint; + + SlotIndexTemp: longint; + pDataTemp: pUint8; + StateTemp: TParseState; +// s : string; + DictIndex: longint; +begin + result := 0; // if we don't find a match. + + for SequenceIndex := 0 to WordSequences.Count - 1 do + begin + WordSequence := TList(WordSequences[ SequenceIndex ]); + pSequenceStepWords := WordSequence[ 0 ]; + + if pSequenceStepWords^[ GlobalDictIndex ] > 0 then + begin + // matched first step in this sequence. Look ahead... + + SequenceStepIndex := 0; + + pDataTemp := pData; + SlotIndexTemp := SlotIndex; + StateTemp := State; + while true do + begin + inc( SequenceStepIndex ); + if SequenceStepIndex = WordSequence.Count then + begin + // have a match for the sequence, insert start highlight + Result := WordSequence.Count; + break; + end; + + // get words for next step in sequence + pSequenceStepWords := WordSequence[ SequenceStepIndex ]; + + DictIndex := GetNextIPFTextItem( SlotIndexTemp, + pDataTemp, + StateTemp ); + if DictIndex = -2 then + begin + // end of text - abort + break; + end; + + if DictIndex = -1 then + begin + // whitespace - abort + // for multi-word phrase searching - count this and subsequent whitespace... + break; + end; + +// s := _GlobalDictionary[ DictIndex ]; // for debug only + if not StrIsEmptyOrSpaces(_GlobalDictionary[ DictIndex ]) then + begin + if pSequenceStepWords^[ DictIndex ] = 0 then + begin + // word doesn't match - abort + break; + end; + end; + + end; // while + + end; + // else - doesn't match first step, do nothing + end; // for sequenceindex ... +end; + +// Main translation function. Turns the IPF data into +// a text string. Translates formatting codes into tags +// as for Rich Text Viewer. +procedure TTopic.GetText( HighlightSequences: TList; + // each element is a TList + // containing a sequence of possible words + // each element of each sequence + // is an array of flags for the dictionary + // indicating if the word is a allowed match at that step + // a match is any sequence that matches one or more words at each step. + ShowCodes: boolean; + ShowWordSeparators: boolean; + var Text: String; + ImageOffsets: TList; + HighlightMatches: TList ); +var + SlotIndex: integer; + Slot: THelpTopicSlot; + pData: pUInt8; + pSlotEnd: pUInt8; + + GlobalDictIndex: uint32; + + WordsOnLine: longint; + + StringToAdd: string; + LocalDictIndex: uint8; + + State: TParseState; + + EscapeLen: uint8; + i: longint; + + SequenceStepIndex: longint; +begin + if Links = nil then + Links := TList.Create; + + if HighlightMatches <> nil then + HighlightMatches.Clear; + + // Text.Clear; + ImageOffsets.Clear; + + try + EnsureSlotsLoaded; + except + on E: EHelpFileException do + begin + Text := Text + E.Message; + exit; + end; + end; + + WordsOnLine := 0; + + State.LinkIndex := 0; + State.FontState := fsNormal; // ? Not sure... this could be reset at start of slot + State.InCharGraphics := false; + State.Spacing := true; + State.ForegroundColorTag := '</color>'; + State.BackgroundColorTag := '</backcolor>'; + State.StartOfTextBlock := -1; + State.TextBlock := ''; + State.FootnoteLink := nil; + Text := Text + '<leftmargin 1>'; + + SequenceStepIndex := 0; + + for SlotIndex := 0 to _NumSlots - 1 do + begin + if not State.InCharGraphics then + State.Spacing := true; // this is just a guess as to the exact view behaviour. + // inf.txt indicates that spacing is reset to true at + // slot (cell) start, but that doesn't seem to be the + // case when in character graphics... hey ho. + + Slot := THelpTopicSlot(_Slots[ SlotIndex ]); + pData := Slot.pData; + pSlotEnd := pData + Slot.Size; + State.Alignment := itaLeft; + + while pData < pSlotEnd do + begin + LocalDictIndex := pData^; + inc( pData ); + + if LocalDictIndex < Slot.LocalDictSize then + begin + // Normal word lookup + GlobalDictIndex := Slot.pLocalDictionary^[ LocalDictIndex ]; + + if ShowWordSeparators then + Text := Text + '{' + IntToStr( GlobalDictIndex )+ '}'; + + // normal lookup + if GlobalDictIndex < _GlobalDictionary.Count then + StringToAdd := _GlobalDictionary[ GlobalDictIndex ] + else + StringToAdd := ''; + + if StrIsEmptyOrSpaces( StringToAdd ) then + begin + // spaces only... + CheckForAutoURL( Text, State ); + end + else + begin + // really is a word, not a space. + + // store string into "word" + if Length(State.TextBlock) = 0 then + // store start of block + State.StartOfTextBlock := Length(Text); + + State.TextBlock := State.TextBlock + StringToAdd; + + SubstituteAngleBrackets( StringToAdd ); + + if HighlightSequences <> nil then + begin + if SequenceStepIndex > 0 then + begin + // currently highlighting a sequence. + dec( SequenceStepIndex ); + if SequenceStepIndex = 0 then + begin + // now finished, insert end highlight + StringToAdd := StringToAdd + + State.BackgroundColorTag; + + end; + end + else + begin + // not yet in a sequence, searching. + SequenceStepIndex := + CheckForSequence( HighlightSequences, + SlotIndex, + pData, + State, + GlobalDictIndex ); + + if SequenceStepIndex > 0 then + begin + // this word starts a sequence! + if HighlightMatches <> nil then + HighlightMatches.Add( pointer( Length(Text) ) ); + StringToAdd := '<backcolor #' + + IntToHex( Settings.Colors[ SearchHighlightTextColorIndex ], 6 ) + + '>' + + StringToAdd; + dec( SequenceStepIndex ); + if SequenceStepIndex = 0 then + // and ends it. + StringToAdd := StringToAdd + + State.BackgroundColorTag; + end; + + end; + end; // if processing sequence + inc( WordsOnLine ); + end; + + Text := Text + StringToAdd; + + if State.FootnoteLink <> nil then + begin + State.FootnoteLink.Title := State.FootnoteLink.Title + StringToAdd; + if State.Spacing then + begin + State.FootnoteLink.Title := State.FootnoteLink.Title + ' '; + end; + end; + + if State.Spacing then + begin + CheckForAutoURL( Text, State ); + Text := Text + ' '; + end; + end + else + begin + // special code + + if ShowCodes then + begin + Text := Text + '[' + IntToHex( LocalDictIndex, 2 ); + if LocalDictIndex = IPF_ESC then + begin + EscapeLen := pData^; + for i := 1 to EscapeLen - 1 do + Text := Text + ' ' + IntToHex( ( pData + i )^, 2 ); + end; + Text := Text + ']'; + end; + + case LocalDictIndex of + IPF_END_PARA: + begin + if SlotIndex = 0 then + if pData - 1 = Slot.pData then + // ignore first FA, not needed with RichTextView + continue; + + CheckForAutoURL( Text, State ); + if State.Alignment = itaCenterOnePara then + begin + State.Alignment := itaLeft; + Text := Text + '<align left>'; + end; + Text := Text + RTF_NewLine; + + if WordsOnLine > 0 then + Text := Text + RTF_NewLine; + + if not State.InCharGraphics then + State.Spacing := true; + + WordsOnLine := 0; + end; + + IPF_CENTER: + begin + CheckForAutoURL( Text, State ); + Text := Text + RTF_NewLine + '<align center>'; + State.Alignment := itaCenterOnePara; + end; + + IPF_INVERT_SPACING: + begin + if not State.InCharGraphics then + State.Spacing := not State.Spacing; + end; + + IPF_LINEBREAK: + begin + CheckForAutoURL( Text, State ); + + if State.Alignment = itaCenterOnePara then + begin + State.Alignment := itaLeft; + Text := Text + '<align left>'; + end; + Text := Text + RTF_NewLine; + if not State.InCharGraphics then + State.Spacing := true; + WordsOnLine := 0; + end; + + IPF_SPACE: + begin + CheckForAutoURL( Text, State ); + if State.Spacing then + Text := Text + ' '; + end; + + IPF_ESC: + begin + // escape sequence + TranslateIPFEscapeCode( State, + pData, + Text, + WordsOnLine, + ImageOffsets ); + + end; + + end; // case code of... + end; + end; // for slotindex = ... + end; + State.TextBlock := ''; +end; + +function TTopic.SearchForWord( DictIndex: integer; + StopAtFirstOccurrence: boolean ) + : longint; +var + SlotIndex: integer; + Slot: THelpTopicSlot; + pData: pUInt8; + pSlotEnd: pUInt8; + + EscapeLen: longint; + + GlobalDictIndex: uint32; + + LocalDictIndex: uint8; +begin + EnsureSlotsLoaded; + + Result := 0; + for SlotIndex := 0 to _NumSlots - 1 do + begin + Slot := THelpTopicSlot(_Slots[ SlotIndex ]); + + pData := Slot.pData; + + pSlotEnd := pData + Slot.Size; + + while pData < pSlotEnd do + begin + LocalDictIndex := pData^; + + if LocalDictIndex < Slot.LocalDictSize then + begin + // Normal word lookup + GlobalDictIndex := Slot.pLocalDictionary^[ LocalDictIndex ]; + + if GlobalDictIndex = DictIndex then + begin + inc( result ); + if StopAtFirstOccurrence then + exit; + end; + end + else + begin + // special code + if LocalDictIndex = $ff then + begin + // escape string, skip it + EscapeLen := ( pData + 1 ) ^; + inc( pData, EscapeLen ); + end; + end; + + inc( pData ); + end; // for slotindex = ... + end; +end; + +// Search for a sequence of bytes, including in escape codes +// this is for debugging to allow finding specific sequences +function TTopic.SearchForData( Data: pbyte; + DataLen: integer ): boolean; +var + SlotIndex: integer; + Slot: THelpTopicSlot; + pData: pUInt8; + pSlotEnd: pUInt8; + + pHold: pUint8; + pSearch: pUint8; +begin + EnsureSlotsLoaded; + + for SlotIndex := 0 to _NumSlots - 1 do + begin + Slot := THelpTopicSlot(_Slots[ SlotIndex ]); + + pSearch := Data; + pHold := Slot.pData; + pData := Slot.pData; + pSlotEnd := Slot.pData + Slot.Size; + + while pHold < pSlotEnd do + begin + if pData^ = pSearch^ then + begin + // byte matches + inc( pData ); + inc( pSearch ); + if ( pSearch >= Data + DataLen ) then + begin + // matches + result := true; + exit; + end + end + else + begin + // no match + pSearch := Data; + inc( pHold ); + pData := pHold; + end; + end; // for slotindex = ... + end; + + result := false; // not found +end; + +function TTopic.SearchForWordSequences( WordSequence: TList; + StopAtFirstOccurrence: boolean ): longint; +var + SlotIndex: integer; + Slot: THelpTopicSlot; + pData: pUInt8; + pSlotEnd: pUInt8; + + EscapeLen: longint; + + GlobalDictIndex: uint32; + IsWord: boolean; + WordRelevance: uint32; + + CurrentMatchRelevance: uint32; // total relevances for words matched so far + // in the current sequence + +// CurrentMatch: string; // useful for debugging only + LocalDictIndex: uint8; + + SequenceIndex: longint; + SequenceStartSlotIndex: longint; + pSequenceStartData: pUInt8; + + pStepWordRelevances: UInt32ArrayPointer; // word relevances for the current step in the sequence + + // get the current slot start and end pointers + procedure GetSlot; + begin + Slot := THelpTopicSlot(_Slots[ SlotIndex ]); + pData := Slot.pData; + pSlotEnd := pData + Slot.Size; + end; + + // get pointer to the current set of word relevances + procedure GetStepFlags; + begin + pStepWordRelevances := WordSequence[ SequenceIndex ]; + end; + + // store the current point as start of a sequence + procedure StoreStartOfSequence; + begin + SequenceIndex := 0; + SequenceStartSlotIndex := SlotIndex; + pSequenceStartData := pData; + CurrentMatchRelevance := 0; +// CurrentMatch := ''; + GetStepFlags; + end; + +begin + Result := 0; + + EnsureSlotsLoaded; + + if _NumSlots = 0 then + // thar's nowt in yon topic, cannae be a match laid + exit; + + SlotIndex := 0; + + GetSlot; + + StoreStartOfSequence; + + while true do + begin + LocalDictIndex := pData^; + IsWord := false; + if LocalDictIndex < Slot.LocalDictSize then + begin + IsWord := true; + // Normal word lookup, so get the global dict idnex before we + // (potentially) move to next slot + GlobalDictIndex := Slot.pLocalDictionary^[ LocalDictIndex ]; + end; + + inc( pData ); + if pData >= pSlotEnd then + begin + // reached end of slot, next please + inc( SlotIndex ); + if SlotIndex < _NumSlots then + GetSlot; + // else - there is nothing more to search + // but we need to check this last item + end; + + if IsWord then + begin + // Normal word lookup + WordRelevance := 0; + + if GlobalDictIndex < _GlobalDictionary.Count then + if not StrIsEmptyOrSpaces( _GlobalDictionary[ GlobalDictIndex ] ) then; + WordRelevance := pStepWordRelevances^[ GlobalDictIndex ]; + + if WordRelevance > 0 then + begin + // Found a matching word + inc( CurrentMatchRelevance, WordRelevance ); +// debug: +// CurrentMatch := CurrentMatch + +// pstring( _GlobalDictionary[ GlobalDictIndex ] )^; + + if SequenceIndex = 0 then + begin + // remember next start point + SequenceStartSlotIndex := SlotIndex; + pSequenceStartData := pData; + end; + + inc( SequenceIndex ); + + if SequenceIndex < WordSequence.Count then + begin + // get next set of flags. + GetStepFlags; + end + else + begin + // found a complete sequence. Cool! + + inc( result, CurrentMatchRelevance ); + + if StopAtFirstOccurrence then + exit; + + // start looking from the beginning of the sequence again. + StoreStartOfSequence; + end; + end + else + begin + // not a match at this point, restart search + if SequenceIndex > 0 then + begin + // we had matched one or more steps already, + // back to start of sequence AND back to + // point we started matching from (+1) + SequenceIndex := 0; + CurrentMatchRelevance := 0; +// CurrentMatch := ''; + SlotIndex := SequenceStartSlotIndex; + GetSlot; + pData := pSequenceStartData; + GetStepFlags; + end + else + begin + // haven't matched anything yet. + // update start of sequence + SequenceStartSlotIndex := SlotIndex; + pSequenceStartData := pData; + end; + end; + end + else + begin + // special code + if LocalDictIndex = $ff then + begin + // escape string, skip it + EscapeLen := pData ^; + inc( pData, EscapeLen ); + end; + end; + + if SlotIndex >= _NumSlots then + begin + // finished searching topic + break; + end; + + // next item + end; +end; + + +function TTopic.CountWord( DictIndex: integer ): longint; +begin + Result := SearchForWord( DictIndex, false ); +end; + +function TTopic.ContainsWord( DictIndex: integer ): boolean; +begin + Result := SearchForWord( DictIndex, true ) > 0; +end; + +// Gets the window dimensions specified by this topic's +// contents header +procedure TTopic.GetContentsWindowRect( ContentsRect: THelpWindowRect ); +var + extendedinfo: TExtendedTOCEntry; + XY: THelpXYPair; + p: pbyte; + + Flags: byte; +begin + Flags := _pTOCEntry ^.flags; + p := pByte( _pTOCEntry + sizeof( TTOCEntryStart ) ); + + ContentsRect.Left := 0; + ContentsRect.Bottom := 0; + ContentsRect.Width := 100; + ContentsRect.Height := 100; + + if ( Flags and TOCEntryExtended ) > 0 then + begin + // have more details available... + ExtendedInfo.w1 := p^; + ExtendedInfo.w2 := ( p+1) ^; + inc( p, sizeof( ExtendedInfo ) ); + + if ( ExtendedInfo.w1 and 1 ) > 0 then + begin + // read origin + XY := pHelpXYPair( p )^; + inc( p, sizeof( XY ) ); + ReadHelpPosition( XY, ContentsRect ); + end; + if ( ExtendedInfo.w1 and 2 ) > 0 then + begin + // read size + XY := pHelpXYPair( p )^; + inc( p, sizeof( XY ) ); + ReadHelpSize( XY, ContentsRect ); + end; + end; +end; + +const + IPFColorNames: array[ 0..15 ] of string = + ( + 'default', + 'blue', + 'red', + 'pink', + 'green', + 'cyan', + 'yellow', + 'neutral', +// 'brown', ?? + 'darkgray', + 'darkblue', + 'darkred', + 'darkpink', + 'darkgreen', + 'darkcyan', + 'black', + 'palegray' + ); + +Procedure SaveExtraLinkData( Link: TWindowedHelpLink; + pData: pUInt8 ); +var + LinkFlags1: uint8; + LinkFlags2: uint8; + LinkDataIndex: longint; + pLinkXY: pHelpXYPair; + pLinkData: pUInt8; +begin + LinkFlags1 := ( pData + 0 ) ^; + LinkFlags2 := ( pData + 1 ) ^; + + pLinkData := pData + 2; + + if ( LinkFlags1 and 1 ) > 0 then + begin + // position specified + pLinkXY := pHelpXYPair( pLinkData ); + inc( pLinkData, sizeof( THelpXYPair ) ); + end; + + if ( LinkFlags1 and 2 ) > 0 then + begin + // size specified + pLinkXY := pHelpXYPair( pLinkData ); + inc( pLinkData, sizeof( THelpXYPair ) ); + end; + + if ( LinkFlags1 and 8 ) > 0 then + begin + // window controls specified - skip + inc( pLinkData, 2 ); + end; + + if ( LinkFlags2 and 4 ) > 0 then + begin + // group specified + Link.GroupIndex := pUInt16( pLinkData )^; + inc( LinkDataIndex, sizeof( uint16 ) ); + end; + + if ( LinkFlags1 and 64 ) > 0 then + begin + Link.Automatic := true; + end; + + if ( LinkFlags1 and 4 ) > 0 then + Link.ViewPort := true; + + if ( LinkFlags2 and 2 ) > 0 then + Link.Dependent := true; + + if ( LinkFlags1 and 128 ) > 0 then + Link.Split := true; + + // cant be bothered with the others. +end; + +procedure TTopic.SaveIPFEscapeCode( Var State: TParseState; + Var pData: pUInt8; + Var F: TextFile; + ImageOffsets: TList ); +var + EscapeLen: uint8; + EscapeCode: uint8; + + Margin: integer; + + BitmapOffset: longword; + BitmapFlags: uint8; + + ColorCode: uint8; + StyleCode: uint8; + + FontIndex: uint8; + pFontSpec: pTHelpFontSpec; + + FaceName: string; + + ExternalLinkFileIndex: uint8; + ExternalLinkTopicID: string; + + ProgramLink: string; + ProgramPath: string; + tmpProgramLinkParts : TStringList; + + OutputString: string; +begin + EscapeLen := pData^; + EscapeCode := (pData + 1) ^; + OutputString := ''; + + case EscapeCode of + + ecSetLeftMargin: + begin + Margin := integer( ( pData + 2 )^ ); + GetMarginTag( Margin, State.FontState, OutputString, false ); + end; + + ecSetLeftMarginNewLine: + begin + Margin := integer( ( pData + 2 )^ ); + GetMarginTag( Margin, State.FontState, OutputString, false ); + OutputString := OutputString + + RTF_NewLine; + end; + + ecSetLeftMarginFit: + begin + Margin := integer( ( pData + 2 )^ ); + GetMarginTag( Margin, State.FontState, OutputString, true ); + // note that this will cause following tex to be "tabbed" across to the + // new margin position, if not yet there. + // if we are already past this margin then a new line should be started. + + end; + + ecSetLeftMarginHere: + begin + OutputString := '<leftmargin here>'; + end; + + ecHighlight1: // hp1,2,3, 5,6,7 + begin + StyleCode := ( pData + 2 ) ^; + if StyleCode > 3 then + StyleCode := StyleCode + 1; // 4, 8 and 9 are expressed in highlight2 code + + if StyleCode > 0 then + Write( F, ':hp' + IntToStr( StyleCode ) + '.' ) + else + Write( F, ':ehp' + IntToStr( State.StyleCode ) + '.' ); + State.StyleCode := StyleCode; + end; + + ecHighlight2: // hp4, 8, 9 + begin + StyleCode := ( pData + 2 ) ^; + case StyleCode of + 1: StyleCode := 4; + 2: StyleCode := 8; + 3: StyleCode := 9; + end; + + if StyleCode > 0 then + Write( F, ':hp' + IntToStr( StyleCode ) + '.' ) + else + Write( F, ':ehp' + IntToStr( State.StyleCode ) + '.' ); + State.StyleCode := StyleCode; + end; + + ecLinkStart: + begin + Write( F, ':link reftype=hd' ); // link to heading + + Write( F, ' refid=' + IntToStr( pUInt16( pData + 2 )^ ) ); + + { + if EscapeLen >= 6 then + begin + GetExtraLinkData( Link, pData + 4 ); + end;} + +// if Link.Automatic then +// Write( F, ' auto' ); + + Write( F, '.' ); + + inc( State.LinkIndex ); + end; + + ecFootnoteLinkStart: + begin + Write( F, ':link reftype=fn refid=fn' + + IntToStr( pUInt16( pData + 2 )^ ) + + '.' ); + inc( State.LinkIndex ); + end; + + ecStartLinkByResourceID: + begin + Write( F, ':link reftype=hd res=' + + IntToStr( pUInt16( pData + 2 )^ ) + + '.' ); + + inc( State.LinkIndex ); + end; + + ecExternalLink: + begin + ExternalLinkFileIndex := ( pData + 2 )^; + ExternalLinkTopicID := StrNPas( pchar( pData + 4 ), ( pData + 3 )^ ); + Write( F, ':link reftype=hd ' + + ' refid=' + StrInSingleQuotes( ExternalLinkTopicID ) + + ' database=' + StrInSingleQuotes( _ReferencedFiles[ ExternalLinkFileIndex ] ) + + '.' ); + + end; + + ecProgramLink: + begin + ProgramLink := StrNPas( pchar( pData + 3 ), EscapeLen - 3 ); + tmpProgramLinkParts := TStringList.Create; + StrExtractStrings(tmpProgramLinkParts, ProgramLink, [' '], #0); + ProgramPath := tmpProgramLinkParts[0]; + tmpProgramLinkParts.Destroy; + + Write( F, ':link reftype=launch' + + ' object=' + StrInSingleQuotes( ProgramPath ) + + ' data=' + StrInSingleQuotes( ProgramLink ) + + '.' ); + end; + + ecLinkEnd: + begin + Write( F, ':elink.' ); + if State.FootnoteLink <> nil then + State.FootnoteLink := nil; + end; + + ecStartCharGraphics: + begin + State.FontState := fsFixed; + State.InCharGraphics := true; + WriteLn( F, '' ); + WriteLn( F, ':cgraphic.' ); + State.Spacing := false; + end; + + ecEndCharGraphics: + begin + State.FontState := fsNormal; + State.InCharGraphics := false; + WriteLn( F, '' ); + WriteLn( F, ':ecgraphic.' ); + State.Spacing := true; + end; + + ecImage: + begin + BitmapFlags := ( pData + 2 )^; + BitmapOffset := pUInt32( pData + 3 )^; + + SaveImageText( BitmapOffset, BitmapFlags, F, ImageOffsets ); + + if State.Spacing then + Write( F, ' ' ); + end; + + ecLinkedImage: + begin + SaveLinkedImage( pData, F, ImageOffsets ); + // Note! Early exit, since the procedure + // will update pData. + exit; + end; + + ecStartLines: + begin + WriteLn( F, '' ); + // aligned text + case ( pData + 2 )^ of + 0, // just in case - to match image alignment oddities + 1: + begin + WriteLn( F, ':lines.' ); + State.Alignment := itaLeft; + end; + + 2: + begin + WriteLn( F, ':lines align=right.' ); + State.Alignment := itaRight; + end; + + 4: + begin + WriteLn( F, ':lines align=center.' ); + State.Alignment := itaCenter; + end; + end; + end; + + ecEndLines: + begin + // supposed to turn word wrap on, default font + WriteLn( F, '' ); + WriteLn( F, ':elines.' ); + State.Alignment := itaLeft; + end; + + ecForegroundColor: + begin + ColorCode := ( pData + 2 )^; + + if ColorCode < High( IPFColorNames ) then + Write( F, ':color fc=' + IPFColorNames[ ColorCode ] + '.' ); + end; + + ecBackgroundColor: + begin + ColorCode := ( pData + 2 )^; + if ColorCode < High( IPFColorNames ) then + Write( F, ':color bc=' + IPFColorNames[ ColorCode ] + '.' ); + end; + + ecFontChange: + begin + FontIndex := ( pData + 2 )^; + if FontIndex = 0 then + begin + // back to default font + Write( F, ':font facename=default.' ); + State.FontState := fsNormal; + end + else if FontIndex < _FontTable.Count then + begin + // valid font index + pFontSpec := _FontTable[ FontIndex ]; + + if pFontSpec = SubstituteFixedFont then + begin + // oops. + OutputString := '<tt>'; + State.FontState := fsFixed; + end + else + begin + pFontSpec := _FontTable[ FontIndex ]; + FaceName := StrNPas( pFontSpec^.FaceName, + sizeof( pFontSpec^.FaceName ) ); + Write( F, + ':font facename=' + StrInSingleQuotes( FaceName ) + + ' size=' + IntToStr( pFontSpec^.Height ) + + 'x' + IntToStr( pFontSpec^.Width ) + + '.' ); + State.FontState := fsCustom; + end; + end; + end + end; // case escape code of... + + // Write( F, OutputString ); + + inc( pData, EscapeLen ); +end; + +procedure TTopic.SaveToIPF( Var f: TextFile; + ImageOffsets: TList ); +var + SlotIndex: integer; + Slot: THelpTopicSlot; + pData: pUInt8; + pSlotEnd: pUInt8; + GlobalDictIndex: uint32; + StringToAdd: string; + LocalDictIndex: uint8; + State: TParseState; + SequenceStepIndex: longint; + LineLen: longint; + c: char; +begin + EnsureSlotsLoaded; + + State.LinkIndex := 0; + State.FontState := fsNormal; // ? Not sure... this could be reset at start of slot + State.InCharGraphics := false; + State.Spacing := true; + State.ForegroundColorTag := '</color>'; + State.BackgroundColorTag := '</backcolor>'; + + State.StartOfTextBlock := -1; + State.TextBlock := ''; + + State.FootnoteLink := nil; + + State.StyleCode := 0; + + SequenceStepIndex := 0; + + LineLen := 0; + + for SlotIndex := 0 to _NumSlots - 1 do + begin + if not State.InCharGraphics then + State.Spacing := true; // this is just a guess as to the exact view behaviour. + // inf.txt indicates that spacing is reset to true at + // slot (cell) start, but that doesn't seem to be the + // case when in character graphics... hey ho. + + Slot := THelpTopicSlot(_Slots[ SlotIndex ]); + + pData := Slot.pData; + + pSlotEnd := pData + Slot.Size; + + State.Alignment := itaLeft; + + while pData < pSlotEnd do + begin + LocalDictIndex := pData^; + inc( pData ); + + if LocalDictIndex < Slot.LocalDictSize then + begin + // Normal word lookup + GlobalDictIndex := Slot.pLocalDictionary^[ LocalDictIndex ]; + + // normal lookup + if GlobalDictIndex < _GlobalDictionary.Count then + StringToAdd := _GlobalDictionary[ GlobalDictIndex ] + else + StringToAdd := ''; + + if (Length( StringToAdd ) = 1) and Settings.IPFTopicSaveAsEscaped then + begin + // could be symbol + c := StringToAdd[ 1 ]; + case C of + '&': StringToAdd := '&.'; + '''': StringToAdd := '&apos.'; + '*': StringToAdd := '&asterisk.'; + '@': StringToAdd := '&atsign.'; + '\': StringToAdd := '&bsl.'; + '^': StringToAdd := '&caret.'; + '"': StringToAdd := '&osq.'; + ':': StringToAdd := '&colon.'; + '.': StringToAdd := '&per.'; + '(': StringToAdd := '&lpar.'; + ')': StringToAdd := '&rpar.'; + '/': StringToAdd := '&slash.'; + ',': StringToAdd := '&comma.'; + '-': StringToAdd := '&hyphen.'; + '_': StringToAdd := '&us.'; + '~': StringToAdd := '&tilde.'; + '+': StringToAdd := '&plus.'; + '>': StringToAdd := '>.'; + ';': StringToAdd := '&semi.'; + Chr($da): StringToAdd := '+'; + Chr($c4): StringToAdd := '-'; + Chr($b3): StringToAdd := '|'; + Chr($c3): StringToAdd := '|'; + Chr($bf): StringToAdd := '+'; + end; + end; + + inc( LineLen, Length( StringToAdd ) ); + if ( LineLen > 80 ) and ( not State.InCharGraphics ) then + begin + WriteLn( F ); + LineLen := 0; + end; + + Write( F, StringToAdd ); +{ + if State.FootnoteLink <> nil then + begin + State.FootnoteLink.Title := State.FootnoteLink.Title + StringToAdd; + if State.Spacing then + begin + State.FootnoteLink.Title := State.FootnoteLink.Title + ' '; + end; + end; + } + if State.Spacing then + begin + Write( F, ' ' ); + inc( LineLen ); + end; + end + else + begin + // special code + + case LocalDictIndex of + IPF_END_PARA: + begin + WriteLn( F, '' ); + Write( F, ':p.' ); + LineLen := 3; + + if not State.InCharGraphics then + State.Spacing := true; + end; + + IPF_CENTER: + begin + WriteLn( F, '' ); + Write( F, '.ce ' ); // remainder of this line is centered. + LineLen := 4; + State.Alignment := itaCenterOnePara; + end; + + IPF_INVERT_SPACING: + begin + State.Spacing := not State.Spacing; + end; + + IPF_LINEBREAK: + begin + WriteLn( F, '' ); + if not State.InCharGraphics then + WriteLn( F, '.br ' ); // break must be the only thing on the line + + LineLen := 0; + if not State.InCharGraphics then + State.Spacing := true; + end; + + IPF_SPACE: + begin + if State.Spacing then + Write( F, ' ' ) + else + Write( F, ' ' ); + end; + + IPF_ESC: + begin + // escape sequence + SaveIPFEscapeCode( State, + pData, + F, + ImageOffsets ); + end; + + end; // case code of... + end; + end; // for slotindex = ... + end; + State.TextBlock := ''; + +end; + +// Compares two topics for purposes of sorting by +// search match relevance +function TopicRelevanceCompare( Item1, Item2: pointer ): longint; +var + Topic1, Topic2: TTopic; +begin + Topic1 := TTopic(Item1); + Topic2 := TTopic(Item2); + + if Topic1.SearchRelevance > Topic2.SearchRelevance then + Result := -1 + else if Topic1.SearchRelevance < Topic2.SearchRelevance then + Result := 1 + else + Result := 0; +end; + +// Compares two topics for purposes of sorting by title +function TopicTitleCompare( Item1, Item2: pointer ): longint; +begin + Result := CompareText( TTopic( Item1 )._Title, + TTopic( Item2 )._Title ); +end; + + +end. diff --git a/docview/src/HelpWindowDimensions.pas b/docview/src/HelpWindowDimensions.pas new file mode 100644 index 00000000..c8335176 --- /dev/null +++ b/docview/src/HelpWindowDimensions.pas @@ -0,0 +1,126 @@ +unit HelpWindowDimensions; + +{$mode objfpc}{$H+} + + // NewView - a new OS/2 Help Viewer + // Copyright 2003 Aaron Lawrence (aaronl at consultant dot com) + // This software is released under the Gnu Public License - see readme.txt + +interface + +uses + IPFFileFormatUnit; + +const + ptCharacters = 0; + ptPercentage = 1; + ptPixels = 2; + ptPoints = 3; + ptDynamic = 4; + + XPosRight = 577; // some random values as markers + YPosTop = 577; + XYPosCenter = 578; + +type + THelpWindowRect = class(TObject) + public + Left: longint; // xposright means, right aligned + Bottom: longint; // xpostop means top aligned + // both: xyposcenter means centered + Width: longint; + Height: longint; + constructor Create; + procedure Assign(Rect: THelpWindowRect); + end; + +var + FootnoteRect: THelpWindowRect; + +procedure ReadHelpSize(const XY: THelpXYPair; var Rect: THelpWindowRect); +procedure ReadHelpPosition(const XY: THelpXYPair; var Rect: THelpWindowRect); + + +implementation + +constructor THelpWindowRect.Create; +begin + Left := -1; + Bottom := -1; + Width := -1; + Height := -1; +end; + +procedure THelpWindowRect.Assign(Rect: THelpWindowRect); +begin + Left := Rect.Left; + Bottom := Rect.Bottom; + Width := Rect.Width; + Height := Rect.Height; +end; + +function GetPos(const PositionType: uint8; const Value: longint): longint; +begin + case PositionType of + ptCharacters: + Result := Value; + ptPercentage: + Result := Value; + ptPixels: + Result := Value * 5; + ptPoints: + Result := Value; + ptDynamic: + case Value of + 1: + Result := 0; // left + 2: + Result := XPosRight; // right + 4: + Result := YPosTop; // top + 8: + Result := 0; // bottom + 16: + Result := XYPosCenter; // center. + end; + end; +end; + +procedure ReadHelpPosition(const XY: THelpXYPair; var Rect: THelpWindowRect); +var + XPositionType: uint8; + YPositionType: uint8; +begin + // read origin + XPositionType := XY.Flags div 16; + YPositionType := XY.Flags and 15; + + if XY.X <> $ffff then + Rect.Left := GetPos(XPositionType, XY.X); + if XY.Y <> $ffff then + Rect.Bottom := GetPos(YPositionType, XY.Y); +end; + +procedure ReadHelpSize(const XY: THelpXYPair; var Rect: THelpWindowRect); +begin + if XY.X <> $ffff then + Rect.Width := XY.X; + if XY.Y <> $ffff then + Rect.Height := XY.Y; +end; + +initialization + FootnoteRect := THelpWindowRect.Create; + with FootnoteRect do + begin + Left := 10; + Width := 80; + Bottom := 10; + Height := 40; + end; + +finalization + FootnoteRect.Free; + +end. + diff --git a/docview/src/IPFEscapeCodes.pas b/docview/src/IPFEscapeCodes.pas new file mode 100644 index 00000000..41e743d4 --- /dev/null +++ b/docview/src/IPFEscapeCodes.pas @@ -0,0 +1,47 @@ +Unit IPFEscapeCodes; + +{$mode objfpc}{$H+} + + +// NewView - a new OS/2 Help Viewer +// Copyright 2001 Aaron Lawrence (aaronl at consultant dot com) +// This software is released under the Gnu Public License - see readme.txt + +Interface + +// List of IPF escape codes. Not complete! Many are just used +// as magic numbers in HelpTopic.pas + +const + // Basic byte codes + IPF_END_PARA = $fa; + IPF_CENTER = $fb; + IPF_INVERT_SPACING = $fc; + IPF_LINEBREAK = $fd; + IPF_SPACE = $fe; + IPF_ESC = $ff; + + // Subescape codes of + HPART_DEFINE = 0; + HPART_PT_HDREF = 1; + HPART_PT_FNREF = 2; + HPART_PT_SPREF = 3; + HPART_HDREF = 4; + HPART_FNREF = 5; + HPART_SPREF = 6; + HPART_LAUNCH = 7; + HPART_PT_LAUNCH = 8; + HPART_INFORM = 9; + HPART_PT_INFORM = 10; + // ?? 11 ?? + HPART_EXTERN_PT_HDREF = 12; + HPART_EXTERN_PT_SPREF = 13; + HPART_EXTERN_HDREF = 14; + HPART_EXTERN_SPREF = 15; + HPART_GLOBAL_HDREF = 16; + HPART_GLOBAL_PT_HDREF = 17; + +Implementation + +Initialization +End. diff --git a/docview/src/IPFFileFormatUnit.pas b/docview/src/IPFFileFormatUnit.pas new file mode 100644 index 00000000..1acc7857 --- /dev/null +++ b/docview/src/IPFFileFormatUnit.pas @@ -0,0 +1,497 @@ +Unit IPFFileFormatUnit; + +{$mode objfpc}{$H+} + +// NewView - a new OS/2 Help Viewer +// Copyright 2003 Aaron Lawrence (aaronl at consultant dot com) +// This software is released under the Gnu Public License - see readme.txt + +Interface + +// Definition of IPF file header and other structures + +uses + SysUtils; + +type + uint32 = longword; + uint16 = word; + uint8 = byte; + pUInt16 = ^uint16; + pUInt32 = ^uint32; + pUInt8 = ^uint8; + Unsigned_31 = 0 .. (1 shl 31) - 1; // 31-bit type + Unsigned_4 = 0 .. (1 shl 4) - 1; // 4-bit type + Unsigned_1 = 0 .. (1 shl 1) - 1; // 1-bit type + + + PCharArray = packed array[ 0..0 ] of PCHar; + UInt32Array = packed array[ 0..0 ] of UInt32; + UInt16Array = packed array[ 0..0 ] of UInt16; + UInt8Array = packed array[ 0..0 ] of UInt8; + + PCharArrayPointer = ^PCharArray; + UInt32ArrayPointer = ^UInt32Array; + UInt16ArrayPointer = ^UInt16Array; + UInt8ArrayPointer = ^UInt8Array; + + TBooleanArray = array[ 0..0 ] of boolean; + BooleanArrayPointer = ^TBooleanArray; + + + EHelpFileException = class( Exception ) + end; + + + EWindowsHelpFormatException = class( Exception ) + end; + + + TProgressCallback = procedure(n, outof: integer; AMessage: string) of object; + + +const + ErrorCorruptHelpFile = 'Corrupt help file, or something similar'; + +const + INF_HEADER_ID = 'HSP'; + +Type + THelpFileHeader = packed record + ID: array[0..2] of ansichar; // ID magic word "HSP" + flags: uint8; // probably a flag word... + // [0x01] bit 0: set if INF style file + // [0x10] bit 4: set if HLP style file + // patching this byte allows reading HLP files + // using the VIEW command, while help files + // seem to work with INF settings here as well. + hdrsize: uint16; // total size of header + version_hi: uint8; + version_lo: uint8; + ntoc: uint16; // number of entries in the tocarray + tocstart: uint32; // file offset of the start of the toc + toclen: uint32; // number of bytes in file occupied by the toc + tocoffsetsstart: uint32; // file offset of the start of array of toc offsets + nres: uint16; // number of panels with ressource numbers + resstart: uint32; // 32 bit file offset of ressource number table + nname: uint16; // number of panels with textual name + namestart: uint32; // 32 bit file offset to panel name table + nindex: uint16; // number of index entries + indexstart: uint32; // 32 bit file offset to index table + indexlen: uint32; // size of index table + icmdCount: uint16; // number of icmd index items + icmdOffset: uint32; // file offset to icmd index items + icmdSize: uint32; // size of icmd index table + searchstart: uint32; // 31 bit file offset of full text search table + // Note: top bit indicates 32 bit search record! + searchlen: uint32; // size of full text search table + nslots: uint16; // number of "slots" + slotsstart: uint32; // file offset of the slots array + dictlen: uint32; // number of bytes occupied by the "dictionary" + ndict: uint16; // number of entries in the dictionary + dictstart: uint32; // file offset of the start of the dictionary + imgstart: uint32; // file offset of image data + maxCVTIndex: byte; // highest index inside panel's local dictionary, + // always seems to be 245 + nlsstart: uint32; // 32 bit file offset of NLS table + nlslen: uint32; // size of NLS table + extstart: uint32; // 32 bit file offset of extended data block + reserved: array[ 0..11 ] of byte; // for future use. set to zero. + title: array[ 0..47 ] of ansichar; // ASCII title of database + end; + TPHelpFileHeader = ^THelpFileHeader; + + TExtendedHelpFileHeader = packed record + NumFontEntry: uint16; // FONT TABLE: Number entries + FontTableOffset: uint32; // FONT TABLE: Offset in file + NumDataBase: uint16; // DATA BASE: Number of files + DataBaseOffset: uint32; // DATA BASE: Offset in file + DataBaseSize: uint32; // DATA BASE: Size in bytes + EntryInGNameTable: uint16; // GLOBAL NAMES: Number entries + HelpPanelGNameTblOffset: uint32; // GLOBAL NAMES: Offset in file + StringsOffset: uint32; // STRINGS : Offset in file + StringsSize: uint16; // STRINGS : Total bytes of all strings + ChildPagesOffset: uint32; // CHILDPAGES : Offset in file + ChildPagesSize: uint32; // CHILDPAGES : Total bytes of all strings + NumGIndexEntry: uint32; // Total number of Global Index items + CtrlOffset: uint32; // CTRL BUTTONS : offset in file + CtrlSize: uint32; // CTRL BUTTONS : size in bytes + Reserved: array[0..3] of uint32; // For future use. Set to zero + end; + TPExtendedHelpFileHeader = ^TExtendedHelpFileHeader; + +Type + TTOCEntryStart = packed record + length: uint8; // length of the entry including this byte (but not including extended data) + flags: uint8; // flag byte, description folows (MSB first) + // bit8 haschildren; // following nodes are a higher level + // bit7 hidden; // this entry doesn't appear in VIEW.EXE's + // presentation of the toc + // bit6 extended; // extended entry format + // bit5 stuff; // ?? + // int4 level; // nesting level + numSlots: uint8; // number of "slots" occupied by the text for + // this toc entry + end; + pTTOCEntryStart = ^TTOCEntryStart; + + TExtendedTOCEntry = packed record + w1: uint8; + // bit 3: Window controls are specified + // bit 2: Viewport + // bit 1: Size is specified. + // bit 0: Position is specified. + w2: uint8; + // bit 3: + // bit 2: Group is specified. + // bit 1 + // bit 0: Clear (all windows before display) + end; + pExtendedTOCEntry = ^TExtendedTOCEntry; + + TTOCEntryOffsetArray = packed array[ 0..0 ] of uint32; + pTTOCEntryOffsetArray = ^TTOCEntryOffsetArray; + +const + TOCEntryExtended = $20; { extended entry format } + TOCEntryHidden = $40; { this entry doesn't appear in VIEW.EXE's presentation of the toc } + TOCEntryHasChildren = $80; { following nodes are a higher level } + TOCEntryLevelMask = $0f; + +type + THelpXYPair = packed record + Flags: uint8; + X: uint16; + Y: uint16; + end; + pHelpXYPair = ^THelpXYPair; + + TSlotHeader = packed record + stuff: uint8; // always 0?? + localdictpos: uint32; // file offset of the local dictionary + nlocaldict: uint8; // number of entries in the local dict + ntext: uint16; // number of bytes in the text + end; + pSlotHeader = ^TSlotHeader; + + THelpFontSpec = packed record + FaceName: array[ 0..32 ] of ansichar; + Height: uint16; + Width: uint16; + Codepage: uint16; + end; + pTHelpFontSpec = ^THelpFontSpec; + + TNlsHeader = packed record + NlsSize: uint16; + NlsType: uint8; + NlsFormat: uint8; + end; + + TNlsCountryDef = packed record + { if the following is true then... + NlsHeader.size = 10 + NlsHeader.type = NLSRecType.CONTROL + NlsHeader.format = 0 + } + Value: uint16; // =256 + Code: uint16; // country code + Page: uint16; // code page + Reserved: uint16; + end; + + // Single-byte character set + TSbcsNlsGrammerDef = packed record + { if the following is true then... + NlsHeader.size = 36 + NlsHeader.type = NLSRecType.WORD || NLSRecType.GRAPHIC + NlsHeader.format = 0 + } + bits: array[0..31] of uint8; // high-order bits first + end; + + TPanelControls = packed record + ControlCount: uint16; // number of ControlDef records + GroupCount: uint16; // number of GroupDef records + GroupIndex: uint16; // for cover page + Reserved: uint16; + end; + + TControlDef = packed record + CtrlType: uint16; // type of control + ResourceID: uint16; // resource id (panel) it belongs to + { variable length data follows, contains button text } + // DictString: array of char; + end; + + TControlGroupDef = packed record + Count: uint16; // number of indexes into ControlDef records + { variable length data follows } + // index[count] of type uint16 + end; + +// List of IPF escape codes. + +const + // Basic byte codes + IPF_END_PARA = $fa; + IPF_CENTER = $fb; + IPF_INVERT_SPACING = $fc; + IPF_LINEBREAK = $fd; + IPF_SPACE = $fe; + IPF_ESC = $ff; // followed by one of the ecXXX codes below + + // FF XX + ecSetLeftMargin = $02; + ecHighlight1 = $04; // hp1,2,3,5,6,7 + ecLinkStart = $05; + ecFootnoteLinkStart = $07; + ecLinkEnd = $08; + ecStartCharGraphics = $0b; + ecEndCharGraphics = $0c; + ecHighlight2 = $0d; // hp4,8,9 + ecImage = $0e; + ecLinkedImage = $0f; + ecProgramLink = $10; + ecSetLeftMarginNewLine = $11; + ecSetLeftMarginFit = $12; + ecForegroundColor = $13; + ecBackgroundColor = $14; + ecFontChange = $19; + ecStartLines = $1a; + ecEndLines = $1b; + ecSetLeftMarginHere = $1c; + ecStartLinkByResourceID = $1d; + ecExternalLink = $1f; + + // Subescape codes of + HPART_DEFINE = 0; + HPART_PT_HDREF = 1; + HPART_PT_FNREF = 2; + HPART_PT_SPREF = 3; + HPART_HDREF = 4; + HPART_FNREF = 5; + HPART_SPREF = 6; + HPART_LAUNCH = 7; + HPART_PT_LAUNCH = 8; + HPART_INFORM = 9; + HPART_PT_INFORM = 10; + // ?? 11 ?? + HPART_EXTERN_PT_HDREF = 12; + HPART_EXTERN_PT_SPREF = 13; + HPART_EXTERN_HDREF = 14; + HPART_EXTERN_SPREF = 15; + HPART_GLOBAL_HDREF = 16; + HPART_GLOBAL_PT_HDREF = 17; + +// ----------------------------------------------------------- +// Operations on Int32 arrays, used for searching +// These could be optimised heavily if needed. +procedure AllocUInt32Array( Var pArray: UInt32ArrayPointer; + Size: longint ); +procedure FreeUInt32Array( Var pArray: UInt32ArrayPointer; + Size: longint ); + +procedure FillUInt32Array( pArray: UInt32ArrayPointer; + Size: longint; + Value: UInt32 ); + +procedure AddUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); + +// Dest = Dest + source * Multiplier +procedure AddMultConstUInt32Array( pSource: UInt32ArrayPointer; + Multiplier: longint; + pDest: UInt32ArrayPointer; + Size: longint ); + +procedure AndUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); + +// If both source and dest > 0 then +// add source to dest +procedure AndAddUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); + +// if Source > 0 then dest is set to 0 +procedure AndNotUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); + +// dest = dest or source; +// if source > 0 then set dest to > 0 +procedure OrUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); + +// if source = 0 then dest set to >0 +procedure NotOrUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); + +procedure CopyUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); + +procedure ClearUInt32Array( pArray: UInt32ArrayPointer; + Size: longint ); +procedure SetUInt32Array( pArray: UInt32ArrayPointer; + Size: longint ); + +// returns the result of ORing every array element. +// Can be useful for debugging e.g. seeing at a glance +// if any element is non-zero +function OrAllUInt32Array( pArray: UInt32ArrayPointer; + Size: longint ): longint; + + +Implementation + + +// Operations on int32 arrays +// ----------------------------------------------------------- + +procedure AllocUInt32Array( Var pArray: UInt32ArrayPointer; + Size: longint ); +begin + GetMem( pArray, + Size + * sizeof( UInt32 ) ); +end; + +procedure FreeUInt32Array( Var pArray: UInt32ArrayPointer; + Size: longint ); +begin + FreeMem( pArray, + Size + * sizeof( UInt32 ) ); +end; + +// This is a nice fast implementation of filling an +// array of dwords (Int32/longword) +procedure FillUInt32Array( pArray: UInt32ArrayPointer; + Size: longint; + Value: UInt32 ); +var + i: integer; +begin + assert( Size > 0 ); + if Size < 1 then + Exit; + for i := 0 to Size-1 do + begin + pArray^[i] := Value; + end; +end; + +procedure ClearUInt32Array( pArray: UInt32ArrayPointer; + Size: longint ); +begin + FillUInt32Array( pArray, Size, 0 ); +end; + +procedure SetUInt32Array( pArray: UInt32ArrayPointer; + Size: longint ); +begin + FillUInt32Array( pArray, Size, $ffffffff ); +end; + +procedure AddUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); +var + i: longint; +begin + for i := 0 to Size - 1 do + inc( pDest^[ i ], pSource^[ i ] ); +end; + +procedure AddMultConstUInt32Array( pSource: UInt32ArrayPointer; + Multiplier: longint; + pDest: UInt32ArrayPointer; + Size: longint ); +var + i: longint; +begin + for i := 0 to Size - 1 do + inc( pDest^[ i ], pSource^[ i ] * Multiplier ); +end; + +procedure OrUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); +var + i: longint; +begin + for i := 0 to Size - 1 do + pDest^[ i ] := pDest^[ i ] or pSource^[ i ]; +end; + +procedure CopyUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); +begin + Move(pSource^, PDest^, Size * SizeOf(LongInt)); +end; + +procedure NotOrUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); +var + i: longint; +begin + for i := 0 to Size - 1 do + if pSource^[ i ] = 0 then + pDest^[ i ] := 1; +end; + +procedure AndUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); +var + i: longint; +begin + for i := 0 to Size - 1 do + pDest^[ i ] := pDest^[ i ] and pSource^[ i ]; +end; + +procedure AndAddUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); +var + i: longint; +begin + for i := 0 to Size - 1 do + if ( pSource^[ i ] > 0 ) + and ( pDest^[ i ] > 0 ) then + inc( pDest^[ i ], pSource^[ i ] ) + else + pDest^[ i ] := 0; +end; + +procedure AndNotUInt32Array( pSource: UInt32ArrayPointer; + pDest: UInt32ArrayPointer; + Size: longint ); +var + i: longint; +begin + for i := 0 to Size - 1 do + if pSource^[ i ] > 0 then + pDest^[ i ] := 0; +end; + +function OrAllUInt32Array( pArray: UInt32ArrayPointer; + Size: longint ): longint; +var + i: longint; +begin + Result := 0; + for i := 0 to Size - 1 do + Result := Result or pArray^[ i ]; +end; + + +end. diff --git a/docview/src/NewViewConstantsUnit.pas b/docview/src/NewViewConstantsUnit.pas new file mode 100644 index 00000000..4e191b15 --- /dev/null +++ b/docview/src/NewViewConstantsUnit.pas @@ -0,0 +1,28 @@ +Unit NewViewConstantsUnit; + +{$mode objfpc}{$H+} + +// NewView - a new OS/2 Help Viewer +// Copyright 2003 Aaron Lawrence (aaronl at consultant dot com) +// Copyright 2006-2009 Ronald Brill (rbri at rbri dot de) +// This software is released under the Gnu Public License - see readme.txt + +// Common used constants for NewView + +Interface + +const + PARAM_LINK_NOTE = 'note'; + PARAM_LINK_PROGRAM = 'program'; + PARAM_LINK_URL = 'url'; + PARAM_LINK_EXTERNAL = 'external'; + + PRGM_EXPLORER = 'explore'; // web explorer + PRGM_NETSCAPE = 'netscape'; + PRGM_MOZILLA = 'mozilla'; + PRGM_FIREFOX = 'firefox'; + + +Implementation + +End. diff --git a/docview/src/SearchTable.pas b/docview/src/SearchTable.pas new file mode 100644 index 00000000..49c67ff5 --- /dev/null +++ b/docview/src/SearchTable.pas @@ -0,0 +1,298 @@ +Unit SearchTable; + +{$mode objfpc}{$H+} + +// NewView - a new OS/2 Help Viewer +// Copyright 2003 Aaron Lawrence (aaronl at consultant dot com) +// This software is released under the Gnu Public License - see readme.txt + +Interface + +uses + Classes, IPFFileFormatUnit; + +// Code to read and use IPF search tables +// NB The RLE decompression was arrived at by trial and error +// it seems to be correct but it's difficult to test. + +type + TSearchTable = class(TObject) + protected + _Data: pointer; + _Entries: TList; // pointers to panel flag records + _RecordLengthIs16Bit: boolean; + _DictionaryCount: longint; + _TopicCount: longint; + + procedure ReadEntries; + + Procedure Check1ByteOfFlags( b: byte; + StartingIndex: longint; + Results: UInt32ArrayPointer ); + + procedure DoRLESearch( p: pbyte; + pDataEnd: pointer; + Results: UInt32ArrayPointer ); + + public + constructor Create( Data: pointer; + RecordLengthIs16Bit: boolean; + DictionaryCount: longint; + TopicCount: longint ); + destructor Destroy; override; + + // Sets Results to 1 for occurrences of DictIndex + procedure Search( DictIndex: uint16; + Results: UInt32ArrayPointer ); + + end; + +Implementation + +constructor TSearchTable.Create( Data: pointer; + RecordLengthIs16Bit: boolean; + DictionaryCount: longint; + TopicCount: longint ); +begin + _Data := Data; + _RecordLengthIs16Bit := RecordLengthIs16Bit; + _Entries := TList.Create; + _DictionaryCount := DictionaryCount; + _TopicCount := TopicCount; + ReadEntries; +end; + +destructor TSearchTable.Destroy; +begin + _Entries.Destroy; +end; + +procedure TSearchTable.ReadEntries; +var + pWordRecord: pointer; + RecordLen: uint16; + WordIndex: uint16; +begin + pWordRecord:= _Data; + + for WordIndex:= 0 to _DictionaryCount - 1 do + begin + _Entries.Add( pWordRecord ); + + if _RecordLengthIs16Bit then + RecordLen:= pUInt16( pWordRecord )^ + else // 8 bit + RecordLen:= pUInt8( pWordRecord )^; + inc( pWordRecord, RecordLen ); + end; +end; + + +// Search table decompression + +// Looks through a single byte of 8 flags, given by b, +// and updates topic entries within results for any flags +// that are set. +Procedure TSearchTable.Check1ByteOfFlags( b: byte; + StartingIndex: longint; + Results: UInt32ArrayPointer ); +var + TopicIndex: longint; +begin + TopicIndex:= StartingIndex; + while b > 0 do + begin + if b and $80 > 0 then + Results^[ TopicIndex ] := 1; + inc( TopicIndex ); + b:= b shl 1; + end; +end; + +// Decompress RLE compressed data starting at p, +// running til pDataEnd. Update topic entries in Results. +procedure TSearchTable.DoRLESearch( p: pbyte; + pDataEnd: pointer; + Results: UInt32ArrayPointer ); +var + TopicIndex: integer; + + N: integer; + thebyte: byte; + byte1, byte2: byte; +begin + assert( pbyte( p )^ = 1, 'Unexpected RLE type' ); + inc( p ); // skip header, always 1? + + TopicIndex:= 0; + + while p < pDataEnd do + begin + thebyte:= p^; + inc( p ); + + if thebyte = $80 then + begin + // escape + thebyte := p^; + inc( p ); + + if thebyte = 0 then + begin + // 16 bit repeat of zeroes?? + N := pUInt16( p )^ + 1; + inc( p, 2 ); + inc( TopicIndex, N ); + end + else + begin + // n+1 repeats of next 2 bytes??? + N := thebyte + 1; + byte1 := p^; + inc( p ); + byte2 := p^; + inc( p ); + while N > 0 do + begin + Check1ByteOfFlags( byte1, + TopicIndex, + Results ); + inc( TopicIndex, 8 ); + Check1ByteOfFlags( byte2, + TopicIndex, + Results ); + inc( TopicIndex, 8 ); + dec( N ); + end; + end; + end + else + begin + N:= thebyte and $7f + 1; + + if thebyte and $80 > 0 then + begin + // literal data + while N > 0 do + begin + Check1ByteOfFlags( p^, + TopicIndex, + Results ); + inc( TopicIndex, 8 ); + inc( p ); + dec( N ); + end; + end + else + begin + // repeat of next byte + thebyte := p^; + inc( p ); + while N > 0 do + begin + Check1ByteOfFlags( thebyte, + TopicIndex, + Results ); + inc( TopicIndex, 8 ); + dec( N ); + end; + end; + end; + end; +end; + +// This function finds uses of the given word (DictIndex) +// using the search table. Results[ topic ] is set to +// non-zero for topics which contain the word. +procedure TSearchTable.Search( DictIndex: uint16; + Results: UInt32ArrayPointer ); +var + TopicIndex: integer; + pWordRecord: pointer; + RecordLen: uint16; + CompressionCode: uint8; + pData: pointer; + pDataEnd: pointer; + Flags: uint8; +begin + FillUInt32Array( Results, _TopicCount, 0 ); + pWordRecord:= _Entries[ DictIndex ]; + + // Check search table format + if _RecordLengthIs16Bit then + begin + RecordLen:= pUInt16( pWordRecord )^; + CompressionCode:= pUInt8( pWordRecord + 2 )^; + pData:= pWordRecord + 3; + end + else // 8 bit + begin + RecordLen:= pUInt8( pWordRecord )^; + CompressionCode:= pUInt8( pWordRecord + 1 )^; + pData:= pWordRecord + 2; + end; + + // Decompress the search table for this word + pDataEnd:= pWordRecord + RecordLen; + case CompressionCode of + 0: // word not used anywhere. + ; + + 1: // used in all panels + FillUInt32Array( Results, _TopicCount, 1 ); + + 2: // RLE + begin + DoRLESearch( pData, + pDataEnd, + Results ); + end; + + 3: // list of topics containing word + begin + while pData < pDataEnd do + begin + TopicIndex:= pUInt16( pData )^; + Results^[ TopicIndex ] := 1; + inc( pData, 2 ); + end; + end; + + 4: // list of topics NOT containing word + begin + FillUInt32Array( Results, _TopicCount, 1 ); + + while pData < pDataEnd do + begin + TopicIndex:= pUInt16( pData )^; + Results^[ TopicIndex ] := 0; + inc( pData, 2 ); + end; + end; + + 5, // compressed by truncating bit stream at last byte containing a set bit. + 6: // same as above but starting at non-zero byte + begin + if CompressionCode = 5 then + TopicIndex:= 0 + else + begin + TopicIndex:= pUInt16( pData )^ * 8; + inc( pData, 2 ); + end; + + while pData < pDataEnd do + begin + Flags:= pUInt8( pData )^; + Check1ByteOfFlags( Flags, + TopicIndex, + Results ); + inc( TopicIndex, 8 ); + inc( pData ); + end; + end; + end; +end; + + +end. diff --git a/docview/src/SearchUnit.pas b/docview/src/SearchUnit.pas new file mode 100644 index 00000000..d8f9c6d6 --- /dev/null +++ b/docview/src/SearchUnit.pas @@ -0,0 +1,567 @@ +Unit SearchUnit; + +{$mode objfpc}{$H+} + +// NewView - a new OS/2 Help Viewer +// Copyright 2003 Aaron Lawrence (aaronl at consultant dot com) +// This software is released under the Gnu Public License - see readme.txt + +Interface + +// Contains code to search help files. + +uses + Classes, + HelpFile, + TextSearchQuery, + IPFFileFormatUnit; + +const + // match weightings + mwOnlyTitleWord = 200; + mwFirstTitleWord = 50; + mwTitleWord = 20; + + mwOnlyIndexWord = 100; + mwFirstIndexWord = 20; + mwIndexWord = 10; + mwTopicTextWord = 1; + + // best case match weighting of a word + mwExactWord = 20; + + +// note on weightings. The title/index weightings +// are multipled by word weightings. +// Topic text matches are equal to word weighting +// times word weighting. + +procedure SearchHelpFile( HelpFile: THelpFile; + Query: TTextSearchQuery; + Results: TList; + WordSequences: TList ); + +// clear a lsit of word sequences (as produced by above) +procedure ClearWordSequences( WordSequences: TList; DictionaryCount: longint ); + +Implementation + +uses + SysUtils + ,HelpTopic + ,CompareWordUnit + ,nvUtilities + ,ACLStringUtility + ; + +type + TSearchType = ( stGeneral, stStarts, stExactMatch, stEnds ); + +procedure ClearWordSequence( WordSequence: TList; + DictionaryCount: longint ); +var + StepIndex: longint; + DictionaryRelevances: UInt32ArrayPointer; +begin + for StepIndex := 0 to WordSequence.Count - 1 do + begin + DictionaryRelevances := WordSequence[ StepIndex ]; + FreeUInt32Array( DictionaryRelevances, DictionaryCount ); + end; + WordSequence.Clear; +end; + +procedure ClearWordSequences( WordSequences: TList; DictionaryCount: longint ); +var + SequenceIndex: longint; + lWordSequence: TList; +begin + for SequenceIndex := 0 to WordSequences.Count - 1 do + begin + lWordSequence := TList(WordSequences[ SequenceIndex ]); + ClearWordSequence( lWordSequence, DictionaryCount ); + lWordSequence.Destroy; + end; + WordSequences.Clear; +end; + +// given a search word which is known to matche Reference word, +// return the relevance +function MatchedWordRelevance( const SearchWord: string; + const ReferenceWord: string ): longint; +begin + Result := mwExactWord + * Length( SearchWord ) + div Length( ReferenceWord ); + if Result = 0 then + Result := 1; +end; + +// Compares the given search word against the given +// reference word. Returns a value indicating how well the +// search word matches, 0 = not at all. +function CompareWord( const SearchWord: string; + const ReferenceWord: string ): longint; +var + OccurrencePos: longint; +begin + Result := 0; + OccurrencePos := CaseInsensitivePos( SearchWord, ReferenceWord ); + if OccurrencePos = 0 then + begin + // no match + exit; + end; + + Result := MatchedWordRelevance( SearchWord, ReferenceWord ); +end; + +// Search the help file dictionary for words that match +// the given search word. Partial matches are considered. +// Results returns the matching word indexes. +procedure SearchDictionary( HelpFile: THelpFile; + SearchWord: string; + Results: UInt32ArrayPointer ); +var + DictIndex: integer; + DictWord: string; +begin + for DictIndex := 0 to HelpFile.DictionaryCount - 1 do + begin + DictWord := HelpFile.DictionaryWords[ DictIndex ]; + Results^[ DictIndex ] := CompareWord( SearchWord, DictWord ); + end; +end; + +// Search the help file dictionary for words that +// match the given search word exactly (except for case-insensitive) +procedure SearchDictionaryExact( HelpFile: THelpFile; + SearchWord: string; + Results: UInt32ArrayPointer ); +var + DictIndex: integer; + DictWord: string; +begin + FillUInt32Array( Results, HelpFile.DictionaryCount, 0 ); + + for DictIndex := 0 to HelpFile.DictionaryCount - 1 do + begin + DictWord := HelpFile.DictionaryWords[ DictIndex ]; + if SameText( SearchWord, DictWord ) then + Results^[ DictIndex ] := mwExactWord; + end; +end; + +// Search the help file dictionary for words that +// start with the given word +procedure SearchDictionaryStarts( HelpFile: THelpFile; + SearchWord: string; + Results: UInt32ArrayPointer ); +var + DictIndex: integer; + DictWord: string; +begin + FillUInt32Array( Results, HelpFile.DictionaryCount, 0 ); + + for DictIndex := 0 to HelpFile.DictionaryCount - 1 do + begin + DictWord := HelpFile.DictionaryWords[ DictIndex ]; + if StrStartsWithIgnoringCase(DictWord, SearchWord) then + Results^[ DictIndex ] := MatchedWordRelevance( SearchWord, DictWord ); + end; +end; + +// Search the help file dictionary for words that +// end with the given word +procedure SearchDictionaryEnds( HelpFile: THelpFile; + SearchWord: string; + Results: UInt32ArrayPointer ); +var + DictIndex: integer; + DictWord: string; +begin + FillUInt32Array( Results, HelpFile.DictionaryCount, 0 ); + + for DictIndex := 0 to HelpFile.DictionaryCount - 1 do + begin + DictWord := HelpFile.DictionaryWords[ DictIndex ]; + if StrEndsWithIgnoringCase( SearchWord, DictWord ) then + Results^[ DictIndex ] := MatchedWordRelevance( SearchWord, DictWord ); + end; +end; + +// Search titles of topics for given searchword +procedure SearchTopicTitles( HelpFile: THelpFile; + SearchWord: string; + Results: UInt32ArrayPointer ); +var + TopicIndex: longint; + Title: string; + TitleWord: string; + Topic: TTopic; + TitleWordIndex: longint; + WordRelevance: longint; + TitleWordRelevance: longint; + tmpTitleWords : TStringList; + i : integer; +begin + tmpTitleWords := TStringList.Create; + + // Search topic titles + for TopicIndex := 0 to HelpFile.TopicCount - 1 do + begin + Topic := HelpFile.Topics[ TopicIndex ]; + Title:= Topic.Title; + TitleWordIndex := 0; + + tmpTitleWords.Clear; + StrExtractStringsQuoted(tmpTitleWords, Title); + + for i := 0 to tmpTitleWords.count-1 do + begin + TitleWord := tmpTitleWords[i]; + + WordRelevance := CompareWord( SearchWord, + TitleWord ); + if WordRelevance > 0 then + begin + if TitleWordIndex = 0 then + begin + // matching the first word is best + if i = tmpTitleWords.count-1 then + begin + // in fact it's the only word + TitleWordRelevance := mwOnlyTitleWord * WordRelevance + end + else + TitleWordRelevance := mwFirstTitleWord * WordRelevance + end + else + begin + TitleWordRelevance := mwTitleWord * WordRelevance; + end; + inc( Results^[ Topic.Index ], TitleWordRelevance ); + end; + inc( TitleWordIndex ); + end; + end; + tmpTitleWords.Free; +end; + +// Search index entries for given searchword +procedure SearchIndex( HelpFile: THelpFile; SearchWord: string; Results: UInt32ArrayPointer ); +var + IndexIndex: longint; + IndexEntry: string; + IndexEntryWord: string; + tmpTopic: TTopic; + IndexEntryWordIndex: longint; + WordRelevance: longint; + IndexEntryWordRelevance: longint; + tmpIndexWords : TStringList; + i : integer; +begin + tmpIndexWords := TStringList.Create; + + for IndexIndex := 0 to HelpFile.Index.Count - 1 do + begin + IndexEntry := HelpFile.Index.GetLabels[IndexIndex]; + IndexEntryWordIndex := 0; + + tmpIndexWords.Clear; + StrExtractStringsQuoted(tmpIndexWords, IndexEntry); + + for i := 0 to tmpIndexWords.count-1 do + begin + IndexEntryWord := tmpIndexWords[i]; + + WordRelevance := CompareWord( SearchWord, IndexEntryWord ); + if WordRelevance > 0 then + begin + if IndexEntryWordIndex = 0 then + begin + // matching the first word is best + if i = tmpIndexWords.count-1 then + begin + // in fact it's the only word + IndexEntryWordRelevance := mwOnlyIndexWord * WordRelevance + end + else + IndexEntryWordRelevance := mwFirstIndexWord * WordRelevance + end + else + begin + IndexEntryWordRelevance := mwIndexWord * WordRelevance; + end; + tmpTopic := HelpFile.Index.getTopic(IndexIndex); + inc( Results^[ tmpTopic.Index ], IndexEntryWordRelevance ); + end; + inc( IndexEntryWordIndex ); + end; + end; + + tmpIndexWords.Free; +end; + +// ------------------------------------------------------ + +// Master search function. Given a search query, +// searches topic text, titles, index entries. +// Matching topics are added to TList, with their +// SearchRelevance set appropriately. +procedure SearchHelpFile( HelpFile: THelpFile; + Query: TTextSearchQuery; + Results: TList; + WordSequences: TList ); +var + TopicCount: longint; + Topic: TTopic; + TopicIndex: longint; + TermIndex: longint; + Term: TSearchTerm; + + DictionaryRelevances: UInt32ArrayPointer; + + TopicsMatchingDictWord: UInt32ArrayPointer; // flags + TopicsMatchingTermPart: UInt32ArrayPointer; // flags + TopicsMatchingTerm: UInt32ArrayPointer; // flag then relevances + TopicRelevances: UInt32ArrayPointer; + TopicsExcluded: UInt32ArrayPointer; + + TopicRelevanceForTerm: longint; + + WordRelevance: longint; + DictIndex: longint; + + TermPartIndex: longint; + TermPart: string; + + s: string; + + TermWordSequence: TList; +begin + if HelpFile.SearchTable = nil then + begin + exit; + end; + + // Reset flags per topic + TopicCount := HelpFile.TopicCount; + + // Get memory for topic relevance arrays + + AllocUInt32Array( TopicsMatchingDictWord, + TopicCount ); + AllocUInt32Array( TopicsMatchingTermPart, + TopicCount ); + AllocUInt32Array( TopicsMatchingTerm, + TopicCount ); + AllocUInt32Array( TopicRelevances, // functions as a flag and a cumulative relevance + TopicCount ); + AllocUInt32Array( TopicsExcluded, // Exclusions are treated as boolean only + TopicCount ); + + FillUInt32Array( TopicRelevances, TopicCount, 0); + FillUInt32Array( TopicsExcluded, TopicCount, 0); + + for TermIndex := 0 to Query.TermCount - 1 do + begin + Term := Query.Term[ TermIndex ]; + + LogEvent(LogSearch, 'Searching for term "' + + Term.Text + + '", ' + + IntToStr( Term.Parts.Count ) + + ' parts' ); + + // look thru all parts of the term. eg. CAKE_SAUSAGE + + TermWordSequence := TList.Create; + + if WordSequences <> nil then + if Term.CombineMethod <> cmExcluded then + // this term is an inclusive one, so we want to remember the matches + WordSequences.Add( TermWordSequence ); + + for TermPartIndex := 0 to Term.Parts.Count - 1 do + begin + TermPart := Term.Parts[ TermPartIndex ]; + + LogEvent(LogSearch, ' Searching for [' + TermPart + ']' ); + + AllocUInt32Array( DictionaryRelevances, + HelpFile.DictionaryCount ); + + TermWordSequence.Add( DictionaryRelevances ); + + // Search the dictionary for matches. + // alpha numeric match + + if Term.Parts.Count = 1 then + // general match allowing all kinds of partial matches + SearchDictionary( HelpFile, + TermPart, + DictionaryRelevances ) + + else if TermPartIndex = 0 then + // first term part: word must match end of a topic word e.g. must end in "cake" + SearchDictionaryEnds( HelpFile, + TermPart, + DictionaryRelevances ) + + else if TermPartIndex = Term.Parts.Count - 1 then + // last term part: word must match start of a topic word e.g. must start with "sausage" + SearchDictionaryStarts( HelpFile, + TermPart, + DictionaryRelevances ) + + else + // intermediate term part: word must match exactly e.g. must be "_" + SearchDictionaryExact( HelpFile, + TermPart, + DictionaryRelevances ); + + // For each word in the dictionary that matches + // this search term part, search topic texts + + LogEvent(LogSearch, ' Dictionary search done' ); + ClearUInt32Array( TopicsMatchingTermPart, + TopicCount ); + + for DictIndex := 0 to HelpFile.DictionaryCount - 1 do + begin + WordRelevance := DictionaryRelevances^[ DictIndex ]; + if WordRelevance > 0 then + begin + // Search for occurrences of this word + // within the text of topics + HelpFile.SearchTable.Search( DictIndex, + TopicsMatchingDictWord ); + + // debug + s := HelpFile.DictionaryWords[ DictIndex ]; + // TopicRelevancesForDictWord now contains 1 + // for topics that contain this word. + + OrUInt32Array( TopicsMatchingDictWord, + TopicsMatchingTermPart, + TopicCount ); + end + end; + + LogEvent(LogSearch, 'Topic searches done' ); + + if TermPartIndex = 0 then + // first part, just copy + CopyUInt32Array( TopicsMatchingTermPart, + TopicsMatchingTerm, + TopicCount ) + else + // and with previous term part results + AndUInt32Array( TopicsMatchingTermPart, + TopicsMatchingTerm, + TopicCount ); + + // loop for next term part (IPF word) + end; + + // Now we have searched the dictionary and worked out matching topics + // for all parts of the term. Now combine all together + + LogEvent(LogSearch, 'Checking for sequences' ); + for TopicIndex := 0 to TopicCount - 1 do + begin + if TopicsMatchingTerm^[ TopicIndex ] > 0 then + begin + Topic := HelpFile.Topics[ TopicIndex ]; + // Topic text contained a match for the all the parts + // of the term. + // Now we need to: + // - verify that they actually occur all in a sequence (if it's a multi-part term) + // - count occurrences for relevance. + + TopicRelevanceForTerm := + Topic.SearchForWordSequences( TermWordSequence, + false ); // don't stop at first match + + TopicRelevanceForTerm := + TopicRelevanceForTerm div Term.Parts.Count; // divide to bring back into scale + + TopicsMatchingTerm^[ TopicIndex ] := TopicRelevanceForTerm; + + end; + end; + + if WordSequences = nil then + begin + // we don't need to keep the sequence + ClearWordSequence( TermWordSequence, HelpFile.DictionaryCount ); + TermWordSequence.Free; + end; + + // Search titles and index + + LogEvent(LogSearch, ' Searching titles' ); + SearchTopicTitles( HelpFile, Term.Text, TopicsMatchingTerm ); + + LogEvent(LogSearch, ' Searching index' ); + SearchIndex( HelpFile, Term.Text, TopicsMatchingTerm ); + + LogEvent(LogSearch, ' Combining' ); + case Term.CombineMethod of + cmOptional: + AddUInt32Array( TopicsMatchingTerm, + TopicRelevances, + TopicCount ); + + cmRequired: + begin + // if zero then add to exclusions + NotOrUInt32Array( TopicsMatchingTerm, + TopicsExcluded, + TopicCount ); + + AddUInt32Array( TopicsMatchingTerm, + TopicRelevances, + TopicCount ); + end; + + cmExcluded: + OrUInt32Array( TopicsMatchingTerm, + TopicsExcluded, + TopicCount ); + end; + +// Term.ClearMatches; + + // loop for next term... + end; + + LogEvent(LogSearch, 'Search completed, converting to list' ); + + // Now convert to list form. + + for TopicIndex := 0 to TopicCount - 1 do + begin + if TopicsExcluded^[ TopicIndex ] = 0 then + begin + Topic := HelpFile.Topics[ TopicIndex ]; + Topic.SearchRelevance := TopicRelevances^[ TopicIndex ]; + if Topic.SearchRelevance > 0 then + begin + Results.Add( Topic ); + end; + end; + end; + + LogEvent(LogSearch, 'Freeing arrays' ); + FreeUInt32Array( TopicRelevances, TopicCount ); + FreeUInt32Array( TopicsExcluded, TopicCount ); + FreeUInt32Array( TopicsMatchingTerm, TopicCount ); + FreeUInt32Array( TopicsMatchingTermPart, TopicCount ); + FreeUInt32Array( TopicsMatchingDictWord, TopicCount ); + + LogEvent(LogSearch, 'Done' ); +end; + +End. diff --git a/docview/src/SettingsUnit.pas b/docview/src/SettingsUnit.pas new file mode 100644 index 00000000..f6b34bc4 --- /dev/null +++ b/docview/src/SettingsUnit.pas @@ -0,0 +1,527 @@ +Unit SettingsUnit; + +{$mode objfpc}{$H+} + +// NewView - a new OS/2 Help Viewer +// Copyright 2003 Aaron Lawrence (aaronl at consultant dot com) +// This software is released under the Gnu Public License - see readme.txt + +Interface + +// Defines settings (options) in a record and contains functions +// for loading and saving them to ini file. + +Uses + Classes + ,fpg_base + ,fpg_main + ,CanvasFontManager + ; + +Const + ContentsBackgroundColorIndex = 0; + ContentsTextColorIndex = 1; + ContentsLinesColorIndex = 2; + IndexBackgroundColorIndex = 3; + IndexTextColorIndex = 4; + SearchBackgroundColorIndex = 5; + SearchTextColorIndex = 6; + NotesListBackgroundColorIndex = 7; + NotesListTextColorIndex = 8; + TopicBackgroundColorIndex = 9; + NotesTextColorIndex = 10; + SearchHighlightTextColorIndex = 11; + NumColorSettings = 12; + + // already defined, but these values are slightly different + //clLightYellow = $ffffc0; + //clLightBlue = $e0e0ff; + //clLightCyan = $c0ffff; + //clLightGreen = $e0ffe0; + + VGADefaultColors: array[ 0 .. NumColorSettings - 1 ] of TfpgColor + = ( clBoxColor, + clText1, + clText1, + clBoxColor, + clText1, + clBoxColor, + clText1, + clBoxColor, + clText1, + clBoxColor, + clGreen, + clYellow ); + + DefaultColors: array[ 0 .. NumColorSettings - 1 ] of TfpgColor + = ( clLightCyan, + clBlack, + clBlue, + clLightGreen, + clBlack, + clLightBlue, + clBlack, + clWhite, + clBlack, + clWhite, + clGreen, + clYellow ); + + ApplicationFontIndex = 0; + NumFontSettings = 1; + + DefaultTopicFont = DefaultTopicFont + '-' + DefaultTopicFontSize; + DefaultTopicFixedFont = DefaultTopicFixedFont + '-10' + DefaultTopicFixedFontSize; + + +Type + TIndexStyle = ( isFileOnly, isAlphabetical, isFull ); + TToolbarStyle = ( tsNone, tsImages, tsText, tsImagesAndText ); + TGlobalSearchLocation = ( gsHelpPaths, gsFixedDrives, gsSelectedHelpPaths, gsCustom ); + + TMRUItem = class(TObject) + public + Title: string; + Filenames: TStringList; + constructor Create; + destructor Destroy; override; + end; + + + TSettings = record + MRUList: TList; + LastOpenDirectory: string; + LastSaveDirectory: string; + StartupHelp: boolean; + LeftPanelWidth: longint; + ShowLeftPanel_Help: boolean; + ShowLeftPanel_Standalone: boolean; + FileDialogSplit: Double; + Colors: array[ 0..NumColorSettings - 1 ] of TfpgColor; + NormalFont: TfpgFont; + FixedFont: TfpgFont; + Fonts: array[ 0..NumFontSettings - 1 ] of TfpgFont; + FixedFontSubstitution: boolean; + FixedFontSubstitutes: string; + IndexStyle: TIndexStyle; + SmoothScrolling: boolean; + UseOriginalDialogs: boolean; + OpenWithExpandedContents: boolean; + ToolbarBackgroundImageFilename: string; + ToolbarStyle: TToolbarStyle; + ConfirmWinHelp: boolean; + GlobalSearchLocation: TGlobalSearchLocation; + SearchDirectories: TStringList; + IPFTopicSaveAsEscaped: boolean; + end; + +// global procs +procedure LoadSettings; +procedure SaveSettings; +procedure writeSettingsDetailsTo(aStrings : TStrings); +procedure AddToMRUList( const Title: string; Filenames: TStrings ); + +var + Settings: TSettings; + +Implementation + +Uses + SysUtils + ,fpg_iniutils + ,ACLStringUtility + ,nvUtilities + ; + +Const + IniFileName = 'NewView.ini'; + GeneralSection = 'General'; + FontsSection = 'Fonts'; + ColoursSection = 'Colours'; + MRUSection = 'RecentFiles'; + MRUItemBaseSection = 'RecentFile'; + SearchSection = 'Search'; + + DefaultWidth = 620; + DefaultHeight = 460; + + MaxMRUListEntries = 9; + +constructor TMRUItem.Create; +begin + Title := ''; + Filenames := TStringList.Create; +end; + +destructor TMRUItem.Destroy; +begin + Filenames.Free; + inherited Destroy; +end; + +Procedure LoadSettings; +var + ColorIndex: longint; + DefaultColor: TfpgColor; + FontName: string; + SettingString: string; + MRUItem: TMRUItem; + MRUItemSection: string; + MRUItemFileCount: longint; + MRUItemFileIndex: longint; + i: longint; + Count: longint; + MRUFilename: string; + MRUFileTitle: string; +begin + LogEvent(LogSettings, 'LoadSettings' ); + with gINI do + begin + EraseSection( 'Windows' ); + with Settings do + begin + LastOpenDirectory := ReadString( GeneralSection, 'LastOpenDirectory', '' ); + LastSaveDirectory := ReadString( GeneralSection, 'LastSaveDirectory', '' ); + + // Read split points, as units of 0.1% + LeftPanelWidth := ReadInteger( GeneralSection, 'LeftPanelWidth', 225 ); + FileDialogSplit := ReadInteger( GeneralSection, 'FileDialogSplit', 500 ) / 1000; + + ShowLeftPanel_Help := ReadBool( GeneralSection, 'ShowLeftPanel_Help', true ); + ShowLeftPanel_Standalone := ReadBool( GeneralSection, 'ShowLeftPanel_Standalone', true ); + + // Colours + for ColorIndex := 0 to High( Colors ) do + begin + //if GetScreenColorDepth > 8 then + DefaultColor := DefaultColors[ ColorIndex ]; + //else + // DefaultColor := VGADefaultColors[ ColorIndex ]; + Colors[ ColorIndex ] := ReadInteger( ColoursSection, + 'Color' + IntToStr( ColorIndex ), + DefaultColor ); + end; + + // Most Recently Used files list... + Count := ReadInteger( MRUSection, 'Count', 0 ); + for i := 0 to Count - 1 do + begin + MRUItemSection := MRUItemBaseSection + IntToStr( i ); + MRUItem := TMRUItem.Create; + MRUItem.Title := ReadString( MRUItemSection, 'Title', '' ); + MRUItemFileCount := ReadInteger( MRUItemSection, 'FileCount', 0 ); + for MRUItemFileIndex := 0 to MRUItemFileCount - 1 do + begin + MRUFilename := ReadString( MRUItemSection, + 'File' + IntToStr( MRUItemFileIndex ), + '' ); + if MRUFilename <> '' then + MRUItem.Filenames.Add( MRUFilename ); + end; + if ( MRUItem.Title <> '' ) and ( MRUItem.Filenames.Count > 0 ) then + // valid MRU item + MRUList.Add( MRUItem ) + else + begin + // not valid + MRUItem.Destroy; + MRUItem := nil; + end; + end; + + // Fonts + NormalFont := fpgGetFont(ReadString(FontsSection, 'NormalFont', DefaultTopicFont)); + if NormalFont = nil then + NormalFont := fpgStyle.DefaultFont; + + FixedFont := fpgGetFont(ReadString(FontsSection, 'FixedFont', DefaultTopicFixedFont)); + if FixedFont = nil then + FixedFont := fpgStyle.FixedFont; + + for i := 0 to NumFontSettings - 1 do + begin + FontName := 'Font' + IntToStr( i ); + Fonts[ i ] := nil; + if ReadBool( FontsSection, FontName + 'Customised', false ) then + Fonts[ i ] := fpgGetFont(ReadString(FontsSection, FontName + 'Desc', DefaultTopicFont)); + end; + + FixedFontSubstitution := ReadBool( FontsSection, 'FixedFontSubstitution', true ); + FixedFontSubstitutes := ReadString( FontsSection, 'FixedFontSubstitutes', 'Mono-10' ); + + // Index style + SettingString := ReadString( GeneralSection, 'IndexStyle', 'Full' ); + if SameText( SettingString, 'FileOnly' ) then + IndexStyle := isFileOnly + else if Sametext( SettingString, 'Alphabetical' ) then + IndexStyle := isAlphabetical + else + IndexStyle := isFull; + + StartupHelp := ReadBool( GeneralSection, 'StartupHelp', true ); + + SmoothScrolling := ReadBool( GeneralSection, 'SmoothScrolling', true ); +// UseOriginalDialogs := ReadBool( GeneralSection, 'UseOriginalDialogs', false ); + OpenWithExpandedContents := ReadBool( GeneralSection, 'OpenWithExpandedContents', false ); + +// ToolBarBackgroundImageFilename := ReadString( GeneralSection, 'ToolbarBackground', '' ); + SettingString := ReadString( GeneralSection, 'ToolbarStyle', 'ImagesAndText' ); + + if SameText( SettingString, 'None' ) then + ToolbarStyle := tsNone + else if SameText( SettingString, 'Images' ) then + ToolbarStyle := tsImages + else if SameText( SettingString, 'Text' ) then + ToolbarStyle := tsText + else + ToolbarStyle := tsImagesAndText; + + ConfirmWinHelp := ReadBool( GeneralSection, 'ConfirmWinHelp', true ); + IPFTopicSaveAsEscaped := ReadBool(GeneralSection, 'IPFTopicSaveAsEscaped', true); + + Count := ReadInteger( SearchSection, 'CustomDirCount', 0 ); + + SearchDirectories.Clear; + for i := 0 to Count - 1 do + begin + SettingString := ReadString( SearchSection, + 'CustomDir' + IntToStr( i ), + '' ); + if trim( SettingString ) <> '' then + SearchDirectories.Add( SettingString ); + end; + SettingString := ReadString( SearchSection, + 'Location', + 'HelpPaths' ); + if SameText( SettingString, 'HelpPaths' ) then + GlobalSearchLocation := gsHelpPaths + else if SameText( SettingString, 'FixedDrives' ) then + GlobalSearchLocation := gsFixedDrives + else if SameText( SettingString, 'SelectedHelpPaths' ) then + GlobalSearchLocation := gsSelectedHelpPaths + else + GlobalSearchLocation := gsCustom; + + end; + end; + LogEvent(LogSettings, ' Done' ); +end; + +procedure SaveSettings; +var + ColorIndex: longint; + FontIndex: longint; + FontName: string; + i: longint; + MRUItemFileIndex: longint; + SettingString: string; + MRUItem: TMRUItem; + MRUItemSection: string; +begin + LogEvent(LogSettings, 'SaveSettings' ); + with gINI do + begin + with Settings do + begin + WriteString( GeneralSection, 'LastOpenDirectory', LastOpenDirectory ); + WriteString( GeneralSection, 'LastSaveDirectory', LastSaveDirectory ); + + WriteInteger( GeneralSection, 'LeftPanelWidth', LeftPanelWidth ); + // Write split points, as units of 0.1% + WriteInteger( GeneralSection, 'FileDialogSplit', Round( FileDialogSplit * 1000 ) ); + + WriteBool( GeneralSection, 'ShowLeftPanel_Help', ShowLeftPanel_Help ); + WriteBool( GeneralSection, 'ShowLeftPanel_Standalone', ShowLeftPanel_Standalone ); + + // Colours + for ColorIndex := 0 to High( Colors ) do + WriteInteger( ColoursSection, + 'Color' + IntToStr( ColorIndex ), + Colors[ ColorIndex ] ); + + // MRU files + WriteInteger( MRUSection, 'Count', MRUList.Count ); + for i := 0 to MRUList.Count - 1 do + begin + MRUItem := TMRUItem(MRUList[ i ]); + MRUItemSection := MRUItemBaseSection + IntToStr( i ); + EraseSection( MRUItemSection ); + WriteString( MRUItemSection, 'Title', MRUItem.Title ); + WriteInteger( MRUItemSection, 'FileCount', MRUItem.Filenames.Count ); + for MRUItemFileIndex := 0 to MRUItem.Filenames.Count - 1 do + WriteString( MRUItemSection, + 'File' + IntToStr( MRUItemFileIndex ), + MRUItem.Filenames[ MRUItemFileIndex ] ); + end; + + // clear unused sections + for i := MRUList.Count to MaxMRUListEntries do + begin + MRUItemSection := MRUItemBaseSection + IntToStr( i ); + EraseSection( MRUItemSection ); + end; + + // Fonts + WriteString( FontsSection, 'NormalFont', NormalFont.FontDesc ); + WriteString( FontsSection, 'FixedFont', FixedFont.FontDesc ); + for FontIndex := 0 to NumFontSettings - 1 do + begin + FontName := 'Font' + IntToStr( FontIndex ); + WriteBool( FontsSection, FontName + 'Customised', Fonts[ FontIndex ] <> nil ); + if Fonts[ FontIndex ] <> nil then + WriteString( FontsSection, FontName + 'Desc', Fonts[ FontIndex ].FontDesc ); + end; + + WriteBool( FontsSection, 'FixedFontSubstitution', FixedFontSubstitution ); + WriteString( FontsSection, 'FixedFontSubstitutes', FixedFontSubstitutes ); + + case IndexStyle of + isFileOnly: + SettingString := 'FileOnly'; + isAlphabetical: + SettingString := 'Alphabetical'; + isFull: + SettingString := 'Full'; + end; + WriteString( GeneralSection, 'IndexStyle', SettingString ); + + WriteBool( GeneralSection, 'StartupHelp', StartupHelp ); + WriteBool( GeneralSection, 'SmoothScrolling', SmoothScrolling ); +// WriteBool( GeneralSection, 'UseOriginalDialogs', UseOriginalDialogs ); + WriteBool( GeneralSection, 'OpenWithExpandedContents', OpenWithExpandedContents ); +// WriteString( GeneralSection, 'ToolbarBackground', ToolbarBackgroundImageFilename ); + + case ToolbarStyle of + tsNone: + SettingString := 'None'; + tsImages: + SettingString := 'Images'; + tsText: + SettingString := 'Text'; + tsImagesAndText: + SettingString := 'ImagesAndText'; + end; + + WriteString( GeneralSection, 'ToolbarStyle', SettingString ); + WriteBool( GeneralSection, 'ConfirmWinHelp', ConfirmWinHelp ); + WriteBool( GeneralSection, 'IPFTopicSaveAsEscaped', IPFTopicSaveAsEscaped); + WriteInteger( SearchSection, 'CustomDirCount', SearchDirectories.Count ); + + SearchDirectories.Sorted := true; + SearchDirectories.CaseSensitive := True; + SearchDirectories.Duplicates := dupIgnore; + + for i := 0 to SearchDirectories.Count - 1 do + begin + WriteString( SearchSection, + 'CustomDir' + IntToStr( i ), + SearchDirectories[ i ] ); + end; + + case GlobalSearchLocation of + gsHelpPaths: + SettingString := 'HelpPaths'; + + gsFixedDrives: + SettingString := 'FixedDrives'; + + gsSelectedHelpPaths: + SettingString := 'SelectedHelpPaths'; + + gsCustom: + SettingString := 'Custom'; + end; + + WriteString( SearchSection, 'Location', SettingString ); + end; + end; + LogEvent(LogSettings, ' Done' ); +End; + +Procedure AddToMRUList( const Title: string; Filenames: TStrings ); +var + MRUIndex: longint; + PreviousMRUIndex: longint; + MRUItem: TMRUItem; +begin + PreviousMRUIndex := -1; + for MRUIndex := 0 to Settings.MRUList.Count - 1 do + begin + MRUItem := TMRUItem(Settings.MRUList[ MRUIndex ]); + if ( MRUItem.Title = Title ) + and ( MRUItem.Filenames.Equals( Filenames ) ) then + begin + // found identical entry in the list already. + PreviousMRUIndex := MRUIndex; + break; + end; + end; + + if PreviousMRUIndex > -1 then + begin + // is already in list, move to top of list + MRUItem := TMRUItem(Settings.MRUList[ PreviousMRUIndex ]); + Settings.MRUList.Delete( PreviousMRUIndex ); + end + else + begin + // not yet in list. Create new + MRUItem := TMRUItem.Create; + MRUItem.Title := Title; + MRUItem.Filenames.Assign( Filenames ); + end; + + Settings.MRUList.Insert( 0, MRUItem ); + while Settings.MRUList.Count > MaxMRUListEntries do + begin + MRUItem := TMRUItem(Settings.MRUList[ MaxMRUListEntries ]); + Settings.MRUList.Delete( MaxMRUListEntries ); + MRUItem.Destroy; + end; +end; + +procedure writeSettingsDetailsTo(aStrings : TStrings); +Begin + aStrings.Add(''); + aStrings.Add('---- Settings ----'); + aStrings.Add('info: Screenwidth=' + IntToStr(fpgApplication.ScreenWidth)); + aStrings.Add('info: Screenheight=' + IntToStr(fpgApplication.ScreenHeight)); + aStrings.Add('info: dpi=' + IntToStr(fpgApplication.Screen_dpi)); + + aStrings.Add('LastOpenDirectory: ' + Settings.LastOpenDirectory); + aStrings.Add('LastSaveDirectory: ' + Settings.LastSaveDirectory); + aStrings.Add('StartupHelp: ' + boolToStr(Settings.StartupHelp)); + // LeftPanelWidth: longint; + aStrings.Add('ShowLeftPanel_Help: ' + boolToStr(Settings.ShowLeftPanel_Help)); + aStrings.Add('ShowLeftPanel_Standalone: ' + boolToStr(Settings.ShowLeftPanel_Standalone)); + // FileDialogSplit: real; + // Colors: array[ 0..NumColorSettings - 1 ] of TColor; + // NormalFont: TFont; + // FixedFont: TFont; + // Fonts: array[ 0..NumFontSettings - 1 ] of TFont; + aStrings.Add('FixedFontSubstitution: ' + boolToStr(Settings.FixedFontSubstitution)); + aStrings.Add('FixedFontSubstitutes: ' + Settings.FixedFontSubstitutes); + // IndexStyle: TIndexStyle; + aStrings.Add('SmoothScrolling: ' + boolToStr(Settings.SmoothScrolling)); +// aStrings.Add('UseOriginalDialogs: ' + boolToStr(Settings.UseOriginalDialogs)); + aStrings.Add('OpenWithExpandedContents: ' + boolToStr(Settings.OpenWithExpandedContents)); +// aStrings.Add('ToolbarBackgroundImageFilename: ' + Settings.ToolbarBackgroundImageFilename); + // ToolbarStyle: TToolbarStyle; + aStrings.Add('ConfirmWinHelp: ' + boolToStr(Settings.ConfirmWinHelp)); + aStrings.Add('IPFTopicSaveAsEscaped: ' + BoolToStr(Settings.IPFTopicSaveAsEscaped)); + // GlobalSearchLocation: TGlobalSearchLocation; + // SearchDirectories: TStringList; +end; + + +Initialization + //Settings.NormalFont := fpgStyle.DefaultFont; + //Settings.FixedFont := fpgStyle.FixedFont; + //Settings.SearchDirectories := TStringList.Create; + +Finalization + Settings.NormalFont.Free; + Settings.FixedFont.Free; + Settings.SearchDirectories.Free; + +End. diff --git a/docview/src/TextSearchQuery.pas b/docview/src/TextSearchQuery.pas new file mode 100644 index 00000000..444b27f1 --- /dev/null +++ b/docview/src/TextSearchQuery.pas @@ -0,0 +1,208 @@ +Unit TextSearchQuery; + +{$mode objfpc}{$H+} + +// NewView - a new OS/2 Help Viewer +// Copyright 2003 Aaron Lawrence (aaronl at consultant dot com) +// This software is released under the Gnu Public License - see readme.txt + +Interface + +// Encapsulates a parsed search query. + +uses + Classes, SysUtils; + +Type + ESearchSyntaxError = class( Exception ) + end; + + TSearchTermCombineMethod = + ( + cmOptional, + cmRequired, + cmExcluded + ); + + TSearchTerm = class(TObject) + public + Text: string; + Parts: TStringList; + CombineMethod: TSearchTermCombineMethod; + constructor Create( const TheText: string; + const TheCombineMethod: TSearchTermCombineMethod ); + destructor Destroy; override; + end; + + + TTextSearchQuery = class(TObject) + protected + Terms: TList; + function GetTerm( Index: longint ): TSearchTerm; + function GetTermCount: longint; + public + constructor Create( const SearchString: string ); + destructor Destroy; override; + property Term[ Index: longint ]: TSearchTerm read GetTerm; + property TermCount: longint read GetTermCount; + end; + + +implementation + +uses + nvUtilities + ,ACLStringUtility + ; + + +const + QueryErrorMissingWord1 = 'No search word given after'; + QueryErrorMissingWord2 = ' before '; + + +constructor TTextSearchQuery.Create( const SearchString: string ); +var + TermText: string; + CombineMethod: TSearchTermCombineMethod; + lTerm: TSearchTerm; + tmpTerms : TStringList; + i : integer; +begin + inherited Create; + Terms := TList.Create; + try + tmpTerms := TStringList.Create; + StrExtractStringsQuoted(tmpTerms, SearchString); + + for i := 0 to tmpTerms.count-1 do + begin + TermText := tmpTerms[i]; + + // Check for modifiers: + // + word must be matched + // - word must not be matched + case TermText[ 1 ] of + '+': + CombineMethod := cmRequired; + '-': + CombineMethod := cmExcluded; + else + CombineMethod := cmOptional; + end; + + if CombineMethod <> cmOptional then + begin + // delete + or - + if Length( TermText ) = 1 then + if (i < tmpTerms.count-1) then + raise ESearchSyntaxError.Create( QueryErrorMissingWord1 + + StrInDoubleQuotes(TermText) + + QueryErrorMissingWord2 + + StrInDoubleQuotes(tmpTerms[i+1]) ) + else + raise ESearchSyntaxError.Create( QueryErrorMissingWord1 + + StrInDoubleQuotes(TermText)); + Delete( TermText, 1, 1 ); + end; + + lTerm := TSearchTerm.Create( TermText, + CombineMethod ); + Terms.Add( lTerm ); + end; + tmpTerms.Free; + except + while Terms.Count > 0 do + begin + lTerm := TSearchTerm(Terms.Last); + Terms.Remove(lTerm); + lTerm.Free; + end; + Terms.Free; + raise; // reraise exception + end; +end; + +destructor TTextSearchQuery.Destroy; +begin + DestroyListObjects( Terms ); + Terms.Free; + inherited Destroy; +end; + +function TTextSearchQuery.GetTerm( index: longint ): TSearchTerm; +begin + Result := TSearchTerm(Terms[ Index ]); +end; + +function TTextSearchQuery.GetTermCount: longint; +begin + Result := Terms.Count; +end; + +constructor TSearchTerm.Create( const TheText: string; + const TheCombineMethod: TSearchTermCombineMethod ); +var + TermParseIndex: longint; + TermChar: char; + TermPart: string; +begin + Parts := TStringList.Create; + + Text := TheText; + CombineMethod := TheCombineMethod; + + // Break out each part of the term as IPF does: + // consecutive alphanumeric chars become a "word" + // but each symbol is a separate word, and symbols break + // up alphanumerics into multiple words. e.g. + // CAKE_SAUSAGE becomes three words in IPF, + // one each for "CAKE" "_" and "SAUSAGE" + + TermParseIndex := 1; + while TermParseIndex <= Length( Text ) do + begin + // collect alphanumeric chars + TermPart := ''; + while TermParseIndex <= Length( Text ) do + begin + TermChar := Text[ TermParseIndex ]; + if ( IsAlpha( TermChar ) + or IsDigit( TermChar ) ) then + begin + // alpha numeric, collect it + TermPart := TermPart + TermChar; + inc( TermParseIndex ); + end + else + begin + // not alpha numeric, so stop + break; + end; + end; + if Length( TermPart ) > 0 then + begin + Parts.Add( TermPart ); // add collected alphanumeric part + end; + + if TermParseIndex <= Length( Text ) then + begin + // must be a symbol, + // each symbol (excluding space) is an individual item + if Text[ TermParseIndex ] <> ' ' then + Parts.Add( Text[ TermParseIndex ] ); + inc( TermParseIndex ); + end; + + end; + +end; + +destructor TSearchTerm.Destroy; +begin + Parts.Free; + inherited Destroy; +end; + + +end. diff --git a/docview/src/docdump/docdump.lpi b/docview/src/docdump/docdump.lpi new file mode 100644 index 00000000..440c482c --- /dev/null +++ b/docview/src/docdump/docdump.lpi @@ -0,0 +1,114 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="7"/> + <General> + <SessionStorage Value="InIDEConfig"/> + <MainUnit Value="0"/> + <TargetFileExt Value=""/> + <UseAppBundle Value="False"/> + </General> + <VersionInfo> + <ProjectVersion Value=""/> + </VersionInfo> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <Units Count="15"> + <Unit0> + <Filename Value="docdump.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="docdump"/> + </Unit0> + <Unit1> + <Filename Value="../IPFEscapeCodes.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="IPFEscapeCodes"/> + </Unit1> + <Unit2> + <Filename Value="../IPFFileFormatUnit.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="IPFFileFormatUnit"/> + </Unit2> + <Unit3> + <Filename Value="readheader.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="readheader"/> + </Unit3> + <Unit4> + <Filename Value="filestreamhelper.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="filestreamhelper"/> + </Unit4> + <Unit5> + <Filename Value="readextfiles.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="readextfiles"/> + </Unit5> + <Unit6> + <Filename Value="../../docs/inf04.txt"/> + <IsPartOfProject Value="True"/> + </Unit6> + <Unit7> + <Filename Value="readstrings.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="readstrings"/> + </Unit7> + <Unit8> + <Filename Value="iterator_impl.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="iterator_impl"/> + </Unit8> + <Unit9> + <Filename Value="iterator_intf.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="iterator_intf"/> + </Unit9> + <Unit10> + <Filename Value="readnlsdata.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="readnlsdata"/> + </Unit10> + <Unit11> + <Filename Value="readfonts.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="readfonts"/> + </Unit11> + <Unit12> + <Filename Value="readcontrols.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="readcontrols"/> + </Unit12> + <Unit13> + <Filename Value="readtoc.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="readtoc"/> + </Unit13> + <Unit14> + <Filename Value="u_Tools.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="u_Tools"/> + </Unit14> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="8"/> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)/"/> + <OtherUnitFiles Value="../"/> + <UnitOutputDirectory Value="units/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> +</CONFIG> diff --git a/docview/src/docdump/docdump.lpr b/docview/src/docdump/docdump.lpr new file mode 100644 index 00000000..84077608 --- /dev/null +++ b/docview/src/docdump/docdump.lpr @@ -0,0 +1,98 @@ +{ + Dumps the structure of an OS/2 IPF help file +} +program docdump; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Classes, SysUtils, IPFFileFormatUnit, IPFEscapeCodes, CustApp, readheader, + filestreamhelper, readextfiles, readstrings, iterator_intf, iterator_impl, + readnlsdata, readfonts, readcontrols, readtoc, u_Tools; + +type + + { TDocDump } + + TDocDump = class(TCustomApplication) + private + FIn: TFileStream; + FOut: TFileTextStream; + protected + procedure DoRun; override; + public + constructor Create(TheOwner: TComponent); override; + destructor Destroy; override; + procedure WriteHelp; virtual; + end; + +{ TDocDump } + +procedure TDocDump.DoRun; +var + ErrorMsg: String; +begin + // quick check parameters + ErrorMsg:=CheckOptions('h','help'); + if ErrorMsg<>'' then begin + ShowException(Exception.Create(ErrorMsg)); + Terminate; + Exit; + end; + + // parse parameters + if HasOption('h','help') then begin + WriteHelp; + Terminate; + Exit; + end; + + FIn := TFileStream.Create(ParamStr(1), fmOpenRead); + FOut := TFileTextStream.Create(ExtractFileName(ParamStr(1))+'.txt', fmCreate); + try + FOut.WriteLn(Format('File name: %s (%d bytes)', [ExtractFileName(ParamStr(1)), FIn.Size])); + ProcessHeader(FIn, FOut); + ProcessExtFiles(FIn, FOut); + ProcessStringsTable(FIn, FOut); + ProcessNLSData(FIn, FOut); + ProcessFonts(FIn, FOut); + ProcessControls(FIn, FOut); + ProcessTOC(FIn, FOut); + finally + FIn.Free; + FOut.Free; + end; + // stop program loop + Terminate; +end; + +constructor TDocDump.Create(TheOwner: TComponent); +begin + inherited Create(TheOwner); + StopOnException:=True; +end; + +destructor TDocDump.Destroy; +begin + inherited Destroy; +end; + +procedure TDocDump.WriteHelp; +begin + { add your help code here } + writeln('Usage: ',ExeName,' -h'); +end; + +var + Application: TDocDump; + + +begin + Application:=TDocDump.Create(nil); + Application.Run; + Application.Free; +end. + diff --git a/docview/src/docdump/filestreamhelper.pas b/docview/src/docdump/filestreamhelper.pas new file mode 100644 index 00000000..ff831a91 --- /dev/null +++ b/docview/src/docdump/filestreamhelper.pas @@ -0,0 +1,35 @@ +unit filestreamhelper; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils; + +type + TFileTextStream = class(TFileStream) + public + procedure WriteLn(const fmt: String; const args: array of const); + procedure WriteLn(const s: String); + end; + +implementation + +{ TFileTextStream } + +procedure TFileTextStream.WriteLn(const fmt: String; const args: array of const); +var + temp: String; +begin + temp := Format(fmt, args) + LineEnding; + Write(temp[1], Length(temp)); +end; + +procedure TFileTextStream.WriteLn(const s: String); +begin + self.WriteLn('%s', [s]); +end; + +end. + diff --git a/docview/src/docdump/iterator_impl.pas b/docview/src/docdump/iterator_impl.pas new file mode 100644 index 00000000..4ad88052 --- /dev/null +++ b/docview/src/docdump/iterator_impl.pas @@ -0,0 +1,480 @@ +unit iterator_impl; + +{$mode objfpc}{$H+} + +interface + +uses + Classes + ,SysUtils + ,Regex { to be used with filtered string iterator } + ,iterator_intf + ,contnrs + ; + +type + + TTBStringsIterator = class(TInterfacedObject, ITBStringIterator, ITBStringAndObjectIterator) + private + FStrings: TStrings; + FCursor: Integer; + { Interface methods should always be private because + we will only ever access them via an Interface, + never via an Object instance } + + { Interface: ITBStringIterator and ITBStringAndObjectIterator } + function HasNext: Boolean; + function Next: string; + function HasPrevious: Boolean; + function Previous: string; + { Interface: ITBStringAndObjectIterator } + function HasNextObject: Boolean; + function NextObject: TObject; + function HasPreviousObject: Boolean; + function PreviousObject: TObject; + public + constructor CreateCustom(const ASource: TStrings); virtual; + end; + + + TTBListIterator = class(TInterfacedObject, ITBIterator) + private + FList: TList; + FCursor: Integer; + { Interface: ITBIterator } + function HasNext: Boolean; + function Next: TObject; + function HasPrevious: Boolean; + function Previous: TObject; + public + constructor CreateCustom(const ASource: TList); virtual; + end; + + + TTBCollectionIterator = class(TInterfacedObject, ITBIterator) + private + FCollection: TCollection; + FCursor: Integer; + { Interface: ITBIterator } + function HasNext: Boolean; + function Next: TObject; + function HasPrevious: Boolean; + function Previous: TObject; + public + constructor CreateCustom(const ASource: TCollection); virtual; + end; + + + TTBInterfaceListIterator = class(TInterfacedObject, ITBInterfaceIterator) + private + FList: TInterfaceList; + FCursor: integer; + { Interface: ITBinterfaceIterator } + function HasNext: Boolean; + function Next: IInterface; + function HasPrevious: Boolean; + function Previous: IInterface; + public + constructor CreateCustom(const ASource: TInterfaceList); virtual; + end; + + + TTBFilteredStringsIterator = class(TTBStringsIterator, ITBFilteredStringIterator) + private + FNextIndex: Integer; + FRegex: TRegexEngine; + { Interface: ITBFilteredStringIterator } + function GetFilter: string; + procedure SetFilter(const AValue: string); + { Interface: ITBStringIterator and ITBStringAndObjectIterator } + function HasNext: Boolean; + function Next: string; + function HasPrevious: Boolean; + function Previous: string; + public + constructor CreateCustom(const ASource: TStrings); override; + destructor Destroy; override; + end; + + + TTBObjectListIterator = class(TInterfacedObject, ITBIterator) + private + FList: TObjectList; + FCursor: Integer; + { Interface: ITBIterator } + function HasNext: Boolean; + function Next: TObject; + function HasPrevious: Boolean; + function Previous: TObject; + public + constructor CreateCustom(const ASource: TObjectList); virtual; + end; + + + +implementation + + +{ TTBStringsIterator } + +function TTBStringsIterator.HasNext: Boolean; +begin + Result := False; + if Assigned(FStrings) then + if FCursor < FStrings.Count - 1 then + Result := True; +end; + +function TTBStringsIterator.Next: string; +begin + Result := ''; + if HasNext then + begin + Inc(FCursor, 1); + Result := FStrings.Strings[FCursor]; + end; +end; + +function TTBStringsIterator.HasPrevious: Boolean; +begin + Result := False; + if Assigned(FStrings) then + if FCursor > 0 then + Result := True; +end; + +function TTBStringsIterator.Previous: string; +begin + Result := ''; + if HasPrevious then + begin + Dec(FCursor, 1); + Result := FStrings.Strings[FCursor]; + end; +end; + +function TTBStringsIterator.HasNextObject: Boolean; +begin + Result := False; + if Assigned(FStrings) then + if FCursor < FStrings.Count - 1 then + Result := FStrings.Objects[FCursor] <> nil; +end; + +function TTBStringsIterator.NextObject: TObject; +begin + Result := nil; + if HasNextObject then + // Note that Next(...) increments the FCursor + Result := FStrings.Objects[FCursor]; +end; + +function TTBStringsIterator.HasPreviousObject: Boolean; +begin + Result := False; + if Assigned(FStrings) then + if FCursor > 0 then + Result := FStrings.Objects[FCursor] <> nil; +end; + +function TTBStringsIterator.PreviousObject: TObject; +begin + Result := nil; + if HasPreviousObject then + // Note that Previous(...) decrements the FCursor + Result := FStrings.Objects[FCursor]; +end; + +constructor TTBStringsIterator.CreateCustom(const ASource: TStrings); +begin + inherited Create; + FStrings := ASource; + FCursor := -1; +end; + + +{ TTBListIterator } + +function TTBListIterator.HasNext: Boolean; +begin + Result := False; + if Assigned(FList) then + if FCursor < FList.Count - 1 then + Result := True; +end; + +function TTBListIterator.Next: TObject; +begin + Result := nil; + if HasNext then + begin + Inc(FCursor, 1); + result := TObject(FList.Items[FCursor]); + end; +end; + +function TTBListIterator.HasPrevious: Boolean; +begin + Result := False; + if Assigned(FList) then + begin + if FCursor > 0 then + Result := True; + end; +end; + +function TTBListIterator.Previous: TObject; +begin + Result := nil; + if HasPrevious then + begin + Dec(FCursor, 1); + Result := TObject(FList.Items[FCursor]); + end; +end; + +constructor TTBListIterator.CreateCustom(const ASource: TList); +begin + inherited Create; + FList := ASource; + FCursor := -1; +end; + + +{ TTBCollectionIterator } + +function TTBCollectionIterator.HasNext: Boolean; +begin + Result := False; + if Assigned(FCollection) then + if FCursor < FCollection.Count - 1 then + Result := True; +end; + +function TTBCollectionIterator.Next: TObject; +begin + Result := nil; + if HasNext then + begin + Inc(FCursor, 1); + result := FCollection.Items[FCursor]; + end; +end; + +function TTBCollectionIterator.HasPrevious: Boolean; +begin + Result := False; + if Assigned(FCollection) then + if FCursor > 0 then + Result := True; +end; + +function TTBCollectionIterator.Previous: TObject; +begin + Result := nil; + if HasPrevious then + begin + Dec(FCursor, 1); + Result := FCollection.Items[FCursor]; + end; +end; + +constructor TTBCollectionIterator.CreateCustom(const ASource: TCollection); +begin + inherited Create; + FCollection := ASource; + FCursor := -1; +end; + + +{ TTBFilteredStringsIterator } + +function TTBFilteredStringsIterator.GetFilter: string; +begin + Result := FRegex.RegexString; +end; + +procedure TTBFilteredStringsIterator.SetFilter(const AValue: string); +const + cFilterErr = 'Error in Filter string at position %d with ErrorCode %d. Filter string <%s>'; +var + LErrorCode: TRegexError; + LErrorPos: integer; +begin + if AValue <> FRegex.RegexString then + begin + FRegex.RegexString := AValue; + if not FRegex.Parse(LErrorPos, LErrorCode) then + raise Exception.CreateFmt(cFilterErr, [LErrorPos, Ord(LErrorCode), AValue]); + end; + FNextIndex := -1; +end; + +function TTBFilteredStringsIterator.HasNext: Boolean; +var + LIndex: integer; + LMatchPos: integer; + LOffset: integer; +begin + Result := False; + if GetFilter = '' then + begin + Result := inherited HasNext; + if Result then + FNextIndex := FCursor + 1; + end + else + begin + if FCursor < FStrings.Count - 1 then + begin + { If we haven't already calculated the next matching item } + if FNextIndex = -1 then + begin + LIndex := FCursor + 1; + { Peek ahead to find the next matching string } + while (LIndex < FStrings.Count) and (FNextIndex = -1) do + begin + { reset MatchString parameters } + LOffset := 0; + LMatchPos := 0; + if FRegex.MatchString(FStrings.Strings[LIndex], LMatchPos, LOffset) then + FNextIndex := LIndex; + Inc(LIndex); + end; + end; + if FNextIndex <> -1 then + Result := True; + end; + end; { if..else } +end; + +function TTBFilteredStringsIterator.Next: string; +begin + Result := ''; + if HasNext then + begin + FCursor := FNextIndex; + FNextIndex := -1; + Result := FStrings.Strings[FCursor]; + end; +end; + +function TTBFilteredStringsIterator.HasPrevious: Boolean; +begin + Result := False; // Filtered String is uni-directional +end; + +function TTBFilteredStringsIterator.Previous: string; +begin + Result := ''; + raise EUniDirectionalIterator.Create('Filtered String Iterator is uni-directional (forward) only.'); +end; + +constructor TTBFilteredStringsIterator.CreateCustom(const ASource: TStrings); +begin + inherited CreateCustom(ASource); + FRegex := TRegexEngine.Create(''); + FRegex.IgnoreCase := True; + FNextIndex := -1; +end; + +destructor TTBFilteredStringsIterator.Destroy; +begin + FRegex.Free; + inherited Destroy; +end; + + +{ TTBInterfaceListIterator } + +function TTBInterfaceListIterator.HasNext: Boolean; +begin + Result := False; + if Assigned(FList) then + if FCursor < FList.Count - 1 then + Result := True; +end; + +function TTBInterfaceListIterator.Next: IInterface; +begin + Result := nil; + if HasNext then + begin + Inc(FCursor, 1); + Result := FList.Items[FCursor]; + end; +end; + +function TTBInterfaceListIterator.HasPrevious: Boolean; +begin + Result := False; + if Assigned(FList) then + if FCursor > 0 then + Result := True; +end; + +function TTBInterfaceListIterator.Previous: IInterface; +begin + Result := nil; + if HasPrevious then + begin + Dec(FCursor, 1); + Result := FList.Items[FCursor]; + end; +end; + +constructor TTBInterfaceListIterator.CreateCustom(const ASource: TInterfaceList); +begin + inherited Create; + FList := ASource; + FCursor := -1; +end; + +{ TTBObjectListIterator } + +function TTBObjectListIterator.HasNext: Boolean; +begin + Result := False; + if Assigned(FList) then + if FCursor < FList.Count - 1 then + Result := True; +end; + +function TTBObjectListIterator.Next: TObject; +begin + result := nil; + if HasNext then + begin + Inc(FCursor); + result := FList.Items[FCursor]; + end; +end; + +function TTBObjectListIterator.HasPrevious: Boolean; +begin + Result := False; + if Assigned(FList) then + if FCursor > 0 then + Result := True; +end; + +function TTBObjectListIterator.Previous: TObject; +begin + result := nil; + if HasPrevious then + begin + Dec(FCursor); + result := FList.Items[FCursor]; + end; +end; + +constructor TTBObjectListIterator.CreateCustom(const ASource: TObjectList); +begin + inherited Create; + FList := ASource; + FCursor := -1; +end; + + +end. + diff --git a/docview/src/docdump/iterator_intf.pas b/docview/src/docdump/iterator_intf.pas new file mode 100644 index 00000000..e82b59a1 --- /dev/null +++ b/docview/src/docdump/iterator_intf.pas @@ -0,0 +1,169 @@ +unit iterator_intf; + +{$mode objfpc}{$H+} + +interface + +uses + Classes + ,SysUtils + ; + +type + { A custom exception class } + ENoIteratorImpl = class(Exception); + EUniDirectionalIterator = class(Exception); + + + { Standard iterators } + + ITBIterator = interface(IInterface) + ['{9C2BC10D-54C8-4B59-88B5-A564921CF0E3}'] + function HasNext: Boolean; + function Next: TObject; + function HasPrevious: Boolean; + function Previous: TObject; + end; + + + ITBStringIterator = interface(IInterface) + ['{B2A449B4-5D0A-4F14-AC11-CA055EDA3ED7}'] + function HasNext: Boolean; + function Next: string; + function HasPrevious: Boolean; + function Previous: string; + end; + + + ITBStringAndObjectIterator = interface(ITBStringIterator) + ['{287373DC-A90D-400E-BAEE-C85474C317A8}'] + function HasNextObject: Boolean; + function NextObject: TObject; + function HasPreviousObject: Boolean; + function PreviousObject: TObject; + end; + + + ITBInterfaceIterator = interface + ['{9B599C5B-4BBB-43F6-AF8E-09FEE9AE0E20}'] + function HasNext: Boolean; + function Next: IInterface; + function HasPrevious: Boolean; + function Previous: IInterface; + end; + + { TODO: + More interfaces could be added for collections like: + TTreeView, TStringGrid etc... } + + + { Filtered iterators } + + ITBFilteredStringIterator = interface(ITBStringIterator) + ['{CF1B9E2D-DD05-4D15-95C6-686EAFA4ED82}'] + function GetFilter: string; + procedure SetFilter(const AValue: string); + property Filter: string read GetFilter write SetFilter; + end; + + + { TODO: + More filtered versions of the standard iterators could + be added here... } + + + + { Iterator Factory } + + TTBIteratorFactory = class(TObject) + function Iterator(const ASource: TObject): ITBIterator; + function StringIterator(const ASource: TObject): ITBStringIterator; + function StringAndObjectIterator(const ASource: TObject): ITBStringAndObjectIterator; + function InterfaceIterator(const ASource: TObject): ITBInterfaceIterator; + function FilteredStringIterator(const ASource: TObject; const AFilter: string): ITBFilteredStringIterator; + end; + + +{ Global iterator factory singleton } +function gIteratorFactory: TTBIteratorFactory; + + +implementation + +uses + iterator_impl; + +var + uIteratorFactory: TTBIteratorFactory; + +const + cNoIteratorImpl = 'No Iterator implementation found for <%s>'; + + +{ The lazy mans singleton implementation, but it does the job just fine. } +function gIteratorFactory: TTBIteratorFactory; +begin + if not Assigned(uIteratorFactory) then + uIteratorFactory := TTBIteratorFactory.Create; + Result := uIteratorFactory; +end; + + +{ TTBIteratorFactory } + +function TTBIteratorFactory.Iterator(const ASource: TObject): ITBIterator; +begin + if ASource is TList then + Result := TTBListIterator.CreateCustom(TList(ASource)) + else if ASource is TCollection then + Result := TTBCollectionIterator.CreateCustom(TCollection(ASource)) + //else if ASource is TTreeNodes then + //Result := TTBTreeNodesIterator.CreateCustom(TTreeNodes(ASource)) + else + raise ENoIteratorImpl.CreateFmt(cNoIteratorImpl, [ASource.ClassName]); +end; + +function TTBIteratorFactory.StringIterator(const ASource: TObject): ITBStringIterator; +begin + if ASource is TStrings then + Result := TTBStringsIterator.CreateCustom(TStrings(ASource)) + else + raise ENoIteratorImpl.CreateFmt(cNoIteratorImpl, [ASource.ClassName]); +end; + +function TTBIteratorFactory.StringAndObjectIterator(const ASource: TObject): ITBStringAndObjectIterator; +begin + if ASource is TStrings then + Result := TTBStringsIterator.CreateCustom(TStrings(ASource)) + else + raise ENoIteratorImpl.CreateFmt(cNoIteratorImpl, [ASource.ClassName]); +end; + +function TTBIteratorFactory.InterfaceIterator(const ASource: TObject): ITBInterfaceIterator; +begin + if ASource is TInterfaceList then + Result := TTBInterfaceListIterator.CreateCustom(TInterfaceList(ASource)) + else + raise ENoIteratorImpl.CreateFmt(cNoIteratorImpl, [ASource.ClassName]); +end; + +function TTBIteratorFactory.FilteredStringIterator(const ASource: TObject; const AFilter: string): ITBFilteredStringIterator; +begin + if ASource is TStrings then + begin + Result := TTBFilteredStringsIterator.CreateCustom(TStrings(ASource)); + Result.Filter := AFilter; + end + else + raise ENoIteratorImpl.CreateFmt(cNoIteratorImpl, [ASource.ClassName]); +end; + + +initialization + uIteratorFactory := nil; + +finalization + uIteratorFactory.Free; + +end. + diff --git a/docview/src/docdump/readcontrols.pas b/docview/src/docdump/readcontrols.pas new file mode 100644 index 00000000..395a36db --- /dev/null +++ b/docview/src/docdump/readcontrols.pas @@ -0,0 +1,44 @@ +{ + Dump the controls data +} +unit readcontrols; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, filestreamhelper; + +procedure ProcessControls(AIn: TFileStream; AOut: TFileTextStream); + + +implementation + +uses + readheader, IPFFileFormatUnit; + +procedure ProcessControls(AIn: TFileStream; AOut: TFileTextStream); +var + ctrls: TPanelControls; + i: integer; +begin + AOut.WriteLn(''); + AOut.WriteLn('Panel Controls (Buttons)'); + if eHdr.CtrlOffset > 0 then + begin + AIn.Seek(eHdr.CtrlOffset, soBeginning); + AIn.Read(ctrls, SizeOf(TControlDef)); + AOut.WriteLn(Format(' PanelControls.ControlCount: %4.4x (%0:d)', [ctrls.ControlCount])); + AOut.WriteLn(Format(' PanelControls.GroupCount: %4.4x (%0:d)', [ctrls.GroupCount])); + AOut.WriteLn(Format(' PanelControls.GroupIndex: %4.4x (%0:d)', [ctrls.GroupIndex])); + AOut.WriteLn(Format(' PanelControls.Reserved: %4.4x (%0:d)', [ctrls.Reserved])); + AOut.WriteLn(' *****'); + AOut.WriteLn(' <todo - process CountrolCount and GroupCount data>'); + end + else + AOut.WriteLn(' No panel control found'); +end; + +end. + diff --git a/docview/src/docdump/readextfiles.pas b/docview/src/docdump/readextfiles.pas new file mode 100644 index 00000000..6ea979d9 --- /dev/null +++ b/docview/src/docdump/readextfiles.pas @@ -0,0 +1,53 @@ +{ + Dumps the names of external database (help) files referenced by this file +} +unit readextfiles; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, IPFFileFormatUnit, filestreamhelper; + +procedure ProcessExtFiles(AIn: TFileStream; AOut: TFileTextStream); + + +implementation + +uses + readheader; + +procedure ProcessExtFiles(AIn: TFileStream; AOut: TFileTextStream); +var + count: integer; + name: string; + pData: pointer; + p: pointer; + pLength: pByte; +begin + AOut.WriteLn(''); + AOut.WriteLn('External File References'); + + if eHdr.NumDataBase > 0 then + begin + pData := nil; + AIn.Seek(eHdr.DataBaseOffset, soBeginning); + GetMem(pData, eHdr.DataBaseSize); // allocate temp space for data + AIn.Read(pData^, eHdr.DataBaseSize); // read all data in one shot + p := pData; // p is our incrementing position in the data + for count := 0 to eHdr.NumDataBase-1 do + begin + pLength := p; // length byte, including itself + SetString(name, p+1, pLength^-1); // use length value minus the length byte to get the string length + AOut.WriteLn(Format(' File #%d: %s', [count, name])); + inc(p, pLength^); // skip to next entry using full length (including length byte) + end; + FreeMem(pData, eHdr.DataBaseSize); // free allocated space + end + else + AOut.WriteLn(' No external file references found'); +end; + +end. + diff --git a/docview/src/docdump/readfonts.pas b/docview/src/docdump/readfonts.pas new file mode 100644 index 00000000..6b684cac --- /dev/null +++ b/docview/src/docdump/readfonts.pas @@ -0,0 +1,47 @@ +{ + Dumps the font data +} +unit readfonts; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, filestreamhelper; + +procedure ProcessFonts(AIn: TFileStream; AOut: TFileTextStream); + + +implementation + +uses + readheader, IPFFileFormatUnit; + +procedure ProcessFonts(AIn: TFileStream; AOut: TFileTextStream); +var + fnt: THelpFontSpec; + pData: pointer; + i: integer; +begin + AOut.WriteLn(''); + AOut.WriteLn('Font Data'); + if eHdr.NumFontEntry > 0 then + begin + AIn.Seek(eHdr.FontTableOffset, soBeginning); + for i := 0 to eHdr.NumFontEntry-1 do + begin + AIn.Read(fnt, SizeOf(THelpFontSpec)); + AOut.WriteLn(Format(' Font Entry #%d', [i+1])); + AOut.WriteLn(Format(' FontSpec.FaceName: %s', [fnt.FaceName])); + AOut.WriteLn(Format(' FontSpec.Height: %4.4x (%0:d)', [fnt.Height])); + AOut.WriteLn(Format(' FontSpec.Width: %4.4x (%0:d)', [fnt.Width])); + AOut.WriteLn(Format(' FontSpec.CodePage: %4.4x (%0:d)', [fnt.Codepage])); + end; + end + else + AOut.WriteLn(' No font data is present'); +end; + +end. + diff --git a/docview/src/docdump/readheader.pas b/docview/src/docdump/readheader.pas new file mode 100644 index 00000000..201fcb86 --- /dev/null +++ b/docview/src/docdump/readheader.pas @@ -0,0 +1,135 @@ +{ + Dump the INF header & extended header structures to a text file +} +unit readheader; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, filestreamhelper, IPFFileFormatUnit; + +procedure ProcessHeader(AIn: TFileStream; AOut: TFileTextStream); + +var + hdr: THelpFileHeader; + eHdr: TExtendedHelpFileHeader; + + +implementation + + +type + TWord = record + b1: AnsiChar; + b2: AnsiChar; + end; + + TOverlayID = packed record + b1: Byte; + b2: Byte; + b3: Byte; + end; + + TOverlaySearchStart = bitpacked record + SearchOffset: Unsigned_31; + IsRec16bitSize: boolean; + end; + + +procedure ProcessHeader(AIn: TFileStream; AOut: TFileTextStream); +var + bytes: integer; + s: string; + w: TWord; + i: uint32; + t0: TOverlayID; + t1: TOverlaySearchStart; +begin + try + AIn.Seek(0, soBeginning); + bytes := AIn.Read(hdr, SizeOf(THelpFileHeader)); + if bytes <> SizeOf(THelpFileHeader) then + raise Exception.Create('Failed to read complete file header'); + + if hdr.ID <> INF_HEADER_ID then + raise Exception.Create('This is not an OS/2 help file'); + + AOut.WriteLn('Header Section'); + t0 := TOverlayID(hdr.ID); + s := hdr.ID; + AOut.WriteLn(Format(' ipfheader.id: %4.2x %2x %2x ("%s") : Magic word' ,[Byte(hdr.id[0]), Byte(hdr.id[1]), Byte(hdr.id[2]), s])); + if (hdr.flags and $01) > 0 then + s := 'INF' + else + s := 'HLP'; + AOut.WriteLn(Format(' ipfheader.flags: %8.2x (%s format) : File format' ,[hdr.flags, s])); + AOut.WriteLn(Format(' ipfheader.size: %8.4x (%0:7d bytes) : Size of this header structure', [hdr.hdrsize])); + AOut.WriteLn(Format(' ipfheader.version: %6d.%d : version of file format?', [hdr.version_hi, hdr.version_lo])); + AOut.WriteLn(Format(' ipfheader.ntoc: %8.4x (%0:13d) : No of TOC entries', [hdr.ntoc])); + AOut.WriteLn(Format(' ipfheader.tocstart: %8.8x (%0:7d bytes) : 32bit file offset to start of TOC', [hdr.tocstart])); + AOut.WriteLn(Format(' ipfheader.toclen: %8.8x (%0:7d bytes) : bytes occupied by TOC entries', [hdr.toclen])); + AOut.WriteLn(Format(' ipfheader.tocoffsetsstart: %8.8x (%0:7d bytes) : file offset to array of TOC offsets', [hdr.tocoffsetsstart])); + AOut.WriteLn(Format(' ipfheader.nres: %8.4x (%0:13d) : number of panels with resource numbers', [hdr.nres])); + AOut.WriteLn(Format(' ipfheader.resstart: %8.8x (%0:7d bytes) : 32bit file offset of ressource number table', [hdr.resstart])); + AOut.WriteLn(Format(' ipfheader.nname: %8.4x (%0:13d) : number of panels with textual name', [hdr.nname])); + AOut.WriteLn(Format(' ipfheader.namestart: %8.8x (%0:7d bytes) : 32bit file offset to panel name table', [hdr.namestart])); + AOut.WriteLn(Format(' ipfheader.nindex: %8.4x (%0:13d) : number of index entries', [hdr.nindex])); + AOut.WriteLn(Format(' ipfheader.indexstart: %8.8x (%0:7d bytes) : 32bit file offset to index table', [hdr.indexstart])); + AOut.WriteLn(Format(' ipfheader.indexlen: %8.8x (%0:7d bytes) : size of index table', [hdr.indexlen])); + AOut.WriteLn(Format(' ipfheader.icmdCount: %8.4x (%0:13d) : number of icmd index items', [hdr.icmdCount])); + AOut.WriteLn(Format(' ipfheader.icmdOffset: %8.8x (%0:7d bytes) : file offset to icmd index items', [hdr.icmdOffset])); + AOut.WriteLn(Format(' ipfheader.icmdSize: %8.8x (%0:7d bytes) : size of icmd index table', [hdr.icmdSize])); + t1 := TOverlaySearchStart(hdr.searchstart); + i := t1.SearchOffset; + AOut.WriteLn(Format(' ipfheader.searchstart :31 %8.8x (%0:7d bytes) : 31bit file offset of full text search table', [i, i])); + if t1.IsRec16bitSize then + s := 'search rec is 16bit size' + else + s := 'search rec is 8bit size'; + AOut.WriteLn(Format(' ipfheader.recSize :1 %s (%s) : if high bit set, search record size is 16bit', [BoolToStr(t1.IsRec16bitSize, True), s])); + AOut.WriteLn(Format(' ipfheader.searchlen: %8.8x (%0:7d bytes) : size of full text search table', [hdr.searchlen])); + AOut.WriteLn(Format(' ipfheader.nslots: %8.4x (%0:13d) : number of "slots"', [hdr.nslots])); + AOut.WriteLn(Format(' ipfheader.slotsstart: %8.8x (%0:7d bytes) : 32bit file offset of the slots array', [hdr.slotsstart])); + AOut.WriteLn(Format(' ipfheader.dictlen: %8.8x (%0:7d bytes) : bytes occupied by the "dictionary"', [hdr.dictlen])); + AOut.WriteLn(Format(' ipfheader.ndict: %8.4x (%0:13d) : number of entries in the dictionary', [hdr.ndict])); + AOut.WriteLn(Format(' ipfheader.dictstart: %8.8x (%0:7d bytes) : 32bit file offset to start of dictionary', [hdr.dictstart])); + AOut.WriteLn(Format(' ipfheader.imgstart: %8.8x (%0:7d bytes) : 32bit file offset to image data', [hdr.imgstart])); + AOut.WriteLn(Format(' ipfheader.maxCVTIndex: %8.2x (%0:13d) : highest index inside panel''s local dictionary', [hdr.maxCVTIndex])); + AOut.WriteLn(Format(' ipfheader.nlsstart: %8.8x (%0:7d bytes) : 32bit file offset of NLS table', [hdr.nlsstart, hdr.nlsstart])); + AOut.WriteLn(Format(' ipfheader.nlslen: %8.8x (%0:7d bytes) : size of NLS table', [hdr.nlslen])); + AOut.WriteLn(Format(' ipfheader.extstart: %8.8x (%0:7d bytes) : 32bit file offset of extended data block', [hdr.extstart])); + AOut.WriteLn(Format(' ipfheader.reserved: %2.2x %2.2x %2.2x %2.2x %2.2x %2.2x %2.2x %2.2x %2.2x %2.2x %2.2x %2.2x : for future use. set to zero.', + [hdr.reserved[0], hdr.reserved[1], hdr.reserved[2], hdr.reserved[3], hdr.reserved[4], hdr.reserved[5], + hdr.reserved[6], hdr.reserved[7], hdr.reserved[8], hdr.reserved[9], hdr.reserved[10], hdr.reserved[11] ])); + AOut.WriteLn(Format(' ipfheader.title: "%s" : ASCII title of database', [hdr.title])); + + AOut.WriteLn(''); + AOut.WriteLn('Extended Header Section'); + AIn.Seek(hdr.extstart, soBeginning); + AIn.Read(eHdr, SizeOf(TExtendedHelpFileHeader)); + AOut.WriteLn(Format(' extheader.NumFontEntry %8.4x (%0:13d) : Font Table - number of entries', [eHdr.NumFontEntry])); + AOut.WriteLn(Format(' extheader.FontTableOffset %8.8x (%0:7d bytes) : Font Table - 32bit offset in file', [eHdr.FontTableOffset])); + AOut.WriteLn(Format(' extheader.NumDataBase %8.4x (%0:13d) : Data Base - No of files', [eHdr.NumDataBase])); + AOut.WriteLn(Format(' extheader.DataBaseOffset %8.8x (%0:7d bytes) : Data Base - 32bit offset in file', [eHdr.DataBaseOffset])); + AOut.WriteLn(Format(' extheader.DataBaseSize %8.8x (%0:7d bytes) : Data Base - Size in bytse', [eHdr.DataBaseSize])); + AOut.WriteLn(Format(' extheader.EntryInGNameTable %8.4x (%0:13d) : Global Names - No entries', [eHdr.EntryInGNameTable])); + AOut.WriteLn(Format(' extheader.HelpPanelGNameTblOffset %8.8x (%0:7d bytes) : Global Names - 32bit offset in file', [eHdr.HelpPanelGNameTblOffset])); + AOut.WriteLn(Format(' extheader.StringsOffset %8.8x (%0:7d bytes) : Strings - 32bit offset in file', [eHdr.StringsOffset])); + AOut.WriteLn(Format(' extheader.StringsSize %8.4x (%0:7d bytes) : Strings - Total bytes of all strings', [eHdr.StringsSize])); + AOut.WriteLn(Format(' extheader.ChildPagesOffset %8.8x (%0:7d bytes) : Child Pages - 32bit offset in file', [eHdr.ChildPagesOffset])); + AOut.WriteLn(Format(' extheader.ChildPagesSize %8.8x (%0:7d bytes) : Child Pages - Total bytes of all strings', [eHdr.ChildPagesSize])); + AOut.WriteLn(Format(' extheader.NumGIndexEntry %8.8x (%0:13d) : Total number of Global Index items', [eHdr.NumGIndexEntry])); + AOut.WriteLn(Format(' extheader.CtrlOffset %8.8x (%0:7d bytes) : Ctrl Buttons : offset in file', [eHdr.CtrlOffset])); + AOut.WriteLn(Format(' extheader.CtrlSize %8.8x (%0:7d bytes) : Ctrl Buttons : size in bytes', [eHdr.CtrlSize])); + AOut.WriteLn(Format(' extheader.reserved: %8.8x %8.8x %8.8x %8.8x : for future use. set to zero.', + [eHdr.reserved[0], eHdr.reserved[1], eHdr.reserved[2], eHdr.reserved[3]])); + + finally + // no nothing + end; +end; + +end. + diff --git a/docview/src/docdump/readnlsdata.pas b/docview/src/docdump/readnlsdata.pas new file mode 100644 index 00000000..68609235 --- /dev/null +++ b/docview/src/docdump/readnlsdata.pas @@ -0,0 +1,31 @@ +unit readnlsdata; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, filestreamhelper; + +procedure ProcessNLSData(AIn: TFileStream; AOut: TFileTextStream); + +implementation + +uses + readheader; + +procedure ProcessNLSData(AIn: TFileStream; AOut: TFileTextStream); +begin + AOut.WriteLn(''); + AOut.WriteLn('NLS Data'); + if hdr.nlslen > 0 then + begin + AOut.WriteLn(' <todo - process NLS data>'); + + end + else + AOut.WriteLn('NLS Data is not present'); +end; + +end. + diff --git a/docview/src/docdump/readstrings.pas b/docview/src/docdump/readstrings.pas new file mode 100644 index 00000000..7b397408 --- /dev/null +++ b/docview/src/docdump/readstrings.pas @@ -0,0 +1,56 @@ +{ + Dump the String table data +} +unit readstrings; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, filestreamhelper; + +procedure ProcessStringsTable(AIn: TFileStream; AOut: TFileTextStream); + + +implementation + +uses + readheader; + +procedure ProcessStringsTable(AIn: TFileStream; AOut: TFileTextStream); +var + name: string; + pData: pointer; + p: pointer; + pLength: pByte; + bytes: integer; +begin + AOut.WriteLn(''); + AOut.WriteLn('Strings Data'); + + if eHdr.StringsSize > 0 then + begin + pData := nil; + AIn.Seek(eHdr.StringsOffset, soBeginning); + GetMem(pData, eHdr.StringsSize); // allocate temp space for data + AIn.Read(pData^, eHdr.StringsSize); // read all data in one shot + p := pData; // p is our incrementing position in the data + bytes := 0; + while bytes < eHdr.StringsSize do; + begin + pLength := p; // length byte, including itself + bytes := bytes + pLength^; + SetString(name, p+1, pLength^-1); // use length value minus the length byte to get the string length + AOut.WriteLn(Format(' %s', [name])); + inc(p, pLength^); // skip to next entry using full length (including length byte) + end; + FreeMem(pData, eHdr.StringsSize); // free allocated space + end + else + AOut.WriteLn(' There are no strings'); + +end; + +end. + diff --git a/docview/src/docdump/readtoc.pas b/docview/src/docdump/readtoc.pas new file mode 100644 index 00000000..0cfae395 --- /dev/null +++ b/docview/src/docdump/readtoc.pas @@ -0,0 +1,171 @@ +{ + Dump the Table of Contents data +} +unit readtoc; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, filestreamhelper; + +procedure ProcessTOC(AIn: TFileStream; AOut: TFileTextStream); + +implementation + +uses + IPFFileFormatUnit, readheader, u_Tools; + +type + TTOCOverlay = bitpacked record + length: uint8; // length of the entry including this byte (but not including extended data) + nestlevel: Unsigned_4; + unknown: boolean; + extended: boolean; + hidden: boolean; + haschildren: boolean; + numSlots: uint8; // number of "slots" occupied by the text for this toc entry + end; + + + TTOCExtendedOverlay = bitpacked record + setPos: boolean; + setSize: boolean; + setView: boolean; + setStyle: boolean; + noSearch: boolean; + noPrint: boolean; + setCtrl: boolean; + setTutor: boolean; + clear: boolean; + unknown1: Unsigned_1; + setGroup: boolean; + isParent: boolean; + unknown2: Unsigned_4; + end; + + +procedure ProcessTOC(AIn: TFileStream; AOut: TFileTextStream); +var + Count: integer; + VisCount: integer; + pOffsets: UInt32ArrayPointer; + toc: TTOCEntryStart; + olay: TTOCOverlay; + tocextolay: TTOCExtendedOverlay; + pData: pointer; + pEntry: pTTOCEntryStart; + pExtendedInfo: pExtendedTOCEntry; + p: PByte; + i: integer; + titleLen: integer; + title: string; +begin + AOut.WriteLn(''); + AOut.WriteLn('Table of Contents'); + VisCount := 0; + GetMem(pOffsets, SizeOf(uint32) * hdr.ntoc); + AIn.Seek(hdr.tocoffsetsstart, soBeginning); + AIn.Read(pOffsets^, SizeOf(uint32) * hdr.ntoc); // now we have array of toc offsets + + AIn.Seek(hdr.tocstart, soBeginning); + GetMem(pData, hdr.toclen); + AIn.Read(pData^, hdr.toclen); + pEntry := pData; + for count := 1 to hdr.ntoc do + begin +// AIn.Read(toc, SizeOf(TTOCEntryStart)); +// FillChar(olay, SizeOf(TTOCOverlay), 0); + p := PByte(pEntry) + sizeof(TTOCEntryStart); + i := Longint(p^); + + olay.extended := (pEntry^.flags and TOCEntryExtended ) = TOCEntryExtended; + olay.nestlevel := (pEntry^.flags and TOCEntryLevelMask); + olay.hidden := (pEntry^.flags and TOCEntryHidden) = TOCEntryHidden; + olay.haschildren := (pEntry^.flags and TOCEntryHasChildren) = TOCEntryHasChildren; + + AOut.WriteLn(Format(' TOC Entry #%d at offset %8.8x (%d bytes)', [count, p^, i])); + AOut.WriteLn(Format(' tocentry.length: %2.2x (%0:d bytes)', [pEntry^.length])); + AOut.WriteLn(Format(' tocentry.nestlevel: %d', [olay.nestlevel])); + AOut.WriteLn(Format(' tocentry.unknown: %s', [iif(olay.unknown, 'set', 'clear')])); + AOut.WriteLn(Format(' tocentry.extended: %s', [iif(olay.extended, 'yes', 'no')])); + AOut.WriteLn(Format(' tocentry.hidden: %s', [iif(olay.hidden, 'yes', 'no')])); + AOut.WriteLn(Format(' tocentry.haschildren: %s', [iif(olay.haschildren, 'yes', 'no')])); + AOut.WriteLn(Format(' tocentry.numSlots: %d', [pEntry^.numSlots])); + if not olay.hidden then + inc(VisCount); + if olay.extended then + begin + pExtendedInfo := pExtendedTOCEntry( p ); // next data to follow must be Extended TOC Entry + + AOut.WriteLn(' Extended TOC Entry'); + tocextolay := TTOCExtendedOverlay(pExtendedInfo^); + + AOut.Writeln(Format(' ExtTocEntry.setPos: %s', [iif(tocextolay.setPos, 'yes', 'no')])); + AOut.Writeln(Format(' ExtTocEntry.setSize: %s', [iif(tocextolay.setSize, 'yes', 'no')])); + AOut.Writeln(Format(' ExtTocEntry.setView: %s', [iif(tocextolay.setView, 'yes', 'no')])); + AOut.Writeln(Format(' ExtTocEntry.setStyle: %s', [iif(tocextolay.setStyle, 'yes', 'no')])); + AOut.Writeln(Format(' ExtTocEntry.noSearch: %s', [iif(tocextolay.noSearch, 'yes', 'no')])); + AOut.Writeln(Format(' ExtTocEntry.noPrint: %s', [iif(tocextolay.noPrint, 'yes', 'no')])); + AOut.Writeln(Format(' ExtTocEntry.setCtrl: %s', [iif(tocextolay.setCtrl, 'yes', 'no')])); + AOut.Writeln(Format(' ExtTocEntry.setTutor: %s', [iif(tocextolay.setTutor, 'yes', 'no')])); + AOut.Writeln(Format(' ExtTocEntry.clear: %s', [iif(tocextolay.clear, 'clear', 'set')])); + AOut.Writeln(Format(' ExtTocEntry.unknown1: %1.1x', [tocextolay.unknown1])); + AOut.Writeln(Format(' ExtTocEntry.setGroup: %s', [iif(tocextolay.setGroup, 'yes', 'no')])); + AOut.Writeln(Format(' ExtTocEntry.isParent: %s', [iif(tocextolay.isParent, 'yes', 'no')])); + AOut.Writeln(Format(' ExtTocEntry.unknown2: %1.1x', [tocextolay.unknown2])); + + inc( p, sizeof( TExtendedTOCEntry ) ); // move p past two flag bytes + + if ( pExtendedInfo^.w1 and 1 ) > 0 then + // skip position + inc( p, sizeof( THelpXYPair ) ); + + if ( pExtendedInfo^.w1 and 2 ) > 0 then + // skip size + inc( p, sizeof( THelpXYPair ) ); + + if ( pExtendedInfo^.w1 and 8 ) > 0 then + // skip window controls + inc( p, sizeof(word) ); // increment by 2 + + if ( pExtendedInfo^.w1 and $40 ) > 0 then + // skip something else, unknown... style? 2 bytes + inc( p, sizeof(word) ); // increment by 2 + + if ( pExtendedInfo^.w2 and 4 ) > 0 then + begin +// _ContentsGroupIndex := pUInt16(p)^; + // read group + inc( p, sizeof( uint16 ) ); + end; + end; + + // skip slot numbers for now. +// _pSlotNumbers := pUInt16(p); + inc( p, pEntry^.numSlots * sizeof(uint16) ); + + // Calculate the remainder of the tocentry length - that is the bytes used for TOC topic (title) text + titleLen := pEntry^.length - ( longword( p ) - longword( pEntry ) ); + + // Read title + if TitleLen > 0 then + SetString(Title, Pointer(p), TitleLen) + else + Title := '<unknown>'; + AOut.WriteLn(Format(' toc Title: %s', [title])); + + + p := PByte(pEntry); + inc(p, pEntry^.Length); + pEntry := pTTOCEntryStart(p); + end; + + AOut.WriteLn(Format(' TOC visible count: %d', [VisCount])); + FreeMem(pOffsets, SizeOf(uint32) * hdr.ntoc); + FreeMem(pData, hdr.toclen); +end; + +end. + diff --git a/docview/src/docdump/u_Tools.pas b/docview/src/docdump/u_Tools.pas new file mode 100644 index 00000000..96192db9 --- /dev/null +++ b/docview/src/docdump/u_Tools.pas @@ -0,0 +1,52 @@ +{ + This unit will grow to include all handy functions that can be used in + different Lazarus projects. + + There may be no links to other non-standard units! +} +unit u_Tools; + +{$mode objfpc}{$H+} + +interface + + { Missing iif() known from Visual Basic - return a string } + function iif(fCon: Boolean; sTrue, sFalse: String): String; + { Missing iif() known from Visual Basic - return an Integer } + function iif(fCon: Boolean; iTrue, iFalse: Integer): Integer; + { Missing iif() known from Visual Basic - return an Extended } + function iif(fCon: Boolean; iTrue, iFalse: Extended): Extended; + + +implementation +uses + SysUtils; + + +function iif(fCon: Boolean; sTrue, sFalse: String): String; +begin + if fCon then + Result := sTrue + else + Result := sFalse; +end; + +function iif(fCon: Boolean; iTrue, iFalse: Integer): Integer; +begin + if fCon then + Result := iTrue + else + Result := iFalse; +end; + +function iif(fCon: Boolean; iTrue, iFalse: Extended): Extended; +begin + if fCon then + Result := iTrue + else + Result := iFalse; +end; + + +end. + diff --git a/docview/src/docview.lpi b/docview/src/docview.lpi new file mode 100644 index 00000000..2495cb6a --- /dev/null +++ b/docview/src/docview.lpi @@ -0,0 +1,197 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="7"/> + <General> + <Flags> + <SaveOnlyProjectUnits Value="True"/> + </Flags> + <SessionStorage Value="InIDEConfig"/> + <MainUnit Value="0"/> + <TargetFileExt Value=""/> + <Title Value="docview"/> + <UseAppBundle Value="False"/> + </General> + <VersionInfo> + <ProjectVersion Value=""/> + </VersionInfo> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="fpgui_toolkit"/> + </Item1> + </RequiredPackages> + <Units Count="27"> + <Unit0> + <Filename Value="docview.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="docview"/> + </Unit0> + <Unit1> + <Filename Value="frm_main.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="frm_main"/> + </Unit1> + <Unit2> + <Filename Value="IPFEscapeCodes.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="IPFEscapeCodes"/> + </Unit2> + <Unit3> + <Filename Value="HelpTopic.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="HelpTopic"/> + </Unit3> + <Unit4> + <Filename Value="HelpFile.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="HelpFile"/> + </Unit4> + <Unit5> + <Filename Value="CompareWordUnit.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="CompareWordUnit"/> + </Unit5> + <Unit6> + <Filename Value="SearchTable.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="SearchTable"/> + </Unit6> + <Unit7> + <Filename Value="TextSearchQuery.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="TextSearchQuery"/> + </Unit7> + <Unit8> + <Filename Value="nvUtilities.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="nvUtilities"/> + </Unit8> + <Unit9> + <Filename Value="nvNullObjects.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="nvNullObjects"/> + </Unit9> + <Unit10> + <Filename Value="../docs/inf04.txt"/> + <IsPartOfProject Value="True"/> + </Unit10> + <Unit11> + <Filename Value="SearchUnit.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="SearchUnit"/> + </Unit11> + <Unit12> + <Filename Value="../components/richtext/RichTextStyleUnit.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="RichTextStyleUnit"/> + </Unit12> + <Unit13> + <Filename Value="../components/richtext/CanvasFontManager.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="CanvasFontManager"/> + </Unit13> + <Unit14> + <Filename Value="../components/richtext/ACLStringUtility.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="ACLStringUtility"/> + </Unit14> + <Unit15> + <Filename Value="../components/richtext/RichTextDocumentUnit.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="RichTextDocumentUnit"/> + </Unit15> + <Unit16> + <Filename Value="../components/richtext/RichTextView.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="RichTextView"/> + </Unit16> + <Unit17> + <Filename Value="../components/richtext/RichTextLayoutUnit.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="RichTextLayoutUnit"/> + </Unit17> + <Unit18> + <Filename Value="../components/richtext/RichTextDisplayUnit.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="RichTextDisplayUnit"/> + </Unit18> + <Unit19> + <Filename Value="IPFFileFormatUnit.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="IPFFileFormatUnit"/> + </Unit19> + <Unit20> + <Filename Value="HelpWindowDimensions.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="HelpWindowDimensions"/> + </Unit20> + <Unit21> + <Filename Value="NewViewConstantsUnit.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="NewViewConstantsUnit"/> + </Unit21> + <Unit22> + <Filename Value="SettingsUnit.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="SettingsUnit"/> + </Unit22> + <Unit23> + <Filename Value="dvconstants.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="dvconstants"/> + </Unit23> + <Unit24> + <Filename Value="dvHelpers.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="dvHelpers"/> + </Unit24> + <Unit25> + <Filename Value="HelpWindow.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="HelpWindow"/> + </Unit25> + <Unit26> + <Filename Value="../TODO.txt"/> + <IsPartOfProject Value="True"/> + </Unit26> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="8"/> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)/"/> + <OtherUnitFiles Value="../components/richtext/"/> + <UnitOutputDirectory Value="units/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <CStyleOperator Value="False"/> + <IncludeAssertionCode Value="True"/> + <AllowLabel Value="False"/> + <CPPInline Value="False"/> + </SyntaxOptions> + </Parsing> + <CodeGeneration> + <Optimizations> + <OptimizationLevel Value="0"/> + </Optimizations> + </CodeGeneration> + <Other> + <CustomOptions Value="-O- +"/> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> +</CONFIG> diff --git a/docview/src/docview.lpr b/docview/src/docview.lpr new file mode 100644 index 00000000..32a80f3b --- /dev/null +++ b/docview/src/docview.lpr @@ -0,0 +1,42 @@ +program docview; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Classes, + {$IFDEF Timing}EpikTimer,{$ENDIF} + fpg_main, frm_main, IPFEscapeCodes, HelpTopic, CompareWordUnit, SearchTable, + TextSearchQuery, nvUtilities, nvNullObjects, HelpFile, SearchUnit, + fpg_cmdlineparams, customstyle, IPFFileFormatUnit, HelpWindowDimensions, + NewViewConstantsUnit, SettingsUnit, RichTextStyleUnit, CanvasFontManager, + ACLStringUtility, RichTextDocumentUnit, RichTextView, RichTextLayoutUnit, + RichTextDisplayUnit, dvconstants, dvHelpers; + + +procedure MainProc; +var + frm: TMainForm; +begin + fpgApplication.Initialize; + + // always load custom style for help viewer + //if Assigned(fpgStyle) then + // fpgStyle.Free; + //fpgStyle := TMyStyle.Create; + + frm := TMainForm.Create(nil); + try + frm.Show; + fpgApplication.Run; + finally + frm.Free; + end; +end; + +begin + MainProc; +end. + diff --git a/docview/src/dvHelpers.pas b/docview/src/dvHelpers.pas new file mode 100644 index 00000000..c5486bb7 --- /dev/null +++ b/docview/src/dvHelpers.pas @@ -0,0 +1,50 @@ +unit dvHelpers; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils; + +const + OWN_HELP_MARKER = '[DOCVIEWHELP]'; + + +function GetOwnHelpFileName: String; +function FindHelpFile(const AFilename: string): string; + + +implementation + +uses + fpg_utils + ; + + +function GetOwnHelpFileName: String; +//var +// tmpLanguage : String; +begin + //tmpLanguage := getLanguage; + //if tmpLanguage = '' then + //begin + // tmpLanguage := GetEnv(LanguageEnvironmentVar) + //end; + // + //result := FindDefaultLanguageHelpFile('NewView', tmpLanguage); + + { TODO -oGraeme -cown help : Improve own help file location } + result := fpgExtractFilePath(ParamStr(0)) + 'docview.inf'; +end; + +// Given a "filename" which may include a path, find it in various paths and extensions +function FindHelpFile(const AFilename: string): string; +begin + { TODO -ograemeg -csearch files : Implement searching know locations } + Result := AFileName; +end; + + +end. + diff --git a/docview/src/dvconstants.pas b/docview/src/dvconstants.pas new file mode 100644 index 00000000..ae8b414d --- /dev/null +++ b/docview/src/dvconstants.pas @@ -0,0 +1,36 @@ +unit dvconstants; + +{$mode objfpc}{$H+} + +interface + +const + { DO NOT LOCALIZE } + HelpPathEnvironmentVar = 'HELP'; + BookshelfEnvironmentVar = 'BOOKSHELF'; + HELP_FILE_DELIMITER = '+'; + HELP_FILE_EXTENSION = ExtensionSeparator + 'hlp'; + INF_FILE_EXTENSION = ExtensionSeparator + 'inf'; + + +resourcestring + rsDVTitle = 'Documentation Viewer'; + rsDVSearchingMsg = 'Searching...'; + rsDVDisplaying = 'Displaying...'; + rsDVLoadingNotes = 'Loading notes...'; + rsDVDisplayContents = 'Display contents...'; + rsDVDisplayingFirstTopic = 'Display first topic...'; + rsDVDone = 'Done'; + rsDVNoFile = 'No file'; + rsDVOpenHelpFile = 'Open Help File'; + rsDVHelpFiles = 'Help Files'; + rsDVNoMatchesFound = '(No matches found for ''%s'')'; + rsDVSearchSyntaxError = 'Error in search syntax: '; + rsDVSearchFoundMsg = 'Found %d matches for '; + rsDVCouldNotOpen = 'Could not open <%s>'; + + +implementation + +end. + diff --git a/docview/src/frm_main.pas b/docview/src/frm_main.pas new file mode 100644 index 00000000..0d1a8495 --- /dev/null +++ b/docview/src/frm_main.pas @@ -0,0 +1,2210 @@ +unit frm_main; + +{$mode objfpc}{$H+} + +interface + +uses + SysUtils, Classes, fpg_base, fpg_main, fpg_form, fpg_panel, fpg_tab, + fpg_tree, fpg_splitter, fpg_menu, fpg_button, fpg_listbox, + fpg_label, fpg_edit, fpg_radiobutton, fpg_progressbar, fpg_mru, + HelpFile, RichTextView, HelpTopic; + +type + // Used by Index ListBox. We can generate a custom Index if the help file + // doesn't contain it's own index entries. + TListType = ( ltContents, ltIndex ); + + TMainForm = class(TfpgForm) + private + {@VFD_HEAD_BEGIN: MainForm} + bvlStatusBar: TfpgBevel; + ProgressBar: TfpgProgressBar; + lblStatus: TfpgLabel; + bvlBody: TfpgBevel; + PageControl1: TfpgPageControl; + tsContents: TfpgTabSheet; + tvContents: TfpgTreeView; + btnGo: TfpgButton; + tsIndex: TfpgTabSheet; + btnIndex: TfpgButton; + lbIndex: TfpgListBox; + IndexSearchEdit: TfpgEdit; + tsSearch: TfpgTabSheet; + Label1: TfpgLabel; + edSearchText: TfpgEdit; + Label2: TfpgLabel; + RadioButton1: TfpgRadioButton; + RadioButton2: TfpgRadioButton; + RadioButton3: TfpgRadioButton; + RadioButton4: TfpgRadioButton; + RadioButton5: TfpgRadioButton; + RadioButton6: TfpgRadioButton; + lbSearchResults: TfpgListBox; + Label3: TfpgLabel; + btnSearch: TfpgButton; + tsNotes: TfpgTabSheet; + ListBox1: TfpgListBox; + btnNotesAdd: TfpgButton; + btnNotesEdit: TfpgButton; + btnNotesDel: TfpgButton; + btnNotesGoto: TfpgButton; + tsHistory: TfpgTabSheet; + lbHistory: TfpgListBox; + Splitter1: TfpgSplitter; + RichView: TRichTextView; + MainMenu: TfpgMenuBar; + miFile: TfpgPopupMenu; + miSettings: TfpgPopupMenu; + miBookmarks: TfpgPopupMenu; + miHelp: TfpgPopupMenu; + miDebug: TfpgPopupMenu; + miOpenRecentMenu: TfpgPopupMenu; + {@VFD_HEAD_END: MainForm} + Files: TList; // current open help files. + Debug: boolean; + mru: TfpgMRU; + FFileOpenRecent: TfpgMenuItem; + + LoadingFilenameList: TStringList; + LoadingFileIndex: integer; + LoadingTotalSize: longint; + LoadingSizeSoFar: longint; + AllFilesWordSequences: TList; // of lists; one per open file; of possible word sequences + CurrentOpenFiles: TList; // current open help files. + MainTitle: string; + InIndexSearch: boolean; // true while searching index + IndexLoaded: boolean; + ContentsLoaded: boolean; + DisplayedIndex: TStringList; // duplicate of index listbox, for fast case insensitive searching + CurrentTopic: TTopic; // so we can get easy access to current topic viewed + + procedure RichViewClickLink(Sender: TRichTextView; Link: string); + procedure IndexSearchEditKeyPress(Sender: TObject; var KeyCode: word; var ShiftState: TShiftState; var Consumed: boolean); + procedure MainFormShow(Sender: TObject); + procedure MainFormDestroy(Sender: TObject); + procedure miFileQuitClicked(Sender: TObject); + procedure miFileOpenClicked(Sender: TObject); + procedure miFileCloseClicked(Sender: TObject); + procedure miHelpProdInfoClicked(Sender: TObject); + procedure miHelpAboutFPGui(Sender: TObject); + procedure miDebugHeader(Sender: TObject); + procedure miDebugHex(Sender: TObject); + procedure miFileSaveTopicAsIPF(Sender: TObject); + procedure miMRUClick(Sender: TObject; const FileName: String); + procedure btnShowIndex(Sender: TObject); + procedure btnGoClicked(Sender: TObject); + procedure tvContentsChange(Sender: TObject); + procedure edSearchTextKeyPress(Sender: TObject; var KeyCode: word; var ShiftState: TShiftState; var Consumed: boolean); + procedure lbSearchResultsKeyPress(Sender: TObject; var KeyCode: word; var ShiftState: TShiftState; var Consumed: boolean); + procedure MainFormException(Sender: TObject; E: Exception); + procedure MainFormCloseQuery(Sender: TObject; var CanClose: boolean); + procedure PageControl1Change(Sender: TObject; NewActiveSheet: TfpgTabSheet); + procedure tvContentsDoubleClick(Sender: TObject; AButton: TMouseButton; AShift: TShiftState; const AMousePos: TPoint); + procedure lbIndexDoubleClick(Sender: TObject; AButton: TMouseButton; AShift: TShiftState; const AMousePos: TPoint); + procedure lbSearchResultsDoubleClick(Sender: TObject; AButton: TMouseButton; AShift: TShiftState; const AMousePos: TPoint); + procedure btnSearchClicked(Sender: TObject); + procedure IndexSearchEditOnChange(Sender: TObject); + procedure DisplaySelectedSearchResultTopic; + procedure UpdateLocationPanel; + procedure EnableControls; + procedure ClearAllWordSequences; + procedure DoSearch; + procedure SetWaitCursor; + procedure ClearWaitCursor; + procedure SetMainCaption; + procedure DisplayFiles(NewFiles: TList; var FirstContentsNode: TfpgTreeNode); + procedure FileOpen; + function LoadFiles(const aFileNames: TStrings; aHelpFiles: TList): boolean; + function OpenFiles(const FileNames: TStrings; const AWindowTitle: string; const DisplayFirstTopic: boolean): boolean; + function OpenFile(const AFileName: string; const AWindowTitle: string; const DisplayFirstTopic: boolean): boolean; + procedure CloseFile(const ADestroying: boolean = False); + procedure OnHelpFileLoadProgress(n, outof: integer; AMessage: string); + procedure LoadNotes(AHelpFile: THelpFile); + procedure LoadContents(AFiles: TList; var FirstNode: TfpgTreeNode); + procedure LoadIndex; + // Used in loading contents + procedure AddChildNodes(AHelpFile: THelpFile; AParentNode: TfpgTreeNode; ALevel: longint; var ATopicIndex: longint ); + procedure ClearNotes; + procedure SaveNotes(AHelpFile: THelpFile); + procedure DisplayTopic(ATopic: TTopic = nil); + procedure ResetProgress; + procedure SetStatus(const AText: TfpgString); + function TranslateEnvironmentVar(AFilenames: TfpgString): TfpgString; + procedure RefreshFontSubstitutions; + procedure DisplaySelectedIndexTopic; + procedure ProcessCommandLineParams; + procedure ShowParamHelp; + function FindTopicForLink( Link: THelpLink ): TTopic; + function FindTopicByResourceID( ID: word ): TTopic; + function FindTopicByName(const AName: string): TTopic; + + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure AfterCreate; override; + end; + +{@VFD_NEWFORM_DECL} + + +implementation + +uses + fpg_dialogs + ,fpg_constants + ,fpg_iniutils + ,fpg_cmdlineparams + ,nvUtilities + ,ACLStringUtility + ,TextSearchQuery + ,SearchUnit + ,dvconstants + ,IPFFileFormatUnit + ,SettingsUnit + ,dvHelpers + ; + +const + cLongName = 'fpGUI Documentation Viewer'; + cCreatedBy = 'Created by Graeme Geldenhuys'; + cVersion = 'Version 0.7 (alpha)'; + +{@VFD_NEWFORM_IMPL} + +procedure TMainForm.MainFormException(Sender: TObject; E: Exception); +begin + TfpgMessageDialog.Critical('An unexpected error occurred.', E.Message); +end; + +procedure TMainForm.RichViewClickLink(Sender: TRichTextView; Link: string); +var + LinkIndex: integer; + lLink: THelpLink; + lHelp: THelpFile; + i: integer; + lTopic: TTopic; + lFound: Boolean; +begin + // TODO: process other types of links (external, application etc...) too! + + LinkIndex := StrToInt( Link ); + lLink := THelpLink(CurrentTopic.Links[LinkIndex]); + lTopic := FindTopicForLink(lLink); + if lTopic <> nil then + DisplayTopic(lTopic); + exit; + + lHelp := THelpFile(lLink.HelpFile); + lTopic := nil; + lFound := False; + for i := 0 to CurrentOpenFiles.Count-1 do + begin + lHelp := THelpFile(CurrentOpenFiles[i]); + lTopic := lHelp.Topics[LinkIndex]; + if lTopic <> nil then + begin + lFound := True; + writeln('Found Topic! ', lTopic.Title); + break; + + end; + if lFound then + break; + end; + if lTopic <> nil then + begin + writeln('Displaying topic <', lTopic.Title, '>'); + DisplayTopic(lTopic); + end; + //lLink := SourceWindow.Topic.Links[ LinkIndex ]; + // + //PostMsg( Self.Handle, + // WM_FOLLOWLINK, + // longint( Link ), + // longint( SourceWindow ) ); + +end; + +procedure TMainForm.IndexSearchEditKeyPress(Sender: TObject; var KeyCode: word; + var ShiftState: TShiftState; var Consumed: boolean); +begin + if (KeyCode = keyEnter) or (KeyCode = keyPEnter) then + begin + Consumed := True; + DisplaySelectedIndexTopic; + end; +end; + +procedure TMainForm.MainFormShow(Sender: TObject); +begin + bvlBody.Realign; + + // restore previous window position and size + gINI.ReadFormState(self); + PageControl1.Width := gINI.ReadInteger('Options', 'SplitterLeft', 260); + UpdateWindowPosition; + + Settings.NormalFont := fpgStyle.DefaultFont; + Settings.FixedFont := fpgStyle.FixedFont; + Settings.SearchDirectories := TStringList.Create; + + LogEvent(LogSettings, 'Loading settings'); + LoadSettings; + + ProcessCommandLineParams; + +end; + +procedure TMainForm.MainFormDestroy(Sender: TObject); +begin + DisplayedIndex.Free; + // save splitter position + gINI.WriteInteger('Options', 'SplitterLeft', PageControl1.Width); + // save form size and position + gINI.WriteFormState(self); + LogEvent(LogSettings, 'Save settings'); + SaveSettings; + LogEvent(LogSettings, 'Save settings done'); +end; + +procedure TMainForm.miFileQuitClicked(Sender: TObject); +begin + Close; +end; + +procedure TMainForm.miFileOpenClicked(Sender: TObject); +begin + FileOpen; +end; + +procedure TMainForm.miFileCloseClicked(Sender: TObject); +begin + CloseFile; +end; + +procedure TMainForm.miHelpProdInfoClicked(Sender: TObject); +var + s: TfpgString; +begin + s := cLongName + LineEnding + LineEnding + + cCreatedBy + LineEnding + + cVersion + ' - '+ {$I %date%} + ' ' + {$I %time%}; + + TfpgMessageDialog.Information('Product Information', s); +end; + +procedure TMainForm.miHelpAboutFPGui(Sender: TObject); +begin + TfpgMessageDialog.AboutFPGui; +end; + +procedure TMainForm.miDebugHeader(Sender: TObject); +var + f: THelpFile; + i: integer; + sl: TStringList; +begin + RichView.Clear; + sl := TStringList.Create; + RichView.AddText(PChar('FileCount = ' + IntToStr(CurrentOpenFiles.Count))); + for i := 0 to CurrentOpenFiles.Count-1 do + begin + f := THelpFile(CurrentOpenFiles[i]); + sl.Clear; + with sl do + begin + Add('<b><u>Filename:</u></b> <red>' + f.Filename + '<black>'); + Add(''); + Add('<b>Title:</b> ' + f.Title); + Add('<b>Dictionary count:</b> ' + IntToStr(f.DictionaryCount)); + Add('<b>Topic count:</b> ' + IntToStr(f.TopicCount)); + Add('<b>Index count:</b> ' + IntToStr(f.Index.Count)); + Add('<b>String resource id count:</b> ' + IntToStr(f.StringResourceIDCount)); + Add('<b>Numeric resource id count:</b> ' + IntToStr(f.NumericResourceIDCount)); + Add(' '); + //Add('Dictionary contents:'); + //for i := 0 to f.DictionaryCount-1 do + // Add('[' + IntToStr(i) + '] = <' + f.DictionaryWords[i] + '>'); + end; + RichView.AddParagraph(PChar(sl.Text)); + end; + sl.Free; +end; + +procedure TMainForm.miDebugHex(Sender: TObject); +begin + Debug := not Debug; + DisplayTopic(nil); +end; + +procedure TMainForm.miFileSaveTopicAsIPF(Sender: TObject); +var + F: TextFile; + T: TTopic; + dlg: TfpgFileDialog; + H: THelpFile; + i: integer; + filename: string; + imglist: TList; +begin +(* + H := THelpFile(CurrentOpenFiles[0]); + + FileName := ChangeFileExt( ExtractFileName( H.Filename ), '.ipf' ); + if not DoSaveFileDialog( FileSaveTitle, + 'IPF' + '|*.ipf', + Filename, + Settings.LastSaveDirectory, + Filename ) then + exit; + if FileExists( Filename ) then + if not DoConfirmDlg( FileSaveTitle, + ReplaceFilePromptA + + Filename + + ReplaceFilePromptB ) then + exit; + + ImageOffsets := TList.Create; + + AssignFile( F, FileName ); + Rewrite( F ); + WriteLn( F, ':userdoc.' ); + + // We can't tell if some levels of the contents were + // merged into the text of topics. So we just assume all are visible + WriteLn( F, ':docprof toc=123456.' ); + + ResourceIDs := TList.Create; + + WriteLn( F, ':title.' + H.Title ); + + for i := 0 to H.TopicCount - 1 do + begin + T := H.Topics[ i ]; + + SetProgress( i div 2, H.TopicCount , 'Saving text...' ); + + WriteLn( F, '' ); + + + if T.ContentsLevel = 0 then + begin + // perhaps it means footnote? + // Level := 1; + Write( F, ':fn id=fn' + IntToStr( i ) + '.' ); // use index as id + + T.SaveToIPF( F, ImageOffsets ); + + WriteLn( F, '' ); + WriteLn( F, ':efn.' ); + end + else + begin + Write( F, ':h' + IntToStr( T.ContentsLevel ) ); + Write( F, ' id=' + IntToStr( i ) ); // use index as id + + H.FindResourceIDsForTopic( T, ResourceIDs ); + if ResourceIDs.Count > 0 then + begin + Write( F, ' res=' + IntToStr( longint( ResourceIDs[ 0 ] ) ) ); + end; + + if not T.ShowInContents then + Write( F, ' hide' ); + + if T.ContentsGroupIndex > 0 then + Write( F, ' group=' + IntToStr( T.ContentsGroupIndex ) ); + + Write( F, '.' ); // end of header + WriteLn( F, T.Title ); + + T.SaveToIPF( F, ImageOffsets ); + end; + + + + end; + + ResourceIDs.Destroy; + + WriteLn( F, ':euserdoc.' ); + System.Close( F ); + + // Now write images + + for i := 0 to ImageOffsets.Count - 1 do + begin + ImageOffset := longint( ImageOffsets[ i ] ); + + SetProgress( i div 2 + ImageOffsets.Count div 2, + ImageOffsets.Count , + 'Saving images...' ); + + Image := H.GetImage( ImageOffset ); + + if Image <> nil then + begin + Image.SaveToFile( ExtractFilePath( Filename ) + + 'img' + + IntToStr( i ) + + '.bmp' ); + Image.Destroy; + end; + + end; + + ResetProgress; + SetStatus( 'Save complete' ); + ImageOffsets.Destroy; +*) + + + + //----------------------------- + if tvContents.Selection = nil then + Exit; //--> + + T := TTopic(tvContents.Selection.Data); + if T <> nil then + begin + dlg := TfpgFileDialog.Create(nil); + try + dlg.FileName := T.Title + '.ipf'; + if dlg.RunSaveFile then + begin + imglist := TList.Create; + AssignFile( F, dlg.FileName ); + Rewrite( F ); + T.SaveToIPF(F, imglist); + System.Close(F); + imglist.free; + dlg.Close; + dlg.Free; + end; + finally + end; + end; +end; + +procedure TMainForm.miMRUClick(Sender: TObject; const FileName: String); +begin + OpenFile(FileName, '', True); +end; + +procedure TMainForm.btnShowIndex(Sender: TObject); +begin + DisplaySelectedIndexTopic; +end; + +procedure TMainForm.btnGoClicked(Sender: TObject); +begin + if tvContents.Selection <> nil then + DisplayTopic(nil); +end; + +procedure TMainForm.tvContentsChange(Sender: TObject); +begin + DisplayTopic(nil); +end; + +procedure TMainForm.edSearchTextKeyPress(Sender: TObject; var KeyCode: word; + var ShiftState: TShiftState; var Consumed: boolean); +begin + if (KeyCode = keyReturn) or (KeyCode = keyPEnter) then + begin + Consumed := True; + btnSearch.Click; + end + else if (KeyCode = keyDown) then + begin + Consumed := True; + lbSearchResults.SetFocus; + end; +end; + +procedure TMainForm.lbSearchResultsKeyPress(Sender: TObject; var KeyCode: word; + var ShiftState: TShiftState; var Consumed: boolean); +begin + if (KeyCode = keyReturn) or (KeyCode = keyPEnter) then + begin + Consumed := True; + DisplayTopic(nil); + end +end; + +procedure TMainForm.MainFormCloseQuery(Sender: TObject; var CanClose: boolean); +begin + CloseFile(True); +end; + +procedure TMainForm.PageControl1Change(Sender: TObject; NewActiveSheet: TfpgTabSheet); +begin + if NewActiveSheet = tsIndex then + begin + if not IndexLoaded then + LoadIndex; + IndexSearchEdit.SetFocus; + end; +end; + +procedure TMainForm.tvContentsDoubleClick(Sender: TObject; AButton: TMouseButton; + AShift: TShiftState; const AMousePos: TPoint); +begin + if tvContents.Selection <> nil then + DisplayTopic(nil); +end; + +procedure TMainForm.lbIndexDoubleClick(Sender: TObject; AButton: TMouseButton; + AShift: TShiftState; const AMousePos: TPoint); +begin + InIndexSearch := True; // prevent edit.OnChange from executing too + try + IndexSearchEdit.Text := lbIndex.Items[lbIndex.FocusItem]; + DisplayTopic(nil); + finally + InIndexSearch := False; + end; +end; + +procedure TMainForm.lbSearchResultsDoubleClick(Sender: TObject; AButton: TMouseButton; + AShift: TShiftState; const AMousePos: TPoint); +begin + DisplaySelectedSearchResultTopic; +end; + +procedure TMainForm.btnSearchClicked(Sender: TObject); +begin + DoSearch; +end; + +procedure TMainForm.IndexSearchEditOnChange(Sender: TObject); +var + tmpMatchIndex: longint; + tmpSearchText: string; + i: longint; +begin + if InIndexSearch then + exit; + + tmpMatchIndex := -1; + tmpSearchText := trim(IndexSearchEdit.Text); + + for i := 0 to DisplayedIndex.Count - 1 do + begin + if StrStartsWithIgnoringCase(DisplayedIndex[i], tmpSearchText) then + begin + tmpMatchIndex := i; + break; + end; + end; + + if tmpMatchIndex = -1 then + exit; + + InIndexSearch:= true; + + + if lbIndex.FocusItem <> tmpMatchIndex then + lbIndex.FocusItem := tmpMatchIndex; + + InIndexSearch:= false; +end; + +procedure TMainForm.DisplaySelectedSearchResultTopic; +var + Topic: TTopic; +begin + if lbSearchResults.FocusItem = -1 then + exit; + if lbSearchResults.Items.Objects[lbSearchResults.FocusItem] = nil then + // the "no results" place holder + exit; + Topic := lbSearchResults.Items.Objects[lbSearchResults.FocusItem] as TTopic; + DisplayTopic( Topic ); +end; + +procedure TMainForm.UpdateLocationPanel; +var + i: integer; + s: string; + n: TfpgTreeNode; + sep: string; +begin + s := ''; + sep := ''; + n := tvContents.Selection; + while n.Parent <> nil do + begin + s := n.Parent.Text + sep + s; + n := n.Parent; + sep := ' > '; + end; + SetStatus(s); +end; + +procedure TMainForm.EnableControls; +begin + // +end; + +procedure TMainForm.ClearAllWordSequences; +var + i: longint; + FileWordSequences: TList; + HelpFile: THelpFile; +begin + if AllFilesWordSequences = nil then + exit; + + for i := 0 to AllFilesWordSequences.Count - 1 do + begin + FileWordSequences := TList(AllFilesWordSequences[ i ]); + HelpFile := THelpFile(CurrentOpenFiles[ i ]); + ClearWordSequences( FileWordSequences, HelpFile.DictionaryCount ); + FileWordSequences.Free; + end; + AllFilesWordSequences.Clear; +end; + +procedure TMainForm.DoSearch; +var + SearchResults: TList; + SearchText: string; + FileIndex: longint; + HelpFile: THelpFile; + TopicIndex: longint; + Topic: TTopic; + FileWordSequences: TList; + Query: TTextSearchQuery; +begin + SearchText := Trim(edSearchText.Text); + lbSearchResults.Items.Clear; + + if SearchText = '' then + exit; + + lbSearchResults.Items.Add(rsDVSearchingMsg); + SetStatus(rsDVSearchingMsg); + + try + Query := TTextSearchQuery.Create( SearchText ); + except + on e: ESearchSyntaxError do + begin + TfpgMessageDialog.Critical( rsSearch, rsDVSearchSyntaxError + e.Message ); + exit; + end; + end; + + ClearAllWordSequences; + + SetWaitCursor; + + SearchResults := TList.Create; + + // Search open help file + for FileIndex := 0 to CurrentOpenFiles.Count - 1 do + begin + HelpFile := THelpFile(CurrentOpenFiles[ FileIndex ]); + FileWordSequences := TList.Create; + try + SearchHelpFile( HelpFile, + Query, + SearchResults, + FileWordSequences ); + except + on E: EHelpFileException do + begin + TfpgMessageDialog.Critical(rsError , E.Message); + Query.Destroy; + ClearWaitCursor; + exit; + end; + end; + + AllFilesWordSequences.Add( FileWordSequences ); + end; + + // Sort results across all files by relevance + SearchResults.Sort( @TopicRelevanceCompare ); + + // Load topics into search results list. + lbSearchResults.Items.BeginUpdate; + lbSearchResults.Items.Clear; + + for TopicIndex := 0 to SearchResults.Count - 1 do + begin + Topic := TTopic(SearchResults[ TopicIndex ]); + lbSearchResults.Items.AddObject( Topic.Title + + ' [' + + IntToStr( Topic.SearchRelevance ) + + ']', + Topic ); + end; + + EnableControls; +// if lbSearchResults.Items.Count > 0 then + // there are some search matches, so highlight words +// ViewHighlightSearchWordsMI.Checked := true; + + lbSearchResults.FocusItem := -1; + lbSearchResults.Items.EndUpdate; + + Query.Free; + SearchResults.Free; + + if lbSearchResults.Items.Count > 0 then + begin + lbSearchResults.FocusItem := 0; + end + else + begin + lbSearchResults.Items.Add( Format(rsDVNoMatchesFound, [SearchText])); +// RefreshWindows( Windows ); // update to remove old highlights + end; + SetStatus( Format(rsDVSearchFoundMsg, [lbSearchResults.Items.Count]) + + StrInDoubleQuotes(SearchText)); + + ClearWaitCursor; + DisplaySelectedSearchResultTopic; +end; + +procedure TMainForm.SetWaitCursor; +begin + // +end; + +procedure TMainForm.ClearWaitCursor; +begin + // +end; + +procedure TMainForm.SetMainCaption; +begin + WindowTitle:= MainTitle; + fpgApplication.ProcessMessages; +end; + +procedure TMainForm.DisplayFiles(NewFiles: TList; var FirstContentsNode: TfpgTreeNode); +var + HelpFile: THelpFile; + FileIndex: longint; +begin + LogEvent(LogStartup, 'DisplayFiles' ); + // Now load the various parts of the file(s) + // into the user interface + ProgressBar.Position := 52; + SetStatus( rsDVDisplaying ); + + // Add our open files in the global filelist + { TODO -ograeme : implement global filelist support } + //for FileIndex := 0 to NewFiles.Count - 1 do + //begin + // HelpFile := NewFiles[ FileIndex ]; + // GlobalFilelist.AddFile( HelpFile.Filename, Frame.Handle ); + // // LoadNotes( HelpFile ); + // LoadBookmarks( HelpFile ); + //end; + + { TODO -ograeme : update notes display } + //UpdateNotesDisplay; + + { TODO -ograeme : bookmarks } + //BuildBookmarksMenu; + //UpdateBookmarksForm; + + ProgressBar.Position := 55; + + ContentsLoaded := false; + IndexLoaded := false; + + LoadContents( NewFiles, FirstContentsNode ); + + ProgressBar.Position := 75; + + LoadIndex; + + ProgressBar.Position := 100; + SetStatus( rsDVDone ); + + LogEvent(LogStartup, 'DisplayFiles Done' ); +end; + +procedure TMainForm.FileOpen; +var + dlg: TfpgFileDialog; +begin + dlg := TfpgFileDialog.Create(nil); + try + dlg.InitialDir := Settings.LastOpenDirectory; + dlg.WindowTitle := rsDVOpenHelpFile; + dlg.Filter := rsDVHelpFiles + ' (*.hlp, *.inf)|*.inf;*.hlp '; + // and a catch all filter + dlg.Filter := dlg.Filter + '|(' + rsAllFiles + ' (*)|*'; + + if dlg.RunOpenFile then + begin + mru.AddItem(dlg.Filename); + Settings.LastOpenDirectory := ExtractFilePath(dlg.Filename); + OpenFile(dlg.Filename, '', true); + end; + { TODO -oGraeme : Add support for multiple files. } + finally + dlg.Free; + end; +end; + +function TMainForm.LoadFiles(const aFileNames: TStrings; aHelpFiles: TList): boolean; +var + HelpFile: THelpFile; + FileIndex, i: longint; + FileName: string; + FullFilePath: string; +begin + LogEvent(LogStartup, 'LoadFiles' ); + LoadingFilenameList := TStringList.Create; + +// RBRi TranslateIPFEnvironmentVars( FileNames, LoadingFilenameList ); + for i := 0 to aFileNames.Count - 1 do + LoadingFilenameList.Add(aFileNames[i]); + + LogEvent(LogStartup, 'Finding files' ); + ProgressBar.Visible := True; + + // now find full file paths, + // and also the total file size for progress display + for FileIndex := 0 to LoadingFilenameList.Count - 1 do + begin + FileName := LoadingFilenameList[ FileIndex ]; + LogEvent(LogStartup, ' File: ' + FileName ); + + // Find the help file, if possible + if Filename = OWN_HELP_MARKER then + begin + FullFilePath := GetOwnHelpFileName; + end + else + begin + FullFilePath := FindHelpFile( Filename ); + end; + + if FullFilePath <> '' then + begin + LogEvent(LogStartup, ' Full path: ' + FullFilePath ); + end + else + begin + LogEvent(LogStartup, ' File not found' ); + FullFilePath := FileName; // we'll complain later. + end; + LoadingFilenameList[ FileIndex ] := FullFilePath; + end; + + // Now actually load the files + for FileIndex := 0 to LoadingFilenameList.Count - 1 do + begin + Filename := LoadingFilenameList[ FileIndex ]; + mru.AddItem(FileName); + LogEvent(LogStartup, ' Loading: ' + Filename ); + try + LoadingFileIndex := FileIndex; + + // load the file + HelpFile := THelpFile.Create( FileName ); + if Settings.FixedFontSubstitution then + HelpFile.SetupFontSubstitutes( Settings.FixedFontSubstitutes ); + + aHelpFiles.Add( HelpFile ); + + except + on E: Exception do + begin + + if E is EWindowsHelpFormatException then + begin + { TODO -ograeme -cnice to have : Implement opening Windows help } + //OpenWindowsHelp( Filename ); + end + else + begin + TfpgMessageDialog.Critical( rsDVOpenHelpFile, + Format(rsDVCouldNotOpen, [Filename]) + + ': ' + + E.Message ); + end; + + // back out of the load process + Result := false; + + DestroyListObjects( aHelpFiles ); + + LoadingFilenameList.Free; + ResetProgress; + exit; + end + end; + end; + + LoadingFilenameList.Free; + Result := true; +end; + +{ Open the file or list of files in FileNames + Set the window title if given, otherwise get it from first file } +function TMainForm.OpenFiles(const FileNames: TStrings; + const AWindowTitle: string; const DisplayFirstTopic: boolean): boolean; +var + tmpHelpFiles: TList; + FirstContentsNode: TfpgTreeNode; +begin + LogEvent(LogStartup, 'OpenFiles' ); + + //if not OKToCloseFile then + // exit; + + SetWaitCursor; + tmpHelpFiles := TList.Create; + +// RBRi Translate + if not LoadFiles(FileNames, tmpHelpFiles) then + begin + ClearWaitCursor; + tmpHelpFiles.Free; + exit; + end; + + Result := true; + + lbSearchResults.Items.Clear; + { TODO : page history support } +// PageHistory.Clear; +// CurrentHistoryIndex := -1; + + // Now that we have successfully loaded the new help file(s) + // close the existing one. + CloseFile; + + AssignList(tmpHelpFiles, CurrentOpenFiles ); + + ProgressBar.Position := 50; + SetStatus( rsDVDisplaying ); + +// AddCurrentToMRUFiles; + + if AWindowTitle = '' then + MainTitle := THelpFile( CurrentOpenFiles[ 0 ] ).Title + else + MainTitle := AWindowTitle; + SetMainCaption; + + // Now load the various parts of the file(s) + // into the user interface + tvContents.RootNode.Clear; + + DisplayFiles( tmpHelpFiles, FirstContentsNode ); + + //if CmdLineParameters.getHelpManagerFlag then + // ShowLeftPanel := Settings.ShowLeftPanel_Help + //else + // ShowLeftPanel := Settings.ShowLeftPanel_Standalone; + + // Select first contents node if there is one + if FirstContentsNode <> nil then + begin + LogEvent(LogStartup, ' Select first node' ); + tvContents.Selection := FirstContentsNode; + tvContents.SetFocus; + end; + + ClearWaitCursor; + + ResetProgress; + +// NotebookOnPageChanged( self ); // ensure e.g. index loaded + + EnableControls; + + if DisplayFirstTopic then + begin + LogEvent(LogStartup, 'Display first topic' ); + { TODO -oGraeme : Improved Display Topic method } +// DisplaySelectedContentsTopic; + DisplayTopic(nil); + end; + + LogEvent(LogStartup, 'OpenFiles complete' ); +end; + +{ Open a single file } +function TMainForm.OpenFile(const AFileName: string; const AWindowTitle: string; + const DisplayFirstTopic: boolean): boolean; +var + tmpFileNames: TStringList; +begin + tmpFileNames := TStringList.Create; + ParseAndExpandFileNames(AFileName, tmpFileNames); + Result := OpenFiles( tmpFileNames, AWindowTitle, DisplayFirstTopic ); + tmpFileNames.Free; +end; + +procedure TMainForm.CloseFile(const ADestroying: boolean = False); +var + FileIndex: longint; + lHelpFile: THelpFile; +begin + tvContents.Selection := nil; + tvContents.RootNode.Clear; + RichView.Clear(ADestroying); + if not ADestroying then + begin + WindowTitle := rsDVTitle + ' - ' + rsDVNoFile; + tvContents.Invalidate; + end; + + // First save notes. It's important we do this first + // since we scan all notes each time to find the ones + // belonging to this file. + for FileIndex := 0 to Files.Count - 1 do + begin + lHelpFile := THelpFile(Files[FileIndex]); + SaveNotes( lHelpFile ); + end; + + DisplayedIndex.Clear; + + // Now destroy help files + for FileIndex := 0 to Files.Count - 1 do + begin + lHelpFile := THelpFile(Files[FileIndex]); + lHelpFile.Free; + end; + + Files.Clear; + ClearNotes; +end; + +procedure TMainForm.OnHelpFileLoadProgress(n, outof: integer; AMessage: string); +begin + // +end; + +procedure TMainForm.LoadNotes(AHelpFile: THelpFile); +begin +// NotesFileName:= ChangeFileExt( HelpFile.FileName, '.nte' ); + +end; + +procedure TMainForm.LoadContents(AFiles: TList; var FirstNode: TfpgTreeNode); +var + FileIndex: integer; + HelpFile: THelpFile; + TopicIndex: integer; + Node: TfpgTreeNode; + Topic: TTopic; +begin + LogEvent(LogStartup, 'Load contents outline'); + // we don't clear treeview here in case we need to load more files later. + LogEvent(LogStartup, 'Loop files'); + + FirstNode := nil; + Node := nil; + + for FileIndex:= 0 to AFiles.Count - 1 do + begin + HelpFile:= THelpFile(AFiles[ FileIndex ]); + ProfileEvent( 'File ' + IntToStr( FileIndex ) ); + TopicIndex:= 0; + ProfileEvent('TopicCount=' + IntToStr(HelpFile.TopicCount)); + while TopicIndex < HelpFile.TopicCount do + begin + Topic := HelpFile.Topics[ TopicIndex ]; + if Topic.ShowInContents then + begin + if Topic.ContentsLevel = 1 then + begin + Node := tvContents.RootNode.AppendText(Topic.Title); + Node.Data := Topic; + if FirstNode = nil then + FirstNode := Node; + inc( TopicIndex ); + end + else + begin + // child nodes + AddChildNodes( HelpFile, + Node, + Topic.ContentsLevel, + TopicIndex ); + Node := nil; + end; + end + else + begin + inc( TopicIndex ); + end; + end; + end; + LogEvent(LogStartup, ' EndUpdate' ); + + if Settings.OpenWithExpandedContents then + begin + LogEvent(LogStartup, ' Expand all contents' ); + tvContents.RootNode.Expand; + node := tvContents.RootNode.Next; + while node <> nil do + begin + node.Expand; + node := tvContents.RootNode.Next; + end; + end + else + begin + LogEvent(LogStartup, ' Expand first node' ); + // Contents has only one top level node... expand it + FirstNode.Expand; + end; + + ContentsLoaded := true; + tvContents.Invalidate; + LogEvent(LogStartup, ' Contents loaded' ); +end; + +// Gets the contents from each file. Sorts it alphabetically. +// Merges all the sorted contents and indexes together, alphabetically. +procedure TMainForm.LoadIndex; +var + tmpHelpFile: THelpFile; + tmpTextCompareResult: integer; + FileIndex: longint; + Contents: TList; + ContentsLists: TList; // of tlist + tmpIndexLists: TList; // of tstringlist + ContentsNextIndex: array[ 0..255 ] of longint; + IndexNextIndex: array[ 0..255 ] of longint; + Topic: TTopic; + ListEntry: string; + LowestEntry: string; + LastEntry: string; + tmpLowestEntryListIndex: longint; + tmpLowestEntryListType: TListType; + tmpLowestEntryTopic: TTopic; + tmpIndex: TStringList; + i: longint; +begin + LogEvent(LogStartup, 'Create index' ); + SetWaitCursor; + LogEvent(LogStartup, ' Get/sort lists' ); + + ProgressBar.Position := 70; + SetStatus( 'Building index... ' ); + + ContentsLists := TList.Create; + tmpIndexLists := TList.Create; + + // collect the contents and index lists from the files + for FileIndex := 0 to CurrentOpenFiles.Count - 1 do + begin + tmpHelpFile := THelpFile(CurrentOpenFiles[ FileIndex ]); + ProgressBar.Position := 70 + 10 * FileIndex div CurrentOpenFiles.Count; + + if Settings.IndexStyle in [ isAlphabetical, isFull ] then + begin + Contents := TList.Create; + Contents.Capacity := tmpHelpFile.TopicCount; // speeds up inserts + // copy [contents] topic list + for i := 0 to tmpHelpFile.TopicCount - 1 do + begin + Topic := tmpHelpFile.Topics[ i ]; + if Topic.ShowInContents then + Contents.Add( Topic ); + end; + // sort by title + Contents.Sort( @TopicTitleCompare ); + ContentsLists.Add( Contents ); + // initialise list index + ContentsNextIndex[ ContentsLists.Count - 1 ] := 0; + end; + + if Settings.IndexStyle in [ isFileOnly, isFull ] then + begin + tmpIndexLists.Add(tmpHelpFile.Index.GetLabels); + IndexNextIndex[ tmpIndexLists.Count - 1 ] := 0; + end; + end; + + // Unlike contents, we do clear the index (even if we are adding more files) + // because we need to re-merge the whole thing + DisplayedIndex.Clear; + ProgressBar.Position := 80; + + LogEvent(LogStartup, ' Merge lists' ); + LastEntry := ''; + while true do + begin + LowestEntry := ''; + tmpLowestEntryListIndex := -1; + // Find alphabetically lowest (remaining) topic + // first, look in contents lists + LogEvent(LogDebug, ' Merge contents' ); + for i := 0 to ContentsLists.Count - 1 do + begin + Contents := TList(ContentsLists.Items[i]); + if ContentsNextIndex[i] < Contents.Count then + begin + // list is not yet finished, get next entry + Topic := TTopic(Contents[ ContentsNextIndex[i] ]); + ListEntry := Topic.Title; + + if LowestEntry <> '' then + tmpTextCompareResult := CompareText( ListEntry, LowestEntry ) + else + tmpTextCompareResult := -1; + + if tmpTextCompareResult < 0 then + begin + // this index entry comes before the lowest one so far + LowestEntry := ListEntry; + tmpLowestEntryListIndex := i; + tmpLowestEntryListType := ltContents; + tmpLowestEntryTopic := Topic; + end; + end; + end; + + // look in indices + LogEvent(LogDebug, ' Merge indices' ); + for i := 0 to tmpIndexLists.Count - 1 do + begin + LogEvent(LogDebug, ' Merge indices ' + IntToStr(i) ); + tmpIndex := TStringList(tmpIndexLists.Items[i]); + if IndexNextIndex[i] < tmpIndex.Count then + begin + // list is not yet finished, get next entry + ListEntry := tmpIndex.Strings[ IndexNextIndex[i] ]; + LogEvent(LogDebug, ' indices ListEntry=' + ListEntry ); + if LowestEntry <> '' then + tmpTextCompareResult := CompareText( ListEntry, LowestEntry ) + else + tmpTextCompareResult := -1; + + if tmpTextCompareResult < 0 then + begin + // this index entry comes before the lowest one so far + LowestEntry := ListEntry; + tmpLowestEntryListIndex := i; + tmpLowestEntryListType := ltIndex; + + LogEvent(LogDebug, ' Merge indices ' + tmpIndex.Objects[ IndexNextIndex[i] ].ClassName); + tmpLowestEntryTopic := TIndexEntry( tmpIndex.Objects[ IndexNextIndex[i] ] ).getTopic; + end; + end; + end; + + if tmpLowestEntryListIndex = -1 then + // we're out + break; + + if LowestEntry <> LastEntry then + // add, if different from last + DisplayedIndex.AddObject( LowestEntry, tmpLowestEntryTopic ); + LastEntry := LowestEntry; + + if tmpLowestEntryListType = ltContents then + begin + inc( ContentsNextIndex[ tmpLowestEntryListIndex ] ); + end + else + begin + // found in one of indices. + // Check for subsequent indented strings + tmpIndex := TStringList(tmpIndexLists[ tmpLowestEntryListIndex ]); + + i := IndexNextIndex[ tmpLowestEntryListIndex ] + 1; + while i < tmpIndex.Count do + begin + ListEntry := tmpIndex.Strings[ i ]; + if ListEntry = '' then + break; + + if ListEntry[ 1 ] <> ' ' then + // not indented, stop looking + break; + + // found one, + Topic := TIndexEntry(tmpIndex.Objects[ i ]).getTopic; + DisplayedIndex.AddObject( ListEntry, Topic ); + inc( i ); + end; + IndexNextIndex[ tmpLowestEntryListIndex ] := i; + end; + end; + + ProgressBar.Position := 95; + LogEvent(LogStartup, ' Display index (count = ' + IntToStr(DisplayedIndex.Count) + ')'); + + // Now display the final index list + lbIndex.Items.Assign( DisplayedIndex ); + + LogEvent(LogStartup, ' Tidy up' ); + tmpIndexLists.Free; + DestroyListAndObjects( ContentsLists ); + IndexLoaded := true; + + ClearWaitCursor; + + SetStatus( 'Index loaded' ); + LogEvent(LogStartup, ' Done' ); +end; + +procedure TMainForm.AddChildNodes(AHelpFile: THelpFile; AParentNode: TfpgTreeNode; + ALevel: longint; var ATopicIndex: longint); +var + Topic: TTopic; + Node: TfpgTreeNode; +begin + Node := nil; + while ATopicIndex < AHelpFile.TopicCount do + begin + Topic := AHelpFile.Topics[ ATopicIndex ]; + if Topic.ShowInContents then + begin + if Topic.ContentsLevel < ALevel then + break; + + if Topic.ContentsLevel = ALevel then + begin + Node := AParentNode.AppendText(Topic.Title); + Node.Data := Topic; + inc( ATopicIndex ); + end + else + begin + AddChildNodes( AHelpFile, + Node, + Topic.ContentsLevel, + ATopicIndex ); + Node := nil; + end + end + else + begin + inc( ATopicIndex ); + end; + end; { while } +end; + +procedure TMainForm.ClearNotes; +begin + { TODO -oGraeme : Implement me } +end; + +procedure TMainForm.SaveNotes(AHelpFile: THelpFile); +begin + { TODO -oGraeme : Implement me } +end; + +procedure TMainForm.DisplayTopic(ATopic: TTopic); +var + lText: String; + ImageIndices: TList; + LinkIndex: longint; + Link: THelpLink; + HelpFile: THelpFile; + Topic: TTopic; + HighlightWordSequences: TList; + FileIndex: integer; +Begin + ProfileEvent('DisplayTopic >>>>'); + if ATopic = nil then + begin + case PageControl1.ActivePageIndex of + 0: begin // TOC tab + if tvContents.Selection = nil then + begin + ShowMessage('You must select a topic first by clicking it.'); + Exit; //==> + end + else + Topic := TTopic(tvContents.Selection.Data); + ProfileEvent('Got Topic from Treeview'); + end; + 1: begin // Index tab + if lbIndex.FocusItem = -1 then + begin + ShowMessage('You must select a index first by clicking it.'); + Exit; //==> + end + else + Topic := TTopic(lbIndex.Items.Objects[lbIndex.FocusItem]); + ProfileEvent('Got Topic from Index listbox'); + end; + 2: begin // Search tab + if lbSearchResults.FocusItem = -1 then + begin + ShowMessage('You must select a search result first by clicking it.'); + Exit; //==> + end + else + Topic := TTopic(lbSearchResults.Items.Objects[lbSearchResults.FocusItem]); + ProfileEvent('Got Topic from Search Results listbox'); + end; + end; + end // case.. + else + Topic := ATopic; // use topic passed in as a parameter + + if Topic = nil then + raise Exception.Create('Unable to locate the Topic'); + + CurrentTopic:= Topic; + + RichView.Clear; + ImageIndices := TList.Create; + ProfileEvent('Cleared memo...'); + + HelpFile := TopicFile(CurrentTopic); + if HelpFile = nil then + raise Exception.Create('Failed to get active HelpFile from Topic'); + + if HelpFile.HighlightWords <> nil then + ProfileEvent('highlightwords is ok'); + + if (AllFilesWordSequences.Count > 0) // ie we have done a search... + {and ViewHighlightSearchWordsMI.Checked} then + begin + FileIndex := CurrentOpenFiles.IndexOf( HelpFile ); + HighlightWordSequences := TList(AllFilesWordSequences[ FileIndex ]); + end + else + HighlightWordSequences := nil; + + lText := ''; + ProfileEvent('Debug show hex values = ' + BoolToStr(Debug)); + if ImageIndices <> nil then + ProfileEvent('ImageIndices initialized'); + + CurrentTopic.GetText( HighlightWordSequences, + Debug {ShowCodes}, + False {ShowWordIndices}, + lText {TopicText}, + ImageIndices, + nil {Highlights} ); + + { TODO -oGraeme : We do not support images yet } + ImageIndices.Free; + + //writeln(lText); + //writeln('-----------------------------'); + RichView.AddText(PChar(lText)); + + tvContents.Selection := tvContents.RootNode.FindSubNode(CurrentTopic, True); + tvContents.Invalidate; + UpdateLocationPanel; +end; + +procedure TMainForm.ResetProgress; +begin + { TODO -oGraeme : implement ResetProgress } + ProgressBar.Visible := False; + ProgressBar.Position := 0; +end; + +procedure TMainForm.SetStatus(const AText: TfpgString); +begin + lblStatus.Text := AText; +end; + +function TMainForm.TranslateEnvironmentVar(AFilenames: TfpgString): TfpgString; +var + EnvironmentVarValue: string; +begin + EnvironmentVarValue := GetEnvironmentVariable(UpperCase(AFilenames)); + if EnvironmentVarValue <> '' then + Result := EnvironmentVarValue + else + Result := AFileNames; +end; + +constructor TMainForm.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + fpgApplication.OnException := @MainFormException; + OnShow := @MainFormShow; + OnDestroy :=@MainFormDestroy; + Files := TList.Create; + AllFilesWordSequences := TList.Create; + CurrentOpenFiles := TList.Create; + DisplayedIndex := TStringList.Create; + { TODO -oGraeme : Make Debug a menu option } + Debug := False; +end; + +destructor TMainForm.Destroy; +var + FileIndex: integer; + lHelpFile: THelpFile; +begin +writeln('DEBUG: TMainForm.Destroy >>>>'); + CurrentTopic := nil; // it was a reference only + FFileOpenRecent := nil; // it was a reference only + DestroyListAndObjects(Files); + DestroyListAndObjects(AllFilesWordSequences); + DestroyListAndObjects(CurrentOpenFiles); +writeln('DEBUG: TMainForm.Destroy 1'); + inherited Destroy; +writeln('DEBUG: TMainForm.Destroy <<<<'); +end; + +procedure TMainForm.AfterCreate; +begin + {%region 'Auto-generated GUI code' -fold} + {@VFD_BODY_BEGIN: MainForm} + Name := 'MainForm'; + SetPosition(602, 274, 654, 386); + WindowTitle := 'fpGUI Documentation Viewer'; + WindowPosition := wpUser; + OnCloseQuery := @MainFormCloseQuery; + + bvlStatusBar := TfpgBevel.Create(self); + with bvlStatusBar do + begin + Name := 'bvlStatusBar'; + SetPosition(0, 366, 653, 20); + Anchors := [anLeft,anRight,anBottom]; + Style := bsLowered; + end; + + ProgressBar := TfpgProgressBar.Create(bvlStatusBar); + with ProgressBar do + begin + Name := 'ProgressBar'; + SetPosition(501, 2, 150, 16); + Anchors := [anRight,anBottom]; + end; + + lblStatus := TfpgLabel.Create(bvlStatusBar); + with lblStatus do + begin + Name := 'lblStatus'; + SetPosition(4, 2, 380, 16); + Anchors := [anLeft,anRight,anBottom]; + FontDesc := '#Label1'; + Hint := ''; + Text := ''; + end; + + bvlBody := TfpgBevel.Create(self); + with bvlBody do + begin + Name := 'bvlBody'; + SetPosition(0, 25, 653, 340); + Anchors := [anLeft,anRight,anTop,anBottom]; + Shape := bsSpacer; + end; + + PageControl1 := TfpgPageControl.Create(bvlBody); + with PageControl1 do + begin + Name := 'PageControl1'; + SetPosition(0, 12, 260, 316); + ActivePageIndex := 4; + TabOrder := 0; + Align := alLeft; + OnChange := @PageControl1Change; + end; + + tsContents := TfpgTabSheet.Create(PageControl1); + with tsContents do + begin + Name := 'tsContents'; + SetPosition(3, 24, 254, 301); + Text := 'Contents'; + end; + + tvContents := TfpgTreeView.Create(tsContents); + with tvContents do + begin + Name := 'tvContents'; + SetPosition(4, 32, 242, 264); + Anchors := [anLeft,anRight,anTop,anBottom]; + FontDesc := '#Label1'; + ScrollWheelDelta := 60; + ShowImages := True; + TabOrder := 0; + OnChange := @tvContentsChange; + //OnDoubleClick := @tvContentsDoubleClick; + end; + + btnGo := TfpgButton.Create(tsContents); + with btnGo do + begin + Name := 'btnGo'; + SetPosition(166, 4, 80, 24); + Anchors := [anRight,anTop]; + Text := 'Go to'; + FontDesc := '#Label1'; + Hint := ''; + ImageName := ''; + TabOrder := 1; + OnClick := @btnGoClicked; + end; + + tsIndex := TfpgTabSheet.Create(PageControl1); + with tsIndex do + begin + Name := 'tsIndex'; + SetPosition(3, 24, 254, 301); + Text := 'Index'; + end; + + btnIndex := TfpgButton.Create(tsIndex); + with btnIndex do + begin + Name := 'btnIndex'; + SetPosition(166, 4, 80, 24); + Anchors := [anRight,anTop]; + Text := 'Go to'; + FontDesc := '#Label1'; + Hint := ''; + ImageName := ''; + TabOrder := 1; + OnClick := @btnShowIndex; + end; + + lbIndex := TfpgListBox.Create(tsIndex); + with lbIndex do + begin + Name := 'lbIndex'; + SetPosition(4, 32, 242, 264); + Anchors := [anLeft,anRight,anTop,anBottom]; + FontDesc := '#List'; + HotTrack := False; + PopupFrame := False; + TabOrder := 1; + OnDoubleClick := @lbIndexDoubleClick; + end; + + IndexSearchEdit := TfpgEdit.Create(tsIndex); + with IndexSearchEdit do + begin + Name := 'IndexSearchEdit'; + SetPosition(4, 4, 152, 24); + Anchors := [anLeft,anRight,anTop]; + TabOrder := 2; + Text := ''; + FontDesc := '#Edit1'; + OnChange := @IndexSearchEditOnChange; + OnKeyPress :=@IndexSearchEditKeyPress; + end; + + tsSearch := TfpgTabSheet.Create(PageControl1); + with tsSearch do + begin + Name := 'tsSearch'; + SetPosition(3, 24, 254, 301); + Text := 'Search'; + end; + + Label1 := TfpgLabel.Create(tsSearch); + with Label1 do + begin + Name := 'Label1'; + SetPosition(4, 4, 120, 16); + FontDesc := '#Label1'; + Hint := ''; + Text := 'Search for:'; + end; + + edSearchText := TfpgEdit.Create(tsSearch); + with edSearchText do + begin + Name := 'edSearchText'; + SetPosition(4, 20, 210, 26); + Anchors := [anLeft,anRight,anTop]; + TabOrder := 1; + Text := ''; + FontDesc := '#Edit1'; + OnKeyPress :=@edSearchTextKeyPress; + end; + + Label2 := TfpgLabel.Create(tsSearch); + with Label2 do + begin + Name := 'Label2'; + SetPosition(4, 48, 172, 16); + FontDesc := '#Label1'; + Hint := ''; + Text := 'Criteria:'; + end; + + RadioButton1 := TfpgRadioButton.Create(tsSearch); + with RadioButton1 do + begin + Name := 'RadioButton1'; + SetPosition(12, 68, 192, 20); + FontDesc := '#Label1'; + GroupIndex := 0; + TabOrder := 3; + Text := 'This section'; + Enabled := False; + end; + + RadioButton2 := TfpgRadioButton.Create(tsSearch); + with RadioButton2 do + begin + Name := 'RadioButton2'; + SetPosition(12, 88, 192, 20); + FontDesc := '#Label1'; + GroupIndex := 0; + TabOrder := 4; + Text := 'Marked sections'; + Enabled := False; + end; + + RadioButton3 := TfpgRadioButton.Create(tsSearch); + with RadioButton3 do + begin + Name := 'RadioButton3'; + SetPosition(12, 108, 192, 20); + Checked := True; + FontDesc := '#Label1'; + GroupIndex := 0; + TabOrder := 5; + Text := 'All sections'; + Enabled := False; + end; + + RadioButton4 := TfpgRadioButton.Create(tsSearch); + with RadioButton4 do + begin + Name := 'RadioButton4'; + SetPosition(12, 128, 192, 20); + FontDesc := '#Label1'; + GroupIndex := 0; + TabOrder := 6; + Text := 'Index'; + Enabled := False; + end; + + RadioButton5 := TfpgRadioButton.Create(tsSearch); + with RadioButton5 do + begin + Name := 'RadioButton5'; + SetPosition(12, 148, 192, 20); + FontDesc := '#Label1'; + GroupIndex := 0; + TabOrder := 7; + Text := 'Marked libraries'; + Enabled := False; + end; + + RadioButton6 := TfpgRadioButton.Create(tsSearch); + with RadioButton6 do + begin + Name := 'RadioButton6'; + SetPosition(12, 168, 192, 20); + FontDesc := '#Label1'; + GroupIndex := 0; + TabOrder := 8; + Text := 'All libraries'; + Enabled := False; + end; + + lbSearchResults := TfpgListBox.Create(tsSearch); + with lbSearchResults do + begin + Name := 'lbSearchResults'; + SetPosition(4, 220, 242, 76); + Anchors := [anLeft,anRight,anTop,anBottom]; + FontDesc := '#List'; + HotTrack := False; + PopupFrame := False; + TabOrder := 9; + OnDoubleClick := @lbSearchResultsDoubleClick; + OnKeyPress := @lbSearchResultsKeyPress; + end; + + Label3 := TfpgLabel.Create(tsSearch); + with Label3 do + begin + Name := 'Label3'; + SetPosition(4, 200, 196, 16); + FontDesc := '#Label1'; + Hint := ''; + Text := 'Search results:'; + end; + + btnSearch := TfpgButton.Create(tsSearch); + with btnSearch do + begin + Name := 'btnSearch'; + SetPosition(220, 20, 28, 26); + Anchors := [anRight,anTop]; + Text := 'Go'; + FontDesc := '#Label1'; + Hint := ''; + ImageName := ''; + TabOrder := 11; + OnClick := @btnSearchClicked; + end; + + tsNotes := TfpgTabSheet.Create(PageControl1); + with tsNotes do + begin + Name := 'tsNotes'; + SetPosition(3, 24, 254, 289); + Text := 'Notes'; + end; + + ListBox1 := TfpgListBox.Create(tsNotes); + with ListBox1 do + begin + Name := 'ListBox1'; + SetPosition(4, 32, 242, 252); + Anchors := [anLeft,anRight,anTop,anBottom]; + FontDesc := '#List'; + HotTrack := False; + PopupFrame := False; + TabOrder := 0; + end; + + btnNotesAdd := TfpgButton.Create(tsNotes); + with btnNotesAdd do + begin + Name := 'btnNotesAdd'; + SetPosition(4, 4, 24, 24); + Text := ''; + FontDesc := '#Label1'; + Hint := ''; + ImageMargin := 0; + ImageName := 'stdimg.add'; + TabOrder := 1; + end; + + btnNotesEdit := TfpgButton.Create(tsNotes); + with btnNotesEdit do + begin + Name := 'btnNotesEdit'; + SetPosition(32, 4, 24, 24); + Text := ''; + FontDesc := '#Label1'; + Hint := ''; + ImageMargin := 0; + ImageName := 'stdimg.edit'; + TabOrder := 2; + end; + + btnNotesDel := TfpgButton.Create(tsNotes); + with btnNotesDel do + begin + Name := 'btnNotesDel'; + SetPosition(60, 4, 24, 24); + Text := ''; + FontDesc := '#Label1'; + Hint := ''; + ImageMargin := 0; + ImageName := 'stdimg.remove'; + TabOrder := 3; + end; + + btnNotesGoto := TfpgButton.Create(tsNotes); + with btnNotesGoto do + begin + Name := 'btnNotesGoto'; + SetPosition(166, 4, 80, 24); + Anchors := [anRight,anTop]; + Text := 'Go to'; + FontDesc := '#Label1'; + Hint := ''; + ImageName := ''; + TabOrder := 4; + end; + + tsHistory := TfpgTabSheet.Create(PageControl1); + with tsHistory do + begin + Name := 'tsHistory'; + SetPosition(3, 24, 254, 289); + Text := 'History'; + end; + + lbHistory := TfpgListBox.Create(tsHistory); + with lbHistory do + begin + Name := 'lbHistory'; + SetPosition(4, 8, 242, 276); + Anchors := [anLeft,anRight,anTop,anBottom]; + FontDesc := '#List'; + HotTrack := False; + PopupFrame := False; + TabOrder := 0; + end; + + Splitter1 := TfpgSplitter.Create(bvlBody); + with Splitter1 do + begin + Name := 'Splitter1'; + SetPosition(265, 4, 8, 284); + Align := alLeft; + end; + + RichView := TRichTextView.Create(bvlBody); + with RichView do + begin + Name := 'RichView'; + SetPosition(368, 192, 244, 92); + TabOrder := 2; + Align := alClient; + OnClickLink:=@RichViewClickLink; + end; + + MainMenu := TfpgMenuBar.Create(self); + with MainMenu do + begin + Name := 'MainMenu'; + SetPosition(0, 0, 654, 24); + Anchors := [anLeft,anRight,anTop]; + end; + + miFile := TfpgPopupMenu.Create(self); + with miFile do + begin + Name := 'miFile'; + SetPosition(292, 28, 132, 20); + AddMenuItem('Open...', '', @miFileOpenClicked); + AddMenuItem('Save current Topic to IPF...', '', @miFileSaveTopicAsIPF); + AddMenuItem('Close', '', @miFileCloseClicked); + AddMenuitem('-', '', nil); + FFileOpenRecent := AddMenuItem('Open Recent...', '', nil); + AddMenuitem('-', '', nil); + AddMenuItem('Quit', '', @miFileQuitClicked); + end; + + miSettings := TfpgPopupMenu.Create(self); + with miSettings do + begin + Name := 'miSettings'; + SetPosition(292, 76, 132, 20); + AddMenuItem('Options...', '', nil); + end; + + miBookmarks := TfpgPopupMenu.Create(self); + with miBookmarks do + begin + Name := 'miBookmarks'; + SetPosition(292, 100, 132, 20); + AddMenuItem('Add..', '', nil); + AddMenuItem('Show', '', nil); + end; + + miHelp := TfpgPopupMenu.Create(self); + with miHelp do + begin + Name := 'miHelp'; + SetPosition(292, 124, 132, 20); + AddMenuItem('Contents...', '', nil); + AddMenuItem('Help using help', '', nil); + AddMenuItem('-', '', nil); + AddMenuItem('About fpGUI Toolkit', '', @miHelpAboutFPGui); + AddMenuItem('Product Information...', '', @miHelpProdInfoClicked); + end; + + miDebug := TfpgPopupMenu.Create(self); + with miDebug do + begin + Name := 'miDebug'; + SetPosition(292, 148, 132, 20); + AddMenuItem('Debug: Header', '', @miDebugHeader); + AddMenuItem('Toggle Hex INF Values in Contents', '', @miDebugHex); + end; + + miOpenRecentMenu := TfpgPopupMenu.Create(self); + with miOpenRecentMenu do + begin + Name := 'miOpenRecentMenu'; + SetPosition(309, 52, 132, 20); + end; + + {@VFD_BODY_END: MainForm} + {%endregion} + + // hook up the sub-menus. + MainMenu.AddMenuItem('&File', nil).SubMenu := miFile; + MainMenu.AddMenuItem('&Settings', nil).SubMenu := miSettings; + MainMenu.AddMenuItem('&Bookmarks', nil).SubMenu := miBookmarks; + MainMenu.AddMenuItem('&Help', nil).SubMenu := miHelp; + MainMenu.AddMenuItem('&Debug', nil).SubMenu := miDebug; + FFileOpenRecent.SubMenu := miOpenRecentMenu; + + // correct default visible tabsheet + PageControl1.ActivePageIndex := 0; + + // most recently used files + mru := TfpgMRU.Create(self); + mru.Name := 'MRU'; + mru.ParentMenuItem := miOpenRecentMenu; + mru.OnClick :=@miMRUClick; + mru.MaxItems := gINI.ReadInteger('Options', 'MRUFileCount', 8); + mru.ShowFullPath := gINI.ReadBool('Options', 'ShowFullPath', True); + mru.LoadMRU; +end; + +procedure TMainForm.RefreshFontSubstitutions; +var + FileIndex: longint; + HelpFile: THelpFile; +begin + for FileIndex := 0 to CurrentOpenFiles.Count - 1 do + begin + HelpFile := THelpFile(CurrentOpenFiles[ FileIndex ]); + + if Settings.FixedFontSubstitution then + HelpFile.SetupFontSubstitutes( Settings.FixedFontSubstitutes ) + else + HelpFile.SetupFontSubstitutes( '' ); + end; +end; + +procedure TMainForm.DisplaySelectedIndexTopic; +var + Topic: TTopic; +Begin + if lbIndex.FocusItem = -1 then + exit; + Topic := DisplayedIndex.Objects[ lbIndex.FocusItem ] as TTopic; + DisplayTopic( Topic ); +end; + +procedure TMainForm.ProcessCommandLineParams; +var + showtopic: boolean; + t: TTopic; +begin + if ParamCount > 0 then + begin + if gCommandLineParams.IsParam('h') then + begin + ShowParamHelp; + Exit; //==> + end + else if gCommandLineParams.IsParam('debuglog') then + // do nothing + else + begin +//writeln('DEBUG: TMainForm.ProcessCommandLineParams - Open file...'); + showtopic := not gCommandLineParams.IsParam('k'); + OpenFile(ParamStr(1), '', showtopic); + end; + end; + + // now process all other parameters + if gCommandLineParams.IsParam('k') then + begin +//writeln('DEBUG: TMainForm.ProcessCommandLineParams - Keyword Search string'); + { Search for a string } + edSearchText.Text := gCommandLineParams.GetParam('k'); + PageControl1.ActivePage := tsSearch; + btnSearch.Click; + end + else if gCommandLineParams.IsParam('n') then + begin + { Display topic with numeric topic id } +//writeln('DEBUG: TMainForm.ProcessCommandLineParams - Display numeric topic id'); + t := FindTopicByResourceID(StrToInt(gCommandLineParams.GetParam('n'))); +//if not Assigned(t) then +// writeln(Format('Failed to find topic <%s>', [gCommandLineParams.GetParam('n')])); + DisplayTopic(t); + end + else if gCommandLineParams.IsParam('s') then + begin +//writeln('DEBUG: TMainForm.ProcessCommandLineParams - display string topic id'); + { Display topic with string topic id } + t := FindTopicByName(gCommandLineParams.GetParam('s')); +//if not Assigned(t) then +// writeln(Format('Failed to find topic <%s>', [gCommandLineParams.GetParam('k')])); + DisplayTopic(t); + end; +end; + +procedure TMainForm.ShowParamHelp; +const + le = LineEnding; +var + s: string; +begin + s := '<font "Arial" 12><b>' + cLongName + '</b></font>' + le + + cVersion + le + le + + 'Supported command line parameters:' + le + le + + '<tt>' + + ' <<filename> Load the help file <<filename>' + le + + ' -h Show this help' + le + + ' -k <<text> Search for keyword <<text> in open help files' + le + + ' -n <<id> Open Topic with numeric ID equal to <<id>' + le + + ' -s <<id> Open Topic with string ID equal to <<id>' + le + + ' -debuglog <<filename> Log information to a file' + le + + '</tt>' + ; + RichView.AddText(PChar(s)); +end; + +// Find the target topic for the given link +function TMainForm.FindTopicForLink(Link: THelpLink): TTopic; +var + HelpFile: THelpFile; +begin + HelpFile := Link.HelpFile as THelpFile; + if Link is TFootnoteHelpLink then + begin + Result := HelpFile.Topics[ TFootnoteHelpLink( Link ).TopicIndex ]; + end + else if Link is TInternalHelpLink then + begin + Result := HelpFile.Topics[ TInternalHelpLink( Link ).TopicIndex ]; + end + else if Link is THelpLinkByResourceID then + begin + Result := FindTopicByResourceID( THelpLinkByResourceID( Link ).ResourceID ); + end +end; + +// Find topic specified by numeric resource ID, in all open files +function TMainForm.FindTopicByResourceID(ID: word): TTopic; +var + FileIndex: longint; + HelpFile: THelpFile; +begin + for FileIndex := 0 to CurrentOpenFiles.Count - 1 do + begin + HelpFile := THelpFile(CurrentOpenFiles[ FileIndex ]); + + Result := HelpFile.FindTopicByResourceID( ID ); + if Result <> nil then + // found + exit; + end; + + // not found. + Result := nil; +end; + +function TMainForm.FindTopicByName(const AName: string): TTopic; +var + FileIndex: longint; + HelpFile: THelpFile; +begin + Result := nil; + for FileIndex := 0 to CurrentOpenFiles.Count - 1 do + begin + HelpFile := THelpFile(CurrentOpenFiles[ FileIndex ]); + Result := HelpFile.FindTopicByLocalName(AName); + if Result <> nil then + // found + exit; //==> + end; + // not found. + Result := nil; +end; + + +end. diff --git a/docview/src/nvNullObjects.pas b/docview/src/nvNullObjects.pas new file mode 100644 index 00000000..ee849b12 --- /dev/null +++ b/docview/src/nvNullObjects.pas @@ -0,0 +1,57 @@ +unit nvNullObjects; + +{$mode objfpc}{$H+} + +interface + +uses + contnrs, Classes, SysUtils; + +type + EHelpBitmapException = class(Exception); + + // forward declaration + THelpBitmap = class; + + + TImageList = class(TObjectList) + public + procedure Add(ABitmap: THelpBitmap; AParam2: TObject); + end; + + + THelpBitmap = class(TObject) + public + constructor CreateFromHelpFile( FileHandle: TFileStream; Offset: longint ); + procedure LoadFromResourceName(const AName: string); + end; + + + +implementation + + + +{ TImageList } + +procedure TImageList.Add(ABitmap: THelpBitmap; AParam2: TObject); +begin + // +end; + +{ THelpBitmap } + + +constructor THelpBitmap.CreateFromHelpFile(FileHandle: TFileStream; Offset: longint); +begin + inherited Create; +end; + +procedure THelpBitmap.LoadFromResourceName(const AName: string); +begin + // +end; + + +end. + diff --git a/docview/src/nvUtilities.pas b/docview/src/nvUtilities.pas new file mode 100644 index 00000000..aed9d392 --- /dev/null +++ b/docview/src/nvUtilities.pas @@ -0,0 +1,398 @@ +unit nvUtilities; + +{$mode objfpc}{$H+} + +// disable to remove debugging output +{.$Define DEBUG} + +interface + +uses + Classes, SysUtils, fpg_base; + +const + { TODO -oGraeme : Should this change to LineEnding (platfrom dependant) } + EndLine= chr(13)+chr(10); + TwoEndLines= chr(13)+chr(10)+chr(13)+chr(10); + Quote = ''''; + DoubleQuote = '"'; + + // -- Logging -- +type + LogAspect = ( LogStartup, + LogShutdown, + LogSettings, + LogI18n, + LogParse, + LogDisplay, + LogSearch, + LogNHM, + LogViewStub, + LogObjConstDest, + LogDebug + ); + LogAspects = SET OF LogAspect; + +procedure LogEvent(const aLogAspect: LogAspect; const anEventDescription: String); + +// 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; + +function AllocateMemory( const Size: ValUInt ): pointer; +procedure DeallocateMemory( Var P: pointer ); + +// Alias method which is the same as Move() but with less confusing name +procedure MemCopy(const src; var dest; size: SizeInt); +// Allows for debug output and quite disable of output +procedure ProfileEvent(const AString: string); +// Return AFilename's size in bytes +function GetFileSize(const AFilename: string): integer; + +function IsDigit(const AChar: TfpgChar): boolean; +function IsAlpha(const AChar: TfpgChar): boolean; +function Between( const Value: longint; const Limit1: longint; const Limit2: longint ): boolean; + + +operator = (ARect: TRect; BRect: TRect): boolean; + +// Destroy the objects stored in List and clear the list. +procedure ClearListAndObjects( List: TList ); +// Destroy the objects stored in the list and then destroy the list itself +// And set the reference to nil +procedure DestroyListAndObjects( Var List: TList ); +// Destroy the objects stored in the list. +// You probably want to use one of the two functions above. +procedure DestroyListObjects( List: TList ); + +procedure AddList( Source, Dest: TList ); +procedure AssignList( Source, Dest: TList ); + +procedure ListFilesInDirectory(const aDirectory: String; const aFilter: String; const aWithDirectoryFlag: boolean; var aList: TStrings); + +// add all file name parts of aFileNameString to the aResult +// check for containing environment vars +// and include all help files if the environment var points +// to a directory +procedure ParseAndExpandFileNames(const aFileNameString: String; aResult: TStrings); + + + +var + startTime : Cardinal; + lastTime : Cardinal; + activeLogAspects : LogAspects; + infoMessage1 : String; + infoMessage2 : String; + + +implementation + +uses + fpg_utils + ,fpg_main + ,ACLStringUtility + ,dvconstants + ; + + Function GetAspectPrefix(const aLogAspect: LogAspect): String; + Begin + Case aLogAspect of + LogStartup : result := 'Startup'; + LogShutdown : result := 'Start'; + LogSettings : result := 'Settings'; + LogI18n : result := 'I18n'; + LogParse : result := 'Parse'; + LogDisplay : result := 'Display'; + LogSearch : result := 'Search'; + LogNHM : result := 'NewHelpManager'; + LogViewStub : result := 'ViewStub'; + LogObjConstDest : result := 'ObjConstDest'; + LogDebug : result := 'Debug'; + else result := 'Unknown'; + end; + End; + + + Procedure SetLogAspects(const aCommaSeparatedListOfAspectNames : String); + Var + tmpAspects : TStringList; + i : Integer; + Begin + tmpAspects := TStringList.Create; + StrExtractStrings(tmpAspects, aCommaSeparatedListOfAspectNames, [','], #0); + + for i:=0 to tmpAspects.count-1 do + begin + if tmpAspects[i] = 'LogStartup' then activeLogAspects := activeLogAspects + [ LogStartup ]; + if tmpAspects[i] = 'LogShutdown' then activeLogAspects := activeLogAspects + [ LogShutdown ]; + if tmpAspects[i] = 'LogSettings' then activeLogAspects := activeLogAspects + [ LogSettings ]; + if tmpAspects[i] = 'LogI18n' then activeLogAspects := activeLogAspects + [ LogI18n ]; + if tmpAspects[i] = 'LogParse' then activeLogAspects := activeLogAspects + [ LogParse ]; + if tmpAspects[i] = 'LogDisplay' then activeLogAspects := activeLogAspects + [ LogDisplay ]; + if tmpAspects[i] = 'LogSearch' then activeLogAspects := activeLogAspects + [ LogSearch ]; + if tmpAspects[i] = 'LogNHM' then activeLogAspects := activeLogAspects + [ LogNHM ]; + if tmpAspects[i] = 'LogViewStub' then activeLogAspects := activeLogAspects + [ LogViewStub ]; + if tmpAspects[i] = 'LogObjConstDest' then activeLogAspects := activeLogAspects + [ LogObjConstDest ]; + if tmpAspects[i] = 'LogDebug' then activeLogAspects := activeLogAspects + [ LogDebug ]; + end; + + tmpAspects.Destroy; + End; + +procedure LogEvent(const aLogAspect: LogAspect; const anEventDescription: String); +var + tmpMessage: String; +begin + if (aLogAspect IN activeLogAspects) then + begin + tmpMessage := 'Log[' + GetAspectPrefix(aLogAspect) + '] ' + anEventDescription; + debugln(tmpMessage); + 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 ] = DoubleQuote then + Delete( Result, 1, 1 ); + + if Result <> '' then + if Result[ length( Result ) ] = DoubleQuote then + Delete( Result, length( Result ), 1 ); +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 AllocateMemory( const Size: ValUInt ): pointer; +begin + GetMem( Result, size + sizeof( Size ) ); + PtrUInt(Result^) := Size; + inc( Result, sizeof( Size ) ); +end; + +procedure DeallocateMemory( Var P: pointer ); +var + Size: ValUInt; +begin + if P = nil then + exit; + + dec( P, sizeof( size ) ); + Size := ValUInt(P^); + FreeMem( P, Size + sizeof( Size ) ); + P := nil; +end; + +procedure MemCopy(const src; var dest; size: SizeInt); +begin + Move(src, dest, size); +end; + +procedure ProfileEvent(const AString: string); +begin + {$IFDEF DEBUG} + writeln('DEBUG: ', AString); + {$ENDIF} +end; + +function GetFileSize(const AFilename: string): integer; +var + f: File; +begin + Result := 0; + {$i-} + FileMode := 0; // read-only + Assign(f, fpgToOSEncoding(AFileName)); + Reset(f); + {$i+} + Result := FileSize(f); + CloseFile(f); +end; + +function IsDigit(const AChar: TfpgChar): boolean; +begin + { TODO -oGraeme -cunicode : Not utf-8 compliant. } + Result := ( AChar>='0' ) and ( AChar<='9' ); + //Result := TCharacter.IsDigit(AChar); +end; + +function IsAlpha(const AChar: TfpgChar): boolean; +var + UppercaseC: TfpgChar; +Begin + { TODO -oGraeme -cunicode : Not utf-8 compliant. } + UppercaseC := UpperCase( AChar ); + Result := ( UppercaseC >= 'A' ) and ( UppercaseC <= 'Z' ); + //Result := TCharacter.IsLetter(AChar); +end; + +function Between( const Value: longint; const Limit1: longint; const Limit2: longint ): boolean; +begin + if Limit1 < Limit2 then + Result:= ( Value >= Limit1 ) and ( Value <= Limit2 ) + else + Result:= ( Value >= Limit2 ) and ( Value <= Limit1 ) +end; + +operator = (ARect: TRect; BRect: TRect): boolean; +begin + result := (ARect.Top = BRect.Top) and + (ARect.Left = BRect.Left) and + (ARect.Bottom = BRect.Bottom) and + (ARect.Right = BRect.Right); +end; + +// Destroy the objects stored in List +// and clear the list. +Procedure ClearListAndObjects( List: TList ); +begin + DestroyListObjects( List ); + List.Clear; +end; + +// Destroy the objects stored in the list +// and then destroy the list itself. +Procedure DestroyListAndObjects( Var List: TList ); +begin + if not Assigned( List ) then + exit; + + DestroyListObjects( List ); + List.Free; + List := nil; +end; + +Procedure DestroyListObjects( List: TList ); +var + Index: longint; +begin + for Index := 0 to List.Count - 1 do + begin + if List[ Index ] <> nil then + begin + TObject( List[ Index ] ).Free; + List[ Index ] := nil; + end; + end; +end; + +Procedure AddList( Source, Dest: TList ); +var + i: longint; +begin + // expand the destination list to what's required + Dest.Capacity := Dest.Capacity + Source.Capacity; + for i:= 0 to Source.Count - 1 do + Dest.Add( Source[ i ] ); +end; + +Procedure AssignList( Source, Dest: TList ); +begin + Dest.Clear; + AddList( Source, Dest ); +end; + +procedure ListFilesInDirectory(const aDirectory: String; const aFilter: String; + const aWithDirectoryFlag: boolean; var aList: TStrings); +var + tmpRC: longint; + tmpSearchResults: TSearchRec; + tmpMask: String; + tmpFilterParts : TStringList; + tmpDirectory: String; + i: integer; +begin + tmpFilterParts := TStringList.Create; + + StrExtractStrings(tmpFilterParts, aFilter, [PathSeparator], #0); + + for i:=0 to tmpFilterParts.count-1 do + begin + tmpMask := tmpFilterParts[i]; + tmpDirectory := IncludeTrailingPathDelimiter(aDirectory); + tmpRC := fpgFindFirst(tmpDirectory + tmpMask, faAnyFile, tmpSearchResults); + + while tmpRC = 0 do + begin + if (tmpSearchResults.Attr and faDirectory) = 0 then + begin + if (aWithDirectoryFlag) then + aList.Add(tmpDirectory + tmpSearchResults.Name) + else + aList.Add(tmpSearchResults.Name); + end; + + tmpRC := fpgFindNext(tmpSearchResults); + end; + + FindClose(tmpSearchResults); + end; + tmpFilterParts.Destroy; +end; + +procedure ParseAndExpandFileNames(const aFileNameString: String; aResult: TStrings); +var + i: longint; + tmpFileNamesList: TStringList; + tmpItem: String; + tmpEnvironmentVarValue: string; +begin + LogEvent(LogDebug, 'ParseAndExpandFileNames "' + aFileNameString + '"'); + tmpFileNamesList := TStringList.Create; + + StrExtractStrings(tmpFileNamesList, aFileNameString, [HELP_FILE_DELIMITER, PathSeparator], #0); + for i := 0 to tmpFileNamesList.Count - 1 do + begin + tmpItem := tmpFileNamesList[i]; + + // is this a environment var + tmpEnvironmentVarValue := GetEnvironmentVariable(tmpItem); + if tmpEnvironmentVarValue <> '' then // environment var exists + begin + LogEvent(LogStartup, ' Environment var found; translated to: "' + tmpEnvironmentVarValue + '"'); + ParseAndExpandFileNames(tmpEnvironmentVarValue, aResult); + end + else if fpgDirectoryExists(tmpItem) then + begin + ListFilesInDirectory(tmpItem, '*' + INF_FILE_EXTENSION, true, aResult); + end + else + begin + aResult.Add(tmpItem); + end; + end; + + tmpFileNamesList.Free; +end; + +{$IFDEF DEBUG} +initialization + SetLogAspects('LogDebug,LogStartup'); +{$ENDIF} + +end. + diff --git a/docview/test/newview.inf b/docview/test/newview.inf Binary files differnew file mode 100644 index 00000000..d711e4a6 --- /dev/null +++ b/docview/test/newview.inf diff --git a/docview/test/testcase1.hlp b/docview/test/testcase1.hlp Binary files differnew file mode 100644 index 00000000..2b88bc7d --- /dev/null +++ b/docview/test/testcase1.hlp diff --git a/docview/test/testcase1.ipf b/docview/test/testcase1.ipf new file mode 100644 index 00000000..bcec749d --- /dev/null +++ b/docview/test/testcase1.ipf @@ -0,0 +1,12 @@ +:userdoc. +:title. Sample INF file... +:h1.Header One +:p.This is a test. Os/2, lies, and Windows 95. +:p.1234.5 +:artwork name='in_inf.bmp'. +Hello +:p. +:artwork name='tocarray.bmp'. +:i1. This is a index entry +:euserdoc. + |
