bug#16377: Undo Tree regression: (error "Unrecognized entry in undo list undo-tree-canary")

[Keith David Bershatsky <esq@lawlist.com>]

I have been working on a fork of undo-tree.el, and am interested in resolving this particular bug.  I saw a recent post on reddit/emacs asking for help on this issue, and thought I would take this opportunity to chime-in.  I am presently using the following modified version of primitive-undo in my forked version for 2 reasons.  First, is to just throw a message instead of an error if bug 16377 shows its head.  Second, I like to have the window-point update in the target window while I am doing a change in the undo-tree visualization buffer.

I have no idea whether bypassing the error about 16377 is a bad thing, so I thought I'd share my function and let the experts decide how best to handle the bug.  I also wanted to remind the powers that be that this bug still affects people in today's day and age.  Another user on reddit added a comment stating he/she also had the same problem.  I have seen this bug as well when playing with undo/redo in region.

Thanks.

(defun undo-tree--primitive-undo (n list)
"Undo N records from the front of the list LIST.
Return what remains of the list."
  (let ((arg n)
        ;; In a writable buffer, enable undoing read-only text that is
        ;; so because of text properties.
        (inhibit-read-only t)
        ;; Don't let `intangible' properties interfere with undo.
        (inhibit-point-motion-hooks t)
        ;; We use oldlist only to check for EQ.  ++kfs
        (oldlist buffer-undo-list)
        (did-apply nil)
        (next nil)
        (window-of-current-buffer (get-buffer-window (current-buffer)))
        (selected-window (selected-window)))
    (while (> arg 0)
      (while (setq next (pop list))     ;Exit inner loop at undo boundary.
        ;; Handle an integer by setting point to that value.
        (pcase next
          ((pred integerp)
            (goto-char next)
              (unless (eq window-of-current-buffer selected-window)
                (set-window-point window-of-current-buffer next)))
          ;; Element (t . TIME) records previous modtime.
          ;; Preserve any flag of NONEXISTENT_MODTIME_NSECS or
          ;; UNKNOWN_MODTIME_NSECS.
          (`(t . ,time)
           ;; If this records an obsolete save
           ;; (not matching the actual disk file)
           ;; then don't mark unmodified.
            (when (or (equal time (visited-file-modtime))
                      (and (consp time)
                           (equal (list (car time) (cdr time)) (visited-file-modtime))))
              (when (fboundp 'unlock-buffer)
                (unlock-buffer))
              (set-buffer-modified-p nil)))
          ;; Element (nil PROP VAL BEG . END) is property change.
          (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare))
            (when (or (> (point-min) beg) (< (point-max) end))
              (let ((debug-on-quit nil)
                    (msg (concat
                           "undo-tree--primative-undo (1 of 4):"
                           "  "
                           "Changes to be undone are outside visible portion of buffer.")))
                (signal 'quit `(,msg))))
           (put-text-property beg end prop val))
          ;; Element (BEG . END) means range was inserted.
          (`(,(and beg (pred integerp)) . ,(and end (pred integerp)))
           ;; (and `(,beg . ,end) `(,(pred integerp) . ,(pred integerp)))
           ;; Ideally: `(,(pred integerp beg) . ,(pred integerp end))
            (when (or (> (point-min) beg) (< (point-max) end))
              (let ((debug-on-quit nil)
                    (msg (concat
                           "undo-tree--primative-undo (2 of 4):"
                           "  "
                           "Changes to be undone are outside visible portion of buffer.")))
                (signal 'quit `(,msg))))
           ;; Set point first thing, so that undoing this undo
           ;; does not send point back to where it is now.
           (goto-char beg)
           (delete-region beg end)
           (unless (eq window-of-current-buffer selected-window)
             (set-window-point window-of-current-buffer beg)))
          ;; Element (apply FUN . ARGS) means call FUN to undo.
          (`(apply . ,fun-args)
           (let ((currbuff (current-buffer)))
             (if (integerp (car fun-args))
                 ;; Long format: (apply DELTA START END FUN . ARGS).
                 (pcase-let* ((`(,delta ,start ,end ,fun . ,args) fun-args)
                              (start-mark (copy-marker start nil))
                              (end-mark (copy-marker end t)))
                    (when (or (> (point-min) start) (< (point-max) end))
              (let ((debug-on-quit nil)
                    (msg (concat
                           "undo-tree--primative-undo (3 of 4):"
                           "  "
                           "Changes to be undone are outside visible portion of buffer.")))
                (signal 'quit `(,msg))))
                   (apply fun args) ;; Use `save-current-buffer'?
                   ;; Check that the function did what the entry
                   ;; said it would do.
                   (unless (and (= start start-mark)
                                (= (+ delta end) end-mark))
                     (error "Changes to be undone by function different than announced"))
                   (set-marker start-mark nil)
                   (set-marker end-mark nil))
               (apply fun-args))
             (unless (eq currbuff (current-buffer))
               (error "Undo function switched buffer"))
             (setq did-apply t)))
          ;; Element (STRING . POS) means STRING was deleted.
          (`(,(and string (pred stringp)) . ,(and pos (pred integerp)))
           (when (let ((apos (abs pos)))
                    (or (< apos (point-min)) (> apos (point-max))))
              (let ((debug-on-quit nil)
                    (msg (concat
                           "undo-tree--primative-undo (4 of 4):"
                           "  "
                           "Changes to be undone are outside visible portion of buffer.")))
                (signal 'quit `(,msg))))
           (let (valid-marker-adjustments)
             ;; Check that marker adjustments which were recorded
             ;; with the (STRING . POS) record are still valid, ie
             ;; the markers haven't moved.  We check their validity
             ;; before reinserting the string so as we don't need to
             ;; mind marker insertion-type.
             (while (and (markerp (car-safe (car list)))
                         (integerp (cdr-safe (car list))))
               (let* ((marker-adj (pop list))
                      (m (car marker-adj)))
                 (and (eq (marker-buffer m) (current-buffer))
                      (= pos m)
                      (push marker-adj valid-marker-adjustments))))
             ;; Insert string and adjust point
             (if (< pos 0)
                 (progn
                   (goto-char (- pos))
                   (insert string))
               (goto-char pos)
               (insert string)
               (goto-char pos))
             (unless (eq window-of-current-buffer selected-window)
               (set-window-point window-of-current-buffer pos))
             ;; Adjust the valid marker adjustments
             (dolist (adj valid-marker-adjustments)
               (set-marker (car adj)
                           (- (car adj) (cdr adj))))))
          ;; (MARKER . OFFSET) means a marker MARKER was adjusted by OFFSET.
          (`(,(and marker (pred markerp)) . ,(and offset (pred integerp)))
            (let ((msg
                    (concat
                      "undo-tree--primitive-undo:  "
                      (format "Encountered %S entry in undo list with no matching (TEXT . POS) entry"
                              next))))
              (message msg))
           ;; Even though these elements are not expected in the undo
           ;; list, adjust them to be conservative for the 24.4
           ;; release.  (Bug#16818)
           (when (marker-buffer marker)
             (set-marker marker
                         (- marker offset)
                         (marker-buffer marker))))
          (_
            (if (eq next 'undo-tree-canary)
              (message "undo-tree--primitive-undo:  catch-all found `%s'." next)
              (error "Unrecognized entry in undo list %S" next)))))
      (setq arg (1- arg)))
    ;; Make sure an apply entry produces at least one undo entry,
    ;; so the test in `undo' for continuing an undo series
    ;; will work right.
    (if (and did-apply
             (eq oldlist buffer-undo-list))
        (setq buffer-undo-list
              (cons (list 'apply 'cdr nil) buffer-undo-list))))
  list)