db-postgresql/postgresql-sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          postgresql-sql.lisp
   6 ;;;; Purpose:       High-level PostgreSQL interface using UFFI
   7 ;;;; Date Started:  Feb 2002
   8 ;;;;
   9 ;;;; $Id$
  10 ;;;;
  11 ;;;; CLSQL users are granted the rights to distribute and use this software
  12 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  13 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  14 ;;;; *************************************************************************
  15
  16 (in-package #:cl-user)
  17
  18 (defpackage #:clsql-postgresql
  19     (:use #:common-lisp #:clsql-sys #:postgresql #:clsql-uffi)
  20     (:export #:postgresql-database)
  21     (:documentation "This is the CLSQL interface to PostgreSQL."))
  22
  23 (in-package #:clsql-postgresql)
  24
  25 ;;; Field conversion functions
  26
  27 (defun make-type-list-for-auto (num-fields res-ptr)
  28   (let ((new-types '()))
  29     (dotimes (i num-fields)
  30       (declare (fixnum i))
  31       (let* ((type (PQftype res-ptr i)))
  32         (push
  33          (case type
  34            ((#.pgsql-ftype#bytea
  35              #.pgsql-ftype#int2
  36              #.pgsql-ftype#int4)
  37             :int32)
  38            (#.pgsql-ftype#int8
  39             :int64)
  40            ((#.pgsql-ftype#float4
  41              #.pgsql-ftype#float8)
  42             :double)
  43            (otherwise
  44             t))
  45          new-types)))
  46       (nreverse new-types)))
  47
  48 (defun canonicalize-types (types num-fields res-ptr)
  49   (if (null types)
  50       nil
  51       (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
  52         (cond
  53           ((listp types)
  54            (canonicalize-type-list types auto-list))
  55           ((eq types :auto)
  56            auto-list)
  57           (t
  58            nil)))))
  59
  60 (defun tidy-error-message (message)
  61   (unless (stringp message)
  62     (setq message (uffi:convert-from-foreign-string message)))
  63   (let ((message (string-right-trim '(#\Return #\Newline) message)))
  64     (cond
  65       ((< (length message) (length "ERROR:"))
  66        message)
  67       ((string= message "ERROR:" :end1 6)
  68        (string-left-trim '(#\Space) (subseq message 6)))
  69       (t
  70        message))))
  71
  72 (defmethod database-initialize-database-type ((database-type
  73                                                (eql :postgresql)))
  74   t)
  75
  76 (uffi:def-type pgsql-conn-def pgsql-conn)
  77 (uffi:def-type pgsql-result-def pgsql-result)
  78
  79
  80 (defclass postgresql-database (database)
  81   ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr
  82              :type pgsql-conn-def)
  83    (lock
  84     :accessor database-lock
  85     :initform (make-process-lock "conn"))))
  86
  87 (defmethod database-type ((database postgresql-database))
  88   :postgresql)
  89
  90 (defmethod database-name-from-spec (connection-spec (database-type
  91                                                      (eql :postgresql)))
  92   (check-connection-spec connection-spec database-type
  93                          (host db user password &optional port options tty))
  94   (destructuring-bind (host db user password &optional port options tty)
  95       connection-spec
  96     (declare (ignore password options tty))
  97     (concatenate 'string
  98       (etypecase host
  99         (null "localhost")
 100         (pathname (namestring host))
 101         (string host))
 102       (when port
 103         (concatenate 'string
 104                      ":"
 105                      (etypecase port
 106                        (integer (write-to-string port))
 107                        (string port))))
 108       "/" db "/" user)))
 109
 110
 111 (defmethod database-connect (connection-spec (database-type (eql :postgresql)))
 112   (check-connection-spec connection-spec database-type
 113                          (host db user password &optional port options tty))
 114   (destructuring-bind (host db user password &optional port options tty)
 115       connection-spec
 116     (uffi:with-cstrings ((host-native host)
 117                          (user-native user)
 118                          (password-native password)
 119                          (db-native db)
 120                          (port-native port)
 121                          (options-native options)
 122                          (tty-native tty))
 123       (let ((connection (PQsetdbLogin host-native port-native
 124                                       options-native tty-native
 125                                       db-native user-native
 126                                       password-native)))
 127         (declare (type pgsql-conn-def connection))
 128         (when (not (eq (PQstatus connection)
 129                        pgsql-conn-status-type#connection-ok))
 130           (error 'clsql-connect-error
 131                  :database-type database-type
 132                  :connection-spec connection-spec
 133                  :errno (PQstatus connection)
 134                  :error (tidy-error-message
 135                          (PQerrorMessage connection))))
 136         (make-instance 'postgresql-database
 137                        :name (database-name-from-spec connection-spec
 138                                                       database-type)
 139                        :database-type :postgresql
 140                        :connection-spec connection-spec
 141                        :conn-ptr connection)))))
 142
 143
 144 (defmethod database-disconnect ((database postgresql-database))
 145   (PQfinish (database-conn-ptr database))
 146   (setf (database-conn-ptr database) nil)
 147   t)
 148
 149 (defmethod database-query (query-expression (database postgresql-database) result-types field-names)
 150   (let ((conn-ptr (database-conn-ptr database)))
 151     (declare (type pgsql-conn-def conn-ptr))
 152     (uffi:with-cstring (query-native query-expression)
 153       (let ((result (PQexec conn-ptr query-native)))
 154         (when (uffi:null-pointer-p result)
 155           (error 'clsql-sql-error
 156                  :database database
 157                  :expression query-expression
 158                  :errno nil
 159                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 160         (unwind-protect
 161             (case (PQresultStatus result)
 162               (#.pgsql-exec-status-type#empty-query
 163                nil)
 164               (#.pgsql-exec-status-type#tuples-ok
 165                (let ((num-fields (PQnfields result)))
 166                  (setq result-types
 167                    (canonicalize-types result-types num-fields
 168                                              result))
 169                  (values
 170                   (loop for tuple-index from 0 below (PQntuples result)
 171                         collect
 172                         (loop for i from 0 below num-fields
 173                               collect
 174                               (if (zerop (PQgetisnull result tuple-index i))
 175                                   (convert-raw-field
 176                                    (PQgetvalue result tuple-index i)
 177                                    result-types i)
 178                                 nil)))
 179                   (when field-names
 180                     (result-field-names num-fields result)))))
 181               (t
 182                (error 'clsql-sql-error
 183                       :database database
 184                       :expression query-expression
 185                       :errno (PQresultStatus result)
 186                       :error (tidy-error-message
 187                               (PQresultErrorMessage result)))))
 188           (PQclear result))))))
 189
 190 (defun result-field-names (num-fields result)
 191   "Return list of result field names."
 192   (let ((names '()))
 193     (dotimes (i num-fields (nreverse names))
 194       (declare (fixnum i))
 195       (push (uffi:convert-from-cstring (PQfname result i)) names))))
 196
 197 (defmethod database-execute-command (sql-expression
 198                                      (database postgresql-database))
 199   (let ((conn-ptr (database-conn-ptr database)))
 200     (declare (type pgsql-conn-def conn-ptr))
 201     (uffi:with-cstring (sql-native sql-expression)
 202       (let ((result (PQexec conn-ptr sql-native)))
 203         (when (uffi:null-pointer-p result)
 204           (error 'clsql-sql-error
 205                  :database database
 206                  :expression sql-expression
 207                  :errno nil
 208                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 209         (unwind-protect
 210             (case (PQresultStatus result)
 211               (#.pgsql-exec-status-type#command-ok
 212                t)
 213               ((#.pgsql-exec-status-type#empty-query
 214                 #.pgsql-exec-status-type#tuples-ok)
 215                (warn "Strange result...")
 216                t)
 217               (t
 218                (error 'clsql-sql-error
 219                       :database database
 220                       :expression sql-expression
 221                       :errno (PQresultStatus result)
 222                       :error (tidy-error-message
 223                               (PQresultErrorMessage result)))))
 224           (PQclear result))))))
 225
 226 (defstruct postgresql-result-set
 227   (res-ptr (uffi:make-null-pointer 'pgsql-result)
 228            :type pgsql-result-def)
 229   (types nil)
 230   (num-tuples 0 :type integer)
 231   (num-fields 0 :type integer)
 232   (tuple-index 0 :type integer))
 233
 234 (defmethod database-query-result-set ((query-expression string)
 235                                       (database postgresql-database)
 236                                       &key full-set result-types)
 237   (let ((conn-ptr (database-conn-ptr database)))
 238     (declare (type pgsql-conn-def conn-ptr))
 239     (uffi:with-cstring (query-native query-expression)
 240       (let ((result (PQexec conn-ptr query-native)))
 241         (when (uffi:null-pointer-p result)
 242           (error 'clsql-sql-error
 243                  :database database
 244                  :expression query-expression
 245                  :errno nil
 246                  :error (tidy-error-message (PQerrorMessage conn-ptr))))
 247         (case (PQresultStatus result)
 248           ((#.pgsql-exec-status-type#empty-query
 249             #.pgsql-exec-status-type#tuples-ok)
 250            (let ((result-set (make-postgresql-result-set
 251                         :res-ptr result
 252                         :num-fields (PQnfields result)
 253                         :num-tuples (PQntuples result)
 254                         :types (canonicalize-types
 255                                       result-types
 256                                       (PQnfields result)
 257                                       result))))
 258              (if full-set
 259                  (values result-set
 260                          (PQnfields result)
 261                          (PQntuples result))
 262                  (values result-set
 263                          (PQnfields result)))))
 264           (t
 265            (unwind-protect
 266                (error 'clsql-sql-error
 267                       :database database
 268                       :expression query-expression
 269                       :errno (PQresultStatus result)
 270                       :error (tidy-error-message
 271                               (PQresultErrorMessage result)))
 272              (PQclear result))))))))
 273
 274 (defmethod database-dump-result-set (result-set (database postgresql-database))
 275   (let ((res-ptr (postgresql-result-set-res-ptr result-set)))
 276     (declare (type pgsql-result-def res-ptr))
 277     (PQclear res-ptr)
 278     t))
 279
 280 (defmethod database-store-next-row (result-set (database postgresql-database)
 281                                     list)
 282   (let ((result (postgresql-result-set-res-ptr result-set))
 283         (types (postgresql-result-set-types result-set)))
 284     (declare (type pgsql-result-def result))
 285     (if (>= (postgresql-result-set-tuple-index result-set)
 286             (postgresql-result-set-num-tuples result-set))
 287         nil
 288       (loop with tuple-index = (postgresql-result-set-tuple-index result-set)
 289           for i from 0 below (postgresql-result-set-num-fields result-set)
 290           for rest on list
 291           do
 292             (setf (car rest)
 293               (if (zerop (PQgetisnull result tuple-index i))
 294                   (convert-raw-field
 295                    (PQgetvalue result tuple-index i)
 296                    types i)
 297                 nil))
 298           finally
 299             (incf (postgresql-result-set-tuple-index result-set))
 300             (return list)))))
 301
 302 ;;; Large objects support (Marc B)
 303
 304 (defmethod database-create-large-object ((database postgresql-database))
 305   (lo-create (database-conn-ptr database)
 306              (logior postgresql::+INV_WRITE+ postgresql::+INV_READ+)))
 307
 308
 309 #+mb-original
 310 (defmethod database-write-large-object (object-id (data string) (database postgresql-database))
 311   (let ((ptr (database-conn-ptr database))
 312         (length (length data))
 313         (result nil)
 314         (fd nil))
 315     (with-transaction (:database database)
 316        (unwind-protect
 317           (progn
 318             (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+))
 319             (when (>= fd 0)
 320               (when (= (lo-write ptr fd data length) length)
 321                 (setf result t))))
 322          (progn
 323            (when (and fd (>= fd 0))
 324              (lo-close ptr fd))
 325            )))
 326     result))
 327
 328 (defmethod database-write-large-object (object-id (data string) (database postgresql-database))
 329   (let ((ptr (database-conn-ptr database))
 330         (length (length data))
 331         (result nil)
 332         (fd nil))
 333     (database-execute-command "begin" database)
 334     (unwind-protect
 335         (progn
 336           (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+))
 337           (when (>= fd 0)
 338             (when (= (lo-write ptr fd data length) length)
 339               (setf result t))))
 340       (progn
 341         (when (and fd (>= fd 0))
 342           (lo-close ptr fd))
 343         (database-execute-command (if result "commit" "rollback") database)))
 344     result))
 345
 346 ;; (MB) the begin/commit/rollback stuff will be removed when with-transaction wil be implemented
 347 ;; (KMR) Can't use with-transaction since that function is in high-level code
 348 (defmethod database-read-large-object (object-id (database postgresql-database))
 349   (let ((ptr (database-conn-ptr database))
 350         (buffer nil)
 351         (result nil)
 352         (length 0)
 353         (fd nil))
 354     (unwind-protect
 355        (progn
 356          (database-execute-command "begin" database)
 357          (setf fd (lo-open ptr object-id postgresql::+INV_READ+))
 358          (when (>= fd 0)
 359            (setf length (lo-lseek ptr fd 0 2))
 360            (lo-lseek ptr fd 0 0)
 361            (when (> length 0)
 362              (setf buffer (uffi:allocate-foreign-string
 363                            length :unsigned t))
 364              (when (= (lo-read ptr fd buffer length) length)
 365                (setf result (uffi:convert-from-foreign-string
 366                              buffer :length length :null-terminated-p nil))))))
 367       (progn
 368         (when buffer (uffi:free-foreign-object buffer))
 369         (when (and fd (>= fd 0)) (lo-close ptr fd))
 370         (database-execute-command (if result "commit" "rollback") database)))
 371     result))
 372
 373 (defmethod database-delete-large-object (object-id (database postgresql-database))
 374   (lo-unlink (database-conn-ptr database) object-id))
 375
 376
 377 ;;; Object listing
 378
 379 (defun owner-clause (owner)
 380   (cond
 381    ((stringp owner)
 382     (format
 383      nil
 384      " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))"
 385      owner))
 386    ((null owner)
 387     (format nil " AND (NOT (relowner=1))"))
 388    (t "")))
 389
 390 (defun database-list-objects-of-type (database type owner)
 391   (mapcar #'car
 392           (database-query
 393            (format nil
 394                    "SELECT relname FROM pg_class WHERE (relkind = '~A')~A"
 395                    type
 396                    (owner-clause owner))
 397            database nil nil)))
 398
 399 (defmethod database-list-tables ((database postgresql-database)
 400                                  &key (owner nil))
 401   (database-list-objects-of-type database "r" owner))
 402
 403 (defmethod database-list-views ((database postgresql-database)
 404                                 &key (owner nil))
 405   (database-list-objects-of-type database "v" owner))
 406
 407 (defmethod database-list-indexes ((database postgresql-database)
 408                                   &key (owner nil))
 409   (database-list-objects-of-type database "i" owner))
 410
 411
 412 (defmethod database-list-table-indexes (table (database postgresql-database)
 413                                         &key (owner nil))
 414   (let ((indexrelids
 415          (database-query
 416           (format
 417            nil
 418            "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
 419            (string-downcase table)
 420            (owner-clause owner))
 421           database :auto nil))
 422         (result nil))
 423     (dolist (indexrelid indexrelids (nreverse result))
 424       (push
 425        (caar (database-query
 426               (format nil "select relname from pg_class where relfilenode='~A'"
 427                       (car indexrelid))
 428               database nil nil))
 429        result))))
 430
 431 (defmethod database-list-attributes ((table string)
 432                                      (database postgresql-database)
 433                                      &key (owner nil))
 434   (let* ((owner-clause
 435           (cond ((stringp owner)
 436                  (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner))
 437                 ((null owner) " AND (not (relowner=1))")
 438                 (t "")))
 439          (result
 440           (mapcar #'car
 441                   (database-query
 442                    (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A"
 443                            (string-downcase table)
 444                            owner-clause)
 445                    database nil nil))))
 446     (if result
 447         (remove-if #'(lambda (it) (member it '("cmin"
 448                                                "cmax"
 449                                                "xmax"
 450                                                "xmin"
 451                                                "oid"
 452                                                "ctid"
 453                                                ;; kmr -- added tableoid
 454                                                "tableoid") :test #'equal))
 455                    result))))
 456
 457 (defmethod database-attribute-type (attribute (table string)
 458                                     (database postgresql-database)
 459                                     &key (owner nil))
 460   (let ((row (car (database-query
 461                    (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"
 462                            (string-downcase table)
 463                            (string-downcase attribute)
 464                            (owner-clause owner))
 465                    database nil nil))))
 466     (when row
 467       (values
 468        (ensure-keyword (first row))
 469        (if (string= "-1" (second row))
 470            (- (parse-integer (third row) :junk-allowed t) 4)
 471          (parse-integer (second row)))
 472        nil
 473        (if (string-equal "f" (fourth row))
 474            1
 475          0)))))
 476
 477 (defmethod database-create-sequence (sequence-name
 478                                      (database postgresql-database))
 479   (database-execute-command
 480    (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
 481    database))
 482
 483 (defmethod database-drop-sequence (sequence-name
 484                                    (database postgresql-database))
 485   (database-execute-command
 486    (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database))
 487
 488 (defmethod database-list-sequences ((database postgresql-database)
 489                                     &key (owner nil))
 490   (database-list-objects-of-type database "S" owner))
 491
 492 (defmethod database-set-sequence-position (name (position integer)
 493                                                 (database postgresql-database))
 494   (values
 495    (parse-integer
 496     (caar
 497      (database-query
 498       (format nil "SELECT SETVAL ('~A', ~A)" name position)
 499       database nil nil)))))
 500
 501 (defmethod database-sequence-next (sequence-name
 502                                    (database postgresql-database))
 503   (values
 504    (parse-integer
 505     (caar
 506      (database-query
 507       (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
 508       database nil nil)))))
 509
 510 (defmethod database-sequence-last (sequence-name (database postgresql-database))
 511   (values
 512    (parse-integer
 513     (caar
 514      (database-query
 515       (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')")
 516       database nil nil)))))
 517
 518 (defmethod database-create (connection-spec (type (eql :postgresql)))
 519   (destructuring-bind (host name user password) connection-spec
 520     (declare (ignore user password))
 521     (multiple-value-bind (output status)
 522         (clsql-sys:command-output "createdb -h~A ~A"
 523                                        (if host host "localhost")
 524                                        name)
 525       (if (or (not (zerop status))
 526               (search "database creation failed: ERROR:" output))
 527           (error 'clsql-access-error
 528                  :connection-spec connection-spec
 529                  :database-type type
 530                  :error
 531                  (format nil "database-create failed: ~A"
 532                          output))
 533         t))))
 534
 535 (defmethod database-destroy (connection-spec (type (eql :postgresql)))
 536   (destructuring-bind (host name user password) connection-spec
 537     (declare (ignore user password))
 538     (multiple-value-bind (output status)
 539         (clsql-sys:command-output "dropdb -h~A ~A"
 540                                        (if host host "localhost")
 541                                        name)
 542       (if (or (not (zerop status))
 543               (search "database removal failed: ERROR:" output))
 544           (error 'clsql-access-error
 545                  :connection-spec connection-spec
 546                  :database-type type
 547                  :error
 548                  (format nil "database-destory failed: ~A"
 549                          output))
 550         t))))
 551
 552
 553 (defmethod database-probe (connection-spec (type (eql :postgresql)))
 554   (when (find (second connection-spec) (database-list connection-spec type)
 555               :key #'car :test #'string-equal)
 556     t))
 557
 558 (defmethod database-list (connection-spec (type (eql :postgresql)))
 559   (destructuring-bind (host name user password) connection-spec
 560     (declare (ignore name))
 561     (let ((database (database-connect (list host "template1" user password)
 562                                       type)))
 563       (unwind-protect
 564            (progn
 565              (setf (slot-value database 'clsql-sys::state) :open)
 566              (mapcar #'car (database-query "select datname from pg_database"
 567                                            database nil nil)))
 568         (progn
 569           (database-disconnect database)
 570           (setf (slot-value database 'clsql-sys::state) :closed))))))
 571
 572 (defmethod database-describe-table ((database postgresql-database) table)
 573   (database-query
 574    (format nil "select a.attname, t.typname
 575                                from pg_class c, pg_attribute a, pg_type t
 576                                where c.relname = '~a'
 577                                    and a.attnum > 0
 578                                    and a.attrelid = c.oid
 579                                    and a.atttypid = t.oid"
 580            (sql-escape (string-downcase table)))
 581    database :auto nil))
 582
 583 (defun %pg-database-connection (connection-spec)
 584   (check-connection-spec connection-spec :postgresql
 585                          (host db user password &optional port options tty))
 586   (macrolet ((coerce-string (var)
 587                `(unless (typep ,var 'simple-base-string)
 588                  (setf ,var (coerce ,var 'simple-base-string)))))
 589     (destructuring-bind (host db user password &optional port options tty)
 590         connection-spec
 591       (coerce-string db)
 592       (coerce-string user)
 593       (let ((connection (PQsetdbLogin host port options tty db user password)))
 594         (declare (type postgresql::pgsql-conn-ptr connection))
 595         (unless (eq (PQstatus connection) :connection-ok)
 596           ;; Connect failed
 597           (error 'clsql-connect-error
 598                  :database-type :postgresql
 599                  :connection-spec connection-spec
 600                  :errno (PQstatus connection)
 601                  :error (PQerrorMessage connection)))
 602         connection))))
 603
 604 (defmethod database-reconnect ((database postgresql-database))
 605   (let ((lock (database-lock database)))
 606     (with-process-lock (lock "Reconnecting")
 607       (with-slots (connection-spec conn-ptr)
 608           database
 609         (setf conn-ptr (%pg-database-connection connection-spec))
 610         database))))
 611
 612 ;;; Database capabilities
 613
 614 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql)))
 615   t)
 616
 617 (defmethod db-type-default-case ((db-type (eql :postgresql)))
 618   :lower)
 619
 620 (when (clsql-sys:database-type-library-loaded :postgresql)
 621   (clsql-sys:initialize-database-type :database-type :postgresql))