/[emacs]/emacs/lisp/gnus/html2text.el
ViewVC logotype

Diff of /emacs/lisp/gnus/html2text.el

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

revision 1.2.4.3 by miles, Fri Oct 29 02:05:07 2004 UTC revision 1.2.4.4 by miles, Thu Nov 4 13:12:19 2004 UTC
# Line 24  Line 24 
24    
25  ;; These functions provide a simple way to wash/clean html infected  ;; These functions provide a simple way to wash/clean html infected
26  ;; mails.  Definitely do not work in all cases, but some improvement  ;; mails.  Definitely do not work in all cases, but some improvement
27  ;; in readability is generally obtained. Formatting is only done in  ;; in readability is generally obtained.  Formatting is only done in
28  ;; the buffer, so the next time you enter the article it will be  ;; the buffer, so the next time you enter the article it will be
29  ;; "re-htmlized".  ;; "re-htmlized".
30  ;;  ;;
31  ;; The main function is "html2text"  ;; The main function is `html2text'.
32    
33  ;;; Code:  ;;; Code:
34    
# Line 47  Line 47 
47    "The map of entity to text.    "The map of entity to text.
48    
49  This is an alist were each element is a dotted pair consisting of an  This is an alist were each element is a dotted pair consisting of an
50  old string, and a replacement string. This replacement is done by the  old string, and a replacement string.  This replacement is done by the
51  function \"html2text-substitute\" which basically performs a  function `html2text-substitute' which basically performs a
52  replace-string operation for every element in the list. This is  `replace-string' operation for every element in the list.  This is
53  completely verbatim - without any use of REGEXP.")  completely verbatim - without any use of REGEXP.")
54    
55  (defvar html2text-remove-tag-list  (defvar html2text-remove-tag-list
# Line 57  completely verbatim - without any use of Line 57  completely verbatim - without any use of
57    "A list of removable tags.    "A list of removable tags.
58    
59  This is a list of tags which should be removed, without any  This is a list of tags which should be removed, without any
60  formatting.  Observe that if you the tags in the list are presented  formatting.  Note that tags in the list are presented *without*
61  *without* any \"<\" or \">\". All occurences of a tag appearing in  any \"<\" or \">\".  All occurences of a tag appearing in this
62  this list are removed, irrespective of whether it is a closing or  list are removed, irrespective of whether it is a closing or
63  opening tag, or if the tag has additional attributes. The actual  opening tag, or if the tag has additional attributes.  The
64  deletion is done by the function \"html2text-remove-tags\".  deletion is done by the function `html2text-remove-tags'.
65    
66  For instance the text:  For instance the text:
67    
# Line 75  If this list contains the element \"font Line 75  If this list contains the element \"font
75    
76  (defvar html2text-format-tag-list  (defvar html2text-format-tag-list
77    '(("b"          . html2text-clean-bold)    '(("b"          . html2text-clean-bold)
78        ("strong"     . html2text-clean-bold)
79      ("u"          . html2text-clean-underline)      ("u"          . html2text-clean-underline)
80      ("i"          . html2text-clean-italic)      ("i"          . html2text-clean-italic)
81        ("em"         . html2text-clean-italic)
82      ("blockquote" . html2text-clean-blockquote)      ("blockquote" . html2text-clean-blockquote)
83      ("a"          . html2text-clean-anchor)      ("a"          . html2text-clean-anchor)
84      ("ul"         . html2text-clean-ul)      ("ul"         . html2text-clean-ul)
# Line 86  If this list contains the element \"font Line 88  If this list contains the element \"font
88    "An alist of tags and processing functions.    "An alist of tags and processing functions.
89    
90  This is an alist where each dotted pair consists of a tag, and then  This is an alist where each dotted pair consists of a tag, and then
91  the name of a function to be called when this tag is found. The  the name of a function to be called when this tag is found.  The
92  function is called with the arguments p1, p2, p3 and p4. These are  function is called with the arguments p1, p2, p3 and p4. These are
93  demontrated below:  demontrated below:
94    
# Line 117  formatting, and then moved afterward.") Line 119  formatting, and then moved afterward.")
119  ;;  ;;
120    
121    
122  (defun html2text-replace-string (from-string to-string p1 p2)  (defun html2text-replace-string (from-string to-string min max)
123    (goto-char p1)    "Replace FROM-STRING with TO-STRING in region from MIN to MAX."
124      (goto-char min)
125    (let ((delta (- (string-width to-string) (string-width from-string)))    (let ((delta (- (string-width to-string) (string-width from-string)))
126          (change 0))          (change 0))
127      (while (search-forward from-string p2 t)      (while (search-forward from-string max t)
128        (replace-match to-string)        (replace-match to-string)
129        (setq change (+ change delta))        (setq change (+ change delta)))
130        )      change))
     change  
     )  
   )  
131    
132  ;;  ;;
133  ;; </Utility functions>  ;; </Utility functions>
# Line 140  formatting, and then moved afterward.") Line 140  formatting, and then moved afterward.")
140  ;; <Functions related to attributes> i.e. <font size=+3>  ;; <Functions related to attributes> i.e. <font size=+3>
141  ;;  ;;
142    
143  (defun html2text-attr-value (attr-list attr)  (defun html2text-attr-value (list attribute)
144    (nth 1 (assoc attr attr-list))    "Get value of ATTRIBUTE from LIST."
145    )    (nth 1 (assoc attribute list)))
146    
147  (defun html2text-get-attr (p1 p2 tag)  (defun html2text-get-attr (p1 p2)
148    (goto-char p1)    (goto-char p1)
149    (re-search-forward " +[^ ]" p2 t)    (re-search-forward " +[^ ]" p2 t)
150    (let* ((attr-string (buffer-substring-no-properties (1- (point)) (1- p2)))    (let* ((attr-string (buffer-substring-no-properties (1- (point)) (1- p2)))
# Line 161  formatting, and then moved afterward.") Line 161  formatting, and then moved afterward.")
161       ((string-match "[^ ]=[^ ]" prev)       ((string-match "[^ ]=[^ ]" prev)
162        (let ((attr  (nth 0 (split-string prev "=")))        (let ((attr  (nth 0 (split-string prev "=")))
163              (value (nth 1 (split-string prev "="))))              (value (nth 1 (split-string prev "="))))
164          (setq attr-list (cons (list attr value) attr-list))          (setq attr-list (cons (list attr value) attr-list))))
         )  
       )  
165       ;; size= 3       ;; size= 3
166       ((string-match "[^ ]=\\'" prev)       ((string-match "[^ ]=\\'" prev)
167        (setq attr-list (cons (list (substring prev 0 -1) this) attr-list))        (setq attr-list (cons (list (substring prev 0 -1) this) attr-list))))
       )  
      )  
168    
169      (while (< index (length tmp-list))      (while (< index (length tmp-list))
170        (cond        (cond
# Line 176  formatting, and then moved afterward.") Line 172  formatting, and then moved afterward.")
172         ((string-match "[^ ]=[^ ]" this)         ((string-match "[^ ]=[^ ]" this)
173          (let ((attr  (nth 0 (split-string this "=")))          (let ((attr  (nth 0 (split-string this "=")))
174                (value (nth 1 (split-string this "="))))                (value (nth 1 (split-string this "="))))
175            (setq attr-list (cons (list attr value) attr-list))            (setq attr-list (cons (list attr value) attr-list))))
           )  
         )  
176         ;; size =3         ;; size =3
177         ((string-match "\\`=[^ ]" this)         ((string-match "\\`=[^ ]" this)
178          (setq attr-list (cons (list prev (substring this 1)) attr-list)))          (setq attr-list (cons (list prev (substring this 1)) attr-list)))
   
179         ;; size= 3         ;; size= 3
180         ((string-match "[^ ]=\\'" this)         ((string-match "[^ ]=\\'" this)
181          (setq attr-list (cons (list (substring this 0 -1) next) attr-list))          (setq attr-list (cons (list (substring this 0 -1) next) attr-list)))
         )  
   
182         ;; size = 3         ;; size = 3
183         ((string= "=" this)         ((string= "=" this)
184          (setq attr-list (cons (list prev next) attr-list))          (setq attr-list (cons (list prev next) attr-list))))
         )  
        )  
185        (setq index (1+ index))        (setq index (1+ index))
186        (setq prev this)        (setq prev this)
187        (setq this next)        (setq this next)
188        (setq next (nth (1+ index) tmp-list))        (setq next (nth (1+ index) tmp-list)))
       )  
   
189      ;;      ;;
190      ;; Tags with no accompanying "=" i.e. value=nil      ;; Tags with no accompanying "=" i.e. value=nil
191      ;;      ;;
# Line 207  formatting, and then moved afterward.") Line 194  formatting, and then moved afterward.")
194      (setq next (nth 2 tmp-list))      (setq next (nth 2 tmp-list))
195      (setq index 1)      (setq index 1)
196    
197      (if (not (string-match "=" prev))      (when (and (not (string-match "=" prev))
198          (progn                 (not (string= (substring this 0 1) "=")))
199            (if (not (string= (substring this 0 1) "="))        (setq attr-list (cons (list prev nil) attr-list)))
               (setq attr-list (cons (list prev nil) attr-list))  
             )  
           )  
       )  
   
200      (while (< index (1- (length tmp-list)))      (while (< index (1- (length tmp-list)))
201        (if (not (string-match "=" this))        (when (and (not (string-match "=" this))
202            (if (not (or (string= (substring next 0 1) "=")                   (not (or (string= (substring next 0 1) "=")
203                         (string= (substring prev -1) "=")))                            (string= (substring prev -1) "="))))
204                (setq attr-list (cons (list this nil) attr-list))          (setq attr-list (cons (list this nil) attr-list)))
             )  
         )  
205        (setq index (1+ index))        (setq index (1+ index))
206        (setq prev this)        (setq prev this)
207        (setq this next)        (setq this next)
208        (setq next (nth (1+ index) tmp-list))        (setq next (nth (1+ index) tmp-list)))
       )  
209    
210      (if this      (when (and this
211          (progn                 (not (string-match "=" this))
212            (if (not (string-match "=" this))                 (not (string= (substring prev -1) "=")))
213                (progn        (setq attr-list (cons (list this nil) attr-list)))
214                  (if (not (string= (substring prev -1) "="))      ;; return - value
215                      (setq attr-list (cons (list this nil) attr-list))      attr-list))
                   )  
                 )  
             )  
           )  
       )  
     attr-list ;; return - value  
     )  
   )  
216    
217  ;;  ;;
218  ;; </Functions related to attributes>  ;; </Functions related to attributes>
# Line 266  formatting, and then moved afterward.") Line 237  formatting, and then moved afterward.")
237        (cond        (cond
238         ((string= list-type "ul") (insert " o "))         ((string= list-type "ul") (insert " o "))
239         ((string= list-type "ol") (insert (format " %s: " item-nr)))         ((string= list-type "ol") (insert (format " %s: " item-nr)))
240         (t (insert " x ")))         (t (insert " x "))))))
       )  
     )  
   )  
