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