added ipfileboker.pas from Armin Diehl

git-svn-id: trunk@9513 -

.gitattributes

@@ -504,6 +504,7 @@ components/turbopower_ipro/ipanim.pas svneol=native#text/pascal
 components/turbopower_ipro/ipconst.pas svneol=native#text/pascal
 components/turbopower_ipro/ipdefct.inc svneol=native#text/pascal
 components/turbopower_ipro/ipdefine.inc svneol=native#text/pascal
+components/turbopower_ipro/ipfilebroker.pas svneol=native#text/plain
 components/turbopower_ipro/iphtml.lrs svneol=native#text/pascal
 components/turbopower_ipro/iphtml.pas svneol=native#text/pascal
 components/turbopower_ipro/iphtmlpv.lfm svneol=native#text/plain

components/turbopower_ipro/ipdefine.inc

@@ -33,7 +33,7 @@
        so options specified here could be overridden by hardcoded
        options in the unit source file.}
 
-{$IFDEF FPC}
+{$IFDEF LCL}
 {$DEFINE IP_LAZARUS}
 {$ENDIF}
 

components/turbopower_ipro/ipfilebroker.pas

@@ -0,0 +1,390 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower Internet Professional
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 2000-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+(* Part of Ipbroker.pas allowing to use local files  Armin <diehl@nordrhein.de> Jun 2006 *)
+
+unit Ipfilebroker;
+
+{$I ipdefine.inc}
+
+interface
+
+{$IFDEF IP_LAZARUS}
+uses Classes, SysUtils, LResources, Graphics, LCLProc,
+     ipconst, iputils, iphtml, ipmsg;
+{$ELSE}
+uses
+  Windows, SysUtils, Graphics, Classes, Dialogs, ShellApi,
+
+  IpConst, IpUtils, IpSock, IpCache, IpHtml, IpHttp, IpMsg, IpStrms, IpFtp;
+{$ENDIF}
+
+const
+  IP_DEFAULT_SCHEME : string = 'HTTP';
+
+{$IFDEF IP_LAZARUS}
+function expandLocalHtmlFileName (URL : string) : string;
+{$ENDIF}
+
+type
+
+TIpGetHtmlDataEvent =
+    procedure(Sender : TObject; const URL : string; const PostData : TIpFormDataEntity; var Stream : TStream) of object;
+  TIpGetImageDataEvent =
+    procedure(Sender : TIpHtmlNode; const URL : string; var Picture : TPicture) of object;
+  TIpLeaveHtmlDocumentEvent =
+    procedure(Sender : TIpHtml) of object;
+  TIpCheckURLEvent =
+    procedure(Sender : TObject; const URL : string; var Available :Boolean; var ContentType : string) of object;
+  TIpReportReferenceEvent =
+    procedure(Sender : TObject; const URL : string) of object;
+  TIpExternalResourceEvent =
+    procedure(Sender : TObject; const URL : string) of object;
+  TIpCanHandleEvent =
+    function(Sender : TObject; const URL : string) : Boolean of object;
+
+
+TIpCustomHtmlDataProvider = class(TIpAbstractHtmlDataProvider)
+  private
+    FProtocols : TStrings;
+    FGetHtml : TIpGetHtmlDataEvent;
+    FGetImage : TIpGetImageDataEvent;
+    FLeave : TIpLeaveHtmlDocumentEvent;
+    FCheckURL : TIpCheckURLEvent;
+    FReportReference : TIpReportReferenceEvent;
+    FCanHandle : TIpCanHandleEvent;
+    function GetProtocols : TStrings;
+    procedure SetProtocols(const Value : TStrings);
+  protected
+    // Nothing
+  public
+    constructor Create(AOwner : TComponent); override;
+    destructor Destroy; override;
+
+    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 GetHtmlStream(const URL : string; PostData : TIpFormDataEntity) : TStream; virtual;
+    function CheckURL(const URL : string; var ContentType : string) : Boolean; virtual;
+    procedure Leave(Html : TIpHtml); virtual;
+    procedure Reference(const URL : string); virtual;
+    procedure GetImage(Sender : TIpHtmlNode; const URL : string; var Picture : TPicture); virtual;
+    function CanHandle(const URL : string) : Boolean; override;
+    function BuildURL(const Old, New : string) : string; override;
+    property HandledProtocols : TStrings read GetProtocols write SetProtocols;
+    property OnCanHandle : TIpCanHandleEvent read FCanHandle write FCanhandle;
+    property OnGetHtml : TIpGetHtmlDataEvent read FGetHtml write FGetHtml;
+    property OnGetImage : TIpGetImageDataEvent read FGetImage write FGetImage;
+    property OnLeave : TIpLeaveHtmlDocumentEvent read FLeave write FLeave;
+    property OnCheckURL : TIpCheckURLEvent read FCheckURL write FCheckURL;
+    property OnReportReference : TIpReportReferenceEvent read FReportReference write FReportReference;
+  published
+    // Nothing
+  end;
+
+  TIpHtmlDataProvider = class(TIpCustomHtmlDataProvider)
+  public
+  published
+    property HandledProtocols;
+    property OnCanHandle;
+    property OnGetHtml;
+    property OnGetImage;
+    property OnLeave;
+    property OnCheckURL;
+    property OnReportReference;
+  end;
+
+  TIpFileDataProvider = class(TIpCustomHtmlDataProvider)
+  private
+    FOldURL : string;
+  public
+    constructor Create(AOwner : TComponent); override;
+    function GetHtmlStream(const URL : string; PostData : TIpFormDataEntity) : TStream; override;
+    function CheckURL(const URL : string; var ContentType : string) : Boolean; override;
+    procedure Leave(Html : TIpHtml); override;
+    procedure Reference(const URL : string); override;
+    procedure GetImage(Sender : TIpHtmlNode; const URL : string; var Picture : TPicture); override;
+    function CanHandle(const URL : string) : Boolean; override;
+  end;
+
+{$IFDEF IP_LAZARUS}
+procedure register;
+{$ENDIF}
+
+implementation
+
+{$IFDEF IP_LAZARUS}
+function expandLocalHtmlFileName (URL : string) : string;
+begin
+  if pos ('FILE://', ansiuppercase(URL)) = 0 then
+    result := 'file://'+DOSToNetPath(ExpandFileName(URL))
+  else
+    result := URL;
+end;
+{$ENDIF}
+
+{ TIpCustomHtmlDataProvider }
+constructor TIpCustomHtmlDataProvider.Create(AOwner : TComponent);
+begin
+  inherited Create(AOwner);
+  FProtocols := TStringList.Create;
+end;
+
+destructor TIpCustomHtmlDataProvider.Destroy;
+begin
+  FProtocols.Free;
+  inherited Destroy;
+end;
+
+function TIpCustomHtmlDataProvider.BuildURL(const Old,
+  New : string) : string;
+begin
+  Result := IpUtils.BuildURL(Old, New);
+  {$IFDEF IP_LAZARUS}
+  DebugLn('TIpCustomHtmlDataProvider.BuildURL Old="',old,'" new="',New,'"');
+  {$ENDIF}
+end;
+
+function TIpCustomHtmlDataProvider.CanHandle(const URL : string) : Boolean;
+var
+  AddrRec : TIpAddrRec;
+begin
+  Initialize(AddrRec);
+  if Assigned(FCanHandle) then begin
+    Result := FCanHandle(self, URL);
+  end
+  else begin
+    Result := False;
+    IpParseURL(URL, AddrRec);
+    if AddrRec.Scheme = '' then begin
+      if FProtocols.Count > 1 then
+        AddrRec.Scheme := FProtocols[1]
+      else
+        AddrRec.Scheme := IP_DEFAULT_SCHEME;
+    end;
+    if FProtocols.IndexOf(UpperCase(AddrRec.Scheme)) > -1 then
+      Result := True
+  end;
+  Initialize(AddrRec);
+  Finalize(AddrRec);
+end;
+
+function TIpCustomHtmlDataProvider.CheckURL(const URL : string;
+  var ContentType : string) : Boolean;
+begin
+  ContentType := '';
+  Result := False;
+end;
+
+function TIpCustomHtmlDataProvider.DoCheckURL(const URL : string;
+      var ContentType : string) : Boolean;
+begin
+  Result := False;
+  if Assigned(FCheckURL) then
+    FCheckURL(Self, URL, Result, ContentType)
+  else
+    Result := CheckURL(URL, ContentType);
+end;
+
+procedure TIpCustomHtmlDataProvider.DoGetImage(Sender : TIpHtmlNode;
+  const URL : string; var Picture : TPicture);
+begin
+  if Assigned(OnGetImage) then begin
+    OnGetImage(Sender, URL, Picture)
+  end
+  else
+    GetImage(Sender, URL, Picture);
+
+  if (Picture <> nil) then begin
+    if not (Picture is TPicture) then
+      raise Exception.Create(ProviderUnknownPicture);
+  end;
+end;
+
+procedure TIpCustomHtmlDataProvider.DoLeave;
+begin
+  if assigned(FLeave) then
+    FLeave(Html)
+  else
+    Leave(Html);
+end;
+
+procedure TIpCustomHtmlDataProvider.DoReference(const URL : string);
+begin
+  if assigned(FReportReference) then
+    FReportReference(Self, URL)
+  else
+    Reference(URL);
+end;
+
+function TIpCustomHtmlDataProvider.DoGetHtmlStream(const URL : string;
+  PostData : TIpFormDataEntity) : TStream;
+begin
+  Result := nil;
+  if Assigned(FGetHtml) then
+    FGetHtml(Self, URL, PostData, Result)
+  else
+    Result := GetHtmlStream(URL, PostData);
+end;
+
+function TIpCustomHtmlDataProvider.GetHtmlStream(const URL : string;
+  PostData : TIpFormDataEntity) : TStream;
+begin
+  { return defaults }
+  Result := nil;
+end;
+
+procedure TIpCustomHtmlDataProvider.GetImage(Sender : TIpHtmlNode;
+  const URL : string; var Picture : TPicture);
+begin
+  { return defaults }
+  Picture := nil;
+end;
+
+function TIpCustomHtmlDataProvider.GetProtocols : TStrings;
+begin
+  Result := FProtocols;
+end;
+
+procedure TIpCustomHtmlDataProvider.Leave(Html : TIpHtml);
+begin
+  { do nothing }
+end;
+
+procedure TIpCustomHtmlDataProvider.Reference(const URL : string);
+begin
+  { do nothing }
+end;
+
+procedure TIpCustomHtmlDataProvider.SetProtocols(const Value : TStrings);
+begin
+  FProtocols.Assign(Value);
+end;
+
+{ TIpFileDataProvider }
+constructor TIpFileDataProvider.Create(AOwner : TComponent);
+begin
+  inherited Create(AOwner);
+  HandledProtocols.Add('FILE');
+end;
+
+function TIpFileDataProvider.CanHandle(const URL : string) : Boolean;
+var
+  FileAddrRec : TIpAddrRec;
+  ContentType, FN : string;
+begin
+  Initialize(FileAddrRec);
+  {$IFDEF IP_LAZARUS}
+  DebugLn('TIpFileDataProvider.CanHandle('+URL+')');
+  {$ENDIF}
+  FN := BuildURL(FOldURL, URL);
+  IpParseURL(FN, FileAddrRec);
+  FN := NetToDosPath(FileAddrRec.Path);
+  {$IFDEF IP_LAZARUS}
+  DebugLn('TIpFileDataProvider.CanHandle FN="'+FN+'"');
+  {$ENDIF}
+  ContentType := UpperCase(GetLocalContent(FN));
+  Result := (FileExists(FN)) and ((Pos('TEXT/HTML', ContentType) > 0) or
+    (Pos('IMAGE/', ContentType) > 0));
+  Finalize(FileAddrRec);
+end;
+
+function TIpFileDataProvider.CheckURL(const URL : string;
+  var ContentType : string) : Boolean;
+var
+  FileAddrRec : TIpAddrRec;
+  FN : string;
+begin
+  Initialize(FileAddrRec);
+  IpParseURL(URL, FileAddrRec);
+  FN := NetToDosPath(FileAddrRec.Path);
+  Result := FileExists(FN);
+  ContentType := GetLocalContent(FN);
+  Finalize(FileAddrRec);
+end;
+
+function TIpFileDataProvider.GetHtmlStream(const URL : string;
+  PostData : TIpFormDataEntity) : TStream;
+var
+  FileAddrRec : TIpAddrRec;
+  FN : string;
+begin
+  Initialize(FileAddrRec);
+  IpParseURL(URL, FileAddrRec);
+  FN := NetToDosPath(FileAddrRec.Path);
+  Result := TMemoryStream.Create;
+  TMemoryStream(Result).LoadFromFile(FN);
+  FOldURL := URL;
+  Finalize(FileAddrRec);
+end;
+
+procedure TIpFileDataProvider.GetImage(Sender : TIpHtmlNode;
+  const URL : string; var Picture : TPicture);
+var
+  FileAddrRec : TIpAddrRec;
+  Content, FN : string;
+begin
+  Initialize(FileAddrRec);
+  Picture := nil;
+  IpParseURL(URL, FileAddrRec);
+  FN := NetToDosPath(FileAddrRec.Path);
+  Content := UpperCase(GetLocalContent(FN));
+  if Pos('IMAGE/', Content) > 0 then begin
+    try
+      Picture := TPicture.Create;
+      Picture.LoadFromFile(FN);
+    except
+      on EInvalidGraphic do begin
+        Picture.Free;
+        Picture := nil;
+      end;
+    end;
+  end;
+  Finalize(FileAddrRec);
+end;
+
+procedure TIpFileDataProvider.Leave(Html : TIpHtml);
+begin
+  inherited Leave(Html);
+  { Do Nothing }
+end;
+
+procedure TIpFileDataProvider.Reference(const URL : string);
+begin
+  inherited Reference(URL);
+  { Do Nothing }
+end;
+
+{$IFDEF IP_LAZARUS}
+procedure Register;
+begin
+  RegisterComponents('IPro', [TIpFileDataProvider]);
+end;
+{$ENDIF}
+
+
+end.

