paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 07:19:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* First set of patches for making mergable CHM files, committed after a point with 0 regressions.

Browse Source 
* IDXHDR internal file added.
    * better defaults for [Windows] lines.
    * Avoid duplication topic if both in index and separately in hhp. Size reduction for many hhp scenarios, no difference for fpdoc
    * System section 13 (copy of idxhdr)
    * index/toc files registered as topic type 2. (incontents field)
      * duplicate code for creating topics cleaned up, all now use addtopic
    * correct number of topics in system file.
    * some bugfixes in binary index.
    * some more global properties supported in sitemaps.

 * many extra (dumping) options for chmls tool.

git-svn-id: trunk@24979 -
This commit is contained in:
marco 2013-06-26 14:31:30 +00:00
parent 87cfd86172
commit 56e9f9301c
7 changed files with 1050 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
packages/chm/src/chmcmd.lpr
View File

@ -25,7 +25,7 @@ program chmcmd;
uses
Classes, Sysutils, chmfilewriter, GetOpts;
Const
Const
CHMCMDVersion = '2.6.0';
Procedure Usage;
@ -129,7 +129,7 @@ begin
except
on e:exception do
begin
Writeln('This HHP CHM project seems corrupt, please check it ',name);
Writeln('This HHP CHM project seems corrupt, please check it ',name,' (', e.message,')');
halt(1);
end;
end;

150
packages/chm/src/chmfilewriter.pas
View File