241    
242  (defun html2text-clean-dtdd (p1 p2)  (defun html2text-clean-dtdd (p1 p2)
243    (goto-char p1)    (goto-char p1)
# Line 308  formatting, and then moved afterward.") Line 276  formatting, and then moved afterward.")
276    (html2text-delete-single-tag p1 p2)    (html2text-delete-single-tag p1 p2)
277    (goto-char p1)    (goto-char p1)
278    (newline 1)    (newline 1)
279    (insert (make-string fill-column ?-))    (insert (make-string fill-column ?-)))
   )  
280    
281  (defun html2text-clean-ul (p1 p2 p3 p4)  (defun html2text-clean-ul (p1 p2 p3 p4)
282    (html2text-delete-tags p1 p2 p3 p4)    (html2text-delete-tags p1 p2 p3 p4)
283    (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ul")    (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ul"))
   )  
284    
285  (defun html2text-clean-ol (p1 p2 p3 p4)  (defun html2text-clean-ol (p1 p2 p3 p4)
286    (html2text-delete-tags p1 p2 p3 p4)    (html2text-delete-tags p1 p2 p3 p4)
287    (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ol")    (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ol"))
   )  
288    
289  (defun html2text-clean-dl (p1 p2 p3 p4)  (defun html2text-clean-dl (p1 p2 p3 p4)
290    (html2text-delete-tags p1 p2 p3 p4)    (html2text-delete-tags p1 p2 p3 p4)
291    (html2text-clean-dtdd p1 (- p3 (- p1 p2)))    (html2text-clean-dtdd p1 (- p3 (- p1 p2))))
   )  
