mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-28 10:02:14 +00:00
Code Issues Projects Releases Packages Wiki Activity

FIX: Compiling with latest FPC - clash between UTF8Encode(UnicodeString) and UTF8Encode(WideString) on Windows.

Browse source
This commit is contained in:
cobines 2009-10-27 06:36:02 +00:00
commit f3cd2c18d2
5 changed files with 2708 additions and 2708 deletions
Download patch file Download diff file Expand all files Collapse all files

932
plugins/wcx/zip/src/ZipFunc.pas
View file

@ -1,466 +1,466 @@
{
Double commander
-------------------------------------------------------------------------
WCX plugin for working with *.zip, *.gz, *.tar, *.tgz archives
Copyright (C) 2007-2009 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
in a file called COPYING along with this program; if not, write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
02139, USA.
}
unit ZipFunc;
interface
uses
WcxPlugin, AbZipKit, AbArcTyp, AbZipTyp, DialogAPI,
AbExcept, AbUtils;
type
TAbZipKitEx = class (TAbZipKit)
private
FProcessDataProc : TProcessDataProc;
procedure AbArchiveItemProgressEvent(Sender : TObject; Item : TAbArchiveItem; Progress : Byte;
var Abort : Boolean);
procedure AbArchiveProgressEvent (Sender : TObject; Progress : Byte; var Abort : Boolean);
procedure AbProcessItemFailureEvent(Sender: TObject; Item: TAbArchiveItem; ProcessType: TAbProcessType;
ErrorClass: TAbErrorClass; ErrorCode: Integer);
end;
{Mandatory functions}
function OpenArchive (var ArchiveData : tOpenArchiveData) : TArcHandle;stdcall;
function ReadHeader (hArcData : TArcHandle; var HeaderData : THeaderData) : Integer;stdcall;
function ProcessFile (hArcData : TArcHandle; Operation : Integer; DestPath, DestName : PChar) : Integer;stdcall;
function CloseArchive (hArcData : TArcHandle) : Integer;stdcall;
procedure SetChangeVolProc (hArcData : TArcHandle; pChangeVolProc1 : PChangeVolProc);stdcall;
procedure SetProcessDataProc (hArcData : TArcHandle; pProcessDataProc1 : TProcessDataProc);stdcall;
{Optional functions}
function PackFiles(PackedFile: pchar; SubPath: pchar; SrcPath: pchar; AddList: pchar; Flags: integer): Integer;stdcall;
function DeleteFiles (PackedFile, DeleteList : PChar) : Integer;stdcall;
function GetPackerCaps : Integer;stdcall;
procedure ConfigurePacker (Parent: THandle; DllInstance: THandle);stdcall;
{Dialog API function}
procedure SetDlgProc(var SetDlgProcInfo: TSetDlgProcInfo);stdcall;
const
IniFileName = 'zip.ini';
var
gProcessDataProc : TProcessDataProc;
gSetDlgProcInfo: TSetDlgProcInfo;
gCompressionMethodToUse : TAbZipSupportedMethod;
gDeflationOption : TAbZipDeflationOption;
gPluginDir: UTF8String;
gPluginConfDir: UTF8String;
implementation
uses SysUtils, Classes, ZipConfDlg, IniFiles
{$IFDEF MSWINDOWS}
, Windows
{$ENDIF}
;
{$IFNDEF FPC} // for compiling under Delphi
Const
DirSeparators : set of char = ['/','\'];
Procedure DoDirSeparators (Var FileName : String);
VAr I : longint;
begin
For I:=1 to Length(FileName) do
If FileName[I] in DirSeparators then
FileName[i]:=PathDelim;
end;
{$ENDIF}
procedure TAbZipKitEx.AbProcessItemFailureEvent(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType;
ErrorClass: TAbErrorClass; ErrorCode: Integer);
var
Msg: String;
begin
//ProcessType:(ptAdd, ptDelete, ptExtract, ptFreshen, ptMove, ptReplace, ptFoundUnhandled);
Msg := 'Error while processing: ' + Item.FileName;
{$IFDEF MSWINDOWS}
// This is supposedly thread-safe.
MessageBox(0, PCHAR(msg), 'Error', MB_OK or MB_ICONERROR);
{$ENDIF}
end;
function ExtractOnlyFileName(const FileName: string): string;
var
iDotIndex,
I: longint;
sExt : String;
begin
(* Find a dot index *)
I := Length(FileName);
while (I > 0) and not (FileName[I] in ['.', '/', '\', ':']) do Dec(I);
if (I > 0) and (FileName[I] = '.') then
begin
iDotIndex := I;
sExt := Copy(FileName, I, MaxInt);
end
else
begin
iDotIndex := MaxInt;
sExt := '';
end;
(* Find file name index *)
I := Length(FileName);
while (I > 0) and not (FileName[I] in ['/', '\', ':']) do Dec(I);
Result := Copy(FileName, I + 1, iDotIndex - I - 1);
if sExt = '.tgz' then
Result := Result + '.tar';
end;
{
Create file list like "filename1;filename2;filename3"
from file list like "filename1#0filename2#0filename3#0#0"
}
function MakeFileList(FileList : PChar) : String;
var
I : Integer;
CurrentChar : Char;
begin
I := 0;
while True do
begin
CurrentChar := (FileList + I)^;
if CurrentChar = #0 then
CurrentChar := AbPathSep;
if ((FileList + I)^ = #0) and ((FileList + I + 1)^ = #0) then
break;
Result := Result + CurrentChar;
I := I + 1;
end;
end;
function OpenArchive (var ArchiveData : tOpenArchiveData) : TArcHandle;
var
Arc : TAbZipKitEx;
begin
Result := 0;
Arc := TAbZipKitEx.Create(nil);
//MessageBox(0,ArchiveData.ArcName,'OpenArchive',16);
Arc.OnArchiveItemProgress := Arc.AbArchiveItemProgressEvent;
Arc.OnArchiveProgress := Arc.AbArchiveProgressEvent;
Arc.OnProcessItemFailure := Arc.AbProcessItemFailureEvent;
try
Arc.TarAutoHandle:=true;
Arc.OpenArchive(ArchiveData.ArcName);
Arc.Tag := 0;
//MessageBox(0,'OpenArchive','OpenArchive',16);
Result := TArcHandle(Arc);
except
on EAbUnhandledType do ArchiveData.OpenResult := E_UNKNOWN_FORMAT;
end;
if (Result = 0) and Assigned(Arc) then
Arc.Free;
end;
function ReadHeader (hArcData : TArcHandle; var HeaderData : THeaderData) : Integer;
var
Arc : TAbZipKitEx;
sFileName : String;
begin
Arc := TAbZipKitEx(Pointer(hArcData));
if Arc.Tag > Arc.Count - 1 then
begin
Result := E_END_ARCHIVE;
Exit;
end;
with HeaderData do
begin
//MessageBox(0,PChar(Arc.Items[Arc.Tag].FileName),'',16);
sFileName := Arc.Items[Arc.Tag].FileName;
if (Arc.ArchiveType in [atGzip, atGzippedTar]) and (sFileName = 'unknown') then
sFileName := ExtractOnlyFileName(Arc.FileName);
DoDirSeparators(sFileName);
sFileName := ExcludeTrailingPathDelimiter(sFileName);
StrPLCopy(FileName, sFileName, SizeOf(FileName) - 1);
PackSize := Arc.Items[Arc.Tag].CompressedSize;
UnpSize := Arc.Items[Arc.Tag].UncompressedSize;
FileCRC := Arc.Items[Arc.Tag].CRC32;
FileTime := Arc.Items[Arc.Tag].SystemSpecificLastModFileTime;
FileAttr := Arc.Items[Arc.Tag].SystemSpecificAttributes;
end;
Result := 0;
end;
function ProcessFile (hArcData : TArcHandle; Operation : Integer; DestPath, DestName : PChar) : Integer;
var
Arc : TAbZipKitEx;
begin
Arc := TAbZipKitEx(Pointer(hArcData));
try
Result := E_SUCCESS;
case Operation of
PK_TEST:
begin
Arc.TagItems('*.*');
Arc.TestTaggedItems;
end;
PK_EXTRACT:
begin
Arc.BaseDirectory := ExtractFilePath(DestName);
Arc.ExtractAt(Arc.Tag, DestName);
// Show progress and ask if aborting.
if Assigned(Arc.FProcessDataProc) then
begin
if Arc.FProcessDataProc(PChar(Arc.Items[Arc.Tag].FileName),
Arc.Items[Arc.Tag].UncompressedSize) = 0
then
Result := E_EABORTED;
end;
end;
PK_SKIP:
begin
end;
end; {case}
except
on EAbUserAbort do
Result := E_EABORTED;
else
Result := E_BAD_DATA;
end;
Arc.Tag := Arc.Tag + 1;
end;
function CloseArchive (hArcData : TArcHandle) : Integer;
var
Arc : TAbZipKitEx;
begin
Arc := TAbZipKitEx(Pointer(hArcData));
Arc.CloseArchive;
FreeAndNil(Arc);
Result := 0;
end;
procedure SetChangeVolProc (hArcData : TArcHandle; pChangeVolProc1 : PChangeVolProc);
begin
end;
procedure SetProcessDataProc (hArcData : TArcHandle; pProcessDataProc1 : TProcessDataProc);
var
Arc : TAbZipKitEx;
begin
if (hArcData <> wcxInvalidHandle) then // if archive is open
begin
Arc := TAbZipKitEx(Pointer(hArcData));
if Assigned(pProcessDataProc1) then
Arc.FProcessDataProc := pProcessDataProc1
else
Arc.FProcessDataProc := nil;
end
else // if archive is close
if Assigned(pProcessDataProc1) then
gProcessDataProc := pProcessDataProc1
else
gProcessDataProc := nil;
end;
{Optional functions}
function PackFiles(PackedFile: pchar; SubPath: pchar; SrcPath: pchar; AddList: pchar; Flags: integer): integer;
var
Arc : TAbZipKitEx;
begin
try
try
Arc := TAbZipKitEx.Create(nil);
Arc.AutoSave := False;
Arc.CompressionMethodToUse:= gCompressionMethodToUse;
Arc.DeflationOption:= gDeflationOption;
Arc.FProcessDataProc := gProcessDataProc;
Arc.OnProcessItemFailure := Arc.AbProcessItemFailureEvent;
Arc.TarAutoHandle:=True;
Arc.OpenArchive(PackedFile);
Arc.OnArchiveItemProgress := Arc.AbArchiveItemProgressEvent;
Arc.OnArchiveProgress := Arc.AbArchiveProgressEvent;
Arc.BaseDirectory := SrcPath;
Arc.AddEntries(MakeFileList(AddList), SubPath);
Arc.Save;
Arc.CloseArchive;
Result := E_SUCCESS;
except
on EAbUserAbort do
Result := E_EABORTED;
on EAbFileNotFound do
Result := E_EOPEN;
else
begin
Result := E_BAD_DATA;
end;
end;
finally
FreeAndNil(Arc);
end;
end;
function DeleteFiles (PackedFile, DeleteList : PChar) : Integer;
function StrEndsWith(S : String; SearchPhrase : String) : Boolean;
begin
Result := (RightStr(S, Length(SearchPhrase)) = SearchPhrase);
end;
var
Arc : TAbZipKitEx;
pFileName : PChar;
FileName : String;
begin
try
try
Arc := TAbZipKitEx.Create(nil);
Arc.FProcessDataProc := gProcessDataProc;
Arc.OnProcessItemFailure := Arc.AbProcessItemFailureEvent;
Arc.TarAutoHandle:=True;
Arc.OpenArchive(PackedFile);
// Set this after opening archive, to get only progress of deleting.
Arc.OnArchiveItemProgress := Arc.AbArchiveItemProgressEvent;
Arc.OnArchiveProgress := Arc.AbArchiveProgressEvent;
// Parse file list.
pFileName := DeleteList;
while pFileName^ <> #0 do
begin
FileName := pFileName; // Convert PChar to String (up to first #0).
// If ends with '.../*.*' or '.../' then delete directory.
if StrEndsWith(FileName, PathDelim + '*.*') or
StrEndsWith(FileName, PathDelim)
then
Arc.DeleteDirectoriesRecursively(ExtractFilePath(FileName))
else
Arc.DeleteFiles(FileName);
pFileName := pFileName + Length(FileName) + 1; // move after filename and ending #0
if pFileName^ = #0 then
Break; // end of list
end;
Arc.Save;
Arc.CloseArchive;
Result := E_SUCCESS;
except
on EAbUserAbort do
Result := E_EABORTED;
else
Result := E_BAD_DATA;
end;
finally
FreeAndNil(Arc);
end;
end;
function GetPackerCaps : Integer;
begin
Result := PK_CAPS_NEW or PK_CAPS_DELETE or PK_CAPS_MODIFY
or PK_CAPS_MULTIPLE or PK_CAPS_OPTIONS or PK_CAPS_BY_CONTENT;
// or PK_CAPS_MEMPACK or PK_CAPS_ENCRYPT
end;
procedure ConfigurePacker(Parent: THandle; DllInstance: THandle);
begin
CreateZipConfDlg;
end;
procedure SetDlgProc(var SetDlgProcInfo: TSetDlgProcInfo);
var
gIni: TIniFile;
begin
gSetDlgProcInfo:= SetDlgProcInfo;
gPluginDir := UTF8Encode(gSetDlgProcInfo.PluginDir);
gPluginConfDir := UTF8Encode(gSetDlgProcInfo.PluginConfDir);
// Clear so they are not used anymore.
gSetDlgProcInfo.PluginDir := nil;
gSetDlgProcInfo.PluginConfDir := nil;
// load configuration from ini file
gIni:= TIniFile.Create(gPluginConfDir + IniFileName);
try
LoadConfig;
finally
gIni.Free;
end;
end;
{ TAbZipKitEx }
procedure TAbZipKitEx.AbArchiveItemProgressEvent(Sender: TObject;
Item: TAbArchiveItem; Progress: Byte; var Abort: Boolean);
begin
try
if Assigned(FProcessDataProc) then
Abort := (FProcessDataProc(PChar(Item.FileName), -(Progress)) = 0);
except
Abort := True;
end;
end;
procedure TAbZipKitEx.AbArchiveProgressEvent(Sender: TObject;
Progress: Byte; var Abort: Boolean);
begin
try
if Assigned(FProcessDataProc) then
Abort := (FProcessDataProc(nil, -(Progress + 1000)) = 0);
except
Abort := True;
end;
end;
end.
{
Double commander
-------------------------------------------------------------------------
WCX plugin for working with *.zip, *.gz, *.tar, *.tgz archives
Copyright (C) 2007-2009 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
in a file called COPYING along with this program; if not, write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
02139, USA.
}
unit ZipFunc;
interface
uses
WcxPlugin, AbZipKit, AbArcTyp, AbZipTyp, DialogAPI,
AbExcept, AbUtils;
type
TAbZipKitEx = class (TAbZipKit)
private
FProcessDataProc : TProcessDataProc;
procedure AbArchiveItemProgressEvent(Sender : TObject; Item : TAbArchiveItem; Progress : Byte;
var Abort : Boolean);
procedure AbArchiveProgressEvent (Sender : TObject; Progress : Byte; var Abort : Boolean);
procedure AbProcessItemFailureEvent(Sender: TObject; Item: TAbArchiveItem; ProcessType: TAbProcessType;
ErrorClass: TAbErrorClass; ErrorCode: Integer);
end;
{Mandatory functions}
function OpenArchive (var ArchiveData : tOpenArchiveData) : TArcHandle;stdcall;
function ReadHeader (hArcData : TArcHandle; var HeaderData : THeaderData) : Integer;stdcall;
function ProcessFile (hArcData : TArcHandle; Operation : Integer; DestPath, DestName : PChar) : Integer;stdcall;
function CloseArchive (hArcData : TArcHandle) : Integer;stdcall;
procedure SetChangeVolProc (hArcData : TArcHandle; pChangeVolProc1 : PChangeVolProc);stdcall;
procedure SetProcessDataProc (hArcData : TArcHandle; pProcessDataProc1 : TProcessDataProc);stdcall;
{Optional functions}
function PackFiles(PackedFile: pchar; SubPath: pchar; SrcPath: pchar; AddList: pchar; Flags: integer): Integer;stdcall;
function DeleteFiles (PackedFile, DeleteList : PChar) : Integer;stdcall;
function GetPackerCaps : Integer;stdcall;
procedure ConfigurePacker (Parent: THandle; DllInstance: THandle);stdcall;
{Dialog API function}
procedure SetDlgProc(var SetDlgProcInfo: TSetDlgProcInfo);stdcall;
const
IniFileName = 'zip.ini';
var
gProcessDataProc : TProcessDataProc;
gSetDlgProcInfo: TSetDlgProcInfo;
gCompressionMethodToUse : TAbZipSupportedMethod;
gDeflationOption : TAbZipDeflationOption;
gPluginDir: UTF8String;
gPluginConfDir: UTF8String;
implementation
uses SysUtils, Classes, ZipConfDlg, IniFiles
{$IFDEF MSWINDOWS}
, Windows
{$ENDIF}
;
{$IFNDEF FPC} // for compiling under Delphi
Const
DirSeparators : set of char = ['/','\'];
Procedure DoDirSeparators (Var FileName : String);
VAr I : longint;
begin
For I:=1 to Length(FileName) do
If FileName[I] in DirSeparators then
FileName[i]:=PathDelim;
end;
{$ENDIF}
procedure TAbZipKitEx.AbProcessItemFailureEvent(Sender: TObject;
Item: TAbArchiveItem; ProcessType: TAbProcessType;
ErrorClass: TAbErrorClass; ErrorCode: Integer);
var
Msg: String;
begin
//ProcessType:(ptAdd, ptDelete, ptExtract, ptFreshen, ptMove, ptReplace, ptFoundUnhandled);
Msg := 'Error while processing: ' + Item.FileName;
{$IFDEF MSWINDOWS}
// This is supposedly thread-safe.
MessageBox(0, PCHAR(msg), 'Error', MB_OK or MB_ICONERROR);
{$ENDIF}
end;
function ExtractOnlyFileName(const FileName: string): string;
var
iDotIndex,
I: longint;
sExt : String;
begin
(* Find a dot index *)
I := Length(FileName);
while (I > 0) and not (FileName[I] in ['.', '/', '\', ':']) do Dec(I);
if (I > 0) and (FileName[I] = '.') then
begin
iDotIndex := I;
sExt := Copy(FileName, I, MaxInt);
end
else
begin
iDotIndex := MaxInt;
sExt := '';
end;
(* Find file name index *)
I := Length(FileName);
while (I > 0) and not (FileName[I] in ['/', '\', ':']) do Dec(I);
Result := Copy(FileName, I + 1, iDotIndex - I - 1);
if sExt = '.tgz' then
Result := Result + '.tar';
end;
{
Create file list like "filename1;filename2;filename3"
from file list like "filename1#0filename2#0filename3#0#0"
}
function MakeFileList(FileList : PChar) : String;
var
I : Integer;
CurrentChar : Char;
begin
I := 0;
while True do
begin
CurrentChar := (FileList + I)^;
if CurrentChar = #0 then
CurrentChar := AbPathSep;
if ((FileList + I)^ = #0) and ((FileList + I + 1)^ = #0) then
break;
Result := Result + CurrentChar;
I := I + 1;
end;
end;
function OpenArchive (var ArchiveData : tOpenArchiveData) : TArcHandle;
var
Arc : TAbZipKitEx;
begin
Result := 0;
Arc := TAbZipKitEx.Create(nil);
//MessageBox(0,ArchiveData.ArcName,'OpenArchive',16);
Arc.OnArchiveItemProgress := Arc.AbArchiveItemProgressEvent;
Arc.OnArchiveProgress := Arc.AbArchiveProgressEvent;
Arc.OnProcessItemFailure := Arc.AbProcessItemFailureEvent;
try
Arc.TarAutoHandle:=true;
Arc.OpenArchive(ArchiveData.ArcName);
Arc.Tag := 0;
//MessageBox(0,'OpenArchive','OpenArchive',16);
Result := TArcHandle(Arc);
except
on EAbUnhandledType do ArchiveData.OpenResult := E_UNKNOWN_FORMAT;
end;
if (Result = 0) and Assigned(Arc) then
Arc.Free;
end;
function ReadHeader (hArcData : TArcHandle; var HeaderData : THeaderData) : Integer;
var
Arc : TAbZipKitEx;
sFileName : String;
begin
Arc := TAbZipKitEx(Pointer(hArcData));
if Arc.Tag > Arc.Count - 1 then
begin
Result := E_END_ARCHIVE;
Exit;
end;
with HeaderData do
begin
//MessageBox(0,PChar(Arc.Items[Arc.Tag].FileName),'',16);
sFileName := Arc.Items[Arc.Tag].FileName;
if (Arc.ArchiveType in [atGzip, atGzippedTar]) and (sFileName = 'unknown') then
sFileName := ExtractOnlyFileName(Arc.FileName);
DoDirSeparators(sFileName);
sFileName := ExcludeTrailingPathDelimiter(sFileName);
StrPLCopy(FileName, sFileName, SizeOf(FileName) - 1);
PackSize := Arc.Items[Arc.Tag].CompressedSize;
UnpSize := Arc.Items[Arc.Tag].UncompressedSize;
FileCRC := Arc.Items[Arc.Tag].CRC32;
FileTime := Arc.Items[Arc.Tag].SystemSpecificLastModFileTime;
FileAttr := Arc.Items[Arc.Tag].SystemSpecificAttributes;
end;
Result := 0;
end;
function ProcessFile (hArcData : TArcHandle; Operation : Integer; DestPath, DestName : PChar) : Integer;
var
Arc : TAbZipKitEx;
begin
Arc := TAbZipKitEx(Pointer(hArcData));
try
Result := E_SUCCESS;
case Operation of
PK_TEST:
begin
Arc.TagItems('*.*');
Arc.TestTaggedItems;
end;
PK_EXTRACT:
begin
Arc.BaseDirectory := ExtractFilePath(DestName);
Arc.ExtractAt(Arc.Tag, DestName);
// Show progress and ask if aborting.
if Assigned(Arc.FProcessDataProc) then
begin
if Arc.FProcessDataProc(PChar(Arc.Items[Arc.Tag].FileName),
Arc.Items[Arc.Tag].UncompressedSize) = 0
then
Result := E_EABORTED;
end;
end;
PK_SKIP:
begin
end;
end; {case}
except
on EAbUserAbort do
Result := E_EABORTED;
else
Result := E_BAD_DATA;
end;
Arc.Tag := Arc.Tag + 1;
end;
function CloseArchive (hArcData : TArcHandle) : Integer;
var
Arc : TAbZipKitEx;
begin
Arc := TAbZipKitEx(Pointer(hArcData));
Arc.CloseArchive;
FreeAndNil(Arc);
Result := 0;
end;
procedure SetChangeVolProc (hArcData : TArcHandle; pChangeVolProc1 : PChangeVolProc);
begin
end;
procedure SetProcessDataProc (hArcData : TArcHandle; pProcessDataProc1 : TProcessDataProc);
var
Arc : TAbZipKitEx;
begin
if (hArcData <> wcxInvalidHandle) then // if archive is open
begin
Arc := TAbZipKitEx(Pointer(hArcData));
if Assigned(pProcessDataProc1) then
Arc.FProcessDataProc := pProcessDataProc1
else
Arc.FProcessDataProc := nil;
end
else // if archive is close
if Assigned(pProcessDataProc1) then
gProcessDataProc := pProcessDataProc1
else
gProcessDataProc := nil;
end;
{Optional functions}
function PackFiles(PackedFile: pchar; SubPath: pchar; SrcPath: pchar; AddList: pchar; Flags: integer): integer;
var
Arc : TAbZipKitEx;
begin
try
try
Arc := TAbZipKitEx.Create(nil);
Arc.AutoSave := False;
Arc.CompressionMethodToUse:= gCompressionMethodToUse;
Arc.DeflationOption:= gDeflationOption;
Arc.FProcessDataProc := gProcessDataProc;
Arc.OnProcessItemFailure := Arc.AbProcessItemFailureEvent;
Arc.TarAutoHandle:=True;
Arc.OpenArchive(PackedFile);
Arc.OnArchiveItemProgress := Arc.AbArchiveItemProgressEvent;
Arc.OnArchiveProgress := Arc.AbArchiveProgressEvent;
Arc.BaseDirectory := SrcPath;
Arc.AddEntries(MakeFileList(AddList), SubPath);
Arc.Save;
Arc.CloseArchive;
Result := E_SUCCESS;
except
on EAbUserAbort do
Result := E_EABORTED;
on EAbFileNotFound do
Result := E_EOPEN;
else
begin
Result := E_BAD_DATA;
end;
end;
finally
FreeAndNil(Arc);
end;
end;
function DeleteFiles (PackedFile, DeleteList : PChar) : Integer;
function StrEndsWith(S : String; SearchPhrase : String) : Boolean;
begin
Result := (RightStr(S, Length(SearchPhrase)) = SearchPhrase);
end;
var
Arc : TAbZipKitEx;
pFileName : PChar;
FileName : String;
begin
try
try
Arc := TAbZipKitEx.Create(nil);
Arc.FProcessDataProc := gProcessDataProc;
Arc.OnProcessItemFailure := Arc.AbProcessItemFailureEvent;
Arc.TarAutoHandle:=True;
Arc.OpenArchive(PackedFile);
// Set this after opening archive, to get only progress of deleting.
Arc.OnArchiveItemProgress := Arc.AbArchiveItemProgressEvent;
Arc.OnArchiveProgress := Arc.AbArchiveProgressEvent;
// Parse file list.
pFileName := DeleteList;
while pFileName^ <> #0 do
begin
FileName := pFileName; // Convert PChar to String (up to first #0).
// If ends with '.../*.*' or '.../' then delete directory.
if StrEndsWith(FileName, PathDelim + '*.*') or
StrEndsWith(FileName, PathDelim)
then
Arc.DeleteDirectoriesRecursively(ExtractFilePath(FileName))
else
Arc.DeleteFiles(FileName);
pFileName := pFileName + Length(FileName) + 1; // move after filename and ending #0
if pFileName^ = #0 then
Break; // end of list
end;
Arc.Save;
Arc.CloseArchive;
Result := E_SUCCESS;
except
on EAbUserAbort do
Result := E_EABORTED;
else
Result := E_BAD_DATA;
end;
finally
FreeAndNil(Arc);
end;
end;
function GetPackerCaps : Integer;
begin
Result := PK_CAPS_NEW or PK_CAPS_DELETE or PK_CAPS_MODIFY
or PK_CAPS_MULTIPLE or PK_CAPS_OPTIONS or PK_CAPS_BY_CONTENT;
// or PK_CAPS_MEMPACK or PK_CAPS_ENCRYPT
end;
procedure ConfigurePacker(Parent: THandle; DllInstance: THandle);
begin
CreateZipConfDlg;
end;
procedure SetDlgProc(var SetDlgProcInfo: TSetDlgProcInfo);
var
gIni: TIniFile;
begin
gSetDlgProcInfo:= SetDlgProcInfo;
gPluginDir := UTF8Encode(WideString(gSetDlgProcInfo.PluginDir));
gPluginConfDir := UTF8Encode(WideString(gSetDlgProcInfo.PluginConfDir));
// Clear so they are not used anymore.
gSetDlgProcInfo.PluginDir := nil;
gSetDlgProcInfo.PluginConfDir := nil;
// load configuration from ini file
gIni:= TIniFile.Create(gPluginConfDir + IniFileName);
try
LoadConfig;
finally
gIni.Free;
end;
end;
{ TAbZipKitEx }
procedure TAbZipKitEx.AbArchiveItemProgressEvent(Sender: TObject;
Item: TAbArchiveItem; Progress: Byte; var Abort: Boolean);
begin
try
if Assigned(FProcessDataProc) then
Abort := (FProcessDataProc(PChar(Item.FileName), -(Progress)) = 0);
except
Abort := True;
end;
end;
procedure TAbZipKitEx.AbArchiveProgressEvent(Sender: TObject;
Progress: Byte; var Abort: Boolean);
begin
try
if Assigned(FProcessDataProc) then
Abort := (FProcessDataProc(nil, -(Progress + 1000)) = 0);
except
Abort := True;
end;
end;
end.

22
src/fdialogbox.pas
View file

@ -100,9 +100,9 @@ var
sDefaultText: UTF8String;
wResult: WideString;
begin
sCaption:= UTF8Encode(Caption);
sPrompt:= UTF8Encode(Prompt);
sDefaultText:= UTF8Encode(DefaultText);
sCaption:= UTF8Encode(WideString(Caption));
sPrompt:= UTF8Encode(WideString(Prompt));
sDefaultText:= UTF8Encode(WideString(DefaultText));
wResult:= Dialogs.InputBox(sCaption, sPrompt, sDefaultText);
Result:= PWideChar(UTF8Decode(wResult));
end;
@ -112,8 +112,8 @@ var
sText,
sCaption: String;
begin
sText:= UTF8Encode(Text);
sCaption:= UTF8Encode(Caption);
sText:= UTF8Encode(WideString(Text));
sCaption:= UTF8Encode(WideString(Caption));
Result:= Application.MessageBox(PChar(sText), PChar(sCaption), Flags);
end;
@ -126,7 +126,7 @@ var
Dialog: TDialogBox = nil;
begin
try
DataString:= UTF8Encode(DlgData);
DataString:= UTF8Encode(WideString(DlgData));
LFMStream:= TStringStream.Create(DataString);
BinStream:= TStringStream.Create('');
@ -162,7 +162,7 @@ var
begin
try
lfmStringList:= TStringListEx.Create;
lfmStringList.LoadFromFile(UTF8Encode(lfmFileName));
lfmStringList.LoadFromFile(UTF8Encode(WideString(lfmFileName)));
wDlgData:= lfmStringList.Text;
Result:= DialogBox(PWideChar(wDlgData), DlgProc);
finally
@ -262,7 +262,7 @@ begin
end;
DM_LISTINDEXOF:
begin
sText:= UTF8Encode(PWideChar(lParam));
sText:= UTF8Encode(WideString(PWideChar(lParam)));
if Control is TComboBox then
Result:= (Control as TComboBox).Items.IndexOf(sText);
if Control is TListBox then
@ -270,7 +270,7 @@ begin
end;
DM_LISTINSERT:
begin
sText:= UTF8Encode(PWideChar(lParam));
sText:= UTF8Encode(WideString(PWideChar(lParam)));
if Control is TComboBox then
(Control as TComboBox).Items.Insert(wParam, sText);
if Control is TListBox then
@ -316,7 +316,7 @@ begin
end;
DM_LISTUPDATE :
begin
sText:= UTF8Encode(PWideChar(lParam));
sText:= UTF8Encode(WideString(PWideChar(lParam)));
if Control is TComboBox then
(Control as TComboBox).Items[wParam]:= sText;
if Control is TListBox then
@ -424,7 +424,7 @@ begin
end;
DM_SETTEXT:
begin
sText:= UTF8Encode(PWideChar(wParam));
sText:= UTF8Encode(WideString(PWideChar(wParam)));
if Control is TButton then
(Control as TButton).Caption:= sText;
if Control is TComboBox then

3926
src/platform/uOSUtils.pas
View file

File diff suppressed because it is too large Load diff

532
src/platform/ufindex.pas
View file

@ -1,266 +1,266 @@
{
Double Commander
-------------------------------------------------------------------------
This unit contains UTF8 versions of Find(First, Next) functions and other stuff
Copyright (C) 2006-2008 Koblov Alexander (Alexx2000@mail.ru)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit uFindEx;
{$mode objfpc}{$H+}
interface
uses
SysUtils {$IFDEF UNIX}, BaseUnix, UnixUtil, uMyUnix{$ELSE}, Windows{$ENDIF};
{$IFDEF UNIX}
type
TUnixFindData = record
DirPtr: PDir; //en> directory pointer for reading directory
sPath: String; //en> file name path
sMask: String; //en> file name mask
iAttr: LongInt; //en> attribute we are searching for
StatRec: Stat;
end;
PUnixFindData = ^TUnixFindData;
{$ENDIF}
function FindFirstEx (const Path : UTF8String; Attr : Longint; out Rslt : TSearchRec) : Longint;
function FindNextEx (var Rslt : TSearchRec) : Longint;
procedure FindCloseEx(var Rslt: TSearchRec);
function CheckAttrMask(DefaultAttr : Cardinal; sAttr : String; Attr : Cardinal) : Boolean;
implementation
uses LCLProc, uFileOp;
function mbFindMatchingFile(var Rslt: TSearchRec): Integer;
{$IFDEF MSWINDOWS}
var
LocalFileTime: TFileTime;
wFindData: TWin32FindDataW;
pwFindData: PWIN32FINDDATAW absolute Rslt.FindData; // for use PWin32FindDataW instead TWin32FindData
begin
with Rslt do
begin
wFindData:= pwFindData^;
while (wFindData.dwFileAttributes and ExcludeAttr) <> 0 do
if not FindNextFileW(FindHandle, wFindData) then Exit(GetLastError);
pwFindData:= @wFindData;
FileTimeToLocalFileTime(wFindData.ftLastWriteTime, LocalFileTime);
FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo);
Size:= (Int64(wFindData.nFileSizeHigh) shl 32) + wFindData.nFileSizeLow;
Attr:= wFindData.dwFileAttributes;
Name:= UTF8Encode(wFindData.cFileName);
end;
Result:= 0;
end;
{$ELSE}
var
UnixFindData: PUnixFindData;
WinAttr: LongInt;
begin
Result:= -1;
UnixFindData:= PUnixFindData(Rslt.FindHandle);
if UnixFindData = nil then Exit;
if FNMatch(UnixFindData^.sMask, Rslt.Name) then
begin
if fpLStat(UnixFindData^.sPath + Rslt.Name, @UnixFindData^.StatRec) >= 0 then
with UnixFindData^.StatRec do
begin
WinAttr:= LinuxToWinAttr(PChar(Rslt.Name), UnixFindData^.StatRec);
if (WinAttr and UnixFindData^.iAttr) = 0 then Exit;
Rslt.Size:= st_size;
Rslt.Time:= UnixToWinAge(st_mtime);
Rslt.Attr:= st_mode;
end;
Result:= 0;
end;
end;
{$ENDIF}
function FindFirstEx (const Path : UTF8String; Attr : Longint; out Rslt : TSearchRec) : Longint;
{$IFDEF MSWINDOWS}
const
faSpecial = faHidden or faSysFile or faVolumeID or faDirectory;
var
wPath: WideString;
wFindData: TWin32FindDataW;
pwFindData: PWIN32FINDDATAW absolute Rslt.FindData; // for use PWin32FindDataW instead TWin32FindData
begin
wPath:= UTF8Decode(Path);
Rslt.ExcludeAttr:= not Attr and faSpecial;
Rslt.FindHandle:= FindFirstFileW(PWideChar(wPath), wFindData);
// if error then exit
if Rslt.FindHandle = INVALID_HANDLE_VALUE then Exit(GetLastError);
pwFindData:= @wFindData;
Result:= mbFindMatchingFile(Rslt);
end;
{$ELSE}
var
UnixFindData: PUnixFindData;
begin
//DebugLn('FindFirstEx with Path == ', Path);
{ Allocate UnixFindData }
New(UnixFindData);
FillChar(UnixFindData^, SizeOf(UnixFindData^), 0);
Rslt.FindHandle:= UnixFindData;
with UnixFindData^ do
begin
iAttr:= Attr;
sPath:= ExtractFileDir(Path);
sMask:= ExtractFileName(Path);
if sPath = '' then
GetDir(0, sPath);
if sMask = '' then
sMask:= '*';
sPath:= IncludeTrailingBackSlash(sPath);
if (Pos('?', sMask) = 0) and (Pos('*', sMask) = 0) and FileExists(Path) then
begin
Rslt.Name:= sMask;
if mbFindMatchingFile(Rslt) = 0 then
Exit(0);
end;
DirPtr:= fpOpenDir(PChar(sPath));
end;
Result:= FindNextEx(Rslt);
end;
{$ENDIF}
function FindNextEx (var Rslt : TSearchRec) : Longint;
{$IFDEF MSWINDOWS}
var
wFindData: TWin32FindDataW;
pwFindData: PWIN32FINDDATAW absolute Rslt.FindData; // for use PWin32FindDataW instead TWin32FindData
begin
wFindData:= pwFindData^;
if FindNextFileW(Rslt.FindHandle, wFindData) then
begin
pwFindData:= @wFindData;
Result:= mbFindMatchingFile(Rslt);
end
else
Result:= GetLastError;
end;
{$ELSE}
var
UnixFindData: PUnixFindData absolute Rslt.FindHandle;
PtrDirEnt: pDirent;
begin
Result:= -1;
if UnixFindData = nil then Exit;
if UnixFindData^.DirPtr = nil then Exit;
PtrDirEnt:= fpReadDir(UnixFindData^.DirPtr);
while PtrDirEnt <> nil do
begin
Rslt.Name:= PtrDirEnt^.d_name;
Result:= mbFindMatchingFile(Rslt);
if Result = 0 then // if found then exit
Exit
else // else read next
PtrDirEnt:= fpReadDir(UnixFindData^.DirPtr);
end;
end;
{$ENDIF}
procedure FindCloseEx(var Rslt: TSearchRec);
{$IFDEF MSWINDOWS}
begin
if Rslt.FindHandle <> INVALID_HANDLE_VALUE then
Windows.FindClose(Rslt.FindHandle);
end;
{$ELSE}
var
UnixFindData: PUnixFindData absolute Rslt.FindHandle;
begin
if UnixFindData = nil then Exit;
if UnixFindData^.DirPtr <> nil then
fpCloseDir(UnixFindData^.DirPtr);
Dispose(UnixFindData);
Rslt.FindHandle:= nil;
end;
{$ENDIF}
function CheckAttrMask(DefaultAttr : Cardinal; sAttr : String; Attr : Cardinal) : Boolean;
{$IFDEF WINDOWS}
begin
Result := True;
if (DefaultAttr <> 0) and (DefaultAttr <> faAnyFile) then
Result := (Attr and DefaultAttr) = DefaultAttr;
if Length(sAttr) < 4 then Exit;
if Result then
begin
if sAttr[1] = 'r' then Result := Result and ((Attr and faReadOnly) = faReadOnly)
else if sAttr[1] = '-' then Result := Result and ((Attr and faReadOnly) <> faReadOnly);
//WriteLN('After r == ', BoolToStr(Result));
if sAttr[2] = 'a' then Result := Result and ((Attr and faArchive) = faArchive)
else if sAttr[2] = '-' then Result := Result and ((Attr and faArchive) <> faArchive);
//WriteLN('After a == ', BoolToStr(Result));
if sAttr[3] = 'h' then Result := Result and ((Attr and faHidden) = faHidden)
else if sAttr[3] = '-' then Result := Result and ((Attr and faHidden) <> faHidden);
//WriteLN('After h == ', BoolToStr(Result));
if sAttr[4] = 's' then Result := Result and ((Attr and faSysFile) = faSysFile)
else if sAttr[4] = '-' then Result := Result and ((Attr and faSysFile) <> faSysFile);
end;
end;
{$ELSE}
begin
Result := True;
if (DefaultAttr <> 0) and (DefaultAttr <> faAnyFile) then
begin
if Boolean(DefaultAttr and faDirectory) then
Result := Result and fpS_ISDIR(Attr);
DebugLn('Result do == ', BoolToStr(Result));
if Boolean(DefaultAttr and faSymLink) then
Result := Result and ((Attr and S_IFLNK) = S_IFLNK);
DebugLn('Result after == ', BoolToStr(Result));
end;
if Length(sAttr) < 9 then Exit;
if sAttr[1]='r' then Result:=Result and ((Attr AND S_IRUSR) = S_IRUSR)
else if sAttr[1]='-' then Result:=Result and ((Attr AND S_IRUSR) <> S_IRUSR);
if sAttr[2]='w' then Result:=Result and ((Attr AND S_IWUSR) = S_IWUSR)
else if sAttr[2]='-' then Result:=Result and ((Attr AND S_IWUSR) <> S_IWUSR);
if sAttr[3]='x' then Result:=Result and ((Attr AND S_IXUSR) = S_IXUSR)
else if sAttr[3]='-' then Result:=Result and ((Attr AND S_IXUSR) <> S_IXUSR);
if sAttr[4]='r' then Result:=Result and ((Attr AND S_IRGRP) = S_IRGRP)
else if sAttr[4]='-' then Result:=Result and ((Attr AND S_IRGRP) <> S_IRGRP);
if sAttr[5]='w' then Result:=Result and ((Attr AND S_IWGRP) = S_IWGRP)
else if sAttr[5]='-' then Result:=Result and ((Attr AND S_IWGRP) <> S_IWGRP);
if sAttr[6]='x' then Result:=Result and ((Attr AND S_IXGRP) = S_IXGRP)
else if sAttr[6]='-' then Result:=Result and ((Attr AND S_IXGRP) <> S_IXGRP);
if sAttr[7]='r' then Result:=Result and ((Attr AND S_IROTH) = S_IROTH)
else if sAttr[7]='-' then Result:=Result and ((Attr AND S_IROTH) <> S_IROTH);
if sAttr[8]='w' then Result:=Result and ((Attr AND S_IWOTH) = S_IWOTH)
else if sAttr[8]='-' then Result:=Result and ((Attr AND S_IWOTH) <> S_IWOTH);
if sAttr[9]='x' then Result:=Result and ((Attr AND S_IXOTH) = S_IXOTH)
else if sAttr[9]='-' then Result:=Result and ((Attr AND S_IXOTH) <> S_IXOTH);
if sAttr[3]='s' then Result:=Result and ((Attr AND S_ISUID) = S_ISUID);
if sAttr[6]='s' then Result:=Result and ((Attr AND S_ISGID) = S_ISGID);
end;
{$ENDIF}
end.
{
Double Commander
-------------------------------------------------------------------------
This unit contains UTF8 versions of Find(First, Next) functions and other stuff
Copyright (C) 2006-2008 Koblov Alexander (Alexx2000@mail.ru)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
}
unit uFindEx;
{$mode objfpc}{$H+}
interface
uses
SysUtils {$IFDEF UNIX}, BaseUnix, UnixUtil, uMyUnix{$ELSE}, Windows{$ENDIF};
{$IFDEF UNIX}
type
TUnixFindData = record
DirPtr: PDir; //en> directory pointer for reading directory
sPath: String; //en> file name path
sMask: String; //en> file name mask
iAttr: LongInt; //en> attribute we are searching for
StatRec: Stat;
end;
PUnixFindData = ^TUnixFindData;
{$ENDIF}
function FindFirstEx (const Path : UTF8String; Attr : Longint; out Rslt : TSearchRec) : Longint;
function FindNextEx (var Rslt : TSearchRec) : Longint;
procedure FindCloseEx(var Rslt: TSearchRec);
function CheckAttrMask(DefaultAttr : Cardinal; sAttr : String; Attr : Cardinal) : Boolean;
implementation
uses LCLProc, uFileOp;
function mbFindMatchingFile(var Rslt: TSearchRec): Integer;
{$IFDEF MSWINDOWS}
var
LocalFileTime: TFileTime;
wFindData: TWin32FindDataW;
pwFindData: PWIN32FINDDATAW absolute Rslt.FindData; // for use PWin32FindDataW instead TWin32FindData
begin
with Rslt do
begin
wFindData:= pwFindData^;
while (wFindData.dwFileAttributes and ExcludeAttr) <> 0 do
if not FindNextFileW(FindHandle, wFindData) then Exit(GetLastError);
pwFindData:= @wFindData;
FileTimeToLocalFileTime(wFindData.ftLastWriteTime, LocalFileTime);
FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo);
Size:= (Int64(wFindData.nFileSizeHigh) shl 32) + wFindData.nFileSizeLow;
Attr:= wFindData.dwFileAttributes;
Name:= UTF8Encode(WideString(wFindData.cFileName));
end;
Result:= 0;
end;
{$ELSE}
var
UnixFindData: PUnixFindData;
WinAttr: LongInt;
begin
Result:= -1;
UnixFindData:= PUnixFindData(Rslt.FindHandle);
if UnixFindData = nil then Exit;
if FNMatch(UnixFindData^.sMask, Rslt.Name) then
begin
if fpLStat(UnixFindData^.sPath + Rslt.Name, @UnixFindData^.StatRec) >= 0 then
with UnixFindData^.StatRec do
begin
WinAttr:= LinuxToWinAttr(PChar(Rslt.Name), UnixFindData^.StatRec);
if (WinAttr and UnixFindData^.iAttr) = 0 then Exit;
Rslt.Size:= st_size;
Rslt.Time:= UnixToWinAge(st_mtime);
Rslt.Attr:= st_mode;
end;
Result:= 0;
end;
end;
{$ENDIF}
function FindFirstEx (const Path : UTF8String; Attr : Longint; out Rslt : TSearchRec) : Longint;
{$IFDEF MSWINDOWS}
const
faSpecial = faHidden or faSysFile or faVolumeID or faDirectory;
var
wPath: WideString;
wFindData: TWin32FindDataW;
pwFindData: PWIN32FINDDATAW absolute Rslt.FindData; // for use PWin32FindDataW instead TWin32FindData
begin
wPath:= UTF8Decode(Path);
Rslt.ExcludeAttr:= not Attr and faSpecial;
Rslt.FindHandle:= FindFirstFileW(PWideChar(wPath), wFindData);
// if error then exit
if Rslt.FindHandle = INVALID_HANDLE_VALUE then Exit(GetLastError);
pwFindData:= @wFindData;
Result:= mbFindMatchingFile(Rslt);
end;
{$ELSE}
var
UnixFindData: PUnixFindData;
begin
//DebugLn('FindFirstEx with Path == ', Path);
{ Allocate UnixFindData }
New(UnixFindData);
FillChar(UnixFindData^, SizeOf(UnixFindData^), 0);
Rslt.FindHandle:= UnixFindData;
with UnixFindData^ do
begin
iAttr:= Attr;
sPath:= ExtractFileDir(Path);
sMask:= ExtractFileName(Path);
if sPath = '' then
GetDir(0, sPath);
if sMask = '' then
sMask:= '*';
sPath:= IncludeTrailingBackSlash(sPath);
if (Pos('?', sMask) = 0) and (Pos('*', sMask) = 0) and FileExists(Path) then
begin
Rslt.Name:= sMask;
if mbFindMatchingFile(Rslt) = 0 then
Exit(0);
end;
DirPtr:= fpOpenDir(PChar(sPath));
end;
Result:= FindNextEx(Rslt);
end;
{$ENDIF}
function FindNextEx (var Rslt : TSearchRec) : Longint;
{$IFDEF MSWINDOWS}
var
wFindData: TWin32FindDataW;
pwFindData: PWIN32FINDDATAW absolute Rslt.FindData; // for use PWin32FindDataW instead TWin32FindData
begin
wFindData:= pwFindData^;
if FindNextFileW(Rslt.FindHandle, wFindData) then
begin
pwFindData:= @wFindData;
Result:= mbFindMatchingFile(Rslt);
end
else
Result:= GetLastError;
end;
{$ELSE}
var
UnixFindData: PUnixFindData absolute Rslt.FindHandle;
PtrDirEnt: pDirent;
begin
Result:= -1;
if UnixFindData = nil then Exit;
if UnixFindData^.DirPtr = nil then Exit;
PtrDirEnt:= fpReadDir(UnixFindData^.DirPtr);
while PtrDirEnt <> nil do
begin
Rslt.Name:= PtrDirEnt^.d_name;
Result:= mbFindMatchingFile(Rslt);
if Result = 0 then // if found then exit
Exit
else // else read next
PtrDirEnt:= fpReadDir(UnixFindData^.DirPtr);
end;
end;
{$ENDIF}
procedure FindCloseEx(var Rslt: TSearchRec);
{$IFDEF MSWINDOWS}
begin
if Rslt.FindHandle <> INVALID_HANDLE_VALUE then
Windows.FindClose(Rslt.FindHandle);
end;
{$ELSE}
var
UnixFindData: PUnixFindData absolute Rslt.FindHandle;
begin
if UnixFindData = nil then Exit;
if UnixFindData^.DirPtr <> nil then
fpCloseDir(UnixFindData^.DirPtr);
Dispose(UnixFindData);
Rslt.FindHandle:= nil;
end;
{$ENDIF}
function CheckAttrMask(DefaultAttr : Cardinal; sAttr : String; Attr : Cardinal) : Boolean;
{$IFDEF WINDOWS}
begin
Result := True;
if (DefaultAttr <> 0) and (DefaultAttr <> faAnyFile) then
Result := (Attr and DefaultAttr) = DefaultAttr;
if Length(sAttr) < 4 then Exit;
if Result then
begin
if sAttr[1] = 'r' then Result := Result and ((Attr and faReadOnly) = faReadOnly)
else if sAttr[1] = '-' then Result := Result and ((Attr and faReadOnly) <> faReadOnly);
//WriteLN('After r == ', BoolToStr(Result));
if sAttr[2] = 'a' then Result := Result and ((Attr and faArchive) = faArchive)
else if sAttr[2] = '-' then Result := Result and ((Attr and faArchive) <> faArchive);
//WriteLN('After a == ', BoolToStr(Result));
if sAttr[3] = 'h' then Result := Result and ((Attr and faHidden) = faHidden)
else if sAttr[3] = '-' then Result := Result and ((Attr and faHidden) <> faHidden);
//WriteLN('After h == ', BoolToStr(Result));
if sAttr[4] = 's' then Result := Result and ((Attr and faSysFile) = faSysFile)
else if sAttr[4] = '-' then Result := Result and ((Attr and faSysFile) <> faSysFile);
end;
end;
{$ELSE}
begin
Result := True;
if (DefaultAttr <> 0) and (DefaultAttr <> faAnyFile) then
begin
if Boolean(DefaultAttr and faDirectory) then
Result := Result and fpS_ISDIR(Attr);
DebugLn('Result do == ', BoolToStr(Result));
if Boolean(DefaultAttr and faSymLink) then
Result := Result and ((Attr and S_IFLNK) = S_IFLNK);
DebugLn('Result after == ', BoolToStr(Result));
end;
if Length(sAttr) < 9 then Exit;
if sAttr[1]='r' then Result:=Result and ((Attr AND S_IRUSR) = S_IRUSR)
else if sAttr[1]='-' then Result:=Result and ((Attr AND S_IRUSR) <> S_IRUSR);
if sAttr[2]='w' then Result:=Result and ((Attr AND S_IWUSR) = S_IWUSR)
else if sAttr[2]='-' then Result:=Result and ((Attr AND S_IWUSR) <> S_IWUSR);
if sAttr[3]='x' then Result:=Result and ((Attr AND S_IXUSR) = S_IXUSR)
else if sAttr[3]='-' then Result:=Result and ((Attr AND S_IXUSR) <> S_IXUSR);
if sAttr[4]='r' then Result:=Result and ((Attr AND S_IRGRP) = S_IRGRP)
else if sAttr[4]='-' then Result:=Result and ((Attr AND S_IRGRP) <> S_IRGRP);
if sAttr[5]='w' then Result:=Result and ((Attr AND S_IWGRP) = S_IWGRP)
else if sAttr[5]='-' then Result:=Result and ((Attr AND S_IWGRP) <> S_IWGRP);
if sAttr[6]='x' then Result:=Result and ((Attr AND S_IXGRP) = S_IXGRP)
else if sAttr[6]='-' then Result:=Result and ((Attr AND S_IXGRP) <> S_IXGRP);
if sAttr[7]='r' then Result:=Result and ((Attr AND S_IROTH) = S_IROTH)
else if sAttr[7]='-' then Result:=Result and ((Attr AND S_IROTH) <> S_IROTH);
if sAttr[8]='w' then Result:=Result and ((Attr AND S_IWOTH) = S_IWOTH)
else if sAttr[8]='-' then Result:=Result and ((Attr AND S_IWOTH) <> S_IWOTH);
if sAttr[9]='x' then Result:=Result and ((Attr AND S_IXOTH) = S_IXOTH)
else if sAttr[9]='-' then Result:=Result and ((Attr AND S_IXOTH) <> S_IXOTH);
if sAttr[3]='s' then Result:=Result and ((Attr AND S_ISUID) = S_ISUID);
if sAttr[6]='s' then Result:=Result and ((Attr AND S_ISGID) = S_ISGID);
end;
{$ENDIF}
end.

4
src/platform/win/ushlobjadditional.pas
View file

@ -1848,7 +1848,7 @@ var
ShellHandle: THandle;
SHChangeIcon: TSHChangeIconProc;
SHChangeIconW: TSHChangeIconProcW;
Buf: array[0..MAX_PATH] of Char;
Buf: array[0..MAX_PATH] of AnsiChar;
BufW: array[0..MAX_PATH] of WideChar;
begin
Result := False;
@ -1869,7 +1869,7 @@ begin
BufW := UTF8Decode(FileName);
Result := SHChangeIconW(hOwner, BufW, SizeOf(BufW), IconIndex) = 1;
if Result then
FileName := UTF8Encode(BufW);
FileName := UTF8Encode(WideString(BufW));
end
else if Assigned(SHChangeIcon) then
begin