Re: closing all inactive server connections

[Katsumi Yamaoka <yamaoka@jpl.org>]

[-- Attachment #1: Type: text/plain, Size: 503 bytes --]

>>>>> Ted Zlatanov wrote:

KY> --- nntp.el~	2007-07-18 12:07:39 +0000
KY> +++ nntp.el	2007-07-31 03:04:52 +0000

> I tried it and the IMAP server still hangs.  Maybe the fix is in
> nnimap.el?  I haven't looked deeper into this issue but I'll be glad to
> debug things on my side.

Is the patch effective for the hanged nntp connections?

Well, I tried looking into the IMAP code although I've never
used nnimap.  And I found the functions that communicate with
the server all have the following form:


[-- Attachment #2: Type: application/emacs-lisp, Size: 166 bytes --]

[-- Attachment #3: Type: text/plain, Size: 528 bytes --]


This can be an infinite loop if the process-status keeps `open'
or `run' even though the connection has actually died.  In
particular, the `imap-wait-for-tag' function can be the cause of
the hanging since it sends the LOGOUT command to the dead server
and waits for the response.  So, I tried modifying it so as to
quit in a certain time.  The patch to imap.el is below.  Anyway,
it needs to be reviewed by someone who is skilled in IMAP.  The
default value of `imap-timeout-seconds' might be too small for
slow connections.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: Type: text/x-patch, Size: 3163 bytes --]

--- imap.el~	2007-01-24 07:15:37 +0000
+++ imap.el	2007-07-31 08:50:30 +0000
@@ -1182,14 +1182,25 @@
 			 imap-server auth)))))
 	imap-state))))
 
+(defvar imap-timeout-seconds 1
+  "*Number of seconds in which `imap-close' gives up working.")
+
+(defvar imap-timeout nil
+  "Flag that indicates process should die immediately.")
+
 (defun imap-close (&optional buffer)
   "Close connection to server in BUFFER.
 If BUFFER is nil, the current buffer is used."
   (with-current-buffer (or buffer (current-buffer))
     (when (imap-opened)
-      (condition-case nil
-	  (imap-send-command-wait "LOGOUT")
-	(quit nil)))
+      (let ((timer (run-at-time imap-timeout-seconds nil
+				#'set 'imap-timeout t)))
+	(unwind-protect
+	    (condition-case nil
+		(imap-send-command-wait "LOGOUT")
+	      (quit nil)))
+	(cancel-timer timer)
+	(setq imap-timeout nil)))
     (when (and imap-process
 	       (memq (process-status imap-process) '(open run)))
       (delete-process imap-process))
@@ -1882,30 +1893,35 @@
       (while (and (null imap-continuation)
 		  (memq (process-status imap-process) '(open run))
 		  (< imap-reached-tag tag))
-	(let ((len (/ (point-max) 1024))
-	      message-log-max)
-	  (unless (< len 10)
-	    (setq imap-have-messaged t)
-	    (message "imap read: %dk" len))
-	  (accept-process-output imap-process
-				 (truncate imap-read-timeout)
-				 (truncate (* (- imap-read-timeout
-						 (truncate imap-read-timeout))
-					      1000)))))
-      ;; A process can die _before_ we have processed everything it
-      ;; has to say.  Moreover, this can happen in between the call to
-      ;; accept-process-output and the call to process-status in an
-      ;; iteration of the loop above.
-      (when (and (null imap-continuation)
-		 (< imap-reached-tag tag))
-	(accept-process-output imap-process 0 0))
-      (when imap-have-messaged
-	(message ""))
-      (and (memq (process-status imap-process) '(open run))
-	   (or (assq tag imap-failed-tags)
-	       (if imap-continuation
-		   'INCOMPLETE
-		 'OK))))))
+	(if imap-timeout
+	    (progn
+	      (setq imap-timeout nil)
+	      (delete-process imap-process))
+	  (let ((len (/ (point-max) 1024))
+		message-log-max)
+	    (unless (< len 10)
+	      (setq imap-have-messaged t)
+	      (message "imap read: %dk" len))
+	    (accept-process-output imap-process
+				   (truncate imap-read-timeout)
+				   (truncate (* (- imap-read-timeout
+						   (truncate imap-read-timeout))
+						1000))))))
+      (when (memq (process-status imap-process) '(open run))
+	;; A process can die _before_ we have processed everything it
+	;; has to say.  Moreover, this can happen in between the call to
+	;; accept-process-output and the call to process-status in an
+	;; iteration of the loop above.
+	(when (and (null imap-continuation)
+		   (< imap-reached-tag tag))
+	  (accept-process-output imap-process 0 0))
+	(when imap-have-messaged
+	  (message ""))
+	(and (memq (process-status imap-process) '(open run))
+	     (or (assq tag imap-failed-tags)
+		 (if imap-continuation
+		     'INCOMPLETE
+		   'OK)))))))
 
 (defun imap-sentinel (process string)
   (delete-process process))