Download
(unless (version<= "22" emacs-version)
(error "Fill-column-indicator requires version 22 or later"))
(defgroup fill-column-indicator nil
"Graphically indicate the fill-column."
:tag "Fill-Column Indicator"
:group 'convenience
:group 'fill)
(defcustom fci-rule-column nil
"Controls where fci-mode displays a vertical line (rule).
If nil, the rule is drawn at the fill column. Otherwise, it is
drawn at the column given by this variable.
Changes to this variable do not take effect until the mode
function `fci-mode' is run."
:group 'fill-column-indicator
:tag "Fill-Column rule column"
:type '(choice (const :tag "Use the fill column" nil)
(integer :tag "Use a custom column"
:match (lambda (w val) (fci-posint-p val)))))
(defcustom fci-rule-color "#cccccc"
"Color used to draw the fill-column rule.
Changes to this variable do not take effect until the mode
function `fci-mode' is run."
:group 'fill-column-indicator
:tag "Fill-column rule color"
:type 'color)
(defcustom fci-rule-width 1
"Width in pixels of the fill-column rule on graphical displays.
Note that a value greater than the default character width is
treated as equivalent to the default character width.
Changes to this variable do not take effect until the mode
function `fci-mode' is run."
:tag "Fill-Column Rule Width"
:group 'fill-column-indicator
:type '(integer :match (lambda (w val) (fci-posint-p val))))
(defcustom fci-rule-image-format
(if (image-type-available-p 'xpm) 'xpm 'pbm)
"Image format used for the fill-column rule on graphical displays.
Changes to this variable do not take effect until the mode
function `fci-mode' is run."
:tag "Fill-Column Rule Image Format"
:group 'fill-column-indicator
:type '(choice (symbol :tag "XPM" 'xpm)
(symbol :tag "PBM" 'pbm)))
(defcustom fci-rule-use-dashes nil
"Whether to show the fill-column rule as dashes or as a solid line.
This has no effect on non-graphical displays.
Changes to this variable do not take effect until the mode
function `fci-mode' is run."
:tag "Fill-Column Rule Use Dashes"
:group 'fill-column-indicator
:type 'boolean)
(defcustom fci-dash-pattern 0.75
"When using a dashed rule, ratio of dash length to line height.
Values less than 0 or greather than 1 are coerced to the nearest
endpoint of that interval.
Changes to this variable do not take effect until the mode
function `fci-mode' is run."
:tag "Fill-Column Rule Use Dashes"
:group 'fill-column-indicator
:type 'float)
(defcustom fci-rule-character ?|
"Character used to draw the fill-column rule on character terminals.
Changes to this variable do not take effect until the mode
function `fci-mode' is run."
:tag "Fill-Column Rule Character"
:group 'fill-column-indicator
:type 'character)
(defcustom fci-rule-character-color nil
"Color used to draw the fill-column rule on character terminals.
If nil, the same color is used as for the graphical rule.
Changes to this variable do not take effect until the mode
function `fci-mode' is run."
:group 'fill-column-indicator
:tag "Fill-column rule color"
:type '(choice (const :tag "Use same color as graphical rule" nil)
(color :tag "Specify a color")))
(defcustom fci-always-use-textual-rule nil
"When non-nil, the rule is always drawn using textual characters.
Specifically, fci-mode will use `fci-rule-character' intead of
bitmap images to draw the rule on graphical displays.
Changes to this variable do not take effect until the mode
function `fci-mode' is run."
:tag "Don't Use Image for Fill-Column Rule"
:group 'fill-column-indicator
:type 'boolean)
(defcustom fci-handle-truncate-lines t
"Whether fci-mode should set truncate-lines to t while enabled.
If non-nil, fci-mode will set truncate-lines to t in buffers in
which it is enabled, and restore it to its previous value when
disabled.
Leaving this option set to the default value is recommended."
:group 'fill-column-indicator
:tag "Locally set truncate-lines to t during fci-mode"
:type 'boolean)
(defcustom fci-handle-line-move-visual (version<= "23" emacs-version)
"Whether fci-mode should set line-move-visual to nil while enabled.
If non-nil, fci-mode will set line-move-visual to nil in buffers
in which it is enabled, and restore t to its previous value when
disabled.
Leaving this option set to the default value is recommended."
:group 'fill-column-indicator
:tag "Locally set line-move-visual to nil during fci-mode"
:type 'boolean)
(defcustom fci-eol-char ?\uE000
"Character used for internal purposes by fci-mode.
If you need to use this character, set this variable's value to a
character you do not care about (a good choice is a character
from the Private Use Area of the Unicode BMP, i.e., the range
U+E000-U+F8FF, inclusive)."
:group 'fill-column-indicator
:type 'character)
(defcustom fci-blank-char ?\uE001
"Character used for internal purposes by fci-mode.
If you need to use this character, set this variable's value to a
character you do not care about (a good choice is a character
from the Private Use Area of the Unicode BMP, i.e., the the range
U+E000-U+F8FF, inclusive)."
:group 'fill-column-indicator
:type 'character)
(defvar fci-saved-line-move-visual)
(defvar fci-line-move-visual-was-buffer-local)
(defvar fci-saved-truncate-lines)
(defvar fci-saved-eol)
(defvar fci-made-display-table)
(defvar fci-display-table-processed)
(defvar fci-local-vars-set)
(defvar fci-column)
(defvar fci-newline)
(defvar fci-tab-width)
(defvar fci-char-width)
(defvar fci-char-height)
(defvar fci-limit)
(defvar fci-pre-limit-string)
(defvar fci-at-limit-string)
(defvar fci-post-limit-string)
(defconst fci-internal-vars '(fci-saved-line-move-visual
fci-line-move-visual-was-buffer-local
fci-saved-truncate-lines
fci-saved-eol
fci-made-display-table
fci-display-table-processed
fci-local-vars-set
fci-column
fci-newline
fci-tab-width
fci-char-width
fci-char-height
fci-limit
fci-pre-limit-string
fci-at-limit-string
fci-post-limit-string))
(dolist (var fci-internal-vars)
(make-variable-buffer-local var))
(defconst fci-hook-assignments
'((after-change-functions fci-redraw-region t)
(before-change-functions fci-extend-rule-for-deletion t)
(window-scroll-functions fci-update-window-for-scroll t)
(window-configuration-change-hook fci-redraw-frame)
(post-command-hook fci-post-command-check t)
(change-major-mode-hook turn-off-fci-mode t)
(longlines-mode-hook fci-update-all-windows t)))
(defun fci-get-buffer-windows (&optional all-frames)
"Return a list of windows displaying the current buffer."
(get-buffer-window-list (current-buffer) 'no-minibuf all-frames))
(defun fci-posint-p (x)
"Return true if X is an integer greater than zero."
(and (wholenump x)
(/= 0 x)))
(if (fboundp 'characterp)
(defalias 'fci-character-p 'characterp)
(defun fci-character-p (c)
"Return true if C is a character."
(and (fci-posint-p c)
(< c 507904))))
(define-minor-mode fci-mode
"Toggle fci-mode on and off.
Fci-mode indicates the location of the fill column by drawing a
thin line (a `rule') at the fill column.
With prefix ARG, turn fci-mode on if and only if ARG is positive.
The following options control the appearance of the fill-column
rule: `fci-rule-column', `fci-rule-width', `fci-rule-color',
`fci-rule-use-dashes', `fci-dash-pattern', `fci-rule-character',
and `fci-rule-character-color'. For further options, see the
Customization menu or the package file. (See the latter for tips
on troubleshooting.)"
nil nil nil
(if fci-mode
(condition-case error
(progn
(fci-check-user-options)
(fci-process-display-table)
(fci-set-local-vars)
(fci-get-frame-dimens)
(dolist (hook fci-hook-assignments)
(add-hook (car hook) (nth 1 hook) nil (nth 2 hook)))
(setq fci-column (or fci-rule-column fill-column)
fci-tab-width tab-width
fci-limit (if fci-newline
(1+ (- fci-column (length fci-saved-eol)))
fci-column))
(fci-make-overlay-strings)
(fci-update-all-windows t))
(error
(fci-mode 0)
(signal (car error) (cdr error))))
(fci-restore-display-table)
(fci-restore-local-vars)
(dolist (hook fci-hook-assignments)
(remove-hook (car hook) (nth 1 hook) (nth 2 hook)))
(fci-delete-overlays-buffer)
(dolist (var fci-internal-vars)
(set var nil))))
(defun turn-on-fci-mode ()
"Turn on fci-mode unconditionally."
(interactive)
(fci-mode 1))
(defun turn-off-fci-mode ()
"Turn off fci-mode unconditionally."
(interactive)
(fci-mode 0))
(defun fci-overlay-fills-background-p (olay)
"Return true if OLAY specifies a background color."
(and (overlay-get olay 'face)
(not (eq (face-attribute (overlay-get olay 'face) :background nil t)
'unspecified))))
(defun fci-competing-overlay-p (posn)
"Return true if there is an overlay at POSN that fills the background."
(memq t (mapcar #'fci-overlay-fills-background-p (overlays-at posn))))
(defconst fci-padding-display
'((when (not (fci-competing-overlay-p buffer-position))
. (space :align-to fci-column))
(space :width 0)))
(defun fci-rule-display (blank rule-img rule-str for-pre-string)
"Generate a display specification for a fill-column rule overlay string."
(let* ((cursor-prop (if (and (not for-pre-string) (not fci-newline)) t))
(propertized-rule-str (propertize rule-str 'cursor cursor-prop))
(display-prop (if rule-img
`((when (not (or (display-images-p)
(fci-competing-overlay-p buffer-position)))
. ,propertized-rule-str)
(when (not (fci-competing-overlay-p buffer-position))
. ,rule-img)
(space :width 0))
`((when (not (fci-competing-overlay-p buffer-position))
. ,propertized-rule-str)
(space :width 0)))))
(propertize blank 'cursor cursor-prop 'display display-prop)))
(defun fci-check-user-options ()
"Check that all user options for fci-mode have valid values."
(unless (memq fci-rule-image-format '(xpm pbm))
(error "Unrecognized value of `fci-rule-image-format'"))
(let ((checks '((fci-rule-color color-defined-p)
(fci-rule-column fci-posint-p t)
(fci-rule-width fci-posint-p t)
(fci-rule-character-color color-defined-p t)
(fci-rule-character fci-character-p)
(fci-blank-char fci-character-p)
(fci-dash-pattern floatp)
(fci-eol-char fci-character-p))))
(dolist (check checks)
(let ((value (symbol-value (nth 0 check)))
(pred (nth 1 check))
(nil-is-ok (nth 2 check)))
(unless (or (and nil-is-ok (null value))
(funcall pred value))
(signal 'wrong-type-argument (list pred value)))))))
(defun fci-process-display-table ()
"Set up a buffer-local display table for fci-mode."
(unless fci-display-table-processed
(unless buffer-display-table
(setq buffer-display-table (make-display-table)
fci-made-display-table t))
(aset buffer-display-table fci-blank-char [32])
(setq fci-saved-eol (aref buffer-display-table 10))
(let ((glyphs (butlast (append fci-saved-eol nil)))
eol)
(if glyphs
(setq fci-newline [10]
eol (vconcat glyphs))
(setq fci-newline nil
eol [32]))
(aset buffer-display-table 10 fci-newline)
(aset buffer-display-table fci-eol-char eol))
(setq fci-display-table-processed t)))
(defun fci-set-local-vars ()
"Set miscellaneous local variables when fci-mode is enabled."
(unless fci-local-vars-set
(when (and fci-handle-line-move-visual
(boundp 'line-move-visual))
(if (local-variable-p 'line-move-visual)
(setq fci-line-move-visual-was-buffer-local t
fci-saved-line-move-visual line-move-visual
line-move-visual nil)
(set (make-local-variable 'line-move-visual) nil)))
(when fci-handle-truncate-lines
(setq fci-saved-truncate-lines truncate-lines
truncate-lines t))
(setq fci-local-vars-set t)))
(defun fci-make-rule-string ()
"Return a string for drawing the fill-column rule."
(let ((color (or fci-rule-character-color
fci-rule-color)))
(propertize (char-to-string fci-rule-character)
'face `(:foreground ,color :weight normal :slant normal))))
(defun fci-make-img-descriptor ()
"Make an image descriptor for the fill-column rule."
(unless (or (= 0 fci-char-width)
fci-always-use-textual-rule)
(if (eq fci-rule-image-format 'xpm)
(fci-make-xpm-img)
(fci-make-pbm-img))))
(defun fci-get-frame-dimens ()
"Determine the frame character height and width.
If the selected frame cannot display images, use the character
height and width of the first graphic frame in the frame list
displaying the current buffer. (This fallback behavior is just a
rough heuristic.)"
(let ((frame (catch 'found-graphic
(if (display-images-p)
(selected-frame)
(dolist (win (fci-get-buffer-windows t))
(when (display-images-p (window-frame win))
(throw 'found-graphic (window-frame win))))))))
(setq fci-char-width (frame-char-width frame)
fci-char-height (frame-char-height frame))))
(defmacro fci-with-rule-parameters (&rest body)
"Define various quantites used in generating rule image descriptors."
(declare (indent defun))
`(let* ((height-str (number-to-string fci-char-height))
(width-str (number-to-string fci-char-width))
(rule-width (min fci-rule-width fci-char-width))
(hmargin (/ (- fci-char-width rule-width) 2.0))
(left-margin (floor hmargin))
(right-margin (ceiling hmargin))
(segment-ratio (if fci-rule-use-dashes fci-dash-pattern 1))
(segment-ratio-coerced (min 1 (max 0 segment-ratio)))
(segment-length (round (* segment-ratio-coerced fci-char-height)))
(vmargin (/ (- fci-char-height segment-length) 2.0))
(top-margin (floor vmargin))
(bottom-margin (ceiling vmargin)))
,@body))
(defun fci-mapconcat (sep &rest lists)
"Concatenate the strings in LISTS, using SEP as separator."
(mapconcat #'identity (apply 'nconc lists) sep))
(defun fci-make-pbm-img ()
"Return an image descriptor for the fill-column rule in PBM format."
(fci-with-rule-parameters
(let* ((magic-number "P1\n")
(dimens (concat width-str " " height-str "\n"))
(on-pixels (fci-mapconcat " "
(make-list left-margin "0")
(make-list rule-width "1")
(make-list right-margin "0")))
(off-pixels (fci-mapconcat " " (make-list fci-char-width "0")))
(raster (fci-mapconcat "\n"
(make-list top-margin off-pixels)
(make-list segment-length on-pixels)
(make-list bottom-margin off-pixels)))
(data (concat magic-number dimens raster)))
`(image :type pbm
:data ,data
:mask heuristic
:foreground ,fci-rule-color
:ascent center))))
(defun fci-make-xpm-img ()
"Return an image descriptor for the fill-column rule in XPM format."
(fci-with-rule-parameters
(let* ((identifier "/* XPM */\nstatic char *rule[] = {")
(dimens (concat "\"" width-str " " height-str " 2 1\","))
(color-spec (concat "\"1 c " fci-rule-color "\",\"0 c None\","))
(on-pixels (concat "\""
(make-string left-margin ?0)
(make-string rule-width ?1)
(make-string right-margin ?0)
"\","))
(off-pixels (concat "\"" (make-string fci-char-width ?0) "\","))
(raster (fci-mapconcat ""
(make-list top-margin off-pixels)
(make-list segment-length on-pixels)
(make-list bottom-margin off-pixels)))
(end "})
(data (concat identifier dimens color-spec raster end)))
`(image :type xpm
:data ,data
:mask heuristic
:ascent center))))
(defun fci-make-overlay-strings ()
"Generate the overlay strings used to display the fill-column rule."
(let* ((str (fci-make-rule-string))
(img (fci-make-img-descriptor))
(blank-str (char-to-string fci-blank-char))
(eol-str (char-to-string fci-eol-char))
(end-cap (propertize blank-str 'display '(space :width 0)))
(pre-or-post-eol (propertize eol-str
'cursor t
'display (propertize eol-str 'cursor t)))
(pre-padding (propertize blank-str 'display fci-padding-display))
(pre-rule (fci-rule-display blank-str img str t))
(at-rule (fci-rule-display blank-str img str fci-newline))
(at-eol (if fci-newline pre-or-post-eol "")))
(setq fci-pre-limit-string (concat pre-or-post-eol pre-padding pre-rule)
fci-at-limit-string (concat at-eol at-rule)
fci-post-limit-string (concat pre-or-post-eol end-cap))))
(defun fci-restore-local-vars ()
"Restore miscellaneous local variables when fci-mode is disabled."
(when fci-local-vars-set
(when (and fci-handle-line-move-visual
(boundp 'line-move-visual))
(if fci-line-move-visual-was-buffer-local
(setq line-move-visual fci-saved-line-move-visual)
(kill-local-variable 'line-move-visual)))
(when fci-handle-truncate-lines
(setq truncate-lines fci-saved-truncate-lines))))
(defun fci-restore-display-table ()
"Restore the buffer display table when fci-mode is disabled."
(when (and buffer-display-table
fci-display-table-processed)
(aset buffer-display-table 10 fci-saved-eol)
(when (and fci-made-display-table
(equal buffer-display-table (make-display-table)))
(setq buffer-display-table nil))))
(defun fci-get-overlays-region (start end)
"Return all overlays between START and END displaying the fill-column rule."
(delq nil (mapcar #'(lambda (o) (if (overlay-get o 'fci) o))
(overlays-in start end))))
(defun fci-delete-overlays-region (start end)
"Delete overlays displaying the fill-column rule between START and END."
(mapc #'(lambda (o) (if (overlay-get o 'fci) (delete-overlay o)))
(overlays-in start end)))
(defun fci-delete-overlays-buffer ()
"Delete all overlays displaying the fill-column rule in the current buffer."
(save-restriction
(widen)
(fci-delete-overlays-region (point-min) (point-max))))
(defsubst fci-posn-visible-p (posn ranges)
"Return true if POSN falls within an interval in RANGES."
(memq t (mapcar #'(lambda (range) (and (<= (car range) posn)
(< posn (cdr range))))
ranges)))
(defsubst fci-get-visible-ranges ()
"Return the window start and end for each window on the current buffer."
(mapcar #'(lambda (w) (cons (window-start w) (window-end w 'updated)))
(fci-get-buffer-windows t)))
(defun fci-delete-unneeded ()
"Erase the fill-column rule at buffer positions not visible in any window."
(let ((olays (fci-get-overlays-region (point-min) (point-max)))
(ranges (fci-get-visible-ranges)))
(dolist (o olays)
(unless (fci-posn-visible-p (overlay-start o) ranges)
(delete-overlay o)))))
(defun fci-put-overlays-region (start end)
"Place overlays displaying the fill-column rule between START and END."
(goto-char start)
(let (o cc)
(while (search-forward "\n" end t)
(goto-char (match-beginning 0))
(setq cc (current-column)
o (make-overlay (match-beginning 0) (match-beginning 0)))
(overlay-put o 'fci t)
(cond
((< cc fci-limit)
(overlay-put o 'after-string fci-pre-limit-string))
((> cc fci-limit)
(overlay-put o 'after-string fci-post-limit-string))
(t
(overlay-put o 'after-string fci-at-limit-string)))
(goto-char (match-end 0)))))
(defun fci-redraw-region (start end _ignored)
"Erase and redraw the fill-column rule between START and END."
(save-match-data
(save-excursion
(let ((inhibit-point-motion-hooks t))
(goto-char end)
(setq end (line-beginning-position 2))
(fci-delete-overlays-region start end)
(when (> (+ (window-width) (window-hscroll))
fci-limit)
(fci-put-overlays-region start end))))))
(defun fci-redraw-window (win &optional start)
"Redraw the fill-column rule in WIN starting from START."
(fci-redraw-region (or start (window-start win)) (window-end win t) 'ignored))
(defun fci-extend-rule-for-deletion (start end)
"Extend the fill-column rule after a deletion that spans newlines."
(unless (= start end)
(let ((delenda (fci-get-overlays-region start end)))
(when delenda
(let ((lossage (1+ (length delenda)))
(max-end 0)
win-end)
(mapc #'delete-overlay delenda)
(dolist (win (fci-get-buffer-windows t))
(setq win-end (window-end win))
(when (and (< 0 (- (min win-end end)
(max (window-start win) start)))
(< max-end win-end))
(setq max-end win-end)))
(unless (= max-end (point-max))
(fci-redraw-region max-end
(save-excursion
(goto-char max-end)
(line-beginning-position lossage))
nil)))))))
(defun fci-update-window-for-scroll (win start)
"Redraw the fill-column rule in WIN after it has been been scrolled."
(fci-delete-unneeded)
(fci-redraw-window win start))
(defun fci-update-all-windows (&optional all-frames)
"Redraw the fill-column rule in all windows showing the current buffer."
(dolist (win (fci-get-buffer-windows all-frames))
(fci-redraw-window win)))
(defun fci-redraw-frame ()
"Redraw the fill-column rule in all windows on the selected frame."
(let* ((wins (window-list (selected-frame) 'no-minibuf))
(bufs (delete-dups (mapcar #'window-buffer wins))))
(dolist (buf bufs)
(with-current-buffer buf
(when fci-mode
(fci-delete-unneeded)
(fci-update-all-windows))))))
(defun fci-post-command-check ()
"This function is a gross hack."
(cond
((not (and buffer-display-table
(equal (aref buffer-display-table 10) fci-newline)))
(setq fci-display-table-processed nil)
(fci-mode 1))
((and (< 1 (frame-char-width))
(not fci-always-use-textual-rule)
(not (and (= (frame-char-width) fci-char-width)
(= (frame-char-height) fci-char-height))))
(fci-mode 1))
((not (and (= (or fci-rule-column fill-column) fci-column)
(= tab-width fci-tab-width)))
(fci-mode 1))
((and (< 0 (window-hscroll))
auto-hscroll-mode
(<= (current-column) (window-hscroll)))
(set-window-hscroll (selected-window) 0))))
(provide 'fill-column-indicator)