292    
293  (defun html2text-clean-center (p1 p2 p3 p4)  (defun html2text-clean-center (p1 p2 p3 p4)
294    (html2text-delete-tags p1 p2 p3 p4)    (html2text-delete-tags p1 p2 p3 p4)
295    (center-region p1 (- p3 (- p2 p1)))    (center-region p1 (- p3 (- p2 p1))))
   )  
296    
297  (defun html2text-clean-bold (p1 p2 p3 p4)  (defun html2text-clean-bold (p1 p2 p3 p4)
298    (put-text-property p2 p3 'face 'bold)    (put-text-property p2 p3 'face 'bold)
299    (html2text-delete-tags p1 p2 p3 p4)    (html2text-delete-tags p1 p2 p3 p4))
   )  
300    
301  (defun html2text-clean-title (p1 p2 p3 p4)  (defun html2text-clean-title (p1 p2 p3 p4)
302    (put-text-property p2 p3 'face 'bold)    (put-text-property p2 p3 'face 'bold)
303    (html2text-delete-tags p1 p2 p3 p4)    (html2text-delete-tags p1 p2 p3 p4))
   )  
304    
305  (defun html2text-clean-underline (p1 p2 p3 p4)  (defun html2text-clean-underline (p1 p2 p3 p4)
306    (put-text-property p2 p3 'face 'underline)    (put-text-property p2 p3 'face 'underline)
307    (html2text-delete-tags p1 p2 p3 p4)    (html2text-delete-tags p1 p2 p3 p4))
   )  
