Merge branch 'master' into dune-universe-v0.10.0

Author: Firobe

B0.ml

@@ -80,6 +80,9 @@ let test_multi =
 let test_threaded =
   test ~/"test/test_threaded.ml" ~requires:[logs_fmt; logs_threaded; threads]
 
+let test_mutext_safe =
+  test ~/"test/test_mutex_safe.ml" ~requires:[logs_fmt; logs_threaded; threads]
+
 let test_lwt =
   let requires = [b0_std; logs_fmt; logs_lwt; fmt; fmt_tty; lwt; lwt_unix] in
   test ~/"test/test_lwt.ml" ~requires
@@ -121,7 +124,7 @@ let default =
       [ "ocaml", {|>= "4.14.0"|};
         "ocamlfind", {|build|};
         "ocamlbuild", {|build|};
-        "topkg", {|build & >= "1.0.3"|};
+        "topkg", {|build & >= "1.1.0"|};
         "mtime", {|with-test|};]
   in
   B0_pack.make "default" ~doc:"logs package" ~meta ~locked:true @@

CHANGES.md

@@ -1,3 +1,8 @@
+
+
+* Make log mutex immune to raising logging functions.
+  Thanks to Nathan Taylor for the report and the repro (#57).
+
 v0.9.0 2025-07-08 Zagreb
 ------------------------
 
@@ -11,7 +16,7 @@ v0.9.0 2025-07-08 Zagreb
 * `Logs.format_reporter` and `Logs_fmt.reporter` replace a few format 
   strings and `^^` uses by direct calls to `Format` primitives.
 * Requires OCaml >= 4.14.
-* Use Format.pp_print_text instead of your own.
+* Use Format.pp_print_text instead of our own.
 * Export `logs` from each sub library.
 
 v0.8.0 2025-03-10 La Forclaz (VS)

src/cli/logs_cli.mli

@@ -46,27 +46,30 @@ let hello _ msg =
   Logs.warn (fun m -> m "Something bad may happen in the future.");
   if Logs.err_count () > 0 then 1 else 0
 
-let setup_log style_renderer level =
+let setup_log ~style_renderer ~level =
   Fmt_tty.setup_std_outputs ?style_renderer ();
   Logs.set_level level;
   Logs.set_reporter (Logs_fmt.reporter ())
 
 (* Command line interface *)
 
 open Cmdliner
+open Cmdliner.Term.Syntax
 
-let setup_log =
+let cmd =
+  Cmd.make (Cmd.info "tool") @@
   let env = Cmd.Env.info "TOOL_VERBOSITY" in
-  Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ~env ())
+  let+ style_renderer = Fmt_cli.style_renderer ()
+  and+ level = Logs_cli.level ~env ()
+  and+ msg =
+    let doc = "The message to output."  in
+    Arg.(value & pos 0 string "Hello horrible world!" & info [] ~doc)
+  in
+  setup_log ~style_renderer ~level;
+  hello msg
 
-let msg =
-  let doc = "The message to output."  in
-  Arg.(value & pos 0 string "Hello horrible world!" & info [] ~doc)
-
-let main () =
-  let cmd = Cmd.make (Cmd.info "tool") Term.(const hello $ setup_log $ msg) in
-  Cmd.eval' cmd
 
+let main () = Cmd.eval' cmd
 let () = if !Sys.interactive then () else exit (main ())
 ]}
 

src/logs.ml

@@ -188,7 +188,11 @@ let report src level ~over k msgf =
   let mutex = Atomic.get reporter_mutex' in
   let over () = over (); mutex.unlock () in
   mutex.lock ();
-  (Atomic.get reporter').report src level ~over k msgf
+  try (Atomic.get reporter').report src level ~over k msgf with
+  | exn ->
+      let bt = Printexc.get_raw_backtrace ()  in
+      over ();
+      Printexc.raise_with_backtrace exn bt
 
 let pp_brackets pp_v ppf v =
   Format.pp_print_char ppf '['; pp_v ppf v; Format.pp_print_char ppf ']'

test/test_mutex_safe.ml

@@ -0,0 +1,23 @@
+(*---------------------------------------------------------------------------
+   Copyright (c) 2025 The logs programmers. All rights reserved.
+   SPDX-License-Identifier: ISC
+  ---------------------------------------------------------------------------*)
+
+(* See https://github.com/dbuenzli/logs/issues/57 *)
+
+let src = Logs.Src.create "repro case"
+module Log = (val Logs.src_log src)
+
+let setup_logs () =
+  Logs.set_reporter (Logs_fmt.reporter ());
+  Logs.set_level ~all:true (Some Logs.Debug);
+  Logs_threaded.enable ();
+  ()
+
+let main () =
+  setup_logs ();
+  (try Logs.app (fun _m -> failwith "uh oh...") with Failure _ -> ());
+  Logs.app (fun m -> m "It works!");
+  0
+
+let () = if !Sys.interactive then () else exit (main ())

test/tool.ml

@@ -2,33 +2,36 @@
 
 (* Example setup for a simple command line tool with colorful output. *)
 
-let hello _ msg =
+let hello msg =
   Logs.app (fun m -> m "%s" msg);
   Logs.info (fun m -> m "End-user information.");
   Logs.debug (fun m -> m "Developer information.");
   Logs.err (fun m -> m "Something bad happened.");
   Logs.warn (fun m -> m "Something bad may happen in the future.");
   if Logs.err_count () > 0 then 1 else 0
 
-let setup_log style_renderer level =
+let setup_log ~style_renderer ~level =
   Fmt_tty.setup_std_outputs ?style_renderer ();
   Logs.set_level level;
   Logs.set_reporter (Logs_fmt.reporter ())
 
 (* Command line interface *)
 
 open Cmdliner
+open Cmdliner.Term.Syntax
 
-let setup_log =
+let cmd =
+  Cmd.make (Cmd.info "tool") @@
   let env = Cmd.Env.info "TOOL_VERBOSITY" in
-  Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ~env ())
+  let+ style_renderer = Fmt_cli.style_renderer ()
+  and+ level = Logs_cli.level ~env ()
+  and+ msg =
+    let doc = "The message to output."  in
+    Arg.(value & pos 0 string "Hello horrible world!" & info [] ~doc)
+  in
+  setup_log ~style_renderer ~level;
+  hello msg
 
-let msg =
-  let doc = "The message to output."  in
-  Arg.(value & pos 0 string "Hello horrible world!" & info [] ~doc)
-
-let main () =
-  let cmd = Cmd.v (Cmd.info "tool") Term.(const hello $ setup_log $ msg) in
-  Cmd.eval' cmd
 
+let main () = Cmd.eval' cmd
 let () = if !Sys.interactive then () else exit (main ())