[initial import drewc@tech.coop**20081107041736] { adddir ./src addfile ./rofl.asd hunk ./rofl.asd 1 - +(defsystem :rofl + :license + "Copyright (c) 2004-2007 Drew Crampsie + +Contains portions of ContextL: +Copyright (c) 2005 - 2007 Pascal Costanza + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the \"Software\"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE." + :components ((:static-file "rofl.asd") + + (:module :src + :components ((:file "packages") + (:file "rofl") + (:file "db-access-object") + (:file "db-access-object-sql") + ) + + :serial t)) + :serial t + :depends-on (:lisp-on-lines + :contextl :arnesi :alexandria :parse-number + ;;for rofl: + :cl-postgres + :simple-date-postgres + :postmodern )) + +(defsystem :rofl.test + :components ((:module :src + :components ( + (:file "rofl-test") + ) + :serial t) +) + :serial t + + + :depends-on (:rofl :stefil)) addfile ./src/db-access-object-sql.lisp hunk ./src/db-access-object-sql.lisp 1 - +(in-package :rofl) + + +(defun %select-objects (type select-fn query) + (mapcar (curry 'make-object-from-plist type) + (apply select-fn (intern (format nil "*")) + (if (string-equal (first query) :from) + query + (append `(:from ,type) query))))) + +(defun select-objects (type &rest query) + (let ((*instance-is-persistent* t)) + (%select-objects type #'select query))) + +(defun select-only-n-objects (n type &rest query) + (let ((*instance-is-persistent* t)) + + (let ((fields (if (eq :fields (car query)) + (loop + :for cons :on (cdr query) + :if (not (keywordp (car cons))) + :collect (car cons) into fields + :else :do + (setf query cons) + (return (nreverse (print fields))) + :finally + (setf query cons) + (return (nreverse (print fields)))) + + (list (intern "*"))))) + (let ((results + (%query + (print `(:limit (:select + ,@fields + ,@(if (string-equal (first query) :from) + (print query) + (append `(:from ,type) query))) + ,n))))) + (if (eql 1 n) + (when (first results) + (make-object-from-plist type (first results))) + (mapcar (curry 'make-object-from-plist type) results)))))) + +(defun make-object-from-plist (type plist) + (let* ((class (find-class type)) + (object (make-instance class)) + (slotds (class-slots class))) + + + (loop + :for (key val) :on plist :by #'cddr + :do + + (dolist (slotd (remove-if #'slot-definition-foreign-type (remove key slotds + :key #'slot-definition-column-name + :test-not #'string-equal))) + + + (setf (slot-value-using-class class object slotd) val)) + :finally (return object)))) + +(defun make-object (type &rest plist) + (make-object-from-plist type plist)) + +(defun insert-object (object) + (let ((class (class-of object)) + insert-query) + (flet + ((ins (slotd + &optional + (val + (slot-value-using-class class object slotd))) + (push (slot-definition-column-name slotd) insert-query) + (push val insert-query))) + + (loop :for slotd in (class-slots class) + :do (cond + ((slot-boundp-using-class class object slotd) + + (cond + ((slot-definition-foreign-type slotd) + (ins slotd + (let ((value + (slot-value-using-class class object slotd))) + (slot-value value (dao-id-column-name (class-of value))))) + ) + (t + (ins slotd)))) + ((slot-definition-primary-key-p slotd) + (setf (slot-value-using-class class object slotd) (get-default-value (class-table-name class) + (slot-definition-column-name slotd))) + (ins slotd )))) + + (let ((query (loop + :for (key val) + :on (nreverse insert-query) + :by #'cddr + :collect key into keys + :unless (find key (butlast keys)) + :nconc (list key val) into list + :finally (return list)))) + + + (apply #'insert-into (class-table-name class) (print query ))))) + object) + + +(defun update-object (object) + (let ((class (class-of object)) + update-query + delayed) + (flet ((ins (slotd &optional (val (slot-value-using-class class object slotd))) + (push (lambda () (push (slot-definition-column-name slotd) update-query) + (push val update-query)) + delayed))) + (loop :for slotd in (class-slots class) + :do (cond ((slot-boundp-using-class class object slotd) + (cond ((or (slot-definition-foreign-relation slotd) + ) + ) + ((slot-definition-foreign-type slotd) + (set-fkey-from-slotd + (slot-value-using-class class object slotd) + object slotd +) + ) + (t + (ins slotd)) )) + ((slot-definition-primary-key-p slotd) + (setf (slot-value-using-class class object slotd) (get-default-value (class-table-name class) + (slot-definition-column-name slotd))) + (ins slotd )))) + (map nil #'funcall delayed) + (apply #'update (class-table-name class) :set (print (nconc (nreverse update-query) + (list :where `(:= ,(dao-id-column-name class) + ,(slot-value object (dao-id-column-name class)) + ))))))) + object) + +(defun select-using-object (object &key (combinator :and)) + (let ((class (class-of object)) + select-query) + (flet ((sel (slotd &optional (val (slot-value-using-class class object slotd))) + (push `(:ilike ,(slot-definition-column-name slotd) ,(if (stringp val) + (format nil "~A%" val) val)) select-query))) + (loop :for slotd in (class-slots class) + :do (cond ((slot-boundp-using-class class object slotd) + (unless (or (slot-definition-foreign-relation slotd) + (slot-definition-foreign-type slotd)) + (sel slotd))))) + (if select-query + (select-objects (class-table-name class) + :where (print `(,combinator ,@(nreverse select-query)))) + nil)))) + + +(defun get-default-value-query (table column) + (format nil "select ~A " + (second (select-only 1 ':adsrc + :from 'pg_attribute 'pg_attrdef + :where `(:and (:= adnum attnum) + (:= attname ,(s-sql::to-sql-name column)) + (:= adrelid attrelid) + (:= attrelid + (:select oid + :from pg_class + :where (:= relname ,(s-sql::to-sql-name table))))))))) + +(defun get-default-value (table column) + (caar (query (get-default-value-query table column)))) + +(defun find-dao (type id + &key (table (class-table-name (find-class type))) + id-column-name) + + "Get the dao corresponding to the given primary key, +or return nil if it does not exist." + (let ((plist + (select-only 1 '* + :from table + :where (list ':= id (or id-column-name + (dao-id-column-name + (find-class type))))))) + (when plist (make-object-from-plist type plist)))) + + + +(defgeneric dao-id (dao) + (:method ((dao standard-db-access-object)) + (let ((class (class-of dao))) + + (slot-value-using-class class dao (class-id-slot-definition class))))) + +(defun make-dao-from-row (type row &key slots) + (let* ((class (find-class type)) + (dao (make-instance class)) + (slotds (class-slots class))) + (loop + :for val :in row + :for slotd + :in (or + (loop + :for slot :in slots + :collect (find slot slotds + :key #'slot-definition-name)) + slotds) + :do (setf (slot-value-using-class class dao slotd) val) + :finally (return (reinitialize-instance dao))))) addfile ./src/db-access-object.lisp hunk ./src/db-access-object.lisp 1 +(in-package :rofl) + +(defvar *persistent-instances/modifications* + (trivial-garbage:make-weak-hash-table :weakness :key)) + +(defvar *instance-is-persistent* nil) + +(defun mark-instance-as-persistent (object) + (setf (gethash object *persistent-instances/modifications*) nil)) + +(defun persistentp (db-object) + (nth-value 1 (gethash db-object *persistent-instances/modifications*))) + +(defun record-modification (db-object slotd old-value new-value) + (let ((mod-table (or (gethash db-object *persistent-instances/modifications*) + (make-hash-table)))) + (push (cons old-value new-value) (gethash slotd mod-table)) + (setf (gethash db-object *persistent-instances/modifications*) mod-table))) + +(defun modifiedp (db-object) + (gethash db-object *persistent-instances/modifications*)) + + +(defclass standard-db-access-object (standard-object) + ()) + +(defmethod (setf slot-value-using-class) :around + (value class (object standard-db-access-object) slotd) + + (when (not (eq :NULL value)) + (if (and (persistentp object) + (not (slot-definition-foreign-relation slotd))) + (let ((old-value (if (slot-boundp-using-class class object slotd) + (slot-value-using-class class object slotd) + '+unbound-slot+))) + (prog1 (call-next-method) + (record-modification object slotd old-value value))) + (call-next-method)))) + +(defmethod shared-initialize :after ((dao standard-db-access-object) + slots &rest initargs) + (when *instance-is-persistent* + (mark-instance-as-persistent dao)) + (let ((class (class-of dao)) + (foreign-key)) + (dolist (slotd (class-slots class)) + (with-slots (foreign-type) slotd + (when foreign-type + (when (consp foreign-type) + (setf foreign-key (cdr foreign-type) + foreign-type (car foreign-type))) + (if (slot-boundp-using-class class dao slotd) + (let ((value (slot-value-using-class class dao slotd))) (unless (typep value foreign-type) + (if (connected-p *database*) + (setf (slot-value-using-class class dao slotd) + (find-dao foreign-type value)) + (let ((obj (make-instance foreign-type))) + (break "here") + (setf (slot-value-using-class + (class-of obj) + obj + (class-id-slot-definition (class-of obj))) + value))))))))))) + addfile ./src/packages.lisp hunk ./src/packages.lisp 1 - +(cl:defpackage #:relational-objects-for-lisp + (:use + :common-lisp + #:closer-mop + #:arnesi + #:postmodern) + (:nicknames #:rofl) + (:export + +;; ROFL + #:standard-db-access-class + #:standard-db-access-object + #:make-object-from-plist + #:described-db-access-class + #:select-only + #:select + #:insert-into + #:select-objects + #:select-only-n-objects + #:select-using-object + #:insert-object + #:update-object + #:primary-key-boundp)) addfile ./src/rofl-test.lisp hunk ./src/rofl-test.lisp 1 - +(in-package :lol-test) + +;;;; CREATE USER rofl_test PASSWORD 'rofl_test'; +;;;; CREATE DATABASE rofl_test OWNER rofl_test; + + +(defmacro db (&body body) + `(postmodern:with-connection '("rofl_test" "rofl_test" "rofl_test" "localhost") + ,@body)) + +(deftest test-create-table () + (finishes (db + (ignore-errors (postmodern:query (:DROP-TABLE 'rofl_test_base))) + + (postmodern:query (:CREATE-TABLE rofl_test_base + ((rofl_test_base_id :type SERIAL :primary-key t) + (test_string :type string) + (test_integer :type integer))))))) + +(deftest test-simple-insert () + (test-create-table) + (let ((plist '(test-string "Test Entry" test-integer 1))) + (finishes (db + (postmodern:execute + (postmodern:sql-compile `(:insert-into rofl-test-base :set ,@plist))))))) + +(deftest test-rofl-select () + (test-simple-insert) + (db + (finishes + (let* ((result (first (select '* :from 'rofl-test-base)))) + (is (equalp '(:ROFL-TEST-BASE-ID 1 :TEST-STRING "Test Entry" :TEST-INTEGER 1) result)))))) + +(deftest test-rofl-select-only-1 () + (test-simple-insert) + (db + (finishes + (let* ((result (select-only 1 '* :from 'rofl-test-base))) + (is (equalp '(:ROFL-TEST-BASE-ID 1 :TEST-STRING "Test Entry" :TEST-INTEGER 1) result)))))) + +(deftest test-rofl-insert () + (test-create-table) + (db + (finishes (insert-into 'rofl-test-base :test-integer 2 :test-string "a")) + (finishes (insert-into 'rofl-test-base :test-integer 3 :test-string "b")) + (finishes (insert-into 'rofl-test-base :test-integer 4 :test-string "c")) + + (let ((r (select '* :from 'rofl-test-base))) + (is (equal 3 (length r)))))) + +(deftest test-rofl-class-creation () + (finishes (eval '(progn + (setf (find-class 'rofl-test-base) nil) + (defclass rofl-test-base () + ((rofl-test-base-id :primary-key t) + test-integer test-string) + (:metaclass standard-db-access-class)))))) + + +(deftest test-rofl-make-object-from-plist () + (test-rofl-class-creation) + (let* ((plist '(:ROFL-TEST-BASE-ID 1 :TEST-STRING "a" :TEST-INTEGER 2)) + (object (make-object-from-plist 'rofl-test-base plist))) + (is (equal (slot-value object 'rofl-test-base-id) 1)))) + + +(deftest test-rofl-select-objects () + (test-create-table) + (test-rofl-class-creation) + (test-rofl-insert) + + (db (finishes + (let ((objects (select-objects 'rofl-test-base + :where '(:= rofl-test-base-id 1)))) + (is (equal (slot-value (first objects) 'rofl-test-base-id) 1)))))) + +(deftest test-rofl-create-references-tables () + (finishes + (db + (ignore-errors (postmodern:query (:DROP-TABLE 'rofl_test_child))) + (ignore-errors (postmodern:query (:DROP-TABLE 'rofl_test_parent))) + + (postmodern:query (:CREATE-TABLE rofl_test_parent + ((rofl_test_parent_id + :type SERIAL + :primary-key t) + (test_string + :type string) + (test_integer + :type integer)))) + + + + (postmodern:query (:CREATE-TABLE rofl_test_child + ((rofl_test_child_id + :type SERIAL + :primary-key t) + (rofl_test_parent_id + :type integer + :references (rofl_test_parent)) + (test_string + :type string) + (test_integer + :type integer))))))) + +(deftest test-rofl-def-references-classes () + (finishes + (eval + '(progn + (defclass rofl-test-parent () + ((rofl-test-parent-id + :primary-key t) + (test-string) + (test-integer)) + (:metaclass standard-db-access-class)) + + ;;; three ways to get to the parent. + ;;; The should all point to the same object. + + (defclass rofl-test-child () + ((rofl-test-child-id + :primary-key t) ((rofl_test_child_id + :type SERIAL + :primary-key t) + (rofl_test_parent_id + :type integer + :references (rofl_test_parent)) + (test_string + :type string) + (test_integer + :type integer))))))) + +) + + +(deftest test-rofl-def-references () + (finishes + (eval + '(progn + (defclass rofl-test-parent () + ((rofl-test-parent-id + :primary-key t) + (test-string) + (test-integer)) + (:metaclass standard-db-access-class)) + + ;;; three ways to get to the parent. + ;;; The should all point to the same object. + + (test-rofl-def-references-classes) + (db + (finishes + (insert-into 'rofl-test-parent :test-string "Parent" :test-integer 1) + (insert-into 'rofl-test-child :test-string "Child 1" :test-integer 1 + :rofl-test-parent-id + (slot-value (first (select-objects 'rofl-test-parent)) 'rofl-test-parent-id))) + (let* ((child (select-only-n-objects 1 'rofl-test-child)) + (parent-same-slot-name/fkey (slot-value child 'rofl-test-parent-id)) + (parent-column-same-fkey (slot-value child 'parent)) + (parent-column-table-and-key (slot-value child 'same-parent))) + + (is (eql 1 (slot-value child 'test-integer))) + + (is (equal 1 (slot-value parent-same-slot-name/fkey 'test-integer))) + (is (equal 1 (slot-value parent-column-same-fkey 'test-integer))) + (is (equal 1 (slot-value parent-column-table-and-key 'test-integer))))))))) + + + + + + + + + + + + + + + + + + + + + + + + + addfile ./src/rofl.lisp hunk ./src/rofl.lisp 1 +(in-package :rofl) + +;;;; NB: These could really be in upstream + +;;;; * A PLIST reader for postmodern. +(postmodern::def-row-reader symbol-plist-row-reader (fields) + (let ((symbols (map 'list (lambda (desc) + (postmodern::from-sql-name (postmodern::field-name desc))) fields))) + (loop :while (postmodern::next-row) + :collect (loop :for field :across fields + :for symbol :in symbols + :nconc (list symbol (postmodern::next-field field)))))) + +(s-sql::def-sql-op :between (n start end) + `(,@(s-sql::sql-expand n) " BETWEEN " ,@(s-sql::sql-expand start) " AND " ,@(s-sql::sql-expand end))) + +(s-sql::def-sql-op :case (&rest clauses) + `("CASE " ,@(loop for (test expr) in clauses collect (format nil "WHEN ~A THEN ~A " (s-sql::sql-expand test) (s-sql::sql-expand expr))) "END")) + + +;;;; now the rofl code itself + +(defvar *row-reader* 'symbol-plist-row-reader) + +(defun %query (query) + (cl-postgres:exec-query *database* (sql-compile query) *row-reader*)) + +(defun select (&rest query) + (%query (cons :select query))) + +(defun prepare (&rest query) + (cl-postgres:prepare-query *database* "test2" (sql-compile (cons :select query)))) + + +(defun select-only (num &rest query) + (let ((results (%query `(:limit ,(cons :select query) ,num)))) + (if (eql 1 num) + (first results) + results))) + +(defun insert-into (table &rest values-plist) + (postmodern:execute + (postmodern:sql-compile `(:insert-into ,table :set ,@values-plist)))) + +(defun update (table &rest query) + (postmodern:execute + (postmodern:sql-compile `(:update ,table ,@query)))) + + +(defclass db-access-slot-definition () + ((column-name :initform nil + :initarg :db-name + :initarg :column + :accessor slot-definition-column-name + :documentation + "If non-NIL, contains the name of the column this slot is representing.") + (primary-key :initform nil + :initarg :primary-key + :accessor slot-definition-primary-key-p) + (transient :initform nil :initarg :transient :accessor slot-definition-transient-p + :documentation + "If non-NIL, this slot should be treated as transient and +ignored in all database related operations.") + + (foreign-type + :initform nil + :initarg :foreign-type + :initarg :references + :accessor slot-definition-foreign-type) + (foreign-relation + :initform nil + :initarg :referenced-from + :initarg :referenced-by + :accessor slot-definition-foreign-relation) + (foreign-join-spec + :initform nil + :initarg :on + :initarg :using + :accessor slot-definition-foreign-join-spec))) + + +(defclass db-access-class (standard-class) + ((table-name :initarg :table-name :initform nil :accessor class-table-name) + ) + (:documentation "Metaclass for simple o/r.")) + +(defmethod validate-superclass + ((class db-access-class) + (superclass standard-class)) + t) + + +(defclass db-access-direct-slot-definition (standard-direct-slot-definition + db-access-slot-definition) + ()) + +(defmethod direct-slot-definition-class + ((class db-access-class) &key &allow-other-keys) + (find-class 'db-access-direct-slot-definition)) + +(defclass db-access-effective-slot-definition + (standard-effective-slot-definition + db-access-slot-definition) + ()) + +(defmethod effective-slot-definition-class + ((class db-access-class) &key &allow-other-keys) + (find-class 'db-access-effective-slot-definition)) + +(defmethod compute-effective-slot-definition + ((class db-access-class) name direct-slot-definitions) + (declare (ignore name)) + (let ((slotd (call-next-method))) + (setf (slot-definition-primary-key-p slotd) + (some #'slot-definition-primary-key-p direct-slot-definitions) + (slot-definition-column-name slotd) + (or (let ((slot (find-if #'slot-definition-column-name direct-slot-definitions))) + (when slot + (slot-definition-column-name slot))) + name) + (slot-definition-transient-p slotd) + (every #'slot-definition-transient-p direct-slot-definitions) + (slot-definition-foreign-type slotd) + (slot-definition-foreign-type (car direct-slot-definitions)) + (slot-definition-foreign-relation slotd) + (slot-definition-foreign-relation (car direct-slot-definitions)) + (slot-definition-foreign-join-spec slotd) + (slot-definition-foreign-join-spec (car direct-slot-definitions)) + (slot-definition-type slotd) (slot-definition-type (car direct-slot-definitions))) + slotd)) + +(defun class-id-slot-definition (class) + (find-if #'slot-definition-primary-key-p + (class-slots class))) + +(defmethod class-table-name :around (class) + (or (call-next-method) + (class-name class))) + +(defclass standard-db-access-class (db-access-class) + ()) + +(defun find-foreign-relations (class object slotd) + (when (slot-boundp object (dao-id-column-name class)) + (select-objects (slot-definition-foreign-relation slotd) + :where `(:= ,(or (slot-definition-foreign-join-spec slotd) + (dao-id-column-name class)) + ,(slot-value object (dao-id-column-name class)))))) + +(defun real-slot-boundp-using-class (class object slotd) + (let ((real-slot-boundp-using-class t)) + (declare (special real-slot-boundp-using-class)) + (slot-boundp-using-class class object slotd))) + +(defmethod slot-boundp-using-class :around + ((class standard-db-access-class) object slotd) + (declare (special real-slot-boundp-using-class)) + (if (boundp 'real-slot-boundp-using-class) + (call-next-method) + (let ((bound? (call-next-method))) + (if(and (not bound?) (slot-definition-foreign-relation slotd)) + (when *database* + (let ((relations (find-foreign-relations class object slotd))) + (when relations + (setf (slot-value-using-class class object slotd) relations)))) + bound?)))) + +(defmethod slot-value-using-class :around + ((class standard-db-access-class) object slotd) + (cond ((slot-definition-foreign-relation slotd) + (if (slot-boundp-using-class class object slotd) + (call-next-method) + (setf (slot-value-using-class class object slotd) + (find-foreign-relations class object slotd)))) + ((slot-definition-foreign-type slotd) + (call-next-method)) + (t + (call-next-method)))) + + +(defun set-fkey-from-slotd (value object slotd) + (when (slot-boundp value (dao-id-column-name (class-of value))) + (setf (slot-value object (slot-definition-column-name slotd)) + (slot-value value (dao-id-column-name (class-of value)))))) + +(defvar *skip-fkey-propogate* nil) + +(defmethod (setf slot-value-using-class) :after + (value (class standard-db-access-class) object slotd) + + (let ((foreign-object-slots + (remove-if-not + (lambda (slot) + (and (slot-definition-foreign-type slot) + (eq (slot-definition-column-name slot) + (slot-definition-column-name slotd)) + (not (eq slotd slot)))) + (class-slots class)))) + (cond ((and value + (typep value 'standard-db-access-object) + (slot-definition-foreign-type slotd) + (primary-key-boundp value) + (not *skip-fkey-propogate*)) + + (set-fkey-from-slotd value object slotd)) + ((and foreign-object-slots + *database*) + + (map nil + (lambda (slot) + (let ((fo (find-dao (slot-definition-foreign-type slot) value))) + (let ((*skip-fkey-propogate* t)) + (setf (slot-value-using-class class object slot) fo)) )) + foreign-object-slots)) + + ))) + +(defun find-foreign-objects (db-object) + (let* ((class (class-of db-object)) + (foreign-objects )) + (mapcar (lambda (x) + (and (slot-value-using-class class db-object x) + (slot-value-using-class class db-object x))) + (remove-if-not #'lol::slot-definition-foreign-type + (lol::class-slots class))))) + + + (defun dao-id-column-name (class) + (slot-definition-column-name + (or (class-id-slot-definition class) + (error "No ID slot (primary key) for ~A" class)))) + +(defun db-access-object-p (thing) + (typep thing 'standard-db-access-object)) + +(defun primary-key-boundp (object) + (check-type object standard-db-access-object) + (slot-boundp object (dao-id-column-name (class-of object)))) + + + +(defmethod initialize-instance :around ((class standard-db-access-class) &rest initargs &key name (direct-superclasses '()) direct-slots) + (declare (dynamic-extent initargs)) + (let ((direct-slots (loop for slot in direct-slots + collect (let* ((sname (getf slot :name)) + (readers (getf slot :readers)) + (writers (getf slot :writers))) + (setf (getf slot :readers) + (cons (intern (format nil "~A.~A" + name sname)) readers)) + (setf (getf slot :writers) + (cons `(setf ,(intern (format nil "~A.~A" + name sname))) writers)) + slot)))) + + + + (if (loop for direct-superclass in direct-superclasses + thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object))) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses + (append direct-superclasses + (list (find-class 'standard-db-access-object))) + :direct-slots direct-slots + initargs)))) + +(defmethod reinitialize-instance :around ((class standard-db-access-class) + &rest initargs + &key (name (class-name class)) + (direct-superclasses '() direct-superclasses-p) direct-slots) + (declare (dynamic-extent initargs)) + (let ((direct-slots (loop for slot in direct-slots + collect (let* ((sname (getf slot :name)) + (readers (getf slot :readers)) + (writers (getf slot :writers))) + (setf (getf slot :readers) + (cons (intern (format nil "~A.~A" + name sname)) readers)) + (setf (getf slot :writers) + (cons `(setf ,(intern (format nil "~A.~A" + name sname))) writers)) + slot)))) + + + + (if (loop for direct-superclass in direct-superclasses + thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object))) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses + (append direct-superclasses + (list (find-class 'standard-db-access-object))) + :direct-slots direct-slots + initargs)))) + + + + +;(defgeneric make-dao (type &rest initargs) +#+nil(defun make-dao (type initargs) + "Create a DAO of the given `TYPE' and initialize it according + to the values of the alist `INITARGS'. `Initargs' may contain + additional values, not used in the initialization proccess." + (let ((instance (make-instance type))) + (iter (for slot in (slots-of instance)) + (setf (slot-value instance (slot-definition-name slot)) + (let ((the-value (cdr (assoc (intern (symbol-name (slot-definition-name slot)) 'keyword) initargs)))) + (if (foreign-type-p slot) + (make-instance (sb-pcl:slot-definition-type slot) :id the-value) + the-value)))) + instance)) + + + + + }