308    
309  (defun html2text-clean-italic (p1 p2 p3 p4)  (defun html2text-clean-italic (p1 p2 p3 p4)
310    (put-text-property p2 p3 'face 'italic)    (put-text-property p2 p3 'face 'italic)
311    (html2text-delete-tags p1 p2 p3 p4)    (html2text-delete-tags p1 p2 p3 p4))
   )  
312    
313  (defun html2text-clean-font (p1 p2 p3 p4)  (defun html2text-clean-font (p1 p2 p3 p4)
314    (html2text-delete-tags p1 p2 p3 p4)    (html2text-delete-tags p1 p2 p3 p4))
   )  
315    
316  (defun html2text-clean-blockquote (p1 p2 p3 p4)  (defun html2text-clean-blockquote (p1 p2 p3 p4)
317    (html2text-delete-tags p1 p2 p3 p4)    (html2text-delete-tags p1 p2 p3 p4))
   )  
318    
319  (defun html2text-clean-anchor (p1 p2 p3 p4)  (defun html2text-clean-anchor (p1 p2 p3 p4)
320    ;; If someone can explain how to make the URL clickable I will    ;; If someone can explain how to make the URL clickable I will surely
321    ;; surely improve upon this.    ;; improve upon this.
322    (let* ((attr-list (html2text-get-attr p1 p2 "a"))    ;; Maybe `goto-addr.el' can be used here.
323      (let* ((attr-list (html2text-get-attr p1 p2))
324           (href (html2text-attr-value attr-list "href")))           (href (html2text-attr-value attr-list "href")))
325      (delete-region p1 p4)      (delete-region p1 p4)
326      (when href      (when href
# Line 386  formatting, and then moved afterward.") Line 344  formatting, and then moved afterward.")
344    (let ((has-br-line)    (let ((has-br-line)
345          (refill-start)          (refill-start)
346          (refill-stop))          (refill-stop))
347      (if (re-search-forward "<br>$" p2 t)      (when (re-search-forward "<br>$" p2 t)
348          (setq has-br-line t)        (goto-char p1)
349        )        (when (re-search-forward ".+[^<][^b][^r][^>]$" p2 t)
350      (if has-br-line          (beginning-of-line)
351          (progn          (setq refill-start (point))
352            (goto-char p1)          (goto-char p2)
353            (if (re-search-forward ".+[^<][^b][^r][^>]$" p2 t)          (re-search-backward ".+[^<][^b][^r][^>]$" refill-start t)
354                (progn          (next-line 1)
355                  (beginning-of-line)          (end-of-line)
356                  (setq refill-start (point))          ;; refill-stop should ideally be adjusted to
357                  (goto-char p2)          ;; accomodate the "<br>" strings which are removed
358                  (re-search-backward ".+[^<][^b][^r][^>]$" refill-start t)          ;; between refill-start and refill-stop.  Can simply
359                  (next-line 1)          ;; be returned from my-replace-string
360                  (end-of-line)          (setq refill-stop (+ (point)
361                  ;; refill-stop should ideally be adjusted to                               (html2text-replace-string
362                  ;; accomodate the "<br>" strings which are removed                                "<br>" ""
363                  ;; between refill-start and refill-stop.  Can simply                                refill-start (point))))
364                  ;; be returned from my-replace-string          ;; (message "Point = %s  refill-stop = %s" (point) refill-stop)
365                  (setq refill-stop (+ (point)          ;; (sleep-for 4)
366                                       (html2text-replace-string          (fill-region refill-start refill-stop))))
367                                        "<br>" ""    (html2text-replace-string "<br>" "" p1 p2))
                                       refill-start (point))))  
                 ;; (message "Point = %s  refill-stop = %s" (point) refill-stop)  
                 ;; (sleep-for 4)  
                 (fill-region refill-start refill-stop)  
                 )  
             )  
           )  
       )  
     )  
   (html2text-replace-string "<br>" "" p1 p2)  
   )  
368    
369  ;;  ;;
370  ;; This one is interactive ...  ;; This one is interactive ...
# Line 452  fashion, quite close to pure guess-work. Line 399  fashion, quite close to pure guess-work.
399  ;;  ;;
400    
401  (defun html2text-remove-tags (tag-list)  (defun html2text-remove-tags (tag-list)
402    "Removes the tags listed in the list \"html2text-remove-tag-list\".    "Removes the tags listed in the list `html2text-remove-tag-list'.
403  See the documentation for that variable."  See the documentation for that variable."
404    (interactive)    (interactive)
405    (dolist (tag tag-list)    (dolist (tag tag-list)
# Line 461  See the documentation for that variable. Line 408  See the documentation for that variable.
408        (delete-region (match-beginning 0) (match-end 0)))))        (delete-region (match-beginning 0) (match-end 0)))))
409    
410  (defun html2text-format-tags ()  (defun html2text-format-tags ()
411    "See the variable \"html2text-format-tag-list\" for documentation"    "See the variable `html2text-format-tag-list' for documentation."
412    (interactive)    (interactive)
413    (dolist (tag-and-function html2text-format-tag-list)    (dolist (tag-and-function html2text-format-tag-list)
414      (let ((tag      (car tag-and-function))      (let ((tag      (car tag-and-function))
# Line 471  See the documentation for that variable. Line 418  See the documentation for that variable.
418                                  (point-max) t)                                  (point-max) t)
419          (let ((p1)          (let ((p1)
420                (p2 (point))                (p2 (point))
421                (p3) (p4)                (p3) (p4))
               (attr (match-string 1)))  
422            (search-backward "<" (point-min) t)            (search-backward "<" (point-min) t)
423            (setq p1 (point))            (setq p1 (point))
424            (re-search-forward (format "</%s>" tag) (point-max) t)            (re-search-forward (format "</%s>" tag) (point-max) t)
# Line 480  See the documentation for that variable. Line 426  See the documentation for that variable.
426            (search-backward "</" (point-min) t)            (search-backward "</" (point-min) t)
427            (setq p3 (point))            (setq p3 (point))
428            (funcall function p1 p2 p3 p4)            (funcall function p1 p2 p3 p4)
429            (goto-char p1)            (goto-char p1))))))
           )  
         )  
       )  
     )  
   )  
