From b7657b86f85f575d5776dc6b626b1dc258d1fa47 Mon Sep 17 00:00:00 2001 From: drewc Date: Fri, 4 Apr 2008 10:43:58 -0700 Subject: [PATCH] added ROFL test cases + extra formatting hooks for attributes darcs-hash:20080404174358-39164-4dfd7751ed2a64ded2d0c91044336069a1fd8f32.gz --- lisp-on-lines-ucw.asd | 7 +- lisp-on-lines.asd | 5 +- src/attribute-test.lisp | 18 ++- src/attribute.lisp | 76 +++++++++-- src/contextl-hacks.lisp | 26 ++++ src/description-class.lisp | 110 +++++++++++----- src/description.lisp | 28 ++-- src/display.lisp | 75 +++++++---- src/packages.lisp | 12 +- src/rofl-test.lisp | 178 ++++++++++++++++++++++++++ src/rofl.lisp | 124 +++++++++++++----- src/standard-descriptions/clos.lisp | 11 +- src/standard-descriptions/edit.lisp | 19 +-- src/standard-descriptions/inline.lisp | 35 ++--- src/standard-descriptions/t.lisp | 71 +++++++--- src/ucw/html-description.lisp | 102 +++++++++------ src/ucw/packages.lisp | 12 +- src/ucw/standard-components.lisp | 49 ++++++- src/ucw/ucw-test.lisp | 50 +++++++- src/utilities.lisp | 21 +++ 20 files changed, 811 insertions(+), 218 deletions(-) create mode 100644 src/rofl-test.lisp rewrite src/standard-descriptions/inline.lisp (67%) diff --git a/lisp-on-lines-ucw.asd b/lisp-on-lines-ucw.asd index 5164fdc..5abc5d4 100644 --- a/lisp-on-lines-ucw.asd +++ b/lisp-on-lines-ucw.asd @@ -11,9 +11,12 @@ :components ((:module :ucw :components ((:file "packages") - (:file "standard-components") (:file "lol-tags") - (:file "html-description")) + (:file "standard-components") + (:file "contextl-components") + (:file "html-description") + (:file "lol-components") + ) :serial t)))) :serial t diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index a3181f2..b0cbff9 100644 --- a/lisp-on-lines.asd +++ b/lisp-on-lines.asd @@ -66,7 +66,9 @@ OTHER DEALINGS IN THE SOFTWARE." :serial t)) :serial t - :depends-on (:contextl :arnesi :alexandria :postmodern)) + :depends-on (:contextl :arnesi :alexandria + ;;for rofl: + :postmodern :simple-date)) @@ -77,6 +79,7 @@ OTHER DEALINGS IN THE SOFTWARE." (:file "description-test") (:file "attribute-test") (:file "display-test") + (:file "rofl-test") (:module :ucw :components ((:file "ucw-test")) :serial t)) diff --git a/src/attribute-test.lisp b/src/attribute-test.lisp index 0cff6eb..74caa00 100644 --- a/src/attribute-test.lisp +++ b/src/attribute-test.lisp @@ -50,10 +50,6 @@ (deftest (test-attribute-with-different-class :compile-before-run t) () (eval '(progn -;;;; We cannot ever redefine this class ic think... -;;; as attributes are also slot meta-objects. - - (define-layered-class test-attribute-class (lol::standard-attribute) ((some-slot :initarg :some-slot @@ -70,6 +66,20 @@ (find-class 'test-attribute-class))) (is (equalp "BRILLANT!" (some-slot a))))) +(deftest (test-attribute-with-different-class-and-subclassed-description :compile-before-run t) () + (test-attribute-with-different-class) + (eval '(progn + (define-description test-attribute-with-different-class-description-sub + (test-attribute-with-different-class-description) + ()))) + + (let* ((d (find-description 'test-attribute-with-different-class-description-sub)) + + (a (find-attribute d 'attribute-with-different-class))) + (is (eq (class-of a) + (find-class 'test-attribute-class))) + (is (equalp "BRILLANT!" (some-slot a))))) + diff --git a/src/attribute.lisp b/src/attribute.lisp index e93ef93..210b36d 100644 --- a/src/attribute.lisp +++ b/src/attribute.lisp @@ -55,7 +55,7 @@ (unbound-slot () (or *init-time-description* -q (call-next-method))))) + (call-next-method))))) (define-layered-class attribute () ((description :initarg :description @@ -69,8 +69,7 @@ q (call-next-method))))) (attribute-class :accessor attribute-class :initarg :attribute-class - :initform 'standard-attribute - :layered t) + :initform 'standard-attribute) (keyword :layered-accessor attribute-keyword :initarg :keyword @@ -82,8 +81,6 @@ q (call-next-method))))) :special t))) - - (define-layered-class standard-attribute (attribute) ((label :layered-accessor attribute-label @@ -91,16 +88,28 @@ q (call-next-method))))) :initform nil :layered t :special t) + (label-formatter + :layered-accessor attribute-label-formatter + :initarg :label-formatter + :initform nil + :layered t + :special t) (function :initarg :function :layered-accessor attribute-function :layered t :special t) - (value - :layered-accessor attribute-value - :initarg :value - :layered t - :special t) + (value + :layered-accessor attribute-value + :initarg :value + :layered t + :special t) + (value-formatter + :layered-accessor attribute-value-formatter + :initarg :value-formatter + :initform nil + :layered t + :special t) (activep :layered-accessor attribute-active-p :initarg :activep ;depreciated @@ -109,7 +118,33 @@ q (call-next-method))))) :layered t :special t :documentation - "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null."))) + "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.") + (active-attributes :layered-accessor attribute-active-attributes + :initarg :attributes + :layered t + :special t) + (active-descriptions :layered-accessor attribute-active-descriptions + :initarg :activate + :initform nil + :layered t + :special t) + (inactive-descriptions :layered-accessor attribute-inactive-descriptions + :initarg :deactivate + :initform nil + :layered t + :special t))) + +(define-layered-method attribute-label-formatter :around (attribute) + (or (slot-value attribute 'label-formatter) + (attribute-value (find-attribute (attribute-description attribute) 'label-formatter)) + (error "No Formatter .. fool!"))) + +(define-layered-method attribute-value-formatter :around (attribute) + + (or (slot-value attribute 'value-formatter) + (attribute-value (find-attribute (attribute-description attribute) 'value-formatter)) + (error "No Formatter .. fool!"))) + (define-layered-method attribute-object ((attribute standard-attribute)) @@ -118,10 +153,11 @@ q (call-next-method))))) (described-object (attribute-description attribute)))) +(define-layered-function attribute-value-using-object (object attribute)) +(define-layered-function (setf attribute-value-using-object) (value object attribute)) + (define-layered-method attribute-value ((attribute standard-attribute)) (attribute-value-using-object (attribute-object attribute) attribute)) - -(define-layered-function attribute-value-using-object (object attribute)) (define-layered-method attribute-value-using-object (object attribute) (let ((fn (handler-case (attribute-function attribute) @@ -130,6 +166,14 @@ q (call-next-method))))) (funcall fn object) (slot-value attribute 'value)))) +(define-layered-method (setf attribute-value) (value (attribute standard-attribute)) + (setf (attribute-value-using-object (attribute-object attribute) attribute) value)) + +(define-layered-method (setf attribute-value-using-object) (value object attribute) + (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable" + object attribute)) + + (defun ensure-access-function (class attribute property) (with-function-access (if (slot-definition-specialp property) @@ -255,6 +299,8 @@ q (call-next-method))))) (:method ((attribute standard-attribute) initarg) nil) (:method ((attribute standard-attribute) (initarg (eql :function))) + t) + (:method ((attribute standard-attribute) (initarg (eql :value))) t)) (defun prepare-initargs (att args) @@ -271,7 +317,9 @@ q (call-next-method))))) (attribute-value *object* attribute)) (defmacro with-attributes (names description &body body) - `(with-slots ,names ,description ,@body)) + `(let ,(loop for name in names collect + (list name `(find-attribute ,description ',name))) + ,@body))q diff --git a/src/contextl-hacks.lisp b/src/contextl-hacks.lisp index ee4e38a..b6af05e 100644 --- a/src/contextl-hacks.lisp +++ b/src/contextl-hacks.lisp @@ -1,5 +1,31 @@ (in-package :contextl) + + + +;;; HACK: +;;; Since i'm not using deflayer, ensure-layer etc, +;;; There are a few places where contextl gets confused +;;; trying to locate my description layers. + +;;; TODO: investigate switching to deflayer! + +(defun contextl::prepare-layer (layer) + (if (symbolp layer) + (if (eq (symbol-package layer) + (find-package :description-definers)) + layer + (contextl::defining-layer layer)) + + layer)) + +(defmethod find-layer-class :around ((layer symbol) &optional errorp environment) + (if (eq (symbol-package layer) + (find-package :description-definers)) + (find-class layer) + (call-next-method))) + + ;;; HACK: We are ending up with classes named NIL in the superclass list. ;;; These cannot be given the special object superclass when re-initializing ;;; is it will be in the subclasses superclasses AFTER this class, causing diff --git a/src/description-class.lisp b/src/description-class.lisp index 7e364e3..fb6e7ff 100644 --- a/src/description-class.lisp +++ b/src/description-class.lisp @@ -4,27 +4,6 @@ ;;;; A description is an object which is used ;;;; to describe another object. -;;; HACK: -;;; Since i'm not using deflayer, ensure-layer etc, -;;; There are a few places where contextl gets confused -;;; trying to locate my description layers. - -;;; TODO: investigate switching to deflayer! - -(defun contextl::prepare-layer (layer) - (if (symbolp layer) - (if (eq (symbol-package layer) - (find-package :description-definers)) - layer - (contextl::defining-layer layer)) - - layer)) - -(defmethod find-layer-class :around ((layer symbol) &optional errorp environment) - (if (eq (symbol-package layer) - (find-package :description-definers)) - (find-class layer) - (call-next-method))) ;;; #+HACK ;;; I'm having some 'issues' with @@ -58,17 +37,25 @@ attribute)) (defmethod slot-value-using-class ((class description-access-class) object slotd) - (if (or + (call-next-method) +#+nil (if (or (eq (slot-definition-name slotd) 'described-object) (not (slot-boundp slotd 'attribute-object))) (call-next-method) (slot-definition-attribute-object slotd))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *description-attributes* (make-hash-table))) + + + (defclass standard-description-class (description-access-class layered-class) - () + ((attributes :accessor description-class-attributes :initform (list))) (:default-initargs :defining-metaclass 'description-access-class)) + + (defmethod validate-superclass ((class standard-description-class) (superclass standard-class)) @@ -80,9 +67,74 @@ (defun description-class-name (description-class) (read-from-string (symbol-name (class-name description-class)))) + +(defgeneric standard-description-p (description-candidate) + (:method (not-description) + NIL) + (:method ((description standard-description-object)) + T)) (defun initialize-description-class (class) +;;; HACK: initialization does not happ en properly +;;; when compiling and loading or something like that. +;;; Obviously i'm not sure why. +;;; So we're going to explicitly initialize things. +;;; For now. --drewc + + (pushnew class *defined-descriptions*) + +;;; ENDHACK. + + (let* ((description (find-layer class)) + (attribute-objects + (setf (description-class-attributes (class-of description)) + (mapcar + (lambda (slot) + (or (find-attribute description + (slot-definition-name slot)) + (let* ((*init-time-description* description) + (attribute-class (or + (ignore-errors + (slot-value-using-class + (class-of description) description slot)) + 'standard-attribute)) + (attribute + (apply #'make-instance + attribute-class + :description description + :attribute-class attribute-class + (attribute-object-initargs slot)))) + (setf (slot-definition-attribute-object slot) attribute)))) + (remove 'described-object (class-slots (class-of description)) + :key #'slot-definition-name)))) + (defining-classes + (partial-class-defining-classes class))) + + (loop + :for (layer class) + :on defining-classes :by #'cddr + :do (funcall-with-layer-context + (adjoin-layer (find-layer layer) (current-layer-context)) + (lambda () + (loop :for direct-slot :in (class-direct-slots class) + :do (let ((attribute + (find (slot-definition-name direct-slot) + attribute-objects + :key #'attribute-name))) + (let ((initargs + (prepare-initargs attribute (direct-attribute-properties direct-slot)))) + + (apply #'reinitialize-instance attribute + initargs ) + (setf (slot-value description (attribute-name attribute)) + (attribute-class attribute)) + (apply #'change-class attribute (attribute-class attribute) + initargs))))))))) + + +#+old(defun initialize-description-class (class) + ;;; HACK: initialization does not happ en properly ;;; when compiling and loading or something like that. ;;; Obviously i'm not sure why. @@ -98,11 +150,12 @@ (mapcar (lambda (slot) (let* ((*init-time-description* description) - (attribute (apply #'make-instance + (attribute + (apply #'make-instance 'standard-attribute :description description (attribute-object-initargs slot)))) - + (setf (slot-definition-attribute-object slot) attribute))) (remove 'described-object (class-slots (class-of description)) @@ -125,14 +178,13 @@ (apply #'reinitialize-instance attribute initargs ) + (warn "Attribute class for ~A is ~A" attribute (attribute-class attribute)) (when (not (eq (find-class (attribute-class attribute)) (class-of attribute))) + (warn "~%CHANGING CLASS~%") (apply #'change-class attribute (attribute-class attribute) - initargs))) - - - ))))))) + initargs)))))))))) ;;;; HACK: run this at startup till we figure things out. (defun initialize-descriptions () diff --git a/src/description.lisp b/src/description.lisp index ae5850c..710771f 100644 --- a/src/description.lisp +++ b/src/description.lisp @@ -7,20 +7,24 @@ (defun description-print-name (description) (description-class-name (class-of description))) -(defun find-attribute (description attribute-name) - (when (slot-exists-p description attribute-name) - (slot-value description attribute-name))) - - (defun description-attributes (description) - (let ((class (class-of description))) - (loop :for slot :in (class-slots class) - :if (and - (not (eq 'described-object - (slot-definition-name slot)))) - :collect (slot-definition-attribute-object slot)))) - + (description-class-attributes (class-of description))) +(defun find-attribute (description attribute-name) + (find attribute-name (description-attributes description) + :key #'attribute-name)) + +(define-layered-function description-active-descriptions (description) + (:method ((description standard-description-object)) + (attribute-value (find-attribute description 'active-descriptions))) + (:method ((description attribute)) + (attribute-active-descriptions description))) + +(define-layered-function description-inactive-descriptions (description) + (:method ((description standard-description-object)) + (attribute-value (find-attribute description 'inactive-descriptions))) + (:method ((description attribute)) + (attribute-inactive-descriptions description))) (define-layered-function attributes (description) (:method (description) diff --git a/src/display.lisp b/src/display.lisp index f9998a7..423ee8c 100644 --- a/src/display.lisp +++ b/src/display.lisp @@ -4,16 +4,30 @@ (defvar *display*) (defvar *object* nil) - -(deflayer display-layer) - (define-layered-function display-using-description (description display object &rest args) (:documentation "Displays OBJECT via description using/in/with/on display")) -(defun display (display object &rest args &key attributes ) - (let ((*display-attributes* attributes)) - (apply #'display-using-description (description-of object) display object args))) + + +(defun modify-layer-context (context &key activate deactivate) + (dolist (d deactivate) + (setf context (remove-layer (find-description d) + context))) + (dolist (d activate context) + (setf context (adjoin-layer (find-description d) + context)))) + + + + +(defun display (display object &rest args &key deactivate activate &allow-other-keys) + (funcall-with-layer-context + (modify-layer-context (current-layer-context) + :activate activate + :deactivate deactivate) + (lambda () + (apply #'display-using-description (description-of object) display object args)))) (define-layered-method display-using-description :around (description display object &rest args) @@ -21,26 +35,37 @@ (let ((*description* description) (*display* display) (*object* object)) +; (<:as-html " " description "Layer Active?: " (layer-active-p (defining-description 'maxclaims::link-to-viewer))) (dletf (((described-object description) object)) - (contextl::funcall-with-special-initargs - (loop - :for (key val) :on args :by #'cddr - :collect (list (find key (description-attributes description) - :key #'attribute-keyword) - :value val)) - (lambda () - (contextl::funcall-with-special-initargs - (let ((attribute (find-attribute description 'active-attributes))) - (when attribute - (loop for spec in (attribute-value attribute) - if (listp spec) - collect (cons (or - (find-attribute description (car spec)) - (error "No attribute matching ~A" (car spec))) - (cdr spec))))) - (lambda () - (call-next-method)))))))) - + (flet ((do-display () + (contextl::funcall-with-special-initargs + (loop + :for (key val) :on args :by #'cddr + :collect (list (find key (description-attributes description) + :key #'attribute-keyword) + :value val)) + (lambda () + (contextl::funcall-with-special-initargs + (let ((attribute (ignore-errors (find-attribute description 'active-attributes)))) + (when attribute + (loop for spec in (attribute-value attribute) + if (listp spec) + collect (cons (or + (find-attribute description (car spec)) + (error "No attribute matching ~A" (car spec))) + (cdr spec))))) + (lambda () (call-next-method))))))) + (funcall-with-layer-context + (modify-layer-context + (if (standard-description-p description) + (adjoin-layer description (current-layer-context)) + (current-layer-context)) + :activate (description-active-descriptions description) + :deactivate (description-inactive-descriptions description)) + (function do-display)))))) + + + (defun display/d (&rest args) diff --git a/src/packages.lisp b/src/packages.lisp index b10abdb..21d2151 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -10,17 +10,22 @@ ;; ROFL stuff here temporarily #:standard-db-access-class - #:make-dao-from-row + #:make-object-from-plist #:described-db-access-class #:select-only #:select - + #:insert-into + #:select-objects + #:select-only-n-objects + ;; Descriptions #:find-description + #:description-of #:define-description #:described-object #:described-class #:with-active-descriptions + #:with-inactive-descriptions ;; Displays #:define-display @@ -35,6 +40,7 @@ #:attributes #:attribute-label #:attribute-function - #:attribute-value)) + #:attribute-value + #:active-attributes)) diff --git a/src/rofl-test.lisp b/src/rofl-test.lisp new file mode 100644 index 0000000..97342f4 --- /dev/null +++ b/src/rofl-test.lisp @@ -0,0 +1,178 @@ +(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 + (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-parent-id + :references rofl-test-parent) + (parent :column rofl-test-parent-id + :references rofl-test-parent) + (same-parent :column rofl-test-parent-id + :references (rofl-test-parent . + rofl-test-parent-id)) + + (test-string) + (test-integer)) + (:metaclass standard-db-access-class)))))) + +(deftest test-rofl-foreign-references () + (test-rofl-create-references-tables) + (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)))))) + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/src/rofl.lisp b/src/rofl.lisp index 4982223..3d73725 100644 --- a/src/rofl.lisp +++ b/src/rofl.lisp @@ -1,8 +1,46 @@ (in-package :lisp-on-lines) +;;;; 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 +(defun %query (query) + (cl-postgres:exec-query *database* (sql-compile query) 'symbol-plist-row-reader)) + +(defun select (&rest query) + (%query (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)))) + (defclass db-access-slot-definition () - ((column-name :initform nil :initarg :db-name :accessor slot-definition-column-name + ((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 @@ -34,9 +72,6 @@ that, for some reason, could not be executed. If there's a slot with this attribute not-NIL in a class definition, then there's something wrong with its SQL counterpart."))) -(defmethod slot-definition-column-name :around (slotd) - (or (call-next-method) (slot-definition-name slotd))) - (defclass db-access-class (standard-class) ((table-name :initarg :table-name :initform nil :accessor class-table-name) @@ -89,6 +124,11 @@ inheritance and does not create any tables for it.")) (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) @@ -146,6 +186,44 @@ inheritance and does not create any tables for it.")) (defclass standard-db-access-object (standard-object) ()) +(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) + (%select-objects type #'select query)) + +(defun select-only-n-objects (n type &rest query) + (let ((results (%query `(:limit ,(cons :select + (intern (format nil "*")) + (if (string-equal (first query) :from) + query + (append `(:from ,type) query))) ,n)))) + (if (eql 1 n) + (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 key slotds + :key #'slot-definition-column-name + :test-not #'string-equal)) + + (setf (slot-value-using-class class object slotd) val)) + :finally (return (reinitialize-instance object))))) + +(defun make-object (type &rest plist) + (make-object-from-plist type plist)) + (defun find-dao (type id @@ -154,20 +232,24 @@ inheritance and does not create any tables for it.")) "Get the dao corresponding to the given primary key, or return nil if it does not exist." - (let ((row (first (query - (:select '* + (let ((plist + (select-only 1 '* :from table - :where (:= id (or id-column-name + :where (list ':= id (or id-column-name (dao-id-column-name - (find-class type))))))))) - (make-dao-from-row type row))) + (find-class type))))))) + (make-object-from-plist type plist))) (defmethod shared-initialize :after ((dao standard-db-access-object) slots &rest initargs) - (let ((class (class-of 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) @@ -187,28 +269,6 @@ or return nil if it does not exist." (slot-value-using-class class dao (class-id-slot-definition class))))) -(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)))))) - - -(setf postmodern::*result-styles* - (nconc (list '(:plists symbol-plist-row-reader nil) - '(:plist symbol-plist-row-reader t)) - postmodern::*result-styles*)) - -(defun select (&rest query) - (query (sql-compile (cons :select query)) :plists)) - -(defun select-only (num &rest query) - (query (sql-compile `(:limit ,(cons :select query) ,num)) - :plists)) - (defun make-dao-from-row (type row &key slots) (let* ((class (find-class type)) (dao (make-instance class)) diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp index 0fc53af..dc056a1 100644 --- a/src/standard-descriptions/clos.lisp +++ b/src/standard-descriptions/clos.lisp @@ -14,7 +14,9 @@ :function (compose 'class-slots 'class-of)))) (define-layered-class slot-definition-attribute (standard-attribute) - ((slot-name :initarg :slot-name :accessor attribute-slot-name))) + ((slot-name :initarg :slot-name + :accessor attribute-slot-name + :layered t))) (defmethod shared-initialize :around ((object slot-definition-attribute) slots &rest args) @@ -29,7 +31,7 @@ (if (slot-boundp object (attribute-slot-name attribute)) (slot-value object (attribute-slot-name attribute)) - (gensym "UNBOUND-SLOT-"))) + +unbound-slot+)) (defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class))))) (let ((desc-class @@ -39,11 +41,12 @@ :collect `(:name ,(slot-definition-name slot) :attribute-class slot-definition-attribute :slot-name ,(slot-definition-name slot) - :label ,(slot-definition-name slot)) + :label ,(format nil + "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot))))) :into slots :collect (slot-definition-name slot) :into names :finally (return (cons `(:name active-attributes - :value ,names) + :value ',names) slots))) :metaclass 'standard-description-class))) diff --git a/src/standard-descriptions/edit.lisp b/src/standard-descriptions/edit.lisp index 6786ceb..0033502 100644 --- a/src/standard-descriptions/edit.lisp +++ b/src/standard-descriptions/edit.lisp @@ -14,12 +14,13 @@ (class :editp nil)) (:in-description editable)) -#+nil(define-layered-function (setf attribute-value) (v o a) - (:method (value object attribute) - (let ((setter (attribute-setter attribute))) - (if setter - (funcall setter value object) - (error "No setter in ~A for ~A" attribute object))))) +(define-layered-method (setf attribute-value-using-object) + :in-layer #.(defining-description 'editable)(value object attribute) + + (let ((setter (attribute-setter attribute))) + (if setter + (funcall setter value object) + (error "No setter in ~A for ~A" attribute object)))) (define-layered-class standard-attribute :in-layer #.(defining-description 'editable) @@ -43,9 +44,9 @@ (object (attribute standard-attribute)) (if (eq :inherit (%attribute-editp attribute)) - (attribute-value object (find-attribute - (attribute-description attribute) - 'editp)) + (attribute-value (find-attribute + (attribute-description attribute) + 'editp)) (%attribute-editp attribute))) diff --git a/src/standard-descriptions/inline.lisp b/src/standard-descriptions/inline.lisp dissimilarity index 67% index 9d05b65..b620fcd 100644 --- a/src/standard-descriptions/inline.lisp +++ b/src/standard-descriptions/inline.lisp @@ -1,16 +1,19 @@ -(in-package :lisp-on-lines) - -(define-description inline ()) - -(define-description t () - ((identity :label nil) - (active-attributes :value (identity))) - (:in-description inline)) - -(define-display :in-description inline ((description t)) - (format *display* "~{~A ~}" - (mapcar - (lambda (attribute) - (with-output-to-string (*display*) - (display-attribute *object* attribute))) - (attributes description)))) +(in-package :lisp-on-lines) + +(define-description inline ()) + +(define-description t () + ((identity :label nil) + (active-attributes :value '(identity)) + (attribute-delimiter :value ", ") + (label-formatter :value (curry #'format nil "~A: ")) + (value-formatter :value (curry #'format nil "~A"))) + (:in-description inline)) + +(define-layered-class standard-attribute + :in-layer #.(defining-description 'inline) + () + ()) + +(define-display :in-description inline ((description t)) + (call-next-method)) diff --git a/src/standard-descriptions/t.lisp b/src/standard-descriptions/t.lisp index eff4d4e..e5c6676 100644 --- a/src/standard-descriptions/t.lisp +++ b/src/standard-descriptions/t.lisp @@ -7,41 +7,72 @@ (active-attributes :label "Attributes" :value nil :activep nil - :keyword :attributes))) + :keyword :attributes) + (attribute-delimiter :label "Attribute Delimiter" + :value "~%" + :activep nil + :keyword :delimter) + (active-descriptions :label "Active Descriptions" + :value nil + :activep nil + :keyword :activate) + (inactive-descriptions :label "Inactive Descriptions" + :value nil + :activep nil + :keyword :deactivate) + (label-formatter :value (curry #'format nil "~A ")) + (value-formatter :value (curry #'format nil "~A")))) (define-layered-method description-of (any-lisp-object) (find-description 't)) -(define-layered-function display-attribute (object attribute) - (:method (object attribute) - (display-using-description attribute *display* object))) +(define-layered-function display-attribute (attribute) + (:method (attribute) + (display-using-description attribute *display* (attribute-object attribute)))) -(define-layered-function display-attribute-label (object attribute) - (:method (object attribute) - (format *display* "~A " (attribute-label attribute)))) +(define-layered-function display-attribute-label (attribute) + (:method (attribute) + (princ (funcall (attribute-label-formatter attribute) (attribute-label attribute)) + *display*))) -(define-layered-function display-attribute-value (object attribute) - (:method (object attribute) + +(define-layered-function display-attribute-value (attribute) + (:method (attribute) + (flet ((disp (val &rest args) + (apply #'display *display* val + :activate (attribute-active-descriptions attribute) + :deactivate (attribute-inactive-descriptions attribute) + args))) + (let ((val (attribute-value attribute))) - (if (eql val object) - (format *display* "~A " val) + (if (eql val (attribute-object attribute)) + (generic-format *display* (funcall (attribute-value-formatter attribute) val)) (with-active-descriptions (inline) - (display *display* val)))))) + (if (slot-boundp attribute 'active-attributes) + (disp val :attributes (slot-value attribute 'active-attributes)) + (disp val)))))))) (define-layered-method display-using-description ((attribute standard-attribute) display object &rest args) (declare (ignore args)) (when (attribute-label attribute) - (display-attribute-label object attribute)) - (display-attribute-value object attribute)) + (display-attribute-label attribute)) + (display-attribute-value attribute)) (define-display ((description t)) - (format *display* "~{~A~%~}" - (mapcar - (lambda (attribute) - (with-output-to-string (*display*) - (display-attribute *object* attribute))) - (attributes description)))) + (let ((attributes (attributes description))) + (display-attribute (first attributes)) + (dolist (attribute (rest attributes)) + (generic-format *display* + (attribute-value + (find-attribute description 'attribute-delimiter))) + (display-attribute attribute)))) + + +(define-display :around ((description t) (display null)) + (with-output-to-string (*display*) + (print (call-next-method) *display*))) + diff --git a/src/ucw/html-description.lisp b/src/ucw/html-description.lisp index 120d317..f05d010 100644 --- a/src/ucw/html-description.lisp +++ b/src/ucw/html-description.lisp @@ -2,6 +2,13 @@ (export '(html-description) (find-package :lisp-on-lines)) +(defvar *escape-html* t) + +(defmethod generic-format ((display lol-ucw:component) string &rest args) + (<:as-html (with-output-to-string (stream) + (apply #'call-next-method stream string args)))) + + (define-description html-description () ()) @@ -32,36 +39,54 @@ (when label (<:as-html (with-output-to-string (*display*) - (display-attribute-label object attribute)))))))) + (display-attribute-label attribute))))))) + (:method + :in-layer #.(defining-description 'inline) + (object attribute) + (let ((label (attribute-label attribute))) + (when label + (<:as-html + (with-output-to-string (*display*) + (display-attribute-label attribute))))))) (define-layered-function display-html-attribute-value (object attribute) (:method (object attribute) (<:span :class "lol-attribute-value" (<:as-html - (with-output-to-string (*display*) - (display-attribute-value object attribute)))) -)) + (display-attribute-value attribute)))) + + (:method + :in-layer #.(defining-description 'inline) (object attribute) + (display-attribute-value attribute))) (define-layered-function display-html-attribute (object attribute) + (:method (object attribute) - (<:div - :class (attribute-css-class attribute) - (when (attribute-dom-id attribute) - :id (attribute-dom-id attribute)) - (display-html-attribute-label object attribute) - (display-html-attribute-value object attribute) - (<:br))) - (:method :in-layer #.(defining-description 'inline) - (object attribute) - (<:span + (<:div + :class (attribute-css-class attribute) + (when (attribute-dom-id attribute) + :id (attribute-dom-id attribute)) + (display-html-attribute-label object attribute) + (display-html-attribute-value object attribute))) + + (:method + :in-layer #.(defining-description 'inline) + (object attribute) + (<:span :class (attribute-css-class attribute) (when (attribute-dom-id attribute) :id (attribute-dom-id attribute)) (display-html-attribute-label object attribute) - (<:as-html " ") - (display-html-attribute-value object attribute) - (<:as-html " ")))) + (display-html-attribute-value object attribute)))) + +(define-layered-method display-using-description + :in-layer #.(defining-description 'html-description) + :around ((attribute standard-attribute) display object &rest args) + (declare (ignore args)) + (display-html-attribute object attribute)) + + (define-layered-method display-html-attribute-value :in-layer #.(defining-description 'editable) (object attribute) @@ -69,14 +94,16 @@ (<:span :class "lol-attribute-value" (if (attribute-editp object attribute) - (