From 51986b390fc7b928650a22296d9f38f559026570 Mon Sep 17 00:00:00 2001 From: Dm Bel Date: Thu, 11 Jul 2019 14:48:13 +0300 Subject: [PATCH] include last fixes --- .../debug/converter/JclDebugIdeImpl.pas | 4 + jcl/source/common/JclBase.pas | 5 + jcl/source/common/JclFileUtils.pas | 97 ++++----- jcl/source/common/JclResources.pas | 6 +- jcl/source/common/JclSynch.pas | 6 +- jcl/source/common/JclSysInfo.pas | 65 ++++++- jcl/source/prototypes/win32api/WinNT.int | 42 +++- jcl/source/windows/JclDotNet.pas | 102 +++++++++- jcl/source/windows/JclNTFS.pas | 184 ++++++++++++++---- jcl/source/windows/JclWin32.pas | 41 +++- readme.md | 2 +- 11 files changed, 448 insertions(+), 106 deletions(-) diff --git a/jcl/experts/debug/converter/JclDebugIdeImpl.pas b/jcl/experts/debug/converter/JclDebugIdeImpl.pas index b709126cf5..22daa53b22 100644 --- a/jcl/experts/debug/converter/JclDebugIdeImpl.pas +++ b/jcl/experts/debug/converter/JclDebugIdeImpl.pas @@ -605,6 +605,10 @@ procedure TJclDebugExtension.DisplayResults; begin if FBuildError or (Length(FResultInfo) = 0) then Exit; + + if Assigned(Settings) and (Settings.LoadBool(JclDebugQuietSetting, false)) then + Exit; + with TJclDebugResultForm.Create(Application, Settings) do try for I := 0 to Length(FResultInfo) - 1 do diff --git a/jcl/source/common/JclBase.pas b/jcl/source/common/JclBase.pas index 635aa8d02d..f561227ec9 100644 --- a/jcl/source/common/JclBase.pas +++ b/jcl/source/common/JclBase.pas @@ -161,6 +161,11 @@ ULARGE_INTEGER = record TJclULargeInteger = ULARGE_INTEGER; PJclULargeInteger = PULARGE_INTEGER; + {$IFNDEF COMPILER16_UP} + LONG = Longint; + {$EXTERNALSYM LONG} + {$ENDIF ~COMPILER16_UP} + // Dynamic Array support type TDynByteArray = array of Byte; diff --git a/jcl/source/common/JclFileUtils.pas b/jcl/source/common/JclFileUtils.pas index e02fd393c3..bbb6147148 100644 --- a/jcl/source/common/JclFileUtils.pas +++ b/jcl/source/common/JclFileUtils.pas @@ -6970,22 +6970,23 @@ function PathListItemIndex(const List, Item: string): Integer; // returns the name of the command line parameter at position index, which is // separated by the given separator, if the first character of the name part // is one of the AllowedPrefixCharacters, this character will be deleted. -function ParamName (Index : Integer; const Separator : string = '='; - const AllowedPrefixCharacters : string = '-/'; TrimName : Boolean = true) : string; -var s: string; - p: Integer; +function ParamName(Index: Integer; const Separator: string; + const AllowedPrefixCharacters: string; TrimName: Boolean): string; +var + S: string; + P: Integer; begin - if (index > 0) and (index <= ParamCount) then + if (Index > 0) and (Index <= ParamCount) then begin - s := ParamStr(index); - if Pos(Copy(s, 1, 1), AllowedPrefixCharacters) > 0 then - s := Copy (s, 2, Length(s)-1); - p := Pos(Separator, s); - if p > 0 then - s := Copy (s, 1, p-1); + S := ParamStr(Index); + if Pos(Copy(S, 1, 1), AllowedPrefixCharacters) > 0 then + S := Copy(S, 2, Length(S) - 1); + P := Pos(Separator, S); + if P > 0 then + S := Copy(S, 1, P - 1); if TrimName then - s := Trim(s); - Result := s; + S := Trim(S); + Result := S; end else Result := ''; @@ -6993,19 +6994,20 @@ function ParamName (Index : Integer; const Separator : string = '='; // returns the value of the command line parameter at position index, which is // separated by the given separator -function ParamValue (Index : Integer; const Separator : string = '='; TrimValue : Boolean = true) : string; -var s: string; - p: Integer; +function ParamValue(Index: Integer; const Separator: string; TrimValue: Boolean): string; +var + S: string; + P: Integer; begin - if (index > 0) and (index <= ParamCount) then + if (Index > 0) and (Index <= ParamCount) then begin - s := ParamStr(index); - p := Pos(Separator, s); - if p > 0 then - s := Copy (s, p+1, Length(s)-p); + S := ParamStr(Index); + P := Pos(Separator, S); + if P > 0 then + S := Copy(S, P + 1, Length(S) - P); if TrimValue then - s := Trim(s); - Result := s; + S := Trim(S); + Result := S; end else Result := ''; @@ -7015,21 +7017,25 @@ function ParamValue (Index : Integer; const Separator : string = '='; TrimValue // and returns the value which is which by the given separator. // CaseSensitive defines the search type. if the first character of the name part // is one of the AllowedPrefixCharacters, this character will be deleted. -function ParamValue (const SearchName : string; const Separator : string = '='; - CaseSensitive : Boolean = False; - const AllowedPrefixCharacters : string = '-/'; TrimValue : Boolean = true) : string; -var pName : string; - i : Integer; +function ParamValue(const SearchName: string; const Separator: string; + CaseSensitive: Boolean; const AllowedPrefixCharacters: string; + TrimValue: Boolean): string; +var + Name: string; + SearchS: String; + I: Integer; begin Result := ''; - for i := 1 to ParamCount do + SearchS := Trim(SearchName); + + for I := 1 to ParamCount do begin - pName := ParamName(i, Separator, AllowedPrefixCharacters, True); - if (CaseSensitive and (pName = Trim(SearchName))) or - (UpperCase(pName) = Trim(UpperCase(SearchName))) then + Name := ParamName(I, Separator, AllowedPrefixCharacters, True); + if (CaseSensitive and (Name = SearchS)) or + ((not CaseSensitive) and (CompareText(Name, SearchS) = 0)) then begin - Result := ParamValue (i, Separator, TrimValue); - exit; + Result := ParamValue(I, Separator, TrimValue); + Exit; end; end; end; @@ -7038,20 +7044,23 @@ function ParamValue (const SearchName : string; const Separator : string = '='; // and returns the position index. if no separator is defined, the full paramstr is compared. // CaseSensitive defines the search type. if the first character of the name part // is one of the AllowedPrefixCharacters, this character will be deleted. -function ParamPos (const SearchName : string; const Separator : string = '='; - CaseSensitive : Boolean = False; - const AllowedPrefixCharacters : string = '-/'): Integer; -var pName : string; - i : Integer; +function ParamPos(const SearchName: string; const Separator: string; + CaseSensitive: Boolean; const AllowedPrefixCharacters: string): Integer; +var + Name: string; + SearchS: string; + I: Integer; begin Result := -1; - for i := 1 to ParamCount do + SearchS := Trim(SearchName); + + for I := 1 to ParamCount do begin - pName := ParamName(i, Separator, AllowedPrefixCharacters, True); - if (CaseSensitive and (pName = SearchName)) or - (UpperCase(pName) = UpperCase(SearchName)) then + Name := ParamName(I, Separator, AllowedPrefixCharacters, True); + if (CaseSensitive and (Name = SearchS)) or + ((not CaseSensitive) and (CompareText(Name, SearchS) = 0)) then begin - Result := i; + Result := I; Exit; end; end; diff --git a/jcl/source/common/JclResources.pas b/jcl/source/common/JclResources.pas index fbe1b0726d..cbaf289b14 100644 --- a/jcl/source/common/JclResources.pas +++ b/jcl/source/common/JclResources.pas @@ -1958,6 +1958,8 @@ interface RsOSVersionWinServer2012R2 = 'Windows Server 2012 R2'; RsOSVersionWin10 = 'Windows 10'; RsOSVersionWinServer2016 = 'Windows Server 2016'; + RsOSVersionWinServer2019 = 'Windows Server 2019'; + RsOSVersionWinServer = 'Windows Server'; RsEditionWinXPHome = 'Home Edition'; RsEditionWinXPPro = 'Professional'; @@ -2004,8 +2006,8 @@ interface RsProductTypeEnterprise = 'Enterprise'; RsProductTypeWebEdition = 'Web Edition'; - RsEOpenGLInfo = 'GetOpenGLVersion: %s failed'; - RsENetWkstaGetInfo = 'NetWkstaGetInfo failed'; + RsEOpenGLInfo = 'GetOpenGLVersion: %s failed'; + RsENetWkstaGetInfo = 'NetWkstaGetInfo failed'; {$IFDEF MSWINDOWS} RsSPInfo = 'SP%u'; diff --git a/jcl/source/common/JclSynch.pas b/jcl/source/common/JclSynch.pas index 64087fd1af..a82ffc2ed1 100644 --- a/jcl/source/common/JclSynch.pas +++ b/jcl/source/common/JclSynch.pas @@ -379,7 +379,11 @@ implementation {$ELSE ~HAS_UNITSCOPE} SysUtils, {$ENDIF ~HAS_UNITSCOPE} - JclLogic, JclRegistry, JclResources, + JclLogic, + {$IFDEF MSWINDOWS} + JclRegistry, + {$ENDIF} + JclResources, JclSysInfo, JclStrings; const diff --git a/jcl/source/common/JclSysInfo.pas b/jcl/source/common/JclSysInfo.pas index e50177251d..23668b9c5e 100644 --- a/jcl/source/common/JclSysInfo.pas +++ b/jcl/source/common/JclSysInfo.pas @@ -261,7 +261,8 @@ function GetShellProcessHandle: THandle; wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4, wvWin2000, wvWinXP, wvWin2003, wvWinXP64, wvWin2003R2, wvWinVista, wvWinServer2008, wvWin7, wvWinServer2008R2, wvWin8, wvWin8RT, wvWinServer2012, - wvWin81, wvWin81RT, wvWinServer2012R2, wvWin10, wvWinServer2016); + wvWin81, wvWin81RT, wvWinServer2012R2, wvWin10, wvWinServer2016, + wvWinServer2019, wvWinServer); TWindowsEdition = (weUnknown, weWinXPHome, weWinXPPro, weWinXPHomeN, weWinXPProN, weWinXPHomeK, weWinXPProK, weWinXPHomeKN, weWinXPProKN, weWinXPStarter, weWinXPMediaCenter, @@ -311,6 +312,8 @@ function GetShellProcessHandle: THandle; IsWinServer2012R2: Boolean = False; IsWin10: Boolean = False; IsWinServer2016: Boolean = False; + IsWinServer2019: Boolean = False; + IsWinServer: Boolean = False; const PROCESSOR_ARCHITECTURE_INTEL = 0; @@ -339,6 +342,8 @@ function GetWindows10ReleaseId: Integer; function GetWindows10ReleaseName: String; function GetWindows10ReleaseCodeName: String; function GetWindows10ReleaseVersion: String; +function GetWindowsServerReleaseId: Integer; +function GetWindowsServerReleaseVersion: String; function GetOpenGLVersion(const Win: THandle; out Version, Vendor: AnsiString): Boolean; function GetNativeSystemInfo(var SystemInfo: TSystemInfo): Boolean; function GetProcessorArchitecture: TProcessorArchitecture; @@ -3473,7 +3478,7 @@ function GetWindowsVersion: TWindowsVersion; TrimmedWin32CSDVersion: string; SystemInfo: TSystemInfo; OSVersionInfoEx: TOSVersionInfoEx; - Win32MajorVersionEx, Win32MinorVersionEx: integer; + Win32MajorVersionEx, Win32MinorVersionEx, WindowsReleaseId: integer; ProductName: string; const SM_SERVERR2 = 89; @@ -3560,7 +3565,7 @@ function GetWindowsVersion: TWindowsVersion; Win32MinorVersionEx := 4 // Windows 10 (builds < 9926) and Windows Server 2016 (builds < 10074) else if Win32MajorVersionEx = 10 then - Win32MinorVersionEx := -1 // Windows 10 (builds >= 9926) and Windows Server 2016 (builds >= 10074), set to -1 to escape case block + Win32MinorVersionEx := -1 // Windows 10 (builds >= 9926) and Windows Server 2016/2019 (builds >= 10074), set to -1 to escape case block else Win32MinorVersionEx := Win32MinorVersion; end; @@ -3625,7 +3630,7 @@ function GetWindowsVersion: TWindowsVersion; end; end; - // This part will only be hit with Windows 10 and Windows Server 2016 (and newer) where an application manifest is not included + // This part will only be hit with Windows 10, Windows Server 2016 and beyond where an application manifest is not included if (Win32MajorVersionEx >= 10) then begin case Win32MajorVersionEx of @@ -3636,12 +3641,22 @@ function GetWindowsVersion: TWindowsVersion; case Win32MinorVersionEx of 0: begin - // Windows 10 (builds >= 9926) and Windows Server 2016 (builds >= 10074) + // Windows 10 (builds >= 9926), Windows Server 2016 (builds >= 10074) and beyond OSVersionInfoEx.dwOSVersionInfoSize := SizeOf(OSVersionInfoEx); if GetVersionEx(OSVersionInfoEx) and (OSVersionInfoEx.wProductType = VER_NT_WORKSTATION) then Result := wvWin10 else - Result := wvWinServer2016; + begin + WindowsReleaseId := StrToIntDef(RegReadStringDef(HKEY_LOCAL_MACHINE, 'SOFTWARE\Microsoft\Windows NT\CurrentVersion', 'ReleaseId', '0'), -1); + case WindowsReleaseId of + 1607: + Result := wvWinServer2016; + 1809: + Result := wvWinServer2019; + else + Result := wvWinServer; + end; + end; end; end; end; @@ -3964,6 +3979,10 @@ function GetWindowsVersionString: string; Result := LoadResString(@RsOSVersionWin10); wvWinServer2016: Result := LoadResString(@RsOSVersionWinServer2016); + wvWinServer2019: + Result := LoadResString(@RsOSVersionWinServer2019); + wvWinServer: + Result := LoadResString(@RsOSVersionWinServer); else Result := ''; end; @@ -4199,6 +4218,8 @@ function GetWindows10ReleaseName: String; Result := 'Windows 10 April 2018 Update'; 1809: Result := 'Windows 10 October 2018 Update'; + 1903: + Result := 'Windows 10 May 2019 Update'; else Result := 'Windows 10 ' + IntToStr(GetWindows10ReleaseId) + ' Update'; end; @@ -4226,6 +4247,8 @@ function GetWindows10ReleaseCodeName: String; Result := 'Redstone 4'; 1809: Result := 'Redstone 5'; + 1903: + Result := '19H1'; else Result := ''; end; @@ -4242,7 +4265,31 @@ function GetWindows10ReleaseVersion: String; begin WindowsReleaseId := GetWindows10ReleaseId; if WindowsReleaseId > 0 then - Result := 'Windows 10 Version ' + IntToStr(WindowsReleaseId) + Result := 'Windows 10, version ' + IntToStr(WindowsReleaseId) + else + Result := ''; + end + else + Result := ''; +end; + +function GetWindowsServerReleaseId: Integer; +begin + if IsWinServer then + Result := StrToIntDef(RegReadStringDef(HKEY_LOCAL_MACHINE, 'SOFTWARE\Microsoft\Windows NT\CurrentVersion', 'ReleaseId', '0'), -1) + else + Result := -1; +end; + +function GetWindowsServerReleaseVersion: String; +var + WindowsReleaseId: Integer; +begin + if IsWinServer then + begin + WindowsReleaseId := GetWindowsServerReleaseId; + if WindowsReleaseId > 0 then + Result := 'Windows Server, version ' + IntToStr(WindowsReleaseId) else Result := ''; end @@ -6364,6 +6411,10 @@ procedure InitSysInfo; IsWin10 := True; wvWinServer2016: IsWinServer2016 := True; + wvWinServer2019: + IsWinServer2019 := True; + wvWinServer: + IsWinServer := True; end; end; diff --git a/jcl/source/prototypes/win32api/WinNT.int b/jcl/source/prototypes/win32api/WinNT.int index 45ce6cd5b0..4f0fadf815 100644 --- a/jcl/source/prototypes/win32api/WinNT.int +++ b/jcl/source/prototypes/win32api/WinNT.int @@ -23,6 +23,7 @@ (*$HPPEMIT ' WORD SubstituteNameLength;'*) (*$HPPEMIT ' WORD PrintNameOffset;'*) (*$HPPEMIT ' WORD PrintNameLength;'*) +(*$HPPEMIT ' ULONG Flags;'*) (*$HPPEMIT ' WCHAR PathBuffer[1];'*) (*$HPPEMIT ' } SymbolicLinkReparseBuffer;'*) (*$HPPEMIT ''*) @@ -62,14 +63,27 @@ type ReparseDataLength: Word; Reserved: Word; case Integer of - 0: ( // SymbolicLinkReparseBuffer and MountPointReparseBuffer - SubstituteNameOffset: Word; - SubstituteNameLength: Word; - PrintNameOffset: Word; - PrintNameLength: Word; - PathBuffer: array [0..0] of WCHAR); - 1: ( // GenericReparseBuffer - DataBuffer: array [0..0] of Byte); + 0: ( + SymbolicLinkReparseBuffer: record + SubstituteNameOffset: Word; + SubstituteNameLength: Word; + PrintNameOffset: Word; + PrintNameLength: Word; + Flags: ULONG; + PathBuffer: array [0..0] of WCHAR; + end); + 1: ( + MountPointReparseBuffer: record + SubstituteNameOffset: Word; + SubstituteNameLength: Word; + PrintNameOffset: Word; + PrintNameLength: Word; + PathBuffer: array [0..0] of WCHAR; + end); + 2: ( + GenericReparseBuffer: record + DataBuffer: array [0..0] of Byte; + end); end; {$EXTERNALSYM REPARSE_DATA_BUFFER} REPARSE_DATA_BUFFER = _REPARSE_DATA_BUFFER; @@ -998,16 +1012,28 @@ const {$EXTERNALSYM IO_REPARSE_TAG_MOUNT_POINT} IO_REPARSE_TAG_HSM = DWORD($C0000004); {$EXTERNALSYM IO_REPARSE_TAG_HSM} + IO_REPARSE_TAG_DRIVER_EXTENDER = DWORD($80000005); + {$EXTERNALSYM IO_REPARSE_TAG_DRIVER_EXTENDER} + IO_REPARSE_TAG_HSM2 = DWORD($80000006); + {$EXTERNALSYM IO_REPARSE_TAG_HSM2} IO_REPARSE_TAG_SIS = DWORD($80000007); {$EXTERNALSYM IO_REPARSE_TAG_SIS} IO_REPARSE_TAG_DFS = DWORD($8000000A); {$EXTERNALSYM IO_REPARSE_TAG_DFS} IO_REPARSE_TAG_FILTER_MANAGER = DWORD($8000000B); {$EXTERNALSYM IO_REPARSE_TAG_FILTER_MANAGER} + IO_REPARSE_TAG_SYMLINK = DWORD($A000000C); + {$EXTERNALSYM IO_REPARSE_TAG_SYMLINK} + IO_REPARSE_TAG_DFSR = DWORD($80000012); + {$EXTERNALSYM IO_REPARSE_TAG_DFSR} + IO_REPARSE_TAG_NFS = DWORD($80000014); + {$EXTERNALSYM IO_REPARSE_TAG_NFS} + IO_COMPLETION_MODIFY_STATE = $0002; {$EXTERNALSYM IO_COMPLETION_MODIFY_STATE} IO_COMPLETION_ALL_ACCESS = DWORD(STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $3); {$EXTERNALSYM IO_COMPLETION_ALL_ACCESS} + DUPLICATE_CLOSE_SOURCE = $00000001; {$EXTERNALSYM DUPLICATE_CLOSE_SOURCE} DUPLICATE_SAME_ACCESS = $00000002; diff --git a/jcl/source/windows/JclDotNet.pas b/jcl/source/windows/JclDotNet.pas index 0bdae4cc33..cde52f1c1b 100644 --- a/jcl/source/windows/JclDotNet.pas +++ b/jcl/source/windows/JclDotNet.pas @@ -103,6 +103,8 @@ TJclClrHost = class(TJclClrBase, ICorRuntimeHost) function GetAppDomainCount: Integer; function GetDefaultAppDomain: _AppDomain; function GetCurrentAppDomain: _AppDomain; + + class procedure GetClrVersionsLegacy(VersionNames: TJclWideStrings); // used for pre v4 runtime protected function AddAppDomain(const AppDomain: TJclClrAppDomain): Integer; function RemoveAppDomain(const AppDomain: TJclClrAppDomain): Integer; @@ -342,6 +344,44 @@ function GetRequestedRuntimeVersionForCLSID(rclsid: TGuid; pVersion: PWideChar; const mscoree_dll = 'mscoree.dll'; +type + ICLRMetaHost = interface(IUnknown) + ['{D332DB9E-B9B3-4125-8207-A14884F53216}'] + function GetRuntime(const pwzVersion: PWideChar; + const riid: TGUID; + out assemblyNGenSetting: IUnknown): HResult; stdcall; + function GetVersionFromFile(const pwzFilePath: PWideChar; + out pwzBuffer: PWideChar; + var pcchBuffer: DWORD): HResult; stdcall; + function EnumerateInstalledRuntimes(out ppEnumerator: IEnumUnknown): HResult; stdcall; + function EnumerateLoadedRuntimes(const hndProcess: THandle; + out ppEnumerator: IEnumUnknown): HResult; stdcall; + function RequestRuntimeLoadedNotification(out pCallbackFunction: PPointer): HResult; stdcall; + function QueryLegacyV2RuntimeBinding(const riid: TGUID; + out ppUnk: PPointer): HResult; stdcall; + function ExitProcess(out iExitCode: Int32): HResult; stdcall; + end; + + + ICLRRuntimeInfo = interface(IUnknown) + ['{BD39D1D2-BA2F-486a-89B0-B4B0CB466891}'] + function GetVersionString(pwzBuffer: PWideChar; var pcchBuffer: DWORD): HRESULT; stdcall; + function GetRuntimeDirectory(pwzBuffer: PWideChar; var pcchBuffer: DWORD): HRESULT; stdcall; + function IsLoaded(hndProcess: THandle; out pbLoaded: BOOL): HRESULT; stdcall; + function LoadErrorString(iResourceID: UINT; pwzBuffer: PWideChar; var pcchBuffer: DWORD; iLocaleID: LONG): HRESULT; stdcall; + function LoadLibrary(pwzDllName: LPCWSTR; out phndModule: HMODULE): HRESULT; stdcall; + function GetProcAddress(pszProcName: LPCSTR; out ppProc: Pointer): HRESULT; stdcall; + function GetInterface(const rclsid: TGuid; const riid: TGuid; out ppUnk: IUnknown): HRESULT; stdcall; + function IsLoadable(out pbLoadable: BOOL): HRESULT; stdcall; + function SetDefaultStartupFlags(dwStartupFlags: DWORD; pwzHostConfigFile: LPCWSTR): HRESULT; stdcall; + function GetDefaultStartupFlags(out pdwStartupFlags: DWORD; pwzHostConfigFile: LPWSTR; var pcchHostConfigFile: DWORD): HRESULT; stdcall; + function BindAsLegacyV2Runtime(): HRESULT; stdcall; + function IsStarted(out pbStarted: BOOL; out pdwStartupFlags: DWORD): HRESULT; stdcall; + end; + +const + CLSID_CLRMetaHost: TGUID = '{9280188d-0e8e-4867-b30c-7fa83884e8de}'; + {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( @@ -743,6 +783,26 @@ function GetRequestedRuntimeVersionForCLSID(rclsid: TGuid; pVersion: PWideChar; Result := _GetRequestedRuntimeVersionForCLSID(rclsid, pVersion, cchBuffer, dwLength, dwResolutionFlags); end; +type + TCLRCreateInstance = function (const clsid: TGuid; const riid: TGuid; out Intf: IUnknown): HRESULT; stdcall; + +var + _CLRCreateInstance: TCLRCreateInstance = nil; + +function CLRCreateInstance(clsid: TGuid; riid: TGuid; out Intf: IUnknown): HRESULT; +begin + GetProcedureAddress(Pointer(@_CLRCreateInstance), mscoree_dll, 'CLRCreateInstance'); + if @_CLRCreateInstance = nil then + begin + Intf := nil; + Result := S_OK; + end + else + begin + Result := _CLRCreateInstance(clsid, riid, Intf); + end; +end; + //=== { TJclClrHost } ======================================================== constructor TJclClrHost.Create(const ClrVer: WideString; const Flavor: TJclClrHostFlavor; @@ -850,7 +910,47 @@ function TJclClrHost.GetDefaultAppDomain: _AppDomain; Result := Unk as _AppDomain; end; -class procedure TJclClrHost.GetClrVersions(VersionNames: TWideStrings); +class procedure TJclClrHost.GetClrVersions(VersionNames: TJclWideStrings); +var + UnknownIntf: IUnknown; + MetaHost: ICLRMetaHost; + Enumerator: IEnumUnknown; + RuntimeInfo: ICLRRuntimeInfo; + + Version: string; + Directory: string; + RequiredSize: DWORD; +begin + // CLRCreateInstance returns S_OK and a nil interface if the entry point was not found in mscoree.dll + OleCheck(CLRCreateInstance(CLSID_CLRMetaHost, ICLRMetaHost, UnknownIntf)); + if Assigned(UnknownIntf) then + begin + MetaHost := UnknownIntf as ICLRMetaHost; + + OleCheck(MetaHost.EnumerateInstalledRuntimes(Enumerator)); + + while Enumerator.Next(1, UnknownIntf, nil) = S_OK do + begin + RuntimeInfo := UnknownIntf as ICLRRuntimeInfo; + + RuntimeInfo.GetVersionString(nil, RequiredSize); // don't OleCheck here, the call fails but still fills RequiredSize + SetLength(Version, RequiredSize - 1); + OleCheck(RuntimeInfo.GetVersionString(@Version[1], RequiredSize)); + + RuntimeInfo.GetRuntimeDirectory(nil, RequiredSize); + SetLength(Directory, RequiredSize - 1); + OleCheck(RuntimeInfo.GetRuntimeDirectory(@Directory[1], RequiredSize)); + + VersionNames.Values[Version] := Directory; + end; + end + else + begin + GetClrVersionsLegacy(VersionNames); + end; +end; + +class procedure TJclClrHost.GetClrVersionsLegacy(VersionNames: TJclWideStrings); // used for pre v4 runtime function DirectoryExistsW(const DirectoryName: WideString): Boolean; var Code: DWORD; diff --git a/jcl/source/windows/JclNTFS.pas b/jcl/source/windows/JclNTFS.pas index f159b4ae9b..6dfc6eaa3c 100644 --- a/jcl/source/windows/JclNTFS.pas +++ b/jcl/source/windows/JclNTFS.pas @@ -120,9 +120,16 @@ function NtfsOpLockBreakNotify(Handle: THandle; Overlapped: TOverlapped): Boolea function NtfsRequestOpLock(Handle: THandle; Kind: TOpLock; Overlapped: TOverlapped): Boolean; // Junction Points +function NtfsIsJunctionPoint(const Path: string): Boolean; function NtfsCreateJunctionPoint(const Source, Destination: string): Boolean; function NtfsDeleteJunctionPoint(const Source: string): Boolean; -function NtfsGetJunctionPointDestination(const Source: string; var Destination: string): Boolean; +function NtfsGetJunctionPointDestination(const Source: string; var Destination: string; RemovePathPrefix: Boolean = False): Boolean; + +// Symbolic Links +function NtfsIsSymlink(const Path: string): Boolean; +function NtfsGetSymlinkDestination(const Source: string; var Destination: string; RemovePathPrefix: Boolean = False): Boolean; + +function NtfsGetReparsePointDestination(const Source: string; var Destination: string; RemovePathPrefix: Boolean = False): Boolean; // Streams type @@ -1160,6 +1167,108 @@ function IsReparseTagValid(Tag: DWORD): Boolean; (Tag > IO_REPARSE_TAG_RESERVED_RANGE); end; +function NtfsRemovePathPrefix(Path: PWideChar; var Len: Integer): PWideChar; +begin + Result := Path; + if Len > 4 then + begin + // Remove '\??\' and '\\?\' + if (Path[0] = '\') and (Path[2] = '?') and (Path[3] = '\') and ((Path[1] = '\') or (Path[1] = '?')) then + begin + Inc(Result, 4); + Dec(Len, 4); + end; + end; +end; + +function NtfsReadMountPointDestination(const ReparseData: TReparseDataBufferOverlay; var Destination: string; RemovePathPrefix: Boolean): Boolean; +var + {$IFNDEF UNICODE} + SubstituteName: WideString; + {$ENDIF ~UNICODE} + SubstituteNameAddr: PWideChar; + Offset: Word; + WideLen: Integer; +begin + case ReparseData.Reparse.ReparseTag of + IO_REPARSE_TAG_MOUNT_POINT: + begin + Offset := ReparseData.Reparse.MountPointReparseBuffer.SubstituteNameOffset div SizeOf(WideChar); + SubstituteNameAddr := @ReparseData.Reparse.MountPointReparseBuffer.PathBuffer[Offset]; + WideLen := ReparseData.Reparse.MountPointReparseBuffer.SubstituteNameLength div SizeOf(WideChar); + end; + + IO_REPARSE_TAG_SYMLINK: + begin + Offset := ReparseData.Reparse.SymbolicLinkReparseBuffer.SubstituteNameOffset div SizeOf(WideChar); + SubstituteNameAddr := @ReparseData.Reparse.SymbolicLinkReparseBuffer.PathBuffer[Offset]; + WideLen := ReparseData.Reparse.SymbolicLinkReparseBuffer.SubstituteNameLength div SizeOf(WideChar); + end; + + else + Result := False; + Exit; + end; + + if RemovePathPrefix then + SubstituteNameAddr := NtfsRemovePathPrefix(SubstituteNameAddr, WideLen); + {$IFDEF UNICODE} + SetString(Destination, SubstituteNameAddr, WideLen); + {$ELSE} + SetString(SubstituteName, SubstituteNameAddr, WideLen); + Destination := string(SubstituteName); + {$ENDIF UNICODE} + + Result := True; +end; + +function NtfsIsJunctionPoint(const Path: string): Boolean; +var + Tag: DWORD; +begin + if NtfsGetReparseTag(Path, Tag) then + Result := Tag = IO_REPARSE_TAG_MOUNT_POINT + else + Result := False; +end; + +function NtfsGetReparsePointData(const Path: string; var ReparseData: TReparseDataBufferOverlay): Boolean; +var + Handle: THandle; + BytesReturned: DWORD; + ByteLen: DWORD; +begin + BytesReturned := 0; + Result := False; + if NtfsFileHasReparsePoint(Path) then + begin + Handle := CreateFile(PChar(Path), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, + OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0); + if Handle <> INVALID_HANDLE_VALUE then + begin + 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 + case ReparseData.Reparse.ReparseTag of + IO_REPARSE_TAG_SYMLINK: + ByteLen := DWORD(ReparseData.Reparse.SymbolicLinkReparseBuffer.SubstituteNameLength) + SizeOf(WideChar); + else + //IO_REPARSE_TAG_MOUNT_POINT: + ByteLen := DWORD(ReparseData.Reparse.MountPointReparseBuffer.SubstituteNameLength) + SizeOf(WideChar); + end; + if BytesReturned >= ByteLen then + Result := True; + end; + finally + CloseHandle(Handle); + end; + end; + end; +end; + function NtfsCreateJunctionPoint(const Source, Destination: string): Boolean; var Dest: array [0..1024] of Char; // Writable copy of Destination @@ -1190,12 +1299,12 @@ function NtfsCreateJunctionPoint(const Source, Destination: string): Boolean; 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; + ReparseData.Reparse.MountPointReparseBuffer.SubstituteNameLength := NameLength; + ReparseData.Reparse.MountPointReparseBuffer.PrintNameOffset := NameLength + SizeOf(WideChar); // #0 // 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)); + Move(DestW[1], ReparseData.Reparse.MountPointReparseBuffer.PathBuffer, Length(DestW) * SizeOf(WideChar)); Result := NtfsSetReparsePoint(Source, ReparseData.Reparse, ReparseData.Reparse.ReparseDataLength + REPARSE_DATA_BUFFER_HEADER_SIZE); end; @@ -1205,41 +1314,48 @@ function NtfsDeleteJunctionPoint(const Source: string): Boolean; Result := NtfsDeleteReparsePoint(Source, IO_REPARSE_TAG_MOUNT_POINT); end; -function NtfsGetJunctionPointDestination(const Source: string; var Destination: string): Boolean; +function NtfsGetJunctionPointDestination(const Source: string; var Destination: string; RemovePathPrefix: Boolean): Boolean; var - Handle: THandle; ReparseData: TReparseDataBufferOverlay; - BytesReturned: DWORD; - SubstituteName: WideString; - SubstituteNameAddr: PWideChar; 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 - BytesReturned := 0; - 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 >= DWORD(ReparseData.Reparse.SubstituteNameLength + SizeOf(WideChar)) then - begin - SetLength(Destination, ReparseData.Reparse.SubstituteNameLength div SizeOf(WideChar)); - SubstituteNameAddr := @ReparseData.Reparse.PathBuffer; - Inc(SubstituteNameAddr, ReparseData.Reparse.SubstituteNameOffset div SizeOf(WideChar)); - SetString(SubstituteName, SubstituteNameAddr, Length(Destination)); - Destination := string(SubstituteName); + if NtfsGetReparsePointData(Source, ReparseData) then + if ReparseData.Reparse.ReparseTag = IO_REPARSE_TAG_MOUNT_POINT then + Result := NtfsReadMountPointDestination(ReparseData, Destination, RemovePathPrefix); +end; - Result := True; - end; - end; - finally - CloseHandle(Handle); - end +function NtfsIsSymlink(const Path: string): Boolean; +var + Tag: DWORD; +begin + if NtfsGetReparseTag(Path, Tag) then + Result := Tag = IO_REPARSE_TAG_SYMLINK + else + Result := False; +end; + +function NtfsGetSymlinkDestination(const Source: string; var Destination: string; RemovePathPrefix: Boolean): Boolean; +var + ReparseData: TReparseDataBufferOverlay; +begin + Result := False; + if NtfsGetReparsePointData(Source, ReparseData) then + if ReparseData.Reparse.ReparseTag = IO_REPARSE_TAG_SYMLINK then + Result := NtfsReadMountPointDestination(ReparseData, Destination, RemovePathPrefix); +end; + +function NtfsGetReparsePointDestination(const Source: string; var Destination: string; RemovePathPrefix: Boolean): Boolean; +var + ReparseData: TReparseDataBufferOverlay; +begin + Result := False; + if NtfsGetReparsePointData(Source, ReparseData) then + begin + case ReparseData.Reparse.ReparseTag of + IO_REPARSE_TAG_MOUNT_POINT, + IO_REPARSE_TAG_SYMLINK: + Result := NtfsReadMountPointDestination(ReparseData, Destination, RemovePathPrefix); + end; end; end; diff --git a/jcl/source/windows/JclWin32.pas b/jcl/source/windows/JclWin32.pas index 006d8df408..e4135a1f77 100644 --- a/jcl/source/windows/JclWin32.pas +++ b/jcl/source/windows/JclWin32.pas @@ -202,14 +202,27 @@ _REPARSE_DATA_BUFFER = record ReparseDataLength: Word; Reserved: Word; case Integer of - 0: ( // SymbolicLinkReparseBuffer and MountPointReparseBuffer - SubstituteNameOffset: Word; - SubstituteNameLength: Word; - PrintNameOffset: Word; - PrintNameLength: Word; - PathBuffer: array [0..0] of WCHAR); - 1: ( // GenericReparseBuffer - DataBuffer: array [0..0] of Byte); + 0: ( + SymbolicLinkReparseBuffer: record + SubstituteNameOffset: Word; + SubstituteNameLength: Word; + PrintNameOffset: Word; + PrintNameLength: Word; + Flags: ULONG; + PathBuffer: array [0..0] of WCHAR; + end); + 1: ( + MountPointReparseBuffer: record + SubstituteNameOffset: Word; + SubstituteNameLength: Word; + PrintNameOffset: Word; + PrintNameLength: Word; + PathBuffer: array [0..0] of WCHAR; + end); + 2: ( + GenericReparseBuffer: record + DataBuffer: array [0..0] of Byte; + end); end; {$EXTERNALSYM REPARSE_DATA_BUFFER} REPARSE_DATA_BUFFER = _REPARSE_DATA_BUFFER; @@ -1138,16 +1151,28 @@ function IsReparseTagNameSurrogate(Tag: ULONG): Boolean; {$EXTERNALSYM IO_REPARSE_TAG_MOUNT_POINT} IO_REPARSE_TAG_HSM = DWORD($C0000004); {$EXTERNALSYM IO_REPARSE_TAG_HSM} + IO_REPARSE_TAG_DRIVER_EXTENDER = DWORD($80000005); + {$EXTERNALSYM IO_REPARSE_TAG_DRIVER_EXTENDER} + IO_REPARSE_TAG_HSM2 = DWORD($80000006); + {$EXTERNALSYM IO_REPARSE_TAG_HSM2} IO_REPARSE_TAG_SIS = DWORD($80000007); {$EXTERNALSYM IO_REPARSE_TAG_SIS} IO_REPARSE_TAG_DFS = DWORD($8000000A); {$EXTERNALSYM IO_REPARSE_TAG_DFS} IO_REPARSE_TAG_FILTER_MANAGER = DWORD($8000000B); {$EXTERNALSYM IO_REPARSE_TAG_FILTER_MANAGER} + IO_REPARSE_TAG_SYMLINK = DWORD($A000000C); + {$EXTERNALSYM IO_REPARSE_TAG_SYMLINK} + IO_REPARSE_TAG_DFSR = DWORD($80000012); + {$EXTERNALSYM IO_REPARSE_TAG_DFSR} + IO_REPARSE_TAG_NFS = DWORD($80000014); + {$EXTERNALSYM IO_REPARSE_TAG_NFS} + IO_COMPLETION_MODIFY_STATE = $0002; {$EXTERNALSYM IO_COMPLETION_MODIFY_STATE} IO_COMPLETION_ALL_ACCESS = DWORD(STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $3); {$EXTERNALSYM IO_COMPLETION_ALL_ACCESS} + DUPLICATE_CLOSE_SOURCE = $00000001; {$EXTERNALSYM DUPLICATE_CLOSE_SOURCE} DUPLICATE_SAME_ACCESS = $00000002; diff --git a/readme.md b/readme.md index de79a6ec47..70e4544ea9 100644 --- a/readme.md +++ b/readme.md @@ -29,7 +29,7 @@ jcl\jcl\source\include\jedi directory. Clone with GIT -------------- ``` -> git clone git://github.com/Makhaon/jcl.git jcl +> git clone https://github.com/Makhaon/jcl.git jcl ``` This will get you the JCL repository. you have to move the jedi.inc and kylix.inc files from the jcl\jcl\source\include to the