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