{**************************************************************************************************}
{                                                                                                  }
{ 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 Original Code is JclNTFS.pas.                                                                }
{                                                                                                  }
{ The Initial Developer of the Original Code is Marcel van Brakel. Portions created by Marcel van  }
{ Brakel are Copyright (C) Marcel van Brakel. All Rights Reserved.                                 }
{                                                                                                  }
{ Contributor(s):                                                                                  }
{   Marcel van Brakel                                                                              }
{   Robert Marquardt (marquardt)                                                                   }
{   Robert Rossmair (rrossmair)                                                                    }
{   Petr Vones (pvones)                                                                            }
{   Oliver Schneider (assarbad)                                                                    }
{                                                                                                  }
{**************************************************************************************************}
{                                                                                                  }
{ Contains routines to perform filesystem related tasks available only with NTFS. These are mostly }
{ relatively straightforward wrappers for various IOCTs related to compression, sparse files,      }
{ reparse points, volume mount points and so forth. Note that some functions require NTFS 5 or     }
{ higher!                                                                                          }
{                                                                                                  }
{**************************************************************************************************}

// Last modified: $Date: 2005/03/08 08:33:22 $
// For history see end of file


// Comments on Win9x compatibility of the functions used in this unit

// These stubs exist on Windows 95B already but all of them
// return ERROR_CALL_NOT_IMPLEMENTED:
//   BackupSeek, BackupRead, BackupWrite

unit JclNTFS;

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

interface

uses
  Windows, Classes,
  JclBase, JclWin32;

// NTFS Exception
type
  EJclNtfsError = class(EJclWin32Error);

// NTFS - Compression
type
  TFileCompressionState = (fcNoCompression, fcDefaultCompression, fcLZNT1Compression);

function NtfsGetCompression(const FileName: string; var State: Short): Boolean; overload;
function NtfsGetCompression(const FileName: string): TFileCompressionState; overload;
function NtfsSetCompression(const FileName: string; const State: Short): Boolean;
procedure NtfsSetFileCompression(const FileName: string; const State: TFileCompressionState);
procedure NtfsSetDirectoryTreeCompression(const Directory: string; const State: TFileCompressionState);
procedure NtfsSetDefaultFileCompression(const Directory: string; const State: TFileCompressionState);
procedure NtfsSetPathCompression(const Path: string; const State: TFileCompressionState; Recursive: Boolean);

// NTFS - Sparse Files
type
  TNtfsAllocRanges = record
    Entries: Integer;
    Data: PFileAllocatedRangeBuffer;
    MoreData: Boolean;
  end;

function NtfsSetSparse(const FileName: string): Boolean;
function NtfsZeroDataByHandle(const Handle: THandle; const First, Last: Int64): Boolean;
function NtfsZeroDataByName(const FileName: string; const First, Last: Int64): Boolean;
function NtfsQueryAllocRanges(const FileName: string; Offset, Count: Int64; var Ranges: TNtfsAllocRanges): Boolean;
function NtfsGetAllocRangeEntry(const Ranges: TNtfsAllocRanges; Index: Integer): TFileAllocatedRangeBuffer;
function NtfsSparseStreamsSupported(const Volume: string): Boolean;
function NtfsGetSparse(const FileName: string): Boolean;

// NTFS - Reparse Points
function NtfsDeleteReparsePoint(const FileName: string; ReparseTag: DWORD): Boolean;
function NtfsSetReparsePoint(const FileName: string; var ReparseData; Size: Longword): Boolean;
function NtfsGetReparsePoint(const FileName: string; var ReparseData: TReparseGuidDataBuffer): Boolean;
function NtfsGetReparseTag(const Path: string; var Tag: DWORD): Boolean;
function NtfsReparsePointsSupported(const Volume: string): Boolean;
function NtfsFileHasReparsePoint(const Path: string): Boolean;

// NTFS - Volume Mount Points
function NtfsIsFolderMountPoint(const Path: string): Boolean;
function NtfsMountDeviceAsDrive(const Device: string; Drive: Char): Boolean;
function NtfsMountVolume(const Volume: Char; const MountPoint: string): Boolean;

// NTFS - Change Journal
// NTFS - Opportunistic Locks
type
  TOpLock = (olExclusive, olReadOnly, olBatch, olFilter);

function NtfsOpLockAckClosePending(Handle: THandle; Overlapped: TOverlapped): Boolean;
function NtfsOpLockBreakAckNo2(Handle: THandle; Overlapped: TOverlapped): Boolean;
function NtfsOpLockBreakAcknowledge(Handle: THandle; Overlapped: TOverlapped): Boolean;
function NtfsOpLockBreakNotify(Handle: THandle; Overlapped: TOverlapped): Boolean;
function NtfsRequestOpLock(Handle: THandle; Kind: TOpLock; Overlapped: TOverlapped): Boolean;

// Junction Points
function NtfsCreateJunctionPoint(const Source, Destination: string): Boolean;
function NtfsDeleteJunctionPoint(const Source: string): Boolean;
function NtfsGetJunctionPointDestination(const Source: string; var Destination: string): Boolean;

// Streams
type
  TStreamId = (siInvalid, siStandard, siExtendedAttribute, siSecurity, siAlternate,
    siHardLink, siProperty, siObjectIdentifier, siReparsePoints, siSparseFile);
  TStreamIds = set of TStreamId;

  TInternalFindStreamData = record
    FileHandle: THandle;
    Context: Pointer;
    StreamIds: TStreamIds;
  end;

  TFindStreamData = record
    Internal: TInternalFindStreamData;
    Attributes: DWORD;
    StreamID: TStreamId;
    Name: WideString;
    Size: Int64;
  end;

function NtfsFindFirstStream(const FileName: string; StreamIds: TStreamIds; var Data: TFindStreamData): Boolean;
function NtfsFindNextStream(var Data: TFindStreamData): Boolean;
function NtfsFindStreamClose(var Data: TFindStreamData): Boolean;

