mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-29 09:07:44 +01:00
aee454aa3c
- r54872 #f9266d01ea lhelp: Fix lhelp to show popup hints. Issue #31732. - r54874 #dbe072e701 Menu designer: Call GlobalDesignHook.Modified after adding an item. Issue #31791. - r54875 #b8d6c0d8dc gridexamples: in title_image_demo show images at start, adapt height of header row to image layout) (http://forum.lazarus.freepascal.org/index.php/topic,36841.0.html) - r54877 #cd4add856f Examples: Minor improvements of sample project motiongraphics (http://forum.lazarus.freepascal.org/index.php/topic,36858.msg245986.html) - r54878 #5377b0e786 Examples: Improved usability of demo "openurltest". - r54881 #c5cf593797 Examples: Fix crash of demo "propstorage" (http://forum.lazarus.freepascal.org/index.php/topic,36862.msg246019/topicseen.html). - r54812 #e3f7770451 lcl: grids: disable VisualChange and UpdateSizes if AutoSize is disabled. Solves part of Issue #31715 - r54813 #ede8a86d9d lcl: support for DebugDisableAutoSizing compiler define - r54815 #118cfb3d98 lcl: wincontrol: ignore FBoundsRealized in WM_SIZE. Solves part of Issue #31715 - r54816 #43e271b439 lcl: grids: Hi-DPI: row heights and column width. New default (system) value is -1. Solves part of Issue #31715 - r54817 #76e4dccfaa lcl: grids: ignore WMSIZE when updating scrollbars. Solves part of Issue #31715 - r54840 lcl: grids: fix scrolling after r54816 #43e271b439, Issue #31715 - r54841 #5fc40612bc lcl: grids: scroll to highest possible value if col/row are out of valid bounds. Related to Issue #31766 - r54842 lcl: dbgrids: adapt after r54816 #43e271b439. Issue #31765 and #31715 - r54843 ide: packager: adapt after r54816 #43e271b439. Issue #31762 and #31715 - r54844 #92cf9781fa lcl: grids: make GetDefaultRowHeight and *ColWidth public. Issue #31762 and #31715 - r54882 #3ba0ca06c3 lcl: grids: make default value for DefRowHeight and DefColWidth 0 and not -1 (due to LCL consistency). Issue #31715 - r54883 #bff91a4961 lcl: grids: rename GetRealDefaultColWidth and GetRealDefaultRowHeight to GetRealDef* (LCL consistency). Issue #31715 git-svn-id: branches/fixes_1_8@54884 -
274 lines
6.7 KiB
ObjectPascal
274 lines
6.7 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,
|
|
lhelpstrconsts;
|
|
|
|
|
|
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;
|
|
var Tmp:string;
|
|
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;
|
|
Tmp := '<HTML>' + slhelp_PageCannotBeFound + '</HTML>';
|
|
Result.Write(Tmp,Length(tmp));
|
|
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
|
|
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 (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 OldURL = '' then
|
|
exit;
|
|
|
|
if Pos('ms-its:', NewURL) = 1 then begin
|
|
if Pos('#', NewURL) = 0 then
|
|
exit;
|
|
X := Pos('::', NewURL);
|
|
if NewURL[X+2] = '/' then // NewURL is complete and absolute --> nothing to do
|
|
exit;
|
|
fNewURL := Copy(fNewURL, X+3, MaxInt);
|
|
end;
|
|
|
|
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.StrictDelimiter := true;
|
|
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.
|
|
|