/[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.4 by miles, Mon Sep 1 15:45:23 2003 UTC revision 1.5 by miles, Sat Sep 4 13:13:43 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      :type '(choice (const :tag "Standard `fill-column'" fill-column)
60                     (const :tag "Fit Window" (- (window-width) 5))
61                     (sexp)
62                     (integer)))
63    
64    (defcustom fill-flowed-encode-column 66
65      "Column beyond which format=flowed lines are wrapped, in outgoing messages.
66    This can be a Lisp expression or an integer.
67    RFC 2646 suggests 66 characters for readability."
68      :type '(choice (const :tag "Standard fill-column" fill-column)
69                     (const :tag "RFC 2646 default (66)" 66)
70                     (sexp)
71                     (integer)))
72    
73  (eval-and-compile  (eval-and-compile
74    (defalias 'fill-flowed-point-at-bol    (defalias 'fill-flowed-point-at-bol
75          (if (fboundp 'point-at-bol)          (if (fboundp 'point-at-bol)
# Line 62  Line 81 
81              'point-at-eol              'point-at-eol
82            'line-end-position)))            'line-end-position)))
83    
84    ;;;###autoload
85    (defun fill-flowed-encode (&optional buffer)
86      (with-current-buffer (or buffer (current-buffer))
87        ;; No point in doing this unless hard newlines is used.
88        (when use-hard-newlines
89          (let ((start (point-min)) end)
90            ;; Go through each paragraph, filling it and adding SPC
91            ;; as the last character on each line.
92            (while (setq end (text-property-any start (point-max) 'hard 't))
93              (let ((fill-column (eval fill-flowed-encode-column)))
94                (fill-region start end t 'nosqueeze 'to-eop))
95              (goto-char start)
96              ;; `fill-region' probably distorted end.
97              (setq end (text-property-any start (point-max) 'hard 't))
98              (while (and (< (point) end)
99                          (re-search-forward "$" (1- end) t))
100                (insert " ")
101                (setq end (1+ end))
102                (forward-char))
103              (goto-char (setq start (1+ end)))))
104          t)))
105    
106    ;;;###autoload
107  (defun fill-flowed (&optional buffer)  (defun fill-flowed (&optional buffer)
108    (save-excursion    (save-excursion
109      (set-buffer (or (current-buffer) buffer))      (set-buffer (or (current-buffer) buffer))
# Line 70  Line 112 
112        (when (save-excursion        (when (save-excursion
113                (beginning-of-line)                (beginning-of-line)
114                (looking-at "^\\(>*\\)\\( ?\\)"))                (looking-at "^\\(>*\\)\\( ?\\)"))
115          (let ((quote (match-string 1)) sig)          (let ((quote (match-string 1))
116                  sig)
117            (if (string= quote "")            (if (string= quote "")
118                (setq quote nil))                (setq quote nil))
119            (when (and quote (string= (match-string 2) ""))            (when (and quote (string= (match-string 2) ""))
# Line 79  Line 122 
122                (beginning-of-line)                (beginning-of-line)
123                (when (> (skip-chars-forward ">") 0)                (when (> (skip-chars-forward ">") 0)
124                  (insert " "))))                  (insert " "))))
125              ;; XXX slightly buggy handling of "-- "
126            (while (and (save-excursion            (while (and (save-excursion
127                          (ignore-errors (backward-char 3))                          (ignore-errors (backward-char 3))
128                          (setq sig (looking-at "-- "))                          (setq sig (looking-at "-- "))
# Line 86  Line 130 
130                        (save-excursion                        (save-excursion
131                          (unless (eobp)                          (unless (eobp)
132                            (forward-char 1)                            (forward-char 1)
133                            (looking-at (format "^\\(%s\\)\\([^>]\\)" (or quote " ?"))))))                            (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)"
134                                                  (or quote " ?"))))))
135              (save-excursion              (save-excursion
136                (replace-match (if (string= (match-string 2) " ")                (replace-match (if (string= (match-string 2) " ")
137                                   "" "\\2")))                                   "" "\\2")))
138              (backward-delete-char -1)              (backward-delete-char -1)
139              (end-of-line))              (end-of-line))
140            (unless sig            (unless sig
141              (let ((fill-prefix (when quote (concat quote " "))))              (condition-case nil
142                (fill-region (fill-flowed-point-at-bol)                  (let ((fill-prefix (when quote (concat quote " ")))
143                             (fill-flowed-point-at-eol)                        (fill-column (eval fill-flowed-display-column))
144                             'left 'nosqueeze))))))))                        filladapt-mode)
145                      (fill-region (fill-flowed-point-at-bol)
146                                   (min (1+ (fill-flowed-point-at-eol))
147                                        (point-max))
148                                   'left 'nosqueeze))
149                  (error
150                   (forward-line 1)
151                   nil))))))))
152    
153    ;; Test vectors.
154    
155    (eval-when-compile
156      (defvar show-trailing-whitespace))
157    
158    (defvar fill-flowed-encode-tests
159      '(
160        ;; The syntax of each list element is:
161        ;; (INPUT . EXPECTED-OUTPUT)
162        ("> Thou villainous ill-breeding spongy dizzy-eyed
163    > reeky elf-skinned pigeon-egg!
164    >> Thou artless swag-bellied milk-livered
165    >> dismal-dreaming idle-headed scut!
166    >>> Thou errant folly-fallen spleeny reeling-ripe
167    >>> unmuzzled ratsbane!
168    >>>> Henceforth, the coding style is to be strictly
169    >>>> enforced, including the use of only upper case.
170    >>>>> I've noticed a lack of adherence to the coding
171    >>>>> styles, of late.
172    >>>>>> Any complaints?
173    " . "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned
174    > pigeon-egg!
175    >> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed
176    >> scut!
177    >>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!
178    >>>> Henceforth, the coding style is to be strictly enforced,
179    >>>> including the use of only upper case.
180    >>>>> I've noticed a lack of adherence to the coding styles, of late.
181    >>>>>> Any complaints?
182    ")
183    ;    ("
184    ;> foo
185    ;>
186    ;>
187    ;> bar
188    ;" . "
189    ;> foo bar
190    ;")
191        ))
192    
193    (defun fill-flowed-test ()
194      (interactive "")
195      (switch-to-buffer (get-buffer-create "*Format=Flowed test output*"))
196      (erase-buffer)
197      (setq show-trailing-whitespace t)
198      (dolist (test fill-flowed-encode-tests)
199        (let (start output)
200          (insert "***** BEGIN TEST INPUT *****\n")
201          (insert (car test))
202          (insert "***** END TEST INPUT *****\n\n")
203          (insert "***** BEGIN TEST OUTPUT *****\n")
204          (setq start (point))
205          (insert (car test))
206          (save-restriction
207            (narrow-to-region start (point))
208            (fill-flowed))
209          (setq output (buffer-substring start (point-max)))
210          (insert "***** END TEST OUTPUT *****\n")
211          (unless (string= output (cdr test))
212            (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n")
213            (insert (cdr test))
214            (insert "***** END TEST EXPECTED OUTPUT *****\n"))
215          (insert "\n\n")))
216      (goto-char (point-max)))
217    
218  (provide 'flow-fill)  (provide 'flow-fill)
219    

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

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