From: drewc Date: Fri, 7 Nov 2008 04:15:39 +0000 (-0800) Subject: remobe ROFL and add validation X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/commitdiff_plain/e8fd1a9a2f3b68a8aee14b8776ff8398ba717eef?hp=a5a635a2ec9a1187c8ebd30c0baab32dd70bd593;ds=sidebyside remobe ROFL and add validation darcs-hash:20081107041539-39164-3dd97bbf55919053c22181005354ca230e17a633.gz --- diff --git a/lisp-on-lines-ucw.asd b/lisp-on-lines-ucw.asd index 5abc5d4..92d4d78 100644 --- a/lisp-on-lines-ucw.asd +++ b/lisp-on-lines-ucw.asd @@ -22,4 +22,4 @@ :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 diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index f4af77b..1d74b1d 100644 --- a/lisp-on-lines.asd +++ b/lisp-on-lines.asd @@ -42,7 +42,7 @@ OTHER DEALINGS IN THE SOFTWARE." (:file "packages") - (:file "rofl") + (:file "utilities") (:file "display") @@ -62,6 +62,7 @@ OTHER DEALINGS IN THE SOFTWARE." (:file "list") (:file "null") (:file "clos") + (:file "validate") ) :serial t)) @@ -69,10 +70,7 @@ OTHER DEALINGS IN THE SOFTWARE." :serial t)) :serial t :depends-on (:contextl :arnesi :alexandria :parse-number - ;;for rofl: - :cl-postgres - :simple-date-postgres - :postmodern )) + )) (defsystem :lisp-on-lines.test @@ -81,7 +79,6 @@ OTHER DEALINGS IN THE SOFTWARE." (:file "description-test") (:file "attribute-test") (:file "display-test") - (:file "rofl-test") (:module :standard-descriptions :components ((:file "edit-test")) :serial t) @@ -98,6 +95,4 @@ OTHER DEALINGS IN THE SOFTWARE." :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.")) + diff --git a/src/attribute.lisp b/src/attribute.lisp index 8f3f862..7273260 100644 --- a/src/attribute.lisp +++ b/src/attribute.lisp @@ -69,7 +69,7 @@ (attribute-class :accessor attribute-class :initarg :attribute-class - :initform 'standard-attribute) + :initform 'standard-attribute) (keyword :layered-accessor attribute-keyword :initarg :keyword diff --git a/src/description-class.lisp b/src/description-class.lisp index d874d82..e599444 100644 --- a/src/description-class.lisp +++ b/src/description-class.lisp @@ -144,58 +144,6 @@ )) -#+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 () diff --git a/src/description.lisp b/src/description.lisp index d373ace..073dc94 100644 --- a/src/description.lisp +++ b/src/description.lisp @@ -31,7 +31,7 @@ (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)) diff --git a/src/packages.lisp b/src/packages.lisp index 431c011..54a34af 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -3,23 +3,11 @@ :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 @@ -52,6 +40,7 @@ #:active-attributes #:attribute-delimiter #:standard-attribute + ;; Standard Library ;; editing @@ -62,6 +51,14 @@ #:password-attribute-editor #:password + ;; :validation + #:validation + #:validate + #:validp + + ;; CLOS + #:slot-definition-attribute + ;; html #:display-html-attribute-editor #:make-attribute-value-writer)) diff --git a/src/rofl-test.lisp b/src/rofl-test.lisp index 97342f4..9dc74e1 100644 --- a/src/rofl-test.lisp +++ b/src/rofl-test.lisp @@ -83,7 +83,7 @@ (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 @@ -119,21 +119,34 @@ (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 @@ -150,7 +163,7 @@ (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))))))))) diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp index 1518392..4bb7abe 100644 --- a/src/standard-descriptions/clos.lisp +++ b/src/standard-descriptions/clos.lisp @@ -18,6 +18,24 @@ :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) diff --git a/src/standard-descriptions/edit.lisp b/src/standard-descriptions/edit.lisp index 3c04a92..f7e0411 100644 --- a/src/standard-descriptions/edit.lisp +++ b/src/standard-descriptions/edit.lisp @@ -51,6 +51,9 @@ (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 diff --git a/src/ucw/packages.lisp b/src/ucw/packages.lisp index 935acb7..0a35539 100644 --- a/src/ucw/packages.lisp +++ b/src/ucw/packages.lisp @@ -2,34 +2,22 @@ (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 diff --git a/src/ucw/standard-components.lisp b/src/ucw/standard-components.lisp dissimilarity index 63% index 533e8fd..c017657 100644 --- a/src/ucw/standard-components.lisp +++ b/src/ucw/standard-components.lisp @@ -1,111 +1,96 @@ -(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))) - (