X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fgeneric-postgresql.lisp;h=feeaced389b125c371f40475cfd8bb0ba79e021a;hp=370c63352eeeb95b633394f7f1ee7185bf8db51b;hb=4972b90bab0ee31300e49c0c06b472de747cbbb6;hpb=399877696a9ea31648ed27f656495bb36c67b03a diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp index 370c633..feeaced 100644 --- a/sql/generic-postgresql.lisp +++ b/sql/generic-postgresql.lisp @@ -1,8 +1,6 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; -;;;; $Id$ -;;;; ;;;; Generic postgresql layer, used by db-postgresql and db-postgresql-socket ;;;; ;;;; This file is part of CLSQL. @@ -24,7 +22,8 @@ (defmethod database-get-type-specifier (type args database (db-type (eql :postgresql))) - (declare (ignore type args database)) + (warn "Could not determine a valid :postgresqlsql type specifier for ~A ~A ~A, defaulting to VARCHAR " + type args database) "VARCHAR") (defmethod database-get-type-specifier ((type (eql 'string)) args database @@ -129,8 +128,8 @@ (database-query (format nil - "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)" - (string-downcase table) + "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where LOWER(relname)='~A'~A)" + (string-downcase (unescaped-database-identifier table)) (owner-clause owner)) database :auto nil)) (result nil)) @@ -142,10 +141,11 @@ database nil nil)) result)))) -(defmethod database-list-attributes ((table string) +(defmethod database-list-attributes ((table %database-identifier) (database generic-postgresql-database) &key (owner nil)) - (let* ((owner-clause + (let* ((table (unescaped-database-identifier table)) + (owner-clause (cond ((stringp owner) (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner)) ((null owner) " AND (not (relowner=1))") @@ -168,9 +168,12 @@ "tableoid") :test #'equal)) result)))) -(defmethod database-attribute-type (attribute (table string) +(defmethod database-attribute-type ((attribute %database-identifier) + (table %database-identifier) (database generic-postgresql-database) - &key (owner nil)) + &key (owner nil) + &aux (table (unescaped-database-identifier table)) + (attribute (unescaped-database-identifier attribute))) (let ((row (car (database-query (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" (string-downcase table) @@ -179,39 +182,41 @@ database nil nil)))) (when row (destructuring-bind (typname attlen atttypmod attnull) row - - (setf attlen (parse-integer attlen :junk-allowed t) - atttypmod (parse-integer atttypmod :junk-allowed t)) - + (setf attlen (%get-int attlen) + atttypmod (%get-int atttypmod)) (let ((coltype (ensure-keyword typname)) - (colnull (if (string-equal "f" attnull) 1 0)) + (colnull (typecase attnull + (string (if (string-equal "f" attnull) 1 0)) + (null 1) + (T 0))) collen colprec) - (setf (values collen colprec) - (case coltype - ((:numeric :decimal) - (if (= -1 atttypmod) - (values nil nil) - (values (ash (- atttypmod 4) -16) - (boole boole-and (- atttypmod 4) #xffff)))) - (otherwise - (values - (cond ((and (= -1 attlen) (= -1 atttypmod)) nil) - ((= -1 attlen) (- atttypmod 4)) - (t attlen)) - nil)))) - (values coltype collen colprec colnull)))))) + (setf (values collen colprec) + (case coltype + ((:numeric :decimal) + (if (= -1 atttypmod) + (values nil nil) + (values (ash (- atttypmod 4) -16) + (boole boole-and (- atttypmod 4) #xffff)))) + (otherwise + (values + (cond ((and (= -1 attlen) (= -1 atttypmod)) nil) + ((= -1 attlen) (- atttypmod 4)) + (t attlen)) + nil)))) + (values coltype collen colprec colnull)))))) (defmethod database-create-sequence (sequence-name (database generic-postgresql-database)) - (database-execute-command - (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) - database)) + (let ((cmd (concatenate + 'string "CREATE SEQUENCE " (escaped-database-identifier sequence-name database)))) + (database-execute-command cmd database))) (defmethod database-drop-sequence (sequence-name (database generic-postgresql-database)) (database-execute-command - (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) + (concatenate 'string "DROP SEQUENCE " (escaped-database-identifier sequence-name database)) + database)) (defmethod database-list-sequences ((database generic-postgresql-database) &key (owner nil)) @@ -220,29 +225,83 @@ (defmethod database-set-sequence-position (name (position integer) (database generic-postgresql-database)) (values - (parse-integer + (%get-int (caar (database-query - (format nil "SELECT SETVAL ('~A', ~A)" name position) + (format nil "SELECT SETVAL ('~A', ~A)" (escaped-database-identifier name) position) database nil nil))))) (defmethod database-sequence-next (sequence-name (database generic-postgresql-database)) (values - (parse-integer + (%get-int (caar (database-query - (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") + (concatenate 'string "SELECT NEXTVAL ('" (escaped-database-identifier sequence-name) "')") database nil nil))))) (defmethod database-sequence-last (sequence-name (database generic-postgresql-database)) (values - (parse-integer + (%get-int (caar (database-query - (concatenate 'string "SELECT LAST_VALUE FROM " sequence-name) + (concatenate 'string "SELECT LAST_VALUE FROM " (escaped-database-identifier sequence-name)) database nil nil))))) +(defmethod auto-increment-sequence-name (table column (database generic-postgresql-database)) + (let* ((sequence-name (or (database-identifier (slot-value column 'autoincrement-sequence)) + (combine-database-identifiers + (list table column 'seq) + database)))) + (when (search "'" (escaped-database-identifier sequence-name) + :test #'string-equal) + (signal-database-too-strange + "PG Sequence names shouldnt contain single quotes for the sake of sanity")) + sequence-name)) + +(defmethod database-last-auto-increment-id ((database generic-postgresql-database) table column) + (let ((seq-name (auto-increment-sequence-name table column database))) + (first (clsql:query (format nil "SELECT currval ('~a')" + (escaped-database-identifier seq-name)) + :flatp t + :database database + :result-types '(:int))))) + +(defmethod database-generate-column-definition + (class slotdef (database generic-postgresql-database)) + (when (member (view-class-slot-db-kind slotdef) '(:base :key)) + (let ((cdef + (list (sql-expression :attribute (database-identifier slotdef database)) + (specified-type slotdef) + (view-class-slot-db-type slotdef))) + (const (listify (view-class-slot-db-constraints slotdef))) + (seq (auto-increment-sequence-name class slotdef database))) + (when seq + (setf const (remove :auto-increment const)) + (unless (member :default const) + (let* ((next (format nil "nextval('~a')" (escaped-database-identifier seq)))) + (setf const (append const (list :default next)))))) + (append cdef const)))) + +(defmethod database-add-autoincrement-sequence + ((self standard-db-class) (database generic-postgresql-database)) + (let ((ordered-slots (slots-for-possibly-normalized-class self))) + (dolist (slotdef ordered-slots) + ;; ensure that referenceed sequences actually exist before referencing them + (let ((sequence-name (auto-increment-sequence-name self slotdef database))) + (when (and sequence-name + (not (sequence-exists-p sequence-name :database database))) + (create-sequence sequence-name :database database)))))) + +(defmethod database-remove-autoincrement-sequence + ((table standard-db-class) + (database generic-postgresql-database)) + (let ((ordered-slots (slots-for-possibly-normalized-class table))) + (dolist (slotdef ordered-slots) + ;; ensure that referenceed sequences are dropped with the table + (let ((sequence-name (auto-increment-sequence-name table slotdef database))) + (when sequence-name (drop-sequence sequence-name)))))) + (defun postgresql-database-list (connection-spec type) (destructuring-bind (host name &rest other-args) connection-spec (declare (ignore name)) @@ -382,3 +441,5 @@ (defmethod db-type-has-prepared-stmt? ((db-type (eql :postgresql-socket))) t) +(defmethod db-type-has-auto-increment? ((db-type (eql :postgresql))) + t)