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