/[mcclim]/mcclim/dialog.lisp
ViewVC logotype

Diff of /mcclim/dialog.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.13 by moore, Fri Oct 15 13:05:36 2004 UTC revision 1.14 by moore, Sun Oct 24 15:47:02 2004 UTC
# Line 67  accept of this query"))) Line 67  accept of this query")))
67    
68  (defclass accepting-values-stream (standard-encapsulating-stream)  (defclass accepting-values-stream (standard-encapsulating-stream)
69    ((queries :accessor queries :initform nil)    ((queries :accessor queries :initform nil)
70     (selected-query :accessor selected-query :initform nil)))     (selected-query :accessor selected-query :initform nil)
71       (align-prompts :accessor align-prompts :initarg :align-prompts
72                      :initform nil)))
73    
74  (defmethod stream-default-view ((stream accepting-values-stream))  (defmethod stream-default-view ((stream accepting-values-stream))
75    +textual-dialog-view+)    +textual-dialog-view+)
# Line 127  accept of this query"))) Line 129  accept of this query")))
129       (command-table 'accepting-values)       (command-table 'accepting-values)
130       (frame-class 'accept-values))       (frame-class 'accept-values))
131    (declare (ignore own-window exit-boxes modify-initial-query    (declare (ignore own-window exit-boxes modify-initial-query
132      resize-frame align-prompts label scroll-bars x-position y-position      resize-frame label scroll-bars x-position y-position
133      width height frame-class))      width height frame-class))
134    (let* ((*accepting-values-stream* (make-instance 'accepting-values-stream    (let* ((*accepting-values-stream*
135                                                    :stream stream))            (make-instance 'accepting-values-stream
136                             :stream stream
137                             :align-prompts align-prompts))
138           (arecord (updating-output (stream           (arecord (updating-output (stream
139                                      :record-type 'accepting-values-record)                                      :record-type 'accepting-values-record)
140                      (funcall body *accepting-values-stream*)                      (if align-prompts
141                            (formatting-table (stream)
142                              (funcall body *accepting-values-stream*))
143                            (funcall body *accepting-values-stream*))
144                      (display-exit-boxes *application-frame*                      (display-exit-boxes *application-frame*
145                                          stream                                          stream
146                                          (stream-default-view                                          (stream-default-view
# Line 205  accept of this query"))) Line 212  accept of this query")))
212    (declare (ignore activation-gestures additional-activation-gestures    (declare (ignore activation-gestures additional-activation-gestures
213                     delimiter-gestures additional-delimiter-gestures))                     delimiter-gestures additional-delimiter-gestures))
214    (let ((query (find query-identifier (queries stream)    (let ((query (find query-identifier (queries stream)
215                       :key #'query-identifier :test #'equal)))                       :key #'query-identifier :test #'equal))
216            (align (align-prompts stream)))
217      (unless query      (unless query
218        (setq query (make-instance 'query        (setq query (make-instance 'query
219                                   :query-identifier query-identifier                                   :query-identifier query-identifier
# Line 220  accept of this query"))) Line 228  accept of this query")))
228      (unless (equal default (default query))      (unless (equal default (default query))
229        (setf (default query) default)        (setf (default query) default)
230        (setf (value query) default))        (setf (value query) default))
231      (let ((query-record (funcall-presentation-generic-function      (flet ((do-prompt ()
232                           accept-present-default               (apply #'prompt-for-accept stream type view rest-args))
233                           type (encapsulating-stream-stream stream) view             (do-accept-present-default ()
234                           (value query)               (funcall-presentation-generic-function
235                           default-supplied-p                accept-present-default
236                           nil query-identifier)))                type (encapsulating-stream-stream stream) view
237        (setf (record query) query-record)                (value query)
238        (when (accept-condition query)                default-supplied-p nil query-identifier)))
239          (signal (accept-condition query)))        (let ((query-record nil))
240        (multiple-value-prog1          (if align
241            (values (value query) (ptype query) (changedp query))              (formatting-row (stream)
242          (setf (default query) default)                (formatting-cell (stream :align-x align)
243          (setf (ptype query) type)                  (do-prompt))
244          (setf (changedp query) nil)))))                (formatting-cell (stream)
245                    (setq query-record (do-accept-present-default))))
246                (progn
247                  (do-prompt)
248                  (setq query-record (do-accept-present-default))))
249            (setf (record query) query-record)
250            (when (accept-condition query)
251              (signal (accept-condition query)))
252            (multiple-value-prog1
253                (values (value query) (ptype query) (changedp query))
254              (setf (default query) default)
255              (setf (ptype query) type)
256              (setf (changedp query) nil))))))
257    
258    
259  (defmethod prompt-for-accept ((stream accepting-values-stream)  (defmethod prompt-for-accept ((stream accepting-values-stream)
260                                type view                                type view
# Line 339  is called. Used to determine if any edit Line 360  is called. Used to determine if any edit
360                               (make-instance 'standard-input-editing-stream                               (make-instance 'standard-input-editing-stream
361                                              :stream stream                                              :stream stream
362                                              :cursor-visibility nil                                              :cursor-visibility nil
363                                              :background-ink +grey90+))))                                              :background-ink +grey90+
364                                                :single-line t))))
365                     (when default-supplied-p                     (when default-supplied-p
366                       (input-editing-rescan-loop ;XXX probably not needed                       (input-editing-rescan-loop ;XXX probably not needed
367                        editing-stream                        editing-stream
# Line 403  is called. Used to determine if any edit Line 425  is called. Used to determine if any edit
425                             :rescan t)))                             :rescan t)))
426          (setf (cursor-visibility estream) t)          (setf (cursor-visibility estream) t)
427          (setf (snapshot record) (copy-seq stream-input-buffer))          (setf (snapshot record) (copy-seq stream-input-buffer))
428          (handler-case          (block accept-condition-handler
429              (av-do-accept query record)            (handler-bind ((condition #'(lambda (c)
430            (condition (c)                                          (format *trace-output*
431              (format *trace-output* "accepting-values accept condition: ~A~%"                                                  "accepting-values accept condition: ~A~%"
432                      c)                                                  c)
433              (setf (accept-condition query) c)))))))                                          (setf (accept-condition query) c)
434                                            (return-from accept-condition-handler
435                                              c))))
436                (av-do-accept query record)))))))
437    
438    
439    
440  (defmethod deselect-query (stream query (record av-text-record))  (defmethod deselect-query (stream query (record av-text-record))

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.14

  ViewVC Help
Powered by ViewVC 1.1.5