[COMMIT] Update message-stack to reflect START and END supplied to #'append-message

APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1426086365 0 # Wed Mar 11 15:06:05 2015 +0000 # Node ID ccb0cff115d2dc5a0752e3f688a562c48ab90ffc # Parent 1044acf60048098a0b60326561d732c7691a357a Update message-stack to reflect START and END supplied to #'append-message lisp/ChangeLog addition: 2015-03-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; 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. diff -r 1044acf60048 -r ccb0cff115d2 lisp/ChangeLog --- a/lisp/ChangeLog Sun Mar 08 20:59:25 2015 +0000 +++ b/lisp/ChangeLog Wed Mar 11 15:06:05 2015 +0000 ＠＠ -1,3 +1,22 ＠＠ +2015-03-11 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + 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. + 2014-12-31 Michael Sperber <mike(a)xemacs.org&gt; * simple.el (line-move): Add `noerror' optional argument, as in diff -r 1044acf60048 -r ccb0cff115d2 lisp/simple.el --- a/lisp/simple.el Sun Mar 08 20:59:25 2015 +0000 +++ b/lisp/simple.el Wed Mar 11 15:06:05 2015 +0000 ＠＠ -4166,8 +4166,9 ＠＠ (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 -as the second argument.") +message is passed as the first argument, the text of the message as the second +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'." ＠＠ -4300,7 +4301,7 ＠＠ "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'. ＠＠ -4316,12 +4317,10 ＠＠ (let (extent) ;; Mark multiline message with an extent, which `view-lossage' ;; will recognize. - (save-match-data - (when (string-match "\n" message) - (setq extent (make-extent (point) (point))) - (set-extent-properties extent '(end-open nil message-multiline t))) - ) - (insert message "\n") + (when (find ?\n message :start start :end end) + (setq extent (make-extent (point) (point))) + (set-extent-properties extent '(end-open nil message-multiline t))) + (write-line message (current-buffer) :start start :end end) (when extent (set-extent-property extent 'end-open t))) (when (> (point-max) (max log-message-max-size (point-min))) ＠＠ -4377,42 +4376,48 ＠＠ (if no-restore nil ; just preparing to put another msg up (if message-stack - (let ((oldmsg (cdr (car message-stack)))) - (raw-append-message oldmsg frame stdout-p) - oldmsg) + (let ((oldmsg (second (car message-stack)))) + (prog1 + ;; #### 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. - ;; Must reverse the stack first to log them in the right order. - (let ((log nil)) - (while (and message-stack - (or (null label) ; null label means clear whole stack - (eq label (car (car message-stack))))) - (push (car message-stack) log) - (setq message-stack (cdr message-stack))) - (let ((s message-stack)) - (while (cdr s) - (let ((msg (car (cdr s)))) - (if (eq label (car msg)) - (progn - (push msg log) - (setcdr s (cdr (cdr s)))) - (setq s (cdr s)))))) + "Remove any message with a specified LABEL from `message-stack'. + +With nil LABEL, remove all messages from `message-stack'. Calls those +functions specified by `remove-message-hook' with the details of each removed +message." + (let (log) + (if label + (setq log (reverse (remove* label message-stack :test-not #'eq +:key #'car)) + message-stack (delete* label message-stack :key #'car)) + ;; If label is nil, we want to remove all messages. Must reverse the + ;; stack first to log them in the right order. + (setq log (nreverse message-stack) + message-stack nil)) ;; (possibly) log each removed message (while log - (with-trapping-errors - :operation 'remove-message-hook - :class 'message-log - :error-form (progn - (setq remove-message-hook nil) - (let ((inhibit-read-only t)) - (erase-buffer " *Echo Area*"))) - :resignal t - (run-hook-with-args 'remove-message-hook - (car (car log)) (cdr (car log)))) + (call-with-condition-handler + ((macro . (lambda (function) (subst '#:xEbgpd2 'error function))) + #'(lambda (error) + (setq remove-message-hook nil) + (let ((inhibit-read-only t)) + (erase-buffer " *Echo Area*")) + (lwarn 'message-log 'warning + "Error in `remove-message-hook': %s\n\nBacktrace follows:\n%s" + (error-message-string error) + (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 ＠＠ -4436,10 +4441,16 ＠＠ ;; 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 (car top)) - (setcdr top (concat (cdr top) message)) - (push (cons label message) message-stack))) + (if (eq label (caar message-stack)) + (setf (cadar message-stack) + (concat (subseq (cadar message-stack) (third (car 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))) -- ‘Tramadol is further fed to cattle […] when working them […] (as draft animals) so that the animals do not get tired quickly. …’ — Angewandte Chemie, Sept 2014, describing the social context of (synthetic) tramadol having been found in Cameroon tree roots. _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches