diff --git a/.gitignore b/.gitignore index 94f2b66..4394aa6 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ t/test.db .qlot/ +.emacs* \ No newline at end of file diff --git a/qlfile b/qlfile index 85374d6..2c51c19 100644 --- a/qlfile +++ b/qlfile @@ -3,3 +3,5 @@ ql cl-mysql :upstream ql dissect :upstream ql sxql :upstream ql rove :upstream +github sharplispers/log4cl +github 40ants/log4sly diff --git a/qlfile.lock b/qlfile.lock index 869dbee..5f86108 100644 --- a/qlfile.lock +++ b/qlfile.lock @@ -27,3 +27,11 @@ :initargs nil :version "ql-upstream-cacea7331c10fe9d8398d104b2dfd579bf7ea353" :remote-url "https://github.com/fukamachi/rove.git")) +("log4cl" . + (:class qlot/source/github:source-github + :initargs (:repos "sharplispers/log4cl" :ref nil :branch nil :tag nil) + :version "github-fe3da517147d023029782ced7cd989ba24f1e62d")) +("log4sly" . + (:class qlot/source/github:source-github + :initargs (:repos "40ants/log4sly" :ref nil :branch nil :tag nil) + :version "github-b229658c7fa8a8ff62cddd832e812cda96b50df6")) diff --git a/src/core/class/column.lisp b/src/core/class/column.lisp index e4025f9..5071e31 100644 --- a/src/core/class/column.lisp +++ b/src/core/class/column.lisp @@ -7,7 +7,10 @@ #:delete-from-plist #:ensure-car) (:export #:table-column-class + #:col-type + #:column-standard-effective-slot-definitions #:table-column-type + #:%table-column-type #:table-column-not-null-p #:table-column-name #:primary-key-p @@ -29,14 +32,24 @@ (otherwise (values col-type t)))) -(defclass table-column-class (c2mop:standard-direct-slot-definition) + +(defgeneric %table-column-type (obj)) +(defmethod %table-column-type (ob) nil) +(defgeneric table-column-references (obj)) +(defmethod table-column-references (ob) nil) +(defgeneric primary-key-p (obj)) +(defmethod primary-key-p (ob) nil) +(defgeneric ghost-slot-p (obj)) +(defmethod ghost-slot-p (ob) nil) + +(defclass column-slot-definitions () ((col-type :type (or symbol cons null) :initarg :col-type :accessor %table-column-type) (references :type references :initarg :references :initform nil - :reader table-column-references) + :accessor table-column-references) (primary-key :type boolean :initarg :primary-key :initform nil @@ -47,10 +60,19 @@ :accessor ghost-slot-p :documentation "Option to specify slots as ghost slots. Ghost slots do not depend on a database."))) +(defclass table-column-class (column-slot-definitions c2mop:standard-direct-slot-definition) + ()) + +(defclass column-standard-effective-slot-definitions (column-slot-definitions + c2mop:standard-effective-slot-definition) + ()) + (defgeneric table-column-type (column) (:method ((column table-column-class)) (values - (parse-col-type (%table-column-type column))))) + (parse-col-type (if (slot-boundp column 'col-type) + (%table-column-type column) + NIL))))) (defgeneric table-column-not-null-p (column) (:method ((column table-column-class)) @@ -58,6 +80,8 @@ (defgeneric table-column-name (column) (:method ((column table-column-class)) + (unlispify (symbol-name-literally (c2mop:slot-definition-name column)))) + (:method ((column column-standard-effective-slot-definitions)) (unlispify (symbol-name-literally (c2mop:slot-definition-name column))))) (defmethod initialize-instance :around ((class table-column-class) &rest rest-initargs @@ -69,14 +93,7 @@ (push (intern (symbol-name name) :keyword) (getf rest-initargs :initargs))) - (let ((class (apply #'call-next-method class rest-initargs))) - (unless (slot-boundp class 'col-type) - (if (or (ghost-slot-p class) - (slot-value class 'references)) - (setf (slot-value class 'col-type) nil) - (error 'col-type-required - :slot class))) - class)) + (apply #'call-next-method class rest-initargs)) (defgeneric table-column-references-column (column)) diff --git a/src/core/class/table.lisp b/src/core/class/table.lisp index 553a51e..0c10016 100644 --- a/src/core/class/table.lisp +++ b/src/core/class/table.lisp @@ -5,7 +5,10 @@ (:import-from #:mito.class.column #:parse-col-type #:table-column-class + #:table-column-references + #:column-standard-effective-slot-definitions #:table-column-type + #:%table-column-type #:table-column-name #:primary-key-p #:ghost-slot-p) @@ -140,9 +143,37 @@ (defmethod c2mop:direct-slot-definition-class ((class table-class) &key &allow-other-keys) 'table-column-class) +(defmethod c2mop:effective-slot-definition-class ((class table-class) &rest initargs) + (declare (ignorable initargs)) + (find-class 'column-standard-effective-slot-definitions)) + (defmethod c2mop:validate-superclass ((class table-class) (super standard-class)) t) +(defmethod c2mop:compute-effective-slot-definition + :around ((class table-class) name direct-slot-definitions) + (declare (ignorable name)) + (let* ((result (call-next-method)) + (have-col-type-slot (remove-if-not + (lambda (x) (slot-exists-p x 'mito.class.column:col-type)) + direct-slot-definitions)) + (found-col-types (remove-if-not + (lambda (x) (slot-boundp x 'mito.class.column:col-type)) + have-col-type-slot))) + ;;(break) + (when result + ;; set here all the relevant slots. See column-standard-effective-slot-definitions + (setf (ghost-slot-p result) + (some #'ghost-slot-p direct-slot-definitions)) + (when found-col-types + (setf (%table-column-type result) + (some #'%table-column-type found-col-types))) + (setf (table-column-references result) + (some #'table-column-references direct-slot-definitions)) + (setf (primary-key-p result) + (some #'primary-key-p direct-slot-definitions)) + result))) + (defgeneric table-name (class) (:method ((class table-class)) (if (slot-value class 'table-name) diff --git a/src/core/dao/column.lisp b/src/core/dao/column.lisp index 8710525..223e70d 100644 --- a/src/core/dao/column.lisp +++ b/src/core/dao/column.lisp @@ -3,32 +3,63 @@ (:use #:cl #:mito.util) (:import-from #:mito.class.column + #:column-standard-effective-slot-definitions #:table-column-class #:table-column-type) (:import-from #:local-time) (:import-from #:cl-ppcre) (:export #:dao-table-column-class #:dao-table-column-inflate + #:dao-table-column-standard-effective-slot-definitions #:dao-table-column-deflate + #:inflate + #:inflate-if-bound + #:deflate + #:deflate-if-bound #:inflate-for-col-type #:deflate-for-col-type)) (in-package :mito.dao.column) (defparameter *conc-name* nil) -(defclass dao-table-column-class (table-column-class) +(defclass dao-table-column-slot-definitions () ((inflate :type (or function null) + :accessor inflate :initarg :inflate) (deflate :type (or function null) + :accessor deflate :initarg :deflate))) +(defgeneric inflate (obj)) +(defmethod inflate (ob) nil) +(defgeneric inflate-if-bound (ob)) +(defmethod inflate-if-bound (obj) nil) +(defmethod inflate-if-bound ((obj dao-table-column-slot-definitions)) + (when (slot-boundp obj 'mito.dao.column:inflate) + (slot-value obj 'mito.dao.column:inflate))) +(defgeneric deflate (obj)) +(defmethod deflate (ob) nil) +(defgeneric deflate-if-bound (ob)) +(defmethod deflate-if-bound (obj) nil) +(defmethod deflate-if-bound ((obj dao-table-column-slot-definitions)) + (when (slot-boundp obj 'mito.dao.column:deflate) + (slot-value obj 'mito.dao.column:deflate))) + +(defclass dao-table-column-class (dao-table-column-slot-definitions table-column-class) + ()) + +(defclass dao-table-column-standard-effective-slot-definitions + (dao-table-column-slot-definitions + column-standard-effective-slot-definitions) + ()) + (defmethod initialize-instance :around ((object dao-table-column-class) &rest rest-initargs &key name readers writers inflate deflate &allow-other-keys) (when *conc-name* (let ((accessor (intern - (format nil "~:@(~A~A~)" *conc-name* name) - *package*))) + (format nil "~:@(~A~A~)" *conc-name* name) + *package*))) (unless readers (pushnew accessor readers) (setf (getf rest-initargs :readers) readers)) diff --git a/src/core/dao/mixin.lisp b/src/core/dao/mixin.lisp index c07bb10..67e442d 100644 --- a/src/core/dao/mixin.lisp +++ b/src/core/dao/mixin.lisp @@ -15,6 +15,7 @@ #:table-column-name #:table-column-references-column) (:import-from #:mito.dao.column + #:dao-table-column-standard-effective-slot-definitions #:dao-table-column-class #:dao-table-column-inflate #:*conc-name*) @@ -46,6 +47,10 @@ (defmethod c2mop:direct-slot-definition-class ((class dao-table-mixin) &key) 'dao-table-column-class) +(defmethod c2mop:effective-slot-definition-class ((class dao-table-mixin) &rest initargs) + (declare (ignorable initargs)) + (find-class 'mito.dao.column:dao-table-column-standard-effective-slot-definitions)) + (defgeneric make-dao-instance (class &rest initargs) (:method ((class-name symbol) &rest initargs) (apply #'make-dao-instance diff --git a/src/core/dao/table.lisp b/src/core/dao/table.lisp index 6bda2da..47eb1b4 100644 --- a/src/core/dao/table.lisp +++ b/src/core/dao/table.lisp @@ -14,7 +14,12 @@ #:table-primary-key #:create-table-sxql) (:import-from #:mito.dao.column + #:inflate + #:inflate-if-bound + #:deflate-if-bound + #:deflate #:dao-table-column-class + #:dao-table-column-standard-effective-slot-definitions #:dao-table-column-inflate) (:import-from #:mito.dao.mixin #:dao-table-mixin @@ -36,6 +41,26 @@ (defmethod c2mop:direct-slot-definition-class ((class dao-table-class) &key) 'dao-table-column-class) +(defmethod c2mop:effective-slot-definition-class ((class dao-table-class) &rest initargs) + (declare (ignorable initargs)) + (find-class 'dao-table-column-standard-effective-slot-definitions)) + +(defmethod c2mop:validate-superclass ((class dao-table-class) (super standard-class)) + t) + +(defmethod c2mop:compute-effective-slot-definition + :around ((class dao-table-class) name direct-slot-definitions) + (declare (ignorable name)) + (let ((result (call-next-method))) + (when result + ;; set here all the relevant slots. + ;; set here inflate and deflate from dao-table-column-standard-effective-slot-definitions + (setf (inflate result) + (some #'inflate-if-bound direct-slot-definitions)) + (setf (deflate result) + (some #'deflate-if-bound direct-slot-definitions)) + result))) + (defun initargs-enables-auto-pk (initargs) (first (or (getf initargs :auto-pk) '(:serial)))) diff --git a/src/core/dao/view.lisp b/src/core/dao/view.lisp index 2d82058..77473e0 100644 --- a/src/core/dao/view.lisp +++ b/src/core/dao/view.lisp @@ -5,6 +5,7 @@ #:table-class #:table-name) (:import-from #:mito.dao.column + #:dao-table-column-standard-effective-slot-definitions #:dao-table-column-class) (:import-from #:sxql) (:export #:dao-table-view @@ -20,6 +21,10 @@ (defmethod c2mop:direct-slot-definition-class ((class dao-table-view) &key) 'dao-table-column-class) +(defmethod c2mop:effective-slot-definition-class ((class dao-table-view) &rest initargs) + (declare (ignorable initargs)) + (find-class 'mito.dao.column:dao-table-column-standard-effective-slot-definitions)) + (defstruct (create-view (:include sxql.sql-type:sql-statement (sxql.sql-type:name "CREATE VIEW")) (:constructor make-create-view (view-name &key or-replace as))) view-name diff --git a/t/class.lisp b/t/class.lisp index 93f633e..51ad0fc 100644 --- a/t/class.lisp +++ b/t/class.lisp @@ -260,7 +260,7 @@ )") (is-table-class :mysql (defclass tweet () - ((user-name :references (user name))) + ((user-name :references (user name) :col-type (:or :null :text))) (:metaclass table-class)) "CREATE TABLE tweet ( user_name VARCHAR(64) NOT NULL