Skip to content

Commit

Permalink
Windows: Remove use of deprecated function SHGetFolderPath and use SH…
Browse files Browse the repository at this point in the history
…GetKnownFolderPath instead
  • Loading branch information
kit-ty-kate committed Feb 28, 2024
1 parent 87a88a5 commit c7f1059
Show file tree
Hide file tree
Showing 8 changed files with 38 additions and 35 deletions.
1 change: 1 addition & 0 deletions master_changes.md
Original file line number Diff line number Diff line change
Expand Up @@ -110,6 +110,7 @@ users)
## Internal: Windows
* Ensure that the system critical error dialog is disabled when opam starts [#5828 @dra27]
* Fix loading git location at init [#5843 @rjbou]
* Remove use of deprecated function SHGetFolderPath and use SHGetKnownFolderPath instead [#5862 @kit-ty-kate]

## Test

Expand Down
6 changes: 2 additions & 4 deletions src/core/opamStd.ml
Original file line number Diff line number Diff line change
Expand Up @@ -984,8 +984,7 @@ module OpamSys = struct
try Unix.getenv "HOME"
with Not_found ->
if Sys.win32 then
(* CSIDL_PROFILE = 0x28 *)
OpamStubs.(shGetFolderPath 0x28 SHGFP_TYPE_CURRENT)
OpamStubs.getPathToHome ()
else
Sys.getcwd ()
) in
Expand All @@ -1007,8 +1006,7 @@ module OpamSys = struct
r

let system () =
(* CSIDL_SYSTEM = 0x25 *)
OpamStubs.(shGetFolderPath 0x25 SHGFP_TYPE_CURRENT)
OpamStubs.getPathToSystem ()

type os =
| Darwin
Expand Down
4 changes: 3 additions & 1 deletion src/core/opamStubs.dummy.ml
Original file line number Diff line number Diff line change
Expand Up @@ -31,7 +31,9 @@ let delete_glyph_checker = that's_a_no_no
let has_glyph _ = that's_a_no_no
let getProcessArchitecture = that's_a_no_no
let process_putenv _ = that's_a_no_no
let shGetFolderPath _ = that's_a_no_no
let getPathToHome = that's_a_no_no
let getPathToSystem = that's_a_no_no
let getPathToLocalAppData = that's_a_no_no
let sendMessageTimeout _ _ _ _ _ = that's_a_no_no
let getProcessAncestry = that's_a_no_no
let getConsoleAlias _ = that's_a_no_no
Expand Down
7 changes: 4 additions & 3 deletions src/core/opamStubs.mli
Original file line number Diff line number Diff line change
Expand Up @@ -105,9 +105,10 @@ val process_putenv : int32 -> string -> string -> bool
if the target process is 32-bit and the current process is 64-bit or vice
versa (outcomes vary from a no-op to a segfault). *)

val shGetFolderPath : int -> shGFP_type -> string
(** Windows only. [shGetFolderPath nFolder dwFlags] retrieves the location of a special
folder by CSIDL value. See https://msdn.microsoft.com/en-us/library/windows/desktop/bb762181.aspx *)
val getPathToHome : unit -> string
val getPathToSystem : unit -> string
val getPathToLocalAppData : unit -> string
(** Windows only. retrieves the location of the wanted directory *)

val sendMessageTimeout :
nativeint -> int -> int -> ('a, 'b, 'c) winmessage -> 'a -> 'b -> int * 'c
Expand Down
7 changes: 0 additions & 7 deletions src/core/opamStubsTypes.ml
Original file line number Diff line number Diff line change
Expand Up @@ -67,13 +67,6 @@ type registry_root =
type _ registry_value =
| REG_SZ : string registry_value

(** SHGetFolderPath flags *)
type shGFP_type =
| SHGFP_TYPE_CURRENT
(** Retrieve the current path *)
| SHGFP_TYPE_DEFAULT
(** Retrieve the default path *)

(** Windows Messages (at least, one of them!) *)
type ('a, 'b, 'c) winmessage =
| WM_SETTINGCHANGE : (int, string, int) winmessage
Expand Down
3 changes: 1 addition & 2 deletions src/state/opamStateConfig.ml
Original file line number Diff line number Diff line change
Expand Up @@ -82,8 +82,7 @@ let default = {
else
let open OpamFilename in
let local_appdata =
(* CSIDL_LOCAL_APPDATA = 0x1c *)
Dir.of_string (OpamStubs.(shGetFolderPath 0x1c SHGFP_TYPE_CURRENT))
Dir.of_string (OpamStubs.getPathToLocalAppData ())
in
concat_and_resolve local_appdata "opam"
);
Expand Down
4 changes: 3 additions & 1 deletion src/stubs/win32/opamWin32Stubs.ml
Original file line number Diff line number Diff line change
Expand Up @@ -30,7 +30,9 @@ external delete_glyph_checker : 'a * 'a -> unit = "OPAMW_DeleteGlyphChecker"
external has_glyph : 'a * 'a -> Uchar.t -> bool = "OPAMW_HasGlyph"
external getProcessArchitecture : int32 option -> 'a = "OPAMW_GetProcessArchitecture"
external process_putenv : int32 -> string -> string -> bool = "OPAMW_process_putenv"
external shGetFolderPath : int -> 'a -> string = "OPAMW_SHGetFolderPath"
external getPathToHome : unit -> string = "OPAMW_GetPathToHome"
external getPathToSystem : unit -> string = "OPAMW_GetPathToSystem"
external getPathToLocalAppData : unit -> string = "OPAMW_GetPathToLocalAppData"
external sendMessageTimeout : nativeint -> int -> int -> 'a -> 'b -> 'c -> int * 'd = "OPAMW_SendMessageTimeout_byte" "OPAMW_SendMessageTimeout"
external getProcessAncestry : unit -> (int32 * string) list = "OPAMW_GetProcessAncestry"
external getConsoleAlias : string -> string -> string = "OPAMW_GetConsoleAlias"
Expand Down
41 changes: 24 additions & 17 deletions src/stubs/win32/opamWindows.c
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,8 @@
#include <Windows.h>
#include <Shlobj.h>
#include <TlHelp32.h>
#include <Knownfolders.h>
#include <Objbase.h>

#include <stdio.h>

Expand Down Expand Up @@ -549,24 +551,29 @@ CAMLprim value OPAMW_process_putenv(value pid, value key, value val)
caml_failwith(result);
}

/*
* Somewhat against my better judgement, wrap SHGetFolderPath rather than
* SHGetKnownFolderPath to maintain XP compatibility. OPAM already requires
* Windows Vista+ because of GetCurrentConsoleFontEx, but there may be a
* workaround for that for XP lusers.
*/
CAMLprim value OPAMW_SHGetFolderPath(value nFolder, value dwFlags)
value OPAMW_SHGetKnownFolderPath(REFKNOWNFOLDERID rfid)
{
WCHAR szPath[MAX_PATH];

if (SUCCEEDED(SHGetFolderPath(NULL,
Int_val(nFolder),
NULL,
Int_val(dwFlags),
szPath)))
return caml_copy_string_of_utf16(szPath);
else
caml_failwith("OPAMW_SHGetFolderPath");
PWSTR path = NULL;
value result;

if (SUCCEEDED(SHGetKnownFolderPath(rfid, (DWORD)0, NULL, &path))) {
result = caml_copy_string_of_utf16(path);
CoTaskMemFree((LPVOID)path);
return result;
} else {
CoTaskMemFree((LPVOID)path);
caml_failwith("OPAMW_SHGetKnownFolderPath");
}
}

CAMLprim value OPAMW_GetPathToHome(value _unit) {
return OPAMW_SHGetKnownFolderPath(&FOLDERID_Profile);
}
CAMLprim value OPAMW_GetPathToSystem(value _unit) {
return OPAMW_SHGetKnownFolderPath(&FOLDERID_System);
}
CAMLprim value OPAMW_GetPathToLocalAppData(value _unit) {
return OPAMW_SHGetKnownFolderPath(&FOLDERID_LocalAppData);
}

CAMLprim value OPAMW_SendMessageTimeout(value vhWnd,
Expand Down

0 comments on commit c7f1059

Please sign in to comment.