// Hard links
function NtfsCreateHardLink(const LinkFileName, ExistingFileName: String): Boolean;
// ANSI-specific version
function NtfsCreateHardLinkA(const LinkFileName, ExistingFileName: AnsiString): Boolean;
// UNICODE-specific version
function NtfsCreateHardLinkW(const LinkFileName, ExistingFileName: WideString): Boolean;

type
  TNtfsHardLinkInfo = record
    LinkCount: Cardinal;
    case Integer of
    0: (
      FileIndexHigh: Cardinal;
      FileIndexLow: Cardinal);
    1: (
      FileIndex: Int64);
  end;

function NtfsGetHardLinkInfo(const FileName: string; var Info: TNtfsHardLinkInfo): Boolean;

function NtfsFindHardLinks(const Path: string; const FileIndexHigh, FileIndexLow: Cardinal; const List: TStrings): Boolean;
function NtfsDeleteHardLinks(const FileName: string): Boolean;

implementation

uses
  {$IFDEF FPC}
  WinSysUt,
  {$ENDIF FPC}
  SysUtils, Hardlinks,
  JclFileUtils, JclSysInfo, JclResources, JclSecurity;

//=== NTFS - Compression =====================================================

// Helper consts, helper types, helper routines

const
  CompressionFormat: array [TFileCompressionState] of Short =
  (
    COMPRESSION_FORMAT_NONE,
    COMPRESSION_FORMAT_DEFAULT,
    COMPRESSION_FORMAT_LZNT1
  );

  // use IsDirectory(FileName) as array index
  FileFlag: array [Boolean] of DWORD = (0, FILE_FLAG_BACKUP_SEMANTICS);

type
  TStackFrame = packed record
    CallersEBP: DWord;
    CallerAddress: DWord;
  end;

  EJclInvalidArgument = class(EJclError);

{$STACKFRAMES OFF}

function CallersCallerAddress: Pointer;
asm
        MOV     EAX, [EBP]
        MOV     EAX, TStackFrame([EAX]).CallerAddress
end;

{$STACKFRAMES ON}

procedure ValidateArgument(Condition: Boolean; const Routine: string;
  const Argument: string);
begin
  if not Condition then
    raise EJclInvalidArgument.CreateResFmt(@RsInvalidArgument, [Routine, Argument])
      at CallersCallerAddress;
end;

{$IFNDEF STACKFRAMES_ON}
{$STACKFRAMES OFF}
{$ENDIF ~STACKFRAMES_ON}

function SetCompression(const FileName: string; const State: Short; FileFlag: DWORD): Boolean;
var
  Handle: THandle;
  BytesReturned: DWORD;
  Buffer: Short;
begin
  Result := False;
  Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE,
    FILE_SHARE_READ, nil, OPEN_EXISTING, FileFlag, 0);
  if Handle <> INVALID_HANDLE_VALUE then
  try
    Buffer := State;
    Result := DeviceIoControl(Handle, FSCTL_SET_COMPRESSION, @Buffer,
      SizeOf(Short), nil, 0, BytesReturned, nil);
  finally
    CloseHandle(Handle);
  end
end;

function SetPathCompression(Dir: string; const Mask: string; const State: Short;
  const SetDefault, Recursive: Boolean): Boolean;
var
  FileName: string;
  SearchRec: TSearchRec;
  R: Integer;
begin
  if SetDefault then
    Result := SetCompression(Dir, State, FILE_FLAG_BACKUP_SEMANTICS)
  else
    Result := True;
  if Result then
  begin
    Dir := PathAddSeparator(Dir);
    if FindFirst(Dir + Mask, faAnyFile, SearchRec) = 0 then
    try
      repeat
        if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
        begin
          FileName := Dir + SearchRec.Name;
          if (SearchRec.Attr and faDirectory) = 0 then
            Result := SetCompression(FileName, State, 0)
          else
            if Recursive then
              Result := SetPathCompression(FileName, Mask, State, SetDefault, True);
          if not Result then
            Exit;
        end;
        R := FindNext(SearchRec);
      until R <> 0;
      Result := (R = ERROR_NO_MORE_FILES);
    finally
      SysUtils.FindClose(SearchRec);
    end;
  end;
end;

function NtfsGetCompression(const FileName: string; var State: Short): Boolean;
var
  Handle: THandle;
  BytesReturned: DWORD;
begin
  Result := False;
  Handle := CreateFile(PChar(FileName), 0, 0, nil, OPEN_EXISTING,
    FileFlag[IsDirectory(FileName)], 0);
  if Handle <> INVALID_HANDLE_VALUE then
    try
      Result := DeviceIoControl(Handle, FSCTL_GET_COMPRESSION, nil, 0, @State,
        SizeOf(Short), BytesReturned, nil);
    finally
      CloseHandle(Handle);
    end;
end;

function NtfsGetCompression(const FileName: string): TFileCompressionState;
var
  State: Short;
begin
  if not NtfsGetCompression(FileName, State) then
    RaiseLastOSError;
  case State of
    COMPRESSION_FORMAT_NONE:
      Result := fcNoCompression;
    COMPRESSION_FORMAT_LZNT1:
      Result := fcLZNT1Compression;
  else
    // (rom) very dubious.
    Assert(False, 'TFileCompressionState requires expansion');
    Result := TFileCompressionState(State);
  end;
end;

function NtfsSetCompression(const FileName: string; const State: Short): Boolean;
begin
  Result := SetCompression(FileName, State, FileFlag[IsDirectory(FileName)]);
end;

{$STACKFRAMES ON}

procedure NtfsSetFileCompression(const FileName: string; const State: TFileCompressionState);
begin
  ValidateArgument(not IsDirectory(FileName), 'NtfsSetFileCompression', 'FileName');
  if not SetCompression(FileName, CompressionFormat[State], 0) then
    RaiseLastOSError;
