![[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.