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

--- Merging r42129 into '.':

Browse Source 
G    packages/chm/src/chmsitemap.pas
--- Recording mergeinfo for merge of r42129 into '.':
 G   .
--- Merging r42137 into '.':
G    packages/chm/src/chmreader.pas
--- Recording mergeinfo for merge of r42137 into '.':
 G   .
--- Merging r42138 into '.':
G    utils/fpdoc/dw_htmlchm.inc
--- Recording mergeinfo for merge of r42138 into '.':
 G   .
--- Merging r42140 into '.':
G    utils/fpdoc/dw_htmlchm.inc
--- Recording mergeinfo for merge of r42140 into '.':
 G   .
--- Merging r42141 into '.':
G    utils/fpdoc/dw_htmlchm.inc
--- Recording mergeinfo for merge of r42141 into '.':
 G   .
--- Merging r42142 into '.':
G    packages/chm/src/chmfilewriter.pas
G    packages/chm/src/chmwriter.pas
--- Recording mergeinfo for merge of r42142 into '.':
 G   .
--- Merging r42156 into '.':
G    packages/chm/src/chmfilewriter.pas
U    packages/chm/src/chmtypes.pas
--- Recording mergeinfo for merge of r42156 into '.':
 G   .

# revisions: 42129,42137,42138,42140,42141,42142,42156

git-svn-id: branches/fixes_3_2@42306 -
This commit is contained in:
marco 2019-06-29 14:23:04 +00:00
parent 15303f3b55
commit 5daebe5544
8 changed files with 1001 additions and 397 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
packages/chm/fpmake.pp
View File

@ -32,6 +32,7 @@ begin
D:=P.Dependencies.Add('fcl-xml');
D:=P.Dependencies.Add('fcl-base');
D.Version:='3.2.0-beta';
D:=P.Dependencies.Add('rtl-generics');
P.SourcePath.Add('src');
P.IncludePath.Add('src');

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

@ -145,7 +145,7 @@ begin
else
begin
try
project.ScanHtmlContents:=htmlscan=scanforce; // .hhp default SCAN
project.ScanHtmlContents:=htmlscan in [scanforce, scandefault]; // .hhp default SCAN
Project.LoadFromFile(name);
except
on e:exception do
@ -166,7 +166,6 @@ begin
end;
OutStream.Free;
Project.Free;
end;
var
@ -178,7 +177,7 @@ var
begin
InitOptions;
Writeln(stderr,'chmcmd, a CHM compiler. (c) 2010 Free Pascal core.');
Writeln(stderr,'chmcmd, a CHM compiler. (c) 2010-2019 Free Pascal core.');
Writeln(Stderr);
repeat
c:=getlongopts('h',@theopts[1],optionindex);

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

