diff --git a/ide/text/fp.pas b/ide/text/fp.pas index 7c16a44599..282d3f543b 100644 --- a/ide/text/fp.pas +++ b/ide/text/fp.pas @@ -89,11 +89,12 @@ BEGIN ReadSwitches(SwitchesPath); MyApp.Init; + { load all options after init because of open files } ReadINIFile; + { Update IDE } - if PrimaryFile<>'' then - MyApp.UpdatePrimaryFile; + MyApp.Update; ProcessParams(false); @@ -118,7 +119,12 @@ BEGIN END. { $Log$ - Revision 1.16 1999-03-12 01:13:01 peter + Revision 1.17 1999-03-16 12:38:06 peter + * tools macro fixes + + tph writer + + first things for resource files + + Revision 1.16 1999/03/12 01:13:01 peter * use TryToOpen() with parameter files to overcome double opened files at startup diff --git a/ide/text/fpcompil.pas b/ide/text/fpcompil.pas index b1a694a428..69147c25aa 100644 --- a/ide/text/fpcompil.pas +++ b/ide/text/fpcompil.pas @@ -46,6 +46,9 @@ uses FPRedir, FPConst,FPVars,FPUtils,FPIntf,FPSwitch; +const + LastStatusUpdate : longint = 0; + constructor TCompileStatusDialog.Init; var R: TRect; begin @@ -117,8 +120,14 @@ end; ****************************************************************************} function CompilerStatus: boolean; {$ifndef FPC}far;{$endif} +var TT: longint; begin + TT:=GetDosTicks; + if abs(TT-LastStatusUpdate)>=round(CompilerStatusUpdateDelay*18.2) then + begin + LastStatusUpdate:=TT; if SD<>nil then SD^.Update; + end; CompilerStatus:=false; end; @@ -279,7 +288,12 @@ end; end. { $Log$ - Revision 1.17 1999-03-12 01:13:56 peter + Revision 1.18 1999-03-16 12:38:07 peter + * tools macro fixes + + tph writer + + first things for resource files + + Revision 1.17 1999/03/12 01:13:56 peter * flag if trytoopen should look for other extensions + browser tab in the tools-compiler diff --git a/ide/text/fpconst.pas b/ide/text/fpconst.pas index 7fbb28d4bb..df9c92cf60 100644 --- a/ide/text/fpconst.pas +++ b/ide/text/fpconst.pas @@ -26,6 +26,8 @@ const MaxRecentFileCount = 5; MaxToolCount = 16; + CompilerStatusUpdateDelay = 0.8; { in secs } + ININame = 'fp.ini'; SwitchesName = 'fp.cfg'; @@ -59,6 +61,14 @@ const { Startup Option constants } soReturnToLastDir = $00000001; + { Desktop Flag constants - what to include in the desktop file } + dfHistoryLists = $00000001; + dfClipboardContent = $00000002; + dfWatches = $00000004; + dfBreakpoints = $00000008; + dfOpenWindows = $00000010; + dfSymbolInformation = $00000020; + { Command constants } cmShowClipboard = 201; cmFindProcedure = 206; @@ -130,6 +140,7 @@ const cmSaveAsINI = 2013; cmSwitchesMode = 2014; cmBrowser = 2015; + cmDesktopOptions = 2016; cmHelpContents = 2100; cmHelpIndex = 2101; @@ -192,6 +203,7 @@ const { hcGrep = hcShift+cmGrep;} hcSwitchesMode = hcShift+cmSwitchesMode; hcBrowser = hcShift+cmBrowser; + hcDesktopOptions = hcShift+cmDesktopOptions; hcAbout = hcShift+cmAbout; hcSystemMenu = 9000; @@ -294,11 +306,16 @@ implementation END. { $Log$ - Revision 1.13 1999-03-01 15:41:51 peter + Revision 1.14 1999-03-16 12:38:08 peter + * tools macro fixes + + tph writer + + first things for resource files + + Revision 1.13 1999/03/01 15:41:51 peter + Added dummy entries for functions not yet implemented * MenuBar didn't update itself automatically on command-set changes * Fixed Debugging/Profiling options dialog - * TCodeEditor converts spaces to tabs at save only if efUseTabChars is set + * TCodeEditor converts spaces to tabs at save only if efUseTabChars is set * efBackSpaceUnindents works correctly + 'Messages' window implemented + Added '$CAP MSG()' and '$CAP EDIT' to available tool-macros diff --git a/ide/text/fphelp.pas b/ide/text/fphelp.pas index bea8b1e15d..bcf7622c67 100644 --- a/ide/text/fphelp.pas +++ b/ide/text/fphelp.pas @@ -155,6 +155,7 @@ begin hcToolsBase.. hcToolsBase+MaxToolCount : S:='User installed tool'; + hcASCIITable : S:='Show ASCII table'; hcOptionsMenu : S:='Setting for compiler, editor, mouse, etc.'; hcSwitchesMode : S:='Select settings for normal, debug or release version'; @@ -170,6 +171,7 @@ begin hcPreferences : S:='Specify desktop settings'; hcEditor : S:='Specify default editor settings'; hcMouse : S:='Specify mouse settings'; + hcDesktopOptions: S:='Specify desktop settings'; hcStartup : S:='Permanently change default startup options'; hcColors : S:='Customize IDE colors for windows, menus, editors, etc.'; hcOpenINI : S:='Load a previously saved options file'; @@ -377,11 +379,16 @@ end; END. { $Log$ - Revision 1.11 1999-03-01 15:41:53 peter + Revision 1.12 1999-03-16 12:38:09 peter + * tools macro fixes + + tph writer + + first things for resource files + + Revision 1.11 1999/03/01 15:41:53 peter + Added dummy entries for functions not yet implemented * MenuBar didn't update itself automatically on command-set changes * Fixed Debugging/Profiling options dialog - * TCodeEditor converts spaces to tabs at save only if efUseTabChars is set + * TCodeEditor converts spaces to tabs at save only if efUseTabChars is set * efBackSpaceUnindents works correctly + 'Messages' window implemented + Added '$CAP MSG()' and '$CAP EDIT' to available tool-macros diff --git a/ide/text/fpide.pas b/ide/text/fpide.pas index b2ea34f1f6..e4631dccd4 100644 --- a/ide/text/fpide.pas +++ b/ide/text/fpide.pas @@ -32,6 +32,7 @@ type procedure Open(FileName: string); function OpenSearch(FileName: string) : boolean; procedure Idle; virtual; + procedure Update; procedure HandleEvent(var Event: TEvent); virtual; procedure GetTileRect(var R: TRect); virtual; function GetPalette: PPalette; virtual; @@ -40,8 +41,6 @@ type public procedure ShowUserScreen; procedure ShowIDEScreen; - public - procedure UpdatePrimaryFile; private Heap: PFPHeapView; procedure NewEditor; @@ -83,6 +82,7 @@ type procedure Preferences; procedure EditorOptions(Editor: PEditor); procedure BrowserOptions(Browser: PBrowserWindow); + procedure DesktopOptions; procedure Mouse; procedure StartUp; procedure Colors; @@ -105,8 +105,8 @@ type function SearchRecentFile(AFileName: string): integer; procedure RemoveRecentFile(Index: integer); private - procedure Update; procedure CurDirChanged; + procedure UpdatePrimaryFile; procedure UpdateINIFile; procedure UpdateRecentFileList; procedure UpdateTools; @@ -251,10 +251,11 @@ begin NewSubMenu('~E~nvironment', hcEnvironmentMenu, NewMenu( NewItem('~P~references...','', kbNoKey, cmPreferences, hcPreferences, NewItem('~E~ditor...','', kbNoKey, cmEditor, hcEditor, + NewItem('~D~esktop...','', kbNoKey, cmDesktopOptions, hcDesktopOptions, NewItem('~M~ouse...','', kbNoKey, cmMouse, hcMouse, NewItem('~S~tartup...','', kbNoKey, cmStartup, hcStartup, NewItem('~C~olors...','', kbNoKey, cmColors, hcColors, - nil)))))), + nil))))))), NewLine( NewItem('~O~pen...','', kbNoKey, cmOpenINI, hcOpenINI, NewItem('~S~ave','', kbNoKey, cmSaveINI, hcSaveINI, @@ -411,6 +412,7 @@ begin cmBrowserOptions : BrowserOptions(Event.InfoPtr); cmMouse : Mouse; cmStartup : StartUp; + cmDesktopOptions: DesktopOptions; cmColors : Colors; cmOpenINI : OpenINI; cmSaveINI : SaveINI; @@ -718,7 +720,12 @@ end; END. { $Log$ - Revision 1.22 1999-03-12 01:13:57 peter + Revision 1.23 1999-03-16 12:38:10 peter + * tools macro fixes + + tph writer + + first things for resource files + + Revision 1.22 1999/03/12 01:13:57 peter * flag if trytoopen should look for other extensions + browser tab in the tools-compiler diff --git a/ide/text/fpmopts.inc b/ide/text/fpmopts.inc index 0df652e579..f7b5a9e3c2 100644 --- a/ide/text/fpmopts.inc +++ b/ide/text/fpmopts.inc @@ -484,7 +484,7 @@ var R,R2: TRect; items : PSItem; videomode : tvideomode; i,modevalue : longint; - + function ToStr(l : longint) : string; @@ -498,7 +498,7 @@ var R,R2: TRect; const color2str : array[false..true] of string = ('in b/w','in color'); - + begin GetVideoMode(videomode); CountModes:=0; @@ -512,7 +512,7 @@ begin items:=nil; r2.assign(2,3,24,17); while assigned(hp) do - begin + begin items:=NewSItem(ToStr(hp^.col)+'x'+ToStr(hp^.row)+' '+color2str[hp^.color],items); if (hp^.col=videomode.col) and (hp^.row=videomode.row) and (hp^.color=videomode.color) then @@ -525,7 +525,7 @@ begin hp:=hp^.next; end; modevalue:=CountModes-modevalue-1; - new(rb1,init(r2,items)); + new(rb1,init(r2,items)); insert(rb1); rb1^.value:=modevalue; @@ -538,7 +538,7 @@ begin { change video mode ? } if rb1^.value<>modevalue then begin - + end; end; Dispose(D, Done); @@ -706,6 +706,38 @@ begin NotImplemented; end; +procedure TIDEApp.DesktopOptions; +var R: TRect; + D: PCenterDialog; + CB: PCheckBoxes; +begin + R.Assign(0,0,40,10); + New(D, Init(R, 'Desktop Preferences')); + with D^ do + begin + GetExtent(R); R.Grow(-2,-2); Inc(R.A.Y); R.B.Y:=R.A.Y+6; + New(CB, Init(R, + NewSItem('~H~istory lists', + NewSItem('~C~lipboard content', + NewSItem('~W~atch expressions', + NewSItem('~B~reakpoints', + NewSItem('~O~pen windows', + NewSItem('~S~ymbol information', + nil)))))))); + CB^.Value:=DesktopFileFlags; + Insert(CB); + R.Move(0,-1); R.B.Y:=R.A.Y+1; + Insert(New(PLabel, Init(R, '~P~reserved across sessions', CB))); + end; + InsertButtons(D); + CB^.Select; + if Desktop^.ExecView(D)=cmOK then + begin + DesktopFileFlags:=CB^.Value; + end; + Dispose(D, Done); +end; + procedure TIDEApp.Mouse; var R,R2: TRect; D: PCenterDialog; @@ -891,7 +923,12 @@ end; { $Log$ - Revision 1.20 1999-03-14 22:18:16 florian + Revision 1.21 1999-03-16 12:38:12 peter + * tools macro fixes + + tph writer + + first things for resource files + + Revision 1.20 1999/03/14 22:18:16 florian + options/preferences dialog added, without function yet Revision 1.19 1999/03/12 01:14:00 peter diff --git a/ide/text/fptools.pas b/ide/text/fptools.pas index 2e382c4afd..2b90a48c80 100644 --- a/ide/text/fptools.pas +++ b/ide/text/fptools.pas @@ -214,6 +214,31 @@ begin GetHotKeyName:=S; end; +function WriteToolMessagesToFile(FileName: string): boolean; +var OK: boolean; + f: text; + M: PToolMessage; + I: sw_integer; +begin + I:=0; + Assign(f,FileName); +{$I-} + Rewrite(f); + OK:=EatIO=0; + if Assigned(ToolMessages) then + while OK and (I0 then Delete(D,1,L); + I:=I+ReplacePart(LastWordStart,I-1,D)-1; end; end else if (WordS='$DRIVE') then @@ -1013,9 +1039,9 @@ begin begin Consume(')'); FSplit(S,D,N,E); - L:=Pos(':',D); if L=0 then L:=-1; - D:=copy(D,1,L+1); - I:=I+ReplacePart(LastWordStart,I-1,D); + L:=Pos(':',D); + D:=copy(D,1,L); + I:=I+ReplacePart(LastWordStart,I-1,D)-1; end; end else if (WordS='$EDNAME') then @@ -1024,13 +1050,13 @@ begin begin if W=nil then S:='' else S:=W^.Editor^.FileName; - I:=I+ReplacePart(LastWordStart,I-1,S); + I:=I+ReplacePart(LastWordStart,I-1,S)-1; end; end else if (WordS='$EXENAME') then begin if (Pass=1) then - I:=I+ReplacePart(LastWordStart,I-1,EXEFile); + I:=I+ReplacePart(LastWordStart,I-1,EXEFile)-1; end else if (WordS='$EXT') then begin @@ -1040,7 +1066,7 @@ begin begin Consume(')'); FSplit(S,D,N,E); E:=copy(E,2,255); - I:=I+ReplacePart(LastWordStart,I-1,E); + I:=I+ReplacePart(LastWordStart,I-1,E)-1; end; end else if (WordS='$LINE') then @@ -1049,7 +1075,7 @@ begin begin if W=nil then L:=0 else L:=W^.Editor^.CurPos.Y+1; - I:=I+ReplacePart(LastWordStart,I-1,IntToStr(L)); + I:=I+ReplacePart(LastWordStart,I-1,IntToStr(L))-1; end; end else if (WordS='$NAME') then @@ -1060,7 +1086,7 @@ begin begin Consume(')'); FSplit(S,D,N,E); - I:=I+ReplacePart(LastWordStart,I-1,N); + I:=I+ReplacePart(LastWordStart,I-1,N)-1; end; end else if (WordS='$NAMEEXT') then @@ -1071,14 +1097,14 @@ begin begin Consume(')'); FSplit(S,D,N,E); - I:=I+ReplacePart(LastWordStart,I-1,N+E); + I:=I+ReplacePart(LastWordStart,I-1,N+E)-1; end; end else if (WordS='$NOSWAP') then begin if (Pass=1) then begin - I:=I+ReplacePart(LastWordStart,I-1,''); + I:=I+ReplacePart(LastWordStart,I-1,'')-1; end; end else if (WordS='$DRIVE') then @@ -1091,7 +1117,7 @@ begin FSplit(S,D,N,E); L:=Pos(':',D); if L=0 then L:=-1; D:=copy(D,1,L+1); - I:=I+ReplacePart(LastWordStart,I-1,D); + I:=I+ReplacePart(LastWordStart,I-1,D)-1; end; end else if (WordS='$PROMPT') then @@ -1108,12 +1134,12 @@ begin if ExecutePromptDialog(S,S)=false then Err:=I else - I:=I+ReplacePart(LastWordStart,I-1,S); + I:=I+ReplacePart(LastWordStart,I-1,S)-1; end; end else { just prompt for parms } begin - I:=I+ReplacePart(LastWordStart,I-1,''); + I:=I+ReplacePart(LastWordStart,I-1,'')-1; if CheckOnly=false then begin S:=copy(Params,I+1,255); @@ -1137,7 +1163,7 @@ begin begin if (Pass=2) then begin - I:=I+ReplacePart(LastWordStart,I-1,''); + I:=I+ReplacePart(LastWordStart,I-1,'')-1; Message(Application,evCommand,cmSaveAll,nil); end; end else @@ -1145,7 +1171,7 @@ begin begin if (Pass=2) then begin - I:=I+ReplacePart(LastWordStart,I-1,''); + I:=I+ReplacePart(LastWordStart,I-1,'')-1; Message(W,evCommand,cmSave,nil); end; end else @@ -1153,12 +1179,24 @@ begin begin if (Pass=2) then begin - I:=I+ReplacePart(LastWordStart,I-1,''); + I:=I+ReplacePart(LastWordStart,I-1,'')-1; if W<>nil then if W^.Editor^.SaveAsk=false then Err:=-1; end; end else + if (WordS='$WRITEMSG') then + begin + if (Pass=2) then + if Consume('(')=false then Err:=I else + if ReadTill(S,')')=false then Err:=I else + begin + Consume(')'); + I:=I+ReplacePart(LastWordStart,I-1,'')-1; + if CheckOnly=false then + WriteToolMessagesToFile(S); + end; + end else if copy(WordS,1,1)='$' then Err:=LastWordStart; WordS:=''; @@ -1388,7 +1426,12 @@ end; END. { $Log$ - Revision 1.5 1999-03-08 14:58:12 peter + Revision 1.6 1999-03-16 12:38:14 peter + * tools macro fixes + + tph writer + + first things for resource files + + Revision 1.5 1999/03/08 14:58:12 peter + prompt with dialogs for tools Revision 1.4 1999/03/01 15:42:04 peter diff --git a/ide/text/fpvars.pas b/ide/text/fpvars.pas index 4e48877ae1..ce4d7c3ebc 100644 --- a/ide/text/fpvars.pas +++ b/ide/text/fpvars.pas @@ -59,6 +59,7 @@ const ClipboardWindow : PClipboardWindow = nil; StartupOptions : longint = 0; LastExitCode : integer = 0; ASCIIChart : PFPASCIIChart = nil; + DesktopFileFlags : longint = dfHistoryLists+dfOpenWindows; ActionCommands : array[acFirstAction..acLastAction] of word = (cmHelpTopicSearch,cmGotoCursor,cmToggleBreakpoint, @@ -73,7 +74,12 @@ implementation END. { $Log$ - Revision 1.12 1999-03-12 01:14:02 peter + Revision 1.13 1999-03-16 12:38:15 peter + * tools macro fixes + + tph writer + + first things for resource files + + Revision 1.12 1999/03/12 01:14:02 peter * flag if trytoopen should look for other extensions + browser tab in the tools-compiler diff --git a/ide/text/utils/grep2msg.pas b/ide/text/utils/grep2msg.pas new file mode 100644 index 0000000000..bb1a61c519 --- /dev/null +++ b/ide/text/utils/grep2msg.pas @@ -0,0 +1,101 @@ +{************************************************} +{ } +{ Grep message filter example } +{ Copyright (c) 1992 by Borland International } +{ } +{************************************************} + +program Grep2Msg; + +{ Message filters read input from the target program (in this case, GREP) + by way of StdIn (by using Read or ReadLn), filter the input, then write + output back to StdOut (using Write or WriteLn). The IDE takes care of + redirecting the transfer program's output to the filter program, as well + as redirecting the filter program's output back to the IDE itself. +} + +{$I-,S-} + +var + LineNo, E: Word; + P1,P2: integer; + Line: String; + InputBuffer: array[0..4095] of Char; + OutputBuffer: array[0..4095] of Char; + + +{ The first data passed back to the IDE by a message filter must always + be the string 'BI#PIP#OK', followed by a null terminator. +} +procedure WriteHeader; +begin + Write('BI#PIP#OK'#0); +end; + +{ The beginning of a new file is marked by a #0, the file's name, terminated + by a #0 character. +} +procedure WriteNewFile(const FileName: String); +begin + Write(#0, FileName, #0); +end; + +{ Each message line begins with a #1, followed the line number (in low/high + order), followed by the column number (in low/high order), then the + message text itself, terminated with a #0 character. +} +procedure WriteMessage(Line, Col: Word; const Message: String); +begin + Write(#1, Chr(Lo(Line)), Chr(Hi(Line)), Chr(Lo(Col)), Chr(Hi(Col)), + Message, #0); +end; + +{ The end of the input stream is marked by a #127 character } +procedure WriteEnd; +begin + Write(#127); +end; + +function TrimLeft(S:String): String; +var + i: Integer; + n: String; +begin + i := 1; + while (i <= Length(s)) and (s[i] = #32) do Inc(i); + if i <= Length(s) then + begin + Move(s[i], n[1], Length(s) - i + 1); + n[0] := Char(Length(s) - i + 1); + end + else n[0] := #0; + TrimLeft := n; +end; + +const LastFileName: string = ''; + +begin + SetTextBuf(Input, InputBuffer); + SetTextBuf(Output, OutputBuffer); + WriteHeader; + while not Eof do + begin + ReadLn(Line); + if Line <> '' then + begin + P1:=Pos(':',Line); + if copy(Line, 1, P1)<>LastFileName then + begin + LastFileName:=copy(Line,1,P1-1); + WriteNewFile(LastFileName); + end; + P2:=Pos(':',copy(Line,P1+1,255)); + if P2>0 then + begin + Val(Copy(Line, P1+1, P2-1), LineNo, E); + if E = 0 then WriteMessage(LineNo, 1, TrimLeft(Copy(Line, P1+1+P2, 132))); + end; + end; + end; + WriteEnd; +end. diff --git a/ide/text/utils/tphc.pas b/ide/text/utils/tphc.pas new file mode 100644 index 0000000000..a6e06335ec --- /dev/null +++ b/ide/text/utils/tphc.pas @@ -0,0 +1,28 @@ +uses Objects,WHelp,WTPHWriter; + +var W: THelpFileWriter; + HF: TOAHelpFile; + P: PTopic; +const Ctx = 32; + +BEGIN + W.Init('TEST.TPH',1); + P:=W.CreateTopic(Ctx); + W.AddTopicToIndex('IndexEntry',P); + W.AddLineToTopic(P,'Hello world!'); + W.AddLineToTopic(P,'This is a '+hscLink+'sample'+hscLink+' help file.'); + W.AddLineToTopic(P,'And this is it''s 3rd line...'); + W.AddLinkToTopic(P,Ctx+1); + P:=W.CreateTopic(Ctx+1); + W.AddTopicToIndex('IndexEntry2',P); + W.AddLineToTopic(P,'And this is an other topic!'); + W.AddLineToTopic(P,'>>>Back to the '+hscLink+'previous topic'+hscLink+'...'); + W.AddLinkToTopic(P,Ctx); + W.WriteFile; + W.Done; + + HF.Init('TEST.TPH',1); + HF.LoadIndex; + P:=HF.LoadTopic(Ctx); + HF.Done; +END. \ No newline at end of file diff --git a/ide/text/whelp.pas b/ide/text/whelp.pas index dcd7a78ce8..36068e3688 100644 --- a/ide/text/whelp.pas +++ b/ide/text/whelp.pas @@ -443,7 +443,11 @@ begin New(F, Init(AFileName, stOpenRead, HelpStreamBufSize)); OK:=F<>nil; if OK then OK:=(F^.Status=stOK); - if OK then begin FS:=F^.GetSize; OK:=ReadHeader; end; + if OK then + begin + FS:=F^.GetSize; + OK:=ReadHeader; + end; while OK do begin L:=F^.GetPos; @@ -478,7 +482,7 @@ var S: string; OK: boolean; begin F^.Seek(0); - F^.Read(S[1],255); S[0]:=#255; + F^.Read(S[1],128); S[0]:=#255; OK:=(F^.Status=stOK); P:=Pos(Signature,S); OK:=OK and (P>0); if OK then @@ -506,7 +510,7 @@ begin OK:=ReadRecord(R, true); if OK then with THLPContexts(R.Data^) do - for I:=1 to ContextCount-1 do + for I:=1 to longint(ContextCount)-1 do begin if Topics^.Count=MaxCollectionSize then Break; L:=GetCtxPos(Contexts[I]); @@ -622,11 +626,10 @@ begin case N of $00 : C:=#0; $01..$0D : C:=chr(Compression.CharTable[N]); -{$ifdef FPC} - ncRawChar : C:=chr(GetNextNibble shl 4+GetNextNibble); -{$else} - ncRawChar : C:=chr(GetNextNibble+GetNextNibble shl 4); -{$endif} + ncRawChar : begin + I:=GetNextNibble; + C:=chr(I+GetNextNibble shl 4); + end; ncRepChar : begin Cnt:=2+GetNextNibble; C:=GetNextChar{$ifdef FPC}(){$endif}; @@ -919,7 +922,12 @@ end; END. { $Log$ - Revision 1.10 1999-03-08 14:58:19 peter + Revision 1.11 1999-03-16 12:38:16 peter + * tools macro fixes + + tph writer + + first things for resource files + + Revision 1.10 1999/03/08 14:58:19 peter + prompt with dialogs for tools Revision 1.9 1999/03/03 16:44:05 pierre diff --git a/ide/text/wresourc.pas b/ide/text/wresourc.pas new file mode 100644 index 0000000000..e62402bf84 --- /dev/null +++ b/ide/text/wresourc.pas @@ -0,0 +1,683 @@ +{ + $Id$ + This file is part of the Free Pascal Integrated Development Environment + Copyright (c) 1998 by Berczi Gabor + + Resource File support objects and routines + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +unit WResource; + +interface + +uses Objects; + +const + TPDataBlockSignature = ord('F')+ord('B')*256; + ResourceBlockSignature = ord('R')+ord('D')*256; + + langDefault = 0; + + rcBinary = 1; + +type + TResourceEntryHeader = packed record + ID : longint; + LangID : longint; + Flags : longint; + DataOfs: longint; + DataLen: longint; + end; + + TResourceHeader = packed record + _Class : longint; + Flags : longint; + NameLen : word; + EntryCount : word; + end; + + TResourceFileHeader = packed record + Signature : word; + InfoType : word; + InfoSize : longint; + { ---- } + TableOfs : longint; + end; + + PResourceFile = ^TResourceFile; + + PResourceEntry = ^TResourceEntry; + TResourceEntry = object(TObject) + constructor Init(AID, ALangID, AFlags, ADataLen: longint); + private + ID : longint; + LangID : longint; + Flags : longint; + DataOfs : longint; + DataLen : longint; + procedure BuildHeader(var Header : TResourceEntryHeader); + end; + + PResourceEntryCollection = ^TResourceEntryCollection; + TResourceEntryCollection = object(TSortedCollection) + function At(Index: Sw_Integer): PResourceEntry; + function Compare(Key1, Key2: Pointer): Sw_Integer; virtual; + function SearchEntryForLang(ALangID: longint): PResourceEntry; + end; + + PGlobalResourceEntryCollection = ^TGlobalResourceEntryCollection; + TGlobalResourceEntryCollection = object(TSortedCollection) + function At(Index: Sw_Integer): PResourceEntry; + function Compare(Key1, Key2: Pointer): Sw_Integer; virtual; + end; + + PResource = ^TResource; + TResource = object(TObject) + constructor Init(const AName: string; AClass, AFlags: longint); + function GetName: string; virtual; + function FirstThatEntry(Func: pointer): PResourceEntry; virtual; + procedure ForEachEntry(Func: pointer); virtual; + destructor Done; virtual; + private + Name : PString; + _Class : longint; + Flags : longint; + Items : PResourceEntryCollection; + procedure BuildHeader(var Header : TResourceHeader); + end; + + PResourceCollection = ^TResourceCollection; + TResourceCollection = object(TSortedCollection) + function At(Index: Sw_Integer): PResource; + function Compare(Key1, Key2: Pointer): Sw_Integer; virtual; + function SearchResourceByName(const AName: string): PResource; + end; + + TResourceFile = object(TObject) + constructor Init(var RS: TStream; ALoad: boolean); + constructor Create(var RS: TStream); + constructor Load(var RS: TStream); + function FirstThatResource(Func: pointer): PResource; virtual; + procedure ForEachResource(Func: pointer); virtual; + procedure ForEachResourceEntry(Func: pointer); virtual; + function CreateResource(const Name: string; AClass, AFlags: longint): boolean; virtual; + function AddResourceEntry(const ResName: string; ALangID, AFlags: longint; var Data; + ADataSize: sw_integer): boolean; virtual; + function AddResourceEntryFromStream(const ResName: string; ALangID, AFlags: longint; + var Source: TStream; ADataSize: longint): boolean; virtual; + function DeleteResourceEntry(const ResName: string; ALangID: longint): boolean; virtual; + function DeleteResource(const ResName: string): boolean; virtual; + procedure Flush; virtual; + destructor Done; virtual; + public + BaseOfs: longint; + function FindResource(const ResName: string): PResource; + function FindResourceEntry(const ResName: string; ALangID: longint): PResourceEntry; + private + S : PStream; + Resources : PResourceCollection; + Entries : PGlobalResourceEntryCollection; + Header : TResourceFileHeader; + Modified : boolean; + procedure UpdateBlockDatas; + function GetNextEntryID: longint; + function GetTotalSize(IncludeHeaders: boolean): longint; + function CalcSizes(IncludeHeaders, UpdatePosData: boolean): longint; + procedure AddResEntryPtr(P: PResource; E: PResourceEntry); + procedure RemoveResEntryPtr(P: PResource; E: PResourceEntry); + function DeleteArea(AreaStart, AreaSize, TotalSize: longint): boolean; + procedure BuildFileHeader; + procedure WriteHeader; + procedure WriteResourceTable; + end; + +implementation + +uses CallSpec, + WUtils; + +function TResourceEntryCollection.At(Index: Sw_Integer): PResourceEntry; +begin + At:=inherited At(Index); +end; + +function TResourceEntryCollection.Compare(Key1, Key2: Pointer): Sw_Integer; +var K1: PResourceEntry absolute Key1; + K2: PResourceEntry absolute Key2; + Re: Sw_integer; +begin + if K1^.LangIDK2^.LangID then Re:= 1 else + Re:=0; + Compare:=Re; +end; + +function TResourceEntryCollection.SearchEntryForLang(ALangID: longint): PResourceEntry; +var P: PResourceEntry; + E: TResourceEntry; + Index: sw_integer; +begin + E.LangID:=ALangID; + if Search(@E,Index)=false then P:=nil else + P:=At(Index); + SearchEntryForLang:=P; +end; + +function TGlobalResourceEntryCollection.At(Index: Sw_Integer): PResourceEntry; +begin + At:=inherited At(Index); +end; + +function TGlobalResourceEntryCollection.Compare(Key1, Key2: Pointer): Sw_Integer; +var K1: PResourceEntry absolute Key1; + K2: PResourceEntry absolute Key2; + Re: Sw_integer; +begin + if K1^.IDK2^.ID then Re:= 1 else + Re:=0; + Compare:=Re; +end; + +constructor TResourceEntry.Init(AID, ALangID, AFlags, ADataLen: longint); +begin + inherited Init; + ID:=AID; + LangID:=ALangID; Flags:=AFlags; DataLen:=ADataLen; +end; + +procedure TResourceEntry.BuildHeader(var Header : TResourceEntryHeader); +begin + FillChar(Header,SizeOf(Header),0); + Header.ID:=ID; + Header.LangID:=LangID; + Header.Flags:=Flags; + Header.DataLen:=DataLen; + Header.DataOfs:=DataOfs; +end; + +constructor TResource.Init(const AName: string; AClass, AFlags: longint); +begin + inherited Init; + Name:=NewStr(AName); + _Class:=AClass; + Flags:=AFlags; + New(Items, Init(10,50)); +end; + +function TResource.GetName: string; +begin + GetName:=GetStr(Name); +end; + +function TResource.FirstThatEntry(Func: pointer): PResourceEntry; +var EP,P: PResourceEntry; + I: sw_integer; +begin + P:=nil; + for I:=0 to Items^.Count-1 do + begin + EP:=Items^.At(I); + if Byte(Longint(CallPointerMethodLocal(Func,PreviousFramePointer,@Self,EP)))<>0 then + begin + P := EP; + Break; + end; + end; + FirstThatEntry:=P; +end; + +procedure TResource.ForEachEntry(Func: pointer); +var RP: PResourceEntry; + I: sw_integer; +begin + for I:=0 to Items^.Count-1 do + begin + RP:=Items^.At(I); + CallPointerMethodLocal(Func,PreviousFramePointer,@Self,RP); + end; +end; + +procedure TResource.BuildHeader(var Header : TResourceHeader); +begin + FillChar(Header,SizeOf(Header),0); + Header._Class:=_Class; + Header.Flags:=Flags; + Header.NameLen:=length(GetName); + Header.EntryCount:=Items^.Count; +end; + +destructor TResource.Done; +begin + inherited Done; + if Name<>nil then DisposeStr(Name); Name:=nil; + if Items<>nil then Dispose(Items, Done); Items:=nil; +end; + +function TResourceCollection.At(Index: Sw_Integer): PResource; +begin + At:=inherited At(Index); +end; + +function TResourceCollection.Compare(Key1, Key2: Pointer): Sw_Integer; +var K1: PResource absolute Key1; + K2: PResource absolute Key2; + N1,N2: string; + Re: Sw_integer; +begin + N1:=UpcaseStr(K1^.GetName); N2:=UpcaseStr(K2^.GetName); + if N1N2 then Re:= 1 else + Re:=0; + Compare:=Re; +end; + +function TResourceCollection.SearchResourceByName(const AName: string): PResource; +var P,R: PResource; + Index: sw_integer; +begin + New(R, Init(AName,0,0)); + if Search(R,Index)=false then P:=nil else + P:=At(Index); + Dispose(R, Done); + SearchResourceByName:=P; +end; + +constructor TResourceFile.Create(var RS: TStream); +begin + if Init(RS,false)=false then + Fail; +end; + +constructor TResourceFile.Load(var RS: TStream); +begin + if Init(RS,true)=false then + Fail; +end; + +constructor TResourceFile.Init(var RS: TStream; ALoad: boolean); +var OK: boolean; + RH: TResourceHeader; + REH: TResourceEntryHeader; + EndPos,I: longint; + P: PResource; + E: PResourceEntry; + St: string; +begin + inherited Init; + S:=@RS; + New(Resources, Init(100, 1000)); + New(Entries, Init(500,2000)); + OK:=true; + if ALoad=false then + Modified:=true + else + begin + BaseOfs:=S^.GetPos; + S^.Read(Header,SizeOf(Header)); + OK:=(S^.Status=stOK) and + (Header.Signature=TPDataBlockSignature) and + (Header.InfoType=ResourceBlockSignature); + if OK then begin S^.Seek(BaseOfs+Header.TableOfs); OK:=S^.Status=stOK; end; + EndPos:=BaseOfs+Header.InfoSize; + if OK then + while OK and (S^.GetPos0 then + begin + P := RP; + Break; + end; + end; + FirstThatResource:=P; +end; + +procedure TResourceFile.ForEachResource(Func: pointer); +var RP: PResource; + I: sw_integer; +begin + for I:=0 to Resources^.Count-1 do + begin + RP:=Resources^.At(I); + CallPointerMethodLocal(Func,PreviousFramePointer,@Self,RP); + end; +end; + +procedure TResourceFile.ForEachResourceEntry(Func: pointer); +var E: PResourceEntry; + I: sw_integer; +begin + for I:=0 to Entries^.Count-1 do + begin + E:=Entries^.At(I); + CallPointerMethodLocal(Func,PreviousFramePointer,@Self,E); + end; +end; + +function TResourceFile.CreateResource(const Name: string; AClass, AFlags: longint): boolean; +var OK: boolean; + P: PResource; +begin + OK:=FindResource(Name)=nil; + if OK then + begin + New(P, Init(Name,AClass,AFlags)); + Resources^.Insert(P); + Modified:=true; + end; + CreateResource:=OK; +end; + +function TResourceFile.AddResourceEntry(const ResName: string; ALangID, AFlags: longint; var Data; + ADataSize: sw_integer): boolean; +const BlockSize = 4096; +var OK: boolean; + P: PResource; + E: PResourceEntry; + RemSize,CurOfs,FragSize: longint; +begin + P:=FindResource(ResName); + OK:=P<>nil; + if OK then + OK:=(P^.Items^.SearchEntryForLang(ALangID)=nil); + if OK then + begin + New(E, Init(GetNextEntryID,ALangID, AFlags, ADataSize)); + AddResEntryPtr(P,E); + UpdateBlockDatas; + RemSize:=ADataSize; CurOfs:=0; + S^.Seek(BaseOfs+E^.DataOfs); + while (RemSize>0) do + begin + FragSize:=Min(RemSize,BlockSize); + S^.Write(PByteArray(@Data)^[CurOfs],FragSize); + Dec(RemSize,FragSize); Inc(CurOfs,FragSize); + end; + Modified:=true; + end; + AddResourceEntry:=OK; +end; + +function TResourceFile.AddResourceEntryFromStream(const ResName: string; ALangID, AFlags: longint; + var Source: TStream; ADataSize: longint): boolean; +const BufSize = 4096; +var OK: boolean; + P: PResource; + E: PResourceEntry; + RemSize,FragSize: longint; + Buf: pointer; +begin + P:=FindResource(ResName); + OK:=P<>nil; + if OK then + OK:=(P^.Items^.SearchEntryForLang(ALangID)=nil); + if OK then + begin + New(E, Init(GetNextEntryID, ALangID, AFlags, ADataSize)); + AddResEntryPtr(P,E); + UpdateBlockDatas; + GetMem(Buf,BufSize); + RemSize:=ADataSize; + S^.Seek(BaseOfs+E^.DataOfs); + while (RemSize>0) do + begin + FragSize:=Min(RemSize,BufSize); + Source.Read(Buf^,FragSize); + S^.Write(Buf^,FragSize); + Dec(RemSize,FragSize); + end; + FreeMem(Buf,BufSize); + Modified:=true; + end; + AddResourceEntryFromStream:=OK; +end; + +function TResourceFile.DeleteResourceEntry(const ResName: string; ALangID: longint): boolean; +var E: PResourceEntry; + P: PResource; + OK: boolean; +begin + P:=FindResource(ResName); + OK:=P<>nil; + if OK then E:=P^.Items^.SearchEntryForLang(ALangID); + OK:=OK and (E<>nil); + if OK then + begin + OK:=DeleteArea(E^.DataOfs,E^.DataLen,GetTotalSize(false)); + if OK then begin RemoveResEntryPtr(P,E); Dispose(E, Done); end; + Modified:=true; + end; + DeleteResourceEntry:=OK; +end; + +function TResourceFile.DeleteResource(const ResName: string): boolean; +var P: PResource; + E: PResourceEntry; + OK: boolean; +begin + P:=FindResource(ResName); + OK:=P<>nil; + if P<>nil then + begin + while OK and (P^.Items^.Count>0) do + begin + E:=P^.Items^.At(P^.Items^.Count-1); + OK:=OK and DeleteResourceEntry(ResName,E^.LangID); + end; + Modified:=true; + end; + if OK then Resources^.Free(P); + DeleteResource:=OK; +end; + +function TResourceFile.FindResource(const ResName: string): PResource; +begin + FindResource:=Resources^.SearchResourceByName(ResName); +end; + +function TResourceFile.FindResourceEntry(const ResName: string; ALangID: longint): PResourceEntry; +var P: PResource; + E: PResourceEntry; +begin + E:=nil; + P:=FindResource(ResName); + if P<>nil then + E:=P^.Items^.SearchEntryForLang(ALangID); + FindResourceEntry:=E; +end; + +procedure TResourceFile.Flush; +begin + if Modified=false then Exit; + BuildFileHeader; + S^.Seek(BaseOfs); + WriteHeader; + S^.Seek(BaseOfs+Header.TableOfs); + WriteResourceTable; + S^.Truncate; + Modified:=false; +end; + +procedure TResourceFile.BuildFileHeader; +begin + FillChar(Header,SizeOf(Header),0); + with Header do + begin + Signature:=TPDataBlockSignature; + InfoType:=ResourceBlockSignature; + InfoSize:=GetTotalSize(true); + TableOfs:=GetTotalSize(false); + end; +end; + +procedure TResourceFile.WriteHeader; +begin + S^.Write(Header,SizeOf(Header)); +end; + +procedure TResourceFile.WriteResourceTable; +var RH: TResourceHeader; + REH: TResourceEntryHeader; +procedure WriteResource(P: PResource); {$ifndef FPC}far;{$endif} +procedure WriteResourceEntry(P: PResourceEntry); {$ifndef FPC}far;{$endif} +begin + P^.BuildHeader(REH); + S^.Write(REH,SizeOf(REH)); +end; +var N: string; +begin + if P^.Items^.Count=0 then Exit; { do not store resources with no entries } + P^.BuildHeader(RH); + S^.Write(RH,SizeOf(RH)); + N:=P^.GetName; + S^.Write(N[1],length(N)); + P^.ForEachEntry(@WriteResourceEntry); +end; +begin + ForEachResource(@WriteResource); +end; + +procedure TResourceFile.UpdateBlockDatas; +begin + CalcSizes(false,true); +end; + +function TResourceFile.GetTotalSize(IncludeHeaders: boolean): longint; +begin + GetTotalSize:=CalcSizes(IncludeHeaders,false); +end; + +function TResourceFile.CalcSizes(IncludeHeaders, UpdatePosData: boolean): longint; +var RH : TResourceHeader; + REH : TResourceEntryHeader; + Size: longint; +procedure AddResourceEntrySize(P: PResourceEntry); {$ifndef FPC}far;{$endif} +begin + if UpdatePosData then P^.DataOfs:=Size; + P^.BuildHeader(REH); + Inc(Size,REH.DataLen); +end; +begin + Size:=0; + Inc(Size,SizeOf(Header)); { this is on start so we always include it } + ForEachResourceEntry(@AddResourceEntrySize); + if IncludeHeaders then + begin + Inc(Size,SizeOf(RH)*Resources^.Count); + Inc(Size,SizeOf(REH)*Entries^.Count); + end; + CalcSizes:=Size; +end; + +function TResourceFile.DeleteArea(AreaStart, AreaSize, TotalSize: longint): boolean; +const BufSize = 4096; +var RemSize,FragSize,CurOfs: longint; + Buf: pointer; + OK: boolean; +begin + GetMem(Buf,BufSize); + RemSize:=TotalSize-(AreaStart+AreaSize); CurOfs:=0; + OK:=RemSize>=0; + while (RemSize>0) do + begin + FragSize:=Min(RemSize,BufSize); + S^.Seek(BaseOfs+AreaStart+AreaSize+CurOfs); + S^.Read(Buf^,BufSize); + OK:=OK and (S^.Status=stOK); + if OK then + begin + S^.Seek(BaseOfs+AreaStart+CurOfs); + S^.Write(Buf^,BufSize); + OK:=OK and (S^.Status=stOK); + end; + Inc(CurOfs,FragSize); Dec(RemSize,FragSize); + end; + FreeMem(Buf,BufSize); + DeleteArea:=OK; +end; + +procedure TResourceFile.AddResEntryPtr(P: PResource; E: PResourceEntry); +begin + if (P=nil) or (E=nil) then Exit; + P^.Items^.Insert(E); + Entries^.Insert(E); +end; + +procedure TResourceFile.RemoveResEntryPtr(P: PResource; E: PResourceEntry); +begin + if (P=nil) or (E=nil) then Exit; + Entries^.Delete(E); + P^.Items^.Delete(E); +end; + +function TResourceFile.GetNextEntryID: longint; +var ID: longint; +begin + if Entries^.Count=0 then ID:=1 else + ID:=Entries^.At(Entries^.Count-1)^.ID+1; + GetNextEntryID:=ID; +end; + +destructor TResourceFile.Done; +begin + Flush; + inherited Done; + if Resources<>nil then Dispose(Resources, Done); Resources:=nil; + if Entries<>nil then + begin Entries^.DeleteAll; Dispose(Entries, Done); Entries:=nil; end; +end; + + +END. +{ + $Log$ + Revision 1.1 1999-03-16 12:38:18 peter + * tools macro fixes + + tph writer + + first things for resource files + +} + diff --git a/ide/text/wtphwrit.pas b/ide/text/wtphwrit.pas new file mode 100644 index 0000000000..e976811d74 --- /dev/null +++ b/ide/text/wtphwrit.pas @@ -0,0 +1,283 @@ +{ + $Id$ + This file is part of the Free Pascal Integrated Development Environment + Copyright (c) 1998 by Berczi Gabor + + Routines to create .tph files + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +unit WTPHWriter; + +interface + +uses Objects,WHelp; + +const + HelpStamp = 'TURBO PASCAL HelpFile.'; + + DefFormatVersion = $34; + +type + PHelpFileWriter = ^THelpFileWriter; + THelpFileWriter = object(TOAHelpFile) + constructor Init(AFileName: string; AID: word); + function CreateTopic(HelpCtx: THelpCtx): PTopic; virtual; + procedure AddTopicToIndex(IndexTag: string; P: PTopic); virtual; + procedure AddLineToTopic(P: PTopic; Line: string); virtual; + procedure AddLinkToTopic(P: PTopic; AHelpCtx: THelpCtx); + procedure AddIndexEntry(Tag: string; P: PTopic); virtual; + function WriteFile: boolean; virtual; + destructor Done; virtual; + private + procedure CompleteContextNo; + procedure CalcTopicOfs; + procedure WriteHeader(var S: TStream); + procedure WriteCompressionRecord(var S: TStream); + procedure WriteContextTable(var S: TStream); + procedure WriteIndexTable(var S: TStream); + procedure WriteTopic(var S: TStream; T: PTopic); + procedure WriteRecord(var S: TStream; RecType: byte; var Buf; Size: word); + end; + +implementation + +constructor THelpFileWriter.Init(AFileName: string; AID: word); +var OK: boolean; +begin + THelpFile.Init(AID); + New(F, Init(AFileName, stCreate, HelpStreamBufSize)); + OK:=F<>nil; + if OK then OK:=(F^.Status=stOK); + if OK=false then Fail; +end; + +function THelpFileWriter.CreateTopic(HelpCtx: THelpCtx): PTopic; +var P: PTopic; +begin + if (HelpCtx<>0) and (SearchTopic(HelpCtx)<>nil) then + P:=nil + else + begin + P:=NewTopic(ID,HelpCtx,0,''); + Topics^.Insert(P); + end; + CreateTopic:=P; +end; + +procedure THelpFileWriter.AddTopicToIndex(IndexTag: string; P: PTopic); +begin + IndexEntries^.Insert(NewIndexEntry(IndexTag,P^.FileID,P^.HelpCtx)); +end; + +procedure THelpFileWriter.AddLineToTopic(P: PTopic; Line: string); +var OldText: pointer; + OldSize: word; +begin + if P=nil then Exit; + OldText:=P^.Text; OldSize:=P^.TextSize; + Inc(P^.TextSize,length(Line)+1); + GetMem(P^.Text,P^.TextSize); + if OldText<>nil then Move(OldText^,P^.Text^,OldSize); + Move(Line[1],P^.Text^[OldSize],length(Line)); + P^.Text^[OldSize+length(Line)]:=0; + if OldText<>nil then FreeMem(OldText,OldSize); +end; + +procedure THelpFileWriter.AddLinkToTopic(P: PTopic; AHelpCtx: THelpCtx); +var OldEntries: pointer; + OldCount : word; + OldSize : word; +begin + if P=nil then Exit; + OldEntries:=P^.Links; OldCount:=P^.LinkCount; OldSize:=P^.LinkSize; + Inc(P^.LinkCount); + GetMem(P^.Links,P^.LinkSize); + if OldEntries<>nil then Move(OldEntries^,P^.Links^,OldSize); + with P^.Links^[P^.LinkCount-1] do + begin + FileID:=ID; + Context:=AHelpCtx; + end; + if OldEntries<>nil then FreeMem(OldEntries,OldSize); +end; + +procedure THelpFileWriter.AddIndexEntry(Tag: string; P: PTopic); +begin + if P=nil then Exit; + IndexEntries^.Insert(NewIndexEntry(Tag,P^.FileID,P^.HelpCtx)); +end; + +function THelpFileWriter.WriteFile: boolean; +var I: sw_integer; + CtxStart: longint; +begin + CompleteContextNo; + CalcTopicOfs; + + WriteHeader(F^); + WriteCompressionRecord(F^); + CtxStart:=F^.GetPos; + WriteContextTable(F^); + WriteIndexTable(F^); + for I:=0 to Topics^.Count-1 do + begin + WriteTopic(F^,Topics^.At(I)); + end; + F^.Seek(CtxStart); + WriteContextTable(F^); +end; + +procedure THelpFileWriter.WriteHeader(var S: TStream); +var St: string; +begin + Version.FormatVersion:=DefFormatVersion; + + St:=HelpStamp+#0#$1a; + F^.Write(St[1],length(St)); + St:=Signature; + F^.Write(St[1],length(St)); + F^.Write(Version,SizeOf(Version)); + + WriteRecord(F^,rtFileHeader,Header,SizeOf(Header)); +end; + +procedure THelpFileWriter.WriteCompressionRecord(var S: TStream); +var CR: THLPCompression; +begin + FillChar(CR,SizeOf(CR),0); + WriteRecord(F^,rtCompression,CR,SizeOf(CR)); +end; + +procedure THelpFileWriter.WriteIndexTable(var S: TStream); +const BufSize = 65000; +var P: ^THLPIndexTable; + TableSize: word; +procedure AddByte(B: byte); +begin + PByteArray(@P^.Entries)^[TableSize]:=B; + Inc(TableSize); +end; +procedure AddEntry(Tag: string; HelpCtx: word); +var Len,I: byte; +begin + Len:=length(Tag); if Len>31 then Len:=31; + AddByte(Len); + for I:=1 to Len do + AddByte(ord(Tag[I])); + AddByte(Lo(HelpCtx)); AddByte(Hi(HelpCtx)); +end; +var I: sw_integer; +begin + if IndexEntries^.Count=0 then Exit; + GetMem(P,BufSize); + + TableSize:=0; + P^.IndexCount:=IndexEntries^.Count; + for I:=0 to IndexEntries^.Count-1 do + with IndexEntries^.At(I)^ do + AddEntry(Tag^,HelpCtx); + Inc(TableSize,SizeOf(P^.IndexCount)); + WriteRecord(F^,rtIndex,P^,TableSize); + + FreeMem(P,BufSize); +end; + +procedure THelpFileWriter.WriteContextTable(var S: TStream); +var Ctxs: ^THLPContexts; + CtxSize,I: word; + T: PTopic; + MaxCtx: longint; +begin + if Topics^.Count=0 then MaxCtx:=1 else + MaxCtx:=Topics^.At(Topics^.Count-1)^.HelpCtx; + CtxSize:=SizeOf(Ctxs^.ContextCount)+SizeOf(Ctxs^.Contexts[0])*(MaxCtx+1); + GetMem(Ctxs,CtxSize); FillChar(Ctxs^,CtxSize,0); + Ctxs^.ContextCount:=MaxCtx+1; + for I:=1 to Topics^.Count do + begin + T:=Topics^.At(I-1); + with Ctxs^.Contexts[T^.HelpCtx] do + begin + LoW:=(T^.FileOfs and $ffff); + HiB:=(T^.FileOfs shr 16) and $ff; + end; + end; + WriteRecord(F^,rtContext,Ctxs^,CtxSize); + FreeMem(Ctxs,CtxSize); +end; + +procedure THelpFileWriter.WriteTopic(var S: TStream; T: PTopic); +var TextBuf: PByteArray; + TextSize: word; + KWBuf: ^THLPKeywordRecord; + I,KWBufSize: word; +begin + T^.FileOfs:=S.GetPos; + TextBuf:=T^.Text; TextSize:=T^.TextSize; + WriteRecord(F^,rtText,TextBuf^,TextSize); + { write keyword record here } + KWBufSize:=SizeOf(KWBuf^)+SizeOf(KWBuf^.Keywords[0])*T^.LinkCount; + GetMem(KWBuf,KWBufSize); FillChar(KWBuf^,KWBufSize,0); + KWBuf^.KeywordCount:=T^.LinkCount; + for I:=0 to T^.LinkCount-1 do + KWBuf^.Keywords[I].kwContext:=T^.Links^[I].Context; + WriteRecord(F^,rtKeyword,KWBuf^,KWBufSize); + FreeMem(KWBuf,KWBufSize); +end; + +procedure THelpFileWriter.CompleteContextNo; +var P: PTopic; + NextTopicID: THelpCtx; +function SearchNextFreeTopicID: THelpCtx; +begin + while Topics^.SearchTopic(NextTopicID)<>nil do + Inc(NextTopicID); + SearchNextFreeTopicID:=NextTopicID; +end; +begin + NextTopicID:=1; + repeat + P:=Topics^.SearchTopic(0); + if P<>nil then + begin + Topics^.Delete(P); + P^.HelpCtx:=SearchNextFreeTopicID; + Topics^.Insert(P); + end; + until P=nil; +end; + +procedure THelpFileWriter.CalcTopicOfs; +begin +end; + +procedure THelpFileWriter.WriteRecord(var S: TStream; RecType: byte; var Buf; Size: word); +var RH: THLPRecordHeader; +begin + RH.RecType:=RecType; RH.RecLength:=Size; + S.Write(RH,SizeOf(RH)); + S.Write(Buf,Size); +end; + +destructor THelpFileWriter.Done; +begin + inherited Done; +end; + +END. +{ + $Log$ + Revision 1.1 1999-03-16 12:38:18 peter + * tools macro fixes + + tph writer + + first things for resource files + +} +