From bad0cc74f5574b40b8f1f7338dee3cd7bdf56228 Mon Sep 17 00:00:00 2001 From: Holger Schauer Date: Thu, 3 Mar 2011 15:48:26 +0100 Subject: [PATCH] Support :autoincrement for Postgres on table creation by rebuilding what Postgres is doing when using the serial tye. view-class-slot-definition-mixin: add new slot autoincrement-sequence. database-make-autoincrement-sequence: new generic function/method. database-generate-column-definition: specialize for postgresql-db. database-last-auto-increment-id: honor autoincrement-sequence. database-last-auto-increment-id: use :int for result-types, not integer. --- sql/generic-postgresql.lisp | 56 +++++++++++++++++++++++++++++-------- sql/generics.lisp | 3 +- sql/metaclasses.lisp | 8 +++++- sql/ooddl.lisp | 2 +- sql/oodml.lisp | 3 +- 5 files changed, 57 insertions(+), 15 deletions(-) diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp index 67175de..9c72946 100644 --- a/sql/generic-postgresql.lisp +++ b/sql/generic-postgresql.lisp @@ -242,18 +242,52 @@ database nil nil))))) (defmethod database-last-auto-increment-id ((database generic-postgresql-database) table column) - (typecase table - (sql-ident (setf table (slot-value table 'name))) - (standard-db-class (setf table (view-table table)))) - (typecase column - (sql-ident (setf column (slot-value column 'name))) - (view-class-slot-definition-mixin - (setf column (view-class-slot-column column)))) - (let ((seq-name (format nil "~a_~a_seq" table column))) + (let (column-helper seq-name) + (typecase table + (sql-ident (setf table (slot-value table 'name))) + (standard-db-class (setf table (view-table table)))) + (typecase column + (sql-ident (setf column-helper (slot-value column 'name))) + (view-class-slot-definition-mixin + (setf column-helper (view-class-slot-column column)))) + (setq seq-name (or (view-class-slot-autoincrement-sequence column) + (convert-to-db-default-case (format nil "~a_~a_seq" table column-helper) database))) (first (clsql:query (format nil "SELECT currval ('~a')" seq-name) - :flatp t - :database database - :result-types '(integer))))) + :flatp t + :database database + :result-types '(:int))))) + +(defmethod database-generate-column-definition (class slotdef (database generic-postgresql-database)) + ; handle autoincr slots special + (when (or (and (listp (view-class-slot-db-constraints slotdef)) + (member :auto-increment (view-class-slot-db-constraints slotdef))) + (eql :auto-increment (view-class-slot-db-constraints slotdef)) + (slot-value slotdef 'autoincrement-sequence)) + (let ((sequence-name (database-make-autoincrement-sequence class slotdef database))) + (setf (view-class-slot-autoincrement-sequence slotdef) sequence-name) + (cond ((listp (view-class-slot-db-constraints slotdef)) + (setf (view-class-slot-db-constraints slotdef) + (remove :auto-increment + (view-class-slot-db-constraints slotdef))) + (unless (member :default (view-class-slot-db-constraints slotdef)) + (setf (view-class-slot-db-constraints slotdef) + (append + (list :default (format nil "nextval('~a')" sequence-name)) + (view-class-slot-db-constraints slotdef))))) + (t + (setf (view-class-slot-db-constraints slotdef) + (list :default (format nil "nextval('~a')" sequence-name))))))) + (call-next-method class slotdef database)) + +(defmethod database-make-autoincrement-sequence (table column (database generic-postgresql-database)) + (let* ((table-name (view-table table)) + (column-name (view-class-slot-column column)) + (sequence-name (or (slot-value column 'autoincrement-sequence) + (convert-to-db-default-case + (format nil "~a_~a_SEQ" table-name column-name) database)))) + (unless (sequence-exists-p sequence-name :database database) + (database-create-sequence sequence-name database)) + sequence-name)) (defun postgresql-database-list (connection-spec type) (destructuring-bind (host name &rest other-args) connection-spec diff --git a/sql/generics.lisp b/sql/generics.lisp index decc005..2208b8d 100644 --- a/sql/generics.lisp +++ b/sql/generics.lisp @@ -139,7 +139,8 @@ DATABASE-NULL-VALUE on the type of the slot.")) ) (defgeneric read-sql-value (val type database db-type) ) - +(defgeneric database-make-autoincrement-sequence (class slotdef database) + ) ;; Generation of SQL strings from lisp expressions diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index 530c674..1ae635a 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -314,7 +314,13 @@ column definition in the database.") :accessor specified-type :initarg specified-type :initform nil - :documentation "Internal slot storing the :type specified by user."))) + :documentation "Internal slot storing the :type specified by user.") + (autoincrement-sequence + :accessor view-class-slot-autoincrement-sequence + :initarg :autoincrement-sequence + :initform nil + :documentation "A string naming the (possibly automatically generated) sequence +for a slot with an :auto-increment constraint."))) (defparameter *db-info-lambda-list* '(&key join-class diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index 33dca04..02c11f0 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -106,7 +106,7 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." (ordered-class-direct-slots self) (ordered-class-slots self)))) (dolist (slotdef ordered-slots) - (let ((res (database-generate-column-definition (class-name self) + (let ((res (database-generate-column-definition self slotdef database))) (when res (push res schemadef)))) diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 0ddaaba..d47bbba 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -232,7 +232,8 @@ :av-pairs av-pairs :database database) (when (and pk-slot (not pk)) - (setf pk (if (member :auto-increment (listify (view-class-slot-db-constraints pk-slot))) + (setf pk (if (or (member :auto-increment (listify (view-class-slot-db-constraints pk-slot))) + (not (null (view-class-slot-autoincrement-sequence pk-slot)))) (setf (slot-value obj (slot-definition-name pk-slot)) (database-last-auto-increment-id database table -- 2.34.1