Создание hardlink и symbolic link.

=== Создание hardlink и symbolic link. ===
{ **** UBPFD *********** by kladovka.net.ru ****
>> Создание hardlink и symbolic link.
Исходный код утилиты, которая создает hard и symbolic links почти как в unix.
Hardlink можно создать только для файлов и только на NTFS.
Symbolic link можно создать только для директориев и только на
NTFS5 (Win2K/XP) и он не может указывать на сетевой ресурс.
Зависимости: Windows, SysUtils
Copyright: http://home.earthlink.net/~akonshin/files/xlink.zip
Дата: 30 декабря 2002 г.
********************************************** }
program xlink;
uses
 Windows,
 SysUtils;
{$APPTYPE CONSOLE}
{$R xlink.res}
type
 TOptions = set of (optSymbolicLink, optOverwrite, optRecursive, optDirectory);
 int64rec = packed record
 lo: longword;
 hi: LongInt;
 end;
const
 FILE_DOES_NOT_EXIST = DWORD(-1);
//=============================================================
function isFileExists(const AFileName: string): boolean;
var
 h: THandle;
 rFindData: TWin32FindData;
begin
 h := Windows.FindFirstFile(PChar(AFileName), rFindData);
 Result := (h <> INVALID_HANDLE_VALUE);
 if not Result then
 Exit;
 Windows.FindClose(h);
 Result := ((rFindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0);
end;
//-------------------------------------------------------------
// warning: function assumes that it is correct directory name
function isDirectoryEmpty(const ADirectoryName: string): boolean;
var
 h: THandle;
 len: integer;
 rFindData: TWin32FindData;
 sSeachMask: string;
begin
 len := Length(ADirectoryName);
 if (PChar(ADirectoryName) + len - 1)^ = '\' then
 sSeachMask := ADirectoryName + '*'
 else
 sSeachMask := ADirectoryName + '\*';
 h := Windows.FindFirstFile(PChar(sSeachMask), rFindData);
 Result := (h = INVALID_HANDLE_VALUE);
 Windows.FindClose(h);
end;
//-------------------------------------------------------------
function SysErrorMessage(ErrorCode: integer): string;
var
 Len: integer;
 Buffer: array[0..255] of char;
begin
 Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
 FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer, SizeOf(Buffer), nil);
 while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do
 Dec(Len);
 SetString(Result, Buffer, Len);
end;
//-------------------------------------------------------------
procedure _CreateHardlink(AFileName: string; AFileWCName: PWideChar;
 ALinkName: string; overwrite: boolean);
var
 aLinkWCFileName, aLinkFullName: array[0..MAX_PATH] of WChar;
 pwFilePart: LPWSTR;
 hFileSource: THandle;
 rStreamId: WIN32_STREAM_ID;
 cbPathLen, dwStreamHeaderSize, dwBytesWritten: DWORD;
 lpContext: Pointer;
begin
 StringToWidechar(ALinkName, aLinkWCFileName, MAX_PATH);
 hFileSource := Windows.CreateFile(PChar(AFileName), GENERIC_READ or
 GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE,
 nil, OPEN_EXISTING, 0, 0);
 if hFileSource = INVALID_HANDLE_VALUE then
 raise Exception.Create('Cannot open file "' + AFileName + '"');
 try
 cbPathLen := Windows.GetFullPathNameW(aLinkWCFileName, MAX_PATH,
 aLinkFullName, pwFilePart);
 if cbPathLen <= 0 then
 raise Exception.Create('Invalid link name "' + ALinkName + '"');
 cbPathLen := (cbPathLen + 1) * SizeOf(WChar);
 lpContext := nil;
 rStreamId.dwStreamId := BACKUP_LINK;
 rStreamId.dwStreamAttributes := 0;
 rStreamId.dwStreamNameSize := 0;
 int64rec(rStreamId.Size).hi := 0;
 int64rec(rStreamId.Size).lo := cbPathLen;
 dwStreamHeaderSize := PChar(@rStreamId.cStreamName) - PChar(@rStreamId) +
 longint(rStreamId.dwStreamNameSize);
 if not BackupWrite(hFileSource, Pointer(@rStreamId),
 // buffer to write
 dwStreamHeaderSize, // number of bytes to write
 dwBytesWritten, False, // don't abort yet
 False, // don't process security
 lpContext) then
 RaiseLastOSError;
 if not BackupWrite(hFileSource, Pointer(@aLinkFullName),
 // buffer to write
 cbPathLen, // number of bytes to write
 dwBytesWritten, False, // don't abort yet
 False, // don't process security
 lpContext) then
 RaiseLastOSError;
 // free context
 if not BackupWrite(hFileSource, nil, // buffer to write
 0, // number of bytes to write
 dwBytesWritten, True, // abort
 False, // don't process security
 lpContext) then
 RaiseLastOSError;
 finally
 CloseHandle(hFileSource);
 end;
