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         (reverse
 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))