yapetavi/uutils.pas

{
********************************************************************************

YaPeTaVi - Yet another Periodic Table Viewer
Copyright (C) 2009-2012 Geoffray Levasseur <geoffray.levasseurbrandin@numericable.fr>.
Parts inspired from PeaZip souce code:
  Copyright (C) 2006 Giorgio Tani <giorgiotani@interfree.it>
Parts inspired from Lazarus source code:
  Copyright (c) 2001-2010 The Lazarus developpers

All rights reserved.
http://www.geoffray-levasseur.org/

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 3 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 along with
this program; if not, write to the Free Software Foundation, Inc., 59 Temple
Place - Suite 330, Boston, MA  02111-1307, USA.

********************************************************************************

Description:
  Various utilities and functions

}

unit uUtils;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Graphics, StdCtrls;

type
  TOperatingSystem = (osWindows, osWin32, osWin64, osWinCE, osGo32V2, osOS2,
    osGenUnix, osFreeBSD, osNetBSD, osLinux, osBeOS, osQNX, osSun, osDarwin,
    osAmiga, osAtari, osMacOS, osPalmOS, osUnknow);

  TPathType = (ptIsDircetory, ptIsFile, ptIsExecutable, ptNotExists,
    ptInvalid, ptDosPathOnUnix, ptUnixPathOnDos);

  TDesktopEnv = (deUnknow, deGnome, deKDE, deMacOSX, deWindows, deLXDE, deXFCE);
  Str4 = string[4];