end;
//-------------------------------------------------------------
// ADirName and ADirForLinks must not end with backslach
procedure _CreateHardlinksForSubDirectory(const ADirName, ADirForLinks: string;
 options: TOptions);
var
 h: THandle;
 sExistedFile, sLinkName: string;
 dwAttributes: DWORD;
 rFindData: TWin32FindData;
 awcFileName: array[0..MAX_PATH] of WChar;
begin
 dwAttributes := GetFileAttributes(PChar(ADirForLinks));
 if dwAttributes = FILE_DOES_NOT_EXIST then
 begin
 // WriteLn('Create Directory ',ADirForLinks);
 if not CreateDir(ADirForLinks) then
 raise Exception.Create('Cannot create directory "' + ADirForLinks + '".');
 end
 else if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
 raise Exception.Create('File "' + ADirName +
 '" already exists and it is not a directory.');
 h := Windows.FindFirstFile(PChar(ADirName + '\*'), rFindData);
 if h = INVALID_HANDLE_VALUE then
 Exit;
 try
 repeat
 if (rFindData.cFileName[0] = '.') and
 ((rFindData.cFileName[1] = #0) or ((rFindData.cFileName[1] = '.') and
 (rFindData.cFileName[2] = #0))) then
 Continue;
 sExistedFile := ADirName + '\' + rFindData.cFileName;
 sLinkName := ADirForLinks + '\' + rFindData.cFileName;
 if (rFindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
 begin
 awcFileName[
 Windows.MultiByteToWideChar(0, 0, PChar(sExistedFile),
 MAX_PATH, awcFileName, MAX_PATH)
 ] := #0;
 _CreateHardlink(sExistedFile, awcFileName, sLinkName,
 optOverwrite in options);
 end
 else if optRecursive in options then
 begin
 _CreateHardlinksForSubDirectory(sExistedFile, sLinkName, options);
 end;
 until not Windows.FindNextFile(h, rFindData);
 finally
 Windows.FindClose(h);
 end;
end;
//-------------------------------------------------------------
procedure CreateHardlink(AFileName, ALinkName: string; options: TOptions);
var
 dwAttributes: DWORD;
 aFileSource: array[0..MAX_PATH] of WChar;
begin
 dwAttributes := Windows.GetFileAttributes(PChar(AFileName));
 if dwAttributes = FILE_DOES_NOT_EXIST then
 raise Exception.Create('File "' + AFileName + '" does not exist.');
 if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
 raise Exception.Create('Cannot create hardlink for directory (file "' +
 AFileName + '").');
 dwAttributes := Windows.GetFileAttributes(PChar(ALinkName));
 if dwAttributes <> FILE_DOES_NOT_EXIST then
 begin
 if not (optOverwrite in options) then
 raise Exception.Create('File "' + ALinkName + '" already exists.');
 if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
 raise Exception.Create('Cannot overwrite directory "' + AFileName + '".');
 end;
 StringToWidechar(AFileName, aFileSource, MAX_PATH);
 _CreateHardlink(AFileName, aFileSource, ALinkName, optOverwrite in options);
end;
//-------------------------------------------------------------
procedure CreateHardlinksForDirectory(const ADirName, ADirForLinks: string;
 options: TOptions);
var
 dwAttributes: DWORD;
 len: integer;
 sDirName, sDirForLinks: string;
begin
 dwAttributes := Windows.GetFileAttributes(PChar(ADirName));
 if dwAttributes = FILE_DOES_NOT_EXIST then
 raise Exception.Create('Directory "' + ADirName + '" does not exist.');
 if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
 raise Exception.Create('File "' + ADirName + '" is not a directory.');
 len := Length(ADirName);
 if (PChar(ADirName) + len - 1)^ = '\' then
 sDirName := Copy(ADirName, 1, len - 1)
 else
 sDirName := ADirName;
 if (PChar(ADirForLinks) + Length(ADirForLinks) - 1)^ <> '\' then
 sDirForLinks := ADirForLinks
 else
 sDirForLinks := Copy(ADirForLinks, 1, Length(ADirForLinks) - 1);
 _CreateHardlinksForSubDirectory(sDirName, sDirForLinks, options);
end;
//-------------------------------------------------------------
procedure CreateHardlinksInDirectory(const AFileName, ADirForLinks: string;
 options: TOptions);
var
 dwAttributes: DWORD;
 len: integer;
 sFileName, sDirForLinks, sLinkName: string;
 aFileSource: array[0..MAX_PATH] of WChar;
begin
 dwAttributes := Windows.GetFileAttributes(PChar(AFileName));
 if dwAttributes = FILE_DOES_NOT_EXIST then
 raise Exception.Create('File or directory "' + AFileName + '" does not exist.');
 if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
 begin
 sLinkName := ADirForLinks + '\' + SysUtils.ExpandFileName(AFileName);
 dwAttributes := Windows.GetFileAttributes(PChar(sLinkName));
 if dwAttributes <> FILE_DOES_NOT_EXIST then
 begin
 if not (optOverwrite in options) then
 raise Exception.Create('File "' + sLinkName + '" already exists.');
 if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
 raise Exception.Create('Cannot overwrite directory "' + AFileName + '".');
 end;
 StringToWidechar(AFileName, aFileSource, MAX_PATH);
 _CreateHardlink(AFileName, aFileSource, sLinkName,
 optOverwrite in options);
 end
 else
 begin
 len := Length(AFileName);
 if (PChar(AFileName) + len - 1)^ = '\' then
 sFileName := Copy(AFileName, 1, len - 1)
 else
 sFileName := AFileName;
 if (PChar(ADirForLinks) + Length(ADirForLinks) - 1)^ <> '\' then
 sDirForLinks := ADirForLinks
 else
 sDirForLinks := Copy(ADirForLinks, 1, Length(ADirForLinks) - 1);
 _CreateHardlinksForSubDirectory(sFileName, sDirForLinks, options);
 end;
end;
//-------------------------------------------------------------
procedure DeleteDirectoryContent(const ADirName: string);
type
 PDirRef = ^TDirRef;
 PPDirRef = ^PDirRef;
 TDirRef = record
 Next: PDirRef;
 DirName: string;
 end;
var
 h: THandle;
 sFileName: string;
 pSubDirs: PDirRef;
 ppLast: PPDirRef;
 pDir: PDirRef;
 rFindData: TWin32FindData;
begin
 pSubDirs := nil;
 ppLast := @pSubDirs;
 h := Windows.FindFirstFile(PChar(ADirName + '\*'), rFindData);
 if h = INVALID_HANDLE_VALUE then
 Exit;
 try
 try
 repeat
 if (rFindData.cFileName[0] = '.') and
 ((rFindData.cFileName[1] = #0) or ((rFindData.cFileName[1] = '.') and
 (rFindData.cFileName[2] = #0))) then
 Continue;
 sFileName := ADirName + '\' + rFindData.cFileName;
 if (rFindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
 begin
 New(pDir);
 with pDir^ do
 begin
 Next := nil;
 DirName := sFileName;
 end;
 ppLast^ := pDir;
 ppLast := @pDir^.Next;
 end
 else if not DeleteFile(sFileName) then
 raise Exception.Create('Cannot delete file "' + sFileName + '".');
 until not Windows.FindNextFile(h, rFindData);
 finally
 Windows.FindClose(h);
 end;
 if pSubDirs <> nil then
 begin
 repeat
 pDir := pSubDirs;
 pSubDirs := pDir^.Next;
 sFileName := pDir^.DirName;
 Dispose(pDir);
 DeleteDirectoryContent(sFileName);
 if not RemoveDir(sFileName) then
 raise Exception.Create('Cannot delete directory "' + sFileName + '".');
 until pSubDirs = nil;
 end;
 except
 while pSubDirs <> nil do
 begin
 pDir := pSubDirs;
 pSubDirs := pDir^.Next;
 Dispose(pDir);
 end;
 raise;
 end;
end;
//-------------------------------------------------------------
const
 FILE_DEVICE_FILE_SYSTEM = $0009;
 // Define the method codes for how buffers are passed for I/O and FS controls
 METHOD_BUFFERED = 0;
 METHOD_IN_DIRECT = 1;
 METHOD_OUT_DIRECT = 2;
 METHOD_NEITHER = 3;
 // Define the access check value for any access
 FILE_ANY_ACCESS = 0;
 FILE_READ_DATA = 1;
 FILE_WRITE_DATA = 2;
 FSCTL_SET_REPARSE_POINT = (FILE_DEVICE_FILE_SYSTEM shl 16) or
 (FILE_ANY_ACCESS shl 14) or (41 shl 2) or (METHOD_BUFFERED);
 FSCTL_GET_REPARSE_POINT = (FILE_DEVICE_FILE_SYSTEM shl 16) or
 (FILE_ANY_ACCESS shl 14) or (42 shl 2) or (METHOD_BUFFERED);
 FSCTL_DELETE_REPARSE_POINT =
 (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or
 (43 shl 2) or (METHOD_BUFFERED);
 FILE_FLAG_OPEN_REPARSE_POINT = $00200000;
 FILE_ATTRIBUTE_REPARSE_POINT = $00000400;
 IO_REPARSE_TAG_MOUNT_POINT = $A0000003;
 REPARSE_MOUNTPOINT_HEADER_SIZE = 8;
type
 REPARSE_MOUNTPOINT_DATA_BUFFER = packed record
 ReparseTag: DWORD;
 ReparseDataLength: DWORD;
 Reserved: Word;
 ReparseTargetLength: Word;
 ReparseTargetMaximumLength: Word;
 Reserved1: Word;
 ReparseTarget: array [0..0] of WChar;
 end;
 TReparseMountpointDataBuffer = REPARSE_MOUNTPOINT_DATA_BUFFER;
 PReparseMountpointDataBuffer = ^TReparseMountpointDataBuffer;
//-------------------------------------------------------------
function CreateSymlink(ATargetName, ALinkName: string;
const options: TOptions): boolean;
const
 pwcNativeFileNamePrefix: PWideChar = '\??\';
 nNativeFileNamePrefixWCharLength = 4;
 nNativeFileNamePrefixByteLength = nNativeFileNamePrefixWCharLength * 2;
var
 hLink: THandle;
 pReparseInfo: PReparseMountpointDataBuffer;
 len, size: integer;
 pwcLinkFileName: PWideChar;
 pwcTargetNativeFileName: PWideChar;
 pwcTargetFileName: PWideChar;
 pwc: PWideChar;
 pc: PChar;
 dwBytesReturned: DWORD;
 dwAttributes: DWORD;
 bDirectoryCreated: boolean;
 aTargetFullName: array [0..MAX_PATH] of char;
begin
 Result := False;
 pReparseInfo := nil;
 hLink := INVALID_HANDLE_VALUE;
 bDirectoryCreated := False;
 len := Length(ALinkName);
 if ((PChar(ALinkName) + len - 1)^ = '\') and ((PChar(ALinkName) + len - 2)^ <> ':') then
 begin
 Dec(len);
 SetLength(ALinkName, len);
 end;
 System.GetMem(pwcLinkFileName, len + len + 2);
 try
 pwcLinkFileName[
 Windows.MultiByteToWideChar(0, 0, PChar(ALinkName), len, wcLinkFileName, len)
 ] := #0;
 dwAttributes := Windows.getFileAttributesW(pwcLinkFileName);
 if dwAttributes <> FILE_DOES_NOT_EXIST then
 begin
 if not (optOverwrite in options) then
 begin
 if (dwAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
 raise Exception.Create('The file "' + ALinkName + '" already exists');
 if not isDirectoryEmpty(ALinkName) then
 raise Exception.Create(
 'The directory "' + ALinkName + '" already exists and is not empty');
 dwAttributes := FILE_DOES_NOT_EXIST;
 end
 else if ((dwAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0) then
 begin
 if not DeleteFile(ALinkName) then
 raise Exception.Create('Cannot overwrite file "' + ALinkName + '"');
 dwAttributes := FILE_DOES_NOT_EXIST;
 end
 else if (dwAttributes and FILE_ATTRIBUTE_REPARSE_POINT) <>
 FILE_ATTRIBUTE_REPARSE_POINT then
 if not isDirectoryEmpty(ALinkName) then
 begin
 if not (optDirectory in options) then
 raise Exception.Create('Cannot overwrite non-empty directory "'
 + ALinkName + '"');
 DeleteDirectoryContent(ALinkName);
 end;
 end;
 if dwAttributes = FILE_DOES_NOT_EXIST then
 begin
 Windows.CreateDirectoryW(pwcLinkFileName, nil);
 bDirectoryCreated := True;
 end;
 try
 hLink := Windows.CreateFileW(pwcLinkFileName, GENERIC_WRITE,
 0, nil, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT or
 FILE_FLAG_BACKUP_SEMANTICS, 0);
 if hLink = INVALID_HANDLE_VALUE then
 RaiseLastOSError;
 len := Length(ATargetName);
 if ((PChar(ATargetName) + len - 1)^ = '\') and
 ((PChar(ATargetName) + len - 2)^ <> ':') then
 begin
 Dec(len);
 SetLength(ATargetName, len);
 end;
 len := Windows.GetFullPathName(PChar(ATargetName), MAX_PATH,
 aTargetFullName, pc);
 size := len + len + 2 + nNativeFileNamePrefixByteLength +
 REPARSE_MOUNTPOINT_HEADER_SIZE + 12;
 System.GetMem(pReparseInfo, size);
 FillChar(pReparseInfo^, size, #0);
 pwcTargetNativeFileName := @pReparseInfo^.ReparseTarget;
 System.Move(pwcNativeFileNamePrefix^, pwcTargetNativeFileName^,
 nNativeFileNamePrefixByteLength + 2);
 pwcTargetFileName := pwcTargetNativeFileName +
 nNativeFileNamePrefixWCharLength;
 pwc := pwcTargetFileName + Windows.MultiByteToWideChar(0, 0,
 aTargetFullName, len, pwcTargetFileName, len);
 pwc^ := #0;
 with pReparseInfo^ do
 begin
 ReparseTag := IO_REPARSE_TAG_MOUNT_POINT;
 ReparseTargetLength := PChar(pwc) - PChar(pwcTargetNativeFileName);
 ReparseTargetMaximumLength := ReparseTargetLength + 2;
 ReparseDataLength := ReparseTargetLength + 12;
 end;
 dwBytesReturned := 0;
 if not DeviceIoControl(hLink, FSCTL_SET_REPARSE_POINT, pReparseInfo,
 pReparseInfo^.ReparseDataLength + REPARSE_MOUNTPOINT_HEADER_SIZE,
 nil, 0, dwBytesReturned, nil) then
 RaiseLastOSError;
 except
 if bDirectoryCreated then
 RemoveDirectoryW(pwcLinkFileName);
 raise;
 end;
 Result := True;
 finally
 if hLink <> INVALID_HANDLE_VALUE then
 Windows.CloseHandle(hLink);
 if pwcLinkFileName <> nil then
 System.FreeMem(pwcLinkFileName);
 if pReparseInfo <> nil then
 System.FreeMem(pReparseInfo);
 end;
end;
//-------------------------------------------------------------
procedure Help;
begin
 WriteLn;
 WriteLn('Create link(s) on NTFS.');
 WriteLn;
 WriteLn('Usage:');
 WriteLn;
 WriteLn('To create hardlink(s) (works only for files):');
 WriteLn('xlink [-fr] <existed_file> <link_name>');
 WriteLn;
 WriteLn('To create symbolic link (works on Windows 2k/XP for directories only):');
 WriteLn('xlink -s[f|F] <existed_directory> <link_name>');
 WriteLn;
 WriteLn('Options:');
 WriteLn('-f Overwrite file with name <link_name> if it exists.');
 WriteLn('-F Overwrite file/directory with name <link_name> if it exists.');
 WriteLn('-r Recursive.');
 WriteLn;
 WriteLn('(c) 2002 Alex Konshin');
 Halt;
end;
//-------------------------------------------------------------
procedure Execute;
var
 iArg: integer;
 sArg: string;
 ptr: PChar;
 options: TOptions;
 sExistedFileName: string;
 sLink: string;
 dwAttrs: DWORD;
begin
 iArg := 1;
 repeat
 sArg := ParamStr(iArg);
 if sArg = then
 Help;
 if PChar(sArg)^ <> '-' then
 Break;
 ptr := PChar(sArg) + 1;
 while ptr^ <> #0 do
 begin
 case ptr^ of
 's', 'S': Include(options, optSymbolicLink);
 'h', 'H': Help;
 'F': options := options + [optOverwrite, optDirectory];
 'f': Include(options, optOverwrite);
 'r', 'R': Include(options, optRecursive);
 'd', 'D': Include(options, optDirectory);
 else
 WriteLn('Error: Invalid option -', ptr^, '');
 Exit;
 end;
 Inc(ptr);
 end;
 Inc(iArg);
 until iArg <= ParamCount;
 if ParamCount <= iArg then
 Help;
 if ParamCount - iArg > 1 then
 Include(options, optDirectory);
 if optSymbolicLink in options then
 begin
 sLink := ParamStr(ParamCount);
 repeat
 sExistedFileName := ParamStr(iArg);
 if not CreateSymlink(sExistedFileName, sLink, options) then
 WriteLn('The symbolic link creation failed.');
 Inc(iArg);
 until iArg >= ParamCount;
 end
 else if (options * [optRecursive, optDirectory]) <> [] then
 begin
 sLink := ParamStr(ParamCount);
 repeat
 sExistedFileName := ParamStr(iArg);
 CreateHardlinksInDirectory(sExistedFileName, sLink, options);
 Inc(iArg);
 until iArg >= ParamCount;
 end
 else
 begin
 sExistedFileName := ParamStr(iArg);
 sLink := ParamStr(ParamCount);
 dwAttrs := GetFileAttributes(PChar(sExistedFileName));
 if dwAttrs = FILE_DOES_NOT_EXIST then
 begin
 writeln('Error: The source file does not exist');
 Exit;
 end;
 if (dwAttrs and FILE_ATTRIBUTE_DIRECTORY) <> 0 then
 begin
 writeln('Error: Cannot create hardlink for directory');
 Exit;
 end;
 CreateHardlink(sExistedFileName, sLink, options);
 end;
end;
//=============================================================
begin
 if ParamCount < 2 then
 Help;
 try
 Execute;
 except
 on E: Exception do
 begin
 WriteLn(E.ClassName + ': ' + E.Message);
 end;
 end;
end.
Author: Alex Konshin, akonshin@earthlink.net, Boston, USA
ID: 03122
Category:Файловая система