components/turbopower_ipro/iphtml.pas

@@ -2759,9 +2759,13 @@ type
     procedure CopyToClipboard;
     procedure EnumDocuments(Enumerator: TIpHtmlEnumerator);
     procedure GoBack;
+    {$IFDEF IP_LAZARUS}
     function canGoBack : boolean;
+    {$ENDIF}
     procedure GoForward;
+    {$IFDEF IP_LAZARUS}
     function canGoForward : boolean;
+    {$ENDIF}
     function HaveSelection: Boolean;
     property HotNode : TIpHtmlNode read FHotNode;                      {!!.12}
     function IsURLHtml(const URL: string): Boolean;
@@ -17443,18 +17447,25 @@ end;
 procedure TIpHtmlCustomPanel.GoBack;
 begin
   if (URLStack.Count > 0) then begin
+    {$IFDEF IP_LAZARUS}
     if URLStack.Count >= URLStack.count then Stp := URLStack.Count - 1;
     if URLStack.Count > 0 then begin
       InternalOpenURL(TargetStack[Stp], URLStack[Stp]);
       dec(Stp);
     end;
+    {$ELSE}
+    InternalOpenURL(TargetStack[Stp], URLStack[Stp]);
+    dec(Stp);
+    {$ENDIF}
   end;
 end;
 
