mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-18 02:39:37 +02:00
IDEIntf: started htmlcontrol interface
git-svn-id: trunk@13529 -
This commit is contained in:
mattias
parent
d3a6947d40
commit
26aebf8d14
@ -34,8 +34,8 @@ interface
|
||||
|
||||
uses
|
||||
// FCL+LCL
|
||||
Classes, SysUtils, LCLProc, Forms, Controls, Buttons, StdCtrls, Dialogs,
|
||||
ExtCtrls, LResources, FileUtil,
|
||||
Classes, SysUtils, AVL_Tree, LCLProc, Forms, Controls, Buttons, StdCtrls,
|
||||
Dialogs, ExtCtrls, LResources, FileUtil,
|
||||
// CodeTools
|
||||
BasicCodeTools, CodeToolManager, CodeAtom, CodeCache, CustomCodeTool, CodeTree,
|
||||
PascalParserTool, FindDeclarationTool,
|
||||
@ -50,6 +50,63 @@ uses
|
||||
IDEContextHelpEdit;
|
||||
|
||||
type
|
||||
|
||||
TLIHProviders = class;
|
||||
|
||||
{ TLazIDEHTMLProvider }
|
||||
|
||||
TLazIDEHTMLProvider = class(TAbstractIDEHTMLProvider)
|
||||
private
|
||||
FProviders: TLIHProviders;
|
||||
procedure SetProviders(const AValue: TLIHProviders);
|
||||
public
|
||||
function GetStream(const URL: string): TStream; override;
|
||||
procedure ReleaseStream(const URL: string); override;
|
||||
property Providers: TLIHProviders read FProviders write SetProviders;
|
||||
end;
|
||||
|
||||
{ TLIHProviderStream }
|
||||
|
||||
TLIHProviderStream = class
|
||||
private
|
||||
FRefCount: integer;
|
||||
public
|
||||
Stream: TStream;
|
||||
URL: string;
|
||||
destructor Destroy; override;
|
||||
procedure IncreaseRefCount;
|
||||
procedure DecreaseRefCount;
|
||||
property RefCount: integer read FRefCount;
|
||||
end;
|
||||
|
||||
{ TLIHProviders
|
||||
manages all TLazIDEHTMLProvider }
|
||||
|
||||
TLIHProviders = class
|
||||
private
|
||||
FStreams: TAVLTree;// tree of TLIHProviderStream sorted for URL
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
function FindStream(const URL: string; CreateIfNotExists: Boolean): TLIHProviderStream;
|
||||
function GetStream(const URL: string): TStream;
|
||||
procedure ReleaseStream(const URL: string);
|
||||
end;
|
||||
|
||||
{ TSimpleHTMLControl }
|
||||
|
||||
TSimpleHTMLControl = class(TLabel,TIDEHTMLControlIntf)
|
||||
private
|
||||
FProvider: TAbstractIDEHTMLProvider;
|
||||
FURL: string;
|
||||
procedure SetProvider(const AValue: TAbstractIDEHTMLProvider);
|
||||
function HTMLToCaption(const s: string): string;
|
||||
public
|
||||
function GetURL: string;
|
||||
procedure SetURL(const AValue: string);
|
||||
property Provider: TAbstractIDEHTMLProvider read FProvider write SetProvider;
|
||||
end;
|
||||
|
||||
{ TIDEHelpDatabases }
|
||||
|
||||
TIDEHelpDatabases = class(THelpDatabases)
|
||||
@ -83,6 +140,7 @@ type
|
||||
FFCLHelpDB: THelpDatabase;
|
||||
FLCLHelpDB: THelpDatabase;
|
||||
FRTLHelpDBPath: THelpBaseURLObject;
|
||||
FHTMLProviders: TLIHProviders;
|
||||
procedure RegisterIDEHelpDatabases;
|
||||
procedure RegisterDefaultIDEHelpViewers;
|
||||
procedure FindDefaultBrowser(var DefaultBrowser, Params: string);
|
||||
@ -162,6 +220,258 @@ var
|
||||
|
||||
implementation
|
||||
|
||||
function LazCreateIDEHTMLControl(Owner: TComponent;
|
||||
var Provider: TAbstractIDEHTMLProvider): TControl;
|
||||
var
|
||||
HTMLControl: TSimpleHTMLControl;
|
||||
begin
|
||||
HTMLControl:=TSimpleHTMLControl.Create(Owner);
|
||||
Result:=HTMLControl;
|
||||
if Provider=nil then
|
||||
Provider:=CreateIDEHTMLProvider(Owner);
|
||||
Provider.ControlIntf:=HTMLControl;
|
||||
HTMLControl.Provider:=Provider;
|
||||
end;
|
||||
|
||||
function LazCreateIDEHTMLProvider(Owner: TComponent): TAbstractIDEHTMLProvider;
|
||||
begin
|
||||
Result:=TLazIDEHTMLProvider.Create(Owner);
|
||||
TLazIDEHTMLProvider(Result).Providers:=THelpManager(HelpBoss).FHTMLProviders;
|
||||
end;
|
||||
|
||||
function CompareLIHProviderStream(Data1, Data2: Pointer): integer;
|
||||
begin
|
||||
Result:=CompareStr(TLIHProviderStream(Data1).URL,TLIHProviderStream(Data2).URL);
|
||||
end;
|
||||
|
||||
function CompareURLWithLIHProviderStream(URL, Stream: Pointer): integer;
|
||||
begin
|
||||
Result:=CompareStr(AnsiString(URL),TLIHProviderStream(Stream).URL);
|
||||
end;
|
||||
|
||||
{ TSimpleHTMLControl }
|
||||
|
||||
procedure TSimpleHTMLControl.SetProvider(const AValue: TAbstractIDEHTMLProvider
|
||||
);
|
||||
begin
|
||||
if FProvider=AValue then exit;
|
||||
FProvider:=AValue;
|
||||
end;
|
||||
|
||||
function TSimpleHTMLControl.HTMLToCaption(const s: string): string;
|
||||
var
|
||||
p: Integer;
|
||||
EndPos: Integer;
|
||||
begin
|
||||
Result:=s;
|
||||
p:=1;
|
||||
while p<=length(Result) do begin
|
||||
if Result[p]='<' then begin
|
||||
// skip html tag
|
||||
EndPos:=p+1;
|
||||
while (EndPos<=length(Result)) do begin
|
||||
if Result[EndPos]='"' then begin
|
||||
// skip " tag
|
||||
while (EndPos<=length(Result)) and (Result[EndPos]<>'"') do
|
||||
inc(EndPos);
|
||||
if EndPos>length(Result) then break;
|
||||
end;
|
||||
if (Result[EndPos]='>') then begin
|
||||
inc(EndPos);
|
||||
break;
|
||||
end;
|
||||
inc(EndPos);
|
||||
end;
|
||||
System.Delete(Result,p,EndPos-p);
|
||||
end else
|
||||
inc(p);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSimpleHTMLControl.GetURL: string;
|
||||
begin
|
||||
Result:=FURL;
|
||||
end;
|
||||
|
||||
procedure TSimpleHTMLControl.SetURL(const AValue: string);
|
||||
var
|
||||
Stream: TStream;
|
||||
s: string;
|
||||
NewURL: String;
|
||||
begin
|
||||
if Provider=nil then raise Exception.Create('TSimpleHTMLControl.SetURL missing Provider');
|
||||
if FURL=AValue then exit;
|
||||
NewURL:=Provider.BuildURL(Provider.BaseURL,AValue);
|
||||
if FURL=NewURL then exit;
|
||||
FURL:=NewURL;
|
||||
try
|
||||
Stream:=Provider.GetStream(FURL);
|
||||
SetLength(s,Stream.Size);
|
||||
if s<>'' then
|
||||
Stream.Read(s[1],length(s));
|
||||
Caption:=HTMLToCaption(s);
|
||||
Provider.ReleaseStream(FURL);
|
||||
except
|
||||
on E: Exception do begin
|
||||
Caption:=E.Message;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TLazIDEHTMLProvider }
|
||||
|
||||
procedure TLazIDEHTMLProvider.SetProviders(const AValue: TLIHProviders);
|
||||
begin
|
||||
if FProviders=AValue then exit;
|
||||
FProviders:=AValue;
|
||||
end;
|
||||
|
||||
function TLazIDEHTMLProvider.GetStream(const URL: string): TStream;
|
||||
begin
|
||||
Result:=FProviders.GetStream(URL);
|
||||
end;
|
||||
|
||||
procedure TLazIDEHTMLProvider.ReleaseStream(const URL: string);
|
||||
begin
|
||||
FProviders.ReleaseStream(URL);
|
||||
end;
|
||||
|
||||
{ TLIHProviders }
|
||||
|
||||
constructor TLIHProviders.Create;
|
||||
begin
|
||||
FStreams:=TAVLTree.Create(@CompareLIHProviderStream);
|
||||
end;
|
||||
|
||||
destructor TLIHProviders.Destroy;
|
||||
begin
|
||||
FStreams.FreeAndClear;
|
||||
FreeAndNil(FStreams);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TLIHProviders.FindStream(const URL: string; CreateIfNotExists: Boolean
|
||||
): TLIHProviderStream;
|
||||
var
|
||||
Node: TAVLTreeNode;
|
||||
begin
|
||||
if URL='' then
|
||||
exit(nil);
|
||||
Node:=FStreams.FindKey(Pointer(URL),@CompareURLWithLIHProviderStream);
|
||||
if Node<>nil then begin
|
||||
Result:=TLIHProviderStream(Node.Data);
|
||||
end else if CreateIfNotExists then begin
|
||||
Result:=TLIHProviderStream.Create;
|
||||
Result.URL:=URL;
|
||||
FStreams.Add(Result);
|
||||
end else
|
||||
Result:=nil;
|
||||
end;
|
||||
|
||||
function TLIHProviders.GetStream(const URL: string): TStream;
|
||||
|
||||
procedure OpenFile(out Stream: TStream; const Filename: string);
|
||||
var
|
||||
fs: TFileStream;
|
||||
ok: Boolean;
|
||||
begin
|
||||
fs:=nil;
|
||||
ok:=false;
|
||||
try
|
||||
fs:=TFileStream.Create(Filename,fmOpenRead);
|
||||
//DebugLn(['OpenFile ',Filename,' ',fs.Size,' ',fs.Position]);
|
||||
Stream:=fs;
|
||||
ok:=true;
|
||||
finally
|
||||
if not ok then
|
||||
fs.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{const
|
||||
HTML =
|
||||
'<HTML>'+#10
|
||||
+'<BODY>'+#10
|
||||
+'Test'+#10
|
||||
+'</BODY>'+#10
|
||||
+'</HTML>';}
|
||||
var
|
||||
Stream: TLIHProviderStream;
|
||||
URLType: string;
|
||||
URLPath: string;
|
||||
URLParams: string;
|
||||
begin
|
||||
if URL='' then raise Exception.Create('TLIHProviders.GetStream no URL');
|
||||
Stream:=FindStream(URL,true);
|
||||
Stream.IncreaseRefCount;
|
||||
Result:=Stream.Stream;
|
||||
try
|
||||
if Result=nil then begin
|
||||
SplitURL(URL,URLType,URLPath,URLParams);
|
||||
DebugLn(['TLIHProviders.GetStream URLType=',URLType,' URLPath=',URLPath,' URLParams=',URLParams]);
|
||||
if URLType='lazdoc' then begin
|
||||
if copy(URLPath,1,8)='lazarus/' then begin
|
||||
URLPath:=copy(URLPath,9,length(URLPath));
|
||||
if (URLPath='index.html')
|
||||
or (URLPath='images/laztitle.jpg')
|
||||
or (URLPath='images/cheetah1.png') then begin
|
||||
OpenFile(Result,'/home/mattias/pascal/wichtig/lazarus/docs/'+URLPath);
|
||||
end;
|
||||
end;
|
||||
end else begin
|
||||
|
||||
end;
|
||||
{Result:=TMemoryStream.Create;
|
||||
Stream.Stream:=Result;
|
||||
Result.Write(HTML[1],length(HTML));
|
||||
Result.Position:=0;}
|
||||
if Result=nil then
|
||||
raise Exception.Create('TLIHProviders.GetStream: URL not found "'+dbgstr(URL)+'"');
|
||||
Stream.Stream:=Result;
|
||||
end;
|
||||
finally
|
||||
if Result=nil then
|
||||
ReleaseStream(URL);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TLIHProviders.ReleaseStream(const URL: string);
|
||||
var
|
||||
Stream: TLIHProviderStream;
|
||||
begin
|
||||
Stream:=FindStream(URL,false);
|
||||
if Stream=nil then
|
||||
raise Exception.Create('TLIHProviders.ReleaseStream "'+URL+'"');
|
||||
Stream.DecreaseRefCount;
|
||||
if Stream.RefCount=0 then begin
|
||||
FStreams.Remove(Stream);
|
||||
Stream.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TLIHProviderStream }
|
||||
|
||||
destructor TLIHProviderStream.Destroy;
|
||||
begin
|
||||
FreeAndNil(Stream);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TLIHProviderStream.IncreaseRefCount;
|
||||
begin
|
||||
inc(FRefCount);
|
||||
end;
|
||||
|
||||
procedure TLIHProviderStream.DecreaseRefCount;
|
||||
begin
|
||||
if FRefCount<=0 then
|
||||
raise Exception.Create('TLIHProviderStream.DecreaseRefCount');
|
||||
dec(FRefCount);
|
||||
end;
|
||||
|
||||
{ THelpSelectorDialog }
|
||||
|
||||
procedure THelpSelectorDialog.HelpSelectorDialogClose(Sender: TObject;
|
||||
var CloseAction: TCloseAction);
|
||||
begin
|
||||
@ -438,10 +748,18 @@ begin
|
||||
// register property editors for URL handling
|
||||
RegisterPropertyEditor(TypeInfo(AnsiString),
|
||||
THTMLHelpDatabase,'BaseURL',TURLDirectoryPropertyEditor);
|
||||
|
||||
FHTMLProviders:=TLIHProviders.Create;
|
||||
|
||||
if CreateIDEHTMLControl=nil then
|
||||
CreateIDEHTMLControl:=@LazCreateIDEHTMLControl;
|
||||
if CreateIDEHTMLProvider=nil then
|
||||
CreateIDEHTMLProvider:=@LazCreateIDEHTMLProvider;
|
||||
end;
|
||||
|
||||
destructor THelpManager.Destroy;
|
||||
begin
|
||||
FreeThenNil(FHTMLProviders);
|
||||
FreeThenNil(CodeHelpBoss);
|
||||
FPCMessagesHelpDB:=nil;
|
||||
FreeThenNil(HelpDatabases);
|
||||
|
||||
@ -23,7 +23,7 @@ unit IDEHelpIntf;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, HelpIntfs, LazHelpIntf, TextTools;
|
||||
Classes, SysUtils, Controls, HelpIntfs, LazHelpIntf, TextTools;
|
||||
|
||||
type
|
||||
{ THelpDBIRegExprMessage
|
||||
@ -65,12 +65,58 @@ type
|
||||
function ConvertSourcePosToPascalHelpContext(const CaretPos: TPoint;
|
||||
const Filename: string): TPascalHelpContextList; virtual; abstract;
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
LazarusHelp: TBaseHelpManager; // initialized by the IDE
|
||||
|
||||
|
||||
type
|
||||
{ TIDEHTMLControlIntf }
|
||||
|
||||
TIDEHTMLControlIntf = interface
|
||||
function GetURL: string;
|
||||
procedure SetURL(const AValue: string);
|
||||
property URL: string read GetURL write SetURL;
|
||||
end;
|
||||
|
||||
{ TAbstractIDEHTMLProvider
|
||||
An instance of this class connects 3 parts:
|
||||
1. IDE html files (via implementation)
|
||||
2. a html viewer control (via ControlIntf)
|
||||
3. IDE or designtime package code
|
||||
All three can communicate. }
|
||||
|
||||
TAbstractIDEHTMLProvider = class(TComponent)
|
||||
protected
|
||||
FBaseURL: string;
|
||||
FControlIntf: TIDEHTMLControlIntf;
|
||||
procedure SetBaseURL(const AValue: string); virtual;
|
||||
procedure SetControlIntf(const AValue: TIDEHTMLControlIntf); virtual;
|
||||
public
|
||||
function GetStream(const URL: string
|
||||
): TStream; virtual; abstract; { provider assumes ownership of returned TStream
|
||||
and increases internal reference count.
|
||||
If not found it raises an exception. }
|
||||
procedure ReleaseStream(const URL: string); virtual; abstract;
|
||||
property BaseURL: string read FBaseURL write SetBaseURL;// fallback for relative URLs
|
||||
function BuildURL(const CurBaseURL, CurURL: string): string; virtual;
|
||||
property ControlIntf: TIDEHTMLControlIntf read FControlIntf write SetControlIntf;
|
||||
end;
|
||||
|
||||
TCreateIDEHTMLControlEvent =
|
||||
function(Owner: TComponent; var Provider: TAbstractIDEHTMLProvider): TControl;
|
||||
TCreateIDEHTMLProviderEvent =
|
||||
function(Owner: TComponent): TAbstractIDEHTMLProvider;
|
||||
|
||||
var
|
||||
CreateIDEHTMLControl: TCreateIDEHTMLControlEvent = nil;// will be set by the IDE
|
||||
// and overidden by a package like turbopoweriprodsgn.lpk
|
||||
CreateIDEHTMLProvider: TCreateIDEHTMLProviderEvent = nil;// will be set by the IDE
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
{ THelpDBIRegExprMessage }
|
||||
|
||||
constructor THelpDBIRegExprMessage.Create(TheNode: THelpNode;
|
||||
@ -88,5 +134,41 @@ begin
|
||||
//writeln('THelpDBIRegExprMessage.MessageMatches TheMessage="',TheMessage,'" Expression="',Expression,'" Result=',Result);
|
||||
end;
|
||||
|
||||
{ TAbstractIDEHTMLProvider }
|
||||
|
||||
procedure TAbstractIDEHTMLProvider.SetBaseURL(const AValue: string);
|
||||
begin
|
||||
if FBaseURL=AValue then exit;
|
||||
FBaseURL:=AValue;
|
||||
end;
|
||||
|
||||
procedure TAbstractIDEHTMLProvider.SetControlIntf(
|
||||
const AValue: TIDEHTMLControlIntf);
|
||||
begin
|
||||
if FControlIntf=AValue then exit;
|
||||
FControlIntf:=AValue;
|
||||
end;
|
||||
|
||||
function TAbstractIDEHTMLProvider.BuildURL(const CurBaseURL, CurURL: string
|
||||
): string;
|
||||
var
|
||||
URLType: string;
|
||||
URLPath: string;
|
||||
URLParams: string;
|
||||
begin
|
||||
Result:=CurURL;
|
||||
SplitURL(CurURL,URLType,URLPath,URLParams);
|
||||
//DebugLn(['TAbstractIDEHTMLProvider.BuildURL CurURL=',CurURL,' URLType=',URLType,' URLPath=',URLPath,' URLParams=',URLParams]);
|
||||
if URLType='' then begin
|
||||
// no URLType => use CurURL as URLPath
|
||||
Result:=CurURL;
|
||||
//DebugLn(['TAbstractIDEHTMLProvider.BuildURL AAA1 ',Result]);
|
||||
if not URLFilenameIsAbsolute(Result) then
|
||||
Result:=CurBaseURL+Result;
|
||||
end else begin
|
||||
Result:=CurURL;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
|
||||
@ -525,7 +525,7 @@ begin
|
||||
ok:=false;
|
||||
try
|
||||
NewGraphic.OnProgress := @Progress;
|
||||
DebugLn(['TPicture.LoadFromStreamWithFileExt ',Stream.Position,' ',Stream.Size,' ',DbgSName(Stream)]);
|
||||
//DebugLn(['TPicture.LoadFromStreamWithFileExt ',Stream.Position,' ',Stream.Size,' ',DbgSName(Stream)]);
|
||||
NewGraphic.LoadFromStream(Stream);
|
||||
ok:=true;
|
||||
finally
|
||||
|
||||
@ -641,7 +641,7 @@ begin
|
||||
ColonPos:=1;
|
||||
while (ColonPos<=len) and (URL[ColonPos]<>':') do
|
||||
inc(ColonPos);
|
||||
if ColonPos=len then exit;
|
||||
if ColonPos>len then exit;
|
||||
// get URLType
|
||||
URLType:=copy(URL,1,ColonPos-1);
|
||||
URLStartPos:=ColonPos+1;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user