Windows: Remove use of deprecated function SHGetFolderPath and use SHGetKnownFolderPath instead

configure.ac

@@ -350,7 +350,7 @@ AS_CASE([$TARGET],
     # NOTE: On Windows, the Windows specific dlls should stay dynamic for security reasons
     # NOTE: -l:libstdc++.a is necessary (vs. -lstdc++) as flexlink will use libstdc++.dll.a
     # which still depends on the DLL at runtime instead of libstdc++.a (that looks like a bug in flexlink)
-    platform_dependant_stuff="-cclib -lopam_stubs_win32_stubs -cclib -l:libstdc++.a -cclib -l:libpthread.a -cclib -Wl,-static -cclib -ladvapi32 -cclib -lgdi32 -cclib -luser32 -cclib -lshell32"
+    platform_dependant_stuff="-cclib -lopam_stubs_win32_stubs -cclib -l:libstdc++.a -cclib -l:libpthread.a -cclib -Wl,-static -cclib -ladvapi32 -cclib -lgdi32 -cclib -luser32 -cclib -lshell32 -cclib -lole32 -cclib -luuid"
   ])
 AS_CASE([${support_static},${enable_static}],
   [no,yes],[AC_MSG_ERROR([--enable-static is not available on this platform (${TARGET}).])],

master_changes.md

@@ -110,6 +110,8 @@ 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]
+  * Improve performance by only calling OpamStubs.getPathToSystem once [#5862 @dra27]
 
 ## Test
 

shell/context_flags.ml

@@ -15,7 +15,7 @@ match Sys.argv.(1) with
       print_string "i686"
 | "clibs" ->
     if Sys.win32 then
-      print_string "(-ladvapi32 -lgdi32 -luser32 -lshell32)"
+      print_string "(-ladvapi32 -lgdi32 -luser32 -lshell32 -lole32 -luuid)"
     else
       print_string "()"
 | _ ->

src/core/opamStd.ml

@@ -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
@@ -1006,9 +1005,9 @@ module OpamSys = struct
         Hashtbl.add memo arg r;
         r
 
-  let system () =
-    (* CSIDL_SYSTEM = 0x25 *)
-    OpamStubs.(shGetFolderPath 0x25 SHGFP_TYPE_CURRENT)
+  let system =
+    let system = Lazy.from_fun OpamStubs.getPathToSystem in
+    fun () -> Lazy.force system
 
   type os =
     | Darwin

src/core/opamStubs.dummy.ml

@@ -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

src/core/opamStubs.mli

@@ -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

src/core/opamStubsTypes.ml

@@ -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

src/state/opamStateConfig.ml

@@ -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"
     );

src/stubs/win32/opamWin32Stubs.ml

@@ -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"

src/stubs/win32/opamWindows.c

@@ -26,6 +26,8 @@
 #include <Windows.h>
 #include <Shlobj.h>
 #include <TlHelp32.h>
+#include <Knownfolders.h>
+#include <Objbase.h>
 
 #include <stdio.h>
 
@@ -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)
+static 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, 0, NULL, &path))) {
+    result = caml_copy_string_of_utf16(path);
+    CoTaskMemFree(path);
+    return result;
+  } else {
+    CoTaskMemFree(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,