mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-21 09:58:13 +00:00
Code Issues Projects Releases Packages Wiki Activity

ADD: Some fixes for bug [ 1696012 ] копрование в линуксе

Browse source
This commit is contained in:
Alexander Koblov 2007-05-13 12:59:12 +00:00
commit fa983cd351
6 changed files with 765 additions and 314 deletions
Download patch file Download diff file Expand all files Collapse all files

299
uNTFSLinks.pas
View file

@ -1,8 +1,8 @@
unit uNTFSLinks;
{
Create link(s) on NTFS.
Create and read link(s) on NTFS.
Based on:
*** Based on: ***
}
{ **** UBPFD *********** by kladovka.net.ru ****
>> Ñîçäàíèå hardlink è symbolic link.
@ -16,6 +16,21 @@ Symbolic link
Copyright: http://home.earthlink.net/~akonshin/files/xlink.zip
Äàòà: 30 äåêàáðÿ 2002 ã.
********************************************** }
{
*** and ***
}
//====================================================================
// Junction creation and listing utility, based on Junction.c source
// by Mark Russinovich, http://www.sysinternals.com. Thanks Mark!
//
// Note: targets of some rare reparse point types are not recognized,
// as in Mark's source.
//
// (C) Alexey Torgashin, http://alextpp.narod.ru, atorg@yandex.ru
// 18.02.06 - initial version
//====================================================================
interface
uses
@ -29,15 +44,44 @@ type
lo: LongWord;
hi: LongInt;
end;
TReparsePointType = (
slUnknown,
slJunction,
slMountPoint,
slSymLink,
slHSM,
slSIS,
slDFS
);
const
FILE_DOES_NOT_EXIST = DWORD(-1);
FILE_ATTRIBUTE_DEVICE = $00000040;
FILE_ATTRIBUTE_SPARSE_FILE = $00000200;
FILE_ATTRIBUTE_REPARSE_POINT = $00000400;
FILE_ATTRIBUTE_OFFLINE = $00001000;
FILE_ATTRIBUTE_NOT_CONTENT_INDEXED = $00002000;
FILE_ATTRIBUTE_ENCRYPTED = $00004000;
SReparsePointType: array[TReparsePointType] of PChar = (
'Unknown point type',
'Junction',
'Mount Point',
'Symbolic Link',
'Hierarchical Storage Management point',
'Single Instance Store point',
'Distributed File System point'
);
(* To create symbolic link (works on Windows 2k/XP for directories only) *)
function CreateSymlink( ATargetName, ALinkName: String; const options: TOptions = []): Boolean;
(* To create hardlink(s) (works only for files) *)
procedure CreateHardlink( AFileName, ALinkName: String; options: TOptions = []);
function FCreateSymlink(const fnLink, fnTarget: WideString): boolean;
function FGetSymlinkInfo(const fn: WideString; var Target: WideString; var LinkType: TReparsePointType): boolean;
function FDeleteSymlink(const fn: WideString): boolean;
function FDriveSupportsSymlinks(const fn: WideString): boolean;
implementation
//=============================================================
@ -399,12 +443,28 @@ const
FILE_FLAG_OPEN_REPARSE_POINT = $00200000;
FILE_ATTRIBUTE_REPARSE_POINT = $00000400;
IO_REPARSE_TAG_MOUNT_POINT = $A0000003;
REPARSE_MOUNTPOINT_HEADER_SIZE = 8;
MAX_REPARSE_SIZE = 17000;
MAX_NAME_LENGTH = 1024;
IO_REPARSE_TAG_RESERVED_ZERO = $000000000;
IO_REPARSE_TAG_SYMBOLIC_LINK = IO_REPARSE_TAG_RESERVED_ZERO;
IO_REPARSE_TAG_RESERVED_ONE = $000000001;
IO_REPARSE_TAG_RESERVED_RANGE = $000000001;
IO_REPARSE_TAG_VALID_VALUES = $0E000FFFF;
IO_REPARSE_TAG_HSM = $0C0000004;
IO_REPARSE_TAG_NSS = $080000005;
IO_REPARSE_TAG_NSSRECOVER = $080000006;
IO_REPARSE_TAG_SIS = $080000007;
IO_REPARSE_TAG_DFS = $080000008;
IO_REPARSE_TAG_MOUNT_POINT = $0A0000003;
FILE_SUPPORTS_REPARSE_POINTS = $00000080;
type
REPARSE_MOUNTPOINT_DATA_BUFFER = packed record
ReparseTag : DWORD;
@ -418,6 +478,18 @@ type
TReparseMountpointDataBuffer = REPARSE_MOUNTPOINT_DATA_BUFFER;
PReparseMountpointDataBuffer = ^TReparseMountpointDataBuffer;
REPARSE_DATA_BUFFER = packed record
ReparseTag: DWORD;
ReparseDataLength: Word;
Reserved: Word;
SubstituteNameOffset: Word;
SubstituteNameLength: Word;
PrintNameOffset: Word;
PrintNameLength: Word;
PathBuffer: array[0..0] of WideChar;
end;
TReparseDataBuffer = REPARSE_DATA_BUFFER;
PReparseDataBuffer = ^TReparseDataBuffer;
//-------------------------------------------------------------
function CreateSymlink( ATargetName, ALinkName: String; const options: TOptions ): Boolean;
@ -637,4 +709,221 @@ begin
end;
}
//-------------------------------------------------------------
procedure Log(const msg: string);
begin
//Writeln(msg);
end;
//-------------------------------------------------------------
const
Prefix: WideString = '\??\';
function FCreateSymlink(const fnLink, fnTarget: WideString): boolean;
var
h: THandle;
Buffer: PReparseMountPointDataBuffer;
BufSize: integer;
TargetName: WideString;
BytesRead: DWORD;
begin
Result:= false;
if FileExists(fnLink) then
begin
Log('Target already exists');
Exit
end;
if not CreateDirectoryW(PWChar(fnLink), nil) then
begin
Log('CreateDirectoryW failed');
Exit
end;
h:= CreateFileW(PWChar(fnLink), GENERIC_WRITE, 0, nil, OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT or FILE_FLAG_BACKUP_SEMANTICS, 0);
if h=INVALID_HANDLE_VALUE then
begin
Log('CreateFileW failed');
RemoveDirectoryW(PWChar(fnLink));
Exit
end;
TargetName:= Prefix+fnTarget;
BufSize:= (Length(Prefix)+Length(fnTarget)+1)*2+REPARSE_MOUNTPOINT_HEADER_SIZE+12;
GetMem(Buffer, BufSize);
FillChar(Buffer^, BufSize, 0);
with Buffer^ do
begin
Move(TargetName[1], ReparseTarget, (Length(TargetName)+1)*2);
ReparseTag:= IO_REPARSE_TAG_MOUNT_POINT;
ReparseTargetLength:= Length(TargetName)*2;
ReparseTargetMaximumLength:= ReparseTargetLength+2;
ReparseDataLength:= ReparseTargetLength+12;
end;
{
with Buffer^ do
begin
Writeln('Reparse info:');
Writeln('ReparseTargetLength: ', ReparseTargetLength);
Writeln('ReparseTarget: "', string(ReparseTarget), '"');
end;
}
BytesRead:= 0;
Result:= DeviceIoControl(h, FSCTL_SET_REPARSE_POINT,
Buffer, Buffer^.ReparseDataLength+REPARSE_MOUNTPOINT_HEADER_SIZE, nil, 0,
BytesRead, nil);
if not Result then
begin
Log('DeviceIoControl failed');
Sleep(500); //for RemoveDirectoryW to work
RemoveDirectoryW(PWChar(fnLink));
end;
FreeMem(Buffer);
CloseHandle(h);
end;
//-------------------------------------------------------------
function FGetSymlinkInfo(const fn: WideString; var Target: WideString; var LinkType: TReparsePointType): boolean;
var
attr: DWORD;
h: THandle;
reparseBuffer: array[0..MAX_REPARSE_SIZE-1] of char;
reparseInfo: PReparseDataBuffer;
reparseData: pointer;
//reparseData1,
reparseData2: PWChar;
//name1,
name2: array[0..MAX_NAME_LENGTH-1] of WideChar;
returnedLength: DWORD;
control: boolean;
begin
Result:= false;
Target:= '';
LinkType:= slUnknown;
attr:= GetFileAttributesW(PWChar(fn));
if (attr and FILE_ATTRIBUTE_REPARSE_POINT)=0 then Exit;
if (attr and FILE_ATTRIBUTE_DIRECTORY)<>0 then
h:= CreateFileW(PWChar(fn), 0,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil,
OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0)
else
h:= CreateFileW(PWChar(fn), 0,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil,
OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT, 0);
if h=INVALID_HANDLE_VALUE then
begin
Log('CreateFileW failed');
Exit
end;
reparseInfo:= @reparseBuffer;
control:= DeviceIoControl(h, FSCTL_GET_REPARSE_POINT,
nil, 0, reparseInfo, SizeOf(reparseBuffer),
returnedLength, nil);
CloseHandle(h);
if not control then
begin
Log('DeviceIoControl failed');
Exit
end;
case reparseInfo^.ReparseTag of
IO_REPARSE_TAG_MOUNT_POINT:
begin
reparseData:= @reparseInfo.PathBuffer;
{
FillChar(name1, SizeOf(name1), 0);
reparseData1:= pointer(integer(reparseData)+reparseInfo.PrintNameOffset);
lstrcpynW(name1, reparseData1, reparseInfo.PrintNameLength);
}
FillChar(name2, SizeOf(name2), 0);
reparseData2:= pointer(integer(reparseData)+reparseInfo.SubstituteNameOffset);
lstrcpynW(name2, reparseData2, reparseInfo.SubstituteNameLength);
Target:= name2;
if Pos(Prefix, Target)=1 then
Delete(Target, 1, Length(Prefix));
if Pos(':', Target)>0
then LinkType:= slJunction
else LinkType:= slMountPoint;
Result:= true;
end;
IO_REPARSE_TAG_SYMBOLIC_LINK or $80000000:
begin
reparseData:= @reparseInfo.PathBuffer;
{
FillChar(name1, SizeOf(name1), 0);
reparseData1:= pointer(integer(reparseData)+reparseInfo.PrintNameOffset);
lstrcpynW(name1, reparseData1, reparseInfo.PrintNameLength);
}
FillChar(name2, SizeOf(name2), 0);
reparseData2:= pointer(integer(reparseData)+reparseInfo.SubstituteNameOffset);
lstrcpynW(name2, reparseData2, reparseInfo.SubstituteNameLength);
Target:= name2;
LinkType:= slSymLink;
Result:= true;
end;
IO_REPARSE_TAG_HSM:
begin
LinkType:= slHSM;
Result:= true;
end;
IO_REPARSE_TAG_SIS:
begin
LinkType:= slSIS;
Result:= true;
end;
IO_REPARSE_TAG_DFS:
begin
LinkType:= slDFS;
Result:= true;
end;
end;
end;
//-------------------------------------------------------------
function FDeleteSymlink(const fn: WideString): boolean;
begin
Result:= RemoveDirectoryW(PWChar(fn));
end;
//-------------------------------------------------------------
function FDriveSupportsSymlinks(const fn: WideString): boolean;
var
disk: char;
buf1, buf2: array[0..50] of char;
Serial, NameLen, Flags: DWORD;
begin
Result:= false;
if (fn='') or (Pos(':\', fn)<>2) then Exit;
disk:= char(fn[1]);
FillChar(buf1, SizeOf(buf1), 0);
FillChar(buf2, SizeOf(buf2), 0);
if GetVolumeInformation(PChar(disk+':\'), @buf1, SizeOf(buf1),
@Serial, NameLen, Flags, @buf2, SizeOf(buf2)) then
Result:= (Flags and FILE_SUPPORTS_REPARSE_POINTS)<>0;
end;
end.

28
uOSUtils.pas
View file

@ -90,6 +90,7 @@ function ExecCmdFork(const sCmd:String):Integer;
function GetDiskFreeSpace(Path : String; var FreeSize, TotalSize : Int64) : Boolean;
function CreateHardLink(Path, LinkName: string) : Boolean;
function CreateSymLink(Path, LinkName: string) : Boolean;
function ReadSymLink(LinkName : String) : String;
function GetHomeDir : String;
function GetLastDir(Path : String) : String;
@ -186,7 +187,7 @@ begin
end;
{$ELSE}
begin
Result := (fplink(PChar(@Path[1]),PChar(@LinkName[1]))=0);
Result := (fplink(PChar(@Path[1]),PChar(@LinkName[1]))=0);
end;
{$ENDIF}
@ -202,7 +203,30 @@ begin
end;
{$ELSE}
begin
Result := (fpsymlink(PChar(@Path[1]),PChar(@LinkName[1]))=0);
Result := (fpsymlink(PChar(@Path[1]),PChar(@LinkName[1]))=0);
end;
{$ENDIF}
(* Get symlink target *)
function ReadSymLink(LinkName : String) : String;
{$IFDEF WIN32}
var
Target: WideString;
LinkType: TReparsePointType;
begin
try
if uNTFSLinks.FGetSymlinkInfo(LinkName, Target, LinkType) then
Result := Target
else
Result := '';
except
Result := '';
end;
end;
{$ELSE}
begin
Result := fpReadlink(LinkName);
end;
{$ENDIF}

26
ucopythread.pas
View file

@ -83,20 +83,20 @@ begin
FFileOpDlg.sFileName:=ExtractFileName(fr^.sName)+' -> '+fr^.sPath+sDstNew;
Synchronize(@FFileOpDlg.UpdateDlg);
if FPS_ISLNK(fr^.iMode) then
begin
// use sDstName as link target
{$IFNDEF WIN32} // Alexx2000
sDstName:=fpReadlink(fr^.sName);
{$ENDIF}
if sDstName<>'' then
begin
if not CreateSymlink(fr^.sName, sDstName) then
writeln('Symlink error:');
// use sDstName as link target
sDstName:=ReadSymLink(fr^.sName);
if sDstName<>'' then
begin
sDstName := GetAbsoluteFileName(ExtractFilePath(fr^.sName), sDstName);
WriteLN('ReadSymLink := ' + sDstName);
if not CreateSymlink(sDstName, sDst+fr^.sPath+sDstNew) then
writeln('Symlink error:');
end
else
writeln('Error reading link');
Result:=True;
end
else
writeln('Error reading link');
Result:=True;
end
else
if FPS_ISDIR(fr^.iMode) then
begin
@ -123,7 +123,7 @@ begin
end;
end;
Result:=CopyFile(fr^.sName, sDst+fr^.sPath+sDstNew, FAppend);
end;
end; // files and other stuff
end;
Function TCopyThread.CopyFile(const sSrc, sDst:String; bAppend:Boolean):Boolean;

621
udcutils.pas
View file

@ -1,287 +1,334 @@
{
Double Commander
----------------------------
Licence : GNU GPL v 2.0
Author : Alexander Koblov (Alexx2000@mail.ru)
Several useful functions
contributors:
Radek Cervinka <radek.cervinka@centrum.cz>
Part of this code got from http://www.delphirus.com.ru
}
unit uDCUtils;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Graphics;
Function cnvFormatFileSize(iSize:Int64):String;
Function MinimizeFilePath(const PathToMince: String; Canvas: TCanvas;
MaxLen: Integer): String;
function G_ValidateWildText(const S, Mask: string; bCaseSens : Boolean = False; MaskChar: Char = '?';
WildCard: Char = '*'): Boolean;
procedure DivFileName(const sFileName:String; var n,e:String);
implementation
uses
uGlobs;
Function cnvFormatFileSize(iSize:Int64):String;
var
d:double;
begin
// writeln(iSize);
if gShortFileSizeFormat then
begin
// TODo Giga
if iSize div (1024*1024) >0 then
begin
// writeln('Div:',Trunc(iSize*10 /(1024*1024))/10);
Result:=FloatToStrF((iSize*10 div (1024*1024))/10, ffFixed, 15, 1)+'M'
end
else
if iSize div 1024 >0 then
begin
Result:=FloatToStrF((iSize*10 div 1024)/10, ffFixed, 15, 1)+'K'
end
else
Result:=IntToStr(iSize);
end
else
begin
d:=iSize;
Result:=Format('%8.0n',[d]);
end;
end;
{=========================================================}
Function MinimizeFilePath(const PathToMince: String; Canvas: TCanvas;
MaxLen: Integer): String;
{=========================================================}
// "C:\Program Files\Delphi\DDropTargetDemo\main.pas"
// "C:\Program Files\..\main.pas"
Var
sl: TStringList;
sHelp, sFile,
sFirst: String;
iPos: Integer;
Begin
sHelp := PathToMince;
iPos := Pos(PathDelim, sHelp);
If iPos = 0 Then
Begin
Result := PathToMince;
End
Else
Begin
sl := TStringList.Create;
// Decode string
While iPos <> 0 Do
Begin
sl.Add(Copy(sHelp, 1, (iPos - 1)));
sHelp := Copy(sHelp, (iPos + 1), Length(sHelp));
iPos := Pos(PathDelim, sHelp);
End;
If sHelp <> '' Then
Begin
sl.Add(sHelp);
End;
// Encode string
sFirst := sl[0];
sFile := sl[sl.Count - 1];
sl.Delete(sl.Count - 1);
Result := '';
MaxLen := MaxLen - Canvas.TextWidth('XXX');
if (sl.Count <> 0) and (Canvas.TextWidth(Result + sl[0] + PathDelim + sFile) < MaxLen) then
begin
While (sl.Count <> 0) and (Canvas.TextWidth(Result + sl[0] + PathDelim + sFile) < MaxLen) Do
Begin
Result := Result + sl[0] + PathDelim;
sl.Delete(0);
End;
If sl.Count = 0 Then
Begin
Result := Result + sFile;
End
Else
Begin
Result := Result + '..' + PathDelim + sFile;
End;
end
else
If sl.Count = 0 Then
Begin
Result := sFirst + PathDelim;
End
Else
Begin
Result := sFirst + PathDelim + '..' + PathDelim + sFile;
End;
sl.Free;
End;
//WriteLN('PathX ' , Result);
if Canvas.TextWidth(Result) > MaxLen + Canvas.TextWidth('XXX') then
begin
while Canvas.TextWidth(Result) > MaxLen do
begin
Delete(Result, Length(Result), 1);
end;
Result := Copy(Result, 1, Length(Result) - 3) + '...';
end;
End;
procedure DivFileName(const sFileName:String; var n,e:String);
var
i:Integer;
begin
for i:= length(sFileName) downto 1 do
if sFileName[i]='.' then
begin
// if i>1 then // hidden files??
e:=Copy(sFileName,i,Length(sFileName)-i+1);
n:=Copy(sFileName,1,i-1);
Exit;
end;
e:='';
n:=sFileName;
end;
function CharPos(C: Char; const S: string; StartPos: Integer = 1): Integer; overload;
var
sNewStr : String;
begin
if StartPos <> 1 then
begin
sNewStr := Copy(S, StartPos, Length(S) - StartPos + 1);
Result := Pos(C, sNewStr);
if Result <> 0 then
Result := Result + StartPos - 1;
end
else
Result := Pos(C, S);
end;
{
This function based on G_ValidateWildText from AcedUtils
http://acedutils.narod.ru/AcedUtils.zip
}
function G_ValidateWildText(const S, Mask: string; bCaseSens : Boolean = False; MaskChar: Char = '?';
WildCard: Char = '*'): Boolean;
label
99;
var
L, X, X0, Q: Integer;
P, P1, B: PChar;
C: Char;
sUpperS,
sUpperMask : String;
begin
if not bCaseSens then
begin
sUpperS := UpperCase(S);
sUpperMask := UpperCase(Mask);
end
else
begin
sUpperS := S;
sUpperMask := Mask;
end;
X := Pos(WildCard, sUpperMask);
Result := False;
if X = 0 then
begin
L := Length(sUpperMask);
if (L > 0) and (L = Length(sUpperS)) then
begin
P := Pointer(sUpperS);
B := Pointer(sUpperMask);
repeat
C := B^;
if (C <> MaskChar) and (C <> P^) then
Exit;
Dec(L);
Inc(B);
Inc(P);
until L = 0;
Result := True;
end;
Exit;
end;
L := Length(sUpperS);
P := Pointer(sUpperS);
B := Pointer(sUpperMask);
Q := X - 1;
if L < Q then
Exit;
while Q > 0 do
begin
C := B^;
if (C <> MaskChar) and (C <> P^) then
Exit;
Dec(Q);
Inc(B);
Inc(P);
end;
Dec(L, X - 1);
repeat
X0 := X;
P1 := P;
while sUpperMask[X0] = WildCard do
Inc(X0);
X := CharPos(WildCard, sUpperMask, X0);
if X = 0 then
Break;
99:
P := P1;
B := @sUpperMask[X0];
Q := X - X0;
if L < Q then
Exit;
while Q > 0 do
begin
C := B^;
if (C <> MaskChar) and (C <> P^) then
begin
Inc(P1);
Dec(L);
goto 99;
end;
Dec(Q);
Inc(B);
Inc(P);
end;
Dec(L, X - X0);
until False;
X := Length(sUpperMask);
if L >= X - X0 + 1 then
begin
P := Pointer(sUpperS);
Inc(P, Length(sUpperS) - 1);
while X >= X0 do
begin
C := sUpperMask[X];
if (C <> MaskChar) and (C <> P^) then
Exit;
Dec(X);
Dec(P);
end;
Result := True;
end;
end;
end.
{
Double Commander
----------------------------
Licence : GNU GPL v 2.0
Author : Alexander Koblov (Alexx2000@mail.ru)
Several useful functions
contributors:
Radek Cervinka <radek.cervinka@centrum.cz>
Part of this code got from http://www.delphirus.com.ru
}
unit uDCUtils;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Graphics;
function GetAbsoluteFileName(sPath, sRelativeFileName : String) : String;
function ExtractOnlyFileName(const FileName: string): string;
Function cnvFormatFileSize(iSize:Int64):String;
Function MinimizeFilePath(const PathToMince: String; Canvas: TCanvas;
MaxLen: Integer): String;
function G_ValidateWildText(const S, Mask: string; bCaseSens : Boolean = False; MaskChar: Char = '?';
WildCard: Char = '*'): Boolean;
procedure DivFileName(const sFileName:String; var n,e:String);
implementation
uses
uGlobs, uVFSUtil;
function GetAbsoluteFileName(sPath, sRelativeFileName : String) : String;
var
iPos : Integer;
sDir : String;
begin
sDir := '';
if (Pos(PathDelim, sRelativeFileName) <> 0) and (Pos(DriveDelim, sRelativeFileName) = 0) then
begin
iPos := Pos('..' + PathDelim, sRelativeFileName);
if iPos <> 0 then
sDir := sPath;
while iPos <> 0 do
begin
sDir := LowDirLevel(sDir);
Delete(sRelativeFileName, iPos, 3);
iPos := Pos('..' + PathDelim, sRelativeFileName);
end;
Result := sDir + sRelativeFileName;
end
else
if Pos(DriveDelim, sRelativeFileName) = 0 then
Result := sPath + sRelativeFileName
else
Result := sRelativeFileName;
end;
function ExtractOnlyFileName(const FileName: string): string;
var
iDotIndex,
I: longint;
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
iDotIndex := I
else
iDotIndex := MaxInt;
(* 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);
end;
Function cnvFormatFileSize(iSize:Int64):String;
var
d:double;
begin
// writeln(iSize);
if gShortFileSizeFormat then
begin
// TODo Giga
if iSize div (1024*1024) >0 then
begin
// writeln('Div:',Trunc(iSize*10 /(1024*1024))/10);
Result:=FloatToStrF((iSize*10 div (1024*1024))/10, ffFixed, 15, 1)+'M'
end
else
if iSize div 1024 >0 then
begin
Result:=FloatToStrF((iSize*10 div 1024)/10, ffFixed, 15, 1)+'K'
end
else
Result:=IntToStr(iSize);
end
else
begin
d:=iSize;
Result:=Format('%8.0n',[d]);
end;
end;
{=========================================================}
Function MinimizeFilePath(const PathToMince: String; Canvas: TCanvas;
MaxLen: Integer): String;
{=========================================================}
// "C:\Program Files\Delphi\DDropTargetDemo\main.pas"
// "C:\Program Files\..\main.pas"
Var
sl: TStringList;
sHelp, sFile,
sFirst: String;
iPos: Integer;
Begin
sHelp := PathToMince;
iPos := Pos(PathDelim, sHelp);
If iPos = 0 Then
Begin
Result := PathToMince;
End
Else
Begin
sl := TStringList.Create;
// Decode string
While iPos <> 0 Do
Begin
sl.Add(Copy(sHelp, 1, (iPos - 1)));
sHelp := Copy(sHelp, (iPos + 1), Length(sHelp));
iPos := Pos(PathDelim, sHelp);
End;
If sHelp <> '' Then
Begin
sl.Add(sHelp);
End;
// Encode string
sFirst := sl[0];
sFile := sl[sl.Count - 1];
sl.Delete(sl.Count - 1);
Result := '';
MaxLen := MaxLen - Canvas.TextWidth('XXX');
if (sl.Count <> 0) and (Canvas.TextWidth(Result + sl[0] + PathDelim + sFile) < MaxLen) then
begin
While (sl.Count <> 0) and (Canvas.TextWidth(Result + sl[0] + PathDelim + sFile) < MaxLen) Do
Begin
Result := Result + sl[0] + PathDelim;
sl.Delete(0);
End;
If sl.Count = 0 Then
Begin
Result := Result + sFile;
End
Else
Begin
Result := Result + '..' + PathDelim + sFile;
End;
end
else
If sl.Count = 0 Then
Begin
Result := sFirst + PathDelim;
End
Else
Begin
Result := sFirst + PathDelim + '..' + PathDelim + sFile;
End;
sl.Free;
End;
//WriteLN('PathX ' , Result);
if Canvas.TextWidth(Result) > MaxLen + Canvas.TextWidth('XXX') then
begin
while Canvas.TextWidth(Result) > MaxLen do
begin
Delete(Result, Length(Result), 1);
end;
Result := Copy(Result, 1, Length(Result) - 3) + '...';
end;
End;
procedure DivFileName(const sFileName:String; var n,e:String);
var
i:Integer;
begin
for i:= length(sFileName) downto 1 do
if sFileName[i]='.' then
begin
// if i>1 then // hidden files??
e:=Copy(sFileName,i,Length(sFileName)-i+1);
n:=Copy(sFileName,1,i-1);
Exit;
end;
e:='';
n:=sFileName;
end;
function CharPos(C: Char; const S: string; StartPos: Integer = 1): Integer; overload;
var
sNewStr : String;
begin
if StartPos <> 1 then
begin
sNewStr := Copy(S, StartPos, Length(S) - StartPos + 1);
Result := Pos(C, sNewStr);
if Result <> 0 then
Result := Result + StartPos - 1;
end
else
Result := Pos(C, S);
end;
{
This function based on G_ValidateWildText from AcedUtils
http://acedutils.narod.ru/AcedUtils.zip
}
function G_ValidateWildText(const S, Mask: string; bCaseSens : Boolean = False; MaskChar: Char = '?';
WildCard: Char = '*'): Boolean;
label
99;
var
L, X, X0, Q: Integer;
P, P1, B: PChar;
C: Char;
sUpperS,
sUpperMask : String;
begin
if not bCaseSens then
begin
sUpperS := UpperCase(S);
sUpperMask := UpperCase(Mask);
end
else
begin
sUpperS := S;
sUpperMask := Mask;
end;
X := Pos(WildCard, sUpperMask);
Result := False;
if X = 0 then
begin
L := Length(sUpperMask);
if (L > 0) and (L = Length(sUpperS)) then
begin
P := Pointer(sUpperS);
B := Pointer(sUpperMask);
repeat
C := B^;
if (C <> MaskChar) and (C <> P^) then
Exit;
Dec(L);
Inc(B);
Inc(P);
until L = 0;
Result := True;
end;
Exit;
end;
L := Length(sUpperS);
P := Pointer(sUpperS);
B := Pointer(sUpperMask);
Q := X - 1;
if L < Q then
Exit;
while Q > 0 do
begin
C := B^;
if (C <> MaskChar) and (C <> P^) then
Exit;
Dec(Q);
Inc(B);
Inc(P);
end;
Dec(L, X - 1);
repeat
X0 := X;
P1 := P;
while sUpperMask[X0] = WildCard do
Inc(X0);
X := CharPos(WildCard, sUpperMask, X0);
if X = 0 then
Break;
99:
P := P1;
B := @sUpperMask[X0];
Q := X - X0;
if L < Q then
Exit;
while Q > 0 do
begin
C := B^;
if (C <> MaskChar) and (C <> P^) then
begin
Inc(P1);
Dec(L);
goto 99;
end;
Dec(Q);
Inc(B);
Inc(P);
end;
Dec(L, X - X0);
until False;
X := Length(sUpperMask);
if L >= X - X0 + 1 then
begin
P := Pointer(sUpperS);
Inc(P, Length(sUpperS) - 1);
while X >= X0 do
begin
C := sUpperMask[X];
if (C <> MaskChar) and (C <> P^) then
Exit;
Dec(X);
Dec(P);
end;
Result := True;
end;
end;
end.

12
udeletethread.pas
View file

@ -13,11 +13,15 @@ unit uDeleteThread;
{$mode objfpc}{$H+}
interface
uses
uFileOpThread, uTypes, SysUtils;
uFileOpThread, uFileList, uTypes, SysUtils;
type
{ TDeleteThread }
TDeleteThread=Class(TFileOpThread)
protected
constructor Create(aFileList:TFileList);override;
procedure MainExecute; override;
Function DeleteFile(fr:PFileRecItem):Boolean;
Function GetCaptionLng:String;override;
@ -27,6 +31,12 @@ implementation
uses
uLng, uOSUtils;
constructor TDeleteThread.Create(aFileList: TFileList);
begin
inherited Create(aFileList);
FSymLinkAll := True;
end;
procedure TDeleteThread.MainExecute;
var
pr:PFileRecItem;

93
ufileopthread.pas
View file

@ -46,6 +46,8 @@ type
FAppend: Boolean; // used mainly for pass information between move and copy
FDlgFileExist : TfrmMsg; //Alexx2000
FMsg : String; //Alexx2000
FSymLinkAll, // process all symlinks
FNotSymLinkAll : Boolean; // process all real files/folders
procedure Execute; override;
@ -53,31 +55,36 @@ type
procedure FillAndCount;
procedure FillAndCountRec(const srcPath, dstPath:String); // rekursive called
procedure EstimateTime(iSizeCoped:Int64);
Function GetCaptionLng:String; virtual;
Function GetCaptionLng:String; virtual;
procedure CorrectMask;
Function CorrectDstName(const sName:String):String;
Function CorrectDstExt(const sExt:String):String;
Function CorrectDstName(const sName:String):String;
Function CorrectDstExt(const sExt:String):String;
procedure ShowDlgFileExist; //Alexx2000
procedure FileOpDlgEnabled;
procedure ShowDlgProcessSymLink;
public
FFileOpDlg: TfrmFileOp; // progress window
sDstPath: String;
sDstMask: String;
constructor Create(aFileList:TFileList);
constructor Create(aFileList:TFileList);virtual;
destructor Destroy; override;
function UseForm:Boolean; virtual;
function FreeAtEnd:Boolean; virtual;
function DlgFileExist(const sMsg:String):Boolean; // result=true > rewrite file
function DlgProcessSymLink(const sMsg:String):Boolean;
end;
const
FMyMsgButtons : array[0..5] of TMyMsgButton = (msmbRewrite, msmbNo, msmbSkip, msmbAppend, msmbRewriteAll, msmbSkipAll); //Alexx2000
FSymLinkBtns : array[0..3] of TMyMsgButton = (msmbYes, msmbNo, msmbRewriteAll, msmbSkipAll); //Alexx2000
implementation
uses
SysUtils, uLng, uFileProcs, Forms, FindEx, uDCUtils, uOSUtils;
SysUtils, uLng, uFileProcs, uFileOp, Forms, FindEx, uDCUtils, uOSUtils;
{ TFileOpThread }
@ -90,6 +97,8 @@ begin
FFileList := aFileList;
FreeOnTerminate:=FreeAtEnd;
sDstMask:='*.*';
FSymLinkAll := False;
FNotSymLinkAll := False;
end;
destructor TFileOpThread.Destroy;
@ -158,6 +167,8 @@ procedure TFileOpThread.FillAndCount;
var
i:Integer;
ptr:PFileRecItem;
sRealName : String;
sr : TSearchRec;
begin
NewFileList.Clear;
FFilesCount:=0;
@ -166,6 +177,29 @@ begin
for i:=0 to FFileList.Count-1 do
begin
ptr:=FFileList.GetItem(i);
//----------------------------------------
(* For process symlink or real file/folder *)
if FPS_ISLNK(ptr^.iMode) then
if (not FSymLinkAll) and (FNotSymLinkAll or not DlgProcessSymLink('Process SymLink "' + ptr^.sName +'"? Press "Yes" to copy or "No" for copy real file/folder')) then //TODO: Localize message
begin
sRealName:=ReadSymLink(ptr^.sName);
sRealName := GetAbsoluteFileName(ExtractFilePath(ptr^.sName), sRealName);
FindFirst(sRealName, faAnyFile, sr);
with ptr^ do
begin
iSize := sr.Size;
sTime := DateTimeToStr(Trunc(FileDateToDateTime(sr.Time)));
iMode := sr.Attr;
sModeStr := AttrToStr(sr.Attr);
bLinkIsDir:=False;
bSelected:=False;
end;
DivFileName(sRealName, ptr^.sName, ptr^.sExt);
end;
//----------------------------------------
if FPS_ISDIR(ptr^.iMode) and (not ptr^.bLinkIsDir) then
begin
inc(FDirCount);
@ -271,7 +305,7 @@ end;
procedure TFileOpThread.ShowDlgFileExist;
begin
FDlgFileExist := MsgBoxModal(FMsg, FMyMsgButtons, msmbRewrite, msmbNo);
FDlgFileExist := MsgBoxModal(FMsg, FMyMsgButtons, msmbYes, msmbNo);
end;
@ -316,6 +350,53 @@ begin
end; //case
end;
{Dialog for process symlink or real file/folder}
procedure TFileOpThread.ShowDlgProcessSymLink;
begin
FDlgFileExist := MsgBoxModal(FMsg, FSymLinkBtns, msmbYes, msmbNo);
end;
function TFileOpThread.DlgProcessSymLink(const sMsg:String):Boolean; // result=true > rewrite file
var
DlgResult : TMyMsgResult;
begin
FAppend:=False;
Result:=False;
FMsg := sMsg;
{For pseudo modal window}
Synchronize(@ShowDlgProcessSymLink);
Synchronize(@FileOpDlgEnabled);
while (FDlgFileExist.iSelected) < 0 do Sleep(10);
Synchronize(@FileOpDlgEnabled);
{/For pseudo modal window}
DlgResult:=TMyMsgResult(FSymLinkBtns[FDlgFileExist.iSelected]);
case DlgResult of
mmrNo:;
mmrYes:
begin
Result:=True;
end;
mmrRewriteAll:
begin
FSymLinkAll:=True;
Result:=True;
end;
mmrSkipAll:
begin
FNotSymLinkAll:=True;
end;
else
Raise Exception.Create('bad handling msg result');
end; //case
end;
{/Dialog for process symlink or real file/folder}
Function TFileOpThread.GetCaptionLng:String;
begin
Result:='';