X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fflow-fill.el;h=987113d4ccad681d1bf3d6fcb9a0620078080933;hb=30e5707a7503b9147f566e53163484a99bdb83e9;hp=9aae7c4b3b98538bcf8df57c5b8958429371467c;hpb=a2d6af2c24264119c5aff0ef0063733674eef102;p=elisp%2Fgnus.git- diff --git a/lisp/flow-fill.el b/lisp/flow-fill.el index 9aae7c4..987113d 100644 --- a/lisp/flow-fill.el +++ b/lisp/flow-fill.el @@ -1,22 +1,26 @@ ;;; flow-fill.el --- interprete RFC2646 "flowed" text -;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Keywords: mail -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2 of the License, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. -;; + ;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;; 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. ;;; Commentary: @@ -31,27 +35,71 @@ ;; paragraph and we let `fill-region' fill the long line into several ;; lines with the quote prefix as `fill-prefix'. -;; Todo: encoding +;; Todo: implement basic `fill-region' (Emacs and XEmacs +;; implementations differ..) -;; History: +;;; History: ;; 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 ;;; Code: +(eval-when-compile (require 'cl)) + +(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." + :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." + :type '(choice (const :tag "Standard fill-column" fill-column) + (const :tag "RFC 2646 default (66)" 66) + (sexp) + (integer))) + (eval-and-compile - (fset 'fill-flowed-point-at-bol - (if (fboundp 'point-at-bol) - 'point-at-bol - 'line-beginning-position)) - - (fset 'fill-flowed-point-at-eol - (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position))) + (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))) + +(defun fill-flowed-encode (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + ;; No point in doing this unless hard newlines is used. + (when use-hard-newlines + (let ((start (point-min)) end) + ;; 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 (eval fill-flowed-encode-column))) + (fill-region start end t 'nosqueeze 'to-eop)) + (goto-char start) + ;; `fill-region' probably distorted end. + (setq end (text-property-any start (point-max) 'hard 't)) + (while (and (< (point) end) + (re-search-forward "$" (1- end) t)) + (insert " ") + (setq end (1+ end)) + (forward-char)) + (goto-char (setq start (1+ end))))) + t))) (defun fill-flowed (&optional buffer) (save-excursion @@ -61,7 +109,8 @@ (when (save-excursion (beginning-of-line) (looking-at "^\\(>*\\)\\( ?\\)")) - (let ((quote (match-string 1))) + (let ((quote (match-string 1)) + sig) (if (string= quote "") (setq quote nil)) (when (and quote (string= (match-string 2) "")) @@ -70,24 +119,33 @@ (beginning-of-line) (when (> (skip-chars-forward ">") 0) (insert " ")))) + ;; XXX slightly buggy handling of "-- " (while (and (save-excursion - (backward-char 3) + (ignore-errors (backward-char 3)) + (setq sig (looking-at "-- ")) (looking-at "[^-][^-] ")) (save-excursion (unless (eobp) (forward-char 1) - (if quote - (looking-at (format "^\\(%s\\)\\([^>]\\)" quote)) - (looking-at "^ ?"))))) + (looking-at (format "^\\(%s\\)\\([^>]\\)" + (or quote " ?")))))) (save-excursion (replace-match (if (string= (match-string 2) " ") "" "\\2"))) (backward-delete-char -1) (end-of-line)) - (let ((fill-prefix (when quote (concat quote " ")))) - (fill-region (fill-flowed-point-at-bol) - (fill-flowed-point-at-eol) - 'left 'nosqueeze))))))) + (unless sig + (condition-case nil + (let ((fill-prefix (when quote (concat quote " "))) + (fill-column (eval fill-flowed-display-column)) + filladapt-mode) + (fill-region (fill-flowed-point-at-bol) + (min (1+ (fill-flowed-point-at-eol)) + (point-max)) + 'left 'nosqueeze)) + (error + (forward-line 1) + nil)))))))) (provide 'flow-fill)