end;

procedure NtfsSetDefaultFileCompression(const Directory: string; const State: TFileCompressionState);
begin
  ValidateArgument(IsDirectory(Directory), 'NtfsSetDefaultFileCompression', 'Directory');
  if not SetCompression(Directory, CompressionFormat[State], FILE_FLAG_BACKUP_SEMANTICS) then
    RaiseLastOSError;
end;

procedure NtfsSetDirectoryTreeCompression(const Directory: string; const State: TFileCompressionState);
begin
  ValidateArgument(IsDirectory(Directory), 'NtfsSetDirectoryTreeCompression', 'Directory');
  if not SetPathCompression(Directory, '*', CompressionFormat[State], True, True) then
    RaiseLastOSError;
end;

{$IFNDEF STACKFRAMES_ON}
{$STACKFRAMES OFF}
{$ENDIF ~STACKFRAMES_ON}

procedure NtfsSetPathCompression(const Path: string;
  const State: TFileCompressionState; Recursive: Boolean);
var
  Dir, Mask: string;
  SetDefault: Boolean;
begin
  SetDefault := IsDirectory(Path);
  if SetDefault then
  begin
    Dir := Path;
    Mask := '*';
  end
  else
  begin
    Dir := ExtractFilePath(Path);
    Mask := ExtractFileName(Path);
    if Mask = '' then
      Mask := '*';
  end;
  if not SetPathCompression(Dir, Mask, CompressionFormat[State], SetDefault, Recursive) then
    RaiseLastOSError;
end;

//=== NTFS - Sparse Files ====================================================

function NtfsSetSparse(const FileName: string): Boolean;
var
  Handle: THandle;
  BytesReturned: DWORD;
begin
  Result := False;
  Handle := CreateFile(PChar(FileName), GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);
  if Handle <> INVALID_HANDLE_VALUE then
    try
      Result := DeviceIoControl(Handle, FSCTL_SET_SPARSE, nil, 0, nil, 0, BytesReturned, nil);
    finally
      CloseHandle(Handle);
    end;
end;

function NtfsZeroDataByHandle(const Handle: THandle; const First, Last: Int64): Boolean;
var
  BytesReturned: DWORD;
  ZeroDataInfo: TFileZeroDataInformation;
  Info: TByHandleFileInformation;
begin
  Result := False;
  if Handle <> INVALID_HANDLE_VALUE then
  begin
    // Continue only if the file is a sparse file, this avoids the overhead
    // associated with an IOCTL when the file isn't even a sparse file.
    GetFileInformationByHandle(Handle, Info);
    Result := (Info.dwFileAttributes and FILE_ATTRIBUTE_SPARSE_FILE) <> 0;
    if Result then
    begin
      ZeroDataInfo.FileOffset.QuadPart := First;
      ZeroDataInfo.BeyondFinalZero.QuadPart := Last;
      Result := DeviceIoControl(Handle, FSCTL_SET_ZERO_DATA, @ZeroDataInfo,
        SizeOf(ZeroDataInfo), nil, 0, BytesReturned, nil);
    end;
  end;
end;

function NtfsZeroDataByName(const FileName: string; const First, Last: Int64): Boolean;
var
  Handle: THandle;
begin
  Result := False;
  Handle := CreateFile(PChar(FileName), GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);
  if Handle <> INVALID_HANDLE_VALUE then
    try
      Result := NtfsZeroDataByHandle(Handle, First, Last);
    finally
      CloseHandle(Handle);
    end;
end;

function NtfsGetAllocRangeEntry(const Ranges: TNtfsAllocRanges;
  Index: Integer): TFileAllocatedRangeBuffer;
var
  Offset: Longint;
begin
  Assert((Index >= 0) and (Index < Ranges.Entries));
  Offset := Longint(Ranges.Data) + Index * SizeOf(TFileAllocatedRangeBuffer);
  Result := PFileAllocatedRangeBuffer(Offset)^;
end;

function __QueryAllocRanges(const Handle: THandle; const Offset, Count: Int64;
  var Ranges: PFileAllocatedRangeBuffer; var MoreData: Boolean; var Size: Cardinal): Boolean;
var
  BytesReturned: DWORD;
  SearchRange: TFileAllocatedRangeBuffer;
  BufferSize: Cardinal;
begin
  SearchRange.FileOffset.QuadPart := Offset;
  SearchRange.Length.QuadPart := Count;
  BufferSize := 4 * 64 * SizeOf(TFileAllocatedRangeBuffer);
  Ranges := AllocMem(BufferSize);
  Result := DeviceIoControl(Handle, FSCTL_QUERY_ALLOCATED_RANGES, @SearchRange,
    SizeOf(SearchRange), Ranges, BufferSize, BytesReturned, nil);
  MoreData := GetLastError = ERROR_MORE_DATA;
  if MoreData then
    Result := True;
  Size := BytesReturned;
  if BytesReturned = 0 then
  begin
    FreeMem(Ranges);
    Ranges := nil;
  end;
end;

function NtfsQueryAllocRanges(const FileName: string; Offset, Count: Int64;
  var Ranges: TNtfsAllocRanges): Boolean;
var
  Handle: THandle;
  CurrRanges: PFileAllocatedRangeBuffer;
  R, MoreData: Boolean;
  Size: Cardinal;
begin
  Result := False;
  Handle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
  if Handle <> INVALID_HANDLE_VALUE then
  try
    R := __QueryAllocRanges(Handle, Offset, Count, CurrRanges, MoreData, Size);
    Ranges.MoreData := MoreData;
    Result := R;
    if R then
    begin
      Ranges.Entries := Size div SizeOf(TFileAllocatedRangeBuffer);
      Ranges.Data := CurrRanges;
    end
    else
    begin
      Ranges.Entries := 0;
      Ranges.Data := nil;
    end;
  finally
    CloseHandle(Handle);
  end;
