////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// MIME applications, see XDG standards.                                      //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20231219 - Created (A.K.).                                                 //
////////////////////////////////////////////////////////////////////////////////

unit _crw_mimeapps; // File associations.

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}
{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 {$IFDEF WINDOWS} registry, jwawindows, comobj, variants, {$ENDIF}
 sysutils, classes, process, lcltype,
 _crw_alloc, _crw_environ, _crw_proc,
 _crw_str, _crw_fio, _crw_wmctrl,
 _crw_hash, _crw_hl, _crw_sesman,
 _crw_spcfld, _crw_mimeglob;

///////////////////////////////////////////////////////////////////////////////////////////
// References:
// https://yamadharma.github.io/ru/post/2023/04/02/xdg-mime-applications/
// https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html
// https://specifications.freedesktop.org/menu-spec/menu-spec-1.0.html#locations
// https://specifications.freedesktop.org/mime-apps-spec/mime-apps-spec-1.0.html
// https://russianpenguin.ru/2016/01/04/linux-связываем-приложение-с-типами-файло/
// https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-latest.html
///////////////////////////////////////////////////////////////////////////////////////////

const // Subdirectoriess to search *.desktop files.
 MimeAppsDesktopSearchSubPattern='applications;applnk';

const // XDG MIME & desktop file sections.
 SectDefaultApplications = '[Default Applications]';
 SectRemovedAssociations = '[Removed Associations]';
 SectAddedAssociations   = '[Added Associations]';
 SectDesktopEntry        = '[Desktop Entry]';

const // MIME list separator.
 MimeSep = ';';

  // Validate file List separated with Delim - exclude non-existing files.
function ValidateMimeAppsFileList(List:LongString; Delim:LongString=MimeSep):LongString;

// Validate directory List separated with Delim - exclude non-existing directories.
function ValidateMimeAppsDirList(List:LongString; Delim:LongString=PathSep):LongString;

 // Get XDG standard mimeapps.list files to search in.
function MimeAppsListSearchFiles(Delim:LongString=MimeSep):LongString;

  // Path (directory list) where to search application *.desktop files.
function MimeAppsDesktopSearchPath(Delim:LongString=PathSep):LongString;

 // Get all application handlers associated with mime type.
function GetMimeAppsAllHandlers(const mime:LongString):LongString;

 // Get default application handler associated with mime type.
function GetMimeAppsDefHandler(const mime:LongString):LongString;

 // Find *.desktop file in system search path.
function FindDesktopFile(const FileName:LongString):LongString;

 // Find full path of *.desktop file by MIME type.
function FindMimeAppsDefDesktopFile(const mime:LongString):LongString;

 // Get Exec clause from *.desktop file.
function GetExecClauseFromDesktopEntry(desktop:LongString):LongString;

 // Find Exec=... entry from *.desktop file by MIME type.
function FindMimeAppsDefExecEntry(const mime:LongString):LongString;

 // Find exectable file (from *.destop Exec entry) by MIME type.
function FindMimeAppsDefExecFile(const mime:LongString):LongString;

 // Find command to handle files by MIME type with subsitution (%f,%F,%u,%U).
function FindMimeAppsDefExecCommand(const mime,files:LongString):LongString;

 // Find MIME type by given file name (by using xdg-mime command).
function FindMimeTypeByFileName(const aFileName:LongString):LongString;

 // Get value of MIME types cache item by name.
function GetMimeTypesCacheItem(aName:LongString):LongString;
 // Set value of MIME types cache item by name.
function SetMimeTypesCacheItem(aName,aValue:LongString):LongString;
 // Clear MIME types cache.
procedure ClearMimeTypesCache;

 // HashList of MimeApps - applications by MIME type.
function MimeAppsList:THashList;

 // MimeAppsList as EOL delimited text.
 // Mode=0:MimeOnly,1:Mime+DefApp,2:Mime+AllApps.
function MimeAppsListAsText(Mode:Integer=2):LongString;

 // For first initialization.
procedure Init_XdgMimeApps;

implementation

const
 ItemDelims=[ASCII_CR,ASCII_LF,';',':']+[MimeSep]+[PathSep];

function ValidateMimeAppsFileList(List:LongString; Delim:LongString=MimeSep):LongString;
var Item:LongString; i:Integer;
begin
 Result:='';
 for i:=1 to WordCount(List,ItemDelims) do begin
  Item:=ExtractWord(i,List,ItemDelims);
  if FileExists(Item) then Result:=Result+Trim(Item)+Delim;
 end;
 Result:=TrimChars(Result,ItemDelims,ItemDelims);
end;

function ValidateMimeAppsDirList(List:LongString; Delim:LongString=PathSep):LongString;
var Item:LongString; i:Integer;
begin
 Result:='';
 for i:=1 to WordCount(List,ItemDelims) do begin
  Item:=ExtractWord(i,List,ItemDelims);
  if DirectoryExists(Item) then Result:=Result+Trim(Item)+Delim;
 end;
 Result:=TrimChars(Result,ItemDelims,ItemDelims);
end;

 // Implemented accocding to "XDG Base Directory Specification"
function MimeAppsListSearchFiles(Delim:LongString=MimeSep):LongString;
{$IFDEF UNIX} var desktop,List:LongString; {$ENDIF ~UNIX}
begin
 Result:='';
 if IsUnix then begin
  {$IFDEF UNIX}
  desktop:=LowerCase(wmctrl.DesktopManager); List:='';
  List:=List+XDG_CONFIG_HOME(desktop+'-mimeapps.list')+Delim;               // user overrides, desktop-specific (for advanced users)
  List:=List+XDG_CONFIG_HOME('mimeapps.list')+Delim;                        // user overrides (recommended location for user configuration GUIs)
  List:=List+XDG_CONFIG_DIRS(desktop+'-mimeapps.list')+Delim;               // sysadmin and ISV overrides, desktop-specific
  List:=List+XDG_CONFIG_DIRS('mimeapps.list')+Delim;	                    // sysadmin and ISV overrides
  List:=List+XDG_DATA_HOME('applications/'+desktop+'-mimeapps.list')+Delim; // for completeness, deprecated, desktop-specific
  List:=List+XDG_DATA_HOME('applications/mimeapps.list')+Delim;             // for compatibility, deprecated
  List:=List+XDG_DATA_DIRS('applications/'+desktop+'-mimeapps.list')+Delim; // distribution-provided defaults, desktop-specific
  List:=List+XDG_DATA_DIRS('applications/mimeapps.list')+Delim;             // distribution-provided defaults
  Result:=ValidateMimeAppsFileList(List,Delim);
  {$ENDIF ~UNIX}
 end;
end;

 // See XDG "Desktop Menu Specification"
function MimeAppsDesktopSearchPath(Delim:LongString=PathSep):LongString;
{$IFDEF UNIX} var List,sub:LongString; i:Integer; {$ENDIF ~UNIX}
begin
 Result:='';
 if IsUnix then begin
  {$IFDEF UNIX}
  List:='';
  for i:=1 to WordCount(MimeAppsDesktopSearchSubPattern,ItemDelims) do begin
   sub:=ExtractWord(i,MimeAppsDesktopSearchSubPattern,ItemDelims);
   List:=List+XDG_DATA_HOME(sub)+Delim+XDG_DATA_DIRS(sub)+Delim;
  end;
  Result:=ValidateMimeAppsDirList(List,Delim);
  {$ENDIF ~UNIX}
 end;
end;

procedure MimeAppsListAdd(List:THashList; Name,Values:LongString);
var Apps,Item:LongString; i:Integer;
begin
 Apps:=List.KeyedParams[Name];
 Apps:=TrimChars(Apps,ItemDelims,ItemDelims);
 for i:=1 to WordCount(Values,ItemDelims) do begin
  Item:=ExtractWord(i,Values,ItemDelims);
  if (WordIndex(Item,Apps,ItemDelims)=0)
  then Apps:=Apps+MimeSep+Item;
 end;
 Apps:=TrimChars(Apps,ItemDelims,ItemDelims);
 List.KeyedParams[Name]:=Apps;
end;

procedure MimeAppsListRem(List:THashList; Name,Values:LongString);
var Apps,Items,Item:LongString; i:Integer;
begin
 Items:='';
 Apps:=List.KeyedParams[Name];
 Apps:=TrimChars(Apps,ItemDelims,ItemDelims);
 for i:=1 to WordCount(Apps,ItemDelims) do begin
  Item:=ExtractWord(i,Apps,ItemDelims);
  if (WordIndex(Item,Values,ItemDelims)=0)
  then Items:=Items+MimeSep+Item;
 end;
 Apps:=Items;
 Apps:=TrimChars(Apps,ItemDelims,ItemDelims);
 List.KeyedParams[Name]:=Apps;
end;

procedure UpdateMimeAppsList(List:THashList);
var fList,fItem,sn,sv:LongString; Lines:TStringList; i,j,p:Integer;
begin
 if not IsUnix then Exit;
 if not Assigned(List) then Exit;
 try
  Lines:=TStringList.Create;
  try
   fList:=MimeAppsListSearchFiles(EOL);
   // [Default Applications]
   for i:=1 to WordCount(fList,ItemDelims) do begin
    fItem:=ExtractWord(i,fList,ItemDelims);
    if not FileExists(fItem) then continue;
    Lines.Text:=ExtractTextSection(fItem,SectDefaultApplications,efAsIs);
    for j:=0 to Lines.Count-1 do begin
     p:=ExtractNameValuePair(Lines[j],sn,sv);
     if (p>0) and (sn<>'') and (sv<>'')
     then MimeAppsListAdd(List,sn,sv);
    end;
   end;
   // [Added Associations]
   for i:=1 to WordCount(fList,ItemDelims) do begin
    fItem:=ExtractWord(i,fList,ItemDelims);
    if not FileExists(fItem) then continue;
    Lines.Text:=ExtractTextSection(fItem,SectAddedAssociations,efAsIs);
    for j:=0 to Lines.Count-1 do begin
     p:=ExtractNameValuePair(Lines[j],sn,sv);
     if (p>0) and (sn<>'') and (sv<>'')
     then MimeAppsListAdd(List,sn,sv);
    end;
   end;
   // [Removed Associations]
   for i:=1 to WordCount(fList,ItemDelims) do begin
    fItem:=ExtractWord(i,fList,ItemDelims);
    if not FileExists(fItem) then continue;
    Lines.Text:=ExtractTextSection(fItem,SectRemovedAssociations,efAsIs);
    for j:=0 to Lines.Count-1 do begin
     p:=ExtractNameValuePair(Lines[j],sn,sv);
     if (p>0) and (sn<>'') and (sv<>'')
     then MimeAppsListRem(List,sn,sv);
    end;
   end;
  finally
   Kill(Lines);
  end;
 except
  on E:Exception do BugReport(E,nil,'UpdateMimeAppsList');
 end;
end;

function MimeAppsListAsText(Mode:Integer=2):LongString;
var Lines:TStringList; i:Integer; Line:LongString;
begin
 Result:='';
 if IsUnix then
 try
  Lines:=TStringList.Create;
  try
   for i:=0 to MimeAppsList.Count-1 do begin
    case Mode of
     0: Line:=MimeAppsList.Keys[i];
     1: Line:=MimeAppsList.Keys[i]+'='+ExtractWord(1,MimeAppsList.Params[i],ItemDelims);
     2: Line:=MimeAppsList.Keys[i]+'='+MimeAppsList.Params[i];
    end;
    if (Line<>'') then Lines.Add(Line);
   end;
   Result:=Lines.Text;
  finally
   Kill(Lines);
  end;
 except
  on E:Exception do BugReport(E,nil,'MimeAppsListAsText');
 end;
end;

function GetMimeAppsAllHandlers(const mime:LongString):LongString;
begin
 if not IsUnix then Exit('');
 if IsEmptyStr(mime) then Exit('');
 Result:=MimeAppsList.KeyedParams[Trim(mime)];
end;

function GetMimeAppsDefHandler(const mime:LongString):LongString;
begin
 if not IsUnix then Exit('');
 if IsEmptyStr(mime) then Exit('');
 Result:=Trim(ExtractWord(1,GetMimeAppsAllHandlers(mime),ItemDelims));
end;

function FindDesktopFile(const FileName:LongString):LongString;
begin
 if not IsUnix then Exit('');
 if IsEmptyStr(FileName) then Exit('');
 Result:=FileSearch(FileName,MimeAppsDesktopSearchPath,false);
end;

function FindMimeAppsDefDesktopFile(const mime:LongString):LongString;
begin
 if not IsUnix then Exit('');
 if IsEmptyStr(mime) then Exit('');
 Result:=FindDesktopFile(GetMimeAppsDefHandler(mime));
end;

function GetExecClauseFromDesktopEntry(desktop:LongString):LongString;
var exec:LongString;
begin
 Result:=''; exec:='';
 if not IsUnix then Exit('');
 if IsEmptyStr(desktop) then Exit('');
 if not SameText(ExtractFileExt(desktop),'.desktop') then Exit;
 if IsRelativePath(desktop) then desktop:=FindDesktopFile(desktop);
 if ReadIniFileString(desktop,SectDesktopEntry,'Exec%s',exec,efAsIs,svAsIs)
 then Result:=Trim(exec);
end;

function FindMimeAppsDefExecEntry(const mime:LongString):LongString;
var desktop:LongString;
begin
 Result:='';
 if not IsUnix then Exit('');
 if IsEmptyStr(mime) then Exit('');
 desktop:=FindMimeAppsDefDesktopFile(mime);
 Result:=GetExecClauseFromDesktopEntry(desktop);
end;

function FindMimeAppsDefExecFile(const mime:LongString):LongString;
begin
 Result:=ExtractFirstParam(FindMimeAppsDefExecEntry(mime));
 if IsRelativePath(Result) then Result:=TrimDef(file_which(Result),Result);
end;

function FindMimeAppsDefExecCommand(const mime,files:LongString):LongString;
var cmd,tmp:LongString;
begin
 Result:='';
 if not IsUnix then Exit('');
 if IsEmptyStr(mime) then Exit('');
 cmd:=FindMimeAppsDefExecEntry(mime);
 cmd:=StringReplace(cmd,ASCII_TAB,' ',[rfReplaceAll]);
 if (cmd='') then Exit; // Desktop entry not found.
 cmd:=cmd+' '; tmp:=cmd;
 // %u replacement: first URL in list
 cmd:=StringReplace(cmd,' %u ',' '+AnsiQuotedIfNeed(ExtractFirstParam(files))+' ',[]);
 // %f replacement: first file in list
 cmd:=StringReplace(cmd,' %f ',' '+AnsiQuotedIfNeed(ExtractFirstParam(files))+' ',[]);
 // %U replacement: all URLs from list
 cmd:=StringReplace(cmd,' %U ',' '+Trim(files)+' ',[]);
 // %F replacement: all files from list
 cmd:=StringReplace(cmd,' %F ',' '+Trim(files)+' ',[]);
 if (cmd=tmp) then cmd:=cmd+files;
 Result:=Trim(cmd);
end;

function FindMimeTypeByFileName(const aFileName:LongString):LongString;
var xdg_mime,cmd,pat,tmp,dir,sample,outstr:LongString;
begin
 Result:=''; tmp:='';
 if IsUnix then
 try
  try
   if HasExtension(aFileName) and IsEmptyStr(ExtractBaseName(aFileName)) then begin
    Result:=Trim(GetMimeTypesCacheItem(ExtractFileExt(aFileName)));
    if (Result<>'') then Exit; // The value found in cache
    if MimeGlob.HasExtToMime then begin
     Result:=MimeGlob.ExtToMime[ExtractFileExt(aFileName)];
     if (Result<>'') then begin
      SetMimeTypesCacheItem(ExtractFileExt(aFileName),Result);
      Exit;
     end;
    end;
   end;
   sample:=Trim(aFileName);
   xdg_mime:=file_which('xdg-mime');
   if IsEmptyStr(xdg_mime) then Exit;
   if IsNonEmptyStr(ExtractBaseName(aFileName))
   then sample:=UnifyFileAlias(aFileName);
   if HasExtension(aFileName) and not FileExists(aFileName) then begin
    pat:='findmimetype_'+ExtractFileExt(aFileName);
    dir:=SessionManager.RuntimeDir;
    tmp:=CreateTempFile(pat,dir);
    if IsEmptyStr(tmp) or not FileExists(tmp) then Exit;
    sample:=tmp;
   end;
   cmd:=xdg_mime+' query filetype '+sample;
   if RunCommand(cmd,outstr) then Result:=ExtractWord(1,outstr,JustSpaces);
   if HasExtension(aFileName) and IsEmptyStr(ExtractBaseName(aFileName)) then begin
    if (Result<>'') then SetMimeTypesCacheItem(ExtractFileExt(aFileName),Result);
   end;
  finally
   if IsNonEmptyStr(tmp) then FileErase(tmp);
  end;
 except
  on E:Exception do BugReport(E,nil,'FindMimeTypeByFileName');
 end;
end;

 // Extension list initialization may take ~ 0.5 sec per item.
 // Another extensions will be added to cache list at runtime.
const
 extlist = '.html;.htm;'
 //       +'.txt;.log;.cfg;.crc;.doc;.docx;.odt;'
 //       +'.bmp;.png;.ico;.jpg;'
          +'.pdf;.md;'
          +'.lm9;';

procedure Init_XdgMimeApps;
var i:Integer; ext,mime,desk,exec,line:LongString;
begin
 if IsUnix then
 try
  DebugOut(stdfDebug,' ');
  DebugOut(stdfDebug,'XDG MimeApps:');
  DebugOut(stdfDebug,'*************');
  DebugOutText(stdfDebug,MimeAppsListAsText);
  for i:=1 to WordCount(extlist,ItemDelims) do begin
   ext:=ExtractWord(i,extlist,ItemDelims);
   mime:=FindMimeTypeByFileName(ext);
   desk:=GetMimeAppsDefHandler(mime);
   exec:=FindMimeAppsDefExecFile(mime);
   line:=Pad(ext,5)+' - '+Pad(mime,25)+'  '+Pad(desk,30)+'  '+exec;
   DebugOut(stdfDebug,line);
  end;
  DebugOut(stdfDebug,' ');
 except
  on E:Exception do BugReport(E,nil,'Init_XdgMimeApps');
 end;
end;

/////////////////////
// MimeTypesCacheList
/////////////////////

const
 TheMimeTypesCacheLatch:TLatch=nil;

function MimeTypesCacheLatch:TLatch;
begin
 if not Assigned(TheMimeTypesCacheLatch) then begin
  TheMimeTypesCacheLatch:=NewLatch;
  TheMimeTypesCacheLatch.Master:=@TheMimeTypesCacheLatch;
 end;
 Result:=TheMimeTypesCacheLatch;
end;

const
 TheMimeTypesCacheList:THashList=nil;

function MimeTypesCacheList:THashList;
begin
 if not Assigned(TheMimeTypesCacheList) then begin
  TheMimeTypesCacheList:=NewHashList(false,Hash32_RS);
  TheMimeTypesCacheList.Master:=@TheMimeTypesCacheList;
 end;
 Result:=TheMimeTypesCacheList;
end;

function GetMimeTypesCacheItem(aName:LongString):LongString;
begin
 Result:=''; aName:=Trim(aName);
 if IsEmptyStr(aName) then Exit;
 MimeTypesCacheLatch.Lock;
 try
  Result:=MimeTypesCacheList.KeyedParams[aName];
 finally
  MimeTypesCacheLatch.UnLock;
 end;
end;

function SetMimeTypesCacheItem(aName,aValue:LongString):LongString;
begin
 Result:=''; aName:=Trim(aName);
 if IsEmptyStr(aName) then Exit;
 MimeTypesCacheLatch.Lock;
 try
  Result:=MimeTypesCacheList.KeyedParams[aName];
  MimeTypesCacheList.KeyedParams[aName]:=aValue;
 finally
  MimeTypesCacheLatch.UnLock;
 end;
end;

procedure ClearMimeTypesCache;
begin
 MimeTypesCacheLatch.Lock;
 try
  MimeTypesCacheList.Clear;
 finally
  MimeTypesCacheLatch.UnLock;
 end;
end;

///////////////
// MimeAppsList
///////////////

const
 TheMimeAppsList:THashList=nil;

function MimeAppsList:THashList;
begin
 if not Assigned(TheMimeAppsList) then begin
  TheMimeAppsList:=NewHashList(false,Hash32_RS);
  TheMimeAppsList.Master:=@TheMimeAppsList;
 end;
 if IsUnix and (TheMimeAppsList.Count=0)
 then UpdateMimeAppsList(TheMimeAppsList);
 Result:=TheMimeAppsList;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_mimeapps;
begin
 MimeTypesCacheLatch.Ok;
end;

procedure Free_crw_mimeapps;
begin
 Kill(TheMimeTypesCacheLatch);
 Kill(TheMimeTypesCacheList);
 Kill(TheMimeAppsList);
end;

initialization

 Init_crw_mimeapps;

finalization

 Free_crw_mimeapps;

end.

//////////////
// END OF FILE
//////////////

