/[emacs]/emacs/lisp/gnus/flow-fill.el
ViewVC logotype

Diff of /emacs/lisp/gnus/flow-fill.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2.18.2 by miles, Tue Oct 14 23:34:50 2003 UTC revision 1.2.18.3 by miles, Thu Sep 16 00:12:15 2004 UTC
# Line 1  Line 1 
1  ;;; flow-fill.el --- interprete RFC2646 "flowed" text  ;;; flow-fill.el --- interprete RFC2646 "flowed" text
2    
3  ;; Copyright (C) 2000, 2002 Free Software Foundation, Inc.  ;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
4    
5  ;; Author: Simon Josefsson <jas@pdc.kth.se>  ;; Author: Simon Josefsson <jas@pdc.kth.se>
6  ;; Keywords: mail  ;; Keywords: mail
# Line 35  Line 35 
35  ;; paragraph and we let `fill-region' fill the long line into several  ;; paragraph and we let `fill-region' fill the long line into several
36  ;; lines with the quote prefix as `fill-prefix'.  ;; lines with the quote prefix as `fill-prefix'.
37    
38  ;; Todo: encoding, implement basic `fill-region' (Emacs and XEmacs  ;; Todo: implement basic `fill-region' (Emacs and XEmacs
39  ;;       implementations differ..)  ;;       implementations differ..)
40    
41  ;; History:  ;;; History:
42    
43  ;; 2000-02-17  posted on ding mailing list  ;; 2000-02-17  posted on ding mailing list
44  ;; 2000-02-19  use `point-at-{b,e}ol' in XEmacs  ;; 2000-02-19  use `point-at-{b,e}ol' in XEmacs
# Line 46  Line 46 
46  ;; 2000-03-26  committed to gnus cvs  ;; 2000-03-26  committed to gnus cvs
47  ;; 2000-10-23  don't flow "-- " lines, make "quote-depth wins" rule  ;; 2000-10-23  don't flow "-- " lines, make "quote-depth wins" rule
48  ;;             work when first line is at level 0.  ;;             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:  ;;; Code:
53    
54  (eval-when-compile (require 'cl))  (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      :group 'mime-display
60      :type '(choice (const :tag "Standard `fill-column'" fill-column)
61                     (const :tag "Fit Window" (- (window-width) 5))
62                     (sexp)
63                     (integer)))
64    
65    (defcustom fill-flowed-encode-column 66
66      "Column beyond which format=flowed lines are wrapped, in outgoing messages.
67    This can be a Lisp expression or an integer.
68    RFC 2646 suggests 66 characters for readability."
69      :group 'mime-display
70      :type '(choice (const :tag "Standard fill-column" fill-column)
71                     (const :tag "RFC 2646 default (66)" 66)
72                     (sexp)
73                     (integer)))
74    
75  (eval-and-compile  (eval-and-compile
76    (defalias 'fill-flowed-point-at-bol    (defalias 'fill-flowed-point-at-bol
77          (if (fboundp 'point-at-bol)          (if (fboundp 'point-at-bol)
# Line 62  Line 83 
83              'point-at-eol              'point-at-eol
84            'line-end-position)))            'line-end-position)))
85    
86    ;;;###autoload
87    (defun fill-flowed-encode (&optional buffer)
88      (with-current-buffer (or buffer (current-buffer))
89        ;; No point in doing this unless hard newlines is used.
90        (when use-hard-newlines
91          (let ((start (point-min)) end)
92            ;; Go through each paragraph, filling it and adding SPC
93            ;; as the last character on each line.
94            (while (setq end (text-property-any start (point-max) 'hard 't))
95              (let ((fill-column (eval fill-flowed-encode-column)))
96                (fill-region start end t 'nosqueeze 'to-eop))
97              (goto-char start)
98              ;; `fill-region' probably distorted end.
99              (setq end (text-property-any start (point-max) 'hard 't))
100              (while (and (< (point) end)
101                          (re-search-forward "$" (1- end) t))
102                (insert " ")
103                (setq end (1+ end))
104                (forward-char))
105              (goto-char (setq start (1+ end)))))
106          t)))
107    
108    ;;;###autoload
109  (defun fill-flowed (&optional buffer)  (defun fill-flowed (&optional buffer)
110    (save-excursion    (save-excursion
111      (set-buffer (or (current-buffer) buffer))      (set-buffer (or (current-buffer) buffer))
# Line 70  Line 114 
114        (when (save-excursion        (when (save-excursion
115                (beginning-of-line)                (beginning-of-line)
116                (looking-at "^\\(>*\\)\\( ?\\)"))                (looking-at "^\\(>*\\)\\( ?\\)"))
117          (let ((quote (match-string 1)) sig)          (let ((quote (match-string 1))
118                  sig)
119            (if (string= quote "")            (if (string= quote "")
120                (setq quote nil))                (setq quote nil))
121            (when (and quote (string= (match-string 2) ""))            (when (and quote (string= (match-string 2) ""))
# Line 79  Line 124 
124                (beginning-of-line)                (beginning-of-line)
125                (when (> (skip-chars-forward ">") 0)                (when (> (skip-chars-forward ">") 0)
126                  (insert " "))))                  (insert " "))))
127              ;; XXX slightly buggy handling of "-- "
128            (while (and (save-excursion            (while (and (save-excursion
129                          (ignore-errors (backward-char 3))                          (ignore-errors (backward-char 3))
130                          (setq sig (looking-at "-- "))                          (setq sig (looking-at "-- "))
# Line 86  Line 132 
132                        (save-excursion                        (save-excursion
133                          (unless (eobp)                          (unless (eobp)
134                            (forward-char 1)                            (forward-char 1)
135                            (looking-at (format "^\\(%s\\)\\([^>]\\)" (or quote " ?"))))))                            (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)"
136                                                  (or quote " ?"))))))
137              (save-excursion              (save-excursion
138                (replace-match (if (string= (match-string 2) " ")                (replace-match (if (string= (match-string 2) " ")
139                                   "" "\\2")))                                   "" "\\2")))
140              (backward-delete-char -1)              (backward-delete-char -1)
141              (end-of-line))              (end-of-line))
142            (unless sig            (unless sig
143              (let ((fill-prefix (when quote (concat quote " "))))              (condition-case nil
144                (fill-region (fill-flowed-point-at-bol)                  (let ((fill-prefix (when quote (concat quote " ")))
145                             (fill-flowed-point-at-eol)                        (fill-column (eval fill-flowed-display-column))
146                             'left 'nosqueeze))))))))                        filladapt-mode)
147                      (fill-region (fill-flowed-point-at-bol)
148                                   (min (1+ (fill-flowed-point-at-eol))
149                                        (point-max))
150                                   'left 'nosqueeze))
151                  (error
152                   (forward-line 1)
153                   nil))))))))
154    
155    ;; Test vectors.
156    
157    (eval-when-compile
158      (defvar show-trailing-whitespace))
159    
160    (defvar fill-flowed-encode-tests
161      '(
162        ;; The syntax of each list element is:
163        ;; (INPUT . EXPECTED-OUTPUT)
164        ("> Thou villainous ill-breeding spongy dizzy-eyed
165    > reeky elf-skinned pigeon-egg!
166    >> Thou artless swag-bellied milk-livered
167    >> dismal-dreaming idle-headed scut!
168    >>> Thou errant folly-fallen spleeny reeling-ripe
169    >>> unmuzzled ratsbane!
170    >>>> Henceforth, the coding style is to be strictly
171    >>>> enforced, including the use of only upper case.
172    >>>>> I've noticed a lack of adherence to the coding
173    >>>>> styles, of late.
174    >>>>>> Any complaints?
175    " . "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned
176    > pigeon-egg!
177    >> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed
178    >> scut!
179    >>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!
180    >>>> Henceforth, the coding style is to be strictly enforced,
181    >>>> including the use of only upper case.
182    >>>>> I've noticed a lack of adherence to the coding styles, of late.
183    >>>>>> Any complaints?
184    ")
185    ;    ("
186    ;> foo
187    ;>
188    ;>
189    ;> bar
190    ;" . "
191    ;> foo bar
192    ;")
193        ))
194    
195    (defun fill-flowed-test ()
196      (interactive "")
197      (switch-to-buffer (get-buffer-create "*Format=Flowed test output*"))
198      (erase-buffer)
199      (setq show-trailing-whitespace t)
200      (dolist (test fill-flowed-encode-tests)
201        (let (start output)
202          (insert "***** BEGIN TEST INPUT *****\n")
203          (insert (car test))
204          (insert "***** END TEST INPUT *****\n\n")
205          (insert "***** BEGIN TEST OUTPUT *****\n")
206          (setq start (point))
207          (insert (car test))
208          (save-restriction
209            (narrow-to-region start (point))
210            (fill-flowed))
211          (setq output (buffer-substring start (point-max)))
212          (insert "***** END TEST OUTPUT *****\n")
213          (unless (string= output (cdr test))
214            (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n")
215            (insert (cdr test))
216            (insert "***** END TEST EXPECTED OUTPUT *****\n"))
217          (insert "\n\n")))
218      (goto-char (point-max)))
219    
220  (provide 'flow-fill)  (provide 'flow-fill)
221    

Legend:
Removed from v.1.2.18.2  
changed lines
  Added in v.1.2.18.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26