Function: occur-after-change-function

occur-after-change-function is a byte-compiled function defined in replace.el.gz.

Signature

(occur-after-change-function BEG END LENGTH)

Source Code

;; Defined in /usr/src/emacs/lisp/replace.el.gz
(defun occur-after-change-function (beg end length)
  (save-excursion
    (goto-char beg)
    (let* ((line-beg (line-beginning-position))
	   (targets (get-text-property line-beg 'occur-target))
           (m (occur--targets-start targets))
	   (buf (marker-buffer m))
	   col)
      (when (and (get-text-property line-beg 'occur-prefix)
		 (not (get-text-property end 'occur-prefix)))
	(when (= length 0)
	  ;; Apply occur-target property to inserted (e.g. yanked) text.
	  (put-text-property beg end 'occur-target targets)
	  ;; Did we insert a newline?  Occur Edit mode can't create new
	  ;; Occur entries; just discard everything after the newline.
	  (save-excursion
	    (and (search-forward "\n" end t)
		 (delete-region (1- (point)) end))))
	(let* ((line (- (line-number-at-pos)
			(line-number-at-pos (window-start))))
	       (readonly (with-current-buffer buf buffer-read-only))
	       (win (or (get-buffer-window buf)
			(display-buffer buf
					'(nil (inhibit-same-window . t)
					      (inhibit-switch-frame . t)))))
	       (line-end (line-end-position))
	       (text (save-excursion
		       (goto-char (next-single-property-change
				   line-beg 'occur-prefix nil
				   line-end))
		       (setq col (- (point) line-beg))
		       (buffer-substring-no-properties (point) line-end))))
	  (with-selected-window win
	    (goto-char m)
	    (recenter line)
	    (if readonly
		(message "Buffer `%s' is read only." buf)
              ;; Replace the line, but make the change as small as
              ;; possible by shrink-wrapping.  That way, we avoid
              ;; disturbing markers unnecessarily.
              (let* ((beg-pos (line-beginning-position))
                     (end-pos (line-end-position))
                     (buf-str (buffer-substring-no-properties beg-pos end-pos))
                     (common-prefix
                      (lambda (s1 s2)
                        (let ((c (compare-strings s1 nil nil s2 nil nil)))
                          (if (numberp c)
                              (1- (abs c))
                            (length s1)))))
                     (prefix-len (funcall common-prefix buf-str text))
                     (suffix-len (funcall common-prefix
                                          (reverse (substring
                                                    buf-str prefix-len))
                                          (reverse (substring
                                                    text prefix-len)))))
                (setq beg-pos (+ beg-pos prefix-len))
                (setq end-pos (- end-pos suffix-len))
                (setq text (substring text prefix-len
                                      (and (not (zerop suffix-len))
                                           (- suffix-len))))
                (delete-region beg-pos end-pos)
                (goto-char beg-pos)
                (insert text)))
	    (move-to-column col)))))))