db-postgresql-socket/postgresql-socket-sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          postgresql-socket-sql.sql
   6 ;;;; Purpose:       High-level PostgreSQL interface using socket
   7 ;;;; Programmers:   Kevin M. Rosenberg based on
   8 ;;;;                Original code by Pierre R. Mai
   9 ;;;; Date Started:  Feb 2002
  10 ;;;;
  11 ;;;; $Id$
  12 ;;;;
  13 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  14 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  15 ;;;;
  16 ;;;; CLSQL users are granted the rights to distribute and use this software
  17 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  18 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  19 ;;;; *************************************************************************
  20
  21 (in-package #:cl-user)
  22
  23 (defpackage :clsql-postgresql-socket
  24     (:use #:common-lisp #:clsql-base-sys #:postgresql-socket)
  25     (:export #:postgresql-socket-database)
  26     (:documentation "This is the CLSQL socket interface to PostgreSQL."))
  27
  28 (in-package #:clsql-postgresql-socket)
  29
  30 ;; interface foreign library loading routines
  31
  32
  33 (clsql-base-sys:database-type-load-foreign :postgresql-socket)
  34
  35
  36 ;; Field type conversion
  37
  38 (defun make-type-list-for-auto (cursor)
  39   (let* ((fields (postgresql-cursor-fields cursor))
  40          (num-fields (length fields))
  41          (new-types '()))
  42     (dotimes (i num-fields)
  43       (declare (fixnum i))
  44       (push (canonical-field-type fields i) new-types))
  45     (nreverse new-types)))
  46
  47 (defun canonical-field-type (fields index)
  48   "Extracts canonical field type from fields list"
  49   (let ((oid (cadr (nth index fields))))
  50     (case oid
  51       ((#.pgsql-ftype#bytea
  52         #.pgsql-ftype#int2
  53         #.pgsql-ftype#int4)
  54        :int32)
  55       (#.pgsql-ftype#int8
  56        :int64)
  57       ((#.pgsql-ftype#float4
  58         #.pgsql-ftype#float8)
  59        :double)
  60       (otherwise
  61        t))))
  62
  63 (defun canonicalize-types (types cursor)
  64   (if (null types)
  65       nil
  66       (let ((auto-list (make-type-list-for-auto cursor)))
  67         (cond
  68           ((listp types)
  69            (canonicalize-type-list types auto-list))
  70           ((eq types :auto)
  71            auto-list)
  72           (t
  73            nil)))))
  74
  75 (defun canonicalize-type-list (types auto-list)
  76   "Ensure a field type list meets expectations.
  77 Duplicated from clsql-uffi package so that this interface
  78 doesn't depend on UFFI."
  79   (let ((length-types (length types))
  80         (new-types '()))
  81     (loop for i from 0 below (length auto-list)
  82           do
  83           (if (>= i length-types)
  84               (push t new-types) ;; types is shorted than num-fields
  85               (push
  86                (case (nth i types)
  87                  (:int
  88                   (case (nth i auto-list)
  89                     (:int32
  90                      :int32)
  91                     (:int64
  92                      :int64)
  93                     (t
  94                      t)))
  95                  (:double
  96                   (case (nth i auto-list)
  97                     (:double
  98                      :double)
  99                     (t
 100                      t)))
 101                  (t
 102                   t))
 103                new-types)))
 104     (nreverse new-types)))
 105
 106
 107 (defun convert-to-clsql-warning (database condition)
 108   (warn 'clsql-database-warning :database database
 109         :message (postgresql-condition-message condition)))
 110
 111 (defun convert-to-clsql-error (database expression condition)
 112   (error 'clsql-sql-error :database database
 113          :expression expression
 114          :errno (type-of condition)
 115          :error (postgresql-condition-message condition)))
 116
 117 (defmacro with-postgresql-handlers
 118     ((database &optional expression)
 119      &body body)
 120   (let ((database-var (gensym))
 121         (expression-var (gensym)))
 122     `(let ((,database-var ,database)
 123            (,expression-var ,expression))
 124        (handler-bind ((postgresql-warning
 125                        (lambda (c)
 126                          (convert-to-clsql-warning ,database-var c)))
 127                       (postgresql-error
 128                        (lambda (c)
 129                          (convert-to-clsql-error
 130                           ,database-var ,expression-var c))))
 131          ;; KMR - removed double @@
 132          ,@body))))
 133
 134 (defmethod database-initialize-database-type ((database-type
 135                                                (eql :postgresql-socket)))
 136   t)
 137
 138 (defclass postgresql-socket-database (database)
 139   ((connection :accessor database-connection :initarg :connection
 140                :type postgresql-connection)))
 141
 142 (defmethod database-type ((database postgresql-socket-database))
 143   :postgresql-socket)
 144
 145 (defmethod database-name-from-spec (connection-spec
 146                                     (database-type (eql :postgresql-socket)))
 147   (check-connection-spec connection-spec database-type
 148                          (host db user password &optional port options tty))
 149   (destructuring-bind (host db user password &optional port options tty)
 150       connection-spec
 151     (declare (ignore password options tty))
 152     (concatenate 'string
 153       (etypecase host
 154         (null
 155          "localhost")
 156         (pathname (namestring host))
 157         (string host))
 158       (when port
 159         (concatenate 'string
 160                      ":"
 161                      (etypecase port
 162                        (integer (write-to-string port))
 163                        (string port))))
 164       "/" db "/" user)))
 165
 166 (defmethod database-connect (connection-spec
 167                              (database-type (eql :postgresql-socket)))
 168   (check-connection-spec connection-spec database-type
 169                          (host db user password &optional port options tty))
 170   (destructuring-bind (host db user password &optional
 171                             (port +postgresql-server-default-port+)
 172                             (options "") (tty ""))
 173       connection-spec
 174     (handler-case
 175         (handler-bind ((postgresql-warning
 176                         (lambda (c)
 177                           (warn 'clsql-simple-warning
 178                                 :format-control "~A"
 179                                 :format-arguments
 180                                 (list (princ-to-string c))))))
 181           (open-postgresql-connection :host host :port port
 182                                       :options options :tty tty
 183                                       :database db :user user
 184                                       :password password))
 185       (postgresql-error (c)
 186         ;; Connect failed
 187         (error 'clsql-connect-error
 188                :database-type database-type
 189                :connection-spec connection-spec
 190                :errno (type-of c)
 191                :error (postgresql-condition-message c)))
 192       (:no-error (connection)
 193                  ;; Success, make instance
 194                  (make-instance 'postgresql-socket-database
 195                                 :name (database-name-from-spec connection-spec
 196                                                                database-type)
 197                                 :database-type :postgresql-socket
 198                                 :connection-spec connection-spec
 199                                 :connection connection)))))
 200
 201 (defmethod database-disconnect ((database postgresql-socket-database))
 202   (close-postgresql-connection (database-connection database))
 203   t)
 204
 205 (defmethod database-query (expression (database postgresql-socket-database) result-types)
 206   (let ((connection (database-connection database)))
 207     (with-postgresql-handlers (database expression)
 208       (start-query-execution connection expression)
 209       (multiple-value-bind (status cursor)
 210           (wait-for-query-results connection)
 211         (unless (eq status :cursor)
 212           (close-postgresql-connection connection)
 213           (error 'clsql-sql-error
 214                  :database database
 215                  :expression expression
 216                  :errno 'missing-result
 217                  :error "Didn't receive result cursor for query."))
 218         (setq result-types (canonicalize-types result-types cursor))
 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
 231 (defmethod database-execute-command
 232     (expression (database postgresql-socket-database))
 233   (let ((connection (database-connection database)))
 234     (with-postgresql-handlers (database expression)
 235       (start-query-execution connection expression)
 236       (multiple-value-bind (status result)
 237           (wait-for-query-results connection)
 238         (when (eq status :cursor)
 239           (loop
 240               (multiple-value-bind (row stuff)
 241                   (skip-cursor-row result)
 242                 (unless row
 243                   (setq status :completed result stuff)
 244                   (return)))))
 245         (cond
 246           ((null status)
 247            t)
 248           ((eq status :completed)
 249            (unless (null (wait-for-query-results connection))
 250              (close-postgresql-connection connection)
 251              (error 'clsql-sql-error
 252                     :database database
 253                     :expression expression
 254                     :errno 'multiple-results
 255                     :error "Received multiple results for command."))
 256            result)
 257           (t
 258            (close-postgresql-connection connection)
 259            (error 'clsql-sql-error
 260                   :database database
 261                   :expression expression
 262                   :errno 'missing-result
 263                   :error "Didn't receive completion for command.")))))))
 264
 265 (defstruct postgresql-socket-result-set
 266   (done nil)
 267   (cursor nil)
 268   (types nil))
 269
 270 (defmethod database-query-result-set ((expression string)
 271                                       (database postgresql-socket-database)
 272                                       &key full-set result-types)
 273   (declare (ignore full-set))
 274   (let ((connection (database-connection database)))
 275     (with-postgresql-handlers (database expression)
 276       (start-query-execution connection expression)
 277       (multiple-value-bind (status cursor)
 278           (wait-for-query-results connection)
 279         (unless (eq status :cursor)
 280           (close-postgresql-connection connection)
 281           (error 'clsql-sql-error
 282                  :database database
 283                  :expression expression
 284                  :errno 'missing-result
 285                  :error "Didn't receive result cursor for query."))
 286         (values (make-postgresql-socket-result-set
 287                  :done nil
 288                  :cursor cursor
 289                  :types (canonicalize-types result-types cursor))
 290                 (length (postgresql-cursor-fields cursor)))))))
 291
 292 (defmethod database-dump-result-set (result-set
 293                                      (database postgresql-socket-database))
 294   (if (postgresql-socket-result-set-done result-set)
 295       t
 296       (with-postgresql-handlers (database)
 297         (loop while (skip-cursor-row
 298                      (postgresql-socket-result-set-cursor result-set))
 299           finally (setf (postgresql-socket-result-set-done result-set) t)))))
 300
 301 (defmethod database-store-next-row (result-set
 302                                     (database postgresql-socket-database)
 303                                     list)
 304   (let ((cursor (postgresql-socket-result-set-cursor result-set)))
 305     (with-postgresql-handlers (database)
 306       (if (copy-cursor-row cursor
 307                            list
 308                            (postgresql-socket-result-set-types
 309                             result-set))
 310           t
 311           (prog1 nil
 312             (setf (postgresql-socket-result-set-done result-set) t)
 313             (wait-for-query-results (database-connection database)))))))
 314
 315 ;;; Object listing
 316
 317 (defun owner-clause (owner)
 318   (cond
 319    ((stringp owner)
 320     (format
 321      nil
 322      " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))"
 323      owner))
 324    ((null owner)
 325     (format nil " AND (NOT (relowner=1))"))
 326    (t "")))
 327
 328 (defun database-list-objects-of-type (database type owner)
 329   (mapcar #'car
 330           (database-query
 331            (format nil
 332                    "SELECT relname FROM pg_class WHERE (relkind = '~A')~A"
 333                    type
 334                    (owner-clause owner))
 335            database nil)))
 336
 337 (defmethod database-list-tables ((database postgresql-socket-database)
 338                                  &key (owner nil))
 339   (database-list-objects-of-type database "r" owner))
 340
 341 (defmethod database-list-views ((database postgresql-socket-database)
 342                                 &key (owner nil))
 343   (database-list-objects-of-type database "v" owner))
 344
 345 (defmethod database-list-indexes ((database postgresql-socket-database)
 346                                   &key (owner nil))
 347   (database-list-objects-of-type database "i" owner))
 348
 349 (defmethod database-list-table-indexes (table
 350                                         (database postgresql-socket-database)
 351                                         &key (owner nil))
 352   (let ((indexrelids
 353          (database-query
 354           (format
 355            nil
 356            "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
 357            (string-downcase table)
 358            (owner-clause owner))
 359           database :auto))
 360         (result nil))
 361     (dolist (indexrelid indexrelids (nreverse result))
 362       (push
 363        (caar (database-query
 364               (format nil "select relname from pg_class where relfilenode='~A'"
 365                       (car indexrelid))
 366               database
 367               nil))
 368        result))))
 369
 370 (defmethod database-list-attributes ((table string)
 371                                      (database postgresql-socket-database)
 372                                      &key (owner nil))
 373   (let* ((owner-clause
 374           (cond ((stringp owner)
 375                  (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
 376                 ((null owner) " AND (not (relowner=1))")
 377                 (t "")))
 378          (result
 379           (mapcar #'car
 380                   (database-query
 381                    (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A"
 382                            (string-downcase table)
 383                            owner-clause)
 384                    database nil))))
 385     (if result
 386         (reverse
 387          (remove-if #'(lambda (it) (member it '("cmin"
 388                                                 "cmax"
 389                                                 "xmax"
 390                                                 "xmin"
 391                                                 "oid"
 392                                                 "ctid"
 393                                                 ;; kmr -- added tableoid
 394                                                 "tableoid") :test #'equal))
 395                     result)))))
 396
 397 (defmethod database-attribute-type (attribute (table string)
 398                                     (database postgresql-socket-database)
 399                                     &key (owner nil))
 400   (let* ((owner-clause
 401           (cond ((stringp owner)
 402                  (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
 403                 ((null owner) " AND (not (relowner=1))")
 404                 (t "")))
 405          (result
 406           (mapcar #'car
 407                   (database-query
 408                    (format nil "SELECT pg_type.typname FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A"
 409                            (string-downcase table)
 410                            (string-downcase attribute)
 411                            owner-clause)
 412                    database nil))))
 413     (when result
 414       (intern (string-upcase (car result)) :keyword))))
 415
 416 (defmethod database-create-sequence (sequence-name
 417                                      (database postgresql-socket-database))
 418   (database-execute-command
 419    (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
 420    database))
 421
 422 (defmethod database-drop-sequence (sequence-name
 423                                    (database postgresql-socket-database))
 424   (database-execute-command
 425    (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database))
 426
 427 (defmethod database-list-sequences ((database postgresql-socket-database)
 428                                     &key (owner nil))
 429   (database-list-objects-of-type database "S" owner))
 430
 431 (defmethod database-set-sequence-position (name (position integer)
 432                                           (database postgresql-socket-database))
 433   (values
 434    (parse-integer
 435     (caar
 436      (database-query
 437       (format nil "SELECT SETVAL ('~A', ~A)" name position)
 438       database nil)))))
 439
 440 (defmethod database-sequence-next (sequence-name
 441                                    (database postgresql-socket-database))
 442   (values
 443    (parse-integer
 444     (caar
 445      (database-query
 446       (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
 447       database nil)))))
 448
 449 (defmethod database-sequence-last (sequence-name (database postgresql-socket-database))
 450   (values
 451    (parse-integer
 452     (caar
 453      (database-query
 454       (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')")
 455       database nil)))))
 456
 457
 458 (defmethod database-create (connection-spec (type (eql :postgresql-socket)))
 459   (destructuring-bind (host name user password) connection-spec
 460     (let ((database (database-connect (list host "template1" user password)
 461                                       type)))
 462       (unwind-protect
 463            (execute-command (format nil "create database ~A" name))
 464         (database-disconnect database)))))
 465
 466 (defmethod database-destroy (connection-spec (type (eql :postgresql-socket)))
 467   (destructuring-bind (host name user password) connection-spec
 468     (let ((database (database-connect (list host "template1" user password)
 469                                       type)))
 470       (unwind-protect
 471           (execute-command (format nil "drop database ~A" name))
 472         (database-disconnect database)))))
 473
 474
 475 (defmethod database-probe (connection-spec (type (eql :postgresql-socket)))
 476   (when (find (second connection-spec) (database-list connection-spec type)
 477               :key #'car :test #'string-equal)
 478     t))
 479
 480 (defmethod database-list (connection-spec (type (eql :postgresql-socket)))
 481   (destructuring-bind (host name user password) connection-spec
 482     (declare (ignore name))
 483     (let ((database (database-connect (list host "template1" user password)
 484                                       type)))
 485       (unwind-protect
 486            (progn
 487              (setf (slot-value database 'clsql-base-sys::state) :open)
 488              (mapcar #'car (database-query "select datname from pg_database"
 489                                            database :auto)))
 490         (progn
 491           (database-disconnect database)
 492           (setf (slot-value database 'clsql-base-sys::state) :closed))))))
 493
 494 (defmethod database-describe-table ((database postgresql-socket-database)
 495                                     table)
 496   (database-query
 497    (format nil "select a.attname, t.typname
 498                                from pg_class c, pg_attribute a, pg_type t
 499                                where c.relname = '~a'
 500                                    and a.attnum > 0
 501                                    and a.attrelid = c.oid
 502                                    and a.atttypid = t.oid"
 503            (sql-escape (string-downcase table)))
 504    database :auto))
 505
 506
 507 ;; Database capabilities
 508
 509 (defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket)))
 510   nil)
 511
 512 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket)))
 513   t)
 514
 515 (defmethod db-type-default-case ((db-type (eql :postgresql)))
 516   :lower)
 517
 518 (when (clsql-base-sys:database-type-library-loaded :postgresql-socket)
 519   (clsql-base-sys:initialize-database-type :database-type :postgresql-socket))