diff options
Diffstat (limited to 'lisp/gnus')
51 files changed, 1506 insertions, 705 deletions
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 993bbbb2475..a294b4c42e2 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,27 +1,322 @@ +2014-08-06 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-summary-expire-articles): Revert. + +2014-08-05 Eric Abrahamsen <eric@ericabrahamsen.net> + + * gnus-sum.el (gnus-summary-expire-articles): Functions registered to + the gnus-summary-article-expire-hook should be told where the function + is going. In particular, the Gnus registry might want to know. + +2014-07-31 Tassilo Horn <tsdh@gnu.org> + + * gnus-msg.el (gnus-inews-insert-gcc): Allow `gcc-self' to be a list of + groups and t. + +2014-07-22 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-utils.el (gnus-recursive-directory-files): + Unify hard or symbolic links (bug#18063). + +2013-07-17 Albert Krewinkel <albert@zeitkraut.de> + + * gnus-msg.el (gnus-configure-posting-style): + Allow string replacements in values when matching against a header. + +2014-07-07 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-dribble-read-file): Don't stop the auto-saving of + the dribble buffer even when it is shrunk a lot. + <http://thread.gmane.org/gmane.emacs.gnus.user/16923> + 2014-06-26 Glenn Morris <rgm@gnu.org> * mm-util.el (help-function-arglist): Remove outdated declaration. -2014-06-22 Andreas Schwab <schwab@linux-m68k.org> +2014-06-24 Andreas Schwab <schwab@linux-m68k.org> * html2text.el (html2text-get-attr): Rewrite to handle spaces in quoted attribute values. (Bug#17834) -2014-05-28 Andreas Schwab <schwab@linux-m68k.org> +2013-06-22 Dmitry Antipov <dmantipov@yandex.ru> + + * gnus-sum.el (gnus-summary-edit-article-done): + Prefer point-marker to copy-marker of point. + +2014-06-05 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-edit-part): Don't modifiy markers. + (gnus-article-read-summary-keys): + Don't bug out when there is no article in the summary buffer. + (gnus-mime-buttonize-attachments-in-header): + Improve criterion that finds parts to display. + + * gnus-art.el (gnus-mm-display-part): + * mm-decode.el (mm-shr): + * mm-view.el (mm-inline-text-html-render-with-w3m, mm-inline-text) + (mm-insert-inline): Revert last changes. + +2014-06-05 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mm-display-part): + * mm-decode.el (mm-shr): + * mm-view.el (mm-inline-text-html-render-with-w3m, mm-inline-text) + (mm-insert-inline): Set insertion type of end-marker, not only + start-marker, of undisplayer so as to stay after inserted text. + +2014-06-02 Andreas Schwab <schwab@linux-m68k.org> * html2text.el (html2text-get-attr): Fix typo when splitting value from attribute. (Bug#17613) -2014-05-06 Glenn Morris <rgm@gnu.org> +2014-05-29 Stefan Monnier <monnier@iro.umontreal.ca> + + * mm-view.el (mm-display-inline-fontify): Use font-lock-ensure. + * gnus-cite.el (gnus-message-citation-mode): Use font-lock-flush. + +2014-05-15 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-inline-part, gnus-mm-display-part): + Don't delete next part button; keep spacing between buttons. + +2014-05-14 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-inline-part, gnus-mm-display-part): + Work for the last MIME part in an article. + (gnus-mime-display-single): Suppress excessive newlines between parts. + + * mm-uu.el (mm-uu-dissect): Assume that separators may be accompanied + by leading or trailing newline. + +2014-05-09 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mm-display-part): Don't put article out of sight + while prompting a user for a file name, etc. + (gnus-mime-display-single): Display part with a common appearance no + matter whether MIME button is omitted or not; don't add duplicate entry + to gnus-article-mime-handle-alist. + (gnus-mime-buttonize-attachments-in-header): Use copied buttons. + +2014-05-08 Adam Sjøgren <asjo@koldfront.dk> + + * mml2015.el (mml2015-display-key-image): New variable. + +2014-05-08 Glenn Morris <rgm@gnu.org> * gnus-fun.el (gnus-grab-cam-face): Do not use predictable temp-file name. (http://bugs.debian.org/747100) This is CVE-2014-3421. -2014-05-01 Glenn Morris <rgm@gnu.org> +2014-05-04 Glenn Morris <rgm@gnu.org> * gnus-registry.el (gnus-registry-install-p): Doc fix. +2014-05-02 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-inline-part): Redisplay a button so as to show + the displaying state of a part. + (gnus-mm-display-part): Don't insert a newline in the beginning of + a part like gnus-mime-inline-part doesn't; work for XEmacs. + + * mm-decode.el (mm-display-part): Don't insert a newline in the top. + (mm-shr): Make undisplayer unbreakable. + + * mm-view.el (mm-inline-image-emacs, mm-inline-image-xemacs): + Don't insert excessive newline. + (mm-inline-text-html-render-with-w3m, mm-inline-text) + (mm-insert-inline): Make undisplayer unbreakable. + +2014-05-01 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mm-display-part): + Highlight header attachment buttons. + +2014-04-30 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mm-display-part): Don't move point while toggling + a part; redisplay a button (enbugged in 2014-03-23). + +2014-04-27 Teodor Zlatanov <tzz@lifelogs.com> + + * auth-source.el (auth-source-search, auth-source-search-backends): + Treat :max 0 as an indicator that a boolean return is wanted, as + documented. Reported by Joe Bloggs. + +2014-04-20 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-icalendar.el: Require gnus-art. + +2014-04-20 Jan Tatarik <jan.tatarik@gmail.com> + + * gnus-icalendar.el (gnus-icalendar-event->org-entry) + (gnus-icalendar--update-org-event): put event timestamp in + the org entry body instead of the drawer. + (gnus-icalendar-event--get-attendee-names): list of participants should + contain even attendees without common name attribute. + (gnus-icalendar--update-org-event): don't generate duplicates of empty + property tags in org drawers. + +2014-04-15 Katsumi Yamaoka <yamaoka@jpl.org> + + * gmm-utils.el (gmm-format-time-string): New function. + + * message.el (message-insert-formatted-citation-line): Use the original + author's time zone to express a date string. + +2014-04-06 Stefan Monnier <monnier@iro.umontreal.ca> + + * gnus-srvr.el (gnus-tmp-how, gnus-tmp-name, gnus-tmp-where) + (gnus-tmp-status, gnus-tmp-agent, gnus-tmp-cloud) + (gnus-tmp-news-server, gnus-tmp-news-method, gnus-tmp-user-defined): + Silence compiler warnings. + (gnus-server-insert-server-line): Don't use dyn-bind var as argument. + +2014-03-24 Katsumi Yamaoka <yamaoka@jpl.org> + + * mml.el: Require url when compiling. + + * gnus-cloud.el (gnus-cloud-parse-version-1): + Use plist-get rather than CL's getf. + (gnus-activate-group, gnus-subscribe-group): Declare. + + * gnus-sum.el (gnus-mime-buttonize-attachments-in-header): Declare. + +2014-03-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-sum.el (gnus-summary-toggle-header): Display header attachment + buttons when toggling the header off. + +2014-03-23 Daiki Ueno <ueno@gnu.org> + + * mml2015.el (mml2015-use): Don't check the availability of GnuPG + commands here; instead, only check if epg-config.el is available. + +2014-03-23 Lars Ingebrigtsen <larsi@gnus.org> + + * mml.el (mml-expand-html-into-multipart-related): Allow sending HTML + messages with embedded images. + (mml-generate-mime): Don't bug out if you don't have libxml. + +2014-03-23 Lars Ingebrigtsen <larsi@gnus.org> + + * message.el (message-make-html-message-with-image-files): New command. + +2014-03-23 Lars Ingebrigtsen <larsi@gnus.org> + + * mml.el (mml-insert-mime-headers): Allow `recipient-filename'. + +2014-03-23 David Engster <deng@randomsample.de> + + * auth-source.el (auth-source-netrc-saver): Do not depend on `cl-lib' + to stay compatible with older Emacsen, so replace `cl-loop' with + `loop'. + +2014-03-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-prepare, gnus-article-prepare-display): + Display header attachment buttons by gnus-article-prepare-display + rather than gnus-article-prepare so as to view in mml-preview as well. + +2014-03-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-goto-part): Find a button in the body first. + (gnus-mime-buttonize-attachments-in-header): Number hidden buttons. + +2014-03-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-mime-buttonize-attachments-in-header): + Display buttons that are hidden in unselected alternative part as well. + (gnus-mime-display-alternative): Redraw attachment buttons in header. + + * gmm-utils.el (gmm-labels): Add edebug spec. + +2014-03-23 Lars Ingebrigtsen <larsi@gnus.org> + + * gnus-srvr.el (gnus-server-toggle-cloud-server): New command and + keystroke. + (gnus-server-toggle-cloud-server): Only allow clouding applicable + types. + +2014-03-23 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus.el (gnus-copy-overlay, gnus-overlays-at): New functions. + + * gnus-art.el (gnus-mime-display-attachment-buttons-in-header): + New user option. + (gnus-mime-buttonize-attachments-in-header): New function. + (gnus-article-prepare): Use it. + (gnus-mime-inline-part): Suppress extra newline. + (gnus-mm-display-part): Save excursion; + remove useless deleting and adding of buttons. + (gnus-insert-mime-button): Allow insertion in the middle of a line. + + * gnus-sum.el (gnus-summary-wash-mime-map, gnus-summary-article-menu): + Add gnus-mime-buttonize-attachments-in-header. + +2014-03-23 Lars Ingebrigtsen <larsi@gnus.org> + + * nnimap.el (nnimap-request-articles): New command to download several + articles at once. + + * gnus.el (gnus-variable-list): Save Cloud variables. + +2014-03-23 Lars Ingebrigtsen <larsi@gnus.org> + + * gnus-cloud.el: New file to provide the Emacs Cloud. + + * gravatar.el (gravatar-retrieve-synchronously): XEmacs also has + `url-retrieve-synchronously', apparently. + + * gnus-notifications.el (gravatar-retrieve-synchronously): Declare for + XEmacs. + + * nnrss.el (libxml-parse-html-region): Silence compilation error. + +2014-03-23 Daniel Dehennin <daniel.dehennin@baby-gnu.org> + + * gnus-mlspl.el (gnus-group-split-fancy): Use `gnus-parameters' in + `gnus-group-split-fancy'. + +2014-03-23 Lars Ingebrigtsen <larsi@gnus.org> + + * message.el (message-remove-header): Doc fix. + (message-forward-included-headers): New variable. + (message-remove-ignored-headers): Use it. + +2014-03-23 Dave Abrahams <dave@boostpro.com> + + * gnus-sum.el (gnus-summary-open-group-with-article): New command. + +2014-03-23 Rasmus Pank Roulund <emacs@pank.eu> + + * gnus-fun.el (gnus-x-face-omit-files): Regexp to omit matched results + from random face commands. + (gnus-face-directory): Like `gnus-x-face-directory` for png files and + Face. + (gnus-face-omit-files): Like `gnus-x-face-omit-files` for Face. + (gnus--random-face-with-type): Generic function returning a face-type + as a string. + (gnus--insert-random-face-with-type): Generic function inserting a face + in a message buffer header. + (gnus-random-x-face): Rewritten to use `gnus--random-face-with-type`. + (gnus-insert-random-x-face-header): Rewritten to use + `gnus--insert-random-face-with-type`. + (gnus-random-face): Return random (png) Face as string. + (nus-insert-random-face-header): Insert random (png) Face in a message + buffer. + +2014-03-23 Lars Ingebrigtsen <larsi@gnus.org> + + * mm-url.el: Remove all usage of w3. + + * nnrss.el: Ditto. + + * mm-decode.el: Ditto. + + * mm-view.el: Ditto. + + * gnus-setup.el: Remove outdated file. + 2014-03-07 Lars Ingebrigtsen <larsi@gnus.org> * nnimap.el (nnimap-request-accept-article): Make respooling to nnimap diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el index a50ad75063b..2efb16b8611 100644 --- a/lisp/gnus/auth-source.el +++ b/lisp/gnus/auth-source.el @@ -654,9 +654,11 @@ Use `auth-source-delete' in ELisp code instead of calling 'secrets are the only ones supported right now. :max N means to try to return at most N items (defaults to 1). -When 0 the function will return just t or nil to indicate if any -matches were found. More than N items may be returned, depending -on the search and the backend. +More than N items may be returned, depending on the search and +the backend. + +When :max is 0 the function will return just t or nil to indicate +if any matches were found. :host (X Y Z) means to match only hosts X, Y, or Z according to the match rules above. Defaults to t. @@ -757,18 +759,22 @@ must call it to obtain the actual value." (when auth-source-do-cache (auth-source-remember spec found))) - found)) + (if (zerop max) + (not (null found)) + found))) (defun auth-source-search-backends (backends spec max create delete require) - (let (matches) + (let ((max (if (zerop max) 1 max)) ; stop with 1 match if we're asked for zero + matches) (dolist (backend backends) - (when (> max (length matches)) ; when we need more matches... + (when (> max (length matches)) ; if we need more matches... (let* ((bmatches (apply (slot-value backend 'search-function) :backend backend :type (slot-value backend :type) ;; note we're overriding whatever the spec - ;; has for :require, :create, and :delete + ;; has for :max, :require, :create, and :delete + :max max :require require :create create :delete delete @@ -783,6 +789,7 @@ must call it to obtain the actual value." (setq matches (append matches bmatches)))))) matches)) +;; (auth-source-search :max 0) ;; (auth-source-search :max 1) ;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret)) ;; (auth-source-search :host "nonesuch" :type 'netrc :K 1) @@ -1524,10 +1531,10 @@ list, it matches the original pattern." (heads (if (stringp value) (list (list key value)) (mapcar (lambda (v) (list key v)) value)))) - (cl-loop + (loop for h in heads nconc - (cl-loop + (loop for tl in tails collect (append h tl)))))) @@ -1653,6 +1660,7 @@ authentication tokens: ;; (let ((auth-sources '("macos-keychain-internet:/Users/tzz/Library/Keychains/login.keychain"))) (auth-source-search :max 1)) ;; (let ((auth-sources '("macos-keychain-generic:Login"))) (auth-source-search :max 1 :host "git.gnus.org")) +;; (let ((auth-sources '("macos-keychain-generic:Login"))) (auth-source-search :max 1)) (defun* auth-source-macos-keychain-search (&rest spec diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index 8ce29323088..70ef27a7e90 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -441,6 +441,39 @@ rather than relying on `lexical-binding'. `(,(progn (require 'cl) (if (fboundp 'cl-labels) 'cl-labels 'labels)) ,bindings ,@body)) (put 'gmm-labels 'lisp-indent-function 1) +(put 'gmm-labels 'edebug-form-spec '((&rest (sexp sexp &rest form)) &rest form)) + +(defun gmm-format-time-string (format-string &optional time tz) + "Use FORMAT-STRING to format the time TIME, or now if omitted. +The optional TZ specifies the time zone in a number of seconds; any +other non-nil value will be treated as 0. Note that both the format +specifiers `%Z' and `%z' will be replaced with a numeric form. " +;; FIXME: is there a smart way to replace %Z with a time zone name? + (if (and (numberp tz) (not (zerop tz))) + (let ((st 0) + (case-fold-search t) + ls nd rest) + (setq time (if time + (copy-sequence time) + (current-time))) + (if (>= (setq ls (- (cadr time) (car (current-time-zone)) (- tz))) 0) + (setcar (cdr time) ls) + (setcar (cdr time) (+ ls 65536)) + (setcar time (1- (car time)))) + (setq tz (format "%s%02d%02d" + (if (>= tz 0) "+" "-") + (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60))) + (while (string-match "%+z" format-string st) + (if (zerop (% (- (setq nd (match-end 0)) (match-beginning 0)) 2)) + (progn + (push (substring format-string st (- nd 2)) rest) + (push tz rest)) + (push (substring format-string st nd) rest)) + (setq st nd)) + (push (substring format-string st) rest) + (format-time-string (apply 'concat (nreverse rest)) time)) + (format-time-string format-string time tz))) (provide 'gmm-utils) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 29d70aa1a86..b08e523c440 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -24,9 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (defvar tool-bar-map) @@ -4728,7 +4725,10 @@ If ALL-HEADERS is non-nil, no headers are hidden." gnus-article-image-alist nil) (gnus-run-hooks 'gnus-tmp-internal-hook) (when gnus-display-mime-function - (funcall gnus-display-mime-function)))) + (funcall gnus-display-mime-function)) + ;; Add attachment buttons to the header. + (when gnus-mime-display-attachment-buttons-in-header + (gnus-mime-buttonize-attachments-in-header)))) ;;; ;;; Gnus Sticky Article Mode @@ -4987,7 +4987,6 @@ and `gnus-mime-delete-part', and not provided at run-time normally." (gnus-article-edit-article `(lambda () (buffer-disable-undo) - (erase-buffer) (let ((mail-parse-charset (or gnus-article-charset ',gnus-newsgroup-charset)) (mail-parse-ignored-charsets @@ -4995,7 +4994,14 @@ and `gnus-mime-delete-part', and not provided at run-time normally." ',gnus-newsgroup-ignored-charsets)) (mbl mml-buffer-list)) (setq mml-buffer-list nil) - (insert-buffer-substring gnus-original-article-buffer) + ;; A new text must be inserted before deleting existing ones + ;; at the end so as not to move existing markers of which + ;; the insertion type is t. + (delete-region + (point-min) + (prog1 + (goto-char (point-max)) + (insert-buffer-substring gnus-original-article-buffer))) (mime-to-mml ',handles) (setq gnus-article-mime-handles nil) (let ((mbl1 mml-buffer-list)) @@ -5300,12 +5306,26 @@ are decompressed." Compressed files like .gz and .bz2 are decompressed." (interactive (list nil current-prefix-arg)) (gnus-article-check-buffer) - (unless handle - (setq handle (get-text-property (point) 'gnus-data))) - (when handle - (let ((b (point)) - (inhibit-read-only t) - contents charset coding-system) + (let* ((inhibit-read-only t) + (b (point)) + (btn ;; position where the MIME button exists + (if handle + (if (eq handle (get-text-property b 'gnus-data)) + b + (article-goto-body) + (or (text-property-any (point) (point-max) 'gnus-data handle) + (text-property-any (point-min) (point) 'gnus-data handle))) + (setq handle (get-text-property b 'gnus-data)) + b)) + start contents charset coding-system) + (when handle + (when (= b (prog1 + btn + (setq start (next-single-property-change btn 'gnus-data + nil (point-max)) + btn (previous-single-property-change start + 'gnus-data)))) + (setq b btn)) (if (and (not arg) (mm-handle-undisplayer handle)) (mm-remove-part handle) (mm-with-unibyte-buffer @@ -5331,9 +5351,48 @@ Compressed files like .gz and .bz2 are decompressed." (mm-read-coding-system "Charset: ")))) ((mm-handle-undisplayer handle) (mm-remove-part handle))) - (forward-line 2) - (mm-display-inline handle) - (goto-char b))))) + (goto-char start) + (unless (bolp) + ;; This is a header button. + (forward-line 1)) + (mm-display-inline handle)) + ;; Toggle the button appearance between `[button]...' and `[button]'. + (goto-char btn) + (let ((displayed-p (mm-handle-displayed-p handle))) + (gnus-insert-mime-button handle (get-text-property btn 'gnus-part) + (list displayed-p)) + (if (featurep 'emacs) + (delete-region + (point) + (next-single-property-change (point) 'gnus-data nil (point-max))) + (let* ((end (next-single-property-change (point) 'gnus-data)) + (annots (annotations-at (or end (point-max))))) + (delete-region (point) + (if end + (if annots (1+ end) end) + (point-max))) + (dolist (annot annots) + (set-extent-endpoints annot (point) (point))))) + (setq start (point)) + (if (search-backward "\n\n" nil t) + (progn + (goto-char start) + (unless (or displayed-p (eolp)) + ;; Add extra newline. + (insert (propertize (buffer-substring (1- start) start) + 'gnus-undeletable t)))) + ;; We're in the article header. + (delete-char -1) + (dolist (ovl (gnus-overlays-in btn (point))) + (gnus-overlay-put ovl 'gnus-button-attachment-extra t) + (gnus-overlay-put ovl 'face nil)) + (save-restriction + (message-narrow-to-field) + (let ((gnus-treatment-function-alist + '((gnus-treat-highlight-headers + gnus-article-highlight-headers)))) + (gnus-treat-article 'head))))) + (goto-char b)))) (defun gnus-mime-set-charset-parameters (handle charset) "Set CHARSET to parameters in HANDLE. @@ -5635,54 +5694,106 @@ all parts." "Display HANDLE and fix MIME button." (let ((id (get-text-property (point) 'gnus-part)) (point (point)) - (inhibit-read-only t)) - (forward-line 1) - (prog1 - (let ((window (selected-window)) - (mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets - (if (gnus-buffer-live-p gnus-summary-buffer) - (with-current-buffer gnus-summary-buffer - gnus-newsgroup-ignored-charsets) - nil))) - (save-excursion - (unwind-protect - (let ((win (gnus-get-buffer-window (current-buffer) t)) - (beg (point))) - (when win - (select-window win)) - (goto-char point) - (forward-line) - (if (mm-handle-displayed-p handle) - ;; This will remove the part. - (mm-display-part handle) - (save-restriction - (narrow-to-region (point) - (if (eobp) (point) (1+ (point)))) - (gnus-bind-safe-url-regexp (mm-display-part handle)) - ;; We narrow to the part itself and - ;; then call the treatment functions. - (goto-char (point-min)) - (forward-line 1) - (narrow-to-region (point) (point-max)) - (gnus-treat-article - nil id - (gnus-article-mime-total-parts) - (mm-handle-media-type handle))))) - (if (window-live-p window) - (select-window window))))) + (inhibit-read-only t) + (window (selected-window)) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (if (gnus-buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets) + nil)) + start retval) + (unwind-protect + (progn + (let ((win (gnus-get-buffer-window (current-buffer) t))) + (when win + (select-window win) + (goto-char point))) + (setq start (next-single-property-change point 'gnus-data + nil (point-max)) + point (previous-single-property-change start 'gnus-data)) + (if (mm-handle-displayed-p handle) + ;; This will remove the part. + (setq retval (mm-display-part handle)) + (let ((part (or (and (mm-inlinable-p handle) + (mm-inlined-p handle) + t) + (with-temp-buffer + (gnus-bind-safe-url-regexp + (setq retval (mm-display-part handle))) + (unless (zerop (buffer-size)) + (buffer-string)))))) + (goto-char start) + (unless (bolp) + ;; This is a header button. + (forward-line 1)) + (cond ((stringp part) + (save-restriction + (narrow-to-region (point) + (progn + (insert part) + (unless (bolp) (insert "\n")) + (point))) + (gnus-treat-article nil id + (gnus-article-mime-total-parts) + (mm-handle-media-type handle)) + (mm-handle-set-undisplayer + handle + `(lambda () + (let ((inhibit-read-only t)) + (delete-region ,(copy-marker (point-min) t) + ,(point-max-marker))))))) + (part + (mm-display-inline handle)))))) (goto-char point) - (gnus-delete-line) - (gnus-insert-mime-button - handle id (list (mm-handle-displayed-p handle))) - (goto-char point)))) + ;; Toggle the button appearance between `[button]...' and `[button]'. + (let ((displayed-p (mm-handle-displayed-p handle))) + (gnus-insert-mime-button handle id (list displayed-p)) + (if (featurep 'emacs) + (delete-region + (point) + (next-single-property-change (point) 'gnus-data nil (point-max))) + (let* ((end (next-single-property-change (point) 'gnus-data)) + (annots (annotations-at (or end (point-max))))) + (delete-region (point) + (if end + (if annots (1+ end) end) + (point-max))) + (dolist (annot annots) + (set-extent-endpoints annot (point) (point))))) + (setq start (point)) + (if (search-backward "\n\n" nil t) + (progn + (goto-char start) + (unless (or displayed-p (eolp)) + ;; Add extra newline. + (insert (propertize (buffer-substring (1- start) start) + 'gnus-undeletable t)))) + ;; We're in the article header. + (delete-char -1) + (dolist (ovl (gnus-overlays-in point (point))) + (gnus-overlay-put ovl 'gnus-button-attachment-extra t) + (gnus-overlay-put ovl 'face nil)) + (save-restriction + (message-narrow-to-field) + (let ((gnus-treatment-function-alist + '((gnus-treat-highlight-headers + gnus-article-highlight-headers)))) + (gnus-treat-article 'head))))) + (goto-char point) + (if (window-live-p window) + (select-window window))) + retval)) (defun gnus-article-goto-part (n) "Go to MIME part N." (when gnus-break-pages (widen)) + (article-goto-body) (prog1 - (let ((start (text-property-any (point-min) (point-max) 'gnus-part n)) + (let ((start (or (text-property-any (point) (point-max) 'gnus-part n) + ;; There may be header buttons. + (text-property-any (point-min) (point) 'gnus-part n))) part handle end next handles) (when start (goto-char start) @@ -5736,8 +5847,6 @@ all parts." (concat "; " gnus-tmp-name)))) (unless (equal gnus-tmp-description "") (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) - (unless (bolp) - (insert "\n")) (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist @@ -5862,6 +5971,16 @@ If displaying \"text/html\" is discouraged \(see :group 'gnus-article-mime :type 'boolean) +(defcustom gnus-mime-display-attachment-buttons-in-header t + "Add attachment buttons in the end of the header of an article. +Since MIME attachments tend to be put at the end of an article, we may +overlook them if there is a huge body. This option offers you a copy +of all non-inlinable MIME parts as buttons shown in front of an article. +If nil, don't show those extra buttons." + :version "24.5" + :group 'gnus-article-mime + :type 'boolean) + (defun gnus-mime-display-part (handle) (cond ;; Maybe a broken MIME message. @@ -5884,14 +6003,6 @@ If displaying \"text/html\" is discouraged \(see ((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) @@ -5915,7 +6026,6 @@ If displaying \"text/html\" is discouraged \(see (let ((type (mm-handle-media-type handle)) (ignored gnus-ignored-mime-types) (not-attachment t) - (move nil) display text) (catch 'ignored (progn @@ -5941,9 +6051,11 @@ If displaying \"text/html\" is discouraged \(see (setq display t) (when (equal (mm-handle-media-supertype handle) "text") (setq text t))) - (let ((id (1+ (length gnus-article-mime-handle-alist))) + (let ((id (car (rassq handle gnus-article-mime-handle-alist))) beg) - (push (cons id handle) gnus-article-mime-handle-alist) + (unless id + (setq id (1+ (length gnus-article-mime-handle-alist))) + (push (cons id handle) gnus-article-mime-handle-alist)) (when (and display (equal (mm-handle-media-supertype handle) "message")) (insert-char @@ -5955,31 +6067,28 @@ If displaying \"text/html\" is discouraged \(see (not (gnus-unbuttonized-mime-type-p type)) (eq id gnus-mime-buttonized-part-id)) (gnus-insert-mime-button - handle id (list (or display (and not-attachment text)))) - (gnus-article-insert-newline) - ;; Remember modify the number of forward lines. - (setq move t)) + handle id (list (or display (and not-attachment text))))) (setq beg (point)) (cond (display - (when move - (forward-line -1) - (setq beg (point))) (let ((mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets (save-excursion (condition-case () (set-buffer gnus-summary-buffer) (error)) gnus-newsgroup-ignored-charsets))) - (gnus-bind-safe-url-regexp (mm-display-part handle t))) - (goto-char (point-max))) + (gnus-bind-safe-url-regexp (mm-display-part handle t)))) ((and text not-attachment) - (when move - (forward-line -1) - (setq beg (point))) - (gnus-article-insert-newline) - (mm-display-inline handle) - (goto-char (point-max)))) + (mm-display-inline handle))) + (goto-char (point-max)) + (if (string-match "\\`image/" type) + (gnus-article-insert-newline) + (if (prog1 + (= (skip-chars-backward "\n") -1) + (forward-char 1)) + (gnus-article-insert-newline) + (put-text-property (point) (point-max) 'gnus-undeletable t)) + (goto-char (point-max))) ;; Do highlighting. (save-excursion (save-restriction @@ -6110,7 +6219,10 @@ If displaying \"text/html\" is discouraged \(see (goto-char (point-max)) (setcdr begend (point-marker))))) (when ibegend - (goto-char point)))) + (goto-char point))) + ;; Redraw attachment buttons in the header. + (when gnus-mime-display-attachment-buttons-in-header + (gnus-mime-buttonize-attachments-in-header))) (defconst gnus-article-wash-status-strings (let ((alist '((cite "c" "Possible hidden citation text" @@ -6216,6 +6328,116 @@ Provided for backwards compatibility." (when image (gnus-add-image 'shr image)))) +(defun gnus-mime-buttonize-attachments-in-header (&optional interactive) + "Show attachments as buttons in the end of the header of an article. +This function toggles the display when called interactively. Note that +buttons to be added to the header are only the ones that aren't inlined +in the body. Use `gnus-header-face-alist' to highlight buttons." + (interactive (list t)) + (gnus-with-article-buffer + (gmm-labels + ;; Function that returns a flattened version of + ;; `gnus-article-mime-handle-alist'. + ((flattened-alist + (&optional alist id all) + (if alist + (let ((i 1) newid flat) + (dolist (handle alist flat) + (setq newid (append id (list i)) + i (1+ i)) + (if (stringp (car handle)) + (setq flat (nconc flat (flattened-alist (cdr handle) + newid all))) + (delq (rassq handle all) all) + (setq flat (nconc flat (list (cons newid handle))))))) + (let ((flat (list nil))) + ;; Assume that elements of `gnus-article-mime-handle-alist' + ;; are in the decreasing order, but unnumbered subsidiaries + ;; in each element are in the increasing order. + (dolist (handle (reverse gnus-article-mime-handle-alist)) + (if (stringp (cadr handle)) + (setq flat (nconc flat (flattened-alist (cddr handle) + (list (car handle)) + flat))) + (delq (rassq (cdr handle) flat) flat) + (setq flat (nconc flat (list (cons (list (car handle)) + (cdr handle))))))) + (setq flat (cdr flat)) + (mapc (lambda (handle) + (if (cdar handle) + ;; This is a hidden (i.e. unnumbered) handle. + (progn + (setcar handle + (1+ (caar gnus-article-mime-handle-alist))) + (push handle gnus-article-mime-handle-alist)) + (setcar handle (caar handle)))) + flat) + flat)))) + (let ((case-fold-search t) buttons handle type st) + (save-excursion + (save-restriction + (widen) + (article-narrow-to-head) + ;; Header buttons exist? + (while (and (not buttons) + (re-search-forward "^attachments?:[\n ]+" nil t)) + (when (get-char-property (match-end 0) + 'gnus-button-attachment-extra) + (setq buttons (match-beginning 0)))) + (widen) + (when buttons + ;; Delete header buttons. + (delete-region buttons (if (re-search-forward "^[^ ]" nil t) + (match-beginning 0) + (point-max)))) + (unless (and interactive buttons) + ;; Find buttons. + (setq buttons nil) + (dolist (button (flattened-alist)) + (setq handle (cdr button) + type (mm-handle-media-type handle)) + (when (or (and (if (gnus-buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + gnus-inhibit-images) + gnus-inhibit-images) + (string-match "\\`image/" type)) + (mm-inline-override-p handle) + (and (mm-handle-disposition handle) + (not (equal (car (mm-handle-disposition handle)) + "inline")) + (not (mm-attachment-override-p handle))) + (not (mm-automatic-display-p handle)) + (not (or (and (mm-inlinable-p handle) + (mm-inlined-p handle)) + (mm-automatic-external-display-p type)))) + (push button buttons))) + (when buttons + ;; Add header buttons. + (article-goto-body) + (forward-line -1) + (narrow-to-region (point) (point)) + (insert "Attachment" (if (cdr buttons) "s" "") ":") + (dolist (button (nreverse buttons)) + (setq st (point)) + (insert " ") + (mm-handle-set-undisplayer + (setq handle (copy-sequence (cdr button))) nil) + (gnus-insert-mime-button handle (car button)) + (skip-chars-backward "\t\n ") + (delete-region (point) (point-max)) + (when (> (current-column) (window-width)) + (goto-char st) + (insert "\n") + (end-of-line))) + (insert "\n") + (dolist (ovl (gnus-overlays-in (point-min) (point))) + (gnus-overlay-put ovl 'gnus-button-attachment-extra t) + (gnus-overlay-put ovl 'face nil)) + (let ((gnus-treatment-function-alist + '((gnus-treat-highlight-headers + gnus-article-highlight-headers)))) + (gnus-treat-article 'head)))))))))) + ;;; Article savers. (defun gnus-output-to-file (file-name) @@ -6584,7 +6806,7 @@ not have a face in `gnus-article-boring-faces'." (when (eq obuf (current-buffer)) (set-buffer in-buffer) t)) - (setq selected (gnus-summary-select-article)) + (setq selected (ignore-errors (gnus-summary-select-article))) (set-buffer obuf) (unless not-restore-window (set-window-configuration owin)) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index d58acbd18ca..544d6672a8c 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -24,10 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'gnus) diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index db6a0f63e38..5a6d6f8f243 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -1204,7 +1204,8 @@ When enabled, it automatically turns on `font-lock-mode'." nil ;; init-value "" ;; lighter nil ;; keymap - (when (eq major-mode 'message-mode) + (when (eq major-mode 'message-mode) ;FIXME: Use derived-mode-p. + ;; FIXME: Use font-lock-add-keywords! (let ((defaults (car (if (featurep 'xemacs) (get 'message-mode 'font-lock-defaults) font-lock-defaults))) @@ -1233,8 +1234,10 @@ When enabled, it automatically turns on `font-lock-mode'." font-lock-keywords nil)) (setq font-lock-set-defaults nil)) (font-lock-set-defaults) - (cond ((symbol-value 'font-lock-mode) - (font-lock-fontify-buffer)) + (cond (font-lock-mode + (if (fboundp 'font-lock-flush) + (font-lock-flush) + (font-lock-fontify-buffer))) (gnus-message-citation-mode (font-lock-mode 1))))) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el new file mode 100644 index 00000000000..c47976bdcfa --- /dev/null +++ b/lisp/gnus/gnus-cloud.el @@ -0,0 +1,332 @@ +;;; gnus-cloud.el --- storing and retrieving data via IMAP + +;; Copyright (C) 2014 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'parse-time) +(require 'nnimap) + +(defgroup gnus-cloud nil + "Syncing Gnus data via IMAP." + :group 'gnus) + +(defcustom gnus-cloud-synced-files + '(;;"~/.authinfo" + "~/.authinfo.gpg" + "~/.gnus.el" + (:directory "~/News" :match ".*.SCORE\\'")) + "List of file regexps that should be kept up-to-date via the cloud." + :group 'gnus-cloud + :type '(repeat regexp)) + +(defvar gnus-cloud-group-name "*Emacs Cloud*") +(defvar gnus-cloud-covered-servers nil) + +(defvar gnus-cloud-version 1) +(defvar gnus-cloud-sequence 1) + +(defvar gnus-cloud-method nil + "The IMAP select method used to store the cloud data.") + +(defun gnus-cloud-make-chunk (elems) + (with-temp-buffer + (insert (format "Version %s\n" gnus-cloud-version)) + (insert (gnus-cloud-insert-data elems)) + (buffer-string))) + +(defun gnus-cloud-insert-data (elems) + (mm-with-unibyte-buffer + (dolist (elem elems) + (cond + ((eq (plist-get elem :type) :file) + (let (length data) + (mm-with-unibyte-buffer + (insert-file-contents-literally (plist-get elem :file-name)) + (setq length (buffer-size) + data (buffer-string))) + (insert (format "(:type :file :file-name %S :timestamp %S :length %d)\n" + (plist-get elem :file-name) + (plist-get elem :timestamp) + length)) + (insert data) + (insert "\n"))) + ((eq (plist-get elem :type) :data) + (insert (format "(:type :data :name %S :length %d)\n" + (plist-get elem :name) + (with-current-buffer (plist-get elem :buffer) + (buffer-size)))) + (insert-buffer-substring (plist-get elem :buffer)) + (insert "\n")) + ((eq (plist-get elem :type) :delete) + (insert (format "(:type :delete :file-name %S)\n" + (plist-get elem :file-name)))))) + (gnus-cloud-encode-data) + (buffer-string))) + +(defun gnus-cloud-encode-data () + (call-process-region (point-min) (point-max) "gzip" + t (current-buffer) nil + "-c") + (base64-encode-region (point-min) (point-max))) + +(defun gnus-cloud-decode-data () + (base64-decode-region (point-min) (point-max)) + (call-process-region (point-min) (point-max) "gunzip" + t (current-buffer) nil + "-c")) + +(defun gnus-cloud-parse-chunk () + (save-excursion + (goto-char (point-min)) + (unless (looking-at "Version \\([0-9]+\\)") + (error "Not a valid Cloud chunk in the current buffer")) + (forward-line 1) + (let ((version (string-to-number (match-string 1))) + (data (buffer-substring (point) (point-max)))) + (mm-with-unibyte-buffer + (insert data) + (cond + ((= version 1) + (gnus-cloud-decode-data) + (goto-char (point-min)) + (gnus-cloud-parse-version-1)) + (t + (error "Unsupported Cloud chunk version %s" version))))))) + +(defun gnus-cloud-parse-version-1 () + (let ((elems nil)) + (while (not (eobp)) + (while (and (not (eobp)) + (not (looking-at "(:type"))) + (forward-line 1)) + (unless (eobp) + (let ((spec (ignore-errors (read (current-buffer)))) + length) + (when (and (consp spec) + (memq (plist-get spec :type) '(:file :data :deleta))) + (setq length (plist-get spec :length)) + (push (append spec + (list + :contents (buffer-substring (1+ (point)) + (+ (point) 1 length)))) + elems) + (goto-char (+ (point) 1 length)))))) + (nreverse elems))) + +(defun gnus-cloud-update-data (elems) + (dolist (elem elems) + (let ((type (plist-get elem :type))) + (cond + ((eq type :data) + ) + ((eq type :delete) + (gnus-cloud-delete-file (plist-get elem :file-name)) + ) + ((eq type :file) + (gnus-cloud-update-file elem)) + (t + (message "Unknown type %s; ignoring" type)))))) + +(defun gnus-cloud-update-file (elem) + (let ((file-name (plist-get elem :file-name)) + (date (plist-get elem :timestamp)) + (contents (plist-get elem :contents))) + (unless (gnus-cloud-file-covered-p file-name) + (message "%s isn't covered by the cloud; ignoring" file-name)) + (when (or (not (file-exists-p file-name)) + (and (file-exists-p file-name) + (mm-with-unibyte-buffer + (insert-file-contents-literally file-name) + (not (equal (buffer-string) contents))))) + (gnus-cloud-replace-file file-name date contents)))) + +(defun gnus-cloud-replace-file (file-name date new-contents) + (mm-with-unibyte-buffer + (insert new-contents) + (when (file-exists-p file-name) + (rename-file file-name (car (find-backup-file-name file-name)))) + (write-region (point-min) (point-max) file-name) + (set-file-times file-name (parse-iso8601-time-string date)))) + +(defun gnus-cloud-delete-file (file-name) + (unless (gnus-cloud-file-covered-p file-name) + (message "%s isn't covered by the cloud; ignoring" file-name)) + (when (file-exists-p file-name) + (rename-file file-name (car (find-backup-file-name file-name))))) + +(defun gnus-cloud-file-covered-p (file-name) + (let ((matched nil)) + (dolist (elem gnus-cloud-synced-files) + (cond + ((stringp elem) + (when (equal elem file-name) + (setq matched t))) + ((consp elem) + (when (and (equal (directory-file-name (plist-get elem :directory)) + (directory-file-name (file-name-directory file-name))) + (string-match (plist-get elem :match) + (file-name-nondirectory file-name))) + (setq matched t))))) + matched)) + +(defun gnus-cloud-all-files () + (let ((files nil)) + (dolist (elem gnus-cloud-synced-files) + (cond + ((stringp elem) + (push elem files)) + ((consp elem) + (dolist (file (directory-files (plist-get elem :directory) + nil + (plist-get elem :match))) + (push (format "%s/%s" + (directory-file-name (plist-get elem :directory)) + file) + files))))) + (nreverse files))) + +(defvar gnus-cloud-file-timestamps nil) + +(defun gnus-cloud-files-to-upload (&optional full) + (let ((files nil) + timestamp) + (dolist (file (gnus-cloud-all-files)) + (if (file-exists-p file) + (when (setq timestamp (gnus-cloud-file-new-p file full)) + (push `(:type :file :file-name ,file :timestamp ,timestamp) files)) + (when (assoc file gnus-cloud-file-timestamps) + (push `(:type :delete :file-name ,file) files)))) + (nreverse files))) + +(defun gnus-cloud-file-new-p (file full) + (let ((timestamp (format-time-string + "%FT%T%z" (nth 5 (file-attributes file)))) + (old (cadr (assoc file gnus-cloud-file-timestamps)))) + (when (or full + (null old) + (string< old timestamp)) + timestamp))) + +(declare-function gnus-activate-group "gnus-start" + (group &optional scan dont-check method dont-sub-check)) +(declare-function gnus-subscribe-group "gnus-start" + (group &optional previous method)) + +(defun gnus-cloud-ensure-cloud-group () + (let ((method (if (stringp gnus-cloud-method) + (gnus-server-to-method gnus-cloud-method) + gnus-cloud-method))) + (unless (or (gnus-active gnus-cloud-group-name) + (gnus-activate-group gnus-cloud-group-name nil nil + gnus-cloud-method)) + (and (gnus-request-create-group gnus-cloud-group-name gnus-cloud-method) + (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method) + (gnus-subscribe-group gnus-cloud-group-name))))) + +(defun gnus-cloud-upload-data (&optional full) + (gnus-cloud-ensure-cloud-group) + (with-temp-buffer + (let ((elems (gnus-cloud-files-to-upload full))) + (insert (format "Subject: (sequence: %d type: %s)\n" + gnus-cloud-sequence + (if full :full :partial))) + (insert "From: nobody@invalid.com\n") + (insert "\n") + (insert (gnus-cloud-make-chunk elems)) + (when (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method + t t) + (setq gnus-cloud-sequence (1+ gnus-cloud-sequence)) + (gnus-cloud-add-timestamps elems))))) + +(defun gnus-cloud-add-timestamps (elems) + (dolist (elem elems) + (let* ((file-name (plist-get elem :file-name)) + (old (assoc file-name gnus-cloud-file-timestamps))) + (when old + (setq gnus-cloud-file-timestamps + (delq old gnus-cloud-file-timestamps))) + (push (list file-name (plist-get elem :timestamp)) + gnus-cloud-file-timestamps)))) + +(defun gnus-cloud-available-chunks () + (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method) + (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)) + (active (gnus-active group)) + headers head) + (when (gnus-retrieve-headers (gnus-uncompress-range active) group) + (with-current-buffer nntp-server-buffer + (goto-char (point-min)) + (while (and (not (eobp)) + (setq head (nnheader-parse-head))) + (push head headers)))) + (sort (nreverse headers) + (lambda (h1 h2) + (> (gnus-cloud-chunk-sequence (mail-header-subject h1)) + (gnus-cloud-chunk-sequence (mail-header-subject h2))))))) + +(defun gnus-cloud-chunk-sequence (string) + (if (string-match "sequence: \\([0-9]+\\)" string) + (string-to-number (match-string 1 string)) + 0)) + +(defun gnus-cloud-prune-old-chunks (headers) + (let ((headers (reverse headers)) + (found nil)) + (while (and headers + (not found)) + (when (string-match "type: :full" (mail-header-subject (car headers))) + (setq found t)) + (pop headers)) + ;; All the chunks that are older than the newest :full chunk can be + ;; deleted. + (when headers + (gnus-request-expire-articles + (mapcar (lambda (h) + (mail-header-number h)) + (nreverse headers)) + (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))))) + +(defun gnus-cloud-download-data () + (let ((articles nil) + chunks) + (dolist (header (gnus-cloud-available-chunks)) + (when (> (gnus-cloud-chunk-sequence (mail-header-subject header)) + gnus-cloud-sequence) + (push (mail-header-number header) articles))) + (when articles + (nnimap-request-articles (nreverse articles) gnus-cloud-group-name) + (with-current-buffer nntp-server-buffer + (goto-char (point-min)) + (while (re-search-forward "^Version " nil t) + (beginning-of-line) + (push (gnus-cloud-parse-chunk) chunks) + (forward-line 1)))))) + +(defun gnus-cloud-server-p (server) + (member server gnus-cloud-covered-servers)) + +(provide 'gnus-cloud) + +;;; gnus-cloud.el ends here diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index 28c6a4d3312..e0d1578f49a 100644 --- a/lisp/gnus/gnus-fun.el +++ b/lisp/gnus/gnus-fun.el @@ -24,10 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) @@ -44,6 +40,24 @@ :group 'gnus-fun :type 'directory) +(defcustom gnus-x-face-omit-files nil + "Regexp to match faces in `gnus-x-face-directory' to be omitted." + :version "24.5" + :group 'gnus-fun + :type 'string) + +(defcustom gnus-face-directory (expand-file-name "faces" gnus-directory) + "*Directory where Face PNG files are stored." + :version "24.5" + :group 'gnus-fun + :type 'directory) + +(defcustom gnus-face-omit-files nil + "Regexp to match faces in `gnus-face-directory' to be omitted." + :version "24.5" + :group 'gnus-fun + :type 'string) + (defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface" "Command for converting a PBM to an X-Face." :version "22.1" @@ -86,35 +100,57 @@ PNG format." nil shell-command-switch command))) ;;;###autoload -(defun gnus-random-x-face () - "Return X-Face header data chosen randomly from `gnus-x-face-directory'." - (interactive) - (when (file-exists-p gnus-x-face-directory) - (let* ((files (directory-files gnus-x-face-directory t "\\.pbm$")) - (file (nth (random (length files)) files))) +(defun gnus--random-face-with-type (dir ext omit fun) + "Return file from DIR with extension EXT, omitting matches of OMIT, processed by FUN." + (when (file-exists-p dir) + (let* ((files + (remove nil (mapcar + (lambda (f) (unless (string-match (or omit "^$") f) f)) + (directory-files dir t ext)))) + (file (nth (random (length files)) files))) (when file - (gnus-shell-command-to-string - (format gnus-convert-pbm-to-x-face-command - (shell-quote-argument file))))))) + (funcall fun file))))) +;;;###autoload (autoload 'message-goto-eoh "message" nil t) +(autoload 'message-insert-header "message" nil t) + +(defun gnus--insert-random-face-with-type (fun type) + "Get a random face using FUN and insert it as a header TYPE. + +For instance, to insert an X-Face use `gnus-random-x-face' as FUN + and \"X-Face\" as TYPE." + (let ((data (funcall fun))) + (save-excursion + (if data + (progn (message-goto-eoh) + (insert type ": " data "\n")) + (message + "No face returned by the function %s." (symbol-name fun)))))) + + + +;;;###autoload +(defun gnus-random-x-face () + "Return X-Face header data chosen randomly from `gnus-x-face-directory'. + +Files matching `gnus-x-face-omit-files' are not considered." + (interactive) + (gnus--random-face-with-type gnus-x-face-directory "\\.pbm$" gnus-x-face-omit-files + (lambda (file) + (gnus-shell-command-to-string + (format gnus-convert-pbm-to-x-face-command + (shell-quote-argument file)))))) ;;;###autoload (defun gnus-insert-random-x-face-header () "Insert a random X-Face header from `gnus-x-face-directory'." (interactive) - (let ((data (gnus-random-x-face))) - (save-excursion - (message-goto-eoh) - (if data - (insert "X-Face: " data) - (message - "No face returned by `gnus-random-x-face'. Does %s/*.pbm exist?" - gnus-x-face-directory))))) + (gnus--insert-random-face-with-type 'gnus-random-x-face 'X-Face)) ;;;###autoload (defun gnus-x-face-from-file (file) - "Insert an X-Face header based on an image file. + "Insert an X-Face header based on an image FILE. Depending on `gnus-convert-image-to-x-face-command' it may accept different input formats." @@ -126,7 +162,7 @@ different input formats." ;;;###autoload (defun gnus-face-from-file (file) - "Return a Face header based on an image file. + "Return a Face header based on an image FILE. Depending on `gnus-convert-image-to-face-command' it may accept different input formats." @@ -191,6 +227,21 @@ FILE should be a PNG file that's 48x48 and smaller than or equal to (buffer-size))) (gnus-face-encode))) +;;;###autoload +(defun gnus-random-face () + "Return randomly chosen Face from `gnus-face-directory'. + +Files matching `gnus-face-omit-files' are not considered." + (interactive) + (gnus--random-face-with-type gnus-face-directory "\\.png$" + gnus-face-omit-files + 'gnus-convert-png-to-face)) + +;;;###autoload +(defun gnus-insert-random-face-header () + "Insert a randome Face header from `gnus-face-directory'." + (gnus--insert-random-face-with-type 'gnus-random-face 'Face)) + (defface gnus-x-face '((t (:foreground "black" :background "white"))) "Face to show X-Face. The colors from this face are used as the foreground and background diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index d8260b40434..31078be48aa 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -24,10 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (defvar tool-bar-mode) diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index 90947fe4d8c..540694f34fb 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -28,10 +28,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'gnus-art) diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index 79f1e2fe203..9027c53a6f3 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -38,6 +38,7 @@ (require 'gmm-utils) (require 'mm-decode) (require 'gnus-sum) +(require 'gnus-art) (eval-when-compile (require 'cl)) @@ -170,7 +171,9 @@ (caddr event)))) (gmm-labels ((attendee-role (prop) (plist-get (cadr prop) 'ROLE)) - (attendee-name (prop) (plist-get (cadr prop) 'CN)) + (attendee-name (prop) + (or (plist-get (cadr prop) 'CN) + (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop)))) (attendees-by-type (type) (gnus-remove-if-not (lambda (p) (string= (attendee-role p) type)) @@ -452,7 +455,6 @@ Return nil for non-recurring EVENT." "Not replied yet")) (props `(("ICAL_EVENT" . "t") ("ID" . ,uid) - ("DT" . ,(gnus-icalendar-event:org-timestamp event)) ("ORGANIZER" . ,(gnus-icalendar-event:organizer event)) ("LOCATION" . ,(gnus-icalendar-event:location event)) ("PARTICIPATION_TYPE" . ,(symbol-name (gnus-icalendar-event:participation-type event))) @@ -470,7 +472,9 @@ Return nil for non-recurring EVENT." (when description (save-restriction (narrow-to-region (point) (point)) - (insert description) + (insert (gnus-icalendar-event:org-timestamp event) + "\n\n" + description) (indent-region (point-min) (point-max) 2) (fill-region (point-min) (point-max)))) @@ -551,20 +555,31 @@ is searched." (when description (save-restriction (narrow-to-region (point) (point)) - (insert "\n" (replace-regexp-in-string "[\n]+$" "\n" description) "\n") + (insert "\n" + (gnus-icalendar-event:org-timestamp event) + "\n\n" + (replace-regexp-in-string "[\n]+$" "\n" description) + "\n") (indent-region (point-min) (point-max) (1+ entry-outline-level)) (fill-region (point-min) (point-max)))) ;; update entry properties - (org-entry-put event-pos "DT" (gnus-icalendar-event:org-timestamp event)) - (org-entry-put event-pos "ORGANIZER" organizer) - (org-entry-put event-pos "LOCATION" location) - (org-entry-put event-pos "PARTICIPATION_TYPE" (symbol-name participation-type)) - (org-entry-put event-pos "REQ_PARTICIPANTS" (gnus-icalendar--format-participant-list req-participants)) - (org-entry-put event-pos "OPT_PARTICIPANTS" (gnus-icalendar--format-participant-list opt-participants)) - (org-entry-put event-pos "RRULE" recur) - (when reply-status (org-entry-put event-pos "REPLY" - (capitalize (symbol-name reply-status)))) + (gmm-labels + ((update-org-entry (position property value) + (if (or (null value) + (string= value "")) + (org-entry-delete position property) + (org-entry-put position property value)))) + + (update-org-entry event-pos "ORGANIZER" organizer) + (update-org-entry event-pos "LOCATION" location) + (update-org-entry event-pos "PARTICIPATION_TYPE" (symbol-name participation-type)) + (update-org-entry event-pos "REQ_PARTICIPANTS" (gnus-icalendar--format-participant-list req-participants)) + (update-org-entry event-pos "OPT_PARTICIPANTS" (gnus-icalendar--format-participant-list opt-participants)) + (update-org-entry event-pos "RRULE" recur) + (update-org-entry event-pos "REPLY" + (if reply-status (capitalize (symbol-name reply-status)) + "Not replied yet"))) (save-buffer))))))))) diff --git a/lisp/gnus/gnus-mlspl.el b/lisp/gnus/gnus-mlspl.el index 8dec6f24217..2d86d0b81ad 100644 --- a/lisp/gnus/gnus-mlspl.el +++ b/lisp/gnus/gnus-mlspl.el @@ -146,20 +146,27 @@ Calling (gnus-group-split-fancy nil nil \"mail.others\") returns: (any \"\\\\(foo@nowhere\\\\.gov\\\\|foo@localhost\\\\|foo-redist@home\\\\)\" - \"bugs-foo\" - \"rambling-foo\" \"mail.foo\")) \"mail.others\")" - (let* ((newsrc (cdr gnus-newsrc-alist)) - split) - (dolist (info newsrc) - (let ((group (gnus-info-group info)) - (params (gnus-info-params info))) - ;; For all GROUPs that match the specified GROUPS - (when (or (not groups) - (and (listp groups) - (memq group groups)) - (and (stringp groups) - (string-match groups group))) - (let ((split-spec (assoc 'split-spec params)) group-clean) - ;; Remove backend from group name - (setq group-clean (string-match ":" group)) + (let ((group-names (if (and (listp groups) + (not (null groups))) + groups + (delete-dups + (delq nil + (mapcar + (lambda (info) + (let ((group (gnus-info-group info))) + (if (or (not groups) + (and (stringp groups) + (string-match groups group))) + group))) + (append gnus-newsrc-alist gnus-parameters)))))) + split) + (dolist (group group-names) + (let ((params (gnus-group-find-parameter group))) + ;; Skip groups without param (or nonexistent) + (when (not (null params)) + (let ((split-spec (assoc 'split-spec params)) group-clean) + ;; Remove backend from group name + (setq group-clean (string-match ":" group)) (setq group-clean (if group-clean (substring group (1+ group-clean)) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index 1c8635c5992..8b9842918da 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -1726,7 +1726,20 @@ this is a reply." (var (or gnus-outgoing-message-group gnus-message-archive-group)) (gcc-self-val (and group (not (gnus-virtual-group-p group)) - (gnus-group-find-parameter group 'gcc-self))) + (gnus-group-find-parameter group 'gcc-self t))) + (gcc-self-get (lambda (gcc-self-val group) + (if (stringp gcc-self-val) + (if (string-match " " gcc-self-val) + (concat "\"" gcc-self-val "\"") + gcc-self-val) + ;; In nndoc groups, we use the parent group name + ;; instead of the current group. + (let ((group (or (gnus-group-find-parameter + gnus-newsgroup-name 'parent-group) + group))) + (if (string-match " " group) + (concat "\"" group "\"") + group))))) result (groups (cond @@ -1777,19 +1790,11 @@ this is a reply." (if gcc-self-val ;; Use the `gcc-self' param value instead. (progn - (insert - (if (stringp gcc-self-val) - (if (string-match " " gcc-self-val) - (concat "\"" gcc-self-val "\"") - gcc-self-val) - ;; In nndoc groups, we use the parent group name - ;; instead of the current group. - (let ((group (or (gnus-group-find-parameter - gnus-newsgroup-name 'parent-group) - group))) - (if (string-match " " group) - (concat "\"" group "\"") - group)))) + (insert (if (listp gcc-self-val) + (mapconcat (lambda (val) + (funcall gcc-self-get val group)) + gcc-self-val ", ") + (funcall gcc-self-get gcc-self-val group))) (if (not (eq gcc-self-val 'none)) (insert "\n") (gnus-delete-line))) @@ -1826,7 +1831,7 @@ this is a reply." (with-current-buffer gnus-summary-buffer gnus-posting-styles) gnus-posting-styles)) - style match attribute value v results + style match attribute value v results matched-string filep name address element) ;; If the group has a posting-style parameter, add it at the end with a ;; regexp matching everything, to be sure it takes precedence over all @@ -1846,7 +1851,9 @@ this is a reply." (when (cond ((stringp match) ;; Regexp string match on the group name. - (string-match match group)) + (when (string-match match group) + (setq matched-string group) + t)) ((eq match 'header) ;; Obsolete format of header match. (and (gnus-buffer-live-p gnus-article-copy) @@ -1875,7 +1882,8 @@ this is a reply." (nnheader-narrow-to-headers) (let ((header (message-fetch-field (nth 1 match)))) (and header - (string-match (nth 2 match) header))))))) + (string-match (nth 2 match) header) + (setq matched-string header))))))) (t ;; This is a form to be evalled. (eval match))))) @@ -1896,10 +1904,11 @@ this is a reply." (setq v (cond ((stringp value) - (if (and (stringp match) + (if (and matched-string (gnus-string-match-p "\\\\[&[:digit:]]" value) (match-beginning 1)) - (gnus-match-substitute-replacement value nil nil group) + (gnus-match-substitute-replacement value nil nil + matched-string) value)) ((or (symbolp value) (functionp value)) diff --git a/lisp/gnus/gnus-notifications.el b/lisp/gnus/gnus-notifications.el index 0621c23c20c..ee1083d8005 100644 --- a/lisp/gnus/gnus-notifications.el +++ b/lisp/gnus/gnus-notifications.el @@ -102,6 +102,9 @@ Return a notification id if any, or t on success." ;; Don't return an id t)) +(declare-function gravatar-retrieve-synchronously "gravatar.el" + (mail-address)) + (defun gnus-notifications-get-photo (mail-address) "Get photo for mail address." (let ((google-photo (when (and gnus-notifications-use-google-contacts diff --git a/lisp/gnus/gnus-picon.el b/lisp/gnus/gnus-picon.el index 83629df1713..05301673a50 100644 --- a/lisp/gnus/gnus-picon.el +++ b/lisp/gnus/gnus-picon.el @@ -37,10 +37,6 @@ ;; ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'gnus) diff --git a/lisp/gnus/gnus-setup.el b/lisp/gnus/gnus-setup.el deleted file mode 100644 index 7ef8dc52530..00000000000 --- a/lisp/gnus/gnus-setup.el +++ /dev/null @@ -1,191 +0,0 @@ -;;; gnus-setup.el --- Initialization & Setup for Gnus 5 - -;; Copyright (C) 1995-1996, 2000-2014 Free Software Foundation, Inc. - -;; Author: Steven L. Baur <steve@miranova.com> -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: -;; My head is starting to spin with all the different mail/news packages. -;; Stop The Madness! - -;; Given that Emacs Lisp byte codes may be diverging, it is probably best -;; not to byte compile this, and just arrange to have the .el loaded out -;; of .emacs. - -;;; Code: - -(eval-when-compile (require 'cl)) - -(defvar gnus-use-installed-gnus t - "*If non-nil use installed version of Gnus.") - -(defvar gnus-use-installed-mailcrypt (featurep 'xemacs) - "*If non-nil use installed version of mailcrypt.") - -(defvar gnus-emacs-lisp-directory (if (featurep 'xemacs) - "/usr/local/lib/xemacs/" - "/usr/local/share/emacs/") - "Directory where Emacs site lisp is located.") - -(defvar gnus-gnus-lisp-directory (concat gnus-emacs-lisp-directory - "gnus/lisp/") - "Directory where Gnus Emacs lisp is found.") - -(defvar gnus-mailcrypt-lisp-directory (concat gnus-emacs-lisp-directory - "site-lisp/mailcrypt/") - "Directory where Mailcrypt Emacs Lisp is found.") - -(defvar gnus-bbdb-lisp-directory (concat gnus-emacs-lisp-directory - "site-lisp/bbdb/") - "Directory where Big Brother Database is found.") - -(defvar gnus-use-mhe nil - "Set this if you want to use MH-E for mail reading.") -(defvar gnus-use-rmail nil - "Set this if you want to use RMAIL for mail reading.") -(defvar gnus-use-sendmail nil - "Set this if you want to use SENDMAIL for mail reading.") -(defvar gnus-use-vm nil - "Set this if you want to use the VM package for mail reading.") -(defvar gnus-use-sc nil - "Set this if you want to use Supercite.") -(defvar gnus-use-mailcrypt t - "Set this if you want to use Mailcrypt for dealing with PGP messages.") -(defvar gnus-use-bbdb nil - "Set this if you want to use the Big Brother DataBase.") - -(when (and (not gnus-use-installed-gnus) - (null (member gnus-gnus-lisp-directory load-path))) - (push gnus-gnus-lisp-directory load-path)) - -;;; We can't do this until we know where Gnus is. -(require 'message) - -;;; Mailcrypt by -;;; Jin Choi <jin@atype.com> -;;; Patrick LoPresti <patl@lcs.mit.edu> - -(when gnus-use-mailcrypt - (when (and (not gnus-use-installed-mailcrypt) - (null (member gnus-mailcrypt-lisp-directory load-path))) - (setq load-path (cons gnus-mailcrypt-lisp-directory load-path))) - (autoload 'mc-install-write-mode "mailcrypt" nil t) - (autoload 'mc-install-read-mode "mailcrypt" nil t) -;;; (add-hook 'message-mode-hook 'mc-install-write-mode) -;;; (add-hook 'gnus-summary-mode-hook 'mc-install-read-mode) - (when gnus-use-mhe - (add-hook 'mh-folder-mode-hook 'mc-install-read-mode) - (add-hook 'mh-letter-mode-hook 'mc-install-write-mode))) - -;;; BBDB by -;;; Jamie Zawinski <jwz@lucid.com> - -(when gnus-use-bbdb - ;; bbdb will never be installed with emacs. - (when (null (member gnus-bbdb-lisp-directory load-path)) - (setq load-path (cons gnus-bbdb-lisp-directory load-path))) - (autoload 'bbdb "bbdb-com" - "Insidious Big Brother Database" t) - (autoload 'bbdb-name "bbdb-com" - "Insidious Big Brother Database" t) - (autoload 'bbdb-company "bbdb-com" - "Insidious Big Brother Database" t) - (autoload 'bbdb-net "bbdb-com" - "Insidious Big Brother Database" t) - (autoload 'bbdb-notes "bbdb-com" - "Insidious Big Brother Database" t) - - (when gnus-use-vm - (autoload 'bbdb-insinuate-vm "bbdb-vm" - "Hook BBDB into VM" t)) - - (when gnus-use-rmail - (autoload 'bbdb-insinuate-rmail "bbdb-rmail" - "Hook BBDB into RMAIL" t) - (add-hook 'rmail-mode-hook 'bbdb-insinuate-rmail)) - - (when gnus-use-mhe - (autoload 'bbdb-insinuate-mh "bbdb-mh" - "Hook BBDB into MH-E" t) - (add-hook 'mh-folder-mode-hook 'bbdb-insinuate-mh)) - - (autoload 'bbdb-insinuate-gnus "bbdb-gnus" - "Hook BBDB into Gnus" t) - (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus) - - (when gnus-use-sendmail - (autoload 'bbdb-insinuate-sendmail "bbdb" - "Insidious Big Brother Database" t) - (add-hook 'mail-setup-hook 'bbdb-insinuate-sendmail) - (add-hook 'message-setup-hook 'bbdb-insinuate-sendmail))) - -(when gnus-use-sc - (add-hook 'mail-citation-hook 'sc-cite-original) - (setq message-cite-function 'sc-cite-original)) - -;;;### (autoloads (gnus gnus-slave gnus-no-server) "gnus" "lisp/gnus.el" (12473 2137)) -;;; Generated autoloads from lisp/gnus.el - -;; Don't redo this if autoloads already exist -(unless (fboundp 'gnus) - (autoload 'gnus-slave-no-server "gnus" "\ -Read network news as a slave without connecting to local server." t nil) - - (autoload 'gnus-no-server "gnus" "\ -Read network news. -If ARG is a positive number, Gnus will use that as the -startup level. If ARG is nil, Gnus will be started at level 2. -If ARG is non-nil and not a positive number, Gnus will -prompt the user for the name of an NNTP server to use. -As opposed to `gnus', this command will not connect to the local server." t nil) - - (autoload 'gnus-slave "gnus" "\ -Read news as a slave." t nil) - - (autoload 'gnus "gnus" "\ -Read network news. -If ARG is non-nil and a positive number, Gnus will use that as the -startup level. If ARG is non-nil and not a positive number, Gnus will -prompt the user for the name of an NNTP server to use." t nil) - -;;;*** - -;;; These have moved out of gnus.el into other files. -;;; FIX FIX FIX: should other things be in gnus-setup? or these not in it? - (autoload 'gnus-update-format "gnus-spec" "\ -Update the format specification near point." t nil) - - (autoload 'gnus-fetch-group "gnus-group" "\ -Start Gnus if necessary and enter GROUP. -Returns whether the fetching was successful or not." t nil) - - (defalias 'gnus-batch-kill 'gnus-batch-score) - - (autoload 'gnus-batch-score "gnus-kill" "\ -Run batched scoring. -Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ... -Newsgroups is a list of strings in Bnews format. If you want to score -the comp hierarchy, you'd say \"comp.all\". If you would not like to -score the alt hierarchy, you'd say \"!alt.all\"." t nil)) - -(provide 'gnus-setup) - -(run-hooks 'gnus-setup-load-hook) - -;;; gnus-setup.el ends here diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el index 54714d503bc..e11ddc4c4f5 100644 --- a/lisp/gnus/gnus-spec.el +++ b/lisp/gnus/gnus-spec.el @@ -24,9 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (defvar gnus-newsrc-file-version) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 319f7a8cbce..083a3d68183 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -45,7 +45,7 @@ :group 'gnus-server :type 'hook) -(defcustom gnus-server-line-format " {%(%h:%w%)} %s%a\n" +(defcustom gnus-server-line-format " {%(%h:%w%)} %s%a%c\n" "Format of server lines. It works along the same lines as a normal formatting string, with some simple extensions. @@ -78,6 +78,16 @@ If nil, a faster, but more primitive, buffer is used instead." ;;; Internal variables. +(defvar gnus-tmp-how) +(defvar gnus-tmp-name) +(defvar gnus-tmp-where) +(defvar gnus-tmp-status) +(defvar gnus-tmp-agent) +(defvar gnus-tmp-cloud) +(defvar gnus-tmp-news-server) +(defvar gnus-tmp-news-method) +(defvar gnus-tmp-user-defined) + (defvar gnus-inserted-opened-servers nil) (defvar gnus-server-line-format-alist @@ -85,7 +95,8 @@ If nil, a faster, but more primitive, buffer is used instead." (?n gnus-tmp-name ?s) (?w gnus-tmp-where ?s) (?s gnus-tmp-status ?s) - (?a gnus-tmp-agent ?s))) + (?a gnus-tmp-agent ?s) + (?c gnus-tmp-cloud ?s))) (defvar gnus-server-mode-line-format-alist `((?S gnus-tmp-news-server ?s) @@ -127,6 +138,7 @@ If nil, a faster, but more primitive, buffer is used instead." ["Close" gnus-server-close-server t] ["Offline" gnus-server-offline-server t] ["Deny" gnus-server-deny-server t] + ["Toggle Cloud" gnus-server-toggle-cloud-server t] "---" ["Open All" gnus-server-open-all-servers t] ["Close All" gnus-server-close-all-servers t] @@ -172,6 +184,8 @@ If nil, a faster, but more primitive, buffer is used instead." "z" gnus-server-compact-server + "i" gnus-server-toggle-cloud-server + "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) @@ -185,6 +199,13 @@ If nil, a faster, but more primitive, buffer is used instead." (put 'gnus-server-agent-face 'face-alias 'gnus-server-agent) (put 'gnus-server-agent-face 'obsolete-face "22.1") +(defface gnus-server-cloud + '((((class color) (background light)) (:foreground "ForestGreen" :bold t)) + (((class color) (background dark)) (:foreground "PaleGreen" :bold t)) + (t (:bold t))) + "Face used for displaying AGENTIZED servers" + :group 'gnus-server-visual) + (defface gnus-server-opened '((((class color) (background light)) (:foreground "Green3" :bold t)) (((class color) (background dark)) (:foreground "Green1" :bold t)) @@ -228,6 +249,7 @@ If nil, a faster, but more primitive, buffer is used instead." (defvar gnus-server-font-lock-keywords '(("(\\(agent\\))" 1 'gnus-server-agent) + ("(\\(cloud\\))" 1 'gnus-server-cloud) ("(\\(opened\\))" 1 'gnus-server-opened) ("(\\(closed\\))" 1 'gnus-server-closed) ("(\\(offline\\))" 1 'gnus-server-offline) @@ -264,8 +286,9 @@ The following commands are available: '(gnus-server-font-lock-keywords t))) (gnus-run-mode-hooks 'gnus-server-mode-hook)) -(defun gnus-server-insert-server-line (gnus-tmp-name method) - (let* ((gnus-tmp-how (car method)) +(defun gnus-server-insert-server-line (name method) + (let* ((gnus-tmp-name name) + (gnus-tmp-how (car method)) (gnus-tmp-where (nth 1 method)) (elem (assoc method gnus-opened-servers)) (gnus-tmp-status @@ -282,6 +305,9 @@ The following commands are available: (gnus-tmp-agent (if (and gnus-agent (gnus-agent-method-p method)) " (agent)" + "")) + (gnus-tmp-cloud (if (gnus-cloud-server-p gnus-tmp-name) + " (cloud)" ""))) (beginning-of-line) (gnus-add-text-properties @@ -1084,6 +1110,27 @@ Requesting compaction of %s... (this may take a long time)" (let ((original (get-buffer gnus-original-article-buffer))) (and original (gnus-kill-buffer original)))))) +(defun gnus-server-toggle-cloud-server () + "Make the server under point be replicated in the Emacs Cloud." + (interactive) + (let ((server (gnus-server-server-name))) + (unless server + (error "No server on the current line")) + + (unless (gnus-method-option-p server 'cloud) + (error "The server under point doesn't support cloudiness")) + + (if (gnus-cloud-server-p server) + (setq gnus-cloud-covered-servers + (delete server gnus-cloud-covered-servers)) + (push server gnus-cloud-covered-servers)) + + (gnus-server-update-server server) + (gnus-message 1 (if (gnus-cloud-server-p server) + "Replication of %s in the cloud will start" + "Replication of %s in the cloud will stop") + server))) + (provide 'gnus-srvr) ;;; gnus-srvr.el ends here diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index b9b259e0d18..766e7c26ac4 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -30,6 +30,7 @@ (require 'gnus-spec) (require 'gnus-range) (require 'gnus-util) +(require 'gnus-cloud) (autoload 'message-make-date "message") (autoload 'gnus-agent-read-servers-validate "gnus-agent") (autoload 'gnus-agent-save-local "gnus-agent") @@ -888,6 +889,11 @@ If REGEXP is given, lines that match it will be deleted." (setq buffer-save-without-query t) (erase-buffer) (setq buffer-file-name dribble-file) + ;; The buffer may be shrunk a lot when deleting old entries. + ;; It caused the auto-saving to stop. + (if (featurep 'emacs) + (set (make-local-variable 'auto-save-include-big-deletions) t) + (set (make-local-variable 'disable-auto-save-when-buffer-shrinks) nil)) (auto-save-mode t) (buffer-disable-undo) (bury-buffer (current-buffer)) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index d6c801fdd39..c0e099ba3ca 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -24,9 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (eval-when-compile @@ -2188,6 +2185,7 @@ increase the score of each group you read." (gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map) "w" gnus-article-decode-mime-words "c" gnus-article-decode-charset + "h" gnus-mime-buttonize-attachments-in-header "v" gnus-mime-view-all-parts "b" gnus-article-view-part) @@ -2394,6 +2392,8 @@ increase the score of each group you read." ["QP" gnus-article-de-quoted-unreadable t] ["Base64" gnus-article-de-base64-unreadable t] ["View MIME buttons" gnus-summary-display-buttonized t] + ["View MIME buttons in header" + gnus-mime-buttonize-attachments-in-header t] ["View all" gnus-mime-view-all-parts t] ["Verify and Decrypt" gnus-summary-force-verify-and-decrypt t] ["Encrypt body" gnus-article-encrypt-body @@ -9085,6 +9085,41 @@ non-numeric or nil fetch the number specified by the (gnus-summary-limit-include-thread id))) (gnus-summary-show-thread)) +(defun gnus-summary-open-group-with-article (message-id) + "Open a group containing the article with the given MESSAGE-ID." + (interactive "sMessage-ID: ") + (require 'nndoc) + (with-temp-buffer + ;; Prepare a dummy article + (erase-buffer) + (insert "From nobody Tue Sep 13 22:05:34 2011\n\n") + + ;; Prepare pretty modelines for summary and article buffers + (let ((gnus-summary-mode-line-format "Found %G") + (gnus-article-mode-line-format + ;; Group names just get in the way here, especially the + ;; abbreviated ones + (if (string-match "%[gG]" gnus-article-mode-line-format) + (concat (substring gnus-article-mode-line-format + 0 (match-beginning 0)) + (substring gnus-article-mode-line-format (match-end 0))) + gnus-article-mode-line-format))) + + ;; Build an ephemeral group containing the dummy article (hidden) + (gnus-group-read-ephemeral-group + message-id + `(nndoc ,message-id + (nndoc-address ,(current-buffer)) + (nndoc-article-type mbox)) + :activate + (cons (current-buffer) gnus-current-window-configuration) + (not :request-only) + '(-1) ; :select-articles + (not :parameters) + 0)) ; :number + ;; Fetch the desired article + (gnus-summary-refer-article message-id))) + (defun gnus-summary-refer-article (message-id) "Fetch an article specified by MESSAGE-ID." (interactive "sMessage-ID: ") @@ -9748,6 +9783,8 @@ If ARG is a negative number, turn header display off." (declare-function article-narrow-to-head "gnus-art" ()) (declare-function gnus-article-hidden-text-p "gnus-art" (type)) (declare-function gnus-delete-wash-type "gnus-art" (type)) +(declare-function gnus-mime-buttonize-attachments-in-header + "gnus-art" (&optional interactive)) (defun gnus-summary-toggle-header (&optional arg) "Show the headers if they are hidden, or hide them if they are shown. @@ -9779,7 +9816,10 @@ If ARG is a negative number, hide the unwanted header lines." (gnus-treat-hide-boring-headers nil)) (gnus-delete-wash-type 'headers) (gnus-treat-article 'head)) - (gnus-treat-article 'head)) + (gnus-treat-article 'head) + ;; Add attachment buttons to the header. + (when gnus-mime-display-attachment-buttons-in-header + (gnus-mime-buttonize-attachments-in-header))) (widen) (if window (set-window-start window (goto-char (point-min)))) @@ -10573,7 +10613,7 @@ groups." (let ((lines (count-lines (point) (point-max))) (length (- (point-max) (point))) (case-fold-search t) - (body (copy-marker (point)))) + (body (point-marker))) (goto-char (point-min)) (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t) (delete-region (match-beginning 1) (match-end 1)) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index a3038a1bfe5..fe4d707be2e 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -32,9 +32,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) @@ -1913,17 +1910,25 @@ Sizes are in pixels." image))) image))) +(eval-when-compile (require 'gmm-utils)) (defun gnus-recursive-directory-files (dir) - "Return all regular files below DIR." - (let (files) - (dolist (file (directory-files dir t)) - (when (and (not (member (file-name-nondirectory file) '("." ".."))) - (file-readable-p file)) - (cond - ((file-regular-p file) - (push file files)) - ((file-directory-p file) - (setq files (append (gnus-recursive-directory-files file) files)))))) + "Return all regular files below DIR. +The first found will be returned if a file has hard or symbolic links." + (let (files attr attrs) + (gmm-labels + ((fn (directory) + (dolist (file (directory-files directory t)) + (setq attr (file-attributes (file-truename file))) + (when (and (not (member attr attrs)) + (not (member (file-name-nondirectory file) + '("." ".."))) + (file-readable-p file)) + (push attr attrs) + (cond ((file-regular-p file) + (push file files)) + ((file-directory-p file) + (fn file))))))) + (fn dir)) files)) (defun gnus-list-memq-of-list (elements list) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index b1d60de93d9..206f5a502fc 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -29,10 +29,6 @@ (eval '(run-hooks 'gnus-load-hook)) -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'wid-edit) (require 'mm-util) @@ -309,6 +305,7 @@ be set in `.emacs' instead." (unless (featurep 'gnus-xmas) (defalias 'gnus-make-overlay 'make-overlay) + (defalias 'gnus-copy-overlay 'copy-overlay) (defalias 'gnus-delete-overlay 'delete-overlay) (defalias 'gnus-overlay-get 'overlay-get) (defalias 'gnus-overlay-put 'overlay-put) @@ -316,6 +313,7 @@ be set in `.emacs' instead." (defalias 'gnus-overlay-buffer 'overlay-buffer) (defalias 'gnus-overlay-start 'overlay-start) (defalias 'gnus-overlay-end 'overlay-end) + (defalias 'gnus-overlays-at 'overlays-at) (defalias 'gnus-overlays-in 'overlays-in) (defalias 'gnus-extent-detached-p 'ignore) (defalias 'gnus-extent-start-open 'ignore) @@ -1614,7 +1612,7 @@ slower." :type 'string) (defcustom gnus-valid-select-methods - '(("nntp" post address prompt-address physical-address) + '(("nntp" post address prompt-address physical-address cloud) ("nnspool" post address) ("nnvirtual" post-mail virtual prompt-address) ("nnmbox" mail respool address) @@ -1631,7 +1629,7 @@ slower." ("nnrss" none global) ("nnagent" post-mail) ("nnimap" post-mail address prompt-address physical-address respool - server-marks) + server-marks cloud) ("nnmaildir" mail respool address server-marks) ("nnnil" none)) "*An alist of valid select methods. @@ -2703,7 +2701,10 @@ such as a mark that says whether an article is stored in the cache gnus-newsrc-last-checked-date gnus-newsrc-alist gnus-server-alist gnus-killed-list gnus-zombie-list - gnus-topic-topology gnus-topic-alist) + gnus-topic-topology gnus-topic-alist + gnus-cloud-sequence + gnus-cloud-covered-servers + gnus-cloud-file-timestamps) "Gnus variables saved in the quick startup file.") (defvar gnus-newsrc-alist nil diff --git a/lisp/gnus/gravatar.el b/lisp/gnus/gravatar.el index 650564e2802..ffbc37ae158 100644 --- a/lisp/gnus/gravatar.el +++ b/lisp/gnus/gravatar.el @@ -138,9 +138,7 @@ You can provide a list of argument to pass to CB in CBARGS." "Retrieve MAIL-ADDRESS gravatar and returns it." (let ((url (gravatar-build-url mail-address))) (if (gravatar-cache-expired url) - (with-current-buffer (if (featurep 'xemacs) - (url-retrieve url) - (url-retrieve-synchronously url)) + (with-current-buffer (url-retrieve-synchronously url) (when gravatar-automatic-caching (url-store-in-cache (current-buffer))) (let ((data (gravatar-data->image))) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index d54377fae19..51b9c911545 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -24,10 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (require 'format-spec) (eval-when-compile (require 'cl) diff --git a/lisp/gnus/mailcap.el b/lisp/gnus/mailcap.el index 5515a348b4c..4f1bdf4b1df 100644 --- a/lisp/gnus/mailcap.el +++ b/lisp/gnus/mailcap.el @@ -216,10 +216,6 @@ This is a compatibility function for different Emacsen." (test . (fboundp 'vm-mode)) (type . "message/rfc822")) ("rfc-*822" - (viewer . w3-mode) - (test . (fboundp 'w3-mode)) - (type . "message/rfc822")) - ("rfc-*822" (viewer . view-mode) (type . "message/rfc822"))) ("image" @@ -253,10 +249,6 @@ This is a compatibility function for different Emacsen." ("needsx11"))) ("text" ("plain" - (viewer . w3-mode) - (test . (fboundp 'w3-mode)) - (type . "text/plain")) - ("plain" (viewer . view-mode) (test . (fboundp 'view-mode)) (type . "text/plain")) @@ -267,10 +259,6 @@ This is a compatibility function for different Emacsen." (viewer . enriched-decode) (test . (fboundp 'enriched-decode)) (type . "text/enriched")) - ("html" - (viewer . mm-w3-prepare-buffer) - (test . (fboundp 'w3-prepare-buffer)) - (type . "text/html")) ("dns" (viewer . dns-mode) (test . (fboundp 'dns-mode)) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 5300de5eabb..ca0280c874f 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -28,9 +28,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) @@ -50,6 +47,7 @@ (require 'mml) (require 'rfc822) (require 'format-spec) +(require 'dired) (autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/ @@ -606,7 +604,8 @@ Done before generating the new subject of a forward." regexp)) (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus" - "*All headers that match this regexp will be deleted when forwarding a message." + "*All headers that match this regexp will be deleted when forwarding a message. +This may also be a list of regexps." :version "21.1" :group 'message-forwarding :type '(repeat :value-to-internal (lambda (widget value) @@ -616,6 +615,19 @@ Done before generating the new subject of a forward." (widget-editable-list-match widget value))) regexp)) +(defcustom message-forward-included-headers nil + "If non-nil, delete non-matching headers when forwarding a message. +Only headers that match this regexp will be included. This +variable should be a regexp or a list of regexps." + :version "24.5" + :group 'message-forwarding + :type '(repeat :value-to-internal (lambda (widget value) + (custom-split-regexp-maybe value)) + :match (lambda (widget value) + (or (stringp value) + (widget-editable-list-match widget value))) + regexp)) + (defcustom message-ignored-cited-headers "." "*Delete these headers from the messages you yank." :group 'message-insertion @@ -970,8 +982,8 @@ configuration. See the variable `gnus-cite-attribution-suffix'." (defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:\n" "Format of the \"Whomever writes:\" line. -The string is formatted using `format-spec'. The following -constructs are replaced: +The string is formatted using `format-spec'. The following constructs +are replaced: %f The full From, e.g. \"John Doe <john.doe@example.invalid>\". %n The mail address, e.g. \"john.doe@example.invalid\". @@ -979,11 +991,14 @@ constructs are replaced: back to the mail address. %F The first name if present, e.g.: \"John\". %L The last name if present, e.g.: \"Doe\". + %Z, %z The time zone in the numeric form, e.g.:\"+0000\". All other format specifiers are passed to `format-time-string' -which is called using the date from the article your replying to. -Extracting the first (%F) and last name (%L) is done -heuristically, so you should always check it yourself. +which is called using the date from the article your replying to, but +the date in the formatted string will be expressed in the author's +time zone as much as possible. +Extracting the first (%F) and last name (%L) is done heuristically, +so you should always check it yourself. Please also read the note in the documentation of `message-citation-line-function'." @@ -2451,6 +2466,7 @@ With prefix-argument just set Follow-Up, don't cross-post." "Remove HEADER in the narrowed buffer. If IS-REGEXP, HEADER is a regular expression. If FIRST, only remove the first instance of the header. +If REVERSE, remove headers that doesn't match HEADER. Return the number of headers removed." (goto-char (point-min)) (let ((regexp (if is-regexp header (concat "^" (regexp-quote header) ":"))) @@ -3907,9 +3923,13 @@ This function uses `mail-citation-hook' if that is non-nil." (defvar gnus-extract-address-components) (autoload 'format-spec "format-spec") +(autoload 'gnus-date-get-time "gnus-util") -(defun message-insert-formatted-citation-line (&optional from date) +(defun message-insert-formatted-citation-line (&optional from date tz) "Function that inserts a formatted citation line. +The optional FROM, and DATE are strings containing the contents of +the From header and the Date header respectively. The optional TZ +is a number of seconds, overrides the time zone of DATE. See `message-citation-line-format'." ;; The optional args are for testing/debugging. They will disappear later. @@ -3917,7 +3937,7 @@ See `message-citation-line-format'." ;; (with-temp-buffer ;; (message-insert-formatted-citation-line ;; "John Doe <john.doe@example.invalid>" - ;; (current-time)) + ;; (message-make-date)) ;; (buffer-string)) (when (or message-reply-headers (and from date)) (unless from @@ -3934,28 +3954,43 @@ See `message-citation-line-format'." (net (car (cdr data))) (name-or-net (or (car data) (car (cdr data)) from)) - (replydate - (or - date - ;; We need Gnus functionality if the user wants date or time from - ;; the original article: - (when (string-match "%[^fnNFL]" message-citation-line-format) - (autoload 'gnus-date-get-time "gnus-util") - (gnus-date-get-time (mail-header-date message-reply-headers))))) + (time + (when (string-match "%[^fnNFL]" message-citation-line-format) + (cond ((numberp (car-safe date)) date) ;; backward compatibility + (date (gnus-date-get-time date)) + (t + (gnus-date-get-time + (setq date (mail-header-date message-reply-headers))))))) + (tz (or tz + (when (stringp date) + (nth 8 (parse-time-string date))))) (flist (let ((i ?A) lst) (when (stringp name) ;; Guess first name and last name: - (let* ((names (delq nil (mapcar (lambda (x) - (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'" x) x nil)) - (split-string name "[ \t]+")))) - (count (length names))) - (cond ((= count 1) (setq fname (car names) - lname "")) - ((or (= count 2) (= count 3)) (setq fname (car names) - lname (mapconcat 'identity (cdr names) " "))) - ((> count 3) (setq fname (mapconcat 'identity (butlast names (- count 2)) " ") - lname (mapconcat 'identity (nthcdr 2 names) " "))) ) + (let* ((names (delq + nil + (mapcar + (lambda (x) + (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'" + x) + x + nil)) + (split-string name "[ \t]+")))) + (count (length names))) + (cond ((= count 1) + (setq fname (car names) + lname "")) + ((or (= count 2) (= count 3)) + (setq fname (car names) + lname (mapconcat 'identity (cdr names) " "))) + ((> count 3) + (setq fname (mapconcat 'identity + (butlast names (- count 2)) + " ") + lname (mapconcat 'identity + (nthcdr 2 names) + " ")))) (when (string-match "\\(.*\\),\\'" fname) (let ((newlname (match-string 1 fname))) (setq fname lname lname newlname))))) @@ -3985,7 +4020,7 @@ See `message-citation-line-format'." (>= i ?a))) (push i lst) (push (condition-case nil - (format-time-string (format "%%%c" i) replydate) + (gmm-format-time-string (format "%%%c" i) time tz) (error (format ">%c<" i))) lst)) (setq i (1+ i))) @@ -7374,17 +7409,25 @@ Optional DIGEST will use digest to forward." (message-remove-ignored-headers b e))) (defun message-remove-ignored-headers (b e) - (when message-forward-ignored-headers + (when (or message-forward-ignored-headers + message-forward-included-headers) (save-restriction (narrow-to-region b e) (goto-char b) (narrow-to-region (point) (or (search-forward "\n\n" nil t) (point))) - (let ((ignored (if (stringp message-forward-ignored-headers) - (list message-forward-ignored-headers) - message-forward-ignored-headers))) - (dolist (elem ignored) - (message-remove-header elem t)))))) + (when message-forward-ignored-headers + (let ((ignored (if (stringp message-forward-ignored-headers) + (list message-forward-ignored-headers) + message-forward-ignored-headers))) + (dolist (elem ignored) + (message-remove-header elem t)))) + (when message-forward-included-headers + (message-remove-header + (if (listp message-forward-included-headers) + (regexp-opt message-forward-included-headers) + message-forward-included-headers) + t nil t))))) (defun message-forward-make-body-mime (forward-buffer &optional beg end) (let ((b (point))) @@ -7432,8 +7475,7 @@ Optional DIGEST will use digest to forward." (goto-char (point-max)))) (setq e (point)) (insert "<#/mml>\n") - (when (and (not message-forward-decoded-p) - message-forward-ignored-headers) + (when (not message-forward-decoded-p) (message-remove-ignored-headers b e)))) (defun message-forward-make-body-digest-plain (forward-buffer) @@ -8421,6 +8463,17 @@ Used in `message-simplify-recipients'." (message-fetch-field hdr) t)) ", ")))) +;;; multipart/related and HTML support. + +(defun message-make-html-message-with-image-files (files) + (interactive (list (dired-get-marked-files nil current-prefix-arg))) + (message-mail) + (message-goto-body) + (insert "<#part type=text/html>\n\n") + (dolist (file files) + (insert (format "<img src=%S>\n\n" file))) + (message-goto-to)) + (when (featurep 'xemacs) (require 'messagexmas) (message-xmas-redefine)) diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el index 49724597382..c2f6df9c62a 100644 --- a/lisp/gnus/mm-bodies.el +++ b/lisp/gnus/mm-bodies.el @@ -23,10 +23,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (require 'mm-util) (require 'rfc2047) (require 'mm-encode) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 17c8fb1b8db..cde0af036a5 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -23,10 +23,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (require 'mail-parse) (require 'mm-bodies) (eval-when-compile (require 'cl)) @@ -124,7 +120,6 @@ ((executable-find "w3m") 'gnus-w3m) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) - ((locate-library "w3") 'w3) ((locate-library "html2text") 'html2text) (t nil)) "Render of HTML contents. @@ -136,13 +131,11 @@ The defined renderer types are: `w3m-standalone': use plain w3m; `links': use links; `lynx': use lynx; -`w3': use Emacs/W3; `html2text': use html2text; nil : use external viewer (default web browser)." :version "24.1" :type '(choice (const shr) (const gnus-w3m) - (const w3) (const w3m :tag "emacs-w3m") (const w3m-standalone :tag "standalone w3m" ) (const links) @@ -153,9 +146,9 @@ nil : use external viewer (default web browser)." :group 'mime-display) (defcustom mm-inline-text-html-with-images nil - "If non-nil, Gnus will allow retrieving images in HTML contents with -the <img> tags. It has no effect on Emacs/w3. See also the -documentation for the `mm-w3m-safe-url-regexp' variable." + "If non-nil, Gnus will allow retrieving images in HTML that has <img> tags. +See also the documentation for the `mm-w3m-safe-url-regexp' +variable." :version "22.1" :type 'boolean :group 'mime-display) @@ -828,7 +821,6 @@ external if displayed external." 'inline) ((and (mm-inlinable-p ehandle) (mm-inlined-p ehandle)) - (forward-line 1) (mm-display-inline handle) 'inline) ((or method @@ -1875,7 +1867,7 @@ If RECURSIVE, search recursively." handle `(lambda () (let ((inhibit-read-only t)) - (delete-region ,(point-min-marker) + (delete-region ,(copy-marker (point-min) t) ,(point-max-marker)))))))) (defvar shr-map) diff --git a/lisp/gnus/mm-extern.el b/lisp/gnus/mm-extern.el index 882c8545e59..d574b9d51df 100644 --- a/lisp/gnus/mm-extern.el +++ b/lisp/gnus/mm-extern.el @@ -24,10 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'mm-util) diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el index 4b46ab74f52..bb342d6b8b1 100644 --- a/lisp/gnus/mm-url.el +++ b/lisp/gnus/mm-url.el @@ -21,7 +21,7 @@ ;;; Commentary: -;; Some codes are stolen from w3 and url packages. Some are moved from +;; Some code is stolen from w3 and url packages. Some are moved from ;; nnweb. ;; TODO: Support POST, cookie. @@ -264,8 +264,6 @@ This is taken from RFC 2396.") (require 'url-parse) (require 'url-vars)) (error nil)) - ;; w3-4.0pre0.46 or earlier version. - (require 'w3-vars) (require 'url))) ;;;###autoload diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 6433ec96938..31b7d073fbe 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -23,10 +23,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'mail-prsvr) diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index 423324a86f4..d91d2a41c8f 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -673,22 +673,34 @@ value of `mm-uu-text-plain-type'." (goto-char text-start) (re-search-forward "." start-point t))) (push - (mm-make-handle (mm-uu-copy-to-buffer text-start start-point) - mm-uu-text-plain-type) + (mm-make-handle + (mm-uu-copy-to-buffer + text-start + ;; A start-separator is likely accompanied by + ;; a leading newline. + (if (and (eq (char-before start-point) ?\n) + (eq (char-before (1- start-point)) ?\n)) + (1- start-point) + start-point)) + mm-uu-text-plain-type) result)) (push (funcall (mm-uu-function-extract entry)) result) (goto-char (setq text-start end-point)))) (when result - (if (and (> (point-max) (1+ text-start)) - (save-excursion - (goto-char text-start) - (re-search-forward "." nil t))) - (push - (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max)) - mm-uu-text-plain-type) - result)) + (goto-char text-start) + (when (re-search-forward "." nil t) + (push (mm-make-handle + (mm-uu-copy-to-buffer + ;; An end-separator is likely accompanied by + ;; a trailing newline. + (if (eq (char-after text-start) ?\n) + (1+ text-start) + text-start) + (point-max)) + mm-uu-text-plain-type) + result)) (setq result (cons "multipart/mixed" (nreverse result)))) result))) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index a764fa51c5d..ecfa2ac9582 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -22,9 +22,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (require 'mail-parse) (require 'mailcap) @@ -51,7 +48,6 @@ (defvar mm-text-html-renderer-alist '((shr . mm-shr) - (w3 . mm-inline-text-html-render-with-w3) (w3m . mm-inline-text-html-render-with-w3m) (w3m-standalone . mm-inline-text-html-render-with-w3m-standalone) (gnus-w3m . gnus-article-html) @@ -100,19 +96,19 @@ (- (nth 3 edges) (nth 1 edges))))))) image)) b) - (insert "\n\n") + (insert "\n") (mm-handle-set-undisplayer handle `(lambda () (let ((b ,b) (inhibit-read-only t)) (remove-images b b) - (delete-region b (+ b 2))))))) + (delete-region b (1+ b))))))) (defun mm-inline-image-xemacs (handle) (when (featurep 'xemacs) - (insert "\n\n") - (forward-char -2) + (insert "\n") + (forward-char -1) (let ((annot (make-annotation (mm-get-image handle) nil 'text)) (inhibit-read-only t)) (mm-handle-set-undisplayer @@ -121,7 +117,7 @@ (let ((b ,(point-marker)) (inhibit-read-only t)) (delete-annotation ,annot) - (delete-region (- b 2) b)))) + (delete-region (1- b) b)))) (set-extent-property annot 'mm t) (set-extent-property annot 'duplicable t)))) @@ -130,91 +126,6 @@ (defalias 'mm-inline-image 'mm-inline-image-xemacs) (defalias 'mm-inline-image 'mm-inline-image-emacs))) -;; External. -(declare-function w3-do-setup "ext:w3" ()) -(declare-function w3-region "ext:w3-display" (st nd)) -(declare-function w3-prepare-buffer "ext:w3-display" (&rest args)) - -(defvar mm-w3-setup nil) -(defun mm-setup-w3 () - (unless mm-w3-setup - (require 'w3) - (w3-do-setup) - (require 'url) - (require 'w3-vars) - (require 'url-vars) - (setq mm-w3-setup t))) - -(defun mm-inline-text-html-render-with-w3 (handle) - (mm-setup-w3) - (let ((text (mm-get-part handle)) - (b (point)) - (url-standalone-mode t) - (url-gateway-unplugged t) - (w3-honor-stylesheets nil) - (url-current-object - (url-generic-parse-url (format "cid:%s" (mm-handle-id handle)))) - (width (window-width)) - (charset (mail-content-type-get - (mm-handle-type handle) 'charset))) - (save-excursion - (insert (if charset (mm-decode-string text charset) text)) - (save-restriction - (narrow-to-region b (point)) - (unless charset - (goto-char (point-min)) - (when (or (and (boundp 'w3-meta-content-type-charset-regexp) - (re-search-forward - w3-meta-content-type-charset-regexp nil t)) - (and (boundp 'w3-meta-charset-content-type-regexp) - (re-search-forward - w3-meta-charset-content-type-regexp nil t))) - (setq charset - (let ((bsubstr (buffer-substring-no-properties - (match-beginning 2) - (match-end 2)))) - (if (fboundp 'w3-coding-system-for-mime-charset) - (w3-coding-system-for-mime-charset bsubstr) - (mm-charset-to-coding-system bsubstr nil t)))) - (delete-region (point-min) (point-max)) - (insert (mm-decode-string text charset)))) - (save-window-excursion - (save-restriction - (let ((w3-strict-width width) - ;; Don't let w3 set the global version of - ;; this variable. - (fill-column fill-column)) - (if (or debug-on-error debug-on-quit) - (w3-region (point-min) (point-max)) - (condition-case () - (w3-region (point-min) (point-max)) - (error - (delete-region (point-min) (point-max)) - (let ((b (point)) - (charset (mail-content-type-get - (mm-handle-type handle) 'charset))) - (if (or (eq charset 'gnus-decoded) - (eq mail-parse-charset 'gnus-decoded)) - (save-restriction - (narrow-to-region (point) (point)) - (mm-insert-part handle) - (goto-char (point-max))) - (insert (mm-decode-string (mm-get-part handle) - charset)))) - (message - "Error while rendering html; showing as text/plain"))))))) - (mm-handle-set-undisplayer - handle - `(lambda () - (let ((inhibit-read-only t)) - ,@(if (functionp 'remove-specifier) - '((dolist (prop '(background background-pixmap foreground)) - (remove-specifier - (face-property 'default prop) - (current-buffer))))) - (delete-region ,(point-min-marker) - ,(point-max-marker))))))))) - (defvar mm-w3m-setup nil "Whether gnus-article-mode has been setup to use emacs-w3m.") @@ -306,7 +217,7 @@ handle `(lambda () (let ((inhibit-read-only t)) - (delete-region ,(point-min-marker) + (delete-region ,(copy-marker (point-min) t) ,(point-max-marker))))))))) (defvar mm-w3m-standalone-supports-m17n-p (if (featurep 'mule) 'undecided) @@ -480,7 +391,7 @@ handle `(lambda () (let ((inhibit-read-only t)) - (delete-region ,(point-min-marker) + (delete-region ,(copy-marker (point-min) t) ,(point-max-marker)))))))) (defun mm-insert-inline (handle text) @@ -493,19 +404,12 @@ handle `(lambda () (let ((inhibit-read-only t)) - (delete-region ,(copy-marker b) - ,(copy-marker (point)))))))) + (delete-region ,(copy-marker b t) + ,(point-marker))))))) (defun mm-inline-audio (handle) (message "Not implemented")) -(defun mm-w3-prepare-buffer () - (require 'w3) - (let ((url-standalone-mode t) - (url-gateway-unplugged t) - (w3-honor-stylesheets nil)) - (w3-prepare-buffer))) - (defun mm-view-message () (mm-enable-multibyte) (let (handles) @@ -616,9 +520,11 @@ If MODE is not set, try to find mode automatically." (set-auto-mode))) ;; The mode function might have already turned on font-lock. ;; Do not fontify if the guess mode is fundamental. - (unless (or (symbol-value 'font-lock-mode) + (unless (or font-lock-mode (eq major-mode 'fundamental-mode)) - (font-lock-fontify-buffer)))) + (if (fboundp 'font-lock-ensure) + (font-lock-ensure) + (font-lock-fontify-buffer))))) ;; By default, XEmacs font-lock uses non-duplicable text ;; properties. This code forces all the text properties ;; to be copied along with the text. diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index bd7a50f7184..caa1380a497 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -24,10 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'smime) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 439d7c5dc13..726faeed6a0 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -22,16 +22,13 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (require 'mm-util) (require 'mm-bodies) (require 'mm-encode) (require 'mm-decode) (require 'mml-sec) (eval-when-compile (require 'cl)) +(eval-when-compile (require 'url)) (eval-when-compile (when (featurep 'xemacs) (require 'easy-mmode))) ; for `define-minor-mode' @@ -463,6 +460,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (defvar mml-multipart-number 0) (defvar mml-inhibit-compute-boundary nil) +(declare-function libxml-parse-html-region "xml.c" + (start end &optional base-url)) + (defun mml-generate-mime (&optional multipart-type) "Generate a MIME message based on the current MML document. MULTIPART-TYPE defaults to \"mixed\", but can also @@ -472,19 +472,69 @@ be \"related\" or \"alternate\"." (options message-options)) (if (not cont) nil + (when (and (consp (car cont)) + (= (length cont) 1) + (fboundp 'libxml-parse-html-region) + (equal (cdr (assq 'type (car cont))) "text/html")) + (setq cont (mml-expand-html-into-multipart-related (car cont)))) (prog1 (mm-with-multibyte-buffer (setq message-options options) - (if (and (consp (car cont)) - (= (length cont) 1)) - (mml-generate-mime-1 (car cont)) + (cond + ((and (consp (car cont)) + (= (length cont) 1)) + (mml-generate-mime-1 (car cont))) + ((eq (car cont) 'multipart) + (mml-generate-mime-1 cont)) + (t (mml-generate-mime-1 (nconc (list 'multipart (cons 'type (or multipart-type "mixed"))) - cont))) + cont)))) (setq options message-options) (buffer-string)) (setq message-options options))))) +(defun mml-expand-html-into-multipart-related (cont) + (let ((new-parts nil) + (cid 1)) + (mm-with-multibyte-buffer + (insert (cdr (assq 'contents cont))) + (goto-char (point-min)) + (with-syntax-table mml-syntax-table + (while (re-search-forward "<img\\b" nil t) + (goto-char (match-beginning 0)) + (let* ((start (point)) + (img (nth 2 + (nth 2 + (libxml-parse-html-region + (point) (progn (forward-sexp) (point)))))) + (end (point)) + (parsed (url-generic-parse-url (cdr (assq 'src (cadr img)))))) + (when (and (null (url-type parsed)) + (url-filename parsed) + (file-exists-p (url-filename parsed))) + (goto-char start) + (when (search-forward (url-filename parsed) end t) + (let ((cid (format "fsf.%d" cid))) + (replace-match (concat "cid:" cid) t t) + (push (list cid (url-filename parsed)) new-parts)) + (setq cid (1+ cid))))))) + ;; We have local images that we want to include. + (if (not new-parts) + (list cont) + (setcdr (assq 'contents cont) (buffer-string)) + (setq cont + (nconc (list 'multipart (cons 'type "related")) + (list cont))) + (dolist (new-part (nreverse new-parts)) + (setq cont + (nconc cont + (list `(part (type . "image/png") + (filename . ,(nth 1 new-part)) + (id . ,(concat "<" (nth 0 new-part) + ">"))))))) + cont)))) + (defun mml-generate-mime-1 (cont) (let ((mm-use-ultra-safe-encoding (or mm-use-ultra-safe-encoding (assq 'sign cont)))) diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el index 8c698edb06a..2663107133d 100644 --- a/lisp/gnus/mml1991.el +++ b/lisp/gnus/mml1991.el @@ -26,9 +26,6 @@ ;;; Code: (eval-and-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) - (if (locate-library "password-cache") (require 'password-cache) (require 'password))) diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 9fc8f6e8c0c..74290f45469 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -28,9 +28,6 @@ ;;; Code: (eval-and-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) - (if (locate-library "password-cache") (require 'password-cache) (require 'password))) @@ -51,12 +48,10 @@ ;; Then mml1991 would not need to require mml2015, and mml1991-use ;; could be removed. (defvar mml2015-use (or - (condition-case nil - (progn - (require 'epg-config) - (epg-check-configuration (epg-configuration)) - 'epg) - (error)) + (progn + (ignore-errors (require 'epg-config)) + (and (fboundp 'epg-check-configuration) + 'epg)) (progn (let ((abs-file (locate-library "pgg"))) ;; Don't load PGG if it is marked as obsolete @@ -152,6 +147,12 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." :group 'mime-security :type 'integer) +(defcustom mml2015-display-key-image t + "If t, try to display key images." + :version "24.5" + :group 'mime-security + :type 'boolean) + ;; Extract plaintext from cleartext signature. IMO, this kind of task ;; should be done by GnuPG rather than Elisp, but older PGP backends ;; (such as Mailcrypt, and PGG) discard the output from GnuPG. @@ -903,7 +904,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (defun mml2015-epg-signature-to-string (signature) (concat (epg-signature-to-string signature) - (mml2015-epg-key-image-to-string (epg-signature-key-id signature)))) + (when mml2015-display-key-image + (mml2015-epg-key-image-to-string (epg-signature-key-id signature))))) (defun mml2015-epg-verify-result-to-string (verify-result) (mapconcat #'mml2015-epg-signature-to-string verify-result "\n")) diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index 3e917b41b19..764314de0af 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -24,10 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (require 'nnheader) (require 'nnmail) (require 'gnus-start) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 1a799d3c573..a403f3965c0 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -28,10 +28,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (require 'nnheader) (require 'message) (require 'nnmail) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 3ce3dfa1e75..994c2d022c8 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -26,9 +26,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (defvar nnmail-extra-headers) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 2fc2dd6af79..1730bd4252c 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -26,10 +26,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-and-compile (require 'nnheader) ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for @@ -628,6 +624,26 @@ textual parts.") (nnheader-ms-strip-cr) (cons group article))))))) +(deffoo nnimap-request-articles (articles &optional group server) + (when group + (setq group (nnimap-decode-gnus-group group))) + (with-current-buffer nntp-server-buffer + (let ((result (nnimap-change-group group server))) + (when result + (erase-buffer) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (when (nnimap-command + (if (nnimap-ver4-p) + "UID FETCH %s BODY.PEEK[]" + "UID FETCH %s RFC822.PEEK") + (nnimap-article-ranges (gnus-compress-sequence articles))) + (let ((buffer (current-buffer))) + (with-current-buffer nntp-server-buffer + (nnheader-insert-buffer-substring buffer) + (nnheader-ms-strip-cr))) + t)))))) + (defun nnimap-get-whole-article (article &optional command) (let ((result (nnimap-command diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index 5910cde1c3d..e2051dfd315 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -171,10 +171,6 @@ ;;; Setup: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (require 'nnoo) (require 'gnus-group) (require 'message) diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index ac4b638fda0..d1a0455a1b0 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -24,10 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'gnus) ; for macro gnus-kill-buffer, at least diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 7d33e511baa..21fa5b37aa4 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -59,10 +59,6 @@ ) ] -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (require 'nnheader) (require 'gnus) (require 'gnus-util) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 5ef91d0be7b..02a9513d07c 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -24,10 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'gnus) @@ -398,8 +394,8 @@ otherwise return nil." nnrss-compatible-encoding-alist))))) (mm-coding-system-p 'utf-8))) -(declare-function w3-parse-buffer "ext:w3-parse" (&optional buff)) - +(declare-function libxml-parse-html-region "xml.c" + (start end &optional base-url)) (defun nnrss-fetch (url &optional local) "Fetch URL and put it in a the expected Lisp structure." (mm-with-unibyte-buffer @@ -426,22 +422,14 @@ otherwise return nil." (mm-enable-multibyte)))) (goto-char (point-min)) - ;; Because xml-parse-region can't deal with anything that isn't - ;; xml and w3-parse-buffer can't deal with some xml, we have to - ;; parse with xml-parse-region first and, if that fails, parse - ;; with w3-parse-buffer. Yuck. Eventually, someone should find out - ;; why w3-parse-buffer fails to parse some well-formed xml and - ;; fix it. - (condition-case err1 (setq xmlform (xml-parse-region (point-min) (point-max))) (error (condition-case err2 - (setq htmlform (caddar (w3-parse-buffer - (current-buffer)))) + (setq htmlform (libxml-parse-html-region (point-min) (point-max))) (error (message "\ -nnrss: %s: Not valid XML %s and w3-parse doesn't work %s" +nnrss: %s: Not valid XML %s and libxml-parse-html-region doesn't work %s" url err1 err2))))) (if htmlform htmlform @@ -599,7 +587,7 @@ which RSS 2.0 allows." (defun nnrss-no-cache (url) "") -(defun nnrss-insert-w3 (url) +(defun nnrss-insert (url) (mm-with-unibyte-current-buffer (condition-case err (mm-url-insert url) @@ -614,8 +602,6 @@ which RSS 2.0 allows." (mm-url-decode-entities-nbsp) (buffer-string)))) -(defalias 'nnrss-insert 'nnrss-insert-w3) - (defun nnrss-mime-encode-string (string) (mm-with-multibyte-buffer (insert string) @@ -880,8 +866,7 @@ Careful with this on large documents!" (defun nnrss-extract-hrefs (data) "Recursively extract hrefs from a page's source. -DATA should be the output of `xml-parse-region' or -`w3-parse-buffer'." +DATA should be the output of `xml-parse-region'." (mapcar (lambda (ahref) (cdr (assoc 'href (cadr ahref)))) (nnrss-find-el 'a data))) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 5ef13984abc..6035162d294 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -25,9 +25,7 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. (eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for ;; `make-network-stream'. (unless (fboundp 'open-protocol-stream) diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index 3fb35b2278d..e909372e8a7 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -22,8 +22,6 @@ ;;; Commentary: -;; Note: You need to have `w3' installed for some functions to work. - ;;; Code: (eval-when-compile (require 'cl)) @@ -38,7 +36,6 @@ (eval-and-compile (ignore-errors (require 'url))) -(autoload 'w3-parse-buffer "w3-parse") (nnoo-declare nnweb) @@ -527,7 +524,7 @@ Valid types include `google', `dejanews', and `gmane'.") url)) ;;; -;;; General web/w3 interface utility functions +;;; General web interface utility functions ;;; (defun nnweb-insert-html (parse) diff --git a/lisp/gnus/rfc1843.el b/lisp/gnus/rfc1843.el index 09c2b723eb7..74e8f12fc30 100644 --- a/lisp/gnus/rfc1843.el +++ b/lisp/gnus/rfc1843.el @@ -31,10 +31,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'mm-util) diff --git a/lisp/gnus/sieve-manage.el b/lisp/gnus/sieve-manage.el index fd97c7d595b..62d185e2857 100644 --- a/lisp/gnus/sieve-manage.el +++ b/lisp/gnus/sieve-manage.el @@ -71,10 +71,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (if (locate-library "password-cache") (require 'password-cache) (require 'password)) diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index 4a763caba8e..bcebe3ddc38 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -118,9 +118,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (require 'dig) (if (locate-library "password-cache") diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 82f98c4294f..664ac53a76f 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -38,10 +38,6 @@ ;;{{{ compilation directives and autoloads/requires -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (eval-when-compile (require 'cl)) (require 'message) ;for the message-fetch-field functions |