Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7003
Modified Files: input-editing.lisp Log Message: Implement classic CLIM behavior for :erase keyword in with-input-editor-typeout.
Doesn't mesh well with border output records, for some reason.
--- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/03 11:35:22 1.70 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2008/02/03 12:11:13 1.71 @@ -67,6 +67,18 @@ (:documentation "A mixin implementing some useful standard behavior for input-editing streams."))
+(defmethod typeout-record :around ((stream standard-input-editing-mixin)) + ;; Can't do this in an initform, since we need to proper position... + (or (call-next-method) + (let ((record + (make-instance 'standard-sequence-output-record + :x-position 0 + :y-position (bounding-rectangle-min-y + (input-editing-stream-output-record stream))))) + (stream-add-output-record (encapsulating-stream-stream stream) + record) + (setf (typeout-record stream) record)))) + ;;; These helper functions take the arguments of ACCEPT so that they ;;; can be used directly by ACCEPT.
@@ -224,39 +236,42 @@
(defmethod invoke-with-input-editor-typeout ((editing-stream standard-input-editing-mixin) (continuation function) &key erase) - (declare (ignore erase)) - (let* ((encapsulated-stream (encapsulating-stream-stream editing-stream)) - (new-typeout-record (with-output-to-output-record (encapsulated-stream) - (funcall continuation encapsulated-stream))) - (editor-record (input-editing-stream-output-record editing-stream))) - (with-accessors ((stream-typeout-record typeout-record)) editing-stream + (with-accessors ((stream-typeout-record typeout-record)) editing-stream + ;; Can't do this in an initform, as we need to set the proper + ;; output record position. + (let* ((encapsulated-stream (encapsulating-stream-stream editing-stream)) + (old-min-y (bounding-rectangle-min-y stream-typeout-record)) + (old-height (bounding-rectangle-height stream-typeout-record)) + (new-typeout-record (with-output-to-output-record (encapsulated-stream + 'standard-sequence-output-record + record) + (unless erase + ;; Steal the children of the old typeout record. + (map nil #'(lambda (child) + (setf (output-record-parent child) nil + (output-record-position child) (values 0 0)) + (add-output-record child record)) + (output-record-children stream-typeout-record)) + ;; Make sure new output is done + ;; after the stolen children. + (stream-increment-cursor-position + encapsulated-stream 0 old-height)) + (funcall continuation encapsulated-stream)))) (with-sheet-medium (medium encapsulated-stream) - (setf (output-record-position new-typeout-record) - (values 0 (bounding-rectangle-min-y (or stream-typeout-record editor-record)))) + (setf (output-record-position new-typeout-record) (values 0 old-min-y)) ;; Calculate the height difference between the old typeout and the new. - (let ((delta-y (- (bounding-rectangle-height new-typeout-record) - (if stream-typeout-record - (bounding-rectangle-height stream-typeout-record) - 0)))) + (let ((delta-y (- (bounding-rectangle-height new-typeout-record) old-height))) (multiple-value-bind (typeout-x typeout-y) (output-record-position new-typeout-record) (declare (ignore typeout-x)) - ;; Clear the old typeout. - (when stream-typeout-record - (clear-output-record stream-typeout-record)) + ;; Clear the old typeout... + (clear-output-record stream-typeout-record) + ;; Move stuff for the new typeout record... (sheet-move-output-vertically encapsulated-stream typeout-y delta-y) - ;; Reuse the old stream-typeout-record, if any. - (cond (stream-typeout-record - (add-output-record new-typeout-record stream-typeout-record)) - (t - (stream-add-output-record encapsulated-stream new-typeout-record) - (setf stream-typeout-record new-typeout-record))) + ;; Reuse the old stream-typeout-record... + (add-output-record new-typeout-record stream-typeout-record) ;; Now, let there be light! - (with-bounding-rectangle* (x1 y1 x2 y2) stream-typeout-record - (declare (ignore x2)) - (repaint-sheet encapsulated-stream - (make-bounding-rectangle - x1 y1 (bounding-rectangle-width encapsulated-stream) y2))))))))) + (repaint-sheet encapsulated-stream stream-typeout-record)))))))
(defun clear-typeout (&optional (stream t)) "Blank out the input-editor typeout displayed on `stream',