* Added Antonio Sanguigni new TfpgHyperLabel component to fpGUI. I converted his gui_browser class to a fpgOpenURL function.

8 files changed, 212 insertions, 31 deletions

diff --git a/src/corelib/gdi/gfx_utils_impl.inc b/src/corelib/gdi/gfx_utils_impl.inc
index c8b264e1..3862dc23 100644
--- a/src/corelib/gdi/gfx_utils_impl.inc
+++ b/src/corelib/gdi/gfx_utils_impl.inc
@@ -1,5 +1,8 @@
 {%mainunit gfx_utils.pas}
 
+uses
+  Registry, Shellapi;
+  
 // GDI specific implementations of encoding functions
 
 function fpgToOSEncoding(aString: TfpgString): string;
@@ -12,3 +15,12 @@ begin
   Result := AnsiToUtf8(aString);
 end;
 
+procedure fpgOpenURL(const aURL: TfpgString);
+begin
+  try
+    ShellExecute(0, 'open', PChar(aURL), nil, nil, 0) ;
+  except
+    // do nothing
+  end;
+end;
+
diff --git a/src/corelib/gfx_constants.pas b/src/corelib/gfx_constants.pas
index e1b8d7b4..e64cf448 100644
--- a/src/corelib/gfx_constants.pas
+++ b/src/corelib/gfx_constants.pas
@@ -59,6 +59,14 @@ resourcestring
 {$IFEND}
 
 
+const
+  {$IFDEF UNIX}
+  AllFilesMask    = '*';
+  {$ELSE}
+  AllFilesMask    = '*.*';
+  {$ENDIF UNIX}
+
+
 { This is so that when we support LTR and RTL languages, the colon will be
   added at the correct place. }
 function fpgAddColon(const AText: TfpgString): TfpgString;
diff --git a/src/corelib/gfx_utils.pas b/src/corelib/gfx_utils.pas
index 6dfa2d2d..04d2aa31 100644
--- a/src/corelib/gfx_utils.pas
+++ b/src/corelib/gfx_utils.pas
@@ -7,43 +7,40 @@ interface
 uses
   Classes, SysUtils, gfxbase;
 
-// Platform specific encoding handling functions
-function fpgToOSEncoding(aString: TfpgString): string;
-function fpgFromOSEncoding(aString: string): TfpgString;
+// *** Platform specific functions ***
+
+function  fpgToOSEncoding(aString: TfpgString): string;
+function  fpgFromOSEncoding(aString: string): TfpgString;
+procedure fpgOpenURL(const aURL: TfpgString);
+
+
+// *** Common functions for all platforms ***
+
+function  fpgAddTrailingValue(const ALine, AValue: TfpgString; ADuplicates: boolean = true): TfpgString;
 
-// Common functions for all platforms
-function fpgAddTrailingValue(const ALine, AValue: TfpgString; ADuplicates: boolean = true): TfpgString;
 
 // RTL wrapper filesystem functions with platform independant encoding
 // These functions are common for all platforms and rely on fpgXXXPlatformEncoding
 
-function fpgFindFirst(const Path: TfpgString; Attr: Longint; out Rslt: TSearchRec): Longint;
-function fpgFindNext(var Rslt: TSearchRec): Longint;
-function fpgGetCurrentDir: TfpgString;
-function fpgSetCurrentDir(const NewDir: TfpgString): Boolean;
-function fpgExpandFileName(const FileName: TfpgString): TfpgString;
-function fpgFileExists(const FileName: TfpgString): Boolean;
-
-{ ***  Examples of others we could do  *** }
+function  fpgFindFirst(const Path: TfpgString; Attr: Longint; out Rslt: TSearchRec): Longint;
+function  fpgFindNext(var Rslt: TSearchRec): Longint;
+function  fpgGetCurrentDir: TfpgString;
+function  fpgSetCurrentDir(const NewDir: TfpgString): Boolean;
+function  fpgExpandFileName(const FileName: TfpgString): TfpgString;
+function  fpgFileExists(const FileName: TfpgString): Boolean;
 
-// function fpgCreateDir(const NewDir: TfpgString): Boolean;
-// function fpgRemoveDir(const Dir: TfpgString): Boolean;
-// function fpgForceDirectories(const Dir: TfpgString): Boolean;
-// function fpgDeleteFile(const FileName: TfpgString): Boolean;
-// function fpgRenameFile(const OldName, NewName: TfpgString): Boolean;
-// function fpgFileSearch(const Name, DirList: TfpgString): TfpgString;
-// function fpgFileIsReadOnly(const FileName: TfpgString): Boolean;
-// ....
 
 
 implementation
 
