summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/corelib/gdi/gfx_utils_impl.inc12
-rw-r--r--src/corelib/gfx_constants.pas8
-rw-r--r--src/corelib/gfx_utils.pas43
-rw-r--r--src/corelib/gfxbase.pas3
-rw-r--r--src/corelib/x11/gfx_utils_impl.inc25
-rw-r--r--src/gui/fpgui_package.lpk14
-rw-r--r--src/gui/fpgui_package.pas2
-rw-r--r--src/gui/gui_hyperlink.pas136
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.
+
generated by cgit v1.2.3-70-g09d2 (git 2.47.1) at 2024-12-28 16:47:38 +0000