430    
431  (defun html2text-substitute ()  (defun html2text-substitute ()
432    "See the variable \"html2text-replace-list\" for documentation"    "See the variable `html2text-replace-list' for documentation."
433    (interactive)    (interactive)
434    (dolist (e html2text-replace-list)    (dolist (e html2text-replace-list)
435      (goto-char (point-min))      (goto-char (point-min))
436      (let ((old-string (car e))      (let ((old-string (car e))
437            (new-string (cdr e)))            (new-string (cdr e)))
438        (html2text-replace-string old-string new-string (point-min) (point-max))        (html2text-replace-string old-string new-string (point-min) (point-max)))))
       )  
     )  
   )  
439    
440  (defun html2text-format-single-elements ()  (defun html2text-format-single-elements ()
   ""  
441    (interactive)    (interactive)
442    (dolist (tag-and-function html2text-format-single-element-list)    (dolist (tag-and-function html2text-format-single-element-list)
443      (let ((tag      (car tag-and-function))      (let ((tag      (car tag-and-function))
# Line 512  See the documentation for that variable. Line 449  See the documentation for that variable.
449                (p2 (point)))                (p2 (point)))
450            (search-backward "<" (point-min) t)            (search-backward "<" (point-min) t)
451            (setq p1 (point))            (setq p1 (point))
452            (funcall function p1 p2)            (funcall function p1 p2))))))
           )  
         )  
       )  
     )  
   )  
453    
454  ;;  ;;
455  ;; Main function  ;; Main function
# Line 540  See the documentation for that variable. Line 472  See the documentation for that variable.
472  ;;  ;;
473  ;; </Interactive functions>  ;; </Interactive functions>
474  ;;  ;;
475    (provide 'html2text)
476  ;;; arch-tag: e9e57b79-35d4-4de1-a647-e7e01fe56d1e  ;;; arch-tag: e9e57b79-35d4-4de1-a647-e7e01fe56d1e
477  ;;; html2text.el ends here  ;;; html2text.el ends here

Legend:
Removed from v.1.2.4.3  
changed lines
  Added in v.1.2.4.4

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