CLIM mail archive


ie-patch.lisp (long)

  Date: Fri, 2 Oct 1992 10:52-0400
  From: Scott McKay <>
  Subject: CR Activation Character Accepting PATHNAME

  This is fixed in CLIM 2.0.  Jeff Morrill may also have a private patch
  that we created to fix this, too, but I don't recall for sure.

Ok, here is that famous patch file again.

Vince, could you please add this to the library for clim 1?  It contains
a pile of fixes to the buggy input editor of clim 1.1.

I don't know if it will fix this particular problem or not.

jeff morrill

;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: CLIM; Base: 10; Patch-File: T -*-
;;; Patch file for Private version 0.0
;;;   this with RESCAN-FOR-ACTIVATION, and flush the latter.
;;; Function (METHOD STREAM-READ-GESTURE (INTERACTIVE-STREAM-MIXIN)):  Inhibit activation rescans,
;;;   reverse two clauses that could only ever have been buggy.
;;; Function CLIM:COMPLETE-INPUT:  ..
;;; Macro DEFINE-INPUT-EDITOR-COMMAND:  Make the default behavior be to queue a rescan, not do an
;;;   immediate rescan.
;;; Recompile all the affected IE commands.
;;; Written by SWM, 4/23/92 11:26:44
;;; while running on Zion from FEP0:>see-clim-8-1-1.load.1
;;; with Genera 8.1.1, Logical Pathnames Translation Files NEWEST, CLIM 28.5,
;;; CLIM Demo 28.2, CLX 431.0, microcode 3640-FPA-MIC 430, FEP 127,
;;; FEP0:>v127-lisp.flod(64), FEP0:>v127-loaders.flod(64), FEP0:>v127-info.flod(64),
;;; FEP0:>v127-debug.flod(38), 1067x748 B&W Screen, Machine serial number 4001.

(in-package :clim)

