:serial t
- :depends-on (:lisp-on-lines :ucw :puri))
\ No newline at end of file
+ :depends-on (:lisp-on-lines :ucw :puri :parenscript))
\ No newline at end of file
(:file "packages")
- (:file "rofl")
+
(:file "utilities")
(:file "display")
(:file "list")
(:file "null")
(:file "clos")
+ (:file "validate")
)
:serial t))
:serial t))
:serial t
:depends-on (:contextl :arnesi :alexandria :parse-number
- ;;for rofl:
- :cl-postgres
- :simple-date-postgres
- :postmodern ))
+ ))
(defsystem :lisp-on-lines.test
(:file "description-test")
(:file "attribute-test")
(:file "display-test")
- (:file "rofl-test")
(:module :standard-descriptions
:components ((:file "edit-test"))
:serial t)
:depends-on (:lisp-on-lines :lisp-on-lines-ucw :stefil))
-(if (asdf:find-system :asdf-system-connections nil)
- (asdf:oos 'asdf:load-op :ucw-system-connections)
- (#+sbcl sb-int:style-warn #-sbcl warn "UCW suggests asdf-system-connections in order to optionally integrate some other libraries. See http://www.cliki.net/asdf-system-connections for details and download instructions."))
+
(attribute-class
:accessor attribute-class
:initarg :attribute-class
- :initform 'standard-attribute)
+ :initform 'standard-attribute)
(keyword
:layered-accessor attribute-keyword
:initarg :keyword
))
-#+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.
-;;; So we're going to explicitly initialize things.
-;;; For now. --drewc
-
- (pushnew class *defined-descriptions*)
-
-;;; ENDHACK.
-
- (let* ((description (find-layer class))
- (attribute-objects
- (mapcar
- (lambda (slot)
- (let* ((*init-time-description* description)
- (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))
- :key #'slot-definition-name)))
- (defining-classes (partial-class-defining-classes (class-of description))))
-
- (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 )
- (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))))))))))
;;;; HACK: run this at startup till we figure things out.
(defun initialize-descriptions ()
(defun find-attribute (description attribute-name &optional (errorp t))
(or (find attribute-name (description-attributes description)
:key #'attribute-name)
- (when errorp (error "No attribute named ~A found in ~A" attribute-name description))))
+ (when errorp (error "No attribute named ~A found in ~A describing ~A" attribute-name description (described-object description)))))
(define-layered-function description-active-descriptions (description)
(:method ((description standard-description-object))
:common-lisp
#:contextl
#:closer-mop
- #:postmodern
+
#:alexandria)
(:nicknames #:lol)
(:export
-;; ROFL stuff here temporarily
- #:standard-db-access-class
- #:standard-db-access-object
- #:make-object-from-plist
- #:described-db-access-class
- #:select-only
- #:select
- #:insert-into
- #:select-objects
- #:select-only-n-objects
- #:insert-object
- #:primary-key-boundp
;; Descriptions
#:find-description
#:active-attributes
#:attribute-delimiter
#:standard-attribute
+
;; Standard Library
;; editing
#:password-attribute-editor
#:password
+ ;; :validation
+ #:validation
+ #:validate
+ #:validp
+
+ ;; CLOS
+ #:slot-definition-attribute
+
;; html
#:display-html-attribute-editor
#:make-attribute-value-writer))
(postmodern:query (:CREATE-TABLE rofl_test_parent
((rofl_test_parent_id
:type SERIAL
- :primary-key t)
+ :primary-key t)
(test_string
:type string)
(test_integer
(defclass rofl-test-child ()
((rofl-test-child-id
+ :primary-key t) ((rofl_test_child_id
+ :type SERIAL
+ :primary-key t)
+ (rofl_test_parent_id
+ :type integer
+ :references (rofl_test_parent))
+ (test_string
+ :type string)
+ (test_integer
+ :type integer)))))))
+
+)
+
+
+(deftest test-rofl-def-references ()
+ (finishes
+ (eval
+ '(progn
+ (defclass rofl-test-parent ()
+ ((rofl-test-parent-id
:primary-key t)
- (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))))))
+ (:metaclass standard-db-access-class))
+
+ ;;; three ways to get to the parent.
+ ;;; The should all point to the same object.
-(deftest test-rofl-foreign-references ()
- (test-rofl-create-references-tables)
(test-rofl-def-references-classes)
(db
(finishes
(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))))))
+ (is (equal 1 (slot-value parent-column-table-and-key 'test-integer)))))))))
:accessor attribute-slot-name
:layered t)))
+
+(define-layered-method attribute-active-p :around ((attribute slot-definition-attribute))
+ (let ((active? (slot-value attribute 'activep)))
+ (if (and (eq :when active?)
+ (unbound-slot-value-p (attribute-value attribute)))
+ NIL
+
+ (call-next-method))))
+
+(define-layered-method attribute-active-p
+ :in-layer #.(defining-description 'editable)
+ :around ((attribute slot-definition-attribute))
+ (let ((active? (slot-value attribute 'activep)))
+ (if (and (eq :when active?)
+ (unbound-slot-value-p (attribute-value attribute)))
+ t
+ (call-next-method))))
+
(defmethod shared-initialize :around ((object slot-definition-attribute)
slots &rest args)
(prog1 (call-next-method)
(parser :initarg :parse-using
:initform 'identity
:accessor attribute-editor-parsing-function)
+ (attributes :initarg :attributes
+ :initform nil
+ :accessor attribute-editor-attributes)
(prompt :initarg :prompt
:initform nil)
(unbound-value
(defpackage lisp-on-lines-ucw
(:documentation "An LoL Layer over ucw.basic")
(:nicknames #:lol-ucw)
- (:use #:lisp-on-lines #:ucw :common-lisp :arnesi :yaclml)
- (:shadow
- #:standard-window-component
- #:make-action
- #:standard-action
- #:uri-parse-error
- #:standard-application
-
- #:call
- #:answer)
-
- (:shadowing-import-from :ucw
- #:parent)
+ (:use #:lisp-on-lines #:ucw-core :common-lisp :arnesi :yaclml :js :contextl)
+
+ (:shadowing-import-from :js
+ #:new)
+ (:shadowing-import-from :ucw-core
+ #:parent )
+ (:import-from :ucw-standard
+ #:call #:answer #:defaction #:*source-component*)
- (:import-from :ucw
- #:register-action-in-frame
- #:+action-parameter-name+
- #:context.current-frame
- #:uri.query
- #:*current-component*
- #:find-action
- #:service)
+
(:export
;;; First, LOL-UCW exports. The rest are from UCW.
#:lol-component
-
+ #:*source-component*
#:defcomponent
#:uri.query
-(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)
- (let ((child *source-component*))
- (setf *source-component* (ucw::component.calling-component child))
- (answer-component child val)))
-
-(defclass described-component-class (described-class standard-component-class )
- ())
-
-(defmacro defaction (&rest args-and-body)
- `(arnesi:defmethod/cc ,@args-and-body))
-
-(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)
- ())
-
-(defclass standard-request-context (ucw::standard-request-context)
- ())
-
-(defmethod ucw:request-context-class list ((application standard-application))
- 'standard-request-context)
-
-(defvar +action-compound-name-delimiter+ #\|)
-
-(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)
- (split-sequence:split-sequence
- +action-compound-name-delimiter+ k)
- (when (and action-id
- (string=
- ucw::+action-parameter-name+ param-name))
- (return action-id))))
- (call-next-method)))
-
-
-
-
-
-(defcomponent standard-window-component
- (ucw::basic-window-component)
- ((body
- :initform nil
- :accessor window-body
- :component t
- :initarg :body)))
-
-(defmethod render-html-head ((window standard-window-component))
- (let* ((app (context.application *context*))
- (url-prefix (application.url-prefix app)))
- (<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
- (awhen (window-component.title window)
- (<:title (if (functionp it)
- (funcall it window)
- (<:as-html it))))
- (awhen (window-component.icon window)
- (<:link :rel "icon"
- :type "image/x-icon"
- :href (concatenate 'string url-prefix it)))
- (dolist (stylesheet (effective-window-stylesheets window))
- (<:link :rel "stylesheet"
- :href stylesheet
- :type "text/css"))))
-
-(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"))
-
-
+(in-package :lisp-on-lines-ucw)
+
+(defclass lisp-on-lines-action (ucw-standard::standard-action)
+ ((layer-context :accessor action-layer-context
+ :initform nil
+ :initarg :layer-context))
+ (:metaclass closer-mop:funcallable-standard-class))
+
+
+(setf ucw-standard::*default-action-class* 'lisp-on-lines-action)
+
+
+
+(defmethod ucw-core:call-action :around ((action lisp-on-lines-action) application session frame)
+ (let ((next-method (lambda ()
+ (layered-call-action
+ action application session frame
+ (lambda ()
+ (call-next-method))))))
+ (let ((layer-context (action-layer-context action)))
+ (if layer-context
+ (funcall-with-layer-context layer-context next-method)
+ (funcall next-method)))
+ ))
+
+(defmethod ucw-core:handle-action :around ((action lisp-on-lines-action) application session frame)
+ (let ((lol::*invalid-objects* (make-hash-table)))
+ (handler-bind ((lol::validation-condition
+ (lambda (c)
+ (let ((object (lol::validation-condition-object c))
+ (attribute (lol::validation-condition-attribute c)))
+
+
+ (setf (gethash object lol::*invalid-objects*)
+ (cons (cons attribute c)
+ (gethash object lol::*invalid-objects*)))))))
+ (call-next-method))))
+
+
+(define-layered-function layered-call-action (action application session frame next-method)
+ (:method (action application session frame next-method)
+ (funcall next-method)))
+
+
+(contextl:define-layered-method layered-call-action
+ :in-layer #.(lol::defining-description 'lol::validate)
+ :around ((action lisp-on-lines-action) application session frame next-method)
+ (call-next-method)
+
+ )
+
+
+
+(defclass described-component-class (described-class standard-component-class )
+ ())
+
+
+
+(defcomponent standard-window-component
+ (ucw-standard::basic-window-component)
+ ((body
+ :initform nil
+ :accessor window-body
+ :component t
+ :initarg :body)))
+
+(defmethod render-html-head ((window standard-window-component))
+ (let* ((app (context.application *context*))
+ (url-prefix (application.url-prefix app)))
+ (<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
+ (awhen (window-component.title window)
+ (<:title (if (functionp it)
+ (funcall it window)
+ (<:as-html it))))
+ (awhen (window-component.icon window)
+ (<:link :rel "icon"
+ :type "image/x-icon"
+ :href (concatenate 'string url-prefix it)))
+ (dolist (stylesheet (effective-window-stylesheets window))
+ (<:link :rel "stylesheet"
+ :href stylesheet
+ :type "text/css"))))
+
+(defmethod render-html-body ((window standard-window-component))
+ (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"))
+
+
HCoop / clinton / lisp-on-lines.git / commitdiff