Mercurial > emacs
comparison lisp/gnus/html2text.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | |
children | c5e16264557d |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
1 ;;; html2text.el --- a simple html to plain text converter | |
2 ;; Copyright (C) 2002, 2003 Free Software Foundation, Inc. | |
3 | |
4 ;; Author: Joakim Hove <hove@phys.ntnu.no> | |
5 | |
6 ;; This file is part of GNU Emacs. | |
7 | |
8 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
9 ;; it under the terms of the GNU General Public License as published by | |
10 ;; the Free Software Foundation; either version 2, or (at your option) | |
11 ;; any later version. | |
12 | |
13 ;; GNU Emacs is distributed in the hope that it will be useful, | |
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 ;; GNU General Public License for more details. | |
17 | |
18 ;; You should have received a copy of the GNU General Public License | |
19 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
21 ;; Boston, MA 02111-1307, USA. | |
22 | |
23 ;;; Commentary: | |
24 | |
25 ;; These functions provide a simple way to wash/clean html infected | |
26 ;; mails. Definitely do not work in all cases, but some improvement | |
27 ;; in readability is generally obtained. Formatting is only done in | |
28 ;; the buffer, so the next time you enter the article it will be | |
29 ;; "re-htmlized". | |
30 ;; | |
31 ;; The main function is "html2text" | |
32 | |
33 ;;; Code: | |
34 | |
35 ;; | |
36 ;; <Global variables> | |
37 ;; | |
38 | |
39 (eval-when-compile | |
40 (require 'cl)) | |
41 | |
42 (defvar html2text-format-single-element-list '(("hr" . html2text-clean-hr))) | |
43 | |
44 (defvar html2text-replace-list | |
45 '((" " . " ") (">" . ">") ("<" . "<") (""" . "\"")) | |
46 "The map of entity to text. | |
47 | |
48 This is an alist were each element is a dotted pair consisting of an | |
49 old string, and a replacement string. This replacement is done by the | |
50 function \"html2text-substitute\" which basically performs a | |
51 replace-string operation for every element in the list. This is | |
52 completely verbatim - without any use of REGEXP.") | |
53 | |
54 (defvar html2text-remove-tag-list | |
55 '("html" "body" "p" "img" "dir" "head" "div" "br" "font" "title" "meta") | |
56 "A list of removable tags. | |
57 | |
58 This is a list of tags which should be removed, without any | |
59 formatting. Observe that if you the tags in the list are presented | |
60 *without* any \"<\" or \">\". All occurences of a tag appearing in | |
61 this list are removed, irrespective of whether it is a closing or | |
62 opening tag, or if the tag has additional attributes. The actual | |
63 deletion is done by the function \"html2text-remove-tags\". | |
64 | |
65 For instance the text: | |
66 | |
67 \"Here comes something <font size\"+3\" face=\"Helvetica\"> big </font>.\" | |
68 | |
69 will be reduced to: | |
70 | |
71 \"Here comes something big.\" | |
72 | |
73 If this list contains the element \"font\".") | |
74 | |
75 (defvar html2text-format-tag-list | |
76 '(("b" . html2text-clean-bold) | |
77 ("u" . html2text-clean-underline) | |
78 ("i" . html2text-clean-italic) | |
79 ("blockquote" . html2text-clean-blockquote) | |
80 ("a" . html2text-clean-anchor) | |
81 ("ul" . html2text-clean-ul) | |
82 ("ol" . html2text-clean-ol) | |
83 ("dl" . html2text-clean-dl) | |
84 ("center" . html2text-clean-center)) | |
85 "An alist of tags and processing functions. | |
86 | |
87 This is an alist where each dotted pair consists of a tag, and then | |
88 the name of a function to be called when this tag is found. The | |
89 function is called with the arguments p1, p2, p3 and p4. These are | |
90 demontrated below: | |
91 | |
92 \"<b> This is bold text </b>\" | |
93 ^ ^ ^ ^ | |
94 | | | | | |
95 p1 p2 p3 p4 | |
96 | |
97 Then the called function will typically format the text somewhat and | |
98 remove the tags.") | |
99 | |
100 (defvar html2text-remove-tag-list2 '("li" "dt" "dd" "meta") | |
101 "Another list of removable tags. | |
102 | |
103 This is a list of tags which are removed similarly to the list | |
104 `html2text-remove-tag-list' - but these tags are retained for the | |
105 formatting, and then moved afterward.") | |
106 | |
107 ;; | |
108 ;; </Global variables> | |
109 ;; | |
110 | |
111 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
112 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
113 | |
114 ;; | |
115 ;; <Utility functions> | |
116 ;; | |
117 | |
118 (defun html2text-buffer-head () | |
119 (if (string= mode-name "Article") | |
120 (beginning-of-buffer) | |
121 (beginning-of-buffer) | |
122 ) | |
123 ) | |
124 | |
125 (defun html2text-replace-string (from-string to-string p1 p2) | |
126 (goto-char p1) | |
127 (let ((delta (- (string-width to-string) (string-width from-string))) | |
128 (change 0)) | |
129 (while (search-forward from-string p2 t) | |
130 (replace-match to-string) | |
131 (setq change (+ change delta)) | |
132 ) | |
133 change | |
134 ) | |
135 ) | |
136 | |
137 ;; | |
138 ;; </Utility functions> | |
139 ;; | |
140 | |
141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
143 | |
144 ;; | |
145 ;; <Functions related to attributes> i.e. <font size=+3> | |
146 ;; | |
147 | |
148 (defun html2text-attr-value (attr-list attr) | |
149 (nth 1 (assoc attr attr-list)) | |
150 ) | |
151 | |
152 (defun html2text-get-attr (p1 p2 tag) | |
153 (goto-char p1) | |
154 (re-search-forward " +[^ ]" p2 t) | |
155 (let* ((attr-string (buffer-substring-no-properties (1- (point)) (1- p2))) | |
156 (tmp-list (split-string attr-string)) | |
157 (attr-list) | |
158 (counter 0) | |
159 (prev (car tmp-list)) | |
160 (this (nth 1 tmp-list)) | |
161 (next (nth 2 tmp-list)) | |
162 (index 1)) | |
163 | |
164 (cond | |
165 ;; size=3 | |
166 ((string-match "[^ ]=[^ ]" prev) | |
167 (let ((attr (nth 0 (split-string prev "="))) | |
168 (value (nth 1 (split-string prev "=")))) | |
169 (setq attr-list (cons (list attr value) attr-list)) | |
170 ) | |
171 ) | |
172 ;; size= 3 | |
173 ((string-match "[^ ]=\\'" prev) | |
174 (setq attr-list (cons (list (substring prev 0 -1) this) attr-list)) | |
175 ) | |
176 ) | |
177 | |
178 (while (< index (length tmp-list)) | |
179 (cond | |
180 ;; size=3 | |
181 ((string-match "[^ ]=[^ ]" this) | |
182 (let ((attr (nth 0 (split-string this "="))) | |
183 (value (nth 1 (split-string this "=")))) | |
184 (setq attr-list (cons (list attr value) attr-list)) | |
185 ) | |
186 ) | |
187 ;; size =3 | |
188 ((string-match "\\`=[^ ]" this) | |
189 (setq attr-list (cons (list prev (substring this 1)) attr-list))) | |
190 | |
191 ;; size= 3 | |
192 ((string-match "[^ ]=\\'" this) | |
193 (setq attr-list (cons (list (substring this 0 -1) next) attr-list)) | |
194 ) | |
195 | |
196 ;; size = 3 | |
197 ((string= "=" this) | |
198 (setq attr-list (cons (list prev next) attr-list)) | |
199 ) | |
200 ) | |
201 (setq index (1+ index)) | |
202 (setq prev this) | |
203 (setq this next) | |
204 (setq next (nth (1+ index) tmp-list)) | |
205 ) | |
206 | |
207 ;; | |
208 ;; Tags with no accompanying "=" i.e. value=nil | |
209 ;; | |
210 (setq prev (car tmp-list)) | |
211 (setq this (nth 1 tmp-list)) | |
212 (setq next (nth 2 tmp-list)) | |
213 (setq index 1) | |
214 | |
215 (if (not (string-match "=" prev)) | |
216 (progn | |
217 (if (not (string= (substring this 0 1) "=")) | |
218 (setq attr-list (cons (list prev nil) attr-list)) | |
219 ) | |
220 ) | |
221 ) | |
222 | |
223 (while (< index (1- (length tmp-list))) | |
224 (if (not (string-match "=" this)) | |
225 (if (not (or (string= (substring next 0 1) "=") | |
226 (string= (substring prev -1) "="))) | |
227 (setq attr-list (cons (list this nil) attr-list)) | |
228 ) | |
229 ) | |
230 (setq index (1+ index)) | |
231 (setq prev this) | |
232 (setq this next) | |
233 (setq next (nth (1+ index) tmp-list)) | |
234 ) | |
235 | |
236 (if this | |
237 (progn | |
238 (if (not (string-match "=" this)) | |
239 (progn | |
240 (if (not (string= (substring prev -1) "=")) | |
241 (setq attr-list (cons (list this nil) attr-list)) | |
242 ) | |
243 ) | |
244 ) | |
245 ) | |
246 ) | |
247 attr-list ;; return - value | |
248 ) | |
249 ) | |
250 | |
251 ;; | |
252 ;; </Functions related to attributes> | |
253 ;; | |
254 | |
255 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
257 | |
258 ;; | |
259 ;; <Functions to be called to format a tag-pair> | |
260 ;; | |
261 (defun html2text-clean-list-items (p1 p2 list-type) | |
262 (goto-char p1) | |
263 (let ((item-nr 0) | |
264 (items 0)) | |
265 (while (re-search-forward "<li>" p2 t) | |
266 (setq items (1+ items))) | |
267 (goto-char p1) | |
268 (while (< item-nr items) | |
269 (setq item-nr (1+ item-nr)) | |
270 (re-search-forward "<li>" (point-max) t) | |
271 (cond | |
272 ((string= list-type "ul") (insert " o ")) | |
273 ((string= list-type "ol") (insert (format " %s: " item-nr))) | |
274 (t (insert " x "))) | |
275 ) | |
276 ) | |
277 ) | |
278 | |
279 (defun html2text-clean-dtdd (p1 p2) | |
280 (goto-char p1) | |
281 (let ((items 0) | |
282 (item-nr 0)) | |
283 (while (re-search-forward "<dt>" p2 t) | |
284 (setq items (1+ items))) | |
285 (goto-char p1) | |
286 (while (< item-nr items) | |
287 (setq item-nr (1+ item-nr)) | |
288 (re-search-forward "<dt>\\([ ]*\\)" (point-max) t) | |
289 (when (match-string 1) | |
290 (delete-region (point) (- (point) (string-width (match-string 1))))) | |
291 (let ((def-p1 (point)) | |
292 (def-p2 0)) | |
293 (re-search-forward "\\([ ]*\\)\\(</dt>\\|<dd>\\)" (point-max) t) | |
294 (if (match-string 1) | |
295 (progn | |
296 (let* ((mw1 (string-width (match-string 1))) | |
297 (mw2 (string-width (match-string 2))) | |
298 (mw (+ mw1 mw2))) | |
299 (goto-char (- (point) mw)) | |
300 (delete-region (point) (+ (point) mw1)) | |
301 (setq def-p2 (point)))) | |
302 (setq def-p2 (- (point) (string-width (match-string 2))))) | |
303 (put-text-property def-p1 def-p2 'face 'bold))))) | |
304 | |
305 (defun html2text-delete-tags (p1 p2 p3 p4) | |
306 (delete-region p1 p2) | |
307 (delete-region (- p3 (- p2 p1)) (- p4 (- p2 p1)))) | |
308 | |
309 (defun html2text-delete-single-tag (p1 p2) | |
310 (delete-region p1 p2)) | |
311 | |
312 (defun html2text-clean-hr (p1 p2) | |
313 (html2text-delete-single-tag p1 p2) | |
314 (goto-char p1) | |
315 (newline 1) | |
316 (insert (make-string fill-column ?-)) | |
317 ) | |
318 | |
319 (defun html2text-clean-ul (p1 p2 p3 p4) | |
320 (html2text-delete-tags p1 p2 p3 p4) | |
321 (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ul") | |
322 ) | |
323 | |
324 (defun html2text-clean-ol (p1 p2 p3 p4) | |
325 (html2text-delete-tags p1 p2 p3 p4) | |
326 (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ol") | |
327 ) | |
328 | |
329 (defun html2text-clean-dl (p1 p2 p3 p4) | |
330 (html2text-delete-tags p1 p2 p3 p4) | |
331 (html2text-clean-dtdd p1 (- p3 (- p1 p2))) | |
332 ) | |
333 | |
334 (defun html2text-clean-center (p1 p2 p3 p4) | |
335 (html2text-delete-tags p1 p2 p3 p4) | |
336 (center-region p1 (- p3 (- p2 p1))) | |
337 ) | |
338 | |
339 (defun html2text-clean-bold (p1 p2 p3 p4) | |
340 (put-text-property p2 p3 'face 'bold) | |
341 (html2text-delete-tags p1 p2 p3 p4) | |
342 ) | |
343 | |
344 (defun html2text-clean-title (p1 p2 p3 p4) | |
345 (put-text-property p2 p3 'face 'bold) | |
346 (html2text-delete-tags p1 p2 p3 p4) | |
347 ) | |
348 | |
349 (defun html2text-clean-underline (p1 p2 p3 p4) | |
350 (put-text-property p2 p3 'face 'underline) | |
351 (html2text-delete-tags p1 p2 p3 p4) | |
352 ) | |
353 | |
354 (defun html2text-clean-italic (p1 p2 p3 p4) | |
355 (put-text-property p2 p3 'face 'italic) | |
356 (html2text-delete-tags p1 p2 p3 p4) | |
357 ) | |
358 | |
359 (defun html2text-clean-font (p1 p2 p3 p4) | |
360 (html2text-delete-tags p1 p2 p3 p4) | |
361 ) | |
362 | |
363 (defun html2text-clean-blockquote (p1 p2 p3 p4) | |
364 (html2text-delete-tags p1 p2 p3 p4) | |
365 ) | |
366 | |
367 (defun html2text-clean-anchor (p1 p2 p3 p4) | |
368 ;; If someone can explain how to make the URL clickable I will | |
369 ;; surely improve upon this. | |
370 (let* ((attr-list (html2text-get-attr p1 p2 "a")) | |
371 (href (html2text-attr-value attr-list "href"))) | |
372 (delete-region p1 p4) | |
373 (when href | |
374 (goto-char p1) | |
375 (insert (substring href 1 -1 )) | |
376 (put-text-property p1 (point) 'face 'bold)))) | |
377 | |
378 ;; | |
379 ;; </Functions to be called to format a tag-pair> | |
380 ;; | |
381 | |
382 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
383 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
384 | |
385 ;; | |
386 ;; <Functions to be called to fix up paragraphs> | |
387 ;; | |
388 | |
389 (defun html2text-fix-paragraph (p1 p2) | |
390 (goto-char p1) | |
391 (let ((has-br-line) | |
392 (refill-start) | |
393 (refill-stop)) | |
394 (if (re-search-forward "<br>$" p2 t) | |
395 (setq has-br-line t) | |
396 ) | |
397 (if has-br-line | |
398 (progn | |
399 (goto-char p1) | |
400 (if (re-search-forward ".+[^<][^b][^r][^>]$" p2 t) | |
401 (progn | |
402 (beginning-of-line) | |
403 (setq refill-start (point)) | |
404 (goto-char p2) | |
405 (re-search-backward ".+[^<][^b][^r][^>]$" refill-start t) | |
406 (next-line 1) | |
407 (end-of-line) | |
408 ;; refill-stop should ideally be adjusted to | |
409 ;; accomodate the "<br>" strings which are removed | |
410 ;; between refill-start and refill-stop. Can simply | |
411 ;; be returned from my-replace-string | |
412 (setq refill-stop (+ (point) | |
413 (html2text-replace-string | |
414 "<br>" "" | |
415 refill-start (point)))) | |
416 ;; (message "Point = %s refill-stop = %s" (point) refill-stop) | |
417 ;; (sleep-for 4) | |
418 (fill-region refill-start refill-stop) | |
419 ) | |
420 ) | |
421 ) | |
422 ) | |
423 ) | |
424 (html2text-replace-string "<br>" "" p1 p2) | |
425 ) | |
426 | |
427 ;; | |
428 ;; This one is interactive ... | |
429 ;; | |
430 (defun html2text-fix-paragraphs () | |
431 "This _tries_ to fix up the paragraphs - this is done in quite a ad-hook | |
432 fashion, quite close to pure guess-work. It does work in some cases though." | |
433 (interactive) | |
434 (html2text-buffer-head) | |
435 (replace-regexp "^<br>$" "") | |
436 ;; Removing lonely <br> on a single line, if they are left intact we | |
437 ;; dont have any paragraphs at all. | |
438 (html2text-buffer-head) | |
439 (while (not (eobp)) | |
440 (let ((p1 (point))) | |
441 (forward-paragraph 1) | |
442 ;;(message "Kaller fix med p1=%s p2=%s " p1 (1- (point))) (sleep-for 5) | |
443 (html2text-fix-paragraph p1 (1- (point))) | |
444 (goto-char p1) | |
445 (when (not (eobp)) | |
446 (forward-paragraph 1))))) | |
447 | |
448 ;; | |
449 ;; </Functions to be called to fix up paragraphs> | |
450 ;; | |
451 | |
452 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
453 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
454 | |
455 ;; | |
456 ;; <Interactive functions> | |
457 ;; | |
458 | |
459 (defun html2text-remove-tags (tag-list) | |
460 "Removes the tags listed in the list \"html2text-remove-tag-list\". | |
461 See the documentation for that variable." | |
462 (interactive) | |
463 (dolist (tag tag-list) | |
464 (html2text-buffer-head) | |
465 (while (re-search-forward (format "\\(</?%s[^>]*>\\)" tag) (point-max) t) | |
466 (delete-region (match-beginning 0) (match-end 0))))) | |
467 | |
468 (defun html2text-format-tags () | |
469 "See the variable \"html2text-format-tag-list\" for documentation" | |
470 (interactive) | |
471 (dolist (tag-and-function html2text-format-tag-list) | |
472 (let ((tag (car tag-and-function)) | |
473 (function (cdr tag-and-function))) | |
474 (html2text-buffer-head) | |
475 (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag) | |
476 (point-max) t) | |
477 (let ((p1) | |
478 (p2 (point)) | |
479 (p3) (p4) | |
480 (attr (match-string 1))) | |
481 (search-backward "<" (point-min) t) | |
482 (setq p1 (point)) | |
483 (re-search-forward (format "</%s>" tag) (point-max) t) | |
484 (setq p4 (point)) | |
485 (search-backward "</" (point-min) t) | |
486 (setq p3 (point)) | |
487 (funcall function p1 p2 p3 p4) | |
488 (goto-char p1) | |
489 ) | |
490 ) | |
491 ) | |
492 ) | |
493 ) | |
494 | |
495 (defun html2text-substitute () | |
496 "See the variable \"html2text-replace-list\" for documentation" | |
497 (interactive) | |
498 (dolist (e html2text-replace-list) | |
499 (html2text-buffer-head) | |
500 (let ((old-string (car e)) | |
501 (new-string (cdr e))) | |
502 (html2text-replace-string old-string new-string (point-min) (point-max)) | |
503 ) | |
504 ) | |
505 ) | |
506 | |
507 (defun html2text-format-single-elements () | |
508 "" | |
509 (interactive) | |
510 (dolist (tag-and-function html2text-format-single-element-list) | |
511 (let ((tag (car tag-and-function)) | |
512 (function (cdr tag-and-function))) | |
513 (html2text-buffer-head) | |
514 (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag) | |
515 (point-max) t) | |
516 (let ((p1) | |
517 (p2 (point))) | |
518 (search-backward "<" (point-min) t) | |
519 (setq p1 (point)) | |
520 (funcall function p1 p2) | |
521 ) | |
522 ) | |
523 ) | |
524 ) | |
525 ) | |
526 | |
527 ;; | |
528 ;; Main function | |
529 ;; | |
530 | |
531 ;;;###autoload | |
532 (defun html2text () | |
533 "Convert HTML to plain text in the current buffer." | |
534 (interactive) | |
535 (save-excursion | |
536 (let ((case-fold-search t) | |
537 (buffer-read-only)) | |
538 (html2text-remove-tags html2text-remove-tag-list) | |
539 (html2text-format-tags) | |
540 (html2text-remove-tags html2text-remove-tag-list2) | |
541 (html2text-substitute) | |
542 (html2text-format-single-elements) | |
543 (html2text-fix-paragraphs)))) | |
544 | |
545 ;; | |
546 ;; </Interactive functions> | |
547 ;; | |
548 | |
549 ;;; arch-tag: e9e57b79-35d4-4de1-a647-e7e01fe56d1e | |
550 ;;; html2text.el ends here |