Line data Source code
1 : ;;; fill.el --- fill commands for Emacs
2 :
3 : ;; Copyright (C) 1985-1986, 1992, 1994-1997, 1999, 2001-2017 Free
4 : ;; Software Foundation, Inc.
5 :
6 : ;; Maintainer: emacs-devel@gnu.org
7 : ;; Keywords: wp
8 : ;; Package: emacs
9 :
10 : ;; This file is part of GNU Emacs.
11 :
12 : ;; GNU Emacs is free software: you can redistribute it and/or modify
13 : ;; it under the terms of the GNU General Public License as published by
14 : ;; the Free Software Foundation, either version 3 of the License, or
15 : ;; (at your option) any later version.
16 :
17 : ;; GNU Emacs is distributed in the hope that it will be useful,
18 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 : ;; GNU General Public License for more details.
21 :
22 : ;; You should have received a copy of the GNU General Public License
23 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 :
25 : ;;; Commentary:
26 :
27 : ;; All the commands for filling text. These are documented in the Emacs
28 : ;; manual.
29 :
30 : ;;; Code:
31 :
32 : (defgroup fill nil
33 : "Indenting and filling text."
34 : :link '(custom-manual "(emacs)Filling")
35 : :group 'editing)
36 :
37 : (defcustom fill-individual-varying-indent nil
38 : "Controls criterion for a new paragraph in `fill-individual-paragraphs'.
39 : Non-nil means changing indent doesn't end a paragraph.
40 : That mode can handle paragraphs with extra indentation on the first line,
41 : but it requires separator lines between paragraphs.
42 : A value of nil means that any change in indentation starts a new paragraph."
43 : :type 'boolean
44 : :group 'fill)
45 :
46 : (defcustom colon-double-space nil
47 : "Non-nil means put two spaces after a colon when filling."
48 : :type 'boolean
49 : :group 'fill)
50 : (put 'colon-double-space 'safe-local-variable 'booleanp)
51 :
52 : (defcustom fill-separate-heterogeneous-words-with-space nil
53 : "Non-nil means that use a space to separate words of different kind.
54 : This will be done with a word in the end of a line and a word in the
55 : beginning of the next line when concatenating them for filling those
56 : lines. Whether to use a space is up to how the words are categorized."
57 : :type 'boolean
58 : :group 'fill
59 : :version "26.1")
60 :
61 : (defvar fill-paragraph-function nil
62 : "Mode-specific function to fill a paragraph, or nil if there is none.
63 : If the function returns nil, then `fill-paragraph' does its normal work.
64 : A value of t means explicitly \"do nothing special\".
65 : Note: This only affects `fill-paragraph' and not `fill-region'
66 : nor `auto-fill-mode', so it is often better to use some other hook,
67 : such as `fill-forward-paragraph-function'.")
68 :
69 : (defvar fill-paragraph-handle-comment t
70 : "Non-nil means paragraph filling will try to pay attention to comments.")
71 :
72 : (defcustom enable-kinsoku t
73 : "Non-nil means enable \"kinsoku\" processing on filling paragraphs.
74 : Kinsoku processing is designed to prevent certain characters from being
75 : placed at the beginning or end of a line by filling.
76 : See the documentation of `kinsoku' for more information."
77 : :type 'boolean
78 : :group 'fill)
79 :
80 : (defun set-fill-prefix ()
81 : "Set the fill prefix to the current line up to point.
82 : Filling expects lines to start with the fill prefix and
83 : reinserts the fill prefix in each resulting line."
84 : (interactive)
85 0 : (let ((left-margin-pos (save-excursion (move-to-left-margin) (point))))
86 0 : (if (> (point) left-margin-pos)
87 0 : (progn
88 0 : (setq fill-prefix (buffer-substring left-margin-pos (point)))
89 0 : (if (equal fill-prefix "")
90 0 : (setq fill-prefix nil)))
91 0 : (setq fill-prefix nil)))
92 0 : (if fill-prefix
93 0 : (message "fill-prefix: \"%s\"" fill-prefix)
94 0 : (message "fill-prefix canceled")))
95 :
96 : (defcustom adaptive-fill-mode t
97 : "Non-nil means determine a paragraph's fill prefix from its text."
98 : :type 'boolean
99 : :group 'fill)
100 :
101 : (defcustom adaptive-fill-regexp
102 : ;; Added `!' for doxygen comments starting with `//!' or `/*!'.
103 : ;; Added `%' for TeX comments.
104 : ;; RMS: deleted the code to match `1.' and `(1)'.
105 : ;; Update mail-mode's paragraph-separate if you change this.
106 : (purecopy "[ \t]*\\([-–!|#%;>*·•‣⁃◦]+[ \t]*\\)*")
107 : "Regexp to match text at start of line that constitutes indentation.
108 : If Adaptive Fill mode is enabled, a prefix matching this pattern
109 : on the first and second lines of a paragraph is used as the
110 : standard indentation for the whole paragraph.
111 :
112 : If the paragraph has just one line, the indentation is taken from that
113 : line, but in that case `adaptive-fill-first-line-regexp' also plays
114 : a role."
115 : :type 'regexp
116 : :group 'fill)
117 :
118 : (defcustom adaptive-fill-first-line-regexp (purecopy "\\`[ \t]*\\'")
119 : "Regexp specifying whether to set fill prefix from a one-line paragraph.
120 : When a paragraph has just one line, then after `adaptive-fill-regexp'
121 : finds the prefix at the beginning of the line, if it doesn't
122 : match this regexp, it is replaced with whitespace.
123 :
124 : By default, this regexp matches sequences of just spaces and tabs.
125 :
126 : However, we never use a prefix from a one-line paragraph
127 : if it would act as a paragraph-starter on the second line."
128 : :type 'regexp
129 : :group 'fill)
130 :
131 : (defcustom adaptive-fill-function nil
132 : "Function to call to choose a fill prefix for a paragraph, or nil.
133 : A nil value means the function has not determined the fill prefix."
134 : :type '(choice (const nil) function)
135 : :group 'fill)
136 :
137 : (defvar fill-indent-according-to-mode nil ;Screws up CC-mode's filling tricks.
138 : "Whether or not filling should try to use the major mode's indentation.")
139 :
140 : (defun current-fill-column ()
141 : "Return the fill-column to use for this line.
142 : The fill-column to use for a buffer is stored in the variable `fill-column',
143 : but can be locally modified by the `right-margin' text property, which is
144 : subtracted from `fill-column'.
145 :
146 : The fill column to use for a line is the first column at which the column
147 : number equals or exceeds the local fill-column - right-margin difference."
148 0 : (save-excursion
149 0 : (if fill-column
150 0 : (let* ((here (line-beginning-position))
151 : (here-col 0)
152 0 : (eol (progn (end-of-line) (point)))
153 : margin fill-col change col)
154 : ;; Look separately at each region of line with a different
155 : ;; right-margin.
156 0 : (while (and (setq margin (get-text-property here 'right-margin)
157 0 : fill-col (- fill-column (or margin 0))
158 0 : change (text-property-not-all
159 0 : here eol 'right-margin margin))
160 0 : (progn (goto-char (1- change))
161 0 : (setq col (current-column))
162 0 : (< col fill-col)))
163 0 : (setq here change
164 0 : here-col col))
165 0 : (max here-col fill-col)))))
166 :
167 : (defun canonically-space-region (beg end)
168 : "Remove extra spaces between words in region.
169 : Leave one space between words, two at end of sentences or after colons
170 : \(depending on values of `sentence-end-double-space', `colon-double-space',
171 : and `sentence-end-without-period').
172 : Remove indentation from each line."
173 : (interactive "*r")
174 : ;; Ideally, we'd want to scan the text from the end, so that changes to
175 : ;; text don't affect the boundary, but the regexp we match against does
176 : ;; not match as eagerly when matching backward, so we instead use
177 : ;; a marker.
178 0 : (unless (markerp end) (setq end (copy-marker end t)))
179 0 : (let ((end-spc-re (concat "\\(" (sentence-end) "\\) *\\| +")))
180 0 : (save-excursion
181 0 : (goto-char beg)
182 : ;; Nuke tabs; they get screwed up in a fill.
183 : ;; This is quick, but loses when a tab follows the end of a sentence.
184 : ;; Actually, it is difficult to tell that from "Mr.\tSmith".
185 : ;; Blame the typist.
186 0 : (subst-char-in-region beg end ?\t ?\s)
187 0 : (while (and (< (point) end)
188 0 : (re-search-forward end-spc-re end t))
189 0 : (delete-region
190 0 : (cond
191 : ;; `sentence-end' matched and did not match all spaces.
192 : ;; I.e. it only matched the number of spaces it needs: drop the rest.
193 0 : ((and (match-end 1) (> (match-end 0) (match-end 1))) (match-end 1))
194 : ;; `sentence-end' matched but with nothing left. Either that means
195 : ;; nothing should be removed, or it means it's the "old-style"
196 : ;; sentence-end which matches all it can. Keep only 2 spaces.
197 : ;; We probably don't even need to check `sentence-end-double-space'.
198 0 : ((match-end 1)
199 0 : (min (match-end 0)
200 0 : (+ (if sentence-end-double-space 2 1)
201 0 : (save-excursion (goto-char (match-end 0))
202 0 : (skip-chars-backward " ")
203 0 : (point)))))
204 : (t ;; It's not an end of sentence.
205 0 : (+ (match-beginning 0)
206 : ;; Determine number of spaces to leave:
207 0 : (save-excursion
208 0 : (skip-chars-backward " ]})\"'")
209 0 : (cond ((and sentence-end-double-space
210 0 : (or (memq (preceding-char) '(?. ?? ?!))
211 0 : (and sentence-end-without-period
212 0 : (= (char-syntax (preceding-char)) ?w)))) 2)
213 0 : ((and colon-double-space
214 0 : (= (preceding-char) ?:)) 2)
215 0 : ((char-equal (preceding-char) ?\n) 0)
216 0 : (t 1))))))
217 0 : (match-end 0))))))
218 :
219 : (defun fill-common-string-prefix (s1 s2)
220 : "Return the longest common prefix of strings S1 and S2, or nil if none."
221 0 : (let ((cmp (compare-strings s1 nil nil s2 nil nil)))
222 0 : (if (eq cmp t)
223 0 : s1
224 0 : (setq cmp (1- (abs cmp)))
225 0 : (unless (zerop cmp)
226 0 : (substring s1 0 cmp)))))
227 :
228 : (defun fill-match-adaptive-prefix ()
229 0 : (let ((str (or
230 0 : (and adaptive-fill-function (funcall adaptive-fill-function))
231 0 : (and adaptive-fill-regexp (looking-at adaptive-fill-regexp)
232 0 : (match-string 0)))))
233 0 : (if (>= (+ (current-left-margin) (length str)) (current-fill-column))
234 : ;; Death to insanely long prefixes.
235 : nil
236 0 : str)))
237 :
238 : (defun fill-context-prefix (from to &optional first-line-regexp)
239 : "Compute a fill prefix from the text between FROM and TO.
240 : This uses the variables `adaptive-fill-regexp' and `adaptive-fill-function'
241 : and `adaptive-fill-first-line-regexp'. `paragraph-start' also plays a role;
242 : we reject a prefix based on a one-line paragraph if that prefix would
243 : act as a paragraph-separator."
244 0 : (or first-line-regexp
245 0 : (setq first-line-regexp adaptive-fill-first-line-regexp))
246 0 : (save-excursion
247 0 : (goto-char from)
248 0 : (if (eolp) (forward-line 1))
249 : ;; Move to the second line unless there is just one.
250 0 : (move-to-left-margin)
251 0 : (let (first-line-prefix
252 : ;; Non-nil if we are on the second line.
253 : second-line-prefix)
254 0 : (setq first-line-prefix
255 : ;; We don't need to consider `paragraph-start' here since it
256 : ;; will be explicitly checked later on.
257 : ;; Also setting first-line-prefix to nil prevents
258 : ;; second-line-prefix from being used.
259 : ;; ((looking-at paragraph-start) nil)
260 0 : (fill-match-adaptive-prefix))
261 0 : (forward-line 1)
262 0 : (if (< (point) to)
263 0 : (progn
264 0 : (move-to-left-margin)
265 0 : (setq second-line-prefix
266 0 : (cond ((looking-at paragraph-start) nil) ;Can it happen? -Stef
267 0 : (t (fill-match-adaptive-prefix))))
268 : ;; If we get a fill prefix from the second line,
269 : ;; make sure it or something compatible is on the first line too.
270 0 : (when second-line-prefix
271 0 : (unless first-line-prefix (setq first-line-prefix ""))
272 : ;; If the non-whitespace chars match the first line,
273 : ;; just use it (this subsumes the 2 checks used previously).
274 : ;; Used when first line is `/* ...' and second-line is
275 : ;; ` * ...'.
276 0 : (let ((tmp second-line-prefix)
277 : (re "\\`"))
278 0 : (while (string-match "\\`[ \t]*\\([^ \t]+\\)" tmp)
279 0 : (setq re (concat re ".*" (regexp-quote (match-string 1 tmp))))
280 0 : (setq tmp (substring tmp (match-end 0))))
281 : ;; (assert (string-match "\\`[ \t]*\\'" tmp))
282 :
283 0 : (if (string-match re first-line-prefix)
284 0 : second-line-prefix
285 :
286 : ;; Use the longest common substring of both prefixes,
287 : ;; if there is one.
288 0 : (fill-common-string-prefix first-line-prefix
289 0 : second-line-prefix)))))
290 : ;; If we get a fill prefix from a one-line paragraph,
291 : ;; maybe change it to whitespace,
292 : ;; and check that it isn't a paragraph starter.
293 0 : (if first-line-prefix
294 0 : (let ((result
295 : ;; If first-line-prefix comes from the first line,
296 : ;; see if it seems reasonable to use for all lines.
297 : ;; If not, replace it with whitespace.
298 0 : (if (or (and first-line-regexp
299 0 : (string-match first-line-regexp
300 0 : first-line-prefix))
301 0 : (and comment-start-skip
302 0 : (string-match comment-start-skip
303 0 : first-line-prefix)))
304 0 : first-line-prefix
305 0 : (make-string (string-width first-line-prefix) ?\s))))
306 : ;; But either way, reject it if it indicates the start
307 : ;; of a paragraph when text follows it.
308 0 : (if (not (eq 0 (string-match paragraph-start
309 0 : (concat result "a"))))
310 0 : result)))))))
311 :
312 : (defun fill-single-word-nobreak-p ()
313 : "Don't break a line after the first or before the last word of a sentence."
314 : ;; Actually, allow breaking before the last word of a sentence, so long as
315 : ;; it's not the last word of the paragraph.
316 0 : (or (looking-at (concat "[ \t]*\\sw+" "\\(?:" (sentence-end) "\\)[ \t]*$"))
317 0 : (save-excursion
318 0 : (skip-chars-backward " \t")
319 0 : (and (/= (skip-syntax-backward "w") 0)
320 0 : (/= (skip-chars-backward " \t") 0)
321 0 : (/= (skip-chars-backward ".?!:") 0)
322 0 : (looking-at (sentence-end))))))
323 :
324 : (defun fill-french-nobreak-p ()
325 : "Return nil if French style allows breaking the line at point.
326 : This is used in `fill-nobreak-predicate' to prevent breaking lines just
327 : after an opening paren or just before a closing paren or a punctuation
328 : mark such as `?' or `:'. It is common in French writing to put a space
329 : at such places, which would normally allow breaking the line at those
330 : places."
331 0 : (or (looking-at "[ \t]*[])}»?!;:-]")
332 0 : (save-excursion
333 0 : (skip-chars-backward " \t")
334 0 : (unless (bolp)
335 0 : (backward-char 1)
336 0 : (or (looking-at "[([{«]")
337 : ;; Don't cut right after a single-letter word.
338 0 : (and (memq (preceding-char) '(?\t ?\s))
339 0 : (eq (char-syntax (following-char)) ?w)))))))
340 :
341 : (defun fill-single-char-nobreak-p ()
342 : "Return non-nil if a one-letter word is before point.
343 : This function is suitable for adding to the hook `fill-nobreak-predicate',
344 : to prevent the breaking of a line just after a one-letter word,
345 : which is an error according to some typographical conventions."
346 0 : (save-excursion
347 0 : (skip-chars-backward " \t")
348 0 : (backward-char 2)
349 0 : (looking-at "[[:space:]][[:alpha:]]")))
350 :
351 : (defcustom fill-nobreak-predicate nil
352 : "List of predicates for recognizing places not to break a line.
353 : The predicates are called with no arguments, with point at the place to
354 : be tested. If it returns t, fill commands do not break the line there."
355 : :group 'fill
356 : :type 'hook
357 : :options '(fill-french-nobreak-p fill-single-word-nobreak-p
358 : fill-single-char-nobreak-p))
359 :
360 : (defcustom fill-nobreak-invisible nil
361 : "Non-nil means that fill commands do not break lines in invisible text."
362 : :type 'boolean
363 : :group 'fill)
364 :
365 : (defun fill-nobreak-p ()
366 : "Return nil if breaking the line at point is allowed.
367 : Can be customized with the variables `fill-nobreak-predicate'
368 : and `fill-nobreak-invisible'."
369 0 : (or
370 0 : (and fill-nobreak-invisible (invisible-p (point)))
371 0 : (unless (bolp)
372 0 : (or
373 : ;; Don't break after a period followed by just one space.
374 : ;; Move back to the previous place to break.
375 : ;; The reason is that if a period ends up at the end of a
376 : ;; line, further fills will assume it ends a sentence.
377 : ;; If we now know it does not end a sentence, avoid putting
378 : ;; it at the end of the line.
379 0 : (and sentence-end-double-space
380 0 : (save-excursion
381 0 : (skip-chars-backward " ")
382 0 : (and (eq (preceding-char) ?.)
383 0 : (looking-at " \\([^ ]\\|$\\)"))))
384 : ;; Another approach to the same problem.
385 0 : (save-excursion
386 0 : (skip-chars-backward " ")
387 0 : (and (eq (preceding-char) ?.)
388 0 : (not (progn (forward-char -1) (looking-at (sentence-end))))))
389 : ;; Don't split a line if the rest would look like a new paragraph.
390 0 : (unless use-hard-newlines
391 0 : (save-excursion
392 0 : (skip-chars-forward " \t")
393 : ;; If this break point is at the end of the line,
394 : ;; which can occur for auto-fill, don't consider the newline
395 : ;; which follows as a reason to return t.
396 0 : (and (not (eolp))
397 0 : (looking-at paragraph-start))))
398 0 : (run-hook-with-args-until-success 'fill-nobreak-predicate)))))
399 :
400 : (defvar fill-find-break-point-function-table (make-char-table nil)
401 : "Char-table of special functions to find line breaking point.")
402 :
403 : (defvar fill-nospace-between-words-table (make-char-table nil)
404 : "Char-table of characters that don't use space between words.")
405 :
406 : (progn
407 : ;; Register `kinsoku' for scripts HAN, KANA, BOPOMOFO, and CJK-MISC.
408 : ;; Also tell that they don't use space between words.
409 : (map-char-table
410 : #'(lambda (key val)
411 : (when (memq val '(han kana bopomofo cjk-misc))
412 : (set-char-table-range fill-find-break-point-function-table
413 : key 'kinsoku)
414 : (set-char-table-range fill-nospace-between-words-table
415 : key t)))
416 : char-script-table)
417 : ;; Do the same thing also for full width characters and half
418 : ;; width kana variants.
419 : (set-char-table-range fill-find-break-point-function-table
420 : '(#xFF01 . #xFFE6) 'kinsoku)
421 : (set-char-table-range fill-nospace-between-words-table
422 : '(#xFF01 . #xFFE6) 'kinsoku))
423 :
424 : (defun fill-find-break-point (limit)
425 : "Move point to a proper line breaking position of the current line.
426 : Don't move back past the buffer position LIMIT.
427 :
428 : This function is called when we are going to break the current line
429 : after or before a non-ASCII character. If the charset of the
430 : character has the property `fill-find-break-point-function', this
431 : function calls the property value as a function with one arg LIMIT.
432 : If the charset has no such property, do nothing."
433 0 : (let ((func (or
434 0 : (aref fill-find-break-point-function-table (following-char))
435 0 : (aref fill-find-break-point-function-table (preceding-char)))))
436 0 : (if (and func (fboundp func))
437 0 : (funcall func limit))))
438 :
439 : (defun fill-delete-prefix (from to prefix)
440 : "Delete the fill prefix from every line except the first.
441 : The first line may not even have a fill prefix.
442 : Point is moved to just past the fill prefix on the first line."
443 0 : (let ((fpre (if (and prefix (not (string-match "\\`[ \t]*\\'" prefix)))
444 0 : (concat "[ \t]*\\("
445 0 : (replace-regexp-in-string
446 : "[ \t]+" "[ \t]*"
447 0 : (regexp-quote prefix))
448 0 : "\\)?[ \t]*")
449 0 : "[ \t]*")))
450 0 : (goto-char from)
451 : ;; Why signal an error here? The problem needs to be caught elsewhere.
452 : ;; (if (>= (+ (current-left-margin) (length prefix))
453 : ;; (current-fill-column))
454 : ;; (error "fill-prefix too long for specified width"))
455 0 : (forward-line 1)
456 0 : (while (< (point) to)
457 0 : (if (looking-at fpre)
458 0 : (delete-region (point) (match-end 0)))
459 0 : (forward-line 1))
460 0 : (goto-char from)
461 0 : (if (looking-at fpre)
462 0 : (goto-char (match-end 0)))
463 0 : (point)))
464 :
465 : ;; The `fill-space' property carries the string with which a newline
466 : ;; should be replaced when unbreaking a line (in fill-delete-newlines).
467 : ;; It is added to newline characters by fill-newline when the default
468 : ;; behavior of fill-delete-newlines is not what we want.
469 : (add-to-list 'text-property-default-nonsticky '(fill-space . t))
470 :
471 : (defun fill-delete-newlines (from to justify nosqueeze squeeze-after)
472 0 : (goto-char from)
473 : ;; Make sure sentences ending at end of line get an extra space.
474 : ;; loses on split abbrevs ("Mr.\nSmith")
475 0 : (let ((eol-double-space-re
476 0 : (cond
477 0 : ((not colon-double-space) (concat (sentence-end) "$"))
478 : ;; Try to add the : inside the `sentence-end' regexp.
479 0 : ((string-match "\\[[^][]*\\(\\.\\)[^][]*\\]" (sentence-end))
480 0 : (concat (replace-match ".:" nil nil (sentence-end) 1) "$"))
481 : ;; Can't find the right spot to insert the colon.
482 0 : (t "[.?!:][])}\"']*$")))
483 : (sentence-end-without-space-list
484 0 : (string-to-list sentence-end-without-space)))
485 0 : (while (re-search-forward eol-double-space-re to t)
486 0 : (or (>= (point) to) (memq (char-before) '(?\t ?\s))
487 0 : (memq (char-after (match-beginning 0))
488 0 : sentence-end-without-space-list)
489 0 : (insert-and-inherit ?\s))))
490 :
491 0 : (goto-char from)
492 0 : (if enable-multibyte-characters
493 : ;; Delete unnecessary newlines surrounded by words. The
494 : ;; character category `|' means that we can break a line at the
495 : ;; character. And, char-table
496 : ;; `fill-nospace-between-words-table' tells how to concatenate
497 : ;; words. If a character has non-nil value in the table, never
498 : ;; put spaces between words, thus delete a newline between them.
499 : ;; Otherwise, delete a newline only when a character preceding a
500 : ;; newline has non-nil value in that table.
501 0 : (while (search-forward "\n" to t)
502 0 : (if (get-text-property (match-beginning 0) 'fill-space)
503 0 : (replace-match (get-text-property (match-beginning 0) 'fill-space))
504 0 : (let ((prev (char-before (match-beginning 0)))
505 0 : (next (following-char)))
506 0 : (if (and (if fill-separate-heterogeneous-words-with-space
507 0 : (and (aref (char-category-set next) ?|)
508 0 : (aref (char-category-set prev) ?|))
509 0 : (or (aref (char-category-set next) ?|)
510 0 : (aref (char-category-set prev) ?|)))
511 0 : (or (aref fill-nospace-between-words-table next)
512 0 : (aref fill-nospace-between-words-table prev)))
513 0 : (delete-char -1))))))
514 :
515 0 : (goto-char from)
516 0 : (skip-chars-forward " \t")
517 : ;; Then change all newlines to spaces.
518 0 : (subst-char-in-region from to ?\n ?\s)
519 0 : (if (and nosqueeze (not (eq justify 'full)))
520 : nil
521 0 : (canonically-space-region (or squeeze-after (point)) to)
522 : ;; Remove trailing whitespace.
523 : ;; Maybe canonically-space-region should do that.
524 0 : (goto-char to) (delete-char (- (skip-chars-backward " \t"))))
525 0 : (goto-char from))
526 :
527 : (defun fill-move-to-break-point (linebeg)
528 : "Move to the position where the line should be broken.
529 : The break position will be always after LINEBEG and generally before point."
530 : ;; If the fill column is before linebeg, move to linebeg.
531 0 : (if (> linebeg (point)) (goto-char linebeg))
532 : ;; Move back to the point where we can break the line
533 : ;; at. We break the line between word or after/before
534 : ;; the character which has character category `|'. We
535 : ;; search space, \c| followed by a character, or \c|
536 : ;; following a character. If not found, place
537 : ;; the point at linebeg.
538 0 : (while
539 0 : (when (re-search-backward "[ \t]\\|\\c|.\\|.\\c|" linebeg 0)
540 : ;; In case of space, we place the point at next to
541 : ;; the point where the break occurs actually,
542 : ;; because we don't want to change the following
543 : ;; logic of original Emacs. In case of \c|, the
544 : ;; point is at the place where the break occurs.
545 0 : (forward-char 1)
546 0 : (when (fill-nobreak-p) (skip-chars-backward " \t" linebeg))))
547 :
548 : ;; Move back over the single space between the words.
549 0 : (skip-chars-backward " \t")
550 :
551 : ;; If the left margin and fill prefix by themselves
552 : ;; pass the fill-column. or if they are zero
553 : ;; but we have no room for even one word,
554 : ;; keep at least one word or a character which has
555 : ;; category `|' anyway.
556 0 : (if (>= linebeg (point))
557 : ;; Ok, skip at least one word or one \c| character.
558 : ;; Meanwhile, don't stop at a period followed by one space.
559 0 : (let ((to (line-end-position))
560 : (first t))
561 0 : (goto-char linebeg)
562 0 : (while (and (< (point) to) (or first (fill-nobreak-p)))
563 : ;; Find a breakable point while ignoring the
564 : ;; following spaces.
565 0 : (skip-chars-forward " \t")
566 0 : (if (looking-at "\\c|")
567 0 : (forward-char 1)
568 0 : (let ((pos (save-excursion
569 0 : (skip-chars-forward "^ \n\t")
570 0 : (point))))
571 0 : (if (re-search-forward "\\c|" pos t)
572 0 : (forward-char -1)
573 0 : (goto-char pos))))
574 0 : (setq first nil)))
575 :
576 0 : (if enable-multibyte-characters
577 : ;; If we are going to break the line after or
578 : ;; before a non-ascii character, we may have to
579 : ;; run a special function for the charset of the
580 : ;; character to find the correct break point.
581 0 : (if (not (and (eq (charset-after (1- (point))) 'ascii)
582 0 : (eq (charset-after (point)) 'ascii)))
583 : ;; Make sure we take SOMETHING after the fill prefix if any.
584 0 : (fill-find-break-point linebeg)))))
585 :
586 : ;; Like text-properties-at but don't include `composition' property.
587 : (defun fill-text-properties-at (pos)
588 0 : (let ((l (text-properties-at pos))
589 : prop-list)
590 0 : (while l
591 0 : (unless (eq (car l) 'composition)
592 0 : (setq prop-list
593 0 : (cons (car l) (cons (cadr l) prop-list))))
594 0 : (setq l (cddr l)))
595 0 : prop-list))
596 :
597 : (defun fill-newline ()
598 : ;; Replace whitespace here with one newline, then
599 : ;; indent to left margin.
600 0 : (skip-chars-backward " \t")
601 0 : (insert ?\n)
602 : ;; Give newline the properties of the space(s) it replaces
603 0 : (set-text-properties (1- (point)) (point)
604 0 : (fill-text-properties-at (point)))
605 0 : (and (looking-at "\\( [ \t]*\\)\\(\\c|\\)?")
606 0 : (or (aref (char-category-set (or (char-before (1- (point))) ?\000)) ?|)
607 0 : (match-end 2))
608 : ;; When refilling later on, this newline would normally not be replaced
609 : ;; by a space, so we need to mark it specially to re-install the space
610 : ;; when we unfill.
611 0 : (put-text-property (1- (point)) (point) 'fill-space (match-string 1)))
612 : ;; If we don't want breaks in invisible text, don't insert
613 : ;; an invisible newline.
614 0 : (if fill-nobreak-invisible
615 0 : (remove-text-properties (1- (point)) (point)
616 0 : '(invisible t)))
617 0 : (if (or fill-prefix
618 0 : (not fill-indent-according-to-mode))
619 0 : (fill-indent-to-left-margin)
620 0 : (indent-according-to-mode))
621 : ;; Insert the fill prefix after indentation.
622 0 : (and fill-prefix (not (equal fill-prefix ""))
623 : ;; Markers that were after the whitespace are now at point: insert
624 : ;; before them so they don't get stuck before the prefix.
625 0 : (insert-before-markers-and-inherit fill-prefix)))
626 :
627 : (defun fill-indent-to-left-margin ()
628 : "Indent current line to the column given by `current-left-margin'."
629 0 : (let ((beg (point)))
630 0 : (indent-line-to (current-left-margin))
631 0 : (put-text-property beg (point) 'face 'default)))
632 :
633 : (defun fill-region-as-paragraph (from to &optional justify
634 : nosqueeze squeeze-after)
635 : "Fill the region as one paragraph.
636 : It removes any paragraph breaks in the region and extra newlines at the end,
637 : indents and fills lines between the margins given by the
638 : `current-left-margin' and `current-fill-column' functions.
639 : \(In most cases, the variable `fill-column' controls the width.)
640 : It leaves point at the beginning of the line following the paragraph.
641 :
642 : Normally performs justification according to the `current-justification'
643 : function, but with a prefix arg, does full justification instead.
644 :
645 : From a program, optional third arg JUSTIFY can specify any type of
646 : justification. Fourth arg NOSQUEEZE non-nil means not to make spaces
647 : between words canonical before filling. Fifth arg SQUEEZE-AFTER, if non-nil,
648 : means don't canonicalize spaces before that position.
649 :
650 : Return the `fill-prefix' used for filling.
651 :
652 : If `sentence-end-double-space' is non-nil, then period followed by one
653 : space does not end a sentence, so don't break a line there."
654 0 : (interactive (progn
655 0 : (barf-if-buffer-read-only)
656 0 : (list (region-beginning) (region-end)
657 0 : (if current-prefix-arg 'full))))
658 0 : (unless (memq justify '(t nil none full center left right))
659 0 : (setq justify 'full))
660 :
661 : ;; Make sure "to" is the endpoint.
662 0 : (goto-char (min from to))
663 0 : (setq to (max from to))
664 : ;; Ignore blank lines at beginning of region.
665 0 : (skip-chars-forward " \t\n")
666 :
667 0 : (let ((from-plus-indent (point))
668 : (oneleft nil))
669 :
670 0 : (beginning-of-line)
671 : ;; We used to round up to whole line, but that prevents us from
672 : ;; correctly handling filling of mixed code-and-comment where we do want
673 : ;; to fill the comment but not the code. So only use (point) if it's
674 : ;; further than `from', which means that `from' is followed by some
675 : ;; number of empty lines.
676 0 : (setq from (max (point) from))
677 :
678 : ;; Delete all but one soft newline at end of region.
679 : ;; And leave TO before that one.
680 0 : (goto-char to)
681 0 : (while (and (> (point) from) (eq ?\n (char-after (1- (point)))))
682 0 : (if (and oneleft
683 0 : (not (and use-hard-newlines
684 0 : (get-text-property (1- (point)) 'hard))))
685 0 : (delete-char -1)
686 0 : (backward-char 1)
687 0 : (setq oneleft t)))
688 0 : (setq to (copy-marker (point) t))
689 : ;; ;; If there was no newline, and there is text in the paragraph, then
690 : ;; ;; create a newline.
691 : ;; (if (and (not oneleft) (> to from-plus-indent))
692 : ;; (newline))
693 0 : (goto-char from-plus-indent))
694 :
695 0 : (if (not (> to (point)))
696 : nil ;; There is no paragraph, only whitespace: exit now.
697 :
698 0 : (or justify (setq justify (current-justification)))
699 :
700 : ;; Don't let Adaptive Fill mode alter the fill prefix permanently.
701 0 : (let ((fill-prefix fill-prefix))
702 : ;; Figure out how this paragraph is indented, if desired.
703 0 : (when (and adaptive-fill-mode
704 0 : (or (null fill-prefix) (string= fill-prefix "")))
705 0 : (setq fill-prefix (fill-context-prefix from to))
706 : ;; Ignore a white-space only fill-prefix
707 : ;; if we indent-according-to-mode.
708 0 : (when (and fill-prefix fill-indent-according-to-mode
709 0 : (string-match "\\`[ \t]*\\'" fill-prefix))
710 0 : (setq fill-prefix nil)))
711 :
712 0 : (goto-char from)
713 0 : (beginning-of-line)
714 :
715 0 : (if (not justify) ; filling disabled: just check indentation
716 0 : (progn
717 0 : (goto-char from)
718 0 : (while (< (point) to)
719 0 : (if (and (not (eolp))
720 0 : (< (current-indentation) (current-left-margin)))
721 0 : (fill-indent-to-left-margin))
722 0 : (forward-line 1)))
723 :
724 0 : (if use-hard-newlines
725 0 : (remove-list-of-text-properties from to '(hard)))
726 : ;; Make sure first line is indented (at least) to left margin...
727 0 : (if (or (memq justify '(right center))
728 0 : (< (current-indentation) (current-left-margin)))
729 0 : (fill-indent-to-left-margin))
730 : ;; Delete the fill-prefix from every line.
731 0 : (fill-delete-prefix from to fill-prefix)
732 0 : (setq from (point))
733 :
734 : ;; FROM, and point, are now before the text to fill,
735 : ;; but after any fill prefix on the first line.
736 :
737 0 : (fill-delete-newlines from to justify nosqueeze squeeze-after)
738 :
739 : ;; This is the actual filling loop.
740 0 : (goto-char from)
741 0 : (let (linebeg)
742 0 : (while (< (point) to)
743 0 : (setq linebeg (point))
744 0 : (move-to-column (current-fill-column))
745 0 : (if (when (< (point) to)
746 : ;; Find the position where we'll break the line.
747 : ;; Use an immediately following space, if any.
748 : ;; However, note that `move-to-column' may overshoot
749 : ;; if there are wide characters (Bug#3234).
750 0 : (unless (> (current-column) (current-fill-column))
751 0 : (forward-char 1))
752 0 : (fill-move-to-break-point linebeg)
753 : ;; Check again to see if we got to the end of
754 : ;; the paragraph.
755 0 : (skip-chars-forward " \t")
756 0 : (< (point) to))
757 : ;; Found a place to cut.
758 0 : (progn
759 0 : (fill-newline)
760 0 : (when justify
761 : ;; Justify the line just ended, if desired.
762 0 : (save-excursion
763 0 : (forward-line -1)
764 0 : (justify-current-line justify nil t))))
765 :
766 0 : (goto-char to)
767 : ;; Justify this last line, if desired.
768 0 : (if justify (justify-current-line justify t t))))))
769 : ;; Leave point after final newline.
770 0 : (goto-char to)
771 0 : (unless (eobp) (forward-char 1))
772 : ;; Return the fill-prefix we used
773 0 : fill-prefix)))
774 :
775 : (defsubst skip-line-prefix (prefix)
776 : "If point is inside the string PREFIX at the beginning of line, move past it."
777 0 : (when (and prefix
778 0 : (< (- (point) (line-beginning-position)) (length prefix))
779 0 : (save-excursion
780 0 : (beginning-of-line)
781 0 : (looking-at (regexp-quote prefix))))
782 0 : (goto-char (match-end 0))))
783 :
784 : (defun fill-minibuffer-function (arg)
785 : "Fill a paragraph in the minibuffer, ignoring the prompt."
786 0 : (save-restriction
787 0 : (narrow-to-region (minibuffer-prompt-end) (point-max))
788 0 : (fill-paragraph arg)))
789 :
790 : (defvar fill-forward-paragraph-function 'forward-paragraph
791 : "Function to move over paragraphs used by the filling code.
792 : It is called with a single argument specifying the number of paragraphs to move.
793 : Just like `forward-paragraph', it should return the number of paragraphs
794 : left to move.")
795 :
796 : (defun fill-forward-paragraph (arg)
797 0 : (funcall fill-forward-paragraph-function arg))
798 :
799 : (defun fill-paragraph (&optional justify region)
800 : "Fill paragraph at or after point.
801 :
802 : If JUSTIFY is non-nil (interactively, with prefix argument), justify as well.
803 : If `sentence-end-double-space' is non-nil, then period followed by one
804 : space does not end a sentence, so don't break a line there.
805 : The variable `fill-column' controls the width for filling.
806 :
807 : If `fill-paragraph-function' is non-nil, we call it (passing our
808 : argument to it), and if it returns non-nil, we simply return its value.
809 :
810 : If `fill-paragraph-function' is nil, return the `fill-prefix' used for filling.
811 :
812 : The REGION argument is non-nil if called interactively; in that
813 : case, if Transient Mark mode is enabled and the mark is active,
814 : call `fill-region' to fill each of the paragraphs in the active
815 : region, instead of just filling the current paragraph."
816 0 : (interactive (progn
817 0 : (barf-if-buffer-read-only)
818 0 : (list (if current-prefix-arg 'full) t)))
819 0 : (let ((hash (and (not (buffer-modified-p))
820 0 : (buffer-hash))))
821 0 : (prog1
822 0 : (or
823 : ;; 1. Fill the region if it is active when called interactively.
824 0 : (and region transient-mark-mode mark-active
825 0 : (not (eq (region-beginning) (region-end)))
826 0 : (or (fill-region (region-beginning) (region-end) justify) t))
827 : ;; 2. Try fill-paragraph-function.
828 0 : (and (not (eq fill-paragraph-function t))
829 0 : (or fill-paragraph-function
830 0 : (and (minibufferp (current-buffer))
831 0 : (= 1 (point-min))))
832 0 : (let ((function (or fill-paragraph-function
833 : ;; In the minibuffer, don't count
834 : ;; the width of the prompt.
835 0 : 'fill-minibuffer-function))
836 : ;; If fill-paragraph-function is set, it probably
837 : ;; takes care of comments and stuff. If not, it
838 : ;; will have to set fill-paragraph-handle-comment
839 : ;; back to t explicitly or return nil.
840 : (fill-paragraph-handle-comment nil)
841 : (fill-paragraph-function t))
842 0 : (funcall function justify)))
843 : ;; 3. Try our syntax-aware filling code.
844 0 : (and fill-paragraph-handle-comment
845 : ;; Our code only handles \n-terminated comments right now.
846 0 : comment-start (equal comment-end "")
847 0 : (let ((fill-paragraph-handle-comment nil))
848 0 : (fill-comment-paragraph justify)))
849 : ;; 4. If it all fails, default to the good ol' text paragraph filling.
850 0 : (let ((before (point))
851 0 : (paragraph-start paragraph-start)
852 : ;; Fill prefix used for filling the paragraph.
853 : fill-pfx)
854 : ;; Try to prevent code sections and comment sections from being
855 : ;; filled together.
856 0 : (when (and fill-paragraph-handle-comment comment-start-skip)
857 0 : (setq paragraph-start
858 0 : (concat paragraph-start "\\|[ \t]*\\(?:"
859 0 : comment-start-skip "\\)")))
860 0 : (save-excursion
861 : ;; To make sure the return value of forward-paragraph is
862 : ;; meaningful, we have to start from the beginning of
863 : ;; line, otherwise skipping past the last few chars of a
864 : ;; paragraph-separator would count as a paragraph (and
865 : ;; not skipping any chars at EOB would not count as a
866 : ;; paragraph even if it is).
867 0 : (move-to-left-margin)
868 0 : (if (not (zerop (fill-forward-paragraph 1)))
869 : ;; There's no paragraph at or after point: give up.
870 0 : (setq fill-pfx "")
871 0 : (let ((end (point))
872 0 : (beg (progn (fill-forward-paragraph -1) (point))))
873 0 : (goto-char before)
874 0 : (setq fill-pfx
875 0 : (if use-hard-newlines
876 : ;; Can't use fill-region-as-paragraph, since this
877 : ;; paragraph may still contain hard newlines. See
878 : ;; fill-region.
879 0 : (fill-region beg end justify)
880 0 : (fill-region-as-paragraph beg end justify))))))
881 0 : fill-pfx))
882 : ;; If we didn't change anything in the buffer (and the buffer
883 : ;; was previously unmodified), then flip the modification status
884 : ;; back to "unchanged".
885 0 : (when (and hash
886 0 : (equal hash (buffer-hash)))
887 0 : (set-buffer-modified-p nil)))))
888 :
889 : (declare-function comment-search-forward "newcomment" (limit &optional noerror))
890 : (declare-function comment-string-strip "newcomment" (str beforep afterp))
891 :
892 :
893 : (defun fill-comment-paragraph (&optional justify)
894 : "Fill current comment.
895 : If we're not in a comment, just return nil so that the caller
896 : can take care of filling. JUSTIFY is used as in `fill-paragraph'."
897 0 : (comment-normalize-vars)
898 0 : (let (has-code-and-comment ; Non-nil if it contains code and a comment.
899 : comin comstart)
900 : ;; Figure out what kind of comment we are looking at.
901 0 : (save-excursion
902 0 : (beginning-of-line)
903 0 : (when (setq comstart (comment-search-forward (line-end-position) t))
904 0 : (setq comin (point))
905 0 : (goto-char comstart) (skip-chars-backward " \t")
906 0 : (setq has-code-and-comment (not (bolp)))))
907 :
908 0 : (if (not (and comstart
909 : ;; Make sure the comment-start mark we found is accepted by
910 : ;; comment-start-skip. If not, all bets are off, and
911 : ;; we'd better not mess with it.
912 0 : (string-match comment-start-skip
913 0 : (buffer-substring comstart comin))))
914 :
915 : ;; Return nil, so the normal filling will take place.
916 : nil
917 :
918 : ;; Narrow to include only the comment, and then fill the region.
919 0 : (let* ((fill-prefix fill-prefix)
920 : (commark
921 0 : (comment-string-strip (buffer-substring comstart comin) nil t))
922 : (comment-re
923 : ;; A regexp more specialized than comment-start-skip, that only
924 : ;; matches the current commark rather than any valid commark.
925 : ;;
926 : ;; The specialized regexp only works for "normal" comment
927 : ;; syntax, not for Texinfo's "@c" (which can't be immediately
928 : ;; followed by word-chars) or Fortran's "C" (which needs to be
929 : ;; at bol), so check that comment-start-skip indeed allows the
930 : ;; commark to appear in the middle of the line and followed by
931 : ;; word chars. The choice of "\0" and "a" is mostly arbitrary.
932 0 : (if (string-match comment-start-skip (concat "\0" commark "a"))
933 0 : (concat "[ \t]*" (regexp-quote commark)
934 : ;; Make sure we only match comments that
935 : ;; use the exact same comment marker.
936 0 : "[^" (substring commark -1) "]")
937 0 : (concat "[ \t]*\\(?:" comment-start-skip "\\)")))
938 : (comment-fill-prefix ; Compute a fill prefix.
939 0 : (save-excursion
940 0 : (goto-char comstart)
941 0 : (if has-code-and-comment
942 0 : (concat
943 0 : (if (not indent-tabs-mode)
944 0 : (make-string (current-column) ?\s)
945 0 : (concat
946 0 : (make-string (/ (current-column) tab-width) ?\t)
947 0 : (make-string (% (current-column) tab-width) ?\s)))
948 0 : (buffer-substring (point) comin))
949 0 : (buffer-substring (line-beginning-position) comin))))
950 : beg end)
951 0 : (save-excursion
952 0 : (save-restriction
953 0 : (beginning-of-line)
954 0 : (narrow-to-region
955 : ;; Find the first line we should include in the region to fill.
956 0 : (if has-code-and-comment
957 0 : (line-beginning-position)
958 0 : (save-excursion
959 0 : (while (and (zerop (forward-line -1))
960 0 : (looking-at comment-re)))
961 : ;; We may have gone too far. Go forward again.
962 0 : (line-beginning-position
963 0 : (if (progn
964 0 : (goto-char
965 0 : (or (comment-search-forward (line-end-position) t)
966 0 : (point)))
967 0 : (looking-at comment-re))
968 0 : (progn (setq comstart (point)) 1)
969 0 : (progn (setq comstart (point)) 2)))))
970 : ;; Find the beginning of the first line past the region to fill.
971 0 : (save-excursion
972 0 : (while (progn (forward-line 1)
973 0 : (looking-at comment-re)))
974 0 : (point)))
975 : ;; Obey paragraph starters and boundaries within comments.
976 0 : (let* ((paragraph-separate
977 : ;; Use the default values since they correspond to
978 : ;; the values to use for plain text.
979 0 : (concat paragraph-separate "\\|[ \t]*\\(?:"
980 0 : comment-start-skip "\\)\\(?:"
981 0 : (default-value 'paragraph-separate) "\\)"))
982 : (paragraph-start
983 0 : (concat paragraph-start "\\|[ \t]*\\(?:"
984 0 : comment-start-skip "\\)\\(?:"
985 0 : (default-value 'paragraph-start) "\\)"))
986 : ;; We used to rely on fill-prefix to break paragraph at
987 : ;; comment-starter changes, but it did not work for the
988 : ;; first line (mixed comment&code).
989 : ;; We now use comment-re instead to "manually" make sure
990 : ;; we treat comment-marker changes as paragraph boundaries.
991 : ;; (paragraph-ignore-fill-prefix nil)
992 : ;; (fill-prefix comment-fill-prefix)
993 0 : (after-line (if has-code-and-comment
994 0 : (line-beginning-position 2))))
995 0 : (setq end (progn (forward-paragraph) (point)))
996 : ;; If this comment starts on a line with code,
997 : ;; include that line in the filling.
998 0 : (setq beg (progn (backward-paragraph)
999 0 : (if (eq (point) after-line)
1000 0 : (forward-line -1))
1001 0 : (point)))))
1002 :
1003 : ;; Find the fill-prefix to use.
1004 0 : (cond
1005 0 : (fill-prefix) ; Use the user-provided fill prefix.
1006 0 : ((and adaptive-fill-mode ; Try adaptive fill mode.
1007 0 : (setq fill-prefix (fill-context-prefix beg end))
1008 0 : (string-match comment-start-skip fill-prefix)))
1009 : (t
1010 0 : (setq fill-prefix comment-fill-prefix)))
1011 :
1012 : ;; Don't fill with narrowing.
1013 0 : (or
1014 0 : (fill-region-as-paragraph
1015 0 : (max comstart beg) end justify nil
1016 : ;; Don't canonicalize spaces within the code just before
1017 : ;; the comment.
1018 0 : (save-excursion
1019 0 : (goto-char beg)
1020 0 : (if (looking-at fill-prefix)
1021 : nil
1022 0 : (re-search-forward comment-start-skip))))
1023 : ;; Make sure we don't return nil.
1024 0 : t))))))
1025 :
1026 : (defun fill-region (from to &optional justify nosqueeze to-eop)
1027 : "Fill each of the paragraphs in the region.
1028 : A prefix arg means justify as well.
1029 : The `fill-column' variable controls the width.
1030 :
1031 : Noninteractively, the third argument JUSTIFY specifies which
1032 : kind of justification to do: `full', `left', `right', `center',
1033 : or `none' (equivalent to nil). A value of t means handle each
1034 : paragraph as specified by its text properties.
1035 :
1036 : The fourth arg NOSQUEEZE non-nil means to leave whitespace other
1037 : than line breaks untouched, and fifth arg TO-EOP non-nil means
1038 : to keep filling to the end of the paragraph (or next hard newline,
1039 : if variable `use-hard-newlines' is on).
1040 :
1041 : Return the fill-prefix used for filling the last paragraph.
1042 :
1043 : If `sentence-end-double-space' is non-nil, then period followed by one
1044 : space does not end a sentence, so don't break a line there."
1045 0 : (interactive (progn
1046 0 : (barf-if-buffer-read-only)
1047 0 : (list (region-beginning) (region-end)
1048 0 : (if current-prefix-arg 'full))))
1049 0 : (unless (memq justify '(t nil none full center left right))
1050 0 : (setq justify 'full))
1051 0 : (let ((start-point (point-marker))
1052 : max beg fill-pfx)
1053 0 : (goto-char (max from to))
1054 0 : (when to-eop
1055 0 : (skip-chars-backward "\n")
1056 0 : (fill-forward-paragraph 1))
1057 0 : (setq max (copy-marker (point) t))
1058 0 : (goto-char (setq beg (min from to)))
1059 0 : (beginning-of-line)
1060 0 : (while (< (point) max)
1061 0 : (let ((initial (point))
1062 : end)
1063 : ;; If using hard newlines, break at every one for filling
1064 : ;; purposes rather than using paragraph breaks.
1065 0 : (if use-hard-newlines
1066 0 : (progn
1067 0 : (while (and (setq end (text-property-any (point) max
1068 0 : 'hard t))
1069 0 : (not (= ?\n (char-after end)))
1070 0 : (not (>= end max)))
1071 0 : (goto-char (1+ end)))
1072 0 : (setq end (if end (min max (1+ end)) max))
1073 0 : (goto-char initial))
1074 0 : (fill-forward-paragraph 1)
1075 0 : (setq end (min max (point)))
1076 0 : (fill-forward-paragraph -1))
1077 0 : (if (< (point) beg)
1078 0 : (goto-char beg))
1079 0 : (if (and (>= (point) initial) (< (point) end))
1080 0 : (setq fill-pfx
1081 0 : (fill-region-as-paragraph (point) end justify nosqueeze))
1082 0 : (goto-char end))))
1083 0 : (goto-char start-point)
1084 0 : (set-marker start-point nil)
1085 0 : fill-pfx))
1086 :
1087 :
1088 : (defcustom default-justification 'left
1089 : "Method of justifying text not otherwise specified.
1090 : Possible values are `left', `right', `full', `center', or `none'.
1091 : The requested kind of justification is done whenever lines are filled.
1092 : The `justification' text-property can locally override this variable."
1093 : :type '(choice (const left)
1094 : (const right)
1095 : (const full)
1096 : (const center)
1097 : (const none))
1098 : :safe 'symbolp
1099 : :group 'fill)
1100 : (make-variable-buffer-local 'default-justification)
1101 :
1102 : (defun current-justification ()
1103 : "How should we justify this line?
1104 : This returns the value of the text-property `justification',
1105 : or the variable `default-justification' if there is no text-property.
1106 : However, it returns nil rather than `none' to mean \"don't justify\"."
1107 0 : (let ((j (or (get-text-property
1108 : ;; Make sure we're looking at paragraph body.
1109 0 : (save-excursion (skip-chars-forward " \t")
1110 0 : (if (and (eobp) (not (bobp)))
1111 0 : (1- (point)) (point)))
1112 0 : 'justification)
1113 0 : default-justification)))
1114 0 : (if (eq 'none j)
1115 : nil
1116 0 : j)))
1117 :
1118 : (defun set-justification (begin end style &optional whole-par)
1119 : "Set the region's justification style to STYLE.
1120 : This commands prompts for the kind of justification to use.
1121 : If the mark is not active, this command operates on the current paragraph.
1122 : If the mark is active, it operates on the region. However, if the
1123 : beginning and end of the region are not at paragraph breaks, they are
1124 : moved to the beginning and end \(respectively) of the paragraphs they
1125 : are in.
1126 :
1127 : If variable `use-hard-newlines' is true, all hard newlines are
1128 : taken to be paragraph breaks.
1129 :
1130 : When calling from a program, operates just on region between BEGIN and END,
1131 : unless optional fourth arg WHOLE-PAR is non-nil. In that case bounds are
1132 : extended to include entire paragraphs as in the interactive command."
1133 0 : (interactive (list (if mark-active (region-beginning) (point))
1134 0 : (if mark-active (region-end) (point))
1135 0 : (let ((s (completing-read
1136 : "Set justification to: "
1137 : '(("left") ("right") ("full")
1138 : ("center") ("none"))
1139 0 : nil t)))
1140 0 : (if (equal s "") (error ""))
1141 0 : (intern s))
1142 0 : t))
1143 0 : (save-excursion
1144 0 : (save-restriction
1145 0 : (if whole-par
1146 0 : (let ((paragraph-start (if use-hard-newlines "." paragraph-start))
1147 0 : (paragraph-ignore-fill-prefix (if use-hard-newlines t
1148 0 : paragraph-ignore-fill-prefix)))
1149 0 : (goto-char begin)
1150 0 : (while (and (bolp) (not (eobp))) (forward-char 1))
1151 0 : (backward-paragraph)
1152 0 : (setq begin (point))
1153 0 : (goto-char end)
1154 0 : (skip-chars-backward " \t\n" begin)
1155 0 : (forward-paragraph)
1156 0 : (setq end (point))))
1157 :
1158 0 : (narrow-to-region (point-min) end)
1159 0 : (unjustify-region begin (point-max))
1160 0 : (put-text-property begin (point-max) 'justification style)
1161 0 : (fill-region begin (point-max) nil t))))
1162 :
1163 : (defun set-justification-none (b e)
1164 : "Disable automatic filling for paragraphs in the region.
1165 : If the mark is not active, this applies to the current paragraph."
1166 0 : (interactive (list (if mark-active (region-beginning) (point))
1167 0 : (if mark-active (region-end) (point))))
1168 0 : (set-justification b e 'none t))
1169 :
1170 : (defun set-justification-left (b e)
1171 : "Make paragraphs in the region left-justified.
1172 : This means they are flush at the left margin and ragged on the right.
1173 : This is usually the default, but see the variable `default-justification'.
1174 : If the mark is not active, this applies to the current paragraph."
1175 0 : (interactive (list (if mark-active (region-beginning) (point))
1176 0 : (if mark-active (region-end) (point))))
1177 0 : (set-justification b e 'left t))
1178 :
1179 : (defun set-justification-right (b e)
1180 : "Make paragraphs in the region right-justified.
1181 : This means they are flush at the right margin and ragged on the left.
1182 : If the mark is not active, this applies to the current paragraph."
1183 0 : (interactive (list (if mark-active (region-beginning) (point))
1184 0 : (if mark-active (region-end) (point))))
1185 0 : (set-justification b e 'right t))
1186 :
1187 : (defun set-justification-full (b e)
1188 : "Make paragraphs in the region fully justified.
1189 : This makes lines flush on both margins by inserting spaces between words.
1190 : If the mark is not active, this applies to the current paragraph."
1191 0 : (interactive (list (if mark-active (region-beginning) (point))
1192 0 : (if mark-active (region-end) (point))))
1193 0 : (set-justification b e 'full t))
1194 :
1195 : (defun set-justification-center (b e)
1196 : "Make paragraphs in the region centered.
1197 : If the mark is not active, this applies to the current paragraph."
1198 0 : (interactive (list (if mark-active (region-beginning) (point))
1199 0 : (if mark-active (region-end) (point))))
1200 0 : (set-justification b e 'center t))
1201 :
1202 : ;; A line has up to six parts:
1203 : ;;
1204 : ;; >>> hello.
1205 : ;; [Indent-1][FP][ Indent-2 ][text][trailing whitespace][newline]
1206 : ;;
1207 : ;; "Indent-1" is the left-margin indentation; normally it ends at column
1208 : ;; given by the `current-left-margin' function.
1209 : ;; "FP" is the fill-prefix. It can be any string, including whitespace.
1210 : ;; "Indent-2" is added to justify a line if the `current-justification' is
1211 : ;; `center' or `right'. In `left' and `full' justification regions, any
1212 : ;; whitespace there is part of the line's text, and should not be changed.
1213 : ;; Trailing whitespace is not counted as part of the line length when
1214 : ;; center- or right-justifying.
1215 : ;;
1216 : ;; All parts of the line are optional, although the final newline can
1217 : ;; only be missing on the last line of the buffer.
1218 :
1219 : (defun justify-current-line (&optional how eop nosqueeze)
1220 : "Do some kind of justification on this line.
1221 : Normally does full justification: adds spaces to the line to make it end at
1222 : the column given by `current-fill-column'.
1223 : Optional first argument HOW specifies alternate type of justification:
1224 : it can be `left', `right', `full', `center', or `none'.
1225 : If HOW is t, will justify however the `current-justification' function says to.
1226 : If HOW is nil or missing, full justification is done by default.
1227 : Second arg EOP non-nil means that this is the last line of the paragraph, so
1228 : it will not be stretched by full justification.
1229 : Third arg NOSQUEEZE non-nil means to leave interior whitespace unchanged,
1230 : otherwise it is made canonical."
1231 : (interactive "*")
1232 0 : (if (eq t how) (setq how (or (current-justification) 'none))
1233 0 : (if (null how) (setq how 'full)
1234 0 : (or (memq how '(none left right center))
1235 0 : (setq how 'full))))
1236 0 : (or (memq how '(none left)) ; No action required for these.
1237 0 : (let ((fc (current-fill-column))
1238 0 : (pos (point-marker))
1239 : fp-end ; point at end of fill prefix
1240 : beg ; point at beginning of line's text
1241 : end ; point at end of line's text
1242 : indent ; column of `beg'
1243 : endcol ; column of `end'
1244 : ncols ; new indent point or offset
1245 : (nspaces 0) ; number of spaces between words
1246 : ; in line (not space characters)
1247 : (curr-fracspace 0) ; current fractional space amount
1248 : count)
1249 0 : (end-of-line)
1250 : ;; Check if this is the last line of the paragraph.
1251 0 : (if (and use-hard-newlines (null eop)
1252 0 : (get-text-property (point) 'hard))
1253 0 : (setq eop t))
1254 0 : (skip-chars-backward " \t")
1255 : ;; Quick exit if it appears to be properly justified already
1256 : ;; or there is no text.
1257 0 : (if (or (bolp)
1258 0 : (and (memq how '(full right))
1259 0 : (= (current-column) fc)))
1260 : nil
1261 0 : (setq end (point))
1262 0 : (beginning-of-line)
1263 0 : (skip-chars-forward " \t")
1264 : ;; Skip over fill-prefix.
1265 0 : (if (and fill-prefix
1266 0 : (not (string-equal fill-prefix ""))
1267 0 : (equal fill-prefix
1268 0 : (buffer-substring
1269 0 : (point) (min (point-max) (+ (length fill-prefix)
1270 0 : (point))))))
1271 0 : (forward-char (length fill-prefix))
1272 0 : (if (and adaptive-fill-mode
1273 0 : (looking-at adaptive-fill-regexp))
1274 0 : (goto-char (match-end 0))))
1275 0 : (setq fp-end (point))
1276 0 : (skip-chars-forward " \t")
1277 : ;; This is beginning of the line's text.
1278 0 : (setq indent (current-column))
1279 0 : (setq beg (point))
1280 0 : (goto-char end)
1281 0 : (setq endcol (current-column))
1282 :
1283 : ;; HOW can't be null or left--we would have exited already
1284 0 : (cond ((eq 'right how)
1285 0 : (setq ncols (- fc endcol))
1286 0 : (if (< ncols 0)
1287 : ;; Need to remove some indentation
1288 0 : (delete-region
1289 0 : (progn (goto-char fp-end)
1290 0 : (if (< (current-column) (+ indent ncols))
1291 0 : (move-to-column (+ indent ncols) t))
1292 0 : (point))
1293 0 : (progn (move-to-column indent) (point)))
1294 : ;; Need to add some
1295 0 : (goto-char beg)
1296 0 : (indent-to (+ indent ncols))
1297 : ;; If point was at beginning of text, keep it there.
1298 0 : (if (= beg pos)
1299 0 : (move-marker pos (point)))))
1300 :
1301 0 : ((eq 'center how)
1302 : ;; Figure out how much indentation is needed
1303 0 : (setq ncols (+ (current-left-margin)
1304 0 : (/ (- fc (current-left-margin) ;avail. space
1305 0 : (- endcol indent)) ;text width
1306 0 : 2)))
1307 0 : (if (< ncols indent)
1308 : ;; Have too much indentation - remove some
1309 0 : (delete-region
1310 0 : (progn (goto-char fp-end)
1311 0 : (if (< (current-column) ncols)
1312 0 : (move-to-column ncols t))
1313 0 : (point))
1314 0 : (progn (move-to-column indent) (point)))
1315 : ;; Have too little - add some
1316 0 : (goto-char beg)
1317 0 : (indent-to ncols)
1318 : ;; If point was at beginning of text, keep it there.
1319 0 : (if (= beg pos)
1320 0 : (move-marker pos (point)))))
1321 :
1322 0 : ((eq 'full how)
1323 : ;; Insert extra spaces between words to justify line
1324 0 : (save-restriction
1325 0 : (narrow-to-region beg end)
1326 0 : (or nosqueeze
1327 0 : (canonically-space-region beg end))
1328 0 : (goto-char (point-max))
1329 : ;; count word spaces in line
1330 0 : (while (search-backward " " nil t)
1331 0 : (setq nspaces (1+ nspaces))
1332 0 : (skip-chars-backward " "))
1333 0 : (setq ncols (- fc endcol))
1334 : ;; Ncols is number of additional space chars needed
1335 0 : (when (and (> ncols 0) (> nspaces 0) (not eop))
1336 0 : (setq curr-fracspace (+ ncols (/ nspaces 2))
1337 0 : count nspaces)
1338 0 : (while (> count 0)
1339 0 : (skip-chars-forward " ")
1340 0 : (insert-char ?\s (/ curr-fracspace nspaces) t)
1341 0 : (search-forward " " nil t)
1342 0 : (setq count (1- count)
1343 : curr-fracspace
1344 0 : (+ (% curr-fracspace nspaces) ncols))))))
1345 0 : (t (error "Unknown justification value"))))
1346 0 : (goto-char pos)
1347 0 : (move-marker pos nil)))
1348 : nil)
1349 :
1350 : (defun unjustify-current-line ()
1351 : "Remove justification whitespace from current line.
1352 : If the line is centered or right-justified, this function removes any
1353 : indentation past the left margin. If the line is full-justified, it removes
1354 : extra spaces between words. It does nothing in other justification modes."
1355 0 : (let ((justify (current-justification)))
1356 0 : (cond ((eq 'left justify) nil)
1357 0 : ((eq nil justify) nil)
1358 0 : ((eq 'full justify) ; full justify: remove extra spaces
1359 0 : (beginning-of-line-text)
1360 0 : (canonically-space-region (point) (line-end-position)))
1361 0 : ((memq justify '(center right))
1362 0 : (save-excursion
1363 0 : (move-to-left-margin nil t)
1364 : ;; Position ourselves after any fill-prefix.
1365 0 : (if (and fill-prefix
1366 0 : (not (string-equal fill-prefix ""))
1367 0 : (equal fill-prefix
1368 0 : (buffer-substring
1369 0 : (point) (min (point-max) (+ (length fill-prefix)
1370 0 : (point))))))
1371 0 : (forward-char (length fill-prefix)))
1372 0 : (delete-region (point) (progn (skip-chars-forward " \t")
1373 0 : (point))))))))
1374 :
1375 : (defun unjustify-region (&optional begin end)
1376 : "Remove justification whitespace from region.
1377 : For centered or right-justified regions, this function removes any indentation
1378 : past the left margin from each line. For full-justified lines, it removes
1379 : extra spaces between words. It does nothing in other justification modes.
1380 : Arguments BEGIN and END are optional; default is the whole buffer."
1381 0 : (save-excursion
1382 0 : (save-restriction
1383 0 : (if end (narrow-to-region (point-min) end))
1384 0 : (goto-char (or begin (point-min)))
1385 0 : (while (not (eobp))
1386 0 : (unjustify-current-line)
1387 0 : (forward-line 1)))))
1388 :
1389 :
1390 : (defun fill-nonuniform-paragraphs (min max &optional justifyp citation-regexp)
1391 : "Fill paragraphs within the region, allowing varying indentation within each.
1392 : This command divides the region into \"paragraphs\",
1393 : only at paragraph-separator lines, then fills each paragraph
1394 : using as the fill prefix the smallest indentation of any line
1395 : in the paragraph.
1396 :
1397 : When calling from a program, pass range to fill as first two arguments.
1398 :
1399 : Optional third and fourth arguments JUSTIFYP and CITATION-REGEXP:
1400 : JUSTIFYP to justify paragraphs (prefix arg).
1401 : When filling a mail message, pass a regexp for CITATION-REGEXP
1402 : which will match the prefix of a line which is a citation marker
1403 : plus whitespace, but no other kind of prefix.
1404 : Also, if CITATION-REGEXP is non-nil, don't fill header lines."
1405 0 : (interactive (progn
1406 0 : (barf-if-buffer-read-only)
1407 0 : (list (region-beginning) (region-end)
1408 0 : (if current-prefix-arg 'full))))
1409 0 : (let ((fill-individual-varying-indent t))
1410 0 : (fill-individual-paragraphs min max justifyp citation-regexp)))
1411 :
1412 : (defun fill-individual-paragraphs (min max &optional justify citation-regexp)
1413 : "Fill paragraphs of uniform indentation within the region.
1414 : This command divides the region into \"paragraphs\",
1415 : treating every change in indentation level or prefix as a paragraph boundary,
1416 : then fills each paragraph using its indentation level as the fill prefix.
1417 :
1418 : There is one special case where a change in indentation does not start
1419 : a new paragraph. This is for text of this form:
1420 :
1421 : foo> This line with extra indentation starts
1422 : foo> a paragraph that continues on more lines.
1423 :
1424 : These lines are filled together.
1425 :
1426 : When calling from a program, pass the range to fill
1427 : as the first two arguments.
1428 :
1429 : Optional third and fourth arguments JUSTIFY and CITATION-REGEXP:
1430 : JUSTIFY to justify paragraphs (prefix arg).
1431 : When filling a mail message, pass a regexp for CITATION-REGEXP
1432 : which will match the prefix of a line which is a citation marker
1433 : plus whitespace, but no other kind of prefix.
1434 : Also, if CITATION-REGEXP is non-nil, don't fill header lines."
1435 0 : (interactive (progn
1436 0 : (barf-if-buffer-read-only)
1437 0 : (list (region-beginning) (region-end)
1438 0 : (if current-prefix-arg 'full))))
1439 0 : (save-restriction
1440 0 : (save-excursion
1441 0 : (goto-char min)
1442 0 : (beginning-of-line)
1443 0 : (narrow-to-region (point) max)
1444 0 : (if citation-regexp
1445 0 : (while (and (not (eobp))
1446 0 : (or (looking-at "[ \t]*[^ \t\n]+:")
1447 0 : (looking-at "[ \t]*$")))
1448 0 : (if (looking-at "[ \t]*[^ \t\n]+:")
1449 0 : (search-forward "\n\n" nil 'move)
1450 0 : (forward-line 1))))
1451 0 : (narrow-to-region (point) max)
1452 : ;; Loop over paragraphs.
1453 0 : (while (progn
1454 : ;; Skip over all paragraph-separating lines
1455 : ;; so as to not include them in any paragraph.
1456 0 : (while (and (not (eobp))
1457 0 : (progn (move-to-left-margin)
1458 0 : (and (not (eobp))
1459 0 : (looking-at paragraph-separate))))
1460 0 : (forward-line 1))
1461 0 : (skip-chars-forward " \t\n") (not (eobp)))
1462 0 : (move-to-left-margin)
1463 0 : (let ((start (point))
1464 : fill-prefix fill-prefix-regexp)
1465 : ;; Find end of paragraph, and compute the smallest fill-prefix
1466 : ;; that fits all the lines in this paragraph.
1467 0 : (while (progn
1468 : ;; Update the fill-prefix on the first line
1469 : ;; and whenever the prefix good so far is too long.
1470 0 : (if (not (and fill-prefix
1471 0 : (looking-at fill-prefix-regexp)))
1472 0 : (setq fill-prefix
1473 0 : (fill-individual-paragraphs-prefix
1474 0 : citation-regexp)
1475 0 : fill-prefix-regexp (regexp-quote fill-prefix)))
1476 0 : (forward-line 1)
1477 0 : (if (bolp)
1478 : ;; If forward-line went past a newline,
1479 : ;; move further to the left margin.
1480 0 : (move-to-left-margin))
1481 : ;; Now stop the loop if end of paragraph.
1482 0 : (and (not (eobp))
1483 0 : (if fill-individual-varying-indent
1484 : ;; If this line is a separator line, with or
1485 : ;; without prefix, end the paragraph.
1486 0 : (and
1487 0 : (not (looking-at paragraph-separate))
1488 0 : (save-excursion
1489 0 : (not (and (looking-at fill-prefix-regexp)
1490 0 : (progn (forward-char
1491 0 : (length fill-prefix))
1492 0 : (looking-at
1493 0 : paragraph-separate))))))
1494 : ;; If this line has more or less indent
1495 : ;; than the fill prefix wants, end the paragraph.
1496 0 : (and (looking-at fill-prefix-regexp)
1497 : ;; If fill prefix is shorter than a new
1498 : ;; fill prefix computed here, end paragraph.
1499 0 : (let ((this-line-fill-prefix
1500 0 : (fill-individual-paragraphs-prefix
1501 0 : citation-regexp)))
1502 0 : (>= (length fill-prefix)
1503 0 : (length this-line-fill-prefix)))
1504 0 : (save-excursion
1505 0 : (not (progn (forward-char
1506 0 : (length fill-prefix))
1507 0 : (or (looking-at "[ \t]")
1508 0 : (looking-at paragraph-separate)
1509 0 : (looking-at paragraph-start)))))
1510 0 : (not (and (equal fill-prefix "")
1511 0 : citation-regexp
1512 0 : (looking-at citation-regexp))))))))
1513 : ;; Fill this paragraph, but don't add a newline at the end.
1514 0 : (let ((had-newline (bolp)))
1515 0 : (fill-region-as-paragraph start (point) justify)
1516 0 : (if (and (bolp) (not had-newline))
1517 0 : (delete-char -1))))))))
1518 :
1519 : (defun fill-individual-paragraphs-prefix (citation-regexp)
1520 0 : (let* ((adaptive-fill-first-line-regexp ".*")
1521 : (just-one-line-prefix
1522 : ;; Accept any prefix rather than just the ones matched by
1523 : ;; adaptive-fill-first-line-regexp.
1524 0 : (fill-context-prefix (point) (line-beginning-position 2)))
1525 : (two-lines-prefix
1526 0 : (fill-context-prefix (point) (line-beginning-position 3))))
1527 0 : (if (not just-one-line-prefix)
1528 0 : (buffer-substring
1529 0 : (point) (save-excursion (skip-chars-forward " \t") (point)))
1530 : ;; See if the citation part of JUST-ONE-LINE-PREFIX
1531 : ;; is the same as that of TWO-LINES-PREFIX,
1532 : ;; except perhaps with longer whitespace.
1533 0 : (if (and just-one-line-prefix two-lines-prefix
1534 0 : (let* ((one-line-citation-part
1535 0 : (fill-individual-paragraphs-citation
1536 0 : just-one-line-prefix citation-regexp))
1537 : (two-lines-citation-part
1538 0 : (fill-individual-paragraphs-citation
1539 0 : two-lines-prefix citation-regexp))
1540 : (adjusted-two-lines-citation-part
1541 0 : (substring two-lines-citation-part 0
1542 0 : (string-match "[ \t]*\\'"
1543 0 : two-lines-citation-part))))
1544 0 : (and
1545 0 : (string-match (concat "\\`"
1546 0 : (regexp-quote
1547 0 : adjusted-two-lines-citation-part)
1548 0 : "[ \t]*\\'")
1549 0 : one-line-citation-part)
1550 0 : (>= (string-width one-line-citation-part)
1551 0 : (string-width two-lines-citation-part)))))
1552 0 : two-lines-prefix
1553 0 : just-one-line-prefix))))
1554 :
1555 : (defun fill-individual-paragraphs-citation (string citation-regexp)
1556 0 : (if citation-regexp
1557 0 : (if (string-match citation-regexp string)
1558 0 : (match-string 0 string)
1559 0 : "")
1560 0 : string))
1561 :
1562 : ;;; fill.el ends here
|