+{$IFDEF IP_LAZARUS}
 function TIpHtmlCustomPanel.canGoBack : boolean;
 begin
   result := (URLStack.Count > 0);
 end;
+{$ENDIF}
 
 procedure TIpHtmlCustomPanel.GoForward;
 begin
@@ -17464,10 +17475,12 @@ begin
   end;
 end;
 
+{$IFDEF IP_LAZARUS}
 function TIpHtmlCustomPanel.canGoForward : boolean;
 begin
   result := (Stp < URLStack.Count - 1);
 end;
+{$ENDIF}
 
 procedure TIpHtmlCustomPanel.Push(const Target, URL: string);
 begin

components/turbopower_ipro/iputils.pas

@@ -42,6 +42,7 @@ uses
   LCLIntf,
   LMessages,
   FileUtil,
+  LCLProc,
   {$ELSE}
   Messages,
   Windows,
@@ -1170,7 +1171,11 @@ begin
   for i := 1 to Length(Result) do begin
     case Result[i] of
       '|': Result[i] := ':';
+      {$IFDEF IP_LAZARUS}
+      '/': Result[i] := DirectorySeparator;
+      {$ELSE}
       '/': Result[i] := '\';
+      {$ENDIF}
     else
       { leave it alone };
     end;
@@ -1191,7 +1196,11 @@ begin
   for i := 1 to Length(Result) do begin
     case Result[i] of
       ':': Result[i] := '|';
