Update of /project/mcclim/cvsroot/mcclim/Goatee In directory common-lisp.net:/tmp/cvs-serv16423/Goatee Modified Files: clim-area.lisp editing-stream.lisp Log Message: Fixed presentation highlighting to do the right thing in the :SINGLE-BOX NIL case. Fixed Goatee to not draw anything when drawing is not enabled for the stream. Changed input editing streams to never put activation gestures in the input buffer. There is only one place to receive an activation gesture: the end of the buffer. If the user types an activation gesture, the insertion pointer is moved to the end of the buffer. Fixed various problems with accepting-values. In particular, the insertion pointer does not need to be left at the end of a field when the user exits the dialog. Also, the behavior in the presence of errors new: if an error occurs while the user is typing in an accepting-values field, the bell is beeped and the insertion pointer is positioned before the stream position where the error occured. Date: Tue Feb 22 15:00:18 2005 Author: tmoore Index: mcclim/Goatee/clim-area.lisp diff -u mcclim/Goatee/clim-area.lisp:1.30 mcclim/Goatee/clim-area.lisp:1.31 --- mcclim/Goatee/clim-area.lisp:1.30 Fri Feb 11 11:03:07 2005 +++ mcclim/Goatee/clim-area.lisp Tue Feb 22 15:00:18 2005 @@ -556,30 +556,31 @@ (line-text-width area line :end line-unchanged-from-end) new-line-end))) - (multiple-value-bind (x y) - (output-record-position line) - ;; Move unchanged text at the end of line, if needed - (when (and (not (eql line-unchanged-from-end new-line-size)) - (not (eql current-unchanged-left - new-unchanged-left))) - (copy-area medium - (+ current-unchanged-left x) - y - (- line-end current-unchanged-left) - (+ ascent descent) - (+ new-unchanged-left x) - y)) - ;; If the line is now shorter, erase the old end of line. - (erase-line line medium new-line-end line-end) - ;; Erase the changed middle - (erase-line line medium start-width new-unchanged-left) - ;; Draw the middle - (when (< line-unchanged-from-start line-unchanged-from-end) - (draw-text* medium current-contents - (+ x start-width) baseline - :start line-unchanged-from-start - :end line-unchanged-from-end - :ink (foreground-ink line)))) + (when (stream-drawing-p stream) + (multiple-value-bind (x y) + (output-record-position line) + ;; Move unchanged text at the end of line, if needed + (when (and (not (eql line-unchanged-from-end new-line-size)) + (not (eql current-unchanged-left + new-unchanged-left))) + (copy-area medium + (+ current-unchanged-left x) + y + (- line-end current-unchanged-left) + (+ ascent descent) + (+ new-unchanged-left x) + y)) + ;; If the line is now shorter, erase the old end of line. + (erase-line line medium new-line-end line-end) + ;; Erase the changed middle + (erase-line line medium start-width new-unchanged-left) + ;; Draw the middle + (when (< line-unchanged-from-start line-unchanged-from-end) + (draw-text* medium current-contents + (+ x start-width) baseline + :start line-unchanged-from-start + :end line-unchanged-from-end + :ink (foreground-ink line))))) ;; Old, wrong, bounding rectangle (with-bounding-rectangle* (old-min-x old-min-y old-max-x old-max-y) line Index: mcclim/Goatee/editing-stream.lisp diff -u mcclim/Goatee/editing-stream.lisp:1.20 mcclim/Goatee/editing-stream.lisp:1.21 --- mcclim/Goatee/editing-stream.lisp:1.20 Sun Oct 24 17:47:02 2004 +++ mcclim/Goatee/editing-stream.lisp Tue Feb 22 15:00:18 2005 @@ -150,44 +150,54 @@ gesture type) (declare (ignore type)) + (when (activation-gesture-p gesture) + (setf (stream-insertion-pointer stream) + (fill-pointer (stream-input-buffer stream))) + (set-editing-stream-insertion-pointer stream + (stream-insertion-pointer stream)) + (setf (climi::activation-gesture stream) gesture) + (rescan-if-necessary stream) + (return-from stream-process-gesture gesture)) (let ((area (area stream)) (snapshot (snapshot stream))) (execute-gesture-command gesture area *simple-area-gesture-table*) - (make-input-editing-stream-snapshot snapshot area) - (let ((first-mismatch (mismatch (stream-input-buffer snapshot) - (stream-input-buffer stream)))) - (unwind-protect - (cond ((null first-mismatch) - ;; No change actually took place, event though IP may have - ;; moved. - nil) - ((< first-mismatch (stream-scan-pointer stream)) - (immediate-rescan stream)) - ((and (eql first-mismatch - (1- (stream-insertion-pointer snapshot))) - (eql (aref (stream-input-buffer snapshot) first-mismatch) - gesture)) - ;; As best we can tell an insertion happened: one gesture was - ;; entered it was inserted in the buffer. There may be other - ;; changes above IP, but we don't care. - gesture) - (t - ;; Other random changes, but we want to allow more editing - ;; before scanning them. - nil)) - (let ((snapshot-buffer (stream-input-buffer snapshot)) - (stream-buffer (stream-input-buffer stream))) - (setf (stream-insertion-pointer stream) - (stream-insertion-pointer snapshot)) - (when (< (car (array-dimensions stream-buffer)) - (fill-pointer snapshot-buffer)) - (adjust-array stream-buffer (fill-pointer snapshot-buffer))) - (setf (fill-pointer stream-buffer) (fill-pointer snapshot-buffer)) - (when (and first-mismatch - (>= (fill-pointer snapshot-buffer) first-mismatch)) - (replace stream-buffer snapshot-buffer - :start1 first-mismatch - :start2 first-mismatch))))))) + (make-input-editing-stream-snapshot snapshot area) + (let ((first-mismatch (mismatch (stream-input-buffer snapshot) + (stream-input-buffer stream)))) + (unwind-protect + (cond ((null first-mismatch) + ;; No change actually took place, event though IP may have + ;; moved. + nil) + ((< first-mismatch (stream-scan-pointer stream)) + ;; Throw out. Buffer is still updated by protect forms + (immediate-rescan stream)) + ((and (eql first-mismatch + (1- (stream-insertion-pointer snapshot))) + (eql (aref (stream-input-buffer snapshot) first-mismatch) + gesture)) + ;; As best we can tell an insertion happened: one gesture was + ;; entered it was inserted in the buffer. There may be other + ;; changes above IP, but we don't care. + gesture) + (t + ;; Other random changes, but we want to allow more editing + ;; before scanning them. + (queue-rescan stream) + nil)) + (let ((snapshot-buffer (stream-input-buffer snapshot)) + (stream-buffer (stream-input-buffer stream))) + (setf (stream-insertion-pointer stream) + (stream-insertion-pointer snapshot)) + (when (< (car (array-dimensions stream-buffer)) + (fill-pointer snapshot-buffer)) + (adjust-array stream-buffer (fill-pointer snapshot-buffer))) + (setf (fill-pointer stream-buffer) (fill-pointer snapshot-buffer)) + (when (and first-mismatch + (>= (fill-pointer snapshot-buffer) first-mismatch)) + (replace stream-buffer snapshot-buffer + :start1 first-mismatch + :start2 first-mismatch))))))) (defun reposition-stream-cursor (stream) "Moves the cursor somewhere clear of Goatee's editing area." @@ -243,6 +253,16 @@ :format "Location line ~S pos ~S isn't in buffer ~S" :format-arguments (list line pos buffer))) (return (+ total-offset pos))))) + +(defgeneric set-editing-stream-insertion-pointer (stream pointer)) + +(defmethod set-editing-stream-insertion-pointer + ((stream goatee-input-editing-mixin) pointer) + (let* ((area (area stream)) + (buffer (buffer area))) + (setf (point* buffer) (location*-offset buffer pointer)) + (redisplay-area area))) + (defun %replace-input (stream new-input start end buffer-start rescan rescan-supplied-p