hardlinks.pas

East make Tray Icon in delphi

  // 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 := NtpGetProcessHeap;
  // Create and allocate a UNICODE_STRING from the zero-terminated parameters
  if RtlCreateUnicodeStringFromAsciiz(usLinkName, szLinkName) then
  try
    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';
  szRtlAllocateHeap                  = 'RtlAllocateHeap';
  szRtlFreeHeap                      = 'RtlFreeHeap';
  szRtlDosPathNameToNtPathName_U     = 'RtlDosPathNameToNtPathName_U';
  szRtlInitUnicodeString             = 'RtlInitUnicodeString';
  szRtlDetermineDosPathNameType_U    = 'RtlDetermineDosPathNameType_U';
  szRtlNtStatusToDosError            = 'RtlNtStatusToDosError';
{$ENDIF RTDL}

{$IFDEF PREFERAPI}
var
  hKernel32: THandle = 0;
{$ENDIF PREFERAPI}

initialization
  {$IFDEF PREFERAPI}
  // 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);
  // 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);
    @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(@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}

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

// History:

{$IFDEF PROTOTYPE}
// $Log: Hardlinks.pas,v $
// Revision 1.12  2005/03/08 08:33:18  marquardt
// overhaul of exceptions and resourcestrings, minor style cleaning
//
// Revision 1.11  2005/03/06 11:03:29  assarbad
// - Changed prototype of RtlDosPathNameToNtPathName_U()
//
// Revision 1.10  2005/03/03 13:47:04  assarbad
// - Dividing lines now enclosed by a preprocessor statement to still show in the author's version.
// - Removed PEB/TEB/TIB declarations and renamed one function (see author's version comments for details v1.13)
// - Any OSI-approved license qualifies now for licensing of this module.
//
// Revision 1.9  2005/02/24 16:34:41  marquardt
// - remove divider lines, add section lines (unfinished)
//
// Revision 1.8  2004/10/29 05:46:36  marquardt
// - style cleaning
//
// Revision 1.7  2004/10/26 14:23:48  assarbad
// - Implementation of Robert Marquardts proposals for the sake of brevity
//   in the CreateHardLinkW() implementation - C-like returns
// - Removal of potential bug in CreateHardLinkA() implementation
// - Removal of two unused function prototypes
// - Some more comments and corrections and indentations
// - Perl script to create "my" version from JCL prototype
// - Compiles fine on Delphi 4 (minor changes would be necessary for D3)
//
// Revision 1.6  2004/10/26 00:05:45  assarbad
// - Removed some superfluous records/structs and constants
// - Replaced literals by symbolic names (constants) to make the source more meaningful
// - Checked with Delphi 4 after preprocessing by JPP - works
// - Will not yet check in the preprocessed version - still discussing in the egroup about it
//
// Revision 1.5  2004/10/25 15:05:12  marquardt
// - remove strange round braces in Hardlinks.pas, bugfix JclRegistry.pas
//
// Revision 1.4  2004/10/22 01:26:50  rrossmair
// - fixed style cleaning collateral damage (as far as required to make it compile)
//
// Revision 1.3  2004/10/21 21:58:03  assarbad
// - minimal changes in the prototype
//   (change of the filename for the release version on assarbad.net
//    Hardlink.pas -> Hardlinks.pas
//    The JCL prototype is now reference for "my" release version)
// - creation of new unit from style-cleaned prototype
//
// Revision 1.2  2004/10/21 17:53:03  marquardt
// - style cleaning
//
// Revision 1.1  2004/10/20 19:49:00  rrossmair
// - added prototype unit Hardlinks (formerly known as Hardlink)
// - modified makefile accordingly
//
{$ENDIF PROTOTYPE}

{
   Version 1.13a - 2005-03-06
   + Minor correction in the prototype of RtlDosPathNameToNtPathName_U()
     to easier pass NIL as the 4th parameter.
     
   Version 1.13 - 2005-03-03
   + NtMyGetProcessHeap() renamed to NtpGetProcessHeap()
   + Removed declarations for TEB/PEB/TIB and supplement. As they depend
     on structures which are unlikely to change, the respective offsets
     can be hardcoded. As soon as this function becomes OS-version-
     dependent, adapted offsets will be used.

   Version 1.12c - 2004-10-26
   + Implementation of Robert Marquardts proposals for the sake of brevity
     in the CreateHardLinkW() implementation - C-like returns
   + Removal of potential bug in CreateHardLinkA() implementation
   + Removal of two unused function prototypes
   + Some more comments and corrections and indentations
   + Perl script to create "my" version from JCL prototype
   + Compiles fine on Delphi 4 (minor changes would be necessary for D3)

   Version 1.12b - 2004-10-26
   + Added some constants and replaced literals by them
   + Removed some superfluous constants and records

   Version 1.12a - 2004-10-21
   + "Original" file renamed according to the change in the JCL prototype
     Hardlink.pas -> Hardlinks.pas
   + The original version is now being created using:
     jpp -c -uJCL -dMSWINDOWS -uUNIX -uHAS_UNIT_LIBC -x..\ Hardlinks.pas
   + Changes will first occur in this prototype and the output of the
     preprocessor undefining the "JCL" symbol will be mirrored to my site
     afterwards. The prototype at the JCL is the reference from now on.

   Version 1.12 - 2004-10-18
   + Code-cleaning (removal of the currently not working softlink stuff from 1.10)
   + Comments for Project JEDI (JCL)
   + Some extra declarations to be compatible with JclNTFS
   + Runtime dynamic linking
   + Checked into the JCL

   Version 1.11 - 2004-07-01
   + Bugfix from Nico Bendlin - Odd behavior of NtMyGetProcessHeap()

  ! Version 1.10 - 2004-04-16 [this was taken out again in 1.12]
  ! + Implemented softlinks for directories (junction points/reparse points)

   Version 1.01 - 2003-08-25
   + Implemented hardlinks
}

end.