+      {$IFDEF IP_LAZARUS}
+      DirectorySeparator: Result[i] := '/';
+      {$ELSE}
       '\': Result[i] := '/';
+      {$ENDIF}
     else
       { leave it alone };
     end;
@@ -1296,6 +1305,9 @@ var
   State : TUrlParseState;
   PotAuth, PotPath : string;
   SchemeSeen: Boolean;
+  {$IFDEF IP_LAZARUS}
+  SlashCount: integer;
+  {$ENDIF}
 
 procedure ProcessChar;
 begin
@@ -1374,6 +1386,9 @@ begin
               SchemeSeen := True;
               PotAuth := '';
               State := psSchemeSlashes;
+              {$IFDEF IP_LAZARUS}
+              SlashCount := 0;
+              {$ENDIF}
             end
             else begin
 
@@ -1427,6 +1442,9 @@ begin
           SchemeSeen := True;
           PotAuth := '';
           State := psSchemeSlashes;
+          {$IFDEF IP_LAZARUS}
+          SlashCount := 0;
+          {$ENDIF}
         end;
 
         'A'..'Z', 'a'..'z': begin
@@ -1453,10 +1471,16 @@ begin
     end;
 
     psSchemeSlashes: begin
+      {$IFDEF IP_LAZARUS}
+      inc(SlashCount);
+      if (p^ <> '/') or (SlashCount > 2) then
+      {$ENDIF}
       case P^ of
