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