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         (null
 155          "localhost")
 156         (pathname (namestring host))
 157         (string host))
 158       (when port
 159         (concatenate 'string
 160                      ":"
 161                      (etypecase port
 162                        (integer (write-to-string port))
 163                        (string port))))
 164       "/" db "/" user)))
 165
 166 (defmethod database-connect (connection-spec
 167                              (database-type (eql :postgresql-socket)))
 168   (check-connection-spec connection-spec database-type
 169                          (host db user password &optional port options tty))
 170   (destructuring-bind (host db user password &optional
 171                             (port +postgresql-server-default-port+)
 172                             (options "") (tty ""))
 173       connection-spec
 174     (handler-case
 175         (handler-bind ((postgresql-warning
 176                         (lambda (c)
 177                           (warn 'clsql-simple-warning
 178                                 :format-control "~A"
 179                                 :format-arguments
 180                                 (list (princ-to-string c))))))
 181           (open-postgresql-connection :host host :port port
 182                                       :options options :tty tty
 183                                       :database db :user user
 184                                       :password password))
 185       (postgresql-error (c)
 186         ;; Connect failed
 187         (error 'clsql-connect-error
 188                :database-type database-type
 189                :connection-spec connection-spec
 190                :errno (type-of c)
 191                :error (postgresql-condition-message c)))
 192       (:no-error (connection)
 193                  ;; Success, make instance
 194                  (make-instance 'postgresql-socket-database
 195                                 :name (database-name-from-spec connection-spec
 196                                                                database-type)
 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)
 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         (loop for row = (read-cursor-row cursor result-types)
 219               while row
 220               collect row
 221               finally
 222               (unless (null (wait-for-query-results connection))
 223                 (close-postgresql-connection connection)
 224                 (error 'clsql-sql-error
 225                        :database database
 226                        :expression expression
 227                        :errno 'multiple-results
 228                        :error "Received multiple results for query.")))))))
 229
 230 (defmethod database-execute-command
 231     (expression (database postgresql-socket-database))
 232   (let ((connection (database-connection database)))
 233     (with-postgresql-handlers (database expression)
 234       (start-query-execution connection expression)
 235       (multiple-value-bind (status result)
 236           (wait-for-query-results connection)
 237         (when (eq status :cursor)
 238           (loop
 239               (multiple-value-bind (row stuff)
 240                   (skip-cursor-row result)
 241                 (unless row
 242                   (setq status :completed result stuff)
 243                   (return)))))
 244         (cond
 245           ((null status)
 246            t)
 247           ((eq status :completed)
 248            (unless (null (wait-for-query-results connection))
 249              (close-postgresql-connection connection)
 250              (error 'clsql-sql-error
 251                     :database database
 252                     :expression expression
 253                     :errno 'multiple-results
 254                     :error "Received multiple results for command."))
 255            result)
 256           (t
 257            (close-postgresql-connection connection)
 258            (error 'clsql-sql-error
 259                   :database database
 260                   :expression expression
 261                   :errno 'missing-result
 262                   :error "Didn't receive completion for command.")))))))
 263
 264 (defstruct postgresql-socket-result-set
 265   (done nil)
 266   (cursor nil)
 267   (types nil))
 268
 269 (defmethod database-query-result-set ((expression string)
 270                                       (database postgresql-socket-database)
 271                                       &key full-set result-types)
 272   (declare (ignore full-set))
 273   (let ((connection (database-connection database)))
 274     (with-postgresql-handlers (database expression)
 275       (start-query-execution connection expression)
 276       (multiple-value-bind (status cursor)
 277           (wait-for-query-results connection)
 278         (unless (eq status :cursor)
 279           (close-postgresql-connection connection)
 280           (error 'clsql-sql-error
 281                  :database database
 282                  :expression expression
 283                  :errno 'missing-result
 284                  :error "Didn't receive result cursor for query."))
 285         (values (make-postgresql-socket-result-set
 286                  :done nil
 287                  :cursor cursor
 288                  :types (canonicalize-types result-types cursor))
 289                 (length (postgresql-cursor-fields cursor)))))))
 290
 291 (defmethod database-dump-result-set (result-set
 292                                      (database postgresql-socket-database))
 293   (if (postgresql-socket-result-set-done result-set)
 294       t
 295       (with-postgresql-handlers (database)
 296         (loop while (skip-cursor-row
 297                      (postgresql-socket-result-set-cursor result-set))
 298           finally (setf (postgresql-socket-result-set-done result-set) t)))))
 299
 300 (defmethod database-store-next-row (result-set
 301                                     (database postgresql-socket-database)
 302                                     list)
 303   (let ((cursor (postgresql-socket-result-set-cursor result-set)))
 304     (with-postgresql-handlers (database)
 305       (if (copy-cursor-row cursor
 306                            list
 307                            (postgresql-socket-result-set-types
 308                             result-set))
 309           t
 310           (prog1 nil
 311             (setf (postgresql-socket-result-set-done result-set) t)
 312             (wait-for-query-results (database-connection database)))))))
 313
 314 ;;; Object listing
 315
 316 (defmethod database-list-objects-of-type ((database postgresql-socket-database)
 317                                           type owner)
 318   (let ((owner-clause
 319          (cond ((stringp owner)
 320                 (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))" owner))
 321                ((null owner)
 322                 (format nil " AND (NOT (relowner=1))"))
 323                (t ""))))
 324     (mapcar #'car
 325             (database-query
 326              (format nil
 327                      "SELECT relname FROM pg_class WHERE (relkind = '~A')~A"
 328                      type
 329                      owner-clause)
 330              database nil))))
 331
 332 (defmethod database-list-tables ((database postgresql-socket-database)
 333                                  &key (owner nil))
 334   (database-list-objects-of-type database "r" owner))
 335
 336 (defmethod database-list-views ((database postgresql-socket-database)
 337                                 &key (owner nil))
 338   (database-list-objects-of-type database "v" owner))
 339
 340 (defmethod database-list-indexes ((database postgresql-socket-database)
 341                                   &key (owner nil))
 342   (database-list-objects-of-type database "i" owner))
 343
 344 (defmethod database-list-attributes ((table string)
 345                                      (database postgresql-socket-database)
 346                                      &key (owner nil))
 347   (let* ((owner-clause
 348           (cond ((stringp owner)
 349                  (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
 350                 ((null owner) " AND (not (relowner=1))")
 351                 (t "")))
 352          (result
 353           (mapcar #'car
 354                   (database-query
 355                    (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A"
 356                            (string-downcase table)
 357                            owner-clause)
 358                    database nil))))
 359     (if result
 360         (reverse
 361          (remove-if #'(lambda (it) (member it '("cmin"
 362                                                 "cmax"
 363                                                 "xmax"
 364                                                 "xmin"
 365                                                 "oid"
 366                                                 "ctid"
 367                                                 ;; kmr -- added tableoid
 368                                                 "tableoid") :test #'equal))
 369                     result)))))
 370
 371 (defmethod database-attribute-type (attribute (table string)
 372                                     (database postgresql-socket-database)
 373                                     &key (owner nil))
 374   (let* ((owner-clause
 375           (cond ((stringp owner)
 376                  (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
 377                 ((null owner) " AND (not (relowner=1))")
 378                 (t "")))
 379          (result
 380           (mapcar #'car
 381                   (database-query
 382                    (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"
 383                            (string-downcase table)
 384                            (string-downcase attribute)
 385                            owner-clause)
 386                    database nil))))
 387     (when result
 388       (intern (string-upcase (car result)) :keyword))))
 389
 390 (defmethod database-create-sequence (sequence-name
 391                                      (database postgresql-socket-database))
 392   (database-execute-command
 393    (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
 394    database))
 395
 396 (defmethod database-drop-sequence (sequence-name
 397                                    (database postgresql-socket-database))
 398   (database-execute-command
 399    (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database))
 400
 401 (defmethod database-list-sequences ((database postgresql-socket-database)
 402                                     &key (owner nil))
 403   (database-list-objects-of-type database "S" owner))
 404
 405 (defmethod database-set-sequence-position (name (position integer)
 406                                           (database postgresql-socket-database))
 407   (values
 408    (parse-integer
 409     (caar
 410      (database-query
 411       (format nil "SELECT SETVAL ('~A', ~A)" name position)
 412       database nil)))))
 413
 414 (defmethod database-sequence-next (sequence-name
 415                                    (database postgresql-socket-database))
 416   (values
 417    (parse-integer
 418     (caar
 419      (database-query
 420       (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
 421       database nil)))))
 422
 423 (defmethod database-sequence-last (sequence-name (database postgresql-socket-database))
 424   (values
 425    (parse-integer
 426     (caar
 427      (database-query
 428       (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')")
 429       database nil)))))
 430
 431
 432 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
 433   (destructuring-bind (host name user password) connection-spec
 434     (let ((database (database-connect (list host "template1" user password)
 435                                       type)))
 436       (unwind-protect
 437            (execute-command (format nil "create database ~A" name))
 438         (database-disconnect database)))))
 439
 440 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket)))
 441   (destructuring-bind (host name user password) connection-spec
 442     (let ((database (database-connect (list host "template1" user password)
 443                                       type)))
 444       (unwind-protect
 445           (execute-command (format nil "drop database ~A" name))
 446         (database-disconnect database)))))
 447
 448 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
 449   (destructuring-bind (host name user password) connection-spec
 450     (let ((database (database-connect (list host "template1" user password)
 451                                       type)))
 452       (unwind-protect
 453           (when
 454               (find name (database-query "select datname from pg_database"
 455                                          database :auto)
 456                     :key #'car :test #'string-equal)
 457             t)
 458         (database-disconnect database)))))
 459
 460 (when (clsql-base-sys:database-type-library-loaded :postgresql-socket)
 461   (clsql-base-sys:initialize-database-type :database-type :postgresql-socket))