xemacs-beta: lisp/simple.el comparison

comparison lisp/simple.el @ 5854:ccb0cff115d2

Update message-stack to reflect START and END supplied to #'append-message lisp/ChangeLog addition: 2015-03-11 Aidan Kehoe <kehoea@parhasard.net> Correct #'clear-message and friends so the START and END supplied to #'append-message are reflected when restoring messages from the message stack. * simple.el (remove-message-hook): Update this to reflect the START and END keyword arguments. * simple.el (log-message): Update this to take START and END keyword arguments. * simple.el (clear-message): Update this to reflect a changed `message-stack' alist structure. * simple.el (remove-message): Update this to reflect a changed `message-stack' alist structure; don't do `with-trapping-errors' and resignal use #'call-with-condition-handler directly instead, for better backtraces and easier debugging. * simple.el (append-message): Update this to reflect a changed message-stack structure.

author	Aidan Kehoe <kehoea@parhasard.net>
date	Wed, 11 Mar 2015 15:06:05 +0000
parents	9e5f3a0d4e66
children	0bddb59072b6

comparison

equal deleted inserted replaced

-:1044acf60048
+:ccb0cff115d2
 `display-message'/`clear-message' functions.")
 (defvar remove-message-hook 'log-message
 "A function or list of functions to be called when a message is removed
 from the echo area at the bottom of the frame.  The label of the removed
-message is passed as the first argument, and the text of the message
+message is passed as the first argument, the text of the message as the second
-as the second argument.")
+argument, and the start and end of the substring of the message can be
+supplied as keyword arguments.")
 (defcustom log-message-max-size 50000
 "Maximum size of the \" *Message-Log*\" buffer.  See `log-message'."
 :type 'integer
 :group 'log-message)
 (defun log-message-filter-errors-only (label message)
 "For use as the `log-message-filter-function'.  Only logs error messages."
 (eq label 'error))
-(defun log-message (label message)
+(defun* log-message (label message &key (start 0) end)
 "Stuff a copy of the message into the \" *Message-Log*\" buffer,
 if it satisfies the `log-message-filter-function'.
 For use on `remove-message-hook'."
 (when (and (not noninteractive)
 (goto-char (point-max))
 ;(insert (concat (upcase (symbol-name label)) ": "  message "\n"))
 (let (extent)
 	;; Mark multiline message with an extent, which `view-lossage'
 	;; will recognize.
-	(save-match-data
+(when (find ?\n message :start start :end end)
-	  (when (string-match "\n" message)
+(setq extent (make-extent (point) (point)))
-	    (setq extent (make-extent (point) (point)))
+(set-extent-properties extent '(end-open nil message-multiline t)))
-	    (set-extent-properties extent '(end-open nil message-multiline t)))
+	(write-line message (current-buffer) :start start :end end)
-	  )
-	(insert message "\n")
 	(when extent
 	  (set-extent-property extent 'end-open t)))
 (when (> (point-max) (max log-message-max-size (point-min)))
 	;; Trim log to ~90% of max size.
 	(goto-char (max (- (point-max)
 (set-device-clear-left-side (frame-device frame) nil)
 (send-string-to-terminal ?\n stdout-p))
 (if no-restore
 	nil			; just preparing to put another msg up
 (if message-stack
-	  (let ((oldmsg (cdr (car message-stack))))
+(let ((oldmsg (second (car message-stack))))
-	    (raw-append-message oldmsg frame stdout-p)
+(prog1
-	    oldmsg)
+;; #### Doesn't pass back information about the substring of
+;; OLDMSG displayed. None of our callers use this, as of
+;; 20150311, though.
+oldmsg
+(raw-append-message oldmsg frame stdout-p
+:start (third (car message-stack))
+:end (fourth (car message-stack)))))
 	;; #### Should we (redisplay-echo-area) here?  Messes some
 	;; things up.
 	nil))))
 (defun remove-message (&optional label frame)
-;; If label is nil, we want to remove all matching messages.
+"Remove any message with a specified LABEL from `message-stack'.
-;; Must reverse the stack first to log them in the right order.
-(let ((log nil))
+With nil LABEL, remove all messages from `message-stack'. Calls those
-(while (and message-stack
+functions specified by `remove-message-hook' with the details of each removed
-		(or (null label)	; null label means clear whole stack
+message."
-		    (eq label (car (car message-stack)))))
+(let (log)
-(push (car message-stack) log)
+(if label
-(setq message-stack (cdr message-stack)))
+(setq log (reverse (remove* label message-stack :test-not #'eq
-(let ((s  message-stack))
+:key #'car))
-(while (cdr s)
+message-stack (delete* label message-stack :key #'car))
-	(let ((msg (car (cdr s))))
+;; If label is nil, we want to remove all messages.  Must reverse the
-	  (if (eq label (car msg))
+;; stack first to log them in the right order.
-	      (progn
+(setq log (nreverse message-stack)
-		(push msg log)
+message-stack nil))
-		(setcdr s (cdr (cdr s))))
-	    (setq s (cdr s))))))
 ;; (possibly) log each removed message
 (while log
-(with-trapping-errors
+(call-with-condition-handler
-	:operation 'remove-message-hook
+((macro . (lambda (function) (subst '#:xEbgpd2 'error function)))
-	:class 'message-log
+#'(lambda (error)
-	:error-form (progn
+(setq remove-message-hook nil)
-		      (setq remove-message-hook nil)
+(let ((inhibit-read-only t))
-		      (let ((inhibit-read-only t))
+(erase-buffer " *Echo Area*"))
-			(erase-buffer " *Echo Area*")))
+(lwarn 'message-log 'warning
-	:resignal t
+"Error in `remove-message-hook': %s\n\nBacktrace follows:\n%s"
-	(run-hook-with-args 'remove-message-hook
+(error-message-string error)
-			    (car (car log)) (cdr (car log))))
+(backtrace-in-condition-handler-eliminating-handler 'error))))
+#'run-hook-with-args 'remove-message-hook (caar log)
+	  (cadar log) :start (third (car log)) :end (fourth (car log)))
 (setq log (cdr log)))))
 (defun* append-message (label message &optional frame stdout-p
 &key (start 0) end)
 "Add MESSAGE to the message-stack, or append it to the existing text.
 ;; If outputting to the terminal, make sure output from anyone else clears
 ;; the left side first, but don't do it ourselves, otherwise we won't be
 ;; able to append to an existing message.
 (if (eq 'stream (frame-type frame))
 (set-device-clear-left-side (frame-device frame) nil))
-(let ((top (car message-stack)))
+(if (eq label (caar message-stack))
-(if (eq label (car top))
+(setf (cadar message-stack)
-	(setcdr top (concat (cdr top) message))
+(concat (subseq (cadar message-stack) (third (car message-stack))
-(push (cons label message) message-stack)))
+(fourth (car message-stack)))
+(if (or end (not (eql start 0)))
+(subseq message start end)
+message))
+(caddar message-stack) nil
+(car (cdddar message-stack)) nil)
+(push (list label message start end) message-stack))
 (raw-append-message message frame stdout-p :start start :end end)
 (if (eq 'stream (frame-type frame))
 (set-device-clear-left-side (frame-device frame) t)))
 ;; Really append the message to the echo area.  No fiddling with

Mercurial > hg > xemacs-beta

comparison lisp/simple.el @ 5854:ccb0cff115d2