+++ /dev/null
-LISP-ON-LINES : A system from rapid web application development.
-
-Copyright(c) Drew Crampsie, 2004-2005
-With funding from The Tech Co-op (http://tech.coop)
-
-LISP-ON-LINES is licensed under the terms of the Lisp Lesser GNU
-Public License (http://opensource.franz.com/preamble.html), known as
-the LLGPL. The LLGPL consists of a preamble (see above URL) and the
-LGPL. Where these conflict, the preamble takes precedence.
-LISP-ON-LINES is referenced in the preamble as the "LIBRARY."
+++ /dev/null
-LISP-ON-LINES
-
-This is a very early release, and there are more bugs then docs. HERE BE DRAGONS!
-
-Having said that, LOL has been used to deliver applications and is undergoing extensive development.
-
-Take a look at the doc/ directory to get started. The (poorly commented) code is your next stop.
-Adding docstrings would be a good idea.
-
-drewc@tech.coop or #tech.coop on freenode for support.. that we have plenty of.
-
-;; This software is Copyright (c) Drew Crampsie, 2004-2005.
-;; You are granted the rights to distribute
-;; and use this software as governed by the terms
-;; of the Lisp Lesser GNU Public License
-;; (http://opensource.franz.com/preamble.html),
-;; known as the LLGPL.
-
(in-package :coop.tech.systems)
(defsystem :lisp-on-lines
+ :license
+"Copyright (c) 2004-2007 Drew Crampsie
+
+Contains portions of ContextL:
+Copyright (c) 2005 - 2007 Pascal Costanza
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the \"Software\"), to deal in the Software without
+restriction, including without limitation the rights to use,
+copy, modify, merge, publish, distribute, sublicense, and/or
+sell copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following
+conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE."
:components ((:static-file "lisp-on-lines.asd")
- (:module :patches
- :components ((:file "yaclml")
- (:file "ucw")
- (:file "clsql")))
+
(:module :src
:components ((:file "packages")
- (:file "special-initargs")
- (:file "properties")
- (:file "mewa")
+ (:file "utilities")
+ (:file "display")
+
+ (:file "attributes")
+
+ (:file "description-class")
+ (:file "description")
+
+
+ (:file "description-test")
+ (:file "attribute-test")
+#| (:file "mewa")
(:file "lisp-on-lines")
(:file "defdisplay")
(:file "standard-display")
(:file "relational-attributes")
(:file "dojo-attributes"))
:serial t)
+ (:module :displays
+ :components ((:file "inspector"))
+
+ :serial t)
(:module :validation
:components
((:file "validation")
(:file "standard-validation")
(:file "email-address"))
- :serial t)
+ :serial t)|#
)
:serial t))
:serial t
- :depends-on (:arnesi :ucw :meta-model :split-sequence :contextl :cl-ppcre :cl-fad))
+ :depends-on (:contextl
+ :stefil
+ :arnesi ;:ucw :stefil :meta-model :split-sequence :cl-ppcre :cl-fad
+ ))
(defsystem :lisp-on-lines.example
:components (
+++ /dev/null
-(in-package :yaclml)
-
-(defun funcall-with-tag (tag-spec thunk)
- (let ((%yaclml-code% nil)
- (%yaclml-indentation-depth% 0))
- (declare (special %yaclml-code%))
- ;; build tag's body
- (dolist (i (fold-strings
- (nreverse
- (funcall (gethash (car (ensure-list tag-spec)) *expanders*)
- (append (cdr tag-spec) (list
- thunk))))))
- (if (functionp i)
- (funcall i)
- (write-string i *yaclml-stream*)))))
\ No newline at end of file
+++ /dev/null
-(in-package :lol)
-
-(defvar *lol-example-application*
- (make-instance 'cookie-session-application
- :url-prefix "/lisp-on-lines/"
- :tal-generator (make-instance 'yaclml:file-system-generator
- :cachep t
- :root-directories (list *ucw-tal-root*))
- :www-roots (list (merge-pathnames "./" *ucw-tal-root*))
- :debug-on-error t))
-
-(defentry-point "reddit" (:application *lol-example-application*) ()
- (call 'front-page))
-
-(defcomponent front-page (simple-window-component)
- ()
- (:default-initargs
- :javascript "/dojo/dojo.js"))
-
-(defmethod render ((self front-page))
- (with-component (self)
- (<:h1 (<:as-html "Lisp on Lines : Reddit Example"))
-
- (<ucw:a :action (add-link self)
- (<:as-html "Add Lispy Link"))
- (<:div
- :class "main"
- (display (find-links)
- :attributes '(link
- (submitter :label "Submitted By :")
- (score :label "Score :")
- buttons)))))
-
-(defclass/meta link ()
- ((url :accessor url :initarg :url :type string)
- (title :accessor title :initarg :title :type string)
- (submitter :accessor submitter :initarg :submitter :type string)
- (score :accessor score :initarg :score :type integer :initform 0)))
-
-(define-attributes (link)
- (link link :label "")
- (buttons score-buttons :label ""))
-
-(defvar *links* (list))
-
-(defmethod/cc add-link ((self component))
- (let ((l (call-display (make-instance 'link)
- :type 'editor)))
- (when l (push l *links*))))
-
-(defun find-links ()
- (sort (copy-list *links*) #'> :key #'score))
-
-(defattribute link-attribute ()
- ()
- (:type-name link))
-
-(defdisplay (:description (link link-attribute))
- (<:a :href (url object)
- (<:as-html (title object))))
-
-(defattribute score-buttons ()
- ()
- (:type-name score-buttons))
-
-(defdisplay (:description (score score-buttons))
- (<ucw:a
- :action (incf (score object))
- (<:as-html "Up " ))
- (<ucw:a
- :action (decf (score object))
- (<:as-html " Down" )))
-
-
-(defdisplay (:combination :around :in-layer editor :class link)
- (with-component (component)
-
- (<ucw:form
- :action (refresh-component component)
- (<:h2 (<:as-html "Add a new Link"))
- (call-next-method)
- (<ucw:submit
- :action (answer link)
- :value "Ok")
- (<ucw:submit
- :action (answer nil)
- :value "Cancel"))))
-
-
-;;;; We are going to use a POSTGRES database.
-;;;; It's a good idea to have created it already.
-
-;; template1=# CREATE USER lol PASSWORD 'lol';
-;; CREATE USER
-;; template1=# CREATE DATABASE lol OWNER lol;
-;; CREATE DATABASE
-;; template1=#
-
-
+++ /dev/null
-(in-package :lisp-on-lines)
-
-(deflayer dojo)
-
-#+nil(define-layered-class
- description :in-layer dojo ()
- ((dojo-type :accessor dojo-type :initarg :dojo-type :initform nil :special t)))
-
-(define-layered-function display-as-dojo-type (type description object component))
-
-(defdisplay
- :in-layer dojo :after (description object)
- (when (dojo-type description)
- (display-as-dojo-type (dojo-type description) description object self)))
-
-(defcomponent combo-results ()
- ())
-
-(defmethod render ((self combo-results))
- (<:as-is (js:js* `(array
- ,@(loop for r in (results self)
- for n upfrom 0
- collect `(array ,
- (with-output-to-string (s)
- (yaclml:with-yaclml-stream s
- (display self r :type 'as-string)))
- ,n))))))
-
-
-(define-layered-method display-as-dojo-type ((type (eql 'combo-box)) attribute object component)
-
- (let* ((search-function (search-function attribute))
- (select-function (select-function attribute))
- (select-callback (ucw::make-new-callback
- (lambda (x)
- (funcall select-function
- (parse-integer x))))))
- "The combo box widget"
- (<ucw:script
- `(dojo.require "dojo.*")
- `(dojo.require "dojo.widget.*")
- `(dojo.require "dojo.widget.html.ComboBox")
- (js:with-unique-js-names (element combo-box)
-
- `(dojo.add-on-load
- (lambda ()
- (setf ,element (dojo.by-id ,(id attribute)))
- (setf ,combo-box
- (dojo.widget.from-script
- "ComboBox"
- (create
- :data-url (+ , (lol::make-action-url
- component
- (call-component
- (context.window-component *context*)
- (make-instance 'combo-results
- :results
- (funcall search-function
- (attribute-value object attribute)))))
- "&"
- ,(escape-as-uri (callback attribute))
- "=%{searchString}")
- :mode "remote")
- ,element))
- ((slot-value ,combo-box 'set-value) (slot-value ,element 'value))
- (dojo.event.connect
- ,combo-box "selectOption"
- (lambda ()
- (setf (slot-value ,element 'value)
- (slot-value ,combo-box 'selected-result))
- (dojo.io.bind
- (create
- :url (+ ,(lol::make-action-url
- component
- nil)
- "&"
- ,(escape-as-uri (callback attribute))
- "="
- (slot-value ,combo-box 'selected-result)
- "&"
- ,select-callback
- "="
- (slot-value ,combo-box 'combo-box-selection-value.value))))))))))))
-
\ No newline at end of file
+++ /dev/null
-(in-package :lisp-on-lines)
-
-(defattribute number-attribute (base-attribute)
- ()
- (:type-name number))
-
-;;;; INTEGER
-(defattribute integer-attribute (number-attribute)
- ()
- (:type-name integer))
-
-(defattribute integer-attribute (number-attribute integer-field)
- ()
- (:in-layer editor)
- (:default-initargs
- :default-value ""
- :default-value-predicate (complement #'numberp))
- (:type-name integer))
-
-
-(define-layered-method (setf attribute-value) ((value string) object (attribute integer-attribute))
- (let ((*read-eval* nil))
- (unless (string= "" value)
- (let ((value (read-from-string value)))
- (when (numberp value)
- (setf (attribute-value object attribute) value))))))
-
-;;;; REALS
-
-(defattribute real-attribute (number-attribute)
- ()
- (:type-name real))
-
-(define-layered-method (setf attribute-value) ((value string) object (attribute real-attribute))
- (let ((*read-eval* nil))
- (unless (string= "" value)
- (let ((value (read-from-string value)))
- (when (numberp value)
- (setf (attribute-value object attribute) value))))))
-
-
-;;;; Currency
-(defattribute currency-attribute (real-attribute)
- ()
- (:type-name currency))
-
-
-(defdisplay
- :in-layer t
- ((currency currency-attribute) object)
-
- (<:as-html (format nil "$~$" (or (attribute-value object currency) ""))))
-
-(defdisplay
- :in-layer editor
- ((currency currency-attribute) object)
- (LET ((value (attribute-value (object currency) currency)))
- (<:input
- :NAME
- (callback currency)
- :VALUE (escape-as-html (strcat (display-value currency value)))
- :TYPE
- "text"))
- )
+++ /dev/null
-(in-package :lisp-on-lines)
-
-;;;; * Relational Attributes
-
-
-(defvar *parent-relations* nil)
-
-;;;; ** has-a
-;;;; Used for foreign keys, currently only works with clsql.
-
-(defattribute relational-attribute ()
- ())
-
-(defdisplay :wrap-around ((attribute relational-attribute) object)
- (print (cons "parent-r" *parent-relations*))
- (dletf (((value attribute) (attribute-value object attribute)))
- (unless (find (value attribute) *parent-relations* :test #'meta-model::generic-equal)
- (call-next-method))))
-
-(defattribute has-a (relational-attribute)
- ()
- (:default-properties
- :has-a nil
- :test 'meta-model::generic-equal))
-
-;;
-(define-layered-method attribute-value (object (attribute has-a))
- (multiple-value-bind (obj key class)
- (meta-model:explode-foreign-key object (slot-name attribute) :nilp t)
- (if (persistentp object)
- obj
- (first (select class
- :where [= [slot-value class key] (call-next-method)]
- :flatp t
- )))))
-
-(define-layered-method (setf attribute-value) ((value standard-object) object (attribute has-a))
- (let ((val (slot-value value (find-if (curry #'primary-key-p value) (list-keys value)))))
- (setf (attribute-value object attribute) val)))
-
-(define-layered-function find-all-foreign-objects (o a))
-
-(define-layered-method find-all-foreign-objects (object (attribute has-a))
- (select (meta-model:find-join-class object (slot-name attribute)) :flatp t))
-
-(defdisplay ((attribute has-a) object)
- (let ((args (plist-union (description.properties attribute) (has-a attribute)))
- (val (attribute-value object attribute)))
- (when val
- (setf (getf args :type)
- 'lol::one-line))
- (apply #'display* val
- args)))
-
-
-(defdisplay
- :in-layer editor ((attribute has-a) object)
- (<ucw:select
- :accessor (attribute-value object attribute)
-
- :test (test attribute)
- (dolist* (obj (find-all-foreign-objects object attribute))
- (<ucw:option
- :value obj
- (display* obj :layers '(+ as-string))))))
-
-;;;; ** Has-Many attribute
-
-(defattribute has-many ()
- ()
- (:default-properties
- :add-new-label "Add New"
- :has-many nil
- :sort-arguments (list #'< :key #'(lambda (x) (funcall (car (list-keys x)) x))))
- (:default-initargs
- :type 'lol::one-line))
-
-(define-layered-method
- attribute-value (object (has-many has-many))
- (slot-value object (slot-name has-many)))
-
-
-(defdisplay ((attribute has-many) object)
- ;
- ;(<ucw:submit :action (add-to-has-many slot instance) :value (add-new-label attribute))
-
- (<:div :style "clear:both;"
- (let* ((i (apply #'sort (slot-value object (slot-name attribute))
- (sort-arguments attribute)))
- (*parent-relations* (cons object *parent-relations*)))
-
- (apply #'display* i (has-many attribute)))))
-
-
-(defun find-many-to-many-class (slot-name instance)
- (let* ((imd (getf (meta-model::find-slot-metadata instance slot-name)
- :db-info))
- (jc (make-instance (getf imd :join-class)))
- (jcmd (getf (meta-model::find-slot-metadata jc (getf imd :target-slot))
- :db-info)))
- (getf jcmd :join-class)))
-
-
-(defattribute many-to-many ()
- ())
-
-
-
-(defdisplay ((attribute many-to-many) object)
- (<:as-html "ASDASD"))
-
- #+nil(let ((instances (select-instances object t))
- new-instance)
- (<:ul
- (<:li (<ucw:button :action (add-new-relation component object (.get slot-name))
- (<:as-html "Add New")))
- (<:li (<ucw:button :action (add-new-relation component object new-instance)
- (<:as-html "Add:"))
- (<ucw:select :accessor new-instance
- (arnesi:dolist* (i instances)
- (<ucw:option
- :value i
- (display component i :type 'one-line)))))
- (dolist* (i (attribute-value object attribute))
- (<:li
- (<ucw:a :action (call-view ((car i) (action-view slot) (ucw::parent slot)))
- (<:as-html "(view) "))
- (<ucw:a :action (delete-relationship slot (second i) instance)
- (<:as-html "(remove) "))
- (display component object)))))
- ;(display component (mapcar #'car (slot-value object (.get :slot-name))))
-
\ No newline at end of file
+++ /dev/null
-(in-package :lisp-on-lines)
-
-
-;TODO: get rid of this.
-(defun attribute.name (attribute)
- (attribute-name attribute))
-
-
-;;;; A few layers related to attributes
-(deflayer omit-nil-attributes)
-
-(defdisplay :in-layer omit-nil-attributes
- :around ((attribute standard-attribute) object)
- (when (attribute-value object attribute)
- (call-next-method)))
-
-;;;; Labels
-(deflayer show-attribute-labels)
-
-(defattribute attribute-label (attribute)
- ()
- (:default-properties
- :attribute nil))
-
-(defdisplay
- ((label attribute-label) object)
- (<:label
- :class "lol-label"
- (<:as-html (or (label (attribute label))
- (attribute-name (attribute label)) " ")
- " ")))
-
-(defvar *attribute-label-attribute*
- (make-instance 'attribute-label))
-
-(defdisplay
- :in-layer show-attribute-labels
- :around ((attribute standard-attribute) object)
- (display-attribute *attribute-label-attribute* object :attribute attribute)
- (call-next-method))
-
-(deflayer use-pretty-labels)
-
-(define-layered-method label
- :in-layer use-pretty-labels
- :around (standard-attribute)
- (let ((label (call-next-method)))
- (when label
- (string-capitalize
- (substitute #\Space #\- label)))))
-
-(deflayer inspect-attributes)
-
-(defdisplay :in-layer inspect-attributes
- :around ((attribute standard-attribute) object)
- (call-next-method)
- (<ucw:a :action-body (ucw::call-inspector self attribute)
- :title
- (strcat "Inspect "
- (attribute-name attribute) ":"
- (description-type attribute) ":"
- (type-of attribute))
- (<:as-html "(i)")))
-
-;;;; Functional attributes
-(defattribute display-attribute ()
- ((display-arguments
- :accessor display-arguments
- :initarg :display
- :special t
- :initform nil))
- (:type-name display)
- (:documentation "Apply the display function to this object"))
-
-(defdisplay ((attribute display-attribute) object)
- (apply #'display self (attribute-value object attribute)
- (display-arguments attribute)))
-
-(defattribute function-attribute ()
- ((function :accessor function-of
- :initarg :function
- :initform #'funcall
- :special t))
- (:type-name function)
- (:documentation ""))
-
-(defdisplay ((function function-attribute) object)
- (funcall (function-of function)
- (attribute-value object function)))
-
-
-;;;; Attribute Grouping
-(defattribute attribute-group ()
- ()
- (:default-properties
- :group nil)
- (:type-name group))
-
-(defdisplay ((group attribute-group) object)
- (apply #'display self object
- :attributes (attributes group)
- (group group)))
-
-
-(defattribute select-attribute (display-attribute)
- ()
- (:default-properties
- :test 'meta-model::generic-equal
- :options-getter (constantly nil))
- (:type-name select))
-
-(defdisplay ((attribute select-attribute) object)
- (<ucw:select
- :accessor (attribute-value object attribute)
-
- :test (test attribute)
- (dolist* (obj (funcall (options-getter attribute) object))
- (<ucw:option
- :value obj
- (apply #'display* obj (display-arguments attribute))))))
-
-;;;; * Base Types
-
-(defattribute base-attribute ()
- ()
- (:default-properties
- :default-value ""))
-
-(defdisplay ((base base-attribute) object)
- (<:as-html (attribute-value object base)))
-
-(defattribute base-attribute ()
- ()
- (:in-layer editor)
- (:default-properties
- :callback nil
- :default-value nil
- :default-value-predicate #'null
- :dom-id (js:gen-js-name-string :prefix "_ucw_")
- :input-size nil))
-
-(define-layered-function display-value (attribute value)
- (:method (attribute value)
- (if (funcall (default-value-predicate attribute) value)
- (default-value attribute)
- value)))
-
-(defdisplay
- :in-layer editor ((field base-attribute) object)
- (LET ((value (attribute-value (object field) field)))
- (<:input
- :NAME
- (callback field)
- :VALUE (escape-as-html (strcat (display-value field value)))
- :TYPE
- "text"
- :ID
- (DOM-ID FIELD)
- :SIZE
- (INPUT-SIZE FIELD))))
-
-(defdisplay
- :in-layer editor :around ((string base-attribute) object)
- (dletf (((callback string)
- (or (callback string)
- (ucw::register-callback
- #'(lambda (val)
- (setf (attribute-value object string) val)))))
- ((object string) object))
- (call-next-method)))
-
-;;;; Strings
-
-(defattribute string-attribute (base-attribute)
- ()
- (:type-name string)
- (:default-properties
- :escape-html-p t
- :size nil
- :max-length nil
- :default-value ""))
-
-
-#|
-
-(defdisplay :in-layer omit-nil-attributes
- :around ((attribute string-attribute) object)
- (when (< 0 (length (attribute-value object attribute)))
- (call-next-method)))
-
-;;;; default
-(defdisplay :in-layer viewer
- ((string string-attribute) object)
- (if (escape-html-p string)
- (<:as-html (attribute-value object string))
- (<:as-is (attribute-value object string))))
-
-
-;;;; editor
-#+nil (defattribute string-attribute (base-attribute)
- ()
- (:in-layer editor)
- (:default-properties
- :callback nil))
-
-
-(defattribute string-search-attribute (string-attribute)
- ()
- (:default-properties
- ;; the func that find search results
-
- :search-action #'(lambda ()
- (with-call/cc
- nil))
- ;; when chosing from a list of results, this function selects one.
- :select-function (constantly t))
- (:type-name string-search))
-
-(defdisplay
- :in-layer editor :after ((search string-search-attribute) object)
- (<:input
- :TYPE "submit"
- :VALUE "search"
- :ONCLICK
- (JS:JS-INLINE*
- `(PROGN
- (IT.BESE.UCW::SET-ACTION-PARAMETER
- ,(IT.BESE.UCW::MAKE-NEW-ACTION
- (IT.BESE.UCW::CONTEXT.CURRENT-FRAME *CONTEXT*)
- (search-action search)))
- (RETURN T)))))
-
-;;;; textarea
-
-(defattribute text-attribute (string-attribute)
- ()
- (:type-name text))
-
-(defdisplay :in-layer editor ((string text-attribute) object)
- (<:textarea
- :id (dom-id string)
- :name (callback string)
- (or (attribute-value object string) "")))
-
-
-
-;;;; WALL-TIME
-
-(defattribute wall-time-attribute (string-attribute)
- ()
- (:type-name clsql-sys:wall-time))
-
-(define-layered-method attribute-value (object (attribute wall-time-attribute))
- (let ((date (call-next-method)))
- (when date (multiple-value-bind (y m d) (clsql:time-ymd date)
- (format nil "~a/~a/~a" m d y)))))
-
-(defdisplay
- ((time wall-time-attribute) object)
- (<:as-html (attribute-value object time)))
-
-
-
-(defattribute image ()
- ()
- (:default-properties
- :css-class "lol-image"
- :prefix "images/"))
-
-(defdisplay ((buttons (eql 'image-editor-buttons)) object)
- (<ucw:a :action (ok component object)
- (<:as-html "select this image")))
-
-(defdisplay ((image image) object)
- (<:img
- :class (or (css-class image) "lol-image")
- :src (arnesi:strcat
- (or (prefix image) "images/")
- (escape-as-uri
- (attribute-value object image)))))
-
-(defdisplay
- :in-layer editor ((image image) object)
-
- (<:div
- :class "lol-image-thumbnails"
- (<:as-html "imagie"))) |#
-
-
-
-
-
-
"Render the object in component,
using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
-(define-layered-method
- display-using-description (d o c)
- (<:as-html "default :" o))
-
(defun make-display-function (component object
&rest properties
- &key type (line #'line-in)
+ &key (line #'line-in)
&allow-other-keys)
"returns a function that expects a 3 argument function as its argument
-The function (which is usually display-using-description) will be called with the proper environment for display all set up nice n pretty like."
+The function argument (which is usually display-using-description) will be called with the proper environment for display all set up nice n pretty like."
(lambda (function)
(let* ((description (find-occurence object)))
-
(if description
- (dletf (((description-type description) type)
- ((attributes description) (or
- (attributes description)
- (list-attributes description))))
+ (dletf (((attributes description)
+ (or
+ (attributes description)
+ (list-attributes description))))
;; apply the default line to the description
(funcall-with-description
description
;;;;; Macros
-
-(defun funcall-with-description (description properties function &rest args)
-
+(defun funcall-with-layers (layers thunk)
+ (let ((context (current-layer-context)))
+ (loop :for (op layer)
+ :on layers :by #'cddr
+ :do (setf context
+ (case op
+ (+ (adjoin-layer layer context))
+ (- (remove-layer layer context)))))
+ (funcall-with-layer-context context thunk)))
+
+
+(defun funcall-with-description (description properties function &rest args)
(if description
- (dletf* (((description-type description) (or
- (getf properties :type)
- (description-type description)))
+ (dletf* (((description-type description)
+ (or
+ (getf properties :type)
+ (description-type description)))
- ((description-layers description) (append
- (description-layers description)
- (getf properties :layers)))
+ ((description-layers description)
+ (append
+ (description-layers description)
+ (getf properties :layers)))
((description-properties description) (append (description-properties description) properties)))
(funcall-with-layers
(description-layers description)
- #'(lambda ()
- (contextl::funcall-with-special-initargs
- (list (cons description properties))
- #'(lambda ()
- (apply function args))))))
+ (lambda ()
+ (contextl::funcall-with-special-initargs
+ (list (cons description properties))
+ #'(lambda ()
+ (apply function args))))))
(apply function args)))
(defmacro with-description ((description &rest properties) &body body)
(declare (ignorable #'display* #'display-attribute))
,@body)))
-(defmacro defdisplay (&body body)
- (loop with in-layerp = (eq (car body) :in-layer)
- with layer = (if in-layerp (cadr body) 't)
- for tail on (if in-layerp (cddr body) body)
- until (listp (car tail))
- collect (car tail) into qualifiers
- finally
- (when (member :in-layer qualifiers)
- (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
- (return
- (destructuring-bind (description &optional object component) (car tail)
- (with-unique-names (d c)
- (let (standard-description-p)
- `(define-layered-method
- display-using-description
- :in-layer ,layer
- ,@qualifiers
-
- ,@(unless object
- (setf object description)
- (setf description d)
- nil)
- (,(cond
- ((listp description)
- (setf d (car description))
- description)
- (t
- (setf d description)
- (setf standard-description-p t)
- `(,d description)))
- ,object
- ,(cond
- ((null component)
- `(,c component))
- ((listp component)
- (setf c (car component))
- component)
- (t
- (setf c component)
- `(,c t))))
- (with-component (,c)
- ,@(cdr tail)))))))))
+
(in-package :lisp-on-lines)
-(defun persistentp (object)
- (slot-value object 'clsql-sys::view-database))
-
-(define-layered-class description ()
- ((description-type
- :initarg :type
- :accessor description-type
- :initform 'viewer
- :special t)
- (description-layers
- :initarg :layers
- :accessor description-layers
- :initform nil
- :special t)
- (described-object
- :layered-accessor object
- :initform nil
- :special t)
- (description-default-attributes
- :accessor default-attributes
- :initarg :default-attributes
- :initform nil
- :special t)
- (description-attributes
- :accessor attributes
- :initarg :attributes
- :initform nil
- :special t)
- (description-properties
- :accessor description-properties
- :initarg :properties
- :initform '()
- :special t)
- (description-default-properties
- :accessor default-properties
- :initarg :default-properties
- :initform '()
- :special t)))
-
-(defmethod attributes :around ((description description))
- "Add any default properties to the attributes"
-
- (let ((default-properties (default-properties description))) (if (and (listp default-properties)
- (not (null default-properties)))
- (let ((a (mapcar #'(lambda (att)
- (append (ensure-list att) default-properties))
- (call-next-method))))
-
-
- a)
- (call-next-method))))
-
-(defmethod print-object ((self description) stream)
- (print-unreadable-object (self stream :type t)
- (with-slots (description-type) self
- (format stream "~A" description-type))))
-
;;;; * Occurences
+;;;; Occurences can be thought of as the class of a description.
+;;;; Most of the occurence stuff is depreciated now.
-(defvar *occurence-map* (make-hash-table)
- "a display is generated by associating an 'occurence'
-with an instance of a class. This is usually keyed off class-name,
-although an arbitrary occurence could be used with an arbitrary class.")
-
-(define-layered-class
- standard-occurence (description)
- ((occurence-name :accessor name :initarg :name)
- (attribute-map :accessor attribute-map :initform (make-hash-table)))
- (:documentation
"an occurence holds the attributes like a class holds slot-definitions.
-Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
+Attributes are the yetadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."
(defun find-or-create-occurence (name)
"Returns the occurence associated with this name."
- (or (get-occurence name)
- (values (setf (get-occurence name) (make-instance 'standard-occurence :name name))
- t)))
-
-(defun get-occurence (name)
- (gethash name *occurence-map*))
-
-(defun (setf get-occurence) (occurence name)
- (setf (gethash name *occurence-map*) occurence))
+ (let ((description (find-description name)))
+ (if description
+ (class-of description)
+ (class-of (ensure-description name)))))
(defun clear-occurence (occurence)
"removes all attributes from the occurence"
(setf (attribute-map occurence) (make-hash-table)))
-(defmethod make-attribute-using-slot-definition (slotd)
- (make-attribute
- :name (closer-mop:slot-definition-name slotd)
- :type-spec (closer-mop:slot-definition-type slotd)
- :type (first (remove-if (lambda (item)
- (or
- (eql item 'or)
- (eql item 'null)
- (eql item nil)))
- (ensure-list (closer-mop:slot-definition-type slotd))))))
-
-(defmethod initialize-occurence-for-instance (occurence instance)
- (let ((slots (closer-mop:class-slots (class-of instance))))
- (dolist (s slots)
- (let ((att (make-attribute-using-slot-definition s)))
- (setf (find-attribute occurence (attribute-name att)) att)))
- occurence))
-
(defgeneric find-occurence (name)
(:method (thing)
nil)
res))
+(defmethod make-attribute-using-slot-definition (slotd)
+ (make-attribute
+ :name (closer-mop:slot-definition-name slotd)
+ :type-spec (closer-mop:slot-definition-type slotd)
+ :type (first (remove-if (lambda (item)
+ (or
+ (eql item 'or)
+ (eql item 'null)
+ (eql item nil)))
+ (ensure-list (closer-mop:slot-definition-type slotd))))))
+
+(defmethod initialize-occurence-for-instance (occurence instance)
+ (let ((slots (closer-mop:class-slots (class-of instance))))
+ (dolist (s slots)
+ (let ((att (make-attribute-using-slot-definition s)))
+ (setf (find-attribute occurence (attribute-name att)) att)))
+ occurence))
+
+
+
+
+;;;; * Attributes
+
(define-layered-class
attribute (description)
((attribute-name :layered-accessor attribute-name
(label :initarg :label :layered-accessor label :initform nil :special t)))
-;;;; * Attributes
(defmethod print-object ((self attribute) stream)
(print-unreadable-object (self stream :type t)
(with-slots (attribute-name description-type) self
:properties args
args))
-(defmethod ensure-attribute ((occurence standard-occurence) &rest args &key name &allow-other-keys)
+(defmethod ensure-attribute ((occurence description) &rest args &key name &allow-other-keys)
"Creates an attribute in the given occurence"
(let ((attribute (apply #'make-attribute :occurence occurence args)))
(setf (find-attribute occurence name) attribute)))
(defmethod find-attribute ((occurence null) name)
nil)
-(defmethod find-attribute ((occurence standard-occurence) name)
+(defmethod find-attribute ((occurence description) name)
(or (gethash name (attribute-map occurence))
(let* ((class (ignore-errors (find-class (name occurence))))
(class-direct-superclasses
name)))
attribute)))))
-(defmethod find-all-attributes ((occurence standard-occurence))
+(defmethod find-all-attributes ((occurence description))
(loop for att being the hash-values of (attribute-map occurence)
collect att))
collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions)))))
-(defmethod find-description (object type)
- (let ((occurence (find-occurence object)))
- occurence))
+
;;"Unused???"
(defmethod setter (attribute)
(defpackage :lisp-on-lines
(:use :arnesi
- :iterate
- :meta-model
+ ;:iterate
+ ;:meta-model
:common-lisp
- :it.bese.ucw
- :clsql
+ ;:it.bese.ucw
+ ;:clsql
:contextl)
(:nicknames :lol :mewa)
- (:shadowing-import-from
+ #+nil(:shadowing-import-from
:ucw
:parent)
- (:shadowing-import-from
+ #+nil(:shadowing-import-from
:iterate
:with)
- (:shadowing-import-from
+#+nil (:shadowing-import-from
:clsql
:time-difference
:make-time
:time+
:date-element)
- (:export
+ (:export
+
+ #:find-description
+ #:ensure-description
+ #:define-description
+
+ #:define-display
+ #:display
+ #:*display*
+ #:*object*
+
+ #:find-attribute
+ #:attribute-label
+
+
+
;;;; CLSQL meta-model/default attributes definers
;;;; TODO: should be moved to meta-model,
;;;; with lol specific function implemented like the
#:crud-viewer
#:crud-summary
#:crud-database
- #:instance))
\ No newline at end of file
+ #:instance))
+
+(cl:defpackage #:lol-test
+ (:use :cl :lisp-on-lines :stefil :contextl))
\ No newline at end of file
(in-package :lisp-on-lines)
+(deflayer lisp-on-lines ())
+
;;;; The Standard Layers
-(deflayer viewer)
-(deflayer editor)
+(deflayer viewer (lisp-on-lines))
+(deflayer editor (lisp-on-lines))
;;;; Attributes
(defdisplay
+++ /dev/null
-(in-package :lol)
-
-;; I lifted this regexp from http://www.ex-parrot.com/~pdw/Mail-RFC822-Address
-
-;; this is the copyright :
-
-;; COPYRIGHT and LICENSE
-
-;; This program is copyright 2001-2002 by Paul Warren.
-
-;; Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the ``Software''), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
-
-;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-
-(defvar +email-regexp+
- "(?:(?:\\r\\n)?[ \\t])*(?:(?:(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*|(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)*\\<(?:(?:\\r\\n)?[ \\t])*(?:@(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*(?:,@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*)*:(?:(?:\\r\\n)?[ \\t])*)?(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*\\>(?:(?:\\r\\n)?[ \\t])*)|(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)*:(?:(?:\\r\\n)?[ \\t])*(?:(?:(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*|(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)*\\<(?:(?:\\r\\n)?[ \\t])*(?:@(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*(?:,@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*)*:(?:(?:\\r\\n)?[ \\t])*)?(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*\\>(?:(?:\\r\\n)?[ \\t])*)(?:,\\s*(?:(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*|(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)*\\<(?:(?:\\r\\n)?[ \\t])*(?:@(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*(?:,@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*)*:(?:(?:\\r\\n)?[ \\t])*)?(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\"(?:[^\\\"\\r\\\\]|\\\\.|(?:(?:\\r\\n)?[ \\t]))*\"(?:(?:\\r\\n)?[ \\t])*))*@(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*)(?:\\.(?:(?:\\r\\n)?[ \\t])*(?:[^()<>@,;:\\\\\".\\[\\] \\000-\\031]+(?:(?:(?:\\r\\n)?[ \\t])+|\\Z|(?=[\\[\"()<>@,;:\\\\\".\\[\\]]))|\\[([^\\[\\]\\r\\\\]|\\\\.)*\\](?:(?:\\r\\n)?[ \\t])*))*\\>(?:(?:\\r\\n)?[ \\t])*))*)?;\\s*)")
-
-(defvar scanner (cl-ppcre:create-scanner +email-regexp+))
-
-(defun validate-email-address (instance attribute value)
- (multiple-value-bind (start end)
- (cl-ppcre:scan scanner value)
- (when (not (and (equal start 0) (equal end (length value))))
- (signal 'attribute-validation-condition
- :message (format nil "~A must be a valid email address."
- (label attribute))
- :attribute attribute))))
\ No newline at end of file
+++ /dev/null
-(in-package :lisp-on-lines)
-
-(defstruct invalid-attribute-value
- (initial-value nil :read-only t)
- (invalid-value nil :read-only t)
- (conditions nil :read-only t))
-
-(deflayer validate (editor))
-
-(defcomponent validation-mixin ()
- ((validation-conditions
- :accessor validation-conditions
- :initform nil
- :backtrack t)
- (inhibit-call-if-invalid-p
- :accessor inhibit-call-if-invalid-p
- :initform t
- :initarg :inhibit-call-if-invalid-p)
- (inhibit-answer-if-invalid-p
- :accessor inhibit-answer-if-invalid-p
- :initform t
- :initarg :inhibit-answer-if-invalid-p)))
-
-(defmethod render :wrap-around ((self validation-mixin))
- (call-next-method)
- (setf (validation-conditions self) nil))
-
-(defun component-valid-p (component)
- (not (validation-conditions component)))
-
-(defmethod/cc call-component :around ((from validation-mixin) to)
- (if (inhibit-call-if-invalid-p from)
- (when (component-valid-p from)
- (call-next-method from to))
- (call-next-method from to)))
-
-(defmethod answer-component :around ((target validation-mixin) value)
- (if (inhibit-answer-if-invalid-p target)
- (when (component-valid-p target)
- (call-next-method))
- (call-next-method)))
-
-(defparameter *invalid-attribute-renderer*
- #'(lambda (invalid-attribute-value next-method)
- (<:div
- :class "lol-invalid-attribute"
- (<:ul
- :class "lol-invalid-attribute-message"
- (dolist (c (invalid-attribute-value-conditions invalid-attribute-value))
- (<:li (<:as-html (message c)))))
- (funcall next-method))))
-
-(defattribute base-attribute ()
- ()
- (:in-layer validate)
- (:default-properties
- :validate-using nil
- :requiredp nil
- :required-test 'validate-string-exists))
-
-(defdisplay :in-layer validate
- :around ((attribute base-attribute) object)
- "Set the callback to perform validation
-and create invalid-attribute-values when things don't validate. duh "
- (let ((callback (or
- (callback attribute)
- (ucw::make-new-callback
- #'(lambda (val)
- (setf (attribute-value object attribute) val)))))
- ;;;; We need to lexically bind some slots here
- ;;;; As by the time the validator runs we'll be in
- ;;;; a totally different dynamic scope.
- (validators (validate-using attribute))
- (label (label attribute)))
-
- ;;;; We have a convenience property for :requiredp
- (when (requiredp attribute)
- (push (required-test attribute) validators))
-
- ;;;; Now we create the validation callback
- (dletf (((callback attribute)
- (ucw::make-new-callback
- #'(lambda (val)
- (flet ((setter (value)
- (ucw::call-callback
- (ucw::context.current-frame *context*)
- callback
- value)))
-
- ;; We have to do DLETF ,as we will no longer be
- ;; in the validation layer at callback-application time.
- (dletf (((validate-using attribute) validators)
- ((slot-value attribute 'label) label))
- (multiple-value-bind (validp conditions)
- (validate-attribute object attribute val)
- (if validp
- (setter val)
- (progn
- (setter
- (make-invalid-attribute-value
- :initial-value (attribute-value object attribute)
- :invalid-value val
- :conditions conditions))
- (when (subtypep (type-of self) 'validation-mixin)
- (setf (validation-conditions self)
- (append conditions (validation-conditions self)))))))))))))
-
-
- ;;;; Ok, so if the attribute-value holds an
- ;;;; invalid-attribute-value struct, we take the appropriate action
- (let ((value (attribute-value object attribute)))
- (if (invalid-attribute-value-p value)
- (progn
- ;;;; set the value back the the previous
- ;;;; TODO: does not handle unbound slots
- (ucw::call-callback
- (ucw::context.current-frame *context*)
- callback
- (invalid-attribute-value-initial-value value))
- (funcall *invalid-attribute-renderer*
- value
- #'(lambda ()
- (call-next-method))))
- (call-next-method))))))
\ No newline at end of file
+++ /dev/null
-(in-package :lisp-on-lines)
-
-;;;; Validation Conditions
-
-(define-condition validation-condition ()
- ((message :accessor message :initarg :message :initform "Invalid value")
- (value :accessor value :initarg :value :initform (warn "condition was not given a value"))))
-
-;;;; ** Attributes
-(define-condition attribute-validation-condition (validation-condition)
- ((attribute :accessor attribute :initarg :attribute :initform nil)))
-
-(defgeneric validate-attribute (instance attribute &optional value)
- (:documentation "
-Returns T if the ATTRIBUTE-VALUE in INSTANCE passes all the validation functions. Otherwise, returns (values nil conditions) where CONDITIONS is a list of conditions representing the validation errors the slot.")
- (:method (instance attribute &optional (value nil value-provided-p))
- (let ((val (if value-provided-p
- value
- (attribute-value instance attribute)))
- (conditions))
- (handler-bind ((attribute-validation-condition
- #'(lambda (c)
- (setf conditions (cons c conditions))
- (signal c))))
-
- (dolist (f (find-validation-functions instance attribute))
- (funcall f instance attribute val)))
- (if conditions
- (values nil conditions)
- t))))
-
-
-(defmethod find-validation-functions (instance (attribute standard-attribute))
- (let ((foo (validate-using attribute)))
- (warn "validation?~A " foo)
- foo))
-
-
-;;;; ** Instances
-(define-condition instance-validation-condition (validation-condition)
- ((instance :accessor instance :initarg instance :initform nil)
- (conditions :accessor conditions :initarg :conditions :initform nil)))
-
-(defmethod invalid-instance-p (instance attributes)
- (let (condition)
- (handler-bind ((instance-validation-condition
- #'(lambda (c)
- (setf condition c))))
- (validate-instance instance attributes))
- condition))
-
-(defmethod validate-instance (instance attributes)
- (let (all-conditions)
- (dolist (att attributes)
- (multiple-value-bind (is-valid-p conditions)
- (validate-attribute instance att)
- (unless is-valid-p
- (setf all-conditions (nconc conditions all-conditions)))))
- (if all-conditions
- (progn (signal 'instance-validation-condition
- :message "Invalid Instance"
- :instance instance
- :conditions all-conditions)
- (values nil all-conditions))
-
- t)))
-
-
-;;;; Attribute Validation Functions
-;;;; I have not quite figured all this out yet.
-;;;; A generic validation system needs more thought than i've given it, but this is a start.
-
-(defun validate-string-exists (instance attribute value)
- (if (or
- (not (stringp value))
- (not (< 0 (length value))))
- (signal 'attribute-validation-condition
- :message (format nil "You must enter a value for ~A."
- (label attribute))
- :attribute attribute)))
-
-
-(defun validate-true (instance attribute value)
- (unless value
- (signal 'attribute-validation-condition
- :message (format nil "~A is required."
- (label attribute))
- :attribute attribute)))
\ No newline at end of file
HCoop / clinton / lisp-on-lines.git / commitdiff