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            (mapcar #'car (postgresql-cursor-fields cursor))))))))
 232
 233 (defmethod database-execute-command
 234     (expression (database postgresql-socket-database))
 235   (let ((connection (database-connection database)))
 236     (with-postgresql-handlers (database expression)
 237       (start-query-execution connection expression)
 238       (multiple-value-bind (status result)
 239           (wait-for-query-results connection)
 240         (when (eq status :cursor)
 241           (loop
 242               (multiple-value-bind (row stuff)
 243                   (skip-cursor-row result)
 244                 (unless row
 245                   (setq status :completed result stuff)
 246                   (return)))))
 247         (cond
 248           ((null status)
 249            t)
 250           ((eq status :completed)
 251            (unless (null (wait-for-query-results connection))
 252              (close-postgresql-connection connection)
 253              (error 'clsql-sql-error
 254                     :database database
 255                     :expression expression
 256                     :errno 'multiple-results
 257                     :error "Received multiple results for command."))
 258            result)
 259           (t
 260            (close-postgresql-connection connection)
 261            (error 'clsql-sql-error
 262                   :database database
 263                   :expression expression
 264                   :errno 'missing-result
 265                   :error "Didn't receive completion for command.")))))))
 266
 267 (defstruct postgresql-socket-result-set
 268   (done nil)
 269   (cursor nil)
 270   (types nil))
 271
 272 (defmethod database-query-result-set ((expression string)
 273                                       (database postgresql-socket-database)
 274                                       &key full-set result-types)
 275   (declare (ignore full-set))
 276   (let ((connection (database-connection database)))
 277     (with-postgresql-handlers (database expression)
 278       (start-query-execution connection expression)
 279       (multiple-value-bind (status cursor)
 280           (wait-for-query-results connection)
 281         (unless (eq status :cursor)
 282           (close-postgresql-connection connection)
 283           (error 'clsql-sql-error
 284                  :database database
 285                  :expression expression
 286                  :errno 'missing-result
 287                  :error "Didn't receive result cursor for query."))
 288         (values (make-postgresql-socket-result-set
 289                  :done nil
 290                  :cursor cursor
 291                  :types (canonicalize-types result-types cursor))
 292                 (length (postgresql-cursor-fields cursor)))))))
 293
 294 (defmethod database-dump-result-set (result-set
 295                                      (database postgresql-socket-database))
 296   (if (postgresql-socket-result-set-done result-set)
 297       t
 298       (with-postgresql-handlers (database)
 299         (loop while (skip-cursor-row
 300                      (postgresql-socket-result-set-cursor result-set))
 301           finally (setf (postgresql-socket-result-set-done result-set) t)))))
 302
 303 (defmethod database-store-next-row (result-set
 304                                     (database postgresql-socket-database)
 305                                     list)
 306   (let ((cursor (postgresql-socket-result-set-cursor result-set)))
 307     (with-postgresql-handlers (database)
 308       (if (copy-cursor-row cursor
 309                            list
 310                            (postgresql-socket-result-set-types
 311                             result-set))
 312           t
 313           (prog1 nil
 314             (setf (postgresql-socket-result-set-done result-set) t)
 315             (wait-for-query-results (database-connection database)))))))
 316
 317 ;;; Object listing
 318
 319 (defun owner-clause (owner)
 320   (cond
 321    ((stringp owner)
 322     (format
 323      nil
 324      " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))"
 325      owner))
 326    ((null owner)
 327     (format nil " AND (NOT (relowner=1))"))
 328    (t "")))
 329
 330 (defun database-list-objects-of-type (database type owner)
 331   (mapcar #'car
 332           (database-query
 333            (format nil
 334                    "SELECT relname FROM pg_class WHERE (relkind = '~A')~A"
 335                    type
 336                    (owner-clause owner))
 337            database nil nil)))
 338
 339 (defmethod database-list-tables ((database postgresql-socket-database)
 340                                  &key (owner nil))
 341   (database-list-objects-of-type database "r" owner))
 342
 343 (defmethod database-list-views ((database postgresql-socket-database)
 344                                 &key (owner nil))
 345   (database-list-objects-of-type database "v" owner))
 346
 347 (defmethod database-list-indexes ((database postgresql-socket-database)
 348                                   &key (owner nil))
 349   (database-list-objects-of-type database "i" owner))
 350
 351 (defmethod database-list-table-indexes (table
 352                                         (database postgresql-socket-database)
 353                                         &key (owner nil))
 354   (let ((indexrelids
 355          (database-query
 356           (format
 357            nil
 358            "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
 359            (string-downcase table)
 360            (owner-clause owner))
 361           database :auto nil))
 362         (result nil))
 363     (dolist (indexrelid indexrelids (nreverse result))
 364       (push
 365        (caar (database-query
 366               (format nil "select relname from pg_class where relfilenode='~A'"
 367                       (car indexrelid))
 368               database nil nil))
 369        result))))
 370
 371 (defmethod database-list-attributes ((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 attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A"
 383                            (string-downcase table)
 384                            owner-clause)
 385                    database nil nil))))
 386     (if result
 387         (reverse
 388          (remove-if #'(lambda (it) (member it '("cmin"
 389                                                 "cmax"
 390                                                 "xmax"
 391                                                 "xmin"
 392                                                 "oid"
 393                                                 "ctid"
 394                                                 ;; kmr -- added tableoid
 395                                                 "tableoid") :test #'equal))
 396                     result)))))
 397
 398 (defmethod database-attribute-type (attribute (table string)
 399                                     (database postgresql-socket-database)
 400                                     &key (owner nil))
 401   (let ((row (car (database-query
 402                    (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"
 403                            (string-downcase table)
 404                            (string-downcase attribute)
 405                            (owner-clause owner))
 406                    database nil nil))))
 407     (when row
 408       (values
 409        (ensure-keyword (first row))
 410        (if (string= "-1" (second row))
 411            (- (parse-integer (third row) :junk-allowed t) 4)
 412          (parse-integer (second row)))
 413        nil
 414        (if (string-equal "f" (fourth row))
 415            1
 416          0)))))
 417
 418 (defmethod database-create-sequence (sequence-name
 419                                      (database postgresql-socket-database))
 420   (database-execute-command
 421    (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
 422    database))
 423
 424 (defmethod database-drop-sequence (sequence-name
 425                                    (database postgresql-socket-database))
 426   (database-execute-command
 427    (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database))
 428
 429 (defmethod database-list-sequences ((database postgresql-socket-database)
 430                                     &key (owner nil))
 431   (database-list-objects-of-type database "S" owner))
 432
 433 (defmethod database-set-sequence-position (name (position integer)
 434                                           (database postgresql-socket-database))
 435   (values
 436    (parse-integer
 437     (caar
 438      (database-query
 439       (format nil "SELECT SETVAL ('~A', ~A)" name position)
 440       database nil nil)))))
 441
 442 (defmethod database-sequence-next (sequence-name
 443                                    (database postgresql-socket-database))
 444   (values
 445    (parse-integer
 446     (caar
 447      (database-query
 448       (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
 449       database nil nil)))))
 450
 451 (defmethod database-sequence-last (sequence-name (database postgresql-socket-database))
 452   (values
 453    (parse-integer
 454     (caar
 455      (database-query
 456       (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')")
 457       database nil nil)))))
 458
 459
 460 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
 461   (destructuring-bind (host name user password) connection-spec
 462     (let ((database (database-connect (list host "template1" user password)
 463                                       type)))
 464       (unwind-protect
 465            (execute-command (format nil "create database ~A" name))
 466         (database-disconnect database)))))
 467
 468 (defmethod database-destroy (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 "drop database ~A" name))
 474         (database-disconnect database)))))
 475
 476
 477 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
 478   (when (find (second connection-spec) (database-list connection-spec type)
 479               :key #'car :test #'string-equal)
 480     t))
 481
 482 (defmethod database-list (connection-spec (type (eql :postgresql-socket)))
 483   (destructuring-bind (host name user password) connection-spec
 484     (declare (ignore name))
 485     (let ((database (database-connect (list host "template1" user password)
 486                                       type)))
 487       (unwind-protect
 488            (progn
 489              (setf (slot-value database 'clsql-base-sys::state) :open)
 490              (mapcar #'car (database-query "select datname from pg_database"
 491                                            database :auto nil)))
 492         (progn
 493           (database-disconnect database)
 494           (setf (slot-value database 'clsql-base-sys::state) :closed))))))
 495
 496 (defmethod database-describe-table ((database postgresql-socket-database)
 497                                     table)
 498   (database-query
 499    (format nil "select a.attname, t.typname
 500                                from pg_class c, pg_attribute a, pg_type t
 501                                where c.relname = '~a'
 502                                    and a.attnum > 0
 503                                    and a.attrelid = c.oid
 504                                    and a.atttypid = t.oid"
 505            (sql-escape (string-downcase table)))
 506    database :auto nil))
 507
 508
 509 ;; Database capabilities
 510
 511 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket)))
 512   nil)
 513
 514 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket)))
 515   t)
 516
 517 (defmethod db-type-default-case ((db-type (eql :postgresql-socket)))
 518   :lower)
 519
 520 (when (clsql-base-sys:database-type-library-loaded :postgresql-socket)
 521   (clsql-base-sys:initialize-database-type :database-type :postgresql-socket))