babaev-an/lasarus_compotents
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Стартовый пул

Browse Source
This commit is contained in:
Александр Бабаев
2024-04-02 08:46:59 +03:00
parent fd57fffd3a
commit 3bb34d000b
5591 changed files with 3291734 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

56
doublecmd/dcbasictypes.pas Normal file
View File

@@ -0,0 +1,56 @@
{
Double commander
-------------------------------------------------------------------------
Definitions of basic types.
Copyright (C) 2012 Przemyslaw Nagay (cobines@gmail.com)
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, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit DCBasicTypes;
interface
type
TDynamicStringArray = array of String;
TCharSet = set of Char;
TFileAttrs = Cardinal; // file attributes type regardless of system
TWinFileTime = QWord; // NTFS time (UTC) (2 x DWORD)
TDosFileTime = LongInt; // MS-DOS time (local)
{$IFDEF MSWINDOWS}
TFileTime = TWinFileTime;
{$ELSE}
// Unix time (UTC).
// Unix defines time_t as signed integer,
// but we define it as unsigned because sign is not needed.
{$IFDEF cpu64}
TFileTime = QWord;
{$ELSE}
TFileTime = DWord;
{$ENDIF}
{$ENDIF}
TUnixFileTime = TFileTime;
PFileTime = ^TFileTime;
PWinFileTime = ^TWinFileTime;
implementation
end.

255
doublecmd/dcclassesutf8.pas Normal file
View File

@@ -0,0 +1,255 @@
{
Double commander
-------------------------------------------------------------------------
This module contains classes with UTF8 file names support.
Copyright (C) 2008-2011 Koblov Alexander (Alexx2000@mail.ru)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit DCClassesUtf8;
{$mode objfpc}{$H+}
interface
uses
Classes, RtlConsts, SysUtils, IniFiles;
{$IF (FPC_VERSION = 2) and (FPC_RELEASE < 5)}
const
{ TFileStream create mode }
fmCreate = $FF00;
{$ENDIF}
type
{ TFileStreamEx class }
TFileStreamEx = class(THandleStream)
private
FHandle: THandle;
FFileName: UTF8String;
public
constructor Create(const AFileName: UTF8String; Mode: Word);
destructor Destroy; override;
{$IF (FPC_VERSION <= 2) and (FPC_RELEASE <= 4) and (FPC_PATCH <= 0)}
function ReadQWord: QWord;
procedure WriteQWord(q: QWord);
{$ENDIF}
property FileName: UTF8String read FFileName;
end;
{ TStringListEx }
TStringListEx = class(TStringList)
public
function IndexOfValue(const Value: String): Integer;
procedure LoadFromFile(const FileName: String); override;
procedure SaveToFile(const FileName: String); override;
end;
{ TIniFileEx }
THackIniFile = class
private
FFileName: String;
FSectionList: TIniFileSectionList;
end;
TIniFileEx = class(TIniFile)
private
FIniFileStream: TFileStreamEx;
FReadOnly: Boolean;
function GetFileName: UTF8String;
procedure SetFileName(const AValue: UTF8String);
public
constructor Create(const AFileName: String; Mode: Word); virtual;
constructor Create(const AFileName: string; AEscapeLineFeeds : Boolean = False); override;
destructor Destroy; override;
procedure UpdateFile; override;
public
procedure Clear;
property FileName: UTF8String read GetFileName write SetFileName;
property ReadOnly: Boolean read FReadOnly;
end;
implementation
uses
DCOSUtils;
{ TFileStreamEx }
constructor TFileStreamEx.Create(const AFileName: UTF8String; Mode: Word);
begin
if (Mode and fmCreate) <> 0 then
begin
FHandle:= mbFileCreate(AFileName, Mode);
if FHandle = feInvalidHandle then
raise EFCreateError.CreateFmt(SFCreateError, [AFileName])
else
inherited Create(FHandle);
end
else
begin
FHandle:= mbFileOpen(AFileName, Mode);
if FHandle = feInvalidHandle then
raise EFOpenError.CreateFmt(SFOpenError, [AFilename])
else
inherited Create(FHandle);
end;
FFileName:= AFileName;
end;
destructor TFileStreamEx.Destroy;
begin
inherited Destroy;
// Close handle after destroying the base object, because it may use Handle in Destroy.
if FHandle >= 0 then FileClose(FHandle);
end;
{$IF (FPC_VERSION <= 2) and (FPC_RELEASE <= 4) and (FPC_PATCH <= 0)}
function TFileStreamEx.ReadQWord: QWord;
var
q: QWord;
begin
ReadBuffer(q, SizeOf(QWord));
ReadQWord:= q;
end;
procedure TFileStreamEx.WriteQWord(q: QWord);
begin
WriteBuffer(q, SizeOf(QWord));
end;
{$ENDIF}
{ TStringListEx }
function TStringListEx.IndexOfValue(const Value: String): Integer;
var
iStart: LongInt;
sTemp: String;
begin
CheckSpecialChars;
Result:= 0;
while (Result < Count) do
begin
sTemp:= Strings[Result];
iStart:= Pos(NameValueSeparator, sTemp) + 1;
if (iStart > 0) and (DoCompareText(Value, Copy(sTemp, iStart, MaxInt)) = 0) then
Exit;
Inc(result);
end;
Result:= -1;
end;
procedure TStringListEx.LoadFromFile(const FileName: String);
var
fsFileStream: TFileStreamEx;
begin
fsFileStream:= TFileStreamEx.Create(FileName, fmOpenRead or fmShareDenyNone);
try
LoadFromStream(fsFileStream);
finally
fsFileStream.Free;
end;
end;
procedure TStringListEx.SaveToFile(const FileName: String);
var
fsFileStream: TFileStreamEx = nil;
begin
try
if mbFileExists(FileName) then
begin
fsFileStream:= TFileStreamEx.Create(FileName, fmOpenWrite or fmShareDenyWrite);
fsFileStream.Position:= 0;
fsFileStream.Size:= 0;
end
else
fsFileStream:= TFileStreamEx.Create(FileName, fmCreate);
SaveToStream(fsFileStream);
finally
fsFileStream.Free;
end;
end;
{ TIniFileEx }
function TIniFileEx.GetFileName: UTF8String;
begin
Result:= THackIniFile(Self).FFileName;
end;
procedure TIniFileEx.SetFileName(const AValue: UTF8String);
begin
THackIniFile(Self).FFileName:= AValue;
end;
constructor TIniFileEx.Create(const AFileName: String; Mode: Word);
begin
FReadOnly := ((Mode and $03) = fmOpenRead);
if mbFileExists(AFileName) then
begin
if (Mode and $F0) = 0 then
Mode := Mode or fmShareDenyWrite;
end
else
begin
Mode := fmCreate;
end;
FIniFileStream:= TFileStreamEx.Create(AFileName, Mode);
inherited Create(FIniFileStream);
FileName:= AFileName;
end;
constructor TIniFileEx.Create(const AFileName: string; AEscapeLineFeeds: Boolean);
begin
if mbFileAccess(AFileName, fmOpenReadWrite or fmShareDenyWrite) then
Create(AFileName, fmOpenReadWrite or fmShareDenyWrite)
else
Create(AFileName, fmOpenRead or fmShareDenyNone);
end;
procedure TIniFileEx.UpdateFile;
begin
if not ReadOnly then
begin
Stream.Position:=0;
Stream.Size:= 0;
FileName:= EmptyStr;
inherited UpdateFile;
FileName:= FIniFileStream.FileName;
end;
end;
procedure TIniFileEx.Clear;
begin
THackIniFile(Self).FSectionList.Clear;
end;
destructor TIniFileEx.Destroy;
begin
inherited Destroy;
// Destroy stream after destroying the base object, because it may use the stream in Destroy.
FreeAndNil(FIniFileStream);
end;
end.

415
doublecmd/dcconvertencoding.pas Normal file
View File

@@ -0,0 +1,415 @@
unit DCConvertEncoding;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
var
{en
Convert from OEM to System encoding, if needed
}
CeOemToSys: function (const Source: String): String;
CeSysToOem: function (const Source: String): String;
{en
Convert from OEM to UTF-8 encoding, if needed
}
CeOemToUtf8: function (const Source: String): String;
CeUtf8ToOem: function (const Source: String): String;
{en
Convert from Ansi to System encoding, if needed
}
CeAnsiToSys: function (const Source: String): String;
CeSysToAnsi: function (const Source: String): String;
{en
Convert from ANSI to UTF-8 encoding, if needed
}
CeAnsiToUtf8: function (const Source: String): String;
CeUtf8ToAnsi: function (const Source: String): String;
{en
Convert from Utf8 to System encoding, if needed
}
CeUtf8ToSys: function (const Source: String): String;
CeSysToUtf8: function (const Source: String): String;
function CeRawToUtf8(const Source: String): String;
{$IF DEFINED(MSWINDOWS)}
function CeTryEncode(const aValue: UnicodeString; aCodePage: Cardinal;
aAllowBestFit: Boolean; out aResult: AnsiString): Boolean;
function CeTryDecode(const aValue: AnsiString; aCodePage: Cardinal;
out aResult: UnicodeString): Boolean;
{$ELSEIF DEFINED(UNIX)}
var
SystemEncodingUtf8: Boolean = False;
SystemLanguage, SystemEncoding: String;
{$ENDIF}
implementation
uses
{$IF DEFINED(UNIX)}
iconvenc_dyn
{$IF DEFINED(DARWIN)}
, MacOSAll
{$ENDIF}
{$ELSEIF DEFINED(MSWINDOWS)}
Windows
{$ENDIF}
;
function UTF8CharacterStrictLength(P: PAnsiChar): integer;
begin
if p=nil then exit(0);
if ord(p^)<%10000000 then begin
// regular single byte character
exit(1);
end
else if ord(p^)<%11000000 then begin
// invalid single byte character
exit(0);
end
else if ((ord(p^) and %11100000) = %11000000) then begin
// should be 2 byte character
if (ord(p[1]) and %11000000) = %10000000 then
exit(2)
else
exit(0);
end
else if ((ord(p^) and %11110000) = %11100000) then begin
// should be 3 byte character
if ((ord(p[1]) and %11000000) = %10000000)
and ((ord(p[2]) and %11000000) = %10000000) then
exit(3)
else
exit(0);
end
else if ((ord(p^) and %11111000) = %11110000) then begin
// should be 4 byte character
if ((ord(p[1]) and %11000000) = %10000000)
and ((ord(p[2]) and %11000000) = %10000000)
and ((ord(p[3]) and %11000000) = %10000000) then
exit(4)
else
exit(0);
end else
exit(0);
end;
function CeRawToUtf8(const Source: String): String;
var
P: PAnsiChar;
I, L: LongInt;
begin
L:= Length(Source);
// Try UTF-8 (this includes ASCII)
P:= PAnsiChar(Source);
repeat
if Ord(P^) < 128 then begin
// ASCII
if (P^ = #0) and (P - PAnsiChar(Source) >= L) then begin
Result:= Source;
Exit;
end;
Inc(P);
end else begin
I:= UTF8CharacterStrictLength(P);
if I = 0 then Break;
Inc(P, I);
end;
until False;
Result:= CeSysToUtf8(Source);
end;
function Dummy(const Source: String): String;
begin
Result:= Source;
end;
function Sys2UTF8(const Source: String): String;
begin
Result:= UTF8Encode(Source);
end;
function UTF82Sys(const Source: String): String;
begin
Result:= UTF8Decode(Source);
end;
{$IF DEFINED(MSWINDOWS)}
function CeTryEncode(const aValue: UnicodeString; aCodePage: Cardinal;
aAllowBestFit: Boolean; out aResult: AnsiString): Boolean;
// Try to encode the given Unicode string as the requested codepage
const
WC_NO_BEST_FIT_CHARS = $00000400;
Flags: array[Boolean] of DWORD = (WC_NO_BEST_FIT_CHARS, 0);
var
UsedDefault: BOOL;
begin
if not aAllowBestFit and not CheckWin32Version(4, 1) then
Result := False
else begin
SetLength(aResult, WideCharToMultiByte(aCodePage, Flags[aAllowBestFit],
PWideChar(aValue), Length(aValue), nil, 0, nil, @UsedDefault));
SetLength(aResult, WideCharToMultiByte(aCodePage, Flags[aAllowBestFit],
PWideChar(aValue), Length(aValue), PAnsiChar(aResult),
Length(aResult), nil, @UsedDefault));
Result := not UsedDefault;
end;
end;
function CeTryDecode(const aValue: AnsiString; aCodePage: Cardinal;
out aResult: UnicodeString): Boolean;
begin
SetLength(aResult, MultiByteToWideChar(aCodePage, MB_ERR_INVALID_CHARS,
LPCSTR(aValue), Length(aValue), nil, 0) * SizeOf(UnicodeChar));
SetLength(aResult, MultiByteToWideChar(aCodePage, MB_ERR_INVALID_CHARS,
LPCSTR(aValue), Length(aValue), PWideChar(aResult), Length(aResult)));
Result := Length(aResult) > 0;
end;
function Oem2Utf8(const Source: String): String;
var
UnicodeResult: UnicodeString;
begin
if CeTryDecode(Source, CP_OEMCP, UnicodeResult) then
Result:= UTF8Encode(UnicodeResult)
else
Result:= Source;
end;
function Utf82Oem(const Source: String): String;
var
AnsiResult: AnsiString;
begin
if CeTryEncode(UTF8Decode(Source), CP_OEMCP, False, AnsiResult) then
Result:= AnsiResult
else
Result:= Source;
end;
function OEM2Ansi(const Source: String): String;
var
Dst: PAnsiChar;
begin
Result:= Source;
Dst:= AllocMem((Length(Result) + 1) * SizeOf(AnsiChar));
if OEMToChar(PAnsiChar(Result), Dst) then
Result:= StrPas(Dst);
FreeMem(Dst);
end;
function Ansi2OEM(const Source: String): String;
var
Dst: PAnsiChar;
begin
Result := Source;
Dst := AllocMem((Length(Result) + 1) * SizeOf(AnsiChar));
if CharToOEM(PAnsiChar(Result), Dst) then
Result := StrPas(Dst);
FreeMem(Dst);
end;
procedure Initialize;
begin
CeOemToSys:= @OEM2Ansi;
CeSysToOem:= @Ansi2OEM;
CeOemToUtf8:= @Oem2Utf8;
CeUtf8ToOem:= @Utf82Oem;
CeAnsiToSys:= @Dummy;
CeSysToAnsi:= @Dummy;
CeAnsiToUtf8:= @Sys2UTF8;
CeUtf8ToAnsi:= @UTF82Sys;
CeSysToUtf8:= @Sys2UTF8;
CeUtf8ToSys:= @UTF82Sys;
end;
{$ELSEIF DEFINED(UNIX)}
const
EncodingUTF8 = 'UTF-8'; // UTF-8 Encoding
var
EncodingOEM, // OEM Encoding
EncodingANSI: String; // ANSI Encoding
function GetSystemEncoding(out Language, Encoding: String): Boolean;
{$IF DEFINED(DARWIN)}
var
LanguageCFArray: CFArrayRef = nil;
LanguageCFRef: CFStringRef = nil;
begin
LanguageCFArray:= CFLocaleCopyPreferredLanguages;
try
Result:= CFArrayGetCount(LanguageCFArray) > 0;
if Result then
begin
LanguageCFRef:= CFArrayGetValueAtIndex(LanguageCFArray, 0);
SetLength(Language, MAX_PATH);
Result:= CFStringGetCString(LanguageCFRef,
PAnsiChar(Language),
MAX_PATH,
kCFStringEncodingUTF8
);
if Result then
begin
Encoding:= EncodingUTF8;
Language:= Copy(Language, 1, 2);
end;
end;
finally
CFRelease(LanguageCFArray);
end;
end;
{$ELSE}
var
I: Integer;
Lang: String;
begin
Result:= True;
Lang:= SysUtils.GetEnvironmentVariable('LC_ALL');
if Length(Lang) = 0 then
begin
Lang:= SysUtils.GetEnvironmentVariable('LC_MESSAGES');
if Length(Lang) = 0 then
begin
Lang:= SysUtils.GetEnvironmentVariable('LANG');
if Length(Lang) = 0 then
Exit(False);
end;
end;
Language:= Copy(Lang, 1, 2);
I:= System.Pos('.', Lang);
if (I > 0) then
Encoding:= Copy(Lang, I + 1, Length(Lang) - I);
if Length(Encoding) = 0 then
Encoding:= EncodingUTF8;
end;
{$ENDIF}
function Oem2Utf8(const Source: String): String;
begin
Result:= Source;
Iconvert(Source, Result, EncodingOEM, EncodingUTF8);
end;
function Utf82Oem(const Source: String): String;
begin
Result:= Source;
Iconvert(Source, Result, EncodingUTF8, EncodingOEM);
end;
function OEM2Sys(const Source: String): String;
begin
Result:= Source;
Iconvert(Source, Result, EncodingOEM, SystemEncoding);
end;
function Sys2OEM(const Source: String): String;
begin
Result:= Source;
Iconvert(Source, Result, SystemEncoding, EncodingOEM);
end;
function Ansi2Sys(const Source: String): String;
begin
Result:= Source;
Iconvert(Source, Result, EncodingANSI, SystemEncoding);
end;
function Sys2Ansi(const Source: String): String;
begin
Result:= Source;
Iconvert(Source, Result, SystemEncoding, EncodingANSI);
end;
function Ansi2Utf8(const Source: String): String;
begin
Result:= Source;
Iconvert(Source, Result, EncodingANSI, EncodingUTF8);
end;
function Utf82Ansi(const Source: String): String;
begin
Result:= Source;
Iconvert(Source, Result, EncodingUTF8, EncodingANSI);
end;
procedure Initialize;
var
Error: String;
begin
CeOemToSys:= @Dummy;
CeSysToOem:= @Dummy;
CeOemToUtf8:= @Dummy;
CeUtf8ToOem:= @Dummy;
CeAnsiToSys:= @Dummy;
CeSysToAnsi:= @Dummy;
CeUtf8ToSys:= @Dummy;
CeSysToUtf8:= @Dummy;
CeAnsiToUtf8:= @Dummy;
CeUtf8ToAnsi:= @Dummy;
// Try to get system encoding and initialize Iconv library
if not (GetSystemEncoding(SystemLanguage, SystemEncoding) and InitIconv(Error)) then
WriteLn(Error)
else
begin
SystemEncodingUtf8:= (SysUtils.CompareText(SystemEncoding, 'UTF-8') = 0) or
(SysUtils.CompareText(SystemEncoding, 'UTF8') = 0);
if (SystemLanguage = 'be') or (SystemLanguage = 'ru') or
(SystemLanguage = 'uk') then
begin
EncodingOEM:= 'CP866';
CeOemToSys:= @OEM2Sys;
CeSysToOem:= @Sys2OEM;
CeOemToUtf8:= @Oem2Utf8;
CeUtf8ToOem:= @Utf82Oem;
end;
if (SystemLanguage = 'be') or (SystemLanguage = 'bg') or
(SystemLanguage = 'ru') or (SystemLanguage = 'uk') then
begin
EncodingANSI:= 'CP1251';
CeAnsiToSys:= @Ansi2Sys;
CeSysToAnsi:= @Sys2Ansi;
CeAnsiToUtf8:= @Ansi2Utf8;
CeUtf8ToAnsi:= @Utf82Ansi;
end;
if not SystemEncodingUtf8 then
begin
CeUtf8ToSys:= @UTF82Sys;
CeSysToUtf8:= @Sys2UTF8;
end;
end;
end;
{$ELSE}
procedure Initialize;
begin
CeOemToSys:= @Dummy;
CeSysToOem:= @Dummy;
CeOemToUtf8:= @Dummy;
CeUtf8ToOem:= @Dummy;
CeAnsiToSys:= @Dummy;
CeSysToAnsi:= @Dummy;
CeUtf8ToSys:= @Dummy;
CeSysToUtf8:= @Dummy;
CeAnsiToUtf8:= @Dummy;
CeUtf8ToAnsi:= @Dummy;
end;
{$ENDIF}
initialization
Initialize;
end.

604
doublecmd/dcdatetimeutils.pas Normal file
View File

@@ -0,0 +1,604 @@
{
Double Commander
-------------------------------------------------------------------------
Date and time functions.
Copyright (C) 2009-2012 Przemysław Nagay (cobines@gmail.com)
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, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit DCDateTimeUtils;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, DCBasicTypes
{$IF DEFINED(MSWINDOWS)}
, Windows
{$ELSEIF DEFINED(UNIX)}
, unixutil
{$ENDIF}
;
function FileTimeToDateTime(FileTime : DCBasicTypes.TFileTime) : TDateTime;
function DateTimeToFileTime(DateTime : TDateTime) : DCBasicTypes.TFileTime;
{en
Converts system specific UTC time to local time.
}
function FileTimeToLocalFileTime(const FileTime: DCBasicTypes.TFileTime;
out LocalFileTime: DCBasicTypes.TFileTime): LongBool;
{en
Converts system specific local time to UTC time.
}
function LocalFileTimeToFileTime(const LocalFileTime: DCBasicTypes.TFileTime;
out FileTime: DCBasicTypes.TFileTime): LongBool;
{en
Converts Windows UTC file time to Windows local file time.
@param(lpFileTime TWinFileTime structure containing the UTC-based file time)
@param(lpLocalFileTime TWinFileTime structure to receive the converted local file time)
@returns(The function returns @true if successful, @false otherwise)
}
function WinFileTimeToLocalFileTime(const FileTime: TWinFileTime;
out LocalFileTime: TWinFileTime): LongBool;
{en
Converts Windows local file time to Windows UTC file time.
@param(lpLocalFileTime TWinFileTime structure that specifies the local file time)
@param(lpFileTime TWinFileTime structure to receive the converted UTC-based file time)
@returns(The function returns @true if successful, @false otherwise)
}
function WinLocalFileTimeToFileTime(const LocalFileTime: TWinFileTime;
out FileTime: TWinFileTime): LongBool;
{en
Converts Windows UTC file time to a file time in TDateTime format.
@param(ft TWinFileTime structure containing the UTC-based file time)
@returns(File time in TDateTime format)
}
function WinFileTimeToDateTime(ft : TWinFileTime) : TDateTime;
{en
Converts a file time in TDateTime format to Windows UTC file time.
@param(dt File time in TDateTime format)
@returns(Windows UTC-based file time)
}
function DateTimeToWinFileTime(dt : TDateTime) : TWinFileTime;
function DosFileTimeToDateTime(const DosTime: TDosFileTime): TDateTime;
function DateTimeToDosFileTime(const DateTime: TDateTime): TDosFileTime;
{$IFDEF MSWINDOWS}
function WinFileTimeToDateTime(ft : Windows.FILETIME) : TDateTime; inline; overload;
function WinToDosTime(const WinTime: Windows.FILETIME; var DosTime: TDosFileTime): LongBool; overload;
function DosToWinTime(const DosTime: TDosFileTime; var WinTime: Windows.FILETIME): LongBool; overload;
function WinToDosTime(const WinTime: TWinFileTime; var DosTime: TDosFileTime): LongBool;
function DosToWinTime(const DosTime: TDosFileTime; var WinTime: TWinFileTime): LongBool;
{$ENDIF}
function UnixFileTimeToDateTime(UnixTime: TUnixFileTime) : TDateTime;
function DateTimeToUnixFileTime(DateTime: TDateTime) : TUnixFileTime;
function UnixFileTimeToDosTime(UnixTime: TUnixFileTime): TDosFileTime;
function UnixFileTimeToWinTime(UnixTime: TUnixFileTime): TWinFileTime;
function GetTimeZoneBias: LongInt;
{en
Converts a month short name to month number.
@param(ShortMonthName Month short name)
@param(Default Default month number)
@returns(Month number)
}
function MonthToNumberDef(const ShortMonthName: String; Default: Word): Word;
{en
Converts a year short record to year long record if need (10 -> 2010).
@param(Year Year short record)
@returns(Year long record)
}
function YearShortToLong(Year: Word): Word;
function TwelveToTwentyFour(Hour: Word; Modifier: AnsiString): Word;
function FileTimeCompare(SourceTime, TargetTime: TDateTime; NtfsShift: Boolean): Integer;
type
EDateOutOfRange = class(EConvertError)
private
FDateTime: TDateTime;
public
constructor Create(ADateTime: TDateTime);
property DateTime: TDateTime read FDateTime;
end;
implementation
uses
DateUtils;
const { Short names of months. }
ShortMonthNames: TMonthNameArray = ('Jan','Feb','Mar','Apr','May','Jun',
'Jul','Aug','Sep','Oct','Nov','Dec');
SecsPerHour = SecsPerMin * MinsPerHour;
{$IF DEFINED(MSWINDOWS)}
var
WinTimeZoneBias: LongInt;
{$ENDIF}
function AdjustUnixFileTime(const FileTime: DCBasicTypes.TFileTime;
out AdjustedFileTime: DCBasicTypes.TFileTime;
AdjustValue: Int64): Boolean;
begin
if AdjustValue < 0 then
begin
if FileTime < DCBasicTypes.TFileTime(-AdjustValue) then
begin
AdjustedFileTime := 0;
Result := False;
end
else
begin
AdjustedFileTime := FileTime - DCBasicTypes.TFileTime(-AdjustValue);
Result := True;
end;
end
else
begin
if High(FileTime) - FileTime < DCBasicTypes.TFileTime(AdjustValue) then
begin
AdjustedFileTime := High(FileTime);
Result := False;
end
else
begin
AdjustedFileTime := FileTime + DCBasicTypes.TFileTime(AdjustValue);
Result := True;
end;
end;
end;
function AdjustWinFileTime(const FileTime: TWinFileTime;
out AdjustedFileTime: TWinFileTime;
AdjustValue: Int64): Boolean;
begin
if AdjustValue < 0 then
begin
if FileTime < DCBasicTypes.TWinFileTime(-AdjustValue) then
begin
AdjustedFileTime := 0;
Result := False;
end
else
begin
AdjustedFileTime := FileTime - DCBasicTypes.TWinFileTime(-AdjustValue);
Result := True;
end;
end
else
begin
if High(FileTime) - FileTime < DCBasicTypes.TWinFileTime(AdjustValue) then
begin
AdjustedFileTime := High(FileTime);
Result := False;
end
else
begin
AdjustedFileTime := FileTime + DCBasicTypes.TWinFileTime(AdjustValue);
Result := True;
end;
end;
end;
function FileTimeToDateTime(FileTime : DCBasicTypes.TFileTime) : TDateTime;
{$IF DEFINED(MSWINDOWS)}
begin
Result := WinFileTimeToDateTime(FileTime);
end;
{$ELSEIF DEFINED(UNIX)}
var
Hrs, Mins, Secs : Word;
TodaysSecs : DCBasicTypes.TFileTime;
begin
FileTimeToLocalFileTime(FileTime, FileTime);
TodaysSecs := FileTime mod SecsPerDay;
Hrs := Word(TodaysSecs div SecsPerHour);
TodaysSecs := TodaysSecs - (Hrs * SecsPerHour);
Mins := Word(TodaysSecs div SecsPerMin);
Secs := Word(TodaysSecs - (Mins * SecsPerMin));
Result := UnixEpoch + // Epoch start +
(FileTime div SecsPerDay) + // Number of days +
EncodeTime(Hrs, Mins, Secs, 0); // Time
end;
{$ELSE}
begin
Result := 0;
end;
{$ENDIF}
function DateTimeToFileTime(DateTime : TDateTime) : DCBasicTypes.TFileTime;
{$IF DEFINED(MSWINDOWS)}
begin
Result := DateTimeToWinFileTime(DateTime);
end;
{$ELSEIF DEFINED(UNIX)}
var
Hrs, Mins, Secs, MSecs : Word;
Dt, Tm : TDateTime;
BigTime: QWord;
begin
Dt := Trunc(DateTime);
Tm := DateTime - Dt;
if Dt < UnixEpoch then
raise EDateOutOfRange.Create(DateTime)
else
{$PUSH}{$Q-}
BigTime := Trunc(Dt - UnixEpoch) * SecsPerDay;
{$POP}
DecodeTime(Tm, Hrs, Mins, Secs, MSecs);
{$PUSH}{$Q-}
BigTime := BigTime + QWord(Hrs * SecsPerHour) + QWord(Mins * SecsPerMin) + Secs;
{$POP}
{$IFDEF cpu32}
if BigTime > High(DCBasicTypes.TFileTime) then
raise EDateOutOfRange.Create(DateTime)
else
{$ENDIF}
LocalFileTimeToFileTime(BigTime, Result);
end;
{$ELSE}
begin
Result := 0;
end;
{$ENDIF}
function FileTimeToLocalFileTime(const FileTime: DCBasicTypes.TFileTime;
out LocalFileTime: DCBasicTypes.TFileTime): LongBool;
{$IFDEF MSWINDOWS}
begin
Result := Windows.FileTimeToLocalFileTime(@Windows.FILETIME(FileTime), @Windows.FILETIME(LocalFileTime));
end;
{$ELSE}
begin
Result := AdjustUnixFileTime(FileTime, LocalFileTime, Tzseconds);
end;
{$ENDIF}
function LocalFileTimeToFileTime(const LocalFileTime: DCBasicTypes.TFileTime;
out FileTime: DCBasicTypes.TFileTime): LongBool;
{$IFDEF MSWINDOWS}
begin
Result := Windows.LocalFileTimeToFileTime(@Windows.FILETIME(LocalFileTime), @Windows.FILETIME(FileTime));
end;
{$ELSE}
begin
Result := AdjustUnixFileTime(LocalFileTime, FileTime, -Tzseconds);
end;
{$ENDIF}
function WinFileTimeToLocalFileTime(const FileTime: TWinFileTime;
out LocalFileTime: TWinFileTime): LongBool;
{$IFDEF MSWINDOWS}
begin
Result := Windows.FileTimeToLocalFileTime(@Windows.FILETIME(FileTime), @Windows.FILETIME(LocalFileTime));
end;
{$ELSE}
begin
Result := AdjustWinFileTime(FileTime, LocalFileTime, 10000000 * Int64(TZSeconds));
end;
{$ENDIF}
function WinLocalFileTimeToFileTime(const LocalFileTime: TWinFileTime;
out FileTime: TWinFileTime): LongBool;
{$IFDEF MSWINDOWS}
begin
Result := Windows.LocalFileTimeToFileTime(@Windows.FILETIME(LocalFileTime), @Windows.FILETIME(FileTime));
end;
{$ELSE}
begin
Result := AdjustWinFileTime(LocalFileTime, FileTime, -10000000 * Int64(TZSeconds));
end;
{$ENDIF}
function WinFileTimeToDateTime(ft : TWinFileTime) : TDateTime;
begin
WinFileTimeToLocalFileTime(ft,ft);
Result := (ft / 864000000000.0) - 109205.0;
end;
function DateTimeToWinFileTime(dt : TDateTime) : TWinFileTime;
begin
Result := Round((dt + 109205.0) * 864000000000.0);
WinLocalFileTimeToFileTime(Result, Result);
end;
function DosFileTimeToDateTime(const DosTime: TDosFileTime): TDateTime;
var
Yr, Mo, Dy : Word;
Hr, Mn, S : Word;
FileDate, FileTime : Word;
begin
FileDate := LongRec(DosTime).Hi;
FileTime := LongRec(DosTime).Lo;
Yr := FileDate shr 9 + 1980;
Mo := FileDate shr 5 and 15;
if Mo < 1 then Mo := 1;
if Mo > 12 then Mo := 12;
Dy := FileDate and 31;
if Dy < 1 then Dy := 1;
if Dy > DaysInAMonth(Yr, Mo) then
Dy := DaysInAMonth(Yr, Mo);
Hr := FileTime shr 11;
if Hr > 23 then Hr := 23;
Mn := FileTime shr 5 and 63;
if Mn > 59 then Mn := 59;
S := FileTime and 31 shl 1;
if S > 59 then S := 59;
Result := ComposeDateTime(EncodeDate(Yr, Mo, Dy),
EncodeTime(Hr, Mn, S, 0));
end;
function DateTimeToDosFileTime(const DateTime: TDateTime): TDosFileTime;
var
Yr, Mo, Dy : Word;
Hr, Mn, S, MS: Word;
begin
DecodeDate(DateTime, Yr, Mo, Dy);
if (Yr < 1980) or (Yr > 2107) then // outside DOS file date year range
Yr := 1980;
DecodeTime(DateTime, Hr, Mn, S, MS);
LongRec(Result).Lo := (S shr 1) or (Mn shl 5) or (Hr shl 11);
LongRec(Result).Hi := Dy or (Mo shl 5) or (Word(Yr - 1980) shl 9);
end;
{$IFDEF MSWINDOWS}
function WinFileTimeToDateTime(ft : Windows.FILETIME) : TDateTime;
begin
Result := WinFileTimeToDateTime(TWinFileTime(ft));
end;
function WinToDosTime(const WinTime: Windows.FILETIME; var DosTime: TDosFileTime): LongBool;
var
lft : Windows.TFILETIME;
begin
Result:= Windows.FileTimeToLocalFileTime(@Windows.FILETIME(WinTime), @lft) and
Windows.FileTimeToDosDateTime(@lft, @LongRec(Dostime).Hi, @LongRec(DosTime).Lo);
end;
function DosToWinTime(const DosTime: TDosFileTime; var WinTime: Windows.FILETIME): LongBool;
var
lft : Windows.TFILETIME;
begin
Result := Windows.DosDateTimeToFileTime(LongRec(DosTime).Hi, LongRec(DosTime).Lo, @lft) and
Windows.LocalFileTimeToFileTime(@lft, @Windows.FILETIME(WinTime));
end;
function WinToDosTime(const WinTime: TWinFileTime; var DosTime: TDosFileTime): LongBool;
var
lft : Windows.TFILETIME;
begin
Result:= Windows.FileTimeToLocalFileTime(@Windows.FILETIME(WinTime), @lft) and
Windows.FileTimeToDosDateTime(@lft, @LongRec(Dostime).Hi, @LongRec(DosTime).Lo);
end;
function DosToWinTime(const DosTime: TDosFileTime; var WinTime: TWinFileTime): LongBool;
var
lft : Windows.TFILETIME;
begin
Result := Windows.DosDateTimeToFileTime(LongRec(DosTime).Hi, LongRec(DosTime).Lo, @lft) and
Windows.LocalFileTimeToFileTime(@lft, @Windows.FILETIME(WinTime));
end;
{$ENDIF}
function UnixFileTimeToDateTime(UnixTime: TUnixFileTime) : TDateTime;
var
Hrs, Mins, Secs : Word;
TodaysSecs : LongInt;
{$IFDEF MSWINDOWS}
LocalWinFileTime, WinFileTime: TWinFileTime;
{$ENDIF}
{$IFDEF UNIX}
LocalUnixTime: TUnixFileTime;
{$ENDIF}
begin
{$IFDEF UNIX}
if FileTimeToLocalFileTime(UnixTime, LocalUnixTime) then
UnixTime := LocalUnixTime;
{$ENDIF}
TodaysSecs := UnixTime mod SecsPerDay;
Hrs := TodaysSecs div SecsPerHour;
TodaysSecs := TodaysSecs - (Hrs * SecsPerHour);
Mins := TodaysSecs div SecsPerMin;
Secs := TodaysSecs - (Mins * SecsPerMin);
Result := UnixDateDelta + (UnixTime div SecsPerDay) +
EncodeTime(Hrs, Mins, Secs, 0);
{$IFDEF MSWINDOWS}
// Convert universal to local TDateTime.
WinFileTime := DateTimeToWinFileTime(Result);
if FileTimeToLocalFileTime(WinFileTime, LocalWinFileTime) then
WinFileTime := LocalWinFileTime;
Result := WinFileTimeToDateTime(WinFileTime);
{$ENDIF}
end;
function DateTimeToUnixFileTime(DateTime : TDateTime): TUnixFileTime;
var
Hrs, Mins, Secs, MSecs : Word;
Dt, Tm : TDateTime;
{$IFDEF MSWINDOWS}
LocalWinFileTime, WinFileTime: TWinFileTime;
{$ENDIF}
{$IFDEF UNIX}
UnixTime: TUnixFileTime;
{$ENDIF}
begin
{$IFDEF MSWINDOWS}
// Convert local to universal TDateTime.
LocalWinFileTime := DateTimeToWinFileTime(DateTime);
if LocalFileTimeToFileTime(LocalWinFileTime, WinFileTime) then
LocalWinFileTime := WinFileTime;
DateTime := WinFileTimeToDateTime(LocalWinFileTime);
{$ENDIF}
Dt := Trunc(DateTime);
Tm := DateTime - Dt;
if Dt < UnixDateDelta then
Result := 0
else
Result := Trunc(Dt - UnixDateDelta) * SecsPerDay;
DecodeTime(Tm, Hrs, Mins, Secs, MSecs);
Result := Result + (Hrs * SecsPerHour) + (Mins * SecsPerMin) + Secs;
{$IFDEF UNIX}
if LocalFileTimeToFileTime(Result, UnixTime) then
Result := UnixTime;
{$ENDIF}
end;
function UnixFileTimeToDosTime(UnixTime: TUnixFileTime): TDosFileTime;
begin
Result := DateTimeToDosFileTime(UnixFileTimeToDateTime(UnixTime));
end;
function UnixFileTimeToWinTime(UnixTime: TUnixFileTime): TWinFileTime;
var
WinFileTime: TWinFileTime;
begin
WinFileTime := $019DB1DED53E8000; // Unix epoch start
if not AdjustWinFileTime(WinFileTime, Result, 10000000 * Int64(UnixTime)) then
Result := WinFileTime;
end;
function GetTimeZoneBias: LongInt;
begin
{$IF DEFINED(MSWINDOWS)}
Result := WinTimeZoneBias;
{$ELSEIF DEFINED(UNIX)}
Result := -Tzseconds div 60;
{$ELSE}
Result := 0;
{$ENDIF}
end;
function MonthToNumberDef(const ShortMonthName: String; Default: Word): Word;
var
I: Word;
begin
Result:= Default;
if ShortMonthName = EmptyStr then Exit;
for I:= 1 to 12 do
if SameText(ShortMonthName, ShortMonthNames[I]) then
Exit(I);
end;
function YearShortToLong(Year: Word): Word;
begin
Result:= Year;
if (Year < 100) then
begin
if (Year < 80) then
Result:= Year + 2000
else
Result:= Year + 1900;
end;
end;
function TwelveToTwentyFour(Hour: Word; Modifier: AnsiString): Word;
begin
if Modifier = EmptyStr then Exit(Hour);
case LowerCase(Modifier[1]) of
'a':
begin
if (Hour = 12) then
Result:= 0;
end;
'p':
begin
if (Hour < 12) then
Result:= Hour + 12;
end;
end;
end;
function FileTimeCompare(SourceTime, TargetTime: TDateTime; NtfsShift: Boolean): Integer;
const
TimeDiff = 3100 / MSecsPerDay;
NtfsDiff = MinsPerHour * SecsPerMin;
var
FileTimeDiff,
NtfsTimeDiff: TDateTime;
begin
FileTimeDiff:= SourceTime - TargetTime;
if NtfsShift then
begin
NtfsTimeDiff:= FileTimeDiff - NtfsDiff;
if (NtfsTimeDiff > -TimeDiff) and (NtfsTimeDiff < TimeDiff) then
Exit(0);
NtfsTimeDiff:= FileTimeDiff + NtfsDiff;
if (NtfsTimeDiff > -TimeDiff) and (NtfsTimeDiff < TimeDiff) then
Exit(0);
end;
if (FileTimeDiff > -TimeDiff) and (FileTimeDiff < TimeDiff) then
Result:= 0
else if FileTimeDiff > 0 then
Result:= +1
else if FileTimeDiff < 0 then
Result:= -1;
end;
{ EDateOutOfRange }
constructor EDateOutOfRange.Create(ADateTime: TDateTime);
begin
inherited Create(EmptyStr);
FDateTime := ADateTime;
end;
{$IF DEFINED(MSWINDOWS)}
procedure InitTimeZoneBias;
var
TZInfo: TTimeZoneInformation;
begin
case GetTimeZoneInformation(@TZInfo) of
TIME_ZONE_ID_UNKNOWN:
WinTimeZoneBias := TZInfo.Bias;
TIME_ZONE_ID_STANDARD:
WinTimeZoneBias := TZInfo.Bias + TZInfo.StandardBias;
TIME_ZONE_ID_DAYLIGHT:
WinTimeZoneBias := TZInfo.Bias + TZInfo.DaylightBias;
else
WinTimeZoneBias := 0;
end;
end;
initialization
InitTimeZoneBias;
{$ENDIF}
end.

327
doublecmd/dcfileattributes.pas Normal file
View File

@@ -0,0 +1,327 @@
{
Double Commander
-------------------------------------------------------------------------
Functions handling file attributes.
Copyright (C) 2012 Przemysław Nagay (cobines@gmail.com)
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, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit DCFileAttributes;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, DCBasicTypes;
const
// Windows attributes
FILE_ATTRIBUTE_READONLY = $0001;
FILE_ATTRIBUTE_HIDDEN = $0002;
FILE_ATTRIBUTE_SYSTEM = $0004;
FILE_ATTRIBUTE_DIRECTORY = $0010;
FILE_ATTRIBUTE_ARCHIVE = $0020;
FILE_ATTRIBUTE_NORMAL = $0080;
FILE_ATTRIBUTE_TEMPORARY = $0100;
FILE_ATTRIBUTE_SPARSE_FILE = $0200;
FILE_ATTRIBUTE_REPARSE_POINT = $0400;
FILE_ATTRIBUTE_COMPRESSED = $0800;
FILE_ATTRIBUTE_OFFLINE = $1000;
FILE_ATTRIBUTE_NOT_CONTENT_INDEXED = $2000;
FILE_ATTRIBUTE_ENCRYPTED = $4000;
FILE_ATTRIBUTE_VIRTUAL = $20000;
// Unix attributes
{ attributes mask }
S_IFMT = $F000;
{ first-in/first-out (FIFO/pipe) }
S_IFIFO = $1000;
{ character-special file (tty/console) }
S_IFCHR = $2000;
{ directory }
S_IFDIR = $4000;
{ blocking device (unused) }
S_IFBLK = $6000;
{ regular }
S_IFREG = $8000;
{ symbolic link (unused) }
S_IFLNK = $A000;
{ Berkeley socket }
S_IFSOCK = $C000;
{ mode_t possible values }
S_IRUSR = %0100000000; { Read permission for owner }
S_IWUSR = %0010000000; { Write permission for owner }
S_IXUSR = %0001000000; { Exec permission for owner }
S_IRGRP = %0000100000; { Read permission for group }
S_IWGRP = %0000010000; { Write permission for group }
S_IXGRP = %0000001000; { Exec permission for group }
S_IROTH = %0000000100; { Read permission for world }
S_IWOTH = %0000000010; { Write permission for world }
S_IXOTH = %0000000001; { Exec permission for world }
S_IRWXU = S_IRUSR or S_IWUSR or S_IXUSR;
S_IRWXG = S_IRGRP or S_IWGRP or S_IXGRP;
S_IRWXO = S_IROTH or S_IWOTH or S_IXOTH;
{ POSIX setuid(), setgid(), and sticky bit }
S_ISUID = $0800;
S_ISGID = $0400;
S_ISVTX = $0200;
function WinToUnixFileAttr(Attr: TFileAttrs): TFileAttrs;
function UnixToWinFileAttr(Attr: TFileAttrs): TFileAttrs;
function UnixToWinFileAttr(const FileName: String; Attr: TFileAttrs): TFileAttrs;
function SingleStrToFileAttr(sAttr: String): TFileAttrs;
function WinSingleStrToFileAttr(sAttr: String): TFileAttrs;
function UnixSingleStrToFileAttr(sAttr: String): TFileAttrs;
{en
Convert file attributes from string to number
@param(Attributes File attributes as string)
@returns(File attributes as number)
}
function StrToFileAttr(sAttr: String): TFileAttrs;
{en
Convert file attributes to string in the format of "attr1+attr2+attr3+".
@param(Attributes File attributes)
@returns(File attributes as string)
}
function FileAttrToStr(Attr: TFileAttrs): String;
{en
Convert Windows file attributes from string to number
@param(Attributes File attributes as string)
@returns(File attributes as number)
}
function WinStrToFileAttr(sAttr: String): TFileAttrs;
{en
Convert Unix file attributes from string to number
@param(Attributes File attributes as string)
@returns(File attributes as number)
}
function UnixStrToFileAttr(sAttr: String): TFileAttrs;
implementation
uses
DCStrUtils;
type
TAttrStrToFileAttr = record
Str: String;
Attr: TFileAttrs;
end;
const
WinAttrStrToFileAttr: array[0..9] of TAttrStrToFileAttr = (
(Str: 'r'; Attr: FILE_ATTRIBUTE_READONLY),
(Str: 'h'; Attr: FILE_ATTRIBUTE_HIDDEN),
(Str: 's'; Attr: FILE_ATTRIBUTE_SYSTEM),
(Str: 'd'; Attr: FILE_ATTRIBUTE_DIRECTORY),
(Str: 'a'; Attr: FILE_ATTRIBUTE_ARCHIVE),
(Str: 't'; Attr: FILE_ATTRIBUTE_TEMPORARY),
(Str: 'p'; Attr: FILE_ATTRIBUTE_SPARSE_FILE),
(Str: 'l'; Attr: FILE_ATTRIBUTE_REPARSE_POINT),
(Str: 'c'; Attr: FILE_ATTRIBUTE_COMPRESSED),
(Str: 'e'; Attr: FILE_ATTRIBUTE_ENCRYPTED));
UnixAttrStrToFileAttr: array[0..18] of TAttrStrToFileAttr = (
// Permissions
(Str: 'ur'; Attr: S_IRUSR),
(Str: 'uw'; Attr: S_IWUSR),
(Str: 'ux'; Attr: S_IXUSR),
(Str: 'gr'; Attr: S_IRGRP),
(Str: 'gw'; Attr: S_IWGRP),
(Str: 'gx'; Attr: S_IXGRP),
(Str: 'or'; Attr: S_IROTH),
(Str: 'ow'; Attr: S_IWOTH),
(Str: 'ox'; Attr: S_IXOTH),
(Str: 'us'; Attr: S_ISUID),
(Str: 'gs'; Attr: S_ISGID),
(Str: 'sb'; Attr: S_ISVTX),
// File types
(Str: 'f'; Attr: S_IFIFO),
(Str: 'c'; Attr: S_IFCHR),
(Str: 'd'; Attr: S_IFDIR),
(Str: 'b'; Attr: S_IFBLK),
(Str: 'r'; Attr: S_IFREG),
(Str: 'l'; Attr: S_IFLNK),
(Str: 's'; Attr: S_IFSOCK));
function WinToUnixFileAttr(Attr: TFileAttrs): TFileAttrs;
begin
Result := S_IRUSR or S_IRGRP or S_IROTH;
if (Attr and faReadOnly) = 0 then
Result := Result or S_IWUSR;
if (Attr and faDirectory) <> 0 then
Result := Result or S_IFDIR
else
Result := Result or S_IFREG;
end;
function UnixToWinFileAttr(Attr: TFileAttrs): TFileAttrs;
begin
Result := 0;
case (Attr and S_IFMT) of
0, S_IFREG:
Result := faArchive;
S_IFLNK:
Result := Result or faSymLink;
S_IFDIR:
Result := Result or faDirectory;
S_IFIFO, S_IFCHR, S_IFBLK, S_IFSOCK:
Result := Result or faSysFile;
end;
if (Attr and S_IWUSR) = 0 then
Result := Result or faReadOnly;
end;
function UnixToWinFileAttr(const FileName: String; Attr: TFileAttrs): TFileAttrs;
begin
Result := UnixToWinFileAttr(Attr);
if (Length(FileName) > 1) and (FileName[1] = '.') and (FileName[2] <> '.') then
Result := Result or faHidden;
end;
function SingleStrToFileAttr(sAttr: String): TFileAttrs;
begin
{$IF DEFINED(MSWINDOWS)}
Result := WinSingleStrToFileAttr(sAttr);
{$ELSEIF DEFINED(UNIX)}
Result := UnixSingleStrToFileAttr(sAttr);
{$ENDIF}
end;
function WinSingleStrToFileAttr(sAttr: String): TFileAttrs;
var
i: Integer;
begin
for i := Low(WinAttrStrToFileAttr) to High(WinAttrStrToFileAttr) do
begin
if sAttr = WinAttrStrToFileAttr[i].Str then
Exit(WinAttrStrToFileAttr[i].Attr);
end;
Result := 0;
end;
function UnixSingleStrToFileAttr(sAttr: String): TFileAttrs;
var
i: Integer;
begin
if Length(sAttr) > 0 then
begin
if sAttr[1] in ['0'..'7'] then
begin
// Octal representation.
Exit(TFileAttrs(OctToDec(sAttr)));
end
else
begin
for i := Low(UnixAttrStrToFileAttr) to High(UnixAttrStrToFileAttr) do
begin
if sAttr = UnixAttrStrToFileAttr[i].Str then
Exit(UnixAttrStrToFileAttr[i].Attr);
end;
end;
end;
Result := 0;
end;
function StrToFileAttr(sAttr: String): TFileAttrs; inline;
begin
{$IF DEFINED(MSWINDOWS)}
Result := WinStrToFileAttr(sAttr);
{$ELSEIF DEFINED(UNIX)}
Result := UnixStrToFileAttr(sAttr);
{$ENDIF}
end;
function FileAttrToStr(Attr: TFileAttrs): String;
var
i: Integer;
begin
Result := '';
{$IF DEFINED(MSWINDOWS)}
for i := Low(WinAttrStrToFileAttr) to High(WinAttrStrToFileAttr) do
begin
if Attr and WinAttrStrToFileAttr[i].Attr <> 0 then
Result := Result + WinAttrStrToFileAttr[i].Str + '+';
end;
{$ELSEIF DEFINED(UNIX)}
for i := Low(UnixAttrStrToFileAttr) to High(UnixAttrStrToFileAttr) do
begin
if Attr and UnixAttrStrToFileAttr[i].Attr <> 0 then
Result := Result + UnixAttrStrToFileAttr[i].Str + '+';
end;
{$ENDIF}
end;
function WinStrToFileAttr(sAttr: String): TFileAttrs;
var
I: LongInt;
begin
Result:= 0;
sAttr:= LowerCase(sAttr);
for I:= 1 to Length(sAttr) do
case sAttr[I] of
'd': Result := Result or FILE_ATTRIBUTE_DIRECTORY;
'l': Result := Result or FILE_ATTRIBUTE_REPARSE_POINT;
'r': Result := Result or FILE_ATTRIBUTE_READONLY;
'a': Result := Result or FILE_ATTRIBUTE_ARCHIVE;
'h': Result := Result or FILE_ATTRIBUTE_HIDDEN;
's': Result := Result or FILE_ATTRIBUTE_SYSTEM;
end;
end;
function UnixStrToFileAttr(sAttr: String): TFileAttrs;
begin
Result:= 0;
if Length(sAttr) < 10 then Exit;
sAttr:= LowerCase(sAttr);
if sAttr[1]='d' then Result:= Result or S_IFDIR;
if sAttr[1]='l' then Result:= Result or S_IFLNK;
if sAttr[1]='s' then Result:= Result or S_IFSOCK;
if sAttr[1]='f' then Result:= Result or S_IFIFO;
if sAttr[1]='b' then Result:= Result or S_IFBLK;
if sAttr[1]='c' then Result:= Result or S_IFCHR;
if sAttr[2]='r' then Result:= Result or S_IRUSR;
if sAttr[3]='w' then Result:= Result or S_IWUSR;
if sAttr[4]='x' then Result:= Result or S_IXUSR;
if sAttr[5]='r' then Result:= Result or S_IRGRP;
if sAttr[6]='w' then Result:= Result or S_IWGRP;
if sAttr[7]='x' then Result:= Result or S_IXGRP;
if sAttr[8]='r' then Result:= Result or S_IROTH;
if sAttr[9]='w' then Result:= Result or S_IWOTH;
if sAttr[10]='x' then Result:= Result or S_IXOTH;
if sAttr[4]='s' then Result:= Result or S_ISUID;
if sAttr[7]='s' then Result:= Result or S_ISGID;
end;
end.

1292
doublecmd/dcosutils.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1061
doublecmd/dcstrutils.pas Normal file
View File

File diff suppressed because it is too large Load Diff

757
doublecmd/dcxmlconfig.pas Normal file
View File

@@ -0,0 +1,757 @@
{
Double Commander
-------------------------------------------------------------------------
Implementation of configuration file in XML.
Based on XmlConf from fcl-xml package.
Copyright (C) 2010 Przemyslaw Nagay (cobines@gmail.com)
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, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit DCXmlConfig;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, DOM, XMLRead, XMLWrite;
type
// Define type aliases so we don't have to include DOM if we want to use config.
TXmlNode = TDOMNode;
TXmlPath = DOMString;
{ TXmlConfig }
TXmlConfig = class
private
FFileName: UTF8String;
FDoc: TXMLDocument;
function GetRootNode: TXmlNode;
procedure SplitPathToNodeAndAttr(const Path: DOMString; out NodePath: DOMString; out AttrName: DOMString);
public
constructor Create; virtual;
constructor Create(const AFileName: UTF8String; AutoLoad: Boolean = False); virtual;
destructor Destroy; override;
procedure Clear;
function AddNode(const RootNode: TDOMNode; const ValueName: DOMString): TDOMNode;
procedure DeleteNode(const RootNode: TDOMNode; const Path: DOMString);
procedure DeleteNode(const Node: TDOMNode);
procedure ClearNode(const Node: TDOMNode);
function FindNode(const RootNode: TDOMNode; const Path: DOMString; bCreate: Boolean = False): TDOMNode;
function GetContent(const Node: TDOMNode): UTF8String;
function IsEmpty: Boolean;
procedure SetContent(const Node: TDOMNode; const AValue: UTF8String);
// ------------------------------------------------------------------------
function GetAttr(const RootNode: TDOMNode; const Path: DOMString; const ADefault: UTF8String): UTF8String;
function GetAttr(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Boolean): Boolean;
function GetAttr(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Integer): Integer;
function GetAttr(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Int64): Int64;
function GetAttr(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Double): Double;
function GetValue(const RootNode: TDOMNode; const Path: DOMString; const ADefault: UTF8String): UTF8String;
function GetValue(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Boolean): Boolean;
function GetValue(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Integer): Integer;
function GetValue(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Int64): Int64;
function GetValue(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Double): Double;
// The Try... functions return True if the attribute/node was found and only then set AValue.
function TryGetAttr(const RootNode: TDOMNode; const Path: DOMString; out AValue: UTF8String): Boolean;
function TryGetAttr(const RootNode: TDOMNode; const Path: DOMString; out AValue: Boolean): Boolean;
function TryGetAttr(const RootNode: TDOMNode; const Path: DOMString; out AValue: Integer): Boolean;
function TryGetAttr(const RootNode: TDOMNode; const Path: DOMString; out AValue: Int64): Boolean;
function TryGetAttr(const RootNode: TDOMNode; const Path: DOMString; out AValue: Double): Boolean;
function TryGetValue(const RootNode: TDOMNode; const Path: DOMString; out AValue: UTF8String): Boolean;
function TryGetValue(const RootNode: TDOMNode; const Path: DOMString; out AValue: Boolean): Boolean;
function TryGetValue(const RootNode: TDOMNode; const Path: DOMString; out AValue: Integer): Boolean;
function TryGetValue(const RootNode: TDOMNode; const Path: DOMString; out AValue: Int64): Boolean;
function TryGetValue(const RootNode: TDOMNode; const Path: DOMString; out AValue: Double): Boolean;
// ------------------------------------------------------------------------
// AddValue functions always add a new node.
procedure AddValue(const RootNode: TDOMNode; const ValueName: DOMString; const AValue: String);
procedure AddValue(const RootNode: TDOMNode; const ValueName: DOMString; const AValue: Boolean);
procedure AddValue(const RootNode: TDOMNode; const ValueName: DOMString; const AValue: Integer);
procedure AddValue(const RootNode: TDOMNode; const ValueName: DOMString; const AValue: Int64);
procedure AddValue(const RootNode: TDOMNode; const ValueName: DOMString; const AValue: Double);
procedure AddValueDef(const RootNode: TDOMNode; const ValueName: DOMString; const AValue, DefaultValue: String);
procedure AddValueDef(const RootNode: TDOMNode; const ValueName: DOMString; const AValue, DefaultValue: Boolean);
procedure AddValueDef(const RootNode: TDOMNode; const ValueName: DOMString; const AValue, DefaultValue: Integer);
procedure AddValueDef(const RootNode: TDOMNode; const ValueName: DOMString; const AValue, DefaultValue: Int64);
procedure AddValueDef(const RootNode: TDOMNode; const ValueName: DOMString; const AValue, DefaultValue: Double);
// SetValue functions can only set values for unique paths.
procedure SetAttr(const RootNode: TDOMNode; const Path: DOMString; const AValue: UTF8String);
procedure SetAttr(const RootNode: TDOMNode; const Path: DOMString; const AValue: Boolean);
procedure SetAttr(const RootNode: TDOMNode; const Path: DOMString; const AValue: Integer);
procedure SetAttr(const RootNode: TDOMNode; const Path: DOMString; const AValue: Int64);
procedure SetAttr(const RootNode: TDOMNode; const Path: DOMString; const AValue: Double);
procedure SetValue(const RootNode: TDOMNode; const Path: DOMString; const AValue: String);
procedure SetValue(const RootNode: TDOMNode; const Path: DOMString; const AValue: Boolean);
procedure SetValue(const RootNode: TDOMNode; const Path: DOMString; const AValue: Integer);
procedure SetValue(const RootNode: TDOMNode; const Path: DOMString; const AValue: Int64);
procedure SetValue(const RootNode: TDOMNode; const Path: DOMString; const AValue: Double);
// ------------------------------------------------------------------------
procedure GetFont(const aNode: TXmlNode; Path: TXmlPath;
out Name: UTF8String; out Size: Integer; out Style: Integer;
const DefName: UTF8String; const DefSize: Integer; const DefStyle: Integer);
procedure SetFont(const aNode: TXmlNode; Path: TXmlPath;
const Name: UTF8String; const Size: Integer; const Style: Integer);
// ------------------------------------------------------------------------
procedure ReadFromFile(const AFilename: UTF8String);
procedure ReadFromStream(AStream: TStream);
procedure WriteToFile(const AFilename: UTF8String);
procedure WriteToStream(AStream: TStream);
function Load: Boolean;
function LoadBypassingErrors: Boolean;
function Save: Boolean;
{en
Get path of form "<RootNodeName>/<Child1NodeName>/<Child2NodeName>...".
}
function GetPathFromNode(aNode: TDOMNode): String;
property FileName: UTF8String read FFileName write FFileName;
property RootNode: TXmlNode read GetRootNode;
end;
EXmlConfigEmpty = class(EFilerError);
EXmlConfigNotFound = class(EFilerError);
implementation
uses
LazUTF8, LazLogger, DCOSUtils, DCClassesUtf8, URIParser;
const
BoolStrings: array[Boolean] of DOMString = ('False', 'True');
constructor TXmlConfig.Create;
begin
Clear;
end;
constructor TXmlConfig.Create(const AFileName: UTF8String; AutoLoad: Boolean);
begin
FFileName := AFileName;
if not (AutoLoad and LoadBypassingErrors) then
Clear;
end;
destructor TXmlConfig.Destroy;
begin
FreeAndNil(FDoc);
inherited Destroy;
end;
procedure TXmlConfig.Clear;
begin
FreeAndNil(FDoc);
FDoc := TXMLDocument.Create;
FDoc.AppendChild(FDoc.CreateElement(ApplicationName));
end;
function TXmlConfig.GetRootNode: TXmlNode;
begin
Result := FDoc.DocumentElement;
end;
// ------------------------------------------------------------------------
function TXmlConfig.GetAttr(const RootNode: TDOMNode; const Path: DOMString; const ADefault: UTF8String): UTF8String;
begin
if not TryGetAttr(RootNode, Path, Result) then
Result := ADefault;
end;
function TXmlConfig.GetAttr(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Boolean): Boolean;
begin
if not TryGetAttr(RootNode, Path, Result) then
Result := ADefault;
end;
function TXmlConfig.GetAttr(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Integer): Integer;
begin
if not TryGetAttr(RootNode, Path, Result) then
Result := ADefault;
end;
function TXmlConfig.GetAttr(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Int64): Int64;
begin
if not TryGetAttr(RootNode, Path, Result) then
Result := ADefault;
end;
function TXmlConfig.GetAttr(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Double): Double;
begin
if not TryGetAttr(RootNode, Path, Result) then
Result := ADefault;
end;
function TXmlConfig.TryGetAttr(const RootNode: TDOMNode; const Path: DOMString; out AValue: UTF8String): Boolean;
var
Node: TDOMNode;
Attr: TDOMAttr;
NodePath, AttrName: DOMString;
begin
SplitPathToNodeAndAttr(Path, NodePath, AttrName);
if NodePath <> EmptyWideStr then
begin
Node := FindNode(RootNode, NodePath, False);
if not Assigned(Node) then
Exit(False);
end
else
Node := RootNode;
Attr := TDOMElement(Node).GetAttributeNode(AttrName);
Result := Assigned(Attr);
if Result then
AValue := UTF16ToUTF8(Attr.Value);
end;
function TXmlConfig.TryGetAttr(const RootNode: TDOMNode; const Path: DOMString; out AValue: Boolean): Boolean;
var
sValue: UTF8String;
begin
Result := TryGetAttr(RootNode, Path, sValue);
if Result then
begin
if SameText(sValue, 'TRUE') then
AValue := True
else if SameText(sValue, 'FALSE') then
AValue := False
else
Result := False; // If other text then return not found.
end;
end;
function TXmlConfig.TryGetAttr(const RootNode: TDOMNode; const Path: DOMString; out AValue: Integer): Boolean;
var
sValue: UTF8String;
begin
Result := TryGetAttr(RootNode, Path, sValue) and TryStrToInt(sValue, AValue);
end;
function TXmlConfig.TryGetAttr(const RootNode: TDOMNode; const Path: DOMString; out AValue: Int64): Boolean;
var
sValue: UTF8String;
begin
Result := TryGetAttr(RootNode, Path, sValue) and TryStrToInt64(sValue, AValue);
end;
function TXmlConfig.TryGetAttr(const RootNode: TDOMNode; const Path: DOMString; out AValue: Double): Boolean;
var
sValue: UTF8String;
begin
Result := TryGetAttr(RootNode, Path, sValue) and TryStrToFloat(sValue, AValue);
end;
function TXmlConfig.GetValue(const RootNode: TDOMNode; const Path: DOMString; const ADefault: UTF8String): UTF8String;
var
Node: TDOMNode;
begin
Node := FindNode(RootNode, Path, False);
if Assigned(Node) then
Result := UTF16ToUTF8(Node.TextContent)
else
Result := ADefault;
end;
function TXmlConfig.IsEmpty: Boolean;
begin
Result := RootNode.ChildNodes.Count = 0;
end;
function TXmlConfig.GetValue(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Boolean): Boolean;
var
sValue: UTF8String;
begin
sValue := GetValue(RootNode, Path, '');
if SameText(sValue, 'TRUE') then
Result := True
else if SameText(sValue, 'FALSE') then
Result := False
else
Result := ADefault;
end;
function TXmlConfig.GetValue(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Integer): Integer;
begin
Result := StrToIntDef(GetValue(RootNode, Path, ''), ADefault);
end;
function TXmlConfig.GetValue(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Int64): Int64;
begin
Result := StrToInt64Def(GetValue(RootNode, Path, ''), ADefault);
end;
function TXmlConfig.GetValue(const RootNode: TDOMNode; const Path: DOMString; const ADefault: Double): Double;
begin
Result := StrToFloatDef(GetValue(RootNode, Path, ''), ADefault);
end;
function TXmlConfig.TryGetValue(const RootNode: TDOMNode; const Path: DOMString; out AValue: UTF8String): Boolean;
var
Node: TDOMNode;
begin
Node := FindNode(RootNode, Path, False);
Result := Assigned(Node);
if Result then
AValue := UTF16ToUTF8(Node.TextContent);
end;
function TXmlConfig.TryGetValue(const RootNode: TDOMNode; const Path: DOMString; out AValue: Boolean): Boolean;
var
sValue: UTF8String;
begin
Result := TryGetValue(RootNode, Path, sValue);
if Result then
begin
if SameText(sValue, 'TRUE') then
AValue := True
else if SameText(sValue, 'FALSE') then
AValue := False
else
Result := False; // If other text then return not found.
end;
end;
function TXmlConfig.TryGetValue(const RootNode: TDOMNode; const Path: DOMString; out AValue: Integer): Boolean;
var
sValue: UTF8String;
begin
Result := TryGetValue(RootNode, Path, sValue) and TryStrToInt(sValue, AValue);
end;
function TXmlConfig.TryGetValue(const RootNode: TDOMNode; const Path: DOMString; out AValue: Int64): Boolean;
var
sValue: UTF8String;
begin
Result := TryGetValue(RootNode, Path, sValue) and TryStrToInt64(sValue, AValue);
end;
function TXmlConfig.TryGetValue(const RootNode: TDOMNode; const Path: DOMString; out AValue: Double): Boolean;
var
sValue: UTF8String;
begin
Result := TryGetValue(RootNode, Path, sValue) and TryStrToFloat(sValue, AValue);
end;
// ----------------------------------------------------------------------------
procedure TXmlConfig.AddValue(const RootNode: TDOMNode; const ValueName: DOMString; const AValue: String);
var
Node: TDOMNode;
begin
Node := RootNode.AppendChild(FDoc.CreateElement(ValueName));
Node.TextContent := UTF8ToUTF16(AValue);
end;
procedure TXmlConfig.AddValueDef(const RootNode: TDOMNode; const ValueName: DOMString; const AValue, DefaultValue: Boolean);
begin
if AValue <> DefaultValue then
AddValue(RootNode, ValueName, AValue);
end;
procedure TXmlConfig.AddValueDef(const RootNode: TDOMNode; const ValueName: DOMString; const AValue, DefaultValue: Double);
begin
if AValue <> DefaultValue then
AddValue(RootNode, ValueName, AValue);
end;
procedure TXmlConfig.AddValueDef(const RootNode: TDOMNode; const ValueName: DOMString; const AValue, DefaultValue: Int64);
begin
if AValue <> DefaultValue then
AddValue(RootNode, ValueName, AValue);
end;
procedure TXmlConfig.AddValueDef(const RootNode: TDOMNode; const ValueName: DOMString; const AValue, DefaultValue: Integer);
begin
if AValue <> DefaultValue then
AddValue(RootNode, ValueName, AValue);
end;
procedure TXmlConfig.AddValueDef(const RootNode: TDOMNode; const ValueName: DOMString; const AValue, DefaultValue: String);
begin
if AValue <> DefaultValue then
AddValue(RootNode, ValueName, AValue);
end;
procedure TXmlConfig.AddValue(const RootNode: TDOMNode; const ValueName: DOMString; const AValue: Boolean);
begin
AddValue(RootNode, ValueName, BoolStrings[AValue]);
end;
procedure TXmlConfig.AddValue(const RootNode: TDOMNode; const ValueName: DOMString; const AValue: Integer);
begin
AddValue(RootNode, ValueName, IntToStr(AValue));
end;
procedure TXmlConfig.AddValue(const RootNode: TDOMNode; const ValueName: DOMString; const AValue: Int64);
begin
AddValue(RootNode, ValueName, IntToStr(AValue));
end;
procedure TXmlConfig.AddValue(const RootNode: TDOMNode; const ValueName: DOMString; const AValue: Double);
begin
AddValue(RootNode, ValueName, FloatToStr(AValue));
end;
procedure TXmlConfig.SetAttr(const RootNode: TDOMNode; const Path: DOMString; const AValue: UTF8String);
var
Node: TDOMNode;
NodePath, AttrName: DOMString;
begin
SplitPathToNodeAndAttr(Path, NodePath, AttrName);
if NodePath <> EmptyWideStr then
begin
Node := FindNode(RootNode, NodePath, True);
TDOMElement(Node)[AttrName] := UTF8ToUTF16(AValue);
end
else
TDOMElement(RootNode)[AttrName] := UTF8ToUTF16(AValue);
end;
procedure TXmlConfig.SetAttr(const RootNode: TDOMNode; const Path: DOMString; const AValue: Boolean);
begin
SetAttr(RootNode, Path, BoolStrings[AValue]);
end;
procedure TXmlConfig.SetAttr(const RootNode: TDOMNode; const Path: DOMString; const AValue: Integer);
begin
SetAttr(RootNode, Path, IntToStr(AValue));
end;
procedure TXmlConfig.SetAttr(const RootNode: TDOMNode; const Path: DOMString; const AValue: Int64);
begin
SetAttr(RootNode, Path, IntToStr(AValue));
end;
procedure TXmlConfig.SetAttr(const RootNode: TDOMNode; const Path: DOMString; const AValue: Double);
begin
SetAttr(RootNode, Path, FloatToStr(AValue));
end;
procedure TXmlConfig.SetValue(const RootNode: TDOMNode; const Path: DOMString; const AValue: String);
var
Node: TDOMNode;
begin
Node := FindNode(RootNode, Path, True);
Node.TextContent := UTF8ToUTF16(AValue);
end;
procedure TXmlConfig.SetValue(const RootNode: TDOMNode; const Path: DOMString; const AValue: Boolean);
begin
SetValue(RootNode, Path, BoolStrings[AValue]);
end;
procedure TXmlConfig.SetValue(const RootNode: TDOMNode; const Path: DOMString; const AValue: Integer);
begin
SetValue(RootNode, Path, IntToStr(AValue));
end;
procedure TXmlConfig.SetValue(const RootNode: TDOMNode; const Path: DOMString; const AValue: Int64);
begin
SetValue(RootNode, Path, IntToStr(AValue));
end;
procedure TXmlConfig.SetValue(const RootNode: TDOMNode; const Path: DOMString; const AValue: Double);
begin
SetValue(RootNode, Path, FloatToStr(AValue));
end;
// ----------------------------------------------------------------------------
procedure TXmlConfig.ReadFromFile(const AFilename: UTF8String);
var
FileStream: TStream;
TmpDoc: TXMLDocument;
begin
FileStream := TFileStreamEx.Create(AFilename, fmOpenRead or fmShareDenyWrite);
try
if FileStream.Size = 0 then
raise EXmlConfigEmpty.Create('');
ReadXMLFile(TmpDoc, FileStream, FilenameToURI(AFilename));
if TmpDoc.DocumentElement.NodeName <> ApplicationName then
raise EXMLReadError.Create('Root element is not <' + ApplicationName + '>.');
FDoc.Free;
FDoc := TmpDoc;
finally
FileStream.Free;
end;
end;
procedure TXmlConfig.ReadFromStream(AStream: TStream);
var
TmpDoc: TXMLDocument;
begin
if AStream.Size = 0 then
raise EXmlConfigEmpty.Create('');
ReadXMLFile(TmpDoc, AStream);
FDoc.Free;
FDoc := TmpDoc;
end;
procedure TXmlConfig.WriteToFile(const AFilename: UTF8String);
var
FileStream: TStream;
begin
FileStream := TFileStreamEx.Create(AFilename, fmCreate or fmShareDenyWrite);
try
WriteXMLFile(FDoc, FileStream);
finally
FileStream.Free;
end;
end;
procedure TXmlConfig.WriteToStream(AStream: TStream);
begin
WriteXMLFile(FDoc, AStream);
end;
function TXmlConfig.Load: Boolean;
begin
Result := False;
if FFileName = '' then
Exit;
if not mbFileExists(FileName) then
raise EXmlConfigNotFound.Create('');
if not mbFileAccess(FileName, fmOpenRead or fmShareDenyWrite) then
raise EFOpenError.Create(SysErrorMessage(GetLastOSError));
ReadFromFile(FileName);
Result := True;
end;
function TXmlConfig.LoadBypassingErrors: Boolean;
var
ErrMsg: String;
begin
try
Result := Load;
except
on e: Exception do
begin
ErrMsg := 'Error loading configuration file ' + FileName;
if e.Message <> EmptyStr then
ErrMsg := ErrMsg + ': ' + e.Message;
DebugLogger.DebugLn(ErrMsg);
Result := False;
end;
end;
end;
function TXmlConfig.Save: Boolean;
var
sTmpConfigFileName: String;
begin
Result := False;
if FFileName = '' then
Exit;
// Write to temporary file and if successfully written rename to proper name.
if (not mbFileExists(FileName)) or mbFileAccess(FileName, fmOpenWrite or fmShareDenyWrite) then
begin
sTmpConfigFileName := GetTempName(FileName);
try
WriteToFile(sTmpConfigFileName);
if not mbRenameFile(sTmpConfigFileName, FileName) then
begin
mbDeleteFile(sTmpConfigFileName);
DebugLogger.Debugln('Cannot save configuration file ', FileName);
end
else
Result := True;
except
on e: EStreamError do
begin
mbDeleteFile(sTmpConfigFileName);
DebugLogger.Debugln('Error saving configuration file ', FileName, ': ' + e.Message);
end;
end;
end
else
begin
DebugLogger.Debugln('Cannot save configuration file ', FileName, ' - check permissions');
end;
end;
procedure TXmlConfig.SplitPathToNodeAndAttr(const Path: DOMString; out NodePath: DOMString; out AttrName: DOMString);
var
AttrSepPos: Integer;
begin
// Last part of the path is the attr name.
AttrSepPos := Length(Path);
while (AttrSepPos > 0) and (Path[AttrSepPos] <> '/') do
Dec(AttrSepPos);
if (AttrSepPos = 0) or (AttrSepPos = Length(Path)) then
begin
NodePath := EmptyWideStr;
AttrName := Path;
end
else
begin
NodePath := Copy(Path, 1, AttrSepPos - 1);
AttrName := Copy(Path, AttrSepPos + 1, Length(Path) - AttrSepPos);
end;
end;
function TXmlConfig.AddNode(const RootNode: TDOMNode; const ValueName: DOMString): TDOMNode;
begin
Result := RootNode.AppendChild(FDoc.CreateElement(ValueName));
end;
procedure TXmlConfig.DeleteNode(const RootNode: TDOMNode; const Path: DOMString);
begin
DeleteNode(FindNode(RootNode, Path, False));
end;
procedure TXmlConfig.DeleteNode(const Node: TDOMNode);
begin
if Assigned(Node) and Assigned(Node.ParentNode) then
Node.ParentNode.DetachChild(Node);
end;
procedure TXmlConfig.ClearNode(const Node: TDOMNode);
var
Attr: TDOMAttr;
begin
while Assigned(Node.FirstChild) do
Node.RemoveChild(Node.FirstChild);
if Node.HasAttributes then
begin
Attr := TDOMAttr(Node.Attributes[0]);
while Assigned(Attr) do
begin
TDOMElement(Node).RemoveAttributeNode(Attr);
Attr := TDOMAttr(Attr.NextSibling);
end;
end;
end;
function TXmlConfig.FindNode(const RootNode: TDOMNode; const Path: DOMString; bCreate: Boolean = False): TDOMNode;
var
StartPos, EndPos: Integer;
PathLen: Integer;
Child: TDOMNode;
function CompareDOMStrings(const s1, s2: DOMPChar; l1, l2: integer): integer;
var i: integer;
begin
Result:=l1-l2;
i:=0;
while (i<l1) and (Result=0) do begin
Result:=ord(s1[i])-ord(s2[i]);
inc(i);
end;
end;
begin
Result := RootNode;
PathLen := Length(Path);
if PathLen = 0 then
Exit;
StartPos := 1;
while Assigned(Result) do
begin
EndPos := StartPos;
while (EndPos <= PathLen) and (Path[EndPos] <> '/') do
Inc(EndPos);
Child := Result.FirstChild;
while Assigned(Child) and not ((Child.NodeType = ELEMENT_NODE)
and (0 = CompareDOMStrings(DOMPChar(Child.NodeName), @Path[StartPos],
Length(Child.NodeName), EndPos-StartPos))) do
Child := Child.NextSibling;
if not Assigned(Child) and bCreate then
begin
Child := FDoc.CreateElementBuf(@Path[StartPos], EndPos-StartPos);
Result.AppendChild(Child);
end;
Result := Child;
StartPos := EndPos + 1;
if StartPos > PathLen then
Break;
end;
end;
function TXmlConfig.GetContent(const Node: TDOMNode): UTF8String;
begin
Result := UTF16ToUTF8(Node.TextContent);
end;
procedure TXmlConfig.SetContent(const Node: TDOMNode; const AValue: UTF8String);
begin
Node.TextContent := UTF8ToUTF16(AValue);
end;
function TXmlConfig.GetPathFromNode(aNode: TDOMNode): String;
begin
Result := aNode.NodeName;
aNode := aNode.ParentNode;
while Assigned(aNode) and (aNode <> RootNode) do
begin
Result := aNode.NodeName + '/' + Result;
aNode := aNode.ParentNode;
end;
end;
procedure TXmlConfig.GetFont(const aNode: TXmlNode; Path: TXmlPath;
out Name: UTF8String; out Size: Integer; out Style: Integer;
const DefName: UTF8String; const DefSize: Integer; const DefStyle: Integer);
begin
if Path <> '' then
Path := Path + '/';
Name := GetValue(aNode, Path + 'Name', DefName);
Size := GetValue(aNode, Path + 'Size', DefSize);
Style := GetValue(aNode, Path + 'Style', DefStyle);
end;
procedure TXmlConfig.SetFont(const aNode: TXmlNode; Path: TXmlPath;
const Name: UTF8String; const Size: Integer; const Style: Integer);
begin
if Path <> '' then
Path := Path + '/';
SetValue(aNode, Path + 'Name', Name);
SetValue(aNode, Path + 'Size', Size);
SetValue(aNode, Path + 'Style', Style);
end;
end.

94
doublecmd/doublecmd_common.lpk Normal file
View File

@@ -0,0 +1,94 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="doublecmd_common"/>
<Author Value="Alexander Koblov"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Conditionals Value="if (TargetCPU &lt;> 'arm') then
begin
CustomOptions += '-fPIC';
UsageCustomOptions += '-fPIC';
end"/>
<Parsing>
<SyntaxOptions>
<IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Checks>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
</Checks>
</CodeGeneration>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf2Set"/>
</Debugging>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="Common units for Double Commander"/>
<License Value="GNU GPL 2"/>
<Version Minor="3"/>
<Files Count="8">
<Item1>
<Filename Value="dcclassesutf8.pas"/>
<UnitName Value="DCClassesUtf8"/>
</Item1>
<Item2>
<Filename Value="dcosutils.pas"/>
<UnitName Value="DCOSUtils"/>
</Item2>
<Item3>
<Filename Value="dcstrutils.pas"/>
<UnitName Value="DCStrUtils"/>
</Item3>
<Item4>
<Filename Value="dcbasictypes.pas"/>
<UnitName Value="DCBasicTypes"/>
</Item4>
<Item5>
<Filename Value="dcfileattributes.pas"/>
<UnitName Value="DCFileAttributes"/>
</Item5>
<Item6>
<Filename Value="dcconvertencoding.pas"/>
<UnitName Value="DCConvertEncoding"/>
</Item6>
<Item7>
<Filename Value="dcdatetimeutils.pas"/>
<UnitName Value="DCDateTimeUtils"/>
</Item7>
<Item8>
<Filename Value="dcxmlconfig.pas"/>
<UnitName Value="DCXmlConfig"/>
</Item8>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item1>
<Item2>
<PackageName Value="LazUtils"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

15
doublecmd/doublecmd_common.pas Normal file
View File

@@ -0,0 +1,15 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit doublecmd_common;
interface
uses
DCClassesUtf8, DCOSUtils, DCStrUtils, DCBasicTypes, DCFileAttributes,
DCConvertEncoding, DCDateTimeUtils, DCXmlConfig;
implementation
end.