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