[mcclim-devel] ABORT gesture for ACCEPT (was: One char patch to presentation-defs [really future of McCLIM]
Max-Gerd Retzlaff
m.retzlaff at gmx.net
Mon Aug 22 18:34:56 UTC 2005
Hi
On Mon, Aug 22, 2005 at 12:10:45PM -0500, Robert P. Goldman wrote:
> Similarly, as I mentioned earlier, it would be nice if one could use
> the ABORT gesture in the middle of ACCEPT and have something good
> happen. Seems like if I type something bad and can't fix it in
> input-editing, I'm just doomed to complete the interaction, and then
> have the command fail into the debugger. I looked into this a little,
> and it seemed like there was no place in the %ACCEPT code that looked
> for an ABORT gesture, but the bottom layers of McCLIM are pretty
> mysterious to me. Is this a GOATEE thing, or should it be handle by
> %ACCEPT or ACCEPT-FROM-STREAM? If you can give me a pointer, I'd be
> happy to try to fix it myself.
Some minutes after you seemed to have left the channel I posted a patch
for you. Basically it is just adding (handler-bind ((abort-gesture #'abort))
in the beginning of ACCEPT in presentation-defs.lisp. That seems to be
okay.
ABORT-GESTURE is the condition that is signaled when any of the
gestures in *ABORT-GESTURES* is read (in STREAM-READ-GESTURE). Right
now *ABORT-GESTURES* contains only :abort on mcclim, which is a the
keyboard gesture (#\c :control) (on Genera it contains #\Abort, the
ABORT-key).
I do not find explicitly in the clim specification that an accept should
be aborted on any abort-gesture, but it seems to be the right thing.
I did short tests with ACCEPTING-VALUES and it seems to behave correctly
with this patch, i.e. the whole dialog will be aborted. Or would it be
better if only the editing of the single input-gadget is aborted?
Also Genera CLIM and Dynamic Windows behave in the same way, although
one gets thrown into the debugger if one presses ABORT during editing
a text-field of an CLIM:ACCEPTING-VALUES dialog... This does not
happen with McCLIM and this patch.
If noone complains I'll apply it to the repository.
Regards,
Max
--
Max-Gerd Retzlaff <m.retzlaff at gmx.net>
For your amusement:
Stay away from hurricanes for a while.
-------------- next part --------------
--- presentation-defs.lisp.~1.44.~ 2005-06-24 01:12:42.000000000 +0200
+++ presentation-defs.lisp 2005-08-22 19:31:42.024459480 +0200
@@ -664,71 +664,72 @@
display-default query-identifier
activation-gestures additional-activation-gestures
delimiter-gestures additional-delimiter-gestures))
- (let* ((real-type (expand-presentation-type-abbreviation type))
- (real-default-type (cond (default-type-p
- (expand-presentation-type-abbreviation
- default-type))
- ((or defaultp provide-default)
- real-type)
- (t nil)))
- (real-history-type (cond ((null historyp) real-type)
- ((null history) nil)
- (t (expand-presentation-type-abbreviation
- history))))
- (*recursive-accept-p* *recursive-accept-1-p*)
- (*recursive-accept-1-p* t))
- (with-keywords-removed (rest-args (:stream))
- (when (or default-type-p defaultp)
- (setf rest-args
- (list* :default-type real-default-type rest-args)))
- (when historyp
- (setf rest-args (list* :history real-history-type rest-args)))
- (cond ((and viewp (symbolp view))
- (setf rest-args
- (list* :view (funcall #'make-instance view) rest-args)))
- ((consp view)
- (setf rest-args
- (list* :view (apply #'make-instance view) rest-args))))
- ;; Presentation type history interaction. According to the spec,
- ;; if provide-default is true, we take the default from the
- ;; presentation history. In addition, we'll implement the Genera
- ;; behavior of temporarily putting the default on the history
- ;; stack so the user can conveniently suck it in.
- (flet ((do-accept (args)
- (apply #'stream-accept stream real-type args))
- (get-history ()
- (when real-history-type
- (funcall-presentation-generic-function
- presentation-type-history-for-stream
- real-history-type stream))))
- (let* ((default-from-history (and (not defaultp) provide-default))
- (history (get-history))
- (results
- (multiple-value-list
- (if history
- (let ((*active-history-type* real-history-type))
- (cond (defaultp
- (with-object-on-history
- (history default real-default-type)
- (do-accept rest-args)))
- (default-from-history
- (multiple-value-bind
- (history-default history-type)
- (presentation-history-head history
- real-default-type)
- (do-accept (if history-type
- (list* :default history-default
- :default-type history-type
- rest-args)
- rest-args))))
- (t (do-accept rest-args))))
- (do-accept rest-args))))
- (results-history (get-history)))
- (when results-history
- (presentation-history-add results-history
- (car results)
- (cadr results)))
- (values-list results))))))
+ (handler-bind ((abort-gesture #'abort))
+ (let* ((real-type (expand-presentation-type-abbreviation type))
+ (real-default-type (cond (default-type-p
+ (expand-presentation-type-abbreviation
+ default-type))
+ ((or defaultp provide-default)
+ real-type)
+ (t nil)))
+ (real-history-type (cond ((null historyp) real-type)
+ ((null history) nil)
+ (t (expand-presentation-type-abbreviation
+ history))))
+ (*recursive-accept-p* *recursive-accept-1-p*)
+ (*recursive-accept-1-p* t))
+ (with-keywords-removed (rest-args (:stream))
+ (when (or default-type-p defaultp)
+ (setf rest-args
+ (list* :default-type real-default-type rest-args)))
+ (when historyp
+ (setf rest-args (list* :history real-history-type rest-args)))
+ (cond ((and viewp (symbolp view))
+ (setf rest-args
+ (list* :view (funcall #'make-instance view) rest-args)))
+ ((consp view)
+ (setf rest-args
+ (list* :view (apply #'make-instance view) rest-args))))
+ ;; Presentation type history interaction. According to the spec,
+ ;; if provide-default is true, we take the default from the
+ ;; presentation history. In addition, we'll implement the Genera
+ ;; behavior of temporarily putting the default on the history
+ ;; stack so the user can conveniently suck it in.
+ (flet ((do-accept (args)
+ (apply #'stream-accept stream real-type args))
+ (get-history ()
+ (when real-history-type
+ (funcall-presentation-generic-function
+ presentation-type-history-for-stream
+ real-history-type stream))))
+ (let* ((default-from-history (and (not defaultp) provide-default))
+ (history (get-history))
+ (results
+ (multiple-value-list
+ (if history
+ (let ((*active-history-type* real-history-type))
+ (cond (defaultp
+ (with-object-on-history
+ (history default real-default-type)
+ (do-accept rest-args)))
+ (default-from-history
+ (multiple-value-bind
+ (history-default history-type)
+ (presentation-history-head history
+ real-default-type)
+ (do-accept (if history-type
+ (list* :default history-default
+ :default-type history-type
+ rest-args)
+ rest-args))))
+ (t (do-accept rest-args))))
+ (do-accept rest-args))))
+ (results-history (get-history)))
+ (when results-history
+ (presentation-history-add results-history
+ (car results)
+ (cadr results)))
+ (values-list results)))))))
(defgeneric stream-accept (stream type
&key
-------------- next part --------------
A non-text attachment was scrubbed...
Name: not available
Type: application/pgp-signature
Size: 189 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/mcclim-devel/attachments/20050822/4e2e42e1/attachment.sig>
More information about the mcclim-devel
mailing list