doublecmd/src/platform/upixmapmanager.pas
2016-09-19 18:10:04 +00:00

2063 lines
65 KiB
ObjectPascal

{
File name: uPixMapManager.pas
Date: 2004/04/xx
Author: Radek Cervinka <radek.cervinka@centrum.cz>
Fast pixmap memory manager a loader
Copyright (C) 2004
contributors:
Copyright (C) 2006-2014 Koblov Alexander (Alexx2000@mail.ru)
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU 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
General Public License for more details.
You should have received a copy of the GNU General Public License
in a file called COPYING along with this program; if not, write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
02139, USA.
}
unit uPixMapManager;
{$mode objfpc}{$H+}
{$IFDEF DARWIN}
{$modeswitch objectivec1}
{$ENDIF}
interface
{
GTK2 is used directly in PixmapManager, because FPC/Lazarus draws bitmaps
without alpha channel under GTK2, so bitmaps looks ugly.
If this problem will be fixed then GTK2 specific code could be dropped.
}
uses
Classes, SysUtils, Graphics, syncobjs, uFileSorting, StringHashList,
uFile, uIconTheme, uDrive, uDisplayFile, uGlobs, uDCReadPSD
{$IF DEFINED(UNIX)}
{$IF NOT DEFINED(DARWIN)}
, contnrs, uDCReadSVG, uGio, uOSUtils
{$IFDEF LCLGTK2}
, gtk2
{$ELSE}
, uUnixIconTheme
{$ENDIF}
{$ENDIF}
{$ENDIF};
type
TDriveIconList = record
Size: Integer;
bmMediaFloppy,
bmDriveHardDisk,
bmMediaFlash,
bmMediaOptical,
bmDriveNetwork,
bmDriveVirtual,
bmDriveRemovableMedia,
bmDriveRemovableMediaUsb: TBitmap;
end;
{ TfromWhatBitmapWasLoaded }
//Used to indicate from where the icon was loaded from.
//Useful when exporting to TC for example which cannot used "as is" the same icon file in some circumstances.
TfromWhatBitmapWasLoaded = (fwbwlNotLoaded, fwbwlIconThemeBitmap, fwbwlResourceFileExtracted, fwbwlGraphicFile, fwbwlGraphicFileNotSupportedByTC, fwbwlFileIconByExtension, fwbwlFiDefaultIconID);
PTfromWhatBitmapWasLoaded = ^TfromWhatBitmapWasLoaded;
{ TPixMapManager }
TPixMapManager = class
private
{en
Maps file extension to index of bitmap (in FPixmapList) for this file extension.
}
FExtList : TStringHashList;
{en
Maps icon filename to index of bitmap (in FPixmapList) for this icon.
Uses absolute file names.
}
FPixmapsFileNames : TStringHashList;
{en
A list of loaded bitmaps.
Stores TBitmap objects (on GTK2 it stores PGdkPixbuf pointers).
}
FPixmapList : TFPList;
{en
Lock used to synchronize access to PixmapManager storage.
}
FPixmapsLock: TCriticalSection;
FDriveIconList : array[0..2] of TDriveIconList;
FiDirIconID : PtrInt;
FiDirLinkIconID : PtrInt;
FiDirLinkBrokenIconID : PtrInt;
FiLinkIconID : PtrInt;
FiLinkBrokenIconID : PtrInt;
FiEmblemLinkID: PtrInt;
FiEmblemUnreadableID: PtrInt;
FiUpDirIconID : PtrInt;
FiDefaultIconID : PtrInt;
FiExeIconID : PtrInt;
FiArcIconID : PtrInt;
FiSortAscID : PtrInt;
FiSortDescID : PtrInt;
{$IF DEFINED(MSWINDOWS)}
FSysImgList : THandle;
{$ELSEIF DEFINED(DARWIN)}
FUseSystemTheme: Boolean;
{$ELSEIF DEFINED(UNIX)}
{en
Maps file extension to MIME icon name(s).
}
FExtToMimeIconName: TFPDataHashTable;
{$IFDEF LCLGTK2}
FIconTheme: PGtkIconTheme;
{$ELSE}
FIconTheme: TIconTheme;
{$ENDIF}
FHomeFolder: String;
{$ENDIF}
{en
Maps theme icon name to index of bitmap (in FPixmapList) for this icon.
}
FThemePixmapsFileNames: TStringHashList;
FDCIconTheme: TIconTheme;
procedure CreateIconTheme;
procedure DestroyIconTheme;
{en
Same as LoadBitmap but displays a warning if pixmap file doesn't exist.
}
function CheckLoadPixmapFromFile(const AIconName: String) : TBitmap;
{en
If path is absolute tries to load bitmap and add to storage.
If path is relative it tries to load theme icon and add to storage.
}
function CheckAddPixmap(AIconName: String; AIconSize : Integer = 0): PtrInt;
{en
Loads a theme icon and adds it to storage.
This function should only be called under FPixmapLock.
}
function CheckAddThemePixmapLocked(AIconName: String; AIconSize: Integer): PtrInt;
{en
Loads a theme icon and adds it to storage.
Safe to call without a lock.
}
function CheckAddThemePixmap(const AIconName: String; AIconSize: Integer = 0) : PtrInt;
{en
Loads a theme icon. Returns TBitmap (on GTK2 convert GdkPixbuf to TBitmap).
This function should only be called under FPixmapLock.
}
function LoadIconThemeBitmapLocked(AIconName: String; AIconSize: Integer): TBitmap;
{$IF DEFINED(WINDOWS)}
{en
Checks if the AIconName points to an icon resource in a library, executable, etc.
@param(AIconName
Full path to the file with the icon with appended "," and icon index.)
@param(IconFile
Returns the full path to the file containing the icon resource.)
@param(IconIndex
Returns the index of the icon in the file.)
@returns(@true if AIconName points to an icon resource, @false otherwise.)
}
function GetIconResourceIndex(const IconPath: String; out IconFile: String; out IconIndex: PtrInt): Boolean;
function GetSystemFolderIcon: PtrInt;
function GetSystemExecutableIcon: PtrInt;
{$ENDIF}
{$IF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
{en
Loads MIME icons names and creates a mapping: file extension -> MIME icon name.
Doesn't need to be synchronized as long as it's only called from Load().
}
procedure LoadMimeIconNames;
{en
Retrieves index of a theme icon based on file extension
using Extension->MIME map.
Loads the icon and adds it into PixmapManager, if not yet added.
This function should only be called under FPixmapLock.
}
function GetMimeIcon(AFileExt: String; AIconSize: Integer): PtrInt;
{en
It is synchronized in GetIconByName->CheckAddPixmap.
}
function GetIconByDesktopFile(sFileName: String; iDefaultIcon: PtrInt): PtrInt;
{$ENDIF}
{$IF DEFINED(DARWIN)}
function GetSystemFolderIcon: PtrInt;
function GetMimeIcon(AFileExt: String; AIconSize: Integer): PtrInt;
{$ENDIF}
function GetBuiltInDriveIcon(Drive : PDrive; IconSize : Integer; clBackColor : TColor) : Graphics.TBitmap;
public
constructor Create;
destructor Destroy; override;
procedure Load(const sFileName : String);
{en
Loads a graphical file (if supported) to a bitmap.
@param(AIconFileName must be a full path to the graphical file.)
@param(ABitmap receives a new bitmap object.)
@returns(@true if bitmap has been loaded, @false otherwise.)
}
function LoadBitmapFromFile(AIconFileName: String; out ABitmap: TBitmap): Boolean;
{en
Loads a graphical file as a bitmap if filename is full path.
Environment variables in the filename are supported.
If filename is not graphic file it tries to load some bitmap associated
with the file (by extension, attributes, etc.).
Loads an icon from a file's resources if filename ends with ",Nr" (on Windows).
Loads a theme icon if filename is not a full path.
Performs resize of the bitmap to <iIconSize>x<iIconSize> if Stretch = @true.
If Stretch = @false then clBackColor is ignored.
}
function LoadBitmapEnhanced(sFileName : String; iIconSize : Integer; Stretch: Boolean; clBackColor : TColor; fromWhatItWasLoaded:PTfromWhatBitmapWasLoaded = nil) : Graphics.TBitmap;
{en
Loads a theme icon as bitmap.
@param(AIconName is a MIME type name.)
}
function LoadIconThemeBitmap(AIconName: String; AIconSize: Integer): TBitmap;
{en
Retrieves a bitmap stored in PixmapManager by index (always returns a new copy).
On Windows if iIndex points to system icon list it creates a new bitmap
by loading system icon and drawing onto the bitmap.
}
function GetBitmap(iIndex : PtrInt) : TBitmap;
function DrawBitmap(iIndex: PtrInt; Canvas : TCanvas; X, Y: Integer) : Boolean;
{en
Draws bitmap stretching it if needed to Width x Height.
If Width is 0 then full bitmap width is used.
If Height is 0 then full bitmap height is used.
@param(iIndex
Index of pixmap manager's bitmap.)
}
function DrawBitmap(iIndex: PtrInt; Canvas : TCanvas; X, Y, Width, Height: Integer) : Boolean;
{en
Draws overlay bitmap for a file.
@param(AFile
File for which is needed to draw the overlay icon.)
@param(DirectAccess
Whether the file is on a directly accessible file source.)
}
function DrawBitmapOverlay(AFile: TDisplayFile; DirectAccess: Boolean; Canvas : TCanvas; X, Y: Integer) : Boolean;
function GetIconBySortingDirection(SortingDirection: TSortDirection): PtrInt;
{en
Retrieves icon index in FPixmapList table for a file.
@param(AFile
File for which to retrieve the icon.)
@param(DirectAccess
Whether the file is on a directly accessible file source.)
@param(LoadIcon
Only used when an icon for a file does not yet exist in FPixmapsList.
If @true then it loads the icon into FPixmapsList table and returns
the index of the loaded icon.
If @false then it returns -1 to notify that an icon for the file
does not exist in FPixmapsList.
If the icon already exists for the file the function returns
its index regardless of LoadIcon parameter.)
@param(IconsMode
Whether to retrieve only standard icon, also from file resources, etc.)
@param(GetIconWithLink
If the file is a link and GetLinkIcon is @true it retrieves icon
with embedded link bitmap. If @false it only retrieves the file icon itself.)
}
function GetIconByFile(AFile: TFile; DirectAccess: Boolean; LoadIcon: Boolean;
IconsMode: TShowIconsMode; GetIconWithLink: Boolean): PtrInt;
{$IF DEFINED(MSWINDOWS) OR DEFINED(RabbitVCS)}
{en
Retrieves overlay icon index for a file.
@param(AFile
File for which to retrieve the overlay icon.)
@param(DirectAccess
Whether the file is on a directly accessible file source.)
}
function GetIconOverlayByFile(AFile: TFile; DirectAccess: Boolean): PtrInt;
{$ELSEIF DEFINED(DARWIN)}
function GetApplicationBundleIcon(sFileName: String; iDefaultIcon: PtrInt): PtrInt;
{$ENDIF}
function GetIconByName(const AIconName: String): PtrInt;
function GetDriveIcon(Drive : PDrive; IconSize : Integer; clBackColor : TColor) : Graphics.TBitmap;
function GetDefaultDriveIcon(IconSize : Integer; clBackColor : TColor) : Graphics.TBitmap;
function GetVirtualDriveIcon(IconSize : Integer; clBackColor : TColor) : Graphics.TBitmap;
function GetArchiveIcon(IconSize: Integer; clBackColor : TColor) : Graphics.TBitmap;
function GetFolderIcon(IconSize: Integer; clBackColor : TColor) : Graphics.TBitmap;
{en
Returns default icon for a file.
For example default folder icon for folder, default executable icon for *.exe, etc.
}
function GetDefaultIcon(AFile: TFile): PtrInt;
end;
var
PixMapManager: TPixMapManager = nil;
procedure LoadPixMapManager;
function StretchBitmap(var bmBitmap : Graphics.TBitmap; iIconSize : Integer;
clBackColor : TColor; bFreeAtEnd : Boolean = False) : Graphics.TBitmap;
implementation
uses
GraphType, LCLIntf, LCLType, LCLProc, Forms, uGlobsPaths, WcxPlugin,
DCStrUtils, uDCUtils, uFileSystemFileSource, uReSample, uDebug,
DCOSUtils, DCClassesUtf8, LazUTF8
{$IFDEF LCLGTK2}
, uPixMapGtk, gdk2pixbuf, gdk2, glib2
{$ENDIF}
{$IFDEF MSWINDOWS}
, CommCtrl, ShellAPI, Windows, uIcoFiles, uGdiPlus, IntfGraphics, uShlObjAdditional
{$ELSE}
, StrUtils, DCBasicTypes
{$ENDIF}
{$IFDEF DARWIN}
, CocoaAll, MacOSAll, uClassesEx
{$ENDIF}
{$IFDEF RabbitVCS}
, Math, uRabbitVCS
{$ENDIF}
;
{$IF DEFINED(MSWINDOWS) OR DEFINED(RabbitVCS)}
const
SystemIconIndexStart: PtrInt = High(PtrInt) div 2;
{$ENDIF}
function StretchBitmap(var bmBitmap : Graphics.TBitmap; iIconSize : Integer;
clBackColor : TColor; bFreeAtEnd : Boolean = False) : Graphics.TBitmap;
var
memstream: TMemoryStream;
{$IFDEF MSWINDOWS}
liiSource: TLazIntfImage = nil;
liiDestination: TLazIntfImage = nil;
ImgFormatDescription:TRawImageDescription;
{$ENDIF}
begin
{$IFDEF MSWINDOWS}
//Let's make sure we're working with 32-bits bitmap
if bmBitmap.PixelFormat<>pf32bit then
begin
liiSource:=bmBitmap.CreateIntfImage;
liiDestination:=TLazIntfImage.Create(bmBitmap.Width,bmBitmap.Height);
try
ImgFormatDescription.Init_BPP32_B8G8R8A8_BIO_TTB(bmBitmap.Width,bmBitmap.Height);
liiDestination.DataDescription:=ImgFormatDescription;
liiDestination.CopyPixels(liiSource);
bmBitmap.FreeImage;
bmBitmap.PixelFormat:=pf32bit;
bmBitmap.LoadFromIntfImage(liiDestination);
finally
liiDestination.Free;
liiSource.Free;
end;
end;
{$ENDIF}
if (iIconSize <> bmBitmap.Height) or (iIconSize <> bmBitmap.Width) then
begin
Result := Graphics.TBitMap.Create;
try
Result.SetSize(iIconSize, iIconSize);
if bmBitmap.RawImage.Description.AlphaPrec <> 0 then // if bitmap has alpha channel
Stretch(bmBitmap, Result, ResampleFilters[2].Filter, ResampleFilters[2].Width)
else
with Result do
begin
Canvas.Brush.Color := clBackColor;
Canvas.FillRect(Canvas.ClipRect);
Canvas.StretchDraw(Canvas.ClipRect, bmBitmap);
{ For drawing color transparent bitmaps }
memstream := TMemoryStream.Create;
try
SaveToStream(memstream);
memstream.position := 0;
LoadFromStream(memstream);
finally
memstream.free;
end;
Transparent := True;
if bmBitmap.RawImage.Description.MaskBitsPerPixel = 0 then
TransparentColor := clBackColor;
end; // with
if bFreeAtEnd then
FreeAndNil(bmBitmap);
except
FreeAndNil(Result);
raise;
end;
end
else // Don't need to stretch.
begin
if bFreeAtEnd then
begin
Result := bmBitmap;
bmBitmap := nil;
end
else
begin
Result := Graphics.TBitMap.Create;
try
Result.Assign(bmBitmap);
except
FreeAndNil(Result);
raise;
end;
end;
end;
end;
{ TPixMapManager }
{ TPixMapManager.LoadBitmapFromFile }
function TPixMapManager.LoadBitmapFromFile(AIconFileName: String; out ABitmap: Graphics.TBitmap): Boolean;
var
{$IFDEF LCLGTK2}
pbPicture : PGdkPixbuf;
{$ELSE}
Picture: TPicture;
{$ENDIF}
begin
Result:= False;
{$IFDEF LCLGTK2}
pbPicture := gdk_pixbuf_new_from_file(PChar(AIconFileName), nil);
if pbPicture <> nil then
begin
ABitmap := PixBufToBitmap(pbPicture);
gdk_pixmap_unref(pbPicture);
// if unsupported BitsPerPixel then exit
if ABitmap.RawImage.Description.BitsPerPixel > 32 then
raise EInvalidGraphic.Create('Unsupported bits per pixel');
Result:= True;
end;
{$ELSE}
Picture := TPicture.Create;
try
ABitmap := Graphics.TBitmap.Create;
try
Picture.LoadFromFile(AIconFileName);
//Picture.Graphic.Transparent := True;
ABitmap.Assign(Picture.Bitmap);
// if unsupported BitsPerPixel then exit
if ABitmap.RawImage.Description.BitsPerPixel > 32 then
raise EInvalidGraphic.Create('Unsupported bits per pixel');
Result:= True;
except
on E: Exception do
begin
FreeAndNil(ABitmap);
DCDebug(Format('Error: Cannot load pixmap [%s] : %s',[AIconFileName, e.Message]));
end;
end;
finally
FreeAndNil(Picture);
end;
{$ENDIF}
end;
function TPixMapManager.LoadBitmapEnhanced(sFileName : String; iIconSize : Integer; Stretch: Boolean; clBackColor : TColor; fromWhatItWasLoaded:PTfromWhatBitmapWasLoaded) : Graphics.TBitmap;
var
{$IFDEF MSWINDOWS}
iIconIndex: PtrInt;
iIconLarge,
iIconSmall: Integer;
phIcon: HICON = INVALID_HANDLE_VALUE;
phIconLarge : HICON = 0;
phIconSmall : HICON = 0;
Icon : TIcon = nil;
IconFileName: String;
{$ENDIF}
AFile: TFile;
iIndex : PtrInt;
sExtFilter,
sGraphicFilter : String;
bmStandartBitmap : Graphics.TBitMap = nil;
begin
Result := nil;
if fromWhatItWasLoaded<> nil then fromWhatItWasLoaded^ := fwbwlNotLoaded;
sFileName:= ReplaceEnvVars(sFileName);
sFileName:= ExpandAbsolutePath(sFileName);
// If the name is not full path then treat it as MIME type.
if GetPathType(sFileName) = ptNone then
begin
bmStandartBitmap := LoadIconThemeBitmap(sFileName, iIconSize);
if fromWhatItWasLoaded<> nil then fromWhatItWasLoaded^ := fwbwlIconThemeBitmap;
end
else
{$IFDEF MSWINDOWS}
if GetIconResourceIndex(sFileName, IconFileName, iIconIndex) then
begin
if ExtractIconExW(PWChar(UTF8Decode(IconFileName)), iIconIndex, phIconLarge, phIconSmall, 1) = 2 then // if extracted both icons
begin
// Get system metrics
iIconSmall:= GetSystemMetrics(SM_CXSMICON);
iIconLarge:= GetSystemMetrics(SM_CXICON);
if (iIconSize = 16) and (iIconSmall = 16) then
phIcon:= phIconSmall // Use small icon
else if (iIconSize = 32) and (iIconLarge = 32) then
phIcon:= phIconLarge // Use large icon
else if iIconSize > iIconSmall then
phicon := phIconLarge // Use large icon
else
phicon := phIconSmall; // Use small icon
if phIcon <> INVALID_HANDLE_VALUE then
try
Icon:= CreateIconFromHandle(phIcon);
bmStandartBitmap := Graphics.TBitMap.Create;
bmStandartBitmap.Assign(Icon);
bmStandartBitmap.Masked := True; // Need to explicitly set Masked=True, Lazarus issue #0019747
if fromWhatItWasLoaded<> nil then fromWhatItWasLoaded^ := fwbwlResourceFileExtracted;
finally
FreeThenNil(Icon);
end;
DestroyIcon(phIconLarge);
DestroyIcon(phIconSmall);
end;
end // GetIconResourceIndex
else
{$ENDIF}
begin
sExtFilter := UTF8LowerCase(ExtractFileExt(sFileName)) + ';';
sGraphicFilter := GraphicFilter(TGraphic);
// if file is graphic
if (Length(sExtFilter) > 1) and (Pos(sExtFilter, sGraphicFilter) <> 0) and mbFileExists(sFileName) then
begin
LoadBitmapFromFile(sFileName, bmStandartBitmap);
if fromWhatItWasLoaded<> nil then fromWhatItWasLoaded^ := fwbwlGraphicFile;
end;
end;
if not Assigned(bmStandartBitmap) then // get file icon by ext
begin
if mbFileSystemEntryExists(sFileName) then
begin
AFile := TFileSystemFileSource.CreateFileFromFile(sFileName);
try
iIndex := GetIconByFile(AFile, True, True, sim_all_and_exe, False);
bmStandartBitmap := GetBitmap(iIndex);
if fromWhatItWasLoaded<> nil then fromWhatItWasLoaded^ := fwbwlFileIconByExtension;
finally
FreeAndNil(AFile);
end;
end
else // file not found
begin
bmStandartBitmap := GetBitmap(FiDefaultIconID);
if fromWhatItWasLoaded<> nil then fromWhatItWasLoaded^ := fwbwlFiDefaultIconID;
end;
end;
if Stretch and Assigned(bmStandartBitmap) then
Result := StretchBitmap(bmStandartBitmap, iIconSize, clBackColor, True)
else
Result := bmStandartBitmap;
end;
function TPixMapManager.LoadIconThemeBitmap(AIconName: String; AIconSize: Integer): Graphics.TBitmap;
begin
FPixmapsLock.Acquire;
try
Result := LoadIconThemeBitmapLocked(AIconName, AIconSize);
finally
FPixmapsLock.Release;
end;
end;
function TPixMapManager.CheckLoadPixmapFromFile(const AIconName: String): Graphics.TBitmap;
begin
if not mbFileExists(AIconName) then
begin
DCDebug(Format('Warning: pixmap [%s] not exists!',[AIconName]));
Exit(nil);
end;
LoadBitmapFromFile(AIconName, Result);
end;
function TPixMapManager.CheckAddThemePixmap(const AIconName: String; AIconSize : Integer) : PtrInt;
begin
if AIconSize = 0 then
AIconSize := gIconsSize;
FPixmapsLock.Acquire;
try
Result := CheckAddThemePixmapLocked(AIconName, AIconSize);
finally
FPixmapsLock.Release;
end;
end;
function TPixMapManager.CheckAddPixmap(AIconName: String; AIconSize : Integer): PtrInt;
var
fileIndex: PtrInt;
{$IFDEF LCLGTK2}
pbPicture : PGdkPixbuf;
{$ELSE}
bmpBitmap: Graphics.TBitmap;
{$ENDIF}
begin
Result:= -1;
if AIconName = EmptyStr then Exit;
if AIconSize = 0 then
AIconSize := gIconsSize;
AIconName := ReplaceEnvVars(AIconName);
if GetPathType(AIconName) = ptAbsolute then
begin
FPixmapsLock.Acquire;
try
// Determine if this file is already loaded.
fileIndex := FPixmapsFileNames.Find(AIconName);
if fileIndex < 0 then
begin
{$IFDEF LCLGTK2}
if not mbFileExists(AIconName) then
begin
DCDebug(Format('Warning: pixmap [%s] not exists!', [AIconName]));
Exit;
end;
pbPicture := gdk_pixbuf_new_from_file_at_size(PChar(AIconName), AIconSize, AIconSize, nil);
if Assigned(pbPicture) then
begin
Result := FPixmapList.Add(pbPicture);
FPixmapsFileNames.Add(AIconName, Pointer(Result));
end
else
DCDebug(Format('Error: pixmap [%s] not loaded!', [AIconName]));
{$ELSE}
bmpBitmap := LoadBitmapEnhanced(AIconName, AIconSize, False, clNone, nil);
if Assigned(bmpBitmap) then
begin
// Shrink big bitmaps before putting them into PixmapManager,
// to speed up later drawing.
//
// Note: Transparent bitmaps may lose transparency, because
// they must drawn onto a background, so we allow smaller bitmaps
// up to 48x48 (icons for example) to load in full size and they
// are resized upon drawing.
//
// TODO:
// This should resize any non-transparent,
// non-alpha channel bitmaps to gIconsSize
// (so if Width<>gIconsSize or Height<>gIconsSize then Resize).
if (bmpBitmap.Width > 48) or (bmpBitmap.Height > 48) then
begin
bmpBitmap := StretchBitmap(bmpBitmap, AIconSize, clBlack, True);
end;
Result := FPixmapList.Add(bmpBitmap);
FPixmapsFileNames.Add(AIconName, Pointer(Result));
end;
{$ENDIF}
end
else
begin
Result:= PtrInt(FPixmapsFileNames.List[fileIndex]^.Data);
end;
finally
FPixmapsLock.Release;
end;
end
else
begin
Result := CheckAddThemePixmap(AIconName, AIconSize);
end;
end;
procedure TPixMapManager.CreateIconTheme;
var
DirList: array of string;
begin
{$IF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
{$IFDEF LCLGTK2}
// get current gtk theme
FIconTheme:= gtk_icon_theme_get_for_screen(gdk_screen_get_default);
{ // load custom theme
FIconTheme:= gtk_icon_theme_new;
gtk_icon_theme_set_custom_theme(FIconTheme, 'oxygen');
}
{$ELSE}
FIconTheme:= TUnixIconTheme.Create;
{$ENDIF}
{$ENDIF}
// Create DC theme.
SetLength(DirList, 1);
DirList[0] := ExcludeTrailingPathDelimiter(gpPixmapPath);
FDCIconTheme := TIconTheme.Create('dctheme', DirList);
end;
procedure TPixMapManager.DestroyIconTheme;
begin
{$IF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
{$IFDEF LCLGTK2}
FIconTheme:= nil;
{$ELSE}
if Assigned(FIconTheme) then
FreeAndNil(FIconTheme);
{$ENDIF}
{$ENDIF}
FreeThenNil(FDCIconTheme);
end;
{$IF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
procedure TPixMapManager.LoadMimeIconNames;
const
mime_globs = '/usr/share/mime/globs';
mime_generic_icons = '/usr/share/mime/generic-icons';
pixmaps_cache = 'pixmaps.cache';
cache_signature: DWord = $44435043; // 'DCPC'
cache_version: DWord = 1;
var
I, J, K: Integer;
globs: TStringListEx = nil;
generic_icons: TStringListEx = nil;
cache: TFileStreamEx = nil;
mTime: TFileTime;
sMimeType,
sMimeIconName,
sExtension: String;
node: THTDataNode = nil;
iconsList: TStringList;
EntriesCount, IconsCount: Cardinal;
nodeList: TFPObjectList;
begin
try
// Try to load from cache.
mTime:= mbFileAge(mime_globs);
if (mbFileAge(gpCfgDir + pixmaps_cache) = mTime) and
(mbFileAccess(gpCfgDir + pixmaps_cache, fmOpenRead)) and
(mbFileSize(gpCfgDir + pixmaps_cache) > SizeOf(DWord) * 2) then
begin
cache := TFileStreamEx.Create(gpCfgDir + pixmaps_cache, fmOpenRead);
if (cache.ReadDWord <> NtoBE(cache_signature)) or
(cache.ReadDWord <> cache_version) then
begin
FreeAndNil(cache);
end;
end;
if Assigned(cache) then
begin
EntriesCount := cache.ReadDWord;
FExtToMimeIconName.HashTableSize := EntriesCount;
// Each entry is a file extension with a list of icon names.
for I := 0 to EntriesCount - 1 do
begin
sExtension := cache.ReadAnsiString;
IconsCount := cache.ReadDWord;
iconsList := TStringList.Create;
FExtToMimeIconName.Add(sExtension, iconsList);
iconsList.Capacity := IconsCount;
for J := 0 to IconsCount - 1 do
iconsList.Add(cache.ReadAnsiString);
end;
end
else if mbFileAccess(mime_globs, fmOpenRead) then
begin
// Load mapping: MIME type -> file extension.
globs:= TStringListEx.Create;
globs.NameValueSeparator:= ':';
globs.LoadFromFile(mime_globs);
// Try to load mapping: MIME type -> generic MIME icon name.
if mbFileExists(mime_generic_icons) then
begin
generic_icons:= TStringListEx.Create;
generic_icons.NameValueSeparator:= ':';
generic_icons.LoadFromFile(mime_generic_icons);
end;
EntriesCount := 0;
// Create mapping: file extension -> list of MIME icon names.
for I:= 0 to globs.Count - 1 do
if (globs.Strings[I] <> '') and // bypass empty lines
(globs.Strings[I][1] <> '#') then // and comments
begin
sMimeType := globs.Names[I];
sMimeIconName:= StringReplace(sMimeType, '/', '-', []);
sExtension:= ExtractFileExt(globs.ValueFromIndex[I]);
// Support only extensions, not full file name masks.
if (sExtension <> '') and (sExtension <> '.*') then
begin
Delete(sExtension, 1, 1);
node := THTDataNode(FExtToMimeIconName.Find(sExtension));
if not Assigned(node) then
begin
iconsList := TStringList.Create;
FExtToMimeIconName.Add(sExtension, iconsList);
Inc(EntriesCount);
end
else
iconsList := TStringList(node.Data);
if iconsList.IndexOf(sMimeIconName) < 0 then
iconsList.Add(sMimeIconName);
// Shared-mime-info spec says:
// "If [generic-icon] is not specified then the mimetype is used to generate the
// generic icon by using the top-level media type (e.g. "video" in "video/ogg")
// and appending "-x-generic" (i.e. "video-x-generic" in the previous example)."
if Assigned(generic_icons) then
begin
J := generic_icons.IndexOfName(sMimeType);
if J <> -1 then
sMimeIconName := generic_icons.ValueFromIndex[J] // found generic icon
else
sMimeIconName := Copy2Symb(sMimeIconName, '-') + '-x-generic';
end
else
sMimeIconName := Copy2Symb(sMimeIconName, '-') + '-x-generic';
if iconsList.IndexOf(sMimeIconName) < 0 then
iconsList.Add(sMimeIconName);
end;
end;
// save to cache
cache := TFileStreamEx.Create(gpCfgDir + pixmaps_cache, fmCreate);
cache.WriteDWord(NtoBE(cache_signature));
cache.WriteDWord(cache_version);
cache.WriteDWord(EntriesCount);
for I := 0 to FExtToMimeIconName.HashTable.Count - 1 do
begin
nodeList := TFPObjectList(FExtToMimeIconName.HashTable.Items[I]);
if Assigned(nodeList) then
for J := 0 to nodeList.Count - 1 do
begin
node := THtDataNode(nodeList.Items[J]);
iconsList := TStringList(node.Data);
cache.WriteAnsiString(node.Key);
cache.WriteDWord(iconsList.Count);
for K := 0 to iconsList.Count - 1 do
cache.WriteAnsiString(iconsList.Strings[K]);
end;
end;
FreeAndNil(cache); // Close file
mbFileSetTime(gpCfgDir + pixmaps_cache, mTime, 0, 0);
end;
finally
if Assigned(globs) then
FreeAndNil(globs);
if Assigned(generic_icons) then
FreeAndNil(generic_icons);
if Assigned(cache) then
FreeAndNil(cache);
end;
end;
function TPixMapManager.GetMimeIcon(AFileExt: String; AIconSize: Integer): PtrInt;
var
I: Integer;
node: THTDataNode;
iconList: TStringList;
begin
// This function must be called under FPixmapsLock.
Result := -1;
// Search for an icon for this file extension.
node := THTDataNode(FExtToMimeIconName.Find(AFileExt));
if Assigned(node) then
begin
iconList := TStringList(node.Data);
// Try to load one of the icons in the list.
for I := 0 to iconList.Count - 1 do
begin
Result := CheckAddThemePixmapLocked(iconList.Strings[I], AIconSize);
if Result <> -1 then break;
end;
end;
end;
function TPixMapManager.GetIconByDesktopFile(sFileName: String; iDefaultIcon: PtrInt): PtrInt;
var
I: PtrInt;
iniDesktop: TIniFileEx = nil;
sIconName: String;
begin
try
iniDesktop:= TIniFileEx.Create(sFileName, fmOpenRead);
try
sIconName:= iniDesktop.ReadString('Desktop Entry', 'Icon', EmptyStr);
finally
FreeAndNil(iniDesktop);
end;
except
Exit(iDefaultIcon);
end;
{
Some icon names in .desktop files are specified with an extension,
even though it is not allowed by the standard unless an absolute path
to the icon is supplied. We delete this extension here.
}
if GetPathType(sIconName) = ptNone then
sIconName := TIconTheme.CutTrailingExtension(sIconName);
I:= GetIconByName(sIconName);
if I < 0 then
Result:= iDefaultIcon
else
Result:= I;
end;
{$ELSEIF DEFINED(DARWIN)}
function TPixMapManager.GetApplicationBundleIcon(sFileName: String;
iDefaultIcon: PtrInt): PtrInt;
var
I, J: PtrInt;
slInfoFile: TStringListEx = nil;
sTemp,
sIconName: String;
begin
Result:= iDefaultIcon;
slInfoFile:= TStringListEx.Create;
try
try
slInfoFile.LoadFromFile(sFileName + '/Contents/Info.plist');
sTemp:= slInfoFile.Text;
I:= Pos('CFBundleIconFile', sTemp);
if I <= 0 then Exit;
I:= PosEx('<string>', sTemp, I) + 8;
J:= PosEx('</string>', sTemp, I);
sIconName:= Copy(sTemp, I, J - I);
if not StrEnds(sIconName, '.icns') then
sIconName:= sIconName + '.icns';
sIconName:= sFileName + '/Contents/Resources/' + sIconName;
except
Exit;
end;
finally
slInfoFile.Free;
end;
I:= GetIconByName(sIconName);
if I >= 0 then Result:= I;
end;
{$ENDIF} // Unix
function TPixMapManager.CheckAddThemePixmapLocked(AIconName: String; AIconSize: Integer): PtrInt;
var
fileIndex: PtrInt;
{$IFDEF LCLGTK2}
pbPicture: PGdkPixbuf = nil;
sIconFileName: String;
{$ELSE}
bmpBitmap: Graphics.TBitmap;
{$ENDIF}
begin
// This function must be called under FPixmapsLock.
fileIndex := FThemePixmapsFileNames.Find(AIconName);
if fileIndex < 0 then
begin
{$IF DEFINED(LCLGTK2) AND DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
if gShowIcons > sim_standart then
begin
pbPicture:= gtk_icon_theme_load_icon(FIconTheme, Pgchar(AIconName),
AIconSize, GTK_ICON_LOOKUP_USE_BUILTIN, nil);
end;
// If not found in system theme or using of system theme is disabled look in DC theme.
if not Assigned(pbPicture) then
begin
sIconFileName := FDCIconTheme.FindIcon(AIconName, AIconSize);
if sIconFileName <> EmptyStr then
pbPicture := gdk_pixbuf_new_from_file_at_size(
PChar(sIconFileName), AIconSize, AIconSize, nil);
end;
if Assigned(pbPicture) then
begin
Result := FPixmapList.Add(pbPicture);
FThemePixmapsFileNames.Add(AIconName, Pointer(Result));
end
else
Result := -1;
{$ELSE}
bmpBitmap := LoadIconThemeBitmapLocked(AIconName, AIconSize);
if Assigned(bmpBitmap) then
begin
Result := FPixmapList.Add(bmpBitmap); // add to list
FThemePixmapsFileNames.Add(AIconName, Pointer(Result));
end
else
Result := -1;
{$ENDIF}
end
else
Result := PtrInt(FThemePixmapsFileNames.List[fileIndex]^.Data);
end;
function TPixMapManager.LoadIconThemeBitmapLocked(AIconName: String; AIconSize: Integer): Graphics.TBitmap;
var
sIconFileName: String;
{$IFDEF LCLGTK2}
pbPicture: PGdkPixbuf = nil;
{$ENDIF}
begin
// This function must be called under FPixmapsLock.
{$IF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
Result := nil;
{$IFDEF LCLGTK2}
if gShowIcons > sim_standart then
begin
pbPicture:= gtk_icon_theme_load_icon(FIconTheme, Pgchar(PChar(AIconName)),
AIconSize, GTK_ICON_LOOKUP_USE_BUILTIN, nil);
if pbPicture <> nil then
Result := PixBufToBitmap(pbPicture);
end;
{$ELSE}
sIconFileName:= FIconTheme.FindIcon(AIconName, AIconSize);
if sIconFileName <> EmptyStr then
begin
if TScalableVectorGraphics.IsFileExtensionSupported(ExtractFileExt(sIconFileName)) then
Result := BitmapLoadFromScalable(sIconFileName, AIconSize, AIconSize)
else
Result := CheckLoadPixmapFromFile(sIconFileName);
end;
{$ENDIF}
if not Assigned(Result) then
{$ENDIF}
begin
sIconFileName:= FDCIconTheme.FindIcon(AIconName, AIconSize);
if sIconFileName <> EmptyStr then
Result := CheckLoadPixmapFromFile(sIconFileName)
else
Result := nil;
end;
end;
{$IFDEF DARWIN}
function TPixMapManager.GetSystemFolderIcon: PtrInt;
var
FileType: String;
begin
FileType:= NSFileTypeForHFSTypeCode(kGenericFolderIcon).UTF8String;
Result:= GetMimeIcon(FileType, gIconsSize);
end;
function TPixMapManager.GetMimeIcon(AFileExt: String; AIconSize: Integer): PtrInt;
var
I: Integer;
nImage: NSImage;
nData: NSData;
nRepresentations: NSArray;
nImageRep: NSImageRep;
WorkStream: TBlobStream;
tfBitmap: TTiffImage;
bmBitmap: TBitmap;
begin
Result:= -1;
if not FUseSystemTheme then Exit;
nImage:= NSWorkspace.sharedWorkspace.iconForFileType(NSSTR(PChar(AFileExt)));
nRepresentations:= nImage.Representations;
if AIconSize = 22 then AIconSize:= 32;
for I:= nRepresentations.Count - 1 downto 0 do
begin
nImageRep:= NSImageRep(nRepresentations.objectAtIndex(I));
if (AIconSize <> nImageRep.Size.Width) then
nImage.removeRepresentation(nImageRep);
end;
if nImage.Representations.Count = 0 then Exit;
nData:= nImage.TIFFRepresentation;
tfBitmap:= TTiffImage.Create;
WorkStream:= TBlobStream.Create(nData.Bytes, nData.Length);
try
tfBitmap.LoadFromStream(WorkStream);
bmBitmap:= TBitmap.Create;
try
bmBitmap.Assign(tfBitmap);
Result:= FPixmapList.Add(bmBitmap);
except
bmBitmap.Free;
end;
finally
tfBitmap.Free;
WorkStream.Free;
end;
end;
{$ENDIF}
{$IFDEF WINDOWS}
function TPixMapManager.GetIconResourceIndex(const IconPath: String; out IconFile: String; out IconIndex: PtrInt): Boolean;
var
iPos, iIndex: Integer;
begin
iPos := Pos(',', IconPath);
if iPos <> 0 then
begin
if TryStrToInt(Copy(IconPath, iPos + 1, Length(IconPath) - iPos), iIndex) and (iIndex >= 0) then
begin
IconIndex := iIndex;
IconFile := Copy(IconPath, 1, iPos - 1);
Result := FileIsExeLib(IconFile);
end
else
Result := False;
end
else
begin
IconIndex := 0;
IconFile := IconPath;
Result := FileIsExeLib(IconFile);
end;
end;
function TPixMapManager.GetSystemFolderIcon: PtrInt;
var
FileInfo: TSHFileInfo;
begin
if (SHGetFileInfo('nil',
FILE_ATTRIBUTE_DIRECTORY,
FileInfo,
SizeOf(FileInfo),
SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES) = 0) then
Result := -1
else
Result := FileInfo.iIcon + SystemIconIndexStart;
end;
function TPixMapManager.GetSystemExecutableIcon: PtrInt;
var
FileInfo: TSHFileInfo;
begin
if (SHGetFileInfo(PAnsiChar('a.exe'), // Ansi version is enough.
FILE_ATTRIBUTE_NORMAL,
FileInfo,
SizeOf(FileInfo),
SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES) = 0) then
Result := -1
else
Result := FileInfo.iIcon + SystemIconIndexStart;
end;
{$ENDIF}
constructor TPixMapManager.Create;
{$IF DEFINED(DARWIN)}
var
systemVersion: SInt32;
{$ELSEIF DEFINED(MSWINDOWS)}
var
iIconSize : Integer;
{$ENDIF}
begin
FExtList := TStringHashList.Create(True);
FPixmapsFileNames := TStringHashList.Create(True);
FPixmapList := TFPList.Create;
{$IF DEFINED(DARWIN)}
FUseSystemTheme:= NSAppKitVersionNumber >= 1038;
{$ELSEIF DEFINED(UNIX)}
FExtToMimeIconName := TFPDataHashTable.Create;
FHomeFolder := IncludeTrailingBackslash(GetHomeDir);
{$ENDIF}
FThemePixmapsFileNames := TStringHashList.Create(True);
CreateIconTheme;
{$IFDEF MSWINDOWS}
case gIconsSize of
16: iIconSize := SHIL_SMALL;
32: iIconSize := SHIL_LARGE;
else iIconSize := SHIL_EXTRALARGE;
end;
FSysImgList := SHGetSystemImageList(iIconSize);
{$ENDIF}
FPixmapsLock := syncobjs.TCriticalSection.Create;
end;
destructor TPixMapManager.Destroy;
var
I : Integer;
{$IF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
J : Integer;
nodeList: TFPObjectList;
{$ENDIF}
begin
if Assigned(FPixmapList) then
begin
for I := 0 to FPixmapList.Count - 1 do
if Assigned(FPixmapList.Items[I]) then
{$IFDEF LCLGTK2}
g_object_unref(PGdkPixbuf(FPixmapList.Items[I]));
{$ELSE}
Graphics.TBitmap(FPixmapList.Items[I]).Free;
{$ENDIF}
FreeAndNil(FPixmapList);
end;
if Assigned(FExtList) then
FreeAndNil(FExtList);
if Assigned(FPixmapsFileNames) then
FreeAndNil(FPixmapsFileNames);
for I := Low(FDriveIconList) to High(FDriveIconList) do
with FDriveIconList[I] do
begin
if Assigned(bmMediaFloppy) then FreeAndNil(bmMediaFloppy);
if Assigned(bmDriveHardDisk) then FreeAndNil(bmDriveHardDisk);
if Assigned(bmMediaFlash) then FreeAndNil(bmMediaFlash);
if Assigned(bmMediaOptical) then FreeAndNil(bmMediaOptical);
if Assigned(bmDriveNetwork) then FreeAndNil(bmDriveNetwork);
if Assigned(bmDriveVirtual) then FreeAndNil(bmDriveVirtual);
if Assigned(bmDriveRemovableMedia) then FreeAndNil(bmDriveRemovableMedia);
if Assigned(bmDriveRemovableMediaUsb) then FreeAndNil(bmDriveRemovableMediaUsb);
end;
{$IF DEFINED(MSWINDOWS)}
ImageList_Destroy(FSysImgList);
{$ELSEIF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
for I := 0 to FExtToMimeIconName.HashTable.Count - 1 do
begin
nodeList := TFPObjectList(FExtToMimeIconName.HashTable.Items[I]);
if Assigned(nodeList) then
for J := 0 to nodeList.Count - 1 do
TStringList(THtDataNode(nodeList.Items[J]).Data).Free;
end;
FreeThenNil(FExtToMimeIconName);
{$ENDIF}
DestroyIconTheme;
FreeThenNil(FThemePixmapsFileNames);
FreeThenNil(FPixmapsLock);
inherited Destroy;
end;
procedure TPixMapManager.Load(const sFileName: String);
var
slPixmapList: TStringListEx;
s:String;
sExt, sPixMap:String;
iekv:integer;
iPixMap:PtrInt;
I : Integer;
iPixmapSize: Integer;
begin
// This function doesn't need to be synchronized
// as long as it is called before creating the main form
// (via LoadPixMapManager in doublecmd.lpr).
// Load icon themes.
{$IF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
if gShowIcons > sim_standart then
begin
LoadMimeIconNames; // For use with GetMimeIcon
{$IFNDEF LCLGTK2}
FIconTheme.Load; // Load system icon theme.
{$ENDIF}
end;
{$ENDIF}
FDCIconTheme.Load; // Load DC theme.
// load all drive icons
FDriveIconList[0].Size := 16;
FDriveIconList[1].Size := 22;
FDriveIconList[2].Size := 32;
for I:= Low(FDriveIconList) to High(FDriveIconList) do
with FDriveIconList[I] do
begin
iPixmapSize := FDriveIconList[I].Size;
bmMediaFloppy := LoadIconThemeBitmapLocked('media-floppy', iPixmapSize);
bmDriveHardDisk := LoadIconThemeBitmapLocked('drive-harddisk', iPixmapSize);
bmMediaFlash := LoadIconThemeBitmapLocked('media-flash', iPixmapSize);
bmMediaOptical := LoadIconThemeBitmapLocked('media-optical', iPixmapSize);
bmDriveNetwork:= LoadIconThemeBitmapLocked('network-wired', iPixmapSize);
bmDriveVirtual:= LoadIconThemeBitmapLocked('folder-virtual', iPixmapSize);
bmDriveRemovableMedia:= LoadIconThemeBitmapLocked('drive-removable-media', iPixmapSize);
bmDriveRemovableMediaUsb:= LoadIconThemeBitmapLocked('drive-removable-media-usb', iPixmapSize);
end;
// load emblems
if gIconsSize = 22 then
I:= 16
else if gIconsSize = 48 then
I:= 22
else
I:= gIconsSize div 2;
FiEmblemLinkID:= CheckAddThemePixmap('emblem-symbolic-link', I);
FiEmblemUnreadableID:= CheckAddThemePixmap('emblem-unreadable', I);
// add some standard icons
FiDefaultIconID:=CheckAddThemePixmap('unknown');
{$IF DEFINED(MSWINDOWS) or DEFINED(DARWIN)}
FiDirIconID := -1;
if gShowIcons > sim_standart then
FiDirIconID := GetSystemFolderIcon;
if FiDirIconID = -1 then
{$ENDIF}
FiDirIconID:=CheckAddThemePixmap('folder');
FiDirLinkIconID:=CheckAddThemePixmap('folder-link');
FiDirLinkBrokenIconID:=CheckAddThemePixmap('folder-link-broken');
FiLinkIconID:=CheckAddThemePixmap('link');
FiLinkBrokenIconID:=CheckAddThemePixmap('link-broken');
FiUpDirIconID:=CheckAddThemePixmap('go-up');
FiArcIconID := CheckAddThemePixmap('package-x-generic');
{$IFDEF MSWINDOWS}
FiExeIconID := -1;
if gShowIcons > sim_standart then
FiExeIconID := GetSystemExecutableIcon;
if FiExeIconID = -1 then
{$ENDIF}
FiExeIconID:= CheckAddThemePixmap('application-x-executable');
FiSortAscID := CheckAddThemePixmap('view-sort-ascending');
FiSortDescID := CheckAddThemePixmap('view-sort-descending');
gFiOwnDCIcon := CheckAddPixmap(ParamStr(0), gIconsSize);
{ Load icons from "extassoc.xml" }
for I := 0 to gExts.Count - 1 do
begin
iPixMap := CheckAddPixmap(gExts.Items[I].Icon, gIconsSize);
if iPixMap >= 0 then
begin
// set pixmap index for all extensions
for iekv := 0 to gExts.Items[I].Extensions.Count - 1 do
begin
sExt := LowerCase(gExts.Items[I].Extensions[iekv]);
if FExtList.Find(sExt) < 0 then
FExtList.Add(sExt, TObject(iPixMap));
end;
end
else
iPixMap:= FiDefaultIconID;
gExts.Items[I].IconIndex:= iPixMap;
end;
{/ Load icons from "extassoc.xml" }
// Load icons from pixmaps.txt only if "Only standart icons" enabled
if (gShowIcons = sim_standart) and mbFileExists(sFileName) then
try
slPixmapList:= TStringListEx.Create;
try
slPixmapList.LoadFromFile(sFileName);
for I:= 0 to slPixmapList.Count - 1 do
begin
s:= Trim(slPixmapList.Strings[I]);
iekv := Pos('=',s);
if iekv = 0 then
Continue;
sPixMap := Copy(s, iekv+1, length(s)-iekv);
// Since DC 0.4.6 filename without path is treated as a MIME type
// and it shouldn't have an extension. Cut any extension here.
// Only '.png' were used in previous versions of pixmaps.txt.
if (GetPathType(sPixMap) = ptNone) and StrEnds(sPixMap, '.png') then
Delete(sPixMap, Length(sPixMap) - 3, 4);
iPixMap := CheckAddPixmap(sPixMap);
if iPixMap >= 0 then
begin
sExt := Copy(s, 1, iekv-1);
if FExtList.Find(sExt) < 0 then
FExtList.Add(sExt, TObject(iPixMap));
end;
end;
except
on E: Exception do
with Application do
MessageBox(PAnsiChar(E.Message), PAnsiChar(Title), MB_OK or MB_ICONERROR);
end;
finally
slPixmapList.Free;
end;
(* Set archive icons *)
for I:=0 to gWCXPlugins.Count - 1 do
begin
if gWCXPlugins.Enabled[I] and ((gWCXPlugins.Flags[I] and PK_CAPS_HIDE) <> PK_CAPS_HIDE) then
begin
sExt := gWCXPlugins.Ext[I];
if (Length(sExt) > 0) and (FExtList.Find(sExt) < 0) then
FExtList.Add(sExt, TObject(FiArcIconID));
end;
end; //for
for I:= 0 to gMultiArcList.Count - 1 do
begin
if gMultiArcList.Items[I].FEnabled then
begin
sExt := gMultiArcList.Items[I].FExtension;
if (Length(sExt) > 0) and (FExtList.Find(sExt) < 0) then
FExtList.Add(sExt, TObject(FiArcIconID));
end;
end;
(* /Set archive icons *)
end;
function TPixMapManager.GetBitmap(iIndex: PtrInt): Graphics.TBitmap;
var
PPixmap: Pointer;
PixmapFromList: Boolean = False;
{$IFDEF MSWINDOWS}
hicn: HICON;
Icon: TIcon = nil;
{$ENDIF}
begin
FPixmapsLock.Acquire;
try
if (iIndex >= 0) and (iIndex < FPixmapList.Count) then
begin
PPixmap := FPixmapList[iIndex];
PixmapFromList := True;
end;
finally
FPixmapsLock.Release;
end;
if PixmapFromList then
begin
{$IFDEF LCLGTK2}
Result:= PixBufToBitmap(PGdkPixbuf(PPixmap));
{$ELSE}
// Make a new copy.
Result := Graphics.TBitmap.Create;
Result.Assign(Graphics.TBitmap(PPixmap));
{$ENDIF}
end
else
{$IFDEF MSWINDOWS}
if iIndex >= SystemIconIndexStart then
begin
Result:= nil;
hicn:= ImageList_GetIcon(FSysImgList, iIndex - SystemIconIndexStart, ILD_NORMAL);
if hicn <> 0 then
try
Icon := CreateIconFromHandle(hicn);
Result := Graphics.TBitmap.Create;
Result.Assign(Icon);
Result.Masked := True; // Need to explicitly set Masked=True, Lazarus issue #0019747
finally
FreeThenNil(Icon);
DestroyIcon(hicn);
end
end
else
{$ENDIF}
Result:= nil;
end;
function TPixMapManager.DrawBitmap(iIndex: PtrInt; Canvas : TCanvas; X, Y: Integer) : Boolean;
begin
Result := DrawBitmap(iIndex, Canvas, X, Y, gIconsSize, gIconsSize); // X, Y, 0, 0 - No bitmap stretching.
end;
function TPixMapManager.DrawBitmap(iIndex: PtrInt; Canvas: TCanvas; X, Y, Width, Height: Integer): Boolean;
procedure TrySetSize(aWidth, aHeight: Integer);
begin
if Width = 0 then
Width := aWidth;
if Height = 0 then
Height := aHeight;
end;
var
PPixmap: Pointer;
PixmapFromList: Boolean = False;
{$IFDEF MSWINDOWS}
hicn: HICON;
cx, cy: Integer;
{$ENDIF}
{$IFDEF LCLGTK2}
pbPicture : PGdkPixbuf;
iPixbufWidth : Integer;
iPixbufHeight : Integer;
{$ELSE}
Bitmap: Graphics.TBitmap;
aRect: TRect;
{$ENDIF}
begin
Result := True;
FPixmapsLock.Acquire;
try
if (iIndex >= 0) and (iIndex < FPixmapList.Count) then
begin
PPixmap := FPixmapList[iIndex];
PixmapFromList := True;
end;
finally
FPixmapsLock.Release;
end;
if PixmapFromList then
begin
{$IFDEF LCLGTK2}
pbPicture := PGdkPixbuf(PPixmap);
iPixbufWidth := gdk_pixbuf_get_width(pbPicture);
iPixbufHeight := gdk_pixbuf_get_height(pbPicture);
TrySetSize(iPixbufWidth, iPixbufHeight);
DrawPixbufAtCanvas(Canvas, pbPicture, 0, 0, X, Y, Width, Height);
{$ELSE}
Bitmap := Graphics.TBitmap(PPixmap);
TrySetSize(Bitmap.Width, Bitmap.Height);
aRect := Classes.Bounds(X, Y, Width, Height);
Canvas.StretchDraw(aRect, Bitmap);
{$ENDIF}
end
else
{$IFDEF MSWINDOWS}
if iIndex >= SystemIconIndexStart then
try
if ImageList_GetIconSize(FSysImgList, @cx, @cy) then
TrySetSize(cx, cy)
else
TrySetSize(gIconsSize, gIconsSize);
if (Height in [16, 32, 48]) and (cx = Width) and (cy = Height) then
// for transparent
ImageList_Draw(FSysImgList, iIndex - SystemIconIndexStart, Canvas.Handle, X, Y, ILD_TRANSPARENT)
else
begin
hicn:= ImageList_GetIcon(FSysImgList, iIndex - SystemIconIndexStart, ILD_NORMAL);
try
if IsGdiPlusLoaded then
Result:= GdiPlusStretchDraw(hicn, Canvas.Handle, X, Y, Width, Height)
else
Result:= DrawIconEx(Canvas.Handle, X, Y, hicn, Width, Height, 0, 0, DI_NORMAL);
finally
DestroyIcon(hicn);
end;
end;
except
Result:= False;
end;
{$ELSE}
Result:= False;
{$ENDIF}
end;
function TPixMapManager.DrawBitmapOverlay(AFile: TDisplayFile; DirectAccess: Boolean; Canvas: TCanvas; X, Y: Integer): Boolean;
var
I: Integer;
begin
if AFile.FSFile.IsLink then
begin
I:= gIconsSize div 2;
Result:= DrawBitmap(FiEmblemLinkID, Canvas, X, Y + I, I, I);
if Assigned(AFile.FSFile.LinkProperty) then
begin
if not AFile.FSFile.LinkProperty.IsValid then
Result:= DrawBitmap(FiEmblemUnreadableID, Canvas, X + I, Y + I, I, I);
end;
end
{$IF DEFINED(MSWINDOWS) OR DEFINED(RabbitVCS)}
else
// Windows XP doesn't draw link overlay icon for soft links (don't know about Vista or 7).
if DirectAccess then
begin
if AFile.IconOverlayID >= SystemIconIndexStart then
Result:= DrawBitmap(AFile.IconOverlayID
{$IFDEF RabbitVCS} - SystemIconIndexStart {$ENDIF},
Canvas, X, Y);
end;
{$ENDIF}
;
end;
function TPixMapManager.GetIconBySortingDirection(SortingDirection: TSortDirection): PtrInt;
begin
case SortingDirection of
sdDescending:
begin
Result := FiSortDescID;
end;
sdAscending:
begin
Result := FiSortAscID;
end;
else
Result := -1;
end;
end;
function TPixMapManager.GetIconByFile(AFile: TFile; DirectAccess: Boolean; LoadIcon: Boolean;
IconsMode: TShowIconsMode; GetIconWithLink: Boolean): PtrInt;
var
Ext: String;
{$IFDEF MSWINDOWS}
sFileName: String;
FileInfo: TSHFileInfoW;
dwFileAttributes: DWORD;
uFlags: UINT;
{$ENDIF}
begin
Result := -1;
if not Assigned(AFile) then Exit;
with AFile do
begin
if Name = '..' then
begin
Result := FiUpDirIconID;
Exit;
end;
if IsLinkToDirectory then
begin
if GetIconWithLink then
begin
if (LinkProperty = nil) or LinkProperty.IsValid then
Result := FiDirLinkIconID
else
Result := FiDirLinkBrokenIconID;
Exit;
end;
end;
if IsDirectory or IsLinkToDirectory then
begin
{$IF DEFINED(MSWINDOWS)}
if (IconsMode = sim_standart) or
// Directory has special icon only if it has "read only" or "system" attributes
// and contains desktop.ini file
(not (DirectAccess and (IsSysFile or FileIsReadOnly(Attributes)) and mbFileExists(FullPath + '\desktop.ini'))) or
(GetDeviceCaps(Application.MainForm.Canvas.Handle, BITSPIXEL) < 16) then
{$ELSEIF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
if (IconsMode = sim_all_and_exe) and (DirectAccess) then
begin
if mbFileAccess(Path + Name + '/.directory', fmOpenRead) then
begin
if LoadIcon then
Result := GetIconByDesktopFile(Path + Name + '/.directory', FiDirIconID)
else
Result := -1;
Exit;
end
else if (FHomeFolder = Path) then
begin
if LoadIcon then
Result := CheckAddThemePixmap(GioFileGetIcon(FullPath))
else
Result := -1;
Exit;
end
else Exit(FiDirIconID);
end
else
{$ELSEIF DEFINED(DARWIN)}
if (IconsMode = sim_all_and_exe) and
(DirectAccess and (ExtractFileExt(FullPath) = '.app')) then
begin
if LoadIcon then
Result := GetApplicationBundleIcon(FullPath, FiDirIconID)
else
Result := -1;
Exit;
end
else
{$ENDIF}
begin
Exit(FiDirIconID);
end;
end
else // not directory
begin
if IsLink and GetIconWithLink then
begin
if (LinkProperty = nil) or LinkProperty.IsValid then
Exit(FiLinkIconID)
else
Exit(FiLinkBrokenIconID);
end;
if (Extension = '') then
Exit(FiDefaultIconID);
Ext := UTF8LowerCase(Extension);
{$IF DEFINED(MSWINDOWS)}
if IconsMode <> sim_all_and_exe then
begin
if Ext = 'exe' then
Exit(FiExeIconID)
else if Ext = 'lnk' then
Exit(FiLinkIconID)
else if Ext = 'url' then
Exit(FiLinkIconID)
else if Ext = 'ico' then
Exit(FiDefaultIconID)
end;
{$ELSEIF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
if IconsMode = sim_all_and_exe then
begin
if DirectAccess and (Ext = 'desktop') then
begin
if LoadIcon then
Result := GetIconByDesktopFile(Path + Name, FiDefaultIconID)
else
Result := -1;
Exit;
end;
end;
{$ENDIF}
FPixmapsLock.Acquire;
try
Result := FExtList.Find(Ext);
if Result >= 0 then
Exit(PtrInt(PtrUInt(FExtList.List[Result]^.Data)));
if IconsMode <= sim_standart then
Exit(FiDefaultIconID);
{$IF DEFINED(UNIX)}
if LoadIcon = False then
Exit(-1);
Result := GetMimeIcon(Ext, gIconsSize);
if Result < 0 then
Result := FiDefaultIconID;
// Default icon should also be associated with the extension
// because it will be faster to find next time.
FExtList.Add(Ext, Pointer(Result));
{$ENDIF}
finally
FPixmapsLock.Release;
end;
end;
{$IF DEFINED(MSWINDOWS)}
if DirectAccess then
begin
if LoadIcon = False then
Exit(-1);
dwFileAttributes := 0;
uFlags := SHGFI_SYSICONINDEX;
sFileName := FullPath;
end
else
begin
// This is fast, so do it even if LoadIcon is false.
dwFileAttributes := FILE_ATTRIBUTE_NORMAL;
uFlags := SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES;
sFileName := Name;
end;
if (SHGetFileInfoW(PWideChar(UTF8Decode(sFileName)),
dwFileAttributes,
FileInfo,
SizeOf(FileInfo),
uFlags) = 0) then
begin
// Could not retrieve icon.
if IsDirectory then
Result := FiDirIconID
else
Result := FiDefaultIconID;
end
else
begin
Result := FileInfo.iIcon + SystemIconIndexStart;
if (not IsDirectory) and
(Ext <> 'exe') and
(Ext <> 'ico') and
(Ext <> 'ani') and
(Ext <> 'cur') and
(Ext <> 'lnk') and
(Ext <> 'url') then
begin
FPixmapsLock.Acquire;
try
FExtList.Add(Ext, Pointer(Result));
finally
FPixmapsLock.Release;
end;
end;
end;
{$ENDIF}
end;
end;
{$IF DEFINED(MSWINDOWS)}
function TPixMapManager.GetIconOverlayByFile(AFile: TFile; DirectAccess: Boolean): PtrInt;
begin
if DirectAccess then
Result:= SHGetOverlayIconIndex(AFile.Path, AFile.Name) + SystemIconIndexStart
else
Result:= -1;
end;
{$ELSEIF DEFINED(RabbitVCS)}
function TPixMapManager.GetIconOverlayByFile(AFile: TFile; DirectAccess: Boolean): PtrInt;
var
Emblem: String;
begin
if RabbitVCS and DirectAccess then
begin
Emblem:= CheckStatus(AFile.FullPath);
if Length(Emblem) = 0 then Exit(0);
Result:= CheckAddThemePixmap(Emblem);
Result:= IfThen(Result < 0, 0, Result + SystemIconIndexStart);
end
else
Result:= 0;
end;
{$ENDIF}
function TPixMapManager.GetIconByName(const AIconName: String): PtrInt;
begin
Result := CheckAddPixmap(AIconName, gIconsSize);
end;
function TPixMapManager.GetDriveIcon(Drive : PDrive; IconSize : Integer; clBackColor : TColor) : Graphics.TBitmap;
{$IFDEF MSWINDOWS}
var
SFI: TSHFileInfoW;
Icon: TIcon = nil;
uFlags: UINT;
iIconSmall,
iIconLarge: Integer;
{$ENDIF}
begin
if Drive^.DriveType = dtVirtual then
begin
Result := GetVirtualDriveIcon(IconSize, clBackColor);
Exit;
end;
Result := nil;
{$IFDEF MSWINDOWS}
if GetDeviceCaps(Application.MainForm.Canvas.Handle, BITSPIXEL) < 15 then Exit;
if (not gCustomDriveIcons) and (GetDeviceCaps(Application.MainForm.Canvas.Handle, BITSPIXEL) > 16) then
begin
SFI.hIcon := 0;
Result := Graphics.TBitMap.Create;
iIconSmall:= GetSystemMetrics(SM_CXSMICON);
iIconLarge:= GetSystemMetrics(SM_CXICON);
if (IconSize = 16) and (iIconSmall = 16) then // standart small icon
uFlags := SHGFI_SMALLICON // Use small icon
else if (IconSize = 32) and (iIconLarge = 32) then // standart large icon
uFlags := SHGFI_LARGEICON // Use large icon
else if IconSize > iIconSmall then
uFlags := SHGFI_LARGEICON // Use large icon
else
uFlags := SHGFI_SMALLICON; // Use small icon
if (SHGetFileInfoW(PWideChar(UTF8Decode(Drive^.Path)), 0, SFI,
SizeOf(SFI), uFlags or SHGFI_ICON) <> 0) and
(SFI.hIcon <> 0) then
begin
if (IconSize = iIconSmall) or (IconSize = iIconLarge) then // standart icon size
try
Icon := CreateIconFromHandle(SFI.hIcon);
Result.Assign(Icon);
Result.Masked := True; // Need to explicitly set Masked=True, Lazarus issue #0019747
finally
FreeThenNil(Icon);
DestroyIcon(SFI.hIcon);
end
else // non standart icon size
try
Icon := CreateIconFromHandle(SFI.hIcon);
Result.Assign(Icon);
Result.Masked := True; // Need to explicitly set Masked=True, Lazarus issue #0019747
Result := StretchBitmap(Result, IconSize, clBackColor, True);
finally
FreeThenNil(Icon);
DestroyIcon(SFI.hIcon);
end
end;
end // not gCustomDriveIcons
else
{$ENDIF}
begin
Result := GetBuiltInDriveIcon(Drive, IconSize, clBackColor);
end;
end;
function TPixMapManager.GetBuiltInDriveIcon(Drive : PDrive; IconSize : Integer; clBackColor : TColor) : Graphics.TBitmap;
var
DriveIconListIndex: Integer;
Bitmap: Graphics.TBitmap;
begin
{$IFDEF MSWINDOWS}
if GetDeviceCaps(Application.MainForm.Canvas.Handle, BITSPIXEL) < 15 then Exit(nil);
{$ENDIF}
case IconSize of
16: // Standart 16x16 icon size
DriveIconListIndex := 0;
22: // Standart 22x22 icon size
DriveIconListIndex := 1;
32: // Standart 32x32 icon size
DriveIconListIndex := 2;
else // for non standart icon size use more large icon for stretch
DriveIconListIndex := 2;
end;
with FDriveIconList[DriveIconListIndex] do
case Drive^.DriveType of
dtFloppy:
Bitmap := bmMediaFloppy;
dtHardDisk:
Bitmap := bmDriveHardDisk;
dtFlash:
Bitmap := bmMediaFlash;
dtOptical:
Bitmap := bmMediaOptical;
dtNetwork:
Bitmap := bmDriveNetwork;
dtRemovable:
Bitmap := bmDriveRemovableMedia;
dtRemovableUsb:
Bitmap := bmDriveRemovableMediaUsb;
else
Bitmap := bmDriveHardDisk;
end;
// if need stretch icon
if (IconSize <> 16) and (IconSize <> 22) and (IconSize <> 32) then
begin
Result := StretchBitmap(Bitmap, IconSize, clBackColor, False);
end
else
begin
Result := Graphics.TBitmap.Create;
Result.Assign(Bitmap);
end;
// 'Bitmap' should not be freed, because it only points to DriveIconList.
end;
function TPixMapManager.GetDefaultDriveIcon(IconSize : Integer; clBackColor : TColor) : Graphics.TBitmap;
var
Drive: TDrive = (DisplayName: ''; Path: ''; DriveLabel: ''; DeviceId: '';
DriveType: dtHardDisk; FileSystem: ''; IsMediaAvailable: True;
IsMediaEjectable: False; IsMediaRemovable: False;
IsMounted: True; AutoMount: True);
begin
Result := GetBuiltInDriveIcon(@Drive, IconSize, clBackColor);
end;
function TPixMapManager.GetVirtualDriveIcon(IconSize: Integer;
clBackColor: TColor): Graphics.TBitmap;
var
DriveIconListIndex: Integer;
begin
case IconSize of
16: // Standart 16x16 icon size
DriveIconListIndex := 0;
22: // Standart 22x22 icon size
DriveIconListIndex := 1;
32: // Standart 32x32 icon size
DriveIconListIndex := 2;
else // for non standart icon size use more large icon for stretch
DriveIconListIndex := 2;
end;
with FDriveIconList[DriveIconListIndex] do
begin
// if need stretch icon
if (IconSize <> 16) and (IconSize <> 22) and (IconSize <> 32) then
begin
Result := StretchBitmap(bmDriveVirtual, IconSize, clBackColor, False);
end
else
begin
Result := Graphics.TBitmap.Create;
Result.Assign(bmDriveVirtual);
end;
end;
end;
function TPixMapManager.GetArchiveIcon(IconSize: Integer; clBackColor : TColor) : Graphics.TBitmap;
begin
Result := GetBitmap(FiArcIconID);
if Assigned(Result) then
begin
// if need stretch icon
if (IconSize <> gIconsSize) then
begin
Result := StretchBitmap(Result, IconSize, clBackColor, True);
end;
end;
end;
function TPixMapManager.GetFolderIcon(IconSize: Integer; clBackColor: TColor): Graphics.TBitmap;
begin
Result := GetBitmap(FiDirIconID);
if Assigned(Result) then
begin
// if need stretch icon
if (IconSize <> gIconsSize) then
begin
Result := StretchBitmap(Result, IconSize, clBackColor, True);
end;
end;
end;
function TPixMapManager.GetDefaultIcon(AFile: TFile): PtrInt;
begin
if AFile.IsDirectory then
Result := FiDirIconID
else if UTF8LowerCase(AFile.Extension) = 'exe' then
Result := FiExeIconID
else
Result := FiDefaultIconID;
end;
procedure LoadPixMapManager;
begin
DCDebug('Creating PixmapManager');
PixMapManager:=TPixMapManager.Create;
PixMapManager.Load(gpCfgDir + 'pixmaps.txt');
end;
initialization
finalization
if Assigned(PixMapManager) then
begin
DCDebug('Shutting down PixmapManager');
FreeAndNil(PixMapManager);
end;
end.