Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15930
Modified Files: builtin-commands.lisp commands.lisp input-editing.lisp panes.lisp presentation-defs.lisp Log Message:
Added some improvements to accept-from-string so that random accept methods and default processing are more likely to work with it.
Added a null command and null-command presentation type so that the REPL doesn't print something obnoxious when the user enters an empty command.
Some fixes to default processing.
Date: Wed Jun 22 11:49:16 2005 Author: tmoore
Index: mcclim/builtin-commands.lisp diff -u mcclim/builtin-commands.lisp:1.18 mcclim/builtin-commands.lisp:1.19 --- mcclim/builtin-commands.lisp:1.18 Sat Jan 22 09:42:40 2005 +++ mcclim/builtin-commands.lisp Wed Jun 22 11:49:15 2005 @@ -24,6 +24,10 @@
;;; Global help command
+(define-command (com-null-command :command-table global-command-table :name nil) + () + nil) + (define-command (com-help :command-table global-command-table :name "Help") ((kind '(completion (("Keyboard" keyboard) ("Commands" commands)) :value-key cadr)
Index: mcclim/commands.lisp diff -u mcclim/commands.lisp:1.51 mcclim/commands.lisp:1.52 --- mcclim/commands.lisp:1.51 Mon Jan 24 10:36:00 2005 +++ mcclim/commands.lisp Wed Jun 22 11:49:15 2005 @@ -1216,6 +1216,23 @@ (position *unsupplied-argument-marker* command))) (t (values command type)))))
+;;; A presentation type for empty input at the command line; something for +;;; read-command to supply as a default. The command is defined in +;;; builtin-commands.lisp. + +(define-presentation-type null-command + () + :inherit-from '(command :command-table global-command-table)) + +(define-presentation-method presentation-typep (object (type null-command)) + (and (consp object) (eq (car object) 'com-null-command))) + +(define-presentation-method present + (object (type null-command) stream (view textual-view) &key) + (declare (ignore object stream view))) + +(defparameter +null-command+ '(com-null-command)) + (defclass presentation-command-translator (presentation-translator) () (:documentation "Wraps the tester function with a test that @@ -1308,16 +1325,20 @@ ((or (typep stream 'interactor-pane) (typep stream 'input-editing-stream)) (handler-case - (let ((command (accept `(command :command-table ,command-table) - :stream stream - :prompt nil))) - (if (partial-command-p command) - (progn - (beep) - (format *query-io* "~&Argument ~D not supplied.~&" - (position *unsupplied-argument-marker* command)) - nil) - command)) + (multiple-value-bind (command ptype) + (accept `(command :command-table ,command-table) + :stream stream + :prompt nil + :default +null-command+ + :default-type 'null-command) + (cond ((eq ptype 'null-command) + nil) + ((partial-command-p command) + (beep) + (format *query-io* "~&Argument ~D not supplied.~&" + (position *unsupplied-argument-marker* command)) + nil) + (t command))) ((or simple-parse-error input-not-of-required-type) (c) (beep) (fresh-line *query-io*)
Index: mcclim/input-editing.lisp diff -u mcclim/input-editing.lisp:1.46 mcclim/input-editing.lisp:1.47 --- mcclim/input-editing.lisp:1.46 Sun Feb 27 01:06:27 2005 +++ mcclim/input-editing.lisp Wed Jun 22 11:49:15 2005 @@ -869,7 +869,8 @@ ;;; not. ;;; XXX Actually, it would be a violation of the `accept' protocol to consume ;;; the gesture, but who knows what random accept methods are doing. -(defun empty-input-p (stream begin-scan-pointer completion-gestures) +(defun empty-input-p + (stream begin-scan-pointer activation-gestures delimiter-gestures) (let ((scan-pointer (stream-scan-pointer stream)) (fill-pointer (fill-pointer (stream-input-buffer stream)))) ;; activated? @@ -881,7 +882,8 @@ (let ((gesture (aref (stream-input-buffer stream) begin-scan-pointer))) (and (characterp gesture) - (gesture-match gesture completion-gestures)))) + (or (gesture-match gesture activation-gestures) + (gesture-match gesture delimiter-gestures))))) (t nil))))
;;; The control flow in here might be a bit confusing. The handler catches @@ -900,13 +902,15 @@ (unless (input-editing-stream-p stream) (return-from invoke-handle-empty-input (funcall input-continuation))) (let ((begin-scan-pointer (stream-scan-pointer stream)) - (completion-gestures *completion-gestures*)) + (activation-gestures *activation-gestures*) + (delimiter-gestures *delimiter-gestures*)) (block empty-input (handler-bind (((or simple-parse-error empty-input-condition) #'(lambda (c) (when (empty-input-p stream begin-scan-pointer - completion-gestures) + activation-gestures + delimiter-gestures) (if (typep c 'empty-input-condition) (signal c) (signal 'empty-input-condition :stream stream)) @@ -914,4 +918,5 @@ (return-from empty-input nil))))) (return-from invoke-handle-empty-input (funcall input-continuation)))) (funcall handler-continuation))) +
Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.152 mcclim/panes.lisp:1.153 --- mcclim/panes.lisp:1.152 Mon Mar 14 23:03:05 2005 +++ mcclim/panes.lisp Wed Jun 22 11:49:15 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.
-;;; $Id: panes.lisp,v 1.152 2005/03/14 22:03:05 tmoore Exp $ +;;; $Id: panes.lisp,v 1.153 2005/06/22 09:49:15 tmoore Exp $
(in-package :clim-internals)
@@ -2518,7 +2518,9 @@ (defmethod close ((stream window-stream) &key abort) (declare (ignore abort)) - (disable-frame (pane-frame stream)) + (let ((frame (pane-frame stream))) + (when frame + (disown-frame (frame-manager frame) frame))) (call-next-method))
(define-application-frame a-window-stream (standard-encapsulating-stream
Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.43 mcclim/presentation-defs.lisp:1.44 --- mcclim/presentation-defs.lisp:1.43 Fri Feb 25 15:15:17 2005 +++ mcclim/presentation-defs.lisp Wed Jun 22 11:49:15 2005 @@ -927,17 +927,44 @@ (declare (ignore type view other-args)) nil)
+;;; XXX This needs work! It needs to do everything that accept does for +;;; expanding ptypes and setting up recursive call processing (defun accept-from-string (type string &rest args &key view - default - default-type + (default nil defaultp) + (default-type nil default-type-p) + activation-gestures additional-activation-gestures + delimiter-gestures additional-delimiter-gestures (start 0) (end (length string))) - (declare (ignore view default default-type)) - (with-input-from-string (stream string :start start :end end) - (with-keywords-removed (args (:start :end)) - (apply #'stream-accept stream type :view +textual-view+ args)))) + (declare (ignore view activation-gestures + additional-activation-gestures + delimiter-gestures additional-delimiter-gestures)) + (with-activation-gestures ((if additional-activations-p + additional-activation-gestures + activation-gestures) + :override activationsp) + (with-delimiter-gestures ((if additional-delimiters-p + additional-delimiter-gestures + delimiter-gestures) + :override delimitersp))) + (when (or (zerop (- end start)) + (let ((maybe-end)))) + (if defaultp + (return-from accept-from-string (values default + (if default-type-p + default-type + type) + 0)) + (simple-parse-error "Empty string"))) + (let ((index 0)) + (multiple-value-bind (val ptype) + (with-input-from-string (stream string :start start :end end + :index index) + (with-keywords-removed (args (:start :end)) + (apply #'stream-accept stream type :view +textual-view+ args))) + (values val ptype index))))
(define-presentation-generic-function %presentation-refined-position-test presentation-refined-position-test