@ -63,6 +63,10 @@ type
FSpareString : TStringIndex;
FBasePath : String; // location of the .hhp file. Needed to resolve relative paths
FReadmeMessage : String; // readme message
FToc,
FIndex : TCHMSiteMap;
FTocStream,
FIndexStream : TMemoryStream;
protected
function GetData(const DataName: String; out PathInChm: String; out FileName: String; var Stream: TStream): Boolean;
procedure LastFileAdded(Sender: TObject);
@ -79,6 +83,7 @@ type
procedure SaveToFile(AFileName: String); virtual;
procedure WriteChm(AOutStream: TStream); virtual;
function ProjectDir: String;
procedure LoadSitemaps;
procedure AddFileWithContext(contextid:integer;filename:ansistring;contextname:ansistring='');
procedure Error(errorkind:TChmProjectErrorKind;msg:String;detaillevel:integer=0);
// though stored in the project file, it is only there for the program that uses the unit
@ -139,45 +144,32 @@ end;
procedure TChmProject.LastFileAdded(Sender: TObject);
var
IndexStream: TFileStream;
TOCStream: TFileStream;
Writer: TChmWriter;
TOCSitemap : TChmSiteMap;
IndexSiteMap: TChmSiteMap;
begin
// Assign the TOC and index files
Writer := TChmWriter(Sender);
{$ifdef chmindex}
Writeln('binindex filename ',IndexFileName);
{$endif}
if (IndexFileName <> '') and FileExists(IndexFileName) then begin
IndexStream := TFileStream.Create(IndexFileName, fmOpenRead);
Writer.AppendIndex(IndexStream);
if assigned(FIndexStream) then
begin
FIndexStream.position:=0;
Writer.AppendIndex(FIndexStream);
if MakeBinaryIndex then
begin
{$ifdef chmindex}
Writeln('into binindex ');
{$endif}
IndexStream.Position := 0;
IndexSitemap := TChmSiteMap.Create(stIndex);
indexSitemap.LoadFromStream(IndexStream);
Writer.AppendBinaryIndexFromSiteMap(IndexSitemap,False);
IndexSitemap.Free;
Writer.AppendBinaryIndexFromSiteMap(FIndex,False);
end;
IndexStream.Free;
end;
if (TableOfContentsFileName <> '') and FileExists(TableOfContentsFileName) then begin
TOCStream := TFileStream.Create(TableOfContentsFileName, fmOpenRead);
Writer.AppendTOC(TOCStream);
if assigned(FTocStream) then
begin
Writer.AppendTOC(FTOCStream);
if MakeBinaryTOC then
begin
TOCStream.Position := 0;
TOCSitemap := TChmSiteMap.Create(stTOC);
TOCSitemap.LoadFromStream(TOCStream);
Writer.AppendBinaryTOCFromSiteMap(TOCSitemap);
TOCSitemap.Free;
Writer.AppendBinaryTOCFromSiteMap(FToc);
end;
TOCStream.Free;
end;
if not assigned(sender) then
Writer.Free;
@ -210,6 +202,10 @@ begin
FTotalFileList.FreeAndClear;
FTotalFileList.Free;
fAllowedExtensions.Free;
FToc.free;
FIndex.free;
FTocStream.Free;
FIndexStream.Free;
inherited Destroy;
end;
@ -401,7 +397,7 @@ procedure addalias(const key,value :string);
var i,j : integer;
node: TCHMContextNode;
keyupper : string;
keyupper,valueupper : string;
begin
{ Defaults other than global }
MakeBinaryIndex:=True;
@ -419,7 +415,9 @@ begin
writeln('alias new node:',key);
{$endif}
node:=TCHMContextNode.create;
node.URLName:=value;
valueupper:=stringReplace(value, '\', '/', [rfReplaceAll]);
valueupper:= StringReplace(valueupper, '//', '/', [rfReplaceAll]);
node.URLName:=valueupper;
node.contextname:=key;
end
else
@ -552,7 +550,7 @@ begin
for j:=0 to strs.count-1 do
begin
nd:=TChmContextNode.Create;
nd.urlname:=strs[j];
nd.urlname:=StringReplace(strs[j],'\', '/', [rfReplaceAll]);
nd.contextnumber:=0;
nd.contextname:='';
Files.AddObject(nd.urlname,nd);
@ -941,7 +939,6 @@ var
helplist,
localfilelist: TStringList;
i : integer;
x : TChmSiteMap;
strrec : TStringIndex;
begin
@ -974,45 +971,29 @@ begin
otherfiles.addstrings(localfilelist);
localfilelist.clear;
end;
if FTableOfContentsFileName<>'' then
if assigned(FToc) then
begin
if fileexists(FTableOfContentsFileName) then
begin
Error(chmnote,'Scanning TOC file : '+FTableOfContentsFileName+'.',3);
x:=TChmSiteMap.Create(sttoc);
try
x.loadfromfile(FTableOfcontentsFilename);
scansitemap(x,localfilelist,true);
scansitemap(ftoc,localfilelist,true);
otherfiles.addstrings(localfilelist);
except
on e: Exception do
error(chmerror,'Error loading TOC file '+FTableOfContentsFileName);
error(chmerror,'Error scanning TOC file ('+FTableOfContentsFileName+')');
end;
x.free;
end
else
error(chmerror,'Can''t find TOC file'+FTableOfContentsFileName);
end;
LocalFileList.clear;
if FIndexFileName<>'' then
begin
if fileexists(FIndexFileName) then
begin
Error(chmnote,'Scanning Index file : '+FIndexFileName+'.',3);
x:=TChmSiteMap.Create(stindex);
try
x.loadfromfile(FIndexFileName);
scansitemap(x,localfilelist,true);
otherfiles.addstrings(localfilelist);
except
on e: Exception do
error(chmerror,'Error loading index file '+FIndexFileName);
end;
x.free;
end
else
error(chmerror,'Can''t find TOC index file '+FIndexFileName);
end;
if assigned(FIndex) then
begin
Error(chmnote,'Scanning Index file : '+FIndexFileName+'.',3);
try
scansitemap(FIndex,localfilelist,true);
otherfiles.addstrings(localfilelist);
except
on e: Exception do
error(chmerror,'Error scanning index file ('+FIndexFileName+')');
end;
end;
localfilelist.free;
end;
@ -1025,8 +1006,10 @@ var
nd : TChmContextNode;
I : Integer;
begin
// Scan html for "rest" files.
LoadSiteMaps;
// Scan html for "rest" files.
If ScanHtmlContents Then
ScanHtml; // Since this is slowing we opt to skip this step, and only do this on html load.
@ -1056,6 +1039,7 @@ begin
Writer.IndexName := ExtractFileName(IndexFileName);
Writer.TocName := ExtractFileName(TableOfContentsFileName);
Writer.ReadmeMessage := ReadmeMessage;
Writer.DefaultWindow := FDefaultWindow;
for i:=0 to files.count-1 do
begin
nd:=TChmContextNode(files.objects[i]);
@ -1066,6 +1050,10 @@ begin
end;
if FWIndows.Count>0 then
Writer.Windows:=FWIndows;
if FMergeFiles.Count>0 then
Writer.Mergefiles:=FMergeFiles;
if assigned(ftoc) then
Writer.TocSitemap:=ftoc;
// and write!
@ -1078,6 +1066,54 @@ begin
Writer.Free;
end;
procedure TChmProject.LoadSitemaps;
// #IDXHDR (merged files) goes into the system file, and need to keep TOC sitemap around
begin
if FTableOfContentsFileName<>'' then
begin
if fileexists(FTableOfContentsFileName) then
begin
FTocStream:=TMemoryStream.Create;
try
FTocStream.loadfromfile(FTableOfContentsFilename);
writeln(ftableofcontentsfilename, ' ' ,ftocstream.size);
FTocStream.Position:=0;
FToc:=TChmSiteMap.Create(sttoc);
FToc.loadfromstream(FTocStream);
ftoc.savetofile('bla.something');
except
on e:exception do
begin
error(chmerror,'Error loading TOC file '+FTableOfContentsFileName);
freeandnil(ftoc); freeandnil(FTocStream);
end;
end;
end
else
error(chmerror,'Can''t find TOC file'+FTableOfContentsFileName);
end;
if FIndexFileName<>'' then
begin
if fileexists(FIndexFileName) then
begin
FIndexStream:=TMemoryStream.Create;
try
FIndexStream.LoadFromFile(FIndexFileName);
FIndexStream.Position:=0;
FIndex:=TChmSiteMap.Create(stindex);
FIndex.loadfromfile(FIndexFileName);
except
on e: Exception do
begin
error(chmerror,'Error loading index file '+FIndexFileName);
freeandnil(findex); freeandnil(findexstream);
end;
end;
end
else
error(chmerror,'Can''t find index file '+FIndexFileName);
end;
end;
end.

502
packages/chm/src/chmls.lpr
View File

@ -1,4 +1,8 @@
{ Copyright (C) <2005> <Andrew Haines> chmls.lpr
Mostly rewritten by Marco van de Voort 2009-2012
An util that concentrates on listing and decompiling various sections
of a CHM.
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
@ -13,8 +17,7 @@
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
{
See the file COPYING, included in this distribution,
for details about the copyright.
}
@ -28,8 +31,10 @@ program chmls;
uses
Classes, GetOpts, SysUtils, Types,
StreamEx,
chmreader, chmbase, chmsitemap;
{$R-} // CHM spec puts "-1" in dwords etc.
type
{ TListObject }
@ -49,11 +54,11 @@ type
procedure OnFileEntry(Name: String; Offset, UncompressedSize, ASection: Integer);
end;
TCmdEnum = (cmdList,cmdExtract,cmdExtractall,cmdUnblock,cmdextractalias,cmdextracttoc,cmdextractindex,cmdNone); // One dummy element at the end avoids rangecheck errors.
Type
TCmdEnum = (cmdList,cmdExtract,cmdExtractall,cmdUnblock,cmdextractalias,cmdextracttoc,cmdextractindex,cmdprintidxhdr,cmdprintsystem,cmdprintwindows,cmdprinttopics,cmdNone); // One dummy element at the end avoids rangecheck errors.
Const
CmdNames : array [TCmdEnum] of String = ('LIST','EXTRACT','EXTRACTALL','UNBLOCK','EXTRACTALIAS','EXTRACTTOC','EXTRACTINDEX','');
CmdNames : array [TCmdEnum] of String = ('LIST','EXTRACT','EXTRACTALL','UNBLOCK','EXTRACTALIAS','EXTRACTTOC','EXTRACTINDEX','PRINTIDXHDR','PRINTSYSTEM','PRINTWINDOWS','PRINTTOPICS','');
var
theopts : array[1..4] of TOption;
@ -89,6 +94,15 @@ begin
writeln(stderr,' Extracts the toc (mainly to check binary TOC)');
writeln(stderr,' extractindex <chmfilename> [filename]');
writeln(stderr,' Extracts the index (mainly to check binary index)');
writeln(stderr,' printidxhdr <chmfilename>');
writeln(stderr,' prints #IDXHDR in readable format ');
writeln(stderr,' printsystem <chmfilename>');
writeln(stderr,' prints #SYSTEM in readable format ');
writeln(stderr,' printwindows <chmfilename>');
writeln(stderr,' prints #WINDOWS in readable format ');
writeln(stderr,' printtopics <chmfilename>');
writeln(stderr,' prints #TOPICS in readable format ');
Halt(1);
end;
@ -286,7 +300,7 @@ begin
if (length(readfrom)>1) and (readfrom[1]<>'/') then
readfrom:='/'+readfrom;
fs:=TFileStream.create(chm,fmOpenRead);
fs:=TFileStream.create(chm,fmOpenRead or fmShareDenyNone);
r:=TChmReader.Create(fs,True);
m:=r.getobject(readfrom);
if assigned(m) then
@ -453,7 +467,452 @@ begin
Files.Free;
end;
const
procedure readchunk13(m:TMemoryStream;r:TChmReader);
var i,cnt,cnt2: integer;
s : ansistring;
procedure fetchstring;
begin
cnt:=m.ReadDWordLE;
s:='';
if (cnt>0) then
s:=r.readstringsentry(cnt);
end;
begin
setlength(s,4);
for i:=1 to 4 do
s[i]:=ansichar(m.readbyte);
Writeln('Identifier tag :',s);
Writeln('Unknown timestamp/checksum :',leton(m.readdword));
Writeln('Always 1 :',leton(m.readdword));
Writeln('Number of topic nodes incl. contents & index :',leton(m.readdword));
Writeln(' The following are mostly parameters of the "text/site properties" object of the sitemap contents');
Writeln('0 (meaning unknown) :',leton(m.readdword));
fetchstring;
Writeln('Imagelist param index in #strings (0,-1=none) :',cnt);
if (cnt>0) then
writeln(' = ',s);
Writeln('0 (meaning unknown) :',leton(m.readdword));
cnt:=m.ReadDWordLE;
if cnt=1 then
s:='Folder'
else
if cnt=0 then
s:='None'
else
s:='unknown value!';
Writeln('imagetype param text/site. :',cnt,' = ',s);
Writeln('Background value :',inttohex(leton(m.readdword),8));
Writeln('Foreground value :',inttohex(leton(m.readdword),8));
fetchstring;
Writeln('Font param index in #strings (0,-1=none) :',cnt);
if (cnt>0) then
writeln(' = ',s);
Writeln('Windows Styles :',inttohex(leton(m.readdword),8));
Writeln('ExWindows Styles :',inttohex(leton(m.readdword),8));
Writeln('Unknown, often -1 or 0 :',leton(m.readdword));
FetchString;
Write ('Framename :',cnt);
if (cnt>0) then
write(' = ',s);
Writeln;
FetchString;
Writeln('Windowname :',cnt);
if (cnt>0) then
writeln(' = ',s);
Writeln('Number of Information Types :',leton(m.readdword));
Writeln('Unknown. Often 1. Also 0, 3. :',leton(m.readdword));
cnt2:=m.ReadDWordLE;
Writeln('Number of files in the [MERGE FILES] list :',cnt2);
Writeln('Unknown. Often 0. :',leton(m.readdword),'(Non-zero mostly in files with some files in the merge files list)');
if cnt2>0 then
for i:=0 to cnt2-1 do
begin
fetchstring;
Writeln(' Offset ', cnt, ' = ',s);
end;
end;
procedure PrintIDXHDR(filespec:TStringDynArray);
var s,
chm,
prefixfn,
symbolname : ansistring;
i,cnt,cnt2: integer;
cl : TList;
x : PcontextItem;
f : textfile;
fs: TFileStream;
r : TChmReader;
m : TMemorystream;
begin
symbolname:='helpid';
chm:=filespec[0];
prefixfn:=changefileext(chm,'');
if not Fileexists(chm) then
begin
writeln(stderr,' Can''t find file ',chm);
halt(1);
end;
fs:=TFileStream.create(chm,fmOpenRead);
r:=TCHMReader.create(fs,true);
m:=r.getobject('/#IDXHDR');
if not assigned(m) then
begin
writeln(stderr,'This CHM doesn''t contain a #IDXHDR internal file');
halt(1);
end;
m.position:=0;
Writeln(' --- #IDXHDR ---');
readchunk13(m,r);
m.free;
r.free;
end;
procedure PrintWindows(filespec:TStringDynArray);
var s,
chm,
prefixfn,
symbolname : ansistring;
i,cnt,cnt2: integer;
x : PcontextItem;
f : textfile;
fs: TFileStream;
r : TChmReader;
m : TMemorystream;
function fetchstring:string;
var xx : longint;
begin
xx:=m.ReadDWordLE;
if (xx>0) then
result:=r.readstringsentry(xx)+ ' (index value = '+inttostr(xx)+')'
else
result:='(0)';
end;
function printstructsize(sz:integer):string;
begin
case sz of
188 : result:='Compatibility 1.0';
196 : result:='Compatibility 1.1 or later';
else
result:='unknown';
end;
end;
begin
chm:=filespec[0];
prefixfn:=changefileext(chm,'');
if not Fileexists(chm) then
begin
writeln(stderr,' Can''t find file ',chm);
halt(1);
end;
fs:=TFileStream.create(chm,fmOpenRead);
r:=TCHMReader.create(fs,true);
m:=r.getobject('/#WINDOWS');
if not assigned(m) then
begin
writeln(stderr,'This CHM doesn''t contain a #WINDOWS internal file. Odd.');
halt(1);
end;
m.position:=0;
cnt:=m.ReadDWordLE;
Writeln('Entries in #Windows : ',Cnt);
cnt2:=m.ReadDWordLE;
Writeln('Structure size : ',cnt2, ' = ',printstructsize(Cnt2));
writeln;
i:=0;
while (i<cnt) do
begin
cnt2:=m.ReadDWordLE;
Writeln('00 Structure size : ',cnt2, ' = ',printstructsize(Cnt2));
Writeln('04 htmlhelp.h indicates "BOOL fUniCodeStrings: ',m.ReadDWordLE);
Writeln('08 WindowType : ',fetchstring);
cnt2:=m.ReadDWordLE;
Write ('0C Which window properties are valid : ');
if (cnt2 and $00002)>0 then Write(' "Navigation pane style"');
if (cnt2 and $00004)>0 then Write(' "Window style flags"');
if (cnt2 and $00008)>0 then Write(' "Window extended style flags"');
if (cnt2 and $00010)>0 then Write(' "Initial window position"');
if (cnt2 and $00020)>0 then Write(' "Navigation pane width"');
if (cnt2 and $00040)>0 then Write(' "Window show state"');
if (cnt2 and $00080)>0 then Write(' "Info types"');
if (cnt2 and $00100)>0 then Write(' "Buttons"');
if (cnt2 and $00200)>0 then Write(' "Navigation Pane initially closed state"');
if (cnt2 and $00400)>0 then Write(' "Tab position"');
if (cnt2 and $00800)>0 then Write(' "Tab order"');
if (cnt2 and $01000)>0 then Write(' "History count"');
if (cnt2 and $02000)>0 then Write(' "Default Pane"');
writeln(' ( = ',inttohex(cnt2,8),')');
Writeln('10 A bit field of navigation pane styles : ',inttohex(m.readdwordLE,8));
Writeln('14 Title Bar Text : ',fetchstring);
Writeln('18 Style Flags : ',inttohex(m.readdwordLE,8));
Writeln('1C Extended Style Flags : ',inttohex(m.readdwordLE,8));
Writeln('20 Initial position (left,top,right,bottom : ',m.readdwordLE,' ' ,m.readdwordLE,' ',m.readdwordLE,' ',m.readdwordLE);
Writeln('30 Window ShowState : ',inttohex(m.readdwordLE,8));
Writeln('34 HWND hwndHelp; OUT: window handle" : ',inttohex(m.readdwordLE,8));
Writeln('38 HWND hwndCaller; OUT: who called window" : ',inttohex(m.readdwordLE,8));
Writeln('3C HH_INFOTYPE* paInfoTypes : ',inttohex(m.readdwordLE,8));
Writeln('40 HWND hwndToolBar; : ',inttohex(m.readdwordLE,8));
Writeln('44 HWND hwndNavigation; : ',inttohex(m.readdwordLE,8));
Writeln('48 HWND hwndHTML; : ',inttohex(m.readdwordLE,8));
Writeln('4C Width of the navigation pane in pixels : ',inttohex(m.readdwordLE,8));
Writeln('50 Topic panel coordinates left,top,right,bottom : ',m.readdwordLE,' ' ,m.readdwordLE,' ',m.readdwordLE,' ',m.readdwordLE);
Writeln('60 TOC File : ',fetchstring);
Writeln('64 Index File : ',fetchstring);
Writeln('68 Default File : ',fetchstring);
Writeln('6C File when Home button is pressed : ',fetchstring);
inc(i);
end;
m.free;
r.free;
end;
procedure PrintTopics(filespec:TStringDynArray);
var s,
chm,
prefixfn,
symbolname : ansistring;
i,cnt,cnt2: integer;
cl : TList;
x : PcontextItem;
f : textfile;
fs: TFileStream;
r : TChmReader;
m : TMemorystream;
chunktype,
chunksize : Word;
entries : integer;
begin
chm:=filespec[0];
prefixfn:=changefileext(chm,'');
if not Fileexists(chm) then
begin
writeln(stderr,' Can''t find file ',chm);
halt(1);
end;
fs:=TFileStream.create(chm,fmOpenRead);
r:=TCHMReader.create(fs,true);
m:=r.getobject('/#TOPICS');
if not assigned(m) then
begin
writeln(stderr,'This CHM doesn''t contain a #SYSTEM internal file. Odd.');
halt(1);
end;
m.position:=0;
entries:=m.size div 16;
if entries>0 then
for i:=0 to entries-1 do
begin
writeln('#TOPICS entry : ',i);
cnt:=m.ReadDWordLE;
writeln(' TOCIDX index:',cnt,5);
write (' Tag name :');
cnt2:=m.ReadDWordLE;
if cnt2=-1 then
writeln(cnt2)
else
begin
s:=r.ReadStringsEntry(cnt2);
writeln(s,'(',cnt2,')');
end;
write (' Tag value :');
cnt2:=m.ReadDWordLE;
if cnt2=-1 then
writeln(cnt2)
else
begin
s:=r.ReadUrlStr(cnt2);
writeln(s,'(',cnt2,')');
end;
cnt2:=m.ReadWordLE;
writeln(' contents val:',cnt2, '(2=not in contents, 6 in contents, 0/4 unknown)');
cnt2:=m.ReadWordLE;
writeln(' unknown val :',cnt2, '(0,2,4,8,10,12,16,32)');
end;
m.free;
r.free;
end;
procedure PrintSystem(filespec:TStringDynArray);
var s,
chm,
prefixfn,
symbolname : ansistring;
i,cnt,cnt2: integer;
cl : TList;
x : PcontextItem;
f : textfile;
fs: TFileStream;
r : TChmReader;
m : TMemorystream;
chunktype,
chunksize : Word;
procedure fetchstring;
begin
cnt:=m.ReadDWordLE;
s:='';
if (cnt>0) then
s:=r.readstringsentry(cnt);
end;
function printnulterminated(sz:word):string;
begin
setlength(result,sz);
if sz>0 then
begin
m.read(result[1],sz);
end;
end;
procedure printentry4(m:TMemoryStream;chsz:dword);
var q : QWord;
ts : TFileTime;
begin
writeln('(4)');
if chsz<32 then
begin
Writeln(' is too small', chsz, ' bytes instead of 32');
m.position:=m.position+chsz;
exit;
end;
writeln(' LCID from HHP file : ',m.readdwordLE );
writeln(' One if DBCS in use : ',m.readdwordLE );
writeln(' one if fullttext search is on : ',m.readdwordLE );
writeln(' Non zero if there are KLinks : ',m.readdwordLE );
writeln(' Non zero if there are ALinks : ',m.readdwordLE );
ts.dwlowdatetime:=m.readdwordLE;
ts.dwhighdatetime:=m.readdwordLE;
writeln(' Timestamp : ',ts.dwhighdatetime,':', ts.dwlowdatetime );
writeln(' 0/1 except in dsmsdn.chi has 1 : ',m.readdwordLE );
writeln(' 0 (unknown) : ',m.readdwordLE );
end;
procedure printentry8(m:TMemoryStream;chsz:dword);
var q : QWord;
ts : TFileTime;
begin
writeln('(8)');
if chsz<16 then
begin
Writeln(' is too small', chsz, ' bytes instead of 16');
m.position:=m.position+chsz;
exit;
end;
writeln(' 0 (or 4 in some) : ',m.readdwordLE );
fetchstring;
writeln(' Abbreviation : ',cnt,' = ',s);
writeln(' 3 or 5 depending on 1st field : ',m.readdwordLE );
fetchstring;
writeln(' Abbreviation explanation : ',cnt,' = ',s);
if chsz>16 then
writeln(' x size is larger than 16');
m.position:=m.position+chsz-16;
end;
begin
symbolname:='helpid';
chm:=filespec[0];
prefixfn:=changefileext(chm,'');
if not Fileexists(chm) then
begin
writeln(stderr,' Can''t find file ',chm);
halt(1);
end;
fs:=TFileStream.create(chm,fmOpenRead);
r:=TCHMReader.create(fs,true);
m:=r.getobject('/#SYSTEM');
if not assigned(m) then
begin
writeln(stderr,'This CHM doesn''t contain a #SYSTEM internal file. Odd.');
halt(1);
end;
m.position:=0;
cnt:=m.ReadDWordLE;
case cnt of
2 : s:='Compatibility 1.0';
3 : s:='Compatibility 1.1 or later';
else
s:='unknown';
end;
Writeln(' --- #SYSTEM---');
while (m.size-m.position)>=8 do
begin
chunktype := m.readwordle;
Chunksize := m.readwordle;
if (m.size-m.position)>=chunksize then
begin
case chunktype of
0 : Writeln('(0) Contents file from [options] :',printnulterminated(chunksize));
1 : Writeln('(1) Index file from [options] :',printnulterminated(chunksize));
2 : Writeln('(2) Default topic from [options] :',printnulterminated(chunksize));
3 : Writeln('(3) Title from [options] :',printnulterminated(chunksize));
4 : printentry4(m,chunksize);
5 : Writeln('(5) Default Window from [options] :',printnulterminated(chunksize));
6 : Writeln('(6) Compiled file from [options] :',printnulterminated(chunksize));
7 : Writeln('(7) DWord when Binary Index is on :',m.readdwordle, '(= entry in #urltbl has same first dword');
8 : printentry8(m,chunksize);
9 : Writeln('(9) CHM compiler version :',printnulterminated(chunksize));
10: begin
writeln('(10) Timestamp (32-bit?) :',m.readdwordle);
m.position:=m.position+chunksize-4;
end;
11: Writeln('(11) DWord when Binary TOC is on :',m.readdwordle, '(= entry in #urltbl has same first dword');
12: begin
writeln('(12) Number of Information files :',m.readdwordle);
m.position:=m.position+chunksize-4;
end;
13: begin
cnt:=m.position;
Writeln('(13)');
readchunk13(m,r);
m.position:=chunksize+cnt;
end;
14: begin
writeln('(14) MS Office related windowing constants ', chunksize,' bytes');
m.position:=m.position+chunksize;
end;
15: Writeln('(15) Information type checksum :',m.readdwordle,' (Unknown algorithm & data source)');
16: Writeln('(16) Default Font from [options] :',printnulterminated(chunksize));
else
begin
writeln('Not (yet) handled chunk, type ',chunktype,' of size ',chunksize);
m.position:=m.position+chunksize;
end;
end;
end;
end;
m.free;
r.free;
end;
const
siteext : array[TSiteMapType] of string = ('.hhc','.hhk');
procedure extracttocindex(filespec:TStringDynArray;sttype:TSiteMapType);
@ -604,18 +1063,43 @@ begin
else
WrongNrParam(cmdnames[cmd],length(localparams));
end;
cmdextracttoc : begin
cmdextracttoc : begin
if length(localparams)>0 then
extracttocindex(localparams,sttoc)
else
WrongNrParam(cmdnames[cmd],length(localparams));
end;
cmdextractindex: begin
cmdextractindex: begin
if length(localparams)>0 then
extracttocindex(localparams,stindex)
else
WrongNrParam(cmdnames[cmd],length(localparams));
end;
cmdprintidxhdr: begin
if length(localparams)=1 then
printidxhdr(localparams)
else
WrongNrParam(cmdnames[cmd],length(localparams));
end;
cmdprintsystem : begin
if length(localparams)=1 then
printsystem(localparams)
else
WrongNrParam(cmdnames[cmd],length(localparams));
end;
cmdprintwindows : begin
if length(localparams)=1 then
printwindows(localparams)
else
WrongNrParam(cmdnames[cmd],length(localparams));
end;
cmdprinttopics : begin
if length(localparams)=1 then
printtopics(localparams)
else
WrongNrParam(cmdnames[cmd],length(localparams));
end;
end; {case cmd of}
end
else

53
packages/chm/src/chmreader.pas
View File

@ -109,16 +109,15 @@ type
fDefaultWindow: String;
private
FSearchReader: TChmSearchReader;
public
procedure ReadCommonData;
function ReadStringsEntry(APosition: DWord): String;
function ReadStringsEntryFromStream ( strm:TStream ) : String;
function ReadURLSTR(APosition: DWord): String;
function CheckCommonStreams: Boolean;
procedure ReadWindows(mem:TMemoryStream);
public
constructor Create(AStream: TStream; FreeStreamOnDestroy: Boolean); override;
destructor Destroy; override;
public
function GetContextUrl(Context: THelpContext): String;
function LookupTopicByID(ATopicID: Integer; out ATitle: String): String; // returns a url
function GetTOCSitemap(ForceXML:boolean=false): TChmSiteMap;
@ -1079,9 +1078,32 @@ begin
end;
procedure parselistingblock(p:pbyte);
var
itemstack:TObjectStack;
curitemdepth : integer;
parentitem:TChmSiteMap;
procedure updateparentitem(entrydepth:integer);
begin
if entrydepth>curitemdepth then
begin
if curitemdepth<>0 then
itemstack.push(parentitem);
curitemdepth:=entrydepth;
end
else
if entrydepth>curitemdepth then
begin
if curitemdepth<>0 then
itemstack.push(parentitem);
curitemdepth:=entrydepth;
end
end;
var hdr:PBTreeBlockHeader;
head,tail : pbyte;
isseealso,
entrydepth,
nrpairs : Integer;
i : integer;
PE : PBtreeBlockEntry;
@ -1091,8 +1113,8 @@ var hdr:PBTreeBlockHeader;
seealsostr,
topic,
Name : AnsiString;
item : TChmSiteMapItem;
begin
//setlength (curitem,10);
hdr:=PBTreeBlockHeader(p);
hdr^.Length :=LEToN(hdr^.Length);
hdr^.NumberOfEntries :=LEToN(hdr^.NumberOfEntries);
@ -1102,10 +1124,12 @@ begin
tail:=p+(2048-hdr^.length);
head:=p+sizeof(TBtreeBlockHeader);
itemstack:=TObjectStack.create;
{$ifdef binindex}
writeln('previndex : ',hdr^.IndexOfPrevBlock);
writeln('nextindex : ',hdr^.IndexOfNextBlock);
{$endif}
curitemdepth:=0;
while head<tail do
begin
if not ReadWCharString(Head,Tail,Name) Then
@ -1118,13 +1142,14 @@ begin
PE :=PBtreeBlockEntry(head);
NrPairs :=LEToN(PE^.nrpairs);
IsSeealso:=LEToN(PE^.isseealso);
EntryDepth:=LEToN(PE^.entrydepth);
CharIndex:=LEToN(PE^.CharIndex);
{$ifdef binindex}
Writeln('seealso: ',IsSeeAlso);
Writeln('entrydepth: ',LEToN(PE^.entrydepth));
Writeln('seealso : ',IsSeeAlso);
Writeln('entrydepth: ',EntryDepth);
Writeln('charindex : ',charindex );
Writeln('Nrpairs : ',NrPairs);
writeln('seealso data : ');
Writeln('CharIndex : ',charindex);
{$endif}
inc(head,sizeof(TBtreeBlockEntry));
@ -1133,10 +1158,22 @@ begin
if not ReadWCharString(Head,Tail,SeeAlsoStr) Then
Break;
// have to figure out first what to do with it.
// is See Also really mutually exclusive with pairs?
// or is the number of pairs equal to the number of seealso
// strings?
{$ifdef binindex}
writeln('seealso: ',seealsostr);
{$endif}
end
else
begin
if NrPairs>0 Then
begin
{$ifdef binindex}
writeln('Pairs : ');
{$endif}
for i:=0 to nrpairs-1 do
begin
if head<tail Then
@ -1151,6 +1188,7 @@ begin
end;
end;
end;
end;
if nrpairs<>0 Then
createentry(Name,CharIndex,Topic,Title);
inc(head,4); // always 1
@ -1183,9 +1221,10 @@ begin
SiteMap:=TChmSitemap.Create(StIndex);
Item :=Nil; // cached last created item, in case we need to make
// a child.
TryTextual:=True;
BHdr.LastLstBlock:=0;
if LoadBtreeHeader(index,BHdr) and (BHdr.LastLstBlock>0) Then
if LoadBtreeHeader(index,BHdr) and (BHdr.LastLstBlock>=0) Then
begin
if BHdr.BlockSize=defblocksize then
begin

122
packages/chm/src/chmsitemap.pas
View File

@ -18,7 +18,7 @@
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
}
unit chmsitemap;
unit chmsitemap;
{$mode objfpc}{$H+}
@ -26,11 +26,11 @@ interface
uses
Classes, SysUtils, fasthtmlparser;
type
TChmSiteMapItems = class; // forward
TChmSiteMap = class;
{ TChmSiteMapItem }
TChmSiteMapItem = class(TPersistent)
@ -45,6 +45,9 @@ type
FSeeAlso: String;
FText: String;
FURL: String;
FMerge : String;
FFrameName : String;
FWindowName : String;
procedure SetChildren(const AValue: TChmSiteMapItems);
public
constructor Create(AOwner: TChmSiteMapItems);
@ -60,10 +63,11 @@ type
property IncreaseImageIndex: Boolean read FIncreaseImageIndex write FIncreaseImageIndex;
property Comment: String read FComment write FComment;
property Owner: TChmSiteMapItems read FOwner;
//property FrameName: String read FFrameName write FFrameName;
//property WindowName: String read FWindowName write FWindowName;
//property Type_: Integer read FType_ write FType_; either Local or URL
//property Merge: Boolean read FMerge write FMerge;
property FrameName: String read FFrameName write FFrameName;
property WindowName: String read FWindowName write FWindowName;
// property Type_: Integer read FType_ write FType_; either Local or URL
property Merge: String read FMerge write FMerge;
end;
{ TChmSiteMapItems }
@ -194,6 +198,7 @@ var
//TagAttribute,
TagAttributeName,
TagAttributeValue: String;
isParam,IsMerged : string;
begin
//WriteLn('TAG:', AActualTag);
TagName := GetTagName(ACaseInsensitiveTag);
@ -241,40 +246,77 @@ begin
end;
end
else begin // we are the properties of the object tag
if (FLevel > 0 ) and (smbtOBJECT in FSiteMapBodyTags) then begin
if (smbtOBJECT in FSiteMapBodyTags) then
begin
if (FLevel > 0 ) then
begin
if LowerCase(GetTagName(AActualTag)) = 'param' then begin
if LowerCase(GetTagName(AActualTag)) = 'param' then begin
TagAttributeName := GetVal(AActualTag, 'name');
TagAttributeValue := GetVal(AActualTag, 'value');
if TagAttributeName <> '' then begin
if CompareText(TagAttributeName, 'keyword') = 0 then begin
ActiveItem.Text := TagAttributeValue;
end
else if CompareText(TagAttributeName, 'name') = 0 then begin
if ActiveItem.Text = '' then ActiveItem.Text := TagAttributeValue;
end
else if CompareText(TagAttributeName, 'local') = 0 then begin
ActiveItem.Local := TagAttributeValue;
end
else if CompareText(TagAttributeName, 'URL') = 0 then begin
ActiveItem.URL := TagAttributeValue;
end
else if CompareText(TagAttributeName, 'ImageNumber') = 0 then begin
ActiveItem.ImageNumber := StrToInt(TagAttributeValue);
end
else if CompareText(TagAttributeName, 'New') = 0 then begin
ActiveItem.IncreaseImageIndex := (LowerCase(TagAttributeValue) = 'yes');
end
else if CompareText(TagAttributeName, 'Comment') = 0 then begin
ActiveItem.Comment := TagAttributeValue;
end;
//else if CompareText(TagAttributeName, '') = 0 then begin
//end;
TagAttributeName := GetVal(AActualTag, 'name');
TagAttributeValue := GetVal(AActualTag, 'value');
//writeln('name,value',tagattributename, ' ',tagattributevalue);
if TagAttributeName <> '' then begin
if CompareText(TagAttributeName, 'keyword') = 0 then begin
ActiveItem.Text := TagAttributeValue;
end
else if CompareText(TagAttributeName, 'name') = 0 then begin
if ActiveItem.Text = '' then ActiveItem.Text := TagAttributeValue;
end
else if CompareText(TagAttributeName, 'local') = 0 then begin
ActiveItem.Local := TagAttributeValue;
end
else if CompareText(TagAttributeName, 'URL') = 0 then begin
ActiveItem.URL := TagAttributeValue;
end
else if CompareText(TagAttributeName, 'ImageNumber') = 0 then begin
ActiveItem.ImageNumber := StrToInt(TagAttributeValue);
end
else if CompareText(TagAttributeName, 'New') = 0 then begin
ActiveItem.IncreaseImageIndex := (LowerCase(TagAttributeValue) = 'yes');
end
else if CompareText(TagAttributeName, 'Comment') = 0 then begin
ActiveItem.Comment := TagAttributeValue
end
else if CompareText(TagAttributeName, 'Merge') = 0 then begin
ActiveItem.Merge:= TagAttributeValue
end;
//else if CompareText(TagAttributeName, '') = 0 then begin
//end;
end;
end;
end
else
begin // object and level is zero?
if LowerCase(GetTagName(AActualTag)) = 'param' then begin
begin
TagAttributeName := uppercase(GetVal(AActualTag, 'name'));
TagAttributeValue := GetVal(AActualTag, 'value');
if TagAttributeName = 'FRAMENAME' then
framename:=TagAttributeValue
else
if TagAttributeName = 'WINDOWNAME' then
WINDOWname:=TagAttributeValue
else
if TagAttributeName = 'WINDOW STYLES' then
WindowStyles:=StrToIntDef(TagAttributeValue,0)
else
if TagAttributeName = 'EXWINDOW STYLES' then
ExWindowStyles:=StrToIntDef(TagAttributeValue,0)
else
if TagAttributeName = 'FONT' then
FONT:=TagAttributeValue
else
if TagAttributeName = 'IMAGELIST' then
IMAGELIST:=TagAttributeValue
else
if TagAttributeName = 'IMAGETYPE' then
UseFolderImages:=uppercase(TagAttributeValue)='FOLDER';
// writeln('0:',flevel,' ' ,aactualtag,' ',tagname,' ' ,tagattributename, ' ' ,tagattributevalue);
end;
end;
end;
end;
end;
end;
end;
end;
//end
@ -346,7 +388,7 @@ begin
fs.free;
end;
end;
procedure TChmSiteMap.SaveToStream(AStream: TStream);
var
Indent: Integer;
@ -407,7 +449,7 @@ begin
WriteString('<meta name="GENERATOR" content="Microsoft&reg; HTML Help Workshop 4.1">'); // Should we change this?
WriteString('<!-- Sitemap 1.0 -->');
WriteString('</HEAD><BODY>');
// Site Properties
WriteString('<OBJECT type="text/site properties">');
Inc(Indent, 8);

7
packages/chm/src/chmtypes.pas
View File

@ -240,6 +240,8 @@ type
function PageBookInfoRecordSize(ARecord: PTOCEntryPageBookInfo): Integer;
Const defvalidflags = [valid_Navigation_pane_style,valid_Window_style_flags,valid_Initial_window_position,valid_Navigation_pane_width,valid_Buttons,valid_Tab_position];
implementation
uses chmbase;
@ -485,22 +487,20 @@ var ind,len,
arr : array[0..3] of integer;
s2 : string;
begin
flags:=[];
j:=pos('=',txt);
if j>0 then
txt[j]:=',';
ind:=1; len:=length(txt);
window_type :=getnext(txt,ind,len);
Title_bar_text :=getnext(txt,ind,len);
index_file :=getnext(txt,ind,len);
Toc_file :=getnext(txt,ind,len);
index_file :=getnext(txt,ind,len);
Default_File :=getnext(txt,ind,len);
Home_button_file :=getnext(txt,ind,len);
Jumpbutton_1_File :=getnext(txt,ind,len);
Jumpbutton_1_Text :=getnext(txt,ind,len);
Jumpbutton_2_File :=getnext(txt,ind,len);
Jumpbutton_2_Text :=getnext(txt,ind,len);
nav_style :=getnextint(txt,ind,len,flags,valid_navigation_pane_style);
navpanewidth :=getnextint(txt,ind,len,flags,valid_navigation_pane_width);
buttons :=getnextint(txt,ind,len,flags,valid_buttons);
@ -588,6 +588,7 @@ end;
Constructor TCHMWindow.create(s:string='');
begin
flags:=defvalidflags;
if s<>'' then
load_from_ini(s);
end;

437
packages/chm/src/chmwriter.pas
View File

@ -23,7 +23,7 @@ unit chmwriter;
{ $DEFINE LZX_USETHREADS}
interface
uses Classes, ChmBase, chmtypes, chmspecialfiles, HtmlIndexer, chmsitemap, contnrs, Avl_Tree{$IFDEF LZX_USETHREADS}, lzxcompressthread{$ENDIF};
uses Classes, ChmBase, chmtypes, chmspecialfiles, HtmlIndexer, chmsitemap, contnrs, StreamEx, Avl_Tree{$IFDEF LZX_USETHREADS}, lzxcompressthread{$ENDIF};
Const
DefaultHHC = 'Default.hhc';
@ -147,11 +147,13 @@ Type
FURLSTRStream: TMemoryStream; // the #URLSTR file
FFiftiMainStream: TMemoryStream;
FContextStream: TMemoryStream; // the #IVB file
FIDXHdrStream : TMemoryStream; // the #IDXHDR and chunk 13 in #SYSTEM
FTitle: String;
FHasTOC: Boolean;
FHasIndex: Boolean;
FIndexedFiles: TIndexedWordList;
FAvlStrings : TAVLTree; // dedupe strings
FAVLTopicdedupe : TAVlTree; // Topic deduping, if we load it both from hhp and TOC
FAvlURLStr : TAVLTree; // dedupe urltbl + binindex must resolve URL to topicid
SpareString : TStringIndex;
SpareUrlStr : TUrlStrIndex;
@ -159,6 +161,10 @@ Type
FDefaultWindow: String;
FTocName : String;
FIndexName : String;
FMergeFiles : TStringList;
FTocSM : TCHMSitemap;
FHasKLinks : Boolean;
FNrTopics : Integer;
protected
procedure FileAdded(AStream: TStream; const AEntry: TFileEntryRec); override;
private
@ -170,6 +176,8 @@ Type
procedure WriteSTRINGS;
procedure WriteTOPICS;
procedure WriteIVB; // context ids
procedure CreateIDXHDRStream;
procedure WriteIDXHDR;
procedure WriteURL_STR_TBL;
procedure WriteOBJINST;
procedure WriteFiftiMain;
@ -178,10 +186,11 @@ Type
function AddString(AString: String): LongWord;
function AddURL(AURL: String; TopicsIndex: DWord): LongWord;
procedure CheckFileMakeSearchable(AStream: TStream; AFileEntry: TFileEntryRec);
function AddTopic(ATitle,AnUrl:AnsiString):integer;
function AddTopic(ATitle,AnUrl:AnsiString;code:integer=-1):integer;
procedure ScanSitemap(asitemap:TCHMSiteMap);
function NextTopicIndex: Integer;
procedure Setwindows (AWindowList:TObjectList);
procedure SetMergefiles(src:TStringList);
public
constructor Create(AOutStream: TStream; FreeStreamOnDestroy: Boolean); override;
destructor Destroy; override;
@ -193,6 +202,7 @@ Type
procedure AppendIndex(AStream: TStream);
procedure AppendSearchDB(AName: String; AStream: TStream);
procedure AddContext(AContext: DWord; ATopic: String);
procedure AddDummyALink;
property Title: String read FTitle write FTitle;
property FullTextSearch: Boolean read FFullTextSearch write FFullTextSearch;
@ -205,6 +215,8 @@ Type
property TOCName : String read FTocName write FTocName;
property IndexName : String read FIndexName write FIndexName;
property DefaultWindow : string read fdefaultwindow write fdefaultwindow;
property MergeFiles :TStringList read FMergeFiles write setmergefiles;
property Tocsitemap :TChmSitemap read ftocsm write ftocsm;
end;
Function CompareStrings(Node1, Node2: Pointer): integer; // also used in filewriter
@ -932,7 +944,7 @@ begin
end;
procedure TChmWriter.WriteSystem;
procedure TChmWriter.WriteSYSTEM;
var
Entry: TFileEntryRec;
TmpStr: String;
@ -941,7 +953,6 @@ const
VersionStr = 'HHA Version 4.74.8702'; // does this matter?
begin
// this creates the /#SYSTEM file
Entry.Name := '#SYSTEM';
Entry.Path := '/';
@ -977,10 +988,11 @@ begin
FSection0.WriteWord(NToLE(Word(36))); // size
FSection0.WriteDWord(NToLE(DWord($0409)));
FSection0.WriteDWord(1);
FSection0.WriteDWord(0);
FSection0.WriteDWord(NToLE(DWord(Ord(FFullTextSearch and FFullTextSearchAvailable))));
FSection0.WriteDWord(0);
FSection0.WriteDWord(0);
FSection0.WriteDWord(NToLE(Dword(Ord(FHasKLinks))) ); // klinks
FSection0.WriteDWord(0); // alinks
// two for a QWord
FSection0.WriteDWord(0);
@ -990,8 +1002,6 @@ begin
FSection0.WriteDWord(0);
////////////////////////<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
// 2 default page to load
if FDefaultPage <> '' then begin
@ -1077,6 +1087,14 @@ begin
end;
// 13
if FIDXHdrStream.size>0 then
begin
FSection0.WriteWord(NToLE(Word(13)));
FSection0.WriteWord(NToLE(Word(FIDXHdrStream.size)));
FSection0.copyfrom(FIDXHdrStream,0);
end;
Entry.DecompressedSize := FSection0.Position - Entry.DecompressedOffset;
FInternalFiles.AddEntry(Entry);
end;
@ -1104,11 +1122,14 @@ begin
end;
procedure TChmWriter.WriteTOPICS;
//var
//FHits: Integer;
begin
if FTopicsStream.Size = 0 then
Exit;
if tocname<>'' then
AddTopic('',self.TOCName,2);
if indexname<>'' then
AddTopic('',self.IndexName,2);
FTopicsStream.Position := 0;
PostAddStreamToArchive('#TOPICS', '/', FTopicsStream);
// I commented the code below since the result seemed unused
@ -1116,6 +1137,14 @@ begin
// FIndexedFiles.ForEach(@IterateWord,FHits);
end;
procedure TChmWriter.WriteIDXHDR;
begin
if FIDXHdrStream.Size = 0 then
Exit;
FIDXHdrStream.Position := 0;
PostAddStreamToArchive('#IDXHDR', '/', FIDXHdrStream);
end;
procedure TChmWriter.WriteIVB;
begin
if FContextStream = nil then exit;
@ -1128,6 +1157,98 @@ begin
AddStreamToArchive('#IVB', '/', FContextStream);
end;
const idxhdrmagic ='T#SM';
procedure TChmWriter.CreateIDXHDRStream;
var i : Integer;
begin
if fmergefiles.count=0 then // I assume text/site properties could also trigger idxhdr
exit;
FIDXHdrStream.setsize(4096);
FIDXHdrStream.position:=0;
FIDXHdrStream.write(idxhdrmagic[1],4); // 0 Magic
FIDXHdrStream.writedword(ntole(1)); // 4 Unknown timestamp/checksum
FIDXHdrStream.writedword(ntole(1)); // 8 1 (unknown)
FIDXHdrStream.writedword(ntole(FNrTopics)); // C Number of topic nodes including the contents & index files
FIDXHdrStream.writedword(ntole(0)); // 10 0 (unknown)
// 14 Offset in the #STRINGS file of the ImageList param of the "text/site properties" object of the sitemap contents (0/-1 = none)
if assigned(ftocsm) and (ftocsm.ImageList<>'') then
FIDXHdrStream.writedwordLE(addstring(ftocsm.ImageList))
else
FIDXHdrStream.writedwordLE(0);
// 18 0 (unknown)
FIDXHdrStream.writedwordLE(0);
// 1C 1 if the value of the ImageType param of the "text/site properties" object of the sitemap contents is Folder. 0 otherwise.
if assigned(ftocsm) and (ftocsm.UseFolderImages) then
FIDXHdrStream.writedwordLE(1)
else
FIDXHdrStream.writedwordLE(0);
// 20 The value of the Background param of the "text/site properties" object of the sitemap contents
if assigned(ftocsm) then
FIDXHdrStream.writedwordLE(ftocsm.Backgroundcolor)
else
FIDXHdrStream.writedwordLE(0);
// 24 The value of the Foreground param of the "text/site properties" object of the sitemap contents
if assigned(ftocsm) then
FIDXHdrStream.writedwordLE(ftocsm.Foregroundcolor)
else
FIDXHdrStream.writedwordLE(0);
// 28 Offset in the #STRINGS file of the Font param of the "text/site properties" object of the sitemap contents (0/-1 = none)
if assigned(ftocsm) and (ftocsm.Font<>'') then
FIDXHdrStream.writedwordLE(addstring(ftocsm.font))
else
FIDXHdrStream.writedwordLE(0);
// 2C The value of the Window Styles param of the "text/site properties" object of the sitemap contents
if assigned(ftocsm) then
FIDXHdrStream.writedwordLE(FTocsm.WindowStyles)
else
FIDXHdrStream.writedwordLE(0);
// 30 The value of the EXWindow Styles param of the "text/site properties" object of the sitemap contents
if assigned(ftocsm) then
FIDXHdrStream.writedwordLE(FTocSm.ExWindowStyles)
else
FIDXHdrStream.writedwordLE(0);
// 34 Unknown. Often -1. Sometimes 0.
FIDXHdrStream.writedwordLE(0);
// 38 Offset in the #STRINGS file of the FrameName param of the "text/site properties" object of the sitemap contents (0/-1 = none)
if assigned(ftocsm) and (ftocsm.framename<>'') then
FIDXHdrStream.writedwordLE(addstring(FTocsm.Framename))
else
FIDXHdrStream.writedwordLE(0);
// 3C Offset in the #STRINGS file of the WindowName param of the "text/site properties" object of the sitemap contents (0/-1 = none)
if assigned(ftocsm) and (ftocsm.windowname<>'') then
FIDXHdrStream.writedwordLE(addstring(FTocsm.windowname))
else
FIDXHdrStream.writedwordLE(0);
FIDXHdrStream.writedword(ntole(0)); // 40 Number of information types.
FIDXHdrStream.writedword(ntole(0)); // 44 Unknown. Often 1. Also 0, 3.
FIDXHdrStream.writedword(ntole(fmergefiles.count)); // 48 Number of files in the [MERGE FILES] list.
// 4C Unknown. Often 0. Non-zero mostly in files with some files in the merge files list.
if fmergefiles.count>0 then
FIDXHdrStream.writedwordLE(1)
else
FIDXHdrStream.writedwordLE(0);
for i:=0 to FMergefiles.count-1 do
FIDXHdrStream.WriteDword(addstring(fmergefiles[i]));
for i:=0 to 1004-fmergefiles.count-1 do
FIDXHdrStream.WriteDword(0);
end;
procedure TChmWriter.WriteURL_STR_TBL;
begin
if FURLSTRStream.Size <> 0 then begin
@ -1295,8 +1416,8 @@ begin
for i:=0 to FWindows.Count-1 Do
begin
Win:=TChmWindow(FWindows[i]);
WindowStream.WriteDword(NToLE(dword(196 ))); // 0 size of entry.
WindowStream.WriteDword(NToLE(dword(0 ))); // 4 unknown (bool Unicodestrings?)
WindowStream.WriteDwordLE (196); // 0 size of entry.
WindowStream.WriteDwordLE (0); // 4 unknown (bool Unicodestrings?)
WindowStream.WriteDword(NToLE(addstring(win.window_type ))); // 8 Arg 0, name of window
WindowStream.WriteDword(NToLE(dword(win.flags ))); // C valid fields
WindowStream.WriteDword(NToLE(dword(win.nav_style))); // 10 arg 10 navigation pane style
@ -1353,6 +1474,8 @@ begin
WriteITBITS;
// This creates and writes the #SYSTEM file to section0
WriteSystem;
if Assigned(FTocSM) then
Scansitemap(FTocSM);
end;
procedure TChmWriter.WriteFinalCompressedFiles;
@ -1360,8 +1483,10 @@ begin
inherited WriteFinalCompressedFiles;
WriteTOPICS;
WriteURL_STR_TBL;
WriteSTRINGS;
WriteWINDOWS;
CreateIDXHDRStream;
WriteIDXHDR;
WriteSTRINGS;
WriteFiftiMain;
end;
@ -1388,30 +1513,38 @@ begin
FURLTBLStream := TMemoryStream.Create;
FFiftiMainStream := TMemoryStream.Create;
FIndexedFiles := TIndexedWordList.Create;
FAVLTopicdedupe :=TAVLTree.Create(@CompareStrings); // dedupe filenames in topics.
FAvlStrings := TAVLTree.Create(@CompareStrings); // dedupe strings
FAvlURLStr := TAVLTree.Create(@CompareUrlStrs); // dedupe urltbl + binindex must resolve URL to topicid
SpareString := TStringIndex.Create; // We need an object to search in avltree
SpareUrlStr := TUrlStrIndex.Create; // to avoid create/free circles we keep one in spare
FIDXHdrStream := TMemoryStream.Create; // the #IDXHDR and chunk 13 in #SYSTEM
// for searching purposes
FWindows := TObjectlist.Create(True);
FDefaultWindow:= '';
FMergeFiles :=TStringList.Create;
FNrTopics :=0;
end;
destructor TChmWriter.Destroy;
begin
if Assigned(FContextStream) then FContextStream.Free;
FMergeFiles.Free;
FIndexedFiles.Free;
FStringsStream.Free;
FTopicsStream.Free;
FURLSTRStream.Free;
FURLTBLStream.Free;
FFiftiMainStream.Free;
FIDXHdrStream.Create;
SpareString.free;
SpareUrlStr.free;
FAvlUrlStr.FreeAndClear;
FAvlUrlStr.Free;
FAvlStrings.FreeAndClear;
FAvlStrings.Free;
FAVLTopicdedupe.FreeAndClear;
FAVLTopicdedupe.free;
FWindows.Free;
inherited Destroy;
@ -1431,7 +1564,7 @@ begin
SpareString.TheString:=AString;
n:=fAvlStrings.FindKey(SpareString,@CompareStrings);
if assigned(n) then
exit(TStringIndex(n.data).strid);
exit(TStringIndex(n.data).strid);
// each entry is a null terminated string
Pos := DWord(FStringsStream.Position);
@ -1445,9 +1578,9 @@ begin
end;
Result := FStringsStream.Position;
FStringsStream.WriteBuffer(AString[1], Length(AString));
if length(AString)>0 Then
FStringsStream.WriteBuffer(AString[1], Length(AString));
FStringsStream.WriteByte(0);
StrRec:=TStringIndex.Create;
StrRec.TheString:=AString;
StrRec.Strid :=Result;
@ -1516,46 +1649,44 @@ begin
FURLTBLStream.WriteDWord(NtoLE(UrlIndex));
end;
procedure TChmWriter.CheckFileMakeSearchable(AStream: TStream; AFileEntry: TFileEntryRec);
var
var
TopicEntry: TTopicEntry;
ATitle: String;
begin
if Pos('.ht', AFileEntry.Name) > 0 then
begin
ATitle := FIndexedFiles.IndexFile(AStream, NextTopicIndex, FSearchTitlesOnly);
if ATitle <> '' then
TopicEntry.StringsOffset := AddString(ATitle)
else
TopicEntry.StringsOffset := $FFFFFFFF;
TopicEntry.URLTableOffset := AddURL(AFileEntry.Path+AFileEntry.Name, NextTopicIndex);
TopicEntry.InContents := 2;
TopicEntry.Unknown := 0;
TopicEntry.TocOffset := 0;
FTopicsStream.WriteDWord(LEtoN(TopicEntry.TocOffset));
FTopicsStream.WriteDWord(LEtoN(TopicEntry.StringsOffset));
FTopicsStream.WriteDWord(LEtoN(TopicEntry.URLTableOffset));
FTopicsStream.WriteWord(LEtoN(TopicEntry.InContents));
FTopicsStream.WriteWord(LEtoN(TopicEntry.Unknown));
end;
AddTopic(ATitle,AFileEntry.Path+AFileEntry.Name,-1);
end;
end;
function TChmWriter.AddTopic(ATitle,AnUrl:AnsiString):integer;
function TChmWriter.AddTopic(ATitle,AnUrl:AnsiString;code:integer=-1):integer;
var
TopicEntry: TTopicEntry;
begin
anurl:=StringReplace(anurl, '\', '/', [rfReplaceAll]);
if ATitle <> '' then
TopicEntry.StringsOffset := AddString(ATitle)
else
TopicEntry.StringsOffset := $FFFFFFFF;
result:=NextTopicIndex;
TopicEntry.URLTableOffset := AddURL(AnUrl, Result);
TopicEntry.InContents := 2;
if code=-1 then
begin
if ATitle<>'' then
TopicEntry.InContents := 6
else
TopicEntry.InContents := 2;
if pos('#',AnUrl)>0 then
TopicEntry.InContents := 0;
end
else
TopicEntry.InContents := code;
inc(FNrTopics);
TopicEntry.Unknown := 0;
TopicEntry.TocOffset := 0;
FTopicsStream.WriteDWord(LEtoN(TopicEntry.TocOffset));
@ -1565,6 +1696,30 @@ begin
FTopicsStream.WriteWord(LEtoN(TopicEntry.Unknown));
end;
procedure TChmWriter.ScanSitemap(asitemap:TCHMSiteMap);
procedure scanitems(it:TChmSiteMapItems);
var i : integer;
x : TChmSiteMapItem;
s : string;
strrec : TStringIndex;
begin
for i:=0 to it.count -1 do
begin
x:=it.item[i];
// if sanitizeurl(fbasepath,x.local,S) then // sanitize, remove stuff etc.
// begin
// writeln(x.text,' : ',x.local,' ',x.url,' ' ,x.merge);
if assigned(x.children) and (x.children.count>0) then
scanitems(x.children);
end;
end;
begin
scanitems(asitemap.items);
end;
function TChmWriter.NextTopicIndex: Integer;
begin
Result := FTopicsStream.Size div 16;
@ -1807,28 +1962,40 @@ Var
blocknplusentries : Integer; // The other blocks indexed on creation.
datastream,mapstream,propertystream : TMemoryStream;
procedure preparecurrentblock;
procedure preparecurrentblock(force:boolean);
var p: PBTreeBlockHeader;
begin
{$ifdef binindex}
writeln('prepcurblock ' ,Entries,' ',lastblock,' ' ,blocknr,' ',indexstream.position);
{$endif}
p:=@curblock[0];
fillchar(p^,sizeof(TBtreeBlockHeader),#0);
p^.Length:=NToLE(Defblocksize-curind);
p^.NumberOfEntries:=Entries;
p^.IndexOfPrevBlock:=lastblock;
p^.IndexOfPrevBlock:=cardinal(lastblock); // lastblock can be -1, avoid rangecheck
p^.IndexOfNextBlock:=Blocknr;
if force and (blocknr=0) then // only one listblock -> no indexblocks.
p^.IndexOfNextBlock:=dword(-1);
IndexStream.Write(curblock[0],Defblocksize);
fillchar(curblock[0],DefBlockSize,#0);
MapStream.Write(NToLE(MapEntries),sizeof(dword));
MapStream.Write(NToLE(BlockNr),Sizeof(DWord));
MapEntries:=TotalEntries;
curind:=sizeof(TBtreeBlockHeader); // index into current block;
lastblock:=blocknr;
inc(blocknr);
Entries:=0;
{$ifdef binindex}
writeln('prepcurblock post' , indexstream.position);
{$endif}
end;
procedure prepareindexblockn(listingblocknr:integer);
var p:PBTreeIndexBlockHeader;
begin
{$ifdef binindex}
writeln('prepindexblockn');
{$endif}
p:=@Blockn[IndexBlockNr];
p^.Length:=defblocksize-BlockInd;
p^.NumberOfEntries:=BlockEntries;
@ -1838,18 +2005,21 @@ begin
BlockEntries:=0;
BlockInd:=0;
if Indexblocknr>=length(blockn) then
setlength(blockn,length(blockn)+1); // larger increments also possible. #blocks is kept independantly.
begin
setlength(blockn,length(blockn)+1); // larger increments also possible. #blocks is kept independantly.
fillchar(blockn[0][0],sizeof(blockn[0]),#0);
end;
p:=@Blockn[IndexBlockNr];
p^.IndexOfChildBlock:=ListingBlockNr;
blockind:=sizeof(TBTreeIndexBlockHeader);
end;
procedure finalizeindexblockn(p:pbyte;var ind:integer;Entries:integer);
procedure finalizeindexblockn(p:pbyte;var ind:integer;xEntries:integer);
var ph:PBTreeIndexBlockHeader;
begin
ph:=PBTreeIndexBlockHeader(p);
ph^.Length:=defblocksize-Ind;
ph^.NumberOfEntries:=Entries;
ph^.NumberOfEntries:=xEntries;
// p^.IndexOfChildBlock // already entered on block creation, since of first entry, not last.
// inc(Ind);
end;
@ -1858,6 +2028,10 @@ procedure CurEntryToIndex(entrysize:integer);
var p,pentry : pbyte;
indexentrysize : integer;
begin
{$ifdef binindex}
writeln('curentrytoindex ', entrysize);
{$endif}
indexentrysize:=entrysize-sizeof(dword); // index entry is 4 bytes shorter, and only the last dword differs
if (blockind+indexentrysize)>=Defblocksize then
prepareindexblockn(blocknr);
@ -1877,6 +2051,7 @@ var p : pbyte;
i : Integer;
begin
inc(TotalEntries);
fillchar(testblock[0],DefBlockSize,#0);
p:=@TestBlock[0];
for i:=1 to Length(str) do
WriteWord(p,Word(str[i])); // write the wstr in little endian
@ -1886,7 +2061,7 @@ begin
// else
// seealso:=2;
WriteWord(p,seealso); // =0 not a see also 2 =seealso
WriteWord(p,2); // Entrydepth. We can't know it, so write 2.
WriteWord(p,0); // Entrydepth. We can't know it, so write 2.
WriteDword(p,commaatposition); // position of the comma
WriteDword(p,0); // unused 0
WriteDword(p,1); // for now only local pair.
@ -1897,19 +2072,29 @@ begin
WriteDword(p,mod13value); //a value that increments with 13.
mod13value:=mod13value+13;
entrysize:=p-pbyte(@testblock[0]);
{$ifdef binindex}
writeln(curind, ' ',entrysize, ' ',defblocksize);
{$endif}
if (curind+entrysize)>=Defblocksize then
begin
preparecurrentblock;
{$ifdef binindex}
writeln('larger!');
{$endif}
preparecurrentblock(False);
EntrytoIndex:=true;
end;
if EntryToIndex Then
begin
{$ifdef binindex}
writeln('entrytoindex');
{$endif}
CurEntryToIndex(entrysize);
EntryToIndex:=False;
end;
move(testblock[0],curblock[curind],entrysize);
inc(curind,entrysize);
datastream.write(DataEntry,Sizeof(DataEntry));
inc(Entries);
end;
procedure MoveIndexEntry(nr:integer;bytes:integer;childblock:integer);
@ -1931,7 +2116,10 @@ begin
FinalizeIndexBlockn(@blocknplus1[blocknplusindex][0],blockind,blocknplusentries);
inc(blocknplusindex);
if blocknplusindex>=length(blocknplus1) then
setlength(blocknplus1,length(blocknplus1)+1);
begin
setlength(blocknplus1,length(blocknplus1)+1);
fillchar(blocknplus1[length(blocknplus1)-1][0],sizeof(blocknplus1[0]),#0);
end;
blockInd:=Sizeof(TBTreeIndexBlockHeader);
pdword(@blocknplus1[blocknplusindex][0])[4]:=NToLE(ChildBlock); /// init 2nd level index to first 1st level index block
end;
@ -2035,17 +2223,28 @@ begin
indexblocknr:=0; // nr of first index block.
BlockEntries:=0; // entries into current block;
MapEntries :=0; // entries before the current listing block, for MAP file
TreeDepth :=0;
fillchar(testblock[0],DefBlockSize,#0);
fillchar(curblock[0],DefBlockSize,#0);
curind :=sizeof(TBTreeBlockHeader); // index into current listing block;
blockind :=sizeof(TBtreeIndexBlockHeader); // index into current index block
Setlength(blockn,1);
fillchar(blockn[0][0],sizeof(blockn[0]),#0);
pdword(@blockn[0][4])^:=NToLE(0); /// init first listingblock nr to 0 in the first index block
EntryToIndex := True;
{$ifdef binindex}
writeln('items:',asitemap.items.count);
{$endif}
for i:=0 to ASiteMap.Items.Count-1 do
begin
item := TChmSiteMapItem(ASiteMap.Items.Item[i]);
key :=Item.Text;
{$ifdef binindex}
writeln('item: ',i,' ',key);
{$endif}
{$ifdef chm_windowsbinindex}
// append 2 to all index level 0 entries. This
// so we can see if Windows loads the binary or textual index.
@ -2054,10 +2253,10 @@ begin
CombineWithChildren(Item,Key,length(key),true);
{$endif}
end;
PrepareCurrentBlock; // flush last listing block.
PrepareCurrentBlock(True); // flush last listing block.
Listingblocks:=blocknr; // blocknr is from now on the number of the first block in blockn.
// we still need the # of listingblocks for the header though
{$ifdef binindex}
writeln('binindex: listingblocks : '+inttostr(listingblocks),' indexblocks: ',indexblocknr,' entries:',blockentries);
{$endif}
@ -2067,70 +2266,75 @@ begin
// and repeat until we have no entries left.
// First we finalize the current set of blocks
if Blockind<>sizeof(TBtreeIndexBlockHeader) Then
if blocknr>1 then
begin
{$ifdef binindex}
writeln('finalizing level 1 index');
{$endif}
FinalizeIndexBlockN(@blockn[indexblocknr][0],blockind,blockentries); // also increasing indexblocknr
inc(IndexBlockNr);
end;
{$ifdef binindex}
writeln('binindex: listingblocks : '+inttostr(listingblocks),' indexblocks: ',indexblocknr,' entries:',blockentries);
{$endif}
while (Indexblocknr>1) do
begin
{$ifdef binindex}
printloopvars(1);
{$endif}
blockind :=sizeof(TBtreeIndexBlockHeader);
pdword(@blockn[0][4])^:=NToLE(Listingblocks); /// init 2nd level index to first 1st level index block
blocknplusindex :=0;
blocknplusentries :=0;
if length(blocknplus1)<1 then
Setlength(blocknplus1,1);
EntryToIndex :=True;
{$ifdef binindex}
printloopvars(2);
{$endif}
for i:=0 to Indexblocknr-1 do
begin
Entrybytes:=ScanIndexBlock(@blockn[i][0]);
// writeln('after scan ,',i, ' bytes: ',entrybytes,' blocknr:',blocknr,' indexblocknr:',indexblocknr,' to:',blocknr+i);
MoveIndexEntry(i,Entrybytes,blocknr+i);
indexStream.Write(blockn[i][0],defblocksize);
end;
{$ifdef binindex}
printloopvars(3);
{$endif}
If Blockind<>sizeof(TBtreeIndexBlockHeader) Then
if Blockind<>sizeof(TBtreeIndexBlockHeader) Then
begin
{$ifdef binindex}
logentry('finalizing');
writeln('finalizing level 1 index');
{$endif}
FinalizeIndexBlockn(@blocknplus1[blocknplusindex][0],blockind,blocknplusentries);
inc(blocknplusindex);
FinalizeIndexBlockN(@blockn[indexblocknr][0],blockind,blockentries); // also increasing indexblocknr
inc(IndexBlockNr);
end;
inc(blocknr,indexblocknr);
indexblocknr:=blocknplusindex;
blockn:=copy(blocknplus1); setlength(blocknplus1,1);
{$ifdef binindex}
printloopvars(5);
writeln('binindex: listingblocks : '+inttostr(listingblocks),' indexblocks: ',indexblocknr,' entries:',blockentries);
{$endif}
inc(TreeDepth);
while (Indexblocknr>1) do
begin
{$ifdef binindex}
printloopvars(1);
{$endif}
blockind :=sizeof(TBtreeIndexBlockHeader);
pdword(@blockn[0][4])^:=NToLE(Listingblocks); /// init 2nd level index to first 1st level index block
blocknplusindex :=0;
blocknplusentries :=0;
if length(blocknplus1)<1 then
begin
Setlength(blocknplus1,1);
fillchar(blocknplus1[0][0],sizeof(blocknplus1[0]),#0);
end;
EntryToIndex :=True;
{$ifdef binindex}
printloopvars(2);
{$endif}
for i:=0 to Indexblocknr-1 do
begin
Entrybytes:=ScanIndexBlock(@blockn[i][0]);
// writeln('after scan ,',i, ' bytes: ',entrybytes,' blocknr:',blocknr,' indexblocknr:',indexblocknr,' to:',blocknr+i);
MoveIndexEntry(i,Entrybytes,blocknr+i);
indexStream.Write(blockn[i][0],defblocksize);
end;
{$ifdef binindex}
printloopvars(3);
{$endif}
If Blockind<>sizeof(TBtreeIndexBlockHeader) Then
begin
{$ifdef binindex}
logentry('finalizing');
{$endif}
FinalizeIndexBlockn(@blocknplus1[blocknplusindex][0],blockind,blocknplusentries);
inc(blocknplusindex);
end;
inc(blocknr,indexblocknr);
indexblocknr:=blocknplusindex;
blockn:=copy(blocknplus1); setlength(blocknplus1,1);
{$ifdef binindex}
printloopvars(5);
{$endif}
inc(TreeDepth);
end;
indexStream.Write(blockn[0][0],defblocksize);
inc(blocknr);
end;
indexStream.Write(blockn[0][0],defblocksize);
inc(blocknr);
// Fixup header.
hdr.ident[0]:=chr($3B); hdr.ident[1]:=chr($29);
hdr.flags :=NToLE(word($2)); // bit $2 is always 1, bit $0400 1 if dir? (always on)
@ -2141,7 +2345,7 @@ begin
hdr.indexrootblock :=NToLE(dword(blocknr-1)); // Index of the root block in the file.
hdr.unknown1 :=NToLE(dword(-1)); // always -1
hdr.nrblock :=NToLE(blocknr); // Number of blocks
hdr.treedepth :=NToLE(TreeDepth); // The depth of the tree of blocks (1 if no index blocks, 2 one level of index blocks, ...)
hdr.treedepth :=NToLE(word(TreeDepth)); // The depth of the tree of blocks (1 if no index blocks, 2 one level of index blocks, ...)
hdr.nrkeywords :=NToLE(Totalentries); // number of keywords in the file.
hdr.codepage :=NToLE(dword(1252)); // Windows code page identifier (usually 1252 - Windows 3.1 US (ANSI))
hdr.lcid :=NToLE(0); // ???? LCID from the HHP file.
@ -2165,6 +2369,7 @@ begin
PropertyStream.Free;
MapStream.Free;
DataStream.Free;
FHasKLinks:=TotalEntries>0;
end;
procedure TChmWriter.AppendBinaryTOCStream(AStream: TStream);
@ -2187,6 +2392,7 @@ begin
end;
begin
AddDummyALink;
stadd('BTree',IndexStream);
stadd('Data', DataStream);
stadd('Map' , MapStream);
@ -2226,7 +2432,17 @@ begin
FContextStream.WriteDWord(Offset);
end;
procedure TChmWriter.SetWindows(AWindowList:TObjectList);
procedure TChmWriter.AddDummyALink;
var stream : TMemoryStream;
begin
stream:=tmemorystream.create;
stream.WriteDWord(0);
stream.position:=0;
AddStreamToArchive('Property','/$WWAssociativeLinks/',stream,True);
stream.free;
end;
procedure TChmWriter.Setwindows(AWindowList: TObjectList);
var i : integer;
x : TCHMWindow;
@ -2240,6 +2456,13 @@ begin
end;
end;
procedure TChmWriter.SetMergefiles(src:TStringList);
var i : integer;
begin
FMergeFiles.Clear;
for i:=0 to Src.count -1 do
FMergefiles.add(src[i]);
end;
end.