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-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-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   (ecase *backend-warning-behavior*
 108     (:warn
 109      (warn 'sql-database-warning :database database
 110            :message (postgresql-condition-message condition)))
 111     (:error
 112      (error 'sql-database-error :database database
 113             :message (format nil "Warning upgraded to error: ~A"
 114                              (postgresql-condition-message condition))))
 115     ((:ignore nil)
 116      ;; do nothing
 117      )))
 118
 119 (defun convert-to-clsql-error (database expression condition)
 120   (error 'sql-database-data-error
 121          :database database
 122          :expression expression
 123          :error-id (type-of condition)
 124          :message (postgresql-condition-message condition)))
 125
 126 (defmacro with-postgresql-handlers
 127     ((database &optional expression)
 128      &body body)
 129   (let ((database-var (gensym))
 130         (expression-var (gensym)))
 131     `(let ((,database-var ,database)
 132            (,expression-var ,expression))
 133        (handler-bind ((postgresql-warning
 134                        (lambda (c)
 135                          (convert-to-clsql-warning ,database-var c)))
 136                       (postgresql-error
 137                        (lambda (c)
 138                          (convert-to-clsql-error
 139                           ,database-var ,expression-var c))))
 140          ,@body))))
 141
 142 (defmethod database-initialize-database-type ((database-type
 143                                                (eql :postgresql-socket)))
 144   t)
 145
 146 (defclass postgresql-socket-database (database)
 147   ((connection :accessor database-connection :initarg :connection
 148                :type postgresql-connection)))
 149
 150 (defmethod database-type ((database postgresql-socket-database))
 151   :postgresql-socket)
 152
 153 (defmethod database-name-from-spec (connection-spec
 154                                     (database-type (eql :postgresql-socket)))
 155   (check-connection-spec connection-spec database-type
 156                          (host db user password &optional port options tty))
 157   (destructuring-bind (host db user password &optional port options tty)
 158       connection-spec
 159     (declare (ignore password options tty))
 160     (concatenate 'string
 161       (etypecase host
 162         (null
 163          "localhost")
 164         (pathname (namestring host))
 165         (string host))
 166       (when port
 167         (concatenate 'string
 168                      ":"
 169                      (etypecase port
 170                        (integer (write-to-string port))
 171                        (string port))))
 172       "/" db "/" user)))
 173
 174 (defmethod database-connect (connection-spec
 175                              (database-type (eql :postgresql-socket)))
 176   (check-connection-spec connection-spec database-type
 177                          (host db user password &optional port options tty))
 178   (destructuring-bind (host db user password &optional
 179                             (port +postgresql-server-default-port+)
 180                             (options "") (tty ""))
 181       connection-spec
 182     (handler-case
 183         (handler-bind ((postgresql-warning
 184                         (lambda (c)
 185                           (warn 'clsql-simple-warning
 186                                 :format-control "~A"
 187                                 :format-arguments
 188                                 (list (princ-to-string c))))))
 189           (open-postgresql-connection :host host :port port
 190                                       :options options :tty tty
 191                                       :database db :user user
 192                                       :password password))
 193       (postgresql-error (c)
 194         ;; Connect failed
 195         (error 'sql-connection-error
 196                :database-type database-type
 197                :connection-spec connection-spec
 198                :error-id (type-of c)
 199                :message (postgresql-condition-message c)))
 200       (:no-error (connection)
 201                  ;; Success, make instance
 202                  (make-instance 'postgresql-socket-database
 203                                 :name (database-name-from-spec connection-spec
 204                                                                database-type)
 205                                 :database-type :postgresql-socket
 206                                 :connection-spec connection-spec
 207                                 :connection connection)))))
 208
 209 (defmethod database-disconnect ((database postgresql-socket-database))
 210   (close-postgresql-connection (database-connection database))
 211   t)
 212
 213 (defmethod database-query (expression (database postgresql-socket-database) result-types field-names)
 214   (let ((connection (database-connection database)))
 215     (with-postgresql-handlers (database expression)
 216       (start-query-execution connection expression)
 217       (multiple-value-bind (status cursor)
 218           (wait-for-query-results connection)
 219         (unless (eq status :cursor)
 220           (close-postgresql-connection connection)
 221           (error 'sql-database-data-error
 222                  :database database
 223                  :expression expression
 224                  :error-id "missing-result"
 225                  :message "Didn't receive result cursor for query."))
 226         (setq result-types (canonicalize-types result-types cursor))
 227         (values
 228          (loop for row = (read-cursor-row cursor result-types)
 229                while row
 230                collect row
 231                finally
 232                (unless (null (wait-for-query-results connection))
 233                  (close-postgresql-connection connection)
 234                  (error 'sql-database-data-error
 235                         :database database
 236                         :expression expression
 237                         :error-id "multiple-results"
 238                         :message "Received multiple results for query.")))
 239          (when field-names
 240            (mapcar #'car (postgresql-cursor-fields cursor))))))))
 241
 242 (defmethod database-execute-command
 243     (expression (database postgresql-socket-database))
 244   (let ((connection (database-connection database)))
 245     (with-postgresql-handlers (database expression)
 246       (start-query-execution connection expression)
 247       (multiple-value-bind (status result)
 248           (wait-for-query-results connection)
 249         (when (eq status :cursor)
 250           (loop
 251             (multiple-value-bind (row stuff)
 252                 (skip-cursor-row result)
 253               (unless row
 254                 (setq status :completed result stuff)
 255                 (return)))))
 256         (cond
 257          ((null status)
 258           t)
 259          ((eq status :completed)
 260           (unless (null (wait-for-query-results connection))
 261              (close-postgresql-connection connection)
 262              (error 'sql-database-data-error
 263                     :database database
 264                     :expression expression
 265                     :error-id "multiple-results"
 266                     :message "Received multiple results for command."))
 267           result)
 268           (t
 269            (close-postgresql-connection connection)
 270            (error 'sql-database-data-error
 271                   :database database
 272                   :expression expression
 273                   :errno "missing-result"
 274                   :message "Didn't receive completion for command.")))))))
 275
 276 (defstruct postgresql-socket-result-set
 277   (done nil)
 278   (cursor nil)
 279   (types nil))
 280
 281 (defmethod database-query-result-set ((expression string)
 282                                       (database postgresql-socket-database)
 283                                       &key full-set result-types)
 284   (declare (ignore full-set))
 285   (let ((connection (database-connection database)))
 286     (with-postgresql-handlers (database expression)
 287       (start-query-execution connection expression)
 288       (multiple-value-bind (status cursor)
 289           (wait-for-query-results connection)
 290         (unless (eq status :cursor)
 291           (close-postgresql-connection connection)
 292           (error 'sql-database-data-error
 293                  :database database
 294                  :expression expression
 295                  :error-id "missing-result"
 296                  :message "Didn't receive result cursor for query."))
 297         (values (make-postgresql-socket-result-set
 298                  :done nil
 299                  :cursor cursor
 300                  :types (canonicalize-types result-types cursor))
 301                 (length (postgresql-cursor-fields cursor)))))))
 302
 303 (defmethod database-dump-result-set (result-set
 304                                      (database postgresql-socket-database))
 305   (if (postgresql-socket-result-set-done result-set)
 306       t
 307       (with-postgresql-handlers (database)
 308         (loop while (skip-cursor-row
 309                      (postgresql-socket-result-set-cursor result-set))
 310           finally (setf (postgresql-socket-result-set-done result-set) t)))))
 311
 312 (defmethod database-store-next-row (result-set
 313                                     (database postgresql-socket-database)
 314                                     list)
 315   (let ((cursor (postgresql-socket-result-set-cursor result-set)))
 316     (with-postgresql-handlers (database)
 317       (if (copy-cursor-row cursor
 318                            list
 319                            (postgresql-socket-result-set-types
 320                             result-set))
 321           t
 322           (prog1 nil
 323             (setf (postgresql-socket-result-set-done result-set) t)
 324             (wait-for-query-results (database-connection database)))))))
 325
 326 ;;; Object listing
 327
 328 (defun owner-clause (owner)
 329   (cond
 330    ((stringp owner)
 331     (format
 332      nil
 333      " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))"
 334      owner))
 335    ((null owner)
 336     (format nil " AND (NOT (relowner=1))"))
 337    (t "")))
 338
 339 (defun database-list-objects-of-type (database type owner)
 340   (mapcar #'car
 341           (database-query
 342            (format nil
 343                    "SELECT relname FROM pg_class WHERE (relkind = '~A')~A"
 344                    type
 345                    (owner-clause owner))
 346            database nil nil)))
 347
 348 (defmethod database-list-tables ((database postgresql-socket-database)
 349                                  &key (owner nil))
 350   (database-list-objects-of-type database "r" owner))
 351
 352 (defmethod database-list-views ((database postgresql-socket-database)
 353                                 &key (owner nil))
 354   (database-list-objects-of-type database "v" owner))
 355
 356 (defmethod database-list-indexes ((database postgresql-socket-database)
 357                                   &key (owner nil))
 358   (database-list-objects-of-type database "i" owner))
 359
 360 (defmethod database-list-table-indexes (table
 361                                         (database postgresql-socket-database)
 362                                         &key (owner nil))
 363   (let ((indexrelids
 364          (database-query
 365           (format
 366            nil
 367            "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
 368            (string-downcase table)
 369            (owner-clause owner))
 370           database :auto nil))
 371         (result nil))
 372     (dolist (indexrelid indexrelids (nreverse result))
 373       (push
 374        (caar (database-query
 375               (format nil "select relname from pg_class where relfilenode='~A'"
 376                       (car indexrelid))
 377               database nil nil))
 378        result))))
 379
 380 (defmethod database-list-attributes ((table string)
 381                                      (database postgresql-socket-database)
 382                                      &key (owner nil))
 383   (let* ((owner-clause
 384           (cond ((stringp owner)
 385                  (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
 386                 ((null owner) " AND (not (relowner=1))")
 387                 (t "")))
 388          (result
 389           (mapcar #'car
 390                   (database-query
 391                    (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A"
 392                            (string-downcase table)
 393                            owner-clause)
 394                    database nil nil))))
 395     (if result
 396         (remove-if #'(lambda (it) (member it '("cmin"
 397                                                "cmax"
 398                                                "xmax"
 399                                                "xmin"
 400                                                "oid"
 401                                                "ctid"
 402                                                ;; kmr -- added tableoid
 403                                                "tableoid") :test #'equal))
 404                    result))))
 405
 406 (defmethod database-attribute-type (attribute (table string)
 407                                     (database postgresql-socket-database)
 408                                     &key (owner nil))
 409   (let ((row (car (database-query
 410                    (format nil "SELECT pg_type.typname,pg_attribute.attlen,pg_attribute.atttypmod,pg_attribute.attnotnull 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"
 411                            (string-downcase table)
 412                            (string-downcase attribute)
 413                            (owner-clause owner))
 414                    database nil nil))))
 415     (when row
 416       (values
 417        (ensure-keyword (first row))
 418        (if (string= "-1" (second row))
 419            (- (parse-integer (third row) :junk-allowed t) 4)
 420          (parse-integer (second row)))
 421        nil
 422        (if (string-equal "f" (fourth row))
 423            1
 424          0)))))
 425
 426 (defmethod database-create-sequence (sequence-name
 427                                      (database postgresql-socket-database))
 428   (database-execute-command
 429    (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
 430    database))
 431
 432 (defmethod database-drop-sequence (sequence-name
 433                                    (database postgresql-socket-database))
 434   (database-execute-command
 435    (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database))
 436
 437 (defmethod database-list-sequences ((database postgresql-socket-database)
 438                                     &key (owner nil))
 439   (database-list-objects-of-type database "S" owner))
 440
 441 (defmethod database-set-sequence-position (name (position integer)
 442                                           (database postgresql-socket-database))
 443   (values
 444    (parse-integer
 445     (caar
 446      (database-query
 447       (format nil "SELECT SETVAL ('~A', ~A)" name position)
 448       database nil nil)))))
 449
 450 (defmethod database-sequence-next (sequence-name
 451                                    (database postgresql-socket-database))
 452   (values
 453    (parse-integer
 454     (caar
 455      (database-query
 456       (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
 457       database nil nil)))))
 458
 459 (defmethod database-sequence-last (sequence-name (database postgresql-socket-database))
 460   (values
 461    (parse-integer
 462     (caar
 463      (database-query
 464       (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')")
 465       database nil nil)))))
 466
 467
 468 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
 469   (destructuring-bind (host name user password) connection-spec
 470     (let ((database (database-connect (list host "template1" user password)
 471                                       type)))
 472       (unwind-protect
 473            (execute-command (format nil "create database ~A" name))
 474         (database-disconnect database)))))
 475
 476 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket)))
 477   (destructuring-bind (host name user password) connection-spec
 478     (let ((database (database-connect (list host "template1" user password)
 479                                       type)))
 480       (unwind-protect
 481           (execute-command (format nil "drop database ~A" name))
 482         (database-disconnect database)))))
 483
 484
 485 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
 486   (when (find (second connection-spec) (database-list connection-spec type)
 487               :key #'car :test #'string-equal)
 488     t))
 489
 490 (defmethod database-list (connection-spec (type (eql :postgresql-socket)))
 491   (destructuring-bind (host name user password) connection-spec
 492     (declare (ignore name))
 493     (let ((database (database-connect (list host "template1" user password)
 494                                       type)))
 495       (unwind-protect
 496            (progn
 497              (setf (slot-value database 'clsql-sys::state) :open)
 498              (mapcar #'car (database-query "select datname from pg_database"
 499                                            database :auto nil)))
 500         (progn
 501           (database-disconnect database)
 502           (setf (slot-value database 'clsql-sys::state) :closed))))))
 503
 504 (defmethod database-describe-table ((database postgresql-socket-database)
 505                                     table)
 506   (database-query
 507    (format nil "select a.attname, t.typname
 508                                from pg_class c, pg_attribute a, pg_type t
 509                                where c.relname = '~a'
 510                                    and a.attnum > 0
 511                                    and a.attrelid = c.oid
 512                                    and a.atttypid = t.oid"
 513            (sql-escape (string-downcase table)))
 514    database :auto nil))
 515
 516
 517 ;; Database capabilities
 518
 519 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket)))
 520   nil)
 521
 522 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket)))
 523   t)
 524
 525 (defmethod db-type-default-case ((db-type (eql :postgresql-socket)))
 526   :lower)
 527
 528 (when (clsql-sys:database-type-library-loaded :postgresql-socket)
 529   (clsql-sys:initialize-database-type :database-type :postgresql-socket))