From: malc <av1474@comtv.ru>
Date: Sun, 13 Jan 2013 20:55:05 +0000 (+0400)
Subject: Handle EINTR
X-Git-Tag: v14~70
X-Git-Url: https://repo.or.cz/w/llpp.git/commitdiff_plain/70712e5a5a274c4dcaac5a4a823081651d8153f4

Handle EINTR

Thanks to Didier Remy for reproduction test-case.
---

diff --git a/Thanks b/Thanks
index 4b68673..75097d5 100644
--- a/Thanks
+++ b/Thanks
@@ -31,3 +31,5 @@ E.A. German (comfy chair, silent x86 box, lots more)
 Andrei Gulin (nudge towards split columns)
 
 Torsten Ww (help with Mesa flickering issue and horizontal wheel)
+
+Didier Remy
diff --git a/main.ml b/main.ml
index 7a468c3..ee0e214 100644
--- a/main.ml
+++ b/main.ml
@@ -1,5 +1,7 @@
 exception Quit;;
 
+let tempfailureretry = Wsi.tempfailureretry;;
+
 type under =
     | Unone
     | Ulinkuri of string
@@ -752,17 +754,17 @@ module Ne = struct
   ;;
 
   let clo fd f =
-    try Unix.close fd
+    try tempfailureretry Unix.close fd
     with exn -> f (Printexc.to_string exn)
   ;;
 
   let dup fd =
-    try Res (Unix.dup fd)
+    try Res (tempfailureretry Unix.dup fd)
     with exn -> Exn exn
   ;;
 
   let dup2 fd1 fd2 =
-    try Res (Unix.dup2 fd1 fd2)
+    try Res (tempfailureretry (Unix.dup2 fd1) fd2)
     with exn -> Exn exn
   ;;
 end;;
@@ -807,7 +809,7 @@ let redirectstderr () =
               (Printexc.to_string exn)
         | Ne.Res () ->
             Ne.clo fd (clofail "dup of stderr");
-            Unix.dup2 state.stderr Unix.stderr;
+            ignore (Ne.dup2 state.stderr Unix.stderr);
             state.errfd <- None;
         end;
     | None -> ()
@@ -995,7 +997,7 @@ let multicolumns_of_string s =
 
 let readcmd fd =
   let s = "xxxx" in
-  let n = Unix.read fd s 0 4 in
+  let n = tempfailureretry (Unix.read fd s 0) 4 in
   if n != 4 then failwith "incomplete read(len)";
   let len = 0
     lor (Char.code s.[0] lsl 24)
@@ -1004,7 +1006,7 @@ let readcmd fd =
     lor (Char.code s.[3] lsl  0)
   in
   let s = String.create len in
-  let n = Unix.read fd s 0 len in
+  let n = tempfailureretry (Unix.read fd s 0) len in
   if n != len then failwith "incomplete read(data)";
   s
 ;;
@@ -1024,7 +1026,7 @@ let wcmd fmt =
       s.[1] <- Char.chr ((len lsr 16) land 0xff);
       s.[2] <- Char.chr ((len lsr  8) land 0xff);
       s.[3] <- Char.chr (len land 0xff);
-      let n' = Unix.write state.sw s 0 n in
+      let n' = tempfailureretry (Unix.write state.sw s 0) n in
       if n' != n then failwith "write failed";
     ) b fmt;
 ;;
@@ -5035,7 +5037,7 @@ let viewkeyboard key mask =
               then
                 (try
                     let l = String.length s in
-                    let n = Unix.write w s 0 l in
+                    let n = tempfailureretry (Unix.write w s 0) l in
                     if n != l
                     then
                       showtext '!'
@@ -7095,7 +7097,7 @@ let () =
       else 0.0
     in
     let r, _, _ =
-      try Unix.select r [] [] timeout
+      try tempfailureretry (Unix.select r [] []) timeout
       with Unix.Unix_error (Unix.EINTR, _, _) -> [], [], []
     in
     begin match r with
@@ -7135,7 +7137,7 @@ let () =
 
           | fd :: rest ->
               let s = String.create 80 in
-              let n = Unix.read fd s 0 80 in
+              let n = tempfailureretry (Unix.read fd s 0) 80 in
               if conf.redirectstderr
               then (
                 Buffer.add_substring state.errmsgs s 0 n;
diff --git a/wsi.ml b/wsi.ml
index 241b4fd..48cb3c8 100644
--- a/wsi.ml
+++ b/wsi.ml
@@ -6,6 +6,12 @@ type cursor =
     | CURSOR_TEXT
 ;;
 
+let tempfailureretry f a =
+  let rec g () =
+    try f a with Unix.Unix_error (Unix.EINTR, _, _) -> g ()
+  in g ()
+;;
+
 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
 external glx : int -> unit = "ml_glx";;
 external glxsync : unit -> unit = "ml_glxsync";;
@@ -141,12 +147,12 @@ let error fmt = Printf.kprintf failwith fmt;;
 let readstr sock n =
   let s = String.create n in
   let rec loop pos n =
-    let m = Unix.read sock s pos n in
+    let m = tempfailureretry (Unix.read sock s pos) n in
     if m = 0
     then state.t#quit;
     if n != m
     then (
-      ignore (Unix.select [sock] [] [] 0.01);
+      ignore (tempfailureretry (Unix.select [sock] [] []) 0.01);
       loop (pos + m) (n - m)
     )
   in
@@ -157,7 +163,7 @@ let readstr sock n =
 let sendstr1 s pos len sock =
   vlog "%d => %S" state.seq s;
   state.seq <- state.seq + 1;
-  let n = Unix.send sock s pos len [] in
+  let n = tempfailureretry (Unix.send sock s pos len) [] in
   if n != len
   then error "send %d returned %d" len n;
 ;;
@@ -591,7 +597,9 @@ let syncsendwithrep sock secstowait s f =
   let now = Unix.gettimeofday in
   let deadline = now () +. secstowait in
   let rec readtillcompletion () =
-    let r, _, _ = Unix.select [sock] [] [] (deadline -. now ()) in
+    let r, _, _ =
+      tempfailureretry (Unix.select [sock] [] []) (deadline -. now ())
+    in
     match r with
     | [] -> error "didn't get X response in %f seconds, aborting" secstowait
     | _ ->
diff --git a/wsi.mli b/wsi.mli
index a009776..de6454e 100644
--- a/wsi.mli
+++ b/wsi.mli
@@ -38,3 +38,4 @@ val shiftmask : int;;
 val ctrlmask : int;;
 val keyname : int -> string;;
 val namekey : string -> int;;
+val tempfailureretry : ('a -> 'b) -> 'a -> 'b;;