← Back to branch summary

~ubuntu-branches/ubuntu/lucid/fpc/lucid-proposed

« back to all changes in this revision

Viewing changes to fpcsrc/packages/chm/src/chmwriter.pas

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-10-09 23:29:00 UTC
  • mfrom: (4.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20081009232900-553f61m37jkp6upv
Tags: 2.2.2-4
http://bugs.debian.org/498882
[ Torsten Werner ]
* Update ABI version in fpc-depends automatically.
* Remove empty directories from binary package fpc-source.

[ Mazen Neifer ]
* Removed leading path when calling update-alternatives to remove a Linitian
  error.
* Fixed clean target.
* Improved description of packages. (Closes: #498882)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/chm/src/chmwriter.pas
 
1
{ Copyright (C) <2005> <Andrew Haines> chmwriter.pas
 
2
 
 
3
  This library is free software; you can redistribute it and/or modify it
 
4
  under the terms of the GNU Library General Public License as published by
 
5
  the Free Software Foundation; either version 2 of the License, or (at your
 
6
  option) any later version.
 
7
 
 
8
  This program is distributed in the hope that it will be useful, but WITHOUT
 
9
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
10
  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
 
11
  for more details.
 
12
 
 
13
  You should have received a copy of the GNU Library General Public License
 
14
  along with this library; if not, write to the Free Software Foundation,
 
15
  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
16
}
 
17
{
 
18
  See the file COPYING.FPC, included in this distribution,
 
19
  for details about the copyright.
 
20
}
 
21
unit chmwriter;
 
22
{$MODE OBJFPC}{$H+}
 
23
 
 
24
interface
 
25
uses Classes, ChmBase, chmtypes, chmspecialfiles;
 
26
 
 
27
type
 
28
 
 
29
  TGetDataFunc = function (const DataName: String; out PathInChm: String; out FileName: String; var Stream: TStream): Boolean of object;
 
30
  //  DataName :  A FileName or whatever so that the getter can find and open the file to add
 
31
  //  PathInChm:  This is the absolute path in the archive. i.e. /home/user/helpstuff/
 
32
  //              becomes '/' and /home/user/helpstuff/subfolder/ > /subfolder/
 
33
  //  FileName :  /home/user/helpstuff/index.html > index.html
 
34
  //  Stream   :  the file opened with DataName should be written to this stream
 
35
 
 
36
 
 
37
  { TChmWriter }
 
38
 
 
39
  TChmWriter = class(TObject)
 
40
    FOnLastFile: TNotifyEvent;
 
41
  private
 
42
  
 
43
    ForceExit: Boolean;
 
44
    
 
45
    FDefaultFont: String;
 
46
    FDefaultPage: String;
 
47
    FFullTextSearch: Boolean;
 
48
    FInternalFiles: TFileEntryList; // Contains a complete list of files in the chm including
 
49
    FFrameSize: LongWord;           // uncompressed files and special internal files of the chm
 
50
    FCurrentStream: TStream; // used to buffer the files that are to be compressed
 
51
    FCurrentIndex: Integer;
 
52
    FOnGetFileData: TGetDataFunc;
 
53
    FStringsStream: TMemoryStream;
 
54
    FContextStream: TMemoryStream; // the #IVB file
 
55
    FSection0: TMemoryStream;
 
56
    FSection1: TStream; // Compressed Stream
 
57
    FSection1Size: QWord;
 
58
    FSection1ResetTable: TMemoryStream; // has a list of frame positions NOT window positions
 
59
    FDirectoryListings: TStream;
 
60
    FOutStream: TStream;
 
61
    FFileNames: TStrings;
 
62
    FDestroyStream: Boolean;
 
63
    FTempStream: TStream;
 
64
    FPostStream: TStream;
 
65
    FTitle: String;
 
66
    FHasTOC: Boolean;
 
67
    FHasIndex: Boolean;
 
68
    FWindowSize: LongWord;
 
69
    FReadCompressedSize: QWord; // Current Size of Uncompressed data that went in Section1 (compressed)
 
70
    // Linear order of file
 
71
    ITSFHeader: TITSFHeader;
 
72
    HeaderSection0Table: TITSFHeaderEntry;  // points to HeaderSection0
 
73
    HeaderSection1Table: TITSFHeaderEntry; // points to HeaderSection1
 
74
    HeaderSuffix: TITSFHeaderSuffix; //contains the offset of CONTENTSection0 from zero
 
75
    HeaderSection0: TITSPHeaderPrefix;
 
76
    HeaderSection1: TITSPHeader; // DirectoryListings header
 
77
    // DirectoryListings
 
78
    // CONTENT Section 0 (section 1 is contained in section 0)
 
79
    // EOF
 
80
    // end linear header parts
 
81
    procedure InitITSFHeader;
 
82
    procedure InitHeaderSectionTable;
 
83
    procedure SetTempRawStream(const AValue: TStream);
 
84
    procedure WriteHeader(Stream: TStream);
 
85
    procedure CreateDirectoryListings;
 
86
    procedure WriteDirectoryListings(Stream: TStream);
 
87
    procedure StartCompressingStream;
 
88
    procedure WriteSYSTEM;
 
89
    procedure WriteITBITS;
 
90
    procedure WriteSTRINGS;
 
91
    procedure WriteIVB; // context ids
 
92
    procedure WriteREADMEFile;
 
93
    procedure WriteSection0;
 
94
    procedure WriteSection1;
 
95
    procedure WriteDataSpaceFiles(const AStream: TStream);
 
96
    function AddString(AString: String): LongWord;
 
97
    // callbacks for lzxcomp
 
98
    function  AtEndOfData: Longbool;
 
99
    function  GetData(Count: LongInt; Buffer: PByte): LongInt;
 
100
    function  WriteCompressedData(Count: Longint; Buffer: Pointer): LongInt;
 
101
    procedure MarkFrame(UnCompressedTotal, CompressedTotal: LongWord);
 
102
    // end callbacks
 
103
  public
 
104
    constructor Create(OutStream: TStream; FreeStreamOnDestroy: Boolean);
 
105
    destructor Destroy; override;
 
106
    procedure Execute;
 
107
    procedure AppendTOC(AStream: TStream);
 
108
    procedure AppendIndex(AStream: TStream);
 
109
    procedure AppendSearchDB(AName: String; AStream: TStream);
 
110
    procedure AddStreamToArchive(AFileName, APath: String; AStream: TStream; Compress: Boolean = True);
 
111
    procedure PostAddStreamToArchive(AFileName, APath: String; AStream: TStream; Compress: Boolean = True);
 
112
    procedure AddContext(AContext: DWord; ATopic: String);
 
113
    property WindowSize: LongWord read FWindowSize write FWindowSize default 2; // in $8000 blocks
 
114
    property FrameSize: LongWord read FFrameSize write FFrameSize default 1; // in $8000 blocks
 
115
    property FilesToCompress: TStrings read FFileNames;
 
116
    property OnGetFileData: TGetDataFunc read FOnGetFileData write FOnGetFileData;
 
117
    property OnLastFile: TNotifyEvent read FOnLastFile write FOnLastFile;
 
118
    property OutStream: TStream read FOutStream;
 
119
    property Title: String read FTitle write FTitle;
 
120
    property FullTextSearch: Boolean read FFullTextSearch write FFullTextSearch;
 
121
    property DefaultFont: String read FDefaultFont write FDefaultFont;
 
122
    property DefaultPage: String read FDefaultPage write FDefaultPage;
 
123
    property TempRawStream: TStream read FTempStream write SetTempRawStream;
 
124
    //property LocaleID: dword read ITSFHeader.LanguageID write ITSFHeader.LanguageID;
 
125
  end;
 
126
 
 
127
implementation
 
128
uses dateutils, sysutils, paslzxcomp;
 
129
 
 
130
const
 
131
 
 
132
  LZX_WINDOW_SIZE = 16; // 16 = 2 frames = 1 shl 16
 
133
  LZX_FRAME_SIZE = $8000;
 
134
 
 
135
{ TChmWriter }
 
136
 
 
137
procedure TChmWriter.InitITSFHeader;
 
138
begin
 
139
  with ITSFHeader do begin
 
140
    ITSFsig := ITSFFileSig;
 
141
    Version := NToLE(DWord(3));
 
142
    // we fix endian order when this is written to the stream
 
143
    HeaderLength := NToLE(DWord(SizeOf(TITSFHeader) + (SizeOf(TITSFHeaderEntry)*2) + SizeOf(TITSFHeaderSuffix)));
 
144
    Unknown_1 := NToLE(DWord(1));
 
145
    TimeStamp:= NToBE(MilliSecondOfTheDay(Now)); //bigendian
 
146
    LanguageID := NToLE(DWord($0409)); // English / English_US
 
147
    Guid1 := ITSFHeaderGUID;
 
148
    Guid2 := ITSFHeaderGUID;
 
149
  end;
 
150
end;
 
151
 
 
152
procedure TChmWriter.InitHeaderSectionTable;
 
153
begin
 
154
  // header section 0
 
155
  HeaderSection0Table.PosFromZero := LEToN(ITSFHeader.HeaderLength);
 
156
  HeaderSection0Table.Length := SizeOf(TITSPHeaderPrefix);
 
157
  // header section 1
 
158
  HeaderSection1Table.PosFromZero := HeaderSection0Table.PosFromZero + HeaderSection0Table.Length;
 
159
  HeaderSection1Table.Length := SizeOf(TITSPHeader)+FDirectoryListings.Size;
 
160
  
 
161
  //contains the offset of CONTENT Section0 from zero
 
162
  HeaderSuffix.Offset := HeaderSection1Table.PosFromZero + HeaderSection1Table.Length;
 
163
  
 
164
  // now fix endian stuff
 
165
  HeaderSection0Table.PosFromZero := NToLE(HeaderSection0Table.PosFromZero);
 
166
  HeaderSection0Table.Length := NToLE(HeaderSection0Table.Length);
 
167
  HeaderSection1Table.PosFromZero := NToLE(HeaderSection1Table.PosFromZero);
 
168
  HeaderSection1Table.Length := NToLE(HeaderSection1Table.Length);
 
169
 
 
170
  with HeaderSection0 do begin // TITSPHeaderPrefix;
 
171
    Unknown1 := NToLE(DWord($01FE));
 
172
    Unknown2 := 0;
 
173
    // at this point we are putting together the headers. content sections 0 and 1 are complete
 
174
    FileSize := NToLE(HeaderSuffix.Offset + FSection0.Size + FSection1Size);
 
175
    Unknown3 := 0;
 
176
    Unknown4 := 0;
 
177
  end;
 
178
  with HeaderSection1 do begin // TITSPHeader; // DirectoryListings header
 
179
    ITSPsig := ITSPHeaderSig;
 
180
    Version := NToLE(DWord(1));
 
181
    DirHeaderLength := NToLE(DWord(SizeOf(TITSPHeader)));  // Length of the directory header
 
182
    Unknown1 := NToLE(DWord($0A));
 
183
    ChunkSize := NToLE(DWord($1000));
 
184
    Density := NToLE(DWord(2));
 
185
    // updated when directory listings were created
 
186
    //IndexTreeDepth := 1 ; // 1 if there is no index 2 if there is one level of PMGI chunks. will update as
 
187
    //IndexOfRootChunk := -1;// if no root chunk
 
188
    //FirstPMGLChunkIndex,
 
189
    //LastPMGLChunkIndex: LongWord;
 
190
    
 
191
    Unknown2 := NToLE(Longint(-1));
 
192
    //DirectoryChunkCount: LongWord;
 
193
    LanguageID := NToLE(DWord($0409));
 
194
    GUID := ITSPHeaderGUID;
 
195
    LengthAgain := NToLE(DWord($54));
 
196
    Unknown3 := NToLE(Longint(-1));
 
197
    Unknown4 := NToLE(Longint(-1));
 
198
    Unknown5 := NToLE(Longint(-1));
 
199
  end;
 
200
  
 
201
  // more endian stuff
 
202
  HeaderSuffix.Offset := NToLE(HeaderSuffix.Offset);
 
203
end;
 
204
 
 
205
procedure TChmWriter.SetTempRawStream(const AValue: TStream);
 
206
begin
 
207
  if (FCurrentStream.Size > 0) or (FSection1.Size > 0) then
 
208
    raise Exception.Create('Cannot set the TempRawStream once data has been written to it!');
 
209
  if AValue = nil then
 
210
    raise Exception.Create('TempRawStream cannot be nil!');
 
211
  if FCurrentStream = AValue then
 
212
    exit;
 
213
  FCurrentStream.Free;
 
214
  FCurrentStream := AValue;
 
215
end;
 
216
 
 
217
procedure TChmWriter.WriteHeader(Stream: TStream);
 
218
begin
 
219
  Stream.Write(ITSFHeader, SizeOf(TITSFHeader));
 
220
  Stream.Write(HeaderSection0Table, SizeOf(TITSFHeaderEntry));
 
221
  Stream.Write(HeaderSection1Table, SizeOf(TITSFHeaderEntry));
 
222
  Stream.Write(HeaderSuffix, SizeOf(TITSFHeaderSuffix));
 
223
  Stream.Write(HeaderSection0, SizeOf(TITSPHeaderPrefix));
 
224
 
 
225
end;
 
226
 
 
227
procedure TChmWriter.CreateDirectoryListings;
 
228
type
 
229
  TFirstListEntry = record
 
230
    Entry: array[0..511] of byte;
 
231
    Size: Integer;
 
232
  end;
 
233
var
 
234
  Buffer: array [0..511] of Byte;
 
235
  IndexBlock: TPMGIDirectoryChunk;
 
236
  ListingBlock: TDirectoryChunk;
 
237
  I: Integer;
 
238
  Size: Integer;
 
239
  FESize: Integer;
 
240
  FileName: String;
 
241
  FileNameSize: Integer;
 
242
  LastListIndex: Integer;
 
243
  FirstListEntry: TFirstListEntry;
 
244
  ChunkIndex: Integer;
 
245
  ListHeader: TPMGListChunk;
 
246
const
 
247
  PMGL = 'PMGL';
 
248
  PMGI = 'PMGI';
 
249
  procedure UpdateLastListChunk;
 
250
  var
 
251
    Tmp: QWord;
 
252
  begin
 
253
    if ChunkIndex < 1 then begin
 
254
      Exit;
 
255
    end;
 
256
    Tmp := FDirectoryListings.Position;
 
257
    FDirectoryListings.Position := (LastListIndex) * $1000;
 
258
    FDirectoryListings.Read(ListHeader, SizeOf(TPMGListChunk));
 
259
    FDirectoryListings.Position := (LastListIndex) * $1000;
 
260
    ListHeader.NextChunkIndex := NToLE(ChunkIndex);
 
261
    FDirectoryListings.Write(ListHeader, SizeOf(TPMGListChunk));
 
262
    FDirectoryListings.Position := Tmp;
 
263
  end;
 
264
  procedure WriteIndexChunk(ShouldFinish: Boolean = False);
 
265
  var
 
266
    IndexHeader: TPMGIIndexChunk;
 
267
    ParentIndex,
 
268
    TmpIndex: TPMGIDirectoryChunk;
 
269
  begin
 
270
    with IndexHeader do begin
 
271
      PMGIsig := PMGI;
 
272
      UnusedSpace := NToLE(IndexBlock.FreeSpace);
 
273
    end;
 
274
    IndexBlock.WriteHeader(@IndexHeader);
 
275
    IndexBlock.WriteChunkToStream(FDirectoryListings, ChunkIndex, ShouldFinish);
 
276
    IndexBlock.Clear;
 
277
    if HeaderSection1.IndexOfRootChunk < 0 then HeaderSection1.IndexOfRootChunk := ChunkIndex;
 
278
    if ShouldFinish then begin;
 
279
      HeaderSection1.IndexTreeDepth := 2;
 
280
      ParentIndex := IndexBlock.ParentChunk;
 
281
      if ParentIndex <> nil then repeat // the parent index is notified by our child index when to write
 
282
        HeaderSection1.IndexOfRootChunk := ChunkIndex;
 
283
        TmpIndex := ParentIndex;
 
284
        ParentIndex := ParentIndex.ParentChunk;
 
285
        TmpIndex.Free;
 
286
        Inc(HeaderSection1.IndexTreeDepth);
 
287
        Inc(ChunkIndex);
 
288
      until ParentIndex = nil;
 
289
    end;
 
290
    Inc(ChunkIndex);
 
291
 
 
292
  end;
 
293
  procedure WriteListChunk;
 
294
  begin
 
295
    with ListHeader do begin
 
296
      PMGLsig := PMGL;
 
297
      UnusedSpace := NToLE(ListingBlock.FreeSpace);
 
298
      Unknown1 :=  0;
 
299
      PreviousChunkIndex := NToLE(LastListIndex);
 
300
      NextChunkIndex := NToLE(Longint(-1)); // we update this when we write the next chunk
 
301
    end;
 
302
    if HeaderSection1.FirstPMGLChunkIndex <= 0 then
 
303
      HeaderSection1.FirstPMGLChunkIndex := NToLE(ChunkIndex);
 
304
    HeaderSection1.LastPMGLChunkIndex := NToLE(ChunkIndex);
 
305
    ListingBlock.WriteHeader(@ListHeader);
 
306
    ListingBlock.WriteChunkToStream(FDirectoryListings);
 
307
    ListingBlock.Clear;
 
308
    UpdateLastListChunk;
 
309
 
 
310
    LastListIndex := ChunkIndex;
 
311
    Inc(ChunkIndex);
 
312
    // now add to index
 
313
    if not IndexBlock.CanHold(FirstListEntry.Size) then
 
314
      WriteIndexChunk;
 
315
    IndexBlock.WriteEntry(FirstListEntry.Size, @FirstListEntry.Entry[0])
 
316
  end;
 
317
begin
 
318
  // first sort the listings
 
319
  FInternalFiles.Sort;
 
320
  HeaderSection1.IndexTreeDepth := 1;
 
321
  HeaderSection1.IndexOfRootChunk := -1;
 
322
  
 
323
  ChunkIndex := 0;
 
324
 
 
325
  IndexBlock := TPMGIDirectoryChunk.Create(SizeOf(TPMGIIndexChunk));
 
326
  ListingBlock := TDirectoryChunk.Create(SizeOf(TPMGListChunk));
 
327
 
 
328
  LastListIndex  := -1;
 
329
 
 
330
  // add files to a pmgl block until it is full.
 
331
  // after the block is full make a pmgi block and add the first entry of the pmgl block
 
332
  // repeat until the index block is full and start another.
 
333
  // the pmgi chunks take care of needed parent chunks in the tree
 
334
  for I := 0 to FInternalFiles.Count-1 do begin
 
335
    Size := 0;
 
336
    FileName := FInternalFiles.FileEntry[I].Path + FInternalFiles.FileEntry[I].Name;
 
337
    FileNameSize := Length(FileName);
 
338
    // filename length
 
339
    Inc(Size, WriteCompressedInteger(@Buffer[Size], FileNameSize));
 
340
    // filename
 
341
    Move(FileName[1], Buffer[Size], FileNameSize);
 
342
    Inc(Size, FileNameSize);
 
343
    FESize := Size;
 
344
    // File is compressed...
 
345
    Inc(Size, WriteCompressedInteger(@Buffer[Size], Ord(FInternalFiles.FileEntry[I].Compressed)));
 
346
    // Offset from section start
 
347
    Inc(Size, WriteCompressedInteger(@Buffer[Size], FInternalFiles.FileEntry[I].DecompressedOffset));
 
348
    // Size when uncompressed
 
349
    Inc(Size, WriteCompressedInteger(@Buffer[Size], FInternalFiles.FileEntry[I].DecompressedSize));
 
350
 
 
351
    if not ListingBlock.CanHold(Size) then
 
352
      WriteListChunk;
 
353
    
 
354
    ListingBlock.WriteEntry(Size, @Buffer[0]);
 
355
    
 
356
    if ListingBlock.ItemCount = 1 then begin // add the first list item to the index
 
357
      Move(Buffer[0], FirstListEntry.Entry[0], FESize);
 
358
      FirstListEntry.Size := FESize + WriteCompressedInteger(@FirstListEntry.Entry[FESize], ChunkIndex);
 
359
    end;
 
360
  end;
 
361
  if ListingBlock.ItemCount > 0 then WriteListChunk;
 
362
 
 
363
  if ChunkIndex > 1 then begin
 
364
    if (IndexBlock.ItemCount > 1)
 
365
    or ( (IndexBlock.ItemCount > 0) and (HeaderSection1.IndexOfRootChunk > -1) )
 
366
    then WriteIndexChunk(True);
 
367
  end;
 
368
 
 
369
  HeaderSection1.DirectoryChunkCount := NToLE(DWord(FDirectoryListings.Size div $1000));
 
370
 
 
371
  IndexBlock.Free;
 
372
  ListingBlock.Free;
 
373
  
 
374
  //now fix some endian stuff
 
375
  HeaderSection1.IndexOfRootChunk := NToLE(HeaderSection1.IndexOfRootChunk);
 
376
  HeaderSection1.IndexTreeDepth := NtoLE(HeaderSection1.IndexTreeDepth);
 
377
end;
 
378
 
 
379
procedure TChmWriter.WriteDirectoryListings(Stream: TStream);
 
380
begin
 
381
  Stream.Write(HeaderSection1, SizeOf(HeaderSection1));
 
382
  FDirectoryListings.Position := 0;
 
383
  Stream.CopyFrom(FDirectoryListings, FDirectoryListings.Size);
 
384
  FDirectoryListings.Position := 0;
 
385
  //TMemoryStream(FDirectoryListings).SaveToFile('dirlistings.pmg');
 
386
end;
 
387
 
 
388
procedure TChmWriter.WriteSystem;
 
389
var
 
390
  Entry: TFileEntryRec;
 
391
  TmpStr: String;
 
392
  TmpTitle: String;
 
393
const
 
394
  VersionStr = 'HHA Version 4.74.8702'; // does this matter?
 
395
begin
 
396
  // this creates the /#SYSTEM file
 
397
  Entry.Name := '#SYSTEM';
 
398
  Entry.Path := '/';
 
399
  Entry.Compressed := False;
 
400
  Entry.DecompressedOffset := FSection0.Position;
 
401
  // EntryCodeOrder: 10 9 4 2 3 16 6 0 1 5
 
402
  FSection0.WriteDWord(NToLE(Word(3))); // Version
 
403
  if Title <> '' then
 
404
    TmpTitle := Title
 
405
  else
 
406
    TmpTitle := 'default';
 
407
 
 
408
  // Code -> Length -> Data
 
409
  // 10
 
410
  FSection0.WriteWord(NToLE(Word(10)));
 
411
  FSection0.WriteWord(NToLE(Word(SizeOf(DWord))));
 
412
  FSection0.WriteDWord(NToLE(MilliSecondOfTheDay(Now)));
 
413
  // 9
 
414
  FSection0.WriteWord(NToLE(Word(9)));
 
415
  FSection0.WriteWord(NToLE(Word(SizeOf(VersionStr)+1)));
 
416
  FSection0.Write(VersionStr, SizeOf(VersionStr));
 
417
  FSection0.WriteByte(0);
 
418
  // 4 A struct that is only needed to set if full text search is on.
 
419
  FSection0.WriteWord(NToLE(Word(4)));
 
420
  FSection0.WriteWord(NToLE(Word(36))); // size
 
421
  FSection0.WriteDWord(NToLE(DWord($0409)));
 
422
  FSection0.WriteDWord(NToLE(DWord(Ord(FFullTextSearch))));
 
423
  FSection0.WriteDWord(0);
 
424
  FSection0.WriteDWord(0);
 
425
  FSection0.WriteDWord(0);
 
426
  // two for a QWord
 
427
  FSection0.WriteDWord(0);
 
428
  FSection0.WriteDWord(0);
 
429
  
 
430
  FSection0.WriteDWord(0);
 
431
  FSection0.WriteDWord(0);
 
432
 
 
433
  
 
434
 
 
435
  
 
436
  ////////////////////////<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 
437
  // 2  default page to load
 
438
  if FDefaultPage <> '' then begin
 
439
    FSection0.WriteWord(NToLE(Word(2)));
 
440
    FSection0.WriteWord(NToLE(Word(Length(FDefaultPage)+1)));
 
441
    FSection0.Write(FDefaultPage[1], Length(FDefaultPage));
 
442
    FSection0.WriteByte(0);
 
443
  end;
 
444
  // 3  Title
 
445
  if FTitle <> '' then begin
 
446
    FSection0.WriteWord(NToLE(Word(3)));
 
447
    FSection0.WriteWord(NToLE(Word(Length(FTitle)+1)));
 
448
    FSection0.Write(FTitle[1], Length(FTitle));
 
449
    FSection0.WriteByte(0);
 
450
  end;
 
451
 
 
452
  // 16 Default Font
 
453
  if FDefaultFont <> '' then begin
 
454
    FSection0.WriteWord(NToLE(Word(16)));
 
455
    FSection0.WriteWord(NToLE(Word(Length(FDefaultFont)+1)));
 
456
    FSection0.Write(FDefaultFont[1], Length(FDefaultFont));
 
457
    FSection0.WriteByte(0);
 
458
  end;
 
459
  
 
460
  // 6
 
461
  // unneeded. if output file is :  /somepath/OutFile.chm the value here is outfile(lowercase)
 
462
  
 
463
  // 0 Table of contents filename
 
464
  if FHasTOC then begin
 
465
    TmpStr := 'default.hhc';
 
466
    FSection0.WriteWord(0);
 
467
    FSection0.WriteWord(NToLE(Word(Length(TmpStr)+1)));
 
468
    FSection0.Write(TmpStr[1], Length(TmpStr));
 
469
    FSection0.WriteByte(0);
 
470
  end;
 
471
  // 1
 
472
  // hhk Index
 
473
  if FHasIndex then begin
 
474
    TmpStr := 'default.hhk';
 
475
    FSection0.WriteWord(NToLE(Word(1)));
 
476
    FSection0.WriteWord(NToLE(Word(Length(TmpStr)+1)));
 
477
    FSection0.Write(TmpStr[1], Length(TmpStr));
 
478
    FSection0.WriteByte(0);
 
479
  end;
 
480
  // 5 Default Window.
 
481
  // Not likely needed
 
482
  
 
483
  Entry.DecompressedSize := FSection0.Position - Entry.DecompressedOffset;
 
484
  FInternalFiles.AddEntry(Entry);
 
485
end;
 
486
 
 
487
procedure TChmWriter.WriteITBITS;
 
488
var
 
489
  Entry: TFileEntryRec;
 
490
begin
 
491
  // This is an empty and useless file
 
492
  Entry.Name := '#ITBITS';
 
493
  Entry.Path := '/';
 
494
  Entry.Compressed := False;
 
495
  Entry.DecompressedOffset := FSection0.Position;
 
496
  Entry.DecompressedSize := 0;
 
497
  
 
498
  FInternalFiles.AddEntry(Entry);
 
499
end;
 
500
 
 
501
procedure TChmWriter.WriteSTRINGS;
 
502
begin
 
503
  if FStringsStream.Size = 0 then;
 
504
    FStringsStream.WriteByte(0);
 
505
  FStringsStream.Position := 0;
 
506
  AddStreamToArchive('#STRINGS', '/', FStringsStream);
 
507
end;
 
508
 
 
509
procedure TChmWriter.WriteIVB;
 
510
begin
 
511
  if FContextStream = nil then exit;
 
512
 
 
513
  FContextStream.Position := 0;
 
514
  // the size of all the entries
 
515
  FContextStream.WriteDWord(NToLE(DWord(FContextStream.Size-SizeOf(dword))));
 
516
  
 
517
  FContextStream.Position := 0;
 
518
  AddStreamToArchive('#IVB', '/', FContextStream);
 
519
end;
 
520
 
 
521
procedure TChmWriter.WriteREADMEFile;
 
522
const DISCLAIMER_STR = 'This archive was not made by the MS HTML Help Workshop(r)(tm) program.';
 
523
var
 
524
  Entry: TFileEntryRec;
 
525
begin
 
526
  // This procedure puts a file in the archive that says it wasn't compiled with the MS compiler
 
527
  Entry.Compressed := False;
 
528
  Entry.DecompressedOffset := FSection0.Position;
 
529
  FSection0.Write(DISCLAIMER_STR, SizeOf(DISCLAIMER_STR));
 
530
  Entry.DecompressedSize := FSection0.Position - Entry.DecompressedOffset;
 
531
  Entry.Path := '/';
 
532
  Entry.Name := '_#_README_#_'; //try to use a name that won't conflict with normal names
 
533
  FInternalFiles.AddEntry(Entry);
 
534
end;
 
535
 
 
536
 
 
537
procedure TChmWriter.WriteSection0;
 
538
begin
 
539
  FSection0.Position := 0;
 
540
  FOutStream.CopyFrom(FSection0, FSection0.Size);
 
541
end;
 
542
 
 
543
procedure TChmWriter.WriteSection1;
 
544
begin
 
545
  WriteContentToStream(FOutStream, FSection1);
 
546
end;
 
547
 
 
548
procedure TChmWriter.WriteDataSpaceFiles(const AStream: TStream);
 
549
var
 
550
  Entry: TFileEntryRec;
 
551
begin
 
552
  // This procedure will write all files starting with ::
 
553
  Entry.Compressed := False; // None of these files are compressed
 
554
 
 
555
  //  ::DataSpace/NameList
 
556
  Entry.DecompressedOffset := FSection0.Position;
 
557
  Entry.DecompressedSize := WriteNameListToStream(FSection0, [snUnCompressed,snMSCompressed]);
 
558
  Entry.Path := '::DataSpace/';
 
559
  Entry.Name := 'NameList';
 
560
  FInternalFiles.AddEntry(Entry, False);
 
561
 
 
562
  //  ::DataSpace/Storage/MSCompressed/ControlData
 
563
  Entry.DecompressedOffset := FSection0.Position;
 
564
  Entry.DecompressedSize := WriteControlDataToStream(FSection0, 2, 2, 1);
 
565
  Entry.Path := '::DataSpace/Storage/MSCompressed/';
 
566
  Entry.Name := 'ControlData';
 
567
  FInternalFiles.AddEntry(Entry, False);
 
568
  
 
569
  //  ::DataSpace/Storage/MSCompressed/SpanInfo
 
570
  Entry.DecompressedOffset := FSection0.Position;
 
571
  Entry.DecompressedSize := WriteSpanInfoToStream(FSection0, FReadCompressedSize);
 
572
  Entry.Path := '::DataSpace/Storage/MSCompressed/';
 
573
  Entry.Name := 'SpanInfo';
 
574
  FInternalFiles.AddEntry(Entry, False);
 
575
 
 
576
  //  ::DataSpace/Storage/MSCompressed/Transform/List
 
577
  Entry.DecompressedOffset := FSection0.Position;
 
578
  Entry.DecompressedSize := WriteTransformListToStream(FSection0);
 
579
  Entry.Path := '::DataSpace/Storage/MSCompressed/Transform/';
 
580
  Entry.Name := 'List';
 
581
  FInternalFiles.AddEntry(Entry, False);
 
582
 
 
583
  //  ::DataSpace/Storage/MSCompressed/Transform/{7FC28940-9D31-11D0-9B27-00A0C91E9C7C}/
 
584
  //  ::DataSpace/Storage/MSCompressed/Transform/{7FC28940-9D31-11D0-9B27-00A0C91E9C7C}/InstanceData/ResetTable
 
585
  Entry.DecompressedOffset := FSection0.Position;
 
586
  Entry.DecompressedSize := WriteResetTableToStream(FSection0, FSection1ResetTable);
 
587
  Entry.Path := '::DataSpace/Storage/MSCompressed/Transform/{7FC28940-9D31-11D0-9B27-00A0C91E9C7C}/InstanceData/';
 
588
  Entry.Name := 'ResetTable';
 
589
  FInternalFiles.AddEntry(Entry, True);
 
590
 
 
591
 
 
592
  //  ::DataSpace/Storage/MSCompressed/Content do this last
 
593
  Entry.DecompressedOffset := FSection0.Position;
 
594
  Entry.DecompressedSize := FSection1Size; // we will write it directly to FOutStream later
 
595
  Entry.Path := '::DataSpace/Storage/MSCompressed/';
 
596
  Entry.Name := 'Content';
 
597
  FInternalFiles.AddEntry(Entry, False);
 
598
 
 
599
  
 
600
end;
 
601
 
 
602
function TChmWriter.AddString(AString: String): LongWord;
 
603
begin
 
604
  // #STRINGS starts with a null char
 
605
  if FStringsStream.Size = 0 then FStringsStream.WriteByte(0);
 
606
  // each entry is a null terminated string
 
607
  Result := FStringsStream.Position;
 
608
  FStringsStream.WriteBuffer(AString[1], Length(AString));
 
609
  FStringsStream.WriteByte(0);
 
610
end;
 
611
 
 
612
function _AtEndOfData(arg: pointer): LongBool; cdecl;
 
613
begin
 
614
  Result := TChmWriter(arg).AtEndOfData;
 
615
end;
 
616
 
 
617
function TChmWriter.AtEndOfData: LongBool;
 
618
begin
 
619
  Result := ForceExit or (FCurrentIndex >= FFileNames.Count-1);
 
620
  if Result then
 
621
    Result := Integer(FCurrentStream.Position) >= Integer(FCurrentStream.Size)-1;
 
622
end;
 
623
 
 
624
function _GetData(arg: pointer; Count: LongInt; Buffer: Pointer): LongInt; cdecl;
 
625
begin
 
626
  Result := TChmWriter(arg).GetData(Count, PByte(Buffer));
 
627
end;
 
628
 
 
629
function TChmWriter.GetData(Count: LongInt; Buffer: PByte): LongInt;
 
630
var
 
631
  FileEntry: TFileEntryRec;
 
632
begin
 
633
  Result := 0;
 
634
  while (Result < Count) and (not AtEndOfData) do begin
 
635
    Inc(Result, FCurrentStream.Read(Buffer[Result], Count-Result));
 
636
    if (Result < Count) and (not AtEndOfData)
 
637
    then begin
 
638
      // the current file has been read. move to the next file in the list
 
639
      FCurrentStream.Position := 0;
 
640
      Inc(FCurrentIndex);
 
641
      ForceExit := OnGetFileData(FFileNames[FCurrentIndex], FileEntry.Path, FileEntry.Name, FCurrentStream);
 
642
      FileEntry.DecompressedSize := FCurrentStream.Size;
 
643
      FileEntry.DecompressedOffset := FReadCompressedSize; //269047723;//to test writing really large numbers
 
644
      FileEntry.Compressed := True;
 
645
      
 
646
      FInternalFiles.AddEntry(FileEntry);
 
647
      // So the next file knows it's offset
 
648
      Inc(FReadCompressedSize,  FileEntry.DecompressedSize);
 
649
      FCurrentStream.Position := 0;
 
650
    end;
 
651
 
 
652
    // this is intended for programs to add perhaps a file
 
653
    // after all the other files have been added.
 
654
    if (AtEndOfData)
 
655
    and (FCurrentStream <> FPostStream) then
 
656
    begin
 
657
      if Assigned(FOnLastFile) then
 
658
        FOnLastFile(Self);
 
659
      FCurrentStream.Free;
 
660
      FCurrentStream := FPostStream;
 
661
      FCurrentStream.Position := 0;
 
662
      Inc(FReadCompressedSize, FCurrentStream.Size);
 
663
    end;
 
664
  end;
 
665
end;
 
666
 
 
667
function _WriteCompressedData(arg: pointer; Count: LongInt; Buffer: Pointer): LongInt; cdecl;
 
668
begin
 
669
  Result := TChmWriter(arg).WriteCompressedData(Count, Buffer);
 
670
end;
 
671
 
 
672
function TChmWriter.WriteCompressedData(Count: Longint; Buffer: Pointer): LongInt;
 
673
begin
 
674
  // we allocate a MB at a time to limit memory reallocation since this
 
675
  // writes usually 2 bytes at a time
 
676
  if (FSection1 is TMemoryStream) and (FSection1.Position >= FSection1.Size-1) then begin
 
677
    FSection1.Size := FSection1.Size+$100000;
 
678
  end;
 
679
  Result := FSection1.Write(Buffer^, Count);
 
680
  Inc(FSection1Size, Result);
 
681
end;
 
682
 
 
683
procedure _MarkFrame(arg: pointer; UncompressedTotal, CompressedTotal: LongWord); cdecl;
 
684
begin
 
685
  TChmWriter(arg).MarkFrame(UncompressedTotal, CompressedTotal);
 
686
end;
 
687
 
 
688
procedure TChmWriter.MarkFrame(UnCompressedTotal, CompressedTotal: LongWord);
 
689
  procedure WriteQWord(Value: QWord);
 
690
  begin
 
691
    FSection1ResetTable.Write(NToLE(Value), 8);
 
692
  end;
 
693
  procedure IncEntryCount;
 
694
  var
 
695
    OldPos: QWord;
 
696
    Value: DWord;
 
697
  begin
 
698
    OldPos := FSection1ResetTable.Position;
 
699
    FSection1ResetTable.Position := $4;
 
700
    Value := LeToN(FSection1ResetTable.ReadDWord)+1;
 
701
    FSection1ResetTable.Position := $4;
 
702
    FSection1ResetTable.WriteDWord(NToLE(Value));
 
703
    FSection1ResetTable.Position := OldPos;
 
704
  end;
 
705
  procedure UpdateTotalSizes;
 
706
  var
 
707
    OldPos: QWord;
 
708
  begin
 
709
    OldPos := FSection1ResetTable.Position;
 
710
    FSection1ResetTable.Position := $10;
 
711
    WriteQWord(FReadCompressedSize); // size of read data that has been compressed
 
712
    WriteQWord(CompressedTotal);
 
713
    FSection1ResetTable.Position := OldPos;
 
714
  end;
 
715
begin
 
716
  if FSection1ResetTable.Size = 0 then begin
 
717
    // Write the header
 
718
    FSection1ResetTable.WriteDWord(NtoLE(DWord(2)));
 
719
    FSection1ResetTable.WriteDWord(0); // number of entries. we will correct this with IncEntryCount
 
720
    FSection1ResetTable.WriteDWord(NtoLE(DWord(8))); // Size of Entries (qword)
 
721
    FSection1ResetTable.WriteDWord(NtoLE(DWord($28))); // Size of this header
 
722
    WriteQWord(0); // Total Uncompressed Size
 
723
    WriteQWord(0); // Total Compressed Size
 
724
    WriteQWord(NtoLE($8000)); // Block Size
 
725
    WriteQWord(0); // First Block start
 
726
  end;
 
727
  IncEntryCount;
 
728
  UpdateTotalSizes;
 
729
  WriteQWord(CompressedTotal); // Next Block Start
 
730
  // We have to trim the last entry off when we are done because there is no next block in that case
 
731
end;
 
732
 
 
733
constructor TChmWriter.Create(OutStream: TStream; FreeStreamOnDestroy: Boolean);
 
734
begin
 
735
  if OutStream = nil then Raise Exception.Create('TChmWriter.OutStream Cannot be nil!');
 
736
  FCurrentStream := TMemoryStream.Create;
 
737
  FCurrentIndex := -1;
 
738
  FOutStream := OutStream;
 
739
  FInternalFiles := TFileEntryList.Create;
 
740
  FStringsStream := TmemoryStream.Create;
 
741
  FSection0 := TMemoryStream.Create;
 
742
  FSection1 := TMemoryStream.Create;
 
743
  FSection1ResetTable := TMemoryStream.Create;
 
744
  FDirectoryListings := TMemoryStream.Create;
 
745
  FPostStream := TMemoryStream.Create;;
 
746
  FDestroyStream := FreeStreamOnDestroy;
 
747
  FFileNames := TStringList.Create;
 
748
end;
 
749
 
 
750
destructor TChmWriter.Destroy;
 
751
begin
 
752
  if FDestroyStream then FOutStream.Free;
 
753
  if Assigned(FContextStream) then FContextStream.Free;
 
754
  FInternalFiles.Free;
 
755
  FCurrentStream.Free;
 
756
  FStringsStream.Free;
 
757
  FSection0.Free;
 
758
  FSection1.Free;
 
759
  FSection1ResetTable.Free;
 
760
  FDirectoryListings.Free;
 
761
  FFileNames.Free;
 
762
  inherited Destroy;
 
763
end;
 
764
 
 
765
procedure TChmWriter.Execute;
 
766
begin
 
767
  InitITSFHeader;
 
768
  FOutStream.Position := 0;
 
769
  FSection1Size := 0;
 
770
 
 
771
  // write any internal files to FCurrentStream that we want in the compressed section
 
772
  WriteIVB;
 
773
  WriteSTRINGS;
 
774
  
 
775
  // written to Section0 (uncompressed)
 
776
  WriteREADMEFile;
 
777
  
 
778
  // move back to zero so that we can start reading from zero :)
 
779
  FReadCompressedSize := FCurrentStream.Size;
 
780
  FCurrentStream.Position := 0;  // when compressing happens, first the FCurrentStream is read
 
781
                                 // before loading user files. So we can fill FCurrentStream with
 
782
                                 // internal files first.
 
783
 
 
784
  // this gathers ALL files that should be in section1 (the compressed section)
 
785
  StartCompressingStream;
 
786
  FSection1.Size := FSection1Size;
 
787
 
 
788
  // This creates and writes the #ITBITS (empty) file to section0
 
789
  WriteITBITS;
 
790
  // This creates and writes the #SYSTEM file to section0
 
791
  WriteSystem;
 
792
 
 
793
  //this creates all special files in the archive that start with ::DataSpace
 
794
  WriteDataSpaceFiles(FSection0);
 
795
  
 
796
  // creates all directory listings including header
 
797
  CreateDirectoryListings;
 
798
 
 
799
  // do this after we have compressed everything so that we know the values that must be written
 
800
  InitHeaderSectionTable;
 
801
 
 
802
  // Now we can write everything to FOutStream
 
803
  WriteHeader(FOutStream);
 
804
  WriteDirectoryListings(FOutStream);
 
805
  WriteSection0; //does NOT include section 1 even though section0.content IS section1
 
806
  WriteSection1; // writes section 1 to FOutStream
 
807
end;
 
808
 
 
809
procedure TChmWriter.AppendTOC(AStream: TStream);
 
810
begin
 
811
  FHasTOC := True;
 
812
  PostAddStreamToArchive('default.hhc', '/', AStream, True);
 
813
end;
 
814
 
 
815
procedure TChmWriter.AppendIndex(AStream: TStream);
 
816
begin
 
817
  FHasIndex := True;
 
818
  PostAddStreamToArchive('default.hhk', '/', AStream, True);
 
819
end;
 
820
 
 
821
procedure TChmWriter.AppendSearchDB(AName: String; AStream: TStream);
 
822
begin
 
823
  PostAddStreamToArchive(AName, '/', AStream);
 
824
end;
 
825
 
 
826
 
 
827
// this procedure is used to manually add files to compress to an internal stream that is
 
828
// processed before FileToCompress is called. Files added this way should not be
 
829
// duplicated in the FilesToCompress property.
 
830
procedure TChmWriter.AddStreamToArchive(AFileName, APath: String; AStream: TStream; Compress: Boolean = True);
 
831
var
 
832
  TargetStream: TStream;
 
833
  Entry: TFileEntryRec;
 
834
begin
 
835
  if AStream = nil then Exit;
 
836
  if Compress then
 
837
    TargetStream := FCurrentStream
 
838
  else
 
839
    TargetStream := FSection0;
 
840
 
 
841
  Entry.Name := AFileName;
 
842
  Entry.Path := APath;
 
843
  Entry.Compressed :=  Compress;
 
844
  Entry.DecompressedOffset := TargetStream.Position;
 
845
  Entry.DecompressedSize := AStream.Size;
 
846
  FInternalFiles.AddEntry(Entry);
 
847
  AStream.Position := 0;
 
848
  TargetStream.CopyFrom(AStream, AStream.Size);
 
849
end;
 
850
 
 
851
procedure TChmWriter.PostAddStreamToArchive(AFileName, APath: String;
 
852
  AStream: TStream; Compress: Boolean);
 
853
var
 
854
  TargetStream: TStream;
 
855
  Entry: TFileEntryRec;
 
856
begin
 
857
  if AStream = nil then Exit;
 
858
  if Compress then
 
859
    TargetStream := FPostStream
 
860
  else
 
861
    TargetStream := FSection0;
 
862
 
 
863
  Entry.Name := AFileName;
 
864
  Entry.Path := APath;
 
865
  Entry.Compressed :=  Compress;
 
866
  if not Compress then
 
867
    Entry.DecompressedOffset := TargetStream.Position
 
868
  else
 
869
    Entry.DecompressedOffset := FReadCompressedSize + TargetStream.Position;
 
870
  Entry.DecompressedSize := AStream.Size;
 
871
  FInternalFiles.AddEntry(Entry);
 
872
  AStream.Position := 0;
 
873
  TargetStream.CopyFrom(AStream, AStream.Size);
 
874
end;
 
875
 
 
876
procedure TChmWriter.AddContext(AContext: DWord; ATopic: String);
 
877
var
 
878
  Offset: DWord;
 
879
begin
 
880
  if FContextStream = nil then begin
 
881
    // #IVB starts with a dword which is the size of the stream - sizeof(dword)
 
882
    FContextStream.WriteDWord(0);
 
883
    // we will update this when we write the file to the final stream
 
884
  end;
 
885
  // an entry is a context id and then the offset of the name of the topic in the strings file
 
886
  FContextStream.WriteDWord(NToLE(AContext));
 
887
  Offset := NToLE(AddString(ATopic));
 
888
  FContextStream.WriteDWord(Offset);
 
889
end;
 
890
 
 
891
procedure TChmWriter.StartCompressingStream;
 
892
var
 
893
  LZXdata: Plzx_data;
 
894
  WSize: LongInt;
 
895
begin
 
896
  lzx_init(@LZXdata, LZX_WINDOW_SIZE, @_GetData, Self, @_AtEndOfData,
 
897
              @_WriteCompressedData, Self, @_MarkFrame, Self);
 
898
 
 
899
  WSize := 1 shl LZX_WINDOW_SIZE;
 
900
  while not AtEndOfData do begin
 
901
    lzx_reset(LZXdata);
 
902
    lzx_compress_block(LZXdata, WSize, True);
 
903
  end;
 
904
 
 
905
  //we have to mark the last frame manually
 
906
  MarkFrame(LZXdata^.len_uncompressed_input, LZXdata^.len_compressed_output);
 
907
 
 
908
  lzx_finish(LZXdata, nil);
 
909
end;
 
910
 
 
911
end.