Mercurial > emacs

comparison lisp/gnus/flow-fill.el @ 82951:0fde48feb604

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author Andreas Schwab <schwab@suse.de>
date Thu, 22 Jul 2004 16:45:51 +0000
parents 695cf19ef79e
children 6d1f39d4f8e6
comparison
equal deleted inserted replaced
56503:8bbd2323fbf2 82951:0fde48feb604
1 ;;; flow-fill.el --- interprete RFC2646 "flowed" text 1 ;;; flow-fill.el --- interprete RFC2646 "flowed" text
2 2
3 ;; Copyright (C) 2000, 2002 Free Software Foundation, Inc. 3 ;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
4 4
5 ;; Author: Simon Josefsson <jas@pdc.kth.se> 5 ;; Author: Simon Josefsson <jas@pdc.kth.se>
6 ;; Keywords: mail 6 ;; Keywords: mail
7 7
8 ;; This file is part of GNU Emacs. 8 ;; This file is part of GNU Emacs.
33 33
34 ;; When no further concatenations are possible, we've found a 34 ;; When no further concatenations are possible, we've found a
35 ;; paragraph and we let `fill-region' fill the long line into several 35 ;; paragraph and we let `fill-region' fill the long line into several
36 ;; lines with the quote prefix as `fill-prefix'. 36 ;; lines with the quote prefix as `fill-prefix'.
37 37
38 ;; Todo: encoding, implement basic `fill-region' (Emacs and XEmacs 38 ;; Todo: implement basic `fill-region' (Emacs and XEmacs
39 ;; implementations differ..) 39 ;; implementations differ..)
40 40
41 ;; History: 41 ;;; History:
42 42
43 ;; 2000-02-17 posted on ding mailing list 43 ;; 2000-02-17 posted on ding mailing list
44 ;; 2000-02-19 use `point-at-{b,e}ol' in XEmacs 44 ;; 2000-02-19 use `point-at-{b,e}ol' in XEmacs
45 ;; 2000-03-11 no compile warnings for point-at-bol stuff 45 ;; 2000-03-11 no compile warnings for point-at-bol stuff
46 ;; 2000-03-26 committed to gnus cvs 46 ;; 2000-03-26 committed to gnus cvs
47 ;; 2000-10-23 don't flow "-- " lines, make "quote-depth wins" rule 47 ;; 2000-10-23 don't flow "-- " lines, make "quote-depth wins" rule
48 ;; work when first line is at level 0. 48 ;; work when first line is at level 0.
49 ;; 2002-01-12 probably incomplete encoding support
50 ;; 2003-12-08 started working on test harness.
49 51
50 ;;; Code: 52 ;;; Code:
51 53
52 (eval-when-compile (require 'cl)) 54 (eval-when-compile (require 'cl))
55
56 (defcustom fill-flowed-display-column 'fill-column
57 "Column beyond which format=flowed lines are wrapped, when displayed.
58 This can be a Lisp expression or an integer."
59 :type '(choice (const :tag "Standard `fill-column'" fill-column)
60 (const :tag "Fit Window" (- (window-width) 5))
61 (sexp)
62 (integer)))
63
64 (defcustom fill-flowed-encode-column 66
65 "Column beyond which format=flowed lines are wrapped, in outgoing messages.
66 This can be a Lisp expression or an integer.
67 RFC 2646 suggests 66 characters for readability."
68 :type '(choice (const :tag "Standard fill-column" fill-column)
69 (const :tag "RFC 2646 default (66)" 66)
70 (sexp)
71 (integer)))
53 72
54 (eval-and-compile 73 (eval-and-compile
55 (defalias 'fill-flowed-point-at-bol 74 (defalias 'fill-flowed-point-at-bol
56 (if (fboundp 'point-at-bol) 75 (if (fboundp 'point-at-bol)
57 'point-at-bol 76 'point-at-bol
60 (defalias 'fill-flowed-point-at-eol 79 (defalias 'fill-flowed-point-at-eol
61 (if (fboundp 'point-at-eol) 80 (if (fboundp 'point-at-eol)
62 'point-at-eol 81 'point-at-eol
63 'line-end-position))) 82 'line-end-position)))
64 83
84 ;;;###autoload
85 (defun fill-flowed-encode (&optional buffer)
86 (with-current-buffer (or buffer (current-buffer))
87 ;; No point in doing this unless hard newlines is used.
88 (when use-hard-newlines
89 (let ((start (point-min)) end)
90 ;; Go through each paragraph, filling it and adding SPC
91 ;; as the last character on each line.
92 (while (setq end (text-property-any start (point-max) 'hard 't))
93 (let ((fill-column (eval fill-flowed-encode-column)))
94 (fill-region start end t 'nosqueeze 'to-eop))
95 (goto-char start)
96 ;; `fill-region' probably distorted end.
97 (setq end (text-property-any start (point-max) 'hard 't))
98 (while (and (< (point) end)
99 (re-search-forward "$" (1- end) t))
100 (insert " ")
101 (setq end (1+ end))
102 (forward-char))
103 (goto-char (setq start (1+ end)))))
104 t)))
105
106 ;;;###autoload
65 (defun fill-flowed (&optional buffer) 107 (defun fill-flowed (&optional buffer)
66 (save-excursion 108 (save-excursion
67 (set-buffer (or (current-buffer) buffer)) 109 (set-buffer (or (current-buffer) buffer))
68 (goto-char (point-min)) 110 (goto-char (point-min))
69 (while (re-search-forward " $" nil t) 111 (while (re-search-forward " $" nil t)
70 (when (save-excursion 112 (when (save-excursion
71 (beginning-of-line) 113 (beginning-of-line)
72 (looking-at "^\\(>*\\)\\( ?\\)")) 114 (looking-at "^\\(>*\\)\\( ?\\)"))
73 (let ((quote (match-string 1)) sig) 115 (let ((quote (match-string 1))
116 sig)
74 (if (string= quote "") 117 (if (string= quote "")
75 (setq quote nil)) 118 (setq quote nil))
76 (when (and quote (string= (match-string 2) "")) 119 (when (and quote (string= (match-string 2) ""))
77 (save-excursion 120 (save-excursion
78 ;; insert SP after quote for pleasant reading of quoted lines 121 ;; insert SP after quote for pleasant reading of quoted lines
79 (beginning-of-line) 122 (beginning-of-line)
80 (when (> (skip-chars-forward ">") 0) 123 (when (> (skip-chars-forward ">") 0)
81 (insert " ")))) 124 (insert " "))))
125 ;; XXX slightly buggy handling of "-- "
82 (while (and (save-excursion 126 (while (and (save-excursion
83 (ignore-errors (backward-char 3)) 127 (ignore-errors (backward-char 3))
84 (setq sig (looking-at "-- ")) 128 (setq sig (looking-at "-- "))
85 (looking-at "[^-][^-] ")) 129 (looking-at "[^-][^-] "))
86 (save-excursion 130 (save-excursion
87 (unless (eobp) 131 (unless (eobp)
88 (forward-char 1) 132 (forward-char 1)
89 (looking-at (format "^\\(%s\\)\\([^>]\\)" (or quote " ?")))))) 133 (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)"
134 (or quote " ?"))))))
90 (save-excursion 135 (save-excursion
91 (replace-match (if (string= (match-string 2) " ") 136 (replace-match (if (string= (match-string 2) " ")
92 "" "\\2"))) 137 "" "\\2")))
93 (backward-delete-char -1) 138 (backward-delete-char -1)
94 (end-of-line)) 139 (end-of-line))
95 (unless sig 140 (unless sig
96 (let ((fill-prefix (when quote (concat quote " ")))) 141 (condition-case nil
97 (fill-region (fill-flowed-point-at-bol) 142 (let ((fill-prefix (when quote (concat quote " ")))
98 (fill-flowed-point-at-eol) 143 (fill-column (eval fill-flowed-display-column))
99 'left 'nosqueeze)))))))) 144 filladapt-mode)
145 (fill-region (fill-flowed-point-at-bol)
146 (min (1+ (fill-flowed-point-at-eol))
147 (point-max))
148 'left 'nosqueeze))
149 (error
150 (forward-line 1)
151 nil))))))))
152
153 ;; Test vectors.
154
155 (eval-when-compile
156 (defvar show-trailing-whitespace))
157
158 (defvar fill-flowed-encode-tests
159 '(
160 ;; The syntax of each list element is:
161 ;; (INPUT . EXPECTED-OUTPUT)
162 ("> Thou villainous ill-breeding spongy dizzy-eyed
163 > reeky elf-skinned pigeon-egg!
164 >> Thou artless swag-bellied milk-livered
165 >> dismal-dreaming idle-headed scut!
166 >>> Thou errant folly-fallen spleeny reeling-ripe
167 >>> unmuzzled ratsbane!
168 >>>> Henceforth, the coding style is to be strictly
169 >>>> enforced, including the use of only upper case.
170 >>>>> I've noticed a lack of adherence to the coding
171 >>>>> styles, of late.
172 >>>>>> Any complaints?
173 " . "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned
174 > pigeon-egg!
175 >> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed
176 >> scut!
177 >>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!
178 >>>> Henceforth, the coding style is to be strictly enforced,
179 >>>> including the use of only upper case.
180 >>>>> I've noticed a lack of adherence to the coding styles, of late.
181 >>>>>> Any complaints?
182 ")
183 ; ("
184 ;> foo
185 ;>
186 ;>
187 ;> bar
188 ;" . "
189 ;> foo bar
190 ;")
191 ))
192
193 (defun fill-flowed-test ()
194 (interactive "")
195 (switch-to-buffer (get-buffer-create "*Format=Flowed test output*"))
196 (erase-buffer)
197 (setq show-trailing-whitespace t)
198 (dolist (test fill-flowed-encode-tests)
199 (let (start output)
200 (insert "***** BEGIN TEST INPUT *****\n")
201 (insert (car test))
202 (insert "***** END TEST INPUT *****\n\n")
203 (insert "***** BEGIN TEST OUTPUT *****\n")
204 (setq start (point))
205 (insert (car test))
206 (save-restriction
207 (narrow-to-region start (point))
208 (fill-flowed))
209 (setq output (buffer-substring start (point-max)))
210 (insert "***** END TEST OUTPUT *****\n")
211 (unless (string= output (cdr test))
212 (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n")
213 (insert (cdr test))
214 (insert "***** END TEST EXPECTED OUTPUT *****\n"))
215 (insert "\n\n")))
216 (goto-char (point-max)))
100 217
101 (provide 'flow-fill) 218 (provide 'flow-fill)
102 219
103 ;;; arch-tag: addc0040-bc53-4f17-b4bc-1eb44eed6f0b 220 ;;; arch-tag: addc0040-bc53-4f17-b4bc-1eb44eed6f0b
104 ;;; flow-fill.el ends here 221 ;;; flow-fill.el ends here