![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fill.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to fill.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp |
1.1 root 1: ;; Fill commands for Emacs
2: ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is distributed in the hope that it will be useful,
7: ;; but WITHOUT ANY WARRANTY. No author or distributor
8: ;; accepts responsibility to anyone for the consequences of using it
9: ;; or for whether it serves any particular purpose or works at all,
10: ;; unless he says so in writing. Refer to the GNU Emacs General Public
11: ;; License for full details.
12:
13: ;; Everyone is granted permission to copy, modify and redistribute
14: ;; GNU Emacs, but only under the conditions described in the
15: ;; GNU Emacs General Public License. A copy of this license is
16: ;; supposed to have been given to you along with GNU Emacs so you
17: ;; can know your rights and responsibilities. It should be in a
18: ;; file named COPYING. Among other things, the copyright notice
19: ;; and this notice must be preserved on all copies.
20:
21:
22: (defun set-fill-prefix ()
23: "Set the fill-prefix to the current line up to point.
24: Filling expects lines to start with the fill prefix
25: and reinserts the fill prefix in each resulting line."
26: (interactive)
27: (setq fill-prefix (buffer-substring
28: (save-excursion (beginning-of-line) (point))
29: (point)))
30: (if (equal fill-prefix "")
31: (setq fill-prefix nil))
32: (if fill-prefix
33: (message "fill-prefix: \"%s\"" fill-prefix)
34: (message "fill-prefix cancelled")))
35:
36: (defun fill-region-as-paragraph (from to &optional justify-flag)
37: "Fill region as one paragraph: break lines to fit fill-column.
38: Prefix arg means justify too.
39: From program, pass args FROM, TO and JUSTIFY-FLAG."
40: (interactive "r\nP")
41: (save-restriction
42: (narrow-to-region from to)
43: (goto-char (point-min))
44: (skip-chars-forward "\n")
45: (narrow-to-region (point) (point-max))
46: (setq from (point))
47: (let ((fpre (and fill-prefix (not (equal fill-prefix ""))
48: (regexp-quote fill-prefix))))
49: ;; Delete the fill prefix from every line except the first.
50: ;; The first line may not even have a fill prefix.
51: (and fpre
52: (progn
53: (if (>= (length fill-prefix) fill-column)
54: (error "fill-prefix too long for specified width"))
55: (goto-char (point-min))
56: (forward-line 1)
57: (while (not (eobp))
58: (if (looking-at fpre)
59: (delete-region (point) (match-end 0)))
60: (forward-line 1))
61: (goto-char (point-min))
62: (and (looking-at fpre) (forward-char (length fill-prefix)))
63: (setq from (point)))))
64: ;; from is now before the text to fill,
65: ;; but after any fill prefix on the first line.
66:
67: ;; Make sure sentences ending at end of line get an extra space.
68: (goto-char from)
69: (while (re-search-forward "[.?!][])""']*$" nil t)
70: (insert ? ))
71: ;; The change all newlines to spaces.
72: (subst-char-in-region from (point-max) ?\n ?\ )
73: ;; Flush excess spaces, except in the paragraph indentation.
74: (goto-char from)
75: (skip-chars-forward " \t")
76: (while (re-search-forward " *" nil t)
77: (delete-region
78: (+ (match-beginning 0)
79: (if (save-excursion
80: (skip-chars-backward " ])\"'")
81: (memq (preceding-char) '(?. ?? ?!)))
82: 2 1))
83: (match-end 0)))
84: (goto-char (point-max))
85: (delete-horizontal-space)
86: (insert " ")
87: (goto-char (point-min))
88: (let ((prefixcol 0))
89: (while (not (eobp))
90: (move-to-column (1+ fill-column))
91: (if (eobp)
92: nil
93: (skip-chars-backward "^ \n")
94: (if (if (zerop prefixcol) (bolp) (>= prefixcol (current-column)))
95: (skip-chars-forward "^ \n")
96: (forward-char -1)))
97: (delete-horizontal-space)
98: (insert ?\n)
99: (and (not (eobp)) fill-prefix (not (equal fill-prefix ""))
100: (progn
101: (insert fill-prefix)
102: (setq prefixcol (current-column))))
103: (and justify-flag (not (eobp))
104: (progn
105: (forward-line -1)
106: (justify-current-line)
107: (forward-line 1)))))))
108:
109: (defun fill-paragraph (arg)
110: "Fill paragraph at or after point.
111: Prefix arg means justify as well."
112: (interactive "P")
113: (save-excursion
114: (forward-paragraph)
115: (or (bolp) (newline 1))
116: (let ((end (point)))
117: (backward-paragraph)
118: (fill-region-as-paragraph (point) end arg))))
119:
120: (defun fill-region (from to &optional justify-flag)
121: "Fill each of the paragraphs in the region.
122: Prefix arg (non-nil third arg, if called from program)
123: means justify as well."
124: (interactive "r\nP")
125: (save-restriction
126: (narrow-to-region from to)
127: (goto-char (point-min))
128: (while (not (eobp))
129: (let ((initial (point))
130: (end (progn
131: (forward-paragraph 1) (point))))
132: (forward-paragraph -1)
133: (if (>= (point) initial)
134: (fill-region-as-paragraph (point) end justify-flag)
135: (goto-char end))))))
136:
137: (defun justify-current-line ()
138: "Add spaces to line point is in, so it ends at fill-column."
139: (interactive)
140: (save-excursion
141: (save-restriction
142: (let (ncols beg)
143: (beginning-of-line)
144: (forward-char (length fill-prefix))
145: (skip-chars-forward " \t")
146: (setq beg (point))
147: (end-of-line)
148: (narrow-to-region beg (point))
149: (goto-char beg)
150: (while (re-search-forward " *" nil t)
151: (delete-region
152: (+ (match-beginning 0)
153: (if (save-excursion
154: (skip-chars-backward " ])\"'")
155: (memq (preceding-char) '(?. ?? ?!)))
156: 2 1))
157: (match-end 0)))
158: (goto-char beg)
159: (while (re-search-forward "[.?!][])""']*\n" nil t)
160: (forward-char -1)
161: (insert ? ))
162: (goto-char (point-max))
163: (setq ncols (- fill-column (current-column)))
164: (if (search-backward " " nil t)
165: (while (> ncols 0)
166: (let ((nmove (+ 3 (% (random) 3))))
167: (while (> nmove 0)
168: (or (search-backward " " nil t)
169: (progn
170: (goto-char (point-max))
171: (search-backward " ")))
172: (skip-chars-backward " ")
173: (setq nmove (1- nmove))))
174: (insert " ")
175: (skip-chars-backward " ")
176: (setq ncols (1- ncols))))))))
177:
178: (defun fill-individual-paragraphs (min max &optional justifyp mailp)
179: "Fill each paragraph in region according to its individual fill prefix.
180: Calling from a program, pass range to fill as first two arguments.
181: Optional third and fourth arguments JUSTIFY-FLAG and MAIL-FLAG:
182: JUSTIFY-FLAG to justify paragraphs (prefix arg),
183: MAIL-FLAG for a mail message, i. e. don't fill header lines."
184: (interactive "r\nP")
185: (let (fill-prefix)
186: (save-restriction
187: (save-excursion
188: (narrow-to-region min max)
189: (goto-char (point-min))
190: (while (progn
191: (skip-chars-forward " \t\n")
192: (not (eobp)))
193: (setq fill-prefix (buffer-substring (point) (progn (beginning-of-line) (point))))
194: (let ((fin (save-excursion (forward-paragraph) (point)))
195: (start (point)))
196: (if mailp
197: (while (re-search-forward "[ \t]*[^ \t\n]*:" fin t)
198: (forward-line 1)))
199: (cond ((= start (point))
200: (fill-region-as-paragraph (point) fin justifyp)
201: (goto-char fin)))))))))
202:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.