: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
:serial t))
:serial t
- :depends-on (:contextl :arnesi :alexandria :postmodern))
+ :depends-on (:contextl :arnesi :alexandria
+ ;;for rofl:
+ :postmodern :simple-date))
(:file "description-test")
(:file "attribute-test")
(:file "display-test")
+ (:file "rofl-test")
(:module :ucw
:components ((:file "ucw-test"))
:serial t))
(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
(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)))))
+
(unbound-slot ()
(or
*init-time-description*
-q (call-next-method)))))
+ (call-next-method)))))
(define-layered-class attribute ()
((description :initarg :description
(attribute-class
:accessor attribute-class
:initarg :attribute-class
- :initform 'standard-attribute
- :layered t)
+ :initform 'standard-attribute)
(keyword
:layered-accessor attribute-keyword
:initarg :keyword
:special t)))
-
-
(define-layered-class standard-attribute (attribute)
((label
:layered-accessor attribute-label
: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
: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))
(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)
(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)
(: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)
(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
(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
;;;; 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
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))
(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.
(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))
(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 ()
(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)
(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)
(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)
;; 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
#:attributes
#:attribute-label
#:attribute-function
- #:attribute-value))
+ #:attribute-value
+ #:active-attributes))
--- /dev/null
+(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
(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
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)
(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)
(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
"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)
(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))
: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)
(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
: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)))
(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)
(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)))
-(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))
(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*)))
+
(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 ()
())
(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)
(<:span
:class "lol-attribute-value"
(if (attribute-editp object attribute)
- (<lol:input :reader (attribute-value object attribute)
- :writer (lambda (val)
- (setf (attribute-value object attribute) val)))
+ (<lol:input :reader (attribute-value attribute)
+ :writer (let ((obj (described-object (attribute-description attribute))))
+ (lambda (val)
+ (dletf (((described-object attribute) obj))
+ (setf (attribute-value attribute) val)))))
(call-next-method))
))
-(define-layered-function display-html-description (description display object)
- (:method (description display object)
+(define-layered-function display-html-description (description display object &optional next-method)
+ (:method (description display object &optional (next-method #'display-using-description))
(<:style
(<:as-html "
(<:div
- :class (list (attribute-value* css-class) "lol-description" "t")
- :id (attribute-value* dom-id)
- (unless *object* (error "Object is nil .. why?"))
- (dolist (attribute (attributes description))
- (display-html-attribute *object* attribute))))))
+ :class (list (attribute-value css-class) "lol-description" "t")
+ :id (attribute-value dom-id)
+ (funcall next-method)))))
(define-layered-method display-html-description
- :in-layer #.(defining-description 'inline) (description display object)
-
+ :in-layer #.(defining-description 'inline) (description display object &optional next-method)
(with-attributes (css-class dom-id) description
-
-
(<:span
- :class (list (attribute-value* css-class) "lol-description")
- :id (attribute-value* dom-id)
- (unless *object* (error "Object is nil .. why?"))
- (dolist (attribute (attributes description))
- (display-html-attribute *object* attribute))))
- )
+ :class (list (attribute-value css-class) "lol-description")
+ :id (attribute-value dom-id)
+ (funcall next-method))))
+
(define-display
:in-description html-description ((description t)
(display lol-ucw:component)
object)
- (display-html-description description display object))
+ (display-html-description description display object (lambda ()
+ (call-next-method))))
+
+
+
+
+
#:make-action
#:standard-action
#:uri-parse-error
- #:standard-application)
+ #:standard-application
+
+ #:call
+ #:answer)
(:shadowing-import-from :ucw
#:parent)
#:service)
(:export
- ;;; Symbols marked ";*" are not from UCW
- ;;; but either shadowed or created for lol.
+
+ ;;; First, LOL-UCW exports. The rest are from UCW.
+ #:lol-component
#:defcomponent
;; Actions
#:call
+ #:answer
#:make-action
#:find-action
#:defaction
#:standard-window-component ;*
#:window-body
+ #:info-message
))
(in-package :lisp-on-lines-ucw)
+(defparameter *source-component* nil)
+
+(defclass standard-basic-action (basic-action)
+ ((source-component :accessor action-source-component))
+ (:metaclass mopp:funcallable-standard-class))
+
+(defmethod shared-initialize :before ((action standard-basic-action) slots &rest args)
+ (declare (ignore slots args))
+ (setf (action-source-component action) *source-component*))
+
+(defmethod handle-action :around ((action standard-basic-action) a s f)
+ (let ((*source-component* (action-source-component action)))
+ (call-next-method)))
+
+(defmethod render :around (component)
+ (let ((*source-component* component))
+ (call-next-method)))
+
+
+(defun/cc call (name &rest args)
+ (call-component *source-component*
+ (apply #'make-instance name args)))
+
+(defun/cc answer (&optional val)
+ (answer-component *source-component*
+ val))
+
(defclass described-component-class (standard-component-class described-class)
())
(defmacro defaction (&rest args-and-body)
`(arnesi:defmethod/cc ,@args-and-body))
-(defun make-action (lambda &rest args)
- (let ((ucw::*default-action-class* 'basic-action))
- (apply #'ucw::make-action lambda args)))
+(defparameter *default-action-class* 'standard-basic-action)
+
+(defun make-action (lambda &rest initargs &key (class *default-action-class*) &allow-other-keys)
+ "Makes a new unregistered action."
+ (remf-keywords initargs :class)
+ (apply #'make-instance class :lambda lambda initargs))
+
(defclass standard-application (ucw:basic-application)
())
(defmethod ucw::find-action-id :around ((context standard-request-context))
(or
(loop
-
:for (k . v) in (ucw::parameters
(context.request context))
:do(destructuring-bind (param-name &optional action-id)
(defmethod render-html-body ((window standard-window-component))
(ucw:render (window-body window)))
+
+(defcomponent info-message ()
+ ((message :accessor message :initarg :message)))
+
+(defmethod render ((m info-message))
+ (<:div
+ :class "info-mssage"
+ (<:as-html (message m)))
+ (<lol:a :action (answer-component m nil) "Ok"))
+
+
(<:li
(<lol:a
:action (call-component $component (make-instance 'lol-test-answer))
- "Test CALL/ANSWER"))
+ "Test CALL-COMPONENT/ANSWER-COMPONENT"))
+ (<:li
+ (<lol:a
+ :action (call-component $component (make-instance 'lol-test-call-magic))
+ "Test CALL/ANSWER MAGIC"))
+ (<:li
+ (<lol:a
+ :action (call-component $component (make-instance 'lol-test-call-answer-action-magic))
+ "Test CALL/ANSWER ACTION MAGIC"))
(<:li
(<lol:a
:action (call-component $component (make-instance 'lol-test-simple-form))
(<:li
(<lol:a
:action (call-component $component (make-instance 'lol-test-input))
- "Test Form input"))))
+ "Test Form input"))
+))
(defcomponent lol-test-answer (lol-test-render) ()
(:default-initargs :message "CALL was ok. Go Back will answer"))
+(defcomponent lol-test-call-magic (lol-test-render)
+ ()
+ (:default-initargs :message "Testing CALL magic."))
+
+(defmethod render :wrapping ((self lol-test-call-magic))
+ (call-next-method)
+ (<lol:a :action (setf (message self) (call 'lol-test-answer-magic)) "Test CALL")
+ (<:br)
+ (<lol:a :action (answer-component self nil) "Go Back."))
+
+
+
+(defcomponent lol-test-answer-magic (lol-test-render)
+ ()
+ (:default-initargs :message "Hit it to answer"))
+
+(defmethod render :wrapping ((self lol-test-answer-magic))
+ (call-next-method)
+
+ (<lol:a :action (answer "Ja, dat is vut ve answer" ) "IT! (hit here)"))
+
+(defcomponent lol-test-call-answer-action-magic (lol-test-render)
+ ()
+ (:default-initargs :message "Hit it to answer"))
+
+(defaction test-call-component ()
+ (call 'lol-test-call-answer-action-magic :message "We made it"))
+
+(defaction test-answer-component ()
+ (answer "We Made IT BACK!!!"))
+
+(defmethod render :wrapping ((self lol-test-call-answer-action-magic))
+ (call-next-method)
+ (<lol:a :action (test-call-component) "Test CALL from ACTION")
+ (<:br)
+ (<lol:a :action (test-answer-component) "Test ANSWER from ACTION"))
+
(in-package :lisp-on-lines)
+(defgeneric generic-format (stream string &rest args)
+ (:method (stream string &rest args)
+ (apply #'format stream string args)))
+
+
+
+
(defun make-enclosing-package (name)
(make-package name :use '()))
`(with-active-layers ,(mapcar #'defining-description descriptions)
,@body))
+
+(defmacro with-inactive-descriptions (descriptions &body body)
+ `(with-inactive-layers ,(mapcar #'defining-description descriptions)
+
+ ,@body))
+
#|
Descriptoons are represented as ContextL classes and layers. To avoid nameclashes with other classes or layers, the name of a description is actually mappend to an internal unambiguous name which is used instead of the regular name.
|#
(defun find-slot-using-initarg (class initarg)
(cdr (assoc-if #'(lambda (x) (member initarg x))
(initargs.slots class))))
+
+(defun ensure-class-finalized (class)
+ (unless (class-finalized-p class)
+ (finalize-inheritance class)))
+
+(defun superclasses (class)
+ (ensure-class-finalized class)
+ (rest (class-precedence-list class)))
HCoop / clinton / lisp-on-lines.git / commitdiff