X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fshr.el;h=8faa5071616e9b581bc0ca08a9ede397ad507b07;hb=6b6601f546f95399fee49605bd4cd186c0d99e31;hp=113137a0046aaf7e7a77c22ade7948ded4036726;hpb=7d572bd284be447a963c50800a8d397c844cb638;p=gnus diff --git a/lisp/shr.el b/lisp/shr.el index 113137a00..8faa50716 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -87,6 +87,18 @@ used." 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 elements." + :group 'shr) + +(defface shr-link + '((t (:inherit link))) + "Font for link elements." + :group 'shr) + ;;; Internal variables. (defvar shr-folding-mode nil) @@ -99,6 +111,7 @@ cid: URL as the argument.") (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))) @@ -127,6 +140,7 @@ cid: URL as the argument.") (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)))) @@ -169,14 +183,23 @@ redirects somewhere else." (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." @@ -392,6 +415,19 @@ redirects somewhere else." (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"))) @@ -476,10 +512,11 @@ redirects somewhere else." (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)))) @@ -489,14 +526,18 @@ redirects somewhere else." (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)) @@ -515,11 +556,9 @@ redirects somewhere else." (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. @@ -552,8 +591,8 @@ START, and END. Note that START and END should be merkers." (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) @@ -572,6 +611,7 @@ START, and END. Note that START and END should be merkers." :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) @@ -613,7 +653,7 @@ ones, in case fg and bg are nil." (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 @@ -686,7 +726,8 @@ ones, in case fg and bg are nil." (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)) @@ -694,7 +735,8 @@ ones, in case fg and bg are nil." (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)) @@ -719,6 +761,19 @@ ones, in case fg and bg are nil." (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)) @@ -735,6 +790,12 @@ ones, in case fg and bg are nil." (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)) @@ -750,9 +811,6 @@ ones, in case fg and bg are nil." (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 @@ -773,13 +831,16 @@ ones, in case fg and bg are nil." 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)) @@ -792,7 +853,7 @@ ones, in case fg and bg are nil." (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) @@ -800,7 +861,7 @@ ones, in case fg and bg are nil." (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 @@ -810,7 +871,7 @@ ones, in case fg and bg are nil." (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 "*")) @@ -826,7 +887,7 @@ ones, in case fg and bg are nil." (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))) @@ -836,13 +897,16 @@ ones, in case fg and bg are nil." (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)