Changeset main,78

Timestamp:

12/05/2007 03:05:40 AM (19 years ago)

Author:

David Owen <dsowen@…>

branch-nick:

tui

revision id:

dsowen@fugue88.ws-20071205030540-vtmraw1ijs01a9ec

Message:

Fixed form traversal bug.
Started adding validators.

File:

• main/form.lisp (modified) (6 diffs)

main/form.lisp

@@ -22 +22 @@
 (defclass value-widget-def (widget-def)
   ((name :initarg :name)
-   (read-only :type boolean :initarg :read-only)))
+   (read-only :type boolean :initarg :read-only)
+   (validator :initarg :validator)))
 
 
@@ -54 +55 @@
 
 (defun make-textbox-def (row column name display-width
-                         &key data-width read-only
+                         &key data-width read-only (validate 'nothing)
                          (inactive-background
                           *default-inactive-widget-background*)
@@ -63 +64 @@
                   :display-width ,display-width :data-width ,data-width
                   :read-only ,read-only
+                  :validator ',validate
                   :inactive-background (list ,@inactive-background)
                   :active-background (list ,@active-background)))
@@ -68 +70 @@
 (defun make-numberbox-def (row column name display-width
                            &key data-width precision read-only
+                           (validate 'nothing)
                            (inactive-background
                             *default-inactive-widget-background*)
@@ -76 +79 @@
                   :display-width ,display-width :data-width ,data-width
                   :precision ,precision :read-only ,read-only
+                  :validator ',validate
                   :inactive-background (list ,@inactive-background)
                   :active-background (list ,@active-background)))
@@ -231 +235 @@
 
 
+(defun focusables (form)
+  (with-slots (peers) form
+    (let* ((n (length peers))
+           (x (make-sequence 'vector n)))
+      (dotimes (i n)
+        (setf (aref x i) i))
+      (delete-if (lambda (i)
+                   (typep (aref peers i) 'label))
+                 x))))
+
 (defmethod activate ((form form) &key (key-callback 'nothing) &allow-other-keys)
-  (with-slots (peers) form
+  (with-slots (data peers widget-defs) form
     (flet ((callback (key)
-             (if (member key '(#\Return #\Newline #\Tab :key-btab))
-                 key
+             (or (find key '(#\Return #\Newline #\Tab :key-btab :key-down
+                             :key-up))
                  (funcall key-callback key))))
-      (let ((focus 0)
-            (n (length peers)))
-        (loop
-           (ensure-widget-visible form focus)
-           (refresh form)
-           (let ((key (activate (aref peers focus) :key-callback #'callback)))
-             (case key
-               ((#\Return #\Newline #\Tab)
-                (setf focus (mod (1+ focus) n)))
-               (:key-btab
-                (setf focus (mod (1- focus) n)))
-               (t
-                (return-from activate key)))))))))
+      (let* ((focusables (focusables form))
+             (focus 0)
+             (n (length focusables)))
+        (assert (> n 0) nil "The form has no fields.")
+        (labels ((f-idx () (aref focusables focus))
+                 (f-peer () (aref peers (f-idx)))
+                 (f-def () (aref widget-defs (f-idx)))
+                 (validate ()
+                   (let* ((v (slot-value (f-def) 'validator))
+                          (name (slot-value (f-def) 'name))
+                          (text (form-value data name))
+                          (r (funcall v text)))
+                     (when r
+                       (setf (form-value data name) r)))))
+          (loop
+             (ensure-widget-visible form (f-idx))
+             (refresh form)
+             (let ((key (activate (f-peer) :key-callback #'callback)))
+               (case key
+                 ((#\Return #\Newline #\Tab :key-down)
+                  #|(setf focus (mod (1+ focus) n))|#
+                  (validate)
+                  (incf focus)
+                  (boundf focus 0 (1- n)))
+                 ((:key-btab :key-up)
+                  #|(setf focus (mod (1- focus) n))|#
+                  (validate)
+                  (decf focus)
+                  (boundf focus 0 (1- n)))
+                 (t
+                  (return-from activate key))))))))))