diff --git a/src/dune b/src/dune index 4601141..55cb1d5 100644 --- a/src/dune +++ b/src/dune @@ -1,3 +1,5 @@ +(include_subdirs qualified) + (executable (name main) (libraries ctypes-foreign) diff --git a/src/main.ml b/src/main.ml index 6802323..aedadaf 100644 --- a/src/main.ml +++ b/src/main.ml @@ -1,22 +1,29 @@ let spawn cmd = - match Unix.fork () with 0 -> Unix.execvp cmd.(0) cmd | _pid -> () + match Unix.fork () with + | 0 -> + let devnull = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0o666 in + Unix.dup2 devnull Unix.stdout; + Unix.dup2 devnull Unix.stderr; + Unix.close devnull; + Unix.execvp cmd.(0) cmd + | _pid -> () let () = - let conn = Xcb.connect () in + let conn = Xcb.Functions.connect () in print_endline "connected"; - let _ = Xcb.window_attribute_setup conn in + Xcb.Functions.window_attribute_setup conn; - Xcb.flush conn; + if Xcb.Functions.flush conn <= 0 then exit 1; spawn [| "kitty" |]; while true do - Xcb.flush conn; + if Xcb.Functions.flush conn <= 0 then exit 1; Unix.sleepf 0.01 done; - Xcb.disconnect conn; + Xcb.Functions.disconnect conn; print_endline "done" diff --git a/src/xcb/functions.ml b/src/xcb/functions.ml new file mode 100644 index 0000000..91ad4ed --- /dev/null +++ b/src/xcb/functions.ml @@ -0,0 +1,53 @@ +open Ctypes +open Foreign + +let xcb_connect = + foreign "xcb_connect" + (string_opt @-> ptr int @-> returning (ptr Types.connection)) + +let disconnect = + foreign "xcb_disconnect" (ptr Types.connection @-> returning void) + +let flush = foreign "xcb_flush" (ptr Types.connection @-> returning int) + +let connect () = + let screen = allocate int 0 in + xcb_connect None screen + +let get_setup = + foreign "xcb_get_setup" (ptr Types.connection @-> returning (ptr Types.setup)) + +let setup_roots_iterator = + foreign "xcb_setup_roots_iterator" + (ptr Types.setup @-> returning Types.screen_iterator) + +let scr conn = getf (setup_roots_iterator (get_setup conn)) Types.data +let root_window conn : Types.window = getf !@(scr conn) Types.root + +let values = + CArray.of_list uint32_t + [ Unsigned.UInt32.of_int (1048576 lor 524288 lor 131072 lor 4194304) ] + +let xcb_change_window_attributes_checked = + foreign "xcb_change_window_attributes_checked" + (ptr Types.connection @-> uint32_t @-> uint32_t @-> ptr uint32_t + @-> returning Types.void_cookie) + +let xcb_request_check = + foreign "xcb_request_check" + (ptr Types.connection @-> Types.void_cookie + @-> returning (ptr_opt Types.generic_error)) + +let window_attribute_setup conn = + let cookie = + xcb_change_window_attributes_checked conn (root_window conn) + (Unsigned.UInt32.of_int 2048) + (CArray.start values) + in + + match xcb_request_check conn cookie with + | None -> print_endline "WM ownership acquired" + | Some _ -> print_endline "another WM already owns the display" + +let connection_has_error = + foreign "xcb_connection_has_error" (ptr Types.connection @-> returning int) diff --git a/src/xcb.ml b/src/xcb/types.ml similarity index 54% rename from src/xcb.ml rename to src/xcb/types.ml index aaf18cc..3b211f3 100644 --- a/src/xcb.ml +++ b/src/xcb/types.ml @@ -41,55 +41,5 @@ let data = field screen_iterator "data" (ptr screen) let rem = field screen_iterator "rem" int let index = field screen_iterator "index" int let () = seal screen_iterator - -(**) let setup : setup structure typ = structure "xcb_setup_t" - -(**) let connection : connection structure typ = structure "xcb_connection_t" - -let xcb_connect = - foreign "xcb_connect" (string_opt @-> ptr int @-> returning (ptr connection)) - -let xcb_disconnect = foreign "xcb_disconnect" (ptr connection @-> returning void) -let xcb_flush = foreign "xcb_flush" (ptr connection @-> returning int) - -let connect () = - let screen = allocate int 0 in - xcb_connect None screen - -let disconnect conn = xcb_disconnect conn -let flush conn = ignore (xcb_flush conn) - -let get_setup = - foreign "xcb_get_setup" (ptr connection @-> returning (ptr setup)) - -let setup_roots_iterator = - foreign "xcb_setup_roots_iterator" (ptr setup @-> returning screen_iterator) - -let scr conn = getf (setup_roots_iterator (get_setup conn)) data -let root_window conn : window = getf !@(scr conn) root - -let values = - CArray.of_list uint32_t - [ Unsigned.UInt32.of_int (1048576 lor 524288 lor 131072 lor 4194304) ] - -let xcb_change_window_attributes_checked = - foreign "xcb_change_window_attributes_checked" - (ptr connection @-> uint32_t @-> uint32_t @-> ptr uint32_t - @-> returning void_cookie) - -let xcb_request_check = - foreign "xcb_request_check" - (ptr connection @-> void_cookie @-> returning (ptr_opt generic_error)) - -let window_attribute_setup conn = - let cookie = - xcb_change_window_attributes_checked conn (root_window conn) - (Unsigned.UInt32.of_int 2048) - (CArray.start values) - in - - match xcb_request_check conn cookie with - | None -> print_endline "WM ownership acquired" - | Some _ -> print_endline "another WM already owns the display"