{
Double Commander
-------------------------------------------------------------------------
This unit contains platform dependent functions dealing with operating system.
Copyright (C) 2006-2025 Alexander Koblov (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
along with this program. If not, see .
}
unit DCOSUtils;
{$mode objfpc}{$H+}
{$modeswitch advancedrecords}
interface
uses
SysUtils, Classes, DynLibs, DCClassesUtf8, DCBasicTypes, DCConvertEncoding
{$IFDEF UNIX}
, BaseUnix, DCUnix
{$ENDIF}
{$IFDEF LINUX}
, DCLinux
{$ENDIF}
{$IFDEF DARWIN}
, DCDarwin
{$ENDIF}
{$IFDEF HAIKU}
, DCHaiku
{$ENDIF}
{$IFDEF MSWINDOWS}
, JwaWinBase, Windows
{$ENDIF}
;
const
fmOpenSync = $10000;
fmOpenDirect = $20000;
fmOpenNoATime = $40000;
fmOpenSpecial = $80000;
{$IF DEFINED(UNIX)}
ERROR_NOT_SAME_DEVICE = ESysEXDEV;
{$ELSE}
ERROR_NOT_SAME_DEVICE = Windows.ERROR_NOT_SAME_DEVICE;
{$ENDIF}
FileNameNormalized = {$IFDEF DARWIN}True{$ELSE}False{$ENDIF};
type
TFileMapRec = record
FileHandle : System.THandle;
FileSize : Int64;
{$IFDEF MSWINDOWS}
MappingHandle : System.THandle;
{$ENDIF}
MappedFile : Pointer;
end;
TFileAttributeData = packed record
Size: Int64;
{$IF DEFINED(UNIX)}
FindData: BaseUnix.Stat;
property Attr: TUnixMode read FindData.st_mode;
property PlatformTime: TUnixTime read FindData.st_ctime;
property LastWriteTime: TUnixTime read FindData.st_mtime;
property LastAccessTime: TUnixTime read FindData.st_atime;
{$ELSE}
case Boolean of
True: (
FindData: Windows.TWin32FileAttributeData;
);
False: (
Attr: TFileAttrs;
PlatformTime: DCBasicTypes.TFileTime;
LastAccessTime: DCBasicTypes.TFileTime;
LastWriteTime: DCBasicTypes.TFileTime;
);
{$ENDIF}
end;
TCopyAttributesOption = (caoCopyAttributes,
caoCopyTime,
caoCopyOwnership,
caoCopyPermissions,
caoCopyXattributes,
// Modifiers
caoCopyTimeEx,
caoCopyAttrEx,
caoRemoveReadOnlyAttr);
TCopyAttributesOptions = set of TCopyAttributesOption;
TCopyAttributesResult = array[TCopyAttributesOption] of Integer;
PCopyAttributesResult = ^TCopyAttributesResult;
const
faInvalidAttributes = TFileAttrs(-1);
CopyAttributesOptionCopyAll = [caoCopyAttributes, caoCopyTime, caoCopyOwnership];
{en
Is file a directory
@param(iAttr File attributes)
@returns(@true if file is a directory, @false otherwise)
}
function FPS_ISDIR(iAttr: TFileAttrs) : Boolean;
{en
Is file a symbolic link
@param(iAttr File attributes)
@returns(@true if file is a symbolic link, @false otherwise)
}
function FPS_ISLNK(iAttr: TFileAttrs) : Boolean;
{en
Is file a regular file
@param(iAttr File attributes)
@returns(@true if file is a regular file, @false otherwise)
}
function FPS_ISREG(iAttr: TFileAttrs) : Boolean;
{en
Is file executable
@param(sFileName File name)
@returns(@true if file is executable, @false otherwise)
}
function FileIsExeLib(const sFileName : String) : Boolean;
{en
Is file console executable
@param(sFileName File name)
@returns(@true if file is console executable, @false otherwise)
}
function FileIsConsoleExe(const FileName: String): Boolean;
{en
Copies a file attributes (attributes, date/time, owner & group, permissions).
@param(sSrc String expression that specifies the name of the file to be copied)
@param(sDst String expression that specifies the target file name)
@param(bDropReadOnlyFlag Drop read only attribute if @true)
@returns(The function returns @true if successful, @false otherwise)
}
function FileIsReadOnly(iAttr: TFileAttrs): Boolean; inline;
{en
Returns path to a temporary name. It ensures that returned path doesn't exist,
i.e., there is no filesystem entry by that name.
If it could not create a unique temporary name then it returns empty string.
@param(PathPrefix
This parameter is added at the beginning of each path that is tried.
The directories in this path are not created if they don't exist.
If it is empty then the system temporary directory is used.
For example:
If PathPrefix is '/tmp/myfile' then files '/tmp/myfile~XXXXXX.tmp' are tried.
The path '/tmp' must already exist.)
}
function GetTempName(PathPrefix: String; Extension: String = 'tmp'): String;
{en
Find file in the system PATH
}
function FindInSystemPath(var FileName: String): Boolean;
{en
Extract file root directory
@param(FileName File name)
}
function ExtractRootDir(const FileName: String): String;
(* File mapping/unmapping routines *)
{en
Create memory map of a file
@param(sFileName Name of file to mapping)
@param(FileMapRec TFileMapRec structure)
@returns(The function returns @true if successful, @false otherwise)
}
function MapFile(const sFileName : String; out FileMapRec : TFileMapRec) : Boolean;
{en
Unmap previously mapped file
@param(FileMapRec TFileMapRec structure)
}
procedure UnMapFile(var FileMapRec : TFileMapRec);
function NormalizeFileName(const Source: String): String;
{en
Convert from console to UTF8 encoding.
}
function ConsoleToUTF8(const Source: String): RawByteString;
{ File handling functions}
function mbFileOpen(const FileName: String; Mode: LongWord): System.THandle;
function mbFileCreate(const FileName: String): System.THandle; overload; inline;
function mbFileCreate(const FileName: String; Mode: LongWord): System.THandle; overload; inline;
function mbFileCreate(const FileName: String; Mode, Rights: LongWord): System.THandle; overload;
function mbFileAge(const FileName: String): DCBasicTypes.TFileTime;
function mbFileGetTime(const FileName: String): DCBasicTypes.TFileTimeEx;
// On success returns True.
// nanoseconds supported
function mbFileGetTime(const FileName: String;
var ModificationTime: DCBasicTypes.TFileTimeEx;
var CreationTime : DCBasicTypes.TFileTimeEx;
var LastAccessTime : DCBasicTypes.TFileTimeEx): Boolean;
// On success returns True.
function mbFileSetTime(const FileName: String;
ModificationTime: DCBasicTypes.TFileTime;
CreationTime : DCBasicTypes.TFileTime = 0;
LastAccessTime : DCBasicTypes.TFileTime = 0): Boolean;
// nanoseconds supported
function mbFileSetTimeEx(const FileName: String;
ModificationTime: DCBasicTypes.TFileTimeEx;
CreationTime : DCBasicTypes.TFileTimeEx;
LastAccessTime : DCBasicTypes.TFileTimeEx): Boolean;
{en
Checks if a given file exists - it can be a real file or a link to a file,
but it can be opened and read from.
Even if the result is @false, we can't be sure a file by that name can be created,
because there may still exist a directory or link by that name.
}
function mbFileExists(const FileName: String): Boolean;
function mbFileAccess(const FileName: String; Mode: Word): Boolean;
function mbFileGetAttr(const FileName: String): TFileAttrs; overload;
function mbFileGetAttr(const FileName: String; out Attr: TFileAttributeData): Boolean; overload;
function mbFileSetAttr(const FileName: String; Attr: TFileAttrs): Boolean;
{en
If any operation in Options is performed and does not succeed it is included
in the result set. If all performed operations succeed the function returns empty set.
For example for Options=[caoCopyTime, caoCopyOwnership] setting ownership
doesn't succeed then the function returns [caoCopyOwnership].
}
function mbFileCopyAttr(const sSrc, sDst: String;
Options: TCopyAttributesOptions;
Errors: PCopyAttributesResult = nil): TCopyAttributesOptions;
// Returns True on success.
function mbFileSetReadOnly(const FileName: String; ReadOnly: Boolean): Boolean;
function mbDeleteFile(const FileName: String): Boolean;
function mbRenameFile(const OldName: String; NewName: String): Boolean;
function mbFileSize(const FileName: String): Int64;
function FileGetSize(Handle: System.THandle): Int64;
function FileFlush(Handle: System.THandle): Boolean;
function FileFlushData(Handle: System.THandle): Boolean;
function FileIsReadOnlyEx(Handle: System.THandle): Boolean;
function FileAllocate(Handle: System.THandle; Size: Int64): Boolean;
{ Directory handling functions}
function mbGetCurrentDir: String;
function mbSetCurrentDir(const NewDir: String): Boolean;
{en
Checks if a given directory exists - it may be a real directory or a link to directory.
Even if the result is @false, we can't be sure a directory by that name can be created,
because there may still exist a file or link by that name.
}
function mbDirectoryExists(const Directory : String) : Boolean;
function mbCreateDir(const NewDir: String): Boolean;
function mbRemoveDir(const Dir: String): Boolean;
{en
Checks if any file system entry exists at given path.
It can be file, directory, link, etc. (links are not followed).
}
function mbFileSystemEntryExists(const Path: String): Boolean;
function mbCompareFileNames(const FileName1, FileName2: String): Boolean;
function mbFileSame(const FileName1, FileName2: String): Boolean;
function mbFileSameVolume(const FileName1, FileName2: String) : Boolean;
{ Other functions }
function mbGetEnvironmentString(Index : Integer) : String;
{en
Expands environment-variable strings and replaces
them with the values defined for the current user
}
function mbExpandEnvironmentStrings(const FileName: String): String;
function mbGetEnvironmentVariable(const sName: String): String;
function mbSetEnvironmentVariable(const sName, sValue: String): Boolean;
function mbUnsetEnvironmentVariable(const sName: String): Boolean;
function mbSysErrorMessage: String; overload; inline;
function mbSysErrorMessage(ErrorCode: Integer): String; overload;
{en
Get current module name
}
function mbGetModuleName(Address: Pointer = nil): String;
function mbLoadLibrary(const Name: String): TLibHandle;
function mbLoadLibraryEx(const Name: String): TLibHandle;
function SafeGetProcAddress(Lib: TLibHandle; const ProcName: AnsiString): Pointer;
{en
Reads the concrete file's name that the link points to.
If the link points to a link then it's resolved recursively
until a valid file name that is not a link is found.
@param(PathToLink Name of symbolic link (absolute path))
@returns(The absolute filename the symbolic link name is pointing to,
or an empty string when the link is invalid or
the file it points to does not exist.)
}
function mbReadAllLinks(const PathToLink : String) : String;
{en
If PathToLink points to a link then it returns file that the link points to (recursively).
If PathToLink does not point to a link then PathToLink value is returned.
}
function mbCheckReadLinks(const PathToLink : String) : String;
{en
Same as mbFileGetAttr, but dereferences any encountered links.
}
function mbFileGetAttrNoLinks(const FileName: String): TFileAttrs;
{en
Create a hard link to a file
@param(Path Name of file)
@param(LinkName Name of hard link)
@returns(The function returns @true if successful, @false otherwise)
}
function CreateHardLink(const Path, LinkName: String) : Boolean;
{en
Create a symbolic link
@param(Path Name of file)
@param(LinkName Name of symbolic link)
@returns(The function returns @true if successful, @false otherwise)
}
function CreateSymLink(const Path, LinkName: string; Attr: UInt32 = faInvalidAttributes) : Boolean;
{en
Read destination of symbolic link
@param(LinkName Name of symbolic link)
@returns(The file name/path the symbolic link name is pointing to.
The path may be relative to link's location.)
}
function ReadSymLink(const LinkName : String) : String;
{en
Sets the last-error code for the calling thread
}
procedure SetLastOSError(LastError: Integer);
function GetTickCountEx: UInt64;
implementation
uses
{$IF DEFINED(MSWINDOWS)}
DCDateTimeUtils, DCWindows, DCNtfsLinks,
{$ENDIF}
{$IF DEFINED(UNIX)}
Unix, dl,
{$ENDIF}
{$IF DEFINED(DARWIN)}
LazFileUtils,
{$ENDIF}
DCStrUtils, LazUTF8;
{$IFDEF UNIX}
function SetModeReadOnly(mode: TMode; ReadOnly: Boolean): TMode;
begin
mode := mode and not (S_IWUSR or S_IWGRP or S_IWOTH);
if ReadOnly = False then
begin
if (mode AND S_IRUSR) = S_IRUSR then
mode := mode or S_IWUSR;
if (mode AND S_IRGRP) = S_IRGRP then
mode := mode or S_IWGRP;
if (mode AND S_IROTH) = S_IROTH then
mode := mode or S_IWOTH;
end;
Result := mode;
end;
{$ENDIF}
{$IF DEFINED(MSWINDOWS)}
const
AccessModes: array[0..2] of DWORD = (
GENERIC_READ,
GENERIC_WRITE,
GENERIC_READ or GENERIC_WRITE);
ShareModes: array[0..4] of DWORD = (
0,
0,
FILE_SHARE_READ,
FILE_SHARE_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE);
OpenFlags: array[0..3] of DWORD = (
0,
FILE_FLAG_WRITE_THROUGH,
FILE_FLAG_NO_BUFFERING,
FILE_FLAG_WRITE_THROUGH or FILE_FLAG_NO_BUFFERING);
var
CurrentDirectory: String;
PerformanceFrequency: LARGE_INTEGER;
{$ELSEIF DEFINED(UNIX)}
const
{$IF NOT DECLARED(O_SYNC)}
O_SYNC = 0;
{$ENDIF}
{$IF NOT DECLARED(O_DIRECT)}
O_DIRECT = 0;
{$ENDIF}
AccessModes: array[0..2] of cInt = (
O_RdOnly,
O_WrOnly,
O_RdWr);
OpenFlags: array[0..3] of cInt = (
0,
O_SYNC,
O_DIRECT,
O_SYNC or O_DIRECT);
{$ENDIF}
function FPS_ISDIR(iAttr: TFileAttrs) : Boolean; inline;
{$IFDEF MSWINDOWS}
begin
Result := (iAttr and FILE_ATTRIBUTE_DIRECTORY <> 0);
end;
{$ELSE}
begin
Result := BaseUnix.FPS_ISDIR(TMode(iAttr));
end;
{$ENDIF}
function FPS_ISLNK(iAttr: TFileAttrs) : Boolean; inline;
{$IFDEF MSWINDOWS}
begin
Result := (iAttr and FILE_ATTRIBUTE_REPARSE_POINT <> 0);
end;
{$ELSE}
begin
Result := BaseUnix.FPS_ISLNK(TMode(iAttr));
end;
{$ENDIF}
function FPS_ISREG(iAttr: TFileAttrs) : Boolean; inline;
{$IFDEF MSWINDOWS}
begin
Result := (iAttr and FILE_ATTRIBUTE_DIRECTORY = 0);
end;
{$ELSE}
begin
Result := BaseUnix.FPS_ISREG(TMode(iAttr));
end;
{$ENDIF}
function FileIsExeLib(const sFileName : String) : Boolean;
var
fsExeLib : TFileStreamEx;
{$IFDEF MSWINDOWS}
Sign : Word;
{$ELSE}
Sign : DWord;
{$ENDIF}
begin
Result := False;
if mbFileExists(sFileName) and (mbFileSize(sFileName) >= SizeOf(Sign)) then
try
fsExeLib := TFileStreamEx.Create(sFileName, fmOpenRead or fmShareDenyNone);
try
{$IFDEF MSWINDOWS}
Sign := fsExeLib.ReadWord;
Result := (Sign = $5A4D);
{$ELSE}
Sign := fsExeLib.ReadDWord;
Result := (Sign = $464C457F);
{$ENDIF}
finally
fsExeLib.Free;
end;
except
Result := False;
end;
end;
function FileIsConsoleExe(const FileName: String): Boolean;
{$IF DEFINED(UNIX)}
begin
Result:= True;
end;
{$ELSE}
var
fsFileStream: TFileStreamEx;
begin
Result:= False;
try
fsFileStream:= TFileStreamEx.Create(FileName, fmOpenRead or fmShareDenyNone);
try
if fsFileStream.ReadWord = IMAGE_DOS_SIGNATURE then
begin
fsFileStream.Seek(60, soBeginning);
fsFileStream.Seek(fsFileStream.ReadDWord, soBeginning);
if fsFileStream.ReadDWord = IMAGE_NT_SIGNATURE then
begin
fsFileStream.Seek(88, soCurrent);
Result:= (fsFileStream.ReadWord = IMAGE_SUBSYSTEM_WINDOWS_CUI);
end;
end;
finally
fsFileStream.Free;
end;
except
Result:= False;
end;
end;
{$ENDIF}
function FileIsReadOnly(iAttr: TFileAttrs): Boolean;
{$IFDEF MSWINDOWS}
begin
Result:= (iAttr and (faReadOnly or faHidden or faSysFile)) <> 0;
end;
{$ELSE}
begin
Result:= (((iAttr AND S_IRUSR) = S_IRUSR) and ((iAttr AND S_IWUSR) <> S_IWUSR));
end;
{$ENDIF}
function mbFileCopyAttr(const sSrc, sDst: String;
Options: TCopyAttributesOptions; Errors: PCopyAttributesResult
): TCopyAttributesOptions;
{$IFDEF MSWINDOWS}
var
Attr: TWin32FileAttributeData;
Option: TCopyAttributesOption;
ModificationTime, CreationTime, LastAccessTime: DCBasicTypes.TFileTime;
begin
Result := [];
if not GetFileAttributesExW(PWideChar(UTF16LongName(sSrc)), GetFileExInfoStandard, @Attr) then
begin
Result := Options;
if Assigned(Errors) then
begin
for Option in Result do
Errors^[Option]:= GetLastOSError;
end;
Exit;
end;
if [caoCopyAttributes, caoCopyAttrEx] * Options <> [] then
begin
if (not (caoCopyAttributes in Options)) and (Attr.dwFileAttributes and faDirectory = 0) then
Attr.dwFileAttributes := (Attr.dwFileAttributes or faArchive);
if (caoRemoveReadOnlyAttr in Options) and ((Attr.dwFileAttributes and faReadOnly) <> 0) then
Attr.dwFileAttributes := (Attr.dwFileAttributes and not faReadOnly);
if not mbFileSetAttr(sDst, Attr.dwFileAttributes) then
begin
Include(Result, caoCopyAttributes);
if Assigned(Errors) then Errors^[caoCopyAttributes]:= GetLastOSError;
end;
end;
if not FPS_ISLNK(Attr.dwFileAttributes) then
begin
if (caoCopyXattributes in Options) then
begin
if not mbFileCopyXattr(sSrc, sDst) then
begin
Include(Result, caoCopyXattributes);
if Assigned(Errors) then Errors^[caoCopyXattributes]:= GetLastOSError;
end;
end;
if ([caoCopyTime, caoCopyTimeEx] * Options <> []) then
begin
if not (caoCopyTime in Options) then
begin
CreationTime:= 0;
LastAccessTime:= 0;
end
else begin
CreationTime:= DCBasicTypes.TFileTime(Attr.ftCreationTime);
LastAccessTime:= DCBasicTypes.TFileTime(Attr.ftLastAccessTime);
end;
ModificationTime:= DCBasicTypes.TFileTime(Attr.ftLastWriteTime);
if not mbFileSetTime(sDst, ModificationTime, CreationTime, LastAccessTime) then
begin
Include(Result, caoCopyTime);
if Assigned(Errors) then Errors^[caoCopyTime]:= GetLastOSError;
end;
end;
end;
if caoCopyPermissions in Options then
begin
if not CopyNtfsPermissions(sSrc, sDst) then
begin
Include(Result, caoCopyPermissions);
if Assigned(Errors) then Errors^[caoCopyPermissions]:= GetLastOSError;
end;
end;
end;
{$ELSE} // *nix
var
Option: TCopyAttributesOption;
StatInfo : TDCStat;
modificationTime: TFileTimeEx;
creationTime: TFileTimeEx;
lastAccessTime: TFileTimeEx;
mode : TMode;
begin
if DC_fpLStat(UTF8ToSys(sSrc), StatInfo) < 0 then
begin
Result := Options;
if Assigned(Errors) then
begin
for Option in Result do
Errors^[Option]:= GetLastOSError;
end;
end
else begin
Result := [];
if FPS_ISLNK(StatInfo.st_mode) then
begin
if caoCopyOwnership in Options then
begin
// Only group/owner can be set for links.
if fpLChown(sDst, StatInfo.st_uid, StatInfo.st_gid) = -1 then
begin
Include(Result, caoCopyOwnership);
if Assigned(Errors) then Errors^[caoCopyOwnership]:= GetLastOSError;
end;
end;
{$IF DEFINED(HAIKU)}
if caoCopyXattributes in Options then
begin
if not mbFileCopyXattr(sSrc, sDst) then
begin
Include(Result, caoCopyXattributes);
if Assigned(Errors) then Errors^[caoCopyXattributes]:= GetLastOSError;
end;
end;
{$ENDIF}
end
else
begin
if caoCopyTime in Options then
begin
modificationTime:= StatInfo.mtime;
lastAccessTime:= StatInfo.atime;
creationTime:= StatInfo.birthtime;
if DC_FileSetTime(sDst, modificationTime, creationTime, lastAccessTime) = false then
begin
Include(Result, caoCopyTime);
if Assigned(Errors) then Errors^[caoCopyTime]:= GetLastOSError;
end;
end;
if caoCopyOwnership in Options then
begin
if fpChown(PChar(UTF8ToSys(sDst)), StatInfo.st_uid, StatInfo.st_gid) = -1 then
begin
Include(Result, caoCopyOwnership);
if Assigned(Errors) then Errors^[caoCopyOwnership]:= GetLastOSError;
end;
end;
if caoCopyAttributes in Options then
begin
mode := StatInfo.st_mode;
if caoRemoveReadOnlyAttr in Options then
mode := SetModeReadOnly(mode, False);
if fpChmod(UTF8ToSys(sDst), mode) = -1 then
begin
Include(Result, caoCopyAttributes);
if Assigned(Errors) then Errors^[caoCopyAttributes]:= GetLastOSError;
end;
end;
{$IF DEFINED(LINUX) or DEFINED(DARWIN) or DEFINED(HAIKU)}
if caoCopyXattributes in Options then
begin
if not mbFileCopyXattr(sSrc, sDst) then
begin
Include(Result, caoCopyXattributes);
if Assigned(Errors) then Errors^[caoCopyXattributes]:= GetLastOSError;
end;
end;
{$ENDIF}
end;
end;
end;
{$ENDIF}
function GetTempName(PathPrefix: String; Extension: String): String;
const
MaxTries = 100;
var
FileName: String;
TryNumber: Integer = 0;
begin
if PathPrefix = '' then
PathPrefix := GetTempDir
else begin
FileName:= ExtractOnlyFileName(PathPrefix);
PathPrefix:= ExtractFilePath(PathPrefix);
// Generated file name should be less the maximum file name length
if (Length(FileName) > 0) then PathPrefix += UTF8Copy(FileName, 1, 48) + '~';
end;
if (Length(Extension) > 0) then
begin
if (not StrBegins(Extension, ExtensionSeparator)) then
Extension := ExtensionSeparator + Extension;
end;
repeat
Result := PathPrefix + IntToStr(System.Random(MaxInt)) + Extension;
Inc(TryNumber);
if TryNumber = MaxTries then
Exit('');
until not mbFileSystemEntryExists(Result);
end;
function FindInSystemPath(var FileName: String): Boolean;
var
I: Integer;
Path, FullName: String;
Value: TDynamicStringArray;
begin
Path:= mbGetEnvironmentVariable('PATH');
Value:= SplitString(Path, PathSeparator);
for I:= Low(Value) to High(Value) do
begin
FullName:= IncludeTrailingPathDelimiter(Value[I]) + FileName;
if mbFileExists(FullName) then
begin
FileName:= FullName;
Exit(True);
end;
end;
Result:= False;
end;
function ExtractRootDir(const FileName: String): String;
{$IFDEF UNIX}
begin
Result:= ExcludeTrailingPathDelimiter(FindMountPointPath(ExcludeTrailingPathDelimiter(FileName)));
end;
{$ELSE}
begin
Result:= ExtractFileDrive(FileName);
end;
{$ENDIF}
function MapFile(const sFileName : String; out FileMapRec : TFileMapRec) : Boolean;
{$IFDEF MSWINDOWS}
begin
Result := False;
with FileMapRec do
begin
MappedFile := nil;
MappingHandle := 0;
FileHandle := mbFileOpen(sFileName, fmOpenRead);
if FileHandle = feInvalidHandle then Exit;
Int64Rec(FileSize).Lo := GetFileSize(FileHandle, @Int64Rec(FileSize).Hi);
if FileSize = 0 then // Cannot map empty files
begin
UnMapFile(FileMapRec);
Exit;
end;
MappingHandle := CreateFileMapping(FileHandle, nil, PAGE_READONLY, 0, 0, nil);
if MappingHandle = 0 then
begin
UnMapFile(FileMapRec);
Exit;
end;
MappedFile := MapViewOfFile(MappingHandle, FILE_MAP_READ, 0, 0, 0);
if not Assigned(MappedFile) then
begin
UnMapFile(FileMapRec);
Exit;
end;
end;
Result := True;
end;
{$ELSE}
var
StatInfo: BaseUnix.Stat;
begin
Result:= False;
with FileMapRec do
begin
MappedFile := nil;
FileHandle:= mbFileOpen(sFileName, fmOpenRead);
if FileHandle = feInvalidHandle then Exit;
if fpfstat(FileHandle, StatInfo) <> 0 then
begin
UnMapFile(FileMapRec);
Exit;
end;
FileSize := StatInfo.st_size;
if FileSize = 0 then // Cannot map empty files
begin
UnMapFile(FileMapRec);
Exit;
end;
MappedFile:= fpmmap(nil,FileSize,PROT_READ, MAP_PRIVATE{SHARED},FileHandle,0 );
if MappedFile = MAP_FAILED then
begin
MappedFile := nil;
UnMapFile(FileMapRec);
Exit;
end;
end;
Result := True;
end;
{$ENDIF}
procedure UnMapFile(var FileMapRec : TFileMapRec);
{$IFDEF MSWINDOWS}
begin
with FileMapRec do
begin
if Assigned(MappedFile) then
begin
UnmapViewOfFile(MappedFile);
MappedFile := nil;
end;
if MappingHandle <> 0 then
begin
CloseHandle(MappingHandle);
MappingHandle := 0;
end;
if FileHandle <> feInvalidHandle then
begin
FileClose(FileHandle);
FileHandle := feInvalidHandle;
end;
end;
end;
{$ELSE}
begin
with FileMapRec do
begin
if FileHandle <> feInvalidHandle then
begin
fpClose(FileHandle);
FileHandle := feInvalidHandle;
end;
if Assigned(MappedFile) then
begin
fpmunmap(MappedFile,FileSize);
MappedFile := nil;
end;
end;
end;
{$ENDIF}
function NormalizeFileName(const Source: String): String; inline;
{$IF DEFINED(DARWIN)}
begin
Result:= GetDarwinNormalizedFileName(Source);
end;
{$ELSE}
begin
Result:= Source;
end;
{$ENDIF}
function ConsoleToUTF8(const Source: String): RawByteString;
{$IFDEF MSWINDOWS}
begin
Result:= CeOemToUtf8(Source);
end;
{$ELSE}
begin
Result:= CeSysToUtf8(Source);
end;
{$ENDIF}
function mbFileOpen(const FileName: String; Mode: LongWord): System.THandle;
{$IFDEF MSWINDOWS}
const
ft: TFileTime = ( dwLowDateTime: $FFFFFFFF; dwHighDateTime: $FFFFFFFF; );
begin
Result:= CreateFileW(PWideChar(UTF16LongName(FileName)),
AccessModes[Mode and 3] or ((Mode and fmOpenNoATime) shr 10),
ShareModes[(Mode and $F0) shr 4], nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, OpenFlags[(Mode shr 16) and 3]);
if (Mode and fmOpenNoATime <> 0) then
begin
if (Result <> feInvalidHandle) then
SetFileTime(Result, nil, @ft, nil)
else if GetLastError = ERROR_ACCESS_DENIED then
Result := mbFileOpen(FileName, Mode and not fmOpenNoATime);
end;
end;
{$ELSE}
var
Info: BaseUnix.Stat;
begin
repeat
Result:= fpOpen(UTF8ToSys(FileName), AccessModes[Mode and 3] or
OpenFlags[(Mode shr 16) and 3] or O_CLOEXEC);
until (Result <> -1) or (fpgeterrno <> ESysEINTR);
if Result <> feInvalidHandle then
begin
FileCloseOnExec(Result);
if (Mode and fmOpenSpecial = 0) then
begin
if fpFStat(Result, Info) = 0 then
begin
if FPS_ISFIFO(Info.st_mode) then
begin
FileClose(Result);
errno:= ESysEINVAL;
Exit(feInvalidHandle);
end;
end;
end;
{$IF DEFINED(DARWIN)}
if (Mode and (fmOpenSync or fmOpenDirect) <> 0) then
begin
if (FpFcntl(Result, F_NOCACHE, 1) = -1) then
begin
FileClose(Result);
Exit(feInvalidHandle);
end;
end;
{$ENDIF}
end;
end;
{$ENDIF}
function mbFileCreate(const FileName: String): System.THandle;
begin
Result:= mbFileCreate(FileName, fmShareDenyWrite);
end;
function mbFileCreate(const FileName: String; Mode: LongWord): System.THandle;
begin
Result:= mbFileCreate(FileName, Mode, 438); // 438 = 666 octal
end;
function mbFileCreate(const FileName: String; Mode, Rights: LongWord): System.THandle;
{$IFDEF MSWINDOWS}
begin
Result:= CreateFileW(PWideChar(UTF16LongName(FileName)), GENERIC_READ or GENERIC_WRITE,
ShareModes[(Mode and $F0) shr 4], nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL,
OpenFlags[(Mode shr 16) and 3]);
end;
{$ELSE}
begin
repeat
Result:= fpOpen(UTF8ToSys(FileName), O_Creat or O_RdWr or O_Trunc or
OpenFlags[(Mode shr 16) and 3] or O_CLOEXEC, Rights);
until (Result <> -1) or (fpgeterrno <> ESysEINTR);
if Result <> feInvalidHandle then
begin
FileCloseOnExec(Result);
{$IF DEFINED(DARWIN)}
if (Mode and (fmOpenSync or fmOpenDirect) <> 0) then
begin
if (FpFcntl(Result, F_NOCACHE, 1) = -1) then
begin
FileClose(Result);
Exit(feInvalidHandle);
end;
end;
{$ENDIF}
end;
end;
{$ENDIF}
function mbFileAge(const FileName: String): DCBasicTypes.TFileTime;
{$IFDEF MSWINDOWS}
var
Handle: System.THandle;
FindData: TWin32FindDataW;
begin
Handle:= FindFirstFileW(PWideChar(UTF16LongName(FileName)), FindData);
if Handle <> INVALID_HANDLE_VALUE then
begin
Windows.FindClose(Handle);
Exit(DCBasicTypes.TFileTime(FindData.ftLastWriteTime));
end;
Result:= DCBasicTypes.TFileTime(-1);
end;
{$ELSE}
var
Info: BaseUnix.Stat;
begin
if fpStat(UTF8ToSys(FileName), Info) >= 0 then
Result:= DCBasicTypes.TFileTime(Info.st_mtime)
else begin
Result:= DCBasicTypes.TFileTime(-1);
end;
end;
{$ENDIF}
function mbFileGetTime(const FileName: String): DCBasicTypes.TFileTimeEx;
var
CreationTime, LastAccessTime: DCBasicTypes.TFileTimeEx;
begin
if not mbFileGetTime(FileName, Result, CreationTime, LastAccessTime) then
Result:= TFileTimeExNull;
end;
function mbFileGetTime(const FileName: String;
var ModificationTime: DCBasicTypes.TFileTimeEx;
var CreationTime : DCBasicTypes.TFileTimeEx;
var LastAccessTime : DCBasicTypes.TFileTimeEx): Boolean;
{$IFDEF MSWINDOWS}
var
Handle: System.THandle;
begin
Handle := CreateFileW(PWideChar(UTF16LongName(FileName)),
FILE_READ_ATTRIBUTES,
FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE,
nil,
OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS, // needed for opening directories
0);
if Handle <> INVALID_HANDLE_VALUE then
begin
Result := Windows.GetFileTime(Handle,
@CreationTime,
@LastAccessTime,
@ModificationTime);
CloseHandle(Handle);
end
else
Result := False;
end;
{$ELSE}
var
StatInfo : TDCStat;
begin
Result := DC_fpLStat(UTF8ToSys(FileName), StatInfo) >= 0;
if Result then
begin
ModificationTime:= StatInfo.mtime;
LastAccessTime:= StatInfo.atime;
{$IF DEFINED(DARWIN)}
CreationTime:= StatInfo.birthtime;
{$ELSE}
CreationTime:= StatInfo.ctime;
{$ENDIF}
end;
end;
{$ENDIF}
function mbFileSetTime(const FileName: String;
ModificationTime: DCBasicTypes.TFileTime;
CreationTime : DCBasicTypes.TFileTime = 0;
LastAccessTime : DCBasicTypes.TFileTime = 0): Boolean;
{$IFDEF MSWINDOWS}
begin
Result:= mbFileSetTimeEx(FileName, ModificationTime, CreationTime, LastAccessTime);
end;
{$ELSE}
var
NewModificationTime: DCBasicTypes.TFileTimeEx;
NewCreationTime : DCBasicTypes.TFileTimeEx;
NewLastAccessTime : DCBasicTypes.TFileTimeEx;
begin
NewModificationTime:= specialize IfThen(ModificationTime<>0, TFileTimeEx.create(ModificationTime), TFileTimeExNull);
NewCreationTime:= specialize IfThen(CreationTime<>0, TFileTimeEx.create(CreationTime), TFileTimeExNull);
NewLastAccessTime:= specialize IfThen(LastAccessTime<>0, TFileTimeEx.create(LastAccessTime), TFileTimeExNull);
Result:= mbFileSetTimeEx(FileName, NewModificationTime, NewCreationTime, NewLastAccessTime);
end;
{$ENDIF}
function mbFileSetTimeEx(const FileName: String;
ModificationTime: DCBasicTypes.TFileTimeEx;
CreationTime : DCBasicTypes.TFileTimeEx;
LastAccessTime : DCBasicTypes.TFileTimeEx): Boolean;
{$IFDEF MSWINDOWS}
var
Handle: System.THandle;
PWinModificationTime: Windows.LPFILETIME = nil;
PWinCreationTime: Windows.LPFILETIME = nil;
PWinLastAccessTime: Windows.LPFILETIME = nil;
begin
Handle := CreateFileW(PWideChar(UTF16LongName(FileName)),
FILE_WRITE_ATTRIBUTES,
FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE,
nil,
OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS, // needed for opening directories
0);
if Handle <> INVALID_HANDLE_VALUE then
begin
if ModificationTime <> 0 then
begin
PWinModificationTime := @ModificationTime;
end;
if CreationTime <> 0 then
begin
PWinCreationTime := @CreationTime;
end;
if LastAccessTime <> 0 then
begin
PWinLastAccessTime := @LastAccessTime;
end;
Result := Windows.SetFileTime(Handle,
PWinCreationTime,
PWinLastAccessTime,
PWinModificationTime);
CloseHandle(Handle);
end
else
Result := False;
end;
{$ELSE}
var
CurrentModificationTime, CurrentCreationTime, CurrentLastAccessTime: DCBasicTypes.TFileTimeEx;
begin
if mbFileGetTime(FileName, CurrentModificationTime, CurrentCreationTime, CurrentLastAccessTime) then
begin
if ModificationTime<>TFileTimeExNull then CurrentModificationTime:= ModificationTime;
if CreationTime<>TFileTimeExNull then CurrentCreationTime:= CreationTime;
if LastAccessTime<>TFileTimeExNull then CurrentLastAccessTime:= LastAccessTime;
Result := DC_FileSetTime(FileName, CurrentModificationTime, CurrentCreationTime, CurrentLastAccessTime);
end
else
begin
Result:=False;
end;
end;
{$ENDIF}
function mbFileExists(const FileName: String) : Boolean;
{$IFDEF MSWINDOWS}
var
Attr: DWORD;
begin
Attr:= GetFileAttributesW(PWideChar(UTF16LongName(FileName)));
if Attr <> DWORD(-1) then
Result:= (Attr and FILE_ATTRIBUTE_DIRECTORY) = 0
else
Result:=False;
end;
{$ELSE}
var
Info: BaseUnix.Stat;
begin
// Can use fpStat, because link to an existing filename can be opened as if it were a real file.
if fpStat(UTF8ToSys(FileName), Info) >= 0 then
Result:= fpS_ISREG(Info.st_mode)
else
Result:= False;
end;
{$ENDIF}
function mbFileAccess(const FileName: String; Mode: Word): Boolean;
{$IFDEF MSWINDOWS}
const
AccessMode: array[0..2] of DWORD = (
GENERIC_READ,
GENERIC_WRITE,
GENERIC_READ or GENERIC_WRITE);
var
hFile: System.THandle;
dwDesiredAccess: DWORD;
dwShareMode: DWORD = 0;
begin
dwDesiredAccess := AccessMode[Mode and 3];
if Mode = fmOpenRead then // If checking Read mode no sharing mode given
Mode := Mode or fmShareDenyNone;
dwShareMode := ShareModes[(Mode and $F0) shr 4];
hFile:= CreateFileW(PWideChar(UTF16LongName(FileName)), dwDesiredAccess, dwShareMode,
nil, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
Result := hFile <> INVALID_HANDLE_VALUE;
if Result then
FileClose(hFile);
end;
{$ELSE}
const
AccessMode: array[0..2] of LongInt = (
R_OK,
W_OK,
R_OK or W_OK);
begin
Result:= fpAccess(UTF8ToSys(FileName), AccessMode[Mode and 3]) = 0;
end;
{$ENDIF}
{$IFOPT R+}
{$DEFINE uOSUtilsRangeCheckOn}
{$R-}
{$ENDIF}
function mbFileGetAttr(const FileName: String): TFileAttrs;
{$IFDEF MSWINDOWS}
begin
Result := GetFileAttributesW(PWideChar(UTF16LongName(FileName)));
end;
{$ELSE}
var
Info: BaseUnix.Stat;
begin
if fpLStat(UTF8ToSys(FileName), @Info) >= 0 then
Result:= Info.st_mode
else
Result:= faInvalidAttributes;
end;
{$ENDIF}
function mbFileGetAttr(const FileName: String; out Attr: TFileAttributeData): Boolean;
{$IFDEF MSWINDOWS}
var
Handle: THandle;
fInfoLevelId: FINDEX_INFO_LEVELS;
FileInfo: Windows.TWin32FindDataW;
begin
if CheckWin32Version(6, 1) then
fInfoLevelId:= FindExInfoBasic
else begin
fInfoLevelId:= FindExInfoStandard;
end;
Handle:= FindFirstFileExW(PWideChar(UTF16LongName(FileName)), fInfoLevelId,
@FileInfo, FindExSearchNameMatch, nil, 0);
Result:= Handle <> INVALID_HANDLE_VALUE;
if Result then
begin
FindClose(Handle);
// If a reparse point tag is not a name surrogate then remove reparse point attribute
// Fixes bug: http://doublecmd.sourceforge.net/mantisbt/view.php?id=531
if (FileInfo.dwFileAttributes and FILE_ATTRIBUTE_REPARSE_POINT <> 0) then
begin
if (FileInfo.dwReserved0 and $20000000 = 0) then
FileInfo.dwFileAttributes-= FILE_ATTRIBUTE_REPARSE_POINT;
end;
Int64Rec(Attr.Size).Lo:= FileInfo.nFileSizeLow;
Int64Rec(Attr.Size).Hi:= FileInfo.nFileSizeHigh;
Move(FileInfo, Attr.FindData, SizeOf(TWin32FileAttributeData));
end;
end;
{$ELSE}
begin
Result:= fpLStat(UTF8ToSys(FileName), Attr.FindData) >= 0;
if Result then
begin
Attr.Size:= Attr.FindData.st_size;
end;
end;
{$ENDIF}
function mbFileSetAttr(const FileName: String; Attr: TFileAttrs): Boolean;
{$IFDEF MSWINDOWS}
begin
Result:= SetFileAttributesW(PWideChar(UTF16LongName(FileName)), Attr);
end;
{$ELSE}
begin
Result:= fpchmod(UTF8ToSys(FileName), Attr) = 0;
end;
{$ENDIF}
{$IFDEF uOSUtilsRangeCheckOn}
{$R+}
{$UNDEF uOSUtilsRangeCheckOn}
{$ENDIF}
function mbFileSetReadOnly(const FileName: String; ReadOnly: Boolean): Boolean;
{$IFDEF MSWINDOWS}
var
iAttr: DWORD;
wFileName: UnicodeString;
begin
wFileName:= UTF16LongName(FileName);
iAttr := GetFileAttributesW(PWideChar(wFileName));
if iAttr = DWORD(-1) then Exit(False);
if ReadOnly then
iAttr:= iAttr or faReadOnly
else
iAttr:= iAttr and not (faReadOnly or faHidden or faSysFile);
Result:= SetFileAttributesW(PWideChar(wFileName), iAttr) = True;
end;
{$ELSE}
var
StatInfo: BaseUnix.Stat;
mode: TMode;
begin
if fpStat(UTF8ToSys(FileName), StatInfo) <> 0 then Exit(False);
mode := SetModeReadOnly(StatInfo.st_mode, ReadOnly);
Result:= fpchmod(UTF8ToSys(FileName), mode) = 0;
end;
{$ENDIF}
function mbDeleteFile(const FileName: String): Boolean;
{$IFDEF MSWINDOWS}
begin
Result:= Windows.DeleteFileW(PWideChar(UTF16LongName(FileName)));
if not Result then Result:= (GetLastError = ERROR_FILE_NOT_FOUND);
end;
{$ELSE}
begin
Result:= fpUnLink(UTF8ToSys(FileName)) = 0;
if not Result then Result:= (fpgetErrNo = ESysENOENT);
end;
{$ENDIF}
function mbRenameFile(const OldName: String; NewName: String): Boolean;
{$IFDEF MSWINDOWS}
var
wTmpName,
wOldName, wNewName: UnicodeString;
begin
wNewName:= UTF16LongName(NewName);
wOldName:= UTF16LongName(OldName);
// Workaround: Windows >= 10 can't change only filename case on the FAT
if (Win32MajorVersion >= 10) and UnicodeSameText(wOldName, wNewName) then
begin
wTmpName:= GetFileSystemType(OldName);
if UnicodeSameText('FAT32', wTmpName) or UnicodeSameText('exFAT', wTmpName) then
begin
wTmpName:= UTF16LongName(GetTempName(OldName));
Result:= MoveFileExW(PWChar(wOldName), PWChar(wTmpName), 0);
if Result then
begin
Result:= MoveFileExW(PWChar(wTmpName), PWChar(wNewName), 0);
if not Result then MoveFileExW(PWChar(wTmpName), PWChar(wOldName), 0);
end;
Exit;
end;
end;
Result:= MoveFileExW(PWChar(wOldName), PWChar(wNewName), MOVEFILE_REPLACE_EXISTING);
end;
{$ELSE}
var
tmpFileName: String;
OldFileStat, NewFileStat: stat;
begin
if GetPathType(NewName) <> ptAbsolute then
NewName := ExtractFilePath(OldName) + NewName;
if OldName = NewName then
Exit(True);
if fpLstat(UTF8ToSys(OldName), OldFileStat) <> 0 then
Exit(False);
// Check if target file exists.
if fpLstat(UTF8ToSys(NewName), NewFileStat) = 0 then
begin
// Check if source and target are the same files (same inode and same device).
if (OldFileStat.st_ino = NewFileStat.st_ino) and
(OldFileStat.st_dev = NewFileStat.st_dev) then
begin
// Check number of links.
// If it is 1 then source and target names most probably differ only
// by case on a case-insensitive filesystem. Direct rename() in such case
// fails on Linux, so we use a temporary file name and rename in two stages.
// If number of links is more than 1 then it's enough to simply unlink
// the source file, since both files are technically identical.
// (On Linux rename() returns success but doesn't do anything
// if renaming a file to its hard link.)
// We cannot use st_nlink for directories because it means "number of
// subdirectories" ("number of all entries" under macOS) in that directory,
// plus its special entries '.' and '..';
// hard links to directories are not supported on Linux
// or Windows anyway (on macOS they are). Therefore we always treat
// directories as if they were a single link and rename them using temporary name.
if (NewFileStat.st_nlink = 1) or BaseUnix.fpS_ISDIR(NewFileStat.st_mode) then
begin
tmpFileName := GetTempName(OldName);
if FpRename(UTF8ToSys(OldName), UTF8ToSys(tmpFileName)) = 0 then
begin
if fpLstat(UTF8ToSys(NewName), NewFileStat) = 0 then
begin
// We have renamed the old file but the new file name still exists,
// so this wasn't a single file on a case-insensitive filesystem
// accessible by two names that differ by case.
FpRename(UTF8ToSys(tmpFileName), UTF8ToSys(OldName)); // Restore old file.
Result := False;
end
else if FpRename(UTF8ToSys(tmpFileName), UTF8ToSys(NewName)) = 0 then
begin
Result := True;
end
else
begin
FpRename(UTF8ToSys(tmpFileName), UTF8ToSys(OldName)); // Restore old file.
Result := False;
end;
end
else
Result := False;
end
else
begin
// Multiple links - simply unlink the source file.
Result := (fpUnLink(UTF8ToSys(OldName)) = 0);
end;
Exit;
end;
end;
Result := FpRename(UTF8ToSys(OldName), UTF8ToSys(NewName)) = 0;
end;
{$ENDIF}
function mbFileSize(const FileName: String): Int64;
{$IFDEF MSWINDOWS}
var
Handle: System.THandle;
FindData: TWin32FindDataW;
begin
Result:= 0;
Handle := FindFirstFileW(PWideChar(UTF16LongName(FileName)), FindData);
if Handle <> INVALID_HANDLE_VALUE then
begin
Windows.FindClose(Handle);
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
begin
Int64Rec(Result).Lo:= FindData.nFileSizeLow;
Int64Rec(Result).Hi:= FindData.nFileSizeHigh;
end;
end;
end;
{$ELSE}
var
Info: BaseUnix.Stat;
begin
Result:= 0;
if fpStat(UTF8ToSys(FileName), Info) >= 0 then
Result:= Info.st_size;
end;
{$ENDIF}
function FileGetSize(Handle: System.THandle): Int64;
{$IFDEF MSWINDOWS}
begin
Int64Rec(Result).Lo := GetFileSize(Handle, @Int64Rec(Result).Hi);
end;
{$ELSE}
var
Info: BaseUnix.Stat;
begin
if fpFStat(Handle, Info) < 0 then
Result := -1
else
Result := Info.st_size;
end;
{$ENDIF}
function FileFlush(Handle: System.THandle): Boolean; inline;
{$IFDEF MSWINDOWS}
begin
Result:= FlushFileBuffers(Handle);
end;
{$ELSE}
begin
Result:= (fpfsync(Handle) = 0);
end;
{$ENDIF}
function FileFlushData(Handle: System.THandle): Boolean; inline;
{$IF DEFINED(LINUX)}
begin
Result:= (fpFDataSync(Handle) = 0);
end;
{$ELSE}
begin
Result:= FileFlush(Handle);
end;
{$ENDIF}
function FileIsReadOnlyEx(Handle: System.THandle): Boolean;
{$IF DEFINED(MSWINDOWS)}
var
Info: BY_HANDLE_FILE_INFORMATION;
begin
if GetFileInformationByHandle(Handle, Info) then
Result:= (Info.dwFileAttributes and (faReadOnly or faHidden or faSysFile) <> 0)
else
Result:= False;
end;
{$ELSEIF DEFINED(LINUX)}
var
Flags: UInt32;
begin
if FileGetFlags(Handle, Flags) then
begin
if (Flags and (FS_IMMUTABLE_FL or FS_APPEND_FL) <> 0) then
Exit(True);
end;
Result:= False;
end;
{$ELSE}
begin
Result:= False;
end;
{$ENDIF}
function FileAllocate(Handle: System.THandle; Size: Int64): Boolean;
{$IF DEFINED(LINUX)}
var
Ret: cint;
Sta: TStat;
StaFS: TStatFS;
begin
if (Size > 0) then
begin
repeat
Ret:= fpfStatFS(Handle, @StaFS);
until (Ret <> -1) or (fpgeterrno <> ESysEINTR);
// FAT32 does not support a fast allocation
if (StaFS.fstype = MSDOS_SUPER_MAGIC) then
Exit(False);
repeat
Ret:= fpFStat(Handle, Sta);
until (Ret <> -1) or (fpgeterrno <> ESysEINTR);
if (Ret = 0) and (Sta.st_size < Size) then
begin
// New size should be aligned to block size
Sta.st_size:= (Size + Sta.st_blksize - 1) and not (Sta.st_blksize - 1);
repeat
Ret:= fpFAllocate(Handle, 0, 0, Sta.st_size);
until (Ret <> -1) or (fpgeterrno <> ESysEINTR);
end;
end;
Result:= FileTruncate(Handle, Size);
end;
{$ELSE}
begin
Result:= FileTruncate(Handle, Size);
end;
{$ENDIF}
function mbGetCurrentDir: String;
{$IFDEF MSWINDOWS}
var
dwSize: DWORD;
wsDir: UnicodeString;
begin
if Length(CurrentDirectory) > 0 then
Result:= CurrentDirectory
else
begin
dwSize:= GetCurrentDirectoryW(0, nil);
if dwSize = 0 then
Result:= EmptyStr
else begin
SetLength(wsDir, dwSize + 1);
SetLength(wsDir, GetCurrentDirectoryW(dwSize, PWideChar(wsDir)));
Result:= UTF16ToUTF8(wsDir);
end;
end;
end;
{$ELSE}
begin
GetDir(0, Result);
Result := SysToUTF8(Result);
end;
{$ENDIF}
function mbSetCurrentDir(const NewDir: String): Boolean;
{$IFDEF MSWINDOWS}
var
Handle: THandle;
wsNewDir: UnicodeString;
FindData: TWin32FindDataW;
begin
if (Pos('\\', NewDir) = 1) then
Result:= True
else begin
wsNewDir:= UTF16LongName(IncludeTrailingBackslash(NewDir)) + '*';
Handle:= FindFirstFileW(PWideChar(wsNewDir), FindData);
Result:= (Handle <> INVALID_HANDLE_VALUE) or (GetLastError = ERROR_FILE_NOT_FOUND);
if (Handle <> INVALID_HANDLE_VALUE) then FindClose(Handle);
end;
if Result then CurrentDirectory:= NewDir;
end;
{$ELSE}
begin
Result:= fpChDir(UTF8ToSys(NewDir)) = 0;
end;
{$ENDIF}
function mbDirectoryExists(const Directory: String) : Boolean;
{$IFDEF MSWINDOWS}
var
Attr: DWORD;
begin
Attr:= GetFileAttributesW(PWideChar(UTF16LongName(Directory)));
if Attr <> DWORD(-1) then
Result:= (Attr and FILE_ATTRIBUTE_DIRECTORY) > 0
else
Result:= False;
end;
{$ELSE}
var
Info: BaseUnix.Stat;
begin
// We can use fpStat here instead of fpLstat, so that True is returned
// when target is a directory or a link to an existing directory.
// Note that same behaviour would be achieved by passing paths
// that end with path delimiter to fpLstat.
// Paths with links can be used the same way as if they were real directories.
if fpStat(UTF8ToSys(Directory), Info) >= 0 then
Result:= fpS_ISDIR(Info.st_mode)
else
Result:= False;
end;
{$ENDIF}
function mbCreateDir(const NewDir: String): Boolean;
{$IFDEF MSWINDOWS}
begin
Result:= CreateDirectoryW(PWideChar(UTF16LongName(NewDir)), nil);
end;
{$ELSE}
begin
Result:= fpMkDir(UTF8ToSys(NewDir), $1FF) = 0; // $1FF = &0777
end;
{$ENDIF}
function mbRemoveDir(const Dir: String): Boolean;
{$IFDEF MSWINDOWS}
begin
Result:= RemoveDirectoryW(PWideChar(UTF16LongName(Dir)));
if not Result then Result:= (GetLastError = ERROR_FILE_NOT_FOUND);
end;
{$ELSE}
begin
Result:= fpRmDir(UTF8ToSys(Dir)) = 0;
if not Result then Result:= (fpgetErrNo = ESysENOENT);
end;
{$ENDIF}
function mbFileSystemEntryExists(const Path: String): Boolean;
begin
Result := mbFileGetAttr(Path) <> faInvalidAttributes;
end;
function mbCompareFileNames(const FileName1, FileName2: String): Boolean;
{$IF DEFINED(DARWIN)}
begin
if (Length(FileName1) = 0) or (Length(FileName2) = 0) then
Result:= (FileName1 = FileName2)
else begin
Result:= CompareFilenamesIgnoreCase(FileName1, FileName2) = 0;
end;
end;
{$ELSEIF DEFINED(MSWINDOWS)}
begin
Result:= (UnicodeCompareText(CeUtf8ToUtf16(FileName1), CeUtf8ToUtf16(FileName2)) = 0);
end;
{$ELSE}
begin
Result:= (UnicodeCompareStr(CeUtf8ToUtf16(FileName1), CeUtf8ToUtf16(FileName2)) = 0);
end;
{$ENDIF}
function mbFileSame(const FileName1, FileName2: String): Boolean;
{$IF DEFINED(MSWINDOWS)}
var
Device1, Device2: TStringArray;
FileHandle1, FileHandle2: System.THandle;
FileInfo1, FileInfo2: BY_HANDLE_FILE_INFORMATION;
begin
Result := mbCompareFileNames(FileName1, FileName2);
if not Result then
begin
FileHandle1 := CreateFileW(PWideChar(UTF16LongName(FileName1)), FILE_READ_ATTRIBUTES,
FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE,
nil, OPEN_EXISTING, 0, 0);
if FileHandle1 <> INVALID_HANDLE_VALUE then
begin
FileHandle2 := CreateFileW(PWideChar(UTF16LongName(FileName2)), FILE_READ_ATTRIBUTES,
FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE,
nil, OPEN_EXISTING, 0, 0);
if FileHandle2 <> INVALID_HANDLE_VALUE then
begin
if GetFileInformationByHandle(FileHandle1, FileInfo1) and
GetFileInformationByHandle(FileHandle2, FileInfo2) then
begin
// Check if both files have the same index on the same volume.
// This check is valid only while both files are open.
Result := (FileInfo1.dwVolumeSerialNumber = FileInfo2.dwVolumeSerialNumber) and
(FileInfo1.nFileIndexHigh = FileInfo2.nFileIndexHigh) and
(FileInfo1.nFileIndexLow = FileInfo2.nFileIndexLow);
// Check that both files on the same physical drive (bug 0001774)
if Result then
begin
Device1:= AnsiString(GetFinalPathNameByHandle(FileHandle1)).Split([PathDelim]);
Device2:= AnsiString(GetFinalPathNameByHandle(FileHandle2)).Split([PathDelim]);
Result:= (Length(Device1) > 2) and (Length(Device2) > 2) and (Device1[2] = Device2[2]);
end;
end;
CloseHandle(FileHandle2);
end;
CloseHandle(FileHandle1);
end
end;
end;
{$ELSEIF DEFINED(UNIX)}
var
File1Stat, File2Stat: stat;
begin
Result := mbCompareFileNames(FileName1, FileName2) or
(
(fpLstat(UTF8ToSys(FileName1), File1Stat) = 0) and
(fpLstat(UTF8ToSys(FileName2), File2Stat) = 0) and
(File1Stat.st_ino = File2Stat.st_ino) and
(File1Stat.st_dev = File2Stat.st_dev)
);
end;
{$ENDIF}
function mbFileSameVolume(const FileName1, FileName2: String): Boolean;
{$IF DEFINED(MSWINDOWS)}
var
lpszVolumePathName1: array[0..maxSmallint] of WideChar;
lpszVolumePathName2: array[0..maxSmallint] of WideChar;
begin
Result:= GetVolumePathNameW(PWideChar(UTF16LongName(FileName1)), PWideChar(lpszVolumePathName1), maxSmallint) and
GetVolumePathNameW(PWideChar(UTF16LongName(FileName2)), PWideChar(lpszVolumePathName2), maxSmallint) and
WideSameText(ExtractFileDrive(lpszVolumePathName1), ExtractFileDrive(lpszVolumePathName2));
end;
{$ELSE}
var
Stat1, Stat2: Stat;
begin
Result:= (fpLStat(UTF8ToSys(FileName1), Stat1) = 0) and
(fpLStat(UTF8ToSys(FileName2), Stat2) = 0) and
(Stat1.st_dev = Stat2.st_dev);
end;
{$ENDIF}
function mbGetEnvironmentString(Index: Integer): String;
{$IFDEF MSWINDOWS}
var
hp, p: PWideChar;
begin
Result:= '';
p:= GetEnvironmentStringsW;
hp:= p;
if (hp <> nil) then
begin
while (hp^ <> #0) and (Index > 1) do
begin
Dec(Index);
hp:= hp + lstrlenW(hp) + 1;
end;
if (hp^ <> #0) then
Result:= UTF16ToUTF8(UnicodeString(hp));
end;
FreeEnvironmentStringsW(p);
end;
{$ELSE}
begin
Result:= SysToUTF8(GetEnvironmentString(Index));
end;
{$ENDIF}
function mbExpandEnvironmentStrings(const FileName: String): String;
{$IF DEFINED(MSWINDOWS)}
var
dwSize: DWORD;
wsResult: UnicodeString;
begin
SetLength(wsResult, MaxSmallInt + 1);
dwSize:= ExpandEnvironmentStringsW(PWideChar(CeUtf8ToUtf16(FileName)), PWideChar(wsResult), MaxSmallInt);
if (dwSize = 0) or (dwSize > MaxSmallInt) then
Result:= FileName
else begin
SetLength(wsResult, dwSize - 1);
Result:= UTF16ToUTF8(wsResult);
end;
end;
{$ELSE}
var
Index: Integer = 1;
EnvCnt, EqualPos: Integer;
EnvVar, EnvName, EnvValue: String;
begin
Result:= FileName;
EnvCnt:= GetEnvironmentVariableCount;
while (Index <= EnvCnt) and (Pos('$', Result) > 0) do
begin
EnvVar:= mbGetEnvironmentString(Index);
EqualPos:= Pos('=', EnvVar);
if EqualPos = 0 then Continue;
EnvName:= Copy(EnvVar, 1, EqualPos - 1);
EnvValue:= Copy(EnvVar, EqualPos + 1, MaxInt);
Result:= StringReplace(Result, '$' + EnvName, EnvValue, [rfReplaceAll]);
Inc(Index);
end;
end;
{$ENDIF}
function mbGetEnvironmentVariable(const sName: String): String;
{$IFDEF MSWINDOWS}
var
wsName: UnicodeString;
smallBuf: array[0..1023] of WideChar;
largeBuf: PWideChar;
dwResult: DWORD;
begin
Result := EmptyStr;
wsName := CeUtf8ToUtf16(sName);
dwResult := GetEnvironmentVariableW(PWideChar(wsName), @smallBuf[0], Length(smallBuf));
if dwResult > Length(smallBuf) then
begin
// Buffer not large enough.
largeBuf := GetMem(SizeOf(WideChar) * dwResult);
if Assigned(largeBuf) then
try
dwResult := GetEnvironmentVariableW(PWideChar(wsName), largeBuf, dwResult);
if dwResult > 0 then
Result := UTF16ToUTF8(UnicodeString(largeBuf));
finally
FreeMem(largeBuf);
end;
end
else if dwResult > 0 then
Result := UTF16ToUTF8(UnicodeString(smallBuf));
end;
{$ELSE}
begin
Result:= CeSysToUtf8(getenv(PAnsiChar(CeUtf8ToSys(sName))));
end;
{$ENDIF}
function mbSetEnvironmentVariable(const sName, sValue: String): Boolean;
{$IFDEF MSWINDOWS}
var
wsName,
wsValue: UnicodeString;
begin
wsName:= CeUtf8ToUtf16(sName);
wsValue:= CeUtf8ToUtf16(sValue);
Result:= SetEnvironmentVariableW(PWideChar(wsName), PWideChar(wsValue));
end;
{$ELSE}
begin
Result:= (setenv(PAnsiChar(CeUtf8ToSys(sName)), PAnsiChar(CeUtf8ToSys(sValue)), 1) = 0);
end;
{$ENDIF}
function mbUnsetEnvironmentVariable(const sName: String): Boolean;
{$IFDEF MSWINDOWS}
var
wsName: UnicodeString;
begin
wsName:= CeUtf8ToUtf16(sName);
Result:= SetEnvironmentVariableW(PWideChar(wsName), NIL);
end;
{$ELSE}
begin
Result:= (unsetenv(PAnsiChar(CeUtf8ToSys(sName))) = 0);
end;
{$ENDIF}
function mbSysErrorMessage: String;
begin
Result := mbSysErrorMessage(GetLastOSError);
end;
function mbSysErrorMessage(ErrorCode: Integer): String;
begin
Result := SysErrorMessage(ErrorCode);
{$IF (FPC_FULLVERSION < 30004)}
Result := CeSysToUtf8(Result);
{$ENDIF}
end;
function mbGetModuleName(Address: Pointer): String;
const
Dummy: Boolean = False;
{$IFDEF UNIX}
var
dlinfo: dl_info;
begin
if Address = nil then Address:= @Dummy;
FillChar({%H-}dlinfo, SizeOf(dlinfo), #0);
if dladdr(Address, @dlinfo) = 0 then
Result:= EmptyStr
else begin
Result:= CeSysToUtf8(dlinfo.dli_fname);
end;
end;
{$ELSE}
var
ModuleName: UnicodeString;
lpBuffer: TMemoryBasicInformation;
begin
if Address = nil then Address:= @Dummy;
if VirtualQuery(Address, @lpBuffer, SizeOf(lpBuffer)) <> SizeOf(lpBuffer) then
Result:= EmptyStr
else begin
SetLength(ModuleName, MAX_PATH + 1);
SetLength(ModuleName, GetModuleFileNameW({%H-}THandle(lpBuffer.AllocationBase),
PWideChar(ModuleName), MAX_PATH));
Result:= UTF16ToUTF8(ModuleName);
end;
end;
{$ENDIF}
function mbLoadLibrary(const Name: String): TLibHandle;
{$IFDEF MSWINDOWS}
var
dwMode: DWORD;
dwErrCode: DWORD;
sRememberPath: String;
begin
dwMode:= SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX);
try
// Some plugins using DLL(s) in their directory are loaded correctly only if "CurrentDir" is poining their location.
// Also, TC switch "CurrentDir" to their directory when loading them. So let's do the same.
sRememberPath:= GetCurrentDir;
SetCurrentDir(ExtractFileDir(Name));
Result:= SafeLoadLibrary(CeUtf8ToUtf16(Name));
dwErrCode:= GetLastError;
finally
SetErrorMode(dwMode);
SetCurrentDir(sRememberPath);
SetLastError(dwErrCode);
end;
end;
{$ELSE}
begin
Result:= SafeLoadLibrary(CeUtf8ToSys(Name));
end;
{$ENDIF}
function mbLoadLibraryEx(const Name: String): TLibHandle;
{$IF DEFINED(MSWINDOWS)}
const
PATH_ENV = 'PATH';
var
dwFlags:DWORD;
APath: String;
APathType: TPathType;
usName: UnicodeString;
begin
usName:= CeUtf8ToUtf16(Name);
APathType:= GetPathType(Name);
if CheckWin32Version(10) or (GetProcAddress(GetModuleHandleW(Kernel32), 'AddDllDirectory') <> nil) then
begin
if APathType <> ptAbsolute then
dwFlags:= 0
else begin
dwFlags:= LOAD_LIBRARY_SEARCH_DLL_LOAD_DIR;
end;
Result:= LoadLibraryExW(PWideChar(usName), 0, dwFlags or LOAD_LIBRARY_SEARCH_DEFAULT_DIRS);
end
else begin
APath:= mbGetEnvironmentVariable(PATH_ENV);
try
if APathType <> ptAbsolute then
SetDllDirectoryW(PWideChar(''))
else begin
SetDllDirectoryW(PWideChar(ExtractFileDir(usName)));
end;
try
SetEnvironmentVariableW(PATH_ENV, nil);
Result:= LoadLibraryW(PWideChar(usName));
finally
SetDllDirectoryW(nil);
end;
finally
mbSetEnvironmentVariable(PATH_ENV, APath);
end;
end;
end;
{$ELSE}
begin
Result:= SafeLoadLibrary(CeUtf8ToSys(Name));
end;
{$ENDIF}
function SafeGetProcAddress(Lib: TLibHandle; const ProcName: AnsiString): Pointer;
begin
Result:= GetProcedureAddress(Lib, ProcName);
if (Result = nil) then raise Exception.Create(ProcName);
end;
function mbReadAllLinks(const PathToLink: String) : String;
var
Attrs: TFileAttrs;
LinkTargets: TStringList; // A list of encountered filenames (for detecting cycles)
function mbReadAllLinksRec(const PathToLink: String): String;
begin
Result := ReadSymLink(PathToLink);
if Result <> '' then
begin
if GetPathType(Result) <> ptAbsolute then
Result := GetAbsoluteFileName(ExtractFilePath(PathToLink), Result);
if LinkTargets.IndexOf(Result) >= 0 then
begin
// Link already encountered - links form a cycle.
Result := '';
{$IFDEF UNIX}
fpseterrno(ESysELOOP);
{$ENDIF}
Exit;
end;
Attrs := mbFileGetAttr(Result);
if (Attrs <> faInvalidAttributes) then
begin
if FPS_ISLNK(Attrs) then
begin
// Points to a link - read recursively.
LinkTargets.Add(Result);
Result := mbReadAllLinksRec(Result);
end;
// else points to a file/dir
end
else
begin
Result := ''; // Target of link doesn't exist
{$IFDEF UNIX}
fpseterrno(ESysENOENT);
{$ENDIF}
end;
end;
end;
begin
LinkTargets := TStringList.Create;
try
Result := mbReadAllLinksRec(PathToLink);
finally
FreeAndNil(LinkTargets);
end;
end;
function mbCheckReadLinks(const PathToLink : String): String;
var
Attrs: TFileAttrs;
begin
Attrs := mbFileGetAttr(PathToLink);
if (Attrs <> faInvalidAttributes) and FPS_ISLNK(Attrs) then
Result := mbReadAllLinks(PathToLink)
else
Result := PathToLink;
end;
function mbFileGetAttrNoLinks(const FileName: String): TFileAttrs;
{$IFDEF UNIX}
var
Info: BaseUnix.Stat;
begin
if fpStat(UTF8ToSys(FileName), Info) >= 0 then
Result := Info.st_mode
else
Result := faInvalidAttributes;
end;
{$ELSE}
var
LinkTarget: String;
begin
LinkTarget := mbReadAllLinks(FileName);
if LinkTarget <> '' then
Result := mbFileGetAttr(LinkTarget)
else
Result := faInvalidAttributes;
end;
{$ENDIF}
function CreateHardLink(const Path, LinkName: String) : Boolean;
{$IFDEF MSWINDOWS}
var
wsPath, wsLinkName: UnicodeString;
begin
wsPath:= UTF16LongName(Path);
wsLinkName:= UTF16LongName(LinkName);
Result:= DCNtfsLinks.CreateHardlink(wsPath, wsLinkName);
end;
{$ELSE}
begin
Result := (fplink(PAnsiChar(CeUtf8ToSys(Path)),PAnsiChar(CeUtf8ToSys(LinkName)))=0);
end;
{$ENDIF}
function CreateSymLink(const Path, LinkName: string; Attr: UInt32): Boolean;
{$IFDEF MSWINDOWS}
var
wsPath, wsLinkName: UnicodeString;
begin
wsPath:= CeUtf8ToUtf16(Path);
wsLinkName:= UTF16LongName(LinkName);
Result:= DCNtfsLinks.CreateSymlink(wsPath, wsLinkName, Attr);
end;
{$ELSE}
begin
Result := (fpsymlink(PAnsiChar(CeUtf8ToSys(Path)), PAnsiChar(CeUtf8ToSys(LinkName)))=0);
end;
{$ENDIF}
function ReadSymLink(const LinkName : String) : String;
{$IFDEF MSWINDOWS}
var
wsLinkName, wsTarget: UnicodeString;
begin
wsLinkName:= UTF16LongName(LinkName);
if DCNtfsLinks.ReadSymLink(wsLinkName, wsTarget) then
Result := UTF16ToUTF8(wsTarget)
else
Result := EmptyStr;
end;
{$ELSE}
begin
Result := SysToUTF8(fpReadlink(UTF8ToSys(LinkName)));
end;
{$ENDIF}
procedure SetLastOSError(LastError: Integer);
{$IFDEF MSWINDOWS}
begin
SetLastError(UInt32(LastError));
end;
{$ELSE}
begin
fpseterrno(LastError);
end;
{$ENDIF}
function GetTickCountEx: UInt64;
begin
{$IF DEFINED(MSWINDOWS)}
if QueryPerformanceCounter(PLARGE_INTEGER(@Result)) then
Result:= Result div PerformanceFrequency.QuadPart
else
{$ENDIF}
begin
Result:= SysUtils.GetTickCount64;
end;
end;
{$IFDEF MSWINDOWS}
initialization
if QueryPerformanceFrequency(@PerformanceFrequency) then
PerformanceFrequency.QuadPart := PerformanceFrequency.QuadPart div 1000;
{$ENDIF}
end.