cgit.sxemacs.org Git - gnus/blob - lisp/shr.el

   1 ;;; shr.el --- Simple HTML Renderer
   2
   3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: html
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This package takes a HTML parse tree (as provided by
  26 ;; libxml-parse-html-region) and renders it in the current buffer.  It
  27 ;; does not do CSS, JavaScript or anything advanced: It's geared
  28 ;; towards rendering typical short snippets of HTML, like what you'd
  29 ;; find in HTML email and the like.
  30
  31 ;;; Code:
  32
  33 (defvar shr-folding-mode nil)
  34
  35 (defvar shr-width 70)
  36
  37 (defun shr-transform-dom (dom)
  38   (let ((result (list (pop dom))))
  39     (dolist (arg (pop dom))
  40       (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
  41                   (cdr arg))
  42             result))
  43     (dolist (sub dom)
  44       (if (stringp sub)
  45           (push (cons :text sub) result)
  46         (push (shr-transform-dom sub) result)))
  47     (nreverse result)))
  48
  49 (defun shr-insert-document (dom)
  50   (setq dom (shr-transform-dom dom))
  51   (shr-descend dom))
  52
  53 (defun shr-descend (dom)
  54   (let ((function (intern (concat "shr-" (symbol-name (car dom))) obarray)))
  55     (if (fboundp function)
  56         (funcall function (cdr dom))
  57       (shr-generic (cdr dom)))))
  58
  59 (defun shr-generic (cont)
  60   (dolist (sub cont)
  61     (cond
  62      ((eq (car sub) :text)
  63       (shr-insert (cdr sub)))
  64      ((consp (cdr sub))
  65       (shr-descend sub)))))
  66
  67 (defun shr-p (cont)
  68   (shr-ensure-newline)
  69   (insert "\n")
  70   (shr-generic cont)
  71   (insert "\n"))
  72
  73 (defun shr-pre (cont)
  74   (let ((shr-folding-mode nil))
  75     (shr-ensure-newline)
  76     (shr-generic cont)
  77     (shr-ensure-newline)))
  78
  79 (defun shr-blockquote (cont)
  80   (shr-pre cont))
  81
  82 (defun shr-ensure-newline ()
  83   (unless (zerop (current-column))
  84     (insert "\n")))
  85
  86 (defun shr-insert (text)
  87   (cond
  88    ((eq shr-folding-mode 'none)
  89     (insert t))
  90    (t
  91     (let (column)
  92       (dolist (elem (split-string text))
  93         (setq column (current-column))
  94         (if (zerop column)
  95             (insert elem)
  96           (if (> (+ column (length elem) 1) shr-width)
  97               (insert "\n" elem)
  98             (insert " " elem))))))))
  99
 100 (provide 'shr)
 101
 102 ;;; shr.el ends here