const
  AOSDesc: array[TOperatingSystem] of string = ('Microsoft Windows (generic)',
    'Microsoft Windows (32 bits)', 'Microsoft Windows (64 bits)',
    'Microsoft Windows CE', 'Microsoft Windows with Go32 v2', 'IBM OS/2',
    'Generic Unix', 'Free BSD', 'Net BSD', 'Linux', 'BeOS', 'QNX',
    'Sun Solaris', 'Mac OS X (Darwin)', 'Amiga OS', 'Atari OS', 'MacOS',
    'Palm OS', 'Unknow Operating System');

  {$warning we should be able to detect more desktop environment}
  ADescEnvDesc: array[TDesktopEnv] of string = ('Unknow', 'Gnome', 'KDE',
    'Mac OS X', 'Microsoft Windows', 'LXDE', 'XFCE');

  cpuUnknow = $00;
  cpu32Bit = $10;
  cpu64Bit = $20;
  cpuGenericMoto = $30;
  cpuMiscRisc = $40;
  cpuGenericPPC = $50;
  cpu86 = $11;
  cpu87 = $12;
  cpu386 = $13;
  cpuX86_64 = $21;
  cpu68k = $31;
  cpuM68020 = $32;
  cpu68 = $33;
  cpuAlpha = $41;
  cpuSparc = $42;
  cpuMips = $43;
  cpuPowerPC = $51;
  cpuArm = $60;
  cpuBigEndian = $80;

  {$IFDEF WIN32}
    Delimiter = '"';
  {$ELSE}
    {$IFDEF WIN64}
      Delimiter = '"';
    {$ELSE}
      {$IFDEF LINUX}
        Delimiter = '''';
      {$ELSE}
        {$IFDEF FREEBSD}
          Delimiter = '''';
        {$ELSE}
          {$IFDEF NETBSD}
            Delimiter = '''';
          {$ELSE}
            {$IFDEF DARWIN}
              Delimiter = '''';
            {$ELSE}
              Delimiter = ''''; //Default value (for other Unixes)
            {$ENDIF}
          {$ENDIF}
        {$ENDIF}
      {$ENDIF}
    {$ENDIF}
  {$ENDIF}

var //default values and variable declaration for configuration
  TwoDigitDateLimit: byte = 30; {$deprecated} //means 29 is 2029 and 30 is 1930 (deprecated)
  DateFormat: string = 'dd/mm/yyyy';

//get the user name from personal directory path (multiplatform way)
//note that builtin FPC GetUserName function is for Windows only
//on unix su command is keeping the username as before launching it: find a workarround
function GetUserName: string;

//get computer name
function GetComputerName: string;

//Get the running operating system
function GetCurrentOS: TOperatingSystem;

//Find the default browser according system configuration
function FindDefaultBrowser(out ABrowser, AParams: String): Boolean;

//Open URL in the default browser
function OpenURL(AURL: String): Boolean;

//convert a 4 char string (maximum) into a Word
function StrToWord(const S: Str4): Word;

//Convert a 3 number date into a string (deprecated)
function DateToStr(Y, M, D: Word): string; deprecated;

//Remove the extention of a file name
function RemoveFileExt(const aFileName: string): string;

//Get the executable path of the program with final / or \
function GetProgramPath: string;

//get program prefix (see explanation in its code)
function GetProgramPrefix: string;

//Give the number of items present in a listed string for the given separator
function CountItemsInStr(Str: string; Separator: Char): integer;

//Return the item in a listed string at the given index
function GetItemInStr(Str: string; Separator: Char; Index: integer): string;

//find which desktop environment is currently running
function GetDesktopEnv: TDesktopEnv; //0 unknown, 1 Gnome, 2 KDE, 20 MS Windows, 30 OSX

//return the position of a string in a stringlist, -1 if no occurence
function StrExistsInList(const StrList: TStringList; S: string): integer;
function StrExistsInListBox(const StrList: TListBox; S: string): integer;

//remove and change (repectively) a string from a StringList, returning position
//of the change in the SL, -1 if no occurence
function StrRemove(var StrList: TStringList; S: string): integer;
function StrChange(var StrList: TStringList; const sOld, sNew: string): integer;

//check filename before use regarding the environment
function FormatFileName(S: String; out VS: string): Integer;

//check if a directory is empty
function DirectoryIsEmpty(ADir: string): Boolean;

//check for possible problematic chars in a string that could be used as filename
function RemoveSpecialChar(const S: UnicodeString): string;

//create a lock file containing the computer name and user name of the locker
function CreateLockFile(const AName: string): Boolean;
procedure GetLockingInfo(const AName: string; out User, Computer: string);

implementation

uses
  {$ifdef WINDOWS}Windows,{$endif}
  {$ifdef UNIX}BaseUnix,{$endif}
  Forms, FileUtil, UTF8Process, Dos, Dialogs, uDebug, uConst;

{$ifdef UNIX}
function GetUserName: string;
begin
  {$warning Find a workarround to get the good username in case where su is being used}
  Result := GetEnvironmentVariable('USER');
end;
{$endif}

{$ifdef WINDOWS}
function GetUserName: string;
var
  pcName: PChar;
  nSize : DWord;
begin
  nSize := 100;
  pcName := StrAlloc(nSize);
  Windows.GetUserName(pcName, nSize);
  Result := StrPas(pcName);
  StrDispose(pcName);
end;
{$endif}

{$ifdef UNIX}
function GetComputerName: String;
var
  AUtsName: UtsName;
begin
  Result := '';
  AUtsName.Nodename[0] := #0; //this is just to avoid the compiler warning
  FillChar(AUtsName, SizeOf(AUtsName), 0);
  if FpUname(AUtsName) <> -1 then
    Result := AUtsName.Nodename;
end;
{$endif}

{$ifdef WINDOWS}
function GetComputerName: String;
var
  aBuf: array[0..255] of Char;
  bRet: Boolean;
  nSize: DWord;
begin
  aBuf[0] := #0;
  nSize := SizeOf(aBuf);
  bRet := Windows.GetComputerName(aBuf, nSize);
  aBuf[SizeOf(aBuf) - 1] := #0; // Just for safety reasons
  Result := Trim(aBuf);
end;
{$endif}

function GetCurrentOS: TOperatingSystem;
begin
  //unrecognized system, it is overwritten if one of the following conditions is met
  Result := osUnknow;
  // DOS/Windows type systems
  {$IFDEF MSWINDOWS}
    //generic Windows, replaced with following $0* codes
    //if a more specific match is found
    Result := osWindows;
  {$ENDIF}
  {$IFDEF WIN32}
    Result := osWin32;
  {$ENDIF}
  {$IFDEF WIN64}
    Result := osWin64;
  {$ENDIF}
  {$IFDEF WINCE}
    Result := osWinCE;
  {$ENDIF}
  {$IFDEF GO32V2}
    Result := Go32V2;
  {$ENDIF}
  {$IFDEF OS2}
    Result := osOS2;
  {$ENDIF}
  // Unix type systems
  {$IFDEF UNIX}
    //generic UNIX, replaced with some following codes
    //if a more specific match is found
    Result := osGenUnix;
  {$ENDIF}
  {$IFDEF FREEBSD}
    Result := osFreeBSD;
  {$ENDIF}
  {$IFDEF NETBSD}
    Result := osNetBSD;
  {$ENDIF}
  {$IFDEF LINUX}
    Result := osLinux;
  {$ENDIF}
  {$IFDEF BEOS}
    Result := osBeOS;
  {$ENDIF}
  {$IFDEF QNX}
    Result := osQNX;
  {$ENDIF}
  {$IFDEF SUNOS}
    Result := osSunOS;
  {$ENDIF}
  {$IFDEF DARWIN} // MacOS <= 10.x
    Result := osDarwin;
  {$ENDIF}
  //Other systems
  {$IFDEF AMIGA}
    Result := osAmiga;
  {$ENDIF}
  {$IFDEF ATARI} //Atari OS
    Result := osAtari;
  {$ENDIF}
  {$IFDEF MAC} // MacOS => 9.x
    Result := osMacOS;
  {$ENDIF}
  {$IFDEF PALMOS}
    Result := osPalmOS;
  {$ENDIF}
end;

//if cpu type, < $80 (encoded in ls 7 bit);
//0 if unrecognized, replaced if a match is found
function GetUsedCPU: Word; //CPU and endianness (in MSB)
begin
  Result := cpuUnknow; //cpu type, < $80 (encoded in ls 7 bit); 0:= unrecognized, replaced if a match is found
  {$IFDEF CPU32}
    //generic 32 bit CPU, replaced if a more specific match is found
    Result := cpu32Bit;
  {$ENDIF}
  {$IFDEF CPU64}
    //generic 64 bit CPU, replaced if a more specific match is found
    Result := cpu64Bit;
  {$ENDIF}
  {$IFDEF CPU86}
    Result := cpu86;
  {$ENDIF}
  {$IFDEF CPU87}
    Result := cpu87;
  {$ENDIF}
  {$IFDEF CPUI386}
    Result := cpu386;
  {$ENDIF}
  {$IFDEF CPUX86_64}
    Result := cpuX86_64;
  {$ENDIF}
  {$IFDEF CPU68k}
    Result := cpu68k;
  {$ENDIF}
  {$IFDEF CPUM68020}
    Result := cpuM68020;
  {$ENDIF}
  {$IFDEF CPU68}
    Result := cpu68;
  {$ENDIF}
  {$IFDEF CPUSPARC}
    Result := cpuSpark;
  {$ENDIF}
  {$IFDEF CPUALPHA}
    Result := cpuAlpha;
  {$ENDIF}
  {$IFDEF CPUMIPS}
    Result := cpuMips;
  {$ENDIF}
  {$IFDEF CPUPOWERPC}
    Result := cpuPowerPC;
  {$ENDIF}
  {$IFDEF CPUARM}
    Result := cpuArm;
  {$ENDIF}
  {$IFDEF ENDIAN_BIG}
    //if processor is declared big endian (some processors don't have a fixed
    //endian setting) the msb is set to 1, otherwise is 0
    Result := Result + cpuBigEndian;
  {$ENDIF}
end;

//This is a somewhat altered version of the Lazarus' source code
//FindDefaultBrowser function
function FindDefaultBrowser(out ABrowser, AParams: String): Boolean;

  function Find(const ShortFilename: String; out ABrowser: String): Boolean; inline;
  begin
    ABrowser := SearchFileInPath(ShortFilename + GetExeExt, '',
      GetEnvironmentVariable('PATH'), PathSeparator, [sffDontSearchInBasePath]);
    Result := ABrowser <> '';
  end;

begin
  {$IFDEF MSWindows}
  Find('rundll32', ABrowser);
  AParams := 'url.dll,FileProtocolHandler %s';
  {$ELSE}
    {$IFDEF DARWIN}
    // open command launches url in the appropriate browser under Mac OS X
    Find('open', ABrowser);
    AParams := '%s';
    {$ELSE}
    ABrowser := '';
    {$ENDIF}
  {$ENDIF}
  if ABrowser = '' then
  begin
    AParams := '%s';
    // Then search in path. Prefer open source ;)
    if Find('xdg-open', ABrowser)  // Portland OSDL/FreeDesktop standard on Linux
    or Find('htmlview', ABrowser)  // some redhat systems
    or Find('konqueror', ABrowser)
    or Find('firefox', ABrowser)
    or Find('mozilla', ABrowser)
    or Find('galeon', ABrowser)
    or Find('safari', ABrowser)
    or Find('netscape', ABrowser)
    or Find('opera', ABrowser)
    or Find('iexplore', ABrowser) then ;// some windows systems
  end;
  Result := ABrowser <> '';
end;

//each system has a different OpenURL working. this is mainly took from
//Lazarus source code with minor changes
{$IFDEF Windows}
function OpenURL(AURL: String): Boolean;
var
{$IFDEF WinCE}
  Info: SHELLEXECUTEINFO;
{$ELSE}
  ws: WideString;
  ans: AnsiString;
{$ENDIF}
begin
  Result := False;
  if AURL = '' then
    Exit;
  {$IFDEF WinCE}
  FillChar(Info, SizeOf(Info), 0);
  Info.cbSize := SizeOf(Info);
  Info.fMask := SEE_MASK_FLAG_NO_UI;
  Info.lpVerb := 'open';
  Info.lpFile := PWideChar(UTF8Decode(AURL));
  Result := ShellExecuteEx(@Info);
  {$ELSE}
  if (GetCurrentOS = osWin32) or (GetCurrentOS = osWin64) then
  begin
    ws := UTF8Decode(AURL);
    Result := ShellExecuteW(0, 'open', PWideChar(ws), nil, nil, 0) > 32;
  end else
  begin
    ans := Utf8ToAnsi(AURL); // utf8 must be converted to Windows Ansi-codepage
    //this should handle every kind of address if software available
    Result := ShellExecute(0, 'open', PAnsiChar(ans), nil, nil, 0) > 32;
  end;
  {$ENDIF}
end;
{$ELSE}
{$IFDEF DARWIN}
function OpenURL(AURL: string): Boolean;
var
  cf: CFStringRef;
  url: CFURLRef;
  w: WideString;
begin
  if AURL = '' then
    Exit(False);
  cf := CFStringCreateWithCString(kCFAllocatorDefault, @AURL[1],
    kCFStringEncodingUTF8);
  if not Assigned(cf) then
    Exit(False);
  url := CFURLCreateWithString(nil, cf, nil);
  Result := LSOpenCFURLRef(url, nil) = 0;
  CFRelease(url);
  CFRelease(cf);
end;
{$ELSE} //we suppose here a Unix system... exotic or very old OS not supported.
function OpenURL(AURL: String): Boolean;
var
  ABrowser, AParams: String;
  BrowserProcess: TProcessUTF8;
begin
  Result := FindDefaultBrowser(ABrowser, AParams) and
    FileExists(ABrowser);
  if not Result then
    Exit;
  //run
  BrowserProcess := TProcessUTF8.Create(nil);
  try
    {$warning test if @ exists and add mailto to open it with default mail composer!}
    BrowserProcess.CommandLine := ABrowser + ' ' + Format(AParams, [AURL]);
    BrowserProcess.Execute;
  finally
    BrowserProcess.Free;
  end;
end;
{$ENDIF}
{$ENDIF}

//if your string is more than 4 char you may have a range error
function StrToWord(const S: Str4): Word;
var
  I: Integer;
begin
  Result := 0;
  I := 1;
  while I <= Length(S) do
  begin
    Result := Result * 10 + Ord(S[I]) - Ord('0');
    Inc(I);
  end;
end;

// Deprecated with Lazarus > 0.9.27
function DateToStr(Y, M, D: Word): string; deprecated;
begin
  {$ifdef fpc}
    if Y < TwoDigitDateLimit then
      Inc(Y, 2000);
    if (Y < 100) and (Y > TwoDigitDateLimit) then
      Inc(Y, 1900);
    Result := FormatDateTime(DateFormat, EncodeDate(Y, M, D));
  {$endif}
  {$ifdef delphi} // FormatDateTime seems to be buggy with Delphi 7 at least
    if D < 10 then
      Result := '0' + IntToStr(D) + '/'
    else Result := IntToStr(D) + '/';
    if M < 10 then
      Result := Result + '0' + IntToStr(M) + '/'
    else Result := Result + IntToStr(M) + '/';
    if Y <= 99 then
      if Y < TwoDigitDateLimit then
        Result := Result + '20' + IntToStr(Y)
      else Result := Result + '19' + IntToStr(Y)
    else Result := Result + IntToStr(Y);
  {$endif}
end;

function RemoveFileExt(const aFileName: string): string;
var
  I: integer;
begin
  I := Length(aFileName);
  while aFileName[I] <> '.' do
    Dec(I);
  if I > 1 then
    Result := Copy(aFileName, 1, I - 1)
  else Result := aFileName; //on unix this is not an extention but an hidden file
end;

function GetProgramPath: string; //this may work on all platform
begin
  Result := Trim(ExtractFilePath(Application.ExeName));
  if Result[Length(Result)] <> DirectorySeparator then
    Result := Result + DirectorySeparator;
end;

function GetProgramPrefix: string;
{this is finding the program prefix dependant on platform...
On Windows / OS/2 this look like:
  Program Dir
    |- bin\yapetavi.exe
    |- db\
    |- icons\
    |- pics\
    |- i18n\
That simply means ProgramPrefix = ..\ProgramPath
On Unix like we have:
  Prefix
    |- bin/yapetavi        (executable is in ProgramDir)
    |- share
         |- icons          (shared icons)
         |- yapetavi       (yapetavi specific data files)
         |    |- pics/
         |    |- db/
         |- locale
              |- <lang_code>
                    |- LC_MESSAGES  (where to find langage file)
This is less complex than we can think... Prefix = ../ProgramPath
Nevertheless if share/yapetavi is not found we should try standard Unix prefix
like /usr or /usr/local
}
var
  Err
    : integer;
begin //I don't know if it's really reliable, but that's quitte simple
  {$ifdef WINDOWS}
    Result := GetProgramPath + '..\';
    if (Result[1] = '\') and (Result[2] <> '\') then //in case where the program path is on a server
      Result := '\' + Result;
  {$else}
  {$ifdef wince}
    Result := GetProgramPath + '..\';
  {$else} //many others OS have unix directory structure but this have to be checked
    Result := GetProgramPath + '../';
    Err := FormatFileName(Result, Result);
    if Err <= 0 then
    begin
      PrintLnDbg('Invalid installation prefix, is it dev mode?', vlLow);
      if DirectoryExists('/usr/local/share/yapetavi') then
        Result := '/usr/local/';
      if DirectoryExists('/usr/share/yapetavi') then //overhide last result
        Result := '/usr/';
    end;
  {$endif}
  {$endif}
  PrintLnDbg('Found prefix: ' + Result, vlHigh);
end;

function CountItemsInStr(Str: string; Separator: Char): integer;
var
  I: integer;
begin
  Str := Trim(Str);
  if Str = '' then
  begin
    Result := 0;
    Exit;
  end;
  Result := 1;
  for I := 1 to Length(Str) do
    if Str[I] = Separator then
      Inc(Result);
  if Str[Length(Str)] = Separator then
    Dec(Result);
end;

function GetItemInStr(Str: string; Separator: Char; Index: integer): string;
var
  I, J: integer;
  S: string;
begin
  //note that result = '' is equivalent to an error
  Result := '';
  S := '';
  Str := Trim(Str);
  if Str = '' then
    Exit;
  I := 1;
  J := 1;
  while (I < Index) and (J < Length(Str)) do
  begin
    if Str[J] = Separator then
      Inc(I);
    Inc(J);
  end;
  if J >= Length(Str) then //in case of a terminal separator
    Exit;
  if Str[J] = Separator then
    Inc(J);
  repeat
    S := S + Str[J];
    Inc(J);
  until (J > Length(Str)) or (Str[J] = Separator);
  Result := Trim(S);
end;

function GetDesktopEnv: TDesktopEnv;
begin
  Result := deUnknow; //unrecognized desktop environment
  {$IFDEF MSWINDOWS}
    Result := deWindows;
  {$ENDIF}
  {$IFDEF DARWIN}
    Result := deMacOSX;
  {$ENDIF}
  {$IFDEF UNIX}
  //if this Gnome specific env variable is set, probably the user is running Gnome
  if GetEnvironmentVariable('GNOME_DESKTOP_SESSION_ID') <> '' then
    Result := deGnome;
  //if this KDE specific env variable is set, probably the user is running KDE
  if GetEnvironmentVariable('KDE_FULL_SESSION') <> '' then
    Result := deKDE;
  //if gnome or kde is explicitely declared in DESKTOP_SESSION env variable,
  //override previously assumed result
  {$warning Complete with other unixes desktop environment}
  if GetEnvironmentVariable('DESKTOP_SESSION') = 'gnome' then
    Result := deGnome
  else
    if getenvironmentvariable('DESKTOP_SESSION') = 'kde' then
      Result := deKDE
    else
      if GetEnvironmentVariable('DESKTOP_SESSION') = 'xfce' then
        Result := deXFCE
      else
        if GetEnvironmentVariable('DESKTOP_SESSION') = 'lxde' then
          Result := deLXDE;
  {$ENDIF}
end;

function GetDesktopPath: string;
//superseeded in Windows
begin
  {$IFDEF MSWINDOWS}
    Result := SysUtils.GetEnvironmentVariable('USERPROFILE') + '\Desktop\';
  {$ENDIF}
  {$IFDEF LINUX}  //this should work on every unixes but have to be tested
    Result := GetEnvironmentVariable('HOME') + '/Desktop/';
  {$ENDIF}
  {$IFDEF FREEBSD}
    Result := GetEnvironmentVariable('HOME') + '/Desktop/';
  {$ENDIF}
  {$IFDEF NETBSD}
    Result := GetEnvironmentVariable('HOME') + '/Desktop/';
  {$ENDIF}
   //generic, superseeded by system specific values, if not empty
  if Result = '' then Result := GetCurrentDir;
  if Result[Length(Result)] <> DirectorySeparator then
    Result := Result + DirectorySeparator;
end;

function GetHomePath: string;
//superseeded in Windows
begin
  {$IFDEF MSWINDOWS}
    Result := SysUtils.GetEnvironmentVariable('USERPROFILE');
  {$ENDIF}
  {$IFDEF LINUX}  //this should work on every unixes but have to be tested
    Result := GetEnvironmentVariable('HOME');
  {$ENDIF}
  {$IFDEF FREEBSD}
    Result := GetEnvironmentVariable('HOME');
  {$ENDIF}
  {$IFDEF NETBSD}
    Result := GetEnvironmentVariable('HOME');
  {$ENDIF}
  //generic, superseeded by system specific values, if not empty
  if Result = '' then Result := GetCurrentDir;
  if Result[Length(Result)] <> DirectorySeparator then
    Result := Result + DirectorySeparator;
end;

//return the first occurence, not usefull if you need multiple ones
function StrExistsInList(const StrList: TStringList; S: string): integer;
var
  I: Integer;
begin
  Result := -1;
  if (StrList = nil) or (not Assigned(StrList)) then
    Exit;
  for I := 0 to StrList.Count - 1 do
    if StrList[I] = S then
    begin
      Result := I;
      Exit;
    end;
end;

function StrExistsInListBox(const StrList: TListBox; S: string): integer;
var
  SL: TStringList;
begin
  SL := TStringList.Create;
  SL.Assign(StrList.Items);
  Result := StrExistsInList(SL, S);
end;

//for both following functions a "repeat [...] until StrXXX(<...>) = -1;"
//will make it happen on every possible occurence if any
function StrRemove(var StrList: TStringList; S: string): integer;
begin
  Result := StrExistsInList(StrList, S);
  StrList.Delete(Result);
end;

function StrChange(var StrList: TStringList; const sOld, sNew: string): integer;
begin
  Result := StrExistsInList(StrList, sOld);
  StrList[Result] := sNew;
end;

////////////////////////////////////////////////////////////////////////////////
//in Linux and BSDs if filename contains delimiter ' change the character in ?,
//and checking special cases for Gnome and KDE in Windows delimiter is " and it's
//not a valid character in filenames, so this control returns the input string
//(which doesn't need to be variable) on other systems filenames are not escaped
//
//- convert %XX (where XX is an hexa value) to the equivalent char by code
//- braces management (' sous unix et " sous Windows) as unneeded with Lazarus.
//- deleting « file:// » if here.
//- Supporting environnement variables (eg. $(USER)\MonProg).
//- deleting double directory separators (eg. \\ or // -> \ or /).
//- automatic separator convertion (eg. with Windows a / would be \)
//- adds terminal \ or / for directories if not exists.
//- detect invalid chars (depending on the OS)
//
//Returns: Negative when errors, positive when Ok where
//Low(Result) is pos of the error when applicable and High(Result) the error code
//
//List of error codes:
//-$01XX: error in %XX convertion (mostly non hexa value)
//-$02XX: "$(" found but no ")" while checking environment (XX pos of "$(")
//-$0300: directory separator in a filename
//-$0400: Comma in a filename
//-$0500: windows only: use of a system reserved file extention
//-$10XX: empty env var (XX pos of "$(")
//-$20XX: invalid char where XX is the invalid char code
//+$0000: valid filename, no such file or directory
//+$1000: valid filename, directory exists
//+$2000: valid filename, file exist
function FormatFileName(S: String; out VS: string): Integer;
var
  Str, TmpS, EnvVar: UnicodeString;
  I, J: Integer;
  Ch: Char;
const
  FilePrefix = 'file://';

  procedure InvalidChar(C: Char);
  begin
    VS := Str;
    Result := $2000 + Ord(C);
  end;

begin
  Result := $0000;
  Str := Trim(S);
  // Delete ' on Unix or " on Windows as it is not needed when assuming there's
  // one file path per string
  I := 1;
  repeat
     I := {$ifndef WINDOWS} Pos('''', Str) {$ELSE} Pos('"', Str) {$ENDIF};
     if I > 0 then
       Delete(Str, I, 1);
  until I = 0;
  //find and delete 'file://' (and any part before) if it is passed as part of
  //filename (it happens sometimes in Gnome, i.e. using "open with" context
  //menu entry) or if it has been entered as is by the user
  I := Pos(FilePrefix, Str);
  if I > 0 then
    Str := Copy(Str, I + Length(FilePrefix), Length(Str) - I - Length(FilePrefix) - 1);
  //replace %xx with the appropriate character used sometimes to pass non
  //available keyboards char or spaces. xx must be 2 hexa char
  repeat
    I := Pos('%', Str);
    if I <> 0 then
    try //if there's synthax error like non hexa char
      Ch := Char(StrToWord(Str[I + 1] + Str[I + 2]));
      Delete(Str, I, 3);
      Insert(Ch, Str, I);
    except
      Result := $0100 + I;
    end;
  //if error leave everything else as is as it's not valid path anyway
  until (I = 0) or (Result <> 0);
  //the application support the use of environment variable in filenames just
  //like Unix command line does, so this extract environment variable when $()
  //symbol is found
  repeat
    I := Pos('$(', Str);
    if I <> 0 then
    try
      J := I;
      while Str[J] <> ')' do
        Inc(J);
      //on windows we use Windows unt that have an incompatible GetEnvironmentVariable
      EnvVar := SysUtils.GetEnvironmentVariable(Copy(Str, I + 2, J - I - 2));
      if EnvVar <> '' then
      begin
        Delete(Str, I, I - J);
        Insert(EnvVar, Str, I);
      end else
        Result := $1000 + I;
    except
      Result := $0200 + I;
    end;
  until (I = 0) or (Result <> 0);
  // remove double / on unix or double \\ on windows
  {$warning This is not working when we have network address}
  repeat
    {$ifdef WINDOWS}
      I := Pos('\\', Str);
    {$else}
      I := Pos('//', Str);
    {$endif}
    if I = 1 then
      I := 0;
    if I <> 0 then
      if Str[I - 1] <> ':' then //it's looking like an URL so don't erase it
        Delete(Str, I, 1);
  until I = 0;
  // check for remaining invalid char
  for I := 0 to 31 do
    if (Pos(Char(I), Str) <> 0) then
      InvalidChar(Char(I));
  if Pos('*', Str) <> 0 then
    InvalidChar('*');
  if Pos('?' , Str) <> 0 then
    InvalidChar('?');
  {$IFDEF MSWINDOWS}
    if Pos('"', Str) <> 0 then
      InvalidChar('"');
  {$ELSE}
    if Pos('''', Str) <> 0 then
      InvalidChar('''');
  if Pos(':', Str) <> 0 then
    InvalidChar(':');
  {$ENDIF}
  if Pos('<', Str) <> 0 then
    InvalidChar('<');
  if Pos('>', Str) <> 0 then
    InvalidChar('>');
  if Pos('|', Str) <> 0 then
    InvalidChar('|');
  TmpS := ExtractFileName(Str);
  //reserved characters, filename only (others are checked for the full name)
  if (Pos('\', TmpS) <> 0) or (Pos('/', TmpS) <> 0) then
    Result := $0300; //we should get the pos for low(result)
  if Pos(':', TmpS) <> 0 then
    Result := $0400; //we should get the pos for low(result)
  //reserved filenames (Windows)
  {$IFDEF MSWINDOWS}
  TmpS := UpCase(ExtractFileExt(TmpS));
  if (TmpS = 'CON') or (TmpS = 'PRN') or (TmpS = 'AUX') or (TmpS = 'NUL') or
   (TmpS = 'COM1') or (TmpS = 'COM2') or (TmpS = 'COM3') or (TmpS = 'COM4') or
   (TmpS = 'COM5') or (TmpS = 'COM6') or (TmpS = 'COM7') or (TmpS = 'COM8') or
   (TmpS = 'COM9') or (TmpS = 'LPT1') or (TmpS = 'LPT2') or (TmpS = 'LPT3') or
   (TmpS = 'LPT4') or (TmpS = 'LPT5') or (TmpS = 'LPT6') or (TmpS = 'LPT7') or
   (TmpS = 'LPT8') or (TmpS = 'LPT9') then
    Result := $0500; //pos is not needed as it's the file extention
  {$ENDIF}
  if Result <> $0000 then
    Result := -Result
  else
    if DirectoryExists(Str) then
    begin
      {$IFDEF MSWINDOWS}
      if Str[Length(Str)] <> '\' then
        Str := Str + '\';
      {$ELSE}
      if Str[Length(Str)] <> '/' then
        Str := Str + '/';
      {$ENDIF}
      Result := $1000;
    end else
      if FileExists(Str) then
        Result := $2000;
  VS := Str;
end;

function DirectoryIsEmpty(ADir: string): Boolean;
var
  SR: SearchRec;
  Mask: string;
begin
  {$IFDEF MSWINDOWS}
  Mask := '*.*';
  {$ELSE}
  Mask := '*';
  {$ENDIF}
  if ADir[Length(ADir)] <> DirectorySeparator then
    ADir := ADir + DirectorySeparator;
  try
    FindFirst(ADir + Mask, faAnyFile, SR);
    if DosError = 0 then //first is directory itself (./)
    begin
      FindNext(SR);
      if DosError = 0 then //second is parent directory (../)
      begin
        FindNext(SR);
        Result := DosError <> 0;
      end else
        Result := False; //this is a file (or damaged directory)
    end else
      Result := False; //the directory do not exists (or the filesystem is damaged)
  finally
    FindClose(SR) ;
  end;
end;

function RemoveSpecialChar(const S: UnicodeString): string;
var
  I: Integer;
  Tmp: UnicodeString;
begin
  Tmp := S;
  for I := 1 to Length(S) do
    if not (S[I] in ['0'..'9', '.', '-', '_', 'A'..'Z', 'a'..'z']) then
      Tmp[I] := '_'
    else
      Tmp[I] := S[I];
  Result := Tmp;
end;

function CreateLockFile(const AName: string): Boolean;
var
  AFile: Text;
  Test: string;
begin
  Result := True;
  try
    if FileExists(AName) then
      //use SysUtils and not Windows one when compiling with Windows target
      if not SysUtils.DeleteFile(AName) then
      begin
        Result := False;
        Exit;
      end;
    {$I-}
    Assign(AFile, AName);
    Rewrite(AFile);
    Writeln(AFile, GetUserName + '|' + GetComputerName);
    Close(AFile);
    Reset(AFile);
    Readln(AFile, Test);
    Close(AFile);
    {$I+}
    if Test = '' then
    begin
      ShowMessage('Error 5: unable to write lock file');
      //trigger an error here as there was an error writing file
      Halt(5);
    end;
  except
    Result := False;
  end;
end;

procedure GetLockingInfo(const AName: string; out User, Computer: string);
var
  AFile: Text;
  I: integer;
  AStr: string;
begin
  if not FileExists(AName) then
  begin
    User := '';
    Computer := '';
  end else
  begin
    {$I-}
    Assign(AFile, AName);
    Reset(AFile);
    Readln(AFile, AStr);
    Close(AFile);
    {$I+}
    if AStr <> '' then
    begin
      I := Pos('|', AStr);
      if I <> 0 then
      begin
        User := Copy(AStr, 1, I - 1);
        Computer := Copy(AStr, I + 1, Length(AStr) - I);
      end else
        User := AStr; //this is not suposed to happen
    end else
    begin
      ShowMessage('Error 6: the lock file is on readable');
      //trigger an error here as the file was probably unreadable
      Halt(6);
    end;
  end;
end;


end.