(eval-when (compile load eval)
  (fmakunbound 'clim::rescan-if-necessary))

;; Do a rescan if one is pending.
;; If it's an "activation" rescan, that means that the user typed an activation
;; character at some point, so this rescan should terminate all input.  That's
;; why we set the insertion pointer to the end of the buffer...
;; In the cases where the program is maintaining another input buffer besides
;; the input editor's buffer, that buffer can get out of synch (for instance,
;; it could appear to be empty) because the user yanked something in and then
;; immediately hit <End>.  In that case, the yank commands have left a rescan
;; pending which we can take care of now.  In general, any piece of code that
;; is maintaining an input buffer separate from the input editor's buffer should
;; call RESCAN-IF-NECESSARY before parsing any input.
(defmethod rescan-if-necessary ((istream interactive-stream-mixin) 
				&optional inhibit-activation)
  (with-slots (rescan-queued input-buffer insertion-pointer) istream
    (when rescan-queued
      (when (and (eql rescan-queued ':activation)
		 (not inhibit-activation))
	(setq insertion-pointer (fill-pointer input-buffer)))
      (setf rescan-queued nil)
      (throw 'rescan (values)))))

(scl:fundefine '(method stream-read-gesture (interactive-stream-mixin)))

(defmethod stream-read-gesture
	   ((istream interactive-stream-mixin)
	    &key timeout peek-p
		 (input-wait-test *input-wait-test*)
		 (input-wait-handler *input-wait-handler*)
		 (pointer-button-press-handler *pointer-button-press-handler*))
  (rescan-if-necessary istream t)
  (with-slots (stream input-buffer scan-pointer insertion-pointer
	       activation-character rescanning-p
	       numeric-argument previous-history) istream
    (declare (fixnum scan-pointer insertion-pointer))
    (loop	;until a real gesture is read or we throw out
      ;; First look in the input-buffer of the input-editor and see
      ;; if there's something there.
	(cond ((= scan-pointer insertion-pointer)
	      ((< scan-pointer insertion-pointer)
	       (let ((gesture (aref input-buffer scan-pointer)))
		 (cond ((characterp gesture)
			(unless peek-p (incf scan-pointer))
			(return-from stream-read-gesture (values gesture)))
		       (t (incf scan-pointer)))))
	      (t (return)
		 ;; If the scan pointer is greater than the insertion pointer
		 ;; then we'll definitely have to rescan if a character is typed
		 ;; at this point.

      ;; If we're about to go to the stream but there's an activation 
      ;; character buffered, return it instead.
      (when activation-character
	(return-from stream-read-gesture
	  (prog1 activation-character
		 (unless peek-p
		   (setf activation-character nil)))))

      ;;--- This is presumably much slower than necessary.
      ;;--- Perhaps there is a better way to keep track of where the cursor should be.
      (multiple-value-bind (x-pos y-pos)
	  (input-buffer-input-position->cursor-position* istream insertion-pointer)
	(declare (fixnum x-pos y-pos))
	(multiple-value-bind (cx cy)
	    (stream-cursor-position* stream)
	  (declare (fixnum cx cy))
	  ;; Don't set the cursor position if it's already right.
	  ;; This prevents the input editor from scrolling the window after
	  ;; the user has scrolled it back until the cursor position actually changes.
	  (unless (and (= cx x-pos) (= cy y-pos))
	    (stream-set-cursor-position* stream x-pos y-pos))))

      (setf rescanning-p nil)
      (multiple-value-bind (thing type)
	  (let ((*accelerator-numeric-argument*
		  (or numeric-argument 1))
		  ;; If there's anything in the input buffer, disallow accelerators
		  (and (zerop (fill-pointer input-buffer)) *accelerator-characters*)))
	    (stream-read-gesture stream
	      :timeout timeout :peek-p peek-p
	      :input-wait-test input-wait-test
	      :input-wait-handler input-wait-handler
	      :pointer-button-press-handler pointer-button-press-handler))
	(cond ((eql type ':timeout)
	       (return-from stream-read-gesture
		 (values thing type)))
	       (return-from stream-read-gesture
		 (values thing type)))
	       (multiple-value-bind (new-thing new-type)
		   ;; This can throw out in order to do rescans.
		   ;; NEW-THING is a character, a presentation "blip", or NIL
		   (interactive-stream-process-gesture istream thing type)
		 (when (and (characterp new-thing)
			    ;; Don't put things in the buffer that we can't echo later
			    (ordinary-char-p new-thing)
			    (not (activation-character-p new-thing)))
		   (dotimes (i (or numeric-argument 1))
		     #-(or excl Minima) (declare (ignore i))
		     (cond ((< insertion-pointer (fill-pointer input-buffer))
			    (erase-input-buffer istream insertion-pointer)
			    (setq input-buffer (shift-buffer-portion
						 insertion-pointer (1+ insertion-pointer)))
			    (setf (aref input-buffer insertion-pointer) new-thing)
			    (redraw-input-buffer istream insertion-pointer)
			    (let ((rescan (> scan-pointer insertion-pointer)))
			      (incf insertion-pointer)
			      (if rescan
				  (immediate-rescan istream)
				  (setf scan-pointer insertion-pointer))))
			   (t (vector-push-extend new-thing input-buffer)
			      (incf scan-pointer)
			      (incf insertion-pointer)
			      (when (ordinary-char-p new-thing)
				(write-char new-thing istream))))))
		 (when new-thing
		   (setq numeric-argument nil
			 previous-history nil)
		   (cond ((activation-character-p new-thing)
			  ;; If we got an activation character, we must first finish
			  ;; scanning the input line, moving the insertion-pointer
			  ;; to the end and finishing rescanning.  Only then can we
			  ;; return the activation character.
			  (cond ((= insertion-pointer (fill-pointer input-buffer))
				 (return-from stream-read-gesture
				   (values new-thing new-type)))
				(t (setf insertion-pointer (fill-pointer input-buffer))
				   (setf activation-character new-thing))))
			 ((or (not (characterp new-thing))
			      (ordinary-char-p new-thing))
			  ;; There might be some queued up rescans from destructive
			  ;; input editing commands, so take care of them now
			  (rescan-if-necessary istream t)
			  (return-from stream-read-gesture
			    (values new-thing new-type)))
			   ;; Some input editing doesn't throw, and should not
			   ;; cause us to return just yet, since IE commands don't
			   ;; count as real gestures.
			   (beep istream)))))))))))

;; READ-TOKEN reads characters until it encounters an activation character,
;; a blip character, or something else (like a mouse click).
(defun read-token (stream &key input-wait-handler pointer-button-press-handler 
			       click-only timeout)
  (with-temporary-string (string :length 50 :adjustable t)
    (let* ((gesture nil)
	   (gesture-type nil)
	   (quote-seen nil)
	   (old-blip-chars *blip-characters*)
	   (*blip-characters* *blip-characters*))
      (flet ((return-token (&optional unread)
	       (when unread
		 (unread-gesture unread :stream stream))
	       (when (and (activation-character-p unread)
			  (interactive-stream-p stream))
		 (rescan-if-necessary stream))
	       (return-from read-token
		 (values (evacuate-temporary-string string)))))
	  (multiple-value-setq (gesture gesture-type)
	    (read-gesture :stream stream
			    (or input-wait-handler
			    (or pointer-button-press-handler
			  :timeout (and click-only timeout)))
	  (cond ((eql gesture-type :timeout)
		 (return-from read-token :timeout))
		((and click-only
		      (not (typep gesture 'pointer-button-event)))
		 (beep stream))
		((typep gesture 'pointer-button-event)
		 ;; No need to do anything, since this should have been handled
		 ;; in the presentation type system already
		((characterp gesture)
		 (cond ((and (zerop (fill-pointer string))
			     (eql gesture *quotation-character*))
			(setq quote-seen t)
			(setq *blip-characters* nil))
		       ((and quote-seen
			     (eql gesture *quotation-character*))
			(setq quote-seen nil)
			(setq *blip-characters* old-blip-chars))
		       ((activation-character-p gesture)
			(return-token gesture))
		       ((blip-character-p gesture)
			;; ditto?
			(return-token gesture))
		       ((ordinary-char-p gesture)
			(vector-push-extend gesture string)
			;;--- haven't updated WRITE-CHAR yet
			#+ignore (write-char gesture stream))
		       (t (beep stream))))
		(t (return-token gesture))))))))

(defun complete-input (stream function
		       &key partial-completers allow-any-input possibility-printer
			    (help-displays-possibilities t))
  (declare (dynamic-extent function))
  (declare (values answer-object success string))
  (with-temporary-string (stuff-so-far :length 100 :adjustable t)
   (with-blip-characters (partial-completers)
    (with-activation-characters (*magic-completion-characters*)
     (flet ((completion-help (stream action string-so-far)
	      (declare (ignore string-so-far))
		stream function stuff-so-far
		:possibility-printer possibility-printer
		  (or (eql action :possibilities)
		      (and (eql action :help) help-displays-possibilities)))))
      (declare (dynamic-extent #'completion-help))
      (with-accept-help ((:subhelp #'completion-help))
       ;; Keep the input editor from handling help and possibilities characters.
       ;; They will get treated as activation characters, thus ensuring that 
       ;; STUFF-SO-FAR will be accurate when we display the possibilities.
       (let ((*ie-help-enabled* nil)
	     (location (input-position stream))
	     token ch
	     unread return extend
	     completion-mode completion-type
	(flet ((ends-in-char-p (string char)
		 (let ((sl (length string)))
		   (and (plusp sl)
			(char-equal (aref string (1- sl)) char)))))
	  (declare (dynamic-extent #'ends-in-char-p))
	    ;; Maybe these, as well as TOKEN and CH should be LET inside the loop...
	    (setq unread nil return nil extend nil)
	    (setq token (read-token stream))
	    (setq ch (read-gesture :stream stream))	;don't care about wait functions
	    (extend-vector stuff-so-far token)
	    (cond ((null ch)
		   (error "Null ch?"))
		  ((characterp ch)
		   (cond ((member ch *help-characters*)
			  (setq completion-mode ':help))
			 ((member ch *possibilities-characters*)
			  (setq completion-mode ':possibilities))
			 ((member ch *complete-characters*)
			  (setq completion-mode ':complete-maximal))
			 ((member ch partial-completers :test #'char-equal)
			  (setq completion-mode ':complete-limited
				unread t extend t return 'if-completed))
			 ;; What about "overloaded" partial completers??
			 ((blip-character-p ch)
			  (setq completion-mode (if allow-any-input nil ':complete)
				unread t extend t return t))
			 ((activation-character-p ch)
			  (setq completion-mode (if allow-any-input nil ':complete) 
				unread t return t))))
		  ((eq ch ':eof)
		   (setq completion-mode (if allow-any-input nil ':complete) 
			 return t))
		  (t				;mouse click?
		   (beep stream)))

	    ;; OK, this is a SPECIAL case.  We check to see if the null string
	    ;; was read, and if so, we signal a parse-error (because ACCEPT
	    ;; handles this specially) so that the default value will be filled
	    ;; in by ACCEPT.
	    ;; There is a tension here between wanting to fill in the default and
	    ;; use the maximal left substring when the user types #\End or a field
	    ;; terminator that also does completion.  Putting this check before the
	    ;; completion code means that the default always wins.
	    (when (and return (zerop (fill-pointer stuff-so-far)))
	      (when unread
		(unread-gesture ch :stream stream))
	      (when (interactive-stream-p stream)
		(rescan-if-necessary stream))
	      (simple-parse-error "Attempting to complete the null string"))

	    (cond ((or (eql completion-mode ':help)
		       (eql completion-mode ':possibilities))
		   ;; Since we've asked the input editor not to do this,
		   ;; we must do it here ourselves
		   (display-accept-help stream completion-mode "")
		   (setq completion-type nil))
		   (multiple-value-bind (string success object nmatches)
		       (funcall function stuff-so-far completion-mode)
		     (setq answer-object object)
		     (cond ((= nmatches 0)
			    ;; no valid completion, so no replace input
			    (setq completion-type 'invalid)
			    (when extend
			      (vector-push-extend ch stuff-so-far)))
			   ((= nmatches 1)
			    (setq completion-type (if success 'unique 'ambiguous))
			    ;; replace contents of stuff-so-far with completion
			    (setf (fill-pointer stuff-so-far) 0)
			    (extend-vector stuff-so-far string)
			   ((> nmatches 1)
			    (setq completion-type 'ambiguous)
			    ;; replace contents of stuff-so-far with completion
			    (setf (fill-pointer stuff-so-far) 0)
			    (extend-vector stuff-so-far string)
			    ;; need-to-add-delimiter test??
			    (when (and extend
				       (not (ends-in-char-p string ch)))
			      (vector-push-extend ch stuff-so-far)))))))

	    ;; Check for errors unconditionally, remembering that we may not have
	    ;; called the completer at all (completion-type = NIL)
	    (ecase completion-type
	      ((nil unique left-substring))	; no possible errors to report
	       (unless allow-any-input
		 (when unread
		   (unread-gesture ch :stream stream))
		 (simple-parse-error "Invalid completion: ~A" stuff-so-far)))
	       ;; only beep on ambiguous full completions, in either ALLOW-ANY-INPUT mode
	       (when (eq completion-mode :complete)
		 (beep stream))))

	    (when (eq return 'if-completed)
	      (unless (eq completion-type 'unique)
		(setq return nil)))

	    ;; Decide whether or not to return, remembering that
	    ;; we might have called the completer.
	    (when return
	      (when (or (member completion-type '(nil unique left-substring))
		;; leave the last delimiter for our caller
		(when unread
		  (unread-gesture ch :stream stream))
		;; Must replace-input after unread-gesture so the delimiter is unread
		;; into the input editor's buffer, not the underlying stream's buffer
		(unless (rescanning-p stream)
		  (replace-input stream stuff-so-far :buffer-start location))
		(return-from complete-input
		  (values answer-object t (evacuate-temporary-string stuff-so-far)))))

	    ;; Not returning yet, but update the input editor's buffer anyway
	    (unless (rescanning-p stream)
	      (replace-input stream stuff-so-far :buffer-start location)))))))))))

(defun simple-lisp-object-parser (type stream &optional coerce-test coerce-function)
    (let ((token (read-token stream)))
      (when (interactive-stream-p stream)
	(rescan-if-necessary stream))
      (multiple-value-bind (object index)
	  (let ((*read-eval* nil))		;disable "#."
	    (read-from-string token nil token))
	(when (eq object token)
	  (simple-parse-error "Unexpected EOF"))
	;; Too bad read-from-string doesn't take a :junk-allowed argument
	;; Simulate what it would do
	(unless (>= index (length token))
	  (when (find-if-not #'whitespace-character-p token :start index)
	    (simple-parse-error "Extra junk ~S found after the ~A."
				(subseq token index)
				(describe-presentation-type type nil nil))))
	(when (presentation-typep object type)
	  (return-from simple-lisp-object-parser (values object type)))
	(when coerce-function
	  (when (funcall coerce-test object)
	    (setq object (funcall coerce-function object))
	    (when (presentation-typep object type)
	      (return-from simple-lisp-object-parser (values object type)))))
	(input-not-of-required-type token type)))))

(define-presentation-method accept ((type expression) stream (view textual-view) &key)
  (let ((*read-recursive-objects* nil))
    (with-temporary-string (string)
      (read-recursive stream string nil)
      (when (interactive-stream-p stream)
	(rescan-if-necessary stream))
      (multiple-value-bind (expression index)
	  (read-from-string string nil string)
	(when (eq expression string)
	  (simple-parse-error "The input ~S is not a complete Lisp expression."
			      (evacuate-temporary-string string)))
	;; Too bad READ-FROM-STRING doesn't take a :JUNK-ALLOWED argument.
	;; Simulate what it would do
	(unless (>= index (length string))
	  (when (find-if-not #'whitespace-character-p string :start index)
	    (simple-parse-error "Extra junk ~S found after the expression."
				(subseq string index))))

(defmacro define-input-editor-command ((name &key (rescan T) (type 'motion) history)
				       arglist &body body)
  (multiple-value-bind (arglist ignores)
      (canonicalize-and-match-lambda-lists *ie-command-arglist* arglist)
    (let ((stream (first arglist)))
      `(define-group ,name define-input-editor-command
	 (defun ,name ,arglist
	   ,@(and ignores `((declare (ignore ,@ignores))))
	   (setf (slot-value ,stream 'last-command-type) ',type)
	   ,@(unless history `((setf (slot-value ,stream 'previous-history) nil)))
	   ,@(ecase rescan
	       ((t) `((queue-rescan ,stream)))
	       (:immediate `((immediate-rescan ,stream)))
	       ((nil) nil))

(define-input-editor-command (com-ie-rubout :type delete)
			     (stream input-buffer numeric-argument)
  (ie-rub-del stream input-buffer (- numeric-argument)))

(define-input-editor-command (com-ie-delete-character :type delete)
			     (stream input-buffer numeric-argument)
  (ie-rub-del stream input-buffer numeric-argument))

(define-input-editor-command (com-ie-rubout-word :type kill)
			     (stream input-buffer numeric-argument)
  (ie-rub-del-word stream input-buffer (- numeric-argument)))

(define-input-editor-command (com-ie-delete-word :type kill)
			     (stream input-buffer numeric-argument)
  (ie-rub-del-word stream input-buffer numeric-argument))

(define-input-editor-command (com-ie-clear-input :type kill)
			     (stream input-buffer)
  ;; Just push a copy of the input buffer onto the kill ring, no merging
  (ie-kill stream input-buffer t 0 (fill-pointer input-buffer)))

(define-input-editor-command (com-ie-kill-line :type kill)
			     (stream input-buffer numeric-argument)
  (let* ((reverse-p (minusp numeric-argument))
	 (point (insertion-pointer stream))
	 (other-point (if reverse-p
			  (ie-line-start input-buffer point)
			  (ie-line-end input-buffer point))))
    (ie-kill stream input-buffer
	     (if (eql (slot-value stream 'last-command-type) 'kill) :merge t)

(define-input-editor-command (com-ie-make-room)
			     (stream input-buffer)
  (let ((point (insertion-pointer stream))
	(end (fill-pointer input-buffer)))
    (cond ((= point end)
	   (incf (fill-pointer input-buffer)))
	   (erase-input-buffer stream point)
	   (shift-buffer-portion input-buffer point (1+ point))))
    (setf (aref input-buffer point) #\Newline)
    (redraw-input-buffer stream point)))

(define-input-editor-command (com-ie-transpose-characters)
			     (stream input-buffer)
  (let* ((start-position (min (1+ (insertion-pointer stream))
			      (fill-pointer input-buffer)))
	 (this-position (forward-or-backward input-buffer start-position t #'true))
	 (prev-position (forward-or-backward input-buffer this-position t #'true)))
    (cond ((and this-position prev-position (/= this-position prev-position))
	   (let ((this-char (aref input-buffer this-position))
		 (prev-char (aref input-buffer prev-position)))
	     (erase-input-buffer stream prev-position)
	     (setf (aref input-buffer prev-position) this-char)
	     (setf (aref input-buffer this-position) prev-char)
	     (redraw-input-buffer stream prev-position)))
	  (t (beep stream)))))

(defun ie-kill (stream input-buffer kill-ring start end &optional reverse)
  (when (< end start) (rotatef start end))
  (when kill-ring
    (let* ((top (and (eql kill-ring ':merge)
		     (eql *kill-ring-application* *application-frame*)
		     (history-top-element *kill-ring*)))
	   (length (if top (length top) 0)))
      (setq *kill-ring-application* *application-frame*)
      (do-input-buffer-pieces (input-buffer :start start :end end)
			      (start end noise-string)
        :normal (incf length (- end start))
	:noise-string (incf length (length (noise-string-display-string noise-string))))
      (let ((new-top (make-string length))
	    (index 0))
	(when top
	  (cond (reverse
		 ;; Even when we're deleting backwards, we want to merge the
		 ;; kills so they come out in the original order
		 (replace new-top top
			  :start1 (- length (length top)))
		 (setq index 0))
		 (replace new-top top)
		 (setq index (length top)))))
	(do-input-buffer-pieces (input-buffer :start start :end end)
				(start end noise-string)
	  :normal (replace new-top input-buffer
			   :start1 index :end1 (incf index (- end start))
			   :start2 start :end2 end)
	  :noise-string (let ((string (noise-string-display-string noise-string)))
			  (replace new-top string
				   :start1 index :end1 (incf index (length string)))))
	(cond (top
	       (setf (history-top-element *kill-ring*) new-top)
	       #+Genera (genera-kill-ring-save new-top t))
	       (push-history-element *kill-ring* new-top)
	       #+Genera (genera-kill-ring-save new-top nil))))))
  ;; Erase what used to be there, side effect the input buffer, then redraw it
  (erase-input-buffer stream start)
  (if end
      (shift-buffer-portion input-buffer end start)
      (setf (fill-pointer input-buffer) start))
  ;; The insertion-pointer started out at either start or end, they're the same now
  (setf (insertion-pointer stream) start)
  ;; Make sure the scan pointer doesn't point past the insertion pointer
  (redraw-input-buffer stream)
  ;; This can be called in a loop, so reflect the kill operation now
  (setf (slot-value stream 'last-command-type) 'kill))


Main Index | Thread Index