[pg-devel] [PATCH] pg-disconnect and abnormal exits

[Vladimir Sekissov]

Good day,

Current implementation of WITH-PG-CONNECTION forces abnormal
connection aborting on any programming error. What about to move
stream handling to PG-DISCONNECT? Here is a possible patch.

In this version PG-DISCONNECT is trying to close connection according
to protocol and only in case of failure or ABORT = T forces stream closing.

Best Regards,
Vladimir Sekissov

diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/utility.lisp pg/utility.lisp
--- pg.orig/utility.lisp	2006-11-21 01:50:36.000000000 +0500
+++ pg/utility.lisp	2006-11-24 15:16:00.000000000 +0500
@@ -36,14 +36,10 @@
 CONNECTION. If the connection is unsuccessful, the forms are not
 evaluated. Otherwise, the BODY forms are executed, and upon
 termination, normal or otherwise, the database connection is closed."
-  (let ((ok (gensym)))
-    `(let ((,con (pg-connect , at open-args))
-           (,ok nil))
-       (unwind-protect
-           (multiple-value-prog1
-               (progn , at body)
-             (setf ,ok t))
-         (when ,con (pg-disconnect ,con :abort (not ,ok)))))))
+  `(let ((,con (pg-connect , at open-args)))
+     (unwind-protect
+          (progn , at body)
+       (when ,con (pg-disconnect ,con :abort nil)))))
 
 ;; this is the old version
 #+(or)
@@ -101,4 +97,28 @@
                    :do (funcall callback (first res)))
            (pg-exec conn "CLOSE " cursor))))))
 
+(defun close-stream (stream &key force)
+  "Close STREAM, if failed and FORCE is T try to close harder.
+Returns T,NIL on success and NIL,ERROR on failer."
+  (let (err)
+    (mapc
+     #'(lambda (attempt)
+         (multiple-value-bind (r e) (ignore-errors (funcall attempt) t)
+           (if r
+               (return-from close-stream (values t nil))
+               (setf err e))))
+     (cons
+      #'(lambda () (close stream))
+      (when force
+        (list
+         #'(lambda () (close stream :abort t))
+         #+cmu
+         #'(lambda ()
+             (unix:unix-close (sys:fd-stream-fd stream)))
+         #+sbcl
+         #'(lambda ()
+             (sb-unix:unix-close (sb-sys:fd-stream-fd stream)))
+         ))))
+    (values nil err)))
+
 ;; EOF
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/v2-protocol.lisp pg/v2-protocol.lisp
--- pg.orig/v2-protocol.lisp	2006-11-21 01:50:36.000000000 +0500
+++ pg/v2-protocol.lisp	2006-11-24 15:07:48.000000000 +0500
@@ -238,14 +238,12 @@
 
 
 (defmethod pg-disconnect ((connection pgcon-v2) &key abort)
-  (cond
-    (abort
-     (close (pgcon-stream connection) :abort t))
-    (t
-     (write-byte 88 (pgcon-stream connection))
-     (%flush connection)
-     (close (pgcon-stream connection))))
-  (values))
+  (close-stream (pgcon-stream connection)
+                :force (or abort
+                           (not (ignore-errors
+                                  (write-byte 88 (pgcon-stream connection))
+                                  (%flush connection)
+                                  t)))))
 
 
 ;; Attribute information is as follows
diff -Naur --exclude=CVS --exclude='*.fasl' --exclude='*~' pg.orig/v3-protocol.lisp pg/v3-protocol.lisp
--- pg.orig/v3-protocol.lisp	2006-11-21 01:50:36.000000000 +0500
+++ pg/v3-protocol.lisp	2006-11-24 15:08:48.000000000 +0500
@@ -642,14 +642,13 @@
 
 
 (defmethod pg-disconnect ((connection pgcon-v3) &key abort)
-  (cond
-    (abort
-     (close (pgcon-stream connection) :abort t))
-    (t
-     (send-packet connection #\X nil)
-     (%flush connection)
-     (close (pgcon-stream connection))))
-  (values))
+  
+  (close-stream (pgcon-stream connection)
+                :force (or abort
+                           (not (ignore-errors
+                                  (send-packet connection #\X nil)
+                                  (%flush connection)
+                                  t)))))
 
 
 ;; Attribute information is as follows