+{ No USES clause is allowed here! Add it to the include file shown below. }
+
 
 // Platform specific encoding handling functions
 {$I gfx_utils_impl.inc}
 
 
-// the common code for all platforms
+
 function fpgAddTrailingValue(const ALine, AValue: TfpgString; ADuplicates: boolean = true): TfpgString;
 begin
   if ALine = '' then
@@ -64,8 +61,6 @@ begin
     result := ALine;
 end;
 
-// RTL wrapper filesystem functions
-
 function fpgFindFirst(const Path: TfpgString; Attr: Longint; out
   Rslt: TSearchRec): Longint;
 begin
diff --git a/src/corelib/gfxbase.pas b/src/corelib/gfxbase.pas
index 7023930f..d7d525f9 100644
--- a/src/corelib/gfxbase.pas
+++ b/src/corelib/gfxbase.pas
@@ -517,6 +517,7 @@ implementation
 uses
   fpgfx,  // needed for fpgApplication
   gfx_utils, // needed for fpgFileList
+  gfx_constants,
   typinfo;
   
   
@@ -2088,7 +2089,7 @@ begin
   try
     // The extra 'or' includes Normal attribute files under Windows. faAnyFile doesn't return those.
     // Reported to FPC as bug 9440 in Mantis.
-    if fpgFindFirst(FDirectoryName + '*', faAnyFile or $00000080, SearchRec) = 0 then
+    if fpgFindFirst(FDirectoryName + AllFilesMask, faAnyFile or $00000080, SearchRec) = 0 then
     begin
       AddEntry(SearchRec);
       while fpgFindNext(SearchRec) = 0 do
diff --git a/src/corelib/x11/gfx_utils_impl.inc b/src/corelib/x11/gfx_utils_impl.inc
index 0f341df4..41e5233d 100644
--- a/src/corelib/x11/gfx_utils_impl.inc
+++ b/src/corelib/x11/gfx_utils_impl.inc
@@ -1,5 +1,8 @@
 {%mainunit gfx_utils.pas}
 
+uses
+  Unix;
+
 // X11 specific filesystem implementations of encoding functions
 
 function fpgToOSEncoding(aString: TfpgString): string;
@@ -12,4 +15,26 @@ begin
   Result := aString;
 end;
 
+procedure fpgOpenURL(const aURL: TfpgString);
+var
+  Helper: string;
+begin
+//TODO: Catch "which" command output to run the browser from there
+  Helper := '';
+  if FileExists('/etc/alternatives/x-www-browser') then
+    Helper := '/etc/alternatives/x-www-browser'
+  else
+  begin
+    if fpsystem('which opera') = 0 then
+      Helper := 'opera';
+    if fpsystem('which mozilla') = 0 then
+       Helper := 'mozilla';
+    if fpsystem('which konqueror') = 0 then
+      Helper := 'konqueror';
+    if fpsystem('which firefox') = 0 then
+      Helper := 'firefox';
+  end;
+
+  fpSystem(Helper + ' ' + aURL + '&');
+end;
 
diff --git a/src/gui/fpgui_package.lpk b/src/gui/fpgui_package.lpk
index 727594b7..edb05757 100644
--- a/src/gui/fpgui_package.lpk
+++ b/src/gui/fpgui_package.lpk
@@ -28,7 +28,7 @@
     <License Value="Modified LGPL
 "/>
     <Version Minor="6" Release="1"/>
-    <Files Count="31">
+    <Files Count="32">
       <Item1>
         <Filename Value="gui_button.pas"/>
         <UnitName Value="gui_button"/>
@@ -153,16 +153,20 @@
         <Filename Value="promptuserdialog.inc"/>
         <Type Value="Include"/>
       </Item31>
+      <Item32>
+        <Filename Value="gui_hyperlink.pas"/>
+        <UnitName Value="gui_hyperlink"/>
+      </Item32>
     </Files>
     <LazDoc Paths="../../docs/xml/gui/"/>
     <RequiredPkgs Count="2">
       <Item1>
-        <PackageName Value="fpgfx_package"/>
-        <MinVersion Minor="6" Release="1" Valid="True"/>
-      </Item1>
-      <Item2>
         <PackageName Value="FCL"/>
         <MinVersion Major="1" Valid="True"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="fpgfx_package"/>
+        <MinVersion Minor="6" Release="1" Valid="True"/>
       </Item2>
     </RequiredPkgs>
     <UsageOptions>