end;

function NtfsSparseStreamsSupported(const Volume: string): Boolean;
begin
  Result := fsSupportsSparseFiles in GetVolumeFileSystemFlags(Volume);
end;

function NtfsGetSparse(const FileName: string): Boolean;
var
  Handle: THandle;
  Info: TByHandleFileInformation;
begin
  Result := False;
  Handle := CreateFile(PChar(FileName), 0, FILE_SHARE_READ or FILE_SHARE_WRITE,
    nil, OPEN_EXISTING, 0, 0);
  if Handle <> INVALID_HANDLE_VALUE then
    try
      GetFileInformationByHandle(Handle, Info);
      Result := (Info.dwFileAttributes and FILE_ATTRIBUTE_SPARSE_FILE) <> 0;
    finally
      CloseHandle(Handle);
    end;
end;

//=== NTFS - Reparse Points ==================================================

function NtfsGetReparseTag(const Path: string; var Tag: DWORD): Boolean;
var
  SearchRec: TSearchRec;
begin
  Result := NtfsFileHasReparsePoint(Path);
  if Result then
  begin
    Result := FindFirst(Path, faAnyFile, SearchRec) = 0;
    if Result then
    begin
      // Check if file has a reparse point
      Result := ((SearchRec.Attr and FILE_ATTRIBUTE_REPARSE_POINT) <> 0);
      // If so the dwReserved0 field contains the reparse tag
      if Result then
        Tag := SearchRec.FindData.dwReserved0;
      FindClose(SearchRec);
    end;
  end;
end;

function NtfsReparsePointsSupported(const Volume: string): Boolean;
begin
  Result := fsSupportsReparsePoints in GetVolumeFileSystemFlags(Volume);
end;

function NtfsFileHasReparsePoint(const Path: string): Boolean;
var
  Attr: DWORD;
begin
  Result := False;
  Attr := GetFileAttributes(PChar(Path));
  if Attr <> DWORD(-1) then
    Result := (Attr and FILE_ATTRIBUTE_REPARSE_POINT) <> 0;
end;

function NtfsDeleteReparsePoint(const FileName: string; ReparseTag: DWORD): Boolean;
var
  Handle: THandle;
  BytesReturned: DWORD;
  ReparseData: TReparseGuidDataBuffer;
begin
  Result := False;
  Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil,
    OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0);
  if Handle <> INVALID_HANDLE_VALUE then
    try
      FillChar(ReparseData, SizeOf(ReparseData), #0);
      ReparseData.ReparseTag := ReparseTag;
      Result := DeviceIoControl(Handle, FSCTL_DELETE_REPARSE_POINT, @ReparseData,
        REPARSE_GUID_DATA_BUFFER_HEADER_SIZE, nil, 0, BytesReturned, nil);
    finally
      CloseHandle(Handle);
    end;
end;

function NtfsSetReparsePoint(const FileName: string; var ReparseData; Size: Longword): Boolean;
var
  Handle: THandle;
  BytesReturned: DWORD;
begin
  Result := False;
  Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil,
    OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0);
  if Handle <> INVALID_HANDLE_VALUE then
    try
      Result := DeviceIoControl(Handle, FSCTL_SET_REPARSE_POINT, @ReparseData,
        Size, nil, 0, BytesReturned, nil);
    finally
      CloseHandle(Handle);
    end;
end;

function NtfsGetReparsePoint(const FileName: string; var ReparseData: TReparseGuidDataBuffer): Boolean;
var
  Handle: THandle;
  BytesReturned: DWORD;
  LastError: DWORD;
begin
  Result := False;
  Handle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil,
    OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0);
  LastError := GetLastError;
  if Handle <> INVALID_HANDLE_VALUE then
    try
      Result := DeviceIoControl(Handle, FSCTL_GET_REPARSE_POINT, nil, 0, @ReparseData,
        ReparseData.ReparseDataLength + SizeOf(ReparseData), BytesReturned, nil);
      if not Result then
      begin
        ReparseData.ReparseDataLength := BytesReturned;
        LastError := GetLastError;
      end;
    finally
      CloseHandle(Handle);
      SetLastError(LastError);
    end;
end;

//=== NTFS - Volume Mount Points =============================================

function NtfsIsFolderMountPoint(const Path: string): Boolean;
var
  Tag: DWORD;
begin
  Result := NtfsGetReparseTag(Path, Tag);
  if Result then
    Result := (Tag = IO_REPARSE_TAG_MOUNT_POINT);
end;

function NtfsMountDeviceAsDrive(const Device: string; Drive: Char): Boolean;
const
  DDD_FLAGS = DDD_RAW_TARGET_PATH or DDD_REMOVE_DEFINITION or DDD_EXACT_MATCH_ON_REMOVE;
var
  DriveStr: string;
  VolumeName: string;
