{$IFDEF JCL}
{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Initial Developer of the Original Code is Oliver Schneider (Assarbad att gmx dott info).     }
{ Portions created by Oliver Schneider are Copyright (C) 1995 - 2004 Oliver Schneider.             }
{ All rights reserved.                                                                             }
{                                                                                                  }
{ Obtained through:                                                                                }
{   Joint Endeavour of Delphi Innovators (Project JEDI)                                            }
{                                                                                                  }
{ You may retrieve the latest version of the original file at the Original Developer's homepage,   }
{ located at [http://assarbad.net]. Note that the original file can be used with an arbitrary OSI- }
{ approved license as long as you follow the additional terms given in the original file.          }
{ Additionally a C/C++ (MS VC++) version is available under the same terms.                        }
{                                                                                                  }
{ Contributor(s):                                                                                  }
{   Oliver Schneider (assarbad)                                                                    }
{   Robert Marquardt (marquardt)                                                                   }
{   Robert Rossmair (rrossmair)                                                                    }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{  Windows NT 4.0 compatible implementation of the CreateHardLink() API introduced in Windows      }
{  2000.                                                                                           }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Last modified: $Date::                                                                         $ }
{ Revision:      $Rev::                                                                          $ }
{ Author:        $Author::                                                                       $ }
{                                                                                                  }
{**************************************************************************************************}
{$ELSE ~JCL}
(******************************************************************************
 ******************************************************************************
 ***                                                                        ***
 ***  Hardlinks. Implementation of the CreateHardLink() API introduced in   ***
 ***  Windows 2000 - BUT ALSO COMPATIBLE with Windows NT 4.0!               ***
 ***  This implementation should be fully compatible with the Windows 2000  ***
 ***  implementation (including last error and so on).                      ***
 ***                                                                        ***
 ***  Version [1.13a]                               {Last mod 2005-03-06}   ***
 ***                                                                        ***
 ******************************************************************************
 ******************************************************************************

                                 _\\|//_
                                (` * * ')
 ______________________________ooO_(_)_Ooo_____________________________________
 ******************************************************************************
 ******************************************************************************
 ***                                                                        ***
 ***                Copyright (c) 1995 - 2005 by -=Assarbad=-               ***
 ***             Portions Copyright (c) 2004 by Robert Marquardt            ***
 ***             Portions Copyright (c) 2004 by Robert Rossmair             ***
 ***                                                                        ***
 ***   CONTACT TO THE AUTHOR(S):                                            ***
 ***    ____________________________________                                ***
 ***   |                                    |                               ***
 ***   | -=Assarbad=- aka Oliver            |                               ***
 ***   |____________________________________|                               ***
 ***   |                                    |                               ***
 ***   | Assarbad @ gmx.info|.net|.com|.de  |                               ***
 ***   | ICQ: 281645                        |                               ***
 ***   | AIM: nixlosheute                   |                               ***
 ***   |      nixahnungnicht                |                               ***
 ***   | MSN: Assarbad@ePost.de             |                               ***
 ***   | YIM: sherlock_holmes_and_dr_watson |                               ***
 ***   |____________________________________|                               ***
 ***             ___                                                        ***
 ***            /   |                     ||              ||                ***
 ***           / _  |   ________ ___  ____||__    ___   __||                ***
 ***          / /_\ |  / __/ __//   |/  _/|   \  /   | /   |                ***
 ***         / ___  |__\\__\\  / /\ || |  | /\ \/ /\ |/ /\ | DOT NET        ***
 ***        /_/   \_/___/___/ /_____\|_|  |____/_____\\__/\|                ***
 ***       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~        ***
 ***              [http://assarbad.net | http://assarbad.org]               ***
 ***                                                                        ***
 ***   Notes:                                                               ***
 ***   - my first name is Oliver, you may well use this in your e-mails     ***
 ***   - for questions and/or proposals drop me a mail or instant message   ***
 ***                                                                        ***
 ***~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~***
 ***              May the source be with you, stranger ... ;)               ***
 ***    Snizhok, eto ne tolko fruktovij kefir, snizhok, eto stil zhizni.    ***
 ***                     Vsekh Privet iz Germanii                           ***
 ***                                                                        ***
 *** Greets from -=Assarbad=- fly to YOU =)                                 ***
 *** Special greets fly 2 Nico, Casper, SA, Pizza, Navarion, Eugen, Zhenja, ***
 *** Xandros, Melkij, Strelok etc pp.                                       ***
 ***                                                                        ***
 *** Thanks to:                                                             ***
 *** W.A. Mozart, Vivaldi, Beethoven, Poeta Magica, Kurtzweyl, Manowar,     ***
 *** Blind Guardian, Weltenbrand, In Extremo, Wolfsheim, Carl Orff, Zemfira ***
 *** ... most of my work was done with their music in the background ;)     ***
 ***                                                                        ***
 ******************************************************************************
 ******************************************************************************

 LEGAL STUFF:
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 NOTE: This source is OSI-licensed. You may choose between any of the licenses
       approved by the OSI (Open Source Initiative) as long as the licensing
       of this module will not force a whole project under the chosen license.
       This basically means that the virulent character of a license (e.g. GPL)
       must no be misused to force a project to use the license you chose for
       this module!
       OSI-approved licenses can be found at this website:
       http://www.opensource.org/licenses/

       You have the choice to make this module compatible with your own open
       source or commercial or whatever project by choosing the right license.

       However, I recommend using either of the following licenses:
       - the BSD-License (as seen below)
       - the LGPL [ http://www.opensource.org/licenses/lgpl-license.php ]
       - the MPL [ http://www.opensource.org/licenses/mozilla1.1.php ]

       !ATTENTION!: if this unit comes bundled with the files of the project
       JEDI the project license (currently MPL) is mandatory!!!
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 Copyright (c) 1995-2005, -=Assarbad=- ["copyright holder(s)"]
 All rights reserved.

 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are met:

 1. Redistributions of source code must retain the above copyright notice, this
    list of conditions and the following disclaimer.
 2. Redistributions in binary form must reproduce the above copyright notice,
    this list of conditions and the following disclaimer in the documentation
    and/or other materials provided with the distribution.
 3. The name(s) of the copyright holder(s) may not be used to endorse or
    promote products derived from this software without specific prior written
    permission.

 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY
 DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
 ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                             .oooO     Oooo.
 ____________________________(   )_____(   )___________________________________
                              \ (       ) /
                               \_)     (_/

 ******************************************************************************)
{$ENDIF ~JCL}

unit Hardlinks;

{$IFDEF JCL}
{$I jcl.inc}
{$I windowsonly.inc}

// ALL enabled by default for Project JEDI
{$DEFINE STDCALL}   // Make functions STDCALL always
{$DEFINE RTDL}      // Use runtime dynamic linking
{$DEFINE PREFERAPI} // Prefer the "real" Windows API on systems on which it exists
                    // If this is defined STDCALL is automatically needed and defined!
{$ENDIF JCL}

{$ALIGN ON}
{$MINENUMSIZE 4}

interface

{$IFDEF JCL}
//DOM-IGNORE-BEGIN
{$ENDIF JCL}

(*
  All possible combinations of the above DEFINEs have been tested and work fine.

   # | A  B  C
  ---|---------
   1 | 0  0  0                 A = STDCALL
   2 | 0  0  X                 B = RTDL
   3 | X  0  0                 C = PREFERAPI
   4 | X  0  X
   5 | X  X  0
   6 | X  X  X
*)
uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  {$IFDEF HAS_UNITSCOPE}
  Winapi.Windows;
  {$ELSE ~HAS_UNITSCOPE}
  Windows;
  {$ENDIF ~HAS_UNITSCOPE}

{$IFDEF PREFERAPI}
  {$DEFINE STDCALL // For the windows API we _require_ STDCALL calling convention }
{$ENDIF PREFERAPI}

{$EXTERNALSYM CreateHardLinkW}
{$EXTERNALSYM CreateHardLinkA}

{$IFNDEF PREFERAPI}
// We prefer the homegrown version - use the static version
function CreateHardLinkW(szLinkName, szLinkTarget: PWideChar; lpSecurityAttributes: PSecurityAttributes): BOOL;
  {$IFDEF STDCALL} stdcall; {$ENDIF} // Makes the actual call STDCALL
function CreateHardLinkA(szLinkName, szLinkTarget: PAnsiChar; lpSecurityAttributes: PSecurityAttributes): BOOL;
  {$IFDEF STDCALL} stdcall; {$ENDIF} // Makes the actual call STDCALL
{$ELSE PREFERAPI}
// Well, we did not decide yet ;) - bind to either address, depending on whether
// the API could be found.
type
  TFNCreateHardLinkW = function(szLinkName, szLinkTarget: PWideChar; lpSecurityAttributes: PSecurityAttributes): BOOL; {$IFDEF STDCALL} stdcall; {$ENDIF}
  TFNCreateHardLinkA = function(szLinkName, szLinkTarget: PAnsiChar; lpSecurityAttributes: PSecurityAttributes): BOOL; {$IFDEF STDCALL} stdcall; {$ENDIF}
var
  CreateHardLinkW: TFNCreateHardLinkW = nil;
  CreateHardLinkA: TFNCreateHardLinkA = nil;
{$ENDIF PREFERAPI}

{$IFDEF RTDL}
var
  hNtDll: THandle = 0; // For runtime dynamic linking
  bRtdlFunctionsLoaded: Boolean = False; // To show wether the RTDL functions had been loaded
{$ENDIF RTDL}

{$IFDEF JCL}
//DOM-IGNORE-END
{$ENDIF JCL}

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$URL$';
    Revision: '$Revision$';
    Date: '$Date$';
    LogPath: 'JCL\source\windows';
    Extra: '';
    Data: nil
    );
{$ENDIF UNITVERSIONING}

implementation

const
  szNtDll           = 'NTDLL.DLL';    // Import native APIs from this DLL
  szKernel32        = 'KERNEL32.DLL';
{$IFDEF PREFERAPI}
  szCreateHardLinkA = 'CreateHardLinkA';
  szCreateHardLinkW = 'CreateHardLinkW';
{$ENDIF PREFERAPI}

(******************************************************************************

 Note, I only include function prototypes and constants here which are needed!
 For other prototypes or constants check out the related books of
 - Gary Nebbett
 - Sven B. Schreiber
 - Rajeev Nagar

 Note, one my homepage I have also some Native APIs listed in Delphi translated
 form. Not all of them might be translated correctly with respect to the fact
 whether or not they are pointer and whether or not the alignment of variables
 or types is always correct. This might be reviewed by me somewhen in future.

 ******************************************************************************)

// =================================================================
// Type definitions
// =================================================================
type
  NTSTATUS = Longint;

type
  UNICODE_STRING = record
    Length: WORD;
    MaximumLength: WORD;
    Buffer: PWideChar;
  end;
  PUNICODE_STRING = ^UNICODE_STRING;

// type
  // ANSI_STRING = record
  //   Length: WORD;
  //   MaximumLength: WORD;
  //   Buffer: PAnsiChar;
  // end;
  // PANSI_STRING = ^ANSI_STRING;

type
  OBJECT_ATTRIBUTES = record
    Length: ULONG;
    RootDirectory: THandle;
    ObjectName: PUNICODE_STRING;
    Attributes: ULONG;
    SecurityDescriptor: Pointer;       // Points to type SECURITY_DESCRIPTOR
    SecurityQualityOfService: Pointer; // Points to type SECURITY_QUALITY_OF_SERVICE
  end;
  // POBJECT_ATTRIBUTES = ^OBJECT_ATTRIBUTES;

type
  IO_STATUS_BLOCK = record
    case integer of
      0:
       (Status: NTSTATUS);
      1:
       (Pointer: Pointer;
        Information: ULONG); // 'Information' does not belong to the union!
  end;
  // PIO_STATUS_BLOCK = ^IO_STATUS_BLOCK;

type
  _FILE_LINK_RENAME_INFORMATION = record // File Information Classes 10 and 11
    ReplaceIfExists: BOOL;
    RootDirectory: THandle;
    FileNameLength: ULONG;
    FileName: array[0..0] of WideChar;
  end;
  FILE_LINK_INFORMATION = _FILE_LINK_RENAME_INFORMATION;
  PFILE_LINK_INFORMATION = ^FILE_LINK_INFORMATION;
  // FILE_RENAME_INFORMATION = _FILE_LINK_RENAME_INFORMATION;
  // PFILE_RENAME_INFORMATION = ^FILE_RENAME_INFORMATION;

// =================================================================
// Constants
// =================================================================
const
  FileLinkInformation          = 11;
  FILE_SYNCHRONOUS_IO_NONALERT = $00000020; // All operations on the file are
                                            // performed synchronously. Waits
                                            // in the system to synchronize I/O
                                            // queuing and completion are not
                                            // subject to alerts. This flag
                                            // also causes the I/O system to
                                            // maintain the file position context.
                                            // If this flag is set, the
                                            // DesiredAccess SYNCHRONIZE flag also
                                            // must be set.
  FILE_OPEN_FOR_BACKUP_INTENT  = $00004000; // The file is being opened for backup
                                            // intent, hence, the system should
                                            // check for certain access rights
                                            // and grant the caller the appropriate
                                            // accesses to the file before checking
                                            // the input DesiredAccess against the
                                            // file's security descriptor.
  FILE_OPEN_REPARSE_POINT      = $00200000;
  DELETE                       = $00010000;
  SYNCHRONIZE                  = $00100000;
  STATUS_SUCCESS               = NTSTATUS(0);
  OBJ_CASE_INSENSITIVE         = $00000040;
  SYMBOLIC_LINK_QUERY          = $00000001;

  // Should be defined, but isn't
  HEAP_ZERO_MEMORY             = $00000008;

  // Related constant(s) for RtlDetermineDosPathNameType_U()
  // INVALID_PATH                 = 0;
  UNC_PATH                     = 1;
  // ABSOLUTE_DRIVE_PATH          = 2;
  // RELATIVE_DRIVE_PATH          = 3;
  // ABSOLUTE_PATH                = 4;
  // RELATIVE_PATH                = 5;
  // DEVICE_PATH                  = 6;
  // UNC_DOT_PATH                 = 7;

// =================================================================
// Function prototypes
// =================================================================

{$IFNDEF RTDL}
function RtlCreateUnicodeStringFromAsciiz(var destination: UNICODE_STRING;
  source: PAnsiChar): Boolean; stdcall; external szNtDll;

function ZwClose(Handle: THandle): NTSTATUS; stdcall; external szNtDll;

function ZwSetInformationFile(FileHandle: THandle; var IoStatusBlock: IO_STATUS_BLOCK;
  FileInformation: Pointer; FileInformationLength: ULONG;
  FileInformationClass: DWORD): NTSTATUS; stdcall; external szNtDll;

function RtlPrefixUnicodeString(const usPrefix: UNICODE_STRING;
  const usContainingString: UNICODE_STRING;
  ignore_case: Boolean): Boolean; stdcall; external szNtDll;

function ZwOpenSymbolicLinkObject(var LinkHandle: THandle; DesiredAccess: DWORD;
  const ObjectAttributes: OBJECT_ATTRIBUTES): NTSTATUS; stdcall; external szNtDll;

function ZwQuerySymbolicLinkObject(LinkHandle: THandle;
  var LinkTarget: UNICODE_STRING; ReturnedLength: PULONG): NTSTATUS; stdcall; external szNtDll;

function ZwOpenFile(var FileHandle: THandle; DesiredAccess: DWORD;
  const ObjectAttributes: OBJECT_ATTRIBUTES; var IoStatusBlock: IO_STATUS_BLOCK;
  ShareAccess: ULONG; OpenOptions: ULONG): NTSTATUS; stdcall; external szNtDll;

function GetProcessHeap: Pointer; stdcall; external szKernel32;

function RtlAllocateHeap(HeapHandle: Pointer;
  Flags, Size: ULONG): Pointer; stdcall; external szNtDll;

function RtlFreeHeap(HeapHandle: Pointer; Flags: ULONG;
  MemoryPointer: Pointer): Boolean; stdcall; external szNtDll;

function RtlDosPathNameToNtPathName_U(DosName: PWideChar;
  var NtName: UNICODE_STRING; DosFilePath: PPWideChar;
  NtFilePath: PUNICODE_STRING): Boolean; stdcall; external szNtDll;

function RtlInitUnicodeString(var DestinationString: UNICODE_STRING;
  const SourceString: PWideChar): NTSTATUS; stdcall; external szNtDll;

function RtlDetermineDosPathNameType_U(wcsPathNameType: PWideChar): DWORD; stdcall; external szNtDll;

function RtlNtStatusToDosError(status: NTSTATUS): ULONG; stdcall; external szNtDll;

{$ELSE RTDL}

type
  TRtlCreateUnicodeStringFromAsciiz = function(var destination: UNICODE_STRING;
    source: PAnsiChar): Boolean; stdcall;

  TZwClose = function(Handle: THandle): NTSTATUS; stdcall;

  TZwSetInformationFile = function(FileHandle: THandle;
    var IoStatusBlock: IO_STATUS_BLOCK; FileInformation: Pointer;
    FileInformationLength: ULONG; FileInformationClass: DWORD): NTSTATUS; stdcall;

  TRtlPrefixUnicodeString = function(const usPrefix: UNICODE_STRING;
    const usContainingString: UNICODE_STRING; ignore_case: Boolean): Boolean; stdcall;

  TZwOpenSymbolicLinkObject = function(var LinkHandle: THandle;
    DesiredAccess: DWORD; const ObjectAttributes: OBJECT_ATTRIBUTES): NTSTATUS; stdcall;

  TZwQuerySymbolicLinkObject = function(LinkHandle: THandle;
    var LinkTarget: UNICODE_STRING; ReturnedLength: PULONG): NTSTATUS; stdcall;

  TZwOpenFile = function(var FileHandle: THandle; DesiredAccess: DWORD;
    const ObjectAttributes: OBJECT_ATTRIBUTES; var IoStatusBlock: IO_STATUS_BLOCK;
    ShareAccess: ULONG; OpenOptions: ULONG): NTSTATUS; stdcall;

  TGetProcessHeap = function: Pointer; stdcall;

  TRtlAllocateHeap = function(HeapHandle: Pointer; Flags, Size: ULONG): Pointer; stdcall;

  TRtlFreeHeap = function(HeapHandle: Pointer; Flags: ULONG;
    MemoryPointer: Pointer): Boolean; stdcall;

  TRtlDosPathNameToNtPathName_U = function(DosName: PWideChar;
    var NtName: UNICODE_STRING; DosFilePath: PPWideChar;
    NtFilePath: PUNICODE_STRING): Boolean; stdcall;

  TRtlInitUnicodeString = function(var DestinationString: UNICODE_STRING;
    const SourceString: PWideChar): NTSTATUS; stdcall;

  TRtlDetermineDosPathNameType_U = function(wcsPathNameType: PWideChar): DWORD; stdcall;

  TRtlNtStatusToDosError = function(status: NTSTATUS): ULONG; stdcall;

// Declare all the _global_ function pointers for RTDL
var
  RtlCreateUnicodeStringFromAsciiz: TRtlCreateUnicodeStringFromAsciiz = nil;
  ZwClose: TZwClose = nil;
  ZwSetInformationFile: TZwSetInformationFile = nil;
  RtlPrefixUnicodeString: TRtlPrefixUnicodeString = nil;
  ZwOpenSymbolicLinkObject: TZwOpenSymbolicLinkObject = nil;
  ZwQuerySymbolicLinkObject: TZwQuerySymbolicLinkObject = nil;
  ZwOpenFile: TZwOpenFile = nil;
  GetProcessHeap: TGetProcessHeap = nil;
  RtlAllocateHeap: TRtlAllocateHeap = nil;
  RtlFreeHeap: TRtlFreeHeap = nil;
  RtlDosPathNameToNtPathName_U: TRtlDosPathNameToNtPathName_U = nil;
  RtlInitUnicodeString: TRtlInitUnicodeString = nil;
  RtlDetermineDosPathNameType_U: TRtlDetermineDosPathNameType_U = nil;
  RtlNtStatusToDosError: TRtlNtStatusToDosError = nil;
{$ENDIF RTDL}

(******************************************************************************

 Syntax:
 -------
  C-Prototype! (if STDCALL enabled)

  BOOL WINAPI CreateHardLink(
    LPCTSTR lpFileName,
    LPCTSTR lpExistingFileName,
    LPSECURITY_ATTRIBUTES lpSecurityAttributes // Reserved; Must be NULL!

 Compatibility:
 --------------
  The function can only work on file systems that support hardlinks through the
  underlying FS driver layer. Currently this only includes NTFS on the NT
  platform (as far as I know).
  The function works fine on Windows NT4/2000/XP and is considered to work on
  future Operating System versions derived from NT (including Windows 2003).

 Remarks:
 --------
  This function tries to resemble the original CreateHardLinkW() call from
  Windows 2000/XP/2003 Kernel32.DLL as close as possible. This is why many
  functions used are NT Native API, whereas one could use Delphi or Win32 API
  functions (e.g. memory management). BUT I included much more SEH code and
  omitted extra code to free buffers and close handles. This all is done during
  the FINALLY block (so there are no memory leaks anyway ;).

  Note, that neither Microsoft's code nor mine ignore the Security Descriptor
  from the SECURITY_ATTRIBUTES structure. In both cases the security descriptor
  is passed on to ZwOpenFile()!

  The limit of 1023 hardlinks to one file is probably related to the system or
  NTFS respectively. At least I saw no special hint, why there would be such a
  limit - the original CreateHardLink() does not check the number of links!
  Thus I consider the limit being the same for the original and my rewrite.

  For the ANSI version of this function see below ...

 Remarks from the  Platform SDK:
 -------------------------------
  Any directory entry for a file, whether created with CreateFile or
  CreateHardLink, is a hard link to the associated file. Additional hard links,
  created with the CreateHardLink function, allow you to have multiple directory
  entries for a file, that is, multiple hard links to the same file. These may
  be different names in the same directory, or they may be the same (or
  different) names in different directories. However, all hard links to a file
  must be on the same volume.
  Because hard links are just directory entries for a file, whenever an
  application modifies a file through any hard link, all applications using any
  other hard link to the file see the changes. Also, all of the directory
  entries are updated if the file changes. For example, if the file's size
  changes, all of the hard links to the file will show the new size.
  The security descriptor belongs to the file to which the hard link points.
  The link itself, being merely a directory entry, has no security descriptor.
  Thus, if you change the security descriptor of any hard link, you're actually
  changing the underlying file's security descriptor. All hard links that point
  to the file will thus allow the newly specified access. There is no way to
  give a file different security descriptors on a per-hard-link basis.
  This function does not modify the security descriptor of the file to be linked
  to, even if security descriptor information is passed in the
  lpSecurityAttributes parameter.
  Use DeleteFile to delete hard links. You can delete them in any order
  regardless of the order in which they were created.
  Flags, attributes, access, and sharing as specified in CreateFile operate on
  a per-file basis. That is, if you open a file with no sharing allowed, another
  application cannot share the file by creating a new hard link to the file.

  CreateHardLink does not work over the network redirector.

  Note that when you create a hard link on NTFS, the file attribute information
  in the directory entry is refreshed only when the file is opened or when
  GetFileInformationByHandle is called with the handle of the file of interest.

 ******************************************************************************)
function
{$IFNDEF PREFERAPI}
  CreateHardLinkW // This name is directly published if PREFERAPI is not defined
{$ELSE PREFERAPI}
  MyCreateHardLinkW // ... otherwise this one
{$ENDIF PREFERAPI}
  (szLinkName, szLinkTarget: PWideChar; lpSecurityAttributes: PSecurityAttributes): BOOL;
const
// Mask for any DOS style drive path in object manager notation
  wcsC_NtName: PWideChar = '\??\C:';
// Prefix of a mapped path's symbolic link
  wcsLanMan: PWideChar = '\Device\LanmanRedirector\';
// Size required to hold a number of wide characters to compare drive notation
  cbC_NtName = $10; // 16 bytes
// Access mask to use for opening - just two bits
  dwDesiredAccessHL = DELETE or SYNCHRONIZE;
// OpenOptions for opening of the link target
// The flag FILE_OPEN_REPARSE_POINT has been found by comparison. Probably it carries
// some information wether the file is on the same volume?!
  dwOpenOptionsHL = FILE_SYNCHRONOUS_IO_NONALERT or FILE_OPEN_FOR_BACKUP_INTENT or FILE_OPEN_REPARSE_POINT;
// ShareAccess flags
  dwShareAccessHL = FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE;
var
  usNtName_LinkName, usNtName_LinkTarget: UNICODE_STRING;
  usCheckDrive, usSymLinkDrive, usLanMan: UNICODE_STRING;
  wcsNtName_LinkTarget, wcsFilePart_LinkTarget: PWideChar;
  oaMisc: OBJECT_ATTRIBUTES;
  IOStats: IO_STATUS_BLOCK;
  hHeap: Pointer;
  NeededSize: DWORD;
  Status: NTSTATUS;
  hLinkTarget, hDrive: THandle;
  lpFileLinkInfo: PFILE_LINK_INFORMATION;
begin
  Result := False;
{$IFDEF RTDL}
  if not bRtdlFunctionsLoaded then
    Exit;
{$ENDIF RTDL}
  // Get process' heap
  hHeap := GetProcessHeap;
  {-------------------------------------------------------------
  Preliminary parameter checks which do Exit with error code set
  --------------------------------------------------------------}
  // If any is not assigned ...
  if (szLinkName = nil) or (szLinkTarget = nil) then
  begin
    SetLastError(ERROR_INVALID_PARAMETER);
    Exit;
  end;
  // Determine DOS path type for both link name and target
  if (RtlDetermineDosPathNameType_U(szLinkName) = UNC_PATH) or
    (RtlDetermineDosPathNameType_U(szLinkTarget) = UNC_PATH) then
  begin
    SetLastError(ERROR_INVALID_NAME);
    Exit;
  end;
  // Convert the link target into a UNICODE_STRING
  usNtName_LinkTarget.Length := 0;
  if not RtlDosPathNameToNtPathName_U(szLinkTarget, usNtName_LinkTarget, nil, nil) then
  begin
    SetLastError(ERROR_PATH_NOT_FOUND);
    Exit;
  end;
  {------------------------
  Actual main functionality
  -------------------------}
  // Initialise the length members
  RtlInitUnicodeString(usNtName_LinkTarget, usNtName_LinkTarget.Buffer);
  // Get needed buffer size (in TCHARs)
  NeededSize := GetFullPathNameW(szLinkTarget, 0, nil, PWideChar(nil^));
  if NeededSize <> 0 then
  begin
    // Calculate needed size (in TCHARs)
    NeededSize := NeededSize + 1; // times SizeOf(WideChar)
    // Freed in FINALLY
    wcsNtName_LinkTarget := RtlAllocateHeap(hHeap, HEAP_ZERO_MEMORY, NeededSize * SizeOf(WideChar));
    // If successfully allocated buffer ...
    if wcsNtName_LinkTarget <> nil then
      try
        {----------------------------------------------------
        Preparation of the checking for mapped network drives
        -----------------------------------------------------}
        // Get the full unicode path name
        wcsFilePart_LinkTarget := nil;
        if GetFullPathNameW(szLinkTarget, NeededSize, wcsNtName_LinkTarget, wcsFilePart_LinkTarget) <> 0 then
        begin
          // Allocate memory to check the drive object
          usCheckDrive.Buffer := RtlAllocateHeap(hHeap, HEAP_ZERO_MEMORY, cbC_NtName);
          // On success ...
          if usCheckDrive.Buffer <> nil then
            try
              // Copy to buffer and set length members
              lstrcpynW(usCheckDrive.Buffer, wcsC_NtName, lstrlenW(wcsC_NtName) + 1);
              RtlInitUnicodeString(usCheckDrive, usCheckDrive.Buffer);
              // Replace drive letter by the drive letter we want
              usCheckDrive.Buffer[4] := wcsNtName_LinkTarget[0];
              // Init OBJECT_ATTRIBUTES
              oaMisc.Length := SizeOf(oaMisc);
              oaMisc.RootDirectory := 0;
              oaMisc.ObjectName := @usCheckDrive;
              oaMisc.Attributes := OBJ_CASE_INSENSITIVE;
              oaMisc.SecurityDescriptor := nil;
              oaMisc.SecurityQualityOfService := nil;
              {--------------------------------------------
              Checking for (illegal!) mapped network drives
              ---------------------------------------------}
              // Open symbolic link object
              hDrive := 0;
              if ZwOpenSymbolicLinkObject(hDrive, SYMBOLIC_LINK_QUERY, oaMisc) = STATUS_SUCCESS then
                try
                  usSymLinkDrive.Buffer := RtlAllocateHeap(hHeap, HEAP_ZERO_MEMORY, MAX_PATH * SizeOf(WideChar));
                  if usSymLinkDrive.Buffer <> nil then
                    try
                      // Query the path the symbolic link points to ...
                      ZwQuerySymbolicLinkObject(hDrive, usSymLinkDrive, nil);
                      // Initialise the length members
                      usLanMan.Length := 0;
                      RtlInitUnicodeString(usLanMan, wcsLanMan);
                      // The path must not be a mapped drive ... check this!
                      if not RtlPrefixUnicodeString(usLanMan, usSymLinkDrive, True) then
                      begin
                        // Initialise OBJECT_ATTRIBUTES
                        oaMisc.Length := SizeOf(oaMisc);
                        oaMisc.RootDirectory := 0;
                        oaMisc.ObjectName := @usNtName_LinkTarget;
                        oaMisc.Attributes := OBJ_CASE_INSENSITIVE;
                        // Set security descriptor in OBJECT_ATTRIBUTES if they were given
                        if lpSecurityAttributes <> nil then
                          oaMisc.SecurityDescriptor := lpSecurityAttributes^.lpSecurityDescriptor
                        else
                          oaMisc.SecurityDescriptor := nil;
                        oaMisc.SecurityQualityOfService := nil;
                        {----------------------
                        Opening the target file
                        -----------------------}
                        IOStats.Status := 0;
                        hLinkTarget := 0;
                        Status := ZwOpenFile(hLinkTarget, dwDesiredAccessHL, oaMisc,
                          IOStats, dwShareAccessHL, dwOpenOptionsHL);
                        if Status = STATUS_SUCCESS then
                          try
                            // Wow ... target opened ... let's try to
                            usNtName_LinkName.Length := 0;
                            if RtlDosPathNameToNtPathName_U(szLinkName, usNtName_LinkName, nil, nil) then
                              try
                                // Initialise the length members
                                RtlInitUnicodeString(usNtName_LinkName, usNtName_LinkName.Buffer);
                                // Now almost everything is done to create a link!
                                NeededSize := usNtName_LinkName.Length +
                                  SizeOf(FILE_LINK_INFORMATION) + SizeOf(WideChar);
                                lpFileLinkInfo := RtlAllocateHeap(hHeap, HEAP_ZERO_MEMORY, NeededSize);
                                if lpFileLinkInfo <> nil then
                                  try
                                    lpFileLinkInfo^.ReplaceIfExists := False;
                                    lpFileLinkInfo^.RootDirectory := 0;
                                    lpFileLinkInfo^.FileNameLength := usNtName_LinkName.Length;
                                    lstrcpynW(lpFileLinkInfo.FileName, usNtName_LinkName.Buffer,
                                      usNtName_LinkName.Length);
                                    {----------------------------------------------------
                                    Final creation of the link - "center" of the function
                                    -----------------------------------------------------}
                                    // Hard-link the file as intended
                                    Status := ZwSetInformationFile(hLinkTarget, IOStats,
                                      lpFileLinkInfo, NeededSize, FileLinkInformation);
                                    // On success return TRUE
                                    Result := Status >= 0;
                                  finally
                                    // Free the buffer
                                    RtlFreeHeap(hHeap, 0, lpFileLinkInfo);
                                    // Set last error code
                                    SetLastError(RtlNtStatusToDosError(Status));
                                  end
                                else // if lpFileLinkInfo <> nil then
                                  SetLastError(ERROR_NOT_ENOUGH_MEMORY);
                              finally
                                RtlFreeHeap(hHeap, 0, usNtName_LinkName.Buffer);
                              end
                            else // if RtlDosPathNameToNtPathName_U(szLinkName, usNtName_LinkName...
                              SetLastError(ERROR_INVALID_NAME);
                          finally
                            ZwClose(hLinkTarget);
                          end
                        else // if Status = STATUS_SUCCESS then
                          SetLastError(RtlNtStatusToDosError(Status));
                      end
                      else // if not RtlPrefixUnicodeString(usLanMan, usSymLinkDrive, True) then
                        SetLastError(ERROR_INVALID_NAME);
                    finally
                      RtlFreeHeap(hHeap, 0, usSymLinkDrive.Buffer);
                    end
                  else // if usSymLinkDrive.Buffer <> nil then
                    SetLastError(ERROR_NOT_ENOUGH_MEMORY);
                finally
                  ZwClose(hDrive);
                end;
            finally
              RtlFreeHeap(hHeap, 0, usCheckDrive.Buffer);
            end
          else // if usCheckDrive.Buffer <> nil then
            SetLastError(ERROR_NOT_ENOUGH_MEMORY);
        end
        else // if GetFullPathNameW(szLinkTarget, NeededSize, wcsNtName_LinkTarget...
          SetLastError(ERROR_INVALID_NAME);
      finally
        RtlFreeHeap(hHeap, 0, wcsNtName_LinkTarget);
      end
    else // if wcsNtName_LinkTarget <> nil then
      SetLastError(ERROR_NOT_ENOUGH_MEMORY);
  end
  else // if NeededSize <> 0 then
    SetLastError(ERROR_INVALID_NAME);
  // Finally free the buffer
  RtlFreeHeap(hHeap, 0, usNtName_LinkTarget.Buffer);
end;

(******************************************************************************
 Hint:
 -----
  For all closer information see the CreateHardLinkW function above.

 Specific to the ANSI-version:
 -----------------------------
  The ANSI-Version can be used as if it was used on Windows 2000. This holds
  for all supported systems for now.

 ******************************************************************************)

function
{$IFNDEF PREFERAPI}
  CreateHardLinkA // This name is directly published if PREFERAPI is not defined
{$ELSE PREFERAPI}
  MyCreateHardLinkA // ... otherwise this one
{$ENDIF PREFERAPI}
  (szLinkName, szLinkTarget: PAnsiChar; lpSecurityAttributes: PSecurityAttributes): BOOL;
var
  usLinkName: UNICODE_STRING;
  usLinkTarget: UNICODE_STRING;
  hHeap: Pointer;
begin
  Result := False;
{$IFDEF RTDL}
  if not bRtdlFunctionsLoaded then
    Exit;
{$ENDIF RTDL}
  // Get the process' heap
  hHeap := GetProcessHeap;
  // Create and allocate a UNICODE_STRING from the zero-terminated parameters
  usLinkName.Length := 0;
  if RtlCreateUnicodeStringFromAsciiz(usLinkName, szLinkName) then
  try
    usLinkTarget.Length := 0;
    if RtlCreateUnicodeStringFromAsciiz(usLinkTarget, szLinkTarget) then
    try
      // Call the Unicode version
      Result := CreateHardLinkW(usLinkName.Buffer, usLinkTarget.Buffer, lpSecurityAttributes);
    finally
      // free the allocated buffer
      RtlFreeHeap(hHeap, 0, usLinkTarget.Buffer);
    end;
  finally
    // free the allocate buffer
    RtlFreeHeap(hHeap, 0, usLinkName.Buffer);
  end;
end;

{$IFDEF RTDL}
const
// Names of the functions to import
  szRtlCreateUnicodeStringFromAsciiz = 'RtlCreateUnicodeStringFromAsciiz';
  szZwClose                          = 'ZwClose';
  szZwSetInformationFile             = 'ZwSetInformationFile';
  szRtlPrefixUnicodeString           = 'RtlPrefixUnicodeString';
  szZwOpenSymbolicLinkObject         = 'ZwOpenSymbolicLinkObject';
  szZwQuerySymbolicLinkObject        = 'ZwQuerySymbolicLinkObject';
  szZwOpenFile                       = 'ZwOpenFile';
  szGetProcessHeap                   = 'GetProcessHeap';
  szRtlAllocateHeap                  = 'RtlAllocateHeap';
  szRtlFreeHeap                      = 'RtlFreeHeap';
  szRtlDosPathNameToNtPathName_U     = 'RtlDosPathNameToNtPathName_U';
  szRtlInitUnicodeString             = 'RtlInitUnicodeString';
  szRtlDetermineDosPathNameType_U    = 'RtlDetermineDosPathNameType_U';
  szRtlNtStatusToDosError            = 'RtlNtStatusToDosError';
{$ENDIF RTDL}

var
  hKernel32: THandle = 0;

initialization
  {$IFDEF UNITVERSIONING}
  RegisterUnitVersion(HInstance, UnitVersioning);
  {$ENDIF UNITVERSIONING}

  // GetModuleHandle because this DLL is loaded into any Win32 subsystem process anyway
  // implicitly. And Delphi cannot create applications for other subsystems without
  // major changes in SysInit und System units.
  hKernel32 := GetModuleHandle(kernel32);
  {$IFDEF PREFERAPI}
  // If we prefer the real Windows APIs try to get their addresses
  @CreateHardLinkA := GetProcAddress(hKernel32, szCreateHardLinkA);
  @CreateHardLinkW := GetProcAddress(hKernel32, szCreateHardLinkW);
  // If they could not be retrieved resort to our home-grown version
  if not (Assigned(@CreateHardLinkA) and Assigned(@CreateHardLinkW)) then
  begin
  {$ENDIF PREFERAPI}

  {$IFDEF RTDL}
  // GetModuleHandle because this DLL is loaded into any Win32 subsystem process anyway
  // implicitly. And Delphi cannot create applications for other subsystems without
  // major changes in SysInit und System units.
  hNtDll := GetModuleHandle(szNtDll);
  if hNtDll <> 0 then
  begin
    // Get all the function addresses
    @RtlCreateUnicodeStringFromAsciiz := GetProcAddress(hNtDll, szRtlCreateUnicodeStringFromAsciiz);
    @ZwClose := GetProcAddress(hNtDll, szZwClose);
    @ZwSetInformationFile := GetProcAddress(hNtDll, szZwSetInformationFile);
    @RtlPrefixUnicodeString := GetProcAddress(hNtDll, szRtlPrefixUnicodeString);
    @ZwOpenSymbolicLinkObject := GetProcAddress(hNtDll, szZwOpenSymbolicLinkObject);
    @ZwQuerySymbolicLinkObject := GetProcAddress(hNtDll, szZwQuerySymbolicLinkObject);
    @ZwOpenFile := GetProcAddress(hNtDll, szZwOpenFile);
    @GetProcessHeap := GetProcAddress(hKernel32, szGetProcessHeap);
    @RtlAllocateHeap := GetProcAddress(hNtDll, szRtlAllocateHeap);
    @RtlFreeHeap := GetProcAddress(hNtDll, szRtlFreeHeap);
    @RtlDosPathNameToNtPathName_U := GetProcAddress(hNtDll, szRtlDosPathNameToNtPathName_U);
    @RtlInitUnicodeString := GetProcAddress(hNtDll, szRtlInitUnicodeString);
    @RtlDetermineDosPathNameType_U := GetProcAddress(hNtDll, szRtlDetermineDosPathNameType_U);
    @RtlNtStatusToDosError := GetProcAddress(hNtDll, szRtlNtStatusToDosError);
    // Check whether we could retrieve all of them
    bRtdlFunctionsLoaded := // Update the "loaded" status
      Assigned(@RtlCreateUnicodeStringFromAsciiz) and
      Assigned(@ZwClose) and
      Assigned(@ZwSetInformationFile) and
      Assigned(@RtlPrefixUnicodeString) and
      Assigned(@ZwOpenSymbolicLinkObject) and
      Assigned(@ZwQuerySymbolicLinkObject) and
      Assigned(@ZwOpenFile) and
      Assigned(@GetProcessHeap) and
      Assigned(@RtlAllocateHeap) and
      Assigned(@RtlFreeHeap) and
      Assigned(@RtlDosPathNameToNtPathName_U) and
      Assigned(@RtlInitUnicodeString) and
      Assigned(@RtlDetermineDosPathNameType_U) and
      Assigned(@RtlNtStatusToDosError);
  end;
  {$ENDIF RTDL}

  {$IFDEF PREFERAPI}
    @CreateHardLinkA := @MyCreateHardLinkA;
    @CreateHardLinkW := @MyCreateHardLinkW;
  end; // if not (Assigned(@CreateHardLinkA) and Assigned(@CreateHardLinkW)) then ...
  {$ENDIF PREFERAPI}

  {$IFDEF UNITVERSIONING}
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}

{$IFNDEF JCL}
//--------------------------------------------------------------------------------------------------
{$ENDIF ~JCL}

end.

