jclntfs.pas

East make Tray Icon in delphi

  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.