{ **** UBPFD *********** by kladovka.net.ru ****
>>
Исходный код утилиты, которая создает hard и symbolic links почти как в unix.
Hardlink можно создать только для файлов и только на NTFS.
Symbolic link можно создать только для директориев и только на
NTFS5 (Win2K/XP) и он не может указывать на сетевой ресурс.
Зависимости: Windows, SysUtils
Автор: Alex Konshin, <a href="mailto:akonshin@earthlink.net">akonshin@earthlink.net</a>, Boston, USA
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.FindFile(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
   : 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
   := nil;
  DirName := sFileName;
  end;
  ppLast^ := pDir;
  ppLast := @pDir^.;
  end
  else if not DeleteFile(sFileName) then
  raise Exception.Create('Cannot delete file "'+sFileName+'".');
  until not Windows.FindFile(h,rFindData);
  finally
  Windows.FindClose(h);
  end;
  if pSubDirs<>nil then
  begin
  repeat
  pDir := pSubDirs;
  pSubDirs := pDir^.;
  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^.;
  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.