1;;; PostgreSQL higher level functions
2;;;
3;;; Copyright (C) 1999-2008 by Sam Steingold
4;;; This is Free Software, distributed under the GNU GPL v2+
5;;; No warranty; you may copy/modify/redistribute under the same
6;;; conditions with the source code (<http://www.gnu.org/copyleft/gpl.html>)
7
8(require "postgresql")
9
10(in-package "SQL")
11
12;;;
13;;; Helper Functions
14;;;
15
16(defvar *sql-log* nil "The PostgreSQL log stream or NIL.")
17(defvar *sql-login* "postgres" "The default PostgreSQL login.")
18(defvar *sql-password* "postgres" "The default PostgreSQL passowrd.")
19
20(define-condition sql-error (error)
21  ((type :type symbol :reader sql-type :initarg :type)
22   (mesg :type simple-string :reader sql-mesg :initarg :mesg))
23  (:report (lambda (cc stream)
24             (format stream "[~a] ~a" (sql-type cc) (sql-mesg cc)))))
25
26(defun pq-finish (conn)
27  "if you do `PQfinish' twice on the same object, you will get segfault!"
28  (when (and conn (validp conn))
29    (PQfinish conn)
30    (setf (validp conn) nil)))
31
32(defun pq-clear (res)
33  "if you do `PQclear' twice on the same object, you will get segfault!"
34  (when (and res (validp res))
35    (PQclear res)
36    (setf (validp res) nil)))
37
38(defun sql-error (conn res format-string &rest args)
39  (pq-clear res) (pq-finish conn)
40  (error 'sql-error :mesg (apply #'format nil format-string args)
41         :type (if res :request :connection)))
42
43(defun sql-connect (&key host port options tty name
44                    (login *sql-login*) (password *sql-password*))
45  (let ((conn (PQsetdbLogin host port options tty name login password)))
46    (when conn (set-foreign-pointer conn :copy))
47    (unless (and conn (= (PQstatus conn) CONNECTION_OK))
48      (sql-error conn nil "~S(~S,~S,~S,~S,~S,~S,~S): ~S"
49                 'sql-connect host port options tty name login password
50                 (PQerrorMessage conn)))
51    (when *sql-log*
52      (format *sql-log* "~&Connection(~S) OK:~% db name: ~S
53 host:port[tty]: ~S:~S[~S]~% options: ~S~%"
54              conn (PQdb conn) (PQhost conn) (PQport conn)
55              (PQtty conn) (PQoptions conn)))
56    conn))
57
58(defmacro with-sql-connection ((conn &rest options &key (log '*sql-log*)
59                                     &allow-other-keys) &body body)
60  `(let* ((*sql-log* ,log)
61          (,conn (sql-connect ,@(ext:remove-plist options :log))))
62     (unwind-protect (progn ,@body)
63       ;; close the connection to the database and cleanup
64       (pq-finish ,conn))))
65
66(defun sql-transaction (conn command status &optional (clear-p t))
67  (let ((res (PQexec conn command)))
68    (when res (set-foreign-pointer res :copy))
69    (unless (and res (= status (PQresultStatus res)))
70      (sql-error conn res command "~S(~S,~S): ~S" 'sql-transaction
71                 conn command (PQresultErrorMessage res)))
72    (when *sql-log*
73      (format *sql-log* " * OK: ~a~%" command))
74    (when clear-p (pq-clear res))
75    res))
76
77(defmacro with-sql-transaction ((res conn command status) &body body)
78  `(let ((,res (sql-transaction ,conn ,command ,status nil)))
79    (unwind-protect (progn ,@body)
80      ;; avoid memory leaks
81      (pq-clear ,res))))
82
83(pushnew "SQL" custom:*system-package-list* :test #'string=)
84
85;;; file sql.lisp ends here
86