diff --git a/postmodern/package.lisp b/postmodern/package.lisp index a0119ef..67654df 100644 --- a/postmodern/package.lisp +++ b/postmodern/package.lisp @@ -8,6 +8,7 @@ #+postmodern-use-mop (:export #:dao-class #:dao-exists-p #:dao-keys #:query-dao #:select-dao #:get-dao + #:define-dao-class #:fetch-defaults #:do-query-dao #:do-select-dao #:with-column-writers diff --git a/postmodern/table.lisp b/postmodern/table.lisp index 881e157..b3f8fba 100644 --- a/postmodern/table.lisp +++ b/postmodern/table.lisp @@ -929,3 +929,26 @@ own queries to add them, in which case look to s-sql's create-table function." `(:default ,(column-default slot))))) ,@(when (and (dao-keys table) (not (find-primary-key-column table))) `((:primary-key ,@(dao-keys table))))))) + +(defmacro define-dao-class (name direct-superclasses direct-slots &rest options) + "Like defclass except two postmodern specific changes: +1. The dao-class metaclass options is automatically added. +2. If second value in a slot is not a keyword, it is assumed to be col-type. + +Example: +(define-dao-class id-class () + ((id integer :initarg :id :accessor test-id) + (email :col-type text :initarg :email :accessor email)) + (:keys id))" + (flet ((expand-slot (rest) + (let ((second + (second rest))) + (if (keywordp second) + rest + (cons (first rest) + (append (list :col-type second) + (cddr rest))))))) + (list* 'defclass name direct-superclasses + (mapcar #'expand-slot direct-slots) + (list :metaclass 'dao-class) + options))) diff --git a/postmodern/tests/test-dao.lisp b/postmodern/tests/test-dao.lisp index aed9a90..a6b1440 100644 --- a/postmodern/tests/test-dao.lisp +++ b/postmodern/tests/test-dao.lisp @@ -1570,3 +1570,31 @@ Note that you need to handle :NULLs." (fiveam:is (equal (pomo::field-name-to-slot-name (find-class 'postmodern-tests::listy) "r-list") 'postmodern-tests::r-list))) + +(define-dao-class test-define-dao-class () + ((id integer :initarg :id :accessor test-id) + (a :col-type text :initarg :a :accessor test-a)) + (:table-name test-define-dao-class) + (:documentation "test-codumentation") + (:keys id)) + +(test define-dao-class + (is (equal (macroexpand-1 + '(define-dao-class test-define-dao-class () + ((id integer :initarg :id :accessor test-id) + (a :col-type text :initarg :a :accessor test-a)) + (:table-name test-define-dao-class) + (:keys id))) + '(defclass test-define-dao-class nil + ((id :col-type integer :initarg :id :accessor test-id) + (a :col-type text :initarg :a :accessor test-a)) + (:metaclass dao-class) (:table-name test-define-dao-class) + (:keys id)))) + (let ((class + (class-of (make-instance 'test-define-dao-class)))) + (is (eq (pomo::find-col-type class 'id) + 'integer)) + (is (eq (pomo::find-col-type class 'a) + 'text)) + (is (equal (dao-keys class) + (list 'id)))))