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