@ -25,7 +25,7 @@ unit chmfilewriter;
interface
uses
Strings, Classes, SysUtils, chmwriter, inifiles, contnrs, chmsitemap, avl_tree,
Classes, SysUtils, chmwriter, inifiles, contnrs, chmsitemap, avl_tree,
{for html scanning } dom,SAX_HTML,dom_html;
type
@ -68,7 +68,8 @@ type
FIndex : TCHMSiteMap;
FTocStream,
FIndexStream : TMemoryStream;
FCores : integer;
FCores : Integer;
FLocaleID : Word;
protected
function GetData(const DataName: String; out PathInChm: String; out FileName: String; var Stream: TStream): Boolean;
procedure LastFileAdded(Sender: TObject);
@ -84,6 +85,7 @@ type
procedure LoadFromFile(AFileName: String); virtual;
procedure LoadFromhhp (AFileName:String;LeaveInclude:Boolean); virtual;
procedure SaveToFile(AFileName: String); virtual;
procedure SaveToHHP(AFileName: String);
procedure WriteChm(AOutStream: TStream); virtual;
procedure ShowUndefinedAnchors;
function ProjectDir: String;
@ -113,17 +115,16 @@ type
property ScanHtmlContents : Boolean read fScanHtmlContents write fScanHtmlContents;
property ReadmeMessage : String read FReadmeMessage write FReadmeMessage;
property AllowedExtensions : TStringList read FAllowedExtensions;
property Cores : integer read fcores write fcores;
property Cores : integer read fcores write fcores;
property LocaleID: word read FLocaleID write FLocaleID;
end;
TChmContextNode = Class
URLName : AnsiString;
ContextNumber : Integer;
ContextNumber : THelpContext;
ContextName : AnsiString;
End;
Const
ChmErrorKindText : array[TCHMProjectErrorKind] of string = ('Error','Warning','Hint','Note','');
@ -272,6 +273,23 @@ begin
inc(result);
end;
// hex codes of LCID (Locale IDs) see at http://msdn.microsoft.com/en-us/goglobal/bb964664.aspx
function GetLanguageID(const sValue: String): word;
const
DefaultLCID = $0409; // default "English - United States", 0x0409
var
ACode: word;
begin
Result := DefaultLCID;
if Length(sValue) >= 5 then
begin
Val(Trim(Copy(sValue, 1, 6)), Result, ACode);
//if Code <> 0 then
//Result := DefaultLCID;
end
end;
procedure TChmProject.readIniOptions(keyvaluepairs:tstringlist);
var i : integer;
Opt : TOptionEnum;
@ -308,7 +326,7 @@ begin
OPTFULL_TEXT_SEARCH : MakeSearchable:=optvalupper='YES';
OPTIGNORE : ;
OPTINDEX_FILE : Indexfilename:=optval;
OPTLANGUAGE : ;
OPTLANGUAGE : LocaleID := GetLanguageID(optval);
OPTPREFIX : ; // doesn't seem to have effect
OPTSAMPLE_STAGING_PATH : ;
OPTSAMPLE_LIST_FILE : ;
@ -401,6 +419,7 @@ begin
DefaultFont := Cfg.GetValue('Settings/DefaultFont/Value', '');
DefaultWindow:= Cfg.GetValue('Settings/DefaultWindow/Value', '');
ScanHtmlContents:= Cfg.GetValue('Settings/ScanHtmlContents/Value', False);
LocaleID := Cfg.GetValue('Settings/LocaleID/Value', $0409);
Cfg.Free;
end;
@ -698,7 +717,7 @@ begin
Cfg.SetValue('Settings/DefaultWindow/Value', DefaultWindow);
Cfg.SetValue('Settings/ScanHtmlContents/Value', ScanHtmlContents);
Cfg.SetValue('Settings/LocaleID/Value', LocaleID);
Cfg.Flush;
Cfg.Free;
@ -742,16 +761,19 @@ begin
i:=pos('#',outstring);
if i<>0 then begin
if i > 1 then
Anchor := outstring
else
Anchor := localname+outstring;
j := fAnchorList.IndexOf(Anchor);
if j < 0 then begin
fAnchorList.AddObject(Anchor,TFirstReference.Create(localname));
Anchor := '(new) '+Anchor;
end;
Error(CHMNote, 'Anchor found '+Anchor+' while scanning '+localname,1);
if i<>length(outstring) then // trims lone '#' at end of url.
begin
if i > 1 then
Anchor := outstring
else
Anchor := localname+outstring;
j := fAnchorList.IndexOf(Anchor);
if j < 0 then begin
fAnchorList.AddObject(Anchor,TFirstReference.Create(localname));
Anchor := '(new) '+Anchor;
end;
Error(CHMNote, 'Anchor found '+Anchor+' while scanning '+localname,1);
end;
delete(outstring,i,length(outstring)-i+1);
end;
@ -759,6 +781,8 @@ begin
outstring:=extractrelativepath(basepath,outstring);
outstring:=StringReplace(outstring,'\','/',[rfReplaceAll]);
if outstring='' then
result:=false;
end;
function TChmProject.FileInTotalList(const s:String):boolean;
@ -808,13 +832,55 @@ begin
filelist.add(fn);
end;
procedure checkattributesA(node:TDomNode;const localname: string; filelist :TStringList);
// workaround for "a" tag that has href and src. If src exists, don't check href, this
// avoids spurious warnings.
var
fn : String;
val : String;
found : boolean;
begin
found:=false;
val := findattribute(node,'SRC');
if sanitizeurl(fbasepath,val,localpath,localname,fn) then
found:=true;
if not found then
begin
val := findattribute(node,'HREF');
if sanitizeurl(fbasepath,val,localpath,localname,fn) then
found:=true;
end;
if found and not FileInTotalList(uppercase(fn)) then
filelist.add(fn);
end;
function scantags(prnt:TDomNode; const localname: string; filelist:TStringlist):TDomNode;
// Seach first matching tag in siblings
var
att : ansistring;
procedure AddAnchor(const s:string);
var
i : Integer;
begin
i := fAnchorList.IndexOf(localname+'#'+s);
if i < 0 then begin
fAnchorList.Add(localname+'#'+s);
Error(ChmNote,'New Anchor with '+att+' '+s+' found while scanning '+localname,1);
end else if fAnchorList.Objects[i] = nil then
Error(chmwarning,'Duplicate anchor definitions with '+att+' '+s+' found while scanning '+localname,1)
else begin
fAnchorList.Objects[i].Free;
fAnchorList.Objects[i] := nil;
Error(ChmNote,'Anchor with '+att+' '+s+' defined while scanning '+localname,1);
end;
end;
var chld: TDomNode;
s,
att : ansistring;
i : Integer;
s,attrval : ansistring;
idfound : boolean;
begin
result:=nil;
if assigned(prnt ) then
@ -826,6 +892,11 @@ begin
if (chld is TDomElement) then
begin
s:=uppercase(tdomelement(chld).tagname);
att := 'ID';
attrval := findattribute(chld, att);
idfound:=attrval <> '' ;
if idfound then
addanchor(attrval);
if s='LINK' then
begin
//printattributes(chld,'');
@ -836,34 +907,21 @@ begin
//printattributes(chld,'');
checkattributes(chld,'SRC',localname,filelist);
end;
if s='IMG'then
if s='IMG' then
begin
//printattributes(chld,'');
checkattributes(chld,'SRC',localname,filelist);
end;
if s='A'then
if s='A' then
begin
//printattributes(chld,'');
checkattributes(chld,'HREF',localname,filelist);
att := 'NAME';
s := findattribute(chld, att);
if s = '' then begin
att := 'ID';
s := findattribute(chld, att);
end;
if s <> '' then
checkattributesA(chld,localname,filelist);
if not idfound then
begin
i := fAnchorList.IndexOf(localname+'#'+s);
if i < 0 then begin
fAnchorList.Add(localname+'#'+s);
Error(ChmNote,'New Anchor with '+att+' '+s+' found while scanning '+localname,1);
end else if fAnchorList.Objects[i] = nil then
Error(chmwarning,'Duplicate anchor definitions with '+att+' '+s+' found while scanning '+localname,1)
else begin
fAnchorList.Objects[i].Free;
fAnchorList.Objects[i] := nil;
Error(ChmNote,'Anchor with '+att+' '+s+' defined while scanning '+localname,1);
end;
att := 'NAME';
attrval := findattribute(chld, att);
if attrval <> '' then
addanchor(attrval);
end;
end;
end;
@ -876,11 +934,8 @@ var
localfilelist: TStringList;
domdoc : THTMLDocument;
i,j : Integer;
fn,s : string;
ext : String;
fn,reffn : string;
tmplst : Tstringlist;
strrec : TStringIndex;
//localpath : string;
function trypath(const vn:string):boolean;
var vn2: String;
@ -926,10 +981,9 @@ begin
scantags(domdoc,extractfilename(fn),localfilelist);
for i:=0 to localFilelist.count-1 do
begin
s:=localfilelist[i];
if not trypath(s) then
// if not trypath(localpath+s) then
Error(ChmWarning,'Found file '+s+' while scanning '+fn+', but couldn''t find it on disk',2);
reffn:=localfilelist[i];
if not trypath(reffn) then // if not trypath(localpath+s) then
Error(ChmWarning,'Found file '+reffn+' while scanning '+fn+', but couldn''t find it on disk',2);
end;
except
on e:EDomError do
@ -952,15 +1006,14 @@ begin
for i:=0 to tmplst.Count-1 do
begin
s:=tmplst[i];
if pos('url(''', tmplst[i])>0 then
reffn:=tmplst[i];
if pos('url(''', reffn)>0 then
begin
delete(s,1,pos('url(''', tmplst[i])+4);
s:=trim(copy(s,1,pos('''',s)-1));
if not trypath(s) then
delete(reffn,1,pos('url(''', reffn)+4);
reffn:=trim(copy(reffn,1,pos('''',reffn)-1));
if not trypath(reffn) then
// if not trypath(localpath+s) then
Error(ChmWarning,'Found file '+s+' while scanning '+fn+', but couldn''t find it on disk',2);
Error(ChmWarning,'Found file '+reffn+' while scanning '+fn+', but couldn''t find it on disk',2);
end;
end;
finally
@ -984,8 +1037,9 @@ procedure TChmProject.ScanSitemap(sitemap:TChmSiteMap;newfiles:TStrings;recursio
procedure scanitems(it:TChmSiteMapItems);
var i : integer;
var i,j : integer;
x : TChmSiteMapItem;
si : TChmSiteMapSubItem;
s : string;
strrec : TStringIndex;
@ -993,34 +1047,37 @@ begin
for i:=0 to it.count -1 do
begin
x:=it.item[i];
if sanitizeurl(fbasepath,x.local,'','Site Map for '+x.Text,S) then // sanitize, remove stuff etc.
begin
if not FileInTotalList(uppercase(s)) then
begin
if fileexists(s) then
begin
Error(chmnote,'Good url: '+s+'.',5);
StrRec:=TStringIndex.Create;
StrRec.TheString:=uppercase(s);
StrRec.Strid :=0;
fTotalFileList.Add(StrRec);
newfiles.add(s);
end
else
Error(chmnote,'duplicate url: '+s+'.',5);
end
else
Error(chmnote,'duplicate url: '+s+'.',5);
end
else
Error(chmnote,'Bad url: '+s+'.',5);
for j:=0 to x.SubItemcount-1 do
begin
si:=x.SubItem[j];
if sanitizeurl(fbasepath,si.local,'','Site Map for '+x.Text,S) then // sanitize, remove stuff etc.
begin
if not FileInTotalList(uppercase(s)) then
begin
if fileexists(s) then
begin
Error(chmnote,'Good url: '+s+'.',5);
StrRec:=TStringIndex.Create;
StrRec.TheString:=uppercase(s);
StrRec.Strid :=0;
fTotalFileList.Add(StrRec);
newfiles.add(s);
end
else
Error(chmnote,'duplicate url: '+s+'.',5);
end
else
Error(chmnote,'duplicate url: '+s+'.',5);
end
else
Error(chmnote,'Bad url: '+s+'.',5);
end;
if assigned(x.children) and (x.children.count>0) then
scanitems(x.children);
end;
end;
var i : integer;
var
localfilelist: TStringList;
begin
@ -1137,6 +1194,7 @@ begin
Writer.TocName := ExtractFileName(TableOfContentsFileName);
Writer.ReadmeMessage := ReadmeMessage;
Writer.DefaultWindow := FDefaultWindow;
Writer.LocaleID := FLocaleID;
for i:=0 to files.count-1 do
begin
nd:=TChmContextNode(files.objects[i]);
@ -1169,7 +1227,7 @@ var
begin
for i := 0 to fAnchorList.Count-1 do
if fAnchorList.Objects[i] <> nil then
Error(chmerror,'Anchor '+fAnchorList[i]+' undefined; first use '+TFirstReference(fAnchorList.Objects[i]).Location);
Error(chmerror,'Anchor '+fAnchorList[i]+' undefined; first use '+TFirstReference(fAnchorList.Objects[i]).Location);
end;
procedure TChmProject.LoadSitemaps;
@ -1188,7 +1246,6 @@ begin
FreeAndNil(FToc);
FToc:=TChmSiteMap.Create(sttoc);
FToc.loadfromstream(FTocStream);
ftoc.savetofile('bla.something');
except
on e:exception do
begin
@ -1227,5 +1284,101 @@ begin
end;
function BoolAsStr(b: Boolean): string;
begin
if b then
Result := 'Yes'
else
Result := 'No';
end;
procedure TChmProject.SaveToHHP(AFileName: String);
var
sl: TStringList;
s : string;
i: Integer;
ContextItem: TChmContextNode;
procedure SetOption(const AKey, AValue: string);
begin
if AValue <> '' then
sl.Add(AKey + '=' + AValue);
end;
begin
sl := TStringList.Create();
try
sl.Add('[OPTIONS]');
SetOption('Title', Title);
SetOption('Compatibility', '1.1 or later');
SetOption('Compiled file', OutputFileName);
SetOption('Default Topic', DefaultPage);
SetOption('Default Font', DefaultFont);
SetOption('Default Window', DefaultWindow);
SetOption('Display compile progress', 'Yes');
//SetOption('Error log file', 'errors.log');
SetOption('Contents file', TableOfContentsFileName);
//SetOption('Auto Index', BoolAsStr(MakeBinaryIndex));
SetOption('Index file', IndexFileName);
SetOption('Binary Index', BoolAsStr(MakeBinaryIndex));
SetOption('Binary TOC', BoolAsStr(MakeBinaryTOC));
SetOption('Full-text search', BoolAsStr(MakeSearchable));
SetOption('Language', '0x' + IntToHex(LocaleID, 4));
sl.Add('');
sl.Add('[FILES]');
for i := 0 to Files.Count - 1 do
begin
s := StringReplace(Files.Strings[i], '/', '\', [rfReplaceAll]);
sl.Add(s);
end;
if MergeFiles.Count > 0 then
begin
sl.Add('');
sl.Add('[MERGE FILES]');
for i := 0 to MergeFiles.Count - 1 do
begin
sl.Add(MergeFiles.Strings[i]);
end;
end;
if Windows.Count > 0 then
begin
sl.Add('');
sl.Add('[WINDOWS]');
for i := 0 to Windows.Count-1 do
begin
TCHMWindow(Windows[i]).SaveToIni(s);
sl.Add(s);
end;
end;
if Files.Count > 0 then
begin
sl.Add('');
sl.Add('[ALIAS]');
for i := 0 to Files.Count - 1 do
begin
contextitem:=TChmContextNode(files.objects[i]);
if assigned(contextitem) then
sl.Add(ContextItem.ContextName + '=' + ContextItem.UrlName);
end;
sl.Add('');
sl.Add('[MAP]');
for I := 0 to Files.Count-1 do
begin
contextitem:=TChmContextNode(files.objects[i]);
if assigned(contextitem) then
sl.Add('#define ' + ContextItem.ContextName + ' ' + IntToStr(ContextItem.ContextNumber));
end;
end;
sl.SaveToFile(AFileName);
finally
sl.Free();
end;
end;
end.

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

@ -20,15 +20,17 @@
}
unit chmreader;
{$mode objfpc}{$H+}
{$mode delphi}
//{$DEFINE CHM_DEBUG}
{ $DEFINE CHM_DEBUG_CHUNKS}
{define binindex}
{define nonumber}
interface
uses
Classes, SysUtils, Contnrs, chmbase, paslzx, chmFIftiMain, chmsitemap;
Generics.Collections, Classes, SysUtils, Contnrs,
chmbase, paslzx, chmFIftiMain, chmsitemap;
type
@ -729,7 +731,7 @@ var
PMGIndex: Integer;
{$ENDIF}
begin
if ForEach = nil then Exit;
if not assigned(ForEach) then Exit;
ChunkStream := TMemoryStream.Create;
{$IFDEF CHM_DEBUG_CHUNKS}
WriteLn('ChunkCount = ',fDirectoryHeader.DirectoryChunkCount);
@ -970,6 +972,12 @@ 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);
@ -1016,7 +1024,10 @@ begin
result:=head<tail;
n:=head-oldhead;
if (n>0) and (oldhead[n-1]=0) then dec(n); // remove trailing #0
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
@ -1024,10 +1035,15 @@ begin
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;
sitemap : TChmSiteMap;
Item : TChmSiteMapItem;
function AbortAndTryTextual:tchmsitemap;
@ -1045,76 +1061,48 @@ begin
result:=nil;
end;
procedure createentry(Name:ansistring;CharIndex:integer;Topic,Title:ansistring);
var litem : TChmSiteMapItem;
shortname : ansistring;
longpart : ansistring;
var
parentitem:TChmSiteMapItems;
itemstack :TObjectList;
lookup : TLookupDict;
curitemdepth : integer;
sitemap : TChmSiteMap;
function getitem(anentrydepth:integer):Tchmsitemapitems;
begin
if charindex=0 then
begin
item:=sitemap.items.NewItem;
item.keyword:=Name;
item.local:=topic;
item.text:=title;
end
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
begin
shortname:=copy(name,1,charindex-2);
longpart:=copy(name,charindex,length(name)-charindex+1);
if assigned(item) and (shortname=item.text) then
begin
litem:=item.children.newitem;
litem.local:=topic;
litem.keyword :=longpart; // recursively split this? No examples.
litem.text:=title;
end
else
begin
item:=sitemap.items.NewItem;
item.keyword:=shortname;
item.local:=topic;
item.text:=title;
litem:=item.children.newitem;
litem.keyword:=longpart;
litem.local:=topic;
litem.text :=Title; // recursively split this? No examples.
end;
end;
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 createentryseealso(Name:ansistring;CharIndex:integer;seealso:ansistring);
var litem : TChmSiteMapItem;
begin
item:=sitemap.items.NewItem;
item.KeyWord:=name;
item.SeeAlso:=seealso;
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;
Item : TChmSiteMapItem;
var hdr:PBTreeBlockHeader;
hdr:PBTreeBlockHeader;
head,tail : pbyte;
isseealso,
entrydepth,
@ -1125,8 +1113,41 @@ var hdr:PBTreeBlockHeader;
CharIndex,
ind:integer;
seealsostr,
topic,
s,
Name : AnsiString;
path,
shortname : AnsiString;
anitem:TChmSiteMapItems;
litem : TChmSiteMapItem;
lookupitem : TLookupRec;
function readvalue:string;
begin
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);
@ -1135,17 +1156,21 @@ begin
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);
itemstack:=TObjectStack.create;
{$ifdef binindex}
{$ifndef nonumber}
writeln('previndex : ',hdr^.IndexOfPrevBlock);
writeln('nextindex : ',hdr^.IndexOfNextBlock);
{$endif}
curitemdepth:=0;
{$endif}
while head<tail do
begin
//writeln(tail-head);
if not ReadWCharString(Head,Tail,Name) Then
Break;
{$ifdef binindex}
@ -1158,6 +1183,75 @@ begin
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);
@ -1178,7 +1272,7 @@ begin
{$ifdef binindex}
writeln('seealso: ',seealsostr);
{$endif}
item.AddSeeAlso(seealsostr);
end
else
begin
@ -1190,24 +1284,13 @@ begin
for i:=0 to nrpairs-1 do
begin
if head<tail Then
begin
ind:=LEToN(plongint(head)^);
topic:=lookuptopicbyid(ind,title);
{$ifdef binindex}
writeln(i:3,' topic: ',topic);
writeln(' title: ',title);
{$endif}
inc(head,4);
end;
s:=readvalue;
// if not ((i=0) and (title=shortname)) then
item.addname(title);
item.addlocal(s);
end;
end;
end;
if isseealso>0 then
createentryseealso(name,charindex,seealsostr)
else
if nrpairs<>0 Then
createentry(Name,CharIndex,Topic,Title);
inc(head,4); // always 1
{$ifdef binindex}
if head<tail then
@ -1215,15 +1298,16 @@ begin
{$endif}
inc(head,4); // zero based index (13 higher than last
end;
ItemStack.Free;
end;
var TryTextual : boolean;
BHdr : TBTreeHeader;
block : Array[0..2047] of Byte;
i : Integer;
begin
Result := nil; SiteMap:=Nil;
lookup:=TDictionary<string,TLookupRec>.create;
// First Try Binary
Index := GetObject('/$WWKeywordLinks/BTree');
if (Index = nil) or ForceXML then
@ -1237,9 +1321,12 @@ begin
Exit;
end;
SiteMap:=TChmSitemap.Create(StIndex);
Item :=Nil; // cached last created item, in case we need to make
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
@ -1248,7 +1335,7 @@ begin
begin
for i:=0 to BHdr.lastlstblock do
begin
if (index.size-index.position)>=defblocksize then
if (index.size-index.position)>=defblocksize then // skips last incomplete block?
begin
Index.read(block,defblocksize);
parselistingblock(@block)
@ -1264,6 +1351,7 @@ begin
Result:=AbortAndTryTextual;
end
else Index.Free;
lookup.free;
end;
function TChmReader.GetTOCSitemap(ForceXML:boolean=false): TChmSiteMap;
@ -1273,19 +1361,19 @@ function TChmReader.GetTOCSitemap(ForceXML:boolean=false): TChmSiteMap;
Item: TChmSiteMapItem;
NextEntry: DWord;
TopicsIndex: DWord;
Title: String;
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.Text:= ReadStringsEntry(LEtoN(TOC.ReadDWord))
Item.AddName(ReadStringsEntry(LEtoN(TOC.ReadDWord)))
else
begin
TopicsIndex := LEtoN(TOC.ReadDWord);
Item.Local := LookupTopicByID(TopicsIndex, Title);
Item.Text := Title;
Local:=LookupTopicByID(TopicsIndex, Title);
Item.AddName(Title);
Item.AddLocal(Local);
end;
TOC.ReadDWord;
Result := LEtoN(TOC.ReadDWord);
@ -1724,7 +1812,7 @@ var
X: Integer;
begin
fOnOpenNewFile := AValue;
if AValue = nil then exit;
if not assigned(AValue) then exit;
for X := 0 to fUnNotifiedFiles.Count-1 do
AValue(Self, X);
fUnNotifiedFiles.Clear;

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

@ -20,54 +20,105 @@
}
unit chmsitemap;
{$mode objfpc}{$H+}
{$mode Delphi}{$H+}
{define preferlower}
interface
uses
Classes, SysUtils, fasthtmlparser;
Classes, SysUtils, fasthtmlparser, contnrs, strutils, generics.collections;
type
TChmSiteMapItems = class; // forward
TChmSiteMap = class;
TChmSiteMapItem = class;
{ TChmSiteMapItem }
TChmSiteMapItemAttrName = (siteattr_NONE,
siteattr_KEYWORD, // alias for name in sitemap
siteattr_NAME,
siteattr_LOCAL,
siteattr_URL,
siteattr_TYPE,
siteattr_SEEALSO,
siteattr_IMAGENUMBER,
siteattr_NEW,
siteattr_COMMENT,
siteattr_MERGE,
siteattr_FRAMENAME,
siteattr_WINDOWNAME,
siteattr_WINDOW_STYLES,
siteattr_EXWINDOW_STYLES,
siteattr_FONT,
siteattr_IMAGELIST,
siteattr_IMAGETYPE
);
{ TChmSiteMapSubItem }
TChmSiteMapGenerationOptions = (Default,emitkeyword);
TChmSiteMapSubItem = class(TPersistent)
private
FName,
FType,
FLocal,
FUrl,
FSeeAlso : String;
FOwner : TChmSiteMapItem;
public
constructor Create(AOwner: TChmSiteMapItem);
destructor Destroy; override;
published
property Name : String read FName write FName; //hhk
property ItemType : String read FType write FType; //both
property Local: String read FLocal write FLocal; //both
property URL : String read FURL write FURL; //both
property SeeAlso: String read FSeeAlso write FSeeAlso; //hhk
end;
// hhk items: Merge | ([Name] ([Name] [Type...] [Local [URL] | See Also])... [FrameName] [WindowName] [Comment])
// hhc items: Merge | ([Name] ([Type...] [Local] [URL])... [FrameName] [WindowName] [Comment] [New] [ImageNumber])
TChmSiteMapItem = class(TPersistent)
private
FChildren: TChmSiteMapItems;
FComment: String;
FImageNumber: Integer;
FIncreaseImageIndex: Boolean;
FKeyWord: String;
FLocal: String;
FOwner: TChmSiteMapItems;
FSeeAlso: String;
FText: String;
FURL: String;
FName : String;
FMerge : String;
FFrameName : String;
FWindowName : String;
FSubItems : TObjectList;
function getlocal: string;
function getseealso:string;
function getsubitem( index : integer): TChmSiteMapSubItem;
function getsubitemcount: integer;
procedure SetChildren(const AValue: TChmSiteMapItems);
public
constructor Create(AOwner: TChmSiteMapItems);
destructor Destroy; override;
procedure AddName(const Name:string);
procedure AddLocal(const Local:string);
procedure AddSeeAlso(const SeeAlso:string);
procedure AddURL(const URL:string);
procedure AddType(const AType:string);
procedure Sort(Compare: TListSortCompare);
published
property Children: TChmSiteMapItems read FChildren write SetChildren;
property Text: String read FText write FText; // Name for TOC; KeyWord for index
property KeyWord: String read FKeyWord write FKeyWord;
property Local: String read FLocal write FLocal;
property URL: String read FURL write FURL;
property SeeAlso: String read FSeeAlso write FSeeAlso;
property Name: String read FName write FName;
property ImageNumber: Integer read FImageNumber write FImageNumber default -1;
property IncreaseImageIndex: Boolean read FIncreaseImageIndex write FIncreaseImageIndex;
property Comment: String read FComment write FComment;
property Owner: TChmSiteMapItems read FOwner;
property Keyword : string read fname; // deprecated; // Use name, sitemaps don't store the difference.
property Local : string read getlocal; // deprecated; // should work on ALL pairs
property Text : string read fname write fname; // deprecated; // should work on ALL pairs
property SeeAlso : string read getseealso; // deprecated; // should work on ALL pairs
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;
property SubItem[ index :integer]:TChmSiteMapSubItem read getsubitem;
property SubItemcount :integer read getsubitemcount;
end;
{ TChmSiteMapItems }
@ -80,6 +131,7 @@ type
FParentItem: TChmSiteMapItem;
function GetCount: Integer;
function GetItem(AIndex: Integer): TChmSiteMapItem;
function getparentname: String;
procedure SetItem(AIndex: Integer; const AValue: TChmSiteMapItem);
public
constructor Create(AOwner: TChmSiteMap; AParentItem: TChmSiteMapItem);
@ -95,6 +147,7 @@ type
property ParentItem: TChmSiteMapItem read FParentItem;
property Owner: TChmSiteMap read FOwner;
property InternalData: Dword read FInternalData write FInternalData;
property ParentName : String read getparentname;
end;
@ -130,13 +183,17 @@ type
FLevel: Integer;
FLevelForced: Boolean;
FWindowStyles: LongInt;
FLoadDict : TDictionary<String,TChmSiteMapItemAttrName>;
fChmSiteMapGenerationOptions:TChmSiteMapGenerationOptions;
procedure SetItems(const AValue: TChmSiteMapItems);
procedure CheckLookup;
protected
procedure FoundTag (ACaseInsensitiveTag, AActualTag: string);
procedure FoundText(AText: string);
public
constructor Create(AType: TSiteMapType);
destructor Destroy; override;
Procedure Sort(Compare: TListSortCompare);
procedure LoadFromFile(AFileName: String);
procedure LoadFromStream(AStream: TStream);
procedure SaveToFile(AFileName:String);
@ -155,11 +212,50 @@ type
property UseFolderImages: Boolean read FUseFolderImages write FUseFolderImages;
property Font: String read FFont write FFont;
property AutoGenerated: Boolean read FAutoGenerated write FAutoGenerated;
property ChmSiteMapGenerationOptions : TChmSiteMapGenerationOptions read fChmSiteMapGenerationOptions write fChmSiteMapGenerationOptions;
end;
function indexitemcompare(Item1, Item2: Pointer): Integer;
implementation
uses HTMLUtil;
const sitemapkws : array[TChmSiteMapItemAttrName] of string = (
'',
'KEYWORD',
'NAME',
'LOCAL',
'URL',
'TYPE',
'SEE ALSO',
'IMAGENUMBER',
'NEW',
'COMMENT',
'MERGE',
'FRAMENAME',
'WINDOWNAME',
'WINDOW STYLES',
'EXWINDOW STYLES',
'FONT',
'IMAGELIST',
'IMAGETYPE');
function indexitemcompare(Item1, Item2: Pointer): Integer;
begin
Result := naturalComparetext(LowerCase(TChmSiteMapItem(item1).name), Lowercase(TChmSiteMapItem(item2).name));
end;
{ TChmSiteMapSubItem }
constructor TChmSiteMapSubItem.Create(AOwner: TChmSiteMapItem);
begin
FOwner:=AOwner;
end;
destructor TChmSiteMapSubItem.Destroy;
begin
inherited Destroy;
end;
{ TChmSiteMapTree }
procedure TChmSiteMap.SetItems(const AValue: TChmSiteMapItems);
@ -168,6 +264,16 @@ begin
FItems:=AValue;
end;
procedure TChmSiteMap.CheckLookup;
var en : TChmSiteMapItemAttrName;
begin
if assigned(FLoadDict) then
exit;
FLoadDict :=TDictionary<String,TChmSiteMapItemAttrName>.Create;
for en:=succ(low(en)) to high(en) do
FLoadDict.add(sitemapkws[en],en);
end;
procedure TChmSiteMap.FoundTag(ACaseInsensitiveTag, AActualTag: string);
procedure NewSiteMapItem;
begin
@ -196,131 +302,98 @@ procedure TChmSiteMap.FoundTag(ACaseInsensitiveTag, AActualTag: string);
else FCurrentItems := nil;
Dec(FLevel);
end;
// hhk items: Merge | ([Name] ([Name] [Type...] [Local [URL] | See Also])... [FrameName] [WindowName] [Comment])
// hhc items: Merge | ([Name] ([Type...] [Local] [URL])... [FrameName] [WindowName] [Comment] [New] [ImageNumber])
var
TagName,
//TagAttribute,
TagAttributeName,
TagAttributeValue: String;
isParam,IsMerged : string;
TagAttrName : TChmSiteMapItemAttrName;
begin
//WriteLn('TAG:', AActualTag);
TagName := GetTagName(ACaseInsensitiveTag);
{ if not (smtHTML in FSiteMapTags) then begin
if (TagName = 'HTML') or (TagName = '/HTML') then Include(FSiteMapTags, smtHTML);
end
else begin // looking for /HTML
if TagName = '/HTML' then Exclude(FSiteMapTags, smtHTML);
end;}
//if (smtHTML in FSiteMapTags) then begin
if not (smtBODY in FSiteMapTags) then begin
if TagName = 'BODY' then Include(FSiteMapTags, smtBODY);
end
else begin
if TagName = '/BODY' then Exclude(FSiteMapTags, smtBODY);
if TagName = 'UL' then begin
IncreaseULevel;
end
else if TagName = '/UL' then begin
DecreaseULevel;
end
else if (TagName = 'LI') and (FLevel = 0) then
FLevelForced := True
else if TagName = 'OBJECT' then begin
Include(FSiteMapBodyTags, smbtOBJECT);
if FLevelForced then
IncreaseULevel;
If FLevel > 0 then // if it is zero it is the site properties
NewSiteMapItem;
end
else if TagName = '/OBJECT' then begin
Exclude(FSiteMapBodyTags, smbtOBJECT);
if FLevelForced then
begin
DecreaseULevel;
FLevelForced := False;
end;
if (smtBODY in FSiteMapTags) then begin
//WriteLn('GOT TAG: ', AActualTag);
if TagName = 'UL' then begin
//WriteLN('Inc Level');
IncreaseULevel;
end
else if TagName = '/UL' then begin
//WriteLN('Dec Level');
DecreaseULevel;
end
else if (TagName = 'LI') and (FLevel = 0) then
FLevelForced := True
else if TagName = 'OBJECT' then begin
Include(FSiteMapBodyTags, smbtOBJECT);
if FLevelForced then
IncreaseULevel;
If FLevel > 0 then // if it is zero it is the site properties
NewSiteMapItem;
end
else if TagName = '/OBJECT' then begin
Exclude(FSiteMapBodyTags, smbtOBJECT);
if FLevelForced then
end
else begin // we are the properties of the object tag
if (smbtOBJECT in FSiteMapBodyTags) then
begin
if (FLevel > 0 ) then
begin
DecreaseULevel;
FLevelForced := False;
end;
end
else begin // we are the properties of the object tag
if (smbtOBJECT in FSiteMapBodyTags) then
begin
if (FLevel > 0 ) then
begin
if LowerCase(GetTagName(AActualTag)) = 'param' then begin
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;
if LowerCase(GetTagName(AActualTag)) = 'param' then begin
TagAttributeName := GetVal(AActualTag, 'name');
TagAttributeValue := GetVal(AActualTag, 'value');
// a hash reduces comparisons and casing, and generics make it easy.
if not FLoadDict.trygetvalue(uppercase(TagAttributeName),TagAttrName) then
TagAttrName:=siteattr_none;
if TagAttrName <> siteattr_none then begin
case TagAttrName of
siteattr_KEYWORD,
siteattr_NAME : Activeitem.AddName(TagAttributeValue);
siteattr_LOCAL : ActiveItem.AddLocal(TagAttributeValue);
siteattr_URL : ActiveItem.AddURL (TagAttributeValue);
siteattr_TYPE : ActiveItem.AddType (TagAttributeValue);
siteattr_SEEALSO : ActiveItem.AddSeeAlso(TagAttributeValue);
siteattr_IMAGENUMBER : ActiveItem.ImageNumber := StrToInt(TagAttributeValue);
siteattr_NEW : ActiveItem.IncreaseImageIndex := (LowerCase(TagAttributeValue) = 'yes');
siteattr_COMMENT : ActiveItem.Comment := TagAttributeValue;
siteattr_MERGE : ActiveItem.Merge:= TagAttributeValue;
siteattr_FRAMENAME : ActiveItem.FrameName:=TagAttributeValue;
siteattr_WINDOWNAME : ActiveItem.WindowName:=TagAttributeValue;
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
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 not FLoadDict.trygetvalue(uppercase(TagAttributeName),TagAttrName) then
TagAttrName:=siteattr_none;
if TagAttrName <> siteattr_none then begin
case TagAttrName of
siteattr_FRAMENAME : FrameName:=TagAttributeValue;
siteattr_WINDOWNAME : WindowName:=TagAttributeValue;
siteattr_WINDOW_STYLES : WindowStyles:=StrToIntDef(TagAttributeValue,0);
siteattr_EXWINDOW_STYLES : ExWindowStyles:=StrToIntDef(TagAttributeValue,0);
siteattr_FONT : Font:=TagAttributeValue;
siteattr_IMAGELIST : ImageList:=TagAttributeValue;
siteattr_IMAGETYPE : UseFolderImages:=uppercase(TagAttributeValue)='FOLDER';
end;
end;
end;
end;
end;
//end
// writeln('0:',flevel,' ' ,aactualtag,' ',tagname,' ' ,tagattributename, ' ' ,tagattributevalue);
end;
end;
end;
end;
end;
// end; {body}
//end {html}
end;
procedure TChmSiteMap.FoundText(AText: string);
@ -342,14 +415,22 @@ destructor TChmSiteMap.Destroy;
begin
if Assigned(FHTMLParser) then FHTMLParser.Free;
FItems.Free;
FLoadDict.Free;
Inherited Destroy;
end;
procedure TChmSiteMap.Sort(Compare: TListSortCompare);
begin
FItems.sort(compare);
end;
procedure TChmSiteMap.LoadFromFile(AFileName: String);
var
Buffer: String;
TmpStream: TMemoryStream;
begin
CheckLookup;
if Assigned(FHTMLParser) then FHTMLParser.Free;
TmpStream := TMemoryStream.Create;
try
@ -362,8 +443,8 @@ begin
end;
FHTMLParser := THTMLParser.Create(Buffer);
try
FHTMLParser.OnFoundTag := @FoundTag;
FHTMLParser.OnFoundText := @FoundText;
FHTMLParser.OnFoundTag := FoundTag;
FHTMLParser.OnFoundText := FoundText;
FHTMLParser.Exec;
finally
FreeAndNil(FHTMLParser);
@ -374,12 +455,13 @@ procedure TChmSiteMap.LoadFromStream(AStream: TStream);
var
Buffer: String;
begin
CheckLookup;
if Assigned(FHTMLParser) then FHTMLParser.Free;
SetLength(Buffer, AStream.Size-AStream.Position);
if AStream.Read(Buffer[1], AStream.Size-AStream.Position) > 0 then begin;
FHTMLParser := THTMLParser.Create(Buffer);
FHTMLParser.OnFoundTag := @FoundTag;
FHTMLParser.OnFoundText := @FoundText;
FHTMLParser.OnFoundTag := FoundTag;
FHTMLParser.OnFoundText := FoundText;
FHTMLParser.Exec;
FreeAndNil(FHTMLParser);
end;
@ -397,6 +479,9 @@ begin
end;
end;
// hhk items: Merge | ([Name] ([Name] [Type...] [Local [URL] | See Also])... [FrameName] [WindowName] [Comment])
// hhc items: Merge | ([Name] ([Type...] [Local] [URL])... [FrameName] [WindowName] [Comment] [New] [ImageNumber])
procedure TChmSiteMap.SaveToStream(AStream: TStream);
var
Indent: Integer;
@ -408,44 +493,86 @@ var
AStream.Write(AString[1], Length(AString));
AStream.WriteByte(10);
end;
procedure WriteStringNoIndent(AString: String);
var
I: Integer;
begin
AStream.Write(AString[1], Length(AString));
end;
procedure WriteParam(AName: String; AValue: String);
begin
WriteString('<param name="'+AName+'" value="'+AValue+'">');
end;
procedure WriteEntries(AItems: TChmSiteMapItems);
var
I : Integer;
I,J : Integer;
Item: TChmSiteMapItem;
Sub : TChmSiteMapSubItem;
lemitkeyword : boolean;
begin
lemitkeyword:=ChmSiteMapGenerationOptions=emitkeyword;
for I := 0 to AItems.Count-1 do begin
Item := AItems.Item[I];
{$ifdef preferlower}
WriteString('<li> <object type="text/sitemap">');
{$else}
WriteString('<LI> <OBJECT type="text/sitemap">');
{$endif}
Inc(Indent, 8);
if (SiteMapType = stIndex) and ((Item.Children.Count > 0) or (item.seealso<>'')) then
WriteParam('Keyword', Item.Text);
//if Item.KeyWord <> '' then WriteParam('Keyword', Item.KeyWord);
if Item.Text <> '' then WriteParam('Name', Item.Text);
if (Item.Local <> '') or (SiteMapType = stIndex) then WriteParam('Local', StringReplace(Item.Local, '\', '/', [rfReplaceAll]));
if Item.URL <> '' then WriteParam('URL', StringReplace(Item.URL, '\', '/', [rfReplaceAll]));
if (SiteMapType = stIndex) and (Item.SeeAlso <> '') then WriteParam('See Also', Item.SeeAlso);
//if Item.FrameName <> '' then WriteParam('FrameName', Item.FrameName);
//if Item.WindowName <> '' then WriteParam('WindowName', Item.WindowName);
if Item.Comment <> '' then WriteParam('Comment', Item.Comment);
if (SiteMapType = stTOC) and (Item.IncreaseImageIndex) then WriteParam('New', 'yes'); // is this a correct value?
if (SiteMapType = stTOC) and (Item.ImageNumber <> -1) then WriteParam('ImageNumber', IntToStr(Item.ImageNumber));
if Item.Name<>'' then
begin
if lemitkeyword then
WriteParam('Keyword', item.Name)
else
WriteParam('Name', Item.Name);
end;
if item.FSubItems.count>0 then
begin
For j:=0 to item.FSubItems.count-1 do
begin
Sub:=TChmSiteMapSubItem(item.fsubitems[j]);
if Sub.Name <> '' then WriteParam('Name', Sub.Name);
if Sub.ItemType <> '' then WriteParam('Type', Sub.ItemType);
if Sub.Local <> '' then WriteParam('Local', Sub.Local);
if Sub.URL <> '' then WriteParam('URL', Sub.URL);
if Sub.SeeAlso <> '' then WriteParam('See Also', Sub.SeeAlso);
end;
end;
if Item.FrameName <> '' then WriteParam('FrameName', Item.FrameName);
if Item.WindowName <> '' then WriteParam('WindowName', Item.WindowName);
if Item.Comment <> '' then WriteParam('Comment', Item.Comment);
if (SiteMapType = stTOC) and (Item.IncreaseImageIndex) then
WriteParam('New', 'yes'); // is this a correct value?
if (SiteMapType = stTOC) and (Item.ImageNumber <> -1) then
WriteParam('ImageNumber', IntToStr(Item.ImageNumber));
Dec(Indent, 3);
{$ifdef preferlower}
WriteString('</object>');
{$else}
WriteString('</OBJECT>');
{$endif}
Dec(Indent, 5);
// Now Sub Entries
if Item.Children.Count > 0 then begin
WriteString('<UL>');
{$ifdef preferlower}
WriteString('<ul>');
{$else}
WriteString('<UL> ');
{$endif}
Inc(Indent, 8);
WriteEntries(Item.Children);
Dec(Indent, 8);
WriteString('</UL>');
{$ifdef preferlower}
WriteString('</ul>');
{$else}
WriteString('</UL>'); //writestringnoident
{$endif}
end;
end;
end;
@ -475,7 +602,7 @@ begin
// both TOC and Index have font
if Font <> '' then
WriteParam('Font', Font);
Dec(Indent, 8);
Dec(Indent, 8);
WriteString('</OBJECT>');
// And now the items
@ -501,19 +628,137 @@ begin
FChildren := AValue;
end;
function TChmSiteMapItem.getlocal: string;
begin
result:='';
if FSubItems.count>0 then
result:=TChmSiteMapSubItem(FSubItems[0]).local;
end;
function TChmSiteMapItem.getseealso: string;
begin
result:='';
if FSubItems.count>0 then
result:=TChmSiteMapSubItem(FSubItems[FSubItems.count-1]).SeeAlso;
end;
function TChmSiteMapItem.getsubitem( index : integer): TChmSiteMapSubItem;
begin
result:=nil;
if index<FSubItems.count then
result:=TChmSiteMapSubItem(FSubItems[index]);
end;
function TChmSiteMapItem.getsubitemcount: integer;
begin
result:=FSubItems.count;
end;
constructor TChmSiteMapItem.Create(AOwner: TChmSiteMapItems);
begin
Inherited Create;
FOwner := AOwner;
FChildren := TChmSiteMapItems.Create(Owner.Owner, Self);
FSubItems := TObjectList.Create(true);
imagenumber:=-1;
end;
destructor TChmSiteMapItem.Destroy;
begin
fsubitems.Free;
FChildren.Free;
Inherited Destroy;
end;
procedure TChmSiteMapItem.AddName(const Name: string);
var sub :TChmSiteMapSubItem;
begin
if fname='' then
fname:=name
else
begin
sub :=TChmSiteMapSubItem.create(self);
FSubItems.add(sub);
sub.Name:=Name;
end;
end;
procedure TChmSiteMapItem.AddLocal(const Local: string);
var sub :TChmSiteMapSubItem;
addnew : boolean;
begin
if fsubitems.count>0 then
begin
sub:=TChmSiteMapSubItem(fsubitems[FSubItems.count-1]);
if sub.FLocal<>'' then
begin
sub.flocal:=local;
exit;
end;
end;
sub :=TChmSiteMapSubItem.create(self);
FSubItems.add(sub);
// sub.name:=name;
sub.Local:=Local;
end;
procedure TChmSiteMapItem.AddSeeAlso(const SeeAlso: string);
// see also is mutually exclusive with "local url", so addition procedure is same as "local"
var sub :TChmSiteMapSubItem;
begin
if fsubitems.count>0 then
begin
sub:=TChmSiteMapSubItem(fsubitems[FSubItems.count-1]);
if sub.FSeeAlso<>'' then
begin
sub.FSeeAlso:=SeeAlso;
exit;
end;
end;
sub :=TChmSiteMapSubItem.create(self);
FSubItems.add(sub);
sub.FSeeAlso:=SeeAlso;
end;
procedure TChmSiteMapItem.AddURL(const URL: string);
var sub :TChmSiteMapSubItem;
begin
if fsubitems.count>0 then
begin
sub:=TChmSiteMapSubItem(fsubitems[FSubItems.count-1]);
if sub.FURL<>'' then
begin
sub.fURL:=URL;
exit;
end;
end
{ else not possible according to chmspec. An URL must always follow a "local" item}
end;
procedure TChmSiteMapItem.AddType(const AType: string);
// in Tocs, Type can be the first is the same as local
var sub :TChmSiteMapSubItem;
begin
if fsubitems.count>0 then
begin
sub:=TChmSiteMapSubItem(fsubitems[FSubItems.count-1]);
if sub.ItemType<>'' then
begin
sub.ItemType:=AType;
exit;
end;
end;
sub :=TChmSiteMapSubItem.create(self);
FSubItems.add(sub);
sub.ItemType:=AType;
end;
procedure TChmSiteMapItem.Sort(Compare: TListSortCompare);
begin
FChildren.sort(compare);
end;
{ TChmSiteMapItems }
function TChmSiteMapItems.GetItem(AIndex: Integer): TChmSiteMapItem;
@ -521,6 +766,15 @@ begin
Result := TChmSiteMapItem(FList.Items[AIndex]);
end;
function TChmSiteMapItems.getparentname: String;
begin
result:='Not assigned';
if assigned(fparentitem) then
begin
result:=FParentItem.name;
end;
end;
function TChmSiteMapItems.GetCount: Integer;
begin
Result := FList.Count;
@ -577,8 +831,11 @@ begin
end;
procedure TChmSiteMapItems.Sort(Compare: TListSortCompare);
var I :Integer;
begin
FList.Sort(Compare);
for i:=0 to flist.Count-1 do
TChmSiteMapItem(flist[i]).sort(Compare)
end;
end.

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

@ -136,6 +136,7 @@ type
// of certain fields. Needs to be inserted into #windows stream
Constructor create(s:string='');
procedure load_from_ini(txt:string);
procedure SaveToIni(out s: string);
procedure savetoxml(cfg:TXMLConfig;key:string);
procedure loadfromxml(cfg:TXMLConfig;key:string);
procedure assign(obj : TCHMWindow);
@ -547,6 +548,39 @@ begin
wm_notify_id :=getnextint(txt,ind,len,flags,valid_unknown1);
end;
procedure TCHMWindow.SaveToIni(out s: string);
begin
s := window_type + '=';
s := s + '"' + Title_bar_text + '"';
s := s + ',"' + Toc_file + '"';
s := s + ',"' + index_file + '"';
s := s + ',"' + Default_File + '"';
s := s + ',"' + Home_button_file + '"';
s := s + ',"' + Jumpbutton_1_File + '"';
s := s + ',"' + Jumpbutton_1_Text + '"';
s := s + ',"' + Jumpbutton_2_File + '"';
s := s + ',"' + Jumpbutton_2_Text + '"';
s := s + ',0x' + IntToHex(nav_style, 1);
s := s + ',' + IntToStr(navpanewidth);
s := s + ',0x' + IntToHex(buttons, 1);
s := s + ',[' + IntToStr(left);
s := s + ',' + IntToStr(top);
s := s + ',' + IntToStr(right);
s := s + ',' + IntToStr(bottom) + ']';
s := s + ',0x' + IntToHex(styleflags, 1);
if xtdstyleflags <> 0 then
s := s + ',0x' + IntToHex(xtdstyleflags, 1)
else
s := s + ',';
s := s + ',0x' + IntToHex(window_show_state, 1);
s := s + ',' + IntToStr(navpane_initially_closed);
s := s + ',' + IntToStr(navpane_default);
s := s + ',' + IntToStr(navpane_location);
//s := s + ',' + IntToStr(wm_notify_id);
end;
procedure TCHMWindow.savetoxml(cfg:TXMLConfig;key:string);
begin
cfg.setvalue(key+'window_type',window_type);

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

@ -6,7 +6,7 @@
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
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.
@ -22,7 +22,7 @@ unit chmwriter;
{$MODE OBJFPC}{$H+}
interface
uses Classes, ChmBase, chmtypes, chmspecialfiles, HtmlIndexer, chmsitemap, contnrs, StreamEx, Avl_Tree, lzxcompressthread;
uses Generics.Collections,Classes, ChmBase, chmtypes, chmspecialfiles, HtmlIndexer, chmsitemap, contnrs, StreamEx, Avl_Tree, lzxcompressthread;
Const
DefaultHHC = 'Default.hhc';
@ -126,7 +126,8 @@ Type
property TempRawStream: TStream read FTempStream write SetTempRawStream;
property ReadmeMessage : String read fReadmeMessage write fReadmeMessage;
property Cores : integer read fcores write fcores;
//property LocaleID: dword read ITSFHeader.LanguageID write ITSFHeader.LanguageID;
{ MS Locale ID code }
property LocaleID: dword read ITSFHeader.LanguageID write ITSFHeader.LanguageID;
end;
{ TChmWriter }
@ -154,6 +155,7 @@ Type
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
FDictTopicsUrlInd : specialize TDictionary<string,integer>; // if url exists reuse topic.
SpareString : TStringIndex;
SpareUrlStr : TUrlStrIndex;
FWindows : TObjectList;
@ -186,6 +188,7 @@ Type
function AddURL(AURL: String; TopicsIndex: DWord): LongWord;
procedure CheckFileMakeSearchable(AStream: TStream; AFileEntry: TFileEntryRec);
function AddTopic(ATitle,AnUrl:AnsiString;code:integer=-1):integer;
function AddTopicindex(ATitle,AnUrl:AnsiString;code:integer=-1):integer;
procedure ScanSitemap(asitemap:TCHMSiteMap);
function NextTopicIndex: Integer;
procedure Setwindows (AWindowList:TObjectList);
@ -1521,6 +1524,7 @@ begin
FDefaultWindow:= '';
FMergeFiles :=TStringList.Create;
FNrTopics :=0;
FDictTopicsUrlInd :=specialize TDictionary<string,integer>.Create;
end;
destructor TChmWriter.Destroy;
@ -1543,7 +1547,7 @@ begin
FAVLTopicdedupe.FreeAndClear;
FAVLTopicdedupe.free;
FWindows.Free;
FDictTopicsUrlInd.Free;
inherited Destroy;
end;
@ -1664,6 +1668,7 @@ var
TopicEntry: TTopicEntry;
begin
ATitle :=StringReplace(Atitle, '&x27;', '', [rfReplaceAll]);
anurl:=StringReplace(anurl, '\', '/', [rfReplaceAll]);
if ATitle <> '' then
TopicEntry.StringsOffset := AddString(ATitle)
@ -1691,6 +1696,35 @@ begin
FTopicsStream.WriteDWord(LEtoN(TopicEntry.URLTableOffset));
FTopicsStream.WriteWord(LEtoN(TopicEntry.InContents));
FTopicsStream.WriteWord(LEtoN(TopicEntry.Unknown));
{$ifdef binindex}
writeln('topout:',result, ' ' , TopicEntry.StringsOffset,' ' ,TopicEntry.URLTableOffset, ' ',atitle,' - ', anurl);
{$endif}
end;
function TChmWriter.AddTopicindex(ATitle, AnUrl: AnsiString; code: integer
): integer;
begin
ATitle :=StringReplace(Atitle, '&x27;', '', [rfReplaceAll]);
// adhoc subsitutions. Replace with real code if exact behaviour is known.
{ Atitle:=StringReplace(atitle, '&x27;', '''', [rfReplaceAll]);
if length(atitle)>0 then
atitle[1]:=uppercase(atitle[1])[1];}
{$ifdef binindex}
writeln('Enter ',ATitle,' ',AnUrl);
{$endif}
if FDictTopicsUrlInd.trygetvalue(anurl,result) then
begin
{$ifdef binindex}
writeln('found:',result);
{$endif}
end
else
begin
result:=addtopic(atitle,anurl);
FDictTopicsUrlInd.add(anurl,result);
end;
end;
procedure TChmWriter.ScanSitemap(asitemap:TCHMSiteMap);
@ -2039,32 +2073,64 @@ begin
inc(blockind,indexentrysize);
end;
procedure CreateEntry(Item:TChmSiteMapItem;Str:WideString;commaatposition:integer);
procedure WritestrNT(var p:pbyte;const str:Unicodestring);
var i : integer;
p2 : pbyte;
begin
p2:=p;
for i:=1 to Length(str) do
WriteWord(p2,Word(str[i])); // write the wstr in little endian
WriteWord(p2,0); // NT
p:=p2;
end;
procedure CreateEntry(Item:TChmSiteMapItem;const Str:UnicodeString;commaatposition,level:integer);
var p : pbyte;
topicid: integer;
seealso: Integer;
entrysize:Integer;
i : Integer;
sb :TChmSiteMapSubItem;
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
WriteWord(p,0); // NT
// if item.seealso='' then // no seealso for now
seealso:=0;
// else
// seealso:=2;
WritestrNT(p,Str);
if item.seealso='' then // no seealso for now
seealso:=0
else
seealso:=2;
WriteWord(p,seealso); // =0 not a see also 2 =seealso
WriteWord(p,0); // Entrydepth. We can't know it, so write 2.
WriteWord(p,level); // 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.
TopicId:=AddTopic(Item.Text,item.Local);
WriteDword(p,TopicId);
// if seealso then _here_ a wchar NT string with seealso?
if seealso=2 then
begin
{$ifdef binindex}
write('!seealso');
{$endif}
WriteDword(p,1);
WritestrNT(p,item.seealso)
end
else
begin
WriteDword(p,item.SubItemcount);
for i:=0 to item.SubItemcount-1 do
begin
sb:=item.SubItem[i];
if sb.name='' then
sb.name:=item.name;
{$ifdef binindex}
writeln('---',sb.name,' ',sb.local);
{$endif}
TopicId:=AddTopicIndex(sb.Name,sb.Local);
WriteDword(p,TopicId);
end;
end;
WriteDword(p,1); // always 1 (unknown);
WriteDword(p,mod13value); //a value that increments with 13.
mod13value:=mod13value+13;
@ -2158,32 +2224,36 @@ begin
Result:=blk-start;
end;
procedure CombineWithChildren(ParentItem:TChmSiteMapItem;Str:WideString;commaatposition:integer;first:boolean);
procedure CombineWithChildren(ParentItem:TChmSiteMapItem;Str:UnicodeString;commaatposition:integer;level:integer);
var i : Integer;
Item : TChmSiteMapItem;
llItem : TChmSiteMapItem;
begin
if ParentItem.Children.Count = 0 Then
Begin
str:=StringReplace(str, '&x27;', '', [rfReplaceAll]);
{$ifdef binindex}
writeln('i:',level,' ',str);
{$endif}
// if ParentItem.Children.Count = 0 Then
// Begin
// comment/fix next
// if commatposition=length(str) then commaatposition:=0;
if first then
CreateEntry(ParentItem,Str,0)
if level=0 then
CreateEntry(ParentItem,Str,0,level)
else
CreateEntry(ParentItem,Str,commaatposition);
End
Else
CreateEntry(ParentItem,Str,commaatposition,level);
// End
// Else
for i:=0 to ParentItem.Children.Count-1 do
begin
item := TChmSiteMapItem(ParentItem.Children.Item[i]);
if first Then
CombineWithChildren(Item,Str+', '+item.text,commaatposition+2,false)
else
CombineWithChildren(Item,Str+', '+item.text,commaatposition,false);
llitem := TChmSiteMapItem(ParentItem.Children.Item[i]);
{ if level=0 Then
CombineWithChildren(Item,str+', '+item.text,0,level+1)
else}
CombineWithChildren(llItem,Str+', '+llitem.text,length(str)+2,level+1);
end;
end;
Var i : Integer;
Key : WideString;
Key : UnicodeString;
Item : TChmSiteMapItem;
ListingBlocks : Integer;
EntryBytes : Integer;
@ -2204,6 +2274,7 @@ begin
{$ifdef binindex}
writeln('starting index');
{$endif}
ASiteMap.sort(@indexitemcompare);
IndexStream:=TMemoryStream.Create;
indexstream.size:=sizeof(TBTreeHeader);
IndexStream.position:=Sizeof(TBTreeHeader);
@ -2251,7 +2322,7 @@ begin
// so we can see if Windows loads the binary or textual index.
CombineWithChildren(Item,Key+'2',length(key)+1,true);
{$else}
CombineWithChildren(Item,Key,length(key),true);
CombineWithChildren(Item,Key,length(key),0);
{$endif}
end;
PrepareCurrentBlock(True); // flush last listing block.
@ -2420,7 +2491,6 @@ begin
PostAddStreamToArchive(AName, '/', AStream);
end;
procedure TChmWriter.AddContext(AContext: DWord; ATopic: String);
var
Offset: DWord;
@ -2448,7 +2518,6 @@ begin
end;
procedure TChmWriter.Setwindows(AWindowList: TObjectList);
var i : integer;
x : TCHMWindow;
begin

57
utils/fpdoc/dw_htmlchm.inc
View File

@ -192,12 +192,12 @@ begin
// by unit
TmpItem := ObjUnitItem.Children.NewItem;
TmpItem.Text := Element.Name;
TmpItem.Local := FixHTMLpath(Allocator.GetFilename(Element, 0));
TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0)));
//alpha
TmpItem := GetAlphaItem(AlphaObjItem.Children, UpperCase(Copy(Element.Name, 1, 2))).Children.NewItem;
TmpItem.Text := Element.Name;
TmpItem.Local := FixHTMLpath(Allocator.GetFilename(Element, 0));
TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0)));
end;
@ -208,12 +208,12 @@ begin
// by unit
TmpItem := RoutinesUnitItem.Children.NewItem;
TmpItem.Text := Element.Name;
TmpItem.Local := FixHTMLpath(Allocator.GetFilename(Element, 0));
TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0)));
// alpha
TmpItem := GetAlphaItem(AlphaRoutinesItem.Children, UpperCase(Element.Name[1])).Children.NewItem;
TmpItem.Text := Element.Name;
TmpItem.Local := FixHTMLpath(Allocator.GetFilename(Element, 0));
TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0)));
end;
end;
end;
@ -289,7 +289,7 @@ var
ParentElement: TPasElement;
MemberItem: TChmSiteMapItem;
Stream: TMemoryStream;
s: String;
RedirectUrl,Urls: String;
begin
DoLog('Generating Index...');
@ -305,7 +305,7 @@ begin
continue;
ParentItem := Index.Items.NewItem;
ParentItem.Text := AModule.Name;
ParentItem.Local := FixHTMLpath(Allocator.GetFilename(AModule, 0));
ParentItem.addLocal(FixHTMLpath(Allocator.GetFilename(AModule, 0)));
// classes
for j := 0 to AModule.InterfaceSection.Classes.Count-1 do
@ -313,18 +313,27 @@ begin
ParentElement := TPasClassType(AModule.InterfaceSection.Classes[j]);
ParentItem := Index.Items.NewItem;
ParentItem.Text := ParentELement.Name;
ParentItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0));
ParentItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
for k := 0 to TPasClassType(ParentElement).Members.Count-1 do
begin
TmpElement := TPasElement(TPasClassType(ParentElement).Members.Items[k]);
if TmpElement is TPasEnumValue then
s := UTF8Encode(ResolveLinkIDAbs(tmpElement.Parent.PathName))
else
s := UTF8Encode(ResolveLinkIDAbs(tmpElement.PathName));
if Engine.HidePrivate and(TmpElement.Visibility = visPrivate) then
if Engine.HidePrivate and(TmpElement.Visibility = visPrivate) then
continue;
if Engine.HideProtected and(TmpElement.Visibility = visProtected) then
continue;
Urls:=FixHTMLpath(Allocator.GetFilename(TmpElement, 0));
RedirectUrl:='';
if TmpElement is TPasEnumValue then
RedirectUrl := UTF8Encode(ResolveLinkIDAbs(tmpElement.Parent.PathName))
else
RedirectUrl := UTF8Encode(ResolveLinkIDAbs(tmpElement.PathName));
if(trim(RedirectUrl)<>'') and (RedirectUrl<>urls) then
begin
writeln('Hint: Index Resolved:',urls,' to ',RedirectUrl);
urls:=RedirectUrl;
end;
TmpItem := ParentItem.Children.NewItem;
case ElementType(TmpElement) of
cmtProcedure : TmpItem.Text := TmpElement.Name + ' procedure';
@ -336,13 +345,7 @@ begin
cmtInterface : TmpItem.Text := TmpElement.Name + ' interface';
cmtUnknown : TmpItem.Text := TmpElement.Name;
end;
TmpItem.Local := FixHTMLpath(Allocator.GetFilename(TmpElement, 0));
if (trim(s)<>'') and (tmpitem.local<>s) then
begin
writeln('Hint: Index: Resolved:',tmpitem.local,' to ',s);
tmpitem.local:=s;
end;
TmpItem.addLocal(Urls);
{
ParentElement = Class
TmpElement = Member
@ -350,11 +353,11 @@ begin
MemberItem := nil;
MemberItem := GetAlphaItem(Index.Items, TmpElement.Name);
// ahh! if MemberItem.Local is empty MemberType is not shown!
MemberItem.Local := FixHTMLpath(Allocator.GetFilename(TmpElement, 0));
MemberItem.addLocal(Urls);
TmpItem := MemberItem.Children.NewItem;
TmpItem.Text := ParentElement.Name;
TmpITem.Local := FixHTMLpath(Allocator.GetFilename(TmpElement, 0));
TmpItem.AddLocal(Urls);
end;
end;
// routines
@ -363,7 +366,7 @@ begin
ParentElement := TPasProcedureType(AModule.InterfaceSection.Functions[j]);
TmpItem := Index.Items.NewItem;
TmpItem.Text := ParentElement.Name + ' ' + ParentElement.ElementTypeName;
TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0));
TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
end;
// consts
for j := 0 to AModule.InterfaceSection.Consts.Count-1 do
@ -371,7 +374,7 @@ begin
ParentElement := TPasElement(AModule.InterfaceSection.Consts[j]);
TmpItem := Index.Items.NewItem;
TmpItem.Text := ParentElement.Name;
TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0));
TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
end;
// types
for j := 0 to AModule.InterfaceSection.Types.Count-1 do
@ -379,7 +382,7 @@ begin
ParentElement := TPasType(AModule.InterfaceSection.Types[j]);
TmpItem := Index.Items.NewItem;
TmpItem.Text := ParentElement.Name;
TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0));
TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
// enums
if ParentELement is TPasEnumType then
begin
@ -390,11 +393,11 @@ begin
// subitem
TmpItem := ParentItem.Children.NewItem;
TmpItem.Text := TmpElement.Name;
TmpItem.Local := ParentItem.Local;
TmpItem.addLocal(ParentItem.Local);
// root level
TmpItem := Index.Items.NewItem;
TmpItem.Text := TmpElement.Name;
TmpItem.Local := ParentItem.Local;
TmpItem.addLocal(ParentItem.Local);
end;
end;
end;
@ -404,7 +407,7 @@ begin
ParentElement := TPasElement(AModule.InterfaceSection.Variables[j]);
TmpItem := Index.Items.NewItem;
TmpItem.Text := ParentElement.Name + ' var';
TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0));
TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
end;
// declarations
{