begin
  // To create a mount point we must obtain a unique volume name first. To obtain
  // a unique volume name the drive must exist. Therefore we must temporarily
  // create a symbolic link for the drive using DefineDosDevice.
  DriveStr := Drive + ':';
  Result := DefineDosDevice(DDD_RAW_TARGET_PATH, PChar(DriveStr), PChar(Device));
  if Result then
  begin
    SetLength(VolumeName, 1024);
    Result := RtdlGetVolumeNameForVolumeMountPoint(PChar(DriveStr + '\'),
      PChar(VolumeName), 1024);
    // Attempt to delete the symbolic link, if it fails then don't attempt to
    // set the mountpoint either but raise an exception instead, there's something
    // seriously wrong so let's try to control the damage done already :)
    if not DefineDosDevice(DDD_FLAGS, PChar(DriveStr), PChar(Device)) then
      raise EJclNtfsError.CreateRes(@RsNtfsUnableToDeleteSymbolicLink);
    if Result then
      Result := RtdlSetVolumeMountPoint(PChar(DriveStr + '\'), PChar(VolumeName));
  end;
end;

function NtfsMountVolume(const Volume: Char; const MountPoint: string): Boolean;
var
  VolumeName: string;
  VolumeStr: string;
begin
  SetLength(VolumeName, 1024);
  VolumeStr := Volume + ':\';
  Result := RtdlGetVolumeNameForVolumeMountPoint(PChar(VolumeStr), PChar(VolumeName), 1024);
  if Result then
  begin
    if not JclFileUtils.DirectoryExists(MountPoint) then
      JclFileUtils.ForceDirectories(MountPoint);
    Result := RtdlSetVolumeMountPoint(PChar(MountPoint), PChar(VolumeName));
  end;
end;

//=== NTFS - Change Journal ==================================================

//=== NTFS - Opportunistic Locks =============================================

function NtfsOpLockAckClosePending(Handle: THandle; Overlapped: TOverlapped): Boolean;
var
  BytesReturned: Cardinal;
begin
  Result := DeviceIoControl(Handle, FSCTL_OPBATCH_ACK_CLOSE_PENDING, nil, 0, nil,
    0, BytesReturned, @Overlapped);
end;

function NtfsOpLockBreakAckNo2(Handle: THandle; Overlapped: TOverlapped): Boolean;
var
  BytesReturned: Cardinal;
begin
  Result := DeviceIoControl(Handle, FSCTL_OPLOCK_BREAK_ACK_NO_2, nil, 0, nil, 0,
    BytesReturned, @Overlapped);
end;

function NtfsOpLockBreakAcknowledge(Handle: THandle; Overlapped: TOverlapped): Boolean;
var
  BytesReturned: Cardinal;
begin
  Result := DeviceIoControl(Handle, FSCTL_OPLOCK_BREAK_ACKNOWLEDGE, nil, 0, nil,
    0, BytesReturned, @Overlapped);
  Result := Result or (GetLastError = ERROR_IO_PENDING);
end;

function NtfsOpLockBreakNotify(Handle: THandle; Overlapped: TOverlapped): Boolean;
var
  BytesReturned: Cardinal;
begin
  Result := DeviceIoControl(Handle, FSCTL_OPLOCK_BREAK_NOTIFY, nil, 0, nil, 0,
    BytesReturned, @Overlapped);
end;

function NtfsRequestOpLock(Handle: THandle; Kind: TOpLock; Overlapped: TOverlapped): Boolean;
const
  IoCodes: array [TOpLock] of Cardinal = (
    FSCTL_REQUEST_OPLOCK_LEVEL_1, FSCTL_REQUEST_OPLOCK_LEVEL_2,
    FSCTL_REQUEST_BATCH_OPLOCK, FSCTL_REQUEST_FILTER_OPLOCK);
var
  BytesReturned: Cardinal;
begin
  Result := DeviceIoControl(Handle, IoCodes[Kind], nil, 0, nil, 0, BytesReturned, @Overlapped);
  Result := Result or (GetLastError = ERROR_IO_PENDING);
end;

//=== Junction Points ========================================================

type
  TReparseDataBufferOverlay = record
  case Boolean of
    False:
      (Reparse: TReparseDataBuffer;);
    True:
      (Buffer: array [0..MAXIMUM_REPARSE_DATA_BUFFER_SIZE] of Char;);
  end;
  
function IsReparseTagValid(Tag: DWORD): Boolean;
begin
  Result := (Tag and (not IO_REPARSE_TAG_VALID_VALUES) = 0) and
    (Tag > IO_REPARSE_TAG_RESERVED_RANGE);
end;

function NtfsCreateJunctionPoint(const Source, Destination: string): Boolean;
var
  Dest: array [0..1024] of Char; // Writable copy of Destination
  DestW: WideString;             // Unicode version of Dest
  FullDir: array [0..1024] of Char;
  FilePart: PChar;
  ReparseData: TReparseDataBufferOverlay;
  NameLength: Longword;
begin
  Result := False;
  // For some reason the destination string must be prefixed with \??\ otherwise
  // the IOCTL will fail, ensure it's there.
  if Copy(Destination, 1, 3) = '\??' then
    StrPCopy(Dest, Destination)
  else
  begin
    // Make sure Destination is a directory or again, the IOCTL will fail.
    if (GetFullPathName(PChar(Destination), 1024, FullDir, FilePart) = 0) or
      (GetFileAttributes(FullDir) = DWORD(-1)) then
    begin
      SetLastError(ERROR_PATH_NOT_FOUND);
      Exit;
    end;
    StrPCopy(Dest, '\??\' + Destination);
  end;
  FillChar(ReparseData, SizeOf(ReparseData), #0);
  NameLength := StrLen(Dest) * SizeOf(WideChar);
  ReparseData.Reparse.ReparseTag := IO_REPARSE_TAG_MOUNT_POINT;
  ReparseData.Reparse.ReparseDataLength := NameLength + 12;
  ReparseData.Reparse.SubstituteNameLength := NameLength;
  ReparseData.Reparse.PrintNameOffset := NameLength + 2;
  // Not the most elegant way to copy an AnsiString into an Unicode buffer but
  // let's avoid dependencies on JclUnicode.pas (adds significant resources).
  DestW := WideString(Dest);
  Move(DestW[1], ReparseData.Reparse.PathBuffer, Length(DestW) * SizeOf(WideChar));
  Result := NtfsSetReparsePoint(Source, ReparseData.Reparse,
    ReparseData.Reparse.ReparseDataLength + REPARSE_DATA_BUFFER_HEADER_SIZE);
end;

function NtfsDeleteJunctionPoint(const Source: string): Boolean;
begin
  Result := NtfsDeleteReparsePoint(Source, IO_REPARSE_TAG_MOUNT_POINT);
end;

function NtfsGetJunctionPointDestination(const Source: string; var Destination: string): Boolean;
var
  Handle: THandle;
  ReparseData: TReparseDataBufferOverlay;
  BytesReturned: DWORD;
begin
  Result := False;
  if NtfsFileHasReparsePoint(Source) then
  begin
    Handle := CreateFile(PChar(Source), GENERIC_READ, 0, nil,
      OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0);
    if Handle <> INVALID_HANDLE_VALUE then
    try
      if DeviceIoControl(Handle, FSCTL_GET_REPARSE_POINT, nil, 0, @ReparseData,
        MAXIMUM_REPARSE_DATA_BUFFER_SIZE, BytesReturned, nil) {and
        IsReparseTagValid(ReparseData.Reparse.ReparseTag) then}
        then
      begin
        if BytesReturned >= ReparseData.Reparse.SubstituteNameLength + SizeOf(WideChar) then
        begin
          SetLength(Destination, (ReparseData.Reparse.SubstituteNameLength div SizeOf(WideChar)) + 1);
          WideCharToMultiByte(CP_THREAD_ACP, 0, ReparseData.Reparse.PathBuffer,
            (ReparseData.Reparse.SubstituteNameLength div SizeOf(WCHAR)) + 1,
            PChar(Destination), Length(Destination), nil, nil);
          Result := True;
        end;
      end;
    finally
      CloseHandle(Handle);
    end
  end;
end;

//=== Streams ================================================================

// FindStream is an internal helper routine for NtfsFindFirstStream and
// NtfsFindNextStream. It uses the backup API to enumerate the streams in an
// NTFS file and returns when it either finds a stream that matches the filter
// specified in the Data parameter or hits EOF. Details are returned through
// the Data parameter and success/failure as the Boolean result value.

function FindStream(var Data: TFindStreamData): Boolean;
var
  Header: TWin32StreamId;
  BytesToRead, BytesRead: DWORD;
  BytesToSeek: TULargeInteger;
  Hi, Lo: DWORD;
  FoundStream: Boolean;
  StreamName: PWideChar;
begin
  Result := False;
  FoundStream := False;
  // We loop until we either found a stream or an error occurs.
  while not FoundStream do
  begin
    // Read stream header
    BytesToRead := DWORD(@Header.cStreamName[0]) - DWORD(@Header.dwStreamId);
    if not Windows.BackupRead(Data.Internal.FileHandle, (@Header), BytesToRead, BytesRead,
      False, True, Data.Internal.Context) then
    begin
      SetLastError(ERROR_READ_FAULT);
      Exit;
    end;
    if BytesRead = 0 then // EOF
    begin
      SetLastError(ERROR_NO_MORE_FILES);
      Exit;
    end;
    // If stream has a name then read it
    if Header.dwStreamNameSize > 0 then
    begin
      StreamName := HeapAlloc(GetProcessHeap, 0, Header.dwStreamNameSize + SizeOf(WCHAR));
      if StreamName = nil then
      begin
        SetLastError(ERROR_OUTOFMEMORY);
        Exit;
      end;
      if not Windows.BackupRead(Data.Internal.FileHandle, Pointer(StreamName),
        Header.dwStreamNameSize, BytesRead, False, True, Data.Internal.Context) then
      begin
        HeapFree(GetProcessHeap, 0, StreamName);
        SetLastError(ERROR_READ_FAULT);
        Exit;
      end;
      StreamName[Header.dwStreamNameSize div SizeOf(WCHAR)] := WideChar(#0);
    end
    else
      StreamName := nil;
    // Did we find any of the specified streams ([] means any stream)?
    if (Data.Internal.StreamIds = []) or
      (TStreamId(Header.dwStreamId) in Data.Internal.StreamIds) then
    begin
      FoundStream := True;
      {$IFDEF FPC}
      Data.Size := Header.Size.QuadPart;
      {$ELSE}
      Data.Size := Header.Size;
      {$ENDIF FPC}
      Data.Name := StreamName;
      Data.Attributes := Header.dwStreamAttributes;
      Data.StreamId := TStreamId(Header.dwStreamId);
    end;
    // Release stream name memory if necessary
    if Header.dwStreamNameSize > 0 then
      HeapFree(GetProcessHeap, 0, StreamName);
    // Move past data part to beginning of next stream (or EOF)
    {$IFDEF FPC}
    BytesToSeek.QuadPart := Header.Size.QuadPart;
    if (Header.Size.QuadPart <> 0) and (not JclWin32.BackupSeek(Data.Internal.FileHandle, BytesToSeek.LowPart,
         BytesToSeek.HighPart, Lo, Hi, Data.Internal.Context)) then
    {$ELSE}
    BytesToSeek.QuadPart := Header.Size;
    if (Header.Size <> 0) and (not JclWin32.BackupSeek(Data.Internal.FileHandle, BytesToSeek.LowPart,
      BytesToSeek.HighPart, Lo, Hi, Data.Internal.Context)) then
    {$ENDIF FPC}
    begin
      SetLastError(ERROR_READ_FAULT);
      Exit;
    end;
  end;
  // Due to the usage of Exit, we only get here if everything succeeded
  Result := True;
end;

function NtfsFindFirstStream(const FileName: string; StreamIds: TStreamIds;
  var Data: TFindStreamData): Boolean;
begin
  Result := False;
  // Open file for reading, note that the FILE_FLAG_BACKUP_SEMANTICS requires
  // the SE_BACKUP_NAME and SE_RESTORE_NAME privileges.
  Data.Internal.FileHandle := CreateFile(PChar(FileName), GENERIC_READ,
    FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
    FILE_FLAG_BACKUP_SEMANTICS, 0);
  if Data.Internal.FileHandle <> INVALID_HANDLE_VALUE then
  begin
    // Initialize private context
    Data.Internal.StreamIds := StreamIds;
    Data.Internal.Context := nil;
    // Call upon the Borg worker to find the next (first) stream
    Result := FindStream(Data);
    if not Result then
    begin
      // Failure, cleanup relieving the caller of having to call FindStreamClose
      CloseHandle(Data.Internal.FileHandle);
      Data.Internal.FileHandle := INVALID_HANDLE_VALUE;
      Data.Internal.Context := nil;
      if GetLastError = ERROR_NO_MORE_FILES then
        SetLastError(ERROR_FILE_NOT_FOUND);
    end;
  end;
end;

function NtfsFindNextStream(var Data: TFindStreamData): Boolean;
begin
  Result := False;
  if Data.Internal.FileHandle <> INVALID_HANDLE_VALUE then
    Result := FindStream(Data)
  else
    SetLastError(ERROR_INVALID_HANDLE);
end;

function NtfsFindStreamClose(var Data: TFindStreamData): Boolean;
var
  BytesRead: DWORD;
  LastError: DWORD;
begin
  Result := Data.Internal.FileHandle <> INVALID_HANDLE_VALUE;
  LastError := ERROR_SUCCESS;
  if Result then
  begin
    // Call BackupRead one last time to signal that we're done with it
    Result := Windows.BackupRead(0, nil, 0, BytesRead, True, False, Data.Internal.Context);
    if not Result then
      LastError := GetLastError;
    CloseHandle(Data.Internal.FileHandle);
    Data.Internal.FileHandle := INVALID_HANDLE_VALUE;
    Data.Internal.Context := nil;
  end
  else
    LastError := ERROR_INVALID_HANDLE;
  SetLastError(LastError);
end;

//=== Hard links =============================================================
(*
   Implementation of CreateHardLink completely swapped to the unit Hardlink.pas

   As with all APIs on the NT platform this version is completely implemented in
   UNICODE and calling the ANSI version results in conversion of parameters and
   call of the underlying UNICODE version of the function.

   This holds both for the homegrown and the Windows API (where it exists).
*)

// For a description see: NtfsCreateHardLink()
(* ANSI implementation of the function - calling UNICODE anyway ;-) *)
function NtfsCreateHardLinkA(const LinkFileName, ExistingFileName: AnsiString): Boolean;
begin
  // Invoke either (homegrown vs. API) function and supply NIL for security attributes
  Result := CreateHardLinkA(PAnsiChar(LinkFileName), PAnsiChar(ExistingFileName), nil);
end;

// For a description see: NtfsCreateHardLink()
(* UNICODE implementation of the function - we are on NT, aren't we ;-) *)
function NtfsCreateHardLinkW(const LinkFileName, ExistingFileName: WideString): Boolean;
begin
  // Invoke either (homegrown vs. API) function and supply NIL for security attributes
  Result := CreateHardLinkW(PWideChar(LinkFileName), PWideChar(ExistingFileName), nil);
end;

// NtfsCreateHardLink
//
// Creates a hardlink on NT 4 and above.
// Both, LinkFileName and ExistingFileName must reside on the same, NTFS formatted volume.
//
// LinkName:          Name of the hard link to create
// ExistingFileName:  Fully qualified path of the file for which to create a hard link
// Result:            True if successfull,
//                    False if failed.
//                    In the latter case use GetLastError to obtain the reason of failure.
//
// Remark:
//   Hardlinks are the same as cross-referenced files were on DOS. With one exception
//   on NTFS they are allowed and are a feature of the filesystem, whereas on FAT
//   they were a feared kind of corruption of the filesystem.
//
//   Hardlinks are no more than references (with different names, but not necessarily
//   in different directories) of the filesystem to exactly the same data!
//
//   To test this you may create a hardlink to some file on your harddisk and then edit
//   it using Notepad (some editors do not work on the original file, but Notepad does).
//   The changes will appear in the "linked" and the "original" location.
//
//   Why did I use quotes? Easy: hardlinks are references to the same data - and such
//   as with handles the object (i.e. data) is only destroyed after all references are
//   "released". To "release" a reference (i.e. a hardlink) simply delete it using
//   the well-known methods to delete files. Because:
//
//   Files are hardlinks and hardlinks are files.
//
//   The above holds for NTFS volumes (and those filesystems supporting hardlinks).
//   Why all references need to reside on the same volume should be clear from these
//   remarks.
function NtfsCreateHardLink(const LinkFileName, ExistingFileName: String): Boolean;
{$DEFINE ANSI} // TODO: review for possible existing compatible DEFINES in the JCL
begin
  {$IFDEF ANSI}
  Result := CreateHardLinkA(PAnsiChar(LinkFileName), PAnsiChar(ExistingFileName), nil);
  {$ELSE}
  Result := CreateHardLinkW(PWideChar(LinkFileName), PWideChar(ExistingFileName));
  {$ENDIF ANSI}
end;

function NtfsGetHardLinkInfo(const FileName: string; var Info: TNtfsHardLinkInfo): Boolean;
var
  F: THandle;
  FileInfo: TByHandleFileInformation;
begin
  Result := False;
  F := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  if F <> INVALID_HANDLE_VALUE then
  try
    if GetFileInformationByHandle(F, FileInfo) then
    begin
      Info.LinkCount := FileInfo.nNumberOfLinks;
      Info.FileIndexHigh := FileInfo.nFileIndexHigh;
      Info.FileIndexLow := FileInfo.nFileIndexLow;
      Result := True;
    end;
  finally
    CloseHandle(F);
  end
end;

function NtfsFindHardLinks(const Path: string; const FileIndexHigh, FileIndexLow: Cardinal; const List: TStrings): Boolean;
var
  SearchRec: TSearchRec;
  R: Integer;
  Info: TNtfsHardLinkInfo;
begin
  // start the search
  R := FindFirst(Path + '\*.*', faAnyFile, SearchRec);
  Result := (R = 0);
  if Result then
  begin
    List.BeginUpdate;
    try
      while R = 0 do
      begin
        if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
        begin
          if (SearchRec.Attr and faDirectory) = faDirectory then
          begin
            // recurse into subdirectory
            Result := NtfsFindHardLinks(Path + '\' + SearchRec.Name, FileIndexHigh, FileIndexLow, List);
            if not Result then
              Break;
          end
          else
          begin
            // found a file, is it a hard link?
            if NtfsGetHardLinkInfo(Path + '\' + SearchRec.Name, Info) then
            begin
              if (Info.FileIndexHigh = FileIndexHigh) and (Info.FileIndexLow = FileIndexLow) then
                List.Add(Path + '\' + SearchRec.Name);
            end;
          end;
        end;
        R := FindNext(SearchRec);
      end;
      Result := R = ERROR_NO_MORE_FILES;
    finally
      SysUtils.FindClose(SearchRec);
      List.EndUpdate;
    end;
  end;
  if R = ERROR_ACCESS_DENIED then
    Result := True;
end;

function NtfsDeleteHardLinks(const FileName: string): Boolean;
var
  FullPathName: string;
  FilePart: PChar;
  Files: TStringList;
  I: Integer;
  Info: TNtfsHardLinkInfo;
begin
  Result := False;
  // get the full pathname of the specified file
  SetLength(FullPathName, MAX_PATH);
  GetFullPathName(PChar(FileName), MAX_PATH, PChar(FullPathName), FilePart);
  SetLength(FullPathName, StrLen(PChar(FullPathName)));
  // get hard link information
  if NtfsGetHardLinkInfo(FullPathName, Info) then
  begin
    Files := TStringList.Create;
    try
      if Info.LinkCount > 1 then
      begin
        // find all hard links for this file
        if not NtfsFindHardLinks(FullPathName[1] + ':', Info.FileIndexHigh, Info.FileIndexLow, Files) then
          Exit;
        // first delete the originally specified file from the list, we don't delete that one until all hard links
        // are succesfully deleted so we can use it to restore them if anything goes wrong. Theoretically one could
        // use any of the hard links but in case the restore goes wrong, at least the specified file still exists...
        for I := 0 to Files.Count - 1 do
        begin
          if CompareStr(FullPathName, Files[I]) = 0 then
          begin
            Files.Delete(I);
            Break;
          end;
        end;
        // delete all found hard links
        I := 0;
        while I < Files.Count do
        begin
          if not DeleteFile(Files[I]) then
            Break;
          Inc(I);
        end;
        if I = Files.Count then
        begin
          // all hard links succesfully deleted, now delete the originally specified file. if this fails we set
          // I to Files.Count - 1 so that the next code block will restore all hard links we just deleted.
          Result := DeleteFile(FullPathName);
          if not Result then
            I := Files.Count - 1;
        end;
        if I < Files.Count then
        begin
          // not all hard links could be deleted, attempt to restore the ones that were
          while I >= 0 do
          begin
            // ignore result, just attempt to restore...
            NtfsCreateHardLink(Files[I], FullPathName);
            Dec(I);
          end;
        end;
      end
      else
        // there are no hard links, just delete the file
        Result := DeleteFile(FullPathName);
    finally
      Files.Free;
    end;
  end;
end;

// History:

// $Log: JclNTFS.pas,v $
// Revision 1.23  2005/03/08 08:33:22  marquardt
// overhaul of exceptions and resourcestrings, minor style cleaning
//
// Revision 1.22  2005/02/25 07:20:16  marquardt
// add section lines
//
// Revision 1.21  2005/02/24 16:34:52  marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.20  2004/12/07 02:46:44  rrossmair
// - NtfsSparseStreamsSupported, NtfsReparsePointsSupported:
//   Fixed bug in call to GetVolumeInformation (did not ensure trailing backslash)
//   by replacing it with new function JclSysInfo.GetVolumeFileSystemFlags
//
// Revision 1.19  2004/10/20 19:52:15  rrossmair
// - renamed Hardlink to Hardlinks
// - Hardlinks now generated from prototype unit
//
// Revision 1.18  2004/10/19 06:26:48  marquardt
// JclRegistry extended, JclNTFS made compiling, JclDateTime style cleaned
//
// Revision 1.17  2004/10/18 18:42:49  assarbad
// Just removed a stupidity (BTW: introduced by PH)
//
// Revision 1.16  2004/10/18 18:20:55  assarbad
// Completely replaced the CreateHardLink() implementation. For the sake of brevity it is kept in the separate unit Hardlink.pas now.
//
// Please check wether it compiles. I had to change fragments as the JCL will not compile on my Delphi 4.
//
// Revision 1.15  2004/10/17 21:00:15  mthoma
// cleaning
//
// Revision 1.14  2004/07/31 06:21:03  marquardt
// fixing TStringLists, adding BeginUpdate/EndUpdate, finalization improved
//
// Revision 1.13  2004/07/29 07:58:21  marquardt
// inc files updated
//
// Revision 1.12  2004/07/28 18:00:53  marquardt
// various style cleanings, some minor fixes
//
// Revision 1.11  2004/07/14 03:00:34  rrossmair
// fixed bug #1962 ( NtfsCreateJunctionPoint fails if a \\??\\ path is used)
//
// Revision 1.10  2004/06/16 07:30:31  marquardt
// added tilde to all IFNDEF ENDIFs, inherited qualified
//
// Revision 1.9  2004/06/14 11:05:53  marquardt
// symbols added to all ENDIFs and some other minor style changes like removing IFOPT
//
// Revision 1.8  2004/05/31 00:30:45  rrossmair
// Processed documentation TODOs
//
// Revision 1.7  2004/05/13 07:46:06  rrossmair
// changes for FPC 1.9.3+ compatibility
//
// Revision 1.6  2004/05/05 07:33:49  rrossmair
// header updated according to new policy: initial developers & contributors listed
//
// Revision 1.5  2004/04/06 04:55:18
// adapt compiler conditions, add log entry
//

end.