diff --git a/src/gui/fpgui_package.pas b/src/gui/fpgui_package.pas
index 964bea47..df82daf5 100644
--- a/src/gui/fpgui_package.pas
+++ b/src/gui/fpgui_package.pas
@@ -12,7 +12,7 @@ uses
     gui_radiobutton, gui_trackbar, gui_tab, gui_basegrid, gui_listview, 
     gui_customgrid, gui_progressbar, gui_menu, gui_style, gui_grid, gui_tree, 
     gui_iniutils, gui_mru, fpgui_db, gui_popupcalendar, gui_gauge, 
-    gui_editcombo; 
+    gui_editcombo, gui_hyperlink; 
 
 implementation
 
diff --git a/src/gui/gui_hyperlink.pas b/src/gui/gui_hyperlink.pas
new file mode 100644
index 00000000..d2a0f5f0
--- /dev/null
+++ b/src/gui/gui_hyperlink.pas
@@ -0,0 +1,136 @@
+{
+    fpGUI  -  Free Pascal GUI Library
+
+    Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this
+    distribution, for details of the copyright.
+
+    See the file COPYING.modifiedLGPL, included in this distribution,
+    for details about redistributing fpGUI.
+
+    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.
+
+    Description:
+      A hyperlink label component. When the user clicks the label, a
+      web browser is opened with the URL specified.
+}
+
+
+unit gui_hyperlink;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes,
+  Sysutils,
+  gui_label,
+  fpgfx,
+  gfxbase;
+
+type
+
+  TfpgHyperlink = class(TfpgCustomLabel)
+  private
+    fHotTrackColor: TfpgColor;
+    fOldColor: TfpgColor;
+    fOldFont: TfpgString;
+    fHTFont: TfpgString;
+    fUrl: TfpgString;
+    procedure   SetHotTrackColor(const AValue: TfpgColor);
+    procedure   SetHotTrackFont(const AValue: TfpgString);
+    procedure   SetURL(const Value: TfpgString);
+  protected
+    procedure   HandleMouseEnter; override;
+    procedure   HandleMouseExit; override;
+    procedure   HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    procedure   GoHyperLink;
+  published
+    property    URL: TfpgString read FUrl write SetURL;
+    property    Autosize;
+    property    FontDesc;
+    property    Text;
+    property    TextColor;
+    property    HotTrackFont: TfpgString read fHTFont write SetHotTrackFont;
+    property    HotTrackColor: TfpgColor read fHotTrackColor write SetHotTrackColor;
+end;
+
+
+
+implementation
+
+uses
+  gfx_utils;
+
+
+{ TfpgHyperlink }
+
+constructor TfpgHyperlink.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  fHotTrackColor  := clBlue;
+  TextColor       := clBlue;
+  fUrl            := 'http://opensoft.homeip.net/fpgui/';
+  Text            := 'fpGUI website';
+  fHTFont         := 'Arial-8:antialias=true:underline:bold';
+  FontDesc        := 'Arial-8:antialias=true:underline';
+  AutoSize        := True;
+end;
+
+procedure TfpgHyperlink.SetURL(const Value: TfpgString);
+begin
+  if fUrl <> Value then
+    fUrl := Value;
+end;
+
+procedure TfpgHyperlink.SetHotTrackFont(const AValue: TfpgString);
+begin
+  if fHTFont = AValue then
+    Exit;
+  fHTFont := AValue;
+end;
+
+procedure TfpgHyperlink.SetHotTrackColor(const AValue: TfpgColor);
+begin
+  if fHotTrackColor = AValue then
+    Exit;
+  fHotTrackColor := AValue;
+end;
+
+procedure TfpgHyperlink.GoHyperLink;
+begin
+  if URL <> '' then
+    fpgOpenURL(URL);
+end;
+
+procedure TfpgHyperlink.HandleMouseEnter;
+begin
+  inherited HandleMouseEnter;
+  fOldColor   := TextColor;
+  TextColor   := fHotTrackColor;
+  fOldFont    := FontDesc;
+  FontDesc    := fHTFont;
+  MouseCursor := mcHand;
+end;
+
+procedure TfpgHyperlink.HandleMouseExit;
+begin
+  inherited HandleMouseExit;
+  TextColor   := fOldColor;
+  MouseCursor := mcDefault;
+  FontDesc    := fOldFont;
+end;
+
+procedure TfpgHyperlink.HandleLMouseDown(x, y: integer; shiftstate: TShiftState);
+begin
+  inherited HandleLMouseDown(x, y, shiftstate);
+  GoHyperlink;
+end;
+
+
+end.
+