From dee565d0d3252060ce31e8de57708ff9edb054d5 Mon Sep 17 00:00:00 2001
From: Drew Crampsie <drewc@tech.coop>
Date: Fri, 30 Dec 2005 05:39:56 -0800
Subject: [PATCH] added files referenced by previous patch

darcs-hash:20051230133956-5417e-cf360e3179c940749024bf0e03673d2f1417a4be.gz
---
 reddit-example.lisp               |  99 ++++++++++++
 src/relational-attributes.lisp    |  39 +++++
 src/standard-display.lisp         | 242 ++++++++++++++++++++++++++++++
 src/standard-occurence-class.lisp |   4 +
 src/validate-email-address.lisp   |  26 ++++
 5 files changed, 410 insertions(+)
 create mode 100644 reddit-example.lisp
 create mode 100644 src/relational-attributes.lisp
 create mode 100644 src/standard-display.lisp
 create mode 100644 src/standard-occurence-class.lisp
 create mode 100644 src/validate-email-address.lisp

diff --git a/reddit-example.lisp b/reddit-example.lisp
new file mode 100644
index 0000000..47ce250
--- /dev/null
+++ b/reddit-example.lisp
@@ -0,0 +1,99 @@
+(in-package :lol)
+
+(defvar *lol-example-application*
+  (make-instance 'cookie-session-application
+                 :url-prefix "/"
+                 :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))
+
+(defaction 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=# 
+
+
diff --git a/src/relational-attributes.lisp b/src/relational-attributes.lisp
new file mode 100644
index 0000000..8766be2
--- /dev/null
+++ b/src/relational-attributes.lisp
@@ -0,0 +1,39 @@
+(in-package :lol)
+
+(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 ()
+  ())
+
+(define-layered-method attribute-value (object (attribute many-to-many))
+  (call-next-method))
+
+(defdisplay (:description (attribute many-to-many))
+    (let ((instances (select-instances object))
+	new-instance)
+    (<:ul
+     (<:li (<ucw:button :action (add-new-relation component object (getp 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 (getp :slot-name)))))
+		      
\ No newline at end of file
diff --git a/src/standard-display.lisp b/src/standard-display.lisp
new file mode 100644
index 0000000..c756096
--- /dev/null
+++ b/src/standard-display.lisp
@@ -0,0 +1,242 @@
+(in-package :lisp-on-lines)
+
+
+;;;; The Standard Layer Hierarchy
+(deflayer viewer)
+(deflayer editor (viewer))
+(deflayer creator (editor))
+
+;;;; 'Mixin' Layers
+(deflayer one-line)
+
+(deflayer wrap-form)
+
+(define-attributes (contextl-default)
+  (:viewer viewer)
+  (:editor editor)
+  (:creator creator))
+
+
+(defmacro with-component ((component) &body body)
+  `(let ((self ,component))
+    (flet ((display* (thing &rest args)
+	     (apply #'display ,component thing args)))
+      ,@body)))
+
+(defmacro call-display (object &rest args)
+  `(call-component self (make-instance 'standard-display-component
+			 :display #'(lambda (component)
+				      (with-component (component)
+					(<:as-html ,object)
+					(display ,object ,@args))))))
+
+;;;;; Macros
+
+(defmacro do-attributes ((var occurence attributes) &body body)
+  (with-unique-names (att plist type)
+    `(loop for ,att in ,attributes
+      do (let* ((,att (ensure-list ,att))
+		(,plist (rest ,att))
+		(,type (getf ,plist :type))
+		(,var (if ,type
+			  (make-attribute :name (first ,att) :type ,type :plist ,plist)
+			  (find-attribute ,occurence (first ,att)))))
+	   (flet ((display-attribute* (component object)
+		    (display-using-description
+		     ,var
+		     component
+		     object
+		     (rest ,att))))
+	     (with-plist ((plist-union (rest ,att) (find-plist ,var)) ,var)	   
+	       ,@body))))))
+
+
+(defmethod find-plist (object)
+  (list))
+
+(defmethod find-plist ((attribute standard-attribute))
+  (attribute.plist attribute))
+
+(defmacro with-plist ((plist-form &optional prefix)  &body body)
+  (with-unique-names (p)
+    (let ((get (intern (string-upcase (if prefix (strcat prefix '-getp) "GETP"))))
+	  (set (intern (string-upcase (if prefix (strcat prefix '-setp) "SETP")))))
+      `(let ((,p ,plist-form))
+	(flet ((,get  (p)
+		 (getf ,p p))
+	       (,set (p v)
+		 (setf (getf ,p p) v)))
+	  (declare (ignorable #',get #',set))
+	  ,@body)))))
+
+
+(defmacro defdisplay ((&key
+		       (in-layer nil layer-supplied-p)
+		       (combination nil combination-supplied-p)
+		       (description '(occurence standard-occurence) description-supplied-p)
+		       (component 'component)
+		       ((:class object)  nil))
+		      &body body)
+
+  `(define-layered-method display-using-description
+    ,@(when layer-supplied-p `(:in-layer ,in-layer))
+    ,@(when combination-supplied-p `(,combination))
+    (,description ,component
+     ,(if object (if (listp object) object (list object object)) 'object)  properties)
+    (declare (ignorable display-attribute))
+
+    (with-plist ((plist-union properties (find-plist ,(car description))))
+      
+      ,(if (not description-supplied-p)
+	   `(flet ((display-attribute (attribute)
+		    (let ((a (ensure-list attribute)))
+		      (display-using-description (find-attribute ,(car description) (car a)) ,component ,(car (ensure-list object))  (cdr a)))))
+	     
+	     ,@body)
+	   `(progn ,@body)))))
+
+
+(define-layered-function display (component object &rest args)
+  (:documentation
+   "Displays OBJECT in COMPONENT. 
+
+ default action is to FUNCALL-WITH-LAYERS the DISPLAY-USING-DESCRIPTION method."))
+
+
+
+(define-layered-method display
+    ((component t) (object t) &rest args &key layers (type 'viewer)  &allow-other-keys)  
+  (let* ((occurence (find-occurence object))
+	 (plist (attribute.plist
+		 (find-attribute occurence (intern (format nil "~A" type) :KEYWORD))))
+	 (layers (append (when type (loop for ty in (ensure-list type)
+					  nconc `(+ ,ty)))
+			 layers
+			 (getf plist :layers))))
+    (funcall-with-layers 
+     layers		 
+     #'display-using-description  occurence component object (plist-union args plist))))
+
+(define-layered-method display
+    ((component t) (object symbol) &rest args &key (layers  '(+ viewer)) &allow-other-keys)
+  (funcall-with-layers 
+     layers		 
+     #'display-using-description  t component object args))
+
+
+(define-layered-method display ((component t) (list list) &rest args)
+  "The Default Display* for LISTS"
+  (<:ul
+   (dolist* (item list)
+     (<:li  (apply #'display component item args)))))
+
+
+(define-layered-function display-using-description (description component object properties)
+  (:documentation
+   "Render the object in component, using DESCRIPTION, which is an occurence, and attribute, or something else"))
+
+(define-layered-method display-using-description (description component object properties)
+  "The standard display simply prints the object"
+  (declare (ignore component properties description))
+  (<:as-html object))
+
+(define-layered-method display-using-description
+    ((occurence standard-occurence) component object properties)
+
+  (with-plist (properties o)
+    (loop for att in (or (o-getp :attributes) (list-slots object))
+	  do (let* ((att (ensure-list att))
+		    (attribute (find-attribute occurence (first att))))
+	       (warn "trying to render ~A in ~A" attribute object)
+	       (with-plist ((plist-union (rest att) (find-plist attribute)))
+		 (<:p :class "attribute"
+		      (<:span :class "label" (<:as-html (getp :label) " "))	   
+		      (display-using-description
+		       attribute
+		       component
+		       object
+		       (rest att))))))))
+
+(define-layered-method display-using-description
+  :in-layer one-line ((occurence standard-occurence) component object properties)
+  (with-plist (properties occurence)
+      (do-attributes (attribute occurence (or (occurence-getp :attributes)
+					      (list-slots object)))
+	(display-attribute* component object) (<:as-html " "))))
+
+
+(define-layered-method display-using-description ((attribute standard-attribute) component object properties)
+  (let ((p (lol:make-view object :type :viewer))
+	(name (attribute.name attribute)))
+    (when name (present-slot-view p name))))
+
+(defdisplay (:in-layer
+	     editor
+ 	     :description (attribute standard-attribute))
+  "Legacy editor using UCW presentations"
+  (let ((p (lol:make-view object :type :editor)))
+    (present-slot-view p (getf (find-plist attribute) :slot-name))))
+
+
+
+(defdisplay (:class
+	     (button (eql 'standard-form-buttons))
+	     :description (description t))
+  (<ucw:submit :action (ok component)
+	       :value "Ok.")
+
+
+(defdisplay (:in-layer wrap-form
+		       :combination :around)
+  (<ucw:form
+   :action (refresh-component component)
+   (call-next-method)
+   (display component 'standard-form-buttons))))
+
+(defclass/meta test-class ()
+  ((test-string :initform "test string" :type string))
+  (:documentation "foo"))
+
+(define-attributes (test-class)
+  (test-string t :label "String :" :editablep t))
+  
+(defcomponent test-component ()
+  ((display-types :accessor display-types :initform (list 'viewer 'editor 'creator 'one-line 'as-string))
+   (current-type :accessor current-type :initform 'viewer)
+   (instance :accessor instance :initform (make-instance 'test-class))))
+
+(defmethod render ((self test-component))
+  (let ((test (instance self))) 
+    (<:h1 (<:as-html "Lisp on Lines Test Component"))
+    (with-component (self)
+      (<ucw:form
+       :action (refresh-component self)
+       (<ucw:select :accessor (current-type self)
+		    (dolist* (type (display-types self))
+		      (<ucw:option :value type (<:as-html type))))
+       (<:input :type "Submit" :value "update")
+       (<:fieldset
+	(<:legend (<:as-html (current-type self)))
+	(display test :type (current-type self)))))
+
+    (<:div
+     (<:h2
+      (<:as-html "UCW Presentation based displays (the old school"))
+     (dolist (type '(:viewer :editor :creator :one-line :as-string))
+       (<:h3 (<:as-html type))
+       (present-view (test type self))
+       (<ucw:a :action (call-view (test type self))
+	       (<:as-html "Call to " type))))))
+
+
+(defcomponent standard-display-component ()
+  ((display-function :accessor display-function :initarg :display)))
+
+(defmethod render ((self standard-display-component))
+  (funcall (display-function self) self))
+
+
+       
+				     
+
+
diff --git a/src/standard-occurence-class.lisp b/src/standard-occurence-class.lisp
new file mode 100644
index 0000000..6c46d66
--- /dev/null
+++ b/src/standard-occurence-class.lisp
@@ -0,0 +1,4 @@
+(in-package :lisp-on-lines)
+
+(defclass standard-occurence-class (standard-class)
+  )
\ No newline at end of file
diff --git a/src/validate-email-address.lisp b/src/validate-email-address.lisp
new file mode 100644
index 0000000..8f3712d
--- /dev/null
+++ b/src/validate-email-address.lisp
@@ -0,0 +1,26 @@
+(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.
+
+(defparameter *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*)")
+
+(defun validate-email-address (instance attribute)
+  (let ((value (lol::attribute-value instance attribute)))
+    (if (or
+	 (not (stringp value))
+	 (not (< 0 (length value))))
+	(signal 'attribute-validation-condition
+		:message (format nil "You must enter a value for ~A."
+			      (getf (attribute.plist attribute) :label))
+		:attribute attribute))))
\ No newline at end of file
-- 
2.20.1