:group 'shr
:type 'regexp)
-(defcustom shr-table-horizontal-line ?-
+(defcustom shr-table-horizontal-line ?
"Character used to draw horizontal table lines."
:group 'shr
:type 'character)
-(defcustom shr-table-vertical-line ?|
+(defcustom shr-table-vertical-line ?
"Character used to draw vertical table lines."
:group 'shr
:type 'character)
-(defcustom shr-table-corner ?+
+(defcustom shr-table-corner ?
"Character used to draw table corners."
:group 'shr
:type 'character)
This is used for cid: URLs, and the function is called with the
cid: URL as the argument.")
+(defvar shr-put-image-function 'shr-put-image
+ "Function called to put image and alt string.")
+
+(defface shr-strike-through '((t (:strike-through t)))
+ "Font for <s> elements."
+ :group 'shr)
+
+(defface shr-link
+ '((t (:inherit link)))
+ "Font for link elements."
+ :group 'shr)
+
;;; Internal variables.
(defvar shr-folding-mode nil)
(defvar shr-kinsoku-shorten nil)
(defvar shr-table-depth 0)
(defvar shr-stylesheet nil)
+(defvar shr-base nil)
(defvar shr-map
(let ((map (make-sparse-keymap)))
;; Public functions and commands.
+(defun shr-visit-file (file)
+ (interactive "fHTML file name: ")
+ (pop-to-buffer "*html*")
+ (erase-buffer)
+ (shr-insert-document
+ (with-temp-buffer
+ (insert-file-contents file)
+ (libxml-parse-html-region (point-min) (point-max)))))
+
;;;###autoload
(defun shr-insert-document (dom)
(setq shr-content-cache nil)
(let ((shr-state nil)
(shr-start nil)
+ (shr-base nil)
(shr-width (or shr-width (window-width))))
(shr-descend (shr-transform-dom dom))))
(message "No image under point")
(message "%s" text))))
-(defun shr-browse-image ()
- "Browse the image under point."
- (interactive)
+(defun shr-browse-image (&optional copy-url)
+ "Browse the image under point.
+If COPY-URL (the prefix if called interactively) is non-nil, copy
+the URL of the image to the kill buffer instead."
+ (interactive "P")
(let ((url (get-text-property (point) 'image-url)))
- (if (not url)
- (message "No image under point")
+ (cond
+ ((not url)
+ (message "No image under point"))
+ (copy-url
+ (with-temp-buffer
+ (insert url)
+ (copy-region-as-kill (point-min) (point-max))
+ (message "Copied %s" url)))
+ (t
(message "Browsing %s..." url)
- (browse-url url))))
+ (browse-url url)))))
(defun shr-insert-image ()
"Insert the image under point into the buffer."
(forward-char 1))))
(not failed)))
+(defun shr-expand-url (url)
+ (cond
+ ;; Absolute URL.
+ ((or (not url)
+ (string-match "\\`[a-z]*:" url)
+ (not shr-base))
+ url)
+ ((and (not (string-match "/\\'" shr-base))
+ (not (string-match "\\`/" url)))
+ (concat shr-base "/" url))
+ (t
+ (concat shr-base url))))
+
(defun shr-ensure-newline ()
(unless (zerop (current-column))
(insert "\n")))
(inhibit-read-only t))
(delete-region start end)
(goto-char start)
- (shr-put-image data alt)))))))
+ (funcall shr-put-image-function data alt)))))))
(kill-buffer (current-buffer)))
(defun shr-put-image (data alt)
+ "Put image DATA with a string ALT. Return image."
(if (display-graphic-p)
(let ((image (ignore-errors
(shr-rescale-image data))))
(when (and (> (current-column) 0)
(> (car (image-size image t)) 400))
(insert "\n"))
- (insert-image image (or alt "*"))))
+ (insert-image image (or alt "*"))
+ (when (image-animated-p image)
+ (image-animate image nil 60)))
+ image)
(insert alt)))
(defun shr-rescale-image (data)
(if (or (not (fboundp 'imagemagick-types))
(not (get-buffer-window (current-buffer))))
- (create-image data nil t)
- (let* ((image (create-image data nil t))
+ (create-image data nil t
+ :ascent 100)
+ (let* ((image (create-image data nil t :ascent 100))
(size (image-size image t))
(width (car size))
(height (cdr size))
(when (> (car size) window-width)
(setq image (or
(create-image data 'imagemagick t
- :width window-width)
+ :width window-width
+ :ascent 100)
image)))
- (when (and (fboundp 'create-animated-image)
- (eq (image-type data nil t) 'gif))
- (setq image (create-animated-image data 'gif t)))
image)))
;; url-cache-extract autoloads url-cache.
(substring url (match-end 0)))))
(when image
(goto-char start)
- (shr-put-image image
- (buffer-substring-no-properties start end))
+ (funcall shr-put-image-function
+ image (buffer-substring start end))
(delete-region (point) end))))
(url-retrieve url 'shr-image-fetched
(list (current-buffer) start end)
:help-echo (if title (format "%s (%s)" url title) url)
:keymap shr-map
url)
+ (shr-add-font start (point) 'shr-link)
(put-text-property start (point) 'shr-url url))
(defun shr-encode-url (url)
(when fg
(shr-put-color start end :foreground (cadr new-colors)))
(when bg
- (shr-put-color start end :background (car new-colors)))))))
+ (shr-put-color start end :background (car new-colors))))
+ new-colors)))
-;; Put a color in the region, but avoid putting colors on on blank
+;; Put a color in the region, but avoid putting colors on blank
;; text at the start of the line, and the newline at the end, to avoid
;; ugliness. Also, don't overwrite any existing color information,
;; since this can be called recursively, and we want the "inner" color
(defun shr-put-color-1 (start end type color)
(let* ((old-props (get-text-property start 'face))
- (do-put (not (memq type old-props)))
+ (do-put (and (listp old-props)
+ (not (memq type old-props))))
change)
(while (< start end)
(setq change (next-single-property-change start 'face nil end))
(put-text-property start change 'face
(nconc (list type color) old-props)))
(setq old-props (get-text-property change 'face))
- (setq do-put (not (memq type old-props)))
+ (setq do-put (and (listp old-props)
+ (not (memq type old-props))))
(setq start change))
(when (and do-put
(> end start))
(defun shr-tag-body (cont)
(let* ((start (point))
- (fgcolor (cdr (assq :fgcolor cont)))
+ (fgcolor (cdr (or (assq :fgcolor cont)
+ (assq :text cont))))
(bgcolor (cdr (assq :bgcolor cont)))
(shr-stylesheet (list (cons 'color fgcolor)
(cons 'background-color bgcolor))))
(defun shr-tag-script (cont)
)
+(defun shr-tag-comment (cont)
+ )
+
+(defun shr-tag-sup (cont)
+ (let ((start (point)))
+ (shr-generic cont)
+ (put-text-property start (point) 'display '(raise 0.5))))
+
+(defun shr-tag-sub (cont)
+ (let ((start (point)))
+ (shr-generic cont)
+ (put-text-property start (point) 'display '(raise -0.5))))
+
(defun shr-tag-label (cont)
(shr-generic cont)
(shr-ensure-paragraph))
(shr-generic cont)
(shr-ensure-newline))
+(defun shr-tag-s (cont)
+ (shr-fontize-cont cont 'shr-strike-through))
+
+(defun shr-tag-del (cont)
+ (shr-fontize-cont cont 'shr-strike-through))
+
(defun shr-tag-b (cont)
(shr-fontize-cont cont 'bold))
(defun shr-tag-u (cont)
(shr-fontize-cont cont 'underline))
-(defun shr-tag-s (cont)
- (shr-fontize-cont cont 'strike-through))
-
(defun shr-parse-style (style)
(when style
(save-match-data
plist)))))
plist)))
+(defun shr-tag-base (cont)
+ (setq shr-base (cdr (assq :href cont))))
+
(defun shr-tag-a (cont)
(let ((url (cdr (assq :href cont)))
(title (cdr (assq :title cont)))
(start (point))
shr-start)
(shr-generic cont)
- (shr-urlify (or shr-start start) url title)))
+ (shr-urlify (or shr-start start) (shr-expand-url url) title)))
(defun shr-tag-object (cont)
(let ((start (point))
(setq url (or url (cdr (assq :value (cdr elem)))))))
(when url
(shr-insert " [multimedia] ")
- (shr-urlify start url))
+ (shr-urlify start (shr-expand-url url)))
(shr-generic cont)))
(defun shr-tag-video (cont)
(url (cdr (assq :src cont)))
(start (point)))
(shr-tag-img nil image)
- (shr-urlify start url)))
+ (shr-urlify start (shr-expand-url url))))
(defun shr-tag-img (cont &optional url)
(when (or url
(not (eq shr-state 'image)))
(insert "\n"))
(let ((alt (cdr (assq :alt cont)))
- (url (or url (cdr (assq :src cont)))))
+ (url (shr-expand-url (or url (cdr (assq :src cont))))))
(let ((start (point-marker)))
(when (zerop (length alt))
(setq alt "*"))
(if (or (not shr-content-function)
(not (setq image (funcall shr-content-function url))))
(insert alt)
- (shr-put-image image alt))))
+ (funcall shr-put-image-function image alt))))
((or shr-inhibit-images
(and shr-blocked-images
(string-match shr-blocked-images url)))
(shr-insert (truncate-string-to-width alt 8))
(shr-insert alt))))
((url-is-cached (shr-encode-url url))
- (shr-put-image (shr-get-image-data url) alt))
+ (funcall shr-put-image-function (shr-get-image-data url) alt))
(t
(insert alt)
- (ignore-errors
- (url-retrieve (shr-encode-url url) 'shr-image-fetched
- (list (current-buffer) start (point-marker))
- t))))
+ (funcall
+ (if (fboundp 'url-queue-retrieve)
+ 'url-queue-retrieve
+ 'url-retrieve)
+ (shr-encode-url url) 'shr-image-fetched
+ (list (current-buffer) start (point-marker))
+ t)))
(put-text-property start (point) 'keymap shr-map)
(put-text-property start (point) 'shr-alt alt)
(put-text-property start (point) 'image-url url)
(fgcolor (cdr (assq :fgcolor cont)))
(style (cdr (assq :style cont)))
(shr-stylesheet shr-stylesheet)
- overlays)
+ overlays actual-colors)
(when style
(setq style (and (string-match "color" style)
(shr-parse-style style))))
(insert (make-string (- width (current-column)) ? )))
(forward-line 1)))
(when style
- (shr-colorize-region
- (point-min) (point-max)
- (cdr (assq 'color shr-stylesheet))
- (cdr (assq 'background-color shr-stylesheet)))))
+ (setq actual-colors
+ (shr-colorize-region
+ (point-min) (point-max)
+ (cdr (assq 'color shr-stylesheet))
+ (cdr (assq 'background-color shr-stylesheet))))))
(if fill
(list max
(count-lines (point-min) (point-max))
(split-string (buffer-string) "\n")
(shr-collect-overlays)
- (cdr (assq 'background-color shr-stylesheet)))
+ (car actual-colors))
(list max
(shr-natural-width)))))))
projects / gnus / blobdiff