mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-30 15:28:41 +01:00
536 lines
17 KiB
ObjectPascal
536 lines
17 KiB
ObjectPascal
{ Copyright (C) <2005> <Andrew Haines> chmsitemap.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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|
}
|
|
{
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
}
|
|
unit wikichmsitemap;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, fasthtmlparser;
|
|
|
|
type
|
|
TChmSiteMapItems = class; // forward
|
|
TChmSiteMap = class;
|
|
|
|
{ TChmSiteMapItem }
|
|
|
|
TChmSiteMapItem = class(TPersistent)
|
|
private
|
|
FChildren: TChmSiteMapItems;
|
|
FComment: String;
|
|
FImageNumber: Integer;
|
|
FIncreaseImageIndex: Boolean;
|
|
FKeyWord: String;
|
|
FLocal: String;
|
|
FOwner: TChmSiteMapItems;
|
|
FSeeAlso: String;
|
|
FText: String;
|
|
FURL: String;
|
|
procedure SetChildren(const AValue: TChmSiteMapItems);
|
|
public
|
|
constructor Create(AOwner: TChmSiteMapItems);
|
|
destructor Destroy; override;
|
|
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 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 FrameName: String read FFrameName write FFrameName;
|
|
//property WindowName: String read FWindowName write FWindowName;
|
|
//property Type_: Integer read FType_ write FType_; either Local or URL
|
|
//property Merge: Boolean read FMerge write FMerge;
|
|
end;
|
|
|
|
{ TChmSiteMapItems }
|
|
|
|
TChmSiteMapItems = class(TPersistent)
|
|
private
|
|
FInternalData: Dword;
|
|
FList: TList;
|
|
FOwner: TChmSiteMap;
|
|
FParentItem: TChmSiteMapItem;
|
|
function GetCount: Integer;
|
|
function GetItem(AIndex: Integer): TChmSiteMapItem;
|
|
procedure SetItem(AIndex: Integer; const AValue: TChmSiteMapItem);
|
|
public
|
|
constructor Create(AOwner: TChmSiteMap; AParentItem: TChmSiteMapItem);
|
|
destructor Destroy; override;
|
|
procedure Delete(AIndex: Integer);
|
|
function Add(AItem: TChmSiteMapItem): Integer;
|
|
function NewItem: TChmSiteMapItem;
|
|
function Insert(AItem: TChmSiteMapItem; AIndex: Integer): Integer;
|
|
procedure Clear;
|
|
procedure Sort(Compare: TListSortCompare);
|
|
property Item[AIndex: Integer]: TChmSiteMapItem read GetItem write SetItem;
|
|
property Count: Integer read GetCount;
|
|
property ParentItem: TChmSiteMapItem read FParentItem;
|
|
property Owner: TChmSiteMap read FOwner;
|
|
property InternalData: Dword read FInternalData write FInternalData;
|
|
end;
|
|
|
|
|
|
{ TChmSiteMapTree }
|
|
TSiteMapType = (stTOC, stIndex);
|
|
|
|
TSiteMapTag = (smtUnknown, smtNone, smtHTML, smtHEAD, smtBODY);
|
|
TSiteMapTags = set of TSiteMapTag;
|
|
|
|
TSiteMapBodyTag = (smbtUnknown, smbtNone, smbtUL, smbtLI, smbtOBJECT, smbtPARAM);
|
|
TSiteMapBodyTags = set of TSiteMapBodyTag;
|
|
|
|
TLIObjectParamType = (ptName, ptLocal, ptKeyword);
|
|
|
|
TChmSiteMap = class
|
|
private
|
|
FAutoGenerated: Boolean;
|
|
FBackgroundColor: LongInt;
|
|
FCurrentItems: TChmSiteMapItems;
|
|
FExWindowStyles: LongInt;
|
|
FFont: String;
|
|
FForegroundColor: LongInt;
|
|
FFrameName: String;
|
|
FImageList: String;
|
|
FImageWidth: Integer;
|
|
FSiteMapTags: TSiteMapTags;
|
|
FSiteMapBodyTags: TSiteMapBodyTags;
|
|
FHTMLParser: THTMLParser;
|
|
FItems: TChmSiteMapItems;
|
|
FSiteMapType: TSiteMapType;
|
|
FUseFolderImages: Boolean;
|
|
FWindowName: String;
|
|
FLevel: Integer;
|
|
FLevelForced: Boolean;
|
|
FWindowStyles: LongInt;
|
|
procedure SetItems(const AValue: TChmSiteMapItems);
|
|
protected
|
|
procedure FoundTag (ACaseInsensitiveTag, AActualTag: string);
|
|
procedure FoundText(AText: string);
|
|
public
|
|
constructor Create(AType: TSiteMapType);
|
|
destructor Destroy; override;
|
|
procedure LoadFromFile(AFileName: String);
|
|
procedure LoadFromStream(AStream: TStream);
|
|
procedure SaveToFile(AFileName:String);
|
|
procedure SaveToStream(AStream: TStream);
|
|
property Items: TChmSiteMapItems read FItems write SetItems;
|
|
property SiteMapType: TSiteMapType read FSiteMapType;
|
|
// SiteMap properties. most of these are invalid for the index
|
|
property FrameName: String read FFrameName write FFrameName;
|
|
property WindowName: String read FWindowName write FWindowName;
|
|
property ImageList: String read FImageList write FImageList;
|
|
property ImageWidth: Integer read FImageWidth write FImageWidth;
|
|
property BackgroundColor: LongInt read FBackgroundColor write FBackgroundColor;
|
|
property ForegroundColor: LongInt read FForegroundColor write FForegroundColor;
|
|
property ExWindowStyles: LongInt read FExWindowStyles write FExWindowStyles;
|
|
property WindowStyles: LongInt read FWindowStyles write FWindowStyles;
|
|
property UseFolderImages: Boolean read FUseFolderImages write FUseFolderImages;
|
|
property Font: String read FFont write FFont;
|
|
property AutoGenerated: Boolean read FAutoGenerated write FAutoGenerated;
|
|
end;
|
|
|
|
implementation
|
|
uses HTMLUtil;
|
|
|
|
{ TChmSiteMapTree }
|
|
|
|
procedure TChmSiteMap.SetItems(const AValue: TChmSiteMapItems);
|
|
begin
|
|
if FItems=AValue then exit;
|
|
FItems:=AValue;
|
|
end;
|
|
|
|
procedure TChmSiteMap.FoundTag(ACaseInsensitiveTag, AActualTag: string);
|
|
function ActiveItem: TChmSiteMapItem;
|
|
begin
|
|
Result := FCurrentItems.Item[FCurrentItems.Count-1]
|
|
end;
|
|
procedure IncreaseULevel;
|
|
begin
|
|
if FCurrentItems = nil then FCurrentItems := Items
|
|
else begin
|
|
//WriteLn('NewLevel. Count = ', FCurrentItems.Count, ' Index = ',Items.Count-1);
|
|
FCurrentItems := ActiveItem.Children;
|
|
end;
|
|
Inc(FLevel);
|
|
end;
|
|
procedure DecreaseULevel;
|
|
begin
|
|
if Assigned(FCurrentItems) and Assigned(FCurrentItems.ParentItem) then
|
|
FCurrentItems := FCurrentItems.ParentItem.Owner
|
|
else FCurrentItems := nil;
|
|
Dec(FLevel);
|
|
end;
|
|
procedure NewSiteMapItem;
|
|
begin
|
|
FCurrentItems.Add(TChmSiteMapItem.Create(FCurrentItems));
|
|
end;
|
|
var
|
|
TagName,
|
|
//TagAttribute,
|
|
TagAttributeName,
|
|
TagAttributeValue: String;
|
|
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);
|
|
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
|
|
begin
|
|
DecreaseULevel;
|
|
FLevelForced := False;
|
|
end;
|
|
end
|
|
else begin // we are the properties of the object tag
|
|
if (FLevel > 0 ) and (smbtOBJECT in FSiteMapBodyTags) then begin
|
|
|
|
if LowerCase(GetTagName(AActualTag)) = 'param' then begin
|
|
|
|
TagAttributeName := GetVal(AActualTag, 'name');
|
|
TagAttributeValue := GetVal(AActualTag, 'value');
|
|
|
|
if TagAttributeName <> '' then begin
|
|
if CompareText(TagAttributeName, 'keyword') = 0 then begin
|
|
ActiveItem.Text := TagAttributeValue;
|
|
end
|
|
else if CompareText(TagAttributeName, 'name') = 0 then begin
|
|
if ActiveItem.Text = '' then ActiveItem.Text := TagAttributeValue;
|
|
end
|
|
else if CompareText(TagAttributeName, 'local') = 0 then begin
|
|
ActiveItem.Local := TagAttributeValue;
|
|
end
|
|
else if CompareText(TagAttributeName, 'URL') = 0 then begin
|
|
ActiveItem.URL := TagAttributeValue;
|
|
end
|
|
else if CompareText(TagAttributeName, 'ImageNumber') = 0 then begin
|
|
ActiveItem.ImageNumber := StrToInt(TagAttributeValue);
|
|
end
|
|
else if CompareText(TagAttributeName, 'New') = 0 then begin
|
|
ActiveItem.IncreaseImageIndex := (LowerCase(TagAttributeValue) = 'yes');
|
|
end
|
|
else if CompareText(TagAttributeName, 'Comment') = 0 then begin
|
|
ActiveItem.Comment := TagAttributeValue;
|
|
end;
|
|
//else if CompareText(TagAttributeName, '') = 0 then begin
|
|
//end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
//end
|
|
end;
|
|
|
|
procedure TChmSiteMap.FoundText(AText: string);
|
|
begin
|
|
//WriteLn('TEXT:', AText);
|
|
end;
|
|
|
|
constructor TChmSiteMap.Create(AType: TSiteMapType);
|
|
begin
|
|
Inherited Create;
|
|
FSiteMapType := AType;
|
|
FSiteMapTags := [smtNone];
|
|
FSiteMapBodyTags := [smbtNone];
|
|
FHTMLParser:=nil;
|
|
FItems := TChmSiteMapItems.Create(Self, nil); ;
|
|
end;
|
|
|
|
destructor TChmSiteMap.Destroy;
|
|
begin
|
|
if Assigned(FHTMLParser) then FHTMLParser.Free;
|
|
FItems.Free;
|
|
Inherited Destroy;
|
|
end;
|
|
|
|
procedure TChmSiteMap.LoadFromFile(AFileName: String);
|
|
var
|
|
Buffer: String;
|
|
TmpStream: TMemoryStream;
|
|
begin
|
|
if Assigned(FHTMLParser) then FHTMLParser.Free;
|
|
TmpStream := TMemoryStream.Create;
|
|
TmpStream.LoadFromFile(AFileName);
|
|
SetLength(Buffer, TmpStream.Size);
|
|
TmpStream.Position := 0;
|
|
TmpStream.Read(Buffer[1], TmpStream.Size);
|
|
FHTMLParser := THTMLParser.Create(Buffer);
|
|
FHTMLParser.OnFoundTag := @FoundTag;
|
|
FHTMLParser.OnFoundText := @FoundText;
|
|
FHTMLParser.Exec;
|
|
FreeAndNil(FHTMLParser);
|
|
end;
|
|
|
|
procedure TChmSiteMap.LoadFromStream(AStream: TStream);
|
|
var
|
|
Buffer: String;
|
|
begin
|
|
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.Exec;
|
|
FreeAndNil(FHTMLParser);
|
|
end;
|
|
end;
|
|
|
|
procedure TChmSiteMap.SaveToFile(AFileName:String);
|
|
var
|
|
fs : TFileStream;
|
|
begin
|
|
fs:=TFileStream.Create(AFileName,fmcreate);
|
|
try
|
|
SaveToStream(fs);
|
|
finally
|
|
fs.free;
|
|
end;
|
|
end;
|
|
|
|
procedure TChmSiteMap.SaveToStream(AStream: TStream);
|
|
var
|
|
Indent: Integer;
|
|
procedure WriteString(AString: String);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to Indent-1 do AStream.WriteByte(Byte(' '));
|
|
AStream.Write(AString[1], Length(AString));
|
|
AStream.WriteByte(10);
|
|
end;
|
|
procedure WriteParam(AName: String; AValue: String);
|
|
begin
|
|
WriteString('<param name="'+AName+'" value="'+AValue+'">');
|
|
end;
|
|
procedure WriteEntries(AItems: TChmSiteMapItems);
|
|
var
|
|
I : Integer;
|
|
Item: TChmSiteMapItem;
|
|
begin
|
|
for I := 0 to AItems.Count-1 do begin
|
|
Item := AItems.Item[I];
|
|
WriteString('<LI> <OBJECT type="text/sitemap">');
|
|
Inc(Indent, 8);
|
|
|
|
if (SiteMapType = stIndex) and (Item.Children.Count > 0) then
|
|
WriteParam('Keyword', Item.Text);
|
|
//if Item.KeyWord <> '' then WriteParam('Keyword', Item.KeyWord);
|
|
if Item.Text <> '' then WriteParam('Name', Item.Text);
|
|
if (Item.Local <> '') 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));
|
|
|
|
Dec(Indent, 3);
|
|
WriteString('</OBJECT>');
|
|
Dec(Indent, 5);
|
|
|
|
// Now Sub Entries
|
|
if Item.Children.Count > 0 then begin
|
|
WriteString('<UL>');
|
|
Inc(Indent, 8);
|
|
WriteEntries(Item.Children);
|
|
Dec(Indent, 8);
|
|
WriteString('</UL>');
|
|
end;
|
|
end;
|
|
end;
|
|
begin
|
|
Indent := 0;
|
|
WriteString('<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">');
|
|
WriteString('<HTML>');
|
|
WriteString('<HEAD>');
|
|
WriteString('<meta name="GENERATOR" content="Microsoft® HTML Help Workshop 4.1">'); // Should we change this?
|
|
WriteString('<!-- Sitemap 1.0 -->');
|
|
WriteString('</HEAD><BODY>');
|
|
|
|
// Site Properties
|
|
WriteString('<OBJECT type="text/site properties">');
|
|
Inc(Indent, 8);
|
|
if SiteMapType = stTOC then begin
|
|
if FrameName <> '' then WriteParam('FrameName', FrameName);
|
|
if WindowName <> '' then WriteParam('WindowName', WindowName);
|
|
if ImageList <> '' then WriteParam('ImageList', ImageList);
|
|
if ImageWidth > 0 then WriteParam('Image Width', IntToStr(ImageWidth));
|
|
if BackgroundColor <> 0 then WriteParam('Background', hexStr(BackgroundColor, 4));
|
|
if ForegroundColor <> 0 then WriteParam('Foreground', hexStr(ForegroundColor, 4));
|
|
if ExWindowStyles <> 0 then WriteParam('ExWindow Styles', hexStr(ExWindowStyles, 4));
|
|
if WindowStyles <> 0 then WriteParam('Window Styles', hexStr(WindowStyles, 4));
|
|
if UseFolderImages then WriteParam('ImageType', 'Folder');
|
|
end;
|
|
// both TOC and Index have font
|
|
if Font <> '' then
|
|
WriteParam('Font', Font);
|
|
Dec(Indent, 8);
|
|
WriteString('</OBJECT>');
|
|
|
|
// And now the items
|
|
if Items.Count > 0 then begin
|
|
WriteString('<UL>');
|
|
Inc(Indent, 8);
|
|
// WriteEntries
|
|
WriteEntries(Items);
|
|
Dec(Indent, 8);
|
|
WriteString('</UL>');
|
|
end;
|
|
|
|
WriteString('</BODY></HTML>');
|
|
|
|
AStream.Size := AStream.Position;
|
|
end;
|
|
|
|
{ TChmSiteMapItem }
|
|
|
|
procedure TChmSiteMapItem.SetChildren(const AValue: TChmSiteMapItems);
|
|
begin
|
|
if FChildren = AValue then exit;
|
|
FChildren := AValue;
|
|
end;
|
|
|
|
constructor TChmSiteMapItem.Create(AOwner: TChmSiteMapItems);
|
|
begin
|
|
Inherited Create;
|
|
FOwner := AOwner;
|
|
FChildren := TChmSiteMapItems.Create(Owner.Owner, Self);
|
|
end;
|
|
|
|
destructor TChmSiteMapItem.Destroy;
|
|
begin
|
|
FChildren.Free;
|
|
Inherited Destroy;
|
|
end;
|
|
|
|
{ TChmSiteMapItems }
|
|
|
|
function TChmSiteMapItems.GetItem(AIndex: Integer): TChmSiteMapItem;
|
|
begin
|
|
Result := TChmSiteMapItem(FList.Items[AIndex]);
|
|
end;
|
|
|
|
function TChmSiteMapItems.GetCount: Integer;
|
|
begin
|
|
Result := FList.Count;
|
|
end;
|
|
|
|
procedure TChmSiteMapItems.SetItem(AIndex: Integer; const AValue: TChmSiteMapItem);
|
|
begin
|
|
FList.Items[AIndex] := AValue;
|
|
end;
|
|
|
|
constructor TChmSiteMapItems.Create(AOwner: TChmSiteMap; AParentItem: TChmSiteMapItem);
|
|
begin
|
|
FList := TList.Create;
|
|
FParentItem := AParentItem;
|
|
FOwner := AOwner;
|
|
FInternalData := maxLongint;
|
|
end;
|
|
|
|
destructor TChmSiteMapItems.Destroy;
|
|
begin
|
|
Clear;
|
|
FList.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TChmSiteMapItems.Delete(AIndex: Integer);
|
|
begin
|
|
Item[AIndex].Free;
|
|
FList.Delete(AIndex);
|
|
end;
|
|
|
|
function TChmSiteMapItems.Add(AItem: TChmSiteMapItem): Integer;
|
|
begin
|
|
Result := FList.Add(AItem);
|
|
end;
|
|
|
|
function TChmSiteMapItems.NewItem: TChmSiteMapItem;
|
|
begin
|
|
Result := TChmSiteMapItem.Create(Self);
|
|
Add(Result);
|
|
end;
|
|
|
|
function TChmSiteMapItems.Insert(AItem: TChmSiteMapItem; AIndex: Integer): Integer;
|
|
begin
|
|
Result := AIndex;
|
|
FList.Insert(AIndex, AItem);
|
|
end;
|
|
|
|
procedure TChmSiteMapItems.Clear;
|
|
var
|
|
I: LongInt;
|
|
begin
|
|
for I := Count-1 downto 0 do Delete(I);
|
|
end;
|
|
|
|
procedure TChmSiteMapItems.Sort(Compare: TListSortCompare);
|
|
begin
|
|
FList.Sort(Compare);
|
|
end;
|
|
|
|
end.
|
|
|