paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-06 09:10:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Andrew Haines to support FPDOC generating CHMs

Browse Source 
git-svn-id: trunk@9406 -
This commit is contained in:
michael 2007-12-07 10:51:52 +00:00
parent e6087db326
commit 853c34fda0
5 changed files with 134 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
packages/extra/chm/chmfilewriter.pas
View File

@ -36,6 +36,7 @@ type
TChmProject = class
private
FWriter: TChmWriter;
FAutoFollowLinks: Boolean;
FDefaultFont: String;
FDefaultPage: String;
@ -49,6 +50,7 @@ type
FTitle: String;
protected
function GetData(const DataName: String; out PathInChm: String; out FileName: String; var Stream: TStream): Boolean;
procedure LastFileAdded(Sender: TObject);
public
constructor Create;
destructor Destroy; override;
@ -93,6 +95,25 @@ begin
if Assigned(FOnProgress) then FOnProgress(Self, DataName);
end;
procedure TChmProject.LastFileAdded(Sender: TObject);
var
IndexStream: TFileStream;
TOCStream: TFileStream;
begin
// Assign the TOC and index files
if (IndexFileName <> '') and FileExists(IndexFileName) then begin
IndexStream := TFileStream.Create(IndexFileName, fmOpenRead);
FWriter.AppendIndex(IndexStream);
IndexStream.Free;
end;
if (TableOfContentsFileName <> '') and FileExists(TableOfContentsFileName) then begin
TOCStream := TFileStream.Create(TableOfContentsFileName, fmOpenRead);
FWriter.AppendTOC(TOCStream);
TOCStream.Free;
end;
end;
constructor TChmProject.Create;
begin
FFiles := TStringList.Create;
@ -174,20 +195,11 @@ begin
Writer := TChmWriter.Create(AOutStream, False);
// our callback to get data
Writer.OnGetFileData := @GetData;
Writer.OnLastFile := @LastFileAdded;
// give it the list of files
Writer.FilesToCompress.AddStrings(Files);
// Assign the TOC and index files
if (IndexFileName <> '') and FileExists(IndexFileName) then begin
IndexStream := TFileStream.Create(IndexFileName, fmOpenRead);
Writer.IndexStream := IndexStream;
end;
if (TableOfContentsFileName <> '') and FileExists(TableOfContentsFileName) then begin
TOCStream := TFileStream.Create(TableOfContentsFileName, fmOpenRead);
Writer.TOCStream := TOCStream;
end;
// now some settings in the chm
Writer.DefaultPage := DefaultPage;
Writer.Title := Title;

3
packages/extra/chm/chmreader.pas
View File

@ -671,7 +671,7 @@ var
I: Integer;
begin
Result := 0;
WriteLn('Looking for URL : ', Name);
if Name = '' then Exit;
if fDirectoryHeader.DirectoryChunkCount = 0 then exit;
@ -1117,6 +1117,7 @@ begin
Found := True;
end;
if not Found then exit;
WriteLn('Looking for URL ', URL, ' in ', AFileName);
if CheckOpenFile(AFileName) then
Result := fLastChm.ObjectExists(URL);
if Result > 0 then NAme := Url;

21
packages/extra/chm/chmsitemap.pas
View File

