X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fflow-fill.el;h=6cc6771ebdaa3973190168af64f4e5069de44b09;hp=e627c4960fe8499fc19e544b5357999b5375c6d4;hb=786d05e27f23ae1e1254d90a50f61487e168c616;hpb=5407f30a97f4a0ab20cb8e4fdca9f1654a69ee64 diff --git a/lisp/flow-fill.el b/lisp/flow-fill.el index e627c4960..6cc6771eb 100644 --- a/lisp/flow-fill.el +++ b/lisp/flow-fill.el @@ -1,6 +1,7 @@ -;;; flow-fill.el --- interprete RFC2646 "flowed" text +;;; flow-fill.el --- interpret RFC2646 "flowed" text -;; Copyright (C) 2000, 2001 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2001, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Keywords: mail @@ -19,8 +20,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -43,26 +44,38 @@ ;; 2000-02-17 posted on ding mailing list ;; 2000-02-19 use `point-at-{b,e}ol' in XEmacs ;; 2000-03-11 no compile warnings for point-at-bol stuff -;; 2000-03-26 commited to gnus cvs +;; 2000-03-26 committed to gnus cvs ;; 2000-10-23 don't flow "-- " lines, make "quote-depth wins" rule ;; work when first line is at level 0. ;; 2002-01-12 probably incomplete encoding support +;; 2003-12-08 started working on test harness. ;;; Code: (eval-when-compile (require 'cl)) -(eval-and-compile - (defalias 'fill-flowed-point-at-bol - (if (fboundp 'point-at-bol) - 'point-at-bol - 'line-beginning-position)) - - (defalias 'fill-flowed-point-at-eol - (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position))) - +(defcustom fill-flowed-display-column 'fill-column + "Column beyond which format=flowed lines are wrapped, when displayed. +This can be a Lisp expression or an integer." + :version "22.1" + :group 'mime-display + :type '(choice (const :tag "Standard `fill-column'" fill-column) + (const :tag "Fit Window" (- (window-width) 5)) + (sexp) + (integer))) + +(defcustom fill-flowed-encode-column 66 + "Column beyond which format=flowed lines are wrapped, in outgoing messages. +This can be a Lisp expression or an integer. +RFC 2646 suggests 66 characters for readability." + :version "22.1" + :group 'mime-display + :type '(choice (const :tag "Standard fill-column" fill-column) + (const :tag "RFC 2646 default (66)" 66) + (sexp) + (integer))) + +;;;###autoload (defun fill-flowed-encode (&optional buffer) (with-current-buffer (or buffer (current-buffer)) ;; No point in doing this unless hard newlines is used. @@ -71,7 +84,7 @@ ;; Go through each paragraph, filling it and adding SPC ;; as the last character on each line. (while (setq end (text-property-any start (point-max) 'hard 't)) - (let ((fill-column 66)) + (let ((fill-column (eval fill-flowed-encode-column))) (fill-region start end t 'nosqueeze 'to-eop)) (goto-char start) ;; `fill-region' probably distorted end. @@ -84,15 +97,22 @@ (goto-char (setq start (1+ end))))) t))) +;;;###autoload (defun fill-flowed (&optional buffer) (save-excursion (set-buffer (or (current-buffer) buffer)) (goto-char (point-min)) + ;; Remove space stuffing. + (while (re-search-forward "^ " nil t) + (delete-char -1) + (forward-line 1)) + (goto-char (point-min)) (while (re-search-forward " $" nil t) (when (save-excursion (beginning-of-line) - (looking-at "^\\(>*\\)\\( ?\\)")) - (let ((quote (match-string 1)) sig) + (looking-at "^\\(>+\\)\\( ?\\)")) + (let ((quote (match-string 1)) + sig) (if (string= quote "") (setq quote nil)) (when (and quote (string= (match-string 2) "")) @@ -109,19 +129,92 @@ (save-excursion (unless (eobp) (forward-char 1) - (looking-at (format "^\\(%s\\)\\([^>]\\)" (or quote " ?")))))) + (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)" + (or quote " ?")))))) (save-excursion (replace-match (if (string= (match-string 2) " ") "" "\\2"))) (backward-delete-char -1) (end-of-line)) (unless sig - (let ((fill-prefix (when quote (concat quote " "))) - (fill-column (1- (window-width)))) - (fill-region (fill-flowed-point-at-bol) - (min (1+ (fill-flowed-point-at-eol)) (point-max)) - 'left 'nosqueeze)))))))) + (condition-case nil + (let ((fill-prefix (when quote (concat quote " "))) + (fill-column (eval fill-flowed-display-column)) + filladapt-mode) + (fill-region (point-at-bol) + (min (1+ (point-at-eol)) + (point-max)) + 'left 'nosqueeze)) + (error + (forward-line 1) + nil)))))))) + +;; Test vectors. + +(eval-when-compile + (defvar show-trailing-whitespace)) + +(defvar fill-flowed-encode-tests + '( + ;; The syntax of each list element is: + ;; (INPUT . EXPECTED-OUTPUT) + ("> Thou villainous ill-breeding spongy dizzy-eyed +> reeky elf-skinned pigeon-egg! +>> Thou artless swag-bellied milk-livered +>> dismal-dreaming idle-headed scut! +>>> Thou errant folly-fallen spleeny reeling-ripe +>>> unmuzzled ratsbane! +>>>> Henceforth, the coding style is to be strictly +>>>> enforced, including the use of only upper case. +>>>>> I've noticed a lack of adherence to the coding +>>>>> styles, of late. +>>>>>> Any complaints? +" . "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned +> pigeon-egg! +>> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed +>> scut! +>>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane! +>>>> Henceforth, the coding style is to be strictly enforced, +>>>> including the use of only upper case. +>>>>> I've noticed a lack of adherence to the coding styles, of late. +>>>>>> Any complaints? +") +; (" +;> foo +;> +;> +;> bar +;" . " +;> foo bar +;") + )) + +(defun fill-flowed-test () + (interactive "") + (switch-to-buffer (get-buffer-create "*Format=Flowed test output*")) + (erase-buffer) + (setq show-trailing-whitespace t) + (dolist (test fill-flowed-encode-tests) + (let (start output) + (insert "***** BEGIN TEST INPUT *****\n") + (insert (car test)) + (insert "***** END TEST INPUT *****\n\n") + (insert "***** BEGIN TEST OUTPUT *****\n") + (setq start (point)) + (insert (car test)) + (save-restriction + (narrow-to-region start (point)) + (fill-flowed)) + (setq output (buffer-substring start (point-max))) + (insert "***** END TEST OUTPUT *****\n") + (unless (string= output (cdr test)) + (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n") + (insert (cdr test)) + (insert "***** END TEST EXPECTED OUTPUT *****\n")) + (insert "\n\n"))) + (goto-char (point-max))) (provide 'flow-fill) +;;; arch-tag: addc0040-bc53-4f17-b4bc-1eb44eed6f0b ;;; flow-fill.el ends here