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