{ Copyright (C) <2005> chmdataprovider.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.modifiedLGPL, included in this distribution, for details about the copyright. } unit ChmDataProvider; {$mode objfpc}{$H+} interface uses Classes, SysUtils, IpHtml, iputils, IpMsg, Graphics, chmreader, LCLType, Controls, FPImage, {fpreadgif,} // doesn't exist yet! FPReadbmp, FPReadxpm, FPReadJPEg, FPReadpng, FPWritebmp, IntFGraphics; type THelpPopupEvent = procedure(HelpFile: String; URL: String); { TIpChmDataProvider } TIpChmDataProvider = class(TIpAbstractHtmlDataProvider) private fChm: TChmFileList; fCurrentPage: String; fCurrentPath: String; fOnHelpPopup: THelpPopupEvent; protected function DoGetHtmlStream(const URL: string; PostData: TIpFormDataEntity) : TStream; override; function DoCheckURL(const URL: string; var ContentType: string): Boolean; override; procedure DoLeave(Html: TIpHtml); override; procedure DoReference(const 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(var AChm: TChmFileList); 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; end; implementation { TIpChmDataProvider } function TIpChmDataProvider.DoGetHtmlStream(const URL: string; PostData: TIpFormDataEntity): TStream; begin Result := fChm.GetObject(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('Page cannot be found!',33); end; end; function TIpChmDataProvider.DoCheckURL(const URL: string; var ContentType: string): Boolean; var X: Integer; begin //DebugLn('RequestedUrl: ',URL); Result := fChm.ObjectExists(Url) > 0; if Result then begin ContentType := 'text/html'; fCurrentPath := ExtractFilePath(Url); if Pos('ms-its:', fCurrentPath) > 0 then begin X := Pos('::', fCurrentPath); fCurrentPath := Copy(fCurrentPath, X+2, Length(fCurrentPAth)-(X+1)); end; 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 = nil; ImageClass: TFPCustomImageReaderClass; ImageReader: TFPCustomImageReader; OutImage: TFPWriterBMP= nil; Img : TFPMemoryImage = nil; FileExt: String; begin //DebugLn('Getting Image ',(Url)); FileExt := ExtractFileExt(URL); if FileExt[1] = '.' then Delete(FileExt,1,1); ImageClass := GetFPImageReaderForFileExtension(FileExt); if ImageClass <> nil then begin ImageReader := ImageClass.Create; try Picture := TPicture.Create; Picture.Graphic := TBitmap.Create; Stream := TMemoryStream(fChm.GetObject('/'+URL)); if Stream = nil then exit; Img := TFPMemoryImage.Create(0,0); Img.UsePalette:=False; Img.LoadFromStream(Stream, ImageReader); Stream.Free; Stream := TMemoryStream.Create; OutImage := TFPWriterBMP.Create; Img.SaveToStream(Stream, OutImage); Stream.Position := 0; Picture.Graphic.LoadFromStream(Stream); finally if Assigned(OutImage) then OutImage.Free; if Assigned(Img) then Img.Free; if Assigned(ImageReader) then ImageReader.Free; if Assigned(Stream) then Stream.Free; end; end else begin // Couldn't find the picture we wanted. Picture := nil; end; end; function TIpChmDataProvider.CanHandle(const URL: string): Boolean; var HelpFile, Link: String; begin Result := True; if Pos('Java', URL) =1 then Result := False; if (fChm.ObjectExists(url)= 0) and (fChm.ObjectExists(BuildUrl(fCurrentPath,Url)) = 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 tmp: String; X: LongInt; RelURL: String = ''; fOldUrl: String; begin if Pos('ms-its:', OldURL) > 0 then begin X := Pos('::', OldUrl); fOldUrl := Copy(OldUrl, X+2, Length(OldUrl)-(X+2)); end else fOldUrl := OldURL; if Length(NewURL) < 1 then Exit(NewURL); if fChm.ObjectExists(NewURL) > 0 then begin Result := NewUrl; Exit; end; Result:=iputils.BuildURL(fOldurl,NewUrl); if NewURL[1] <> '/' then begin if fChm.ObjectExists(Result) > 0 then Tmp := Result else if fChm.ObjectExists('/'+Result) > 0 then begin Tmp := '/'+Result; end else if fChm.ObjectExists(fCurrentPath+Result) > 0 then begin Tmp := fCurrentPath+Result; end else if fChm.ObjectExists(fCurrentPath+NewUrl) > 0 then begin Tmp := fCurrentPath+NewURL; end else if fChm.ObjectExists('/'+fCurrentPath+NewUrl) > 0 then begin Tmp := '/'+fCurrentPath+NewURL; end; Result := Tmp; end; X := Pos('//', Result); while X > 0 do begin Delete(Result, X ,1); X := Pos('//', Result); end; end; function TIpChmDataProvider.GetDirsParents(ADir: String): TStringList; var X: Integer; Tmp: String; begin Result := TStringList.Create; //Result.Add(ADir); for X := Length(ADir) downto 1 do begin if ADir[X] = '/' then begin Tmp := Copy(ADir, 1, X); Result.Add(Tmp); end; end; 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(var AChm: TChmFileList); begin inherited Create(nil); fChm := AChm; end; destructor TIpChmDataProvider.Destroy; begin inherited Destroy; end; end.