@ -39,6 +39,7 @@ type
FComment: String;
FImageNumber: Integer;
FIncreaseImageIndex: Boolean;
FKeyWord: String;
FLocal: String;
FOwner: TChmSiteMapItems;
FSeeAlso: String;
@ -50,6 +51,7 @@ type
destructor Destroy; override;
property Children: TChmSiteMapItems read FChildren write SetChildren;
property Text: String read FText write FText; // Name for TOC; KeyWord for index
property KeyWord: String read FKeyWord write FKeyWord;
property Local: String read FLocal write FLocal;
property URL: String read FURL write FURL;
property SeeAlso: String read FSeeAlso write FSeeAlso;
@ -81,6 +83,7 @@ type
function NewItem: TChmSiteMapItem;
function Insert(AItem: TChmSiteMapItem; AIndex: Integer): Integer;
procedure Clear;
procedure Sort(Compare: TListSortCompare);
property Item[AIndex: Integer]: TChmSiteMapItem read GetItem write SetItem;
property Count: Integer read GetCount;
property ParentItem: TChmSiteMapItem read FParentItem;
@ -338,15 +341,15 @@ var
Item: TChmSiteMapItem;
begin
for I := 0 to AItems.Count-1 do begin
Item := AItems.Item[I];
WriteString('<LI> <OBJECT type="text/sitemap">');
Inc(Indent, 8);
//Merge
//if (SiteMapType = stIndex) and (Item.Text <> '') then WriteParam('Keyword', Item.Text);
if (SiteMapType = stIndex) and (Item.Children.Count > 0) then
WriteParam('Keyword', Item.Text);
//if Item.KeyWord <> '' then WriteParam('Keyword', Item.KeyWord);
if Item.Text <> '' then WriteParam('Name', Item.Text);
if Item.Local <> '' then WriteParam('Local', Item.Local);
if (Item.Local <> '') or (SiteMapType = stIndex) then WriteParam('Local', Item.Local);
if Item.URL <> '' then WriteParam('URL', Item.URL);
if (SiteMapType = stIndex) and (Item.SeeAlso <> '') then WriteParam('See Also', Item.SeeAlso);
//if Item.FrameName <> '' then WriteParam('FrameName', Item.FrameName);
@ -367,9 +370,6 @@ var
Dec(Indent, 8);
WriteString('</UL>');
end;
end;
end;
begin
@ -498,5 +498,10 @@ begin
for I := Count-1 downto 0 do Delete(I);
end;
procedure TChmSiteMapItems.Sort(Compare: TListSortCompare);
begin
FList.Sort(Compare);
end;
end.

4
packages/extra/chm/chmspecialfiles.pas
View File

@ -34,7 +34,7 @@ uses
function WriteSpanInfoToStream(const AStream: TStream; UncompressedSize: QWord): Integer;
function WriteTransformListToStream(const AStream: TStream): Integer;
function WriteResetTableToStream(const AStream: TStream; ResetTableStream: TMemoryStream): Integer;
function WriteContentToStream(const AStream: TStream; ContentStream: TMemoryStream): Integer;
function WriteContentToStream(const AStream: TStream; ContentStream: TStream): Integer;
implementation
@ -120,7 +120,7 @@ begin
Result := AStream.CopyFrom(ResetTableStream, ResetTableStream.Size-SizeOf(QWord));
end;
function WriteContentToStream(const AStream: TStream; ContentStream: TMemoryStream): Integer;
function WriteContentToStream(const AStream: TStream; ContentStream: TStream): Integer;
begin
// ::DataSpace/Storage/MSCompressed/Content
ContentStream.Position := 0;

152
packages/extra/chm/chmwriter.pas
View File

