mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-10-26 02:01:30 +01:00
260 lines
6.5 KiB
ObjectPascal
260 lines
6.5 KiB
ObjectPascal
{
|
|
*****************************************************************************
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
|
|
Copyright (C) <2005> <Andrew Haines> chmdataprovider.pas
|
|
|
|
}
|
|
unit ChmDataProvider;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, IpHtml, iputils, IpMsg, Graphics, chmreader,
|
|
LCLType, Controls,
|
|
FPImage,
|
|
{$IF FPC_FULLVERSION>=20602} //fpreadgif exists since at least this version
|
|
FPReadgif,
|
|
{$ENDIF}
|
|
FPReadbmp,
|
|
FPReadxpm,
|
|
FPReadJPEG,
|
|
FPReadpng,
|
|
FPWritebmp,
|
|
FPWritePNG,
|
|
IntFGraphics;
|
|
|
|
|
|
type
|
|
|
|
THelpPopupEvent = procedure(HelpFile: String; URL: String);
|
|
THtmlPageLoadStreamEvent = procedure (var AStream: TStream) of object;
|
|
|
|
{ TIpChmDataProvider }
|
|
|
|
TIpChmDataProvider = class(TIpAbstractHtmlDataProvider)
|
|
private
|
|
fChm: TChmFileList;
|
|
fCurrentPage: String;
|
|
fCurrentPath: String;
|
|
FOnGetHtmlPage: THtmlPageLoadStreamEvent;
|
|
fOnHelpPopup: THelpPopupEvent;
|
|
function StripInPageLink(AURL: String): String;
|
|
protected
|
|
function DoGetHtmlStream(const URL: string;
|
|
{%H-}PostData: TIpFormDataEntity) : TStream; override;
|
|
function DoCheckURL(const URL: string;
|
|
var ContentType: string): Boolean; override;
|
|
procedure DoLeave({%H-}Html: TIpHtml); override;
|
|
procedure DoReference(const {%H-}URL: string); override;
|
|
procedure DoGetImage(Sender: TIpHtmlNode; const URL: string;
|
|
var Picture: TPicture); override;
|
|
function CanHandle(const URL: string): Boolean; override;
|
|
function BuildURL(const OldURL, NewURL: string): string; override;
|
|
function GetDirsParents(ADir: String): TStringList;
|
|
function DoGetStream(const URL: string): TStream; override;
|
|
public
|
|
constructor Create(AOwner: TComponent; AChm: TChmFileList); reintroduce;
|
|
destructor Destroy; override;
|
|
property Chm: TChmFileList read fChm write fChm;
|
|
property OnHelpPopup: THelpPopupEvent read fOnHelpPopup write fOnHelpPopup;
|
|
property CurrentPage: String read fCurrentPage;
|
|
property CurrentPath: String read fCurrentPath write fCurrentPath;
|
|
property OnGetHtmlPage: THtmlPageLoadStreamEvent read FOnGetHtmlPage write FOnGetHtmlPage;
|
|
|
|
end;
|
|
|
|
implementation
|
|
|
|
{ TIpChmDataProvider }
|
|
|
|
function TIpChmDataProvider.StripInPageLink ( AURL: String ) : String;
|
|
var
|
|
i: LongInt;
|
|
begin
|
|
Result := AURL;
|
|
i := Pos('#', Result);
|
|
if i > 0 then
|
|
Result := Copy(Result, 1, i-1);
|
|
end;
|
|
|
|
function TIpChmDataProvider.DoGetHtmlStream(const URL: string;
|
|
PostData: TIpFormDataEntity): TStream;
|
|
begin
|
|
Result := fChm.GetObject(StripInPageLink(URL));
|
|
// If for some reason we were not able to get the page return something so that
|
|
// we don't cause an AV
|
|
if Result = nil then begin
|
|
Result := TMemoryStream.Create;
|
|
Result.Write('<HTML>Page cannot be found!</HTML>',33);
|
|
end;
|
|
if Assigned(FOnGetHtmlPage) then
|
|
FOnGetHtmlPage(Result);
|
|
end;
|
|
|
|
function TIpChmDataProvider.DoCheckURL(const URL: string;
|
|
var ContentType: string): Boolean;
|
|
var
|
|
Reader: TChmReader = nil;
|
|
begin
|
|
//DebugLn('RequestedUrl: ',URL);
|
|
Result := fChm.ObjectExists(StripInPageLink(Url), Reader) > 0;
|
|
if Result then begin
|
|
ContentType := 'text/html';
|
|
fCurrentPath := ExtractFilePath(Url);
|
|
Result := True;
|
|
fCurrentPage := URL;
|
|
end;
|
|
end;
|
|
|
|
procedure TIpChmDataProvider.DoLeave(Html: TIpHtml);
|
|
begin
|
|
//
|
|
// //DebugLn('Left: ');
|
|
end;
|
|
|
|
procedure TIpChmDataProvider.DoReference(const URL: string);
|
|
begin
|
|
//
|
|
////DebugLn('Reference=',URL);
|
|
end;
|
|
|
|
procedure TIpChmDataProvider.DoGetImage(Sender: TIpHtmlNode; const URL: string;
|
|
var Picture: TPicture);
|
|
var
|
|
Stream: TMemoryStream;
|
|
FileExt: String;
|
|
begin
|
|
//DebugLn('Getting Image ',(Url));
|
|
Picture := nil;
|
|
|
|
FileExt := ExtractFileExt(URL);
|
|
|
|
Picture := TPicture.Create;
|
|
Stream := fChm.GetObject('/'+URL);
|
|
try
|
|
if Assigned(Stream) then
|
|
begin
|
|
Stream.Position := 0;
|
|
Picture.LoadFromStreamWithFileExt(Stream, FileExt);
|
|
end;
|
|
except
|
|
// only happens if it's an image type we can't handle
|
|
end;
|
|
if Stream <> nil then
|
|
Stream.Free;
|
|
end;
|
|
|
|
function TIpChmDataProvider.CanHandle(const URL: string): Boolean;
|
|
var
|
|
HelpFile: String;
|
|
Reader: TChmReader = nil;
|
|
begin
|
|
Result := True;
|
|
if Pos('Java', URL) =1 then Result := False;
|
|
if (fChm.ObjectExists(StripInPageLink(url), Reader)= 0)
|
|
and (fChm.ObjectExists(StripInPageLink(BuildUrl(fCurrentPath,Url)), Reader) = 0) then Result := False;
|
|
//DebugLn('CanHandle ',Url,' = ', Result);
|
|
//if not Result then if fChm.ObjectExists(BuildURL('', URL)) > 0 Then result := true;
|
|
if Pos('javascript:helppopup(''', LowerCase(URL)) = 1 then begin
|
|
HelpFile := Copy(URL, 23, Length(URL) - (23-1));
|
|
HelpFile := Copy(HelpFile, 1, Pos('''', HelpFile)-1);
|
|
//DebugLn('HelpFile = ', HelpFile);
|
|
end;
|
|
if (not Result) and (Pos('#', URL) = 1) then Result := True;
|
|
end;
|
|
|
|
function TIpChmDataProvider.BuildURL(const OldURL, NewURL: string): string;
|
|
var
|
|
X: LongInt;
|
|
fNewURL: String;
|
|
ParentDirs: TStringList;
|
|
RemoveDirCount: Integer;
|
|
begin
|
|
Result := NewURL;
|
|
|
|
fNewURL := NewURL;
|
|
if Pos('ms-its:', NewURL) = 1 then
|
|
Exit;
|
|
|
|
ParentDirs := GetDirsParents(OldURL);
|
|
RemoveDirCount := 0;
|
|
repeat
|
|
X := Pos('../', fNewURL);
|
|
if X > 0 then
|
|
begin
|
|
Delete(fNewURL, X, 3);
|
|
Inc(RemoveDirCount);
|
|
end;
|
|
until X = 0;
|
|
|
|
repeat
|
|
X := Pos('./', fNewURL);
|
|
if X > 0 then
|
|
Delete(fNewURL, X, 2);
|
|
until X = 0;
|
|
|
|
Result := '';
|
|
for X := 0 to ParentDirs.Count-RemoveDirCount-1 do
|
|
Result := Result + ParentDirs[X] + '/';
|
|
|
|
Result := Result+fNewURL;
|
|
|
|
repeat
|
|
X := Pos('//', Result);
|
|
if X > 0 then
|
|
Delete(Result, X, 1);
|
|
until X = 0;
|
|
|
|
ParentDirs.Free;
|
|
//WriteLn('res = ', Result);
|
|
end;
|
|
|
|
function TIpChmDataProvider.GetDirsParents(ADir: String): TStringList;
|
|
var
|
|
LastName: String;
|
|
begin
|
|
Result := TStringList.Create;
|
|
Result.Delimiter := '/';
|
|
Result.DelimitedText := ADir;
|
|
|
|
LastName := ExtractFileName(ADir);
|
|
if LastName <> '' then
|
|
Result.Delete(Result.Count-1);
|
|
if Result[Result.Count-1] = '' then
|
|
Result.Delete(Result.Count-1);
|
|
end;
|
|
|
|
function TIpChmDataProvider.DoGetStream(const URL: string): TStream;
|
|
var
|
|
NewURL: String;
|
|
begin
|
|
Result := nil;
|
|
if Length(URL) = 0 then
|
|
Exit;
|
|
if not (URL[1] in ['/']) then
|
|
NewURL := BuildUrl(fCurrentPath,URL)
|
|
else
|
|
NewURL := URL;
|
|
|
|
Result := fChm.GetObject(NewURL);
|
|
end;
|
|
|
|
constructor TIpChmDataProvider.Create(AOwner: TComponent; AChm: TChmFileList);
|
|
begin
|
|
inherited Create(AOwner);
|
|
fChm := AChm;
|
|
end;
|
|
|
|
destructor TIpChmDataProvider.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
end;
|
|
|
|
end.
|
|
|