+        {$IFNDEF IP_LAZARUS}
         '/': { ignore };
+        {$ENDIF}
 
-        '.', '\': begin { start of a local path }                      {!!.12}
+        '.', '\','/': begin { start of a local path }                      {!!.12}
           PotPath := PotPath + P^;                                     {!!.12}
           State := psLocalPath;                                        {!!.12}
         end;                                                           {!!.12}
@@ -2665,6 +2689,61 @@ end;
 
 { File/Directory Stuff }
 
+{ Retreive Windows "MIME" type for a particular file extension }
+{$IFDEF IP_LAZARUS}
+{$ifndef MSWindows}
+{define some basic mime types}
+const MimeTypeExt : Array[0..4] of String = ('.htm','.html','.txt','.jpg','.png');
+      MimeTypes   : Array[0..4] of String = ('text/html','text/html','text/plain','image/jpeg','image/png');
+{$endif}
+
+{$IFDEF VER2_0_2}
+type
+ TMyRegistry=Class(TRegistry);
+{$ENDIF}
+function GetLocalContent(const TheFileName: string): string;
+var
+  Reg : TRegistry;
+  Ext : string;
+  {$ifndef MSWindows}
+  ExtU: string;
+  i : integer;
+  {$ENDIF}
+begin
+  Result := '';
+  Ext := ExtractFileExt(TheFileName);
+  {$ifndef MSWindows}
+  ExtU := AnsiLowerCase(Ext);
+  for i := 0 to high(MimeTypeExt) do
+    if MimeTypeExt[i] = ExtU then
+    begin
+      result := MimeTypes[i];
+      break;
+    end;
+  {$endif}
+  if result = '' then
+  begin
+    Reg := nil;
+    try
+      {$IFDEF VER2_0_2}
+      Reg := TMyRegistry.Create;
+      Reg.RootKey := HKEY_CLASSES_ROOT;
+      TMyRegistry(Reg).SetCurrentKey(Reg.RootKey);
+      {$ELSE}
+      Reg := TRegistry.Create;
+      Reg.RootKey := HKEY_CLASSES_ROOT;
+      {$ENDIF}
+      if Reg.OpenKey(Ext, False) then
+        Result := Reg.ReadString('Content Type');
+    finally
+      Reg.CloseKey;
+      Reg.Free;
+    end;
+  end;
+  DebugLn('IpUtils.GetLocalContent File:'+TheFileName+' Result:'+result);
+end;
+
+{$ELSE}
 { Retreive Windows "MIME" type for a particular file extension }
 function GetLocalContent(const TheFileName: string): string;
 var
@@ -2685,6 +2764,7 @@ begin
     Reg.Free;
   end;
 end;
+{$ENDIF}
 
 { Determine if a directory exists }
 function DirExists(Dir : string): Boolean;

components/turbopower_ipro/turbopoweripro.lpk

@@ -41,7 +41,7 @@
       </Item4>
       <Item5>
         <Filename Value="ipfilebroker.pas"/>
-        <AddToUsesPkgSection Value="False"/>
+        <HasRegisterProc Value="True"/>
         <UnitName Value="Ipfilebroker"/>
       </Item5>
       <Item6>

components/turbopower_ipro/turbopoweripro.pas

@@ -7,13 +7,14 @@ unit TurboPowerIPro;
 interface
 
 uses
-  IpAnim, IpConst, IpHtml, IpHtmlPv, IpMsg, IpStrms, IpUtils, 
+  IpAnim, IpConst, Ipfilebroker, IpHtml, IpHtmlPv, IpMsg, IpStrms, IpUtils, 
     LazarusPackageIntf; 
 
 implementation
 
 procedure Register; 
 begin
+  RegisterUnit('Ipfilebroker', @Ipfilebroker.Register); 
   RegisterUnit('IpHtml', @IpHtml.Register); 
 end;