@ -32,19 +32,16 @@ type
// becomes '/' and /home/user/helpstuff/subfolder/ > /subfolder/
// FileName : /home/user/helpstuff/index.html > index.html
// Stream : the file opened with DataName should be written to this stream
{ TChmWriter }
TChmWriter = class(TObject)
FOnLastFile: TNotifyEvent;
private
ForceExit: Boolean;
FDefaultFont: String;
FDefaultPage: String;
FFullTextSearch: Boolean;
@ -56,16 +53,18 @@ type
FStringsStream: TMemoryStream;
FContextStream: TMemoryStream; // the #IVB file
FSection0: TMemoryStream;
FSection1: TMemoryStream; // Compressed Stream
FSection1: TStream; // Compressed Stream
FSection1Size: Int64;
FSection1ResetTable: TMemoryStream; // has a list of frame positions NOT window positions
FDirectoryListings: TStream;
FIndexStream: TStream;
FOutStream: TStream;
FFileNames: TStrings;
FDestroyStream: Boolean;
FTempStream: TStream;
FPostStream: TStream;
FTitle: String;
FTOCStream: TStream;
FHasTOC: Boolean;
FHasIndex: Boolean;
FWindowSize: LongWord;
FReadCompressedSize: Int64; // Current Size of Uncompressed data that went in Section1 (compressed)
// Linear order of file
@ -81,12 +80,11 @@ type
// end linear header parts
procedure InitITSFHeader;
procedure InitHeaderSectionTable;
procedure SetTempRawStream(const AValue: TStream);
procedure WriteHeader(Stream: TStream);
procedure CreateDirectoryListings;
procedure WriteDirectoryListings(Stream: TStream);
procedure StartCompressingStream;
procedure WriteTOC;
procedure WriteIndex;
procedure WriteSYSTEM;
procedure WriteITBITS;
procedure WriteSTRINGS;
@ -106,19 +104,23 @@ type
constructor Create(OutStream: TStream; FreeStreamOnDestroy: Boolean);
destructor Destroy; override;
procedure Execute;
procedure AppendTOC(AStream: TStream);
procedure AppendIndex(AStream: TStream);
procedure AppendSearchDB(AName: String; AStream: TStream);
procedure AddStreamToArchive(AFileName, APath: String; AStream: TStream; Compress: Boolean = True);
procedure PostAddStreamToArchive(AFileName, APath: String; AStream: TStream; Compress: Boolean = True);
procedure AddContext(AContext: DWord; ATopic: String);
property WindowSize: LongWord read FWindowSize write FWindowSize default 2; // in $8000 blocks
property FrameSize: LongWord read FFrameSize write FFrameSize default 1; // in $8000 blocks
property FilesToCompress: TStrings read FFileNames;
property OnGetFileData: TGetDataFunc read FOnGetFileData write FOnGetFileData;
property OnLastFile: TNotifyEvent read FOnLastFile write FOnLastFile;
property OutStream: TStream read FOutStream;
property Title: String read FTitle write FTitle;
property FullTextSearch: Boolean read FFullTextSearch write FFullTextSearch;
property DefaultFont: String read FDefaultFont write FDefaultFont;
property DefaultPage: String read FDefaultPage write FDefaultPage;
property TOCStream: TStream read FTOCStream write FTOCStream;
property IndexStream: TStream read FIndexStream write FIndexStream;
property TempRawStream: TStream read FTempStream write SetTempRawStream;
//property LocaleID: dword read ITSFHeader.LanguageID write ITSFHeader.LanguageID;
end;
@ -200,6 +202,18 @@ begin
HeaderSuffix.Offset := NToLE(HeaderSuffix.Offset);
end;
procedure TChmWriter.SetTempRawStream(const AValue: TStream);
begin
if (FCurrentStream.Size > 0) or (FSection1.Size > 0) then
raise Exception.Create('Cannot set the TempRawStream once data has been written to it!');
if AValue = nil then
raise Exception.Create('TempRawStream cannot be nil!');
if FCurrentStream = AValue then
exit;
FCurrentStream.Free;
FCurrentStream := AValue;
end;
procedure TChmWriter.WriteHeader(Stream: TStream);
begin
Stream.Write(ITSFHeader, SizeOf(TITSFHeader));
@ -225,8 +239,7 @@ var
FESize: Integer;
FileName: String;
FileNameSize: Integer;
LastListIndex,
LastIndexIndex: Integer;
LastListIndex: Integer;
FirstListEntry: TFirstListEntry;
ChunkIndex: Integer;
ListHeader: TPMGListChunk;
@ -311,8 +324,7 @@ begin
IndexBlock := TPMGIDirectoryChunk.Create(SizeOf(TPMGIIndexChunk));
ListingBlock := TDirectoryChunk.Create(SizeOf(TPMGListChunk));
LastIndexIndex := -1;
LastListIndex := -1;
// add files to a pmgl block until it is full.
@ -373,24 +385,9 @@ begin
//TMemoryStream(FDirectoryListings).SaveToFile('dirlistings.pmg');
end;
procedure TChmWriter.WriteIndex;
var
Entry: TFileEntryRec;
TmpTitle: String;
begin
if IndexStream = nil then Exit;
if Title <> '' then TmpTitle := Title
else TmpTitle := 'default';
AddStreamToArchive(TmpTitle+'.hhk', '/', IndexStream);
end;
procedure TChmWriter.WriteSystem;
var
Entry: TFileEntryRec;
EntryCode,
EntryLength: Word;
TmpStr: String;
TmpTitle: String;
const
@ -449,6 +446,7 @@ begin
FSection0.WriteWord(NToLE(Word(3)));
FSection0.WriteWord(NToLE(Word(Length(FTitle)+1)));
FSection0.Write(FTitle[1], Length(FTitle));
FSection0.WriteByte(0);
end;
// 16 Default Font
@ -456,14 +454,15 @@ begin
FSection0.WriteWord(NToLE(Word(16)));
FSection0.WriteWord(NToLE(Word(Length(FDefaultFont)+1)));
FSection0.Write(FDefaultFont[1], Length(FDefaultFont));
FSection0.WriteByte(0);
end;
// 6
// unneeded. if output file is : /somepath/OutFile.chm the value here is outfile(lowercase)
// 0 Table of contents filename
if TOCStream <> nil then begin
TmpStr := TmpTitle+'.hhc';
if FHasTOC then begin
TmpStr := 'default.hhc';
FSection0.WriteWord(0);
FSection0.WriteWord(NToLE(Word(Length(TmpStr)+1)));
FSection0.Write(TmpStr[1], Length(TmpStr));
@ -471,8 +470,8 @@ begin
end;
// 1
// hhk Index
if IndexStream <> nil then begin
TmpStr := TmpTitle+'.hhk';
if FHasIndex then begin
TmpStr := 'default.hhk';
FSection0.WriteWord(NToLE(Word(1)));
FSection0.WriteWord(NToLE(Word(Length(TmpStr)+1)));
FSection0.Write(TmpStr[1], Length(TmpStr));
@ -530,7 +529,7 @@ begin
FSection0.Write(DISCLAIMER_STR, SizeOf(DISCLAIMER_STR));
Entry.DecompressedSize := FSection0.Position - Entry.DecompressedOffset;
Entry.Path := '/';
Entry.Name := '_::_README_::_'; //try to use a name that won't conflict with normal names
Entry.Name := '_#_README_#_'; //try to use a name that won't conflict with normal names
FInternalFiles.AddEntry(Entry);
end;
@ -649,6 +648,19 @@ begin
Inc(FReadCompressedSize, FileEntry.DecompressedSize);
FCurrentStream.Position := 0;
end;
// this is intended for programs to add perhaps a file
// after all the other files have been added.
if (AtEndOfData)
and (FCurrentStream <> FPostStream) then
begin
if Assigned(FOnLastFile) then
FOnLastFile(Self);
FCurrentStream.Free;
FCurrentStream := FPostStream;
FCurrentStream.Position := 0;
Inc(FReadCompressedSize, FCurrentStream.Size);
end;
end;
end;
@ -661,11 +673,11 @@ function TChmWriter.WriteCompressedData(Count: Longint; Buffer: Pointer): LongIn
begin
// we allocate a MB at a time to limit memory reallocation since this
// writes usually 2 bytes at a time
if FSection1.Position >= FSection1.Size-1 then begin
if (FSection1 is TMemoryStream) and (FSection1.Position >= FSection1.Size-1) then begin
FSection1.Size := FSection1.Size+$100000;
end;
Inc(FSection1Size, FSection1.Write(Buffer^, Count));
Result := FSection1.Write(Buffer^, Count);
Inc(FSection1Size, Result);
end;
procedure _MarkFrame(arg: pointer; UncompressedTotal, CompressedTotal: LongWord); cdecl;
@ -693,7 +705,6 @@ procedure TChmWriter.MarkFrame(UnCompressedTotal, CompressedTotal: LongWord);
procedure UpdateTotalSizes;
var
OldPos: Int64;
Value: DWord;
begin
OldPos := FSection1ResetTable.Position;
FSection1ResetTable.Position := $10;
@ -701,8 +712,6 @@ procedure TChmWriter.MarkFrame(UnCompressedTotal, CompressedTotal: LongWord);
WriteQWord(CompressedTotal);
FSection1ResetTable.Position := OldPos;
end;
var
Tmp : QWord;
begin
if FSection1ResetTable.Size = 0 then begin
// Write the header
@ -733,6 +742,7 @@ begin
FSection1 := TMemoryStream.Create;
FSection1ResetTable := TMemoryStream.Create;
FDirectoryListings := TMemoryStream.Create;
FPostStream := TMemoryStream.Create;;
FDestroyStream := FreeStreamOnDestroy;
FFileNames := TStringList.Create;
end;
@ -760,8 +770,6 @@ begin
// write any internal files to FCurrentStream that we want in the compressed section
WriteIVB;
WriteTOC;
WriteIndex;
WriteSTRINGS;
// written to Section0 (uncompressed)
@ -798,10 +806,27 @@ begin
WriteSection1; // writes section 1 to FOutStream
end;
procedure TChmWriter.AppendTOC(AStream: TStream);
begin
FHasTOC := True;
PostAddStreamToArchive('default.hhc', '/', AStream, True);
end;
procedure TChmWriter.AppendIndex(AStream: TStream);
begin
FHasIndex := True;
PostAddStreamToArchive('default.hhk', '/', AStream, True);
end;
procedure TChmWriter.AppendSearchDB(AName: String; AStream: TStream);
begin
PostAddStreamToArchive(AName, '/', AStream);
end;
// this procedure is used to manually add files to compress to an internal stream that is
// processed before FileToCompress is called. Files added this way should not be
// in the FilesToCompress property.
// duplicated in the FilesToCompress property.
procedure TChmWriter.AddStreamToArchive(AFileName, APath: String; AStream: TStream; Compress: Boolean = True);
var
TargetStream: TStream;
@ -823,6 +848,31 @@ begin
TargetStream.CopyFrom(AStream, AStream.Size);
end;
procedure TChmWriter.PostAddStreamToArchive(AFileName, APath: String;
AStream: TStream; Compress: Boolean);
var
TargetStream: TStream;
Entry: TFileEntryRec;
begin
if AStream = nil then Exit;
if Compress then
TargetStream := FPostStream
else
TargetStream := FSection0;
Entry.Name := AFileName;
Entry.Path := APath;
Entry.Compressed := Compress;
if not Compress then
Entry.DecompressedOffset := TargetStream.Position
else
Entry.DecompressedOffset := FReadCompressedSize + TargetStream.Position;
Entry.DecompressedSize := AStream.Size;
FInternalFiles.AddEntry(Entry);
AStream.Position := 0;
TargetStream.CopyFrom(AStream, AStream.Size);
end;
procedure TChmWriter.AddContext(AContext: DWord; ATopic: String);
var
Offset: DWord;
@ -858,16 +908,4 @@ begin
lzx_finish(LZXdata, nil);
end;
procedure TChmWriter.WriteTOC;
var
TmpTitle: String;
begin
if TOCStream = nil then Exit;
if Title <> '' then TmpTitle := Title
else TmpTitle := 'default';
AddStreamToArchive(TmpTitle+'.hhc', '/', TOCStream);
end;
end.