db-postgresql-socket/postgresql-socket-sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     postgresql-socket-sql.sql
   6 ;;;; Purpose:  High-level PostgreSQL interface using socket
   7 ;;;; Authors:  Kevin M. Rosenberg based on original code by Pierre R. Mai
   8 ;;;; Created:  Feb 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
  13 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  14 ;;;;
  15 ;;;; CLSQL users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  18 ;;;; *************************************************************************
  19
  20 (in-package #:cl-user)
  21
  22 (defpackage :clsql-postgresql-socket
  23     (:use #:common-lisp #:clsql-base-sys #:postgresql-socket)
  24     (:export #:postgresql-socket-database)
  25     (:documentation "This is the CLSQL socket interface to PostgreSQL."))
  26
  27 (in-package #:clsql-postgresql-socket)
  28
  29 ;; interface foreign library loading routines
  30
  31
  32 (clsql-base-sys:database-type-load-foreign :postgresql-socket)
  33
  34
  35 ;; Field type conversion
  36
  37 (defun make-type-list-for-auto (cursor)
  38   (let* ((fields (postgresql-cursor-fields cursor))
  39          (num-fields (length fields))
  40          (new-types '()))
  41     (dotimes (i num-fields)
  42       (declare (fixnum i))
  43       (push (canonical-field-type fields i) new-types))
  44     (nreverse new-types)))
  45
  46 (defun canonical-field-type (fields index)
  47   "Extracts canonical field type from fields list"
  48   (let ((oid (cadr (nth index fields))))
  49     (case oid
  50       ((#.pgsql-ftype#bytea
  51         #.pgsql-ftype#int2
  52         #.pgsql-ftype#int4)
  53        :int32)
  54       (#.pgsql-ftype#int8
  55        :int64)
  56       ((#.pgsql-ftype#float4
  57         #.pgsql-ftype#float8)
  58        :double)
  59       (otherwise
  60        t))))
  61
  62 (defun canonicalize-types (types cursor)
  63   (if (null types)
  64       nil
  65       (let ((auto-list (make-type-list-for-auto cursor)))
  66         (cond
  67           ((listp types)
  68            (canonicalize-type-list types auto-list))
  69           ((eq types :auto)
  70            auto-list)
  71           (t
  72            nil)))))
  73
  74 (defun canonicalize-type-list (types auto-list)
  75   "Ensure a field type list meets expectations.
  76 Duplicated from clsql-uffi package so that this interface
  77 doesn't depend on UFFI."
  78   (let ((length-types (length types))
  79         (new-types '()))
  80     (loop for i from 0 below (length auto-list)
  81           do
  82           (if (>= i length-types)
  83               (push t new-types) ;; types is shorted than num-fields
  84               (push
  85                (case (nth i types)
  86                  (:int
  87                   (case (nth i auto-list)
  88                     (:int32
  89                      :int32)
  90                     (:int64
  91                      :int64)
  92                     (t
  93                      t)))
  94                  (:double
  95                   (case (nth i auto-list)
  96                     (:double
  97                      :double)
  98                     (t
  99                      t)))
 100                  (t
 101                   t))
 102                new-types)))
 103     (nreverse new-types)))
 104
 105
 106 (defun convert-to-clsql-warning (database condition)
 107   (warn 'clsql-database-warning :database database
 108         :message (postgresql-condition-message condition)))
 109
 110 (defun convert-to-clsql-error (database expression condition)
 111   (error 'clsql-sql-error :database database
 112          :expression expression
 113          :errno (type-of condition)
 114          :error (postgresql-condition-message condition)))
 115
 116 (defmacro with-postgresql-handlers
 117     ((database &optional expression)
 118      &body body)
 119   (let ((database-var (gensym))
 120         (expression-var (gensym)))
 121     `(let ((,database-var ,database)
 122            (,expression-var ,expression))
 123        (handler-bind ((postgresql-warning
 124                        (lambda (c)
 125                          (convert-to-clsql-warning ,database-var c)))
 126                       (postgresql-error
 127                        (lambda (c)
 128                          (convert-to-clsql-error
 129                           ,database-var ,expression-var c))))
 130          ;; KMR - removed double @@
 131          ,@body))))
 132
 133 (defmethod database-initialize-database-type ((database-type
 134                                                (eql :postgresql-socket)))
 135   t)
 136
 137 (defclass postgresql-socket-database (database)
 138   ((connection :accessor database-connection :initarg :connection
 139                :type postgresql-connection)))
 140
 141 (defmethod database-type ((database postgresql-socket-database))
 142   :postgresql-socket)
 143
 144 (defmethod database-name-from-spec (connection-spec
 145                                     (database-type (eql :postgresql-socket)))
 146   (check-connection-spec connection-spec database-type
 147                          (host db user password &optional port options tty))
 148   (destructuring-bind (host db user password &optional port options tty)
 149       connection-spec
 150     (declare (ignore password options tty))
 151     (concatenate 'string
 152       (etypecase host
 153         (null
 154          "localhost")
 155         (pathname (namestring host))
 156         (string host))
 157       (when port
 158         (concatenate 'string
 159                      ":"
 160                      (etypecase port
 161                        (integer (write-to-string port))
 162                        (string port))))
 163       "/" db "/" user)))
 164
 165 (defmethod database-connect (connection-spec
 166                              (database-type (eql :postgresql-socket)))
 167   (check-connection-spec connection-spec database-type
 168                          (host db user password &optional port options tty))
 169   (destructuring-bind (host db user password &optional
 170                             (port +postgresql-server-default-port+)
 171                             (options "") (tty ""))
 172       connection-spec
 173     (handler-case
 174         (handler-bind ((postgresql-warning
 175                         (lambda (c)
 176                           (warn 'clsql-simple-warning
 177                                 :format-control "~A"
 178                                 :format-arguments
 179                                 (list (princ-to-string c))))))
 180           (open-postgresql-connection :host host :port port
 181                                       :options options :tty tty
 182                                       :database db :user user
 183                                       :password password))
 184       (postgresql-error (c)
 185         ;; Connect failed
 186         (error 'clsql-connect-error
 187                :database-type database-type
 188                :connection-spec connection-spec
 189                :errno (type-of c)
 190                :error (postgresql-condition-message c)))
 191       (:no-error (connection)
 192                  ;; Success, make instance
 193                  (make-instance 'postgresql-socket-database
 194                                 :name (database-name-from-spec connection-spec
 195                                                                database-type)
 196                                 :database-type :postgresql-socket
 197                                 :connection-spec connection-spec
 198                                 :connection connection)))))
 199
 200 (defmethod database-disconnect ((database postgresql-socket-database))
 201   (close-postgresql-connection (database-connection database))
 202   t)
 203
 204 (defmethod database-query (expression (database postgresql-socket-database) result-types field-names)
 205   (let ((connection (database-connection database)))
 206     (with-postgresql-handlers (database expression)
 207       (start-query-execution connection expression)
 208       (multiple-value-bind (status cursor)
 209           (wait-for-query-results connection)
 210         (unless (eq status :cursor)
 211           (close-postgresql-connection connection)
 212           (error 'clsql-sql-error
 213                  :database database
 214                  :expression expression
 215                  :errno 'missing-result
 216                  :error "Didn't receive result cursor for query."))
 217         (setq result-types (canonicalize-types result-types cursor))
 218         (values
 219          (loop for row = (read-cursor-row cursor result-types)
 220                while row
 221                collect row
 222                finally
 223                (unless (null (wait-for-query-results connection))
 224                  (close-postgresql-connection connection)
 225                  (error 'clsql-sql-error
 226                         :database database
 227                         :expression expression
 228                         :errno 'multiple-results
 229                         :error "Received multiple results for query.")))
 230          (when field-names
 231            (result-field-names cursor)))))))
 232
 233 (defun result-field-names (cursor)
 234   "Return list of result field names."
 235   ;; FIXME -- implement
 236   nil)
 237
 238 (defmethod database-execute-command
 239     (expression (database postgresql-socket-database))
 240   (let ((connection (database-connection database)))
 241     (with-postgresql-handlers (database expression)
 242       (start-query-execution connection expression)
 243       (multiple-value-bind (status result)
 244           (wait-for-query-results connection)
 245         (when (eq status :cursor)
 246           (loop
 247               (multiple-value-bind (row stuff)
 248                   (skip-cursor-row result)
 249                 (unless row
 250                   (setq status :completed result stuff)
 251                   (return)))))
 252         (cond
 253           ((null status)
 254            t)
 255           ((eq status :completed)
 256            (unless (null (wait-for-query-results connection))
 257              (close-postgresql-connection connection)
 258              (error 'clsql-sql-error
 259                     :database database
 260                     :expression expression
 261                     :errno 'multiple-results
 262                     :error "Received multiple results for command."))
 263            result)
 264           (t
 265            (close-postgresql-connection connection)
 266            (error 'clsql-sql-error
 267                   :database database
 268                   :expression expression
 269                   :errno 'missing-result
 270                   :error "Didn't receive completion for command.")))))))
 271
 272 (defstruct postgresql-socket-result-set
 273   (done nil)
 274   (cursor nil)
 275   (types nil))
 276
 277 (defmethod database-query-result-set ((expression string)
 278                                       (database postgresql-socket-database)
 279                                       &key full-set result-types)
 280   (declare (ignore full-set))
 281   (let ((connection (database-connection database)))
 282     (with-postgresql-handlers (database expression)
 283       (start-query-execution connection expression)
 284       (multiple-value-bind (status cursor)
 285           (wait-for-query-results connection)
 286         (unless (eq status :cursor)
 287           (close-postgresql-connection connection)
 288           (error 'clsql-sql-error
 289                  :database database
 290                  :expression expression
 291                  :errno 'missing-result
 292                  :error "Didn't receive result cursor for query."))
 293         (values (make-postgresql-socket-result-set
 294                  :done nil
 295                  :cursor cursor
 296                  :types (canonicalize-types result-types cursor))
 297                 (length (postgresql-cursor-fields cursor)))))))
 298
 299 (defmethod database-dump-result-set (result-set
 300                                      (database postgresql-socket-database))
 301   (if (postgresql-socket-result-set-done result-set)
 302       t
 303       (with-postgresql-handlers (database)
 304         (loop while (skip-cursor-row
 305                      (postgresql-socket-result-set-cursor result-set))
 306           finally (setf (postgresql-socket-result-set-done result-set) t)))))
 307
 308 (defmethod database-store-next-row (result-set
 309                                     (database postgresql-socket-database)
 310                                     list)
 311   (let ((cursor (postgresql-socket-result-set-cursor result-set)))
 312     (with-postgresql-handlers (database)
 313       (if (copy-cursor-row cursor
 314                            list
 315                            (postgresql-socket-result-set-types
 316                             result-set))
 317           t
 318           (prog1 nil
 319             (setf (postgresql-socket-result-set-done result-set) t)
 320             (wait-for-query-results (database-connection database)))))))
 321
 322 ;;; Object listing
 323
 324 (defun owner-clause (owner)
 325   (cond
 326    ((stringp owner)
 327     (format
 328      nil
 329      " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))"
 330      owner))
 331    ((null owner)
 332     (format nil " AND (NOT (relowner=1))"))
 333    (t "")))
 334
 335 (defun database-list-objects-of-type (database type owner)
 336   (mapcar #'car
 337           (database-query
 338            (format nil
 339                    "SELECT relname FROM pg_class WHERE (relkind = '~A')~A"
 340                    type
 341                    (owner-clause owner))
 342            database nil)))
 343
 344 (defmethod database-list-tables ((database postgresql-socket-database)
 345                                  &key (owner nil))
 346   (database-list-objects-of-type database "r" owner))
 347
 348 (defmethod database-list-views ((database postgresql-socket-database)
 349                                 &key (owner nil))
 350   (database-list-objects-of-type database "v" owner))
 351
 352 (defmethod database-list-indexes ((database postgresql-socket-database)
 353                                   &key (owner nil))
 354   (database-list-objects-of-type database "i" owner))
 355
 356 (defmethod database-list-table-indexes (table
 357                                         (database postgresql-socket-database)
 358                                         &key (owner nil))
 359   (let ((indexrelids
 360          (database-query
 361           (format
 362            nil
 363            "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
 364            (string-downcase table)
 365            (owner-clause owner))
 366           database :auto))
 367         (result nil))
 368     (dolist (indexrelid indexrelids (nreverse result))
 369       (push
 370        (caar (database-query
 371               (format nil "select relname from pg_class where relfilenode='~A'"
 372                       (car indexrelid))
 373               database
 374               nil))
 375        result))))
 376
 377 (defmethod database-list-attributes ((table string)
 378                                      (database postgresql-socket-database)
 379                                      &key (owner nil))
 380   (let* ((owner-clause
 381           (cond ((stringp owner)
 382                  (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
 383                 ((null owner) " AND (not (relowner=1))")
 384                 (t "")))
 385          (result
 386           (mapcar #'car
 387                   (database-query
 388                    (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A"
 389                            (string-downcase table)
 390                            owner-clause)
 391                    database nil))))
 392     (if result
 393         (reverse
 394          (remove-if #'(lambda (it) (member it '("cmin"
 395                                                 "cmax"
 396                                                 "xmax"
 397                                                 "xmin"
 398                                                 "oid"
 399                                                 "ctid"
 400                                                 ;; kmr -- added tableoid
 401                                                 "tableoid") :test #'equal))
 402                     result)))))
 403
 404 (defmethod database-attribute-type (attribute (table string)
 405                                     (database postgresql-socket-database)
 406                                     &key (owner nil))
 407   (let* ((owner-clause
 408           (cond ((stringp owner)
 409                  (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
 410                 ((null owner) " AND (not (relowner=1))")
 411                 (t "")))
 412          (result
 413           (mapcar #'car
 414                   (database-query
 415                    (format nil "SELECT pg_type.typname FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A"
 416                            (string-downcase table)
 417                            (string-downcase attribute)
 418                            owner-clause)
 419                    database nil))))
 420     (when result
 421       (intern (string-upcase (car result)) :keyword))))
 422
 423 (defmethod database-create-sequence (sequence-name
 424                                      (database postgresql-socket-database))
 425   (database-execute-command
 426    (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
 427    database))
 428
 429 (defmethod database-drop-sequence (sequence-name
 430                                    (database postgresql-socket-database))
 431   (database-execute-command
 432    (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database))
 433
 434 (defmethod database-list-sequences ((database postgresql-socket-database)
 435                                     &key (owner nil))
 436   (database-list-objects-of-type database "S" owner))
 437
 438 (defmethod database-set-sequence-position (name (position integer)
 439                                           (database postgresql-socket-database))
 440   (values
 441    (parse-integer
 442     (caar
 443      (database-query
 444       (format nil "SELECT SETVAL ('~A', ~A)" name position)
 445       database nil)))))
 446
 447 (defmethod database-sequence-next (sequence-name
 448                                    (database postgresql-socket-database))
 449   (values
 450    (parse-integer
 451     (caar
 452      (database-query
 453       (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
 454       database nil)))))
 455
 456 (defmethod database-sequence-last (sequence-name (database postgresql-socket-database))
 457   (values
 458    (parse-integer
 459     (caar
 460      (database-query
 461       (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')")
 462       database nil)))))
 463
 464
 465 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
 466   (destructuring-bind (host name user password) connection-spec
 467     (let ((database (database-connect (list host "template1" user password)
 468                                       type)))
 469       (unwind-protect
 470            (execute-command (format nil "create database ~A" name))
 471         (database-disconnect database)))))
 472
 473 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket)))
 474   (destructuring-bind (host name user password) connection-spec
 475     (let ((database (database-connect (list host "template1" user password)
 476                                       type)))
 477       (unwind-protect
 478           (execute-command (format nil "drop database ~A" name))
 479         (database-disconnect database)))))
 480
 481
 482 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
 483   (when (find (second connection-spec) (database-list connection-spec type)
 484               :key #'car :test #'string-equal)
 485     t))
 486
 487 (defmethod database-list (connection-spec (type (eql :postgresql-socket)))
 488   (destructuring-bind (host name user password) connection-spec
 489     (declare (ignore name))
 490     (let ((database (database-connect (list host "template1" user password)
 491                                       type)))
 492       (unwind-protect
 493            (progn
 494              (setf (slot-value database 'clsql-base-sys::state) :open)
 495              (mapcar #'car (database-query "select datname from pg_database"
 496                                            database :auto)))
 497         (progn
 498           (database-disconnect database)
 499           (setf (slot-value database 'clsql-base-sys::state) :closed))))))
 500
 501 (defmethod database-describe-table ((database postgresql-socket-database)
 502                                     table)
 503   (database-query
 504    (format nil "select a.attname, t.typname
 505                                from pg_class c, pg_attribute a, pg_type t
 506                                where c.relname = '~a'
 507                                    and a.attnum > 0
 508                                    and a.attrelid = c.oid
 509                                    and a.atttypid = t.oid"
 510            (sql-escape (string-downcase table)))
 511    database :auto))
 512
 513
 514 ;; Database capabilities
 515
 516 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket)))
 517   nil)
 518
 519 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket)))
 520   t)
 521
 522 (defmethod db-type-default-case ((db-type (eql :postgresql)))
 523   :lower)
 524
 525 (when (clsql-base-sys:database-type-library-loaded :postgresql-socket)
 526   (clsql-base-sys:initialize-database-type :database-type :postgresql-socket))