X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=50363b6c9de5330ac58fe56f21dd3ea9136778d3;hb=e2696774a2e225ea60d46cc665d4232c80412731;hp=dcab65736c33dd718eb5b255c554804d1ff425d8;hpb=7e9eb62a83810ca426393feb960596f041d50ec4;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index dcab657..50363b6 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -246,7 +246,9 @@ that number. If it is a floating point number, no signature may be longer (in lines) than that number. If it is a function, the function will be called without any parameters, and if it returns nil, there is no signature in the buffer. If it is a string, it will be used as a -regexp. If it matches, the text in question is not a signature." +regexp. If it matches, the text in question is not a signature. + +This can also be a list of the above values." :type '(choice (integer :value 200) (number :value 4.0) (function :value fun) @@ -379,8 +381,6 @@ advertisements. For example: (format format (car spec) (car (cdr spec))) 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) types) - ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)" - 2 3 gnus-emphasis-strikethru) ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" 2 3 gnus-emphasis-underline))) "*Alist that says how to fontify certain phrases. @@ -450,14 +450,14 @@ Example: (_/*word*/_)." "Face used for displaying highlighted words." :group 'gnus-article-emphasis) -(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" +(defcustom gnus-article-time-format "%a, %d %b %Y %T %Z" "Format for display of Date headers in article bodies. See `format-time-string' for the possible values. The variable can also be function, which should return a complete Date header. The function is called with one argument, the time, which can be fed to `format-time-string'." - :type '(choice string symbol) + :type '(choice string function) :link '(custom-manual "(gnus)Article Date") :group 'gnus-article-washing) @@ -814,12 +814,6 @@ as described by the variables `gnus-buttonized-mime-types' and :group 'gnus-article-mime :type 'boolean) -(defcustom gnus-mime-recompute-hierarchical-structure nil - "Non-nil means recompute article's hierarchical MIME structure. -The hierarchy numbers will be displayed in MIME buttons." - :group 'gnus-article-mime - :type 'boolean) - (defcustom gnus-body-boundary-delimiter "_" "String used to delimit header and body. This variable is used by `gnus-article-treat-body-boundary' which can @@ -828,7 +822,8 @@ be controlled by `gnus-treat-body-boundary'." :type '(choice (item :tag "None" :value nil) string)) -(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces") +(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces" + "/usr/share/picons") "Defines the location of the faces database. For information on obtaining this database of pretty pictures, please see http://www.cs.indiana.edu/picons/ftp/index.html" @@ -854,16 +849,7 @@ on parts -- for instance, adding Vcard info to a database." :type 'function) (defcustom gnus-mime-multipart-functions nil - "An alist of MIME types to functions to display them. -Consider using `gnus-mime-accumulate-hierarchy' for each MIME handle -when defining your function. For example: - -\(setq gnus-mime-multipart-functions - (list (cons \"multipart/examples\" - (lambda (handles) - (dolist (handle (cdr handles)) - (gnus-mime-accumulate-hierarchy handle) - (function-to-display-an-example handle))))))" + "An alist of MIME types to functions to display them." :version "21.1" :group 'gnus-article-mime :type '(repeat (cons :format "%v" (string :tag "MIME type") function))) @@ -1574,8 +1560,6 @@ This requires GNU Libidn, and by default only enabled if it is found." (defvar gnus-article-mime-handle-alist nil) (defvar article-lapsed-timer nil) (defvar gnus-article-current-summary nil) -(defvar gnus-article-mime-hierarchy nil) -(defvar gnus-article-mime-hierarchy-next nil) (defvar gnus-article-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) @@ -1713,25 +1697,35 @@ Initialized from `text-mode-syntax-table.") (when (eq 1 (point-min)) (set-window-start (get-buffer-window (current-buffer)) 1))) (unless gnus-inhibit-hiding - (save-excursion - (save-restriction - (let ((inhibit-read-only t) - (case-fold-search t) - (max (1+ (length gnus-sorted-header-list))) - (ignored (when (not gnus-visible-headers) - (cond ((stringp gnus-ignored-headers) - gnus-ignored-headers) - ((listp gnus-ignored-headers) - (mapconcat 'identity gnus-ignored-headers - "\\|"))))) - (visible - (cond ((stringp gnus-visible-headers) - gnus-visible-headers) - ((and gnus-visible-headers - (listp gnus-visible-headers)) - (mapconcat 'identity gnus-visible-headers "\\|")))) - (inhibit-point-motion-hooks t) - beg) + (let ((inhibit-read-only t) + (case-fold-search t) + (max (1+ (length gnus-sorted-header-list))) + (inhibit-point-motion-hooks t) + (cur (current-buffer)) + ignored visible beg) + (save-excursion + ;; `gnus-ignored-headers' and `gnus-visible-headers' may be + ;; group parameters, so we should go to the summary buffer. + (when (prog1 + (condition-case nil + (progn (set-buffer gnus-summary-buffer) t) + (error nil)) + (setq ignored (when (not gnus-visible-headers) + (cond ((stringp gnus-ignored-headers) + gnus-ignored-headers) + ((listp gnus-ignored-headers) + (mapconcat 'identity + gnus-ignored-headers + "\\|")))) + visible (cond ((stringp gnus-visible-headers) + gnus-visible-headers) + ((and gnus-visible-headers + (listp gnus-visible-headers)) + (mapconcat 'identity + gnus-visible-headers + "\\|"))))) + (set-buffer cur)) + (save-restriction ;; First we narrow to just the headers. (article-narrow-to-head) ;; Hide any "From " lines at the beginning of (mail) articles. @@ -2220,7 +2214,7 @@ unfolded." (save-restriction (mail-narrow-to-head) (while (gnus-article-goto-header "Face") - (push (mail-header-field-value) faces)))) + (setq faces (nconc faces (list (mail-header-field-value))))))) (while (setq face (pop faces)) (let ((png (gnus-convert-face-to-png face)) image) @@ -2416,15 +2410,13 @@ If PROMPT (the prefix), prompt for a coding system to use." buffer-read-only) (article-narrow-to-head) (goto-char (point-min)) - (while (re-search-forward "\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t) + (while (re-search-forward "@.*\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t) (let (ace unicode) (when (save-match-data (and (setq ace (match-string 1)) (save-excursion (and (re-search-backward "^[^ \t]" nil t) (looking-at "From\\|To\\|Cc"))) - (save-excursion (backward-char) - (message-idna-inside-rhs-p)) (setq unicode (idna-to-unicode ace)))) (unless (string= ace unicode) (replace-match unicode nil nil nil 1))))))))) @@ -2641,18 +2633,25 @@ always hide." (article-really-strip-banner (gnus-parameter-banner gnus-newsgroup-name))) (when gnus-article-address-banner-alist - (article-really-strip-banner - (let ((from (save-restriction - (widen) - (article-narrow-to-head) - (mail-fetch-field "from")))) - (when (and from - (setq from - (caar (mail-header-parse-addresses from)))) - (catch 'found - (dolist (pair gnus-article-address-banner-alist) - (when (string-match (car pair) from) - (throw 'found (cdr pair))))))))))))) + ;; It is necessary to encode from fields before checking, + ;; because `mail-header-parse-addresses' does not work + ;; (reliably) on decoded headers. And more, it is + ;; impossible to use `gnus-fetch-original-field' here, + ;; because `article-strip-banner' may be called in draft + ;; buffers to preview them. + (let ((from (save-restriction + (widen) + (article-narrow-to-head) + (mail-fetch-field "from")))) + (when (and from + (setq from + (caar (mail-header-parse-addresses + (mail-encode-encoded-word-string from))))) + (catch 'found + (dolist (pair gnus-article-address-banner-alist) + (when (string-match (car pair) from) + (throw 'found + (article-really-strip-banner (cdr pair))))))))))))) (defun article-really-strip-banner (banner) "Strip the banner specified by the argument." @@ -3004,10 +3003,8 @@ should replace the \"Date:\" one, or should be added below it." (forward-line -1) ;; Do highlighting. (when (looking-at "\\([^:]+\\): *\\(.*\\)$") - (put-text-property (match-beginning 1) (1+ (match-end 1)) - 'original-date date) - (put-text-property (match-beginning 1) (1+ (match-end 1)) - 'face bface) + (add-text-properties (match-beginning 1) (1+ (match-end 1)) + (list 'original-date date 'face bface)) (put-text-property (match-beginning 2) (match-end 2) 'face eface)))))))) @@ -3020,22 +3017,21 @@ should replace the \"Date:\" one, or should be added below it." (cond ;; Convert to the local timezone. ((eq type 'local) - (let ((tz (car (current-time-zone time)))) - (format "Date: %s %s%02d%02d" (current-time-string time) - (if (> tz 0) "+" "-") (/ (abs tz) 3600) - (/ (% (abs tz) 3600) 60)))) + (concat "Date: " (message-make-date time))) ;; Convert to Universal Time. ((eq type 'ut) (concat "Date: " - (current-time-string - (let* ((e (parse-time-string date)) - (tm (apply 'encode-time e)) - (ms (car tm)) - (ls (- (cadr tm) (car (current-time-zone time))))) - (cond ((< ls 0) (list (1- ms) (+ ls 65536))) - ((> ls 65535) (list (1+ ms) (- ls 65536))) - (t (list ms ls))))) - " UT")) + (substring + (message-make-date + (let* ((e (parse-time-string date)) + (tm (apply 'encode-time e)) + (ms (car tm)) + (ls (- (cadr tm) (car (current-time-zone time))))) + (cond ((< ls 0) (list (1- ms) (+ ls 65536))) + ((> ls 65535) (list (1+ ms) (- ls 65536))) + (t (list ms ls))))) + 0 -5) + "UT")) ;; Get the original date from the article. ((eq type 'original) (concat "Date: " (if (string-match "\n+$" date) @@ -3867,10 +3863,10 @@ commands: (make-local-variable 'gnus-article-image-alist) (make-local-variable 'gnus-article-charset) (make-local-variable 'gnus-article-ignored-charsets) - (make-local-variable 'gnus-article-mime-hierarchy) (gnus-set-default-directory) (buffer-disable-undo) - (setq buffer-read-only t) + (setq buffer-read-only t + show-trailing-whitespace nil) (set-syntax-table gnus-article-mode-syntax-table) (gnus-run-hooks 'gnus-article-mode-hook)) @@ -3885,8 +3881,6 @@ commands: (setq gnus-article-buffer name) (setq gnus-original-article-buffer original) (setq gnus-article-mime-handle-alist nil) - (setq gnus-article-mime-hierarchy nil - gnus-article-mime-hierarchy-next nil) ;; This might be a variable local to the summary buffer. (unless gnus-single-article-buffer (save-excursion @@ -4441,6 +4435,8 @@ Deleting parts may malfunction or destroy the article; continue? ") (or (mail-content-type-get (mm-handle-disposition data) 'filename) none)) (type (mm-handle-media-type data))) + (unless data + (error "No MIME part under point")) (with-current-buffer (mm-handle-buffer data) (let ((bsize (format "%s" (buffer-size)))) (erase-buffer) @@ -4864,17 +4860,11 @@ N is the numerical prefix." (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist - (prog1 - `(keymap ,gnus-mime-button-map - gnus-callback gnus-mm-display-part - gnus-part ,gnus-tmp-id - article-type annotation - gnus-data ,handle) - (when gnus-mime-recompute-hierarchical-structure - (setq gnus-tmp-id (mapconcat 'number-to-string - (car (nth (1- gnus-tmp-id) - gnus-article-mime-hierarchy)) - "."))))) + `(keymap ,gnus-mime-button-map + gnus-callback gnus-mm-display-part + gnus-part ,gnus-tmp-id + article-type annotation + gnus-data ,handle)) (setq e (if (bolp) ;; Exclude a newline. (1- (point)) @@ -4983,111 +4973,44 @@ If displaying \"text/html\" is discouraged \(see :group 'gnus-article-mime :type 'boolean) -(defun gnus-mime-accumulate-hierarchy (handle &optional single) - "Accumulate the MIME hierarchy." - (when gnus-mime-recompute-hierarchical-structure - (prog1 - (setq gnus-article-mime-hierarchy - (nconc - gnus-article-mime-hierarchy - (list - (cons - (or - gnus-article-mime-hierarchy-next - (if gnus-article-mime-hierarchy - (let ((last (1- (length gnus-article-mime-hierarchy)))) - (prog1 - (setq last - (copy-sequence - (car (nth last - gnus-article-mime-hierarchy)))) - (setq last (nthcdr (1- (length last)) last)) - (setcar last (1+ (car last))))) - (list 1))) - ;; A placeholder which may be replaced with `handle'. - nil)))) - (if (and single - (not (member (mm-handle-media-type handle) - '("message/rfc822")))) - (let ((last (copy-sequence - (car (nth (1- (length gnus-article-mime-hierarchy)) - gnus-article-mime-hierarchy))))) - (setq gnus-article-mime-hierarchy-next last - last (nthcdr (1- (length last)) last)) - (setcar last (1+ (car last)))) - (setq gnus-article-mime-hierarchy-next nil))))) - -(defun gnus-mime-enter-multipart () - (when gnus-mime-recompute-hierarchical-structure - (setq gnus-article-mime-hierarchy-next - (cond (gnus-article-mime-hierarchy-next - (nconc gnus-article-mime-hierarchy-next (list 1))) - (gnus-article-mime-hierarchy - (append (car (nth (1- (length gnus-article-mime-hierarchy)) - gnus-article-mime-hierarchy)) - (list 1))) - (t - (list 1)))))) - -(defun gnus-mime-leave-multipart () - (when gnus-mime-recompute-hierarchical-structure - (setq gnus-article-mime-hierarchy-next - (when gnus-article-mime-hierarchy - (let ((last (car (nth (1- (length gnus-article-mime-hierarchy)) - gnus-article-mime-hierarchy)))) - (when (cdr last) - (prog1 - (setq last (butlast last)) - (setq last (nthcdr (1- (length last)) last)) - (setcar last (1+ (car last)))))))))) - (defun gnus-mime-display-part (handle) - (if (not (stringp (car handle))) - ;; Single part. - (progn - (gnus-mime-accumulate-hierarchy handle t) - (gnus-mime-display-single handle)) - (gnus-mime-enter-multipart) - (prog1 - (cond - ;; User-defined multipart - ((cdr (assoc (car handle) gnus-mime-multipart-functions)) - (gnus-mime-accumulate-hierarchy handle) - (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions)) - handle)) - ;; multipart/alternative - ((and (equal (car handle) "multipart/alternative") - (not (or gnus-mime-display-multipart-as-mixed - gnus-mime-display-multipart-alternative-as-mixed))) - (gnus-mime-accumulate-hierarchy handle) - (let ((id (1+ (length gnus-article-mime-handle-alist)))) - (push (cons id handle) gnus-article-mime-handle-alist) - (gnus-mime-display-alternative (cdr handle) nil nil id))) - ;; multipart/related - ((and (equal (car handle) "multipart/related") - (not (or gnus-mime-display-multipart-as-mixed - gnus-mime-display-multipart-related-as-mixed))) - ;;;!!!We should find the start part, but we just default - ;;;!!!to the first part. - ;;(gnus-mime-display-part (cadr handle)) - ;;;!!! Most multipart/related is an HTML message plus images. - ;;;!!! Unfortunately we are unable to let W3 display those - ;;;!!! included images, so we just display it as a mixed multipart. - ;;(gnus-mime-display-mixed (cdr handle)) - ;;;!!! No, w3 can display everything just fine. - (gnus-mime-display-part (cadr handle))) - ((equal (car handle) "multipart/signed") - (gnus-mime-accumulate-hierarchy handle) - (gnus-add-wash-type 'signed) - (gnus-mime-display-security handle)) - ((equal (car handle) "multipart/encrypted") - (gnus-mime-accumulate-hierarchy handle) - (gnus-add-wash-type 'encrypted) - (gnus-mime-display-security handle)) - ;; Other multiparts are handled like multipart/mixed. - (t - (gnus-mime-display-mixed (cdr handle)))) - (gnus-mime-leave-multipart)))) + (cond + ;; Single part. + ((not (stringp (car handle))) + (gnus-mime-display-single handle)) + ;; User-defined multipart + ((cdr (assoc (car handle) gnus-mime-multipart-functions)) + (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions)) + handle)) + ;; multipart/alternative + ((and (equal (car handle) "multipart/alternative") + (not (or gnus-mime-display-multipart-as-mixed + gnus-mime-display-multipart-alternative-as-mixed))) + (let ((id (1+ (length gnus-article-mime-handle-alist)))) + (push (cons id handle) gnus-article-mime-handle-alist) + (gnus-mime-display-alternative (cdr handle) nil nil id))) + ;; multipart/related + ((and (equal (car handle) "multipart/related") + (not (or gnus-mime-display-multipart-as-mixed + gnus-mime-display-multipart-related-as-mixed))) + ;;;!!!We should find the start part, but we just default + ;;;!!!to the first part. + ;;(gnus-mime-display-part (cadr handle)) + ;;;!!! Most multipart/related is an HTML message plus images. + ;;;!!! Unfortunately we are unable to let W3 display those + ;;;!!! included images, so we just display it as a mixed multipart. + ;;(gnus-mime-display-mixed (cdr handle)) + ;;;!!! No, w3 can display everything just fine. + (gnus-mime-display-part (cadr handle))) + ((equal (car handle) "multipart/signed") + (gnus-add-wash-type 'signed) + (gnus-mime-display-security handle)) + ((equal (car handle) "multipart/encrypted") + (gnus-add-wash-type 'encrypted) + (gnus-mime-display-security handle)) + ;; Other multiparts are handled like multipart/mixed. + (t + (gnus-mime-display-mixed (cdr handle))))) (defun gnus-mime-part-function (handles) (if (stringp (car handles)) @@ -5208,14 +5131,7 @@ If displaying \"text/html\" is discouraged \(see (gnus-add-text-properties (setq from (point)) (progn - (insert (format "%s. " - (if gnus-mime-recompute-hierarchical-structure - (mapconcat - 'number-to-string - (car (nth (1- id) - gnus-article-mime-hierarchy)) - ".") - id))) + (insert (format "%d. " id)) (point)) `(gnus-callback (lambda (handles) @@ -5473,6 +5389,7 @@ Argument LINES specifies lines to be scrolled up." (save-excursion (save-restriction (widen) + (forward-line) (eobp)))) ;Real end-of-buffer? (progn (when gnus-article-over-scroll @@ -5715,7 +5632,7 @@ the entire article will be yanked." (interactive "P") (let ((article (cdr gnus-article-current)) contents) - (if (not (gnus-mark-active-p)) + (if (not (gnus-region-active-p)) (with-current-buffer gnus-summary-buffer (gnus-summary-reply (list (list article)) wide)) (setq contents (buffer-substring (point) (mark t))) @@ -5734,7 +5651,7 @@ the entire article will be yanked." (interactive) (let ((article (cdr gnus-article-current)) contents) - (if (not (gnus-mark-active-p)) + (if (not (gnus-region-active-p)) (with-current-buffer gnus-summary-buffer (gnus-summary-followup (list (list article)))) (setq contents (buffer-substring (point) (mark t))) @@ -6730,16 +6647,16 @@ positives are possible." (gnus-button-url-regexp 0 (>= gnus-button-browse-level 0) browse-url 0) ;; man pages - ("\\b\\([a-z][a-z]+\\)([1-9])\\W" + ("\\b\\([a-z][a-z]+([1-9])\\)\\W" 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) gnus-button-handle-man 1) ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x) - ("\\b\\([a-z][-_.a-z0-9]+\\)([1-9])\\W" + ("\\b\\([a-z][-_.a-z0-9]+([1-9])\\)\\W" 0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5)) gnus-button-handle-man 1) ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm), ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7) - ("\\b\\([a-z][-+_.:a-z0-9]+\\)([1-9][X1a-z]*)\\W\\|\\b\\(X\\)([1-9])\\W" + ("\\b\\(\\(?:[a-z][-+_.:a-z0-9]+([1-9][X1a-z]*)\\)\\|\\b\\(?:X([1-9])\\)\\)\\W" 0 (>= gnus-button-man-level 5) gnus-button-handle-man 1) ;; MID or mail: To avoid too many false positives we don't try to catch ;; all kind of allowed MIDs or mail addresses. Domain part must contain @@ -7144,6 +7061,10 @@ specified by `gnus-button-alist'." (defun gnus-button-handle-man (url) "Fetch a man page." + (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url) + (when (eq gnus-button-man-handler 'woman) + (setq url (gnus-replace-in-string url "([1-9][X1a-z]*).*\\'" ""))) + (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url) (funcall gnus-button-man-handler url)) (defun gnus-button-handle-info-url (url)