{$IFDEF MSWINDOWS}
procedure CreateDesktopShortCut(const Target, TargetArguments, ShortcutName: string; const AddContext:boolean);
var
IObject: IUnknown;
ISLink: IShellLink;
IPFile: IPersistFile;
PIDL: PItemIDList;
InFolder: array[0..MAX_PATH] of Char;
LinkName: WideString;
begin
{ Creates an instance of IShellLink }
IObject := CreateComObject(CLSID_ShellLink);
ISLink := IObject as IShellLink;
IPFile := IObject as IPersistFile;
ISLink.SetPath(pChar(Target));
ISLink.SetArguments(pChar(TargetArguments));
ISLink.SetWorkingDirectory(pChar(ExtractFilePath(Target)));
{ Get the desktop location }
SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, PIDL);
SHGetPathFromIDList(PIDL, InFolder);
LinkName := IncludeTrailingPathDelimiter(InFolder) + ShortcutName+'.lnk';
{ Get rid of any existing shortcut first }
SysUtils.DeleteFile(LinkName);
{ Create the link }
IPFile.Save(PWChar(LinkName), false);
end;
{$ELSE}
{$IFDEF DARWIN}
procedure CreateDesktopShortCut(const Target, TargetArguments, ShortcutName: string; const AddContext:boolean);
begin
// Create shortcut on Desktop and in Applications
fpSystem(
'/usr/bin/osascript << EOF'+#10+
'tell application "Finder"'+#10+
'set myLazApp to POSIX file "'+IncludeLeadingPathDelimiter(Target)+'.app" as alias'+#10+
'try'+#10+
'set myLazDeskShort to (path to desktop folder as string) & "'+ShortcutName+'" as alias'+#10+
'on error'+#10+
'make new alias to myLazApp at (path to desktop folder as text)'+#10+
'set name of result to "'+ShortcutName+'"'+#10+
'end try'+#10+
'try'+#10+
'set myLazAppShort to (path to applications folder as string) & "'+ShortcutName+'" as alias'+#10+
'on error'+#10+
'make new alias to myLazApp at (path to applications folder as text)'+#10+
'set name of result to "'+ShortcutName+'"'+#10+
'end try'+#10+
'end tell'+#10+
'EOF');
end;
{$ELSE}
{$IFDEF UNIX}
procedure CreateDesktopShortCut(const Target, TargetArguments, ShortcutName: string; const AddContext:boolean);
var
OperationSucceeded: boolean;
XdgDesktopContent: TStringList;
XdgMimeContent: TStringList;
Output,XdgDesktopFile,XdgMimeFile: string;
aDirectory:string;
aIconFile:string;
begin
{$ifdef Haiku}
exit;
{$endif}
// Fail by default:
OperationSucceeded:=false;
XdgDesktopFile:=IncludeTrailingPathDelimiter(GetTempDir(false))+'fpcup-'+shortcutname+'.desktop';
XdgDesktopContent:=TStringList.Create;
try
XdgDesktopContent.Add('[Desktop Entry]');
XdgDesktopContent.Add('Version=1.0');
XdgDesktopContent.Add('Encoding=UTF-8');
XdgDesktopContent.Add('Type=Application');
aIconFile:='';
{$ifdef LINUX}
aIconFile:=ExtractFilePath(Target)+'images/icons/lazarus128x128.png';
if (NOT FileExists(aIconFile)) then aIconFile:=ExtractFilePath(Target)+'images/icons/lazarus32x32.png';
if (NOT FileExists(aIconFile)) then aIconFile:=ExtractFilePath(Target)+'images/icons/lazarus.png';
{$endif}
if (Length(aIconFile)=0) OR (NOT FileExists(aIconFile)) then aIconFile:=ExtractFilePath(Target)+'images/icons/lazarus.ico';
XdgDesktopContent.Add('Icon='+aIconFile);
XdgDesktopContent.Add('Path='+ExtractFilePath(Target));
{$ifdef DISABLE_PPC_CONFIG_PATH}
XdgDesktopContent.Add('Exec=env -u PPC_CONFIG_PATH '+Target+' '+TargetArguments+' %f');
{$else}
XdgDesktopContent.Add('Exec='+Target+' '+TargetArguments+' %f');
{$endif}
XdgDesktopContent.Add('Name='+ShortcutName);
XdgDesktopContent.Add('GenericName=Lazarus IDE with Free Pascal Compiler');
XdgDesktopContent.Add('Category=Application;IDE;Development;GUIDesigner;Programming;');
XdgDesktopContent.Add('Categories=Application;IDE;Development;GUIDesigner;Programming;');
XdgDesktopContent.Add('Keywords=editor;Pascal;IDE;FreePascal;fpc;Design;Designer;');
if AddContext then
begin
//XdgDesktopContent.Add('StartupWMClass=Lazarus');
XdgDesktopContent.Add('MimeType=application/x-lazarus;');
//XdgDesktopContent.Add('Patterns=*.pas;*.pp;*.p;*.inc;*.lpi;*.lpk;*.lpr;*.lfm;*.lrs;*.lpl;');
end;
// We're going to try and call xdg-desktop-icon/menu
// this may fail if shortcut exists already
try
XdgDesktopContent.SaveToFile(XdgDesktopFile);
FpChmod(XdgDesktopFile, &711); //rwx--x--x
OperationSucceeded:=RunCommand('xdg-desktop-icon' ,['install','--novendor',XdgDesktopFile],Output,[poUsePipes, poStderrToOutPut]{$IF DEFINED(FPC_FULLVERSION) AND (FPC_FULLVERSION >= 30200)},swoHide{$ENDIF});
OperationSucceeded:=RunCommand('xdg-desktop-menu' ,['install','--novendor',XdgDesktopFile],Output,[poUsePipes, poStderrToOutPut]{$IF DEFINED(FPC_FULLVERSION) AND (FPC_FULLVERSION >= 30200)},swoHide{$ENDIF});
except
OperationSucceeded:=false;
end;
if (true) then
begin
aDirectory:=ConcatPaths(['usr','share','applications']);
if ( (FpGeteuid=0) AND DirectoryExists(aDirectory) ) then
begin
FileCopy(XdgDesktopFile,aDirectory+DirectorySeparator+ExtractFileName(XdgDesktopFile),[]);
end
else
begin
// Create shortcut directly on User-Desktop
aDirectory:=ConcatPaths([GetUserDir,'Desktop']);
if DirectoryExists(aDirectory) then
FileCopy(XdgDesktopFile,aDirectory+DirectorySeparator+ExtractFileName(XdgDesktopFile),[]);
// Create user menu item
if (NOT OperationSucceeded) then
begin
aDirectory:=ConcatPaths([GetUserDir,'.local','share','applications']);
if DirectoryExists(aDirectory) then
FileCopy(XdgDesktopFile,aDirectory+DirectorySeparator+ExtractFileName(XdgDesktopFile),[]);
end;
end;
end;
// Temp file is no longer needed....
try
SysUtils.DeleteFile(XdgDesktopFile);
finally
// Swallow, let filesystem maintenance clear it up
end;
finally
XdgDesktopContent.Free;
OperationSucceeded:=true;
end;
if (OperationSucceeded) then
begin
aDirectory:=ConcatPaths([GetUserDir,'.local','share','applications']);
OperationSucceeded:=RunCommand('update-desktop-database' ,[aDirectory],Output,[poUsePipes, poStderrToOutPut]{$IF DEFINED(FPC_FULLVERSION) AND (FPC_FULLVERSION >= 30200)},swoHide{$ENDIF});
end;
if AddContext then
begin
ThreadLog('Adding context !');
{$ifdef LCL}
Application.ProcessMessages;
{$endif}
aDirectory:=ConcatPaths([GetUserDir,'.local','share','mime']);
ForceDirectoriesSafe(aDirectory);
//Create mime file associations
XdgMimeFile:=IncludeTrailingPathDelimiter(GetTempDir(false))+'fpcup-'+shortcutname+'.xml';
XdgMimeContent:=TStringList.Create;
try
XdgMimeContent.Add('<?xml version="1.0" encoding="UTF-8"?>');
XdgMimeContent.Add('<mime-info xmlns="http://www.freedesktop.org/standards/shared-mime-info">');
XdgMimeContent.Add(' <mime-type type="application/x-lazarus">');
XdgMimeContent.Add(' <comment>Lazarus file</comment>');
XdgMimeContent.Add(' <icon name="application-x-lazarus"/>');
XdgMimeContent.Add(' <glob-deleteall/>');
XdgMimeContent.Add(' <glob pattern="*.lpi"/>');
XdgMimeContent.Add(' <glob pattern="*.lpr"/>');
XdgMimeContent.Add(' <glob pattern="*.lfm"/>');
XdgMimeContent.Add(' <glob pattern="*.pas"/>');
XdgMimeContent.Add(' <glob pattern="*.pp"/>');
XdgMimeContent.Add(' <glob pattern="*.inc"/>');
XdgMimeContent.Add(' </mime-type>');
XdgMimeContent.Add('</mime-info>');
aDirectory:=ConcatPaths([GetUserDir,'.local','share','mime','packages']);
ForceDirectoriesSafe(aDirectory);
XdgMimeContent.SaveToFile(XdgMimeFile);
OperationSucceeded:=RunCommand('xdg-mime' ,['install','--novendor',XdgMimeFile],Output,[poUsePipes, poStderrToOutPut]{$IF DEFINED(FPC_FULLVERSION) AND (FPC_FULLVERSION >= 30200)},swoHide{$ENDIF});
SysUtils.DeleteFile(XdgMimeFile);
finally
XdgMimeContent.Free;
end;
//Process icon
aDirectory:=ConcatPaths([GetUserDir,'.local','share','icons']);
ForceDirectoriesSafe(aDirectory);
//OperationSucceeded:=RunCommand('xdg-icon-resource' ,['install','--novendor','--context','mimetypes','--size','64',ExtractFilePath(Target)+'images/icons/lazarus.ico','application-x-lazarus'],Output,[poUsePipes, poStderrToOutPut]{$IF DEFINED(FPC_FULLVERSION) AND (FPC_FULLVERSION >= 30200)},swoHide{$ENDIF});
OperationSucceeded:=RunCommand('xdg-icon-resource' ,['install','--novendor','--context','mimetypes','--size','64',ExtractFilePath(Target)+'images/icons/lazarus64x64.png','application-x-lazarus'],Output,[poUsePipes, poStderrToOutPut]{$IF DEFINED(FPC_FULLVERSION) AND (FPC_FULLVERSION >= 30200)},swoHide{$ENDIF});
//Update mime database
aDirectory:=ConcatPaths([GetUserDir,'.local','share','mime']);
OperationSucceeded:=RunCommand('update-mime-database' ,[aDirectory],Output,[poUsePipes, poStderrToOutPut]{$IF DEFINED(FPC_FULLVERSION) AND (FPC_FULLVERSION >= 30200)},swoHide{$ENDIF});
end;
end;
{$ELSE}
procedure CreateDesktopShortCut(const Target, TargetArguments, ShortcutName: string; const AddContext:boolean);
begin
ThreadLog('Not creating desktop shortcut: don''t know how to do this.');
end;
{$ENDIF UNIX}
{$ENDIF DARWIN}
{$ENDIF MSWINDOWS}
Recent
