1;;; flow-fill.el --- interpret RFC2646 "flowed" text
2
3;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Simon Josefsson <jas@pdc.kth.se>
7;; Keywords: mail
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING.  If not, write to the
23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
25
26;;; Commentary:
27
28;; This implement decoding of RFC2646 formatted text, including the
29;; quoted-depth wins rules.
30
31;; Theory of operation: search for lines ending with SPC, save quote
32;; length of line, remove SPC and concatenate line with the following
33;; line if quote length of following line matches current line.
34
35;; When no further concatenations are possible, we've found a
36;; paragraph and we let `fill-region' fill the long line into several
37;; lines with the quote prefix as `fill-prefix'.
38
39;; Todo: implement basic `fill-region' (Emacs and XEmacs
40;;       implementations differ..)
41
42;;; History:
43
44;; 2000-02-17  posted on ding mailing list
45;; 2000-02-19  use `point-at-{b,e}ol' in XEmacs
46;; 2000-03-11  no compile warnings for point-at-bol stuff
47;; 2000-03-26  committed to gnus cvs
48;; 2000-10-23  don't flow "-- " lines, make "quote-depth wins" rule
49;;             work when first line is at level 0.
50;; 2002-01-12  probably incomplete encoding support
51;; 2003-12-08  started working on test harness.
52
53;;; Code:
54
55(eval-when-compile (require 'cl))
56
57(defcustom fill-flowed-display-column 'fill-column
58  "Column beyond which format=flowed lines are wrapped, when displayed.
59This can be a Lisp expression or an integer."
60  :version "22.1"
61  :group 'mime-display
62  :type '(choice (const :tag "Standard `fill-column'" fill-column)
63		 (const :tag "Fit Window" (- (window-width) 5))
64		 (sexp)
65		 (integer)))
66
67(defcustom fill-flowed-encode-column 66
68  "Column beyond which format=flowed lines are wrapped, in outgoing messages.
69This can be a Lisp expression or an integer.
70RFC 2646 suggests 66 characters for readability."
71  :version "22.1"
72  :group 'mime-display
73  :type '(choice (const :tag "Standard fill-column" fill-column)
74		 (const :tag "RFC 2646 default (66)" 66)
75		 (sexp)
76		 (integer)))
77
78(eval-and-compile
79  (defalias 'fill-flowed-point-at-bol
80	(if (fboundp 'point-at-bol)
81	    'point-at-bol
82	  'line-beginning-position))
83
84   (defalias 'fill-flowed-point-at-eol
85	(if (fboundp 'point-at-eol)
86	    'point-at-eol
87	  'line-end-position)))
88
89;;;###autoload
90(defun fill-flowed-encode (&optional buffer)
91  (with-current-buffer (or buffer (current-buffer))
92    ;; No point in doing this unless hard newlines is used.
93    (when use-hard-newlines
94      (let ((start (point-min)) end)
95	;; Go through each paragraph, filling it and adding SPC
96	;; as the last character on each line.
97	(while (setq end (text-property-any start (point-max) 'hard 't))
98	  (let ((fill-column (eval fill-flowed-encode-column)))
99	    (fill-region start end t 'nosqueeze 'to-eop))
100	  (goto-char start)
101	  ;; `fill-region' probably distorted end.
102	  (setq end (text-property-any start (point-max) 'hard 't))
103	  (while (and (< (point) end)
104		      (re-search-forward "$" (1- end) t))
105	    (insert " ")
106	    (setq end (1+ end))
107	    (forward-char))
108	  (goto-char (setq start (1+ end)))))
109      t)))
110
111;;;###autoload
112(defun fill-flowed (&optional buffer)
113  (save-excursion
114    (set-buffer (or (current-buffer) buffer))
115    (goto-char (point-min))
116    ;; Remove space stuffing.
117    (while (re-search-forward "^\\( \\|>+ $\\)" nil t)
118      (delete-char -1)
119      (forward-line 1))
120    (goto-char (point-min))
121    (while (re-search-forward " $" nil t)
122      (when (save-excursion
123	      (beginning-of-line)
124	      (looking-at "^\\(>*\\)\\( ?\\)"))
125	(let ((quote (match-string 1))
126	      sig)
127	  (if (string= quote "")
128	      (setq quote nil))
129	  (when (and quote (string= (match-string 2) ""))
130	    (save-excursion
131	      ;; insert SP after quote for pleasant reading of quoted lines
132	      (beginning-of-line)
133	      (when (> (skip-chars-forward ">") 0)
134		(insert " "))))
135	  ;; XXX slightly buggy handling of "-- "
136	  (while (and (save-excursion
137			(ignore-errors (backward-char 3))
138			(setq sig (looking-at "-- "))
139			(looking-at "[^-][^-] "))
140		      (save-excursion
141			(unless (eobp)
142			  (forward-char 1)
143			  (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)"
144					      (or quote " ?"))))))
145	    (save-excursion
146	      (replace-match (if (string= (match-string 2) " ")
147				 "" "\\2")))
148	    (backward-delete-char -1)
149	    (end-of-line))
150	  (unless sig
151	    (condition-case nil
152		(let ((fill-prefix (when quote (concat quote " ")))
153		      (fill-column (eval fill-flowed-display-column))
154		      filladapt-mode
155		      adaptive-fill-mode)
156		  (fill-region (fill-flowed-point-at-bol)
157			       (min (1+ (fill-flowed-point-at-eol))
158				    (point-max))
159			       'left 'nosqueeze))
160	      (error
161	       (forward-line 1)
162	       nil))))))))
163
164;; Test vectors.
165
166(eval-when-compile
167  (defvar show-trailing-whitespace))
168
169(defvar fill-flowed-encode-tests
170  `(
171    ;; The syntax of each list element is:
172    ;; (INPUT . EXPECTED-OUTPUT)
173    (,(concat
174       "> Thou villainous ill-breeding spongy dizzy-eyed \n"
175       "> reeky elf-skinned pigeon-egg! \n"
176       ">> Thou artless swag-bellied milk-livered \n"
177       ">> dismal-dreaming idle-headed scut!\n"
178       ">>> Thou errant folly-fallen spleeny reeling-ripe \n"
179       ">>> unmuzzled ratsbane!\n"
180       ">>>> Henceforth, the coding style is to be strictly \n"
181       ">>>> enforced, including the use of only upper case.\n"
182       ">>>>> I've noticed a lack of adherence to the coding \n"
183       ">>>>> styles, of late.\n"
184       ">>>>>> Any complaints?")
185     .
186     ,(concat
187       "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned\n"
188       "> pigeon-egg! \n"
189       ">> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed\n"
190       ">> scut!\n"
191       ">>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!\n"
192       ">>>> Henceforth, the coding style is to be strictly enforced,\n"
193       ">>>> including the use of only upper case.\n"
194       ">>>>> I've noticed a lack of adherence to the coding styles, of late.\n"
195       ">>>>>> Any complaints?\n"
196       ))
197    ;; (,(concat
198    ;;    "\n"
199    ;;    "> foo\n"
200    ;;    "> \n"
201    ;;    "> \n"
202    ;;    "> bar\n")
203    ;;  .
204    ;;  ,(concat
205    ;;    "\n"
206    ;;    "> foo bar\n"))
207    ))
208
209(defun fill-flowed-test ()
210  (interactive "")
211  (switch-to-buffer (get-buffer-create "*Format=Flowed test output*"))
212  (erase-buffer)
213  (setq show-trailing-whitespace t)
214  (dolist (test fill-flowed-encode-tests)
215    (let (start output)
216      (insert "***** BEGIN TEST INPUT *****\n")
217      (insert (car test))
218      (insert "***** END TEST INPUT *****\n\n")
219      (insert "***** BEGIN TEST OUTPUT *****\n")
220      (setq start (point))
221      (insert (car test))
222      (save-restriction
223	(narrow-to-region start (point))
224	(fill-flowed))
225      (setq output (buffer-substring start (point-max)))
226      (insert "***** END TEST OUTPUT *****\n")
227      (unless (string= output (cdr test))
228	(insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n")
229	(insert (cdr test))
230	(insert "***** END TEST EXPECTED OUTPUT *****\n"))
231      (insert "\n\n")))
232  (goto-char (point-max)))
233
234(provide 'flow-fill)
235
236;;; arch-tag: addc0040-bc53-4f17-b4bc-1eb44eed6f0b
237;;; flow-fill.el ends here
238