paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 20:39:24 +02:00
Code Issues Packages Projects Releases Wiki Activity
main
fpc/packages/chm/src/chmreader.pas
Michaël Van Canneyt cbc938900f * Fix wrong assigned check pointed out by Gareth Moreton
2024-02-22 09:17:44 +01:00

1875 lines
59 KiB
ObjectPascal
Raw Permalink Blame History

{ Copyright (C) <2005> <Andrew Haines> chmreader.pas
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
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
}
{
See the file COPYING.modifiedLGPL, included in this distribution,
for details about the copyright.
}
{$IFNDEF FPC_DOTTEDUNITS}
unit chmreader;
{$ENDIF FPC_DOTTEDUNITS}
{$mode delphi}
//{$DEFINE CHM_DEBUG}
{ $DEFINE CHM_DEBUG_CHUNKS}
{define binindex}
{define nonumber}
interface
{$IFDEF FPC_DOTTEDUNITS}
uses
System.Generics.Collections, System.Classes, System.SysUtils, System.Contnrs,
Chm.Base, Chm.Lzx, Chm.FiftiMain, Chm.Sitemap;
{$ELSE FPC_DOTTEDUNITS}
uses
Generics.Collections, Classes, SysUtils, Contnrs,
chmbase, paslzx, chmFIftiMain, chmsitemap;
{$ENDIF FPC_DOTTEDUNITS}
type
TLZXResetTableArr = array of QWord;
PContextItem = ^TContextItem;
TContextItem = record
Context: THelpContext;
Url: String;
end;
TContextList = class(TList)
public
procedure AddContext(Context: THelpContext; Url: String);
function GetURL(Context: THelpContext): String;
procedure Clear; override;
end;
{ TITSFReader }
TFileEntryForEach = procedure(Name: String; Offset, UncompressedSize, _Section: Integer) of object;
TITSFReader = class(TObject)
protected
fStream: TStream;
fFreeStreamOnDestroy: Boolean;
fITSFHeader: TITSFHeader;
fHeaderSuffix: TITSFHeaderSuffix;
fDirectoryHeader: TITSPHeader;
fDirectoryHeaderPos: QWord;
fDirectoryHeaderLength: QWord;
fDirectoryEntriesStartPos: QWord;
fCachedEntry: TPMGListChunkEntry; //contains the last entry found by ObjectExists
fDirectoryEntriesCount: LongWord;
procedure ReadHeader; virtual;
procedure ReadHeaderEntries; virtual;
function GetChunkType(Stream: TMemoryStream; ChunkIndex: LongInt): TDirChunkType;
procedure GetSections(out Sections: TStringList);
private
function GetDirectoryChunk(Index: Integer; OutStream: TStream): Integer;
function ReadPMGLchunkEntryFromStream(Stream: TMemoryStream; var PMGLEntry: TPMGListChunkEntry): Boolean;
function ReadPMGIchunkEntryFromStream(Stream: TMemoryStream; var PMGIEntry: TPMGIIndexChunkEntry): Boolean;
procedure LookupPMGLchunk(Stream: TMemoryStream; out PMGLChunk: TPMGListChunk);
procedure LookupPMGIchunk(Stream: TMemoryStream; out PMGIChunk: TPMGIIndexChunk);
function GetBlockFromSection(SectionPrefix: String; StartPos: QWord; BlockLength: QWord): TMemoryStream;
function FindBlocksFromUnCompressedAddr(var ResetTableEntry: TPMGListChunkEntry;
out CompressedSize: QWord; out UnCompressedSize: QWord; out LZXResetTable: TLZXResetTableArr): QWord; // Returns the blocksize
public
constructor Create(AStream: TStream; FreeStreamOnDestroy: Boolean); virtual;
destructor Destroy; override;
public
ChmLastError: LongInt;
function IsValidFile: Boolean;
procedure GetCompleteFileList(ForEach: TFileEntryForEach; AIncludeInternalFiles: Boolean = True); virtual;
function ObjectExists(Name: String): QWord; virtual; // zero if no. otherwise it is the size of the object
// NOTE directories will return zero size even if they exist
function GetObject(Name: String): TMemoryStream; virtual; // YOU must Free the stream
property CachedEntry: TPMGListChunkEntry read fCachedEntry;
end;
{ TChmReader }
TChmReader = class(TITSFReader)
protected
fDefaultPage: String;
fIndexFile: String;
fTOCFile: String;
fTitle: String;
fPreferedFont: String;
fContextList: TContextList;
fTOPICSStream,
fURLSTRStream,
fURLTBLStream,
fStringsStream: TMemoryStream;
fLocaleID: DWord;
fWindowsList : TObjectList;
fDefaultWindow: String;
private
FSearchReader: TChmSearchReader;
public
procedure ReadCommonData;
function ReadStringsEntry(APosition: DWord): String;
function ReadStringsEntryFromStream ( strm:TStream ) : String;
{ Return LocalUrl string from #URLSTR }
function ReadURLSTR(APosition: DWord): String;
function CheckCommonStreams: Boolean;
procedure ReadWindows(mem:TMemoryStream);
constructor Create(AStream: TStream; FreeStreamOnDestroy: Boolean); override;
destructor Destroy; override;
function GetContextUrl(Context: THelpContext): String;
function LookupTopicByID(ATopicID: Integer; out ATitle: String): String; // returns a url
function GetTOCSitemap(ForceXML:boolean=false): TChmSiteMap;
function GetIndexSitemap(ForceXML:boolean=false): TChmSiteMap;
function HasContextList: Boolean;
property DefaultPage: String read fDefaultPage;
property IndexFile: String read fIndexFile;
property TOCFile: String read fTOCFile;
property Title: String read fTitle write fTitle;
property PreferedFont: String read fPreferedFont;
property LocaleID: dword read fLocaleID;
property SearchReader: TChmSearchReader read FSearchReader write FSearchReader;
property contextlist : tcontextlist read fcontextlist;
property Windows : TObjectlist read fWindowsList;
property DefaultWindow : string read fdefaultwindow;
end;
{ TChmFileList }
TChmFileList = class;
TChmFileOpenEvent = procedure(ChmFileList: TChmFileList; Index: Integer) of object;
TChmFileList = class(TStringList)
protected
fLastChm: TChmReader;
fUnNotifiedFiles: TList;
fOnOpenNewFile: TChmFileOpenEvent;
procedure Delete(Index: Integer); override;
function GetChm(AIndex: Integer): TChmReader;
function GetFileName(AIndex: Integer): String;
procedure OpenNewFile(AFileName: String);
function CheckOpenFile(AFileName: String): Boolean;
function MetaObjectExists(var Name: String): QWord;
function MetaGetObject(Name: String): TMemoryStream;
procedure SetOnOpenNewFile(AValue: TChmFileOpenEvent);
public
constructor Create(PrimaryFileName: String);
destructor Destroy; override;
function GetObject(Name: String): TMemoryStream;
function IsAnOpenFile(AFileName: String): Boolean;
function ObjectExists(Name: String; var fChm: TChmReader): QWord;
//properties
property Chm[Index: Integer]: TChmReader read GetChm;
property FileName[Index: Integer]: String read GetFileName;
property OnOpenNewFile: TChmFileOpenEvent read fOnOpenNewFile write SetOnOpenNewFile;
end;
//ErrorCodes
const
ERR_NO_ERR = 0;
ERR_STREAM_NOT_ASSIGNED = 1;
ERR_NOT_SUPPORTED_VERSION = 2;
ERR_NOT_VALID_FILE = 3;
ERR_UNKNOWN_ERROR = 10;
function ChmErrorToStr(Error: Integer): String;
implementation
{$IFDEF FPC_DOTTEDUNITS}
uses Chm.Types;
{$ELSE FPC_DOTTEDUNITS}
uses ChmTypes;
{$ENDIF FPC_DOTTEDUNITS}
function ChmErrorToStr(Error: Integer): String;
begin
Result := '';
case Error of
ERR_STREAM_NOT_ASSIGNED : Result := 'ERR_STREAM_NOT_ASSIGNED';
ERR_NOT_SUPPORTED_VERSION : Result := 'ERR_NOT_SUPPORTED_VERSION';
ERR_NOT_VALID_FILE : Result := 'ERR_NOT_VALID_FILE';
ERR_UNKNOWN_ERROR : Result := 'ERR_UNKNOWN_ERROR';
end;
end;
function ChunkType(Stream: TMemoryStream): TDirChunkType;
var
ChunkID: array[0..3] of AnsiChar;
begin
Result := ctUnknown;
if Stream.Size< 4 then exit;
Move(Stream.Memory^, ChunkId[0], 4);
if ChunkID = 'PMGL' then Result := ctPMGL
else if ChunkID = 'PMGI' then Result := ctPMGI
else if ChunkID = 'AOLL' then Result := ctAOLL
else if ChunkID = 'AOLI' then Result := ctAOLI;
end;
{ TITSFReader }
procedure TITSFReader.ReadHeader;
begin
fStream.Read(fITSFHeader,SizeOf(fITSFHeader));
// Fix endian issues
{$IFDEF ENDIAN_BIG}
fITSFHeader.Version := LEtoN(fITSFHeader.Version);
fITSFHeader.HeaderLength := LEtoN(fITSFHeader.HeaderLength);
//Unknown_1
fITSFHeader.TimeStamp := BEtoN(fITSFHeader.TimeStamp);//bigendian
fITSFHeader.LanguageID := LEtoN(fITSFHeader.LanguageID);
{$ENDIF}
if fITSFHeader.Version < 4 then
fStream.Seek(SizeOf(TGuid)*2, soCurrent);
if not IsValidFile then Exit;
ReadHeaderEntries;
end;
procedure TITSFReader.ReadHeaderEntries;
var
fHeaderEntries: array [0..1] of TITSFHeaderEntry;
begin
// Copy EntryData into memory
fStream.Read(fHeaderEntries[0], SizeOf(fHeaderEntries));
if fITSFHeader.Version = 3 then
fStream.Read(fHeaderSuffix.Offset, SizeOf(QWord));
fHeaderSuffix.Offset := LEtoN(fHeaderSuffix.Offset);
// otherwise this is set in fill directory entries
fStream.Position := LEtoN(fHeaderEntries[1].PosFromZero);
fDirectoryHeaderPos := LEtoN(fHeaderEntries[1].PosFromZero);
fStream.Read(fDirectoryHeader, SizeOf(fDirectoryHeader));
{$IFDEF ENDIAN_BIG}
with fDirectoryHeader do begin
Version := LEtoN(Version);
DirHeaderLength := LEtoN(DirHeaderLength);
//Unknown1
ChunkSize := LEtoN(ChunkSize);
Density := LEtoN(Density);
IndexTreeDepth := LEtoN(IndexTreeDepth);
IndexOfRootChunk := LEtoN(IndexOfRootChunk);
FirstPMGLChunkIndex := LEtoN(FirstPMGLChunkIndex);
LastPMGLChunkIndex := LEtoN(LastPMGLChunkIndex);
//Unknown2
DirectoryChunkCount := LEtoN(DirectoryChunkCount);
LanguageID := LEtoN(LanguageID);
//GUID: TGuid;
LengthAgain := LEtoN(LengthAgain);
end;
{$ENDIF}
{$IFDEF CHM_DEBUG}
WriteLn('PMGI depth = ', fDirectoryHeader.IndexTreeDepth);
WriteLn('PMGI Root = ', fDirectoryHeader.IndexOfRootChunk);
Writeln('DirCount = ', fDirectoryHeader.DirectoryChunkCount);
{$ENDIF}
fDirectoryEntriesStartPos := fStream.Position;
fDirectoryHeaderLength := LEtoN(fHeaderEntries[1].Length);
end;
procedure TChmReader.ReadCommonData;
// A little helper proc to make reading a null terminated string easier
function ReadString(const Stream: TStream; StartPos: DWord; FixURL: Boolean): String;
var
buf: array[0..49] of AnsiChar;
begin
Result := '';
Stream.Position := StartPos;
repeat
Stream.Read(buf, 50);
Result := Result + buf;
until IndexByte(buf, 50, 0) <> -1;
if FixURL then
Result := StringReplace(Result, '\', '/', [rfReplaceAll]);
end;
procedure ReadFromSystem;
var
//Version: DWord;
EntryType: Word;
EntryLength: Word;
Data: array[0..511] of AnsiChar;
fSystem: TMemoryStream;
Tmp: String;
begin
fSystem := TMemoryStream(GetObject('/#SYSTEM'));
if fSystem = nil then begin
exit;
end;
fSystem.Position := 0;
if fSystem.Size < SizeOf(DWord) then begin
fSystem.Free;
Exit;
end;
{Version := }LEtoN(fSystem.ReadDWord);
while fSystem.Position < fSystem.Size do begin
EntryType := LEtoN(fSystem.ReadWord);
EntryLength := LEtoN(fSystem.ReadWord);
case EntryType of
0: // Table of contents
begin
if EntryLength > 511 then EntryLength := 511;
fSystem.Read(Data[0], EntryLength);
Data[EntryLength] := #0;
fTOCFile := '/'+Data;
end;
1: // Index File
begin
if EntryLength > 511 then EntryLength := 511;
fSystem.Read(Data[0], EntryLength);
Data[EntryLength] := #0;
fIndexFile := '/'+Data;
end;
2: // DefaultPage
begin
if EntryLength > 511 then EntryLength := 511;
fSystem.Read(Data[0], EntryLength);
Data[EntryLength] := #0;
fDefaultPage := '/'+Data;
end;
3: // Title of chm
begin
if EntryLength > 511 then EntryLength := 511;
fSystem.Read(Data[0], EntryLength);
Data[EntryLength] := #0;
fTitle := Data;
end;
4: // Locale ID
begin
fLocaleID := LEtoN(fSystem.ReadDWord);
fSystem.Position := (fSystem.Position + EntryLength) - SizeOf(DWord);
end;
6: // chm file name. use this to get the index and toc name
begin
if EntryLength > 511 then EntryLength := 511;
fSystem.Read(Data[0], EntryLength);
Data[EntryLength] := #0;
if (fIndexFile = '') then begin
Tmp := '/'+Data+'.hhk';
if (ObjectExists(Tmp) > 0) then begin
fIndexFile := Tmp;
end
end;
if (fTOCFile = '') then begin
Tmp := '/'+Data+'.hhc';
if (ObjectExists(Tmp) > 0) then begin
fTOCFile := Tmp;
end;
end;
end;
16: // Prefered font
begin
if EntryLength > 511 then EntryLength := 511;
fSystem.Read(Data[0], EntryLength);
Data[EntryLength] := #0;
fPreferedFont := Data;
end;
else
// Skip entries we are not interested in
fSystem.Position := fSystem.Position + EntryLength;
end;
end;
fSystem.Free;
end;
procedure ReadFromWindows;
var
fWindows,
fStrings: TMemoryStream;
EntryCount,
EntrySize: DWord;
EntryStart: QWord;
X: Integer;
OffSet: QWord;
begin
fWindows := TMemoryStream(GetObject('/#WINDOWS'));
if fWindows = nil then begin
exit;
end;
fStrings := TMemoryStream(GetObject('/#STRINGS'));
if fStrings = nil then begin
if fWindows <> nil then fWindows.Free;
Exit;
end;
fWindows.Position := 0;
if (fWindows.Size = 0) or (fStrings.Size = 0) then begin
fWindows.Free;
fStrings.Free;
Exit;
end;
EntryCount := LEtoN(fWindows.ReadDWord);
EntrySize := LEtoN(fWindows.ReadDWord);
OffSet := fWindows.Position;
for X := 0 to EntryCount -1 do begin
EntryStart := OffSet + (X*EntrySize);
if fTitle = '' then begin
fWindows.Position := EntryStart + $14;
fTitle := '/'+ReadString(fStrings, LEtoN(fWindows.ReadDWord), False);
end;
if fTOCFile = '' then begin
fWindows.Position := EntryStart + $60;
fTOCFile := '/'+ReadString(fStrings, LEtoN(fWindows.ReadDWord), True);
end;
if fIndexFile = '' then begin
fWindows.Position := EntryStart + $64;
fIndexFile := '/'+ReadString(fStrings, LEtoN(fWindows.ReadDWord), True);
end;
if fDefaultPage = '' then begin
fWindows.Position := EntryStart + $68;
fDefaultPage := '/'+ReadString(fStrings, LEtoN(fWindows.ReadDWord), True);
end;
end;
ReadWindows(FWindows);
fWindows.Free;
fStrings.Free;
end;
procedure ReadContextIds;
var
fIVB,
fStrings: TStream;
Str: String;
Value: DWord;
OffSet: DWord;
//TotalSize: DWord;
begin
fIVB := GetObject('/#IVB');
if fIVB = nil then Exit;
fStrings := GetObject('/#STRINGS');
if fStrings = nil then begin
fIVB.Free;
Exit;
end;
fIVB.Position := 0;
{TotalSize := }LEtoN(fIVB.ReadDWord);
while fIVB.Position < fIVB.Size do begin
Value := LEtoN(fIVB.ReadDWord);
OffSet := LEtoN(fIVB.ReadDWord);
Str := '/'+ ReadString(fStrings, Offset, True);
fContextList.AddContext(Value, Str);
end;
fIVB.Free;
fStrings.Free;
end;
begin
ReadFromSystem;
ReadFromWindows;
ReadContextIds;
{$IFDEF CHM_DEBUG}
WriteLn('TOC=',fTocfile);
WriteLn('DefaultPage=',fDefaultPage);
{$ENDIF}
end;
function TChmReader.ReadStringsEntry ( APosition: DWord ) : String;
begin
Result := '';
if fStringsStream = nil then
fStringsStream := GetObject('/#STRINGS');
if fStringsStream = nil then
Exit;
if APosition < fStringsStream.Size-1 then
begin
Result := PAnsiChar(fStringsStream.Memory+APosition);
end;
end;
function TChmReader.ReadStringsEntryFromStream ( strm:TStream ) : String;
var APosition : DWord;
begin
APosition:=LEtoN(strm.ReadDWord);
result:=ReadStringsEntry(APosition);
end;
function TChmReader.ReadURLSTR ( APosition: DWord ) : String;
begin
result:='';
if not CheckCommonStreams then
Exit;
fURLTBLStream.Position := APosition;
fURLTBLStream.ReadDWord; // unknown
fURLTBLStream.ReadDWord; // TOPIC index #
fURLSTRStream.Position := LEtoN(fURLTBLStream.ReadDWord);
fURLSTRStream.ReadDWord; // URL
fURLSTRStream.ReadDWord; // FrameName
if fURLSTRStream.Position < fURLSTRStream.Size-1 then
Result := PAnsiChar(fURLSTRStream.Memory+fURLSTRStream.Position);
end;
function TChmReader.CheckCommonStreams: Boolean;
begin
if fTOPICSStream = nil then
fTOPICSStream := GetObject('/#TOPICS');
if fURLSTRStream = nil then
fURLSTRStream := GetObject('/#URLSTR');
if fURLTBLStream = nil then
fURLTBLStream := GetObject('/#URLTBL');
Result := (fTOPICSStream <> nil)
and (fURLSTRStream <> nil)
and (fURLTBLStream <> nil);
end;
procedure TChmReader.ReadWindows(mem:TMemoryStream);
var
i,cnt,
version : integer;
x : TChmWindow;
begin
fWindowsList.Clear;
mem.Position:=0;
cnt := LEtoN(mem.ReadDWord);
version := LEtoN(mem.ReadDWord);
while (cnt>0) do
begin
x:=TChmWindow.Create;
version := LEtoN(mem.ReadDWord); // 0 size of entry.
mem.readDWord; // 4 unknown (bool Unicodestrings?)
x.window_type :=ReadStringsEntryFromStream(mem); // 8 Arg 0, name of window
x.flags := TValidWindowFields(LEtoN(mem.ReadDWord)); // C valid fields
x.nav_style := LEtoN(mem.ReadDWord); // 10 arg 10 navigation pane style
x.title_bar_text :=ReadStringsEntryFromStream(mem); // 14 Arg 1, title bar text
x.styleflags := LEtoN(mem.ReadDWord); // 18 Arg 14, style flags
x.xtdstyleflags := LEtoN(mem.ReadDWord); // 1C Arg 15, xtd style flags
x.left := LEtoN(mem.ReadDWord); // 20 Arg 13, rect.left
x.right := LEtoN(mem.ReadDWord); // 24 Arg 13, rect.top
x.top := LEtoN(mem.ReadDWord); // 28 Arg 13, rect.right
x.bottom := LEtoN(mem.ReadDWord); // 2C Arg 13, rect.bottom
x.window_show_state:= LEtoN(mem.ReadDWord); // 30 Arg 16, window show state
mem.readdword; // 34 - , HWND hwndhelp OUT: window handle"
mem.readdword; // 38 - , HWND hwndcaller OUT: who called this window"
mem.readdword; // 3C - , HH_INFO_TYPE paINFO_TYPES IN: Pointer to an array of Information Types"
mem.readdword; // 40 - , HWND hwndtoolbar OUT: toolbar window in tri-pane window"
mem.readdword; // 44 - , HWND hwndnavigation OUT: navigation window in tri-pane window"
mem.readdword; // 48 - , HWND hwndhtml OUT: window displaying HTML in tri-pane window"
x.navpanewidth := LEtoN(mem.ReadDWord); // 4C Arg 11, width of nav pane
mem.readdword; // 50 - , rect.left, OUT:Specifies the coordinates of the Topic pane
mem.readdword; // 54 - , rect.top , OUT:Specifies the coordinates of the Topic pane
mem.readdword; // 58 - , rect.right, OUT:Specifies the coordinates of the Topic pane
mem.readdword; // 5C - , rect.bottom, OUT:Specifies the coordinates of the Topic pane
x.toc_file :=ReadStringsEntryFromStream(mem); // 60 Arg 2, toc file
x.index_file :=ReadStringsEntryFromStream(mem); // 64 Arg 3, index file
x.default_file :=ReadStringsEntryFromStream(mem); // 68 Arg 4, default file
x.home_button_file :=ReadStringsEntryFromStream(mem); // 6c Arg 5, home button file.
x.buttons := LEtoN(mem.ReadDWord); // 70 arg 12,
x.navpane_initially_closed := LEtoN(mem.ReadDWord); // 74 arg 17
x.navpane_default := LEtoN(mem.ReadDWord); // 78 arg 18,
x.navpane_location := LEtoN(mem.ReadDWord); // 7C arg 19,
x.wm_notify_id := LEtoN(mem.ReadDWord); // 80 arg 20,
for i:=0 to 4 do
mem.ReadDWord; // 84 - byte[20] unknown - "BYTE tabOrder[HH_MAX_TABS + 1]; // IN/OUT: tab order: Contents, Index, Search, History, Favorites, Reserved 1-5, Custom tabs"
mem.ReadDWord; // 94 - int cHistory; // IN/OUT: number of history items to keep (default is 30)
x.jumpbutton_1_text:=ReadStringsEntryFromStream(mem); // 9C Arg 7, The text of the Jump 1 button.
x.jumpbutton_2_text:=ReadStringsEntryFromStream(mem); // A0 Arg 9, The text of the Jump 2 button.
x.jumpbutton_1_file:=ReadStringsEntryFromStream(mem); // A4 Arg 6, The file shown for Jump 1 button.
x.jumpbutton_2_file:=ReadStringsEntryFromStream(mem); // A8 Arg 8, The file shown for Jump 1 button.
for i:=0 to 3 do
mem.ReadDWord;
dec(version,188); // 1.1 specific onesf
while (version>=4) do
begin
mem.readdword;
dec(version,4);
end;
fWindowslist.Add(x);
dec(cnt);
end;
end;
constructor TChmReader.Create(AStream: TStream; FreeStreamOnDestroy: Boolean);
begin
fContextList := TContextList.Create;
fWindowslist := TObjectlist.Create(True);
fDefaultWindow:='';
inherited Create(AStream, FreeStreamOnDestroy);
if not IsValidFile then exit;
ReadCommonData;
end;
destructor TChmReader.Destroy;
begin
FreeAndNil(fContextList);
FreeAndNil(FWindowslist);
FreeAndNil(FSearchReader);
FreeAndNil(fTOPICSStream);
FreeAndNil(fURLSTRStream);
FreeAndNil(fURLTBLStream);
FreeAndNil(fStringsStream);
inherited Destroy;
end;
function TITSFReader.GetChunkType(Stream: TMemoryStream; ChunkIndex: LongInt): TDirChunkType;
var
Sig: array[0..3] of AnsiChar;
begin
Result := ctUnknown;
Stream.Position := fDirectoryEntriesStartPos + (fDirectoryHeader.ChunkSize * ChunkIndex);
Stream.Read(Sig, 4);
if Sig = 'PMGL' then Result := ctPMGL
else if Sig = 'PMGI' then Result := ctPMGI
else if Sig = 'AOLL' then Result := ctAOLL
else if Sig = 'AOLI' then Result := ctAOLI;
end;
function TITSFReader.GetDirectoryChunk(Index: Integer; OutStream: TStream): Integer;
begin
Result := Index;
fStream.Position := fDirectoryEntriesStartPos + (fDirectoryHeader.ChunkSize * Index);
OutStream.Position := 0;
OutStream.Size := fDirectoryHeader.ChunkSize;
OutStream.CopyFrom(fStream, fDirectoryHeader.ChunkSize);
OutStream.Position := 0;
end;
procedure TITSFReader.LookupPMGLchunk(Stream: TMemoryStream; out PMGLChunk: TPMGListChunk);
begin
//Stream.Position := fDirectoryEntriesStartPos + (fDirectoryHeader.ChunkSize * ChunkIndex);
Stream.Read(PMGLChunk, SizeOf(PMGLChunk));
{$IFDEF ENDIAN_BIG}
with PMGLChunk do begin
UnusedSpace := LEtoN(UnusedSpace);
//Unknown1
PreviousChunkIndex := LEtoN(PreviousChunkIndex);
NextChunkIndex := LEtoN(NextChunkIndex);
end;
{$ENDIF}
end;
function TITSFReader.ReadPMGLchunkEntryFromStream(Stream: TMemoryStream; var PMGLEntry: TPMGListChunkEntry): Boolean;
var
Buf: array [0..1023] of AnsiChar;
NameLength: LongInt;
begin
Result := False;
//Stream.Position := fDirectoryEntriesStartPos + (fDirectoryHeader.ChunkSize * ChunkIndex);
NameLength := LongInt(GetCompressedInteger(Stream));
if NameLength > 1022 then NameLength := 1022;
Stream.Read(buf[0], NameLength);
buf[NameLength] := #0;
PMGLEntry.Name := buf;
PMGLEntry.ContentSection := LongWord(GetCompressedInteger(Stream));
PMGLEntry.ContentOffset := GetCompressedInteger(Stream);
PMGLEntry.DecompressedLength := GetCompressedInteger(Stream);
if NameLength = 0 then Exit; // failed GetCompressedInteger sanity check
Result := True;
end;
procedure TITSFReader.LookupPMGIchunk(Stream: TMemoryStream; out PMGIChunk: TPMGIIndexChunk);
begin
//Stream.Position := fDirectoryEntriesStartPos + (fDirectoryHeader.ChunkSize * ChunkIndex);
Stream.Read(PMGIChunk, SizeOf(PMGIChunk));
{$IFDEF ENDIAN_BIG}
with PMGIChunk do begin
UnusedSpace := LEtoN(UnusedSpace);
end;
{$ENDIF}
end;
function TITSFReader.ReadPMGIchunkEntryFromStream(Stream: TMemoryStream;
var PMGIEntry: TPMGIIndexChunkEntry): Boolean;
var
Buf: array [0..1023] of AnsiChar;
NameLength: LongInt;
begin
Result := False;
//Stream.Position := fDirectoryEntriesStartPos + (fDirectoryHeader.ChunkSize * ChunkIndex);
NameLength := LongInt(GetCompressedInteger(Stream));
if NameLength > 1023 then NameLength := 1023;
Stream.Read(buf, NameLength);
buf[NameLength] := #0;
PMGIEntry.Name := buf;
PMGIEntry.ListingChunk := GetCompressedInteger(Stream);
if NameLength = 0 then Exit; // failed GetCompressedInteger sanity check
Result := True;
end;
constructor TITSFReader.Create(AStream: TStream; FreeStreamOnDestroy: Boolean);
begin
fStream := AStream;
fStream.Position := 0;
fFreeStreamOnDestroy := FreeStreamOnDestroy;
ReadHeader;
if not IsValidFile then Exit;
end;
destructor TITSFReader.Destroy;
begin
if fFreeStreamOnDestroy then FreeAndNil(fStream);
inherited Destroy;
end;
function TITSFReader.IsValidFile: Boolean;
begin
if (fStream = nil) then ChmLastError := ERR_STREAM_NOT_ASSIGNED
else if (fITSFHeader.ITSFsig <> 'ITSF') then ChmLastError := ERR_NOT_VALID_FILE
//else if (fITSFHeader.Version <> 2) and (fITSFHeader.Version <> 3)
else if not (fITSFHeader.Version in [2..4])
then
ChmLastError := ERR_NOT_SUPPORTED_VERSION;
Result := ChmLastError = ERR_NO_ERR;
end;
procedure TITSFReader.GetCompleteFileList(ForEach: TFileEntryForEach; AIncludeInternalFiles: Boolean = True);
var
ChunkStream: TMemoryStream;
I : Integer;
Entry: TPMGListChunkEntry;
PMGLChunk: TPMGListChunk;
CutOffPoint: Integer;
NameLength: Integer;
{$IFDEF CHM_DEBUG_CHUNKS}
PMGIChunk: TPMGIIndexChunk;
PMGIndex: Integer;
{$ENDIF}
begin
if not assigned(ForEach) then Exit;
ChunkStream := TMemoryStream.Create;
{$IFDEF CHM_DEBUG_CHUNKS}
WriteLn('ChunkCount = ',fDirectoryHeader.DirectoryChunkCount);
{$ENDIF}
for I := 0 to fDirectoryHeader.DirectoryChunkCount-1 do begin
GetDirectoryChunk(I, ChunkStream);
case ChunkType(ChunkStream) of
ctPMGL:
begin
LookupPMGLchunk(ChunkStream, PMGLChunk);
{$IFDEF CHM_DEBUG_CHUNKS}
WriteLn('PMGL: ', I, ' Prev PMGL: ', PMGLChunk.PreviousChunkIndex, ' Next PMGL: ', PMGLChunk.NextChunkIndex);
{$ENDIF}
CutOffPoint := ChunkStream.Size - PMGLChunk.UnusedSpace;
while ChunkStream.Position < CutOffPoint do begin
NameLength := GetCompressedInteger(ChunkStream);
if (ChunkStream.Position > CutOffPoint) then Continue; // we have entered the quickref section
SetLength(Entry.Name, NameLength);
ChunkStream.ReadBuffer(Entry.Name[1], NameLength);
if (Entry.Name = '') or (ChunkStream.Position > CutOffPoint) then Break; // we have entered the quickref section
Entry.ContentSection := GetCompressedInteger(ChunkStream);
if ChunkStream.Position > CutOffPoint then Break; // we have entered the quickref section
Entry.ContentOffset := GetCompressedInteger(ChunkStream);
if ChunkStream.Position > CutOffPoint then Break; // we have entered the quickref section
Entry.DecompressedLength := GetCompressedInteger(ChunkStream);
if ChunkStream.Position > CutOffPoint then Break; // we have entered the quickref section
fCachedEntry := Entry; // if the caller trys to get this data we already know where it is :)
if (Length(Entry.Name) = 1)
or (AIncludeInternalFiles
or
((Length(Entry.Name) > 1) and (not(Entry.Name[2] in ['#','$',':']))))
then
ForEach(Entry.Name, Entry.ContentOffset, Entry.DecompressedLength, Entry.ContentSection);
end;
end;
{$IFDEF CHM_DEBUG_CHUNKS}
ctPMGI:
begin
WriteLn('PMGI: ', I);
LookupPMGIchunk(ChunkStream, PMGIChunk);
CutOffPoint := ChunkStream.Size - PMGIChunk.UnusedSpace - 10;
while ChunkStream.Position < CutOffPoint do begin
NameLength := GetCompressedInteger(ChunkStream);
SetLength(Entry.Name, NameLength);
ChunkStream.ReadBuffer(Entry.Name[1], NameLength);
PMGIndex := GetCompressedInteger(ChunkStream);
WriteLn(Entry.Name, ' ', PMGIndex);
end;
end;
ctUnknown: WriteLn('UNKNOWN CHUNKTYPE!' , I);
{$ENDIF}
end;
end;
end;
function TITSFReader.ObjectExists(Name: String): QWord;
var
ChunkStream: TMemoryStream;
QuickRefCount: Word;
QuickRefIndex: array of Word;
ItemCount: Integer;
procedure ReadQuickRefSection;
var
OldPosn: QWord;
Posn: Integer;
I: Integer;
begin
OldPosn := ChunkStream.Position;
Posn := ChunkStream.Size-SizeOf(Word);
ChunkStream.Position := Posn;
ItemCount := LEToN(ChunkStream.ReadWord);
//WriteLn('Max ITems for next block = ', ItemCount-1);
QuickRefCount := ItemCount div (1 + (1 shl fDirectoryHeader.Density));
//WriteLn('QuickRefCount = ' , QuickRefCount);
SetLength(QuickRefIndex, QuickRefCount+1);
for I := 1 to QuickRefCount do begin
Dec(Posn, SizeOf(Word));
ChunkStream.Position := Posn;
QuickRefIndex[I] := LEToN(ChunkStream.ReadWord);
end;
Inc(QuickRefCount);
ChunkStream.Position := OldPosn;
end;
function ReadString(StreamPosition: Integer = -1): String;
var
NameLength: Integer;
begin
if StreamPosition > -1 then ChunkStream.Position := StreamPosition;
NameLength := GetCompressedInteger(ChunkStream);
SetLength(Result, NameLength);
if NameLength>0 then
ChunkStream.Read(Result[1], NameLength);
end;
var
PMGLChunk: TPMGListChunk;
PMGIChunk: TPMGIIndexChunk;
//ChunkStream: TMemoryStream; declared above
Entry: TPMGListChunkEntry;
NextIndex: Integer;
EntryName: String;
CRes: Integer;
I: Integer;
begin
Result := 0;
//WriteLn('Looking for URL : ', Name);
if Name = '' then Exit;
if fDirectoryHeader.DirectoryChunkCount = 0 then exit;
//WriteLn('Looking for ', Name);
if Name = fCachedEntry.Name then
Exit(fCachedEntry.DecompressedLength); // we've already looked it up
ChunkStream := TMemoryStream.Create;
try
NextIndex := fDirectoryHeader.IndexOfRootChunk;
if NextIndex < 0 then NextIndex := 0; // no PMGI chunks
while NextIndex > -1 do begin
GetDirectoryChunk(NextIndex, ChunkStream);
NextIndex := -1;
ReadQuickRefSection;
{$IFDEF CHM_DEBUG}
WriteLn('In Block ', NextIndex);
{$endif}
case ChunkType(ChunkStream) of
ctUnknown: // something is wrong
begin
{$IFDEF CHM_DEBUG}WriteLn(NextIndex, ' << Unknown BlockType!');{$ENDIF}
Break;
end;
ctPMGI: // we must follow the PMGI tree until we reach a PMGL block
begin
LookupPMGIchunk(ChunkStream, PMGIChunk);
//QuickRefIndex[0] := ChunkStream.Position;
I := 0;
while ChunkStream.Position <= ChunkStream.Size - PMGIChunk.UnusedSpace do begin;
EntryName := ReadString;
if EntryName = '' then break;
if ChunkStream.Position >= ChunkStream.Size - PMGIChunk.UnusedSpace then break;
CRes := ChmCompareText(Name, EntryName);
if CRes = 0 then begin
// no more need of this block. onto the next!
NextIndex := GetCompressedInteger(ChunkStream);
Break;
end;
if CRes < 0 then begin
if I = 0 then Break; // File doesn't exist
// file is in previous entry
Break;
end;
NextIndex := GetCompressedInteger(ChunkStream);
Inc(I);
end;
end;
ctPMGL:
begin
LookupPMGLchunk(ChunkStream, PMGLChunk);
QuickRefIndex[0] := ChunkStream.Position;
I := 0;
while ChunkStream.Position <= ChunkStream.Size - PMGLChunk.UnusedSpace do begin
// we consume the entry by reading it
Entry.Name := ReadString;
if Entry.Name = '' then break;
if ChunkStream.Position >= ChunkStream.Size - PMGLChunk.UnusedSpace then break;
Entry.ContentSection := GetCompressedInteger(ChunkStream);
Entry.ContentOffset := GetCompressedInteger(ChunkStream);
Entry.DecompressedLength := GetCompressedInteger(ChunkStream);
CRes := ChmCompareText(Name, Entry.Name);
if CRes = 0 then begin
fCachedEntry := Entry;
Result := Entry.DecompressedLength;
Break;
end;
Inc(I);
end;
end; // case
end;
end;
finally
ChunkStream.Free;
end;
end;
function TITSFReader.GetObject(Name: String): TMemoryStream;
var
SectionNames: TStringList;
Entry: TPMGListChunkEntry;
SectionName: String;
begin
Result := nil;
if ObjectExists(Name) = 0 then begin
//WriteLn('Object ', name,' Doesn''t exist or is zero sized.');
Exit;
end;
Entry := fCachedEntry;
if Entry.ContentSection = 0 then begin
Result := TMemoryStream.Create;
fStream.Position := fHeaderSuffix.Offset+ Entry.ContentOffset;
Result.CopyFrom(fStream, fCachedEntry.DecompressedLength);
end
else begin // we have to get it from ::DataSpace/Storage/[MSCompressed,Uncompressed]/ControlData
GetSections(SectionNames);
FmtStr(SectionName, '::DataSpace/Storage/%s/',[SectionNames[Entry.ContentSection]]);
Result := GetBlockFromSection(SectionName, Entry.ContentOffset, Entry.DecompressedLength);
SectionNames.Free;
end;
if Result <> nil then Result.Position := 0;
end;
function TChmReader.GetContextUrl(Context: THelpContext): String;
begin
// will get '' if context not found
Result := fContextList.GetURL(Context);
end;
function TChmReader.LookupTopicByID ( ATopicID: Integer; out ATitle: String) : String;
var
TopicURLTBLOffset: DWord;
TopicTitleOffset: DWord;
begin
Result := '';
ATitle := '';
//WriteLn('Getting topic# ',ATopicID);
if not CheckCommonStreams then
Exit;
fTOPICSStream.Position := ATopicID * 16;
if fTOPICSStream.Position = ATopicID * 16 then
begin
fTOPICSStream.ReadDWord;
TopicTitleOffset := LEtoN(fTOPICSStream.ReadDWord);
TopicURLTBLOffset := LEtoN(fTOPICSStream.ReadDWord);
{$ifdef binindex}
{$ifndef nonumber}
writeln('titleid:',TopicTitleOffset);
writeln('urlid :',TopicURLTBLOffset);
{$endif}
{$endif}
if TopicTitleOffset <> $FFFFFFFF then
ATitle := ReadStringsEntry(TopicTitleOffset);
//WriteLn('Got a title: ', ATitle);
Result := ReadURLSTR(TopicURLTBLOffset);
end;
end;
const DefBlockSize = 2048;
function LoadBtreeHeader(m:TMemoryStream;var btreehdr:TBtreeHeader):boolean;
begin
if m.size<sizeof(TBtreeHeader) Then
Exit(False);
result:=true;
m.read(btreeHdr,sizeof(TBtreeHeader));
{$IFDEF ENDIAN_BIG}
btreehdr.flags :=LEToN(btreehdr.flags);
btreehdr.blocksize :=LEToN(btreehdr.blocksize);
btreehdr.lastlstblock :=LEToN(btreehdr.lastlstblock);
btreehdr.indexrootblock:=LEToN(btreehdr.indexrootblock);
btreehdr.nrblock :=LEToN(btreehdr.nrblock);
btreehdr.treedepth :=LEToN(btreehdr.treedepth);
btreehdr.nrkeywords :=LEToN(btreehdr.nrkeywords);
btreehdr.codepage :=LEToN(btreehdr.codepage);
btreehdr.lcid :=LEToN(btreehdr.lcid);
btreehdr.ischm :=LEToN(btreehdr.ischm);
{$endif}
end;
function readwcharstring(var head:pbyte;tail:pbyte;var readv : ansistring):boolean;
var pw : PWord;
oldhead : PByte;
ws : WideString;
n : Integer;
begin
oldhead:=head;
pw:=pword(head);
while (pw<pword(tail)) and (pw^<>word(0)) do
inc(pw);
inc(pw); // skip #0#0.
head:=pbyte(pw);
result:=head<tail;
n:=head-oldhead;
pw:=pword(@oldhead[n]);
if (n>1) and (pw[-1]=0) then
dec(n,2); // remove trailing #0
setlength(ws,n div sizeof(widechar));
move(oldhead^,ws[1],n);
for n:=1 to length(ws) do
word(ws[n]):=LEToN(word(ws[n]));
readv:=ws; // force conversion for now, and hope it doesn't require cwstring
end;
Type TLookupRec = record
item : TChmSiteMapItems;
depth : integer;
end;
TLookupDict = TDictionary<string,TLookupRec>;
function TChmReader.GetIndexSitemap(ForceXML:boolean=false): TChmSiteMap;
var Index : TMemoryStream;
function AbortAndTryTextual:tchmsitemap;
begin
if Assigned(Index) Then Index.Free;
// Second Try text Index
Index := GetObject(IndexFile);
if Index <> nil then
begin
Result := TChmSiteMap.Create(stIndex);
Result.LoadFromStream(Index);
Index.Free;
end
else
result:=nil;
end;
var
parentitem:TChmSiteMapItems;
itemstack :TObjectList;
lookup : TLookupDict;
curitemdepth : integer;
sitemap : TChmSiteMap;
function getitem(anentrydepth:integer):Tchmsitemapitems;
begin
if anentrydepth<itemstack.count then
result:=tchmsitemapitems(itemstack[anentrydepth])
else
begin
{$ifdef binindex}
writeln('pop from emptystack at ',anentrydepth,' ',itemstack.count);
{$endif}
result:=tchmsitemapitems(itemstack[itemstack.Count-1]);
end;
end;
procedure pushitem(anentrydepth:integer;anitem:tchmsitemapitem);
begin
if anentrydepth<itemstack.count then
itemstack[anentrydepth]:=anitem.children
else
if anentrydepth=itemstack.count then
itemstack.add(anitem.Children)
else
begin
{$ifdef binindex}
writeln('push more than 1 larger ' ,anentrydepth,' ',itemstack.count);
{$endif}
itemstack.add(anitem.Children)
end;
end;
procedure parselistingblock(p:pbyte);
var
Item : TChmSiteMapItem;
hdr:PBTreeBlockHeader;
head,tail : pbyte;
isseealso,
entrydepth,
nrpairs : Integer;
i : integer;
PE : PBtreeBlockEntry;
title : string;
CharIndex,
ind:integer;
seealsostr,
s,
Name : AnsiString;
path,
shortname : AnsiString;
anitem:TChmSiteMapItems;
litem : TChmSiteMapItem;
lookupitem : TLookupRec;
function readvalue:string;
begin
result:='';
title:='';
if head<tail Then
begin
ind:=LEToN(plongint(head)^);
result:=lookuptopicbyid(ind,title);
{$ifdef binindex}
writeln(i:3,' topic: ' {$ifndef nonumber},' (',ind,')' {$endif});
writeln(' title: ',title);
writeln(' result: ',result);
{$endif}
inc(head,4);
end;
end;
procedure dumpstack;
var fp : TChmSiteMapItems;
ix : Integer;
begin
for ix:=0 to itemstack.Count-1 do
begin
fp :=TChmSiteMapItems(itemstack[ix]);
writeln(ix:3,' ',fp.parentname);
end;
end;
begin
//setlength (curitem,10);
hdr:=PBTreeBlockHeader(p);
hdr^.Length :=LEToN(hdr^.Length);
hdr^.NumberOfEntries :=LEToN(hdr^.NumberOfEntries);
hdr^.IndexOfPrevBlock:=LEToN(hdr^.IndexOfPrevBlock);
hdr^.IndexOfNextBlock:=LEToN(hdr^.IndexOfNextBlock);
{$ifdef binindex}
writeln('hdr:',hdr^.length);
{$endif}
tail:=p+(2048-hdr^.length);
head:=p+sizeof(TBtreeBlockHeader);
{$ifdef binindex}
{$ifndef nonumber}
writeln('previndex : ',hdr^.IndexOfPrevBlock);
writeln('nextindex : ',hdr^.IndexOfNextBlock);
{$endif}
{$endif}
while head<tail do
begin
//writeln(tail-head);
if not ReadWCharString(Head,Tail,Name) Then
Break;
{$ifdef binindex}
Writeln('name : ',name);
{$endif}
if (head+sizeof(TBtreeBlockEntry))>=tail then
break;
PE :=PBtreeBlockEntry(head);
NrPairs :=LEToN(PE^.nrpairs);
IsSeealso:=LEToN(PE^.isseealso);
EntryDepth:=LEToN(PE^.entrydepth);
CharIndex:=LEToN(PE^.CharIndex);
Path:='';
if charindex<>0 then
begin
Path:=Trim(Copy(Name,1,charindex-2));
Shortname:=trim(copy(Name,charindex,Length(Name)-Charindex+1));
end
else
shortname:=name;
{$ifdef binindex}
writeln('depth:', curitemdepth, ' ' ,entrydepth);
{$endif}
if curitemdepth=entrydepth then // same level, so of same parent
begin
item:=parentitem.newitem;
pushitem(entrydepth+1,item);
end
else
if curitemdepth=entrydepth-1 then // new child, one lower.
begin
parentitem:=getitem(entrydepth);
item:=parentitem.newitem;
pushitem(entrydepth+1,item);
end
else
if entrydepth<curitemdepth then
begin
parentitem:=getitem(entrydepth);
{$ifdef binindex}
writeln('bingo!', parentitem.parentname);
dumpstack;
{$endif}
item:=parentitem.newitem;
pushitem(entrydepth+1,item);
end;
curitemdepth:=entrydepth;
{$ifdef binindex}
writeln('lookup:', Name, ' = ', path,' = ',shortname);
{$endif}
(* if lookup.trygetvalue(path,lookupitem) then
begin
// if lookupitem.item<>parentitem then
// writeln('mismatch: ',lookupitem.item.item[0].name,' ',name);
{ if curitemdepth<entrydepth then
begin
writeln('lookup ok!',curitemdepth,' ' ,entrydepth);
curitemdepth:=entrydepth;
end
else
begin
writeln('lookup odd!',curitemdepth,' ' ,entrydepth);
end;
curitemdepth:=lookupitem.depth+1;
parentitem:=lookupitem.item;}
end
else
begin
// parentitem:=sitemap.Items;
if not curitemdepth=entrydepth then
writeln('no lookup odd!',curitemdepth,' ' ,entrydepth);
end; *)
{ item:=parentitem.newitem;}
lookupitem.item:=item.children;
lookupitem.depth:=entrydepth;
lookup.addorsetvalue(name,lookupitem);
item.AddName(Shortname);
{$ifdef binindex}
Writeln('seealso : ',IsSeeAlso);
Writeln('entrydepth: ',EntryDepth);
Writeln('charindex : ',charindex );
Writeln('Nrpairs : ',NrPairs);
Writeln('CharIndex : ',charindex);
{$endif}
inc(head,sizeof(TBtreeBlockEntry));
if isseealso>0 then
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}
item.AddSeeAlso(seealsostr);
end
else
begin
if NrPairs>0 Then
begin
{$ifdef binindex}
writeln('Pairs : ');
{$endif}
for i:=0 to nrpairs-1 do
begin
s:=readvalue;
// if not ((i=0) and (title=shortname)) then
item.addname(title);
item.addlocal(s);
end;
end;
end;
inc(head,4); // always 1
{$ifdef binindex}
if head<tail then
writeln('Zero based index (13 higher than last) :',plongint(head)^);
{$endif}
inc(head,4); // zero based index (13 higher than last
end;
end;
var TryTextual : boolean;
BHdr : TBTreeHeader;
block : Array[0..2047] of Byte;
i : Integer;
begin
Result := nil; SiteMap:=Nil;
// First Try Binary
Index := GetObject('/$WWKeywordLinks/BTree');
if (Index = nil) or ForceXML then
begin
Result:=AbortAndTryTextual; // frees index if needed
Exit;
end;
if not CheckCommonStreams then
begin
index.free;
Result:=AbortAndTryTextual; // frees index if needed
Exit;
end;
lookup:=TDictionary<string,TLookupRec>.create;
SiteMap:=TChmSitemap.Create(StIndex);
itemstack :=TObjectList.create(false);
//Item :=Nil; // cached last created item, in case we need to make
// a child.
parentitem:=sitemap.Items;
itemstack.add(parentitem); // level 0
curitemdepth:=0;
TryTextual:=True;
BHdr.LastLstBlock:=0;
if LoadBtreeHeader(index,BHdr) and (BHdr.LastLstBlock>=0) Then
begin
if BHdr.BlockSize=defblocksize then
begin
for i:=0 to BHdr.lastlstblock do
begin
if (index.size-index.position)>=defblocksize then // skips last incomplete block?
begin
Index.read(block,defblocksize);
parselistingblock(@block)
end;
end;
trytextual:=false;
result:=sitemap;
end;
end;
if trytextual then
begin
sitemap.free;
Result:=AbortAndTryTextual; // frees index if needed
end
else Index.Free;
itemstack.free;
lookup.free;
end;
function TChmReader.GetTOCSitemap(ForceXML:boolean=false): TChmSiteMap;
function AddTOCItem(TOC: TStream; AItemOffset: DWord; SiteMapITems: TChmSiteMapItems): DWord;
var
Props: DWord;
Item: TChmSiteMapItem;
NextEntry: DWord;
TopicsIndex: DWord;
Title, Local : String;
begin
Toc.Position:= AItemOffset + 4;
Item := SiteMapITems.NewItem;
Props := LEtoN(TOC.ReadDWord);
if (Props and TOC_ENTRY_HAS_LOCAL) = 0 then
Item.AddName(ReadStringsEntry(LEtoN(TOC.ReadDWord)))
else
begin
TopicsIndex := LEtoN(TOC.ReadDWord);
Local:=LookupTopicByID(TopicsIndex, Title);
Item.AddName(Title);
Item.AddLocal(Local);
end;
TOC.ReadDWord;
Result := LEtoN(TOC.ReadDWord);
if Props and TOC_ENTRY_HAS_CHILDREN > 0 then
begin
NextEntry := LEtoN(TOC.ReadDWord);
repeat
NextEntry := AddTOCItem(TOC, NextEntry, Item.Children);
until NextEntry = 0;
end;
end;
var
TOC: TStream;
TOPICSOffset: DWord;
EntriesOffset: DWord;
EntryCount: DWord;
EntryInfoOffset: DWord;
NextItem: DWord;
begin
Result := nil;
// First Try Binary
TOC := GetObject('/#TOCIDX');
if (TOC = nil) or ForceXML then
begin
if Assigned(TOC) Then Toc.Free;
// Second Try text toc
TOC := GetObject(TOCFile);
if TOC <> nil then
begin
Result := TChmSiteMap.Create(stTOC);
Result.LoadFromStream(TOC);
Toc.Free;
end;
Exit;
end;
// TOPICS URLSTR URLTBL must all exist to read binary toc
// if they don't then try text file
if not CheckCommonStreams then
begin
TOC.Free;
TOC := GetObject(TOCFile);
if TOC <> nil then
begin
Result := TChmSiteMap.Create(stTOC);
Result.LoadFromStream(TOC);
Toc.Free;
end;
Exit;
end;
// Binary Toc Exists
Result := TChmSiteMap.Create(stTOC);
EntryInfoOffset := NtoLE(TOC.ReadDWord);
EntriesOffset := NtoLE(TOC.ReadDWord);
EntryCount := NtoLE(TOC.ReadDWord);
TOPICSOffset := NtoLE(TOC.ReadDWord);
if EntryCount = 0 then
begin
Toc.Free;
Exit;
end;
NextItem := EntryInfoOffset;
repeat
NextItem := AddTOCItem(Toc, NextItem, Result.Items);
until NextItem = 0;
TOC.Free;
end;
function TChmReader.HasContextList: Boolean;
begin
Result := fContextList.Count > 0;
end;
procedure TITSFReader.GetSections(out Sections: TStringList);
var
Stream: TStream;
EntryCount: Word;
X: Integer;
{$IFDEF ENDIAN_BIG}
I: Integer;
{$ENDIF}
WString: array [0..31] of WideChar;
StrLength: Word;
begin
Sections := TStringList.Create;
//WriteLn('::DataSpace/NameList Size = ', ObjectExists('::DataSpace/NameList'));
Stream := GetObject('::DataSpace/NameList');
if Stream = nil then begin
//WriteLn('Failed to get ::DataSpace/NameList!');
exit;
end;
Stream.Position := 2;
EntryCount := LEtoN(Stream.ReadWord);
for X := 0 to EntryCount -1 do begin
StrLength := LEtoN(Stream.ReadWord);
if StrLength > 31 then StrLength := 31;
Stream.Read(WString, SizeOf(WideChar)*(StrLength+1)); // the strings are stored null terminated
{$IFDEF ENDIAN_BIG}
for I := 0 to StrLength-1 do
WString[I] := WideChar(LEtoN(Ord(WString[I])));
{$ENDIF}
Sections.Add(WString);
end;
Stream.Free;
end;
function TITSFReader.GetBlockFromSection(SectionPrefix: String; StartPos: QWord;
BlockLength: QWord): TMemoryStream;
var
Compressed: Boolean;
Sig: Array [0..3] of AnsiChar;
CompressionVersion: LongWord;
CompressedSize: QWord;
UnCompressedSize: QWord;
//LZXResetInterval: LongWord;
//LZXWindowSize: LongWord;
//LZXCacheSize: LongWord;
ResetTableEntry: TPMGListChunkEntry;
ResetTable: TLZXResetTableArr;
WriteCount: QWord;
BlockWriteLength: QWord;
WriteStart: LongWord;
ReadCount:LongInt;
LZXState: PLZXState;
InBuf: array of Byte;
OutBuf: PByte;
BlockSize: QWord;
X: Integer;
FirstBlock, LastBlock: LongInt;
ResultCode: LongInt;
procedure ReadBlock;
begin
if ReadCount > Length(InBuf) then
SetLength(InBuf, ReadCount);
fStream.Read(InBuf[0], ReadCount);
end;
begin
// okay now the fun stuff ;)
Result := nil;
Compressed := ObjectExists(SectionPrefix+'Transform/{7FC28940-9D31-11D0-9B27-00A0C91E9C7C}/InstanceData/ResetTable')>0;
// the easy method
if Not(Compressed) then begin
if ObjectExists(SectionPrefix+'Content') > 0 then begin
Result := TMemoryStream.Create;
fStream.Position := fHeaderSuffix.Offset + fCachedEntry.ContentOffset + StartPos;
Result.CopyFrom(fStream, BlockLength);
end;
Exit;
end
else
ResetTableEntry := fCachedEntry;
// First make sure that it is a compression we can read
if ObjectExists(SectionPrefix+'ControlData') > 0 then begin
fStream.Position := fHeaderSuffix.Offset + fCachedEntry.ContentOffset + 4;
fStream.Read(Sig, 4);
if Sig <> 'LZXC' then Exit;
CompressionVersion := LEtoN(fStream.ReadDWord);
if CompressionVersion > 2 then exit;
{LZXResetInterval := }LEtoN(fStream.ReadDWord);
{LZXWindowSize := }LEtoN(fStream.ReadDWord);
{LZXCacheSize := }LEtoN(fStream.ReadDWord);
BlockSize := FindBlocksFromUnCompressedAddr(ResetTableEntry, CompressedSize, UnCompressedSize, ResetTable);
if UncompressedSize > 0 then ; // to avoid a compiler note
if StartPos > 0 then
FirstBlock := StartPos div BlockSize
else
FirstBlock := 0;
LastBlock := (StartPos+BlockLength) div BlockSize;
if ObjectExists(SectionPrefix+'Content') = 0 then exit;
//WriteLn('Compressed Data start''s at: ', fHeaderSuffix.Offset + fCachedEntry.ContentOffset,' Size is: ', fCachedEntry.DecompressedLength);
Result := TMemoryStream.Create;
Result.Size := BlockLength;
SetLength(InBuf,BlockSize);
OutBuf := GetMem(BlockSize);
// First Init a PLZXState
LZXState := LZXinit(16);
if LZXState = nil then begin
Exit;
end;
// if FirstBlock is odd (1,3,5,7 etc) we have to read the even block before it first.
if FirstBlock and 1 = 1 then begin
fStream.Position := fHeaderSuffix.Offset + fCachedEntry.ContentOffset + (ResetTable[FirstBLock-1]);
ReadCount := ResetTable[FirstBlock] - ResetTable[FirstBlock-1];
BlockWriteLength:=BlockSize;
ReadBlock;
ResultCode := LZXdecompress(LZXState, @InBuf[0], OutBuf, ReadCount, LongInt(BlockWriteLength));
end;
// now start the actual decompression loop
for X := FirstBlock to LastBlock do begin
fStream.Position := fHeaderSuffix.Offset + fCachedEntry.ContentOffset + (ResetTable[X]);
if X = FirstBLock then
WriteStart := StartPos - (X*BlockSize)
else
WriteStart := 0;
if X = High(ResetTable) then
ReadCount := CompressedSize - ResetTable[X]
else
ReadCount := ResetTable[X+1] - ResetTable[X];
BlockWriteLength := BlockSize;
if FirstBlock = LastBlock then begin
WriteCount := BlockLength;
end
else if X = LastBlock then
WriteCount := (StartPos+BlockLength) - (X*BlockSize)
else WriteCount := BlockSize - WriteStart;
ReadBlock;
ResultCode := LZXdecompress(LZXState, @InBuf[0], OutBuf, ReadCount, LongInt(BlockWriteLength));
//now write the decompressed data to the stream
if ResultCode = DECR_OK then begin
Result.Write(OutBuf[WriteStart], QWord(WriteCount));
end
else begin
{$IFDEF CHM_DEBUG} // windows gui program will cause an exception with writeln's
WriteLn('Decompress FAILED with error code: ', ResultCode);
{$ENDIF}
Result.Free;
Result := Nil;
FreeMem(OutBuf);
SetLength(ResetTable,0);
LZXteardown(LZXState);
Exit;
end;
// if the next block is an even numbered block we have to reset the decompressor state
if (X < LastBlock) and (X and 1 = 1) then LZXreset(LZXState);
end;
FreeMem(OutBuf);
SetLength(ResetTable,0);
LZXteardown(LZXState);
end;
end;
function TITSFReader.FindBlocksFromUnCompressedAddr(var ResetTableEntry: TPMGListChunkEntry;
out CompressedSize: QWord; out UnCompressedSize: QWord; out LZXResetTable: TLZXResetTableArr): QWord;
var
BlockCount: LongWord;
{$IFDEF ENDIAN_BIG}
I: Integer;
{$ENDIF}
begin
Result := 0;
fStream.Position := fHeaderSuffix.Offset + ResetTableEntry.ContentOffset;
fStream.ReadDWord;
BlockCount := LEtoN(fStream.ReadDWord);
fStream.ReadDWord;
fStream.ReadDWord; // TableHeaderSize;
fStream.Read(UnCompressedSize, SizeOf(QWord));
UnCompressedSize := LEtoN(UnCompressedSize);
fStream.Read(CompressedSize, SizeOf(QWord));
CompressedSize := LEtoN(CompressedSize);
fStream.Read(Result, SizeOf(QWord)); // block size
Result := LEtoN(Result);
// now we are located at the first block index
SetLength(LZXResetTable, BlockCount);
fStream.Read(LZXResetTable[0], SizeOf(QWord)*BlockCount);
{$IFDEF ENDIAN_BIG}
for I := 0 to High(LZXResetTable) do
LZXResetTable[I] := LEtoN(LZXResetTable[I]);
{$ENDIF}
end;
{ TContextList }
procedure TContextList.AddContext(Context: THelpContext; Url: String);
var
ContextItem: PContextItem;
begin
New(ContextItem);
Add(ContextItem);
ContextItem^.Context := Context;
ContextItem^.Url := Url;
end;
function TContextList.GetURL(Context: THelpContext): String;
var
X: Integer;
begin
Result := '';
for X := 0 to Count-1 do begin
if PContextItem(Get(X))^.Context = Context then begin
Result := PContextItem(Get(X))^.Url;
Exit;
end;
end;
end;
procedure TContextList.Clear;
var
X: Integer;
begin
for X := Count-1 downto 0 do begin
Dispose(PContextItem(Get(X)));
Delete(X);
end;
end;
{ TChmFileList }
procedure TChmFileList.Delete(Index: Integer);
begin
Chm[Index].Free;
inherited Delete(Index);
end;
function TChmFileList.GetChm(AIndex: Integer): TChmReader;
begin
if AIndex = -1 then
Result := fLastChm
else
Result := TChmReader(Objects[AIndex]);
end;
function TChmFileList.GetFileName(AIndex: Integer): String;
begin
if AIndex = -1 then
AIndex := IndexOfObject(fLastChm);
Result := Strings[AIndex];
end;
procedure TChmFileList.OpenNewFile(AFileName: String);
var
AStream: TFileStream;
AChm: TChmReader;
AIndex: Integer;
begin
if not FileExists(AFileName) then exit;
AStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
AChm := TChmReader.Create(AStream, True);
AIndex := AddObject(AFileName, AChm);
fLastChm := AChm;
if Assigned(fOnOpenNewFile) then fOnOpenNewFile(Self, AIndex)
else fUnNotifiedFiles.Add(AChm);
end;
function TChmFileList.CheckOpenFile(AFileName: String): Boolean;
var
X: Integer;
begin
Result := False;
for X := 0 to Count-1 do begin
if ExtractFileName(FileName[X]) = AFileName then begin
fLastChm := Chm[X];
Result := True;
Exit;
end;
end;
if not Result then begin
AFileName := ExtractFilePath(FileName[0])+AFileName;
if FileExists(AFileName) and (LowerCase(ExtractFileExt(AFileName)) = '.chm') then OpenNewFile(AFileName);
Result := True;
end;
end;
function TChmFileList.MetaObjectExists(var Name: String): QWord;
var
AFileName: String;
URL: String;
fStart, fEnd: Integer;
Found: Boolean;
begin
Found := False;
Result := 0;
//Known META file link types
// ms-its:name.chm::/topic.htm
//mk:@MSITStore:name.chm::/topic.htm
if Pos('ms-its:', Name) > 0 then begin
fStart := Pos('ms-its:', Name)+Length('ms-its:');
fEnd := Pos('::', Name)-fStart;
AFileName := Copy(Name, fStart, fEnd);
fStart := fEnd+fStart+2;
fEnd := Length(Name) - (fStart-1);
URL := Copy(Name, fStart, fEnd);
Found := True;
end
else if Pos('mk:@MSITStore:', Name) > 0 then begin
fStart := Pos('mk:@MSITStore:', Name)+Length('mk:@MSITStore:');
fEnd := Pos('::', Name)-fStart;
AFileName := Copy(Name, fStart, fEnd);
fStart := fEnd+fStart+2;
fEnd := Length(Name) - (fStart-1);
URL := Copy(Name, fStart, fEnd);
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;
end;
function TChmFileList.MetaGetObject(Name: String): TMemoryStream;
begin
Result := nil;
if MetaObjectExists(Name) > 0 then Result := fLastChm.GetObject(Name);
end;
constructor TChmFileList.Create(PrimaryFileName: String);
begin
inherited Create;
fUnNotifiedFiles := TList.Create;
OpenNewFile(PrimaryFileName);
end;
destructor TChmFileList.Destroy;
begin
fUnNotifiedFiles.Free;
inherited Destroy;
end;
procedure TChmFileList.SetOnOpenNewFile(AValue: TChmFileOpenEvent);
var
X: Integer;
begin
fOnOpenNewFile := AValue;
if not assigned(AValue) then exit;
for X := 0 to fUnNotifiedFiles.Count-1 do
AValue(Self, X);
fUnNotifiedFiles.Clear;
end;
function TChmFileList.ObjectExists(Name: String; var fChm: TChmReader): QWord;
begin
Result := 0;
if Count = 0 then exit;
if fChm <> nil then fLastChm := fChm;
Result := fLastChm.ObjectExists(Name);
if Result = 0 then begin
Result := Chm[0].ObjectExists(Name);
if Result > 0 then fLastChm := Chm[0];
end;
if Result = 0 then begin
Result := MetaObjectExists(Name);
end;
if (Result <> 0) and (fChm = nil) then
fChm := fLastChm;
end;
function TChmFileList.GetObject(Name: String): TMemoryStream;
begin
Result := nil;
if Count = 0 then exit;
Result := fLastChm.GetObject(Name);
if Result = nil then Result := MetaGetObject(Name);
end;
function TChmFileList.IsAnOpenFile(AFileName: String): Boolean;
var
X: Integer;
begin
Result := False;
for X := 0 to Count-1 do begin
if AFileName = FileName[X] then Exit(True);
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink