diff options
Diffstat (limited to 'lisp/gnus')
110 files changed, 2975 insertions, 15535 deletions
diff --git a/lisp/gnus/ChangeLog.1 b/lisp/gnus/ChangeLog.1 index 6f6500b32df..4cf5129dcd5 100644 --- a/lisp/gnus/ChangeLog.1 +++ b/lisp/gnus/ChangeLog.1 @@ -3230,7 +3230,7 @@ * gnus-picon.el (gnus-picons-display-pairs): Don't add two bars. (gnus-picons-try-face): Set the foreground color on the bar. - (gnus-picons-group-exluded-groups): New variable. + (gnus-picons-group-excluded-groups): New variable. (gnus-group-display-picons): Use it. 1997-10-13 Lars Magne Ingebrigtsen <larsi@ifi.uio.no> diff --git a/lisp/gnus/ChangeLog.2 b/lisp/gnus/ChangeLog.2 index 8ddcb8f6bc0..d7ff3b6205e 100644 --- a/lisp/gnus/ChangeLog.2 +++ b/lisp/gnus/ChangeLog.2 @@ -4705,7 +4705,7 @@ illegible and invisible text. * gnus-util.el (gnus-multiple-choice): Separate choices with - ", ". Suggested by Dan Jacobson <jidanni@dman.ddts.net>. + ", ". Suggested by Dan Jacobson <jidanni@dman.ddts.net>. 2003-02-18 Jesper Harder <harder@ifa.au.dk> diff --git a/lisp/gnus/ChangeLog.3 b/lisp/gnus/ChangeLog.3 index 2fc774a70a4..5f07d3f0d3f 100644 --- a/lisp/gnus/ChangeLog.3 +++ b/lisp/gnus/ChangeLog.3 @@ -9090,7 +9090,7 @@ (shr-kinsoku-shorten): New internal variable. (shr-find-fill-point): Make kinsoku shorten text line if shr-kinsoku-shorten is bound to non-nil. - (shr-tag-table): Bild shr-kinsoku-shorten to t; refer to + (shr-tag-table): Bind shr-kinsoku-shorten to t; refer to shr-indentation too when testing if table is wider than frame width. (shr-insert-table): Use `string-width' instead of `length' to measure text width. diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el deleted file mode 100644 index cc2cce2f724..00000000000 --- a/lisp/gnus/auth-source.el +++ /dev/null @@ -1,2137 +0,0 @@ -;;; auth-source.el --- authentication sources for Gnus and Emacs - -;; Copyright (C) 2008-2017 Free Software Foundation, Inc. - -;; Author: Ted Zlatanov <tzz@lifelogs.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: - -;; This is the auth-source.el package. It lets users tell Gnus how to -;; authenticate in a single place. Simplicity is the goal. Instead -;; of providing 5000 options, we'll stick to simple, easy to -;; understand options. - -;; See the auth.info Info documentation for details. - -;; TODO: - -;; - never decode the backend file unless it's necessary -;; - a more generic way to match backends and search backend contents -;; - absorb netrc.el and simplify it -;; - protect passwords better -;; - allow creating and changing netrc lines (not files) e.g. change a password - -;;; Code: - -(require 'password-cache) -(require 'mm-util) -(require 'gnus-util) - -(eval-when-compile (require 'cl)) -(require 'eieio) - -(autoload 'secrets-create-item "secrets") -(autoload 'secrets-delete-item "secrets") -(autoload 'secrets-get-alias "secrets") -(autoload 'secrets-get-attributes "secrets") -(autoload 'secrets-get-secret "secrets") -(autoload 'secrets-list-collections "secrets") -(autoload 'secrets-search-items "secrets") - -(autoload 'rfc2104-hash "rfc2104") - -(autoload 'plstore-open "plstore") -(autoload 'plstore-find "plstore") -(autoload 'plstore-put "plstore") -(autoload 'plstore-delete "plstore") -(autoload 'plstore-save "plstore") -(autoload 'plstore-get-file "plstore") - -(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' -(autoload 'epg-make-context "epg") -(autoload 'epg-context-set-passphrase-callback "epg") -(autoload 'epg-decrypt-string "epg") -(autoload 'epg-encrypt-string "epg") - -(autoload 'help-mode "help-mode" nil t) - -(defvar secrets-enabled) - -(defgroup auth-source nil - "Authentication sources." - :version "23.1" ;; No Gnus - :group 'gnus) - -;;;###autoload -(defcustom auth-source-cache-expiry 7200 - "How many seconds passwords are cached, or nil to disable -expiring. Overrides `password-cache-expiry' through a -let-binding." - :version "24.1" - :group 'auth-source - :type '(choice (const :tag "Never" nil) - (const :tag "All Day" 86400) - (const :tag "2 Hours" 7200) - (const :tag "30 Minutes" 1800) - (integer :tag "Seconds"))) - -;; The slots below correspond with the `auth-source-search' spec, -;; so a backend with :host set, for instance, would match only -;; searches for that host. Normally they are nil. -(defclass auth-source-backend () - ((type :initarg :type - :initform 'netrc - :type symbol - :custom symbol - :documentation "The backend type.") - (source :initarg :source - :type string - :custom string - :documentation "The backend source.") - (host :initarg :host - :initform t - :type t - :custom string - :documentation "The backend host.") - (user :initarg :user - :initform t - :type t - :custom string - :documentation "The backend user.") - (port :initarg :port - :initform t - :type t - :custom string - :documentation "The backend protocol.") - (data :initarg :data - :initform nil - :documentation "Internal backend data.") - (create-function :initarg :create-function - :initform ignore - :type function - :custom function - :documentation "The create function.") - (search-function :initarg :search-function - :initform ignore - :type function - :custom function - :documentation "The search function."))) - -(defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993") - (pop3 "pop3" "pop" "pop3s" "110" "995") - (ssh "ssh" "22") - (sftp "sftp" "115") - (smtp "smtp" "25")) - "List of authentication protocols and their names" - - :group 'auth-source - :version "23.2" ;; No Gnus - :type '(repeat :tag "Authentication Protocols" - (cons :tag "Protocol Entry" - (symbol :tag "Protocol") - (repeat :tag "Names" - (string :tag "Name"))))) - -;; Generate all the protocols in a format Customize can use. -;; TODO: generate on the fly from auth-source-protocols -(defconst auth-source-protocols-customize - (mapcar (lambda (a) - (let ((p (car-safe a))) - (list 'const - :tag (upcase (symbol-name p)) - p))) - auth-source-protocols)) - -(defvar auth-source-creation-defaults nil - ;; FIXME: AFAICT this is not set (or let-bound) anywhere! - "Defaults for creating token values. Usually let-bound.") - -(defvar auth-source-creation-prompts nil - "Default prompts for token values. Usually let-bound.") - -(make-obsolete 'auth-source-hide-passwords nil "Emacs 24.1") - -(defcustom auth-source-save-behavior 'ask - "If set, auth-source will respect it for save behavior." - :group 'auth-source - :version "23.2" ;; No Gnus - :type `(choice - :tag "auth-source new token save behavior" - (const :tag "Always save" t) - (const :tag "Never save" nil) - (const :tag "Ask" ask))) - -;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car epa-file-auto-mode-alist-entry) "\\.gpg\\'") never) (t gpg))) -;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never) - -(defcustom auth-source-netrc-use-gpg-tokens 'never - "Set this to tell auth-source when to create GPG password -tokens in netrc files. It's either an alist or `never'. -Note that if EPA/EPG is not available, this should NOT be used." - :group 'auth-source - :version "23.2" ;; No Gnus - :type `(choice - (const :tag "Always use GPG password tokens" (t gpg)) - (const :tag "Never use GPG password tokens" never) - (repeat :tag "Use a lookup list" - (list - (choice :tag "Matcher" - (const :tag "Match anything" t) - (const :tag "The EPA encrypted file extensions" - ,(if (boundp 'epa-file-auto-mode-alist-entry) - (car epa-file-auto-mode-alist-entry) - "\\.gpg\\'")) - (regexp :tag "Regular expression")) - (choice :tag "What to do" - (const :tag "Save GPG-encrypted password tokens" gpg) - (const :tag "Don't encrypt tokens" never)))))) - -(defvar auth-source-magic "auth-source-magic ") - -(defcustom auth-source-do-cache t - "Whether auth-source should cache information with `password-cache'." - :group 'auth-source - :version "23.2" ;; No Gnus - :type `boolean) - -(defcustom auth-source-debug nil - "Whether auth-source should log debug messages. - -If the value is nil, debug messages are not logged. - -If the value is t, debug messages are logged with `message'. In -that case, your authentication data will be in the clear (except -for passwords). - -If the value is a function, debug messages are logged by calling - that function using the same arguments as `message'." - :group 'auth-source - :version "23.2" ;; No Gnus - :type `(choice - :tag "auth-source debugging mode" - (const :tag "Log using `message' to the *Messages* buffer" t) - (const :tag "Log all trivia with `message' to the *Messages* buffer" - trivia) - (function :tag "Function that takes arguments like `message'") - (const :tag "Don't log anything" nil))) - -(defcustom auth-sources '("~/.authinfo" "~/.authinfo.gpg" "~/.netrc") - "List of authentication sources. -Each entry is the authentication type with optional properties. -Entries are tried in the order in which they appear. -See Info node `(auth)Help for users' for details. - -If an entry names a file with the \".gpg\" extension and you have -EPA/EPG set up, the file will be encrypted and decrypted -automatically. See Info node `(epa)Encrypting/decrypting gpg files' -for details. - -It's best to customize this with `\\[customize-variable]' because the choices -can get pretty complex." - :group 'auth-source - :version "24.1" ;; No Gnus - :type `(repeat :tag "Authentication Sources" - (choice - (string :tag "Just a file") - (const :tag "Default Secrets API Collection" default) - (const :tag "Login Secrets API Collection" "secrets:Login") - (const :tag "Temp Secrets API Collection" "secrets:session") - - (const :tag "Default internet Mac OS Keychain" - macos-keychain-internet) - - (const :tag "Default generic Mac OS Keychain" - macos-keychain-generic) - - (list :tag "Source definition" - (const :format "" :value :source) - (choice :tag "Authentication backend choice" - (string :tag "Authentication Source (file)") - (list - :tag "Secret Service API/KWallet/GNOME Keyring" - (const :format "" :value :secrets) - (choice :tag "Collection to use" - (string :tag "Collection name") - (const :tag "Default" default) - (const :tag "Login" "Login") - (const - :tag "Temporary" "session"))) - (list - :tag "Mac OS internet Keychain" - (const :format "" - :value :macos-keychain-internet) - (choice :tag "Collection to use" - (string :tag "internet Keychain path") - (const :tag "default" default))) - (list - :tag "Mac OS generic Keychain" - (const :format "" - :value :macos-keychain-generic) - (choice :tag "Collection to use" - (string :tag "generic Keychain path") - (const :tag "default" default)))) - (repeat :tag "Extra Parameters" :inline t - (choice :tag "Extra parameter" - (list - :tag "Host" - (const :format "" :value :host) - (choice :tag "Host (machine) choice" - (const :tag "Any" t) - (regexp - :tag "Regular expression"))) - (list - :tag "Protocol" - (const :format "" :value :port) - (choice - :tag "Protocol" - (const :tag "Any" t) - ,@auth-source-protocols-customize)) - (list :tag "User" :inline t - (const :format "" :value :user) - (choice - :tag "Personality/Username" - (const :tag "Any" t) - (string - :tag "Name"))))))))) - -(defcustom auth-source-gpg-encrypt-to t - "List of recipient keys that `authinfo.gpg' encrypted to. -If the value is not a list, symmetric encryption will be used." - :group 'auth-source - :version "24.1" ;; No Gnus - :type '(choice (const :tag "Symmetric encryption" t) - (repeat :tag "Recipient public keys" - (string :tag "Recipient public key")))) - -;; temp for debugging -;; (unintern 'auth-source-protocols) -;; (unintern 'auth-sources) -;; (customize-variable 'auth-sources) -;; (setq auth-sources nil) -;; (format "%S" auth-sources) -;; (customize-variable 'auth-source-protocols) -;; (setq auth-source-protocols nil) -;; (format "%S" auth-source-protocols) -;; (auth-source-pick nil :host "a" :port 'imap) -;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap) -;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap) -;; (auth-source-user-or-password-imap "login" "imap.myhost.com") -;; (auth-source-user-or-password-imap "password" "imap.myhost.com") -;; (auth-source-protocol-defaults 'imap) - -;; (let ((auth-source-debug 'debug)) (auth-source-do-debug "hello")) -;; (let ((auth-source-debug t)) (auth-source-do-debug "hello")) -;; (let ((auth-source-debug nil)) (auth-source-do-debug "hello")) -(defun auth-source-do-debug (&rest msg) - (when auth-source-debug - (apply #'auth-source-do-warn msg))) - -(defun auth-source-do-trivia (&rest msg) - (when (or (eq auth-source-debug 'trivia) - (functionp auth-source-debug)) - (apply #'auth-source-do-warn msg))) - -(defun auth-source-do-warn (&rest msg) - (apply - ;; set logger to either the function in auth-source-debug or 'message - ;; note that it will be 'message if auth-source-debug is nil - (if (functionp auth-source-debug) - auth-source-debug - 'message) - msg)) - - -;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q)) -(defun auth-source-read-char-choice (prompt choices) - "Read one of CHOICES by `read-char-choice', or `read-char'. -`dropdown-list' support is disabled because it doesn't work reliably. -Only one of CHOICES will be returned. The PROMPT is augmented -with \"[a/b/c] \" if CHOICES is \(?a ?b ?c)." - (when choices - (let* ((prompt-choices - (apply #'concat (loop for c in choices - collect (format "%c/" c)))) - (prompt-choices (concat "[" (substring prompt-choices 0 -1) "] ")) - (full-prompt (concat prompt prompt-choices)) - k) - - (while (not (memq k choices)) - (setq k (cond - ((fboundp 'read-char-choice) - (read-char-choice full-prompt choices)) - (t (message "%s" full-prompt) - (setq k (read-char)))))) - k))) - -;; (auth-source-pick nil :host "any" :port 'imap :user "joe") -;; (auth-source-pick t :host "any" :port 'imap :user "joe") -;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe") -;; (:source (:secrets "session") :host t :port t :user "joe") -;; (:source (:secrets "Login") :host t :port t) -;; (:source "~/.authinfo.gpg" :host t :port t))) - -;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe") -;; (:source (:secrets "session") :host t :port t :user "joe") -;; (:source (:secrets "Login") :host t :port t) -;; )) - -;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :port t))) - -;; (auth-source-backend-parse "myfile.gpg") -;; (auth-source-backend-parse 'default) -;; (auth-source-backend-parse "secrets:Login") -;; (auth-source-backend-parse 'macos-keychain-internet) -;; (auth-source-backend-parse 'macos-keychain-generic) -;; (auth-source-backend-parse "macos-keychain-internet:/path/here.keychain") -;; (auth-source-backend-parse "macos-keychain-generic:/path/here.keychain") - -(defun auth-source-backend-parse (entry) - "Creates an auth-source-backend from an ENTRY in `auth-sources'." - (auth-source-backend-parse-parameters - entry - (cond - ;; take 'default and recurse to get it as a Secrets API default collection - ;; matching any user, host, and protocol - ((eq entry 'default) - (auth-source-backend-parse '(:source (:secrets default)))) - ;; take secrets:XYZ and recurse to get it as Secrets API collection "XYZ" - ;; matching any user, host, and protocol - ((and (stringp entry) (string-match "^secrets:\\(.+\\)" entry)) - (auth-source-backend-parse `(:source (:secrets ,(match-string 1 entry))))) - - ;; take 'macos-keychain-internet and recurse to get it as a Mac OS - ;; Keychain collection matching any user, host, and protocol - ((eq entry 'macos-keychain-internet) - (auth-source-backend-parse '(:source (:macos-keychain-internet default)))) - ;; take 'macos-keychain-generic and recurse to get it as a Mac OS - ;; Keychain collection matching any user, host, and protocol - ((eq entry 'macos-keychain-generic) - (auth-source-backend-parse '(:source (:macos-keychain-generic default)))) - ;; take macos-keychain-internet:XYZ and recurse to get it as macOS - ;; Keychain "XYZ" matching any user, host, and protocol - ((and (stringp entry) (string-match "^macos-keychain-internet:\\(.+\\)" - entry)) - (auth-source-backend-parse `(:source (:macos-keychain-internet - ,(match-string 1 entry))))) - ;; take macos-keychain-generic:XYZ and recurse to get it as macOS - ;; Keychain "XYZ" matching any user, host, and protocol - ((and (stringp entry) (string-match "^macos-keychain-generic:\\(.+\\)" - entry)) - (auth-source-backend-parse `(:source (:macos-keychain-generic - ,(match-string 1 entry))))) - - ;; take just a file name and recurse to get it as a netrc file - ;; matching any user, host, and protocol - ((stringp entry) - (auth-source-backend-parse `(:source ,entry))) - - ;; a file name with parameters - ((stringp (plist-get entry :source)) - (if (equal (file-name-extension (plist-get entry :source)) "plist") - (auth-source-backend - (plist-get entry :source) - :source (plist-get entry :source) - :type 'plstore - :search-function #'auth-source-plstore-search - :create-function #'auth-source-plstore-create - :data (plstore-open (plist-get entry :source))) - (auth-source-backend - (plist-get entry :source) - :source (plist-get entry :source) - :type 'netrc - :search-function #'auth-source-netrc-search - :create-function #'auth-source-netrc-create))) - - ;; the macOS Keychain - ((and - (not (null (plist-get entry :source))) ; the source must not be nil - (listp (plist-get entry :source)) ; and it must be a list - (or - (plist-get (plist-get entry :source) :macos-keychain-generic) - (plist-get (plist-get entry :source) :macos-keychain-internet))) - - (let* ((source-spec (plist-get entry :source)) - (keychain-generic (plist-get source-spec :macos-keychain-generic)) - (keychain-type (if keychain-generic - 'macos-keychain-generic - 'macos-keychain-internet)) - (source (plist-get source-spec (if keychain-generic - :macos-keychain-generic - :macos-keychain-internet)))) - - (when (symbolp source) - (setq source (symbol-name source))) - - (auth-source-backend - (format "Mac OS Keychain (%s)" source) - :source source - :type keychain-type - :search-function #'auth-source-macos-keychain-search - :create-function #'auth-source-macos-keychain-create))) - - ;; the Secrets API. We require the package, in order to have a - ;; defined value for `secrets-enabled'. - ((and - (not (null (plist-get entry :source))) ; the source must not be nil - (listp (plist-get entry :source)) ; and it must be a list - (require 'secrets nil t) ; and we must load the Secrets API - secrets-enabled) ; and that API must be enabled - - ;; the source is either the :secrets key in ENTRY or - ;; if that's missing or nil, it's "session" - (let ((source (or (plist-get (plist-get entry :source) :secrets) - "session"))) - - ;; if the source is a symbol, we look for the alias named so, - ;; and if that alias is missing, we use "Login" - (when (symbolp source) - (setq source (or (secrets-get-alias (symbol-name source)) - "Login"))) - - (if (featurep 'secrets) - (auth-source-backend - (format "Secrets API (%s)" source) - :source source - :type 'secrets - :search-function #'auth-source-secrets-search - :create-function #'auth-source-secrets-create) - (auth-source-do-warn - "auth-source-backend-parse: no Secrets API, ignoring spec: %S" entry) - (auth-source-backend - (format "Ignored Secrets API (%s)" source) - :source "" - :type 'ignore)))) - - ;; none of them - (t - (auth-source-do-warn - "auth-source-backend-parse: invalid backend spec: %S" entry) - (make-instance 'auth-source-backend - :source "" - :type 'ignore))))) - -(defun auth-source-backend-parse-parameters (entry backend) - "Fills in the extra auth-source-backend parameters of ENTRY. -Using the plist ENTRY, get the :host, :port, and :user search -parameters." - (let ((entry (if (stringp entry) - nil - entry)) - val) - (when (setq val (plist-get entry :host)) - (oset backend host val)) - (when (setq val (plist-get entry :user)) - (oset backend user val)) - (when (setq val (plist-get entry :port)) - (oset backend port val))) - backend) - -;; (mapcar 'auth-source-backend-parse auth-sources) - -(defun* auth-source-search (&rest spec - &key max - require create delete - &allow-other-keys) - "Search or modify authentication backends according to SPEC. - -This function parses `auth-sources' for matches of the SPEC -plist. It can optionally create or update an authentication -token if requested. A token is just a standard Emacs property -list with a :secret property that can be a function; all the -other properties will always hold scalar values. - -Typically the :secret property, if present, contains a password. - -Common search keys are :max, :host, :port, and :user. In -addition, :create specifies if and how tokens will be created. -Finally, :type can specify which backend types you want to check. - -A string value is always matched literally. A symbol is matched -as its string value, literally. All the SPEC values can be -single values (symbol or string) or lists thereof (in which case -any of the search terms matches). - -:create t means to create a token if possible. - -A new token will be created if no matching tokens were found. -The new token will have only the keys the backend requires. For -the netrc backend, for instance, that's the user, host, and -port keys. - -Here's an example: - -\(let ((auth-source-creation-defaults \\='((user . \"defaultUser\") - (A . \"default A\")))) - (auth-source-search :host \"mine\" :type \\='netrc :max 1 - :P \"pppp\" :Q \"qqqq\" - :create t)) - -which says: - -\"Search for any entry matching host `mine' in backends of type - `netrc', maximum one result. - - Create a new entry if you found none. The netrc backend will - automatically require host, user, and port. The host will be - `mine'. We prompt for the user with default `defaultUser' and - for the port without a default. We will not prompt for A, Q, - or P. The resulting token will only have keys user, host, and - port.\" - -:create \\='(A B C) also means to create a token if possible. - -The behavior is like :create t but if the list contains any -parameter, that parameter will be required in the resulting -token. The value for that parameter will be obtained from the -search parameters or from user input. If any queries are needed, -the alist `auth-source-creation-defaults' will be checked for the -default value. If the user, host, or port are missing, the alist -`auth-source-creation-prompts' will be used to look up the -prompts IN THAT ORDER (so the `user' prompt will be queried first, -then `host', then `port', and finally `secret'). Each prompt string -can use %u, %h, and %p to show the user, host, and port. - -Here's an example: - -\(let ((auth-source-creation-defaults \\='((user . \"defaultUser\") - (A . \"default A\"))) - (auth-source-creation-prompts - \\='((password . \"Enter IMAP password for %h:%p: \")))) - (auth-source-search :host \\='(\"nonesuch\" \"twosuch\") :type \\='netrc :max 1 - :P \"pppp\" :Q \"qqqq\" - :create \\='(A B Q))) - -which says: - -\"Search for any entry matching host `nonesuch' - or `twosuch' in backends of type `netrc', maximum one result. - - Create a new entry if you found none. The netrc backend will - automatically require host, user, and port. The host will be - `nonesuch' and Q will be `qqqq'. We prompt for the password - with the shown prompt. We will not prompt for Q. The resulting - token will have keys user, host, port, A, B, and Q. It will not - have P with any value, even though P is used in the search to - find only entries that have P set to `pppp'.\" - -When multiple values are specified in the search parameter, the -user is prompted for which one. So :host (X Y Z) would ask the -user to choose between X, Y, and Z. - -This creation can fail if the search was not specific enough to -create a new token (it's up to the backend to decide that). You -should `catch' the backend-specific error as usual. Some -backends (netrc, at least) will prompt the user rather than throw -an error. - -:require (A B C) means that only results that contain those -tokens will be returned. Thus for instance requiring :secret -will ensure that any results will actually have a :secret -property. - -:delete t means to delete any found entries. nil by default. -Use `auth-source-delete' in ELisp code instead of calling -`auth-source-search' directly with this parameter. - -:type (X Y Z) will check only those backend types. `netrc' and -`secrets' are the only ones supported right now. - -:max N means to try to return at most N items (defaults to 1). -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. - -:user (X Y Z) means to match only users X, Y, or Z according to -the match rules above. Defaults to t. - -:port (P Q R) means to match only protocols P, Q, or R. -Defaults to t. - -:K (V1 V2 V3) for any other key K will match values V1, V2, or -V3 (note the match rules above). - -The return value is a list with at most :max tokens. Each token -is a plist with keys :backend :host :port :user, plus any other -keys provided by the backend (notably :secret). But note the -exception for :max 0, which see above. - -The token can hold a :save-function key. If you call that, the -user will be prompted to save the data to the backend. You can't -request that this should happen right after creation, because -`auth-source-search' has no way of knowing if the token is -actually useful. So the caller must arrange to call this function. - -The token's :secret key can hold a function. In that case you -must call it to obtain the actual value." - (let* ((backends (mapcar #'auth-source-backend-parse auth-sources)) - (max (or max 1)) - (ignored-keys '(:require :create :delete :max)) - (keys (loop for i below (length spec) by 2 - unless (memq (nth i spec) ignored-keys) - collect (nth i spec))) - (cached (auth-source-remembered-p spec)) - ;; note that we may have cached results but found is still nil - ;; (there were no results from the search) - (found (auth-source-recall spec)) - filtered-backends) - - (if (and cached auth-source-do-cache) - (auth-source-do-debug - "auth-source-search: found %d CACHED results matching %S" - (length found) spec) - - (assert - (or (eq t create) (listp create)) t - "Invalid auth-source :create parameter (must be t or a list): %s %s") - - (assert - (listp require) t - "Invalid auth-source :require parameter (must be a list): %s") - - (setq filtered-backends (copy-sequence backends)) - (dolist (backend backends) - (dolist (key keys) - ;; ignore invalid slots - (condition-case nil - (unless (auth-source-search-collection - (plist-get spec key) - (slot-value backend key)) - (setq filtered-backends (delq backend filtered-backends)) - (return)) - (invalid-slot-name nil)))) - - (auth-source-do-trivia - "auth-source-search: found %d backends matching %S" - (length filtered-backends) spec) - - ;; (debug spec "filtered" filtered-backends) - ;; First go through all the backends without :create, so we can - ;; query them all. - (setq found (auth-source-search-backends filtered-backends - spec - ;; to exit early - max - ;; create is always nil here - nil delete - require)) - - (auth-source-do-debug - "auth-source-search: found %d results (max %d) matching %S" - (length found) max spec) - - ;; If we didn't find anything, then we allow the backend(s) to - ;; create the entries. - (when (and create - (not found)) - (setq found (auth-source-search-backends filtered-backends - spec - ;; to exit early - max - create delete - require)) - (auth-source-do-debug - "auth-source-search: CREATED %d results (max %d) matching %S" - (length found) max spec)) - - ;; note we remember the lack of result too, if it's applicable - (when auth-source-do-cache - (auth-source-remember spec found))) - - (if (zerop max) - (not (null found)) - found))) - -(defun auth-source-search-backends (backends spec max create delete require) - (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)) ; 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 :max, :require, :create, and :delete - :max max - :require require - :create create - :delete delete - spec))) - (when bmatches - (auth-source-do-trivia - "auth-source-search-backend: got %d (max %d) in %s:%s matching %S" - (length bmatches) max - (slot-value backend 'type) - (slot-value backend 'source) - spec) - (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) -;; (auth-source-search :host "nonesuch" :type 'secrets) - -(defun auth-source-delete (&rest spec) - "Delete entries from the authentication backends according to SPEC. -Calls `auth-source-search' with the :delete property in SPEC set to t. -The backend may not actually delete the entries. - -Returns the deleted entries." - (auth-source-search (plist-put spec :delete t))) - -(defun auth-source-search-collection (collection value) - "Returns t is VALUE is t or COLLECTION is t or COLLECTION contains VALUE." - (when (and (atom collection) (not (eq t collection))) - (setq collection (list collection))) - - ;; (debug :collection collection :value value) - (or (eq collection t) - (eq value t) - (equal collection value) - (member value collection))) - -(defvar auth-source-netrc-cache nil) - -(defun auth-source-forget-all-cached () - "Forget all cached auth-source data." - (interactive) - (loop for sym being the symbols of password-data - ;; when the symbol name starts with auth-source-magic - when (string-match (concat "^" auth-source-magic) - (symbol-name sym)) - ;; remove that key - do (password-cache-remove (symbol-name sym))) - (setq auth-source-netrc-cache nil)) - -(defun auth-source-format-cache-entry (spec) - "Format SPEC entry to put it in the password cache." - (concat auth-source-magic (format "%S" spec))) - -(defun auth-source-remember (spec found) - "Remember FOUND search results for SPEC." - (let ((password-cache-expiry auth-source-cache-expiry)) - (password-cache-add - (auth-source-format-cache-entry spec) found))) - -(defun auth-source-recall (spec) - "Recall FOUND search results for SPEC." - (password-read-from-cache (auth-source-format-cache-entry spec))) - -(defun auth-source-remembered-p (spec) - "Check if SPEC is remembered." - (password-in-cache-p - (auth-source-format-cache-entry spec))) - -(defun auth-source-forget (spec) - "Forget any cached data matching SPEC exactly. - -This is the same SPEC you passed to `auth-source-search'. -Returns t or nil for forgotten or not found." - (password-cache-remove (auth-source-format-cache-entry spec))) - -;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym)) - -;; (auth-source-remember '(:host "wedd") '(4 5 6)) -;; (auth-source-remembered-p '(:host "wedd")) -;; (auth-source-remember '(:host "xedd") '(1 2 3)) -;; (auth-source-remembered-p '(:host "xedd")) -;; (auth-source-remembered-p '(:host "zedd")) -;; (auth-source-recall '(:host "xedd")) -;; (auth-source-recall '(:host t)) -;; (auth-source-forget+ :host t) - -(defun auth-source-forget+ (&rest spec) - "Forget any cached data matching SPEC. Returns forgotten count. - -This is not a full `auth-source-search' spec but works similarly. -For instance, \(:host \"myhost\" \"yourhost\") would find all the -cached data that was found with a search for those two hosts, -while \(:host t) would find all host entries." - (let ((count 0) - sname) - (loop for sym being the symbols of password-data - ;; when the symbol name matches with auth-source-magic - when (and (setq sname (symbol-name sym)) - (string-match (concat "^" auth-source-magic "\\(.+\\)") - sname) - ;; and the spec matches what was stored in the cache - (auth-source-specmatchp spec (read (match-string 1 sname)))) - ;; remove that key - do (progn - (password-cache-remove sname) - (incf count))) - count)) - -(defun auth-source-specmatchp (spec stored) - (let ((keys (loop for i below (length spec) by 2 - collect (nth i spec)))) - (not (eq - (dolist (key keys) - (unless (auth-source-search-collection (plist-get stored key) - (plist-get spec key)) - (return 'no))) - 'no)))) - -;; (auth-source-pick-first-password :host "z.lifelogs.com") -;; (auth-source-pick-first-password :port "imap") -(defun auth-source-pick-first-password (&rest spec) - "Pick the first secret found from applying SPEC to `auth-source-search'." - (let* ((result (nth 0 (apply #'auth-source-search (plist-put spec :max 1)))) - (secret (plist-get result :secret))) - - (if (functionp secret) - (funcall secret) - secret))) - -;; (auth-source-format-prompt "test %u %h %p" '((?u "user") (?h "host"))) -(defun auth-source-format-prompt (prompt alist) - "Format PROMPT using %x (for any character x) specifiers in ALIST." - (dolist (cell alist) - (let ((c (nth 0 cell)) - (v (nth 1 cell))) - (when (and c v) - (setq prompt (replace-regexp-in-string (format "%%%c" c) - (format "%s" v) - prompt nil t))))) - prompt) - -(defun auth-source-ensure-strings (values) - (if (eq values t) - values - (unless (listp values) - (setq values (list values))) - (mapcar (lambda (value) - (if (numberp value) - (format "%s" value) - value)) - values))) - -;;; Backend specific parsing: netrc/authinfo backend - -(defun auth-source--aput-1 (alist key val) - (let ((seen ()) - (rest alist)) - (while (and (consp rest) (not (equal key (caar rest)))) - (push (pop rest) seen)) - (cons (cons key val) - (if (null rest) alist - (nconc (nreverse seen) - (if (equal key (caar rest)) (cdr rest) rest)))))) -(defmacro auth-source--aput (var key val) - `(setq ,var (auth-source--aput-1 ,var ,key ,val))) - -(defun auth-source--aget (alist key) - (cdr (assoc key alist))) - -;; (auth-source-netrc-parse :file "~/.authinfo.gpg") -(defun* auth-source-netrc-parse (&key file max host user port require - &allow-other-keys) - "Parse FILE and return a list of all entries in the file. -Note that the MAX parameter is used so we can exit the parse early." - (if (listp file) - ;; We got already parsed contents; just return it. - file - (when (file-exists-p file) - (setq port (auth-source-ensure-strings port)) - (with-temp-buffer - (let* ((max (or max 5000)) ; sanity check: default to stop at 5K - (modified 0) - (cached (cdr-safe (assoc file auth-source-netrc-cache))) - (cached-mtime (plist-get cached :mtime)) - (cached-secrets (plist-get cached :secret)) - (check (lambda(alist) - (and alist - (auth-source-search-collection - host - (or - (auth-source--aget alist "machine") - (auth-source--aget alist "host") - t)) - (auth-source-search-collection - user - (or - (auth-source--aget alist "login") - (auth-source--aget alist "account") - (auth-source--aget alist "user") - t)) - (auth-source-search-collection - port - (or - (auth-source--aget alist "port") - (auth-source--aget alist "protocol") - t)) - (or - ;; the required list of keys is nil, or - (null require) - ;; every element of require is in n(ormalized) - (let ((n (nth 0 (auth-source-netrc-normalize - (list alist) file)))) - (loop for req in require - always (plist-get n req))))))) - result) - - (if (and (functionp cached-secrets) - (equal cached-mtime - (nth 5 (file-attributes file)))) - (progn - (auth-source-do-trivia - "auth-source-netrc-parse: using CACHED file data for %s" - file) - (insert (funcall cached-secrets))) - (insert-file-contents file) - ;; cache all netrc files (used to be just .gpg files) - ;; Store the contents of the file heavily encrypted in memory. - ;; (note for the irony-impaired: they are just obfuscated) - (auth-source--aput - auth-source-netrc-cache file - (list :mtime (nth 5 (file-attributes file)) - :secret (lexical-let ((v (mapcar #'1+ (buffer-string)))) - (lambda () (apply #'string (mapcar #'1- v))))))) - (goto-char (point-min)) - (let ((entries (auth-source-netrc-parse-entries check max)) - alist) - (while (setq alist (pop entries)) - (push (nreverse alist) result))) - - (when (< 0 modified) - (when auth-source-gpg-encrypt-to - ;; (see bug#7487) making `epa-file-encrypt-to' local to - ;; this buffer lets epa-file skip the key selection query - ;; (see the `local-variable-p' check in - ;; `epa-file-write-region'). - (unless (local-variable-p 'epa-file-encrypt-to (current-buffer)) - (make-local-variable 'epa-file-encrypt-to)) - (if (listp auth-source-gpg-encrypt-to) - (setq epa-file-encrypt-to auth-source-gpg-encrypt-to))) - - ;; ask AFTER we've successfully opened the file - (when (y-or-n-p (format "Save file %s? (%d deletions)" - file modified)) - (write-region (point-min) (point-max) file nil 'silent) - (auth-source-do-debug - "auth-source-netrc-parse: modified %d lines in %s" - modified file))) - - (nreverse result)))))) - -(defun auth-source-netrc-parse-next-interesting () - "Advance to the next interesting position in the current buffer." - ;; If we're looking at a comment or are at the end of the line, move forward - (while (or (looking-at "#") - (and (eolp) - (not (eobp)))) - (forward-line 1)) - (skip-chars-forward "\t ")) - -(defun auth-source-netrc-parse-one () - "Read one thing from the current buffer." - (auth-source-netrc-parse-next-interesting) - - (when (or (looking-at "'\\([^']*\\)'") - (looking-at "\"\\([^\"]*\\)\"") - (looking-at "\\([^ \t\n]+\\)")) - (forward-char (length (match-string 0))) - (auth-source-netrc-parse-next-interesting) - (match-string-no-properties 1))) - -;; with thanks to org-mode -(defsubst auth-source-current-line (&optional pos) - (save-excursion - (and pos (goto-char pos)) - ;; works also in narrowed buffer, because we start at 1, not point-min - (+ (if (bolp) 1 0) (count-lines 1 (point))))) - -(defun auth-source-netrc-parse-entries(check max) - "Parse up to MAX netrc entries, passed by CHECK, from the current buffer." - (let ((adder (lambda(check alist all) - (when (and - alist - (> max (length all)) - (funcall check alist)) - (push alist all)) - all)) - item item2 all alist default) - (while (setq item (auth-source-netrc-parse-one)) - (setq default (equal item "default")) - ;; We're starting a new machine. Save the old one. - (when (and alist - (or default - (equal item "machine"))) - ;; (auth-source-do-trivia - ;; "auth-source-netrc-parse-entries: got entry %S" alist) - (setq all (funcall adder check alist all) - alist nil)) - ;; In default entries, we don't have a next token. - ;; We store them as ("machine" . t) - (if default - (push (cons "machine" t) alist) - ;; Not a default entry. Grab the next item. - (when (setq item2 (auth-source-netrc-parse-one)) - ;; Did we get a "machine" value? - (if (equal item2 "machine") - (progn - (gnus-error 1 - "%s: Unexpected `machine' token at line %d" - "auth-source-netrc-parse-entries" - (auth-source-current-line)) - (forward-line 1)) - (push (cons item item2) alist))))) - - ;; Clean up: if there's an entry left over, use it. - (when alist - (setq all (funcall adder check alist all)) - ;; (auth-source-do-trivia - ;; "auth-source-netrc-parse-entries: got2 entry %S" alist) - ) - (nreverse all))) - -(defvar auth-source-passphrase-alist nil) - -(defun auth-source-token-passphrase-callback-function (_context _key-id file) - (let* ((file (file-truename file)) - (entry (assoc file auth-source-passphrase-alist)) - passphrase) - ;; return the saved passphrase, calling a function if needed - (or (copy-sequence (if (functionp (cdr entry)) - (funcall (cdr entry)) - (cdr entry))) - (progn - (unless entry - (setq entry (list file)) - (push entry auth-source-passphrase-alist)) - (setq passphrase - (read-passwd - (format "Passphrase for %s tokens: " file) - t)) - (setcdr entry (lexical-let ((p (copy-sequence passphrase))) - (lambda () p))) - passphrase)))) - -;; (auth-source-epa-extract-gpg-token "gpg:LS0tLS1CRUdJTiBQR1AgTUVTU0FHRS0tLS0tClZlcnNpb246IEdudVBHIHYxLjQuMTEgKEdOVS9MaW51eCkKCmpBMEVBd01DT25qMjB1ak9rZnRneVI3K21iNm9aZWhuLzRad3cySkdlbnVaKzRpeEswWDY5di9icDI1U1dsQT0KPS9yc2wKLS0tLS1FTkQgUEdQIE1FU1NBR0UtLS0tLQo=" "~/.netrc") -(defun auth-source-epa-extract-gpg-token (secret file) - "Pass either the decoded SECRET or the gpg:BASE64DATA version. -FILE is the file from which we obtained this token." - (when (string-match "^gpg:\\(.+\\)" secret) - (setq secret (base64-decode-string (match-string 1 secret)))) - (let ((context (epg-make-context 'OpenPGP))) - (epg-context-set-passphrase-callback - context - (cons #'auth-source-token-passphrase-callback-function - file)) - (epg-decrypt-string context secret))) - -(defvar pp-escape-newlines) - -;; (insert (auth-source-epa-make-gpg-token "mysecret" "~/.netrc")) -(defun auth-source-epa-make-gpg-token (secret file) - (let ((context (epg-make-context 'OpenPGP)) - (pp-escape-newlines nil) - cipher) - (setf (epg-context-armor context) t) - (epg-context-set-passphrase-callback - context - (cons #'auth-source-token-passphrase-callback-function - file)) - (setq cipher (epg-encrypt-string context secret nil)) - (with-temp-buffer - (insert cipher) - (base64-encode-region (point-min) (point-max) t) - (concat "gpg:" (buffer-substring-no-properties - (point-min) - (point-max)))))) - -(defun auto-source--symbol-keyword (symbol) - (intern (format ":%s" symbol))) - -(defun auth-source-netrc-normalize (alist filename) - (mapcar (lambda (entry) - (let (ret item) - (while (setq item (pop entry)) - (let ((k (car item)) - (v (cdr item))) - - ;; apply key aliases - (setq k (cond ((member k '("machine")) "host") - ((member k '("login" "account")) "user") - ((member k '("protocol")) "port") - ((member k '("password")) "secret") - (t k))) - - ;; send back the secret in a function (lexical binding) - (when (equal k "secret") - (setq v (lexical-let ((lexv v) - (token-decoder nil)) - (when (string-match "^gpg:" lexv) - ;; it's a GPG token: create a token decoder - ;; which unsets itself once - (setq token-decoder - (lambda (val) - (prog1 - (auth-source-epa-extract-gpg-token - val - filename) - (setq token-decoder nil))))) - (lambda () - (when token-decoder - (setq lexv (funcall token-decoder lexv))) - lexv)))) - (setq ret (plist-put ret - (auto-source--symbol-keyword k) - v)))) - ret)) - alist)) - -;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret)) -;; (funcall secret) - -(defun* auth-source-netrc-search (&rest - spec - &key backend require create - type max host user port - &allow-other-keys) - "Given a property list SPEC, return search matches from the :backend. -See `auth-source-search' for details on SPEC." - ;; just in case, check that the type is correct (null or same as the backend) - (assert (or (null type) (eq type (oref backend type))) - t "Invalid netrc search: %s %s") - - (let ((results (auth-source-netrc-normalize - (auth-source-netrc-parse - :max max - :require require - :file (oref backend source) - :host (or host t) - :user (or user t) - :port (or port t)) - (oref backend source)))) - - ;; if we need to create an entry AND none were found to match - (when (and create - (not results)) - - ;; create based on the spec and record the value - (setq results (or - ;; if the user did not want to create the entry - ;; in the file, it will be returned - (apply (slot-value backend 'create-function) spec) - ;; if not, we do the search again without :create - ;; to get the updated data. - - ;; the result will be returned, even if the search fails - (apply #'auth-source-netrc-search - (plist-put spec :create nil))))) - results)) - -(defun auth-source-netrc-element-or-first (v) - (if (listp v) - (nth 0 v) - v)) - -;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t) -;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B))) - -(defun* auth-source-netrc-create (&rest spec - &key backend - host port create - &allow-other-keys) - (let* ((base-required '(host user port secret)) - ;; we know (because of an assertion in auth-source-search) that the - ;; :create parameter is either t or a list (which includes nil) - (create-extra (if (eq t create) nil create)) - (current-data (car (auth-source-search :max 1 - :host host - :port port))) - (required (append base-required create-extra)) - (file (oref backend source)) - (add "") - ;; `valist' is an alist - valist - ;; `artificial' will be returned if no creation is needed - artificial) - - ;; only for base required elements (defined as function parameters): - ;; fill in the valist with whatever data we may have from the search - ;; we complete the first value if it's a list and use the value otherwise - (dolist (br base-required) - (let ((val (plist-get spec (auto-source--symbol-keyword br)))) - (when val - (let ((br-choice (cond - ;; all-accepting choice (predicate is t) - ((eq t val) nil) - ;; just the value otherwise - (t val)))) - (when br-choice - (auth-source--aput valist br br-choice)))))) - - ;; for extra required elements, see if the spec includes a value for them - (dolist (er create-extra) - (let ((k (auto-source--symbol-keyword er)) - (keys (loop for i below (length spec) by 2 - collect (nth i spec)))) - (when (memq k keys) - (auth-source--aput valist er (plist-get spec k))))) - - ;; for each required element - (dolist (r required) - (let* ((data (auth-source--aget valist r)) - ;; take the first element if the data is a list - (data (or (auth-source-netrc-element-or-first data) - (plist-get current-data - (auto-source--symbol-keyword r)))) - ;; this is the default to be offered - (given-default (auth-source--aget - auth-source-creation-defaults r)) - ;; the default supplementals are simple: - ;; for the user, try `given-default' and then (user-login-name); - ;; otherwise take `given-default' - (default (cond - ((and (not given-default) (eq r 'user)) - (user-login-name)) - (t given-default))) - (printable-defaults (list - (cons 'user - (or - (auth-source-netrc-element-or-first - (auth-source--aget valist 'user)) - (plist-get artificial :user) - "[any user]")) - (cons 'host - (or - (auth-source-netrc-element-or-first - (auth-source--aget valist 'host)) - (plist-get artificial :host) - "[any host]")) - (cons 'port - (or - (auth-source-netrc-element-or-first - (auth-source--aget valist 'port)) - (plist-get artificial :port) - "[any port]")))) - (prompt (or (auth-source--aget auth-source-creation-prompts r) - (case r - (secret "%p password for %u@%h: ") - (user "%p user name for %h: ") - (host "%p host name for user %u: ") - (port "%p port for %u@%h: ")) - (format "Enter %s (%%u@%%h:%%p): " r))) - (prompt (auth-source-format-prompt - prompt - `((?u ,(auth-source--aget printable-defaults 'user)) - (?h ,(auth-source--aget printable-defaults 'host)) - (?p ,(auth-source--aget printable-defaults 'port)))))) - - ;; Store the data, prompting for the password if needed. - (setq data (or data - (if (eq r 'secret) - ;; Special case prompt for passwords. - ;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car epa-file-auto-mode-alist-entry) "\\.gpg\\'") nil) (t gpg))) - ;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never) - (let* ((ep (format "Use GPG password tokens in %s?" file)) - (gpg-encrypt - (cond - ((eq auth-source-netrc-use-gpg-tokens 'never) - 'never) - ((listp auth-source-netrc-use-gpg-tokens) - (let ((check (copy-sequence - auth-source-netrc-use-gpg-tokens)) - item ret) - (while check - (setq item (pop check)) - (when (or (eq (car item) t) - (string-match (car item) file)) - (setq ret (cdr item)) - (setq check nil))) - ;; FIXME: `ret' unused. - ;; Should we return it here? - )) - (t 'never))) - (plain (or (eval default) (read-passwd prompt)))) - ;; ask if we don't know what to do (in which case - ;; auth-source-netrc-use-gpg-tokens must be a list) - (unless gpg-encrypt - (setq gpg-encrypt (if (y-or-n-p ep) 'gpg 'never)) - ;; TODO: save the defcustom now? or ask? - (setq auth-source-netrc-use-gpg-tokens - (cons `(,file ,gpg-encrypt) - auth-source-netrc-use-gpg-tokens))) - (if (eq gpg-encrypt 'gpg) - (auth-source-epa-make-gpg-token plain file) - plain)) - (if (stringp default) - (read-string (if (string-match ": *\\'" prompt) - (concat (substring prompt 0 (match-beginning 0)) - " (default " default "): ") - (concat prompt "(default " default ") ")) - nil nil default) - (eval default))))) - - (when data - (setq artificial (plist-put artificial - (auto-source--symbol-keyword r) - (if (eq r 'secret) - (lexical-let ((data data)) - (lambda () data)) - data)))) - - ;; When r is not an empty string... - (when (and (stringp data) - (< 0 (length data))) - ;; this function is not strictly necessary but I think it - ;; makes the code clearer -tzz - (let ((printer (lambda () - ;; append the key (the symbol name of r) - ;; and the value in r - (format "%s%s %s" - ;; prepend a space - (if (zerop (length add)) "" " ") - ;; remap auth-source tokens to netrc - (case r - (user "login") - (host "machine") - (secret "password") - (port "port") ; redundant but clearer - (t (symbol-name r))) - (if (string-match "[\"# ]" data) - (format "%S" data) - data))))) - (setq add (concat add (funcall printer))))))) - - (plist-put - artificial - :save-function - (lexical-let ((file file) - (add add)) - (lambda () (auth-source-netrc-saver file add)))) - - (list artificial))) - -;;(funcall (plist-get (nth 0 (auth-source-search :host '("nonesuch2") :user "tzz" :port "imap" :create t :max 1)) :save-function)) -(defun auth-source-netrc-saver (file add) - "Save a line ADD in FILE, prompting along the way. -Respects `auth-source-save-behavior'. Uses -`auth-source-netrc-cache' to avoid prompting more than once." - (let* ((key (format "%s %s" file (rfc2104-hash 'md5 64 16 file add))) - (cached (assoc key auth-source-netrc-cache))) - - (if cached - (auth-source-do-trivia - "auth-source-netrc-saver: found previous run for key %s, returning" - key) - (with-temp-buffer - (when (file-exists-p file) - (insert-file-contents file)) - (when auth-source-gpg-encrypt-to - ;; (see bug#7487) making `epa-file-encrypt-to' local to - ;; this buffer lets epa-file skip the key selection query - ;; (see the `local-variable-p' check in - ;; `epa-file-write-region'). - (unless (local-variable-p 'epa-file-encrypt-to (current-buffer)) - (make-local-variable 'epa-file-encrypt-to)) - (if (listp auth-source-gpg-encrypt-to) - (setq epa-file-encrypt-to auth-source-gpg-encrypt-to))) - ;; we want the new data to be found first, so insert at beginning - (goto-char (point-min)) - - ;; Ask AFTER we've successfully opened the file. - (let ((prompt (format "Save auth info to file %s? " file)) - (done (not (eq auth-source-save-behavior 'ask))) - (bufname "*auth-source Help*") - k) - (while (not done) - (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ?e ??))) - (case k - (?y (setq done t)) - (?? (save-excursion - (with-output-to-temp-buffer bufname - (princ - (concat "(y)es, save\n" - "(n)o but use the info\n" - "(N)o and don't ask to save again\n" - "(e)dit the line\n" - "(?) for help as you can see.\n")) - ;; Why? Doesn't with-output-to-temp-buffer already do - ;; the exact same thing anyway? --Stef - (set-buffer standard-output) - (help-mode)))) - (?n (setq add "" - done t)) - (?N - (setq add "" - done t) - (customize-save-variable 'auth-source-save-behavior nil)) - (?e (setq add (read-string "Line to add: " add))) - (t nil))) - - (when (get-buffer-window bufname) - (delete-window (get-buffer-window bufname))) - - ;; Make sure the info is not saved. - (when (null auth-source-save-behavior) - (setq add "")) - - (when (< 0 (length add)) - (progn - (unless (bolp) - (insert "\n")) - (insert add "\n") - (write-region (point-min) (point-max) file nil 'silent) - ;; Make the .authinfo file non-world-readable. - (set-file-modes file #o600) - (auth-source-do-debug - "auth-source-netrc-create: wrote 1 new line to %s" - file) - (message "Saved new authentication information to %s" file) - nil)))) - (auth-source--aput auth-source-netrc-cache key "ran")))) - -;;; Backend specific parsing: Secrets API backend - -;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t)) -;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t)) -;; (let ((auth-sources '(default))) (auth-source-search :max 1)) -;; (let ((auth-sources '(default))) (auth-source-search)) -;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1)) -;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git")) - -(defun auth-source-secrets-listify-pattern (pattern) - "Convert a pattern with lists to a list of string patterns. - -auth-source patterns can have values of the form :foo (\"bar\" -\"qux\"), which means to match any secret with :foo equal to -\"bar\" or :foo equal to \"qux\". The secrets backend supports -only string values for patterns, so this routine returns a list -of patterns that is equivalent to the single original pattern -when interpreted such that if a secret matches any pattern in the -list, it matches the original pattern." - (if (null pattern) - '(nil) - (let* ((key (pop pattern)) - (value (pop pattern)) - (tails (auth-source-secrets-listify-pattern pattern)) - (heads (if (stringp value) - (list (list key value)) - (mapcar (lambda (v) (list key v)) value)))) - (loop - for h in heads - nconc - (loop - for tl in tails - collect (append h tl)))))) - -(defun* auth-source-secrets-search (&rest - spec - &key backend create delete label max - &allow-other-keys) - "Search the Secrets API; spec is like `auth-source'. - -The :label key specifies the item's label. It is the only key -that can specify a substring. Any :label value besides a string -will allow any label. - -All other search keys must match exactly. If you need substring -matching, do a wider search and narrow it down yourself. - -You'll get back all the properties of the token as a plist. - -Here's an example that looks for the first item in the `Login' -Secrets collection: - - (let ((auth-sources \\='(\"secrets:Login\"))) - (auth-source-search :max 1) - -Here's another that looks for the first item in the `Login' -Secrets collection whose label contains `gnus': - - (let ((auth-sources \\='(\"secrets:Login\"))) - (auth-source-search :max 1 :label \"gnus\") - -And this one looks for the first item in the `Login' Secrets -collection that's a Google Chrome entry for the git.gnus.org site -authentication tokens: - - (let ((auth-sources \\='(\"secrets:Login\"))) - (auth-source-search :max 1 :signon_realm \"https://git.gnus.org/Git\")) -" - - ;; TODO - (assert (not create) nil - "The Secrets API auth-source backend doesn't support creation yet") - ;; TODO - ;; (secrets-delete-item coll elt) - (assert (not delete) nil - "The Secrets API auth-source backend doesn't support deletion yet") - - (let* ((coll (oref backend source)) - (max (or max 5000)) ; sanity check: default to stop at 5K - (ignored-keys '(:create :delete :max :backend :label :require :type)) - (search-keys (loop for i below (length spec) by 2 - unless (memq (nth i spec) ignored-keys) - collect (nth i spec))) - ;; build a search spec without the ignored keys - ;; if a search key is nil or t (match anything), we skip it - (search-specs (auth-source-secrets-listify-pattern - (apply #'append (mapcar - (lambda (k) - (if (or (null (plist-get spec k)) - (eq t (plist-get spec k))) - nil - (list k (plist-get spec k)))) - search-keys)))) - ;; needed keys (always including host, login, port, and secret) - (returned-keys (mm-delete-duplicates (append - '(:host :login :port :secret) - search-keys))) - (items - (loop for search-spec in search-specs - nconc - (loop for item in (apply #'secrets-search-items coll search-spec) - unless (and (stringp label) - (not (string-match label item))) - collect item))) - ;; TODO: respect max in `secrets-search-items', not after the fact - (items (butlast items (- (length items) max))) - ;; convert the item name to a full plist - (items (mapcar (lambda (item) - (append - ;; make an entry for the secret (password) element - (list - :secret - (lexical-let ((v (secrets-get-secret coll item))) - (lambda () v))) - ;; rewrite the entry from ((k1 v1) (k2 v2)) to plist - (apply #'append - (mapcar (lambda (entry) - (list (car entry) (cdr entry))) - (secrets-get-attributes coll item))))) - items)) - ;; ensure each item has each key in `returned-keys' - (items (mapcar (lambda (plist) - (append - (apply #'append - (mapcar (lambda (req) - (if (plist-get plist req) - nil - (list req nil))) - returned-keys)) - plist)) - items))) - items)) - -(defun auth-source-secrets-create (&rest spec) - ;; TODO - ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec) - (debug spec)) - -;;; Backend specific parsing: Mac OS Keychain (using /usr/bin/security) backend - -;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1 :create t)) -;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1 :delete t)) -;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1)) -;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search)) - -;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1 :create t)) -;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1 :delete t)) -;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1)) -;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search)) - -;; (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 - &key backend create delete - type max - &allow-other-keys) - "Search the macOS Keychain; spec is like `auth-source'. - -All search keys must match exactly. If you need substring -matching, do a wider search and narrow it down yourself. - -You'll get back all the properties of the token as a plist. - -The :type key is either `macos-keychain-internet' or -`macos-keychain-generic'. - -For the internet keychain type, the :label key searches the -item's labels (\"-l LABEL\" passed to \"/usr/bin/security\"). -Similarly, :host maps to \"-s HOST\", :user maps to \"-a USER\", -and :port maps to \"-P PORT\" or \"-r PROT\" -\(note PROT has to be a 4-character string). - -For the generic keychain type, the :label key searches the item's -labels (\"-l LABEL\" passed to \"/usr/bin/security\"). -Similarly, :host maps to \"-c HOST\" (the \"creator\" keychain -field), :user maps to \"-a USER\", and :port maps to \"-s PORT\". - -Here's an example that looks for the first item in the default -generic macOS Keychain: - - (let ((auth-sources \\='(macos-keychain-generic))) - (auth-source-search :max 1) - -Here's another that looks for the first item in the internet -macOS Keychain collection whose label is `gnus': - - (let ((auth-sources \\='(macos-keychain-internet))) - (auth-source-search :max 1 :label \"gnus\") - -And this one looks for the first item in the internet keychain -entries for git.gnus.org: - - (let ((auth-sources \\='(macos-keychain-internet\"))) - (auth-source-search :max 1 :host \"git.gnus.org\")) -" - ;; TODO - (assert (not create) nil - "The macOS Keychain auth-source backend doesn't support creation yet") - ;; TODO - ;; (macos-keychain-delete-item coll elt) - (assert (not delete) nil - "The macOS Keychain auth-source backend doesn't support deletion yet") - - (let* ((coll (oref backend source)) - (max (or max 5000)) ; sanity check: default to stop at 5K - (ignored-keys '(:create :delete :max :backend :label)) - (search-keys (loop for i below (length spec) by 2 - unless (memq (nth i spec) ignored-keys) - collect (nth i spec))) - ;; build a search spec without the ignored keys - ;; if a search key is nil or t (match anything), we skip it - (search-spec (apply #'append (mapcar - (lambda (k) - (if (or (null (plist-get spec k)) - (eq t (plist-get spec k))) - nil - (list k (plist-get spec k)))) - search-keys))) - ;; needed keys (always including host, login, port, and secret) - (returned-keys (mm-delete-duplicates (append - '(:host :login :port :secret) - search-keys))) - (items (apply #'auth-source-macos-keychain-search-items - coll - type - max - search-spec)) - - ;; ensure each item has each key in `returned-keys' - (items (mapcar (lambda (plist) - (append - (apply #'append - (mapcar (lambda (req) - (if (plist-get plist req) - nil - (list req nil))) - returned-keys)) - plist)) - items))) - items)) - -(defun* auth-source-macos-keychain-search-items (coll _type _max - &key label type - host user port - &allow-other-keys) - - (let* ((keychain-generic (eq type 'macos-keychain-generic)) - (args `(,(if keychain-generic - "find-generic-password" - "find-internet-password") - "-g")) - (ret (list :type type))) - (when label - (setq args (append args (list "-l" label)))) - (when host - (setq args (append args (list (if keychain-generic "-c" "-s") host)))) - (when user - (setq args (append args (list "-a" user)))) - - (when port - (if keychain-generic - (setq args (append args (list "-s" port))) - (setq args (append args (list - (if (string-match "[0-9]+" port) "-P" "-r") - port))))) - - (unless (equal coll "default") - (setq args (append args (list coll)))) - - (with-temp-buffer - (apply #'call-process "/usr/bin/security" nil t nil args) - (goto-char (point-min)) - (while (not (eobp)) - (cond - ((looking-at "^password: \"\\(.+\\)\"$") - (setq ret (auth-source-macos-keychain-result-append - ret - keychain-generic - "secret" - (lexical-let ((v (match-string 1))) - (lambda () v))))) - ;; TODO: check if this is really the label - ;; match 0x00000007 <blob>="AppleID" - ((looking-at "^[ ]+0x00000007 <blob>=\"\\(.+\\)\"") - (setq ret (auth-source-macos-keychain-result-append - ret - keychain-generic - "label" - (match-string 1)))) - ;; match "crtr"<uint32>="aapl" - ;; match "svce"<blob>="AppleID" - ((looking-at "^[ ]+\"\\([a-z]+\\)\"[^=]+=\"\\(.+\\)\"") - (setq ret (auth-source-macos-keychain-result-append - ret - keychain-generic - (match-string 1) - (match-string 2))))) - (forward-line))) - ;; return `ret' iff it has the :secret key - (and (plist-get ret :secret) (list ret)))) - -(defun auth-source-macos-keychain-result-append (result generic k v) - (push v result) - (push (auto-source--symbol-keyword - (cond - ((equal k "acct") "user") - ;; for generic keychains, creator is host, service is port - ((and generic (equal k "crtr")) "host") - ((and generic (equal k "svce")) "port") - ;; for internet keychains, protocol is port, server is host - ((and (not generic) (equal k "ptcl")) "port") - ((and (not generic) (equal k "srvr")) "host") - (t k))) - result)) - -(defun auth-source-macos-keychain-create (&rest spec) - ;; TODO - (debug spec)) - -;;; Backend specific parsing: PLSTORE backend - -(defun* auth-source-plstore-search (&rest - spec - &key backend create delete - max - &allow-other-keys) - "Search the PLSTORE; spec is like `auth-source'." - (let* ((store (oref backend data)) - (max (or max 5000)) ; sanity check: default to stop at 5K - (ignored-keys '(:create :delete :max :backend :label :require :type)) - (search-keys (loop for i below (length spec) by 2 - unless (memq (nth i spec) ignored-keys) - collect (nth i spec))) - ;; build a search spec without the ignored keys - ;; if a search key is nil or t (match anything), we skip it - (search-spec (apply #'append (mapcar - (lambda (k) - (let ((v (plist-get spec k))) - (if (or (null v) - (eq t v)) - nil - (if (stringp v) - (setq v (list v))) - (list k v)))) - search-keys))) - ;; needed keys (always including host, login, port, and secret) - (returned-keys (mm-delete-duplicates (append - '(:host :login :port :secret) - search-keys))) - (items (plstore-find store search-spec)) - (item-names (mapcar #'car items)) - (items (butlast items (- (length items) max))) - ;; convert the item to a full plist - (items (mapcar (lambda (item) - (let* ((plist (copy-tree (cdr item))) - (secret (plist-member plist :secret))) - (if secret - (setcar - (cdr secret) - (lexical-let ((v (car (cdr secret)))) - (lambda () v)))) - plist)) - items)) - ;; ensure each item has each key in `returned-keys' - (items (mapcar (lambda (plist) - (append - (apply #'append - (mapcar (lambda (req) - (if (plist-get plist req) - nil - (list req nil))) - returned-keys)) - plist)) - items))) - (cond - ;; if we need to create an entry AND none were found to match - ((and create - (not items)) - - ;; create based on the spec and record the value - (setq items (or - ;; if the user did not want to create the entry - ;; in the file, it will be returned - (apply (slot-value backend 'create-function) spec) - ;; if not, we do the search again without :create - ;; to get the updated data. - - ;; the result will be returned, even if the search fails - (apply #'auth-source-plstore-search - (plist-put spec :create nil))))) - ((and delete - item-names) - (dolist (item-name item-names) - (plstore-delete store item-name)) - (plstore-save store))) - items)) - -(defun* auth-source-plstore-create (&rest spec - &key backend - host port create - &allow-other-keys) - (let* ((base-required '(host user port secret)) - (base-secret '(secret)) - ;; we know (because of an assertion in auth-source-search) that the - ;; :create parameter is either t or a list (which includes nil) - (create-extra (if (eq t create) nil create)) - (current-data (car (auth-source-search :max 1 - :host host - :port port))) - (required (append base-required create-extra)) - ;; `valist' is an alist - valist - ;; `artificial' will be returned if no creation is needed - artificial - secret-artificial) - - ;; only for base required elements (defined as function parameters): - ;; fill in the valist with whatever data we may have from the search - ;; we complete the first value if it's a list and use the value otherwise - (dolist (br base-required) - (let ((val (plist-get spec (auto-source--symbol-keyword br)))) - (when val - (let ((br-choice (cond - ;; all-accepting choice (predicate is t) - ((eq t val) nil) - ;; just the value otherwise - (t val)))) - (when br-choice - (auth-source--aput valist br br-choice)))))) - - ;; for extra required elements, see if the spec includes a value for them - (dolist (er create-extra) - (let ((k (auto-source--symbol-keyword er)) - (keys (loop for i below (length spec) by 2 - collect (nth i spec)))) - (when (memq k keys) - (auth-source--aput valist er (plist-get spec k))))) - - ;; for each required element - (dolist (r required) - (let* ((data (auth-source--aget valist r)) - ;; take the first element if the data is a list - (data (or (auth-source-netrc-element-or-first data) - (plist-get current-data - (auto-source--symbol-keyword r)))) - ;; this is the default to be offered - (given-default (auth-source--aget - auth-source-creation-defaults r)) - ;; the default supplementals are simple: - ;; for the user, try `given-default' and then (user-login-name); - ;; otherwise take `given-default' - (default (cond - ((and (not given-default) (eq r 'user)) - (user-login-name)) - (t given-default))) - (printable-defaults (list - (cons 'user - (or - (auth-source-netrc-element-or-first - (auth-source--aget valist 'user)) - (plist-get artificial :user) - "[any user]")) - (cons 'host - (or - (auth-source-netrc-element-or-first - (auth-source--aget valist 'host)) - (plist-get artificial :host) - "[any host]")) - (cons 'port - (or - (auth-source-netrc-element-or-first - (auth-source--aget valist 'port)) - (plist-get artificial :port) - "[any port]")))) - (prompt (or (auth-source--aget auth-source-creation-prompts r) - (case r - (secret "%p password for %u@%h: ") - (user "%p user name for %h: ") - (host "%p host name for user %u: ") - (port "%p port for %u@%h: ")) - (format "Enter %s (%%u@%%h:%%p): " r))) - (prompt (auth-source-format-prompt - prompt - `((?u ,(auth-source--aget printable-defaults 'user)) - (?h ,(auth-source--aget printable-defaults 'host)) - (?p ,(auth-source--aget printable-defaults 'port)))))) - - ;; Store the data, prompting for the password if needed. - (setq data (or data - (if (eq r 'secret) - (or (eval default) (read-passwd prompt)) - (if (stringp default) - (read-string - (if (string-match ": *\\'" prompt) - (concat (substring prompt 0 (match-beginning 0)) - " (default " default "): ") - (concat prompt "(default " default ") ")) - nil nil default) - (eval default))))) - - (when data - (if (member r base-secret) - (setq secret-artificial - (plist-put secret-artificial - (auto-source--symbol-keyword r) - data)) - (setq artificial (plist-put artificial - (auto-source--symbol-keyword r) - data)))))) - (plstore-put (oref backend data) - (sha1 (format "%s@%s:%s" - (plist-get artificial :user) - (plist-get artificial :host) - (plist-get artificial :port))) - artificial secret-artificial) - (if (y-or-n-p (format "Save auth info to file %s? " - (plstore-get-file (oref backend data)))) - (plstore-save (oref backend data))))) - -;;; older API - -;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz") - -;; deprecate the old interface -(make-obsolete 'auth-source-user-or-password - 'auth-source-search "Emacs 24.1") -(make-obsolete 'auth-source-forget-user-or-password - 'auth-source-forget "Emacs 24.1") - -(defun auth-source-user-or-password - (mode host port &optional username create-missing delete-existing) - "Find MODE (string or list of strings) matching HOST and PORT. - -DEPRECATED in favor of `auth-source-search'! - -USERNAME is optional and will be used as \"login\" in a search -across the Secret Service API (see secrets.el) if the resulting -items don't have a username. This means that if you search for -username \"joe\" and it matches an item but the item doesn't have -a :user attribute, the username \"joe\" will be returned. - -A non nil DELETE-EXISTING means deleting any matching password -entry in the respective sources. This is useful only when -CREATE-MISSING is non nil as well; the intended use case is to -remove wrong password entries. - -If no matching entry is found, and CREATE-MISSING is non nil, -the password will be retrieved interactively, and it will be -stored in the password database which matches best (see -`auth-sources'). - -MODE can be \"login\" or \"password\"." - (auth-source-do-debug - "auth-source-user-or-password: DEPRECATED get %s for %s (%s) + user=%s" - mode host port username) - - (let* ((listy (listp mode)) - (mode (if listy mode (list mode))) - ;; (cname (if username - ;; (format "%s %s:%s %s" mode host port username) - ;; (format "%s %s:%s" mode host port))) - (search (list :host host :port port)) - (search (if username (append search (list :user username)) search)) - (search (if create-missing - (append search (list :create t)) - search)) - (search (if delete-existing - (append search (list :delete t)) - search)) - ;; (found (if (not delete-existing) - ;; (gethash cname auth-source-cache) - ;; (remhash cname auth-source-cache) - ;; nil))) - (found nil)) - (if found - (progn - (auth-source-do-debug - "auth-source-user-or-password: DEPRECATED cached %s=%s for %s (%s) + %s" - mode - ;; don't show the password - (if (and (member "password" mode) t) - "SECRET" - found) - host port username) - found) ; return the found data - ;; else, if not found, search with a max of 1 - (let ((choice (nth 0 (apply #'auth-source-search - (append '(:max 1) search))))) - (when choice - (dolist (m mode) - (cond - ((equal "password" m) - (push (if (plist-get choice :secret) - (funcall (plist-get choice :secret)) - nil) found)) - ((equal "login" m) - (push (plist-get choice :user) found))))) - (setq found (nreverse found)) - (setq found (if listy found (car-safe found))))) - - found)) - -(defun auth-source-user-and-password (host &optional user) - (let* ((auth-info (car - (if user - (auth-source-search - :host host - :user "yourusername" - :max 1 - :require '(:user :secret) - :create nil) - (auth-source-search - :host host - :max 1 - :require '(:user :secret) - :create nil)))) - (user (plist-get auth-info :user)) - (password (plist-get auth-info :secret))) - (when (functionp password) - (setq password (funcall password))) - (list user password auth-info))) - -(provide 'auth-source) - -;;; auth-source.el ends here diff --git a/lisp/gnus/canlock.el b/lisp/gnus/canlock.el index a38c49a9193..9e13ced4670 100644 --- a/lisp/gnus/canlock.el +++ b/lisp/gnus/canlock.el @@ -70,13 +70,6 @@ buffer does not look like a news message." :type 'boolean :group 'canlock) -(eval-when-compile - (defmacro canlock-string-as-unibyte (string) - "Return a unibyte string with the same individual bytes as STRING." - (if (fboundp 'string-as-unibyte) - (list 'string-as-unibyte string) - string))) - (defun canlock-sha1 (message) "Make a SHA-1 digest of MESSAGE as a unibyte string of length 20 bytes." (let (sha1-maximum-internal-length) @@ -97,7 +90,7 @@ buffer does not look like a news message." (canlock-sha1 (concat opad (canlock-sha1 - (concat ipad (canlock-string-as-unibyte message-id)))))))) + (concat ipad (string-as-unibyte message-id)))))))) (defun canlock-narrow-to-header () "Narrow the buffer to the head of the message." diff --git a/lisp/gnus/compface.el b/lisp/gnus/compface.el deleted file mode 100644 index a5ebb33bc24..00000000000 --- a/lisp/gnus/compface.el +++ /dev/null @@ -1,62 +0,0 @@ -;;; compface.el --- functions for converting X-Face headers - -;; Copyright (C) 2002-2017 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; 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: - -;;; Code: - -;;;### -(defun uncompface (face) - "Convert FACE to pbm. -Requires the external programs `uncompface', and `icontopbm'. On a -GNU/Linux system these might be in packages with names like `compface' -or `faces-xface' and `netpbm' or `libgr-progs', for instance." - (with-temp-buffer - (unless (featurep 'xemacs) (set-buffer-multibyte nil)) - (insert face) - (let ((coding-system-for-read 'raw-text) - ;; At least "icontopbm" doesn't work with Windows because - ;; the line-break code is converted into CRLF by default. - (coding-system-for-write 'binary)) - (and (eq 0 (apply 'call-process-region (point-min) (point-max) - "uncompface" - 'delete '(t nil) nil)) - (progn - (goto-char (point-min)) - (insert "/* Format_version=1, Width=48, Height=48, Depth=1,\ - Valid_bits_per_item=16 */\n") - ;; I just can't get "icontopbm" to work correctly on its - ;; own in XEmacs. And Emacs doesn't understand un-raw pbm - ;; files. - (if (not (featurep 'xemacs)) - (eq 0 (call-process-region (point-min) (point-max) - "icontopbm" - 'delete '(t nil))) - (shell-command-on-region (point-min) (point-max) - "icontopbm | pnmnoraw" - (current-buffer) t) - t)) - (buffer-string))))) - -(provide 'compface) - -;;; compface.el ends here diff --git a/lisp/gnus/ecomplete.el b/lisp/gnus/ecomplete.el deleted file mode 100644 index e90739a7cfb..00000000000 --- a/lisp/gnus/ecomplete.el +++ /dev/null @@ -1,167 +0,0 @@ -;;; ecomplete.el --- electric completion of addresses and the like - -;; Copyright (C) 2006-2017 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)) - -(eval-when-compile - (when (featurep 'xemacs) - ;; The `kbd' macro requires that the `read-kbd-macro' macro is available. - (require 'edmacro))) - -(defgroup ecomplete nil - "Electric completion of email addresses and the like." - :group 'mail) - -(defcustom ecomplete-database-file "~/.ecompleterc" - "*The name of the file to store the ecomplete data." - :group 'ecomplete - :type 'file) - -(defcustom ecomplete-database-file-coding-system 'iso-2022-7bit - "Coding system used for writing the ecomplete database file." - :type '(symbol :tag "Coding system") - :group 'ecomplete) - -;;; Internal variables. - -(defvar ecomplete-database nil) - -;;;###autoload -(defun ecomplete-setup () - (when (file-exists-p ecomplete-database-file) - (with-temp-buffer - (let ((coding-system-for-read ecomplete-database-file-coding-system)) - (insert-file-contents ecomplete-database-file) - (setq ecomplete-database (read (current-buffer))))))) - -(defun ecomplete-add-item (type key text) - (let ((elems (assq type ecomplete-database)) - (now (string-to-number - (format "%.0f" (if (featurep 'emacs) - (float-time) - (require 'gnus-util) - (gnus-float-time))))) - entry) - (unless elems - (push (setq elems (list type)) ecomplete-database)) - (if (setq entry (assoc key (cdr elems))) - (setcdr entry (list (1+ (cadr entry)) now text)) - (nconc elems (list (list key 1 now text)))))) - -(defun ecomplete-get-item (type key) - (assoc key (cdr (assq type ecomplete-database)))) - -(defun ecomplete-save () - (with-temp-buffer - (let ((coding-system-for-write ecomplete-database-file-coding-system)) - (insert "(") - (loop for (type . elems) in ecomplete-database - do - (insert (format "(%s\n" type)) - (dolist (entry elems) - (prin1 entry (current-buffer)) - (insert "\n")) - (insert ")\n")) - (insert ")") - (write-region (point-min) (point-max) - ecomplete-database-file nil 'silent)))) - -(defun ecomplete-get-matches (type match) - (let* ((elems (cdr (assq type ecomplete-database))) - (match (regexp-quote match)) - (candidates - (sort - (loop for (key count time text) in elems - when (string-match match text) - collect (list count time text)) - (lambda (l1 l2) - (> (car l1) (car l2)))))) - (when (> (length candidates) 10) - (setcdr (nthcdr 10 candidates) nil)) - (unless (zerop (length candidates)) - (with-temp-buffer - (dolist (candidate candidates) - (insert (caddr candidate) "\n")) - (goto-char (point-min)) - (put-text-property (point) (1+ (point)) 'ecomplete t) - (while (re-search-forward match nil t) - (put-text-property (match-beginning 0) (match-end 0) - 'face 'isearch)) - (buffer-string))))) - -(defun ecomplete-display-matches (type word &optional choose) - (let* ((matches (ecomplete-get-matches type word)) - (line 0) - (max-lines (when matches (- (length (split-string matches "\n")) 2))) - (message-log-max nil) - command highlight) - (if (not matches) - (progn - (message "No ecomplete matches") - nil) - (if (not choose) - (progn - (message "%s" matches) - nil) - (setq highlight (ecomplete-highlight-match-line matches line)) - (let ((local-map (make-sparse-keymap)) - selected) - (define-key local-map (kbd "RET") - (lambda () (setq selected (nth line (split-string matches "\n"))))) - (define-key local-map (kbd "M-n") - (lambda () (setq line (min (1+ line) max-lines)))) - (define-key local-map (kbd "M-p") - (lambda () (setq line (max (1- line) 0)))) - (let ((overriding-local-map local-map)) - (while (and (null selected) - (setq command (read-key-sequence highlight)) - (lookup-key local-map command)) - (apply (key-binding command) nil) - (setq highlight (ecomplete-highlight-match-line matches line)))) - (if selected - (message selected) - (message "Abort")) - selected))))) - -(defun ecomplete-highlight-match-line (matches line) - (with-temp-buffer - (insert matches) - (goto-char (point-min)) - (forward-line line) - (save-restriction - (narrow-to-region (point) (point-at-eol)) - (while (not (eobp)) - ;; Put the 'region face on any characters on this line that - ;; aren't already highlighted. - (unless (get-text-property (point) 'face) - (put-text-property (point) (1+ (point)) 'face 'highlight)) - (forward-char 1))) - (buffer-string))) - -(provide 'ecomplete) - -;;; ecomplete.el ends here diff --git a/lisp/gnus/flow-fill.el b/lisp/gnus/flow-fill.el deleted file mode 100644 index e361c16598f..00000000000 --- a/lisp/gnus/flow-fill.el +++ /dev/null @@ -1,241 +0,0 @@ -;;; flow-fill.el --- interpret RFC2646 "flowed" text - -;; Copyright (C) 2000-2017 Free Software Foundation, Inc. - -;; Author: Simon Josefsson <jas@pdc.kth.se> -;; 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: - -;; This implement decoding of RFC2646 formatted text, including the -;; quoted-depth wins rules. - -;; Theory of operation: search for lines ending with SPC, save quote -;; length of line, remove SPC and concatenate line with the following -;; line if quote length of following line matches current line. - -;; When no further concatenations are possible, we've found a -;; paragraph and we let `fill-region' fill the long line into several -;; lines with the quote prefix as `fill-prefix'. - -;; Todo: implement basic `fill-region' (Emacs and XEmacs -;; implementations differ..) - -;;; History: - -;; 2000-02-17 posted on ding mailing list -;; 2000-02-19 use `point-at-{b,e}ol' in XEmacs -;; 2000-03-11 no compile warnings for point-at-bol stuff -;; 2000-03-26 committed to gnus cvs -;; 2000-10-23 don't flow "-- " lines, make "quote-depth wins" rule -;; work when first line is at level 0. -;; 2002-01-12 probably incomplete encoding support -;; 2003-12-08 started working on test harness. - -;;; Code: - -(eval-when-compile (require 'cl)) - -(defcustom fill-flowed-display-column 'fill-column - "Column beyond which format=flowed lines are wrapped, when displayed. -This can be a Lisp expression or an integer." - :version "22.1" - :group 'mime-display - :type '(choice (const :tag "Standard `fill-column'" fill-column) - (const :tag "Fit Window" (- (window-width) 5)) - (sexp) - (integer))) - -(defcustom fill-flowed-encode-column 66 - "Column beyond which format=flowed lines are wrapped, in outgoing messages. -This can be a Lisp expression or an integer. -RFC 2646 suggests 66 characters for readability." - :version "22.1" - :group 'mime-display - :type '(choice (const :tag "Standard fill-column" fill-column) - (const :tag "RFC 2646 default (66)" 66) - (sexp) - (integer))) - -;;;###autoload -(defun fill-flowed-encode (&optional buffer) - (with-current-buffer (or buffer (current-buffer)) - ;; No point in doing this unless hard newlines is used. - (when use-hard-newlines - (let ((start (point-min)) end) - ;; Go through each paragraph, filling it and adding SPC - ;; as the last character on each line. - (while (setq end (text-property-any start (point-max) 'hard 't)) - (save-restriction - (narrow-to-region start end) - (let ((fill-column (eval fill-flowed-encode-column))) - (fill-flowed-fill-buffer)) - (goto-char (point-min)) - (while (re-search-forward "\n" nil t) - (replace-match " \n" t t)) - (goto-char (setq start (1+ (point-max))))))) - t))) - -(defun fill-flowed-fill-buffer () - (let ((prefix nil) - (prev-prefix nil) - (start (point-min))) - (goto-char (point-min)) - (while (not (eobp)) - (setq prefix (and (looking-at "[> ]+") - (match-string 0))) - (if (equal prefix prev-prefix) - (forward-line 1) - (save-restriction - (narrow-to-region start (point)) - (let ((fill-prefix prev-prefix)) - (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop)) - (goto-char (point-max))) - (setq prev-prefix prefix - start (point)))) - (save-restriction - (narrow-to-region start (point)) - (let ((fill-prefix prev-prefix)) - (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop))))) - -;;;###autoload -(defun fill-flowed (&optional buffer delete-space) - (with-current-buffer (or (current-buffer) buffer) - (goto-char (point-min)) - ;; Remove space stuffing. - (while (re-search-forward "^\\( \\|>+ $\\)" nil t) - (delete-char -1) - (forward-line 1)) - (goto-char (point-min)) - (while (re-search-forward " $" nil t) - (when (save-excursion - (beginning-of-line) - (looking-at "^\\(>*\\)\\( ?\\)")) - (let ((quote (match-string 1)) - sig) - (if (string= quote "") - (setq quote nil)) - (when (and quote (string= (match-string 2) "")) - (save-excursion - ;; insert SP after quote for pleasant reading of quoted lines - (beginning-of-line) - (when (> (skip-chars-forward ">") 0) - (insert " ")))) - ;; XXX slightly buggy handling of "-- " - (while (and (save-excursion - (ignore-errors (backward-char 3)) - (setq sig (looking-at "-- ")) - (looking-at "[^-][^-] ")) - (save-excursion - (unless (eobp) - (forward-char 1) - (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)" - (or quote " ?")))))) - (save-excursion - (replace-match (if (string= (match-string 2) " ") - "" "\\2"))) - (backward-delete-char -1) - (when delete-space - (delete-char -1)) - (end-of-line)) - (unless sig - (condition-case nil - (let ((fill-prefix (when quote (concat quote " "))) - (fill-column (eval fill-flowed-display-column)) - filladapt-mode - adaptive-fill-mode) - (fill-region (point-at-bol) - (min (1+ (point-at-eol)) - (point-max)) - 'left 'nosqueeze)) - (error - (forward-line 1) - nil)))))))) - -;; Test vectors. - -(defvar show-trailing-whitespace) - -(defvar fill-flowed-encode-tests - `( - ;; The syntax of each list element is: - ;; (INPUT . EXPECTED-OUTPUT) - (,(concat - "> Thou villainous ill-breeding spongy dizzy-eyed \n" - "> reeky elf-skinned pigeon-egg! \n" - ">> Thou artless swag-bellied milk-livered \n" - ">> dismal-dreaming idle-headed scut!\n" - ">>> Thou errant folly-fallen spleeny reeling-ripe \n" - ">>> unmuzzled ratsbane!\n" - ">>>> Henceforth, the coding style is to be strictly \n" - ">>>> enforced, including the use of only upper case.\n" - ">>>>> I've noticed a lack of adherence to the coding \n" - ">>>>> styles, of late.\n" - ">>>>>> Any complaints?") - . - ,(concat - "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned\n" - "> pigeon-egg! \n" - ">> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed\n" - ">> scut!\n" - ">>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!\n" - ">>>> Henceforth, the coding style is to be strictly enforced,\n" - ">>>> including the use of only upper case.\n" - ">>>>> I've noticed a lack of adherence to the coding styles, of late.\n" - ">>>>>> Any complaints?\n" - )) - ;; (,(concat - ;; "\n" - ;; "> foo\n" - ;; "> \n" - ;; "> \n" - ;; "> bar\n") - ;; . - ;; ,(concat - ;; "\n" - ;; "> foo bar\n")) - )) - -(defun fill-flowed-test () - (interactive "") - (switch-to-buffer (get-buffer-create "*Format=Flowed test output*")) - (erase-buffer) - (setq show-trailing-whitespace t) - (dolist (test fill-flowed-encode-tests) - (let (start output) - (insert "***** BEGIN TEST INPUT *****\n") - (insert (car test)) - (insert "***** END TEST INPUT *****\n\n") - (insert "***** BEGIN TEST OUTPUT *****\n") - (setq start (point)) - (insert (car test)) - (save-restriction - (narrow-to-region start (point)) - (fill-flowed)) - (setq output (buffer-substring start (point-max))) - (insert "***** END TEST OUTPUT *****\n") - (unless (string= output (cdr test)) - (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n") - (insert (cdr test)) - (insert "***** END TEST EXPECTED OUTPUT *****\n")) - (insert "\n\n"))) - (goto-char (point-max))) - -(provide 'flow-fill) - -;;; flow-fill.el ends here diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index 59aec05cbff..45035646f76 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -97,34 +97,6 @@ ARGS are passed to `message'." (autoload 'widget-convert "wid-edit") (autoload 'widget-default-get "wid-edit") -;; Copy of the `nnmail-lazy' code from `nnmail.el': -(define-widget 'gmm-lazy 'default - "Base widget for recursive data structures. - -This is a copy of the `lazy' widget in Emacs 22.1 provided for compatibility." - :format "%{%t%}: %v" - :convert-widget 'widget-value-convert-widget - :value-create (lambda (widget) - (let ((value (widget-get widget :value)) - (type (widget-get widget :type))) - (widget-put widget :children - (list (widget-create-child-value - widget (widget-convert type) value))))) - :value-delete 'widget-children-value-delete - :value-get (lambda (widget) - (widget-value (car (widget-get widget :children)))) - :value-inline (lambda (widget) - (widget-apply (car (widget-get widget :children)) - :value-inline)) - :default-get (lambda (widget) - (widget-default-get - (widget-convert (widget-get widget :type)))) - :match (lambda (widget value) - (widget-apply (widget-convert (widget-get widget :type)) - :match value)) - :validate (lambda (widget) - (widget-apply (car (widget-get widget :children)) :validate))) - ;; Note: The format of `gmm-tool-bar-item' may change if some future Emacs ;; version will provide customizable tool bar buttons using a different ;; interface. @@ -144,7 +116,7 @@ This is a copy of the `lazy' widget in Emacs 22.1 provided for compatibility." ;; ;; Then use (plist-get rs-command :none), (plist-get rs-command :shift) -(define-widget 'gmm-tool-bar-item (if (gmm-widget-p 'lazy) 'lazy 'gmm-lazy) +(define-widget 'gmm-tool-bar-item 'lazy "Tool bar list item." :tag "Tool bar item" :type '(choice @@ -163,7 +135,7 @@ This is a copy of the `lazy' widget in Emacs 22.1 provided for compatibility." (const :tag "No map") (plist :inline t :tag "Properties")))) -(define-widget 'gmm-tool-bar-zap-list (if (gmm-widget-p 'lazy) 'lazy 'gmm-lazy) +(define-widget 'gmm-tool-bar-zap-list 'lazy "Tool bar zap list." :tag "Tool bar zap list" :type '(choice (const :tag "Zap all" t) @@ -193,28 +165,12 @@ This is a copy of the `lazy' widget in Emacs 22.1 provided for compatibility." :tag "Other" (symbol :tag "Icon item"))))) -;; (defun gmm-color-cells (&optional display) -;; "Return the number of color cells supported by DISPLAY. -;; Compatibility function." -;; ;; `display-color-cells' doesn't return more than 256 even if color depth is -;; ;; > 8 in Emacs 21. -;; ;; -;; ;; Feel free to add proper XEmacs support. -;; (let* ((cells (and (fboundp 'display-color-cells) -;; (display-color-cells display))) -;; (plane (and (fboundp 'x-display-planes) -;; (ash 1 (x-display-planes)))) -;; (none -1)) -;; (max (if (integerp cells) cells none) -;; (if (integerp plane) plane none)))) - (defcustom gmm-tool-bar-style (if (and (boundp 'tool-bar-mode) tool-bar-mode - (and (fboundp 'display-visual-class) - (not (memq (display-visual-class) - (list 'static-gray 'gray-scale - 'static-color 'pseudo-color))))) + (memq (display-visual-class) + (list 'static-gray 'gray-scale + 'static-color 'pseudo-color))) 'gnome 'retro) "Preferred tool bar style." @@ -242,15 +198,13 @@ item. When \\[describe-key] <icon> shows \"<tool-bar> <new-file> runs the command find-file\", then use `new-file' in ZAP-LIST. DEFAULT-MAP specifies the default key map for ICON-LIST." - (let (;; For Emacs 21, we must let-bind `tool-bar-map'. In Emacs 22, we - ;; could use some other local variable. - (tool-bar-map (if (eq zap-list t) - (make-sparse-keymap) - (copy-keymap tool-bar-map)))) + (let ((map (if (eq zap-list t) + (make-sparse-keymap) + (copy-keymap tool-bar-map)))) (when (listp zap-list) ;; Zap some items which aren't relevant for this mode and take up space. (dolist (key zap-list) - (define-key tool-bar-map (vector key) nil))) + (define-key map (vector key) nil))) (mapc (lambda (el) (let ((command (car el)) (icon (nth 1 el)) @@ -262,7 +216,7 @@ DEFAULT-MAP specifies the default key map for ICON-LIST." ;; widget. Suppress tooltip by adding `:enable nil'. (if (fboundp 'tool-bar-local-item) (apply 'tool-bar-local-item icon nil nil - tool-bar-map :enable nil props) + map :enable nil props) ;; (tool-bar-local-item ICON DEF KEY MAP &rest PROPS) ;; (tool-bar-add-item ICON DEF KEY &rest PROPS) (apply 'tool-bar-add-item icon nil nil :enable nil props))) @@ -270,18 +224,18 @@ DEFAULT-MAP specifies the default key map for ICON-LIST." (apply 'tool-bar-local-item icon command (intern icon) ;; reuse icon or fmap here? - tool-bar-map props)) + map props)) (t ;; A menu command (apply 'tool-bar-local-item-from-menu ;; (apply 'tool-bar-local-item icon def key ;; tool-bar-map props) - command icon tool-bar-map (symbol-value fmap) + command icon map (symbol-value fmap) props))) t)) (if (symbolp icon-list) (eval icon-list) icon-list)) - tool-bar-map)) + map)) (defmacro defun-gmm (name function arg-list &rest body) "Create function NAME. @@ -292,109 +246,6 @@ Otherwise, create function NAME with ARG-LIST and BODY." `(defalias ',name ',function) `(defun ,name ,arg-list ,@body)))) -(defun-gmm gmm-image-search-load-path - image-search-load-path (file &optional path) - "Emacs 21 and XEmacs don't have `image-search-load-path'. -This function returns nil on those systems." - nil) - -;; Cf. `mh-image-load-path-for-library' in `mh-compat.el'. - -(defun-gmm gmm-image-load-path-for-library - image-load-path-for-library (library image &optional path no-error) - "Return a suitable search path for images used by LIBRARY. - -It searches for IMAGE in `image-load-path' (excluding -\"`data-directory'/images\") and `load-path', followed by a path -suitable for LIBRARY, which includes \"../../etc/images\" and -\"../etc/images\" relative to the library file itself, and then -in \"`data-directory'/images\". - -Then this function returns a list of directories which contains -first the directory in which IMAGE was found, followed by the -value of `load-path'. If PATH is given, it is used instead of -`load-path'. - -If NO-ERROR is non-nil and a suitable path can't be found, don't -signal an error. Instead, return a list of directories as before, -except that nil appears in place of the image directory. - -Here is an example that uses a common idiom to provide -compatibility with versions of Emacs that lack the variable -`image-load-path': - - ;; Shush compiler. - (defvar image-load-path) - - (let* ((load-path (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\")) - (image-load-path (cons (car load-path) - (when (boundp \\='image-load-path) - image-load-path)))) - (mh-tool-bar-folder-buttons-init))" - (unless library (error "No library specified")) - (unless image (error "No image specified")) - (let (image-directory image-directory-load-path) - ;; Check for images in image-load-path or load-path. - (let ((img image) - (dir (or - ;; Images in image-load-path. - (gmm-image-search-load-path image) ;; "gmm-" prefix! - ;; Images in load-path. - (locate-library image))) - parent) - ;; Since the image might be in a nested directory (for - ;; example, mail/attach.pbm), adjust `image-directory' - ;; accordingly. - (when dir - (setq dir (file-name-directory dir)) - (while (setq parent (file-name-directory img)) - (setq img (directory-file-name parent) - dir (expand-file-name "../" dir)))) - (setq image-directory-load-path dir)) - - ;; If `image-directory-load-path' isn't Emacs's image directory, - ;; it's probably a user preference, so use it. Then use a - ;; relative setting if possible; otherwise, use - ;; `image-directory-load-path'. - (cond - ;; User-modified image-load-path? - ((and image-directory-load-path - (not (equal image-directory-load-path - (file-name-as-directory - (expand-file-name "images" data-directory))))) - (setq image-directory image-directory-load-path)) - ;; Try relative setting. - ((let (library-name d1ei d2ei) - ;; First, find library in the load-path. - (setq library-name (locate-library library)) - (if (not library-name) - (error "Cannot find library %s in load-path" library)) - ;; And then set image-directory relative to that. - (setq - ;; Go down 2 levels. - d2ei (file-name-as-directory - (expand-file-name - (concat (file-name-directory library-name) "../../etc/images"))) - ;; Go down 1 level. - d1ei (file-name-as-directory - (expand-file-name - (concat (file-name-directory library-name) "../etc/images")))) - (setq image-directory - ;; Set it to nil if image is not found. - (cond ((file-exists-p (expand-file-name image d2ei)) d2ei) - ((file-exists-p (expand-file-name image d1ei)) d1ei))))) - ;; Use Emacs's image directory. - (image-directory-load-path - (setq image-directory image-directory-load-path)) - (no-error - (message "Could not find image %s for library %s" image library)) - (t - (error "Could not find image %s for library %s" image library))) - - ;; Return an augmented `path' or `load-path'. - (nconc (list image-directory) - (delete image-directory (copy-sequence (or path load-path)))))) - (defun gmm-customize-mode (&optional mode) "Customize customization group for MODE. If mode is nil, use `major-mode' of the current buffer." @@ -405,75 +256,8 @@ If mode is nil, use `major-mode' of the current buffer." (string-match "^\\(.+\\)-mode$" mode) (match-string 1 mode)))))) -(defun gmm-write-region (start end filename &optional append visit - lockname mustbenew) - "Compatibility function for `write-region'. - -In XEmacs, the seventh argument of `write-region' specifies the -coding-system." - (if (and mustbenew (featurep 'xemacs)) - (if (file-exists-p filename) - (signal 'file-already-exists (list "File exists" filename)) - (write-region start end filename append visit lockname)) - (write-region start end filename append visit lockname mustbenew))) - -;; `interactive-p' is obsolete since Emacs 23.2. -(defmacro gmm-called-interactively-p (kind) - (condition-case nil - (progn - (eval '(called-interactively-p 'any)) - ;; Emacs >=23.2 - `(called-interactively-p ,kind)) - ;; Emacs <23.2 - (wrong-number-of-arguments '(called-interactively-p)) - ;; XEmacs - (void-function '(interactive-p)))) - -;; `labels' is obsolete since Emacs 24.3. -(defmacro gmm-labels (bindings &rest body) - "Make temporary function bindings. -The bindings can be recursive and the scoping is lexical, but capturing -them in closures will only work if `lexical-binding' is in use. But in -Emacs 24.2 and older, the lexical scoping is handled via `lexical-let' -rather than relying on `lexical-binding'. - -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" - `(,(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 t))) +(define-obsolete-function-alias 'gmm-format-time-string 'format-time-string + "26.1") (provide 'gmm-utils) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 52cca4b762f..93d86526af0 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -30,10 +30,8 @@ (require 'gnus-score) (require 'gnus-srvr) (require 'gnus-util) +(require 'timer) (eval-when-compile - (if (featurep 'xemacs) - (require 'itimer) - (require 'timer)) (require 'cl)) (autoload 'gnus-server-update-server "gnus-srvr") @@ -82,28 +80,16 @@ If nil, only read articles will be expired." :group 'gnus-agent :type 'hook) -;; Extracted from gnus-xmas-redefine in order to preserve user settings -(when (featurep 'xemacs) - (add-hook 'gnus-agent-group-mode-hook 'gnus-xmas-agent-group-menu-add)) - (defcustom gnus-agent-summary-mode-hook nil "Hook run in Agent summary minor modes." :group 'gnus-agent :type 'hook) -;; Extracted from gnus-xmas-redefine in order to preserve user settings -(when (featurep 'xemacs) - (add-hook 'gnus-agent-summary-mode-hook 'gnus-xmas-agent-summary-menu-add)) - (defcustom gnus-agent-server-mode-hook nil "Hook run in Agent summary minor modes." :group 'gnus-agent :type 'hook) -;; Extracted from gnus-xmas-redefine in order to preserve user settings -(when (featurep 'xemacs) - (add-hook 'gnus-agent-server-mode-hook 'gnus-xmas-agent-server-menu-add)) - (defcustom gnus-agent-confirmation-function 'y-or-n-p "Function to confirm when error happens." :version "21.1" @@ -175,7 +161,7 @@ enable expiration per categories, topics, and groups." (const :format "Disable " DISABLE))) (defcustom gnus-agent-expire-unagentized-dirs t - "*Whether expiration should expire in unagentized directories. + "Whether expiration should expire in unagentized directories. Have gnus-agent-expire scan the directories under \(gnus-agent-directory) for groups that are no longer agentized. When found, offer to remove them." @@ -252,16 +238,6 @@ NOTES: (defvar gnus-headers) (defvar gnus-score) -;; Added to support XEmacs -(eval-and-compile - (unless (fboundp 'directory-files-and-attributes) - (defun directory-files-and-attributes (directory - &optional full match nosort) - (let (result) - (dolist (file (directory-files directory full match nosort)) - (push (cons file (file-attributes file)) result)) - (nreverse result))))) - ;;; ;;; Setup ;;; @@ -571,19 +547,9 @@ manipulated as follows: ["Remove" gnus-agent-remove-server t])))) (defun gnus-agent-make-mode-line-string (string mouse-button mouse-func) - (if (and (fboundp 'propertize) - (fboundp 'make-mode-line-mouse-map)) - (propertize string 'local-map - (make-mode-line-mouse-map mouse-button mouse-func) - 'mouse-face - (if (and (featurep 'xemacs) - ;; XEmacs's `facep' only checks for a face - ;; object, not for a face name, so it's useless - ;; to check with `facep'. - (find-face 'modeline)) - 'modeline - 'mode-line-highlight)) - string)) + (propertize string 'local-map + (make-mode-line-mouse-map mouse-button mouse-func) + 'mouse-face 'mode-line-highlight)) (defun gnus-agent-toggle-plugged (set-to) "Toggle whether Gnus is unplugged or not." @@ -868,7 +834,7 @@ be a select method." (not (eq gnus-agent-synchronize-flags 'ask))) (and (eq gnus-agent-synchronize-flags 'ask) (gnus-y-or-n-p - (gnus-format-message + (format-message "Synchronize flags on server `%s'? " (cadr method)))))) (gnus-agent-synchronize-flags-server method))) @@ -2667,8 +2633,10 @@ General format specifiers can also be used. See Info node "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) -(defvar gnus-category-menu-hook nil - "*Hook run after the creation of the menu.") +(defcustom gnus-category-menu-hook nil + "Hook run after the creation of the menu." + :group 'gnus-agent + :type 'hook) (defun gnus-category-make-menu-bar () (gnus-turn-off-edit-menu 'category) @@ -2713,7 +2681,7 @@ The following commands are available: (let* ((gnus-tmp-name (format "%s" (car category))) (gnus-tmp-groups (length (gnus-agent-cat-groups category)))) (beginning-of-line) - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) ;; Insert the text. diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 60b6a3718ba..920ef1e2494 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -158,7 +158,7 @@ "Envelope-To" "X-Spam-Score" "System-Type" "X-Injected-Via-Gmane" "X-Gmane-NNTP-Posting-Host" "Jabber-ID" "Archived-At" "Envelope-Sender" "Envelope-Recipients")) - "*All headers that start with this regexp will be hidden. + "All headers that start with this regexp will be hidden. This variable can also be a list of regexps of headers to be ignored. If `gnus-visible-headers' is non-nil, this variable will be ignored." :type '(choice regexp @@ -167,7 +167,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." (defcustom gnus-visible-headers "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:" - "*All headers that do not match this regexp will be hidden. + "All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. If this variable is non-nil, `gnus-ignored-headers' will be ignored." :type '(choice @@ -184,7 +184,7 @@ If this variable is non-nil, `gnus-ignored-headers' will be ignored." (defcustom gnus-sorted-header-list '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:") - "*This variable is a list of regular expressions. + "This variable is a list of regular expressions. If it is non-nil, headers that match the regular expressions will be placed first in the article buffer in the sequence specified by this list." @@ -266,19 +266,12 @@ This can also be a list of the above values." ;; Fixme: This isn't the right thing for mixed graphical and non-graphical ;; frames in a session. (defcustom gnus-article-x-face-command - (if (featurep 'xemacs) - (if (or (gnus-image-type-available-p 'xface) - (gnus-image-type-available-p 'pbm)) - 'gnus-display-x-face-in-from - "{ echo \ + (if (gnus-image-type-available-p 'pbm) + 'gnus-display-x-face-in-from + "{ echo \ '/* Format_version=1, Width=48, Height=48, Depth=1, Valid_bits_per_item=16 */'\ -; uncompface; } | icontopbm | ee -") - (if (gnus-image-type-available-p 'pbm) - 'gnus-display-x-face-in-from - "{ echo \ -'/* Format_version=1, Width=48, Height=48, Depth=1, Valid_bits_per_item=16 */'\ -; uncompface; } | icontopbm | display -")) - "*String or function to be executed to display an X-Face header. +; uncompface; } | icontopbm | display -") + "String or function to be executed to display an X-Face header. If it is a string, the command will be executed in a sub-shell asynchronously. The compressed face will be piped to this command." :type `(choice string @@ -396,7 +389,7 @@ advertisements. For example: ;; 2 3 gnus-emphasis-strikethru) ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" 2 3 gnus-emphasis-underline)))) - "*Alist that says how to fontify certain phrases. + "Alist that says how to fontify certain phrases. Each item looks like this: (\"_\\\\(\\\\w+\\\\)_\" 0 1 \\='underline) @@ -484,9 +477,7 @@ and the latter avoids underlining any whitespace at all." Example: (_/*word*/_)." :group 'gnus-article-emphasis) -(defface gnus-emphasis-strikethru (if (featurep 'xemacs) - '((t (:strikethru t))) - '((t (:strike-through t)))) +(defface gnus-emphasis-strikethru '((t (:strike-through t))) "Face used for displaying strike-through text (-word-)." :group 'gnus-article-emphasis) @@ -507,7 +498,7 @@ be fed to `format-time-string'." :group 'gnus-article-washing) (defcustom gnus-save-all-headers t - "*If non-nil, don't remove any headers before saving. + "If non-nil, don't remove any headers before saving. This will be overridden by the `:headers' property that the symbol of the saver function, which is specified by `gnus-default-article-saver', might have." @@ -515,7 +506,7 @@ might have." :type 'boolean) (defcustom gnus-prompt-before-saving 'always - "*This variable says how much prompting is to be done when saving articles. + "This variable says how much prompting is to be done when saving articles. If it is nil, no prompting will be done, and the articles will be saved to the default files. If this variable is `always', each and every article that is saved will be preceded by a prompt, even when @@ -662,7 +653,7 @@ LAST-FILE." (defcustom gnus-split-methods '((gnus-article-archive-name) (gnus-article-nndoc-name)) - "*Variable used to suggest where articles are to be saved. + "Variable used to suggest where articles are to be saved. For instance, if you would like to save articles related to Gnus in the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\", you could set this variable to something like: @@ -688,14 +679,14 @@ used as possible file names." (sexp :value nil)))) (defcustom gnus-page-delimiter "^\^L" - "*Regexp describing what to use as article page delimiters. + "Regexp describing what to use as article page delimiters. The default value is \"^\^L\", which is a form linefeed at the beginning of a line." :type 'regexp :group 'gnus-article-various) (defcustom gnus-article-mode-line-format "Gnus: %g %S%m" - "*The format specification for the article mode line. + "The format specification for the article mode line. See `gnus-summary-mode-line-format' for a closer description. The following additional specs are available: @@ -707,24 +698,17 @@ The following additional specs are available: :group 'gnus-article-various) (defcustom gnus-article-mode-hook nil - "*A hook for Gnus article mode." + "A hook for Gnus article mode." :type 'hook :group 'gnus-article-various) -(when (featurep 'xemacs) - ;; Extracted from gnus-xmas-define in order to preserve user settings - (when (fboundp 'turn-off-scroll-in-place) - (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place)) - ;; Extracted from gnus-xmas-redefine in order to preserve user settings - (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)) - (defcustom gnus-article-menu-hook nil - "*Hook run after the creation of the article mode menu." + "Hook run after the creation of the article mode menu." :type 'hook :group 'gnus-article-various) (defcustom gnus-article-prepare-hook nil - "*A hook called after an article has been prepared in the article buffer." + "A hook called after an article has been prepared in the article buffer." :type 'hook :group 'gnus-article-various) @@ -862,7 +846,7 @@ articles." ("Subject" nil gnus-header-subject) ("Newsgroups:.*," nil gnus-header-newsgroups) ("" gnus-header-name gnus-header-content)) - "*Controls highlighting of article headers. + "Controls highlighting of article headers. An alist of the form (HEADER NAME CONTENT). @@ -883,10 +867,8 @@ be displayed by the first non-nil matching CONTENT face." (item :tag "skip" nil) (face :value default))))) -(defcustom gnus-face-properties-alist (if (featurep 'xemacs) - '((xface . (:face gnus-x-face))) - '((pbm . (:face gnus-x-face)) - (png . nil))) +(defcustom gnus-face-properties-alist '((pbm . (:face gnus-x-face)) + (png . nil)) "Alist of image types and properties applied to Face and X-Face images. Here are examples: @@ -902,8 +884,7 @@ Here are examples: See the manual for the valid properties for various image types. Currently, `pbm' is used for X-Face images and `png' is used for Face -images in Emacs. Only the `:face' property is effective on the `xface' -image type in XEmacs if it is built with the libcompface library." +images in Emacs." :version "23.1" ;; No Gnus :group 'gnus-article-headers :type '(repeat (cons :format "%v" (symbol :tag "Image type") plist))) @@ -911,7 +892,7 @@ image type in XEmacs if it is built with the libcompface library." (defcustom gnus-article-decode-hook '(article-decode-charset article-decode-encoded-words article-decode-group-name article-decode-idna-rhs) - "*Hook run to decode charsets in articles." + "Hook run to decode charsets in articles." :group 'gnus-article-headers :type 'hook) @@ -1412,7 +1393,7 @@ predicate. See Info node `(gnus)Customizing Articles'." :type gnus-article-treat-custom) (put 'gnus-treat-overstrike 'highlight t) -(defcustom gnus-treat-ansi-sequences (if (locate-library "ansi-color") t) +(defcustom gnus-treat-ansi-sequences t "Treat ANSI SGR control sequences. Valid values are nil, t, `head', `first', `last', an integer or a predicate. See Info node `(gnus)Customizing Articles'." @@ -1426,14 +1407,12 @@ predicate. See Info node `(gnus)Customizing Articles'." (defcustom gnus-treat-display-x-face (and (not noninteractive) (gnus-image-type-available-p 'xbm) - (if (featurep 'xemacs) - (featurep 'xface) - (condition-case nil - (and (string-match "^0x" (shell-command-to-string "uncompface")) - (executable-find "icontopbm")) - ;; shell-command-to-string may signal an error, e.g. if - ;; shell-file-name is not found. - (error nil))) + (condition-case nil + (and (string-match "^0x" (shell-command-to-string "uncompface")) + (executable-find "icontopbm")) + ;; shell-command-to-string may signal an error, e.g. if + ;; shell-file-name is not found. + (error nil)) 'head) "Display X-Face headers. Valid values are nil and `head'. @@ -1631,18 +1610,9 @@ It is a string, such as \"PGP\". If nil, ask user." :type 'string :group 'mime-security) -(defvar idna-program) - -(defcustom gnus-use-idna (and (mm-coding-system-p 'utf-8) - (condition-case nil - (require 'idna) - (file-error) - (invalid-operation)) - idna-program - (executable-find idna-program)) - "Whether IDNA decoding of headers is used when viewing messages. -This requires GNU Libidn, and by default only enabled if it is found." - :version "22.1" +(defcustom gnus-use-idna t + "Whether IDNA decoding of headers is used when viewing messages." + :version "26.1" :group 'gnus-article-headers :type 'boolean) @@ -2087,7 +2057,7 @@ always hide." (- gnus-article-normalized-header-length column) ? ))) ((> column gnus-article-normalized-header-length) - (gnus-put-text-property + (put-text-property (progn (forward-char gnus-article-normalized-header-length) (point)) @@ -2117,21 +2087,17 @@ try this wash." "Translate many Unicode characters into their ASCII equivalents." (interactive) (require 'org-entities) - (let ((table (make-char-table (if (featurep 'xemacs) 'generic)))) + (let ((table (make-char-table nil))) (dolist (elem org-entities) (when (and (listp elem) (= (length (nth 6 elem)) 1)) - (if (featurep 'xemacs) - (put-char-table (aref (nth 6 elem) 0) (nth 4 elem) table) - (set-char-table-range table (aref (nth 6 elem) 0) (nth 4 elem))))) + (set-char-table-range table (aref (nth 6 elem) 0) (nth 4 elem)))) (save-excursion (when (article-goto-body) (let ((inhibit-read-only t) replace props) (while (not (eobp)) - (if (not (setq replace (if (featurep 'xemacs) - (get-char-table (following-char) table) - (aref table (following-char))))) + (if (not (setq replace (aref table (following-char)))) (forward-char 1) (if (prog1 (setq props (text-properties-at (point))) @@ -2314,8 +2280,6 @@ long lines if and only if arg is positive." (setq truncate-lines nil)) ((numberp arg) (setq truncate-lines t))) - ;; In versions of Emacs 22 (CVS) before 2006-05-26, - ;; `toggle-truncate-lines' needs an argument. (toggle-truncate-lines))) (defun gnus-article-treat-body-boundary () @@ -2327,15 +2291,13 @@ long lines if and only if arg is positive." (goto-char (point-max)) (let ((start (point))) (insert "X-Boundary: ") - (gnus-add-text-properties start (point) gnus-hidden-properties) + (add-text-properties start (point) gnus-hidden-properties) (insert (let (str (max (window-width))) - (if (featurep 'xemacs) - (setq max (1- max))) (while (>= max (length str)) (setq str (concat str gnus-body-boundary-delimiter))) (substring str 0 max)) "\n") - (gnus-put-text-property start (point) 'gnus-decoration 'header))))) + (put-text-property start (point) 'gnus-decoration 'header))))) (defun article-fill-long-lines () "Fill lines that are wider than the window width." @@ -2492,7 +2454,7 @@ long lines if and only if arg is positive." ;; The command is a string, so we interpret the command ;; as a, well, command, and fork it off. (let ((process-connection-type nil)) - (gnus-set-process-query-on-exit-flag + (set-process-query-on-exit-flag (start-process "article-x-face" nil shell-file-name shell-command-switch gnus-article-x-face-command) @@ -2541,7 +2503,7 @@ If PROMPT (the prefix), prompt for a coding system to use." ctl (and ct (mail-header-parse-content-type ct)) charset (cond (prompt - (mm-read-coding-system "Charset to decode: ")) + (read-coding-system "Charset to decode: ")) (ctl (mail-content-type-get ctl 'charset))) format (and ctl (mail-content-type-get ctl 'format))) @@ -2620,8 +2582,6 @@ If PROMPT (the prefix), prompt for a coding system to use." t t nil 1)) (goto-char (point-min))))))) -(autoload 'idna-to-unicode "idna") - (defun article-decode-idna-rhs () "Decode IDNA strings in RHS in various headers in current buffer. The following headers are decoded: From:, To:, Cc:, Reply-To:, @@ -2639,7 +2599,7 @@ Mail-Reply-To: and Mail-Followup-To:." (save-excursion (and (re-search-backward "^[^ \t]" nil t) (looking-at "From\\|To\\|Cc\\|Reply-To\\|Mail-Reply-To\\|Mail-Followup-To"))) - (setq unicode (idna-to-unicode ace)))) + (setq unicode (puny-decode-domain ace)))) (unless (string= ace unicode) (replace-match unicode nil nil nil 1))))))))) @@ -2662,7 +2622,7 @@ If READ-CHARSET, ask for a coding system." (if (stringp charset) (setq charset (intern (downcase charset))))))) (if read-charset - (setq charset (mm-read-coding-system "Charset: " charset))) + (setq charset (read-coding-system "Charset: " charset))) (unless charset (setq charset gnus-newsgroup-charset)) (when (or force @@ -2690,7 +2650,7 @@ If READ-CHARSET, ask for a coding system." (if (stringp charset) (setq charset (intern (downcase charset))))))) (if read-charset - (setq charset (mm-read-coding-system "Charset: " charset))) + (setq charset (read-coding-system "Charset: " charset))) (unless charset (setq charset gnus-newsgroup-charset)) (when (or force @@ -2700,12 +2660,11 @@ If READ-CHARSET, ask for a coding system." (save-restriction (narrow-to-region (point) (point-max)) (base64-decode-region (point-min) (point-max)) - (mm-decode-coding-region + (decode-coding-region (point-min) (point-max) (mm-charset-to-coding-system charset nil t))))))) -(eval-when-compile - (require 'rfc1843)) +(declare-function rfc1843-decode-region "rfc1843" (from to)) (defun article-decode-HZ () "Translate a HZ-encoded article." @@ -2724,7 +2683,7 @@ If READ-CHARSET, ask for a coding system." (while (re-search-forward "\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t) (replace-match "\\1\\3" t))) - (when (gmm-called-interactively-p 'any) + (when (called-interactively-p 'any) (gnus-treat-article nil)))) (defun article-wash-html () @@ -2777,7 +2736,7 @@ summary buffer." (cond ((file-directory-p file) (when (or (not (eq how 'file)) (gnus-y-or-n-p - (gnus-format-message + (format-message "Delete temporary HTML file(s) in directory `%s'? " (file-name-as-directory file)))) (gnus-delete-directory file))) @@ -2883,7 +2842,7 @@ message header will be added to the bodies of the \"text/html\" parts." <img[\t\n ]+\\(?:[^\t\n >]+[\t\n ]+\\)*src=\"\\(cid:\\([^\"]+\\)\\)\"" nil t) (unless cid-dir - (setq cid-dir (mm-make-temp-file "cid" t)) + (setq cid-dir (make-temp-file "cid" t)) (add-to-list 'gnus-article-browse-html-temp-list cid-dir)) (setq file nil content nil) @@ -2896,7 +2855,7 @@ message header will be added to the bodies of the \"text/html\" parts." (replace-match cid-file nil nil nil 1)))) (unless content (setq content (buffer-string)))) (when (or charset header (not file)) - (setq tmp-file (mm-make-temp-file + (setq tmp-file (make-temp-file ;; Do we need to care for 8.3 filenames? "mm-" nil ".html"))) ;; Add a meta html tag to specify charset and a header. @@ -2930,11 +2889,11 @@ message header will be added to the bodies of the \"text/html\" parts." ;; charset specified in parts might be different. (if (eq charset 'gnus-decoded) (setq charset 'utf-8 - eheader (mm-encode-coding-string (buffer-string) - charset) + eheader (encode-coding-string (buffer-string) + charset) title (when title - (mm-encode-coding-string title charset)) - body (mm-encode-coding-string content charset)) + (encode-coding-string title charset)) + body (encode-coding-string content charset)) (setq hcharset (mm-find-mime-charset-region (point-min) (point-max))) (cond ((= (length hcharset) 1) @@ -2951,30 +2910,30 @@ message header will be added to the bodies of the \"text/html\" parts." (mm-charset-to-coding-system charset nil t)) (if (eq coding body) - (setq eheader (mm-encode-coding-string + (setq eheader (encode-coding-string (buffer-string) coding) title (when title - (mm-encode-coding-string + (encode-coding-string title coding)) body content) (setq charset 'utf-8 - eheader (mm-encode-coding-string + eheader (encode-coding-string (buffer-string) charset) title (when title - (mm-encode-coding-string + (encode-coding-string title charset)) - body (mm-encode-coding-string - (mm-decode-coding-string + body (encode-coding-string + (decode-coding-string content body) charset)))) (setq charset hcharset - eheader (mm-encode-coding-string + eheader (encode-coding-string (buffer-string) coding) title (when title - (mm-encode-coding-string + (encode-coding-string title coding)) body content)) - (setq eheader (mm-string-as-unibyte (buffer-string)) + (setq eheader (string-as-unibyte (buffer-string)) body content))) (erase-buffer) (mm-disable-multibyte) @@ -2997,8 +2956,8 @@ message header will be added to the bodies of the \"text/html\" parts." (charset (mm-with-unibyte-buffer (insert (if (eq charset 'gnus-decoded) - (mm-encode-coding-string content - (setq charset 'utf-8)) + (encode-coding-string content + (setq charset 'utf-8)) content)) (if (or (mm-add-meta-html-tag handle charset) (not file)) @@ -3637,7 +3596,7 @@ possible values." ;; If the date is seriously mangled, the timezone functions are ;; liable to bug out, so we ignore all errors. (let* ((now (current-time)) - (real-time (subtract-time now time)) + (real-time (time-subtract now time)) (real-sec (and real-time (+ (* (float (car real-time)) 65536) (cadr real-time)))) @@ -4161,8 +4120,7 @@ and the raw article including all headers will be piped." (setq command (if (and (eq command 'default) default) default - (gnus-read-shell-command "Shell command on this article: " - default)))) + (read-shell-command "Shell command on this article: " default)))) (when (string-equal command "") (if default (setq command default) @@ -4326,8 +4284,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is (put-text-property (match-end 0) (point-max) 'face eface))))))))) -(autoload 'canlock-verify "canlock" nil t) ;; for XEmacs. - (defun article-verify-cancel-lock () "Verify Cancel-Lock header." (interactive) @@ -4440,13 +4396,9 @@ If variable `gnus-use-long-file-name' is non-nil, it is 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map) (defvar gnus-article-send-map) - (gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map) - "W" gnus-article-wide-reply-with-original) -(if (featurep 'xemacs) - (set-keymap-default-binding gnus-article-send-map - 'gnus-article-read-summary-send-keys) - (define-key gnus-article-send-map [t] 'gnus-article-read-summary-send-keys)) + "W" gnus-article-wide-reply-with-original + [t] gnus-article-read-summary-send-keys) (defun gnus-article-make-menu-bar () (unless (boundp 'gnus-article-commands-menu) @@ -4522,8 +4474,8 @@ commands: (make-local-variable 'gnus-article-ignored-charsets) (set (make-local-variable 'bookmark-make-record-function) 'gnus-summary-bookmark-make-record) - ;; Prevent Emacs 22 from displaying non-break space with `nobreak-space' - ;; face. + ;; Prevent Emacs from displaying non-break space with + ;; `nobreak-space' face. (set (make-local-variable 'nobreak-char-display) nil) ;; Enable `gnus-article-remove-images' to delete images shr.el renders. (set (make-local-variable 'shr-put-image-function) 'gnus-shr-put-image) @@ -4602,7 +4554,7 @@ commands: (defun gnus-article-stop-animations () (dolist (timer (and (boundp 'timer-list) timer-list)) - (when (eq (gnus-timer--function timer) 'image-animate-timeout) + (when (eq (timer--function timer) 'image-animate-timeout) (cancel-timer timer)))) (defun gnus-stop-downloads () @@ -4645,8 +4597,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-article-setup-buffer) (set-buffer gnus-article-buffer) ;; Deactivate active regions. - (when (and (boundp 'transient-mark-mode) - transient-mark-mode) + (when transient-mark-mode (setq mark-active nil)) (if (not (setq result (let ((inhibit-read-only t)) (gnus-request-article-this-buffer @@ -4906,8 +4857,8 @@ General format specifiers can also be used. See Info node (defvar gnus-mime-button-map (let ((map (make-sparse-keymap))) - (define-key map gnus-mouse-2 'gnus-article-push-button) - (define-key map gnus-down-mouse-3 'gnus-mime-button-menu) + (define-key map [mouse-2] 'gnus-article-push-button) + (define-key map [down-mouse-3] 'gnus-mime-button-menu) (dolist (c gnus-mime-button-commands) (define-key map (cadr c) (car c))) map)) @@ -5050,7 +5001,6 @@ and `gnus-mime-delete-part', and not provided at run-time normally." (let ((mbl1 mml-buffer-list)) (setq mml-buffer-list mbl) (set (make-local-variable 'mml-buffer-list) mbl1)) - (gnus-make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) `(lambda (no-highlight) (let ((mail-parse-charset (or gnus-article-charset @@ -5294,7 +5244,7 @@ are decompressed." ((numberp arg) (setq charset (or (cdr (assq arg gnus-summary-show-article-charset-alist)) - (mm-read-coding-system "Charset: "))))) + (read-coding-system "Charset: "))))) (switch-to-buffer (generate-new-buffer filename)) (if (or coding-system (and charset @@ -5303,11 +5253,8 @@ are decompressed." (not (eq coding-system 'ascii)))) (progn (mm-enable-multibyte) - (insert (mm-decode-coding-string contents coding-system)) - (setq buffer-file-coding-system - (if (boundp 'last-coding-system-used) - (symbol-value 'last-coding-system-used) - coding-system))) + (insert (decode-coding-string contents coding-system)) + (setq buffer-file-coding-system last-coding-system-used)) (mm-disable-multibyte) (insert contents) (setq buffer-file-coding-system mm-binary-coding-system)) @@ -5325,7 +5272,7 @@ are decompressed." (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) (contents (and handle (mm-get-part handle))) - (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory))) + (file (make-temp-file (expand-file-name "mm." mm-tmp-directory))) (printer (mailcap-mime-info (mm-handle-media-type handle) "print"))) (when contents (if printer @@ -5394,18 +5341,9 @@ Compressed files like .gz and .bz2 are decompressed." (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))))) + (delete-region + (point) + (next-single-property-change (point) 'gnus-data nil (point-max))) (setq start (point)) (if (search-backward "\n\n" nil t) (progn @@ -5466,7 +5404,7 @@ specified charset." (or (cdr (assq arg gnus-summary-show-article-charset-alist)) - (mm-read-coding-system "Charset: ")))) + (read-coding-system "Charset: ")))) (if (mm-handle-undisplayer handle) (mm-remove-part handle))) (gnus-mime-set-charset-parameters handle charset) @@ -5581,7 +5519,7 @@ If INTERACTIVE, call FUNCTION interactively." window (setq window (selected-window)) ;; Article may be displayed in the other frame. - (gnus-select-frame-set-input-focus + (select-frame-set-input-focus (prog1 frame (setq frame (selected-frame)))))) @@ -5609,7 +5547,7 @@ If INTERACTIVE, call FUNCTION interactively." (get-text-property (point) 'gnus-data)))) (set-marker overlay-arrow-position nil) (unless gnus-auto-select-part - (gnus-select-frame-set-input-focus frame) + (select-frame-set-input-focus frame) (select-window window)))) t)) (if gnus-inhibit-mime-unbuttonizing @@ -5788,18 +5726,9 @@ all parts." ;; 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))))) + (delete-region + (point) + (next-single-property-change (point) 'gnus-data nil (point-max))) (setq start (point)) (if (search-backward "\n\n" nil t) (progn @@ -5910,16 +5839,12 @@ all parts." :button-keymap gnus-mime-button-map :help-echo (lambda (widget) - ;; Needed to properly clear the message due to a bug in - ;; wid-edit (XEmacs only). - (if (boundp 'help-echo-owns-message) - (setq help-echo-owns-message t)) (format "%S: %s the MIME part; %S: more options" - (aref gnus-mouse-2 0) + 'mouse-2 (if (mm-handle-displayed-p (widget-get widget :mime-handle)) "hide" "show") - (aref gnus-down-mouse-3 0)))))) + 'down-mouse-3))))) (defun gnus-widget-press-button (elems _el) (goto-char (widget-get elems :from)) @@ -6164,8 +6089,7 @@ If nil, don't show those extra buttons." (defun gnus-article-insert-newline () "Insert a newline, but mark it as undeletable." - (gnus-put-text-property - (point) (progn (insert "\n") (point)) 'gnus-undeletable t)) + (put-text-property (point) (progn (insert "\n") (point)) 'gnus-undeletable t)) (defun gnus-mime-display-alternative (handles &optional preferred ibegend id) (let* ((preferred (or preferred (mm-preferred-alternative handles))) @@ -6191,7 +6115,7 @@ If nil, don't show those extra buttons." (not preferred) (not (gnus-unbuttonized-mime-type-p "multipart/alternative"))) - (gnus-add-text-properties + (add-text-properties (setq from (point)) (progn (insert (format "%d. " id)) @@ -6204,17 +6128,16 @@ If nil, don't show those extra buttons." (gnus-mime-display-alternative ',ihandles ',not-pref ',begend ,id)) keymap ,gnus-mime-button-map - ,gnus-mouse-face-prop ,gnus-article-mouse-face + mouse-face ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id article-type multipart rear-nonsticky t)) (widget-convert-button 'link from (point) - :action 'gnus-widget-press-button - :button-keymap gnus-widget-button-keymap) + :action 'gnus-widget-press-button) ;; Do the handles (while (setq handle (pop handles)) - (gnus-add-text-properties + (add-text-properties (setq from (point)) (progn (insert (format "(%c) %-18s" @@ -6229,14 +6152,13 @@ If nil, don't show those extra buttons." (gnus-mime-display-alternative ',ihandles ',handle ',begend ,id)) keymap ,gnus-mime-button-map - ,gnus-mouse-face-prop ,gnus-article-mouse-face + mouse-face ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id gnus-data ,handle rear-nonsticky t)) (widget-convert-button 'link from (point) - :action 'gnus-widget-press-button - :button-keymap gnus-widget-button-keymap) + :action 'gnus-widget-press-button) (insert " ")) (insert "\n\n")) (when preferred @@ -6350,7 +6272,7 @@ Provided for backwards compatibility." (not (with-current-buffer gnus-summary-buffer gnus-have-all-headers))) (not gnus-inhibit-hiding)) - (gnus-article-hide-headers))) + (article-hide-headers))) (declare-function shr-put-image "shr" (data alt &optional flags)) @@ -6506,14 +6428,13 @@ the coding cookie." (when coding ;; If the coding system is not suitable to encode the text, ;; ask a user for a proper one. - (when (fboundp 'select-safe-coding-system) - (setq coding (coding-system-base - (save-window-excursion - (select-safe-coding-system (point-min) (point-max) - coding)))) - (setq coding-system-for-write - (or (cdr (assq coding '((mule-utf-8 . utf-8)))) - coding))) + (setq coding (coding-system-base + (save-window-excursion + (select-safe-coding-system (point-min) (point-max) + coding)))) + (setq coding-system-for-write + (or (cdr (assq coding '((mule-utf-8 . utf-8)))) + coding)) (goto-char (point-min)) ;; Add the coding cookie. (insert (format "X-Gnus-Coding-System: -*- coding: %s; -*-\n\n" @@ -6584,14 +6505,14 @@ If given a numerical ARG, move forward ARG pages." (interactive) (when (gnus-article-next-page) (goto-char (point-min)) - (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) + (gnus-article-read-summary-keys nil ?n))) (defun gnus-article-goto-prev-page () "Show the previous page of the article." (interactive) (if (save-restriction (widen) (bobp)) ;; Real beginning-of-buffer? - (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) + (gnus-article-read-summary-keys nil ?p) (gnus-article-prev-page nil))) ;; This is cleaner but currently breaks `gnus-pick-mode': @@ -6613,12 +6534,10 @@ If given a numerical ARG, move forward ARG pages." If end of article, return non-nil. Otherwise return nil. Argument LINES specifies lines to be scrolled up." (interactive "p") - (move-to-window-line (if (featurep 'xemacs) -1 (- -1 scroll-margin))) + (move-to-window-line (- -1 scroll-margin)) (if (and (not (and gnus-article-over-scroll (> (count-lines (window-start) (point-max)) - (if (featurep 'xemacs) - (or lines (1- (window-height))) - (+ (or lines (1- (window-height))) scroll-margin))))) + (+ (or lines (1- (window-height))) scroll-margin)))) (save-excursion (end-of-line) (and (pos-visible-in-window-p) ;Not continuation line. @@ -6642,20 +6561,18 @@ Argument LINES specifies lines to be scrolled up." (defun gnus-article-beginning-of-window () "Move point to the beginning of the window. -In Emacs, the point is placed at the line number which `scroll-margin' +The point is placed at the line number which `scroll-margin' specifies." - (if (featurep 'xemacs) - (move-to-window-line 0) - ;; There is an obscure bug in Emacs that makes it impossible to - ;; scroll past big pictures in the article buffer. Try to fix - ;; this by adding a sanity check by counting the lines visible. - (when (> (count-lines (window-start) (window-end)) 30) - (move-to-window-line - (min (max 0 scroll-margin) - (max 1 (- (window-height) - (if mode-line-format 1 0) - (if header-line-format 1 0) - 2))))))) + ;; There is an obscure bug in Emacs that makes it impossible to + ;; scroll past big pictures in the article buffer. Try to fix + ;; this by adding a sanity check by counting the lines visible. + (when (> (count-lines (window-start) (window-end)) 30) + (move-to-window-line + (min (max 0 scroll-margin) + (max 1 (- (window-height) + (if mode-line-format 1 0) + (if header-line-format 1 0) + 2)))))) (defvar scroll-in-place) @@ -6682,10 +6599,7 @@ Argument LINES specifies lines to be scrolled down." (goto-char (point-max)) (recenter (if gnus-article-over-scroll (if lines - (max (if (featurep 'xemacs) - lines - (+ lines scroll-margin)) - 3) + (max (+ lines scroll-margin) 3) (- (window-height) 2)) -1))) (prog1 @@ -6766,9 +6680,7 @@ not have a face in `gnus-article-boring-faces'." (let (gnus-pick-mode) (setq unread-command-events (nconc unread-command-events (list (or key last-command-event))) - keys (if (featurep 'xemacs) - (events-to-keys (read-key-sequence nil t)) - (read-key-sequence nil t))))) + keys (read-key-sequence nil t)))) (message "") @@ -6816,7 +6728,7 @@ not have a face in `gnus-article-boring-faces'." (article 1.0))))))) (gnus-configure-windows 'article)) (setq win (get-buffer-window summary-buffer 'visible))) - (gnus-select-frame-set-input-focus (window-frame win)) + (select-frame-set-input-focus (window-frame win)) (select-window win)))) (setq in-buffer (current-buffer)) ;; We disable the pick minor mode commands. @@ -6869,27 +6781,25 @@ not have a face in `gnus-article-boring-faces'." (defun gnus-article-read-summary-send-keys () (interactive) - (let ((unread-command-events (list (gnus-character-to-event ?S)))) + (let ((unread-command-events (list ?S))) (gnus-article-read-summary-keys))) (defun gnus-article-describe-key (key) "Display documentation of the function invoked by KEY. KEY is a string or a vector." - (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs. + (interactive (list (let ((cursor-in-echo-area t)) (read-key-sequence "Describe key: ")))) (gnus-article-check-buffer) (if (memq (key-binding key t) '(gnus-article-read-summary-keys gnus-article-read-summary-send-keys)) (with-current-buffer gnus-article-current-summary (setq unread-command-events - (if (featurep 'xemacs) - (append key unread-command-events) - (nconc - (mapcar (lambda (x) (if (and (integerp x) (>= x 128)) - (list 'meta (- x 128)) - x)) - key) - unread-command-events))) + (nconc + (mapcar (lambda (x) (if (and (integerp x) (>= x 128)) + (list 'meta (- x 128)) + x)) + key) + unread-command-events)) (let ((cursor-in-echo-area t) gnus-pick-mode) (describe-key (read-key-sequence nil t)))) @@ -6898,7 +6808,7 @@ KEY is a string or a vector." (defun gnus-article-describe-key-briefly (key &optional insert) "Display documentation of the function invoked by KEY. KEY is a string or a vector." - (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs. + (interactive (list (let ((cursor-in-echo-area t)) (read-key-sequence "Describe key: ")) current-prefix-arg)) (gnus-article-check-buffer) @@ -6906,14 +6816,12 @@ KEY is a string or a vector." gnus-article-read-summary-send-keys)) (with-current-buffer gnus-article-current-summary (setq unread-command-events - (if (featurep 'xemacs) - (append key unread-command-events) - (nconc - (mapcar (lambda (x) (if (and (integerp x) (>= x 128)) - (list 'meta (- x 128)) - x)) - key) - unread-command-events))) + (nconc + (mapcar (lambda (x) (if (and (integerp x) (>= x 128)) + (list 'meta (- x 128)) + x)) + key) + unread-command-events)) (let ((cursor-in-echo-area t) gnus-pick-mode) (describe-key-briefly (read-key-sequence nil t) insert))) @@ -6987,13 +6895,12 @@ the entire article will be yanked." (interactive) (let ((article (cdr gnus-article-current)) contents) - (if (not (gnus-region-active-p)) + (if (not (and transient-mark-mode mark-active)) (with-current-buffer gnus-summary-buffer (gnus-summary-reply (list (list article)) wide)) (setq contents (buffer-substring (point) (mark t))) ;; Deactivate active regions. - (when (and (boundp 'transient-mark-mode) - transient-mark-mode) + (when transient-mark-mode (setq mark-active nil)) (with-current-buffer gnus-summary-buffer (gnus-summary-reply @@ -7013,13 +6920,12 @@ the entire article will be yanked." (interactive) (let ((article (cdr gnus-article-current)) contents) - (if (not (gnus-region-active-p)) + (if (not (and transient-mark-mode mark-active)) (with-current-buffer gnus-summary-buffer (gnus-summary-followup (list (list article)))) (setq contents (buffer-substring (point) (mark t))) ;; Deactivate active regions. - (when (and (boundp 'transient-mark-mode) - transient-mark-mode) + (when transient-mark-mode (setq mark-active nil)) (with-current-buffer gnus-summary-buffer (gnus-summary-followup @@ -7031,10 +6937,11 @@ This means that signatures, cited text and (some) headers will be hidden. If given a prefix, show the hidden text instead." (interactive (append (gnus-article-hidden-arg) (list 'force))) - (gnus-article-hide-headers arg) - (gnus-article-hide-list-identifiers arg) - (gnus-article-hide-citation-maybe arg force) - (gnus-article-hide-signature arg)) + (gnus-with-article-buffer + (article-hide-headers arg) + (article-hide-list-identifiers) + (gnus-article-hide-citation-maybe arg force) + (article-hide-signature arg))) (defun gnus-check-group-server () ;; Make sure the connection to the server is alive. @@ -7120,7 +7027,7 @@ If given a prefix, show the hidden text instead." ;; equivalent of string-make-multibyte which amount to decoding ;; with locale-coding-system, causing failure of ;; subsequent decoding. - (insert (mm-string-to-multibyte + (insert (string-to-multibyte (with-current-buffer gnus-original-article-buffer (buffer-substring (point-min) (point-max))))) 'article) @@ -7338,7 +7245,8 @@ groups." (when (and (not force) (gnus-group-read-only-p)) (error "The current newsgroup does not support article editing")) - (gnus-article-date-original) + (gnus-with-article-buffer + (article-date-original)) (gnus-article-edit-article 'ignore `(lambda (no-highlight) @@ -7441,31 +7349,26 @@ groups." "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" "\\(//[-a-z0-9_.]+:[0-9]*\\)?" - (if (string-match "[[:digit:]]" "1") ;; Support POSIX? - (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") - (punct "!?:;.,")) - (concat - "\\(?:" - ;; Match paired parentheses, e.g. in Wikipedia URLs: - ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" - "\\(?:" "[" chars punct "]+" "[" chars "]" "\\)?" - "\\|" - "[" chars punct "]+" "[" chars "]" - "\\)")) - (concat ;; XEmacs 21.4 doesn't support POSIX. - "\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+" - "\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)")) + (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") + (punct "!?:;.,")) + (concat + "\\(?:" + ;; Match paired parentheses, e.g. in Wikipedia URLs: + ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com + "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" + "\\(?:" "[" chars punct "]+" "[" chars "]" "\\)?" + "\\|" + "[" chars punct "]+" "[" chars "]" + "\\)")) "\\)") "Regular expression that matches URLs." :version "24.4" :group 'gnus-article-buttons :type 'regexp) -(defcustom gnus-button-valid-fqdn-regexp - message-valid-fqdn-regexp +(defcustom gnus-button-valid-fqdn-regexp "\\([-A-Za-z0-9]+\\.\\)+[A-Za-z]+" "Regular expression that matches a valid FQDN." - :version "22.1" + :version "26.1" :group 'gnus-article-buttons :type 'regexp) @@ -7582,7 +7485,7 @@ address, `ask' if unsure and `invalid' if the string is invalid." (list gnus-button-mid-or-mail-heuristic-alist) (result 0) rate regexp lpartlen elem) (setq lpartlen - (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1"))) + (length (replace-regexp-in-string "^\\(.*\\)@.*$" "\\1" mid-or-mail))) (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen) ;; Certain special cases... (when (string-match @@ -7653,7 +7556,7 @@ address, `ask' if unsure and `invalid' if the string is invalid." (setq guessed ;; get rid of surrounding angles... (funcall pref - (gnus-replace-in-string mid-or-mail "^<\\|>$" ""))) + (replace-regexp-in-string "^<\\|>$" "" mid-or-mail))) (if (or (eq 'mid guessed) (eq 'mail guessed)) (setq pref guessed) (setq pref 'ask))) @@ -7685,13 +7588,13 @@ as a symbol to FUN." "Call `describe-function' when pushing the corresponding URL button." (describe-function (intern - (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))) + (replace-regexp-in-string gnus-button-handle-describe-prefix "" url)))) (defun gnus-button-handle-describe-variable (url) "Call `describe-variable' when pushing the corresponding URL button." (describe-variable (intern - (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))) + (replace-regexp-in-string gnus-button-handle-describe-prefix "" url)))) (defun gnus-button-handle-symbol (url) "Display help on variable or function. @@ -7705,7 +7608,7 @@ Calls `describe-variable' or `describe-function'." (defun gnus-button-handle-describe-key (url) "Call `describe-key' when pushing the corresponding URL button." (let* ((key-string - (gnus-replace-in-string url gnus-button-handle-describe-prefix "")) + (replace-regexp-in-string gnus-button-handle-describe-prefix "" url)) (keys (ignore-errors (eval `(kbd ,key-string))))) (if keys (describe-key keys) @@ -7713,36 +7616,34 @@ Calls `describe-variable' or `describe-function'." (defun gnus-button-handle-apropos (url) "Call `apropos' when pushing the corresponding URL button." - (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) + (apropos (replace-regexp-in-string gnus-button-handle-describe-prefix "" url))) (defun gnus-button-handle-apropos-command (url) "Call `apropos' when pushing the corresponding URL button." (apropos-command - (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) + (replace-regexp-in-string gnus-button-handle-describe-prefix "" url))) (defun gnus-button-handle-apropos-variable (url) "Call `apropos' when pushing the corresponding URL button." - (funcall - (if (fboundp 'apropos-variable) 'apropos-variable 'apropos) - (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) + (apropos-variable + (replace-regexp-in-string gnus-button-handle-describe-prefix "" url))) (defun gnus-button-handle-apropos-documentation (url) "Call `apropos' when pushing the corresponding URL button." - (funcall - (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos) - (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))) + (apropos-documentation + (replace-regexp-in-string gnus-button-handle-describe-prefix "" url))) (defun gnus-button-handle-library (url) "Call `locate-library' when pushing the corresponding URL button." (gnus-message 9 "url=`%s'" url) (let* ((lib (locate-library url)) - (file (gnus-replace-in-string (or lib "") "\\.elc" ".el"))) + (file (replace-regexp-in-string "\\.elc" ".el" (or lib "")))) (if (not lib) (gnus-message 1 "Cannot locate library `%s'." url) (find-file-read-only file)))) (defcustom gnus-button-man-level 5 - "*Integer that says how many man-related buttons Gnus will show. + "Integer that says how many man-related buttons Gnus will show. The higher the number, the more buttons will appear and the more false positives are possible. Note that you can set this variable local to specific groups. Setting it higher in Unix groups is probably a good idea. @@ -7754,7 +7655,7 @@ how to set variables in specific groups." :type 'integer) (defcustom gnus-button-emacs-level 5 - "*Integer that says how many emacs-related buttons Gnus will show. + "Integer that says how many emacs-related buttons Gnus will show. The higher the number, the more buttons will appear and the more false positives are possible. Note that you can set this variable local to specific groups. Setting it higher in Emacs or Gnus related groups is @@ -7766,7 +7667,7 @@ probably a good idea. See Info node `(gnus)Group Parameters' and the variable :type 'integer) (defcustom gnus-button-message-level 5 - "*Integer that says how many buttons for news or mail messages will appear. + "Integer that says how many buttons for news or mail messages will appear. The higher the number, the more buttons will appear and the more false positives are possible." ;; mail addresses, MIDs, URLs for news, ... @@ -7775,7 +7676,7 @@ positives are possible." :type 'integer) (defcustom gnus-button-browse-level 5 - "*Integer that says how many buttons for browsing will appear. + "Integer that says how many buttons for browsing will appear. The higher the number, the more buttons will appear and the more false positives are possible." ;; stuff handled by `browse-url' or `gnus-button-embedded-url' @@ -7896,7 +7797,7 @@ positives are possible." ;; so that non-ambiguous entries (see above) match first. (gnus-button-mid-or-mail-regexp 0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1)) - "*Alist of regexps matching buttons in article bodies. + "Alist of regexps matching buttons in article bodies. Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where REGEXP: is the string (case insensitive) matching text around the button (can @@ -7938,7 +7839,7 @@ variable it the real callback function." 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)" 1 (>= gnus-button-message-level 0) gnus-button-message-id 4)) - "*Alist of headers and regexps to match buttons in article heads. + "Alist of headers and regexps to match buttons in article heads. This alist is very similar to `gnus-button-alist', except that each alist has an additional HEADER element first in each entry: @@ -8030,14 +7931,14 @@ do the highlighting. See the documentation for those functions." (when (and header-face (not (memq (point) hpoints))) (push (point) hpoints) - (gnus-put-text-property from (point) 'face header-face)) + (put-text-property from (point) 'face header-face)) (when (and field-face (not (memq (setq from (point)) fpoints))) (push from fpoints) (if (re-search-forward "^[^ \t]" nil t) (forward-char -2) (goto-char (point-max))) - (gnus-put-text-property from (point) 'face field-face))))))) + (put-text-property from (point) 'face field-face))))))) (defun gnus-article-highlight-signature () "Highlight the signature in an article. @@ -8092,7 +7993,7 @@ specified by `gnus-button-alist'." (gnus-article-extend-url-button from start end)) (gnus-article-add-button start end 'gnus-button-push (list from entry)) - (gnus-put-text-property + (put-text-property start end 'gnus-string (buffer-substring-no-properties start end)))))))))) @@ -8194,16 +8095,15 @@ url is put as the `gnus-button-url' overlay property on the button." (when gnus-article-button-face (overlay-put (make-overlay from to nil t) 'face gnus-article-button-face)) - (gnus-add-text-properties + (add-text-properties from to (nconc (and gnus-article-mouse-face - (list gnus-mouse-face-prop gnus-article-mouse-face)) + (list 'mouse-face gnus-article-mouse-face)) (list 'gnus-callback fun) (and data (list 'gnus-data data)))) (widget-convert-button 'link from to :action 'gnus-widget-press-button :help-echo (or text "Follow the link") - :keymap gnus-url-button-map - :button-keymap gnus-widget-button-keymap)) + :keymap gnus-url-button-map)) (defun gnus-article-copy-string () "Copy the string in the button to the kill ring." @@ -8335,13 +8235,13 @@ url is put as the `gnus-button-url' overlay property on the button." "Fetch a man page." (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url) (when (eq gnus-button-man-handler 'woman) - (setq url (gnus-replace-in-string url "([1-9][X1a-z]*).*\\'" ""))) + (setq url (replace-regexp-in-string "([1-9][X1a-z]*).*\\'" "" url))) (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url) (funcall gnus-button-man-handler url)) (defun gnus-button-handle-info-url (url) "Fetch an info URL." - (setq url (mm-subst-char-in-string ?+ ?\ url)) + (setq url (subst-char-in-string ?+ ?\ url)) (cond ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url) (gnus-info-find-node @@ -8350,14 +8250,14 @@ url is put as the `gnus-button-url' overlay property on the button." ")" (gnus-url-unhex-string (match-string 2 url))))) ((string-match "([^)\"]+)[^\"]+" url) (setq url - (gnus-replace-in-string - (gnus-replace-in-string url "[\n\t ]+" " ") "\"" "")) + (replace-regexp-in-string + "\"" "" (replace-regexp-in-string "[\n\t ]+" " " url))) (gnus-info-find-node url)) (t (error "Can't parse %s" url)))) (defun gnus-button-handle-info-url-gnome (url) "Fetch GNOME style info URL." - (setq url (mm-subst-char-in-string ?_ ?\ url)) + (setq url (subst-char-in-string ?_ ?\ url)) (if (string-match "\\([^#]+\\)#?\\(.*\\)" url) (gnus-info-find-node (concat "(" @@ -8489,9 +8389,9 @@ url is put as the `gnus-button-url' overlay property on the button." (if (fboundp func) (funcall func) (message-position-on-field (caar args))) - (insert (gnus-replace-in-string - (mapconcat 'identity (reverse (cdar args)) ", ") - "\r\n" "\n" t)) + (insert (replace-regexp-in-string + "\r\n" "\n" + (mapconcat 'identity (reverse (cdar args)) ", ") nil t)) (setq args (cdr args))) (if subject (message-goto-body) @@ -8508,13 +8408,13 @@ url is put as the `gnus-button-url' overlay property on the button." (defvar gnus-prev-page-map (let ((map (make-sparse-keymap))) - (define-key map gnus-mouse-2 'gnus-button-prev-page) + (define-key map [mouse-2] 'gnus-button-prev-page) (define-key map "\r" 'gnus-button-prev-page) map)) (defvar gnus-next-page-map (let ((map (make-sparse-keymap))) - (define-key map gnus-mouse-2 'gnus-button-next-page) + (define-key map [mouse-2] 'gnus-button-next-page) (define-key map "\r" 'gnus-button-next-page) map)) @@ -8828,8 +8728,8 @@ For example: (defvar gnus-mime-security-button-map (let ((map (make-sparse-keymap))) - (define-key map gnus-mouse-2 'gnus-article-push-button) - (define-key map gnus-down-mouse-3 'gnus-mime-security-button-menu) + (define-key map [mouse-2] 'gnus-article-push-button) + (define-key map [down-mouse-3] 'gnus-mime-security-button-menu) (dolist (c gnus-mime-security-button-commands) (define-key map (cadr c) (car c))) map)) @@ -8973,14 +8873,10 @@ For example: :button-keymap gnus-mime-security-button-map :help-echo (lambda (_widget) - ;; Needed to properly clear the message due to a bug in - ;; wid-edit (XEmacs only). - (when (boundp 'help-echo-owns-message) - (setq help-echo-owns-message t)) (format "%S: show detail; %S: more options" - (aref gnus-mouse-2 0) - (aref gnus-down-mouse-3 0)))))) + 'mouse-2 + 'down-mouse-3))))) (defun gnus-mime-display-security (handle) (save-restriction @@ -9026,8 +8922,6 @@ For example: (interactive) (gnus-mime-security-run-function 'mm-pipe-part)) -(gnus-ems-redefine) - (provide 'gnus-art) (run-hooks 'gnus-art-load-hook) diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index 45499daed85..11e765d2d77 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -35,7 +35,7 @@ :group 'gnus) (defcustom gnus-use-article-prefetch 30 - "*If non-nil, prefetch articles in groups that allow this. + "If non-nil, prefetch articles in groups that allow this. If a number, prefetch only that many articles forward; if t, prefetch as many articles as possible." :group 'gnus-asynchronous @@ -44,7 +44,7 @@ if t, prefetch as many articles as possible." (integer :tag "some" 0))) (defcustom gnus-asynchronous nil - "*If nil, inhibit all Gnus asynchronicity. + "If nil, inhibit all Gnus asynchronicity. If non-nil, let the other asynch variables be heeded." :group 'gnus-asynchronous :type 'boolean) @@ -59,7 +59,7 @@ from that group." :type '(set (const read) (const exit))) (defcustom gnus-use-header-prefetch nil - "*If non-nil, prefetch the headers to the next group." + "If non-nil, prefetch the headers to the next group." :group 'gnus-asynchronous :type 'boolean) @@ -148,18 +148,13 @@ that was fetched." (with-current-buffer gnus-summary-buffer (let ((next (caadr (gnus-data-find-list article)))) (when next - (if (not (fboundp 'run-with-idle-timer)) - ;; This is either an older Emacs or XEmacs, so we - ;; do this, which leads to slightly slower article - ;; buffer display. - (gnus-async-prefetch-article group next summary) - (when gnus-async-timer - (ignore-errors - (nnheader-cancel-timer 'gnus-async-timer))) - (setq gnus-async-timer - (run-with-idle-timer - 0.1 nil 'gnus-async-prefetch-article - group next summary)))))))) + (when gnus-async-timer + (ignore-errors + (nnheader-cancel-timer 'gnus-async-timer))) + (setq gnus-async-timer + (run-with-idle-timer + 0.1 nil 'gnus-async-prefetch-article + group next summary))))))) (defun gnus-async-prefetch-article (group article summary &optional next) "Possibly prefetch several articles starting with ARTICLE." diff --git a/lisp/gnus/gnus-bcklg.el b/lisp/gnus/gnus-bcklg.el index 8840187aade..d85448e109f 100644 --- a/lisp/gnus/gnus-bcklg.el +++ b/lisp/gnus/gnus-bcklg.el @@ -83,7 +83,7 @@ (insert-buffer-substring buffer) ;; Tag the beginning of the article with the ident. (if (> (point-max) b) - (gnus-put-text-property b (1+ b) 'gnus-backlog ident) + (put-text-property b (1+ b) 'gnus-backlog ident) (gnus-error 3 "Article %d is blank" number)))))))) (defun gnus-backlog-remove-oldest-article () diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index caeb5a0b2f6..655881396c0 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -174,17 +174,6 @@ where each BMK is of the form So the cdr of each bookmark is an alist too.") -(defmacro gnus-bookmark-mouse-available-p () - "Return non-nil if a mouse is available." - (if (featurep 'xemacs) - '(device-on-window-system-p) - '(display-mouse-p))) - -(defun gnus-bookmark-remove-properties (string) - "Remove all text properties from STRING." - (set-text-properties 0 (length string) nil string) - string) - ;;;###autoload (defun gnus-bookmark-set () "Set a bookmark for this article." @@ -209,7 +198,7 @@ So the cdr of each bookmark is an alist too.") ;; Set the bookmark list (setq gnus-bookmark-alist (cons - (list (gnus-bookmark-remove-properties bmk-name) + (list (substring-no-properties bmk-name) (gnus-bookmark-make-record group message-id author date subject annotation)) gnus-bookmark-alist)))) @@ -220,12 +209,12 @@ So the cdr of each bookmark is an alist too.") (group message-id author date subject annotation) "Return the record part of a new bookmark, given GROUP MESSAGE-ID AUTHOR DATE SUBJECT and ANNOTATION." (let ((the-record - `((group . ,(gnus-bookmark-remove-properties group)) - (message-id . ,(gnus-bookmark-remove-properties message-id)) - (author . ,(gnus-bookmark-remove-properties author)) - (date . ,(gnus-bookmark-remove-properties date)) - (subject . ,(gnus-bookmark-remove-properties subject)) - (annotation . ,(gnus-bookmark-remove-properties annotation))))) + `((group . ,(substring-no-properties group)) + (message-id . ,(substring-no-properties message-id)) + (author . ,(substring-no-properties author)) + (date . ,(substring-no-properties date)) + (subject . ,(substring-no-properties subject)) + (annotation . ,(substring-no-properties annotation))))) the-record)) (defun gnus-bookmark-set-bookmark-name (group author subject) @@ -237,7 +226,7 @@ So the cdr of each bookmark is an alist too.") "-" (car subject) "-" (cadr subject))) (default-name-1 ;; Strip "[]" chars from the bookmark name: - (gnus-replace-in-string default-name-0 "[]_[]" "")) + (replace-regexp-in-string "[]_[]" "" default-name-0)) (name (read-from-minibuffer (format "Set bookmark (%s): " default-name-1) nil nil nil nil @@ -367,7 +356,7 @@ The leftmost column displays a D if the bookmark is flagged for deletion, or > if it is flagged for displaying." (interactive) (gnus-bookmark-maybe-load-default-file) - (if (gmm-called-interactively-p 'any) + (if (called-interactively-p 'any) (switch-to-buffer (get-buffer-create "*Gnus Bookmark List*")) (set-buffer (get-buffer-create "*Gnus Bookmark List*"))) (let ((inhibit-read-only t) @@ -387,7 +376,7 @@ deletion, or > if it is flagged for displaying." (insert (if (member (gnus-bookmark-get-annotation name) (list nil "")) " " " *")) - (if (gnus-bookmark-mouse-available-p) + (if (display-mouse-p) (add-text-properties (prog1 (point) @@ -400,7 +389,7 @@ deletion, or > if it is flagged for displaying." (insert "\n"))) `(mouse-face highlight follow-link t help-echo ,(format "%s: go to this article" - (aref gnus-mouse-2 0)))) + 'mouse-2))) (insert name "\n"))) (goto-char (point-min)) (forward-line 2) @@ -443,9 +432,7 @@ That is, all information but the name." nil (setq gnus-bookmark-bmenu-mode-map (make-keymap)) (suppress-keymap gnus-bookmark-bmenu-mode-map t) - (define-key gnus-bookmark-bmenu-mode-map "q" (if (fboundp 'quit-window) - 'quit-window - 'bury-buffer)) + (define-key gnus-bookmark-bmenu-mode-map "q" 'quit-window) (define-key gnus-bookmark-bmenu-mode-map "\C-m" 'gnus-bookmark-bmenu-select) (define-key gnus-bookmark-bmenu-mode-map "v" 'gnus-bookmark-bmenu-select) (define-key gnus-bookmark-bmenu-mode-map "d" 'gnus-bookmark-bmenu-delete) @@ -463,7 +450,7 @@ That is, all information but the name." (define-key gnus-bookmark-bmenu-mode-map "s" 'gnus-bookmark-bmenu-save) (define-key gnus-bookmark-bmenu-mode-map "t" 'gnus-bookmark-bmenu-toggle-infos) (define-key gnus-bookmark-bmenu-mode-map "a" 'gnus-bookmark-bmenu-show-details) - (define-key gnus-bookmark-bmenu-mode-map gnus-mouse-2 + (define-key gnus-bookmark-bmenu-mode-map [mouse-2] 'gnus-bookmark-bmenu-select-by-mouse)) ;; Bookmark Buffer Menu mode is suitable only for specially formatted @@ -536,7 +523,7 @@ Optional argument SHOW means show them unconditionally." (let ((start (point-at-eol))) (move-to-column gnus-bookmark-bmenu-file-column t) ;; Strip off `mouse-face' from the white spaces region. - (if (gnus-bookmark-mouse-available-p) + (if (display-mouse-p) (remove-text-properties start (point) '(mouse-face nil help-echo nil)))) (delete-region (point) (progn (end-of-line) (point))) @@ -552,7 +539,7 @@ Optional argument SHOW means show them unconditionally." (insert (gnus-bookmark-get-details bmk-name gnus-bookmark-bookmark-inline-details)) - (if (gnus-bookmark-mouse-available-p) + (if (display-mouse-p) (add-text-properties start (save-excursion (re-search-backward @@ -561,7 +548,7 @@ Optional argument SHOW means show them unconditionally." `(mouse-face highlight follow-link t help-echo ,(format "%s: go to this article" - (aref gnus-mouse-2 0)))))))) + 'mouse-2))))))) (defun gnus-bookmark-kill-line (&optional newline-too) "Kill from point to end of line. @@ -601,7 +588,7 @@ Does not affect the kill ring." (gnus-bookmark-kill-line) (let ((start (point))) (insert (car gnus-bookmark-bmenu-hidden-bookmarks)) - (if (gnus-bookmark-mouse-available-p) + (if (display-mouse-p) (add-text-properties start (save-excursion (re-search-backward @@ -611,7 +598,7 @@ Does not affect the kill ring." follow-link t help-echo ,(format "%s: go to this bookmark in other window" - (aref gnus-mouse-2 0)))))) + 'mouse-2))))) (setq gnus-bookmark-bmenu-hidden-bookmarks (cdr gnus-bookmark-bmenu-hidden-bookmarks)) (forward-line 1)))))))) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 1f03e4368dd..fa3df7b14aa 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -35,7 +35,7 @@ (defcustom gnus-cache-active-file (expand-file-name "active" gnus-cache-directory) - "*The cache active file." + "The cache active file." :group 'gnus-cache :type 'file) @@ -50,7 +50,7 @@ :type '(set (const ticked) (const dormant) (const unread) (const read))) (defcustom gnus-cacheable-groups nil - "*Groups that match this regexp will be cached. + "Groups that match this regexp will be cached. If you only want to cache your nntp groups, you could set this variable to \"^nntp\". @@ -62,7 +62,7 @@ it's not cached." regexp)) (defcustom gnus-uncacheable-groups nil - "*Groups that match this regexp will not be cached. + "Groups that match this regexp will not be cached. If you want to avoid caching your nnml groups, you could set this variable to \"^nnml\". @@ -453,13 +453,11 @@ system for example was used.") (or (cdr (assoc group gnus-cache-decoded-group-names)) (let ((decoded (gnus-group-decoded-name group)) (coding (or nnmail-pathname-coding-system - (and (boundp 'file-name-coding-system) - file-name-coding-system) - (and (boundp 'default-file-name-coding-system) - default-file-name-coding-system)))) + file-name-coding-system + default-file-name-coding-system))) (push (cons group decoded) gnus-cache-decoded-group-names) - (push (cons (mm-decode-coding-string - (mm-encode-coding-string decoded coding) + (push (cons (decode-coding-string + (encode-coding-string decoded coding) coding) group) gnus-cache-unified-group-names) diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index a947941951f..3194e966f0f 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -24,9 +24,6 @@ ;;; Code: (eval-when-compile (require 'cl)) -(eval-when-compile - (when (featurep 'xemacs) - (require 'easy-mmode))) ; for `define-minor-mode' (require 'gnus) (require 'gnus-range) @@ -75,7 +72,7 @@ Set it to nil to parse all articles." (defcustom gnus-supercite-regexp (concat "^\\(" message-cite-prefix-regexp "\\)? *" ">>>>> +\"\\([^\"\n]+\\)\" +==") - "*Regexp matching normal Supercite attribution lines. + "Regexp matching normal Supercite attribution lines. The first grouping must match prefixes added by other packages." :group 'gnus-cite :type 'regexp) @@ -110,13 +107,13 @@ The first regexp group should match the Supercite attribution." (defcustom gnus-cite-attribution-prefix "In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|----- ?Original Message ?-----" - "*Regexp matching the beginning of an attribution line." + "Regexp matching the beginning of an attribution line." :group 'gnus-cite :type 'regexp) (defcustom gnus-cite-attribution-suffix "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\|----- ?Original Message ?-----\\)[ \t]*$" - "*Regexp matching the end of an attribution line. + "Regexp matching the end of an attribution line. The text matching the first grouping will be used as a button." :group 'gnus-cite :type 'regexp) @@ -307,7 +304,7 @@ It is merged with the face for the cited text belonging to the attribution." (defcustom gnus-cite-face-list '(gnus-cite-1 gnus-cite-2 gnus-cite-3 gnus-cite-4 gnus-cite-5 gnus-cite-6 gnus-cite-7 gnus-cite-8 gnus-cite-9 gnus-cite-10 gnus-cite-11) - "*List of faces used for highlighting citations. + "List of faces used for highlighting citations. When there are citations from multiple articles in the same message, Gnus will try to give each citation from each article its own face. @@ -530,7 +527,6 @@ longer than the frame width." (inhibit-point-motion-hooks t) (marks (gnus-dissect-cited-text)) (adaptive-fill-mode nil) - (filladapt-mode nil) (fill-column (if width (prefix-numeric-value width) fill-column))) (save-restriction (while (cdr marks) @@ -1121,7 +1117,7 @@ See also the documentation for `gnus-article-highlight-citation'." ((assq number gnus-cite-attribution-alist)) (t (gnus-add-wash-type 'cite) - (gnus-add-text-properties + (add-text-properties (point) (progn (forward-line 1) (point)) (nconc (list 'article-type 'cite) gnus-hidden-properties)))) @@ -1194,9 +1190,7 @@ Returns nil if there is no such line before LIMIT, t otherwise." (defvar font-lock-keywords) (defvar font-lock-set-defaults) -(eval-and-compile - (unless (featurep 'xemacs) - (autoload 'font-lock-set-defaults "font-lock"))) +(autoload 'font-lock-set-defaults "font-lock") (define-minor-mode gnus-message-citation-mode "Minor mode providing more font-lock support for nested citations. @@ -1206,9 +1200,7 @@ When enabled, it automatically turns on `font-lock-mode'." nil ;; keymap (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))) + (let ((defaults (car font-lock-defaults)) default keywords) (while defaults (setq default (if (consp defaults) @@ -1227,19 +1219,11 @@ When enabled, it automatically turns on `font-lock-mode'." gnus-message-citation-keywords)) (kill-local-variable default)))) ;; Force `font-lock-set-defaults' to update `font-lock-keywords'. - (if (featurep 'xemacs) - (progn - (require 'font-lock) - (setq font-lock-defaults-computed nil - font-lock-keywords nil)) - (setq font-lock-set-defaults nil)) + (setq font-lock-set-defaults nil) (font-lock-set-defaults) - (cond (font-lock-mode - (if (fboundp 'font-lock-flush) - (font-lock-flush) - (font-lock-fontify-buffer))) - (gnus-message-citation-mode - (font-lock-mode 1))))) + (if font-lock-mode + (font-lock-flush) + (gnus-message-citation-mode (font-lock-mode 1))))) (defun turn-on-gnus-message-citation-mode () "Turn on `gnus-message-citation-mode'." @@ -1248,8 +1232,6 @@ When enabled, it automatically turns on `font-lock-mode'." "Turn off `gnus-message-citation-mode'." (gnus-message-citation-mode -1)) -(gnus-ems-redefine) - (provide 'gnus-cite) ;; Local Variables: diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index 446c05d98b5..605dda2509b 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -28,6 +28,12 @@ (require 'parse-time) (require 'nnimap) +(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' +(autoload 'epg-make-context "epg") +(autoload 'epg-context-set-passphrase-callback "epg") +(autoload 'epg-decrypt-string "epg") +(autoload 'epg-encrypt-string "epg") + (defgroup gnus-cloud nil "Syncing Gnus data via IMAP." :version "25.1" @@ -43,18 +49,36 @@ ;; FIXME this type does not match the default. Nor does the documentation. :type '(repeat regexp)) -(defvar gnus-cloud-group-name "*Emacs Cloud*") +(defcustom gnus-cloud-storage-method (if (featurep 'epg) 'epg 'base64-gzip) + "Storage method for cloud data, defaults to EPG if that's available." + :group 'gnus-cloud + :type '(radio (const :tag "No encoding" nil) + (const :tag "Base64" base64) + (const :tag "Base64+gzip" base64-gzip) + (const :tag "EPG" epg))) + +(defcustom gnus-cloud-interactive t + "Whether Gnus Cloud changes should be confirmed." + :group 'gnus-cloud + :type 'boolean) + +(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.") +(defcustom gnus-cloud-method nil + "The IMAP select method used to store the cloud data. +See also `gnus-server-toggle-cloud-method-server' for an +easy interactive way to set this from the Server buffer." + :group 'gnus-cloud + :type '(radio (const :tag "Not set" nil) + (string :tag "A Gnus server name as a string"))) (defun gnus-cloud-make-chunk (elems) (with-temp-buffer - (insert (format "Version %s\n" gnus-cloud-version)) + (insert (format "Gnus-Cloud-Version %s\n" gnus-cloud-version)) (insert (gnus-cloud-insert-data elems)) (buffer-string))) @@ -63,106 +87,189 @@ (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")) + (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) :newsrc-data) + (let ((print-level nil) + (print-length nil)) + (print elem (current-buffer))) + (insert "\n")) ((eq (plist-get elem :type) :delete) - (insert (format "(:type :delete :file-name %S)\n" - (plist-get elem :file-name)))))) + (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))) + (cond + ((eq gnus-cloud-storage-method 'base64-gzip) + (progn + (call-process-region (point-min) (point-max) "gzip" + t (current-buffer) nil + "-c") + (base64-encode-region (point-min) (point-max)))) + + ((eq gnus-cloud-storage-method 'base64) + (base64-encode-region (point-min) (point-max))) + + ((eq gnus-cloud-storage-method 'epg) + (let ((context (epg-make-context 'OpenPGP)) + cipher) + (setf (epg-context-armor context) t) + (setf (epg-context-textmode context) t) + (let ((data (epg-encrypt-string context + (buffer-substring-no-properties + (point-min) + (point-max)) + nil))) + (delete-region (point-min) (point-max)) + (insert data)))) + + ((null gnus-cloud-storage-method) + (gnus-message 5 "Leaving cloud data plaintext")) + (t (gnus-error 1 "Invalid cloud storage method %S" + gnus-cloud-storage-method)))) (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")) + (cond + ((memq gnus-cloud-storage-method '(base64 base64-gzip)) + (base64-decode-region (point-min) (point-max))) + + ((eq gnus-cloud-storage-method 'base64-gzip) + (call-process-region (point-min) (point-max) "gunzip" + t (current-buffer) nil + "-c")) + + ((eq gnus-cloud-storage-method 'epg) + (let* ((context (epg-make-context 'OpenPGP)) + (data (epg-decrypt-string context (buffer-substring-no-properties + (point-min) + (point-max))))) + (delete-region (point-min) (point-max)) + (insert data))) + + ((null gnus-cloud-storage-method) + (gnus-message 5 "Reading cloud data as plaintext")) + + (t (gnus-error 1 "Invalid cloud storage method %S" + gnus-cloud-storage-method)))) (defun gnus-cloud-parse-chunk () (save-excursion - (goto-char (point-min)) - (unless (looking-at "Version \\([0-9]+\\)") + (unless (looking-at "Gnus-Cloud-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)))) + (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))))))) + (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)) + (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 :delete))) - (setq length (plist-get spec :length)) - (push (append spec - (list - :contents (buffer-substring (1+ (point)) - (+ (point) 1 length)))) - elems) - (goto-char (+ (point) 1 length)))))) + (let ((spec (ignore-errors (read (current-buffer)))) + length) + (when (consp spec) + (cond + ((memq (plist-get spec :type) '(:file :delete)) + (setq length (plist-get spec :length)) + (push (append spec + (list + :contents (buffer-substring (1+ (point)) + (+ (point) 1 length)))) + elems) + (goto-char (+ (point) 1 length))) + ((memq (plist-get spec :type) '(:newsrc-data)) + (push spec elems))))))) (nreverse elems))) -(defun gnus-cloud-update-data (elems) +(defun gnus-cloud-update-all (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)) + ((eq type :newsrc-data) + (gnus-cloud-update-newsrc-data (plist-get elem :name) elem)) + ((memq type '(:delete :file)) + (gnus-cloud-update-file elem type)) (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)))) + (gnus-message 1 "Unknown type %s; ignoring" type)))))) + +(defun gnus-cloud-update-newsrc-data (group elem &optional force-older) + "Update the newsrc data for GROUP from ELEM. +Use old data if FORCE-OLDER is not nil." + (let* ((contents (plist-get elem :contents)) + (date (or (plist-get elem :timestamp) "0")) + (now (gnus-cloud-timestamp (current-time))) + (newer (string-lessp date now)) + (group-info (gnus-get-info group))) + (if (and contents + (stringp (nth 0 contents)) + (integerp (nth 1 contents))) + (if group-info + (if (equal (format "%S" group-info) + (format "%S" contents)) + (gnus-message 3 "Skipping cloud update of group %s, the info is the same" group) + (if (and newer (not force-older)) + (gnus-message 3 "Skipping outdated cloud info for group %s, the info is from %s (now is %s)" group date now) + (when (or (not gnus-cloud-interactive) + (gnus-y-or-n-p + (format "%s has older different info in the cloud as of %s, update it here? " + group date)))) + (gnus-message 2 "Installing cloud update of group %s" group) + (gnus-set-info group contents) + (gnus-group-update-group group))) + (gnus-error 1 "Sorry, group %s is not subscribed" group)) + (gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data %S)" + group elem)))) + +(defun gnus-cloud-update-file (elem op) + "Apply Gnus Cloud data ELEM and operation OP to a file." + (let* ((file-name (plist-get elem :file-name)) + (date (plist-get elem :timestamp)) + (contents (plist-get elem :contents)) + (exists (file-exists-p file-name))) + (if (gnus-cloud-file-covered-p file-name) + (cond + ((eq op :delete) + (if (and exists + ;; prompt only if the file exists already + (or (not gnus-cloud-interactive) + (gnus-y-or-n-p (format "%s has been deleted as of %s, delete it locally? " + file-name date)))) + (rename-file file-name (car (find-backup-file-name file-name))) + (gnus-message 3 "%s was already deleted before the cloud got it" file-name))) + ((eq op :file) + (when (or (not exists) + (and exists + (mm-with-unibyte-buffer + (insert-file-contents-literally file-name) + (not (equal (buffer-string) contents))) + ;; prompt only if the file exists already + (or (not gnus-cloud-interactive) + (gnus-y-or-n-p (format "%s has updated contents as of %s, update it? " + file-name date))))) + (gnus-cloud-replace-file file-name date contents)))) + (gnus-message 2 "%s isn't covered by the cloud; ignoring" file-name)))) (defun gnus-cloud-replace-file (file-name date new-contents) (mm-with-unibyte-buffer @@ -172,25 +279,19 @@ (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))) + (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))))) + (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 () @@ -198,106 +299,126 @@ (dolist (elem gnus-cloud-synced-files) (cond ((stringp elem) - (push elem files)) + (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))))) + (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) + 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)))) + (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-timestamp (time) + "Return a general timestamp string for TIME." + (format-time-string "%FT%T%z" time)) + (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)))) + (let ((timestamp (gnus-cloud-timestamp (nth 5 (file-attributes file)))) + (old (cadr (assoc file gnus-cloud-file-timestamps)))) (when (or full - (null old) - (string< old timestamp)) + (null old) + (string< old timestamp)) timestamp))) (declare-function gnus-activate-group "gnus-start" - (group &optional scan dont-check method dont-sub-check)) + (group &optional scan dont-check method dont-sub-check)) (declare-function gnus-subscribe-group "gnus-start" - (group &optional previous method)) + (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))) + (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)) + (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))))) + (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method) + (gnus-subscribe-group gnus-cloud-group-name))))) + +(defun gnus-cloud-upload-all-data () + "Upload all data (newsrc and files) to the Gnus Cloud." + (interactive) + (gnus-cloud-upload-data t)) (defun gnus-cloud-upload-data (&optional full) + "Upload data (newsrc and files) to the Gnus Cloud. +When FULL is t, upload everything, not just a difference from the last full." + (interactive) (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") + (let ((elems (append + (gnus-cloud-files-to-upload full) + (gnus-cloud-collect-full-newsrc))) + (group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))) + (insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n" + (or gnus-cloud-sequence "UNKNOWN") + (if full :full :partial) + gnus-cloud-storage-method)) + (insert "From: nobody@gnus.cloud.invalid\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))))) + (if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method + t t) + (progn + (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0))) + (gnus-cloud-add-timestamps elems) + (gnus-message 3 "Uploaded Gnus Cloud data successfully to %s" group) + (gnus-group-refresh-group group)) + (gnus-error 2 "Failed to upload Gnus Cloud data to %s" group))))) (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))) + (old (assoc file-name gnus-cloud-file-timestamps))) (when old - (setq gnus-cloud-file-timestamps - (delq old gnus-cloud-file-timestamps))) + (setq gnus-cloud-file-timestamps + (delq old gnus-cloud-file-timestamps))) (push (list file-name (plist-get elem :timestamp)) - gnus-cloud-file-timestamps)))) + 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) + (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)))) + (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))))))) + (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)) +;; TODO: use this (defun gnus-cloud-prune-old-chunks (headers) (let ((headers (reverse headers)) - (found nil)) + (found nil)) (while (and headers - (not found)) + (not found)) (when (string-match "type: :full" (mail-header-subject (car headers))) (setq found t)) (pop headers)) @@ -306,37 +427,68 @@ (when headers (gnus-request-expire-articles (mapcar (lambda (h) - (mail-header-number h)) - (nreverse headers)) + (mail-header-number h)) + (nreverse headers)) (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))))) -(defun gnus-cloud-download-data () +(defun gnus-cloud-download-all-data () + "Download the Gnus Cloud data and install it. +Starts at `gnus-cloud-sequence' in the sequence." + (interactive) + (gnus-cloud-download-data t)) + +(defun gnus-cloud-download-data (&optional update sequence-override) + "Download the Gnus Cloud data and install it if UPDATE is t. +When SEQUENCE-OVERRIDE is given, start at that sequence number +instead of `gnus-cloud-sequence'. + +When UPDATE is t, returns the result of calling `gnus-cloud-update-all'. +Otherwise, returns the Gnus Cloud data chunks." (let ((articles nil) - chunks) + 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))) + (or sequence-override gnus-cloud-sequence -1)) + + (if (string-match (format "storage-method: %s" gnus-cloud-storage-method) + (mail-header-subject header)) + (push (mail-header-number header) articles) + (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s" + (mail-header-number header) + gnus-cloud-storage-method + (mail-header-subject header))))) (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)))))) + (goto-char (point-min)) + (while (re-search-forward "^Gnus-Cloud-Version " nil t) + (beginning-of-line) + (push (gnus-cloud-parse-chunk) chunks) + (forward-line 1)))) + (if update + (mapcar #'gnus-cloud-update-all chunks) + chunks))) (defun gnus-cloud-server-p (server) (member server gnus-cloud-covered-servers)) +(defun gnus-cloud-host-server-p (server) + (equal gnus-cloud-method server)) + +(defun gnus-cloud-host-acceptable-method-p (server) + (eq (car-safe (gnus-server-to-method server)) 'nnimap)) + (defun gnus-cloud-collect-full-newsrc () + "Collect all the Gnus newsrc data in a portable format." (let ((infos nil)) (dolist (info (cdr gnus-newsrc-alist)) (when (gnus-cloud-server-p - (gnus-method-to-server - (gnus-find-method-for-group (gnus-info-group info)))) - (push info infos))) - )) + (gnus-method-to-server + (gnus-find-method-for-group (gnus-info-group info)))) + + (push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp (current-time))) + infos))) + infos)) (provide 'gnus-cloud) diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index 787a2a444a6..e5787e86257 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -416,7 +416,7 @@ category.")) ;; Decode values posting-style holds. (dolist (style (cdr (assq 'posting-style values))) (when (stringp (cadr style)) - (setcdr style (list (mm-decode-coding-string (cadr style) 'utf-8))))) + (setcdr style (list (decode-coding-string (cadr style) 'utf-8))))) (setq gnus-custom-params (apply 'widget-create 'group @@ -492,7 +492,7 @@ form, but who cares?" ;; Encode values posting-style holds. (dolist (style (cdr (assq 'posting-style params))) (when (stringp (cadr style)) - (setcdr style (list (mm-encode-coding-string (cadr style) 'utf-8))))) + (setcdr style (list (encode-coding-string (cadr style) 'utf-8))))) (if gnus-custom-topic (gnus-topic-set-parameters gnus-custom-topic params) (gnus-group-edit-group-done 'params gnus-custom-group params) diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el index 347240183a3..7b599679125 100644 --- a/lisp/gnus/gnus-delay.el +++ b/lisp/gnus/gnus-delay.el @@ -53,12 +53,12 @@ :group 'gnus-delay) (defcustom gnus-delay-default-delay "3d" - "*Default length of delay." + "Default length of delay." :type 'string :group 'gnus-delay) (defcustom gnus-delay-default-hour 8 - "*If deadline is given as date, then assume this time of day." + "If deadline is given as date, then assume this time of day." :version "22.1" :type 'integer :group 'gnus-delay) @@ -103,10 +103,10 @@ DELAY is a string, giving the length of the time. Possible values are: (aset deadline 1 minute) (aset deadline 2 hour) ;; Convert to seconds. - (setq deadline (gnus-float-time (apply 'encode-time - (append deadline nil)))) + (setq deadline (float-time (apply 'encode-time + (append deadline nil)))) ;; If this time has passed already, add a day. - (when (< deadline (gnus-float-time)) + (when (< deadline (float-time)) (setq deadline (+ 86400 deadline))) ; 86400 secs/day ;; Convert seconds to date header. (setq deadline (message-make-date @@ -129,7 +129,7 @@ DELAY is a string, giving the length of the time. Possible values are: (t (setq delay (* num 60)))) (setq deadline (message-make-date - (seconds-to-time (+ (gnus-float-time) delay))))) + (seconds-to-time (+ (float-time) delay))))) (t (error "Malformed delay `%s'" delay))) (message-add-header (format "%s: %s" gnus-delay-header deadline))) (set-buffer-modified-p t) diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index 3eb53c2683c..81f9650ae3f 100644 --- a/lisp/gnus/gnus-demon.el +++ b/lisp/gnus/gnus-demon.el @@ -93,10 +93,7 @@ Emacs has been idle for IDLE `gnus-demon-timestep's." (defun gnus-demon-idle-since () "Return the number of seconds since when Emacs is idle." - (if (featurep 'xemacs) - (itimer-time-difference (current-time) last-command-event-time) - (float-time (or (current-idle-time) - '(0 0 0))))) + (float-time (or (current-idle-time) '(0 0 0)))) (defun gnus-demon-run-callback (func &optional idle time special) "Run FUNC if Emacs has been idle for longer than IDLE seconds. diff --git a/lisp/gnus/gnus-diary.el b/lisp/gnus/gnus-diary.el index a459cedaf70..99d3a2b38ee 100644 --- a/lisp/gnus/gnus-diary.el +++ b/lisp/gnus/gnus-diary.el @@ -50,19 +50,19 @@ :group 'gnus) (defcustom gnus-diary-summary-line-format "%U%R%z %uD: %(%s%) (%ud)\n" - "*Summary line format for nndiary groups." + "Summary line format for nndiary groups." :type 'string :group 'gnus-diary :group 'gnus-summary-format) (defcustom gnus-diary-time-format "%a, %b %e %y, %H:%M" - "*Time format to display appointments in nndiary summary buffers. + "Time format to display appointments in nndiary summary buffers. Please refer to `format-time-string' for information on possible values." :type 'string :group 'gnus-diary) (defcustom gnus-diary-delay-format-function 'gnus-diary-delay-format-english - "*Function called to format a diary delay string. + "Function called to format a diary delay string. It is passed two arguments. The first one is non-nil if the delay is in the past. The second one is of the form ((NUM . UNIT) ...) where NUM is an integer and UNIT is one of 'year 'month 'week 'day 'hour or 'minute. @@ -83,13 +83,10 @@ There are currently two built-in format functions: ;; Compatibility functions ================================================== -(eval-and-compile - (if (fboundp 'kill-entire-line) - (defalias 'gnus-diary-kill-entire-line 'kill-entire-line) - (defun gnus-diary-kill-entire-line () - (beginning-of-line) - (let ((kill-whole-line t)) - (kill-line))))) +(defun gnus-diary-kill-entire-line () + (beginning-of-line) + (let ((kill-whole-line t)) + (kill-line))) ;; Summary line format ====================================================== @@ -164,7 +161,7 @@ There are currently two built-in format functions: (sched (gnus-diary-header-schedule extras)) (occur (nndiary-next-occurence sched (current-time))) (now (current-time)) - (real-time (subtract-time occur now))) + (real-time (time-subtract occur now))) (if (null real-time) "?????" (let* ((sec (+ (* (float (car real-time)) 65536) (cadr real-time))) diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el index f08338551ee..10533cafd97 100644 --- a/lisp/gnus/gnus-dired.el +++ b/lisp/gnus/gnus-dired.el @@ -38,9 +38,6 @@ ;;; Code: -(eval-when-compile - (when (featurep 'xemacs) - (require 'easy-mmode))) ; for `define-minor-mode' (require 'dired) (autoload 'mml-attach-file "mml") (autoload 'mm-default-file-encoding "mm-decode");; Shift this to `mailcap.el'? @@ -86,12 +83,6 @@ See `mail-user-agent' for more information." gnus-user-agent) (function :tag "Other"))) -(eval-when-compile - (when (featurep 'xemacs) - (defvar gnus-dired-mode-hook) - (defvar gnus-dired-mode-on-hook) - (defvar gnus-dired-mode-off-hook))) - (define-minor-mode gnus-dired-mode "Minor mode for intersections of gnus and dired. @@ -134,9 +125,7 @@ filenames." (mapcar ;; don't attach directories (lambda (f) (if (file-directory-p f) nil f)) - (nreverse - (let ((arg nil)) ;; Silence XEmacs 21.5 when compiling. - (dired-map-over-marks (dired-get-filename) arg))))))) + (nreverse (dired-map-over-marks (dired-get-filename) nil)))))) (let ((destination nil) (files-str nil) (bufs nil)) diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 210ea2e7dfe..6e7b307770c 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -31,9 +31,6 @@ (require 'nndraft) (require 'gnus-agent) (eval-when-compile (require 'cl)) -(eval-when-compile - (when (featurep 'xemacs) - (require 'easy-mmode))) ; for `define-minor-mode' ;;; Draft minor mode @@ -320,7 +317,7 @@ If DONT-POP is nil, display the buffer after setting it up." (let* ((window (get-buffer-window buff t)) (frame (and window (window-frame window)))) (if frame - (gnus-select-frame-set-input-focus frame) + (select-frame-set-input-focus frame) (pop-to-buffer buff t))) (error "The draft %s is under edit" file))))) diff --git a/lisp/gnus/gnus-dup.el b/lisp/gnus/gnus-dup.el index 7ce0dc5fbc0..f91ebbeff12 100644 --- a/lisp/gnus/gnus-dup.el +++ b/lisp/gnus/gnus-dup.el @@ -39,19 +39,19 @@ :group 'gnus) (defcustom gnus-save-duplicate-list nil - "*If non-nil, save the duplicate list when shutting down Gnus. + "If non-nil, save the duplicate list when shutting down Gnus. If nil, duplicate suppression will only work on duplicates seen in the same session." :group 'gnus-duplicate :type 'boolean) (defcustom gnus-duplicate-list-length 10000 - "*The number of Message-IDs to keep in the duplicate suppression list." + "The number of Message-IDs to keep in the duplicate suppression list." :group 'gnus-duplicate :type 'integer) (defcustom gnus-duplicate-file (nnheader-concat gnus-directory "suppression") - "*The name of the file to store the duplicate suppression list." + "The name of the file to store the duplicate suppression list." :group 'gnus-duplicate :type 'file) diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index 539a5d05827..787c0e3a0f5 100644 --- a/lisp/gnus/gnus-fun.el +++ b/lisp/gnus/gnus-fun.el @@ -28,14 +28,13 @@ (require 'cl)) (require 'mm-util) -(require 'gnus-ems) (require 'gnus-util) (require 'gnus) (defvar gnus-face-properties-alist) (defcustom gnus-x-face-directory (expand-file-name "x-faces" gnus-directory) - "*Directory where X-Face PBM files are stored." + "Directory where X-Face PBM files are stored." :version "22.1" :group 'gnus-fun :type 'directory) @@ -47,7 +46,7 @@ :type '(choice (const nil) string)) (defcustom gnus-face-directory (expand-file-name "faces" gnus-directory) - "*Directory where Face PNG files are stored." + "Directory where Face PNG files are stored." :version "25.1" :group 'gnus-fun :type 'directory) diff --git a/lisp/gnus/gnus-gravatar.el b/lisp/gnus/gnus-gravatar.el index 0d214956df9..b4763c76814 100644 --- a/lisp/gnus/gnus-gravatar.el +++ b/lisp/gnus/gnus-gravatar.el @@ -94,8 +94,9 @@ Set image category to CATEGORY." (mail-address (cadr address))) (when (if real-name (re-search-forward - (concat (gnus-replace-in-string - (regexp-quote real-name) "[\t ]+" "[\t\n ]+") + (concat (replace-regexp-in-string + "[\t ]+" "[\t\n ]+" + (regexp-quote real-name)) "\\|" (regexp-quote mail-address)) nil t) @@ -110,8 +111,7 @@ Set image category to CATEGORY." ;; another mail with the same someaddress. (unless (memq 'gnus-gravatar (text-properties-at (point))) (let ((point (point))) - (unless (featurep 'xemacs) - (setq gravatar (append gravatar gnus-gravatar-properties))) + (setq gravatar (append gravatar gnus-gravatar-properties)) (gnus-put-image gravatar (buffer-substring (point) (1+ point)) category) (put-text-property point (point) 'gnus-gravatar address) (gnus-add-wash-type category) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index f6bf3db3c8b..2488cdb7060 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -38,7 +38,6 @@ (require 'gnus-undo) (require 'gmm-utils) (require 'time-date) -(require 'gnus-ems) (eval-when-compile (require 'mm-url) @@ -52,13 +51,16 @@ (autoload 'gnus-group-make-nnir-group "nnir") +(autoload 'gnus-cloud-upload-all-data "gnus-cloud") +(autoload 'gnus-cloud-download-all-data "gnus-cloud") + (defcustom gnus-no-groups-message "No news is good news" - "*Message displayed by Gnus when no groups are available." + "Message displayed by Gnus when no groups are available." :group 'gnus-start :type 'string) (defcustom gnus-keep-same-level nil - "*Non-nil means that the next newsgroup after the current will be on the same level. + "Non-nil means that the next newsgroup after the current will be on the same level. When you type, for instance, `n' after reading the last article in the current newsgroup, you will go to the next newsgroup. If this variable is nil, the next newsgroup will be the next from the group @@ -75,19 +77,19 @@ with the best level." (sexp :tag "other" t))) (defcustom gnus-group-goto-unread t - "*If non-nil, movement commands will go to the next unread and subscribed group." + "If non-nil, movement commands will go to the next unread and subscribed group." :link '(custom-manual "(gnus)Group Maneuvering") :group 'gnus-group-various :type 'boolean) (defcustom gnus-goto-next-group-when-activating t - "*If non-nil, the \\<gnus-group-mode-map>\\[gnus-group-get-new-news-this-group] command will advance point to the next group." + "If non-nil, the \\<gnus-group-mode-map>\\[gnus-group-get-new-news-this-group] command will advance point to the next group." :link '(custom-manual "(gnus)Scanning New Messages") :group 'gnus-group-various :type 'boolean) (defcustom gnus-permanently-visible-groups nil - "*Regexp to match groups that should always be listed in the group buffer. + "Regexp to match groups that should always be listed in the group buffer. This means that they will still be listed even when there are no unread articles in the groups. @@ -108,7 +110,7 @@ effective only when emacs-w3m renders html articles, i.e., in the case (const nil))) (defcustom gnus-list-groups-with-ticked-articles t - "*If non-nil, list groups that have only ticked articles. + "If non-nil, list groups that have only ticked articles. If nil, only list groups that have unread articles." :group 'gnus-group-listing :type 'boolean) @@ -121,13 +123,13 @@ Ignored if `gnus-group-use-permanent-levels' is non-nil." (function :tag "Function returning level"))) (defcustom gnus-group-list-inactive-groups t - "*If non-nil, inactive groups will be listed." + "If non-nil, inactive groups will be listed." :group 'gnus-group-listing :group 'gnus-group-levels :type 'boolean) (defcustom gnus-group-sort-function 'gnus-group-sort-by-alphabet - "*Function used for sorting the group buffer. + "Function used for sorting the group buffer. This function will be called with group info entries as the arguments for the groups to be sorted. Pre-made functions include `gnus-group-sort-by-alphabet', `gnus-group-sort-by-real-name', @@ -156,7 +158,7 @@ list." (function :tag "other" nil)))) (defcustom gnus-group-line-format "%M\ %S\ %p\ %P\ %5y:%B%(%g%)\n" - "*Format of group lines. + "Format of group lines. It works along the same lines as a normal formatting string, with some simple extensions. @@ -214,7 +216,7 @@ See Info node `(gnus)Formatting Variables'." :type 'string) (defcustom gnus-group-mode-line-format "Gnus: %%b {%M\ %:%S}" - "*The format specification for the group mode line. + "The format specification for the group mode line. It works along the same lines as a normal formatting string, with some simple extensions: @@ -224,11 +226,6 @@ with some simple extensions: :group 'gnus-group-visual :type 'string) -;; Extracted from gnus-xmas-redefine in order to preserve user settings -(when (featurep 'xemacs) - (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) - (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)) - (defcustom gnus-group-menu-hook nil "Hook run after the creation of the group mode menu." :group 'gnus-group-various @@ -246,7 +243,7 @@ with some simple extensions: :type 'hook) (defcustom gnus-group-prepare-function 'gnus-group-prepare-flat - "*A function that is called to generate the group buffer. + "A function that is called to generate the group buffer. The function is called with three arguments: The first is a number; all group with a level less or equal to that number should be listed, if the second is non-nil, empty groups should also be displayed. If @@ -303,7 +300,7 @@ If you want to modify the group buffer, you can use this hook." (unless file (error "Couldn't find doc group")) file)))))) - "*Alist of useful group-server pairs." + "Alist of useful group-server pairs." :group 'gnus-group-listing :type '(repeat (list (string :tag "Description") (string :tag "Name") @@ -356,7 +353,7 @@ If you want to modify the group buffer, you can use this hook." gnus-group-news-low-empty) (t . gnus-group-news-low)) - "*Controls the highlighting of group buffer lines. + "Controls the highlighting of group buffer lines. Below is a list of `Form'/`Face' pairs. When deciding how a particular group line should be displayed, each form is @@ -391,7 +388,7 @@ ticked: The number of ticked articles." (defcustom gnus-group-icon-list nil - "*Controls the insertion of icons into group buffer lines. + "Controls the insertion of icons into group buffer lines. Below is a list of `Form'/`File' pairs. When deciding how a particular group line should be displayed, each form is evaluated. @@ -427,8 +424,7 @@ For example: :type '(repeat (cons (sexp :tag "Method") (symbol :tag "Charset")))) (defcustom gnus-group-name-charset-group-alist - (if (or (and (fboundp 'find-coding-system) (find-coding-system 'utf-8)) - (mm-coding-system-p 'utf-8)) + (if (mm-coding-system-p 'utf-8) '((".*" . utf-8)) nil) "Alist of group regexp and the charset for group names. @@ -455,10 +451,12 @@ used when no prefix argument is given to `gnus-group-jump-to-group'." (repeat (cons (integer :tag "Argument") (string :tag "Prompt string"))))) -(defvar gnus-group-listing-limit 1000 - "*A limit of the number of groups when listing. +(defcustom gnus-group-listing-limit 1000 + "A limit of the number of groups when listing. If the number of groups is larger than the limit, list them in a -simple manner.") +simple manner." + :group 'gnus-group-listing + :type 'integer) ;;; Internal variables @@ -535,10 +533,7 @@ simple manner.") (?O gnus-tmp-moderated-string ?s) (?p gnus-tmp-process-marked ?c) (?s gnus-tmp-news-server ?s) - (?n ,(if (featurep 'xemacs) - '(symbol-name gnus-tmp-news-method) - 'gnus-tmp-news-method) - ?s) + (?n gnus-tmp-news-method ?s) (?P gnus-group-indentation ?s) (?E gnus-tmp-group-icon ?s) (?B gnus-tmp-summary-live ?c) @@ -632,8 +627,8 @@ simple manner.") "\C-c\C-i" gnus-info-find-node "\M-e" gnus-group-edit-group-method "^" gnus-group-enter-server-mode - gnus-mouse-2 gnus-mouse-pick-group - [follow-link] mouse-face + [mouse-2] gnus-mouse-pick-group + [follow-link] 'mouse-face "<" beginning-of-buffer ">" end-of-buffer "\C-c\C-b" gnus-bug @@ -644,6 +639,12 @@ simple manner.") "#" gnus-group-mark-group "\M-#" gnus-group-unmark-group) +(gnus-define-keys (gnus-group-cloud-map "~" gnus-group-mode-map) + "u" gnus-cloud-upload-all-data + "~" gnus-cloud-upload-all-data + "d" gnus-cloud-download-all-data + "\r" gnus-cloud-download-all-data) + (gnus-define-keys (gnus-group-mark-map "M" gnus-group-mode-map) "m" gnus-group-mark-group "u" gnus-group-unmark-group @@ -798,32 +799,26 @@ simple manner.") ["Catch up" gnus-group-catchup-current :included (not (gnus-topic-mode-p)) :active (gnus-group-group-name) - ,@(if (featurep 'xemacs) nil - '(:help "Mark unread articles in the current group as read"))] + :help "Mark unread articles in the current group as read"] ["Catch up " gnus-topic-catchup-articles :included (gnus-topic-mode-p) - ,@(if (featurep 'xemacs) nil - '(:help "Mark unread articles in the current group or topic as read"))] + :help "Mark unread articles in the current group or topic as read"] ["Catch up all articles" gnus-group-catchup-current-all (gnus-group-group-name)] ["Check for new articles" gnus-group-get-new-news-this-group :included (not (gnus-topic-mode-p)) :active (gnus-group-group-name) - ,@(if (featurep 'xemacs) nil - '(:help "Check for new messages in current group"))] + :help "Check for new messages in current group"] ["Check for new articles " gnus-topic-get-new-news-this-topic :included (gnus-topic-mode-p) - ,@(if (featurep 'xemacs) nil - '(:help "Check for new messages in current group or topic"))] + :help "Check for new messages in current group or topic"] ["Toggle subscription" gnus-group-unsubscribe-current-group (gnus-group-group-name)] ["Kill" gnus-group-kill-group :active (gnus-group-group-name) - ,@(if (featurep 'xemacs) nil - '(:help "Kill (remove) current group"))] + :help "Kill (remove) current group"] ["Yank" gnus-group-yank-group gnus-list-of-killed-groups] ["Describe" gnus-group-describe-group :active (gnus-group-group-name) - ,@(if (featurep 'xemacs) nil - '(:help "Display description of the current group"))] + :help "Display description of the current group"] ;; Actually one should check, if any of the marked groups gives t for ;; (gnus-check-backend-function 'request-expire-articles ...) ["Expire articles" gnus-group-expire-articles @@ -905,14 +900,14 @@ simple manner.") (memq (gnus-group-group-name) gnus-group-marked))] ["Unmark all" gnus-group-unmark-all-groups gnus-group-marked] ["Mark regexp..." gnus-group-mark-regexp t] - ["Mark region" gnus-group-mark-region :active (gnus-mark-active-p)] + ["Mark region" gnus-group-mark-region :active mark-active] ["Mark buffer" gnus-group-mark-buffer t] ["Execute command" gnus-group-universal-argument (or gnus-group-marked (gnus-group-group-name))]) ("Subscribe" ["Subscribe to a group..." gnus-group-unsubscribe-group t] ["Kill all newsgroups in region" gnus-group-kill-region - :active (gnus-mark-active-p)] + :active mark-active] ["Kill all zombie groups" gnus-group-kill-all-zombies gnus-zombie-list] ["Kill all groups on level..." gnus-group-kill-level t]) @@ -960,13 +955,9 @@ simple manner.") ["Send a message (mail or news)" gnus-group-post-news t] ["Create a local message" gnus-group-news t] ["Check for new news" gnus-group-get-new-news - ,@(if (featurep 'xemacs) '(t) - '(:help "Get newly arrived articles")) - ] + :help "Get newly arrived articles"] ["Send queued messages" gnus-delay-send-queue - ,@(if (featurep 'xemacs) '(t) - '(:help "Send all messages that are scheduled to be sent now")) - ] + :help "Send all messages that are scheduled to be sent now"] ["Activate all groups" gnus-activate-all-groups t] ["Restart Gnus" gnus-group-restart t] ["Read init file" gnus-group-read-init-file t] @@ -981,9 +972,7 @@ simple manner.") ["Flush score cache" gnus-score-flush-cache t] ["Toggle topics" gnus-topic-mode t] ["Send a bug report" gnus-bug t] - ["Exit from Gnus" gnus-group-exit - ,@(if (featurep 'xemacs) '(t) - '(:help "Quit reading news"))] + ["Exit from Gnus" gnus-group-exit :help "Quit reading news"] ["Exit without saving" gnus-group-quit t])) (gnus-run-hooks 'gnus-group-menu-hook))) @@ -1101,18 +1090,14 @@ See `gmm-tool-bar-from-list' for the format of the list." (defun gnus-group-make-tool-bar (&optional force) "Make a group mode tool bar from `gnus-group-tool-bar'. When FORCE, rebuild the tool bar." - (when (and (not (featurep 'xemacs)) - (boundp 'tool-bar-mode) + (when (and (boundp 'tool-bar-mode) tool-bar-mode (display-graphic-p) (or (not gnus-group-tool-bar-map) force)) (let* ((load-path - (gmm-image-load-path-for-library "gnus" - "gnus/toggle-subscription.xpm" - nil t)) - (image-load-path (cons (car load-path) - (when (boundp 'image-load-path) - image-load-path))) + (image-load-path-for-library + "gnus" "gnus/toggle-subscription.xpm" nil t)) + (image-load-path (cons (car load-path) image-load-path)) (map (gmm-tool-bar-from-list gnus-group-tool-bar gnus-group-tool-bar-zap-list 'gnus-group-mode-map))) @@ -1167,7 +1152,7 @@ The following commands are available: (goto-char (point-min)) (setq gnus-group-mark-positions (list (cons 'process (and (search-forward - (mm-string-to-multibyte "\200") nil t) + (string-to-multibyte "\200") nil t) (- (point) (point-min) 1)))))))) (defun gnus-mouse-pick-group (e) @@ -1229,8 +1214,8 @@ The following commands are available: (defun gnus-group-name-decode (string charset) ;; Fixme: Don't decode in unibyte mode. - (if (and string charset (featurep 'mule)) - (mm-decode-coding-string string charset) + (if (and string charset) + (decode-coding-string string charset) string)) (defun gnus-group-decoded-name (string) @@ -1394,7 +1379,7 @@ if it is a string, only list groups matching REGEXP." (when (or gnus-group-listed-groups (and (>= level gnus-level-killed) (<= lowest gnus-level-killed))) (gnus-group-prepare-flat-list-dead - (gnus-union + (cl-union not-in-list (setq gnus-killed-list (sort gnus-killed-list 'string<)) :test 'equal) @@ -1418,7 +1403,7 @@ if it is a string, only list groups matching REGEXP." (or (not regexp) (and (stringp regexp) (string-match regexp group)) (and (functionp regexp) (funcall regexp group)))) - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) (insert " " mark " *: " (gnus-group-decoded-name group) @@ -1510,13 +1495,10 @@ if it is a string, only list groups matching REGEXP." ;; Date: Mon, 23 Jan 2006 19:59:13 +0100 ;; Message-ID: <v9acdmrcse.fsf@marauder.physik.uni-ulm.de> -(defcustom gnus-group-update-tool-bar - (and (not (featurep 'xemacs)) - (boundp 'tool-bar-mode) - tool-bar-mode - ;; Using `redraw-frame' (see `gnus-tool-bar-update') in Emacs might - ;; be confusing, so maybe we shouldn't call it by default. - (fboundp 'force-window-update)) +;; Using `redraw-frame' (see `gnus-tool-bar-update') in Emacs might +;; be confusing, so maybe we shouldn't call it by default. +(defcustom gnus-group-update-tool-bar (and (boundp 'tool-bar-mode) + tool-bar-mode) "Force updating the group buffer tool bar." :group 'gnus-group :version "22.1" @@ -1597,7 +1579,7 @@ if it is a string, only list groups matching REGEXP." gnus-tmp-header) ; passed as parameter to user-funcs. (beginning-of-line) (setq beg (point)) - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) ;; Insert the text. @@ -1625,58 +1607,42 @@ if it is a string, only list groups matching REGEXP." (progn (unless (bound-and-true-p cursor-sensor-mode) (cursor-sensor-mode 1)) - (gnus-put-text-property beg end 'cursor-sensor-functions + (put-text-property beg end 'cursor-sensor-functions '(gnus-tool-bar-update))) - (gnus-put-text-property beg end 'point-entered + (put-text-property beg end 'point-entered #'gnus-tool-bar-update) - (gnus-put-text-property beg end 'point-left + (put-text-property beg end 'point-left #'gnus-tool-bar-update)))) (defun gnus-group-update-eval-form (group list) "Eval `car' of each element of LIST, and return the first that return t. Some value are bound so the form can use them." - (defvar group-age) (defvar ticked) (defvar score) (defvar level) - (defvar mailp) (defvar total) (defvar unread) (when list (let* ((entry (gnus-group-entry group)) - (unread (if (numberp (car entry)) (car entry) 0)) (active (gnus-active group)) - (total (if active (1+ (- (cdr active) (car active))) 0)) (info (nth 2 entry)) - (method (inline (gnus-server-get-method group (gnus-info-method info)))) + (method (inline (gnus-server-get-method + group (gnus-info-method info)))) (marked (gnus-info-marks info)) - (mailp (apply 'append - (mapcar - (lambda (x) - (memq x (assoc (symbol-name - (car (or method gnus-select-method))) - gnus-valid-select-methods))) - '(mail post-mail)))) - (level (or (gnus-info-level info) gnus-level-killed)) - (score (or (gnus-info-score info) 0)) - (ticked (gnus-range-length (cdr (assq 'tick marked)))) - (group-age (gnus-group-timestamp-delta group))) - ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465 - ;; ====================================================================== - ;; From: Richard Stallman - ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...]) - ;; Cc: ding@gnus.org - ;; Date: Sat, 27 Oct 2007 19:41:20 -0400 - ;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org> - ;; - ;; [...] - ;; The kludge is that the alist elements contain expressions that refer - ;; to local variables with short names. Perhaps write your own tiny - ;; evaluator that handles just `and', `or', and numeric comparisons - ;; and just a few specific variables. - ;; ====================================================================== - ;; - ;; Similar for other evaluated variables. Grep for risky-local-variable - ;; to find them! -- rsteib - ;; - ;; Eval the cars of the lists until we find a match. + (env + (list + (cons 'unread (if (numberp (car entry)) (car entry) 0)) + (cons 'total (if active (1+ (- (cdr active) (car active))) 0)) + (cons 'mailp (apply + 'append + (mapcar + (lambda (x) + (memq x (assoc + (symbol-name + (car (or method gnus-select-method))) + gnus-valid-select-methods))) + '(mail post-mail)))) + (cons 'level (or (gnus-info-level info) gnus-level-killed)) + (cons 'score (or (gnus-info-score info) 0)) + (cons 'ticked (gnus-range-length (cdr (assq 'tick marked)))) + (cons 'group-age (gnus-group-timestamp-delta group))))) (while (and list - (not (eval (caar list)))) + (not (eval (caar list) env))) (setq list (cdr list))) list))) @@ -1687,12 +1653,12 @@ and ends at END." (let ((face (cdar (gnus-group-update-eval-form group gnus-group-highlight)))) - (unless (eq face (gnus-get-text-property-excluding-characters-with-faces beg 'face)) + (unless (eq face (gnus-get-text-property-excluding-characters-with-faces + beg 'face)) (let ((inhibit-read-only t)) (gnus-put-text-property-excluding-characters-with-faces beg end 'face - (if (boundp face) (symbol-value face) face))) - (gnus-extent-start-open beg)))) + (if (boundp face) (symbol-value face) face)))))) (defun gnus-group-get-icon (group) "Return an icon for GROUP according to `gnus-group-icon-list'." @@ -1800,8 +1766,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." (mode-string (eval gformat))) ;; Say whether the dribble buffer has been modified. (setq mode-line-modified - (if modified (car gnus-mode-line-modified) - (cdr gnus-mode-line-modified))) + (if modified "**" "--")) ;; If the line is too long, we chop it off. (when (> (length mode-string) max-len) (setq mode-string (substring mode-string 0 (- max-len 4)))) @@ -2028,7 +1993,7 @@ Take into consideration N (the prefix) and the list of marked groups." (setq n (1- n)) (gnus-group-next-group way))) (nreverse groups))) - ((and (gnus-region-active-p) (mark)) + ((and transient-mark-mode mark-active (mark)) ;; Work on the region between point and mark. (let ((max (max (point) (mark))) groups) @@ -2240,9 +2205,9 @@ if it is not a list." (member group (mapcar 'symbol-name collection)) (symbol-value (intern-soft group collection))) (setq group - (mm-encode-coding-string + (encode-coding-string group (gnus-group-name-charset nil group)))) - (gnus-replace-in-string group "\n" ""))) + (replace-regexp-in-string "\n" "" group))) ;;;###autoload (defun gnus-fetch-group (group &optional articles) @@ -2402,7 +2367,7 @@ specified by `gnus-gmane-group-download-format'." (unless range (setq range 500)) (when (< range 1) (error "Invalid range: %s" range)) - (let ((tmpfile (mm-make-temp-file + (let ((tmpfile (make-temp-file (format "%s.start-%s.range-%s." group start range))) (gnus-thread-sort-functions '(gnus-thread-sort-by-number))) (with-temp-file tmpfile @@ -2488,21 +2453,25 @@ the bug number, and browsing the URL must return mbox output." (setq ids (string-to-number ids))) (unless (listp ids) (setq ids (list ids))) - (let ((tmpfile (mm-make-temp-file "gnus-temp-group-"))) + (let ((tmpfile (make-temp-file "gnus-temp-group-"))) (let ((coding-system-for-write 'binary) (coding-system-for-read 'binary)) (with-temp-file tmpfile (mm-disable-multibyte) (dolist (id ids) - (url-insert-file-contents (format mbox-url id))) + (let ((file (format "~/.emacs.d/debbugs-cache/%s" id))) + (if (and (not gnus-plugged) + (file-exists-p file)) + (insert-file-contents file) + (url-insert-file-contents (format mbox-url id))))) (goto-char (point-min)) ;; Add the debbugs address so that we can respond to reports easily. (while (re-search-forward "^To: " nil t) (end-of-line) (insert (format ", %s@%s" (car ids) - (gnus-replace-in-string - (gnus-replace-in-string mbox-url "^http://" "") - "/.*$" "")))))) + (replace-regexp-in-string + "/.*$" "" + (replace-regexp-in-string "^http://" "" mbox-url))))))) (gnus-group-read-ephemeral-group (format "nndoc+ephemeral:bug#%s" (mapconcat 'number-to-string ids ",")) @@ -2762,7 +2731,7 @@ server." (when (stringp method) (setq method (or (gnus-server-to-method method) method))) (unless encoded - (setq name (mm-encode-coding-string + (setq name (encode-coding-string name (gnus-group-name-charset method name)))) (let* ((meth (gnus-method-simplify @@ -2880,7 +2849,7 @@ and NEW-NAME will be prompted for." "Rename group to: " (gnus-group-real-name (gnus-group-decoded-name group))) method (gnus-info-method (gnus-get-info group))) - (list group (mm-encode-coding-string + (list group (encode-coding-string new-name (gnus-group-name-charset method @@ -2951,7 +2920,7 @@ and NEW-NAME will be prompted for." (gnus-info-params info)) (t info)) ;; The proper documentation. - (gnus-format-message + (format-message "Editing the %s for `%s'." (cond ((eq part 'method) "select method") @@ -3094,9 +3063,9 @@ If called with a prefix argument, ask for the file type." (list 'nndoc-address file) (list 'nndoc-article-type (or type 'guess)))) (coding (gnus-group-name-charset method name))) - (setcar (cdr method) (mm-encode-coding-string file coding)) + (setcar (cdr method) (encode-coding-string file coding)) (gnus-group-make-group - (mm-encode-coding-string (gnus-group-real-name name) coding) + (encode-coding-string (gnus-group-real-name name) coding) method nil nil t))) (defvar nnweb-type-definition) @@ -3173,8 +3142,8 @@ If there is, use Gnus to create an nnrss group" (coding (gnus-group-name-charset '(nnrss "") title))) (when coding ;; Unify non-ASCII text. - (setq title (mm-decode-coding-string - (mm-encode-coding-string title coding) + (setq title (decode-coding-string + (encode-coding-string title coding) coding))) (gnus-group-make-group title '(nnrss "")) (push (list title href desc) nnrss-group-alist) @@ -3279,7 +3248,7 @@ mail messages or news articles in files that have numeric names." (error "%s is not an nnimap group" group)) (unless (setq acl (nnimap-acl-get mailbox (cadr method))) (error "Server does not support ACL's")) - (gnus-edit-form acl (gnus-format-message "\ + (gnus-edit-form acl (format-message "\ Editing the access control list for `%s'. An access control list is a list of (identifier . rights) elements. @@ -4040,7 +4009,7 @@ entail asking the server for the groups." (erase-buffer) (while groups (setq group (pop groups)) - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) (insert " *: " (gnus-group-decoded-name group) @@ -4162,22 +4131,23 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (gnus-read-all-descriptions-files))) (error "Couldn't request descriptions file")) (let ((buffer-read-only nil) - b) - (erase-buffer) + b groups) (mapatoms (lambda (group) - (setq b (point)) - (let ((charset (gnus-group-name-charset nil (symbol-name group)))) - (insert (format " *: %-20s %s\n" - (gnus-group-name-decode - (symbol-name group) charset) - (gnus-group-name-decode - (symbol-value group) charset)))) - (gnus-add-text-properties - b (1+ b) (list 'gnus-group group - 'gnus-unread t 'gnus-marked nil - 'gnus-level (1+ gnus-level-subscribed)))) + (push (symbol-name group) groups)) gnus-description-hashtb) + (setq groups (sort groups 'string<)) + (erase-buffer) + (dolist (group groups) + (setq b (point)) + (let ((charset (gnus-group-name-charset nil group))) + (insert (format " *: %-20s %s\n" + (gnus-group-name-decode group charset) + (gnus-group-name-decode group charset)))) + (add-text-properties + b (1+ b) (list 'gnus-group (intern group gnus-description-hashtb) + 'gnus-unread t 'gnus-marked nil + 'gnus-level (1+ gnus-level-subscribed)))) (goto-char (point-min)) (gnus-group-position-point))) @@ -4533,7 +4503,7 @@ and the second element is the address." (if force (if (null articles) (setcar (nthcdr 3 info) - (gnus-delete-alist type (car marked))) + (assq-delete-all type (car marked))) (setcdr m (gnus-compress-sequence articles t))) (setcdr m (gnus-compress-sequence (sort (nconc (gnus-uncompress-range (cdr m)) @@ -4571,7 +4541,7 @@ or `gnus-group-catchup-group-hook'." "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." (let* ((time (or (gnus-group-timestamp group) (list 0 0))) - (delta (subtract-time (current-time) time))) + (delta (time-subtract (current-time) time))) (+ (* (nth 0 delta) 65536.0) (nth 1 delta)))) @@ -4675,14 +4645,10 @@ This command may read the active file." (gnus-group-list-mode gnus-group-list-mode) ;; Save it. func) (push last-command-event unread-command-events) - (if (featurep 'xemacs) - (push (make-event 'key-press '(key ?A)) unread-command-events) - (push ?A unread-command-events)) + (push ?A unread-command-events) (let (gnus-pick-mode keys) - (setq keys (if (featurep 'xemacs) - (events-to-keys (read-key-sequence nil)) - (read-key-sequence nil))) - (setq func (lookup-key (current-local-map) keys))) + (setq keys (read-key-sequence nil) + func (lookup-key (current-local-map) keys))) (if (or (not func) (numberp func)) (ding) diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index 1fd9f179649..d4dccfb7b1f 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -39,7 +39,8 @@ (require 'xml) (require 'browse-url) (require 'mm-util) -(eval-and-compile (unless (featurep 'xemacs) (require 'help-fns))) +(require 'help-fns) +(require 'url-queue) (defcustom gnus-html-image-cache-ttl (days-to-time 7) "Time used to determine if we should use images from the cache." @@ -88,27 +89,9 @@ fit these criteria." (define-key map [tab] 'widget-forward) map)) -(eval-and-compile - (defalias 'gnus-html-encode-url-chars - (if (fboundp 'browse-url-url-encode-chars) - 'browse-url-url-encode-chars - (lambda (text chars) - "URL-encode the chars in TEXT that match CHARS. -CHARS is a regexp-like character alternative (e.g., \"[)$]\")." - (let ((encoded-text (copy-sequence text)) - (s 0)) - (while (setq s (string-match chars encoded-text s)) - (setq encoded-text - (replace-match (format "%%%x" - (string-to-char - (match-string 0 encoded-text))) - t t encoded-text) - s (1+ s))) - encoded-text))))) - (defun gnus-html-encode-url (url) "Encode URL." - (gnus-html-encode-url-chars url "[)$ ]")) + (browse-url-url-encode-chars url "[)$ ]")) (defun gnus-html-cache-expired (url ttl) "Check if URL is cached for more than TTL." @@ -143,7 +126,7 @@ CHARS is a regexp-like character alternative (e.g., \"[)$]\")." charset nil t)) (not (eq charset 'ascii))) (insert (prog1 - (mm-decode-coding-string (buffer-string) charset) + (decode-coding-string (buffer-string) charset) (erase-buffer) (mm-enable-multibyte)))) (call-process-region (point-min) (point-max) @@ -197,7 +180,7 @@ CHARS is a regexp-like character alternative (e.g., \"[)$]\")." alt-text (when (string-match "\\(alt\\|title\\)=\"\\([^\"]+\\)" parameters) (xml-substitute-special (match-string 2 parameters)))) - (gnus-add-text-properties + (add-text-properties start end (list 'image-url url 'image-displayer `(lambda (url start end) @@ -310,7 +293,7 @@ Use ALT-TEXT for the image string." (let ((overlay (make-overlay start end))) (overlay-put overlay 'evaporate t) (overlay-put overlay 'gnus-button-url url) - (gnus-put-text-property start end 'gnus-string url) + (put-text-property start end 'gnus-string url) (when gnus-article-mouse-face (overlay-put overlay 'mouse-face gnus-article-mouse-face))))) ;; The upper-case IMG_ALT is apparently just an artifact that @@ -391,14 +374,9 @@ Use ALT-TEXT for the image string." "Retrieve IMAGE, and place it into BUFFER on arrival." (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, image %s" buffer image) - (if (fboundp 'url-queue-retrieve) - (url-queue-retrieve (car image) - 'gnus-html-image-fetched - (list buffer image) t t) - (ignore-errors - (url-retrieve (car image) - 'gnus-html-image-fetched - (list buffer image))))) + (url-queue-retrieve (car image) + 'gnus-html-image-fetched + (list buffer image) t t)) (defun gnus-html-image-fetched (status buffer image) "Callback function called when image has been fetched." @@ -427,7 +405,7 @@ Return a string with image data." (defun gnus-html-maximum-image-size () "Return the maximum size of an image according to `gnus-max-image-proportion'." - (let ((edges (gnus-window-inside-pixel-edges + (let ((edges (window-inside-pixel-edges (get-buffer-window (current-buffer))))) ;; (width . height) (cons @@ -444,7 +422,7 @@ Return a string with image data." (defun gnus-html-put-image (data url &optional alt-text) "Put an image with DATA from URL and optional ALT-TEXT." - (when (gnus-graphic-display-p) + (when (display-graphic-p) (let* ((start (text-property-any (point-min) (point-max) 'image-url url)) (end (when start @@ -454,10 +432,7 @@ Return a string with image data." (let* ((image (ignore-errors (gnus-create-image data nil t))) - (size (and image - (if (featurep 'xemacs) - (cons (glyph-width image) (glyph-height image)) - (image-size image t))))) + (size (and image (image-size image t)))) (save-excursion (goto-char start) (let ((alt-text (or alt-text @@ -466,16 +441,8 @@ Return a string with image data." (if (and image ;; Kludge to avoid displaying 30x30 gif images, which ;; seems to be a signal of a broken image. - (not (and (if (featurep 'xemacs) - (glyphp image) - (listp image)) - (eq (if (featurep 'xemacs) - (let ((d (cdadar - (specifier-spec-list - (glyph-image image))))) - (and (vectorp d) - (aref d 0))) - (plist-get (cdr image) :type)) + (not (and (listp image) + (eq (plist-get (cdr image) :type) 'gif) (= (car size) 30) (= (cdr size) 30)))) @@ -488,10 +455,9 @@ Return a string with image data." :help-echo alt-text :keymap gnus-html-displayed-image-map url) - (gnus-put-text-property start (point) - 'gnus-alt-text alt-text) + (put-text-property start (point) 'gnus-alt-text alt-text) (when url - (gnus-add-text-properties + (add-text-properties start (point) `(image-url ,url diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index 72413962673..1f194f888d2 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -119,17 +119,17 @@ nil "iCalendar class for REPLY events") -(defmethod gnus-icalendar-event:recurring-p ((event gnus-icalendar-event)) +(cl-defmethod gnus-icalendar-event:recurring-p ((event gnus-icalendar-event)) "Return t if EVENT is recurring." (not (null (gnus-icalendar-event:recur event)))) -(defmethod gnus-icalendar-event:recurring-freq ((event gnus-icalendar-event)) +(cl-defmethod gnus-icalendar-event:recurring-freq ((event gnus-icalendar-event)) "Return recurring frequency of EVENT." (let ((rrule (gnus-icalendar-event:recur event))) (string-match "FREQ=\\([[:alpha:]]+\\)" rrule) (match-string 1 rrule))) -(defmethod gnus-icalendar-event:recurring-interval ((event gnus-icalendar-event)) +(cl-defmethod gnus-icalendar-event:recurring-interval ((event gnus-icalendar-event)) "Return recurring interval of EVENT." (let ((rrule (gnus-icalendar-event:recur event)) (default-interval 1)) @@ -138,7 +138,7 @@ (or (match-string 1 rrule) default-interval))) -(defmethod gnus-icalendar-event:start ((event gnus-icalendar-event)) +(cl-defmethod gnus-icalendar-event:start ((event gnus-icalendar-event)) (format-time-string "%Y-%m-%d %H:%M" (gnus-icalendar-event:start-time event))) (defun gnus-icalendar-event--decode-datefield (event field zone-map) @@ -152,17 +152,19 @@ (defun gnus-icalendar-event--find-attendee (ical name-or-email) (let* ((event (car (icalendar--all-events ical))) (event-props (caddr event))) - (gmm-labels ((attendee-name (att) (plist-get (cadr att) 'CN)) - (attendee-email (att) - (replace-regexp-in-string "^.*MAILTO:" "" (caddr att))) - (attendee-prop-matches-p (prop) - (and (eq (car prop) 'ATTENDEE) - (or (member (attendee-name prop) name-or-email) - (let ((att-email (attendee-email prop))) - (gnus-icalendar-find-if (lambda (email) - (string-match email att-email)) - name-or-email)))))) - + (cl-labels ((attendee-name (att) (plist-get (cadr att) 'CN)) + (attendee-email + (att) + (replace-regexp-in-string "^.*MAILTO:" "" (caddr att))) + (attendee-prop-matches-p + (prop) + (and (eq (car prop) 'ATTENDEE) + (or (member (attendee-name prop) name-or-email) + (let ((att-email (attendee-email prop))) + (gnus-icalendar-find-if + (lambda (email) + (string-match email att-email)) + name-or-email)))))) (gnus-icalendar-find-if #'attendee-prop-matches-p event-props)))) (defun gnus-icalendar-event--get-attendee-names (ical) @@ -171,17 +173,19 @@ (lambda (p) (eq (car p) 'ATTENDEE)) (caddr event)))) - (gmm-labels ((attendee-role (prop) (plist-get (cadr prop) 'ROLE)) - (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)) - attendee-props)) - (attendee-names-by-type (type) - (mapcar #'attendee-name (attendees-by-type type)))) - + (cl-labels + ((attendee-role (prop) (plist-get (cadr prop) 'ROLE)) + (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)) + attendee-props)) + (attendee-names-by-type + (type) + (mapcar #'attendee-name (attendees-by-type type)))) (list (attendee-names-by-type "REQ-PARTICIPANT") (attendee-names-by-type "OPT-PARTICIPANT"))))) @@ -220,23 +224,25 @@ ((string= method "REPLY") 'gnus-icalendar-event-reply) (t 'gnus-icalendar-event)))) - (gmm-labels ((map-property (prop) - (let ((value (icalendar--get-event-property event prop))) - (when value - ;; ugly, but cannot get - ;;replace-regexp-in-string work with "\\" as - ;;REP, plus we should also handle "\\;" - (replace-regexp-in-string - "\\\\," "," - (replace-regexp-in-string - "\\\\n" "\n" (substring-no-properties value)))))) - (accumulate-args (mapping) - (destructuring-bind (slot . ical-property) mapping - (setq args (append (list - (intern (concat ":" (symbol-name slot))) - (map-property ical-property)) - args))))) - + (cl-labels + ((map-property + (prop) + (let ((value (icalendar--get-event-property event prop))) + (when value + ;; ugly, but cannot get + ;;replace-regexp-in-string work with "\\" as + ;;REP, plus we should also handle "\\;" + (replace-regexp-in-string + "\\\\," "," + (replace-regexp-in-string + "\\\\n" "\n" (substring-no-properties value)))))) + (accumulate-args + (mapping) + (destructuring-bind (slot . ical-property) mapping + (setq args (append (list + (intern (concat ":" (symbol-name slot))) + (map-property ical-property)) + args))))) (mapc #'accumulate-args prop-map) (apply 'make-instance event-class args)))) @@ -264,41 +270,46 @@ status will be retrieved from the first matching attendee record." (let ((summary-status (capitalize (symbol-name status))) (attendee-status (upcase (symbol-name status))) reply-event-lines) - (gmm-labels ((update-summary (line) - (if (string-match "^[^:]+:" line) - (replace-match (format "\\&%s: " summary-status) t nil line) - line)) - (update-dtstamp () - (format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t)) - (attendee-matches-identity (line) - (gnus-icalendar-find-if (lambda (name) (string-match-p name line)) - identities)) - (update-attendee-status (line) - (when (and (attendee-matches-identity line) - (string-match "\\(PARTSTAT=\\)[^;]+" line)) - (replace-match (format "\\1%s" attendee-status) t nil line))) - (process-event-line (line) - (when (string-match "^\\([^;:]+\\)" line) - (let* ((key (match-string 0 line)) - ;; NOTE: not all of the below fields are mandatory, - ;; but they are often present in other clients' - ;; replies. Can be helpful for debugging, too. - (new-line - (cond - ((string= key "ATTENDEE") (update-attendee-status line)) - ((string= key "SUMMARY") (update-summary line)) - ((string= key "DTSTAMP") (update-dtstamp)) - ((member key '("ORGANIZER" "DTSTART" "DTEND" - "LOCATION" "DURATION" "SEQUENCE" - "RECURRENCE-ID" "UID")) line) - (t nil)))) - (when new-line - (push new-line reply-event-lines)))))) + (cl-labels + ((update-summary + (line) + (if (string-match "^[^:]+:" line) + (replace-match (format "\\&%s: " summary-status) t nil line) + line)) + (update-dtstamp () + (format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t)) + (attendee-matches-identity + (line) + (gnus-icalendar-find-if (lambda (name) (string-match-p name line)) + identities)) + (update-attendee-status + (line) + (when (and (attendee-matches-identity line) + (string-match "\\(PARTSTAT=\\)[^;]+" line)) + (replace-match (format "\\1%s" attendee-status) t nil line))) + (process-event-line + (line) + (when (string-match "^\\([^;:]+\\)" line) + (let* ((key (match-string 0 line)) + ;; NOTE: not all of the below fields are mandatory, + ;; but they are often present in other clients' + ;; replies. Can be helpful for debugging, too. + (new-line + (cond + ((string= key "ATTENDEE") (update-attendee-status line)) + ((string= key "SUMMARY") (update-summary line)) + ((string= key "DTSTAMP") (update-dtstamp)) + ((member key '("ORGANIZER" "DTSTART" "DTEND" + "LOCATION" "DURATION" "SEQUENCE" + "RECURRENCE-ID" "UID")) line) + (t nil)))) + (when new-line + (push new-line reply-event-lines)))))) (mapc #'process-event-line (split-string ical-request "\n")) (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x)) - reply-event-lines) + reply-event-lines) (error "Could not find an event attendee matching given identity")) (mapconcat #'identity `("BEGIN:VEVENT" @@ -311,16 +322,17 @@ status will be retrieved from the first matching attendee record." The reply will have STATUS (`accepted', `tentative' or `declined'). The reply will be composed for attendees matching any entry on the IDENTITIES list." - (gmm-labels ((extract-block (blockname) - (save-excursion - (let ((block-start-re (format "^BEGIN:%s" blockname)) - (block-end-re (format "^END:%s" blockname)) - start) - (when (re-search-forward block-start-re nil t) - (setq start (line-beginning-position)) - (re-search-forward block-end-re) - (buffer-substring-no-properties start (line-end-position))))))) - + (cl-labels + ((extract-block + (blockname) + (save-excursion + (let ((block-start-re (format "^BEGIN:%s" blockname)) + (block-end-re (format "^END:%s" blockname)) + start) + (when (re-search-forward block-start-re nil t) + (setq start (line-beginning-position)) + (re-search-forward block-end-re) + (buffer-substring-no-properties start (line-end-position))))))) (let (zone event) (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf)) (goto-char (point-min)) @@ -376,7 +388,7 @@ on the IDENTITIES list." (defvar gnus-icalendar-org-enabled-p nil) -(defmethod gnus-icalendar-event:org-repeat ((event gnus-icalendar-event)) +(cl-defmethod gnus-icalendar-event:org-repeat ((event gnus-icalendar-event)) "Return `org-mode' timestamp repeater string for recurring EVENT. Return nil for non-recurring EVENT." (when (gnus-icalendar-event:recurring-p event) @@ -390,14 +402,14 @@ Return nil for non-recurring EVENT." (when org-freq (format "+%s%s" (gnus-icalendar-event:recurring-interval event) org-freq))))) -(defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-event)) +(cl-defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-event)) "Build `org-mode' timestamp from EVENT start/end dates and recurrence info." (let* ((start (gnus-icalendar-event:start-time event)) (end (gnus-icalendar-event:end-time event)) - (start-date (format-time-string "%Y-%m-%d %a" start)) + (start-date (format-time-string "%Y-%m-%d" start)) (start-time (format-time-string "%H:%M" start)) (start-at-midnight (string= start-time "00:00")) - (end-date (format-time-string "%Y-%m-%d %a" end)) + (end-date (format-time-string "%Y-%m-%d" end)) (end-time (format-time-string "%H:%M" end)) (end-at-midnight (string= end-time "00:00")) (start-end-date-diff @@ -417,7 +429,7 @@ Return nil for non-recurring EVENT." ;; A 0:0 - A+1 0:0 -> A ;; A 0:0 - A+n 0:0 -> A - A+n-1 ((and start-at-midnight end-at-midnight) (if (> start-end-date-diff 1) - (let ((end-ts (format-time-string "%Y-%m-%d %a" (time-subtract end time-1-day)))) + (let ((end-ts (format-time-string "%Y-%m-%d" (time-subtract end time-1-day)))) (format "<%s>--<%s>" start-date end-ts)) (format "<%s%s>" start-date repeat))) ;; end midnight @@ -425,7 +437,7 @@ Return nil for non-recurring EVENT." ;; A .:. - A+n 0:0 -> A .:. - A_n-1 (end-at-midnight (if (= start-end-date-diff 1) (format "<%s %s-23:59%s>" start-date start-time repeat) - (let ((end-ts (format-time-string "%Y-%m-%d %a" (time-subtract end time-1-day)))) + (let ((end-ts (format-time-string "%Y-%m-%d" (time-subtract end time-1-day)))) (format "<%s %s>--<%s>" start-date start-time end-ts)))) ;; start midnight ;; A 0:0 - A .:. -> A 0:0-.:. (default 1) @@ -448,7 +460,7 @@ Return nil for non-recurring EVENT." (mapconcat #'identity participants ", ")) ;; TODO: make the template customizable -(defmethod gnus-icalendar-event->org-entry ((event gnus-icalendar-event) reply-status) +(cl-defmethod gnus-icalendar-event->org-entry ((event gnus-icalendar-event) reply-status) "Return string with new `org-mode' entry describing EVENT." (with-temp-buffer (org-mode) @@ -498,16 +510,17 @@ the optional ORG-FILE argument is specified, only that one file is searched." (let ((uid (gnus-icalendar-event:uid event)) (files (or org-file (org-agenda-files t 'ifmode)))) - (gmm-labels - ((find-event-in (file) - (org-check-agenda-file file) - (with-current-buffer (find-file-noselect file) - (let ((event-pos (org-find-entry-with-id uid))) - (when (and event-pos - (string= (cdr (assoc "ICAL_EVENT" (org-entry-properties event-pos))) - "t")) - (throw 'found file)))))) - + (cl-labels + ((find-event-in + (file) + (org-check-agenda-file file) + (with-current-buffer (find-file-noselect file) + (let ((event-pos (org-find-entry-with-id uid))) + (when (and event-pos + (string= (cdr (assoc "ICAL_EVENT" + (org-entry-properties event-pos))) + "t")) + (throw 'found file)))))) (gnus-icalendar-find-if #'find-event-in files)))) @@ -567,22 +580,29 @@ is searched." (fill-region (point-min) (point-max)))) ;; update entry properties - (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)))) + (cl-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 "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"))) + (update-org-entry + event-pos "REPLY" + (if reply-status (capitalize (symbol-name reply-status)) + "Not replied yet"))) (save-buffer))))))))) @@ -641,12 +661,12 @@ is searched." (org-agenda-list nil (gnus-icalendar-event:start event) duration-days))) -(defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status) +(cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status) (if (gnus-icalendar-find-org-event-file event) (gnus-icalendar--update-org-event event reply-status) (gnus-icalendar:org-event-save event reply-status))) -(defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) reply-status) +(cl-defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) reply-status) (when (gnus-icalendar-find-org-event-file event) (gnus-icalendar--cancel-org-event event))) @@ -703,40 +723,43 @@ only makes sense to define names or email addresses." These will be used to retrieve the RSVP information from ical events." (apply #'append - (mapcar (lambda (x) (if (listp x) x (list x))) - (list user-full-name (regexp-quote user-mail-address) - ; NOTE: these can be lists - gnus-ignored-from-addresses ; already regexp-quoted - message-alternative-emails ; - (mapcar #'regexp-quote gnus-icalendar-additional-identities))))) + (mapcar + (lambda (x) (if (listp x) x (list x))) + (list user-full-name (regexp-quote user-mail-address) + ;; NOTE: these can be lists + gnus-ignored-from-addresses ; already regexp-quoted + (unless (functionp message-alternative-emails) ; String or function. + message-alternative-emails) + (mapcar #'regexp-quote gnus-icalendar-additional-identities))))) ;; TODO: make the template customizable -(defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status) +(cl-defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status) "Format an overview of EVENT details." - (gmm-labels ((format-header (x) - (format "%-12s%s" - (propertize (concat (car x) ":") 'face 'bold) - (cadr x)))) + (cl-labels + ((format-header (x) + (format "%-12s%s" + (propertize (concat (car x) ":") 'face 'bold) + (cadr x)))) (with-slots (organizer summary description location recur uid method rsvp participation-type) event (let ((headers `(("Summary" ,summary) - ("Location" ,(or location "")) - ("Time" ,(gnus-icalendar-event:org-timestamp event)) - ("Organizer" ,organizer) - ("Attendance" ,(if (eq participation-type 'non-participant) - "You are not listed as an attendee" - (capitalize (symbol-name participation-type)))) - ("Method" ,method)))) - - (when (and (not (gnus-icalendar-event-reply-p event)) rsvp) - (setq headers (append headers - `(("Status" ,(or reply-status "Not replied yet")))))) - - (concat - (mapconcat #'format-header headers "\n") - "\n\n" - description))))) + ("Location" ,(or location "")) + ("Time" ,(gnus-icalendar-event:org-timestamp event)) + ("Organizer" ,organizer) + ("Attendance" ,(if (eq participation-type 'non-participant) + "You are not listed as an attendee" + (capitalize (symbol-name participation-type)))) + ("Method" ,method)))) + + (when (and (not (gnus-icalendar-event-reply-p event)) rsvp) + (setq headers (append headers + `(("Status" ,(or reply-status "Not replied yet")))))) + + (concat + (mapconcat #'format-header headers "\n") + "\n\n" + description))))) (defmacro gnus-icalendar-with-decoded-handle (handle &rest body) "Execute BODY in buffer containing the decoded contents of HANDLE." @@ -745,8 +768,7 @@ These will be used to retrieve the RSVP information from ical events." (with-temp-buffer (mm-insert-part ,handle) (when (string= ,charset "utf-8") - (mm-decode-coding-region (point-min) (point-max) 'utf-8)) - + (decode-coding-region (point-min) (point-max) 'utf-8)) ,@body)))) @@ -758,7 +780,7 @@ These will be used to retrieve the RSVP information from ical events." ;; FIXME: the gnus-mime-button-map keymap does not make sense for this kind ;; of button. (let ((start (point))) - (gnus-add-text-properties + (add-text-properties start (progn (insert "[ " text " ]") @@ -769,8 +791,7 @@ These will be used to retrieve the RSVP information from ical events." face ,gnus-article-button-face gnus-data ,data)) (widget-convert-button 'link start (point) - :action 'gnus-widget-press-button - :button-keymap gnus-widget-button-keymap))) + :action 'gnus-widget-press-button))) (defun gnus-icalendar-send-buffer-by-mail (buffer-name subject) (let ((message-signature nil)) @@ -794,11 +815,13 @@ These will be used to retrieve the RSVP information from ical events." (current-buffer) status (gnus-icalendar-identities))))) (when reply - (gmm-labels ((fold-icalendar-buffer () - (goto-char (point-min)) - (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t) - (replace-match "\\1\n \\2") - (goto-char (line-beginning-position))))) + (cl-labels + ((fold-icalendar-buffer + () + (goto-char (point-min)) + (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t) + (replace-match "\\1\n \\2") + (goto-char (line-beginning-position))))) (let ((subject (concat (capitalize (symbol-name status)) ": " (gnus-icalendar-event:summary event)))) @@ -819,27 +842,27 @@ These will be used to retrieve the RSVP information from ical events." (defun gnus-icalendar-sync-event-to-org (event) (gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status)) -(defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle) +(cl-defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle) (when (gnus-icalendar-event:rsvp event) `(("Accept" gnus-icalendar-reply (,handle accepted ,event)) ("Tentative" gnus-icalendar-reply (,handle tentative ,event)) ("Decline" gnus-icalendar-reply (,handle declined ,event))))) -(defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply) handle) +(cl-defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply) handle) "No buttons for REPLY events." nil) -(defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event)) +(cl-defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event)) (or (when gnus-icalendar-org-enabled-p (gnus-icalendar--get-org-event-reply-status event)) "Not replied yet")) -(defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event-reply)) +(cl-defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event-reply)) "No reply status for REPLY events." nil) -(defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event)) +(cl-defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event)) (let* ((org-entry-exists-p (gnus-icalendar-find-org-event-file event)) (export-button-text (if org-entry-exists-p "Update Org Entry" "Export to Org"))) @@ -851,7 +874,7 @@ These will be used to retrieve the RSVP information from ical events." `("Show Org Entry" gnus-icalendar--show-org-event ,event)))))) -(defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event-cancel)) +(cl-defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event-cancel)) (let ((org-entry-exists-p (gnus-icalendar-find-org-event-file event))) (delq nil (list @@ -868,13 +891,15 @@ These will be used to retrieve the RSVP information from ical events." (setq gnus-icalendar-reply-status nil) (when event - (gmm-labels ((insert-button-group (buttons) - (when buttons - (mapc (lambda (x) - (apply 'gnus-icalendar-insert-button x) - (insert " ")) - buttons) - (insert "\n\n")))) + (cl-labels + ((insert-button-group + (buttons) + (when buttons + (mapc (lambda (x) + (apply 'gnus-icalendar-insert-button x) + (insert " ")) + buttons) + (insert "\n\n")))) (insert-button-group (gnus-icalendar-event:inline-reply-buttons event handle)) diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index a4f75e076f7..aaeba4a4331 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -164,7 +164,7 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server." (gnus-open-server gnus-select-method) gnus-batch-mode (gnus-y-or-n-p - (gnus-format-message + (format-message "%s (%s) open error: `%s'. Continue? " (car gnus-select-method) (cadr gnus-select-method) (gnus-status-message gnus-select-method))) @@ -777,8 +777,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (message-options-set-recipient) (save-restriction (message-narrow-to-head) - (let ((mail-parse-charset message-default-charset)) - (mail-encode-encoded-word-buffer))) + (mail-encode-encoded-word-buffer)) (message-encode-message-body))) (let ((gnus-command-method (or gnus-command-method (gnus-find-method-for-group group))) @@ -800,8 +799,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (message-options-set-recipient) (save-restriction (message-narrow-to-head) - (let ((mail-parse-charset message-default-charset)) - (mail-encode-encoded-word-buffer))) + (mail-encode-encoded-word-buffer)) (message-encode-message-body))) (let* ((func (car (gnus-group-name-to-method group))) (result (funcall (intern (format "%s-request-replace-article" func)) diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 1c8a0d15ecf..c405c04e38e 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -37,13 +37,13 @@ :type 'hook) (defcustom gnus-kill-expiry-days 7 - "*Number of days before expiring unused kill file entries." + "Number of days before expiring unused kill file entries." :group 'gnus-score-kill :group 'gnus-score-expire :type 'integer) (defcustom gnus-kill-save-kill-file nil - "*If non-nil, will save kill files after processing them." + "If non-nil, will save kill files after processing them." :group 'gnus-score-kill :type 'boolean) @@ -52,7 +52,7 @@ I don't know, Per.") (defcustom gnus-kill-killed t - "*If non-nil, Gnus will apply kill files to already killed articles. + "If non-nil, Gnus will apply kill files to already killed articles. If it is nil, Gnus will never apply kill files to articles that have already been through the scoring process, which might very well save lots of time." diff --git a/lisp/gnus/gnus-mh.el b/lisp/gnus/gnus-mh.el index 0816b7838f1..502b295cd60 100644 --- a/lisp/gnus/gnus-mh.el +++ b/lisp/gnus/gnus-mh.el @@ -40,6 +40,13 @@ (defvar mh-lib-progs) +(defcustom gnus-rcvstore-options nil + "Options that are passed to rcvstore, or nil. +These are used when saving articles to an MH folder." + :version "26.1" + :group 'gnus-article + :type '(repeat string)) + (defun gnus-summary-save-article-folder (&optional arg) "Append the current article to an mh folder. If N is a positive number, save the N next articles. @@ -77,8 +84,10 @@ Optional argument FOLDER specifies folder name." (save-restriction (widen) (unwind-protect - (call-process-region - (point-min) (point-max) "rcvstore" nil errbuf nil folder) + (apply + #'call-process-region + (point-min) (point-max) "rcvstore" nil errbuf nil folder + gnus-rcvstore-options) (set-buffer errbuf) (if (zerop (buffer-size)) (message "Article saved in folder: %s" folder) diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el index 729efd12a5d..32cf1713317 100644 --- a/lisp/gnus/gnus-ml.el +++ b/lisp/gnus/gnus-ml.el @@ -29,9 +29,6 @@ (require 'gnus) (require 'gnus-msg) (eval-when-compile (require 'cl)) -(eval-when-compile - (when (featurep 'xemacs) - (require 'easy-mmode))) ; for `define-minor-mode' ;;; Mailing list minor mode @@ -84,12 +81,6 @@ If FORCE is non-nil, replace the old ones." (gnus-mailing-list-mode 1)) (gnus-message 1 "no list-post in this message.")))) -(eval-when-compile - (when (featurep 'xemacs) - (defvar gnus-mailing-list-mode-hook) - (defvar gnus-mailing-list-mode-on-hook) - (defvar gnus-mailing-list-mode-off-hook))) - ;;;###autoload (define-minor-mode gnus-mailing-list-mode "Minor mode for providing mailing-list commands. diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index 70284a2e4a4..19111171198 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -28,13 +28,12 @@ (eval-when-compile (require 'cl)) (require 'gnus) -(require 'gnus-ems) (require 'message) (require 'gnus-art) (require 'gnus-util) (defcustom gnus-post-method 'current - "*Preferred method for posting USENET news. + "Preferred method for posting USENET news. If this variable is `current' (which is the default), Gnus will use the \"current\" select method when posting. If it is `native', Gnus @@ -72,7 +71,7 @@ of names)." (make-obsolete-variable 'gnus-outgoing-message-group 'gnus-message-archive-group "24.1") (defcustom gnus-mailing-list-groups nil - "*If non-nil a regexp matching groups that are really mailing lists. + "If non-nil a regexp matching groups that are really mailing lists. This is useful when you're reading a mailing list that has been gatewayed to a newsgroup, and you want to followup to an article in the group." @@ -81,7 +80,7 @@ the group." (const nil))) (defcustom gnus-add-to-list nil - "*If non-nil, add a `to-list' parameter automatically." + "If non-nil, add a `to-list' parameter automatically." :group 'gnus-message :type 'boolean) @@ -112,12 +111,12 @@ the second with the current group name." :type 'hook) (defcustom gnus-bug-create-help-buffer t - "*Should we create the *Gnus Help Bug* buffer?" + "Should we create the *Gnus Help Bug* buffer?" :group 'gnus-message :type 'boolean) (defcustom gnus-posting-styles nil - "*Alist of styles to use when posting. + "Alist of styles to use when posting. See Info node `(gnus)Posting Styles'." :group 'gnus-message :link '(custom-manual "(gnus)Posting Styles") @@ -496,8 +495,6 @@ Thank you for your help in stamping out bugs. (let ((mbl1 mml-buffer-list)) (setq mml-buffer-list mbl) ;; Global value (set (make-local-variable 'mml-buffer-list) mbl1);; Local value - (gnus-make-local-hook 'kill-buffer-hook) - (gnus-make-local-hook 'change-major-mode-hook) (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t) (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)) (mml-destroy-buffers) @@ -594,11 +591,9 @@ instead." (defun gnus-inews-add-send-actions (winconf buffer article &optional config yanked winconf-name) - (gnus-make-local-hook 'message-sent-hook) (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc 'gnus-inews-do-gcc) nil t) (when gnus-agent - (gnus-make-local-hook 'message-header-hook) (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t)) (setq message-post-method `(lambda (&optional arg) @@ -1139,9 +1134,9 @@ See the variable `gnus-user-agent'." (gnus-v (when (memq 'gnus gnus-user-agent) (concat "Gnus/" - (gnus-replace-in-string - (format "%1.8f" (gnus-continuum-version gnus-version)) - "0+\\'" "") + (replace-regexp-in-string + "0+\\'" "" + (format "%1.8f" (gnus-continuum-version gnus-version))) " (" gnus-version ")"))) (emacs-v (gnus-emacs-version))) (concat gnus-v (when (and gnus-v emacs-v) " ") @@ -1347,7 +1342,7 @@ For the \"inline\" alternatives, also see the variable (gnus-inews-insert-gcc) (let ((gcc (mapcar (lambda (group) - (mm-encode-coding-string + (encode-coding-string group (gnus-group-name-charset (gnus-inews-group-method group) group))) @@ -1364,7 +1359,7 @@ For the \"inline\" alternatives, also see the variable (insert "Gcc: \"" gnus-newsgroup-name "\"\n")) ((stringp self) (insert "Gcc: " - (mm-encode-coding-string + (encode-coding-string (if (string-match " " self) (concat "\"" self "\"") self) @@ -1403,7 +1398,7 @@ For the \"inline\" alternatives, also see the variable tem) (dolist (style styles) (when (stringp (cadr style)) - (setcdr style (list (mm-decode-coding-string (cadr style) 'utf-8))))) + (setcdr style (list (decode-coding-string (cadr style) 'utf-8))))) (dolist (style (if styles (append gnus-posting-styles (list (cons ".*" styles))) gnus-posting-styles)) @@ -1496,7 +1491,7 @@ See `gnus-summary-mail-forward' for ARG." (message-goto-subject) (re-search-forward " *$") (replace-match " (crosspost notification)" t t) - (gnus-deactivate-mark) + (deactivate-mark) (when (gnus-y-or-n-p "Send this complaint? ") (message-send-and-exit)))))) @@ -1642,7 +1637,7 @@ this is a reply." ;; Copy the article over to some group(s). (while (setq group (pop groups)) (setq method (gnus-inews-group-method group) - group (mm-encode-coding-string + group (encode-coding-string group (gnus-group-name-charset method group))) (unless (gnus-check-server method) @@ -1663,8 +1658,7 @@ this is a reply." (run-hooks 'gnus-gcc-post-body-encode-hook) (save-restriction (message-narrow-to-headers) - (let* ((mail-parse-charset message-default-charset) - (newsgroups-field (save-restriction + (let* ((newsgroups-field (save-restriction (message-narrow-to-headers-or-head) (message-fetch-field "Newsgroups"))) (followup-field (save-restriction @@ -1845,8 +1839,8 @@ this is a reply." (when tmp-style (dolist (style tmp-style) (when (stringp (cadr style)) - (setcdr style (list (mm-decode-coding-string (cadr style) - 'utf-8))))) + (setcdr style (list (decode-coding-string (cadr style) + 'utf-8))))) (setq styles (append styles (list (cons ".*" tmp-style))))))) ;; Go through all styles and look for matches. (dolist (style styles) @@ -1909,10 +1903,10 @@ this is a reply." (cond ((stringp value) (if (and matched-string - (gnus-string-match-p "\\\\[&[:digit:]]" value) + (string-match-p "\\\\[&[:digit:]]" value) (match-beginning 1)) - (gnus-match-substitute-replacement value nil nil - matched-string) + (match-substitute-replacement value nil nil + matched-string) value)) ((or (symbolp value) (functionp value)) @@ -1954,7 +1948,6 @@ this is a reply." (setq name (assq 'name results) address (assq 'address results)) (setq results (delq name (delq address results))) - (gnus-make-local-hook 'message-setup-hook) (setq results (sort results (lambda (x y) (string-lessp (car x) (car y))))) (dolist (result results) @@ -2006,10 +1999,6 @@ this is a reply." (insert "From: " (message-make-from) "\n")))) nil 'local))))) -;;; Allow redefinition of functions. - -(gnus-ems-redefine) - (provide 'gnus-msg) ;;; gnus-msg.el ends here diff --git a/lisp/gnus/gnus-notifications.el b/lisp/gnus/gnus-notifications.el index c943da5c1d3..288dbe1b9f2 100644 --- a/lisp/gnus/gnus-notifications.el +++ b/lisp/gnus/gnus-notifications.el @@ -81,7 +81,7 @@ not get notifications." (article (nth 2 group-article))) (cond ((string= key "read") (gnus-fetch-group group (list article)) - (gnus-select-frame-set-input-focus (selected-frame))) + (select-frame-set-input-focus (selected-frame))) ((string= key "mark-read") (gnus-update-read-articles group @@ -180,8 +180,11 @@ This is typically a function to add in ;; Ignore mails from ourselves (unless (and gnus-ignored-from-addresses address - (gnus-string-match-p gnus-ignored-from-addresses - address)) + (cond ((functionp gnus-ignored-from-addresses) + (funcall gnus-ignored-from-addresses address)) + (t (string-match-p + (gnus-ignored-from-addresses) + address)))) (let* ((photo-file (gnus-notifications-get-photo-file address)) (notification-id (gnus-notifications-notify (or (car address-components) address) diff --git a/lisp/gnus/gnus-picon.el b/lisp/gnus/gnus-picon.el index 4d1d32242b1..41463e3f02f 100644 --- a/lisp/gnus/gnus-picon.el +++ b/lisp/gnus/gnus-picon.el @@ -45,17 +45,17 @@ ;;; User variables: (defcustom gnus-picon-news-directories '("news") - "*List of directories to search for newsgroups faces." + "List of directories to search for newsgroups faces." :type '(repeat string) :group 'gnus-picon) (defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc") - "*List of directories to search for user faces." + "List of directories to search for user faces." :type '(repeat string) :group 'gnus-picon) (defcustom gnus-picon-domain-directories '("domains") - "*List of directories to search for domain faces. + "List of directories to search for domain faces. Some people may want to add \"unknown\" to this list." :type '(repeat string) :group 'gnus-picon) @@ -67,7 +67,7 @@ Some people may want to add \"unknown\" to this list." (when (gnus-image-type-available-p 'xpm) (push "xpm" types)) types) - "*List of suffixes on picon file names to try." + "List of suffixes on picon file names to try." :type '(repeat string) :group 'gnus-picon) @@ -81,7 +81,6 @@ Some people may want to add \"unknown\" to this list." "How should picons be displayed. If `inline', the textual representation is replaced. If `right', picons are added right to the textual representation." - ;; FIXME: `right' needs improvement for XEmacs. :type '(choice (const inline) (const right)) :group 'gnus-picon) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index b86e6e7b2fe..f728b191110 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -87,12 +87,6 @@ (require 'easymenu) (require 'registry) -;; Silence XEmacs byte compiler, which will otherwise complain about -;; call to `eieio-persistent-read'. -(when (featurep 'xemacs) - (byte-compiler-options - (warnings (- callargs)))) - (defvar gnus-adaptive-word-syntax-table) (defvar gnus-registry-dirty t @@ -832,8 +826,7 @@ Addresses without a name will say \"noname\"." (defun gnus-registry-sort-addresses (&rest addresses) "Return a normalized and sorted list of ADDRESSES." - (sort (apply 'nconc (mapcar 'gnus-registry-extract-addresses addresses)) - 'string-lessp)) + (sort (mapcan 'gnus-registry-extract-addresses addresses) 'string-lessp)) (defun gnus-registry-simplify-subject (subject) (if (stringp subject) @@ -1036,7 +1029,7 @@ only the last one's marks are returned." (let* ((article (last articles)) (id (gnus-registry-fetch-message-id-fast article)) (marks (when id (gnus-registry-get-id-key id 'mark)))) - (when (gmm-called-interactively-p 'any) + (when (called-interactively-p 'any) (gnus-message 1 "Marks are %S" marks)) marks)) diff --git a/lisp/gnus/gnus-rfc1843.el b/lisp/gnus/gnus-rfc1843.el new file mode 100644 index 00000000000..4e6fdc6d877 --- /dev/null +++ b/lisp/gnus/gnus-rfc1843.el @@ -0,0 +1,77 @@ +;;; gnus-rfc1843.el --- HZ (rfc1843) decoding interface functions for Gnus + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> +;; Keywords: news HZ HZ+ mail i18n + +;; 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: + +;; Usage: +;; (require 'gnus-rfc1843) +;; (rfc1843-gnus-setup) + +;;; Code: + +(require 'rfc1843) +(require 'gnus-sum) +(require 'gnus-art) +(require 'message) + +(defun rfc1843-decode-article-body () + "Decode HZ encoded text in the article body." + (if (string-match (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>") + (or gnus-newsgroup-name "")) + (save-excursion + (save-restriction + (message-narrow-to-head) + (let* ((inhibit-point-motion-hooks t) + (case-fold-search t) + (ct (message-fetch-field "Content-Type" t)) + (ctl (and ct (mail-header-parse-content-type ct)))) + (if (and ctl (not (string-match "/" (car ctl)))) + (setq ctl nil)) + (goto-char (point-max)) + (widen) + (forward-line 1) + (narrow-to-region (point) (point-max)) + (when (or (not ctl) + (equal (car ctl) "text/plain")) + (rfc1843-decode-region (point) (point-max)))))))) + +(defun rfc1843-gnus-setup () + "Setup HZ decoding for Gnus." + (add-hook 'gnus-article-decode-hook 'rfc1843-decode-article-body t) + (setq gnus-decode-encoded-word-function + 'gnus-multi-decode-encoded-word-string + gnus-decode-header-function + 'gnus-multi-decode-header + gnus-decode-encoded-word-methods + (nconc gnus-decode-encoded-word-methods + (list + (cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>") + 'rfc1843-decode-string))) + gnus-decode-header-methods + (nconc gnus-decode-header-methods + (list + (cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>") + 'rfc1843-decode-region))))) + +(provide 'gnus-rfc1843) + +;;; gnus-rfc1843.el ends here diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index e10d1f66ab9..5361c2b86fc 100644 --- a/lisp/gnus/gnus-salt.el +++ b/lisp/gnus/gnus-salt.el @@ -25,9 +25,6 @@ ;;; Code: (eval-when-compile (require 'cl)) -(eval-when-compile - (when (featurep 'xemacs) - (require 'easy-mmode))) ; for `define-minor-mode' (require 'gnus) (require 'gnus-sum) @@ -38,7 +35,7 @@ ;;; (defcustom gnus-pick-display-summary nil - "*Display summary while reading." + "Display summary while reading." :type 'boolean :group 'gnus-summary-pick) @@ -47,11 +44,8 @@ :type 'hook :group 'gnus-summary-pick) -(when (featurep 'xemacs) - (add-hook 'gnus-pick-mode-hook 'gnus-xmas-pick-menu-add)) - (defcustom gnus-mark-unpicked-articles-as-read nil - "*If non-nil, mark all unpicked articles as read." + "If non-nil, mark all unpicked articles as read." :type 'boolean :group 'gnus-summary-pick) @@ -63,7 +57,7 @@ (defcustom gnus-summary-pick-line-format "%-5P %U\ %R\ %z\ %I\ %(%[%4L: %-23,23n%]%) %s\n" - "*The format specification of the lines in pick buffers. + "The format specification of the lines in pick buffers. It accepts the same format specs that `gnus-summary-line-format' does." :type 'string :group 'gnus-summary-pick) @@ -76,7 +70,7 @@ It accepts the same format specs that `gnus-summary-line-format' does." " " gnus-pick-next-page "u" gnus-pick-unmark-article-or-thread "." gnus-pick-article-or-thread - gnus-down-mouse-2 gnus-pick-mouse-pick-region + [down-mouse-2] gnus-pick-mouse-pick-region "\r" gnus-pick-start-reading) map)) @@ -100,11 +94,6 @@ It accepts the same format specs that `gnus-summary-line-format' does." ["Start reading" gnus-pick-start-reading t] ["Switch pick mode off" gnus-pick-mode gnus-pick-mode])))) -(eval-when-compile - (when (featurep 'xemacs) - (defvar gnus-pick-mode-on-hook) - (defvar gnus-pick-mode-off-hook))) - (define-minor-mode gnus-pick-mode "Minor mode for providing a pick-and-read interface in Gnus summary buffers. @@ -229,7 +218,7 @@ This must be bound to a button-down mouse event." (start-point (posn-point start-posn)) (start-line (1+ (count-lines (point-min) start-point))) (start-window (posn-window start-posn)) - (bounds (gnus-window-edges start-window)) + (bounds (window-edges start-window)) (top (nth 1 bounds)) (bottom (if (window-minibuffer-p start-window) (nth 3 bounds) @@ -339,11 +328,6 @@ This must be bound to a button-down mouse event." '("Pick" ["Switch binary mode off" gnus-binary-mode t])))) -(eval-when-compile - (when (featurep 'xemacs) - (defvar gnus-binary-mode-on-hook) - (defvar gnus-binary-mode-off-hook))) - (define-minor-mode gnus-binary-mode "Minor mode for providing a binary group interface in Gnus summary buffers." :lighter " Binary" :keymap gnus-binary-mode-map @@ -389,7 +373,7 @@ lines." :group 'gnus-summary-tree) (defcustom gnus-selected-tree-face 'mode-line - "*Face used for highlighting selected articles in the thread tree." + "Face used for highlighting selected articles in the thread tree." :type 'face :group 'gnus-summary-tree) @@ -401,12 +385,12 @@ lines." "Characters used to connect parents with children.") (defcustom gnus-tree-mode-line-format "Gnus: %%b %S %Z" - "*The format specification for the tree mode line." + "The format specification for the tree mode line." :type 'string :group 'gnus-summary-tree) (defcustom gnus-generate-tree-function 'gnus-generate-vertical-tree - "*Function for generating a thread tree. + "Function for generating a thread tree. Two predefined functions are available: `gnus-generate-horizontal-tree' and `gnus-generate-vertical-tree'." :type '(radio (function-item gnus-generate-vertical-tree) @@ -415,15 +399,10 @@ Two predefined functions are available: :group 'gnus-summary-tree) (defcustom gnus-tree-mode-hook nil - "*Hook run in tree mode buffers." + "Hook run in tree mode buffers." :type 'hook :group 'gnus-summary-tree) -(when (featurep 'xemacs) - (add-hook 'gnus-tree-mode-hook 'gnus-xmas-tree-menu-add) - (add-hook 'gnus-tree-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off)) - - ;;; Internal variables. (defvar gnus-tmp-name) @@ -458,7 +437,7 @@ Two predefined functions are available: (gnus-define-keys map "\r" gnus-tree-select-article - gnus-mouse-2 gnus-tree-pick-article + [mouse-2] gnus-tree-pick-article "\C-?" gnus-tree-read-summary-keys "h" gnus-tree-show-summary @@ -639,7 +618,7 @@ Two predefined functions are available: (t (cdar gnus-tree-brackets)))) (buffer-read-only nil) beg end) - (gnus-add-text-properties + (add-text-properties (setq beg (point)) (setq end (progn (eval gnus-tree-line-format-spec) (point))) (list 'gnus-number gnus-tmp-number)) @@ -855,8 +834,7 @@ it in the environment specified by BINDINGS." region) (set-buffer gnus-tree-buffer) (when (setq region (gnus-tree-article-region article)) - (when (or (not gnus-selected-tree-overlay) - (gnus-extent-detached-p gnus-selected-tree-overlay)) + (when (not gnus-selected-tree-overlay) ;; Create a new overlay. (overlay-put (setq gnus-selected-tree-overlay @@ -885,13 +863,10 @@ it in the environment specified by BINDINGS." (with-current-buffer (gnus-get-tree-buffer) (let (region) (when (setq region (gnus-tree-article-region article)) - (gnus-put-text-property (car region) (cdr region) 'face face) + (put-text-property (car region) (cdr region) 'face face) (set-window-point (gnus-get-buffer-window (current-buffer) t) (cdr region))))))) -;;; Allow redefinition of functions. -(gnus-ems-redefine) - (provide 'gnus-salt) ;;; gnus-salt.el ends here diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index c7e883021a5..2defa76f50d 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -29,6 +29,7 @@ (require 'gnus) (require 'gnus-sum) +(require 'gnus-art) (require 'gnus-range) (require 'gnus-win) (require 'message) @@ -126,26 +127,26 @@ the `a' symbolic prefix to the score commands will always use (function :tag "Other" :value 'ignore))) (defcustom gnus-score-interactive-default-score 1000 - "*Scoring commands will raise/lower the score with this number as the default." + "Scoring commands will raise/lower the score with this number as the default." :group 'gnus-score-default :type 'integer) (defcustom gnus-score-expiry-days 7 - "*Number of days before unused score file entries are expired. + "Number of days before unused score file entries are expired. If this variable is nil, no score file entries will be expired." :group 'gnus-score-expire :type '(choice (const :tag "never" nil) number)) (defcustom gnus-update-score-entry-dates t - "*If non-nil, update matching score entry dates. + "If non-nil, update matching score entry dates. If this variable is nil, then score entries that provide matches will be expired along with non-matching score entries." :group 'gnus-score-expire :type 'boolean) (defcustom gnus-decay-scores nil - "*If non-nil, decay non-permanent scores. + "If non-nil, decay non-permanent scores. If it is a regexp, only decay score files matching regexp." :group 'gnus-score-decay @@ -156,19 +157,19 @@ If it is a regexp, only decay score files matching regexp." (regexp))) (defcustom gnus-decay-score-function 'gnus-decay-score - "*Function called to decay a score. + "Function called to decay a score. It is called with one parameter -- the score to be decayed." :group 'gnus-score-decay :type '(radio (function-item gnus-decay-score) (function :tag "Other"))) (defcustom gnus-score-decay-constant 3 - "*Decay all \"small\" scores with this amount." + "Decay all \"small\" scores with this amount." :group 'gnus-score-decay :type 'integer) (defcustom gnus-score-decay-scale .05 - "*Decay all \"big\" scores with this factor." + "Decay all \"big\" scores with this factor." :group 'gnus-score-decay :type 'number) @@ -248,7 +249,7 @@ If you use score decays, you might want to set values higher than (integer :tag "Score")))))) (defcustom gnus-adaptive-word-length-limit nil - "*Words of a length lesser than this limit will be ignored when doing adaptive scoring." + "Words of a length lesser than this limit will be ignored when doing adaptive scoring." :version "22.1" :group 'gnus-score-adapt :type '(radio (const :format "Unlimited " nil) @@ -274,7 +275,7 @@ If you use score decays, you might want to set values higher than "being" "current" "back" "still" "go" "point" "value" "each" "did" "both" "true" "off" "say" "another" "state" "might" "under" "start" "try" "re") - "*Default list of words to be ignored when doing adaptive word scoring." + "Default list of words to be ignored when doing adaptive word scoring." :group 'gnus-score-adapt :type '(repeat string)) @@ -283,7 +284,7 @@ If you use score decays, you might want to set values higher than (,gnus-catchup-mark . -10) (,gnus-killed-mark . -20) (,gnus-del-mark . -15)) - "*Alist of marks and scores." + "Alist of marks and scores." :group 'gnus-score-adapt :type '(repeat (cons (character :tag "Mark") (integer :tag "Score")))) @@ -299,12 +300,12 @@ If you use score decays, you might want to set values higher than :type 'boolean) (defcustom gnus-score-mimic-keymap nil - "*Have the score entry functions pretend that they are a keymap." + "Have the score entry functions pretend that they are a keymap." :group 'gnus-score-default :type 'boolean) (defcustom gnus-score-exact-adapt-limit 10 - "*Number that says how long a match has to be before using substring matching. + "Number that says how long a match has to be before using substring matching. When doing adaptive scoring, one normally uses fuzzy or substring matching. However, if the header one matches is short, the possibility for false positives is great, so if the length of the match is less @@ -739,6 +740,8 @@ current score file." (with-current-buffer gnus-summary-buffer (gnus-score-load-file current-score-file))))) +(autoload 'appt-select-lowest-window "appt") + (defun gnus-score-insert-help (string alist idx) (setq gnus-score-help-winconf (current-window-configuration)) (with-current-buffer (gnus-get-buffer-create "*Score Help*") @@ -773,7 +776,7 @@ current score file." (setq i (1+ i)))) (goto-char (point-min)) ;; display ourselves in a small window at the bottom - (gnus-select-lowest-window) + (appt-select-lowest-window) (if (< (/ (window-height) 2) window-min-height) (switch-to-buffer "*Score Help*") (split-window) @@ -1428,7 +1431,7 @@ If FORMAT, also format the current score file." (and (file-exists-p file) (not (file-writable-p file)))) () - (setq score (setcdr entry (gnus-delete-alist 'touched score))) + (setq score (setcdr entry (assq-delete-all 'touched score))) (erase-buffer) (let (emacs-lisp-mode-hook) (if (and (not gnus-adaptive-pretty-print) @@ -1724,7 +1727,7 @@ score in `gnus-newsgroup-scored' by SCORE." nil) (defun gnus-score-decode-text-parts () - (gmm-labels + (cl-labels ((mm-text-parts (handle) (cond ((stringp (car handle)) @@ -1748,7 +1751,7 @@ score in `gnus-newsgroup-scored' by SCORE." (mm-display-inline handle) (goto-char (point-max)))))) - (let (;(mm-text-html-renderer 'w3m-standalone) + (let ( ;(mm-text-html-renderer 'w3m-standalone) (handles (mm-dissect-buffer t))) (save-excursion (article-goto-body) @@ -3048,19 +3051,12 @@ If ADAPT, return the home adaptive file instead." (defun gnus-decay-score (score) "Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'." - (let ((n (- score - (* (if (< score 0) -1 1) - (min (abs score) - (max gnus-score-decay-constant - (* (abs score) - gnus-score-decay-scale))))))) - (if (and (featurep 'xemacs) - ;; XEmacs's floor can handle only the floating point - ;; number below the half of the maximum integer. - (> (abs n) (lsh -1 -2))) - (string-to-number - (car (split-string (number-to-string n) "\\."))) - (floor n)))) + (floor (- score + (* (if (< score 0) -1 1) + (min (abs score) + (max gnus-score-decay-constant + (* (abs score) + gnus-score-decay-scale))))))) (defun gnus-decay-scores (alist day) "Decay non-permanent scores in ALIST." diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el index cf26cf323ee..809371d6109 100644 --- a/lisp/gnus/gnus-spec.el +++ b/lisp/gnus/gnus-spec.el @@ -29,19 +29,6 @@ (require 'gnus) -(defcustom gnus-use-correct-string-widths (featurep 'xemacs) - "*If non-nil, use correct functions for dealing with wide characters." - :version "22.1" - :group 'gnus-format - :type 'boolean) - -(defcustom gnus-make-format-preserve-properties (featurep 'xemacs) - "*If non-nil, use a replacement `format' function which preserves -text properties. This is only needed on XEmacs, as Emacs does this anyway." - :version "22.1" - :group 'gnus-format - :type 'boolean) - ;;; Internal variables. (defvar gnus-summary-mark-positions nil) @@ -79,7 +66,6 @@ text properties. This is only needed on XEmacs, as Emacs does this anyway." (defvar gnus-tmp-news-method) (defvar gnus-tmp-news-server) (defvar gnus-mouse-face) -(defvar gnus-mouse-face-prop) (defvar gnus-tmp-header) (defvar gnus-tmp-from) @@ -87,11 +73,9 @@ text properties. This is only needed on XEmacs, as Emacs does this anyway." (header gnus-tmp-from)) (defmacro gnus-lrm-string-p (string) - (if (fboundp 'bidi-string-mark-left-to-right) - ;; LRM, RLM, PDF characters as integers to avoid breaking Emacs - ;; 23. - `(memq (aref ,string (1- (length ,string))) '(8206 8207 8236)) - nil)) + ;; LRM, RLM, PDF characters as integers to avoid breaking Emacs + ;; 23. + `(memq (aref ,string (1- (length ,string))) '(8206 8207 8236))) (defvar gnus-lrm-string (if (ignore-errors (string 8206)) (propertize (string 8206) 'invisible t) @@ -226,9 +210,9 @@ Return a list of updated types." :type 'face) (defun gnus-mouse-face-function (form type) - `(gnus-put-text-property + `(put-text-property (point) (progn ,@form (point)) - gnus-mouse-face-prop + 'mouse-face ,(if (equal type 0) 'gnus-mouse-face `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type))))))) @@ -259,23 +243,20 @@ Return a list of updated types." :type 'face) (defun gnus-face-face-function (form type) - `(gnus-add-text-properties + `(add-text-properties (point) (progn ,@form (point)) (cons 'face (cons ;; Delay consing the value of the `face' property until - ;; `gnus-add-text-properties' runs, since it will be modified - ;; by `gnus-put-text-property-excluding-characters-with-faces'. + ;; `add-text-properties' runs, since it will be modified + ;; by `put-text-property-excluding-characters-with-faces'. (list ',(symbol-value (intern (format "gnus-face-%d" type))) 'default) ;; Redundant now, but still convenient. '(gnus-face t))))) (defun gnus-balloon-face-function (form type) - `(gnus-put-text-property - (point) (progn ,@form (point)) - ,(if (fboundp 'balloon-help-mode) - ''balloon-help - ''help-echo) + `(put-text-property + (point) (progn ,@form (point)) 'help-echo ,(intern (format "gnus-balloon-face-%d" type)))) (defun gnus-spec-tab (column) @@ -316,62 +297,42 @@ Return a list of updated types." (setq wend seek) (substring string wstart (1- wend)))) -(defun gnus-string-width-function () - (cond - (gnus-use-correct-string-widths - 'gnus-correct-length) - ((fboundp 'string-width) - 'string-width) - (t - 'length))) - -(defun gnus-substring-function () - (cond - (gnus-use-correct-string-widths - 'gnus-correct-substring) - ((fboundp 'string-width) - 'gnus-correct-substring) - (t - 'substring))) - (defun gnus-tilde-max-form (el max-width) "Return a form that limits EL to MAX-WIDTH." - (let ((max (abs max-width)) - (length-fun (gnus-string-width-function)) - (substring-fun (gnus-substring-function))) + (let ((max (abs max-width))) (if (symbolp el) - `(if (> (,length-fun ,el) ,max) + `(if (> (string-width ,el) ,max) ,(if (< max-width 0) - `(,substring-fun ,el (- (,length-fun ,el) ,max)) + `(gnus-correct-substring ,el (- (string-width ,el) ,max)) `(if (gnus-lrm-string-p ,el) - (concat (,substring-fun ,el 0 ,max) ,gnus-lrm-string) - (,substring-fun ,el 0 ,max))) + (concat (gnus-correct-substring ,el 0 ,max) + ,gnus-lrm-string) + (gnus-correct-substring ,el 0 ,max))) ,el) `(let ((val (eval ,el))) - (if (> (,length-fun val) ,max) + (if (> (string-width val) ,max) ,(if (< max-width 0) - `(,substring-fun val (- (,length-fun val) ,max)) + `(gnus-correct-substring val (- (string-width val) ,max)) `(if (gnus-lrm-string-p val) - (concat (,substring-fun val 0 ,max) ,gnus-lrm-string) - (,substring-fun val 0 ,max))) + (concat (gnus-correct-substring val 0 ,max) + ,gnus-lrm-string) + (gnus-correct-substring val 0 ,max))) val))))) (defun gnus-tilde-cut-form (el cut-width) "Return a form that cuts CUT-WIDTH off of EL." - (let ((cut (abs cut-width)) - (length-fun (gnus-string-width-function)) - (substring-fun (gnus-substring-function))) + (let ((cut (abs cut-width))) (if (symbolp el) - `(if (> (,length-fun ,el) ,cut) + `(if (> (string-width ,el) ,cut) ,(if (< cut-width 0) - `(,substring-fun ,el 0 (- (,length-fun ,el) ,cut)) - `(,substring-fun ,el ,cut)) + `(gnus-correct-substring ,el 0 (- (string-width ,el) ,cut)) + `(gnus-correct-substring ,el ,cut)) ,el) `(let ((val (eval ,el))) - (if (> (,length-fun val) ,cut) + (if (> (string-width val) ,cut) ,(if (< cut-width 0) - `(,substring-fun val 0 (- (,length-fun val) ,cut)) - `(,substring-fun val ,cut)) + `(gnus-correct-substring val 0 (- (string-width val) ,cut)) + `(gnus-correct-substring val ,cut)) val))))) (defun gnus-tilde-ignore-form (el ignore-value) @@ -388,17 +349,16 @@ Return a list of updated types." characters correctly. This is because `format' may pad to columns or to characters when given a pad value." (let ((pad (abs pad-width)) - (side (< 0 pad-width)) - (length-fun (gnus-string-width-function))) + (side (< 0 pad-width))) (if (symbolp el) - `(let ((need (- ,pad (,length-fun ,el)))) + `(let ((need (- ,pad (string-width ,el)))) (if (> need 0) (concat ,(when side '(make-string need ?\ )) ,el ,(when (not side) '(make-string need ?\ ))) ,el)) `(let* ((val (eval ,el)) - (need (- ,pad (,length-fun val)))) + (need (- ,pad (string-width val)))) (if (> need 0) (concat ,(when side '(make-string need ?\ )) val @@ -464,7 +424,7 @@ characters when given a pad value." `(let (gnus-position) ,@(gnus-complex-form-to-spec form spec-alist) (if gnus-position - (gnus-put-text-property gnus-position (1+ gnus-position) + (put-text-property gnus-position (1+ gnus-position) 'gnus-position t))) `(progn ,@(gnus-complex-form-to-spec form spec-alist))))))) @@ -486,42 +446,6 @@ characters when given a pad value." (nth 1 sform))))) form))) - -(defun gnus-xmas-format (fstring &rest args) - "A version of `format' which preserves text properties. - -Required for XEmacs, where the built in `format' function strips all text -properties from both the format string and any inserted strings. - -Only supports the format sequence %s, and %% for inserting -literal % characters. A pad width and an optional - (to right pad) -are supported for %s." - (let ((re "%%\\|%\\(-\\)?\\([1-9][0-9]*\\)?s") - (n (length args))) - (with-temp-buffer - (insert fstring) - (goto-char (point-min)) - (while (re-search-forward re nil t) - (goto-char (match-end 0)) - (cond - ((string= (match-string 0) "%%") - (delete-char -1)) - (t - (if (null args) - (signal 'wrong-number-of-arguments - (list #'gnus-xmas-format n fstring))) - (let* ((minlen (string-to-number (or (match-string 2) ""))) - (arg (car args)) - (str (if (stringp arg) arg (format "%s" arg))) - (lpad (null (match-string 1))) - (padlen (max 0 (- minlen (length str))))) - (replace-match "") - (if lpad (insert-char ?\ padlen)) - (insert str) - (unless lpad (insert-char ?\ padlen)) - (setq args (cdr args)))))) - (buffer-string)))) - (defun gnus-parse-simple-format (format spec-alist &optional insert) ;; This function parses the FORMAT string with the help of the ;; SPEC-ALIST and returns a list that can be eval'ed to return a @@ -628,14 +552,10 @@ are supported for %s." (setq elem '("*" ?s)))) (setq elem-type (cadr elem)) ;; Insert the new format elements. - (when (and pad-width - (not (and (featurep 'xemacs) - gnus-use-correct-string-widths))) + (when pad-width (insert (number-to-string pad-width))) ;; Create the form to be evalled. - (if (or max-width cut-width ignore-value - (and (featurep 'xemacs) - gnus-use-correct-string-widths)) + (if (or max-width cut-width ignore-value) (progn (insert ?s) (let ((el (car elem))) @@ -690,13 +610,6 @@ are supported for %s." ;; A single string spec in the end of the spec. ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring) (list (match-string 1 fstring) (car flist))) - ;; Only string (and %) specs (XEmacs only!) - ((and (featurep 'xemacs) - gnus-make-format-preserve-properties - (string-match - "\\`\\([^%]*\\(%%\\|%-?\\([1-9][0-9]*\\)?s\\)\\)*[^%]*\\'" - fstring)) - (list (cons 'gnus-xmas-format (cons fstring (nreverse flist))))) ;; A more complex spec. (t (list (cons 'format (cons fstring (nreverse flist))))))) @@ -717,7 +630,7 @@ are supported for %s." If PROPS, insert the result." (let ((form (gnus-parse-format format alist props))) (if props - (gnus-add-text-properties (point) (progn (eval form) (point)) props) + (add-text-properties (point) (progn (eval form) (point)) props) (eval form)))) (defun gnus-set-format (type &optional insertable) @@ -727,6 +640,25 @@ If PROPS, insert the result." (symbol-value (intern (format "gnus-%s-line-format-alist" type))) insertable))) + + (defun gnus-summary-line-format-spec () + (insert gnus-tmp-unread gnus-tmp-replied + gnus-tmp-score-char gnus-tmp-indentation) + (put-text-property + (point) + (progn + (insert + gnus-tmp-opening-bracket + (format "%4d: %-20s" + gnus-tmp-lines + (if (> (length gnus-tmp-name) 20) + (truncate-string-to-width gnus-tmp-name 20) + gnus-tmp-name)) + gnus-tmp-closing-bracket) + (point)) + 'mouse-face gnus-mouse-face) + (insert " " gnus-tmp-subject-or-nil "\n")) + (provide 'gnus-spec) ;; Local Variables: diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 6008cc8f627..bed5993b9c1 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -32,6 +32,7 @@ (require 'gnus-group) (require 'gnus-int) (require 'gnus-range) +(require 'gnus-cloud) (autoload 'gnus-group-make-nnir-group "nnir") @@ -109,8 +110,10 @@ If nil, a faster, but more primitive, buffer is used instead." (defvar gnus-server-mode-map) -(defvar gnus-server-menu-hook nil - "*Hook run after the creation of the server mode menu.") +(defcustom gnus-server-menu-hook nil + "Hook run after the creation of the server mode menu." + :type 'hook + :group 'gnus-server) (defun gnus-server-make-menu-bar () (gnus-turn-off-edit-menu 'server) @@ -138,7 +141,8 @@ 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] + ["Toggle Cloud Sync for this server" gnus-server-toggle-cloud-server t] + ["Toggle Cloud Sync Host" gnus-server-toggle-cloud-method-server t] "---" ["Open All" gnus-server-open-all-servers t] ["Close All" gnus-server-close-all-servers t] @@ -156,7 +160,7 @@ If nil, a faster, but more primitive, buffer is used instead." (gnus-define-keys gnus-server-mode-map " " gnus-server-read-server-in-server-buffer "\r" gnus-server-read-server - gnus-mouse-2 gnus-server-pick-server + [mouse-2] gnus-server-pick-server "q" gnus-server-exit "l" gnus-server-list-servers "k" gnus-server-kill-server @@ -185,6 +189,7 @@ If nil, a faster, but more primitive, buffer is used instead." "z" gnus-server-compact-server "i" gnus-server-toggle-cloud-server + "I" gnus-server-toggle-cloud-method-server "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) @@ -203,7 +208,14 @@ If nil, a faster, but more primitive, buffer is used instead." '((((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" + "Face used for displaying Cloud-synced servers" + :group 'gnus-server-visual) + +(defface gnus-server-cloud-host + '((((class color) (background light)) (:foreground "ForestGreen" :inverse-video t :italic t)) + (((class color) (background dark)) (:foreground "PaleGreen" :inverse-video t :italic t)) + (t (:inverse-video t :italic t))) + "Face used for displaying the Cloud Host" :group 'gnus-server-visual) (defface gnus-server-opened @@ -249,7 +261,8 @@ 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) + ("(\\(cloud[-]sync\\))" 1 'gnus-server-cloud) + ("(\\(CLOUD[-]HOST\\))" 1 'gnus-server-cloud-host) ("(\\(opened\\))" 1 'gnus-server-opened) ("(\\(closed\\))" 1 'gnus-server-closed) ("(\\(offline\\))" 1 'gnus-server-offline) @@ -280,10 +293,8 @@ The following commands are available: (buffer-disable-undo) (setq truncate-lines t) (setq buffer-read-only t) - (if (featurep 'xemacs) - (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t)) - (set (make-local-variable 'font-lock-defaults) - '(gnus-server-font-lock-keywords t))) + (set (make-local-variable 'font-lock-defaults) + '(gnus-server-font-lock-keywords t)) (gnus-run-mode-hooks 'gnus-server-mode-hook)) (defun gnus-server-insert-server-line (name method) @@ -306,11 +317,15 @@ The following commands are available: (gnus-agent-method-p method)) " (agent)" "")) - (gnus-tmp-cloud (if (gnus-cloud-server-p gnus-tmp-name) - " (cloud)" - ""))) + (gnus-tmp-cloud (concat + (if (gnus-cloud-host-server-p gnus-tmp-name) + " (CLOUD-HOST)" + "") + (if (gnus-cloud-server-p gnus-tmp-name) + " (cloud-sync)" + "")))) (beginning-of-line) - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) ;; Insert the text. @@ -686,8 +701,10 @@ The following commands are available: ;;; Browse Server Mode ;;; -(defvar gnus-browse-menu-hook nil - "*Hook run after the creation of the browse mode menu.") +(defcustom gnus-browse-menu-hook nil + "Hook run after the creation of the browse mode menu." + :group 'gnus-server + :type 'hook) (defcustom gnus-browse-subscribe-newsgroup-method 'gnus-subscribe-alphabetically @@ -804,7 +821,7 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (mm-string-as-unibyte + (string-as-unibyte (buffer-substring (point) (progn @@ -817,7 +834,7 @@ claim them." (while (not (eobp)) (ignore-errors (push (cons - (mm-string-as-unibyte + (string-as-unibyte (if (eq (char-after) ?\") (read cur) (let ((p (point)) (name "")) @@ -865,7 +882,7 @@ claim them." (prefix (let ((gnus-select-method orig-select-method)) (gnus-group-prefixed-name "" method)))) (while (setq group (pop groups)) - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) (insert @@ -882,10 +899,9 @@ claim them." (t ?K))) (max 0 (- (1+ (cddr group)) (cadr group))) ;; Don't decode if name is ASCII - (if (and (fboundp 'detect-coding-string) - (eq (detect-coding-string name t) 'undecided)) + (if (eq (detect-coding-string name t) 'undecided) name - (mm-decode-coding-string + (decode-coding-string name (inline (gnus-group-name-charset method name))))))) (list 'gnus-group name) @@ -1131,6 +1147,25 @@ Requesting compaction of %s... (this may take a long time)" "Replication of %s in the cloud will stop") server))) +(defun gnus-server-toggle-cloud-method-server () + "Set the server under point to host the Emacs Cloud." + (interactive) + (let ((server (gnus-server-server-name))) + (unless server + (error "No server on the current line")) + (unless (gnus-cloud-host-acceptable-method-p server) + (error "The server under point can't host the Emacs Cloud")) + + (when (not (string-equal gnus-cloud-method server)) + (custom-set-variables '(gnus-cloud-method server)) + ;; Note we can't use `Custom-save' here. + (when (gnus-yes-or-no-p + (format "The new cloud host server is %S now. Save it? " server)) + (customize-save-variable 'gnus-cloud-method server))) + (when (gnus-yes-or-no-p (format "Upload Cloud data to %S now? " server)) + (gnus-message 1 "Uploading all data to Emacs Cloud server %S" server) + (gnus-cloud-upload-data t)))) + (provide 'gnus-srvr) ;;; gnus-srvr.el ends here diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 92967bec4fe..47e33af96e8 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -87,21 +87,21 @@ If a file with the `.el' or `.elc' suffixes exists, it will be read instead." :type '(choice file (const nil))) (defcustom gnus-use-dribble-file t - "*Non-nil means that Gnus will use a dribble file to store user updates. + "Non-nil means that Gnus will use a dribble file to store user updates. If Emacs should crash without saving the .newsrc files, complete information can be restored from the dribble file." :group 'gnus-dribble-file :type 'boolean) (defcustom gnus-dribble-directory nil - "*The directory where dribble files will be saved. + "The directory where dribble files will be saved. If this variable is nil, the directory where the .newsrc files are saved will be used." :group 'gnus-dribble-file :type '(choice directory (const nil))) (defcustom gnus-check-new-newsgroups 'ask-server - "*Non-nil means that Gnus will run `gnus-find-new-newsgroups' at startup. + "Non-nil means that Gnus will run `gnus-find-new-newsgroups' at startup. This normally finds new newsgroups by comparing the active groups the servers have already reported with those Gnus already knows, either alive or killed. @@ -138,14 +138,14 @@ check for new newsgroups with \\<gnus-group-mode-map>\\[gnus-find-new-newsgroups (sexp :format "%v")))) (defcustom gnus-check-bogus-newsgroups nil - "*Non-nil means that Gnus will check and remove bogus newsgroup at startup. + "Non-nil means that Gnus will check and remove bogus newsgroup at startup. If this variable is nil, then you have to tell Gnus explicitly to check for bogus newsgroups with \\<gnus-group-mode-map>\\[gnus-group-check-bogus-groups]." :group 'gnus-start-server :type 'boolean) (defcustom gnus-read-active-file 'some - "*Non-nil means that Gnus will read the entire active file at startup. + "Non-nil means that Gnus will read the entire active file at startup. If this variable is nil, Gnus will only know about the groups in your `.newsrc' file. @@ -183,24 +183,24 @@ Levels' for details.") "Groups with this level are killed.") (defcustom gnus-level-default-subscribed 3 - "*New subscribed groups will be subscribed at this level." + "New subscribed groups will be subscribed at this level." :group 'gnus-group-levels :type 'integer) (defcustom gnus-level-default-unsubscribed 6 - "*New unsubscribed groups will be unsubscribed at this level." + "New unsubscribed groups will be unsubscribed at this level." :group 'gnus-group-levels :type 'integer) (defcustom gnus-activate-level (1+ gnus-level-subscribed) - "*Groups higher than this level won't be activated on startup. + "Groups higher than this level won't be activated on startup. Setting this variable to something low might save lots of time when you have many groups that you aren't interested in." :group 'gnus-group-levels :type 'integer) (defcustom gnus-activate-foreign-newsgroups 4 - "*If nil, Gnus will not check foreign newsgroups at startup. + "If nil, Gnus will not check foreign newsgroups at startup. If it is non-nil, it should be a number between one and nine. Foreign newsgroups that have a level lower or equal to this number will be activated on startup. For instance, if you want to active all @@ -216,7 +216,7 @@ groups." (const :tag "none" nil))) (defcustom gnus-read-newsrc-file t - "*Non-nil means that Gnus will read the `.newsrc' file. + "Non-nil means that Gnus will read the `.newsrc' file. Gnus always reads its own startup file, which is called \".newsrc.eld\". The file called \".newsrc\" is in a format that can be readily understood by other newsreaders. If you don't plan on @@ -227,7 +227,7 @@ entry." :type 'boolean) (defcustom gnus-save-newsrc-file t - "*Non-nil means that Gnus will save the `.newsrc' file. + "Non-nil means that Gnus will save the `.newsrc' file. Gnus always saves its own startup file, which is called \".newsrc.eld\". The file called \".newsrc\" is in a format that can be readily understood by other newsreaders. If you don't plan on @@ -237,7 +237,7 @@ exit." :type 'boolean) (defcustom gnus-save-killed-list t - "*If non-nil, save the list of killed groups to the startup file. + "If non-nil, save the list of killed groups to the startup file. If you set this variable to nil, you'll save both time (when starting and quitting) and space (both memory and disk), but it will also mean that Gnus has no record of which groups are new and which are old, so @@ -263,7 +263,7 @@ not match this regexp will be removed before saving the list." "^[\"][\"#'()]" ; bogus characters ) "\\|") - "*A regexp to match uninteresting newsgroups in the active file. + "A regexp to match uninteresting newsgroups in the active file. Any lines in the active file matching this regular expression are removed from the newsgroup list before anything else is done to it, thus making them effectively non-existent." @@ -271,7 +271,7 @@ thus making them effectively non-existent." :type 'regexp) (defcustom gnus-subscribe-newsgroup-method 'gnus-subscribe-zombies - "*Function(s) called with a group name when new group is detected. + "Function(s) called with a group name when new group is detected. A few pre-made functions are supplied: `gnus-subscribe-randomly' inserts new groups at the beginning of the list of groups; `gnus-subscribe-alphabetically' inserts new groups in strict @@ -295,7 +295,7 @@ claim them." (define-obsolete-variable-alias 'gnus-subscribe-newsgroup-hooks 'gnus-subscribe-newsgroup-functions "24.3") (defcustom gnus-subscribe-newsgroup-functions nil - "*Hooks run after you subscribe to a new group. + "Hooks run after you subscribe to a new group. The hooks will be called with new group's name as argument." :version "22.1" :group 'gnus-group-new @@ -303,7 +303,7 @@ The hooks will be called with new group's name as argument." (defcustom gnus-subscribe-options-newsgroup-method 'gnus-subscribe-alphabetically - "*Function(s) called to subscribe newsgroups mentioned on \"options -n\" lines. + "Function(s) called to subscribe newsgroups mentioned on \"options -n\" lines. If, for instance, you want to subscribe to all newsgroups in the \"no\" and \"alt\" hierarchies, you'd put the following in your .newsrc file: @@ -324,7 +324,7 @@ with the subscription method in this variable." (repeat function))) (defcustom gnus-subscribe-hierarchical-interactive nil - "*If non-nil, Gnus will offer to subscribe hierarchically. + "If non-nil, Gnus will offer to subscribe hierarchically. When a new hierarchy appears, Gnus will ask the user: 'alt.binaries': Do you want to subscribe to this hierarchy? ([d]ys): @@ -336,7 +336,7 @@ hierarchy in its entirety." :type 'boolean) (defcustom gnus-auto-subscribed-categories '(mail post-mail) - "*New groups from methods of these categories will be subscribed automatically. + "New groups from methods of these categories will be subscribed automatically. Note that this variable only deals with new groups. It has no effect whatsoever on old groups. The default is to automatically subscribe all groups from mail-like backends." @@ -346,7 +346,7 @@ subscribe all groups from mail-like backends." (defcustom gnus-auto-subscribed-groups "^nnml\\|^nnfolder\\|^nnmbox\\|^nnmh\\|^nnbabyl\\|^nnmaildir\\|^nnimap" - "*All new groups that match this regexp will be subscribed automatically. + "All new groups that match this regexp will be subscribed automatically. Note that this variable only deals with new groups. It has no effect whatsoever on old groups. @@ -357,7 +357,7 @@ be subscribed using `gnus-subscribe-options-newsgroup-method'." :type 'regexp) (defcustom gnus-options-subscribe nil - "*All new groups matching this regexp will be subscribed unconditionally. + "All new groups matching this regexp will be subscribed unconditionally. Note that this variable deals only with new newsgroups. This variable does not affect old newsgroups. @@ -369,7 +369,7 @@ be subscribed using `gnus-subscribe-options-newsgroup-method'." (const :tag "none" nil))) (defcustom gnus-options-not-subscribe nil - "*All new groups matching this regexp will be ignored. + "All new groups matching this regexp will be ignored. Note that this variable deals only with new newsgroups. This variable does not affect old (already subscribed) newsgroups." :group 'gnus-group-new @@ -377,7 +377,7 @@ does not affect old (already subscribed) newsgroups." (const :tag "none" nil))) (defcustom gnus-modtime-botch nil - "*Non-nil means .newsrc should be deleted prior to save. + "Non-nil means .newsrc should be deleted prior to save. Its use is due to the bogus appearance that .newsrc was modified on disc." :group 'gnus-newsrc @@ -432,7 +432,7 @@ See also `gnus-before-startup-hook'." (defcustom gnus-after-getting-new-news-hook '(gnus-display-time-event-handler) - "*A hook run after Gnus checks for new news when Gnus is already running." + "A hook run after Gnus checks for new news when Gnus is already running." :version "24.1" :group 'gnus-group-new :type 'hook) @@ -865,11 +865,6 @@ If REGEXP is given, lines that match it will be deleted." ;; Make sure that each dribble entry is a single line, so that ;; the "remove" code above works. (insert (replace-regexp-in-string "\n" "\\\\n" string) "\n") - ;; This has been commented by Josh Huber <huber@alum.wpi.edu> - ;; It causes problems with both XEmacs and Emacs 21, and doesn't - ;; seem to be of much value. (FIXME: remove this after we make sure - ;; it's not needed). - ;; (set-window-point (get-buffer-window (current-buffer)) (point-max)) (bury-buffer gnus-dribble-buffer) (with-current-buffer gnus-group-buffer (gnus-group-set-mode-line)) @@ -893,9 +888,7 @@ If REGEXP is given, lines that match it will be deleted." (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)) + (set (make-local-variable 'auto-save-include-big-deletions) t) (auto-save-mode t) (buffer-disable-undo) (bury-buffer (current-buffer)) @@ -1675,10 +1668,10 @@ backend check whether the group actually exists." type-cache)) ;; Only add groups that need updating. (if (or (and foreign-level (null (numberp foreign-level))) - (funcall (if one-level #'= #'<=) (gnus-info-level info) - (if (eq (cadr method-group-list) 'foreign) - foreign-level - alevel))) + (funcall (if one-level #'= #'<=) (gnus-info-level info) + (if (eq (cadr method-group-list) 'foreign) + foreign-level + alevel))) (setcar (nthcdr 2 method-group-list) (cons info (nth 2 method-group-list))) ;; The group is inactive, so we nix out the number of unread articles. @@ -1997,7 +1990,7 @@ backend check whether the group actually exists." (while lists (setq killed (car lists)) (while killed - (gnus-sethash (mm-string-as-unibyte (car killed)) nil hashtb) + (gnus-sethash (string-as-unibyte (car killed)) nil hashtb) (setq killed (cdr killed))) (setq lists (cdr lists))))) @@ -2393,8 +2386,8 @@ If FORCE is non-nil, the .newsrc file is read." (funcall func convert-to))) (gnus-dribble-enter - (gnus-format-message ";Converted gnus from version `%s' to `%s'." - gnus-newsrc-file-version gnus-version))))))) + (format-message ";Converted gnus from version `%s' to `%s'." + gnus-newsrc-file-version gnus-version))))))) (defun gnus-convert-mark-converter-prompt (converter no-prompt) "Indicate whether CONVERTER requires gnus-convert-old-newsrc to @@ -2460,7 +2453,7 @@ If FORCE is non-nil, the .newsrc file is read." (dolist (elem gnus-newsrc-alist) ;; Protect against broken .newsrc.el files. (when (car elem) - (setcar elem (mm-string-as-unibyte (car elem))))) + (setcar elem (string-as-unibyte (car elem))))) (gnus-make-hashtable-from-newsrc-alist) (when (file-newer-than-file-p file ding-file) ;; Old format quick file @@ -3032,7 +3025,7 @@ If FORCE is non-nil, the .newsrc file is read." (defun gnus-slave-save-newsrc () (with-current-buffer gnus-dribble-buffer (let ((slave-name - (mm-make-temp-file (concat gnus-current-startup-file "-slave-"))) + (make-temp-file (concat gnus-current-startup-file "-slave-"))) (modes (ignore-errors (file-modes (concat gnus-current-startup-file ".eld"))))) (let ((coding-system-for-write gnus-ding-file-coding-system)) @@ -3164,8 +3157,8 @@ If FORCE is non-nil, the .newsrc file is read." (gnus-parameter-charset name) gnus-default-charset))) ;; Fixme: Don't decode in unibyte mode. - (when (and str charset (featurep 'mule)) - (setq str (mm-decode-coding-string str charset))) + (when (and str charset) + (setq str (decode-coding-string str charset))) (set group str))) (forward-line 1)))) (gnus-message 5 "Reading descriptions file...done") @@ -3203,26 +3196,7 @@ If this variable is nil, don't do anything." (defun gnus-check-reasonable-setup () ;; Check whether nnml and nnfolder share a directory. - (let ((display-warn - (if (fboundp 'display-warning) - 'display-warning - (lambda (type message) - (if noninteractive - (message "Warning (%s): %s" type message) - (let (window) - (with-current-buffer (get-buffer-create "*Warnings*") - (goto-char (point-max)) - (unless (bolp) - (insert "\n")) - (insert (format "Warning (%s): %s\n" type message)) - (setq window (display-buffer (current-buffer))) - (set-window-start - window - (prog2 - (forward-line (- 1 (window-height window))) - (point) - (goto-char (point-max)))))))))) - method active actives match) + (let (method active actives match) (dolist (server gnus-server-alist) (setq method (gnus-server-to-method server) active (intern (format "%s-active-file" (car method)))) @@ -3230,11 +3204,11 @@ If this variable is nil, don't do anything." (gnus-server-opened method) (boundp active)) (when (setq match (assoc (symbol-value active) actives)) - (funcall display-warn 'gnus-server - (format "%s and %s share the same active file %s" - (car method) - (cadr match) - (car match)))) + (display-warning 'gnus-server + (format "%s and %s share the same active file %s" + (car method) + (cadr match) + (car match)))) (push (list (symbol-value active) method) actives))))) (provide 'gnus-start) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index ca55de001f7..c28557af765 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -24,11 +24,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) -(eval-when-compile - (when (featurep 'xemacs) - (require 'easy-mmode))) ; for `define-minor-mode' +(eval-when-compile (require 'cl)) (defvar tool-bar-mode) (defvar gnus-tmp-header) @@ -60,7 +56,7 @@ (autoload 'nnir-article-group "nnir" nil nil 'macro) (defcustom gnus-kill-summary-on-exit t - "*If non-nil, kill the summary buffer when you exit from it. + "If non-nil, kill the summary buffer when you exit from it. If nil, the summary will become a \"*Dead Summary*\" buffer, and it will be killed sometime later." :group 'gnus-summary-exit @@ -82,7 +78,7 @@ See `gnus-group-goto-unread'." :type 'boolean) (defcustom gnus-fetch-old-headers nil - "*Non-nil means that Gnus will try to build threads by grabbing old headers. + "Non-nil means that Gnus will try to build threads by grabbing old headers. If an unread article in the group refers to an older, already read (or just marked as read) article, the old article will not normally be displayed in the Summary buffer. If this variable is @@ -109,14 +105,14 @@ leads to very slow summary generation." (sexp :menu-tag "other" t))) (defcustom gnus-refer-thread-limit 500 - "*The number of old headers to fetch when doing \\<gnus-summary-mode-map>\\[gnus-summary-refer-thread]. + "The number of old headers to fetch when doing \\<gnus-summary-mode-map>\\[gnus-summary-refer-thread]. If t, fetch all the available old headers." :group 'gnus-thread :type '(choice number (sexp :menu-tag "other" t))) (defcustom gnus-refer-thread-use-nnir nil - "*Use nnir to search an entire server when referring threads. A + "Use nnir to search an entire server when referring threads. A nil value will only search for thread-related articles in the current group." :version "24.1" @@ -124,7 +120,7 @@ current group." :type 'boolean) (defcustom gnus-summary-make-false-root 'adopt - "*nil means that Gnus won't gather loose threads. + "nil means that Gnus won't gather loose threads. If the root of a thread has expired or been read in a previous session, the information necessary to build a complete thread has been lost. Instead of having many small sub-threads from this original thread @@ -159,7 +155,7 @@ given by the `gnus-summary-same-subject' variable.)" :type 'boolean) (defcustom gnus-summary-gather-exclude-subject "^ *$\\|^(none)$" - "*A regexp to match subjects to be excluded from loose thread gathering. + "A regexp to match subjects to be excluded from loose thread gathering. As loose thread gathering is done on subjects only, that means that there can be many false gatherings performed. By rooting out certain common subjects, gathering might become saner." @@ -167,7 +163,7 @@ common subjects, gathering might become saner." :type 'regexp) (defcustom gnus-summary-gather-subject-limit nil - "*Maximum length of subject comparisons when gathering loose threads. + "Maximum length of subject comparisons when gathering loose threads. Use nil to compare full subjects. Setting this variable to a low number will help gather threads that have been corrupted by newsreaders chopping off subject lines, but it might also mean that @@ -192,13 +188,13 @@ Useful functions to put in this list include: :type '(repeat function)) (defcustom gnus-simplify-ignored-prefixes nil - "*Remove matches for this regexp from subject lines when simplifying fuzzily." + "Remove matches for this regexp from subject lines when simplifying fuzzily." :group 'gnus-thread :type '(choice (const :tag "off" nil) regexp)) (defcustom gnus-build-sparse-threads nil - "*If non-nil, fill in the gaps in threads. + "If non-nil, fill in the gaps in threads. If `some', only fill in the gaps that are needed to tie loose threads together. If `more', fill in all leaf nodes that Gnus can find. If non-nil and non-`some', fill in all gaps that Gnus manages to guess." @@ -210,7 +206,7 @@ non-nil and non-`some', fill in all gaps that Gnus manages to guess." (defcustom gnus-summary-thread-gathering-function 'gnus-gather-threads-by-subject - "*Function used for gathering loose threads. + "Function used for gathering loose threads. There are two pre-defined functions: `gnus-gather-threads-by-subject', which only takes Subjects into consideration; and `gnus-gather-threads-by-references', which compared the References @@ -221,14 +217,14 @@ headers of the articles to find matches." (function :tag "other"))) (defcustom gnus-summary-same-subject "" - "*String indicating that the current article has the same subject as the previous. + "String indicating that the current article has the same subject as the previous. This variable will only be used if the value of `gnus-summary-make-false-root' is `empty'." :group 'gnus-summary-format :type 'string) (defcustom gnus-summary-goto-unread nil - "*If t, many commands will go to the next unread article. + "If t, many commands will go to the next unread article. This applies to marking commands as well as other commands that \"naturally\" select the next article, like, for instance, `SPC' at the end of an article. @@ -245,7 +241,7 @@ whether it is read or not." (sexp :menu-tag "on" t))) (defcustom gnus-summary-default-score 0 - "*Default article score level. + "Default article score level. All scores generated by the score files will be added to this score. If this variable is nil, scoring will be disabled." :group 'gnus-score-default @@ -253,7 +249,7 @@ If this variable is nil, scoring will be disabled." integer)) (defcustom gnus-summary-default-high-score 0 - "*Default threshold for a high scored article. + "Default threshold for a high scored article. An article will be highlighted as high scored if its score is greater than this score." :version "22.1" @@ -261,7 +257,7 @@ than this score." :type 'integer) (defcustom gnus-summary-default-low-score 0 - "*Default threshold for a low scored article. + "Default threshold for a low scored article. An article will be highlighted as low scored if its score is smaller than this score." :version "22.1" @@ -269,14 +265,14 @@ than this score." :type 'integer) (defcustom gnus-summary-zcore-fuzz 0 - "*Fuzziness factor for the zcore in the summary buffer. + "Fuzziness factor for the zcore in the summary buffer. Articles with scores closer than this to `gnus-summary-default-score' will not be marked." :group 'gnus-summary-format :type 'integer) (defcustom gnus-simplify-subject-fuzzy-regexp nil - "*Strings to be removed when doing fuzzy matches. + "Strings to be removed when doing fuzzy matches. This can either be a regular expression or list of regular expressions that will be removed from subject strings if fuzzy subject simplification is selected." @@ -284,12 +280,12 @@ simplification is selected." :type '(repeat regexp)) (defcustom gnus-show-threads t - "*If non-nil, display threads in summary mode." + "If non-nil, display threads in summary mode." :group 'gnus-thread :type 'boolean) (defcustom gnus-thread-hide-subtree nil - "*If non-nil, hide all threads initially. + "If non-nil, hide all threads initially. This can be a predicate specifier which says which threads to hide. If threads are hidden, you have to run the command `gnus-summary-show-thread' by hand or select an article." @@ -302,19 +298,19 @@ If threads are hidden, you have to run the command (sexp :tag "Predicate specifier"))) (defcustom gnus-thread-hide-killed t - "*If non-nil, hide killed threads automatically." + "If non-nil, hide killed threads automatically." :group 'gnus-thread :type 'boolean) (defcustom gnus-thread-ignore-subject t - "*If non-nil, which is the default, ignore subjects and do all threading based on the Reference header. + "If non-nil, which is the default, ignore subjects and do all threading based on the Reference header. If nil, articles that have different subjects from their parents will start separate threads." :group 'gnus-thread :type 'boolean) (defcustom gnus-thread-operation-ignore-subject t - "*If non-nil, subjects will be ignored when doing thread commands. + "If non-nil, subjects will be ignored when doing thread commands. This affects commands like `gnus-summary-kill-thread' and `gnus-summary-lower-thread'. @@ -328,12 +324,12 @@ equal will be included." (sexp :tag "on" t))) (defcustom gnus-thread-indent-level 4 - "*Number that says how much each sub-thread should be indented." + "Number that says how much each sub-thread should be indented." :group 'gnus-thread :type 'integer) (defcustom gnus-auto-extend-newsgroup t - "*If non-nil, extend newsgroup forward and backward when requested." + "If non-nil, extend newsgroup forward and backward when requested." :group 'gnus-summary-choose :type 'boolean) @@ -357,7 +353,7 @@ newsgroups, set the variable to nil in `gnus-select-group-hook'." (sexp :menu-tag "first" t))) (defcustom gnus-auto-select-subject 'unseen-or-unread - "*Says what subject to place under point when entering a group. + "Says what subject to place under point when entering a group. This variable can either be the symbols `first' (place point on the first subject), `unread' (place point on the subject line of the first @@ -377,7 +373,7 @@ place point on some subject line." (function :tag "Function to call"))) (defcustom gnus-auto-select-next t - "*If non-nil, offer to go to the next group from the end of the previous. + "If non-nil, offer to go to the next group from the end of the previous. If the value is t and the next newsgroup is empty, Gnus will exit summary mode and go back to group mode. If the value is neither nil nor t, Gnus will select the following unread newsgroup. In @@ -395,7 +391,7 @@ will go to the next group without confirmation." (sexp :menu-tag "on" t))) (defcustom gnus-auto-select-same nil - "*If non-nil, select the next article with the same subject. + "If non-nil, select the next article with the same subject. If there are no more articles with the same subject, go to the first unread article." :group 'gnus-summary-maneuvering @@ -424,7 +420,7 @@ article selected before entering to the ephemeral group will appear." (sexp :tag "other" :value nil))) (defcustom gnus-auto-goto-ignores 'unfetched - "*Says how to handle unfetched articles when maneuvering. + "Says how to handle unfetched articles when maneuvering. This variable can either be the symbols nil (maneuver to any article), `undownloaded' (maneuvering while unplugged ignores articles @@ -442,7 +438,7 @@ and, when unplugged, a subset of the undownloaded article list." (const :tag "Unfetched" unfetched))) (defcustom gnus-summary-check-current nil - "*If non-nil, consider the current article when moving. + "If non-nil, consider the current article when moving. The \"unread\" movement commands will stay on the same line if the current article is unread." :group 'gnus-summary-maneuvering @@ -450,7 +446,7 @@ current article is unread." (defcustom gnus-auto-center-summary (max (or (bound-and-true-p scroll-margin) 0) 2) - "*If non-nil, always center the current summary buffer. + "If non-nil, always center the current summary buffer. In particular, if `vertical' do only vertical recentering. If non-nil and non-`vertical', do both horizontal and vertical recentering." :group 'gnus-summary-maneuvering @@ -465,18 +461,18 @@ and non-`vertical', do both horizontal and vertical recentering." :type 'boolean) (defcustom gnus-show-all-headers nil - "*If non-nil, don't hide any headers." + "If non-nil, don't hide any headers." :group 'gnus-article-hiding :group 'gnus-article-headers :type 'boolean) (defcustom gnus-summary-ignore-duplicates nil - "*If non-nil, ignore articles with identical Message-ID headers." + "If non-nil, ignore articles with identical Message-ID headers." :group 'gnus-summary :type 'boolean) (defcustom gnus-single-article-buffer nil - "*If non-nil, display all articles in the same buffer. + "If non-nil, display all articles in the same buffer. If nil, each group will get its own article buffer." :version "24.1" :group 'gnus-article-various @@ -489,14 +485,14 @@ If nil, each group will get its own article buffer." :type 'boolean) (defcustom gnus-break-pages t - "*If non-nil, do page breaking on articles. + "If non-nil, do page breaking on articles. The page delimiter is specified by the `gnus-page-delimiter' variable." :group 'gnus-article-various :type 'boolean) (defcustom gnus-move-split-methods nil - "*Variable used to suggest where articles are to be moved to. + "Variable used to suggest where articles are to be moved to. It uses the same syntax as the `gnus-split-methods' variable. However, whereas `gnus-split-methods' specifies file names as targets, this variable specifies group names." @@ -516,163 +512,163 @@ string with the suggested prefix." ;; using multibyte characters (Latin-1, UTF-8) doesn't work. -- rs (defcustom gnus-unread-mark ? ;Whitespace - "*Mark used for unread articles." + "Mark used for unread articles." :group 'gnus-summary-marks :type 'character) (defcustom gnus-ticked-mark ?! - "*Mark used for ticked articles." + "Mark used for ticked articles." :group 'gnus-summary-marks :type 'character) (defcustom gnus-dormant-mark ?? - "*Mark used for dormant articles." + "Mark used for dormant articles." :group 'gnus-summary-marks :type 'character) (defcustom gnus-del-mark ?r - "*Mark used for del'd articles." + "Mark used for del'd articles." :group 'gnus-summary-marks :type 'character) (defcustom gnus-read-mark ?R - "*Mark used for read articles." + "Mark used for read articles." :group 'gnus-summary-marks :type 'character) (defcustom gnus-expirable-mark ?E - "*Mark used for expirable articles." + "Mark used for expirable articles." :group 'gnus-summary-marks :type 'character) (defcustom gnus-killed-mark ?K - "*Mark used for killed articles." + "Mark used for killed articles." :group 'gnus-summary-marks :type 'character) (defcustom gnus-spam-mark ?$ - "*Mark used for spam articles." + "Mark used for spam articles." :version "22.1" :group 'gnus-summary-marks :type 'character) (defcustom gnus-kill-file-mark ?X - "*Mark used for articles killed by kill files." + "Mark used for articles killed by kill files." :group 'gnus-summary-marks :type 'character) (defcustom gnus-low-score-mark ?Y - "*Mark used for articles with a low score." + "Mark used for articles with a low score." :group 'gnus-summary-marks :type 'character) (defcustom gnus-catchup-mark ?C - "*Mark used for articles that are caught up." + "Mark used for articles that are caught up." :group 'gnus-summary-marks :type 'character) (defcustom gnus-replied-mark ?A - "*Mark used for articles that have been replied to." + "Mark used for articles that have been replied to." :group 'gnus-summary-marks :type 'character) (defcustom gnus-forwarded-mark ?F - "*Mark used for articles that have been forwarded." + "Mark used for articles that have been forwarded." :version "22.1" :group 'gnus-summary-marks :type 'character) (defcustom gnus-recent-mark ?N - "*Mark used for articles that are recent." + "Mark used for articles that are recent." :version "22.1" :group 'gnus-summary-marks :type 'character) (defcustom gnus-cached-mark ?* - "*Mark used for articles that are in the cache." + "Mark used for articles that are in the cache." :group 'gnus-summary-marks :type 'character) (defcustom gnus-saved-mark ?S - "*Mark used for articles that have been saved." + "Mark used for articles that have been saved." :group 'gnus-summary-marks :type 'character) (defcustom gnus-unseen-mark ?. - "*Mark used for articles that haven't been seen." + "Mark used for articles that haven't been seen." :version "22.1" :group 'gnus-summary-marks :type 'character) (defcustom gnus-no-mark ? ;Whitespace - "*Mark used for articles that have no other secondary mark." + "Mark used for articles that have no other secondary mark." :version "22.1" :group 'gnus-summary-marks :type 'character) (defcustom gnus-ancient-mark ?O - "*Mark used for ancient articles." + "Mark used for ancient articles." :group 'gnus-summary-marks :type 'character) (defcustom gnus-sparse-mark ?Q - "*Mark used for sparsely reffed articles." + "Mark used for sparsely reffed articles." :group 'gnus-summary-marks :type 'character) (defcustom gnus-canceled-mark ?G - "*Mark used for canceled articles." + "Mark used for canceled articles." :group 'gnus-summary-marks :type 'character) (defcustom gnus-duplicate-mark ?M - "*Mark used for duplicate articles." + "Mark used for duplicate articles." :group 'gnus-summary-marks :type 'character) (defcustom gnus-undownloaded-mark ?- - "*Mark used for articles that weren't downloaded." + "Mark used for articles that weren't downloaded." :version "22.1" :group 'gnus-summary-marks :type 'character) (defcustom gnus-downloaded-mark ?+ - "*Mark used for articles that were downloaded." + "Mark used for articles that were downloaded." :group 'gnus-summary-marks :type 'character) (defcustom gnus-downloadable-mark ?% - "*Mark used for articles that are to be downloaded." + "Mark used for articles that are to be downloaded." :group 'gnus-summary-marks :type 'character) (defcustom gnus-unsendable-mark ?= - "*Mark used for articles that won't be sent." + "Mark used for articles that won't be sent." :group 'gnus-summary-marks :type 'character) (defcustom gnus-score-over-mark ?+ - "*Score mark used for articles with high scores." + "Score mark used for articles with high scores." :group 'gnus-summary-marks :type 'character) (defcustom gnus-score-below-mark ?- - "*Score mark used for articles with low scores." + "Score mark used for articles with low scores." :group 'gnus-summary-marks :type 'character) (defcustom gnus-empty-thread-mark ? ;Whitespace - "*There is no thread under the article." + "There is no thread under the article." :group 'gnus-summary-marks :type 'character) (defcustom gnus-not-empty-thread-mark ?= - "*There is a thread under the article." + "There is a thread under the article." :group 'gnus-summary-marks :type 'character) (defcustom gnus-view-pseudo-asynchronously nil - "*If non-nil, Gnus will view pseudo-articles asynchronously." + "If non-nil, Gnus will view pseudo-articles asynchronously." :group 'gnus-extract-view :type 'boolean) @@ -680,13 +676,13 @@ string with the suggested prefix." (list gnus-killed-mark gnus-del-mark gnus-catchup-mark gnus-low-score-mark gnus-ancient-mark gnus-read-mark gnus-duplicate-mark) - "*The list of marks converted into expiration if a group is auto-expirable." + "The list of marks converted into expiration if a group is auto-expirable." :version "24.1" :group 'gnus-summary :type '(repeat character)) (defcustom gnus-inhibit-user-auto-expire t - "*If non-nil, user marking commands will not mark an article as expirable, even if the group has auto-expire turned on." + "If non-nil, user marking commands will not mark an article as expirable, even if the group has auto-expire turned on." :version "21.1" :group 'gnus-summary :type 'boolean) @@ -703,7 +699,7 @@ which auto-expire is turned on." :group 'gnus-summary-marks) (defcustom gnus-view-pseudos nil - "*If `automatic', pseudo-articles will be viewed automatically. + "If `automatic', pseudo-articles will be viewed automatically. If `not-confirm', pseudos will be viewed automatically, and the user will not be asked to confirm the command." :group 'gnus-extract-view @@ -712,20 +708,20 @@ will not be asked to confirm the command." (const not-confirm))) (defcustom gnus-view-pseudos-separately t - "*If non-nil, one pseudo-article will be created for each file to be viewed. + "If non-nil, one pseudo-article will be created for each file to be viewed. If nil, all files that use the same viewing command will be given as a list of parameters to that command." :group 'gnus-extract-view :type 'boolean) (defcustom gnus-insert-pseudo-articles t - "*If non-nil, insert pseudo-articles when decoding articles." + "If non-nil, insert pseudo-articles when decoding articles." :group 'gnus-extract-view :type 'boolean) (defcustom gnus-summary-dummy-line-format " %(: :%) %S\n" - "*The format specification for the dummy roots in the summary buffer. + "The format specification for the dummy roots in the summary buffer. It works along the same lines as a normal formatting string, with some simple extensions. @@ -738,7 +734,7 @@ See `(gnus)Formatting Variables'." :type 'string) (defcustom gnus-summary-mode-line-format "Gnus: %g [%A] %Z" - "*The format specification for the summary mode line. + "The format specification for the summary mode line. It works along the same lines as a normal formatting string, with some simple extensions: @@ -771,7 +767,7 @@ This can also be a list of regexps." (repeat :value (".*") regexp))) (defcustom gnus-summary-mark-below 0 - "*Mark all articles with a score below this variable as read. + "Mark all articles with a score below this variable as read. This variable is local to each summary buffer and usually set by the score file." :group 'gnus-score-default @@ -812,7 +808,7 @@ VALUE should have the form `(FOO nil)' or `(FOO t)', where FOO is an atom. :value-to-external 'gnus-widget-reversible-to-external) (defcustom gnus-article-sort-functions '(gnus-article-sort-by-number) - "*List of functions used for sorting articles in the summary buffer. + "List of functions used for sorting articles in the summary buffer. Each function takes two articles and returns non-nil if the first article should be sorted before the other. If you use more than one @@ -845,7 +841,7 @@ controls how articles are sorted." (boolean :tag "Reverse order")))) (defcustom gnus-thread-sort-functions '(gnus-thread-sort-by-number) - "*List of functions used for sorting threads in the summary buffer. + "List of functions used for sorting threads in the summary buffer. By default, threads are sorted by article number. Each function takes two threads and returns non-nil if the first @@ -891,7 +887,7 @@ subthreads, customize `gnus-subthread-sort-functions'." (boolean :tag "Reverse order")))) (defcustom gnus-subthread-sort-functions 'gnus-thread-sort-functions - "*List of functions used for sorting subthreads in the summary buffer. + "List of functions used for sorting subthreads in the summary buffer. By default, subthreads are sorted the same as threads, i.e., according to the value of `gnus-thread-sort-functions'." :version "24.4" @@ -914,7 +910,7 @@ according to the value of `gnus-thread-sort-functions'." (boolean :tag "Reverse order"))))) (defcustom gnus-thread-score-function '+ - "*Function used for calculating the total score of a thread. + "Function used for calculating the total score of a thread. The function is called with the scores of the article and each subthread and should then return the score of the thread. @@ -942,50 +938,43 @@ This variable is local to the summary buffers." integer)) (defcustom gnus-summary-mode-hook nil - "*A hook for Gnus summary mode. + "A hook for Gnus summary mode. This hook is run before any variables are set in the summary buffer." :options '(turn-on-gnus-mailing-list-mode gnus-pick-mode) :group 'gnus-summary-various :type 'hook) -;; Extracted from gnus-xmas-redefine in order to preserve user settings -(when (featurep 'xemacs) - (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) - (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar) - (add-hook 'gnus-summary-mode-hook - 'gnus-xmas-switch-horizontal-scrollbar-off)) - (defcustom gnus-summary-menu-hook nil - "*Hook run after the creation of the summary mode menu." + "Hook run after the creation of the summary mode menu." :group 'gnus-summary-visual :type 'hook) (defcustom gnus-summary-exit-hook nil - "*A hook called on exit from the summary buffer. + "A hook called on exit from the summary buffer. It will be called with point in the group buffer." :group 'gnus-summary-exit :type 'hook) (defcustom gnus-summary-prepare-hook nil - "*A hook called after the summary buffer has been generated. + "A hook called after the summary buffer has been generated. If you want to modify the summary buffer, you can use this hook." :group 'gnus-summary-various :type 'hook) (defcustom gnus-summary-prepared-hook nil - "*A hook called as the last thing after the summary buffer has been generated." + "A hook called as the last thing after the summary buffer has been generated." :group 'gnus-summary-various :type 'hook) (defcustom gnus-summary-generate-hook nil - "*A hook run just before generating the summary buffer. + "A hook run just before generating the summary buffer. This hook is commonly used to customize threading variables and the like." :group 'gnus-summary-various :type 'hook) (defcustom gnus-select-group-hook nil - "*A hook called when a newsgroup is selected. + "A hook called when a newsgroup is selected. If you'd like to simplify subjects like the `gnus-summary-next-same-subject' command does, you can use the @@ -1003,32 +992,32 @@ following hook: :type 'hook) (defcustom gnus-select-article-hook nil - "*A hook called when an article is selected." + "A hook called when an article is selected." :group 'gnus-summary-choose :options '(gnus-agent-fetch-selected-article) :type 'hook) (defcustom gnus-visual-mark-article-hook (list 'gnus-highlight-selected-summary) - "*Hook run after selecting an article in the summary buffer. + "Hook run after selecting an article in the summary buffer. It is meant to be used for highlighting the article in some way. It is not run if `gnus-visual' is nil." :group 'gnus-summary-visual :type 'hook) (defcustom gnus-parse-headers-hook nil - "*A hook called before parsing the headers." + "A hook called before parsing the headers." :group 'gnus-various :type 'hook) (defcustom gnus-exit-group-hook nil - "*A hook called when exiting summary mode. + "A hook called when exiting summary mode. This hook is not called from the non-updating exit commands like `Q'." :group 'gnus-various :type 'hook) (defcustom gnus-summary-update-hook nil - "*A hook called when a summary line is changed. + "A hook called when a summary line is changed. The hook will not be called if `gnus-visual' is nil. The default function `gnus-summary-highlight-line' will @@ -1038,44 +1027,42 @@ variable." :type 'hook) (defcustom gnus-mark-article-hook '(gnus-summary-mark-read-and-unread-as-read) - "*A hook called when an article is selected for the first time. + "A hook called when an article is selected for the first time. The hook is intended to mark an article as read (or unread) automatically when it is selected." :group 'gnus-summary-choose :type 'hook) (defcustom gnus-group-no-more-groups-hook nil - "*A hook run when returning to group mode having no more (unread) groups." + "A hook run when returning to group mode having no more (unread) groups." :group 'gnus-group-select :type 'hook) (defcustom gnus-ps-print-hook nil - "*A hook run before ps-printing something from Gnus." + "A hook run before ps-printing something from Gnus." :group 'gnus-summary :type 'hook) (defcustom gnus-summary-article-move-hook nil - "*A hook called after an article is moved, copied, respooled, or crossposted." + "A hook called after an article is moved, copied, respooled, or crossposted." :version "22.1" :group 'gnus-summary :type 'hook) (defcustom gnus-summary-article-delete-hook nil - "*A hook called after an article is deleted." + "A hook called after an article is deleted." :version "22.1" :group 'gnus-summary :type 'hook) (defcustom gnus-summary-article-expire-hook nil - "*A hook called after an article is expired." + "A hook called after an article is expired." :version "22.1" :group 'gnus-summary :type 'hook) -(defcustom gnus-summary-display-arrow - (and (fboundp 'display-graphic-p) - (display-graphic-p)) - "*If non-nil, display an arrow highlighting the current article." +(defcustom gnus-summary-display-arrow (display-graphic-p) + "If non-nil, display an arrow highlighting the current article." :version "22.1" :group 'gnus-summary :type 'boolean) @@ -1125,7 +1112,7 @@ automatically when it is selected." . gnus-summary-low-read) (t . gnus-summary-normal-read)) - "*Controls the highlighting of summary buffer lines. + "Controls the highlighting of summary buffer lines. A list of (FORM . FACE) pairs. When deciding how a particular summary line should be displayed, each form is evaluated. The content @@ -1161,7 +1148,7 @@ which it may alter in any way." "Function used to decode addresses with encoded words.") (defcustom gnus-extra-headers '(To Cc Keywords Gcc Newsgroups X-GM-LABELS) - "*Extra headers to parse." + "Extra headers to parse." :version "25.1" :group 'gnus-summary :type '(repeat symbol)) @@ -1170,25 +1157,30 @@ which it may alter in any way." (and user-mail-address (not (string= user-mail-address "")) (regexp-quote user-mail-address)) - "*From headers that may be suppressed in favor of To headers. -This can be a regexp or a list of regexps." + "From headers that may be suppressed in favor of To headers. +This can be a regexp, a list of regexps or a function. + +If a function, an email string is passed as the argument." :version "21.1" :group 'gnus-summary :type '(choice regexp - (repeat :tag "Regexp List" regexp))) + (repeat :tag "Regexp List" regexp) + function)) (defsubst gnus-ignored-from-addresses () - (gmm-regexp-concat gnus-ignored-from-addresses)) + (cond ((functionp gnus-ignored-from-addresses) + gnus-ignored-from-addresses) + (t (gmm-regexp-concat gnus-ignored-from-addresses)))) (defcustom gnus-summary-to-prefix "-> " - "*String prefixed to the To field in the summary line when + "String prefixed to the To field in the summary line when using `gnus-ignored-from-addresses'." :version "22.1" :group 'gnus-summary :type 'string) (defcustom gnus-summary-newsgroup-prefix "=> " - "*String prefixed to the Newsgroup field in the summary + "String prefixed to the Newsgroup field in the summary line when using the option `gnus-ignored-from-addresses'." :version "22.1" :group 'gnus-summary @@ -1272,13 +1264,13 @@ For example: ((1 . cn-gb-2312) (2 . big5))." :group 'gnus-summary) (defcustom gnus-orphan-score nil - "*All orphans get this score added. Set in the score file." + "All orphans get this score added. Set in the score file." :group 'gnus-score-default :type '(choice (const nil) integer)) (defcustom gnus-summary-save-parts-default-mime "image/.*" - "*A regexp to match MIME parts when saving multiple parts of a + "A regexp to match MIME parts when saving multiple parts of a message with `gnus-summary-save-parts' (\\<gnus-summary-mode-map>\\[gnus-summary-save-parts]). This regexp will be used by default when prompting the user for which type of files to save." @@ -1896,7 +1888,7 @@ increase the score of each group you read." "&" gnus-summary-execute-command "c" gnus-summary-catchup-and-exit "\C-w" gnus-summary-mark-region-as-read - "\C-t" gnus-summary-toggle-truncation + "\C-t" toggle-truncate-lines "?" gnus-summary-mark-as-dormant "\C-c\M-\C-s" gnus-summary-limit-include-expunged "\C-c\C-s\C-n" gnus-summary-sort-by-number @@ -1931,7 +1923,7 @@ increase the score of each group you read." "q" gnus-summary-exit "Q" gnus-summary-exit-no-update "\C-c\C-i" gnus-info-find-node - gnus-mouse-2 gnus-mouse-pick-article + [mouse-2] gnus-mouse-pick-article [follow-link] mouse-face "m" gnus-summary-mail-other-window "a" gnus-summary-post-news @@ -2399,8 +2391,7 @@ increase the score of each group you read." ["Verify and Decrypt" gnus-summary-force-verify-and-decrypt t] ["Encrypt body" gnus-article-encrypt-body :active (not (gnus-group-read-only-p)) - ,@(if (featurep 'xemacs) nil - '(:help "Encrypt the message body on disk"))] + :help "Encrypt the message body on disk"] ["Extract all parts..." gnus-summary-save-parts t] ("Multipart" ["Repair multipart" gnus-summary-repair-multipart t] @@ -2409,8 +2400,7 @@ increase the score of each group you read." ["View part as type..." gnus-article-view-part-as-type t] ["Encrypt body" gnus-article-encrypt-body :active (not (gnus-group-read-only-p)) - ,@(if (featurep 'xemacs) nil - '(:help "Encrypt the message body on disk"))] + :help "Encrypt the message body on disk"] ["View part externally" gnus-article-view-part-externally t] ["View HTML parts in browser" gnus-article-browse-html-article t] ["View part with charset..." gnus-article-view-part-as-charset t] @@ -2450,10 +2440,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) '((1 . ,cs)))) (gnus-summary-show-article 1)))) `[,(symbol-name cs) ,command t])) - (sort (if (fboundp 'coding-system-list) - (coding-system-list) - (mapcar 'car mm-mime-mule-charset-alist)) - 'string<))))) + (sort (coding-system-list) 'string<))))) ("Washing" ("Remove Blanks" ["Leading" gnus-article-strip-leading-blank-lines t] @@ -2477,8 +2464,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Quoted-Printable" gnus-article-de-quoted-unreadable t] ["Base64" gnus-article-de-base64-unreadable t] ["Rot 13" gnus-summary-caesar-message - ,@(if (featurep 'xemacs) '(t) - '(:help "\"Caesar rotate\" article by 13"))] + :help "\"Caesar rotate\" article by 13"] ["De-IDNA" gnus-summary-idna-message t] ["Morse decode" gnus-summary-morse-message t] ["Unix pipe..." gnus-summary-pipe-message t] @@ -2503,11 +2489,9 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ) ("Output" ["Save in default format..." gnus-summary-save-article - ,@(if (featurep 'xemacs) '(t) - '(:help "Save article using default method"))] + :help "Save article using default method"] ["Save in file..." gnus-summary-save-article-file - ,@(if (featurep 'xemacs) '(t) - '(:help "Save article in file"))] + :help "Save article in file"] ["Save in Unix mail format..." gnus-summary-save-article-mail t] ["Save in MH folder..." gnus-summary-save-article-folder t] ["Save in VM folder..." gnus-summary-save-article-vm t] @@ -2516,11 +2500,9 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Pipe through a filter..." gnus-summary-pipe-output t] ["Print with Muttprint..." gnus-summary-muttprint t] ["Print" gnus-summary-print-article - ,@(if (featurep 'xemacs) '(t) - '(:help "Generate and print a PostScript image"))]) + :help "Generate and print a PostScript image"]) ("Copy, move,... (Backend)" - ,@(if (featurep 'xemacs) nil - '(:help "Copying, moving, expiring articles...")) + :help "Copying, moving, expiring articles..." ["Respool article..." gnus-summary-respool-article t] ["Move article..." gnus-summary-move-article (gnus-check-backend-function @@ -2547,9 +2529,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) (gnus-check-backend-function 'request-expire-articles gnus-newsgroup-name)]) ("Extract" - ["Uudecode" gnus-uu-decode-uu - ,@(if (featurep 'xemacs) '(t) - '(:help "Decode uuencoded article(s)"))] + ["Uudecode" gnus-uu-decode-uu :help "Decode uuencoded article(s)"] ["Uudecode and save" gnus-uu-decode-uu-and-save t] ["Unshar" gnus-uu-decode-unshar t] ["Unshar and save" gnus-uu-decode-unshar-and-save t] @@ -2582,7 +2562,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) (easy-menu-define gnus-article-commands-menu gnus-article-mode-map "" (cons "Commands" innards)) - ;; in Emacs, don't share menu. + ;; Don't share the menu. (setq gnus-article-commands-menu (copy-keymap gnus-summary-article-menu)) (define-key gnus-article-mode-map [menu-bar commands] @@ -2612,28 +2592,22 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) gnus-summary-post-menu gnus-summary-mode-map "" `("Post" ["Send a message (mail or news)" gnus-summary-post-news - ,@(if (featurep 'xemacs) '(t) - '(:help "Compose a new message (mail or news)"))] + :help "Compose a new message (mail or news)"] ["Followup" gnus-summary-followup - ,@(if (featurep 'xemacs) '(t) - '(:help "Post followup to this article"))] + :help "Post followup to this article"] ["Followup and yank" gnus-summary-followup-with-original - ,@(if (featurep 'xemacs) '(t) - '(:help "Post followup to this article, quoting its contents"))] + :help "Post followup to this article, quoting its contents"] ["Supersede article" gnus-summary-supersede-article t] ["Cancel article" gnus-summary-cancel-article - ,@(if (featurep 'xemacs) '(t) - '(:help "Cancel an article you posted"))] + :help "Cancel an article you posted"] ["Reply" gnus-summary-reply t] ["Reply and yank" gnus-summary-reply-with-original t] ["Wide reply" gnus-summary-wide-reply t] ["Wide reply and yank" gnus-summary-wide-reply-with-original - ,@(if (featurep 'xemacs) '(t) - '(:help "Mail a reply, quoting this article"))] + :help "Mail a reply, quoting this article"] ["Very wide reply" gnus-summary-very-wide-reply t] ["Very wide reply and yank" gnus-summary-very-wide-reply-with-original - ,@(if (featurep 'xemacs) '(t) - '(:help "Mail a very wide reply, quoting this article"))] + :help "Mail a very wide reply, quoting this article"] ["Mail forward" gnus-summary-mail-forward t] ["Post forward" gnus-summary-post-forward t] ["Digest and mail" gnus-uu-digest-mail-forward t] @@ -2644,38 +2618,25 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Send a mail" gnus-summary-mail-other-window t] ["Create a local message" gnus-summary-news-other-window t] ["Uuencode and post" gnus-uu-post-news - ,@(if (featurep 'xemacs) '(t) - '(:help "Post a uuencoded article"))] + :help "Post a uuencoded article"] ["Followup via news" gnus-summary-followup-to-mail t] ["Followup via news and yank" gnus-summary-followup-to-mail-with-original t] ["Strip signature on reply" (lambda () (interactive) - (if (not (memq message-cite-function - '(message-cite-original-without-signature - message-cite-original))) - ;; Stupid workaround for XEmacs not honoring :visible. - (message "Can't toggle this value of `message-cite-function'") - (setq message-cite-function - (if (eq message-cite-function - 'message-cite-original-without-signature) - 'message-cite-original - 'message-cite-original-without-signature)))) - ;; XEmacs barfs on :visible. - ,@(if (featurep 'xemacs) nil - '(:visible (memq message-cite-function - '(message-cite-original-without-signature - message-cite-original)))) + (setq message-cite-function + (if (eq message-cite-function + 'message-cite-original-without-signature) + 'message-cite-original + 'message-cite-original-without-signature))) + :visible (memq message-cite-function + '(message-cite-original-without-signature + message-cite-original)) :style toggle :selected (eq message-cite-function 'message-cite-original-without-signature) - ,@(if (featurep 'xemacs) nil - '(:help "Strip signature from cited article when replying."))] - ;;("Draft" - ;;["Send" gnus-summary-send-draft t] - ;;["Send bounced" gnus-resend-bounced-mail t]) - )) + :help "Strip signature from cited article when replying."])) (cond ((not (keymapp gnus-summary-post-menu)) @@ -2696,13 +2657,11 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) gnus-summary-kill-same-subject-and-select t] ["Mark same subject" gnus-summary-kill-same-subject t] ["Catchup" gnus-summary-catchup - ,@(if (featurep 'xemacs) '(t) - '(:help "Mark unread articles in this group as read"))] + :help "Mark unread articles in this group as read"] ["Catchup all" gnus-summary-catchup-all t] ["Catchup to here" gnus-summary-catchup-to-here t] ["Catchup from here" gnus-summary-catchup-from-here t] - ["Catchup region" gnus-summary-mark-region-as-read - (gnus-mark-active-p)] + ["Catchup region" gnus-summary-mark-region-as-read mark-active] ["Mark excluded" gnus-summary-limit-mark-excluded-as-read t]) ("Mark Various" ["Tick" gnus-summary-tick-article-forward t] @@ -2741,8 +2700,8 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Invert marks" gnus-uu-invert-processable t] ["Mark above" gnus-uu-mark-over t] ["Mark series" gnus-uu-mark-series t] - ["Mark region" gnus-uu-mark-region (gnus-mark-active-p)] - ["Unmark region" gnus-uu-unmark-region (gnus-mark-active-p)] + ["Mark region" gnus-uu-mark-region mark-active] + ["Unmark region" gnus-uu-unmark-region mark-active] ["Mark by regexp..." gnus-uu-mark-by-regexp t] ["Unmark by regexp..." gnus-uu-unmark-by-regexp t] ["Mark all" gnus-uu-mark-all t] @@ -2759,11 +2718,9 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ("Registry Marks") ("Scroll article" ["Page forward" gnus-summary-next-page - ,@(if (featurep 'xemacs) '(t) - '(:help "Show next page of article"))] + :help "Show next page of article"] ["Page backward" gnus-summary-prev-page - ,@(if (featurep 'xemacs) '(t) - '(:help "Show previous page of article"))] + :help "Show previous page of article"] ["Line forward" gnus-summary-scroll-up t]) ("Move" ["Next unread article" gnus-summary-next-unread-article t] @@ -2811,7 +2768,7 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Run command on articles..." gnus-summary-universal-argument t] ["Search articles forward..." gnus-summary-search-article-forward t] ["Search articles backward..." gnus-summary-search-article-backward t] - ["Toggle line truncation" gnus-summary-toggle-truncation t] + ["Toggle line truncation" toggle-truncate-lines t] ["Expand window" gnus-summary-expand-window t] ["Expire expirable articles" gnus-summary-expire-articles (gnus-check-backend-function @@ -2823,14 +2780,12 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) ["Send a bug report" gnus-bug t] ("Exit" ["Catchup and exit" gnus-summary-catchup-and-exit - ,@(if (featurep 'xemacs) '(t) - '(:help "Mark unread articles in this group as read, then exit"))] + :help "Mark unread articles in this group as read, then exit"] ["Catchup all and exit" gnus-summary-catchup-all-and-exit t] ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t] ["Catchup and goto prev" gnus-summary-catchup-and-goto-prev-group t] ["Exit group" gnus-summary-exit - ,@(if (featurep 'xemacs) '(t) - '(:help "Exit current group, return to group selection mode"))] + :help "Exit current group, return to group selection mode"] ["Exit group without updating" gnus-summary-exit-no-update t] ["Exit and goto next group" gnus-summary-next-group t] ["Exit and goto prev group" gnus-summary-prev-group t] @@ -2979,17 +2934,12 @@ See `gmm-tool-bar-from-list' for the format of the list." (defun gnus-summary-make-tool-bar (&optional force) "Make a summary mode tool bar from `gnus-summary-tool-bar'. When FORCE, rebuild the tool bar." - (when (and (not (featurep 'xemacs)) - (boundp 'tool-bar-mode) + (when (and (boundp 'tool-bar-mode) tool-bar-mode (or (not gnus-summary-tool-bar-map) force)) (let* ((load-path - (gmm-image-load-path-for-library "gnus" - "mail/save.xpm" - nil t)) - (image-load-path (cons (car load-path) - (when (boundp 'image-load-path) - image-load-path))) + (image-load-path-for-library "gnus" "mail/save.xpm" nil t)) + (image-load-path (cons (car load-path) image-load-path)) (map (gmm-tool-bar-from-list gnus-summary-tool-bar gnus-summary-tool-bar-zap-list 'gnus-summary-mode-map))) @@ -3120,12 +3070,10 @@ The following commands are available: (setq mode-name "Summary") (use-local-map gnus-summary-mode-map) (buffer-disable-undo) - (setq buffer-read-only t ;Disable modification - show-trailing-whitespace nil) - (setq truncate-lines t) - ;; Force paragraph direction to be left-to-right. Don't make it - ;; bound globally in old Emacsen and XEmacsen. - (set (make-local-variable 'bidi-paragraph-direction) 'left-to-right) + (setq buffer-read-only t + show-trailing-whitespace nil + truncate-lines t + bidi-paragraph-direction 'left-to-right) (add-to-invisibility-spec '(gnus-sum . t)) (gnus-summary-set-display-table) (gnus-set-default-directory) @@ -3134,7 +3082,6 @@ The following commands are available: (make-local-variable 'gnus-summary-dummy-line-format) (make-local-variable 'gnus-summary-dummy-line-format-spec) (make-local-variable 'gnus-summary-mark-positions) - (gnus-make-local-hook 'pre-command-hook) (add-hook 'pre-command-hook 'gnus-set-global-variables nil t) (gnus-run-mode-hooks 'gnus-summary-mode-hook) (turn-on-gnus-mailing-list-mode) @@ -3479,13 +3426,13 @@ display only a single character." (i 32)) ;; Nix out all the control chars... (while (>= (setq i (1- i)) 0) - (gnus-put-display-table i [??] table)) + (aset table i [??])) ;; ... but not newline and cr, of course. (cr is necessary for the ;; selective display). - (gnus-put-display-table ?\n nil table) - (gnus-put-display-table ?\r nil table) + (aset table ?\n nil) + (aset table ?\r nil) ;; We keep TAB as well. - (gnus-put-display-table ?\t nil table) + (aset table ?\t nil) ;; We nix out any glyphs 127 through 255, or 127 through 159 in ;; Emacs 23 (unicode), that are not set already. (let ((i (if (ignore-errors (= (make-char 'latin-iso8859-1 160) 160)) @@ -3493,8 +3440,8 @@ display only a single character." 256))) (while (>= (setq i (1- i)) 127) ;; Only modify if the entry is nil. - (unless (gnus-get-display-table i table) - (gnus-put-display-table i [??] table)))) + (unless (aref table i) + (aset table i [??])))) (setq buffer-display-table table))) (defun gnus-summary-set-article-display-arrow (pos) @@ -3676,7 +3623,7 @@ buffer that was in action when the last article was fetched." (defun gnus-summary-insert-dummy-line (gnus-tmp-subject gnus-tmp-number) "Insert a dummy root in the summary buffer." (beginning-of-line) - (gnus-add-text-properties + (add-text-properties (point) (progn (eval gnus-summary-dummy-line-format-spec) (point)) (list 'gnus-number gnus-tmp-number 'gnus-intangible gnus-tmp-number))) @@ -3686,15 +3633,17 @@ buffer that was in action when the last article was fetched." (defun gnus-summary-from-or-to-or-newsgroups (header gnus-tmp-from) (let ((mail-parse-charset gnus-newsgroup-charset) - (ignored-from-addresses (gnus-ignored-from-addresses)) ;; Is it really necessary to do this next part for each summary line? ;; Luckily, doesn't seem to slow things down much. (mail-parse-ignored-charsets (with-current-buffer gnus-summary-buffer gnus-newsgroup-ignored-charsets))) (or - (and ignored-from-addresses - (string-match ignored-from-addresses gnus-tmp-from) + (and gnus-ignored-from-addresses + (cond ((functionp gnus-ignored-from-addresses) + (funcall gnus-ignored-from-addresses + (mail-strip-quoted-names gnus-tmp-from))) + (t (string-match (gnus-ignored-from-addresses) gnus-tmp-from))) (let ((extra-headers (mail-header-extra header)) to newsgroups) @@ -3713,7 +3662,7 @@ buffer that was in action when the last article was fetched." gnus-newsgroup-name)) 'nntp) (gnus-group-real-name gnus-newsgroup-name)))) (concat gnus-summary-newsgroup-prefix newsgroups))))) - (gnus-string-mark-left-to-right + (bidi-string-mark-left-to-right (inline (gnus-summary-extract-address-component gnus-tmp-from)))))) @@ -3780,7 +3729,7 @@ buffer that was in action when the last article was fetched." (setq gnus-tmp-lines "?") (setq gnus-tmp-lines (number-to-string gnus-tmp-lines))) (condition-case () - (gnus-put-text-property + (put-text-property (point) (progn (eval gnus-summary-line-format-spec) (point)) 'gnus-number gnus-tmp-number) @@ -3897,8 +3846,8 @@ respectively." Returns \" ? \" if there's bad input or if another error occurs. Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." (condition-case () - (let* ((messy-date (gnus-float-time (gnus-date-get-time messy-date))) - (now (gnus-float-time)) + (let* ((messy-date (float-time (gnus-date-get-time messy-date))) + (now (float-time)) ;;If we don't find something suitable we'll use this one (my-format "%b %d '%y")) (let* ((difference (- now messy-date)) @@ -4488,9 +4437,9 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise." (defsubst gnus-remove-odd-characters (string) "Translate STRING into something that doesn't contain weird characters." - (mm-subst-char-in-string + (subst-char-in-string ?\r ?\- - (mm-subst-char-in-string ?\n ?\- string t) t)) + (subst-char-in-string ?\n ?\- string t) t)) ;; This function has to be called with point after the article number ;; on the beginning of the line. @@ -4800,7 +4749,7 @@ If LINE, insert the rebuilt thread starting on line LINE." (defun gnus-articles-in-thread (thread) "Return the list of articles in THREAD." (cons (mail-header-number (car thread)) - (apply 'nconc (mapcar 'gnus-articles-in-thread (cdr thread))))) + (mapcan 'gnus-articles-in-thread (cdr thread)))) (defun gnus-remove-thread (id &optional dont-remove) "Remove the thread that has ID in it." @@ -5110,7 +5059,7 @@ Unscored articles will be counted as having a score of zero." (defun gnus-thread-latest-date (thread) "Return the highest article date in THREAD." (apply 'max - (mapcar (lambda (header) (gnus-float-time + (mapcar (lambda (header) (float-time (gnus-date-get-time (mail-header-date header)))) (message-flatten-list thread)))) @@ -5470,7 +5419,7 @@ or a straight list of headers." (if (= gnus-tmp-lines -1) (setq gnus-tmp-lines "?") (setq gnus-tmp-lines (number-to-string gnus-tmp-lines))) - (gnus-put-text-property + (put-text-property (point) (progn (eval gnus-summary-line-format-spec) (point)) 'gnus-number number) @@ -5620,15 +5569,15 @@ If SELECT-ARTICLES, only select those articles from GROUP." (gnus-kill-buffer (current-buffer))) (error "Couldn't activate group %s: %s" - (mm-decode-coding-string group charset) - (mm-decode-coding-string (gnus-status-message group) charset)))) + (decode-coding-string group charset) + (decode-coding-string (gnus-status-message group) charset)))) (unless (gnus-request-group group t nil (gnus-get-info group)) (when (derived-mode-p 'gnus-summary-mode) (gnus-kill-buffer (current-buffer))) (error "Couldn't request group %s: %s" - (mm-decode-coding-string group charset) - (mm-decode-coding-string (gnus-status-message group) charset))) + (decode-coding-string group charset) + (decode-coding-string (gnus-status-message group) charset))) (when (and gnus-agent (gnus-active group)) @@ -6085,6 +6034,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq arts (cdr arts))) (setq list (cdr all))))) + ;; When exiting the group, everything that's previously been + ;; unseen is now seen. (when (eq (cdr type) 'seen) (setq list (gnus-range-add list gnus-newsgroup-unseen))) @@ -6677,7 +6628,7 @@ current article will be taken into consideration." (gnus-summary-find-next nil article))) (decf n))) (nreverse articles))) - ((and (gnus-region-active-p) (mark)) + ((and (and transient-mark-mode mark-active) (mark)) (message "region active") ;; Work on the region between point and mark. (let ((max (max (point) (mark))) @@ -6867,9 +6818,7 @@ Also do horizontal recentering." (when (and gnus-auto-center-summary (not (eq gnus-auto-center-summary 'vertical))) (gnus-horizontal-recenter)) - (if (fboundp 'recenter-top-bottom) - (recenter-top-bottom n) - (recenter n))) + (recenter-top-bottom n)) (put 'gnus-recenter 'isearch-scroll t) @@ -6880,8 +6829,8 @@ Like forward-line, but skip over (and don't count) invisible lines." (while (and (> n 0) (not done)) ;; If the following character is currently invisible, ;; skip all characters with that same `invisible' property value. - (while (gnus-invisible-p (point)) - (goto-char (gnus-next-char-property-change (point)))) + (while (invisible-p (point)) + (goto-char (next-char-property-change (point)))) (forward-line 1) (if (eobp) (setq done t) @@ -6890,8 +6839,8 @@ Like forward-line, but skip over (and don't count) invisible lines." (forward-line -1) (if (bobp) (setq done t) (setq n (1+ n)) - (while (and (not (bobp)) (gnus-invisible-p (1- (point)))) - (goto-char (gnus-previous-char-property-change (point)))))))) + (while (and (not (bobp)) (invisible-p (1- (point)))) + (goto-char (previous-char-property-change (point)))))))) (defun gnus-summary-recenter () "Center point in the summary window. @@ -7110,14 +7059,8 @@ buffer." (gnus-summary-remove-process-mark article))))) (gnus-summary-position-point)) -(defun gnus-summary-toggle-truncation (&optional arg) - "Toggle truncation of summary lines. -With ARG, turn line truncation on if ARG is positive." - (interactive "P") - (setq truncate-lines - (if (null arg) (not truncate-lines) - (> (prefix-numeric-value arg) 0))) - (redraw-display)) +(define-obsolete-function-alias + 'gnus-summary-toggle-truncation 'toggle-truncate-lines "26.1") (defun gnus-summary-find-for-reselect () "Return the number of an article to stay on across a reselect. @@ -7814,9 +7757,7 @@ If BACKWARD, the previous article is selected instead of the next." (t (unless (gnus-ephemeral-group-p gnus-newsgroup-name) (gnus-summary-jump-to-group gnus-newsgroup-name)) - (let ((cmd (if (featurep 'xemacs) - last-command-char - last-command-event)) + (let ((cmd last-command-event) (point (with-current-buffer gnus-group-buffer (point))) @@ -7844,7 +7785,7 @@ If BACKWARD, the previous article is selected instead of the next." "exiting")) (gnus-summary-next-group nil group backward))) (t - (when (gnus-key-press-event-p last-input-event) + (when (numberp last-input-event) ;; Somehow or other, we may now have selected a different ;; window. Make point go back to the summary buffer. (when (eq current-summary (current-buffer)) @@ -8368,15 +8309,14 @@ in `nnmail-extra-headers'." (gnus-summary-position-point)))) (defun gnus-summary-limit-strange-charsets-predicate (header) - (when (fboundp 'char-charset) - (let ((string (concat (mail-header-subject header) - (mail-header-from header))) - charset found) - (dotimes (i (1- (length string))) - (setq charset (format "%s" (char-charset (aref string (1+ i))))) - (when (string-match "unicode\\|big\\|japanese" charset) - (setq found t))) - found))) + (let ((string (concat (mail-header-subject header) + (mail-header-from header))) + charset found) + (dotimes (i (1- (length string))) + (setq charset (format "%s" (char-charset (aref string (1+ i))))) + (when (string-match "unicode\\|big\\|japanese" charset) + (setq found t))) + found)) (defun gnus-summary-limit-to-predicate (predicate) "Limit to articles where PREDICATE returns non-nil. @@ -8671,7 +8611,7 @@ fetched for this group." (gnus-agent nil) (gnus-read-all-available-headers t)) (setq gnus-newsgroup-headers - (gnus-merge + (cl-merge 'list gnus-newsgroup-headers (gnus-fetch-headers articles nil t) 'gnus-article-sort-by-number)) @@ -9083,7 +9023,7 @@ non-numeric or nil fetch the number specified by the (gnus-sorted-nunion gnus-newsgroup-unreads new-unreads)) (setq gnus-newsgroup-headers (gnus-delete-duplicate-headers - (gnus-merge + (cl-merge 'list gnus-newsgroup-headers new-headers 'gnus-article-sort-by-number))) (setq gnus-newsgroup-articles @@ -9132,7 +9072,7 @@ non-numeric or nil fetch the number specified by the (gnus-warp-to-article) (when (and (stringp message-id) (not (zerop (length message-id)))) - (setq message-id (gnus-replace-in-string message-id " " "")) + (setq message-id (replace-regexp-in-string " " "" message-id)) ;; Construct the correct Message-ID if necessary. ;; Suggested by tale@pawl.rpi.edu. (unless (string-match "^<" message-id) @@ -9435,7 +9375,6 @@ Optional argument BACKWARD means do search for backward. (gnus-article-prepare-hook nil) (gnus-mark-article-hook nil) ;Inhibit marking as read. (gnus-use-article-prefetch nil) - (gnus-xmas-force-redisplay nil) ;Inhibit XEmacs redisplay. (gnus-use-trees nil) ;Inhibit updating tree buffer. (gnus-visual nil) (gnus-keep-backlog nil) @@ -9611,10 +9550,10 @@ article. If BACKWARD (the prefix) is non-nil, search backward instead." (defun gnus-summary-print-truncate-and-quote (string &optional len) "Truncate to LEN and quote all \"(\"'s in STRING." - (gnus-replace-in-string (if (and len (> (length string) len)) - (substring string 0 len) - string) - "[()]" "\\\\\\&")) + (replace-regexp-in-string "[()]" "\\\\\\&" + (if (and len (> (length string) len)) + (substring string 0 len) + string))) (defun gnus-summary-print-article (&optional filename n) "Generate and print a PostScript image of the process-marked (mail) articles. @@ -9701,7 +9640,7 @@ C-u g', show the raw article." (gnus-summary-show-article t) (let ((gnus-newsgroup-charset (or (cdr (assq arg gnus-summary-show-article-charset-alist)) - (mm-read-coding-system + (read-coding-system "View as charset: " ;; actually it is coding system. (with-current-buffer gnus-article-buffer (mm-detect-coding-region (point) (point-max)))))) @@ -9862,8 +9801,6 @@ prefix specifies how many places to rotate each letter forward." ;; Create buttons and stuff... (gnus-treat-article nil)) -(declare-function idna-to-unicode "ext:idna" (str)) - (defun gnus-summary-idna-message (&optional arg) "Decode IDNA encoded domain names in the current articles. IDNA encoded domain names looks like `xn--bar'. If a string @@ -9873,25 +9810,16 @@ invalid IDNA string (`xn--bar' is invalid). You must have GNU Libidn (URL `http://www.gnu.org/software/libidn/') installed for this command to work." (interactive "P") - (if (not (and (mm-coding-system-p 'utf-8) - (condition-case nil - (require 'idna) - (file-error) - (invalid-operation)) - (symbol-value 'idna-program) - (executable-find (symbol-value 'idna-program)))) - (gnus-message - 5 "GNU Libidn not installed properly (`idn' or `idna.el' missing)") - (gnus-summary-select-article) - (let ((mail-header-separator "")) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-restriction - (widen) - (let ((start (window-start)) - buffer-read-only) - (while (re-search-forward "\\(xn--[-0-9a-z]+\\)" nil t) - (replace-match (idna-to-unicode (match-string 1)))) - (set-window-start (get-buffer-window (current-buffer)) start))))))) + (gnus-summary-select-article) + (let ((mail-header-separator "")) + (gnus-eval-in-buffer-window gnus-article-buffer + (save-restriction + (widen) + (let ((start (window-start)) + buffer-read-only) + (while (re-search-forward "\\(xn--[-0-9a-z]+\\)" nil t) + (replace-match (puny-decode-domain (match-string 1)))) + (set-window-start (get-buffer-window (current-buffer)) start)))))) (defun gnus-summary-morse-message (&optional arg) "Morse decode the current article." @@ -9996,7 +9924,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." encoded to-newsgroup to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) (set (intern (format "gnus-current-%s-group" action)) - (mm-decode-coding-string + (decode-coding-string to-newsgroup (gnus-group-name-charset to-method to-newsgroup)))) (unless to-method @@ -10006,7 +9934,7 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (setq to-newsgroup (or encoded (and to-newsgroup - (mm-encode-coding-string + (encode-coding-string to-newsgroup (gnus-group-name-charset to-method to-newsgroup))))) ;; Check the method we are to move this article to... @@ -10589,7 +10517,6 @@ groups." (let ((mbl1 mml-buffer-list)) (setq mml-buffer-list mbl) (set (make-local-variable 'mml-buffer-list) mbl1)) - (gnus-make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))) `(lambda (no-highlight) (let ((mail-parse-charset ',gnus-newsgroup-charset) @@ -10830,7 +10757,7 @@ If N is negative, mark backward instead. If UNMARK is non-nil, remove the process mark instead. The difference between N and the actual number of articles marked is returned." (interactive "P") - (if (and (null n) (gnus-region-active-p)) + (if (and (null n) (and transient-mark-mode mark-active)) (gnus-uu-mark-region (region-beginning) (region-end) unmark) (setq n (prefix-numeric-value n)) (let ((backward (< n 0)) @@ -11184,7 +11111,7 @@ If NO-EXPIRE, auto-expiry will be inhibited." (goto-char (+ forward (point))) ;; Replace the old mark with the new mark. (let ((to-insert - (mm-subst-char-in-string + (subst-char-in-string (char-after) mark (buffer-substring (point) (1+ (point)))))) (delete-region (point) (1+ (point))) @@ -11716,17 +11643,7 @@ Returns nil if no thread was there to be shown." (end (or (gnus-summary--inv end) (gnus-summary--inv (1- end)))) ;; Leave point at bol (beg (progn (beginning-of-line) (if (bobp) (point) (1- (point))))) - (eoi (when end - (if (fboundp 'next-single-char-property-change) - ;; Note: XEmacs version of n-s-c-p-c may return nil - (or (next-single-char-property-change end 'invisible) - (point-max)) - (while (progn - (end-of-line 2) - (and (not (eobp)) - (eq (get-char-property (point) 'invisible) - 'gnus-sum)))) - (point))))) + (eoi (and end (next-single-char-property-change end 'invisible)))) (when eoi (remove-overlays beg eoi 'invisible 'gnus-sum) (goto-char orig) @@ -12130,7 +12047,7 @@ no matter what the properties `:decode' and `:headers' are." command result) (unless (numberp (car articles)) (error "No article to pipe")) - (setq command (gnus-read-shell-command + (setq command (read-shell-command (concat "Shell command on " (if (cdr articles) (format "these %d articles" (length articles)) @@ -12301,7 +12218,6 @@ save those articles instead." (defun gnus-read-move-group-name (prompt default articles prefix) "Read a group name." (let* ((split-name (gnus-get-split-value gnus-move-split-methods)) - (minibuffer-confirm-incomplete nil) ; XEmacs (prom (format "%s %s to" prompt @@ -12331,7 +12247,7 @@ save those articles instead." (setq to-newsgroup default)) (unless to-newsgroup (error "No group name entered")) - (setq encoded (mm-encode-coding-string + (setq encoded (encode-coding-string to-newsgroup (gnus-group-name-charset to-method to-newsgroup))) (or (gnus-active encoded) @@ -12457,9 +12373,9 @@ If REVERSE, save parts that do not match TYPE." ": " (or (cdr (assq 'execute (car pslist))) "") "\n") (setq e (point)) (forward-line -1) ; back to `b' - (gnus-add-text-properties + (add-text-properties b (1- e) (list 'gnus-number gnus-reffed-article-number - gnus-mouse-face-prop gnus-mouse-face)) + 'mouse-face gnus-mouse-face)) (gnus-data-enter after-article gnus-reffed-article-number gnus-unread-mark b (car pslist) 0 (- e b)) @@ -12601,16 +12517,16 @@ If REVERSE, save parts that do not match TYPE." (let* ((beg (point-at-bol)) (end (point-at-eol)) ;; Fix by Mike Dugan <dugan@bucrf16.bu.edu>. - (from (if (get-text-property beg gnus-mouse-face-prop) + (from (if (get-text-property beg 'mouse-face) beg (or (next-single-property-change - beg gnus-mouse-face-prop nil end) + beg 'mouse-face nil end) beg))) (to (if (= from end) (- from 2) (or (next-single-property-change - from gnus-mouse-face-prop nil end) + from 'mouse-face nil end) end)))) ;; If no mouse-face prop on line we will have to = from = end, ;; so we highlight the entire line instead. @@ -12914,10 +12830,10 @@ returned." (mail-header-number h)) gnus-newsgroup-headers))) (setq gnus-newsgroup-headers - (gnus-merge 'list - gnus-newsgroup-headers - (gnus-fetch-headers articles nil t) - 'gnus-article-sort-by-number)) + (cl-merge 'list + gnus-newsgroup-headers + (gnus-fetch-headers articles nil t) + 'gnus-article-sort-by-number)) (setq gnus-newsgroup-articles (gnus-sorted-nunion gnus-newsgroup-articles articles)) ;; Suppress duplicates? @@ -13115,8 +13031,6 @@ BOOKMARK is a bookmark name or a bookmark record." (gnus-summary-make-all-marking-commands) -(gnus-ems-redefine) - (provide 'gnus-sum) (run-hooks 'gnus-sum-load-hook) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index dba599c9242..8ab8f462885 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -44,9 +44,6 @@ :type 'hook :group 'gnus-topic) -(when (featurep 'xemacs) - (add-hook 'gnus-topic-mode-hook 'gnus-xmas-topic-menu-add)) - (defcustom gnus-topic-line-format "%i[ %(%{%n%}%) -- %A ]%v\n" "Format of topic lines. It works along the same lines as a normal formatting string, @@ -66,12 +63,12 @@ See Info node `(gnus)Formatting Variables'." :group 'gnus-topic) (defcustom gnus-topic-indent-level 2 - "*How much each subtopic should be indented." + "How much each subtopic should be indented." :type 'integer :group 'gnus-topic) (defcustom gnus-topic-display-empty-topics t - "*If non-nil, display the topic lines even of topics that have no unread articles." + "If non-nil, display the topic lines even of topics that have no unread articles." :type 'boolean :group 'gnus-topic) @@ -575,7 +572,6 @@ articles in the topic and its subtopics." (not (zerop unread)) ;Non-empty tick ;Ticked articles (/= point-max (point-max)))) ;Inactive groups - (gnus-extent-start-open (point)) (gnus-topic-insert-topic-line (car type) visiblep (not (eq (nth 2 type) 'hidden)) @@ -644,7 +640,7 @@ articles in the topic and its subtopics." (beginning-of-line) ;; Insert the text. (if shownp - (gnus-add-text-properties + (add-text-properties (point) (prog1 (1+ (point)) (eval gnus-topic-line-format-spec)) @@ -1065,7 +1061,7 @@ articles in the topic and its subtopics." [(meta tab)] gnus-topic-unindent "\C-i" gnus-topic-indent "\M-\C-i" gnus-topic-unindent - gnus-mouse-2 gnus-mouse-pick-topic) + [mouse-2] gnus-mouse-pick-topic) ;; Define a new submap. (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map) @@ -1153,7 +1149,6 @@ articles in the topic and its subtopics." 'gnus-group-sort-topic) (setq gnus-group-change-level-function 'gnus-topic-change-level) (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) - (gnus-make-local-hook 'gnus-check-bogus-groups-hook) (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist nil 'local) (setq gnus-topology-checked-p nil) @@ -1167,7 +1162,7 @@ articles in the topic and its subtopics." (remove-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) (setq gnus-group-prepare-function 'gnus-group-prepare-flat) (setq gnus-group-sort-alist-function 'gnus-group-sort-flat)) - (when (gmm-called-interactively-p 'any) + (when (called-interactively-p 'any) (gnus-group-list-groups)))) (defun gnus-topic-select-group (&optional all) @@ -1294,7 +1289,7 @@ If COPYP, copy the groups instead." (list current-prefix-arg (gnus-completing-read "Move to topic" (mapcar 'car gnus-topic-alist) t nil 'gnus-topic-history))) - (let ((use-marked (and (not n) (not (gnus-region-active-p)) + (let ((use-marked (and (not n) (not (and transient-mark-mode mark-active)) gnus-group-marked t)) (groups (gnus-group-process-prefix n)) (topicl (assoc topic gnus-topic-alist)) @@ -1319,7 +1314,7 @@ If COPYP, copy the groups instead." (defun gnus-topic-remove-group (&optional n) "Remove the current group from the topic." (interactive "P") - (let ((use-marked (and (not n) (not (gnus-region-active-p)) + (let ((use-marked (and (not n) (not (and transient-mark-mode mark-active)) gnus-group-marked t)) (groups (gnus-group-process-prefix n))) (mapc @@ -1615,8 +1610,8 @@ If performed on a topic, edit the topic parameters instead." (let ((topic (gnus-group-topic-name))) (gnus-edit-form (gnus-topic-parameters topic) - (gnus-format-message "Editing the topic parameters for `%s'." - (or group topic)) + (format-message "Editing the topic parameters for `%s'." + (or group topic)) `(lambda (form) (gnus-topic-set-parameters ,topic form))))))) diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el index d98237bfcb1..74e0601c6e3 100644 --- a/lisp/gnus/gnus-undo.el +++ b/lisp/gnus/gnus-undo.el @@ -44,9 +44,6 @@ ;;; Code: (eval-when-compile (require 'cl)) -(eval-when-compile - (when (featurep 'xemacs) - (require 'easy-mmode))) ; for `define-minor-mode' (require 'gnus-util) (require 'gnus) @@ -111,7 +108,6 @@ ;; Set up the menu. (when (gnus-visual-p 'undo-menu 'menu) (gnus-undo-make-menu-bar)) - (gnus-make-local-hook 'post-command-hook) (add-hook 'post-command-hook 'gnus-undo-boundary nil t))) ;;; Interface functions. diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index c005528be5f..ff5c2950914 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -44,24 +44,18 @@ :type `(radio (function-item :doc "Use Emacs standard `completing-read' function." gnus-emacs-completing-read) - ;; iswitchb.el is very old and ido.el is unavailable - ;; in XEmacs, so we exclude those function items. - ,@(unless (featurep 'xemacs) - '((function-item - :doc "Use `ido-completing-read' function." - gnus-ido-completing-read) - (function-item - :doc "Use iswitchb based completing-read function." - gnus-iswitchb-completing-read))))) + (function-item + :doc "Use `ido-completing-read' function." + gnus-ido-completing-read) + (function-item + :doc "Use iswitchb based completing-read function." + gnus-iswitchb-completing-read))) (defcustom gnus-completion-styles - (if (and (boundp 'completion-styles-alist) - (boundp 'completion-styles)) - (append (when (and (assq 'substring completion-styles-alist) - (not (memq 'substring completion-styles))) - (list 'substring)) - completion-styles) - nil) + (append (when (and (assq 'substring completion-styles-alist) + (not (memq 'substring completion-styles))) + (list 'substring)) + completion-styles) "Value of `completion-styles' to use when completing." :version "24.1" :group 'gnus-meta @@ -81,23 +75,14 @@ (autoload 'nnheader-replace-chars-in-string "nnheader") (autoload 'mail-header-remove-comments "mail-parse") -(eval-and-compile - (cond - ;; Prefer `replace-regexp-in-string' (present in Emacs, XEmacs 21.5, - ;; SXEmacs 22.1.4) over `replace-in-string'. The latter leads to inf-loops - ;; on empty matches: - ;; (replace-in-string "foo" "/*$" "/") - ;; (replace-in-string "xe" "\\(x\\)?" "") - ((fboundp 'replace-regexp-in-string) - (defun gnus-replace-in-string (string regexp newtext &optional literal) - "Replace all matches for REGEXP with NEWTEXT in STRING. +(defun gnus-replace-in-string (string regexp newtext &optional literal) + "Replace all matches for REGEXP with NEWTEXT in STRING. If LITERAL is non-nil, insert NEWTEXT literally. Return a new string containing the replacements. This is a compatibility function for different Emacsen." - (replace-regexp-in-string regexp newtext string nil literal))) - ((fboundp 'replace-in-string) - (defalias 'gnus-replace-in-string 'replace-in-string)))) + (declare (obsolete replace-regexp-in-string "26.1")) + (replace-regexp-in-string regexp newtext string nil literal)) (defun gnus-boundp (variable) "Return non-nil if VARIABLE is bound and non-nil." @@ -141,14 +126,6 @@ This is a compatibility function for different Emacsen." (funcall (if (stringp buffer) 'get-buffer 'buffer-name) buffer)))) -;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and -;; XEmacs. In Emacs we don't need to call `make-local-hook' first. -;; It's harmless, though, so the main purpose of this alias is to shut -;; up the byte compiler. -(defalias 'gnus-make-local-hook (if (featurep 'xemacs) - 'make-local-hook - 'ignore)) - (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." (if (equal (car list) elt) @@ -311,13 +288,6 @@ Symbols are also allowed; their print names are used instead." (and (= (car fdate) (car date)) (> (nth 1 fdate) (nth 1 date)))))) -;; Every version of Emacs Gnus supports has built-in float-time. -;; The featurep test silences an irritating compiler warning. -(defalias 'gnus-float-time - (if (or (featurep 'emacs) - (fboundp 'float-time)) - 'float-time 'time-to-seconds)) - ;;; Keymap macros. (defmacro gnus-local-set-keys (&rest plist) @@ -326,13 +296,6 @@ Symbols are also allowed; their print names are used instead." (defmacro gnus-define-keys (keymap &rest plist) "Define all keys in PLIST in KEYMAP." - ;; Convert the key [?\S-\ ] to [(shift space)] for XEmacs. - (when (featurep 'xemacs) - (let ((bindings plist)) - (while bindings - (when (equal (car bindings) [?\S-\ ]) - (setcar bindings [(shift space)])) - (setq bindings (cddr bindings))))) `(gnus-define-keys-1 (quote ,keymap) (quote ,plist))) (defmacro gnus-define-keys-safe (keymap &rest plist) @@ -434,7 +397,7 @@ Cache the result as a text property stored in DATE." (defun gnus-mode-string-quote (string) "Quote all \"%\"'s in STRING." - (gnus-replace-in-string string "%" "%%")) + (replace-regexp-in-string "%" "%%" string)) ;; Make a hash table (default and minimum size is 256). ;; Optional argument HASHSIZE specifies the table size. @@ -454,7 +417,7 @@ Cache the result as a text property stored in DATE." i)) (defcustom gnus-verbose 6 - "*Integer that says how verbose Gnus should be. + "Integer that says how verbose Gnus should be. The higher the number, the more messages Gnus will flash to say what it's doing. At zero, Gnus will be totally mute; at five, Gnus will display most important messages; and at ten, Gnus will keep on @@ -465,10 +428,10 @@ jabbering all the time." (defcustom gnus-add-timestamp-to-message nil "Non-nil means add timestamps to messages that Gnus issues. -If it is `log', add timestamps to only the messages that go into the -\"*Messages*\" buffer (in XEmacs, it is the \" *Message-Log*\" buffer). -If it is neither nil nor `log', add timestamps not only to log messages -but also to the ones displayed in the echo area." +If it is `log', add timestamps to only the messages that go into +the \"*Messages*\" buffer. If it is neither nil nor `log', add +timestamps not only to log messages but also to the ones +displayed in the echo area." :version "23.1" ;; No Gnus :group 'gnus-various :type '(choice :format "%{%t%}:\n %[Value Menu%] %v" @@ -481,56 +444,37 @@ but also to the ones displayed in the echo area." (eval-when-compile (defmacro gnus-message-with-timestamp-1 (format-string args) (let ((timestamp '(format-time-string "%Y%m%dT%H%M%S.%3N> " time))) - (if (featurep 'xemacs) - `(let (str time) - (if (or (and (null ,format-string) (null ,args)) - (progn - (setq str (apply 'format ,format-string ,args)) - (zerop (length str)))) - (prog1 - (and ,format-string str) - (clear-message nil)) - (cond ((eq gnus-add-timestamp-to-message 'log) - (setq time (current-time)) - (display-message 'no-log str) - (log-message 'message (concat ,timestamp str))) - (gnus-add-timestamp-to-message - (setq time (current-time)) - (display-message 'message (concat ,timestamp str))) - (t - (display-message 'message str)))) - str) - `(let (str time) - (cond ((eq gnus-add-timestamp-to-message 'log) - (setq str (let (message-log-max) - (apply 'message ,format-string ,args))) - (when (and message-log-max - (> message-log-max 0) - (/= (length str) 0)) - (setq time (current-time)) - (with-current-buffer (if (fboundp 'messages-buffer) - (messages-buffer) - (get-buffer-create "*Messages*")) - (goto-char (point-max)) - (let ((inhibit-read-only t)) - (insert ,timestamp str "\n") - (forward-line (- message-log-max)) - (delete-region (point-min) (point))) - (goto-char (point-max)))) - str) - (gnus-add-timestamp-to-message - (if (or (and (null ,format-string) (null ,args)) - (progn - (setq str (apply 'format ,format-string ,args)) - (zerop (length str)))) - (prog1 - (and ,format-string str) - (message nil)) - (setq time (current-time)) - (message "%s" (concat ,timestamp str)) - str)) - (t - (apply 'message ,format-string ,args)))))))) + `(let (str time) + (cond ((eq gnus-add-timestamp-to-message 'log) + (setq str (let (message-log-max) + (apply 'message ,format-string ,args))) + (when (and message-log-max + (> message-log-max 0) + (/= (length str) 0)) + (setq time (current-time)) + (with-current-buffer (if (fboundp 'messages-buffer) + (messages-buffer) + (get-buffer-create "*Messages*")) + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (insert ,timestamp str "\n") + (forward-line (- message-log-max)) + (delete-region (point-min) (point))) + (goto-char (point-max)))) + str) + (gnus-add-timestamp-to-message + (if (or (and (null ,format-string) (null ,args)) + (progn + (setq str (apply 'format ,format-string ,args)) + (zerop (length str)))) + (prog1 + (and ,format-string str) + (message nil)) + (setq time (current-time)) + (message "%s" (concat ,timestamp str)) + str)) + (t + (apply 'message ,format-string ,args))))))) (defvar gnus-action-message-log nil) @@ -646,7 +590,6 @@ If N, return the Nth ancestor instead." (defun gnus-read-event-char (&optional prompt) "Get the next event." (let ((event (read-event prompt))) - ;; should be gnus-characterp, but this can't be called in XEmacs anyway (cons (and (numberp event) event) event))) (defun gnus-copy-file (file &optional to) @@ -839,9 +782,6 @@ If there's no subdirectory, delete DIRECTORY as well." (setq string (replace-match "" t t string))) string) -(declare-function gnus-put-text-property "gnus" - (start end property value &optional object)) - (defsubst gnus-put-text-property-excluding-newlines (beg end prop val) "The same as `put-text-property', but don't put this prop on any newlines in the region." (save-match-data @@ -849,9 +789,9 @@ If there's no subdirectory, delete DIRECTORY as well." (save-restriction (goto-char beg) (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move) - (gnus-put-text-property beg (match-beginning 0) prop val) + (put-text-property beg (match-beginning 0) prop val) (setq beg (point))) - (gnus-put-text-property beg (point) prop val))))) + (put-text-property beg (point) prop val))))) (defsubst gnus-put-overlay-excluding-newlines (beg end prop val) "The same as `put-text-property', but don't put this prop on any newlines in the region." @@ -875,7 +815,7 @@ Otherwise, do nothing." (when (eq prop 'face) (setcar (cdr (get-text-property beg 'face)) (or val 'default))) (inline - (gnus-put-text-property beg stop prop val))) + (put-text-property beg stop prop val))) (setq beg stop)))) (defun gnus-get-text-property-excluding-characters-with-faces (pos prop) @@ -890,39 +830,12 @@ Otherwise, return the value." (defmacro gnus-faces-at (position) "Return a list of faces at POSITION." - (if (featurep 'xemacs) - `(let ((pos ,position)) - (mapcar-extents 'extent-face - nil (current-buffer) pos pos nil 'face)) - `(let ((pos ,position)) - (delq nil (cons (get-text-property pos 'face) - (mapcar - (lambda (overlay) - (overlay-get overlay 'face)) - (overlays-at pos))))))) - -(if (fboundp 'invisible-p) - (defalias 'gnus-invisible-p 'invisible-p) - ;; for Emacs < 22.2, and XEmacs. - (defun gnus-invisible-p (pos) - "Return non-nil if the character after POS is currently invisible." - (let ((prop (get-char-property pos 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec)))))) - -;; Note: the optional 2nd argument has a different meaning between -;; Emacs and XEmacs. -;; (next-char-property-change POSITION &optional LIMIT) -;; (next-extent-change POS &optional OBJECT) -(defalias 'gnus-next-char-property-change - (if (fboundp 'next-extent-change) - 'next-extent-change 'next-char-property-change)) - -(defalias 'gnus-previous-char-property-change - (if (fboundp 'previous-extent-change) - 'previous-extent-change 'previous-char-property-change)) + `(let ((pos ,position)) + (delq nil (cons (get-text-property pos 'face) + (mapcar + (lambda (overlay) + (overlay-get overlay 'face)) + (overlays-at pos)))))) ;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 ;; The primary idea here is to try to protect internal data structures @@ -1001,16 +914,8 @@ with potentially long computations." ;;; Functions for saving to babyl/mail files. -(eval-when-compile - (if (featurep 'xemacs) - ;; Don't load tm and apel XEmacs packages that provide some - ;; Emacs emulating functions and variables. - (let ((features features)) - (provide 'tm-view) - (unless (fboundp 'set-alist) (defalias 'set-alist 'ignore)) - (require 'rmail)) ;; It requires tm-view that loads apel. - (require 'rmail)) - (autoload 'rmail-update-summary "rmailsum")) +(require 'rmail) +(autoload 'rmail-update-summary "rmailsum") (defvar mm-text-coding-system) @@ -1207,11 +1112,8 @@ ARG is passed to the first function." (apply 'run-hook-with-args hook args))) (defun gnus-run-mode-hooks (&rest funcs) - "Run `run-mode-hooks' if it is available, otherwise `run-hooks'. -This function saves the current buffer." - (if (fboundp 'run-mode-hooks) - (save-current-buffer (apply 'run-mode-hooks funcs)) - (save-current-buffer (apply 'run-hooks funcs)))) + "Run `run-mode-hooks', saving the current buffer." + (save-current-buffer (apply 'run-mode-hooks funcs))) ;;; Various @@ -1259,16 +1161,6 @@ If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." (setq sequence (cdr sequence)))) (nreverse out))) -(if (fboundp 'assq-delete-all) - (defalias 'gnus-delete-alist 'assq-delete-all) - (defun gnus-delete-alist (key alist) - "Delete from ALIST all elements whose car is KEY. -Return the modified alist." - (let (entry) - (while (setq entry (assq key alist)) - (setq alist (delq entry alist))) - alist))) - (defun gnus-grep-in-list (word list) "Find if a WORD matches any regular expression in the given LIST." (when (and word list) @@ -1370,43 +1262,17 @@ Return the modified alist." (put 'gnus-with-output-to-file 'lisp-indent-function 1) (put 'gnus-with-output-to-file 'edebug-form-spec '(form body)) -(if (fboundp 'union) - (defalias 'gnus-union 'union) - (defun gnus-union (l1 l2 &rest keys) - "Set union of lists L1 and L2. -If KEYS contains the `:test' and `equal' pair, use `equal' to compare -items in lists, otherwise use `eq'." - (cond ((null l1) l2) - ((null l2) l1) - ((equal l1 l2) l1) - (t - (or (>= (length l1) (length l2)) - (setq l1 (prog1 l2 (setq l2 l1)))) - (if (eq 'equal (plist-get keys :test)) - (while l2 - (or (member (car l2) l1) - (push (car l2) l1)) - (pop l2)) - (while l2 - (or (memq (car l2) l1) - (push (car l2) l1)) - (pop l2))) - l1)))) - -(declare-function gnus-add-text-properties "gnus" - (start end properties &optional object)) - (defun gnus-add-text-properties-when (property value start end properties &optional object) - "Like `gnus-add-text-properties', only applied on where PROPERTY is VALUE." + "Like `add-text-properties', only applied on where PROPERTY is VALUE." (let (point) (while (and start (< start end) ;; XEmacs will loop for every when start=end. (setq point (text-property-not-all start end property value))) - (gnus-add-text-properties start point properties object) + (add-text-properties start point properties object) (setq start (text-property-any point end property value))) (if start - (gnus-add-text-properties start end properties object)))) + (add-text-properties start end properties object)))) (defun gnus-remove-text-properties-when (property value start end properties &optional object) @@ -1449,10 +1315,6 @@ is run." "Byte-compile FORM if `gnus-use-byte-compile' is non-nil." (if gnus-use-byte-compile (progn - (condition-case nil - ;; Work around a bug in XEmacs 21.4 - (require 'byte-optimize) - (error)) (require 'bytecomp) (defalias 'gnus-byte-compile (lambda (form) @@ -1555,16 +1417,7 @@ SPEC is a predicate specifier that contains stuff like `or', `and', initial-input history def) "Call standard `completing-read-function'." (let ((completion-styles gnus-completion-styles)) - (completing-read prompt - (if (featurep 'xemacs) - ;; Old XEmacs (at least 21.4) expect an alist, - ;; in which the car of each element is a string, - ;; for collection. - (mapcar - (lambda (elem) - (list (format "%s" (or (car-safe elem) elem)))) - collection) - collection) + (completing-read prompt collection nil require-match initial-input history def))) (autoload 'ido-completing-read "ido") @@ -1605,11 +1458,6 @@ SPEC is a predicate specifier that contains stuff like `or', `and', (or iswitchb-mode (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))))) -(defun gnus-graphic-display-p () - (if (featurep 'xemacs) - (device-on-window-system-p) - (display-graphic-p))) - (put 'gnus-parse-without-error 'lisp-indent-function 0) (put 'gnus-parse-without-error 'edebug-form-spec '(body)) @@ -1655,7 +1503,7 @@ CHOICE is a list of the choice char and help message at IDX." (setq tchar nil) (setq buf (get-buffer-create "*Gnus Help*")) (pop-to-buffer buf) - (fundamental-mode) ; for Emacs 20.4+ + (fundamental-mode) (buffer-disable-undo) (erase-buffer) (insert prompt ":\n\n") @@ -1690,31 +1538,18 @@ CHOICE is a list of the choice char and help message at IDX." (kill-buffer buf)) tchar)) -(if (featurep 'emacs) - (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus) - (if (fboundp 'select-frame-set-input-focus) - (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus) - ;; XEmacs 21.4, SXEmacs - (defun gnus-select-frame-set-input-focus (frame) - "Select FRAME, raise it, and set input focus, if possible." - (raise-frame frame) - (select-frame frame) - (focus-frame frame)))) - (defun gnus-frame-or-window-display-name (object) "Given a frame or window, return the associated display name. Return nil otherwise." - (if (featurep 'xemacs) - (device-connection (dfw-device object)) - (if (or (framep object) - (and (windowp object) - (setq object (window-frame object)))) - (let ((display (frame-parameter object 'display))) - (if (and (stringp display) - ;; Exclude invalid display names. - (string-match "\\`[^:]*:[0-9]+\\(\\.[0-9]+\\)?\\'" - display)) - display))))) + (if (or (framep object) + (and (windowp object) + (setq object (window-frame object)))) + (let ((display (frame-parameter object 'display))) + (if (and (stringp display) + ;; Exclude invalid display names. + (string-match "\\`[^:]*:[0-9]+\\(\\.[0-9]+\\)?\\'" + display)) + display)))) (defvar tool-bar-mode) @@ -1723,9 +1558,7 @@ Return nil otherwise." (when (and (boundp 'tool-bar-mode) tool-bar-mode) (let* ((args nil) - (func (cond ((featurep 'xemacs) - 'ignore) - ((fboundp 'tool-bar-update) + (func (cond ((fboundp 'tool-bar-update) 'tool-bar-update) ((fboundp 'force-window-update) 'force-window-update) @@ -1766,29 +1599,10 @@ sequence, this is like `mapcar'. With several, it is like the Common Lisp heads)) nil)) (setq ,result-tail (cdr ,result-tail) - ,@(apply 'nconc (mapcar (lambda (h) (list h (list 'cdr h))) heads)))) + ,@(mapcan (lambda (h) (list h (list 'cdr h))) heads))) (cdr ,result))) `(mapcar ,function ,seq1))) -(if (fboundp 'merge) - (defalias 'gnus-merge 'merge) - ;; Adapted from cl-seq.el - (defun gnus-merge (type list1 list2 pred) - "Destructively merge lists LIST1 and LIST2 to produce a new list. -Argument TYPE is for compatibility and ignored. -Ordering of the elements is preserved according to PRED, a `less-than' -predicate on the elements." - (let ((res nil)) - (while (and list1 list2) - (if (funcall pred (car list2) (car list1)) - (push (pop list2) res) - (push (pop list1) res))) - (nconc (nreverse res) list1 list2)))) - -(defvar xemacs-codename) -(defvar sxemacs-codename) -(defvar emacs-program-version) - (defun gnus-emacs-version () "Stringified Emacs version." (let* ((lst (if (listp gnus-user-agent) @@ -1799,37 +1613,15 @@ predicate on the elements." ((memq 'type lst) (symbol-name system-type)) (t nil))) - codename emacsname) - (cond ((featurep 'sxemacs) - (setq emacsname "SXEmacs" - codename sxemacs-codename)) - ((featurep 'xemacs) - (setq emacsname "XEmacs" - codename xemacs-codename)) - (t - (setq emacsname "Emacs"))) + codename) (cond ((not (memq 'emacs lst)) nil) ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version) - ;; Emacs: (concat "Emacs/" (match-string 1 emacs-version) (if system-v (concat " (" system-v ")") ""))) - ((or (featurep 'sxemacs) (featurep 'xemacs)) - ;; XEmacs or SXEmacs: - (concat emacsname "/" emacs-program-version - (let (plst) - (when (memq 'codename lst) - (push codename plst)) - (when system-v - (push system-v plst)) - (unless (featurep 'mule) - (push "no MULE" plst)) - (when (> (length plst) 0) - (concat - " (" (mapconcat 'identity (reverse plst) ", ") ")"))))) (t emacs-version)))) (defun gnus-rename-file (old-path new-path &optional trim) @@ -1858,36 +1650,6 @@ empty directories from OLD-PATH." (ignore-errors (set-file-modes filename mode))) -(if (fboundp 'set-process-query-on-exit-flag) - (defalias 'gnus-set-process-query-on-exit-flag - 'set-process-query-on-exit-flag) - (defalias 'gnus-set-process-query-on-exit-flag - 'process-kill-without-query)) - -(defalias 'gnus-read-shell-command - (if (fboundp 'read-shell-command) 'read-shell-command 'read-string)) - -(defmacro gnus-put-display-table (range value display-table) - "Set the value for char RANGE to VALUE in DISPLAY-TABLE. " - (if (featurep 'xemacs) - (progn - `(if (fboundp 'put-display-table) - (put-display-table ,range ,value ,display-table) - (if (sequencep ,display-table) - (aset ,display-table ,range ,value) - (put-char-table ,range ,value ,display-table)))) - `(aset ,display-table ,range ,value))) - -(defmacro gnus-get-display-table (character display-table) - "Find value for CHARACTER in DISPLAY-TABLE. " - (if (featurep 'xemacs) - `(if (fboundp 'get-display-table) - (get-display-table ,character ,display-table) - (if (sequencep ,display-table) - (aref ,display-table ,character) - (get-char-table ,character ,display-table))) - `(aref ,display-table ,character))) - (declare-function image-size "image.c" (spec &optional pixels frame)) (defun gnus-rescale-image (image size) @@ -1910,12 +1672,11 @@ Sizes are in pixels." image))) image))) -(eval-when-compile (require 'gmm-utils)) (defun gnus-recursive-directory-files (dir) "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 + (cl-labels ((fn (directory) (dolist (file (directory-files directory t)) (setq attr (file-attributes (file-truename file))) @@ -1939,63 +1700,6 @@ The first found will be returned if a file has hard or symbolic links." (memq elem list)))) found)) -(eval-and-compile - (cond - ((fboundp 'match-substitute-replacement) - (defalias 'gnus-match-substitute-replacement 'match-substitute-replacement)) - (t - (defun gnus-match-substitute-replacement (replacement &optional fixedcase literal string subexp) - "Return REPLACEMENT as it will be inserted by `replace-match'. -In other words, all back-references in the form `\\&' and `\\N' -are substituted with actual strings matched by the last search. -Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same -meaning as for `replace-match'. - -This is the definition of match-substitute-replacement in subr.el from GNU Emacs." - (let ((match (match-string 0 string))) - (save-match-data - (set-match-data (mapcar (lambda (x) - (if (numberp x) - (- x (match-beginning 0)) - x)) - (match-data t))) - (replace-match replacement fixedcase literal match subexp))))))) - -(if (fboundp 'string-match-p) - (defalias 'gnus-string-match-p 'string-match-p) - (defsubst gnus-string-match-p (regexp string &optional start) - "\ -Same as `string-match' except this function does not change the match data." - (save-match-data - (string-match regexp string start)))) - -(if (fboundp 'string-prefix-p) - (defalias 'gnus-string-prefix-p 'string-prefix-p) - (defun gnus-string-prefix-p (str1 str2 &optional ignore-case) - "Return non-nil if STR1 is a prefix of STR2. -If IGNORE-CASE is non-nil, the comparison is done without paying attention -to case differences." - (and (<= (length str1) (length str2)) - (let ((prefix (substring str2 0 (length str1)))) - (if ignore-case - (string-equal (downcase str1) (downcase prefix)) - (string-equal str1 prefix)))))) - -(defalias 'gnus-format-message - (if (fboundp 'format-message) 'format-message - ;; for Emacs < 25, and XEmacs, don't worry about quote translation. - 'format)) - -;; Simple check: can be a macro but this way, although slow, it's really clear. -;; We don't use `bound-and-true-p' because it's not in XEmacs. -(defun gnus-bound-and-true-p (sym) - (and (boundp sym) (symbol-value sym))) - -(if (fboundp 'timer--function) - (defalias 'gnus-timer--function 'timer--function) - (defun gnus-timer--function (timer) - (elt timer 5))) - (defun gnus-test-list (list predicate) "To each element of LIST apply PREDICATE. Return nil if LIST is no list or is empty or some test returns nil; @@ -2021,6 +1725,59 @@ lists of strings." (gnus-setdiff (cdr list1) list2) (cons (car list1) (gnus-setdiff (cdr list1) list2))))) +;;; Image functions. + +(defun gnus-image-type-available-p (type) + (and (display-images-p) + (image-type-available-p type))) + +(defun gnus-create-image (file &optional type data-p &rest props) + (let ((face (plist-get props :face))) + (when face + (setq props (plist-put props :foreground (face-foreground face))) + (setq props (plist-put props :background (face-background face)))) + (ignore-errors + (apply 'create-image file type data-p props)))) + +(defun gnus-put-image (glyph &optional string category) + (let ((point (point))) + (insert-image glyph (or string " ")) + (put-text-property point (point) 'gnus-image-category category) + (unless string + (put-text-property (1- (point)) (point) + 'gnus-image-text-deletable t)) + glyph)) + +(defun gnus-remove-image (image &optional category) + "Remove the image matching IMAGE and CATEGORY found first." + (let ((start (point-min)) + val end) + (while (and (not end) + (or (setq val (get-text-property start 'display)) + (and (setq start + (next-single-property-change start 'display)) + (setq val (get-text-property start 'display))))) + (setq end (or (next-single-property-change start 'display) + (point-max))) + (if (and (equal val image) + (equal (get-text-property start 'gnus-image-category) + category)) + (progn + (put-text-property start end 'display nil) + (when (get-text-property start 'gnus-image-text-deletable) + (delete-region start end))) + (unless (= end (point-max)) + (setq start end + end nil)))))) + +(defun gnus-kill-all-overlays () + "Delete all overlays in the current buffer." + (let* ((overlayss (overlay-lists)) + (buffer-read-only nil) + (overlays (delq nil (nconc (car overlayss) (cdr overlayss))))) + (while overlays + (delete-overlay (pop overlays))))) + (provide 'gnus-util) ;;; gnus-util.el ends here diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index ada89a982ac..62192173498 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -73,7 +73,7 @@ ("\\.\\(flc\\|fli\\|rle\\|iff\\|pfx\\|avi\\|sme\\|rpza\\|dl\\|qt\\|rsrc\\|mov\\)$" "xanim") ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$" "gnus-uu-archive")) - "*Default actions to be taken when the user asks to view a file. + "Default actions to be taken when the user asks to view a file. To change the behavior, you can either edit this variable or set `gnus-uu-user-view-rules' to something useful. @@ -113,7 +113,7 @@ details." (defcustom gnus-uu-user-view-rules-end '(("" "file")) - "*What actions are to be taken if no rule matched the file name. + "What actions are to be taken if no rule matched the file name. See the documentation on the `gnus-uu-default-view-rules' variable for details." :group 'gnus-extract-view @@ -131,7 +131,7 @@ details." ("\\.Z$" "uncompress") ("\\.gz$" "gunzip") ("\\.arc$" "arc -x")) - "*See `gnus-uu-user-archive-rules'." + "See `gnus-uu-user-archive-rules'." :group 'gnus-extract-archive :type '(repeat (group regexp (string :tag "Command")))) @@ -149,7 +149,7 @@ unpack zip files, say the following: :type '(repeat (group regexp (string :tag "Command")))) (defcustom gnus-uu-ignore-files-by-name nil - "*A regular expression saying what files should not be viewed based on name. + "A regular expression saying what files should not be viewed based on name. If, for instance, you want gnus-uu to ignore all .au and .wav files, you could say something like @@ -162,7 +162,7 @@ Note that this variable can be used in conjunction with the (regexp :format "%v"))) (defcustom gnus-uu-ignore-files-by-type nil - "*A regular expression saying what files that shouldn't be viewed, based on MIME file type. + "A regular expression saying what files that shouldn't be viewed, based on MIME file type. If, for instance, you want gnus-uu to ignore all audio files and all mpegs, you could say something like @@ -217,23 +217,20 @@ Note that this variable can be used in conjunction with the ;; Various variables users may set -(defcustom gnus-uu-tmp-dir - (cond ((fboundp 'temp-directory) (temp-directory)) - ((boundp 'temporary-file-directory) temporary-file-directory) - ("/tmp/")) - "*Variable saying where gnus-uu is to do its work. +(defcustom gnus-uu-tmp-dir temporary-file-directory + "Variable saying where gnus-uu is to do its work. Default is \"/tmp/\"." :group 'gnus-extract :type 'directory) (defcustom gnus-uu-do-not-unpack-archives nil - "*Non-nil means that gnus-uu won't peek inside archives looking for files to display. + "Non-nil means that gnus-uu won't peek inside archives looking for files to display. Default is nil." :group 'gnus-extract-archive :type 'boolean) (defcustom gnus-uu-ignore-default-view-rules nil - "*Non-nil means that gnus-uu will ignore the default viewing rules. + "Non-nil means that gnus-uu will ignore the default viewing rules. Only the user viewing rules will be consulted. Default is nil." :group 'gnus-extract-view :type 'boolean) @@ -248,19 +245,19 @@ and `gnus-uu-grab-move'." :type 'hook) (defcustom gnus-uu-ignore-default-archive-rules nil - "*Non-nil means that gnus-uu will ignore the default archive unpacking commands. + "Non-nil means that gnus-uu will ignore the default archive unpacking commands. Only the user unpacking commands will be consulted. Default is nil." :group 'gnus-extract-archive :type 'boolean) (defcustom gnus-uu-kill-carriage-return t - "*Non-nil means that gnus-uu will strip all carriage returns from articles. + "Non-nil means that gnus-uu will strip all carriage returns from articles. Default is t." :group 'gnus-extract :type 'boolean) (defcustom gnus-uu-view-with-metamail nil - "*Non-nil means that files will be viewed with metamail. + "Non-nil means that files will be viewed with metamail. The gnus-uu viewing functions will be ignored and gnus-uu will try to guess at a content-type based on file name suffixes. Default it nil." @@ -268,19 +265,19 @@ it nil." :type 'boolean) (defcustom gnus-uu-unmark-articles-not-decoded nil - "*Non-nil means that gnus-uu will mark articles that were unsuccessfully decoded as unread. + "Non-nil means that gnus-uu will mark articles that were unsuccessfully decoded as unread. Default is nil." :group 'gnus-extract :type 'boolean) (defcustom gnus-uu-correct-stripped-uucode nil - "*Non-nil means that gnus-uu will *try* to fix uuencoded files that have had trailing spaces deleted. + "Non-nil means that gnus-uu will *try* to fix uuencoded files that have had trailing spaces deleted. Default is nil." :group 'gnus-extract :type 'boolean) (defcustom gnus-uu-save-in-digest nil - "*Non-nil means that gnus-uu, when asked to save without decoding, will save in digests. + "Non-nil means that gnus-uu, when asked to save without decoding, will save in digests. If this variable is nil, gnus-uu will just save everything in a file without any embellishments. The digesting almost conforms to RFC1153 - no easy way to specify any meaningful volume and issue numbers were found, @@ -298,19 +295,19 @@ so I simply dropped them." "^Summary:" "^References:" "^Content-Type:" "^Content-Transfer-Encoding:" "^MIME-Version:" "^Content-Disposition:" "^Content-Description:" "^Content-ID:") - "*List of regexps to match headers included in digested messages. + "List of regexps to match headers included in digested messages. The headers will be included in the sequence they are matched. If nil include all headers." :group 'gnus-extract :type '(repeat regexp)) (defcustom gnus-uu-save-separate-articles nil - "*Non-nil means that gnus-uu will save articles in separate files." + "Non-nil means that gnus-uu will save articles in separate files." :group 'gnus-extract :type 'boolean) (defcustom gnus-uu-be-dangerous 'ask - "*Specifies what to do if unusual situations arise during decoding. + "Specifies what to do if unusual situations arise during decoding. If nil, be as conservative as possible. If t, ignore things that didn't work, and overwrite existing files. Otherwise, ask each time." :group 'gnus-extract @@ -408,7 +405,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time." gnus-uu-default-dir)))) (gnus-uu-initialize) (setq gnus-uu-binhex-article-name - (mm-make-temp-file (expand-file-name "binhex" gnus-uu-work-dir))) + (make-temp-file (expand-file-name "binhex" gnus-uu-work-dir))) (gnus-uu-decode-with-method 'gnus-uu-binhex-article n dir)) (defun gnus-uu-decode-yenc (n dir) @@ -474,7 +471,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time." gnus-uu-default-dir gnus-uu-default-dir))) (gnus-uu-initialize) (setq gnus-uu-binhex-article-name - (mm-make-temp-file (expand-file-name "binhex" gnus-uu-work-dir))) + (make-temp-file (expand-file-name "binhex" gnus-uu-work-dir))) (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-binhex n file))) @@ -486,7 +483,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (interactive "P") (gnus-uu-initialize) (let ((gnus-uu-save-in-digest t) - (file (mm-make-temp-file (nnheader-concat gnus-uu-work-dir "forward"))) + (file (make-temp-file (nnheader-concat gnus-uu-work-dir "forward"))) (message-forward-as-mime message-forward-as-mime) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) @@ -876,10 +873,7 @@ When called interactively, prompt for REGEXP." (with-current-buffer buffer (save-restriction (let ((inhibit-read-only t)) - (set-text-properties (point-min) (point-max) nil) - ;; These two are necessary for XEmacs 19.12 fascism. - (put-text-property (point-min) (point-max) 'invisible nil) - (put-text-property (point-min) (point-max) 'intangible nil)) + (set-text-properties (point-min) (point-max) nil)) (when (and message-forward-as-mime message-forward-show-mml gnus-uu-digest-buffer) @@ -1787,7 +1781,7 @@ Gnus might fail to display all of it.") gnus-uu-tmp-dir))) (setq gnus-uu-work-dir - (mm-make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir)) + (make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir)) (gnus-set-file-modes gnus-uu-work-dir 448) (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) (push (cons gnus-newsgroup-name gnus-uu-work-dir) diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index bccb1d7eb78..255bb5f42eb 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -34,27 +34,27 @@ :group 'gnus) (defcustom gnus-use-full-window t - "*If non-nil, use the entire Emacs screen." + "If non-nil, use the entire Emacs screen." :group 'gnus-windows :type 'boolean) (defcustom gnus-window-min-width 2 - "*Minimum width of Gnus buffers." + "Minimum width of Gnus buffers." :group 'gnus-windows :type 'integer) (defcustom gnus-window-min-height 1 - "*Minimum height of Gnus buffers." + "Minimum height of Gnus buffers." :group 'gnus-windows :type 'integer) (defcustom gnus-always-force-window-configuration nil - "*If non-nil, always force the Gnus window configurations." + "If non-nil, always force the Gnus window configurations." :group 'gnus-windows :type 'boolean) (defcustom gnus-use-frames-on-any-display nil - "*If non-nil, frames on all displays will be considered usable by Gnus. + "If non-nil, frames on all displays will be considered usable by Gnus. When nil, only frames on the same display as the selected frame will be used to display Gnus windows." :version "22.1" @@ -195,7 +195,7 @@ See the Gnus manual for an explanation of the syntax used.") "Mapping from short symbols to buffer names or buffer variables.") (defcustom gnus-configure-windows-hook nil - "*A hook called when configuring windows." + "A hook called when configuring windows." :version "22.1" :group 'gnus-windows :type 'hook) @@ -273,9 +273,7 @@ See the Gnus manual for an explanation of the syntax used.") (cond ((eq buf (window-buffer (selected-window))) (set-buffer buf)) - ((eq t (window-dedicated-p - ;; XEmacs version of `window-dedicated-p' requires it. - (selected-window))) + ((eq t (window-dedicated-p)) ;; If the window is hard-dedicated, we have a problem because ;; we just can't do what we're asked. But signaling an error, ;; like `switch-to-buffer' would do, is not an option because @@ -417,19 +415,15 @@ See the Gnus manual for an explanation of the syntax used.") (gnus-delete-windows-in-gnusey-frames)) ;; Just remove some windows. (gnus-remove-some-windows) - (if (featurep 'xemacs) - (switch-to-buffer nntp-server-buffer) - (set-buffer nntp-server-buffer))) + (set-buffer nntp-server-buffer)) (select-frame frame))) (let (gnus-window-frame-focus) - (if (featurep 'xemacs) - (switch-to-buffer nntp-server-buffer) - (set-buffer nntp-server-buffer)) + (set-buffer nntp-server-buffer) (gnus-configure-frame split) (run-hooks 'gnus-configure-windows-hook) (when gnus-window-frame-focus - (gnus-select-frame-set-input-focus + (select-frame-set-input-focus (window-frame gnus-window-frame-focus))))))))) (defun gnus-delete-windows-in-gnusey-frames () @@ -510,27 +504,15 @@ should have point." lowest-buf buf)))) (when lowest-buf (pop-to-buffer lowest-buf) - (if (featurep 'xemacs) - (switch-to-buffer nntp-server-buffer) - (set-buffer nntp-server-buffer))) + (set-buffer nntp-server-buffer)) (mapcar (lambda (b) (delete-windows-on b t)) (delq lowest-buf bufs))))) -(eval-and-compile - (cond - ((fboundp 'frames-on-display-list) - (defalias 'gnus-frames-on-display-list 'frames-on-display-list)) - ((and (featurep 'xemacs) (fboundp 'frame-device)) - (defun gnus-frames-on-display-list () - (apply 'filtered-frame-list 'identity (list (frame-device nil))))) - (t - (defalias 'gnus-frames-on-display-list 'frame-list)))) - (defun gnus-get-buffer-window (buffer &optional frame) (cond ((and (null gnus-use-frames-on-any-display) (memq frame '(t 0 visible))) (car - (let ((frames (gnus-frames-on-display-list))) + (let ((frames (frames-on-display-list))) (gnus-remove-if (lambda (win) (not (memq (window-frame win) frames))) (get-buffer-window-list buffer nil frame))))) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 9ab5c336fd6..ef6bd89c36e 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -27,7 +27,7 @@ ;;; Code: -(eval '(run-hooks 'gnus-load-hook)) +(run-hooks 'gnus-load-hook) (eval-when-compile (require 'cl)) (require 'wid-edit) @@ -303,15 +303,9 @@ be set in `.emacs' instead." :group 'gnus-start :type 'boolean) -(unless (featurep 'gnus-xmas) - (defalias 'gnus-extent-detached-p 'ignore) - (defalias 'gnus-extent-start-open 'ignore) - (defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names) - (defalias 'gnus-character-to-event 'identity) - (defalias 'gnus-assq-delete-all 'assq-delete-all) - (defalias 'gnus-add-text-properties 'add-text-properties) - (defalias 'gnus-put-text-property 'put-text-property) - (defvar gnus-mode-line-image-cache t) +(defvar gnus-mode-line-image-cache t) + +(eval-and-compile (if (fboundp 'find-image) (defun gnus-mode-line-buffer-identification (line) (let ((str (car-safe line)) @@ -336,12 +330,7 @@ be set in `.emacs' instead." str) (list str)) line))) - (defalias 'gnus-mode-line-buffer-identification 'identity)) - (defalias 'gnus-deactivate-mark 'deactivate-mark) - (defalias 'gnus-window-edges 'window-edges) - (defalias 'gnus-key-press-event-p 'numberp) - ;;(defalias 'gnus-decode-rfc1522 'ignore) - ) + (defalias 'gnus-mode-line-buffer-identification 'identity))) ;; We define these group faces here to avoid the display ;; update forced when creating new faces. @@ -914,14 +903,20 @@ be set in `.emacs' instead." (defun gnus-add-buffer () "Add the current buffer to the list of Gnus buffers." + (gnus-prune-buffers) (push (current-buffer) gnus-buffers)) (defmacro gnus-kill-buffer (buffer) "Kill BUFFER and remove from the list of Gnus buffers." `(let ((buf ,buffer)) (when (gnus-buffer-exists-p buf) - (setq gnus-buffers (delete (get-buffer buf) gnus-buffers)) - (kill-buffer buf)))) + (kill-buffer buf) + (gnus-prune-buffers)))) + +(defun gnus-prune-buffers () + (dolist (buf gnus-buffers) + (unless (buffer-live-p buf) + (setq gnus-buffers (delete buf gnus-buffers))))) (defun gnus-buffers () "Return a list of live Gnus buffers." @@ -1002,7 +997,7 @@ be set in `.emacs' instead." "Color alist used for the Gnus logo.") (defcustom gnus-logo-color-style 'ma - "*Color styles used for the Gnus logo." + "Color styles used for the Gnus logo." :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem))) gnus-logo-color-alist)) :group 'gnus-xmas) @@ -1245,7 +1240,7 @@ in `.gnus.el'. Set this variable in `.emacs' instead." (defcustom gnus-directory (or (getenv "SAVEDIR") (nnheader-concat gnus-home-directory "News/")) - "*Directory variable from which all other Gnus file variables are derived. + "Directory variable from which all other Gnus file variables are derived. Note that Gnus is mostly loaded when the `.gnus.el' file is read. This means that other directory variables that are initialized from @@ -1255,7 +1250,7 @@ Set this variable in `.emacs' instead." :type 'directory) (defcustom gnus-default-directory nil - "*Default directory for all Gnus buffers." + "Default directory for all Gnus buffers." :group 'gnus-files :type '(choice (const :tag "current" nil) directory)) @@ -1326,7 +1321,7 @@ see the manual for details." :type 'gnus-select-method) (defcustom gnus-message-archive-method "archive" - "*Method used for archiving messages you've sent. + "Method used for archiving messages you've sent. This should be a mail method. See also `gnus-update-message-archive-method'." @@ -1352,7 +1347,7 @@ saved \"archive\" method to be updated whenever you change the value of :type 'boolean) (defcustom gnus-message-archive-group '((format-time-string "sent.%Y-%m")) - "*Name of the group in which to save the messages you've written. + "Name of the group in which to save the messages you've written. This can either be a string; a list of strings; or an alist of regexps/functions/forms to be evaluated to return a string (or a list of strings). The functions are called with the name of the current @@ -1438,7 +1433,7 @@ list, Gnus will try all the methods in the list until it finds a match." gnus-select-method)))) (defcustom gnus-use-cross-reference t - "*Non-nil means that cross referenced articles will be marked as read. + "Non-nil means that cross referenced articles will be marked as read. If nil, ignore cross references. If t, mark articles as read in subscribed newsgroups. If neither t nor nil, mark as read in all newsgroups." @@ -1449,13 +1444,13 @@ newsgroups." :value always))) (defcustom gnus-process-mark ?# - "*Process mark." + "Process mark." :group 'gnus-group-visual :group 'gnus-summary-marks :type 'character) (defcustom gnus-large-newsgroup 200 - "*The number of articles which indicates a large newsgroup. + "The number of articles which indicates a large newsgroup. If the number of articles in a newsgroup is greater than this value, confirmation is required for selecting the newsgroup. If it is nil, no confirmation is required. @@ -1489,24 +1484,24 @@ on all other systems it defaults to t." (const not-kill)))) (defcustom gnus-kill-files-directory gnus-directory - "*Name of the directory where kill files will be stored (default \"~/News\")." + "Name of the directory where kill files will be stored (default \"~/News\")." :group 'gnus-score-files :group 'gnus-score-kill :type 'directory) (defcustom gnus-save-score nil - "*If non-nil, save group scoring info." + "If non-nil, save group scoring info." :group 'gnus-score-various :group 'gnus-start :type 'boolean) (defcustom gnus-use-undo t - "*If non-nil, allow undoing in Gnus group mode buffers." + "If non-nil, allow undoing in Gnus group mode buffers." :group 'gnus-meta :type 'boolean) (defcustom gnus-use-adaptive-scoring nil - "*If non-nil, use some adaptive scoring scheme. + "If non-nil, use some adaptive scoring scheme. If a list, then the values `word' and `line' are meaningful. The former will perform adaption on individual words in the subject header while `line' will perform adaption on several headers." @@ -1515,7 +1510,7 @@ header while `line' will perform adaption on several headers." :type '(set (const word) (const line))) (defcustom gnus-use-cache 'passive - "*If nil, Gnus will ignore the article cache. + "If nil, Gnus will ignore the article cache. If `passive', it will allow entering (and reading) articles explicitly entered into the cache. If anything else, use the cache to the full extent of the law." @@ -1526,12 +1521,12 @@ cache to the full extent of the law." (const :tag "active" t))) (defcustom gnus-use-trees nil - "*If non-nil, display a thread tree buffer." + "If non-nil, display a thread tree buffer." :group 'gnus-meta :type 'boolean) (defcustom gnus-keep-backlog 20 - "*If non-nil, Gnus will keep read articles for later re-retrieval. + "If non-nil, Gnus will keep read articles for later re-retrieval. If it is a number N, then Gnus will only keep the last N articles read. If it is neither nil nor a number, Gnus will keep all read articles. This is not a good idea." @@ -1542,43 +1537,43 @@ articles. This is not a good idea." :value t))) (defcustom gnus-suppress-duplicates nil - "*If non-nil, Gnus will mark duplicate copies of the same article as read." + "If non-nil, Gnus will mark duplicate copies of the same article as read." :group 'gnus-meta :type 'boolean) (defcustom gnus-use-scoring t - "*If non-nil, enable scoring." + "If non-nil, enable scoring." :group 'gnus-meta :type 'boolean) (defcustom gnus-summary-prepare-exit-hook '(gnus-summary-expire-articles) - "*A hook called when preparing to exit from the summary buffer. + "A hook called when preparing to exit from the summary buffer. It calls `gnus-summary-expire-articles' by default." :group 'gnus-summary-exit :type 'hook) (defcustom gnus-novice-user t - "*Non-nil means that you are a Usenet novice. + "Non-nil means that you are a Usenet novice. If non-nil, verbose messages may be displayed and confirmations may be required." :group 'gnus-meta :type 'boolean) (defcustom gnus-expert-user nil - "*Non-nil means that you will never be asked for confirmation about anything. + "Non-nil means that you will never be asked for confirmation about anything. That doesn't mean *anything* anything; particularly destructive commands will still require prompting." :group 'gnus-meta :type 'boolean) (defcustom gnus-interactive-catchup t - "*If non-nil, require your confirmation when catching up a group." + "If non-nil, require your confirmation when catching up a group." :group 'gnus-group-select :type 'boolean) (defcustom gnus-interactive-exit t - "*If non-nil, require your confirmation when exiting Gnus. + "If non-nil, require your confirmation when exiting Gnus. If `quiet', update any active summary buffers automatically first before exiting." :group 'gnus-exit @@ -1586,7 +1581,7 @@ first before exiting." (const quiet))) (defcustom gnus-extract-address-components 'gnus-extract-address-components - "*Function for extracting address components from a From header. + "Function for extracting address components from a From header. Two pre-defined function exist: `gnus-extract-address-components', which is the default, quite fast, and too simplistic solution, and `mail-extract-address-components', which works much better, but is @@ -1622,7 +1617,7 @@ slower." server-marks cloud) ("nnmaildir" mail respool address server-marks) ("nnnil" none)) - "*An alist of valid select methods. + "An alist of valid select methods. The first element of each list lists should be a string with the name of the select method. The other elements may be the category of this method (i. e., `post', `mail', `none' or whatever) or other @@ -1681,7 +1676,7 @@ If this variable is nil, screen refresh may be quicker." (const tree))) (defcustom gnus-mode-non-string-length 30 - "*Max length of mode-line non-string contents. + "Max length of mode-line non-string contents. If this is nil, Gnus will take space as is needed, leaving the rest of the mode line intact." :version "24.1" @@ -1698,7 +1693,7 @@ of the mode line intact." :function-document "Return GROUP's to-address." :variable-document - "*Alist of group regexps and correspondent to-addresses." + "Alist of group regexps and correspondent to-addresses." :variable-group gnus-group-parameter :parameter-type '(gnus-email-address :tag "To Address") :parameter-document "\ @@ -1725,7 +1720,7 @@ address was listed in gnus-group-split Addresses (see below).") :function-document "Return GROUP's to-list." :variable-document - "*Alist of group regexps and correspondent to-lists." + "Alist of group regexps and correspondent to-lists." :variable-group gnus-group-parameter :parameter-type '(gnus-email-address :tag "To List") :parameter-document "\ @@ -1744,7 +1739,7 @@ address was listed in gnus-group-split Addresses (see below).") :function-document "Return GROUP's subscription status." :variable-document - "*Groups which are automatically considered subscribed." + "Groups which are automatically considered subscribed." :variable-group gnus-group-parameter :parameter-type '(const :tag "Subscribed" t) :parameter-document "\ @@ -1763,7 +1758,7 @@ above, or the list address (if the To address has not been set).") :variable gnus-auto-expirable-newsgroups :variable-default nil :variable-document - "*Groups in which to automatically mark read articles as expirable. + "Groups in which to automatically mark read articles as expirable. If non-nil, this should be a regexp that should match all groups in which to perform auto-expiry. This only makes sense for mail groups." :variable-group nnmail-expire @@ -1782,7 +1777,7 @@ which to perform auto-expiry. This only makes sense for mail groups." :variable gnus-total-expirable-newsgroups :variable-default nil :variable-document - "*Groups in which to perform expiry of all read articles. + "Groups in which to perform expiry of all read articles. Use with extreme caution. All groups that match this regexp will be expiring - which means that all read articles will be deleted after \(say) one week. (This only goes for mail groups and the like, of @@ -1851,7 +1846,7 @@ posting an article." :function-document "Return GROUP's initial input of the number of articles." :variable-document - "*Alist of group regexps and its initial input of the number of articles." + "Alist of group regexps and its initial input of the number of articles." :variable-group gnus-group-parameter :parameter-type '(choice :tag "Initial Input for Large Newsgroup" (const :tag "All" nil) @@ -1875,7 +1870,7 @@ total number of articles in the group.") '("delayed$" "drafts$" "queue$" "INBOX$" "^nnmairix:" "^nnir:" "archive")) :variable-document - "*Groups in which the registry should be turned off." + "Groups in which the registry should be turned off." :variable-group gnus-registry :variable-type '(repeat (list @@ -1888,7 +1883,7 @@ total number of articles in the group.") ;; group parameters for spam processing added by Ted Zlatanov <tzz@lifelogs.com> (defcustom gnus-install-group-spam-parameters t - "*Disable the group parameters for spam detection. + "Disable the group parameters for spam detection. Enable if `G c' in XEmacs is giving you trouble, and make sure to submit a bug report." :version "22.1" :type 'boolean @@ -1918,7 +1913,7 @@ registry.") :variable gnus-spam-newsgroup-contents :variable-default nil :variable-document - "*Group classification (spam, ham, or neither). Only + "Group classification (spam, ham, or neither). Only meaningful when spam.el is loaded. If non-nil, this should be a list of group name regexps associated with a classification for each one. In spam groups, new articles are marked as spam on @@ -2075,7 +2070,7 @@ Only applicable to non-spam (unclassified and ham) groups.") :variable gnus-spam-process-newsgroups :variable-default nil :variable-document - "*Groups in which to automatically process spam or ham articles with + "Groups in which to automatically process spam or ham articles with a backend on summary exit. If non-nil, this should be a list of group name regexps that should match all groups in which to do automatic spam processing, associated with the appropriate processor." @@ -2134,7 +2129,7 @@ spam processing, associated with the appropriate processor." :variable gnus-spam-autodetect :variable-default nil :variable-document - "*Groups in which spam should be autodetected when they are entered. + "Groups in which spam should be autodetected when they are entered. Only unseen articles will be examined, unless spam-autodetect-recheck-messages is set." :variable-group spam @@ -2180,7 +2175,7 @@ spam-autodetect-recheck-messages is set.") :variable gnus-spam-autodetect-methods :variable-default nil :variable-document - "*Methods for autodetecting spam per group. + "Methods for autodetecting spam per group. Requires the spam-autodetect parameter. Only unseen articles will be examined, unless spam-autodetect-recheck-messages is set." @@ -2232,7 +2227,7 @@ set.") :variable gnus-spam-process-destinations :variable-default nil :variable-document - "*Groups in which to explicitly send spam-processed articles to + "Groups in which to explicitly send spam-processed articles to another group, or expire them (the default). If non-nil, this should be a list of group name regexps that should match all groups in which to do spam-processed article moving, associated with the destination @@ -2269,7 +2264,7 @@ mail groups." :variable gnus-ham-process-destinations :variable-default nil :variable-document - "*Groups in which to explicitly send ham articles to + "Groups in which to explicitly send ham articles to another group, or do nothing (the default). If non-nil, this should be a list of group name regexps that should match all groups in which to do ham article moving, associated with the destination @@ -2314,7 +2309,7 @@ spam-ham-marks variable takes precedence." gnus-low-score-mark)))) :variable-group spam :variable-document - "*Groups in which to explicitly set the ham marks to some value.") + "Groups in which to explicitly set the ham marks to some value.") (gnus-define-group-parameter spam-marks @@ -2333,7 +2328,7 @@ spam-spam-marks variable takes precedence." :variable-default '((".*" ((gnus-spam-mark)))) :variable-group spam :variable-document - "*Groups in which to explicitly set the spam marks to some value.")) + "Groups in which to explicitly set the spam marks to some value.")) (defcustom gnus-group-uncollapsed-levels 1 "Number of group name elements to leave alone when making a short group name." @@ -2341,7 +2336,7 @@ spam-spam-marks variable takes precedence." :type 'integer) (defcustom gnus-group-use-permanent-levels nil - "*If non-nil, once you set a level, Gnus will use this level." + "If non-nil, once you set a level, Gnus will use this level." :group 'gnus-group-levels :type 'boolean) @@ -2389,7 +2384,7 @@ It is called with three parameters -- GROUP, LEVEL and OLDLEVEL." tree-highlight menu highlight browse-menu server-menu page-marker tree-menu binary-menu pick-menu) - "*Enable visual features. + "Enable visual features. If `visual' is disabled, there will be no menus and few faces. Most of the visual customization options below will be ignored. Gnus will use less space and be faster as a result. @@ -2442,14 +2437,14 @@ Valid elements include `summary-highlight', `group-highlight', 'highlight) 'default) (error 'highlight)) - "*Face used for group or summary buffer mouse highlighting. + "Face used for group or summary buffer mouse highlighting. The line beneath the mouse pointer will be highlighted with this face." :group 'gnus-visual :type 'face) (defcustom gnus-article-save-directory gnus-directory - "*Name of the directory articles will be saved in (default \"~/News\")." + "Name of the directory articles will be saved in (default \"~/News\")." :group 'gnus-article-saving :type 'directory) @@ -2503,16 +2498,11 @@ Disabling the agent may result in noticeable loss of performance." (function-item gnus-slave-no-server))) (defcustom gnus-other-frame-parameters nil - "Frame parameters used by `gnus-other-frame' to create a Gnus frame. -This should be an alist for Emacs, or a plist for XEmacs." + "Frame parameters used by `gnus-other-frame' to create a Gnus frame." :group 'gnus-start - :type (if (featurep 'xemacs) - '(repeat (list :inline t :format "%v" - (symbol :tag "Property") - (sexp :tag "Value"))) - '(repeat (cons :format "%v" - (symbol :tag "Parameter") - (sexp :tag "Value"))))) + :type '(repeat (cons :format "%v" + (symbol :tag "Parameter") + (sexp :tag "Value")))) (defcustom gnus-user-agent '(emacs gnus type) "Which information should be exposed in the User-Agent header. @@ -2606,7 +2596,7 @@ a string, be sure to use a valid format, see RFC 2616." (defcustom gnus-cache-directory (nnheader-concat gnus-directory "cache/") - "*The directory where cached articles will be stored." + "The directory where cached articles will be stored." :group 'gnus-cache :type 'directory) @@ -2940,7 +2930,7 @@ gnus-registry.el will populate this if it's loaded.") (defcustom gnus-summary-line-format "%U%R%z%I%(%[%4L: %-23,23f%]%) %s\n" - "*The format specification of the lines in the summary buffer. + "The format specification of the lines in the summary buffer. It works along the same lines as a normal formatting string, with some simple extensions. @@ -3026,7 +3016,7 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-suppress-keymap (keymap) (suppress-keymap keymap) - (let ((keys `([delete] "\177" "\M-u"))) ;gnus-mouse-2 + (let ((keys `([delete] "\177" "\M-u"))) ;[mouse-2] (while keys (define-key keymap (pop keys) 'undefined)))) @@ -3155,10 +3145,6 @@ Return nil if not defined." (setcar (nthcdr 2 (gnus-gethash group gnus-newsrc-hashtb)) info)) -;;; Load the compatibility functions. - -(require 'gnus-ems) - ;;; ;;; Shutdown @@ -3243,8 +3229,7 @@ If ARG, insert string at point." 4.99 (+ 5 (* 0.02 (abs - (- (mm-char-int (aref (downcase alpha) 0)) - (mm-char-int ?t)))) + (- (aref (downcase alpha) 0) ?t))) -0.01)) minor least) (format "%d.%02d%02d" major minor least)))))) @@ -3448,7 +3433,7 @@ that that variable is buffer-local to the summary buffers." (defun gnus-simplify-mode-line () "Make mode lines a bit simpler." - (setq mode-line-modified (cdr gnus-mode-line-modified)) + (setq mode-line-modified "--") (when (listp mode-line-format) (make-local-variable 'mode-line-format) (setq mode-line-format (copy-sequence mode-line-format)) @@ -4386,12 +4371,12 @@ current display is used." (with-current-buffer (window-buffer window) (string-match "\\`gnus-" (symbol-name major-mode)))) - (gnus-select-frame-set-input-focus + (select-frame-set-input-focus (setq gnus-other-frame-object (window-frame window))) (select-window window) (throw 'found t))) 'ignore t))) - (gnus-select-frame-set-input-focus + (select-frame-set-input-focus (setq gnus-other-frame-object (if display (make-frame-on-display display gnus-other-frame-parameters) @@ -4435,10 +4420,6 @@ prompt the user for the name of an NNTP server to use." (require 'debbugs-gnu) (debbugs-gnu nil "gnus")) -;; Allow redefinition of Gnus functions. - -(gnus-ems-redefine) - (provide 'gnus) ;;; gnus.el ends here diff --git a/lisp/gnus/gravatar.el b/lisp/gnus/gravatar.el deleted file mode 100644 index 2a2bdf4fc8e..00000000000 --- a/lisp/gnus/gravatar.el +++ /dev/null @@ -1,166 +0,0 @@ -;;; gravatar.el --- Get Gravatars - -;; Copyright (C) 2010-2017 Free Software Foundation, Inc. - -;; Author: Julien Danjou <julien@danjou.info> -;; 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: - -;;; Code: - -(require 'url) -(require 'url-cache) - -(defgroup gravatar nil - "Gravatar." - :version "24.1" - :group 'comm) - -(defcustom gravatar-automatic-caching t - "Whether to cache retrieved gravatars." - :type 'boolean - :group 'gravatar) - -;; FIXME a time value is not the nicest format for a custom variable. -(defcustom gravatar-cache-ttl (days-to-time 30) - "Time to live for gravatar cache entries." - :type '(repeat integer) - :group 'gravatar) - -;; FIXME Doc is tautological. What are the options? -(defcustom gravatar-rating "g" - "Default rating for gravatar." - :type 'string - :group 'gravatar) - -(defcustom gravatar-size 32 - "Default size in pixels for gravatars." - :type 'integer - :group 'gravatar) - -(defconst gravatar-base-url - "http://www.gravatar.com/avatar" - "Base URL for getting gravatars.") - -(defun gravatar-hash (mail-address) - "Create an hash from MAIL-ADDRESS." - (md5 (downcase mail-address))) - -(defun gravatar-build-url (mail-address) - "Return an URL to retrieve MAIL-ADDRESS gravatar." - (format "%s/%s?d=404&r=%s&s=%d" - gravatar-base-url - (gravatar-hash mail-address) - gravatar-rating - gravatar-size)) - -(defun gravatar-cache-expired (url) - "Check if URL is cached for more than `gravatar-cache-ttl'." - (cond (url-standalone-mode - (not (file-exists-p (url-cache-create-filename url)))) - (t (let ((cache-time (url-is-cached url))) - (if cache-time - (time-less-p - (time-add - cache-time - gravatar-cache-ttl) - (current-time)) - t))))) - -(defun gravatar-get-data () - "Get data from current buffer." - (save-excursion - (goto-char (point-min)) - (when (re-search-forward "^HTTP/.+ 200 OK$" nil (line-end-position)) - (when (search-forward "\n\n" nil t) - (buffer-substring (point) (point-max)))))) - -(eval-and-compile - (cond ((featurep 'xemacs) - (require 'gnus-xmas) - (defalias 'gravatar-create-image 'gnus-xmas-create-image)) - ((featurep 'gnus-ems) - (defalias 'gravatar-create-image 'gnus-create-image)) - (t - (require 'image) - (defalias 'gravatar-create-image 'create-image)))) - -(defun gravatar-data->image () - "Get data of current buffer and return an image. -If no image available, return 'error." - (let ((data (gravatar-get-data))) - (if data - (gravatar-create-image data nil t) - 'error))) - -(autoload 'help-function-arglist "help-fns") - -;;;###autoload -(defun gravatar-retrieve (mail-address cb &optional cbargs) - "Retrieve MAIL-ADDRESS gravatar and call CB on retrieval. -You can provide a list of argument to pass to CB in CBARGS." - (let ((url (gravatar-build-url mail-address))) - (if (gravatar-cache-expired url) - (let ((args (list url - 'gravatar-retrieved - (list cb (when cbargs cbargs))))) - (when (> (length (if (featurep 'xemacs) - (cdr (split-string (function-arglist 'url-retrieve))) - (help-function-arglist 'url-retrieve))) - 4) - (setq args (nconc args (list t)))) - (apply #'url-retrieve args)) - (apply cb - (with-temp-buffer - (mm-disable-multibyte) - (url-cache-extract (url-cache-create-filename url)) - (gravatar-data->image)) - cbargs)))) - -;;;###autoload -(defun gravatar-retrieve-synchronously (mail-address) - "Retrieve MAIL-ADDRESS gravatar and returns it." - (let ((url (gravatar-build-url mail-address))) - (if (gravatar-cache-expired url) - (with-current-buffer (url-retrieve-synchronously url) - (when gravatar-automatic-caching - (url-store-in-cache (current-buffer))) - (let ((data (gravatar-data->image))) - (kill-buffer (current-buffer)) - data)) - (with-temp-buffer - (mm-disable-multibyte) - (url-cache-extract (url-cache-create-filename url)) - (gravatar-data->image))))) - - -(defun gravatar-retrieved (status cb &optional cbargs) - "Callback function used by `gravatar-retrieve'." - ;; Store gravatar? - (when gravatar-automatic-caching - (url-store-in-cache (current-buffer))) - (if (plist-get status :error) - ;; Error happened. - (apply cb 'error cbargs) - (apply cb (gravatar-data->image) cbargs)) - (kill-buffer (current-buffer))) - -(provide 'gravatar) - -;;; gravatar.el ends here diff --git a/lisp/gnus/html2text.el b/lisp/gnus/html2text.el deleted file mode 100644 index 87c71dc504a..00000000000 --- a/lisp/gnus/html2text.el +++ /dev/null @@ -1,461 +0,0 @@ -;;; html2text.el --- a simple html to plain text converter -*- coding: utf-8 -*- - -;; Copyright (C) 2002-2017 Free Software Foundation, Inc. - -;; Author: Joakim Hove <hove@phys.ntnu.no> - -;; 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: - -;; These functions provide a simple way to wash/clean html infected -;; mails. Definitely do not work in all cases, but some improvement -;; in readability is generally obtained. Formatting is only done in -;; the buffer, so the next time you enter the article it will be -;; "re-htmlized". -;; -;; The main function is `html2text'. - -;;; Code: - -;; -;; <Global variables> -;; - -(eval-when-compile - (require 'cl)) - -(defvar html2text-format-single-element-list '(("hr" . html2text-clean-hr))) - -(defvar html2text-replace-list - '(("´" . "`") - ("&" . "&") - ("'" . "'") - ("¦" . "|") - ("¢" . "c") - ("ˆ" . "^") - ("©" . "(C)") - ("¤" . "(#)") - ("°" . "degree") - ("÷" . "/") - ("€" . "e") - ("½" . "1/2") - (">" . ">") - ("¿" . "?") - ("«" . "<<") - ("&ldquo" . "\"") - ("‹" . "(") - ("‘" . "`") - ("<" . "<") - ("—" . "--") - (" " . " ") - ("–" . "-") - ("‰" . "%%") - ("±" . "+-") - ("£" . "£") - (""" . "\"") - ("»" . ">>") - ("&rdquo" . "\"") - ("®" . "(R)") - ("›" . ")") - ("’" . "'") - ("§" . "§") - ("¹" . "^1") - ("²" . "^2") - ("³" . "^3") - ("˜" . "~")) - "The map of entity to text. - -This is an alist were each element is a dotted pair consisting of an -old string, and a replacement string. This replacement is done by the -function `html2text-substitute' which basically performs a -`replace-string' operation for every element in the list. This is -completely verbatim - without any use of REGEXP.") - -(defvar html2text-remove-tag-list - '("html" "body" "p" "img" "dir" "head" "div" "br" "font" "title" "meta") - "A list of removable tags. - -This is a list of tags which should be removed, without any -formatting. Note that tags in the list are presented *without* -any \"<\" or \">\". All occurrences of a tag appearing in this -list are removed, irrespective of whether it is a closing or -opening tag, or if the tag has additional attributes. The -deletion is done by the function `html2text-remove-tags'. - -For instance the text: - -\"Here comes something <font size\"+3\" face=\"Helvetica\"> big </font>.\" - -will be reduced to: - -\"Here comes something big.\" - -If this list contains the element \"font\".") - -(defvar html2text-format-tag-list - '(("b" . html2text-clean-bold) - ("strong" . html2text-clean-bold) - ("u" . html2text-clean-underline) - ("i" . html2text-clean-italic) - ("em" . html2text-clean-italic) - ("blockquote" . html2text-clean-blockquote) - ("a" . html2text-clean-anchor) - ("ul" . html2text-clean-ul) - ("ol" . html2text-clean-ol) - ("dl" . html2text-clean-dl) - ("center" . html2text-clean-center)) - "An alist of tags and processing functions. - -This is an alist where each dotted pair consists of a tag, and then -the name of a function to be called when this tag is found. The -function is called with the arguments p1, p2, p3 and p4. These are -demonstrated below: - -\"<b> This is bold text </b>\" - ^ ^ ^ ^ - | | | | -p1 p2 p3 p4 - -Then the called function will typically format the text somewhat and -remove the tags.") - -(defvar html2text-remove-tag-list2 '("li" "dt" "dd" "meta") - "Another list of removable tags. - -This is a list of tags which are removed similarly to the list -`html2text-remove-tag-list' - but these tags are retained for the -formatting, and then moved afterward.") - -;; -;; </Global variables> -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; <Utility functions> -;; - - -(defun html2text-replace-string (from-string to-string min max) - "Replace FROM-STRING with TO-STRING in region from MIN to MAX." - (goto-char min) - (let ((delta (- (string-width to-string) (string-width from-string))) - (change 0)) - (while (search-forward from-string max t) - (replace-match to-string) - (setq change (+ change delta))) - change)) - -;; -;; </Utility functions> -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; <Functions related to attributes> i.e. <font size=+3> -;; - -(defun html2text-attr-value (list attribute) - "Get value of ATTRIBUTE from LIST." - (nth 1 (assoc attribute list))) - -(defun html2text-get-attr (p1 p2) - (goto-char p1) - (re-search-forward "\\s-+" p2 t) - (let (attr-list) - (while (re-search-forward "[-a-z0-9._]+" p2 t) - (setq attr-list - (cons - (list (match-string 0) - (when (looking-at "\\s-*=") - (goto-char (match-end 0)) - (skip-chars-forward "[:space:]") - (when (or (looking-at "\"[^\"]*\"\\|'[^']*'") - (looking-at "[-a-z0-9._:]+")) - (goto-char (match-end 0)) - (match-string 0)))) - attr-list))) - attr-list)) - -;; -;; </Functions related to attributes> -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; <Functions to be called to format a tag-pair> -;; -(defun html2text-clean-list-items (p1 p2 list-type) - (goto-char p1) - (let ((item-nr 0) - (items 0)) - (while (search-forward "<li>" p2 t) - (setq items (1+ items))) - (goto-char p1) - (while (< item-nr items) - (setq item-nr (1+ item-nr)) - (search-forward "<li>" (point-max) t) - (cond - ((string= list-type "ul") (insert " o ")) - ((string= list-type "ol") (insert (format " %s: " item-nr))) - (t (insert " x ")))))) - -(defun html2text-clean-dtdd (p1 p2) - (goto-char p1) - (let ((items 0) - (item-nr 0)) - (while (search-forward "<dt>" p2 t) - (setq items (1+ items))) - (goto-char p1) - (while (< item-nr items) - (setq item-nr (1+ item-nr)) - (re-search-forward "<dt>\\([ ]*\\)" (point-max) t) - (when (match-string 1) - (delete-region (point) (- (point) (string-width (match-string 1))))) - (let ((def-p1 (point)) - (def-p2 0)) - (re-search-forward "\\([ ]*\\)\\(</dt>\\|<dd>\\)" (point-max) t) - (if (match-string 1) - (progn - (let* ((mw1 (string-width (match-string 1))) - (mw2 (string-width (match-string 2))) - (mw (+ mw1 mw2))) - (goto-char (- (point) mw)) - (delete-region (point) (+ (point) mw1)) - (setq def-p2 (point)))) - (setq def-p2 (- (point) (string-width (match-string 2))))) - (put-text-property def-p1 def-p2 'face 'bold))))) - -(defun html2text-delete-tags (p1 p2 p3 p4) - (delete-region p1 p2) - (delete-region (- p3 (- p2 p1)) (- p4 (- p2 p1)))) - -(defun html2text-delete-single-tag (p1 p2) - (delete-region p1 p2)) - -(defun html2text-clean-hr (p1 p2) - (html2text-delete-single-tag p1 p2) - (goto-char p1) - (newline 1) - (insert (make-string fill-column ?-))) - -(defun html2text-clean-ul (p1 p2 p3 p4) - (html2text-delete-tags p1 p2 p3 p4) - (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ul")) - -(defun html2text-clean-ol (p1 p2 p3 p4) - (html2text-delete-tags p1 p2 p3 p4) - (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ol")) - -(defun html2text-clean-dl (p1 p2 p3 p4) - (html2text-delete-tags p1 p2 p3 p4) - (html2text-clean-dtdd p1 (- p3 (- p1 p2)))) - -(defun html2text-clean-center (p1 p2 p3 p4) - (html2text-delete-tags p1 p2 p3 p4) - (center-region p1 (- p3 (- p2 p1)))) - -(defun html2text-clean-bold (p1 p2 p3 p4) - (put-text-property p2 p3 'face 'bold) - (html2text-delete-tags p1 p2 p3 p4)) - -(defun html2text-clean-title (p1 p2 p3 p4) - (put-text-property p2 p3 'face 'bold) - (html2text-delete-tags p1 p2 p3 p4)) - -(defun html2text-clean-underline (p1 p2 p3 p4) - (put-text-property p2 p3 'face 'underline) - (html2text-delete-tags p1 p2 p3 p4)) - -(defun html2text-clean-italic (p1 p2 p3 p4) - (put-text-property p2 p3 'face 'italic) - (html2text-delete-tags p1 p2 p3 p4)) - -(defun html2text-clean-font (p1 p2 p3 p4) - (html2text-delete-tags p1 p2 p3 p4)) - -(defun html2text-clean-blockquote (p1 p2 p3 p4) - (html2text-delete-tags p1 p2 p3 p4)) - -(defun html2text-clean-anchor (p1 p2 p3 p4) - ;; If someone can explain how to make the URL clickable I will surely - ;; improve upon this. - ;; Maybe `goto-addr.el' can be used here. - (let* ((attr-list (html2text-get-attr p1 p2)) - (href (html2text-attr-value attr-list "href"))) - (delete-region p1 p4) - (when href - (goto-char p1) - (insert (if (string-match "\\`['\"].*['\"]\\'" href) - (substring href 1 -1) href)) - (put-text-property p1 (point) 'face 'bold)))) - -;; -;; </Functions to be called to format a tag-pair> -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; <Functions to be called to fix up paragraphs> -;; - -(defun html2text-fix-paragraph (p1 p2) - (goto-char p1) - (let ((refill-start) - (refill-stop)) - (when (re-search-forward "<br>$" p2 t) - (goto-char p1) - (when (re-search-forward ".+[^<][^b][^r][^>]$" p2 t) - (beginning-of-line) - (setq refill-start (point)) - (goto-char p2) - (re-search-backward ".+[^<][^b][^r][^>]$" refill-start t) - (forward-line 1) - (end-of-line) - ;; refill-stop should ideally be adjusted to - ;; accommodate the "<br>" strings which are removed - ;; between refill-start and refill-stop. Can simply - ;; be returned from my-replace-string - (setq refill-stop (+ (point) - (html2text-replace-string - "<br>" "" - refill-start (point)))) - ;; (message "Point = %s refill-stop = %s" (point) refill-stop) - ;; (sleep-for 4) - (fill-region refill-start refill-stop)))) - (html2text-replace-string "<br>" "" p1 p2)) - -;; -;; This one is interactive ... -;; -(defun html2text-fix-paragraphs () - "This _tries_ to fix up the paragraphs - this is done in quite a ad-hook -fashion, quite close to pure guess-work. It does work in some cases though." - (interactive) - (goto-char (point-min)) - (while (re-search-forward "^<br>$" nil t) - (delete-region (match-beginning 0) (match-end 0))) - ;; Removing lonely <br> on a single line, if they are left intact we - ;; don't have any paragraphs at all. - (goto-char (point-min)) - (while (not (eobp)) - (let ((p1 (point))) - (forward-paragraph 1) - ;;(message "Kaller fix med p1=%s p2=%s " p1 (1- (point))) (sleep-for 5) - (html2text-fix-paragraph p1 (1- (point))) - (goto-char p1) - (when (not (eobp)) - (forward-paragraph 1))))) - -;; -;; </Functions to be called to fix up paragraphs> -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; <Interactive functions> -;; - -(defun html2text-remove-tags (tag-list) - "Removes the tags listed in the list `html2text-remove-tag-list'. -See the documentation for that variable." - (interactive) - (dolist (tag tag-list) - (goto-char (point-min)) - (while (re-search-forward (format "\\(</?%s[^>]*>\\)" tag) (point-max) t) - (delete-region (match-beginning 0) (match-end 0))))) - -(defun html2text-format-tags () - "See the variable `html2text-format-tag-list' for documentation." - (interactive) - (dolist (tag-and-function html2text-format-tag-list) - (let ((tag (car tag-and-function)) - (function (cdr tag-and-function))) - (goto-char (point-min)) - (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag) - (point-max) t) - (let ((p1) - (p2 (point)) - (p3) (p4)) - (search-backward "<" (point-min) t) - (setq p1 (point)) - (unless (search-forward (format "</%s>" tag) (point-max) t) - (goto-char p2) - (insert (format "</%s>" tag))) - (setq p4 (point)) - (search-backward "</" (point-min) t) - (setq p3 (point)) - (funcall function p1 p2 p3 p4) - (goto-char p1)))))) - -(defun html2text-substitute () - "See the variable `html2text-replace-list' for documentation." - (interactive) - (dolist (e html2text-replace-list) - (goto-char (point-min)) - (let ((old-string (car e)) - (new-string (cdr e))) - (html2text-replace-string old-string new-string (point-min) (point-max))))) - -(defun html2text-format-single-elements () - (interactive) - (dolist (tag-and-function html2text-format-single-element-list) - (let ((tag (car tag-and-function)) - (function (cdr tag-and-function))) - (goto-char (point-min)) - (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag) - (point-max) t) - (let ((p1) - (p2 (point))) - (search-backward "<" (point-min) t) - (setq p1 (point)) - (funcall function p1 p2)))))) - -;; -;; Main function -;; - -;;;###autoload -(defun html2text () - "Convert HTML to plain text in the current buffer." - (interactive) - (save-excursion - (let ((case-fold-search t) - (buffer-read-only)) - (html2text-remove-tags html2text-remove-tag-list) - (html2text-format-tags) - (html2text-remove-tags html2text-remove-tag-list2) - (html2text-substitute) - (html2text-format-single-elements) - (html2text-fix-paragraphs)))) - -;; -;; </Interactive functions> -;; -(provide 'html2text) - -;;; html2text.el ends here diff --git a/lisp/gnus/ietf-drums.el b/lisp/gnus/ietf-drums.el deleted file mode 100644 index 5674132bd20..00000000000 --- a/lisp/gnus/ietf-drums.el +++ /dev/null @@ -1,297 +0,0 @@ -;;; ietf-drums.el --- Functions for parsing RFC822bis headers - -;; Copyright (C) 1998-2017 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; 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: - -;; DRUMS is an IETF Working Group that works (or worked) on the -;; successor to RFC822, "Standard For The Format Of Arpa Internet Text -;; Messages". This library is based on -;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05. - -;; Pending a real regression self test suite, Simon Josefsson added -;; various self test expressions snipped from bug reports, and their -;; expected value, below. I you believe it could be useful, please -;; add your own test cases, or write a real self test suite, or just -;; remove this. - -;; <m3oekvfd50.fsf@whitebox.m5r.de> -;; (ietf-drums-parse-address "'foo' <foo@example.com>") -;; => ("foo@example.com" . "'foo'") - -;;; Code: - -(eval-when-compile (require 'cl)) -(require 'mm-util) - -(defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177" - "US-ASCII control characters excluding CR, LF and white space.") -(defvar ietf-drums-text-token "\001-\011\013\014\016-\177" - "US-ASCII characters excluding CR and LF.") -(defvar ietf-drums-specials-token "()<>[]:;@\\,.\"" - "Special characters.") -(defvar ietf-drums-quote-token "\\" - "Quote character.") -(defvar ietf-drums-wsp-token " \t" - "White space.") -(defvar ietf-drums-fws-regexp - (concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+") - "Folding white space.") -(defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~" - "Textual token.") -(defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~." - "Textual token including full stop.") -(defvar ietf-drums-qtext-token - (concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177") - "Non-white-space control characters, plus the rest of ASCII excluding -backslash and doublequote.") -(defvar ietf-drums-tspecials "][()<>@,;:\\\"/?=" - "Tspecials.") - -(defvar ietf-drums-syntax-table - (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) - (modify-syntax-entry ?\\ "/" table) - (modify-syntax-entry ?< "(" table) - (modify-syntax-entry ?> ")" table) - (modify-syntax-entry ?@ "w" table) - (modify-syntax-entry ?/ "w" table) - (modify-syntax-entry ?* "_" table) - (modify-syntax-entry ?\; "_" table) - (modify-syntax-entry ?\' "_" table) - (if (featurep 'xemacs) - (let ((i 128)) - (while (< i 256) - (modify-syntax-entry i "w" table) - (setq i (1+ i))))) - table)) - -(defun ietf-drums-token-to-list (token) - "Translate TOKEN into a list of characters." - (let ((i 0) - b e c out range) - (while (< i (length token)) - (setq c (mm-char-int (aref token i))) - (incf i) - (cond - ((eq c (mm-char-int ?-)) - (if b - (setq range t) - (push c out))) - (range - (while (<= b c) - (push (make-char 'ascii b) out) - (incf b)) - (setq range nil)) - ((= i (length token)) - (push (make-char 'ascii c) out)) - (t - (when b - (push (make-char 'ascii b) out)) - (setq b c)))) - (nreverse out))) - -(defsubst ietf-drums-init (string) - (set-syntax-table ietf-drums-syntax-table) - (insert string) - (ietf-drums-unfold-fws) - (goto-char (point-min))) - -(defun ietf-drums-remove-comments (string) - "Remove comments from STRING." - (with-temp-buffer - (let (c) - (ietf-drums-init string) - (while (not (eobp)) - (setq c (char-after)) - (cond - ((eq c ?\") - (condition-case err - (forward-sexp 1) - (error (goto-char (point-max))))) - ((eq c ?\() - (delete-region - (point) - (condition-case nil - (with-syntax-table (copy-syntax-table ietf-drums-syntax-table) - (modify-syntax-entry ?\" "w") - (forward-sexp 1) - (point)) - (error (point-max))))) - (t - (forward-char 1)))) - (buffer-string)))) - -(defun ietf-drums-remove-whitespace (string) - "Remove whitespace from STRING." - (with-temp-buffer - (ietf-drums-init string) - (let (c) - (while (not (eobp)) - (setq c (char-after)) - (cond - ((eq c ?\") - (forward-sexp 1)) - ((eq c ?\() - (forward-sexp 1)) - ((memq c '(?\ ?\t ?\n)) - (delete-char 1)) - (t - (forward-char 1)))) - (buffer-string)))) - -(defun ietf-drums-get-comment (string) - "Return the first comment in STRING." - (with-temp-buffer - (ietf-drums-init string) - (let (result c) - (while (not (eobp)) - (setq c (char-after)) - (cond - ((eq c ?\") - (forward-sexp 1)) - ((eq c ?\() - (setq result - (buffer-substring - (1+ (point)) - (progn (forward-sexp 1) (1- (point)))))) - (t - (forward-char 1)))) - result))) - -(defun ietf-drums-strip (string) - "Remove comments and whitespace from STRING." - (ietf-drums-remove-whitespace (ietf-drums-remove-comments string))) - -(defun ietf-drums-parse-address (string) - "Parse STRING and return a MAILBOX / DISPLAY-NAME pair." - (with-temp-buffer - (let (display-name mailbox c display-string) - (ietf-drums-init string) - (while (not (eobp)) - (setq c (char-after)) - (cond - ((or (eq c ? ) - (eq c ?\t)) - (forward-char 1)) - ((eq c ?\() - (forward-sexp 1)) - ((eq c ?\") - (push (buffer-substring - (1+ (point)) (progn (forward-sexp 1) (1- (point)))) - display-name)) - ((looking-at (concat "[" ietf-drums-atext-token "@" "]")) - (push (buffer-substring (point) (progn (forward-sexp 1) (point))) - display-name)) - ((eq c ?<) - (setq mailbox - (ietf-drums-remove-whitespace - (ietf-drums-remove-comments - (buffer-substring - (1+ (point)) - (progn (forward-sexp 1) (1- (point)))))))) - (t - (forward-char 1)))) - ;; If we found no display-name, then we look for comments. - (if display-name - (setq display-string - (mapconcat 'identity (reverse display-name) " ")) - (setq display-string (ietf-drums-get-comment string))) - (if (not mailbox) - (when (and display-string - (string-match "@" display-string)) - (cons - (mapconcat 'identity (nreverse display-name) "") - (ietf-drums-get-comment string))) - (cons mailbox display-string))))) - -(defun ietf-drums-parse-addresses (string &optional rawp) - "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs. -If RAWP, don't actually parse the addresses, but instead return -a list of address strings." - (if (null string) - nil - (with-temp-buffer - (ietf-drums-init string) - (let ((beg (point)) - pairs c address) - (while (not (eobp)) - (setq c (char-after)) - (cond - ((memq c '(?\" ?< ?\()) - (condition-case nil - (forward-sexp 1) - (error - (skip-chars-forward "^,")))) - ((eq c ?,) - (setq address - (if rawp - (buffer-substring beg (point)) - (condition-case nil - (ietf-drums-parse-address - (buffer-substring beg (point))) - (error nil)))) - (if address (push address pairs)) - (forward-char 1) - (setq beg (point))) - (t - (forward-char 1)))) - (setq address - (if rawp - (buffer-substring beg (point)) - (condition-case nil - (ietf-drums-parse-address - (buffer-substring beg (point))) - (error nil)))) - (if address (push address pairs)) - (nreverse pairs))))) - -(defun ietf-drums-unfold-fws () - "Unfold folding white space in the current buffer." - (goto-char (point-min)) - (while (re-search-forward ietf-drums-fws-regexp nil t) - (replace-match " " t t)) - (goto-char (point-min))) - -(defun ietf-drums-parse-date (string) - "Return an Emacs time spec from STRING." - (apply 'encode-time (parse-time-string string))) - -(defun ietf-drums-narrow-to-header () - "Narrow to the header section in the current buffer." - (narrow-to-region - (goto-char (point-min)) - (if (re-search-forward "^\r?$" nil 1) - (match-beginning 0) - (point-max))) - (goto-char (point-min))) - -(defun ietf-drums-quote-string (string) - "Quote string if it needs quoting to be displayed in a header." - (if (string-match (concat "[^" ietf-drums-atext-token "]") string) - (concat "\"" string "\"") - string)) - -(defun ietf-drums-make-address (name address) - (if name - (concat (ietf-drums-quote-string name) " <" address ">") - address)) - -(provide 'ietf-drums) - -;;; ietf-drums.el ends here diff --git a/lisp/gnus/legacy-gnus-agent.el b/lisp/gnus/legacy-gnus-agent.el index 75d6bef68fa..e51181ef5f8 100644 --- a/lisp/gnus/legacy-gnus-agent.el +++ b/lisp/gnus/legacy-gnus-agent.el @@ -148,17 +148,17 @@ converted to the compressed format." (gnus-pp gnus-agent-expire-days) (insert - (gnus-format-message + (format-message "\nIn order to use version `%s' of gnus, you will need to set\n" converting-to)) (insert "gnus-agent-expire-days to an integer. If you still wish to set different\n") (insert "expiration days to individual groups, you must instead set the\n") - (insert (gnus-format-message + (insert (format-message "`agent-days-until-old' group and/or topic parameter.\n")) (insert "\n") (insert "If you would like, gnus can iterate over every group comparing its name to the\n") (insert "regular expressions that you currently have in gnus-agent-expire-days. When\n") - (insert (gnus-format-message + (insert (format-message "gnus finds a match, it will update that group's `agent-days-until-old' group\n")) (insert "parameter to the value associated with the regular expression.\n") (insert "\n") diff --git a/lisp/gnus/mail-parse.el b/lisp/gnus/mail-parse.el deleted file mode 100644 index 546673db6fd..00000000000 --- a/lisp/gnus/mail-parse.el +++ /dev/null @@ -1,75 +0,0 @@ -;;; mail-parse.el --- Interface functions for parsing mail - -;; Copyright (C) 1998-2017 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; 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: - -;; This file contains wrapper functions for a wide range of mail -;; parsing functions. The idea is that there are low-level libraries -;; that implement according to various specs (RFC2231, DRUMS, USEFOR), -;; but that programmers that want to parse some header (say, -;; Content-Type) will want to use the latest spec. -;; -;; So while each low-level library (rfc2231.el, for instance) decodes -;; faithfully according to that (proposed) standard, this library is -;; the interface library. If some later RFC supersedes RFC2231, one -;; would just have to write a new low-level library, adjust the -;; aliases in this library, and the users and programmers won't notice -;; any changes. - -;;; Code: - -(require 'mail-prsvr) -(require 'ietf-drums) -(require 'rfc2231) -(require 'rfc2047) -(require 'rfc2045) - -(defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string) -(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string) -(defalias 'mail-content-type-get 'rfc2231-get-value) -(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter) - -(defalias 'mail-header-remove-comments 'ietf-drums-remove-comments) -(defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace) -(defalias 'mail-header-strip 'ietf-drums-strip) -(defalias 'mail-header-get-comment 'ietf-drums-get-comment) -(defalias 'mail-header-parse-address 'ietf-drums-parse-address) -(defalias 'mail-header-parse-addresses 'ietf-drums-parse-addresses) -(defalias 'mail-header-parse-date 'ietf-drums-parse-date) -(defalias 'mail-narrow-to-head 'ietf-drums-narrow-to-header) -(defalias 'mail-quote-string 'ietf-drums-quote-string) -(defalias 'mail-header-make-address 'ietf-drums-make-address) - -(defalias 'mail-header-fold-field 'rfc2047-fold-field) -(defalias 'mail-header-unfold-field 'rfc2047-unfold-field) -(defalias 'mail-header-narrow-to-field 'rfc2047-narrow-to-field) -(defalias 'mail-header-field-value 'rfc2047-field-value) - -(defalias 'mail-encode-encoded-word-region 'rfc2047-encode-region) -(defalias 'mail-encode-encoded-word-buffer 'rfc2047-encode-message-header) -(defalias 'mail-encode-encoded-word-string 'rfc2047-encode-string) -(defalias 'mail-decode-encoded-word-region 'rfc2047-decode-region) -(defalias 'mail-decode-encoded-word-string 'rfc2047-decode-string) -(defalias 'mail-decode-encoded-address-region 'rfc2047-decode-address-region) -(defalias 'mail-decode-encoded-address-string 'rfc2047-decode-address-string) - -(provide 'mail-parse) - -;;; mail-parse.el ends here diff --git a/lisp/gnus/mail-prsvr.el b/lisp/gnus/mail-prsvr.el deleted file mode 100644 index 07f650942c0..00000000000 --- a/lisp/gnus/mail-prsvr.el +++ /dev/null @@ -1,43 +0,0 @@ -;;; mail-prsvr.el --- Interface variables for parsing mail - -;; Copyright (C) 1999-2017 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; 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: - -(defvar mail-parse-charset nil - "Default charset used by low-level libraries. -This variable should never be set. Instead, it should be bound by -functions that wish to call mail-parse functions and let them know -what the desired charset is to be.") - -(defvar mail-parse-mule-charset nil - "Default MULE charset used by low-level libraries. -This variable should never be set.") - -(defvar mail-parse-ignored-charsets nil - "Ignored charsets used by low-level libraries. -This variable should never be set. Instead, it should be bound by -functions that wish to call mail-parse functions and let them know -what the desired charsets is to be ignored.") - -(provide 'mail-prsvr) - -;;; mail-prsvr.el ends here diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 8f12d3f965d..e15d820a274 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -66,7 +66,7 @@ See Info node `(gnus)Mail Source Specifiers'." (repeat :tag "List" (choice :format "%[Value Menu%] %v" :value (file) - (cons :tag "Group parameter `mail-source'" + (list :tag "Group parameter `mail-source'" (const :format "" group)) (cons :tag "Spool file" (const :format "" file) @@ -228,7 +228,7 @@ Leave mails for this many days" :value 14))))) (boolean :tag "Plugged")))))))) (defcustom mail-source-ignore-errors nil - "*Ignore errors when querying mail sources. + "Ignore errors when querying mail sources. If nil, the user will be prompted when an error occurs. If non-nil, the error will be ignored." :version "22.1" @@ -236,13 +236,13 @@ the error will be ignored." :type 'boolean) (defcustom mail-source-primary-source nil - "*Primary source for incoming mail. + "Primary source for incoming mail. If non-nil, this maildrop will be checked periodically for new mail." :group 'mail-source :type 'sexp) (defcustom mail-source-flash t - "*If non-nil, flash periodically when mail is available." + "If non-nil, flash periodically when mail is available." :group 'mail-source :type 'boolean) @@ -603,8 +603,8 @@ If CONFIRM is non-nil, ask for confirmation before removing a file." currday (+ currday (* low2days (nth 1 (current-time))))) (while files (let* ((ffile (car files)) - (bfile (gnus-replace-in-string - ffile "\\`.*/\\([^/]+\\)\\'" "\\1")) + (bfile (replace-regexp-in-string "\\`.*/\\([^/]+\\)\\'" "\\1" + ffile)) (filetime (nth 5 (file-attributes ffile))) (fileday (* (car filetime) high2days)) (fileday (+ fileday (* low2days (nth 1 filetime))))) @@ -612,7 +612,7 @@ If CONFIRM is non-nil, ask for confirmation before removing a file." (when (and (> (- currday fileday) diff) (if confirm (y-or-n-p - (gnus-format-message "\ + (format-message "\ Delete old (> %s day(s)) incoming mail file `%s'? " diff bfile)) (gnus-message 8 "\ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) @@ -629,8 +629,6 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) 0) (funcall callback mail-source-crash-box info))) -(autoload 'gnus-float-time "gnus-util") - (defvar mail-source-incoming-last-checked-time nil) (defun mail-source-delete-crash-box () @@ -639,7 +637,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (if (eq mail-source-delete-incoming t) (delete-file mail-source-crash-box) (let ((incoming - (mm-make-temp-file + (make-temp-file (expand-file-name mail-source-incoming-file-prefix mail-source-directory)))) @@ -651,7 +649,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) ;; Don't check for old incoming files more than once per day to ;; save a lot of file accesses. (when (or (null mail-source-incoming-last-checked-time) - (> (gnus-float-time + (> (float-time (time-since mail-source-incoming-last-checked-time)) (* 24 60 60))) (setq mail-source-incoming-last-checked-time (current-time)) @@ -997,7 +995,6 @@ This only works when `display-time' is enabled." (if on (progn (require 'time) - ;; display-time-mail-function is an Emacs feature. (setq display-time-mail-function #'mail-source-new-mail-p) ;; Set up the main timer. (setq mail-source-report-new-mail-timer diff --git a/lisp/gnus/mailcap.el b/lisp/gnus/mailcap.el deleted file mode 100644 index fc259d43090..00000000000 --- a/lisp/gnus/mailcap.el +++ /dev/null @@ -1,1077 +0,0 @@ -;;; mailcap.el --- MIME media types configuration - -;; Copyright (C) 1998-2017 Free Software Foundation, Inc. - -;; Author: William M. Perry <wmperry@aventail.com> -;; Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Keywords: news, mail, multimedia - -;; 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: - -;; Provides configuration of MIME media types from directly from Lisp -;; and via the usual mailcap mechanism (RFC 1524). Deals with -;; mime.types similarly. - -;;; Code: - -(eval-when-compile (require 'cl)) -(autoload 'mail-header-parse-content-type "mail-parse") - -;; `mm-delete-duplicates' is an alias for `delete-dups' in Emacs 22. -(defalias 'mailcap-delete-duplicates - (if (fboundp 'delete-dups) - 'delete-dups - (autoload 'mm-delete-duplicates "mm-util") - 'mm-delete-duplicates)) - -;; `mailcap-replace-in-string' is an alias like `gnus-replace-in-string'. -(eval-and-compile - (cond - ((fboundp 'replace-regexp-in-string) - (defun mailcap-replace-in-string (string regexp newtext &optional literal) - "Replace all matches for REGEXP with NEWTEXT in STRING. -If LITERAL is non-nil, insert NEWTEXT literally. Return a new -string containing the replacements. -This is a compatibility function for different Emacsen." - (replace-regexp-in-string regexp newtext string nil literal))) - ((fboundp 'replace-in-string) - (defalias 'mailcap-replace-in-string 'replace-in-string)))) - -(defgroup mailcap nil - "Definition of viewers for MIME types." - :version "21.1" - :group 'mime) - -(defvar mailcap-parse-args-syntax-table - (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) - (modify-syntax-entry ?' "\"" table) - (modify-syntax-entry ?` "\"" table) - (modify-syntax-entry ?{ "(" table) - (modify-syntax-entry ?} ")" table) - table) - "A syntax table for parsing SGML attributes.") - -(eval-and-compile - (when (featurep 'xemacs) - (condition-case nil - (require 'lpr) - (error nil)))) - -(defvar mailcap-print-command - (mapconcat 'identity - (cons (if (boundp 'lpr-command) - lpr-command - "lpr") - (when (boundp 'lpr-switches) - (if (stringp lpr-switches) - (list lpr-switches) - lpr-switches))) - " ") - "Shell command (including switches) used to print PostScript files.") - -;; Postpone using defcustom for this as it's so big and we essentially -;; have to have two copies of the data around then. Perhaps just -;; customize the Lisp viewers and rely on the normal configuration -;; files for the rest? -- fx -(defvar mailcap-mime-data - `(("application" - ("vnd\\.ms-excel" - (viewer . "gnumeric %s") - (test . (getenv "DISPLAY")) - (type . "application/vnd.ms-excel")) - ("x-x509-ca-cert" - (viewer . ssl-view-site-cert) - (type . "application/x-x509-ca-cert")) - ("x-x509-user-cert" - (viewer . ssl-view-user-cert) - (type . "application/x-x509-user-cert")) - ("octet-stream" - (viewer . mailcap-save-binary-file) - (non-viewer . t) - (type . "application/octet-stream")) - ("dvi" - (viewer . "xdvi -safer %s") - (test . (eq window-system 'x)) - ("needsx11") - (type . "application/dvi") - ("print" . "dvips -qRP %s")) - ("dvi" - (viewer . "dvitty %s") - (test . (not (getenv "DISPLAY"))) - (type . "application/dvi") - ("print" . "dvips -qRP %s")) - ("emacs-lisp" - (viewer . mailcap-maybe-eval) - (type . "application/emacs-lisp")) - ("x-emacs-lisp" - (viewer . mailcap-maybe-eval) - (type . "application/x-emacs-lisp")) - ("x-tar" - (viewer . mailcap-save-binary-file) - (non-viewer . t) - (type . "application/x-tar")) - ("x-latex" - (viewer . tex-mode) - (type . "application/x-latex")) - ("x-tex" - (viewer . tex-mode) - (type . "application/x-tex")) - ("latex" - (viewer . tex-mode) - (type . "application/latex")) - ("tex" - (viewer . tex-mode) - (type . "application/tex")) - ("texinfo" - (viewer . texinfo-mode) - (type . "application/tex")) - ("zip" - (viewer . mailcap-save-binary-file) - (non-viewer . t) - (type . "application/zip") - ("copiousoutput")) - ("pdf" - (viewer . pdf-view-mode) - (type . "application/pdf") - (test . (eq window-system 'x))) - ("pdf" - (viewer . doc-view-mode) - (type . "application/pdf") - (test . (eq window-system 'x))) - ("pdf" - (viewer . "gv -safer %s") - (type . "application/pdf") - (test . window-system) - ("print" . ,(concat "pdf2ps %s - | " mailcap-print-command))) - ("pdf" - (viewer . "gpdf %s") - (type . "application/pdf") - ("print" . ,(concat "pdftops %s - | " mailcap-print-command)) - (test . (eq window-system 'x))) - ("pdf" - (viewer . "xpdf %s") - (type . "application/pdf") - ("print" . ,(concat "pdftops %s - | " mailcap-print-command)) - (test . (eq window-system 'x))) - ("pdf" - (viewer . ,(concat "pdftotext %s -")) - (type . "application/pdf") - ("print" . ,(concat "pdftops %s - | " mailcap-print-command)) - ("copiousoutput")) - ("postscript" - (viewer . "gv -safer %s") - (type . "application/postscript") - (test . window-system) - ("print" . ,(concat mailcap-print-command " %s")) - ("needsx11")) - ("postscript" - (viewer . "ghostview -dSAFER %s") - (type . "application/postscript") - (test . (eq window-system 'x)) - ("print" . ,(concat mailcap-print-command " %s")) - ("needsx11")) - ("postscript" - (viewer . "ps2ascii %s") - (type . "application/postscript") - (test . (not (getenv "DISPLAY"))) - ("print" . ,(concat mailcap-print-command " %s")) - ("copiousoutput")) - ("sieve" - (viewer . sieve-mode) - (type . "application/sieve")) - ("pgp-keys" - (viewer . "gpg --import --interactive --verbose") - (type . "application/pgp-keys") - ("needsterminal"))) - ("audio" - ("x-mpeg" - (viewer . "maplay %s") - (type . "audio/x-mpeg")) - (".*" - (viewer . "showaudio") - (type . "audio/*"))) - ("message" - ("rfc-*822" - (viewer . mm-view-message) - (test . (and (featurep 'gnus) - (gnus-alive-p))) - (type . "message/rfc822")) - ("rfc-*822" - (viewer . vm-mode) - (type . "message/rfc822")) - ("rfc-*822" - (viewer . view-mode) - (type . "message/rfc822"))) - ("image" - ("x-xwd" - (viewer . "xwud -in %s") - (type . "image/x-xwd") - ("compose" . "xwd -frame > %s") - (test . (eq window-system 'x)) - ("needsx11")) - ("x11-dump" - (viewer . "xwud -in %s") - (type . "image/x-xwd") - ("compose" . "xwd -frame > %s") - (test . (eq window-system 'x)) - ("needsx11")) - ("windowdump" - (viewer . "xwud -in %s") - (type . "image/x-xwd") - ("compose" . "xwd -frame > %s") - (test . (eq window-system 'x)) - ("needsx11")) - (".*" - (viewer . "display %s") - (type . "image/*") - (test . (eq window-system 'x)) - ("needsx11")) - (".*" - (viewer . "ee %s") - (type . "image/*") - (test . (eq window-system 'x)) - ("needsx11"))) - ("text" - ("plain" - (viewer . view-mode) - (type . "text/plain")) - ("plain" - (viewer . fundamental-mode) - (type . "text/plain")) - ("enriched" - (viewer . enriched-decode) - (type . "text/enriched")) - ("dns" - (viewer . dns-mode) - (type . "text/dns"))) - ("video" - ("mpeg" - (viewer . "mpeg_play %s") - (type . "video/mpeg") - (test . (eq window-system 'x)) - ("needsx11"))) - ("x-world" - ("x-vrml" - (viewer . "webspace -remote %s -URL %u") - (type . "x-world/x-vrml") - ("description" - "VRML document"))) - ("archive" - ("tar" - (viewer . tar-mode) - (type . "archive/tar")))) - "The mailcap structure is an assoc list of assoc lists. -1st assoc list is keyed on the major content-type -2nd assoc list is keyed on the minor content-type (which can be a regexp) - -Which looks like: ------------------ - ((\"application\" - (\"postscript\" . <info>)) - (\"text\" - (\"plain\" . <info>))) - -Where <info> is another assoc list of the various information -related to the mailcap RFC 1524. This is keyed on the lowercase -attribute name (viewer, test, etc). This looks like: - ((viewer . VIEWERINFO) - (test . TESTINFO) - (xxxx . \"STRING\") - FLAG) - -Where VIEWERINFO specifies how the content-type is viewed. Can be -a string, in which case it is run through a shell, with appropriate -parameters, or a symbol, in which case the symbol is `funcall'ed if -and only if it exists as a function, with the buffer as an argument. - -TESTINFO is a test for the viewer's applicability, or nil. If nil, it -means the viewer is always valid. If it is a Lisp function, it is -called with a list of items from any extra fields from the -Content-Type header as argument to return a boolean value for the -validity. Otherwise, if it is a non-function Lisp symbol or list -whose car is a symbol, it is `eval'led to yield the validity. If it -is a string or list of strings, it represents a shell command to run -to return a true or false shell value for the validity.") -(put 'mailcap-mime-data 'risky-local-variable t) - -(defcustom mailcap-download-directory nil - "*Directory to which `mailcap-save-binary-file' downloads files by default. -nil means your home directory." - :type '(choice (const :tag "Home directory" nil) - directory) - :group 'mailcap) - -(defvar mailcap-poor-system-types - '(ms-dos windows-nt) - "Systems that don't have a Unix-like directory hierarchy.") - -;;; -;;; Utility functions -;;; - -(defun mailcap-save-binary-file () - (goto-char (point-min)) - (unwind-protect - (let ((file (read-file-name - "Filename to save as: " - (or mailcap-download-directory "~/"))) - (require-final-newline nil)) - (write-region (point-min) (point-max) file)) - (kill-buffer (current-buffer)))) - -(defvar mailcap-maybe-eval-warning - "*** WARNING *** - -This MIME part contains untrusted and possibly harmful content. -If you evaluate the Emacs Lisp code contained in it, a lot of nasty -things can happen. Please examine the code very carefully before you -instruct Emacs to evaluate it. You can browse the buffer containing -the code using \\[scroll-other-window]. - -If you are unsure what to do, please answer \"no\"." - "Text of warning message displayed by `mailcap-maybe-eval'. -Make sure that this text consists only of few text lines. Otherwise, -Gnus might fail to display all of it.") - -(defun mailcap-maybe-eval () - "Maybe evaluate a buffer of Emacs Lisp code." - (let ((lisp-buffer (current-buffer))) - (goto-char (point-min)) - (when - (save-window-excursion - (delete-other-windows) - (let ((buffer (get-buffer-create (generate-new-buffer-name - "*Warning*")))) - (unwind-protect - (with-current-buffer buffer - (insert (substitute-command-keys - mailcap-maybe-eval-warning)) - (goto-char (point-min)) - (display-buffer buffer) - (yes-or-no-p "This is potentially dangerous emacs-lisp code, evaluate it? ")) - (kill-buffer buffer)))) - (eval-buffer (current-buffer))) - (when (buffer-live-p lisp-buffer) - (with-current-buffer lisp-buffer - (emacs-lisp-mode))))) - - -;;; -;;; The mailcap parser -;;; - -(defun mailcap-replace-regexp (regexp to-string) - ;; Quiet replace-regexp. - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (replace-match to-string t nil))) - -(defvar mailcap-parsed-p nil) - -(defun mailcap-parse-mailcaps (&optional path force) - "Parse out all the mailcaps specified in a path string PATH. -Components of PATH are separated by the `path-separator' character -appropriate for this system. If FORCE, re-parse even if already -parsed. If PATH is omitted, use the value of environment variable -MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus -/usr/local/etc/mailcap." - (interactive (list nil t)) - (when (or (not mailcap-parsed-p) - force) - (cond - (path nil) - ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS"))) - ((memq system-type mailcap-poor-system-types) - (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap"))) - (t (setq path - ;; This is per RFC 1524, specifically - ;; with /usr before /usr/local. - '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap" - "/usr/local/etc/mailcap")))) - (let ((fnames (reverse - (if (stringp path) - (split-string path path-separator t) - path))) - fname) - (while fnames - (setq fname (car fnames)) - (if (and (file-readable-p fname) - (file-regular-p fname)) - (mailcap-parse-mailcap fname)) - (setq fnames (cdr fnames)))) - (setq mailcap-parsed-p t))) - -(defun mailcap-parse-mailcap (fname) - "Parse out the mailcap file specified by FNAME." - (let (major ; The major mime type (image/audio/etc) - minor ; The minor mime type (gif, basic, etc) - save-pos ; Misc saved positions used in parsing - viewer ; How to view this mime type - info ; Misc info about this mime type - ) - (with-temp-buffer - (insert-file-contents fname) - (set-syntax-table mailcap-parse-args-syntax-table) - (mailcap-replace-regexp "#.*" "") ; Remove all comments - (mailcap-replace-regexp "\\\\[ \t]*\n" " ") ; And collapse spaces - (mailcap-replace-regexp "\n+" "\n") ; And blank lines - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (delete-region (point) (point-max)) - (while (not (bobp)) - (skip-chars-backward " \t\n") - (beginning-of-line) - (setq save-pos (point) - info nil) - (skip-chars-forward "^/; \t\n") - (downcase-region save-pos (point)) - (setq major (buffer-substring save-pos (point))) - (skip-chars-forward " \t") - (setq minor "") - (when (eq (char-after) ?/) - (forward-char) - (skip-chars-forward " \t") - (setq save-pos (point)) - (skip-chars-forward "^; \t\n") - (downcase-region save-pos (point)) - (setq minor - (cond - ((eq ?* (or (char-after save-pos) 0)) ".*") - ((= (point) save-pos) ".*") - (t (regexp-quote (buffer-substring save-pos (point))))))) - (skip-chars-forward " \t") - ;;; Got the major/minor chunks, now for the viewers/etc - ;;; The first item _must_ be a viewer, according to the - ;;; RFC for mailcap files (#1524) - (setq viewer "") - (when (eq (char-after) ?\;) - (forward-char) - (skip-chars-forward " \t") - (setq save-pos (point)) - (skip-chars-forward "^;\n") - ;; skip \; - (while (eq (char-before) ?\\) - (backward-delete-char 1) - (forward-char) - (skip-chars-forward "^;\n")) - (if (eq (or (char-after save-pos) 0) ?') - (setq viewer (progn - (narrow-to-region (1+ save-pos) (point)) - (goto-char (point-min)) - (prog1 - (read (current-buffer)) - (goto-char (point-max)) - (widen)))) - (setq viewer (buffer-substring save-pos (point))))) - (setq save-pos (point)) - (end-of-line) - (unless (equal viewer "") - (setq info (nconc (list (cons 'viewer viewer) - (cons 'type (concat major "/" - (if (string= minor ".*") - "*" minor)))) - (mailcap-parse-mailcap-extras save-pos (point)))) - (mailcap-mailcap-entry-passes-test info) - (mailcap-add-mailcap-entry major minor info)) - (beginning-of-line))))) - -(defun mailcap-parse-mailcap-extras (st nd) - "Grab all the extra stuff from a mailcap entry." - (let ( - name ; From name= - value ; its value - results ; Assoc list of results - name-pos ; Start of XXXX= position - val-pos ; Start of value position - done ; Found end of \'d ;s? - ) - (save-restriction - (narrow-to-region st nd) - (goto-char (point-min)) - (skip-chars-forward " \n\t;") - (while (not (eobp)) - (setq done nil) - (setq name-pos (point)) - (skip-chars-forward "^ \n\t=;") - (downcase-region name-pos (point)) - (setq name (buffer-substring name-pos (point))) - (skip-chars-forward " \t\n") - (if (not (eq (char-after (point)) ?=)) ; There is no value - (setq value t) - (skip-chars-forward " \t\n=") - (setq val-pos (point)) - (if (memq (char-after val-pos) '(?\" ?')) - (progn - (setq val-pos (1+ val-pos)) - (condition-case nil - (progn - (forward-sexp 1) - (backward-char 1)) - (error (goto-char (point-max))))) - (while (not done) - (skip-chars-forward "^;") - (if (eq (char-after (1- (point))) ?\\ ) - (progn - (subst-char-in-region (1- (point)) (point) ?\\ ? ) - (skip-chars-forward ";")) - (setq done t)))) - (setq value (buffer-substring val-pos (point)))) - ;; `test' as symbol, others like "copiousoutput" and "needsx11" as - ;; strings - (setq results (cons (cons (if (string-equal name "test") - 'test - name) - value) results)) - (skip-chars-forward " \";\n\t")) - results))) - -(defun mailcap-mailcap-entry-passes-test (info) - "Replace the test clause of INFO itself with a boolean for some cases. -This function supports only `test -n $DISPLAY' and `test -z $DISPLAY', -replaces them with t or nil. As for others or if INFO has a interactive -spec (needsterm, needsterminal, or needsx11) but DISPLAY is not set, -the test clause will be unchanged." - (let ((test (assq 'test info)) ; The test clause - status) - (setq status (and test (split-string (cdr test) " "))) - (if (and (or (assoc "needsterm" info) - (assoc "needsterminal" info) - (assoc "needsx11" info)) - (not (getenv "DISPLAY"))) - (setq status nil) - (cond - ((and (equal (nth 0 status) "test") - (equal (nth 1 status) "-n") - (or (equal (nth 2 status) "$DISPLAY") - (equal (nth 2 status) "\"$DISPLAY\""))) - (setq status (if (getenv "DISPLAY") t nil))) - ((and (equal (nth 0 status) "test") - (equal (nth 1 status) "-z") - (or (equal (nth 2 status) "$DISPLAY") - (equal (nth 2 status) "\"$DISPLAY\""))) - (setq status (if (getenv "DISPLAY") nil t))) - (test nil) - (t nil))) - (and test (listp test) (setcdr test status)))) - -;;; -;;; The action routines. -;;; - -(defun mailcap-possible-viewers (major minor) - "Return a list of possible viewers from MAJOR for minor type MINOR." - (let ((exact '()) - (wildcard '())) - (while major - (cond - ((equal (car (car major)) minor) - (setq exact (cons (cdr (car major)) exact))) - ((and minor (string-match (concat "^" (car (car major)) "$") minor)) - (setq wildcard (cons (cdr (car major)) wildcard)))) - (setq major (cdr major))) - (nconc exact wildcard))) - -(defun mailcap-unescape-mime-test (test type-info) - (let (save-pos save-chr subst) - (cond - ((symbolp test) test) - ((and (listp test) (symbolp (car test))) test) - ((or (stringp test) - (and (listp test) (stringp (car test)) - (setq test (mapconcat 'identity test " ")))) - (with-temp-buffer - (insert test) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward "^%") - (if (/= (- (point) - (progn (skip-chars-backward "\\\\") - (point))) - 0) ; It is an escaped % - (progn - (delete-char 1) - (skip-chars-forward "%.")) - (setq save-pos (point)) - (skip-chars-forward "%") - (setq save-chr (char-after (point))) - ;; Escapes: - ;; %s: name of a file for the body data - ;; %t: content-type - ;; %{<parameter name}: value of parameter in mailcap entry - ;; %n: number of sub-parts for multipart content-type - ;; %F: a set of content-type/filename pairs for multiparts - (cond - ((null save-chr) nil) - ((= save-chr ?t) - (delete-region save-pos (progn (forward-char 1) (point))) - (insert (or (cdr (assq 'type type-info)) "\"\""))) - ((memq save-chr '(?M ?n ?F)) - (delete-region save-pos (progn (forward-char 1) (point))) - (insert "\"\"")) - ((= save-chr ?{) - (forward-char 1) - (skip-chars-forward "^}") - (downcase-region (+ 2 save-pos) (point)) - (setq subst (buffer-substring (+ 2 save-pos) (point))) - (delete-region save-pos (1+ (point))) - (insert (or (cdr (assoc subst type-info)) "\"\""))) - (t nil)))) - (buffer-string))) - (t (error "Bad value to mailcap-unescape-mime-test: %s" test))))) - -(defvar mailcap-viewer-test-cache nil) - -(defun mailcap-viewer-passes-test (viewer-info type-info) - "Return non-nil if viewer specified by VIEWER-INFO passes its test clause. -Also return non-nil if it has no test clause. TYPE-INFO is an argument -to supply to the test." - (let* ((test-info (assq 'test viewer-info)) - (test (cdr test-info)) - (otest test) - (viewer (cdr (assq 'viewer viewer-info))) - (default-directory (expand-file-name "~/")) - status parsed-test cache result) - (cond ((not (or (stringp viewer) (fboundp viewer))) - nil) ; Non-existent Lisp function - ((setq cache (assoc test mailcap-viewer-test-cache)) - (cadr cache)) - ((not test-info) t) ; No test clause - (t - (setq - result - (cond - ((not test) nil) ; Already failed test - ((eq test t) t) ; Already passed test - ((functionp test) ; Lisp function as test - (funcall test type-info)) - ((and (symbolp test) ; Lisp variable as test - (boundp test)) - (symbol-value test)) - ((and (listp test) ; List to be eval'd - (symbolp (car test))) - (eval test)) - (t - (setq test (mailcap-unescape-mime-test test type-info) - test (list shell-file-name nil nil nil - shell-command-switch test) - status (apply 'call-process test)) - (eq 0 status)))) - (push (list otest result) mailcap-viewer-test-cache) - result)))) - -(defun mailcap-add-mailcap-entry (major minor info) - (let ((old-major (assoc major mailcap-mime-data))) - (if (null old-major) ; New major area - (setq mailcap-mime-data - (cons (cons major (list (cons minor info))) - mailcap-mime-data)) - (let ((cur-minor (assoc minor old-major))) - (cond - ((or (null cur-minor) ; New minor area, or - (assq 'test info)) ; Has a test, insert at beginning - (setcdr old-major (cons (cons minor info) (cdr old-major)))) - ((and (not (assq 'test info)) ; No test info, replace completely - (not (assq 'test cur-minor)) - (equal (assq 'viewer info) ; Keep alternative viewer - (assq 'viewer cur-minor))) - (setcdr cur-minor info)) - (t - (setcdr old-major (cons (cons minor info) (cdr old-major)))))) - ))) - -(defun mailcap-add (type viewer &optional test) - "Add VIEWER as a handler for TYPE. -If TEST is not given, it defaults to t." - (let ((tl (split-string type "/"))) - (when (or (not (car tl)) - (not (cadr tl))) - (error "%s is not a valid MIME type" type)) - (mailcap-add-mailcap-entry - (car tl) (cadr tl) - `((viewer . ,viewer) - (test . ,(if test test t)) - (type . ,type))))) - -;;; -;;; The main whabbo -;;; - -(defun mailcap-viewer-lessp (x y) - "Return t if viewer X is more desirable than viewer Y." - (let ((x-wild (string-match "[*?]" (or (cdr-safe (assq 'type x)) ""))) - (y-wild (string-match "[*?]" (or (cdr-safe (assq 'type y)) ""))) - (x-lisp (not (stringp (or (cdr-safe (assq 'viewer x)) "")))) - (y-lisp (not (stringp (or (cdr-safe (assq 'viewer y)) ""))))) - (cond - ((and x-wild (not y-wild)) - nil) - ((and (not x-wild) y-wild) - t) - ((and (not y-lisp) x-lisp) - t) - (t nil)))) - -(defun mailcap-mime-info (string &optional request no-decode) - "Get the MIME viewer command for STRING, return nil if none found. -Expects a complete content-type header line as its argument. - -Second argument REQUEST specifies what information to return. If it is -nil or the empty string, the viewer (second field of the mailcap -entry) will be returned. If it is a string, then the mailcap field -corresponding to that string will be returned (print, description, -whatever). If a number, then all the information for this specific -viewer is returned. If `all', then all possible viewers for -this type is returned. - -If NO-DECODE is non-nil, don't decode STRING." - ;; NO-DECODE avoids calling `mail-header-parse-content-type' from - ;; `mail-parse.el' - (let ( - major ; Major encoding (text, etc) - minor ; Minor encoding (html, etc) - info ; Other info - save-pos ; Misc. position during parse - major-info ; (assoc major mailcap-mime-data) - minor-info ; (assoc minor major-info) - test ; current test proc. - viewers ; Possible viewers - passed ; Viewers that passed the test - viewer ; The one and only viewer - ctl) - (save-excursion - (setq ctl - (if no-decode - (list (or string "text/plain")) - (mail-header-parse-content-type (or string "text/plain")))) - (setq major (split-string (car ctl) "/")) - (setq minor (cadr major) - major (car major)) - (when (setq major-info (cdr (assoc major mailcap-mime-data))) - (when (setq viewers (mailcap-possible-viewers major-info minor)) - (setq info (mapcar (lambda (a) (cons (symbol-name (car a)) - (cdr a))) - (cdr ctl))) - (while viewers - (if (mailcap-viewer-passes-test (car viewers) info) - (setq passed (cons (car viewers) passed))) - (setq viewers (cdr viewers))) - (setq passed (sort passed 'mailcap-viewer-lessp)) - (setq viewer (car passed)))) - (when (and (stringp (cdr (assq 'viewer viewer))) - passed) - (setq viewer (car passed))) - (cond - ((and (null viewer) (not (equal major "default")) request) - (mailcap-mime-info "default" request no-decode)) - ((or (null request) (equal request "")) - (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info)) - ((stringp request) - (mailcap-unescape-mime-test - (cdr-safe (assoc request viewer)) info)) - ((eq request 'all) - passed) - (t - ;; MUST make a copy *sigh*, else we modify mailcap-mime-data - (setq viewer (copy-sequence viewer)) - (let ((view (assq 'viewer viewer)) - (test (assq 'test viewer))) - (if view (setcdr view (mailcap-unescape-mime-test (cdr view) info))) - (if test (setcdr test (mailcap-unescape-mime-test (cdr test) info)))) - viewer))))) - -;;; -;;; Experimental MIME-types parsing -;;; - -(defvar mailcap-mime-extensions - '(("" . "text/plain") - (".1" . "text/plain") ;; Manual pages - (".3" . "text/plain") - (".8" . "text/plain") - (".abs" . "audio/x-mpeg") - (".aif" . "audio/aiff") - (".aifc" . "audio/aiff") - (".aiff" . "audio/aiff") - (".ano" . "application/x-annotator") - (".au" . "audio/ulaw") - (".avi" . "video/x-msvideo") - (".bcpio" . "application/x-bcpio") - (".bin" . "application/octet-stream") - (".cdf" . "application/x-netcdr") - (".cpio" . "application/x-cpio") - (".csh" . "application/x-csh") - (".css" . "text/css") - (".dvi" . "application/x-dvi") - (".diff" . "text/x-patch") - (".dpatch". "test/x-patch") - (".el" . "application/emacs-lisp") - (".eps" . "application/postscript") - (".etx" . "text/x-setext") - (".exe" . "application/octet-stream") - (".fax" . "image/x-fax") - (".gif" . "image/gif") - (".hdf" . "application/x-hdf") - (".hqx" . "application/mac-binhex40") - (".htm" . "text/html") - (".html" . "text/html") - (".icon" . "image/x-icon") - (".ief" . "image/ief") - (".jpg" . "image/jpeg") - (".macp" . "image/x-macpaint") - (".man" . "application/x-troff-man") - (".me" . "application/x-troff-me") - (".mif" . "application/mif") - (".mov" . "video/quicktime") - (".movie" . "video/x-sgi-movie") - (".mp2" . "audio/x-mpeg") - (".mp3" . "audio/x-mpeg") - (".mp2a" . "audio/x-mpeg2") - (".mpa" . "audio/x-mpeg") - (".mpa2" . "audio/x-mpeg2") - (".mpe" . "video/mpeg") - (".mpeg" . "video/mpeg") - (".mpega" . "audio/x-mpeg") - (".mpegv" . "video/mpeg") - (".mpg" . "video/mpeg") - (".mpv" . "video/mpeg") - (".ms" . "application/x-troff-ms") - (".nc" . "application/x-netcdf") - (".nc" . "application/x-netcdf") - (".oda" . "application/oda") - (".patch" . "text/x-patch") - (".pbm" . "image/x-portable-bitmap") - (".pdf" . "application/pdf") - (".pgm" . "image/portable-graymap") - (".pict" . "image/pict") - (".png" . "image/png") - (".pnm" . "image/x-portable-anymap") - (".pod" . "text/plain") - (".ppm" . "image/portable-pixmap") - (".ps" . "application/postscript") - (".qt" . "video/quicktime") - (".ras" . "image/x-raster") - (".rgb" . "image/x-rgb") - (".rtf" . "application/rtf") - (".rtx" . "text/richtext") - (".sh" . "application/x-sh") - (".sit" . "application/x-stuffit") - (".siv" . "application/sieve") - (".snd" . "audio/basic") - (".soa" . "text/dns") - (".src" . "application/x-wais-source") - (".tar" . "archive/tar") - (".tcl" . "application/x-tcl") - (".tex" . "application/x-tex") - (".texi" . "application/texinfo") - (".tga" . "image/x-targa") - (".tif" . "image/tiff") - (".tiff" . "image/tiff") - (".tr" . "application/x-troff") - (".troff" . "application/x-troff") - (".tsv" . "text/tab-separated-values") - (".txt" . "text/plain") - (".vbs" . "video/mpeg") - (".vox" . "audio/basic") - (".vrml" . "x-world/x-vrml") - (".wav" . "audio/x-wav") - (".xls" . "application/vnd.ms-excel") - (".wrl" . "x-world/x-vrml") - (".xbm" . "image/xbm") - (".xpm" . "image/xpm") - (".xwd" . "image/windowdump") - (".zip" . "application/zip") - (".ai" . "application/postscript") - (".jpe" . "image/jpeg") - (".jpeg" . "image/jpeg") - (".org" . "text/x-org")) - "An alist of file extensions and corresponding MIME content-types. -This exists for you to customize the information in Lisp. It is -merged with values from mailcap files by `mailcap-parse-mimetypes'.") - -(defvar mailcap-mimetypes-parsed-p nil) - -(defun mailcap-parse-mimetypes (&optional path force) - "Parse out all the mimetypes specified in a Unix-style path string PATH. -Components of PATH are separated by the `path-separator' character -appropriate for this system. If PATH is omitted, use the value of -environment variable MIMETYPES if set; otherwise use a default path. -If FORCE, re-parse even if already parsed." - (interactive (list nil t)) - (when (or (not mailcap-mimetypes-parsed-p) - force) - (cond - (path nil) - ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES"))) - ((memq system-type mailcap-poor-system-types) - (setq path '("~/mime.typ" "~/etc/mime.typ"))) - (t (setq path - ;; mime.types seems to be the normal name, definitely so - ;; on current GNUish systems. The search order follows - ;; that for mailcap. - '("~/.mime.types" - "/etc/mime.types" - "/usr/etc/mime.types" - "/usr/local/etc/mime.types" - "/usr/local/www/conf/mime.types" - "~/.mime-types" - "/etc/mime-types" - "/usr/etc/mime-types" - "/usr/local/etc/mime-types" - "/usr/local/www/conf/mime-types")))) - (let ((fnames (reverse (if (stringp path) - (split-string path path-separator t) - path))) - fname) - (while fnames - (setq fname (car fnames)) - (if (and (file-readable-p fname)) - (mailcap-parse-mimetype-file fname)) - (setq fnames (cdr fnames)))) - (setq mailcap-mimetypes-parsed-p t))) - -(defun mailcap-parse-mimetype-file (fname) - "Parse out a mime-types file FNAME." - (let (type ; The MIME type for this line - extns ; The extensions for this line - save-pos ; Misc. saved buffer positions - ) - (with-temp-buffer - (insert-file-contents fname) - (mailcap-replace-regexp "#.*" "") - (mailcap-replace-regexp "\n+" "\n") - (mailcap-replace-regexp "[ \t]+$" "") - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (delete-region (point) (point-max)) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\n") - (setq save-pos (point)) - (skip-chars-forward "^ \t\n") - (downcase-region save-pos (point)) - (setq type (buffer-substring save-pos (point))) - (while (not (eolp)) - (skip-chars-forward " \t") - (setq save-pos (point)) - (skip-chars-forward "^ \t\n") - (setq extns (cons (buffer-substring save-pos (point)) extns))) - (while extns - (setq mailcap-mime-extensions - (cons - (cons (if (= (string-to-char (car extns)) ?.) - (car extns) - (concat "." (car extns))) type) - mailcap-mime-extensions) - extns (cdr extns))))))) - -(defun mailcap-extension-to-mime (extn) - "Return the MIME content type of the file extensions EXTN." - (mailcap-parse-mimetypes) - (if (and (stringp extn) - (not (eq (string-to-char extn) ?.))) - (setq extn (concat "." extn))) - (cdr (assoc (downcase extn) mailcap-mime-extensions))) - -;; Unused? -(defalias 'mailcap-command-p 'executable-find) - -(defun mailcap-mime-types () - "Return a list of MIME media types." - (mailcap-parse-mimetypes) - (mailcap-delete-duplicates - (nconc - (mapcar 'cdr mailcap-mime-extensions) - (apply - 'nconc - (mapcar - (lambda (l) - (delq nil - (mapcar - (lambda (m) - (let ((type (cdr (assq 'type (cdr m))))) - (if (equal (cadr (split-string type "/")) - "*") - nil - type))) - (cdr l)))) - mailcap-mime-data))))) - -;;; -;;; Useful supplementary functions -;;; - -(defun mailcap-file-default-commands (files) - "Return a list of default commands for FILES." - (mailcap-parse-mailcaps) - (mailcap-parse-mimetypes) - (let* ((all-mime-type - ;; All unique MIME types from file extensions - (mailcap-delete-duplicates - (mapcar (lambda (file) - (mailcap-extension-to-mime - (file-name-extension file t))) - files))) - (all-mime-info - ;; All MIME info lists - (mailcap-delete-duplicates - (mapcar (lambda (mime-type) - (mailcap-mime-info mime-type 'all)) - all-mime-type))) - (common-mime-info - ;; Intersection of mime-infos from different mime-types; - ;; or just the first MIME info for a single MIME type - (if (cdr all-mime-info) - (delq nil (mapcar (lambda (mi1) - (unless (memq nil (mapcar - (lambda (mi2) - (member mi1 mi2)) - (cdr all-mime-info))) - mi1)) - (car all-mime-info))) - (car all-mime-info))) - (commands - ;; Command strings from `viewer' field of the MIME info - (mailcap-delete-duplicates - (delq nil (mapcar (lambda (mime-info) - (let ((command (cdr (assoc 'viewer mime-info)))) - (if (stringp command) - (mailcap-replace-in-string - ;; Replace mailcap's `%s' placeholder - ;; with dired's `?' placeholder - (mailcap-replace-in-string - ;; Remove the final filename placeholder - command "[ \t\n]*\\('\\)?%s\\1?[ \t\n]*\\'" "" t) - "%s" "?" t)))) - common-mime-info))))) - commands)) - -(defun mailcap-view-mime (type) - "View the data in the current buffer that has MIME type TYPE. -`mailcap-mime-data' determines the method to use." - (let ((method (mailcap-mime-info type))) - (if (stringp method) - (shell-command-on-region (point-min) (point-max) - ;; Use stdin as the "%s". - (format method "-") - (current-buffer) - t) - (funcall method)))) - -(provide 'mailcap) - -;;; mailcap.el ends here diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 55ce56bcf2c..4d4ba089434 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -1,4 +1,4 @@ -;;; message.el --- composing mail and news messages +;;; message.el --- composing mail and news messages -*- lexical-binding: t -*- ;; Copyright (C) 1996-2017 Free Software Foundation, Inc. @@ -40,16 +40,18 @@ ;; This is apparently necessary even though things are autoloaded. ;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better ;; require mailabbrev here. -(if (featurep 'xemacs) - (require 'mail-abbrevs) - (require 'mailabbrev)) +(require 'mailabbrev) (require 'mail-parse) (require 'mml) (require 'rfc822) (require 'format-spec) (require 'dired) +(require 'mm-util) +(require 'rfc2047) +(require 'puny) +(require 'subr-x) -(autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/ +(autoload 'mailclient-send-it "mailclient") (defvar gnus-message-group-art) (defvar gnus-list-identifiers) ; gnus-sum is required where necessary @@ -114,12 +116,12 @@ :group 'faces) (defcustom message-directory "~/Mail/" - "*Directory from which all other mail file variables are derived." + "Directory from which all other mail file variables are derived." :group 'message-various :type 'directory) (defcustom message-max-buffers 10 - "*How many buffers to keep before starting to kill them off." + "How many buffers to keep before starting to kill them off." :group 'message-buffers :type 'integer) @@ -129,7 +131,7 @@ :type '(choice function (const nil))) (defcustom message-fcc-handler-function 'message-output - "*A function called to save outgoing articles. + "A function called to save outgoing articles. This function will be called with the name of the file to store the article in. The default function is `message-output' which saves in Unix mailbox format." @@ -145,7 +147,7 @@ mailbox format." (defcustom message-courtesy-message "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" - "*This is inserted at the start of a mailed copy of a posted message. + "This is inserted at the start of a mailed copy of a posted message. If the string contains the format spec \"%s\", the Newsgroups the article has been posted to will be inserted there. If this variable is nil, no such courtesy message will be added." @@ -154,7 +156,7 @@ If this variable is nil, no such courtesy message will be added." (defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\|Delivered-To\\):" - "*Regexp that matches headers to be removed in resent bounced mail." + "Regexp that matches headers to be removed in resent bounced mail." :group 'message-interface :type 'regexp) @@ -186,7 +188,7 @@ Otherwise, most addresses look like `angles', but they look like (defcustom message-syntax-checks (if message-insert-canlock '((sender . disabled)) nil) ;; Guess this one shouldn't be easy to customize... - "*Controls what syntax checks should not be performed on outgoing posts. + "Controls what syntax checks should not be performed on outgoing posts. To disable checking of long signatures, for instance, add `(signature . disabled)' to this list. @@ -204,7 +206,7 @@ and `valid-newsgroups'." (defcustom message-required-headers '((optional . References) From) - "*Headers to be generated or prompted for when sending a message. + "Headers to be generated or prompted for when sending a message. Also see `message-required-news-headers' and `message-required-mail-headers'." :version "22.1" @@ -214,7 +216,7 @@ Also see `message-required-news-headers' and :type '(repeat sexp)) (defcustom message-draft-headers '(References From Date) - "*Headers to be generated when saving a draft message." + "Headers to be generated when saving a draft message." :version "22.1" :group 'message-news :group 'message-headers @@ -225,7 +227,7 @@ Also see `message-required-news-headers' and '(From Newsgroups Subject Date Message-ID (optional . Organization) (optional . User-Agent)) - "*Headers to be generated or prompted for when posting an article. + "Headers to be generated or prompted for when posting an article. RFC977 and RFC1036 require From, Date, Newsgroups, Subject, Message-ID. Organization, Lines, In-Reply-To, Expires, and User-Agent are optional. If you don't want message to insert some @@ -238,7 +240,7 @@ header, remove it from this list." (defcustom message-required-mail-headers '(From Subject Date (optional . In-Reply-To) Message-ID (optional . User-Agent)) - "*Headers to be generated or prompted for when mailing a message. + "Headers to be generated or prompted for when mailing a message. It is recommended that From, Date, To, Subject and Message-ID be included. Organization and User-Agent are optional." :group 'message-mail @@ -263,7 +265,7 @@ This is a list of regexps and regexp matches." (defcustom message-ignored-news-headers "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:\\|^X-Message-SMTP-Method:\\|^X-Gnus-Delayed:" - "*Regexp of headers to be removed unconditionally before posting." + "Regexp of headers to be removed unconditionally before posting." :group 'message-news :group 'message-headers :link '(custom-manual "(message)Message Headers") @@ -276,14 +278,14 @@ This is a list of regexps and regexp matches." (defcustom message-ignored-mail-headers "^\\([GF]cc\\|Resent-Fcc\\|Xref\\|X-Draft-From\\|X-Gnus-Agent-Meta-Information\\):" - "*Regexp of headers to be removed unconditionally before mailing." + "Regexp of headers to be removed unconditionally before mailing." :group 'message-mail :group 'message-headers :link '(custom-manual "(message)Mail Headers") :type 'regexp) (defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-ID:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:\\|^Injection-Date:\\|^Injection-Info:" - "*Header lines matching this regexp will be deleted before posting. + "Header lines matching this regexp will be deleted before posting. It's best to delete old Path and Date headers before posting to avoid any confusion." :group 'message-interface @@ -296,8 +298,8 @@ any confusion." regexp)) (defcustom message-subject-re-regexp - "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*" - "*Regexp matching \"Re: \" in the subject line." + "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)* ?:[ \t]*\\)*[ \t]*" + "Regexp matching \"Re: \" in the subject line." :group 'message-various :link '(custom-manual "(message)Message Headers") :type 'regexp) @@ -305,7 +307,7 @@ any confusion." ;;; Start of variables adopted from `message-utils.el'. (defcustom message-subject-trailing-was-query t - "*What to do with trailing \"(was: <old subject>)\" in subject lines. + "What to do with trailing \"(was: <old subject>)\" in subject lines. If nil, leave the subject unchanged. If it is the symbol `ask', query the user what do do. In this case, the subject is matched against `message-subject-trailing-was-ask-regexp'. If @@ -321,7 +323,7 @@ used." (defcustom message-subject-trailing-was-ask-regexp "[ \t]*\\([[(]+[Ww][Aa][Ss]:?[ \t]*.*[])]+\\)" - "*Regexp matching \"(was: <old subject>)\" in the subject line. + "Regexp matching \"(was: <old subject>)\" in the subject line. The function `message-strip-subject-trailing-was' uses this regexp if `message-subject-trailing-was-query' is set to the symbol `ask'. If @@ -336,7 +338,7 @@ It is okay to create some false positives here, as the user is asked." (defcustom message-subject-trailing-was-regexp "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)" - "*Regexp matching \"(was: <old subject>)\" in the subject line. + "Regexp matching \"(was: <old subject>)\" in the subject line. If `message-subject-trailing-was-query' is set to t, the subject is matched against `message-subject-trailing-was-regexp' in @@ -437,7 +439,7 @@ whitespace)." :group 'message-various) (defcustom message-elide-ellipsis "\n[...]\n\n" - "*The string which is inserted for elided text. + "The string which is inserted for elided text. This is a format-spec string, and you can use %l to say how many lines were removed, and %c to say how many characters were removed." @@ -463,7 +465,7 @@ A value of nil means let mailer mail back a message to report errors." :type 'boolean) (defcustom message-generate-new-buffers 'unsent - "*Say whether to create a new message buffer to compose a message. + "Say whether to create a new message buffer to compose a message. Valid values include: nil @@ -496,13 +498,13 @@ function (function :format "\n %{%t%}: %v"))) (defcustom message-kill-buffer-on-exit nil - "*Non-nil means that the message buffer will be killed after sending a message." + "Non-nil means that the message buffer will be killed after sending a message." :group 'message-buffers :link '(custom-manual "(message)Message Buffers") :type 'boolean) (defcustom message-kill-buffer-query t - "*Non-nil means that killing a modified message buffer has to be confirmed. + "Non-nil means that killing a modified message buffer has to be confirmed. This is used by `message-kill-buffer'." :version "23.1" ;; No Gnus :group 'message-buffers @@ -524,14 +526,14 @@ If t, use `message-user-organization-file'." (when (file-readable-p f) (setq orgfile f))) orgfile) - "*Local news organization file." + "Local news organization file." :type '(choice (const nil) file) :link '(custom-manual "(message)News Headers") :group 'message-headers) (defcustom message-make-forward-subject-function #'message-forward-subject-name-subject - "*List of functions called to generate subject headers for forwarded messages. + "List of functions called to generate subject headers for forwarded messages. The subject generated by the previous function is passed into each successive function. @@ -551,7 +553,7 @@ The provided functions are: (repeat :tag "List of functions" function))) (defcustom message-forward-as-mime t - "*Non-nil means forward messages as an inline/rfc822 MIME section. + "Non-nil means forward messages as an inline/rfc822 MIME section. Otherwise, directly inline the old message in the forwarded message." :version "21.1" :group 'message-forwarding @@ -559,7 +561,7 @@ Otherwise, directly inline the old message in the forwarded message." :type 'boolean) (defcustom message-forward-show-mml 'best - "*Non-nil means show forwarded messages as MML (decoded from MIME). + "Non-nil means show forwarded messages as MML (decoded from MIME). Otherwise, forwarded messages are unchanged. Can also be the symbol `best' to indicate that MML should be used, except when it is a bad idea to use MML. One example where @@ -573,12 +575,12 @@ digital signature." (const :tag "use MML when appropriate" best))) (defcustom message-forward-before-signature t - "*Non-nil means put forwarded message before signature, else after." + "Non-nil means put forwarded message before signature, else after." :group 'message-forwarding :type 'boolean) (defcustom message-wash-forwarded-subjects nil - "*Non-nil means try to remove as much cruft as possible from the subject. + "Non-nil means try to remove as much cruft as possible from the subject. Done before generating the new subject of a forward." :group 'message-forwarding :link '(custom-manual "(message)Forwarding") @@ -592,7 +594,7 @@ Done before generating the new subject of a forward." ;; bounced with a "mailing loop" error). "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From \\|^Delivered-To:\ \\|^X-Content-Length:\\|^X-UIDL:" - "*All headers that match this regexp will be deleted when resending a message." + "All headers that match this regexp will be deleted when resending a message." :version "24.4" :group 'message-interface :link '(custom-manual "(message)Resending") @@ -604,7 +606,7 @@ 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 @@ -629,13 +631,13 @@ variable should be a regexp or a list of regexps." regexp)) (defcustom message-ignored-cited-headers "." - "*Delete these headers from the messages you yank." + "Delete these headers from the messages you yank." :group 'message-insertion :link '(custom-manual "(message)Insertion Variables") :type 'regexp) (defcustom message-cite-prefix-regexp mail-citation-prefix-regexp - "*Regexp matching the longest possible citation prefix on a line." + "Regexp matching the longest possible citation prefix on a line." :version "24.1" :group 'message-insertion :link '(custom-manual "(message)Insertion Variables") @@ -746,7 +748,7 @@ These are used when composing a wide reply." :type '(repeat string)) (defcustom message-use-followup-to 'ask - "*Specifies what to do with Followup-To header. + "Specifies what to do with Followup-To header. If nil, always ignore the header. If it is t, use its value, but query before using the \"poster\" value. If it is the symbol `ask', always query the user whether to use the value. If it is the symbol @@ -759,7 +761,7 @@ always query the user whether to use the value. If it is the symbol (const ask))) (defcustom message-use-mail-followup-to 'use - "*Specifies what to do with Mail-Followup-To header. + "Specifies what to do with Mail-Followup-To header. If nil, always ignore the header. If it is the symbol `ask', always query the user whether to use the value. If it is the symbol `use', always use the value." @@ -771,7 +773,7 @@ always use the value." (const ask))) (defcustom message-subscribed-address-functions nil - "*Specifies functions for determining list subscription. + "Specifies functions for determining list subscription. If nil, do not attempt to determine list subscription with functions. If non-nil, this variable contains a list of functions which return regular expressions to match lists. These functions can be used in @@ -783,7 +785,7 @@ conjunction with `message-subscribed-regexps' and :type '(repeat sexp)) (defcustom message-subscribed-address-file nil - "*A file containing addresses the user is subscribed to. + "A file containing addresses the user is subscribed to. If nil, do not look at any files to determine list subscriptions. If non-nil, each line of this file should be a mailing list address." :version "22.1" @@ -792,7 +794,7 @@ non-nil, each line of this file should be a mailing list address." :type '(radio file (const nil))) (defcustom message-subscribed-addresses nil - "*Specifies a list of addresses the user is subscribed to. + "Specifies a list of addresses the user is subscribed to. If nil, do not use any predefined list subscriptions. This list of addresses can be used in conjunction with `message-subscribed-address-functions' and `message-subscribed-regexps'." @@ -802,7 +804,7 @@ addresses can be used in conjunction with :type '(repeat string)) (defcustom message-subscribed-regexps nil - "*Specifies a list of addresses the user is subscribed to. + "Specifies a list of addresses the user is subscribed to. If nil, do not use any predefined list subscriptions. This list of regular expressions can be used in conjunction with `message-subscribed-address-functions' and `message-subscribed-addresses'." @@ -824,7 +826,7 @@ symbol `never', the posting is not allowed. If it is the symbol (const ask))) (defcustom message-sendmail-f-is-evil nil - "*Non-nil means don't add \"-f username\" to the sendmail command line. + "Non-nil means don't add \"-f username\" to the sendmail command line. Doing so would be even more evil than leaving it out." :group 'message-sending :link '(custom-manual "(message)Mail Variables") @@ -833,7 +835,7 @@ Doing so would be even more evil than leaving it out." (defcustom message-sendmail-envelope-from ;; `mail-envelope-from' is unavailable unless sendmail.el is loaded. (if (boundp 'mail-envelope-from) mail-envelope-from) - "*Envelope-from when sending mail with sendmail. + "Envelope-from when sending mail with sendmail. If this is nil, use `user-mail-address'. If it is the symbol `header', use the From: header of the message." :version "23.2" @@ -881,7 +883,7 @@ might set this variable to (\"-f\" \"you@some.where\")." ((boundp 'gnus-select-method) gnus-select-method) (t '(nnspool ""))) - "*Method used to post news. + "Method used to post news. Note that when posting from inside Gnus, for instance, this variable isn't used." :group 'message-news @@ -962,7 +964,7 @@ the signature is inserted." :group 'message-various) (defcustom message-citation-line-function 'message-insert-citation-line - "*Function called to insert the \"Whomever writes:\" line. + "Function called to insert the \"Whomever writes:\" line. Predefined functions include `message-insert-citation-line' and `message-insert-formatted-citation-line' (see the variable @@ -1011,7 +1013,7 @@ Please also read the note in the documentation of :group 'message-insertion) (defcustom message-yank-prefix mail-yank-prefix - "*Prefix inserted on the lines of yanked messages. + "Prefix inserted on the lines of yanked messages. Fix `message-cite-prefix-regexp' if it is set to an abnormal value. See also `message-yank-cited-prefix' and `message-yank-empty-prefix'." :version "23.2" @@ -1020,7 +1022,7 @@ See also `message-yank-cited-prefix' and `message-yank-empty-prefix'." :group 'message-insertion) (defcustom message-yank-cited-prefix ">" - "*Prefix inserted on cited lines of yanked messages. + "Prefix inserted on cited lines of yanked messages. Fix `message-cite-prefix-regexp' if it is set to an abnormal value. See also `message-yank-prefix' and `message-yank-empty-prefix'." :version "22.1" @@ -1029,7 +1031,7 @@ See also `message-yank-prefix' and `message-yank-empty-prefix'." :group 'message-insertion) (defcustom message-yank-empty-prefix ">" - "*Prefix inserted on empty lines of yanked messages. + "Prefix inserted on empty lines of yanked messages. See also `message-yank-prefix' and `message-yank-cited-prefix'." :version "22.1" :type 'string @@ -1037,7 +1039,7 @@ See also `message-yank-prefix' and `message-yank-cited-prefix'." :group 'message-insertion) (defcustom message-indentation-spaces mail-indentation-spaces - "*Number of spaces to insert at the beginning of each cited line. + "Number of spaces to insert at the beginning of each cited line. Used by `message-yank-original' via `message-yank-cite'." :version "23.2" :group 'message-insertion @@ -1045,7 +1047,7 @@ Used by `message-yank-original' via `message-yank-cite'." :type 'integer) (defcustom message-cite-function 'message-cite-original-without-signature - "*Function for citing an original message. + "Function for citing an original message. Predefined functions include `message-cite-original' and `message-cite-original-without-signature'. Note that these functions use `mail-citation-hook' if that is non-nil." @@ -1058,7 +1060,7 @@ Note that these functions use `mail-citation-hook' if that is non-nil." :group 'message-insertion) (defcustom message-indent-citation-function 'message-indent-citation - "*Function for modifying a citation just inserted in the mail buffer. + "Function for modifying a citation just inserted in the mail buffer. This can also be a list of functions. Each function can find the citation between (point) and (mark t). And each function should leave point and mark around the citation text as modified." @@ -1067,7 +1069,7 @@ point and mark around the citation text as modified." :group 'message-insertion) (defcustom message-signature mail-signature - "*String to be inserted at the end of the message buffer. + "String to be inserted at the end of the message buffer. If t, the `message-signature-file' file will be inserted instead. If a function, the result from the function will be used instead. If a form, the result from the form will be used instead." @@ -1080,7 +1082,7 @@ If a form, the result from the form will be used instead." :group 'message-insertion) (defcustom message-signature-file mail-signature-file - "*Name of file containing the text inserted at end of message buffer. + "Name of file containing the text inserted at end of message buffer. Ignored if the named file doesn't exist. If nil, don't insert a signature. If a path is specified, the value of `message-signature-directory' is ignored, @@ -1091,7 +1093,7 @@ even if set." :group 'message-insertion) (defcustom message-signature-directory nil - "*Name of directory containing signature files. + "Name of directory containing signature files. Comes in handy if you have many such files, handled via posting styles for instance. If nil, `message-signature-file' is expected to specify the directory if @@ -1101,14 +1103,14 @@ needed." :group 'message-insertion) (defcustom message-signature-insert-empty-line t - "*If non-nil, insert an empty line before the signature separator." + "If non-nil, insert an empty line before the signature separator." :version "22.1" :type 'boolean :link '(custom-manual "(message)Insertion Variables") :group 'message-insertion) (defcustom message-cite-reply-position 'traditional - "*Where the reply should be positioned. + "Where the reply should be positioned. If `traditional', reply inline. If `above', reply above quoted text. If `below', reply below quoted text. @@ -1125,7 +1127,7 @@ e.g. using `gnus-posting-styles': :group 'message-insertion) (defcustom message-cite-style nil - "*The overall style to be used when yanking cited text. + "The overall style to be used when yanking cited text. Value is either nil (no variable overrides) or a let-style list of pairs (VARIABLE VALUE) that will be bound in `message-yank-original' to do the quoting. @@ -1174,7 +1176,7 @@ use in `gnus-posting-styles', such as: "Message citation style used by Gmail. Use with message-cite-style.") (defcustom message-distribution-function nil - "*Function called to return a Distribution header." + "Function called to return a Distribution header." :group 'message-news :group 'message-headers :link '(custom-manual "(message)News Headers") @@ -1249,12 +1251,8 @@ called and its result is inserted." (if (and (boundp 'mail-archive-file-name) (stringp mail-archive-file-name)) (format "FCC: %s\n" mail-archive-file-name)) - ;; Use the value of `mail-default-headers' if available. - ;; Note: as for XEmacs 21.4 and 21.5, it is unavailable - ;; unless sendmail.el is loaded. - (if (boundp 'mail-default-headers) - mail-default-headers)) - "*A string of header lines to be inserted in outgoing mails." + mail-default-headers) + "A string of header lines to be inserted in outgoing mails." :version "23.2" :group 'message-headers :group 'message-mail @@ -1262,7 +1260,7 @@ called and its result is inserted." :type 'message-header-lines) (defcustom message-default-news-headers "" - "*A string of header lines to be inserted in outgoing news articles." + "A string of header lines to be inserted in outgoing news articles." :group 'message-headers :group 'message-news :link '(custom-manual "(message)News Headers") @@ -1284,7 +1282,7 @@ called and its result is inserted." ;; 33 and 126, except colon)", i. e., any chars except ctl chars, ;; space, or colon. '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) - "*Set this non-nil if the system's mailer runs the header and body together. + "Set this non-nil if the system's mailer runs the header and body together. \(This problem exists on Sunos 4 when sendmail is run in remote mode.) The value should be an expression to test whether the problem will actually occur." @@ -1316,7 +1314,7 @@ PREDICATE returns non-nil. FUNCTION is called with one parameter -- the prefix.") (defcustom message-mail-alias-type 'abbrev - "*What alias expansion type to use in Message buffers. + "What alias expansion type to use in Message buffers. The default is `abbrev', which uses mailabbrev. `ecomplete' uses an electric completion mode. nil switches mail aliases off. This can also be a list of values." @@ -1340,26 +1338,29 @@ text and it replaces `self-insert-command' with the other command, e.g. (if (file-writable-p message-directory) (file-name-as-directory (expand-file-name "drafts" message-directory)) "~/") - "*Directory where Message auto-saves buffers if Gnus isn't running. + "Directory where Message auto-saves buffers if Gnus isn't running. If nil, Message won't auto-save." :group 'message-buffers :link '(custom-manual "(message)Various Message Variables") :type '(choice directory (const :tag "Don't auto-save" nil))) -(defcustom message-default-charset - (and (not (mm-multibyte-p)) 'iso-8859-1) +(defcustom message-default-charset (and (not (mm-multibyte-p)) 'iso-8859-1) "Default charset used in non-MULE Emacsen. If nil, you might be asked to input the charset." :version "21.1" :group 'message :link '(custom-manual "(message)Various Message Variables") :type 'symbol) +(make-obsolete-variable + 'message-default-charset + "The default charset comes from the language environment" "26.1") -(defcustom message-dont-reply-to-names - (and (boundp 'mail-dont-reply-to-names) mail-dont-reply-to-names) - "*Addresses to prune when doing wide replies. -This can be a regexp or a list of regexps. Also, a value of nil means -exclude your own user name only." +(defcustom message-dont-reply-to-names mail-dont-reply-to-names + "Addresses to prune when doing wide replies. +This can be a regexp, a list of regexps or a predicate function. +Also, a value of nil means exclude your own user name only. + +If a function email is passed as the argument." :version "24.3" :group 'message :link '(custom-manual "(message)Wide Reply") @@ -1368,10 +1369,12 @@ exclude your own user name only." (repeat :tag "Regexp List" regexp))) (defsubst message-dont-reply-to-names () - (gmm-regexp-concat message-dont-reply-to-names)) + (if (functionp message-dont-reply-to-names) + message-dont-reply-to-names + (gmm-regexp-concat message-dont-reply-to-names))) -(defvar message-shoot-gnksa-feet nil - "*A list of GNKSA feet you are allowed to shoot. +(defcustom message-shoot-gnksa-feet nil + "A list of GNKSA feet you are allowed to shoot. Gnus gives you all the opportunity you could possibly want for shooting yourself in the foot. Also, Gnus allows you to shoot the feet of Good Net-Keeping Seal of Approval. The following are foot @@ -1381,7 +1384,11 @@ candidates: `multiple-copies' Allow you to post multiple copies; `cancel-messages' Allow you to cancel or supersede messages from your other email addresses; -`canlock-verify' Allow you to cancel messages without verifying canlock.") +`canlock-verify' Allow you to cancel messages without verifying canlock." + :group 'message + :type '(set (const empty-article) (const quoted-text-only) + (const multiple-copies) (const cancel-messages) + (const canlock-verify))) (defsubst message-gnksa-enable-p (feature) (or (not (listp message-shoot-gnksa-feet)) @@ -1630,11 +1637,6 @@ starting with `not' and followed by regexps." (0 'message-mml)))) "Additional expressions to highlight in Message mode.") - -;; XEmacs does it like this. For Emacs, we have to set the -;; `font-lock-defaults' buffer-local variable. -(put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t)) - (defvar message-face-alist '((bold . message-bold-region) (underline . underline-region) @@ -1676,12 +1678,8 @@ news." (defvar message-send-coding-system 'binary "Coding system to encode outgoing mail.") -(defvar message-draft-coding-system - mm-auto-save-coding-system - "*Coding system to compose mail. -If you'd like to make it possible to share draft files between XEmacs -and Emacs, you may use `iso-2022-7bit' for this value at your own risk. -Note that the coding-system `iso-2022-7bit' isn't suitable to all data.") +(defvar message-draft-coding-system mm-auto-save-coding-system + "Coding system to compose mail.") (defcustom message-send-mail-partially-limit nil "The limitation of messages sent as message/partial. @@ -1694,17 +1692,20 @@ should be sent in several parts. If it is nil, the size is unlimited." (integer 1000000))) (defcustom message-alternative-emails nil - "*Regexp matching alternative email addresses. + "Regexp or predicate function matching alternative email addresses. The first address in the To, Cc or From headers of the original article matching this variable is used as the From field of outgoing messages. +If a function, an email string is passed as the argument. + This variable has precedence over posting styles and anything that runs off `message-setup-hook'." :group 'message-headers :link '(custom-manual "(message)Message Headers") :type '(choice (const :tag "Always use primary" nil) - regexp)) + regexp + function)) (defcustom message-hierarchical-addresses nil "A list of hierarchical mail address definitions. @@ -1754,32 +1755,16 @@ no, only reply back to the author." :type 'boolean) (defcustom message-user-fqdn nil - "*Domain part of Message-Ids." + "Domain part of Message-Ids." :version "22.1" :group 'message-headers :link '(custom-manual "(message)News Headers") :type '(radio (const :format "%v " nil) (string :format "FQDN: %v"))) -(defcustom message-use-idna - (and (or (mm-coding-system-p 'utf-8) - (condition-case nil - (let (mucs-ignore-version-incompatibilities) - (require 'un-define)) - (error))) - (condition-case nil - (require 'idna) - (file-error) - (invalid-operation)) - idna-program - (executable-find idna-program) - (string= (idna-to-ascii "räksmörgås") "xn--rksmrgs-5wao1o") - t) - "Whether to encode non-ASCII in domain names into ASCII according to IDNA. -GNU Libidn, and in particular the elisp package \"idna.el\" and -the external program \"idn\", must be installed for this -functionality to work." - :version "22.1" +(defcustom message-use-idna t + "Whether to encode non-ASCII in domain names into ASCII according to IDNA." + :version "26.1" :group 'message-headers :link '(custom-manual "(message)IDNA") :type '(choice (const :tag "Ask" ask) @@ -1787,7 +1772,7 @@ functionality to work." (const :tag "Always" t))) (defcustom message-generate-hashcash (if (executable-find "hashcash") 'opportunistic) - "*Whether to generate X-Hashcash: headers. + "Whether to generate X-Hashcash: headers. If t, always generate hashcash headers. If `opportunistic', only generate hashcash headers if it can be done without the user waiting (i.e., only asynchronously). @@ -1910,12 +1895,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (defvar message-options nil "Some saved answers when sending message.") -;; FIXME: On XEmacs this causes problems since let-binding like: -;; (let ((message-options message-options)) ...) -;; as in `message-send' and `mml-preview' loses to buffer-local -;; variable initialization. -(unless (featurep 'xemacs) - (make-variable-buffer-local 'message-options)) +(make-variable-buffer-local 'message-options) (defvar message-send-mail-real-function nil "Internal send mail function.") @@ -1923,63 +1903,6 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (defvar message-bogus-system-names "\\`localhost\\.\\|\\.local\\'" "The regexp of bogus system names.") -(defcustom message-valid-fqdn-regexp - (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain. - ;; valid TLDs: - "\\([a-z][a-z]\\|" ;; two letter country TDLs - "aero\\|arpa\\|asia\\|bitnet\\|biz\\|bofh\\|" - "cat\\|com\\|coop\\|edu\\|gov\\|" - "info\\|int\\|jobs\\|" - "mil\\|mobi\\|museum\\|name\\|net\\|" - "org\\|pro\\|tel\\|travel\\|uucp\\|" - ;; ICANN-era generic top-level domains - "academy\\|actor\\|agency\\|airforce\\|archi\\|associates\\|axa\\|" - "bar\\|bargains\\|bayern\\|beer\\|berlin\\|best\\|bid\\|bike\\|" - "biz\\|black\\|blackfriday\\|blue\\|boutique\\|build\\|builders\\|" - "buzz\\|cab\\|camera\\|camp\\|capital\\|cards\\|care\\|career\\|" - "careers\\|cash\\|catering\\|center\\|ceo\\|cheap\\|christmas\\|" - "church\\|citic\\|cleaning\\|clinic\\|clothing\\|club\\|codes\\|" - "coffee\\|college\\|cologne\\|com\\|community\\|company\\|computer\\|" - "construction\\|contractors\\|cooking\\|cool\\|country\\|creditcard\\|" - "cruises\\|dance\\|dating\\|democrat\\|dental\\|desi\\|design\\|" - "diamonds\\|directory\\|discount\\|domains\\|education\\|email\\|" - "engineering\\|enterprises\\|equipment\\|estate\\|eus\\|events\\|" - "exchange\\|expert\\|exposed\\|fail\\|farm\\|feedback\\|finance\\|" - "financial\\|fish\\|fishing\\|fitness\\|flights\\|florist\\|foo\\|" - "foundation\\|frogans\\|fund\\|furniture\\|futbol\\|gal\\|" - "gallery\\|gift\\|glass\\|globo\\|gmo\\|gop\\|graphics\\|gratis\\|" - "gripe\\|guide\\|guitars\\|guru\\|hamburg\\|haus\\|hiphop\\|" - "holdings\\|holiday\\|homes\\|horse\\|house\\|immobilien\\|" - "industries\\|info\\|ink\\|institute\\|insure\\|international\\|" - "investments\\|jetzt\\|juegos\\|kaufen\\|kim\\|kitchen\\|kiwi\\|" - "koeln\\|kred\\|land\\|lat\\|latino\\|lease\\|life\\|lighting\\|" - "limited\\|limo\\|link\\|loans\\|london\\|luxe\\|luxury\\|" - "management\\|mango\\|marketing\\|media\\|meet\\|menu\\|miami\\|" - "moda\\|moe\\|monash\\|moscow\\|motorcycles\\|nagoya\\|name\\|" - "net\\|neustar\\|ninja\\|nyc\\|okinawa\\|onl\\|org\\|paris\\|" - "partners\\|parts\\|photo\\|photography\\|photos\\|pics\\|" - "pictures\\|pink\\|plumbing\\|pro\\|productions\\|properties\\|" - "pub\\|qpon\\|quebec\\|recipes\\|red\\|reisen\\|ren\\|rentals\\|" - "repair\\|report\\|rest\\|reviews\\|rich\\|rocks\\|rodeo\\|" - "ruhr\\|ryukyu\\|saarland\\|schule\\|scot\\|services\\|sexy\\|" - "shiksha\\|shoes\\|singles\\|social\\|sohu\\|solar\\|solutions\\|" - "soy\\|supplies\\|supply\\|support\\|surgery\\|systems\\|tattoo\\|" - "tax\\|technology\\|tienda\\|tips\\|today\\|tokyo\\|tools\\|" - "town\\|toys\\|trade\\|training\\|university\\|uno\\|vacations\\|" - "vegas\\|ventures\\|viajes\\|villas\\|vision\\|vodka\\|vote\\|" - "voting\\|voto\\|voyage\\|wang\\|watch\\|webcam\\|wed\\|wien\\|" - "wiki\\|works\\|wtc\\|wtf\\|xyz\\|yachts\\|yokohama\\|you\\|" - "zone\\)") - ;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains - ;; http://en.wikipedia.org/wiki/GTLD - ;; `approved, but not yet in operation': .xxx - ;; "dead" nato bitnet uucp - "Regular expression that matches a valid FQDN." - ;; see also: gnus-button-valid-fqdn-regexp - :version "25.1" - :group 'message-headers - :type 'regexp) - (autoload 'gnus-alive-p "gnus-util") (autoload 'gnus-delay-article "gnus-delay") (autoload 'gnus-extract-address-components "gnus-util") @@ -1988,14 +1911,11 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (autoload 'gnus-group-name-charset "gnus-group") (autoload 'gnus-group-name-decode "gnus-group") (autoload 'gnus-groups-from-server "gnus") -(autoload 'gnus-make-local-hook "gnus-util") (autoload 'gnus-open-server "gnus-int") (autoload 'gnus-output-to-mail "gnus-util") (autoload 'gnus-output-to-rmail "gnus-util") (autoload 'gnus-request-post "gnus-int") -(autoload 'gnus-select-frame-set-input-focus "gnus-util") (autoload 'gnus-server-string "gnus") -(autoload 'idna-to-ascii "idna") (autoload 'message-setup-toolbar "messagexmas") (autoload 'mh-new-draft-name "mh-comp") (autoload 'mh-send-letter "mh-comp") @@ -2005,20 +1925,8 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (autoload 'rmail-msg-is-pruned "rmail") (autoload 'rmail-output "rmailout") -;; Emacs < 24.1 do not have mail-dont-reply-to -(unless (fboundp 'mail-dont-reply-to) - (defalias 'mail-dont-reply-to 'rmail-dont-reply-to)) - -(eval-and-compile - (if (featurep 'emacs) - (progn - (defun message-kill-all-overlays () - (mapcar #'delete-overlay (overlays-in (point-min) (point-max)))) - (defalias 'message-window-inside-pixel-edges - 'window-inside-pixel-edges)) - (defun message-kill-all-overlays () - (map-extents (lambda (extent ignore) (delete-extent extent)))) - (defalias 'message-window-inside-pixel-edges 'ignore))) +(defun message-kill-all-overlays () + (mapcar #'delete-overlay (overlays-in (point-min) (point-max)))) @@ -2238,8 +2146,8 @@ contains a valid encoded word. Decode again? " ;; No double encoded subject? => bogus charset. (unless cs-coding (setq cs-coding - (mm-read-coding-system - (gnus-format-message "\ + (read-coding-system + (format-message "\ Decoded Subject \"%s\" contains an encoded word. The charset `%s' is unknown or invalid. Hit RET to replace non-decodable characters with \"%s\" or enter replacement @@ -2277,33 +2185,26 @@ charset: " "Remove trailing \"(was: <old subject>)\" from SUBJECT lines. Leading \"Re: \" is not stripped by this function. Use the function `message-strip-subject-re' for this." - (let* ((query message-subject-trailing-was-query) - (new) (found)) - (setq found - (string-match - (if (eq query 'ask) - message-subject-trailing-was-ask-regexp - message-subject-trailing-was-regexp) - subject)) - (if found - (setq new (substring subject 0 (match-beginning 0)))) - (if (or (not found) (eq query nil)) - subject - (if (eq query 'ask) - (if (message-y-or-n-p - "Strip `(was: <old subject>)' in subject? " t - (concat - "Strip `(was: <old subject>)' in subject " - "and use the new one instead?\n\n" - "Current subject is: \"" - subject "\"\n\n" - "New subject would be: \"" - new "\"\n\n" - "See the variable `message-subject-trailing-was-query' " - "to get rid of this query." - )) - new subject) - new)))) + (or + (let ((query message-subject-trailing-was-query) new) + (and query + (string-match (if (eq query 'ask) + message-subject-trailing-was-ask-regexp + message-subject-trailing-was-regexp) + subject) + (setq new (substring subject 0 (match-beginning 0))) + (or (not (eq query 'ask)) + (message-y-or-n-p + "Strip `(was: <old subject>)' in subject? " t + (concat + "Strip `(was: <old subject>)' in subject " + "and use the new one instead?\n\n" + "Current subject is: \"" subject "\"\n\n" + "New subject would be: \"" new "\"\n\n" + "See the variable `message-subject-trailing-was-query' " + "to get rid of this query."))) + new)) + subject)) ;;; Suggested by Jonas Steverud @ www.dtek.chalmers.se/~d4jonas/ @@ -2702,19 +2603,16 @@ Prefixed with one \\[universal-argument], display the Emacs MIME manual. With two \\[universal-argument]'s, display the EasyPG or PGG manual, depending on the value of `mml2015-use'." (interactive "p") - ;; Don't use `info' because support for `(filename)nodename' is not - ;; available in XEmacs < 21.5.12. - (Info-goto-node (format "(%s)Top" - (cond ((eq arg 16) - (require 'mml2015) - mml2015-use) - ((eq arg 4) 'emacs-mime) - ;; `booleanp' only available in Emacs 22+ - ((and (not (memq arg '(nil t))) - (symbolp arg)) - arg) - (t - 'message))))) + (info (format "(%s)Top" + (cond ((eq arg 16) + (require 'mml2015) + mml2015-use) + ((eq arg 4) 'emacs-mime) + ((and (not (booleanp arg)) + (symbolp arg)) + arg) + (t + 'message))))) @@ -2812,43 +2710,29 @@ PGG manual, depending on the value of `mml2015-use'." ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)] ["Elide Region" message-elide-region :active (message-mark-active-p) - ,@(if (featurep 'xemacs) nil - '(:help "Replace text in region with an ellipsis"))] + :help "Replace text in region with an ellipsis"] ["Delete Outside Region" message-delete-not-region :active (message-mark-active-p) - ,@(if (featurep 'xemacs) nil - '(:help "Delete all quoted text outside region"))] + :help "Delete all quoted text outside region"] ["Kill To Signature" message-kill-to-signature t] ["Newline and Reformat" message-newline-and-reformat t] ["Rename buffer" message-rename-buffer t] - ["Spellcheck" ispell-message - ,@(if (featurep 'xemacs) '(t) - '(:help "Spellcheck this message"))] + ["Spellcheck" ispell-message :help "Spellcheck this message"] "----" ["Insert Region Marked" message-mark-inserted-region - :active (message-mark-active-p) - ,@(if (featurep 'xemacs) nil - '(:help "Mark region with enclosing tags"))] + :active (message-mark-active-p) :help "Mark region with enclosing tags"] ["Insert File Marked..." message-mark-insert-file - ,@(if (featurep 'xemacs) '(t) - '(:help "Insert file at point marked with enclosing tags"))] + :help "Insert file at point marked with enclosing tags"] "----" - ["Send Message" message-send-and-exit - ,@(if (featurep 'xemacs) '(t) - '(:help "Send this message"))] + ["Send Message" message-send-and-exit :help "Send this message"] ["Postpone Message" message-dont-send - ,@(if (featurep 'xemacs) '(t) - '(:help "File this draft message and exit"))] + :help "File this draft message and exit"] ["Send at Specific Time..." gnus-delay-article - ,@(if (featurep 'xemacs) '(t) - '(:help "Ask, then arrange to send message at that time"))] + :help "Ask, then arrange to send message at that time"] ["Kill Message" message-kill-buffer - ,@(if (featurep 'xemacs) '(t) - '(:help "Delete this message without sending"))] + :help "Delete this message without sending"] "----" - ["Message manual" message-info - ,@(if (featurep 'xemacs) '(t) - '(:help "Display the Message manual"))])) + ["Message manual" message-info :help "Display the Message manual"])) (easy-menu-define message-mode-field-menu message-mode-map "" @@ -2862,15 +2746,12 @@ PGG manual, depending on the value of `mml2015-use'." ["Fcc" message-goto-fcc t] ["Reply-To" message-goto-reply-to t] ["Flag As Important" message-insert-importance-high - ,@(if (featurep 'xemacs) '(t) - '(:help "Mark this message as important"))] + :help "Mark this message as important"] ["Flag As Unimportant" message-insert-importance-low - ,@(if (featurep 'xemacs) '(t) - '(:help "Mark this message as unimportant"))] + :help "Mark this message as unimportant"] ["Request Receipt" message-insert-disposition-notification-to - ,@(if (featurep 'xemacs) '(t) - '(:help "Request a receipt notification"))] + :help "Request a receipt notification"] "----" ;; (typical) news stuff ["Summary" message-goto-summary t] @@ -2886,18 +2767,14 @@ PGG manual, depending on the value of `mml2015-use'." "----" ;; (typical) mailing-lists stuff ["Fetch To" message-insert-to - ,@(if (featurep 'xemacs) '(t) - '(:help "Insert a To header that points to the author."))] + :help "Insert a To header that points to the author."] ["Fetch To and Cc" message-insert-wide-reply - ,@(if (featurep 'xemacs) '(t) - '(:help - "Insert To and Cc headers as if you were doing a wide reply."))] + :help "Insert To and Cc headers as if you were doing a wide reply."] "----" ["Send to list only" message-to-list-only t] ["Mail-Followup-To" message-goto-mail-followup-to t] ["Unsubscribed list post" message-generate-unsubscribed-mail-followup-to - ,@(if (featurep 'xemacs) '(t) - '(:help "Insert a reasonable `Mail-Followup-To:' header."))] + :help "Insert a reasonable `Mail-Followup-To:' header."] ["Reduce To: to Cc:" message-reduce-to-to-cc t] "----" ["Sort Headers" message-sort-headers t] @@ -2943,7 +2820,6 @@ message composition doesn't break too bad." ;; category, face, display: probably doesn't do any harm. ;; fontified: is used by font-lock. ;; syntax-table, local-map: I dunno. - ;; We need to add XEmacs names to the list. "Property list of with properties forbidden in message buffers. The values of the properties are ignored, only the property names are used.") @@ -2979,8 +2855,6 @@ See also `message-forbidden-properties'." (inhibit-read-only t)) (remove-text-properties begin end message-forbidden-properties)))) -(autoload 'ecomplete-setup "ecomplete") ;; for Emacs <23. - (defvar message-smileys '(":-)" ":)" ":-(" ":(" ";-)" ";)") @@ -3078,25 +2952,19 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (set (make-local-variable 'comment-start) message-yank-prefix) (set (make-local-variable 'comment-start-skip) (concat "^" (regexp-quote message-yank-prefix) "[ \t]*"))) - (if (featurep 'xemacs) - (message-setup-toolbar) - (set (make-local-variable 'font-lock-defaults) - '(message-font-lock-keywords t)) - (if (boundp 'tool-bar-map) - (set (make-local-variable 'tool-bar-map) (message-make-tool-bar)))) + (set (make-local-variable 'font-lock-defaults) + '(message-font-lock-keywords t)) + (if (boundp 'tool-bar-map) + (set (make-local-variable 'tool-bar-map) (message-make-tool-bar))) (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) - (gnus-make-local-hook 'after-change-functions) ;; Mmmm... Forbidden properties... (add-hook 'after-change-functions 'message-strip-forbidden-properties nil 'local) ;; Allow mail alias things. (cond ((message-mail-alias-type-p 'abbrev) - (if (fboundp 'mail-abbrevs-setup) - (mail-abbrevs-setup) - (if (fboundp 'mail-aliases-setup) ; warning avoidance - (mail-aliases-setup)))) + (mail-abbrevs-setup)) ((message-mail-alias-type-p 'ecomplete) (ecomplete-setup))) (add-hook 'completion-at-point-functions 'message-completion-function nil t) @@ -3122,8 +2990,6 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (make-local-variable 'paragraph-separate) (make-local-variable 'paragraph-start) (make-local-variable 'adaptive-fill-regexp) - (unless (boundp 'adaptive-fill-first-line-regexp) - (setq adaptive-fill-first-line-regexp nil)) (make-local-variable 'adaptive-fill-first-line-regexp) (let ((quote-prefix-regexp ;; User should change message-cite-prefix-regexp if @@ -3146,20 +3012,8 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (setq adaptive-fill-first-line-regexp (concat quote-prefix-regexp "\\|" adaptive-fill-first-line-regexp))) - (make-local-variable 'auto-fill-inhibit-regexp) - ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:") - (setq auto-fill-inhibit-regexp nil) - (make-local-variable 'normal-auto-fill-function) - (setq normal-auto-fill-function 'message-do-auto-fill) - ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'. - ;; In that case, ensure that it uses the right function. The real - ;; solution would be not to use `define-derived-mode', and run - ;; `text-mode-hook' ourself at the end of the mode. - ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19. - ;; This kludge is unneeded in Emacs>=21 since define-derived-mode is - ;; now careful to run parent hooks after the body. --Stef - (when auto-fill-function - (setq auto-fill-function normal-auto-fill-function))) + (setq-local auto-fill-inhibit-regexp nil) + (setq-local normal-auto-fill-function 'message-do-auto-fill)) @@ -3250,7 +3104,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (defun message-goto-body () "Move point to the beginning of the message body." (interactive) - (when (and (gmm-called-interactively-p 'any) + (when (and (called-interactively-p 'any) (looking-at "[ \t]*\n")) (expand-abbrev)) (push-mark) @@ -3565,22 +3419,20 @@ Prefix arg means justify as well." This function is used as the value of `fill-paragraph-function' in Message buffers and is not meant to be called directly." (interactive (list (if current-prefix-arg 'full))) - (if (if (boundp 'filladapt-mode) filladapt-mode) - nil - (if (message-point-in-header-p) - (message-fill-field) - (message-newline-and-reformat arg t)) - t)) + (if (message-point-in-header-p) + (message-fill-field) + (message-newline-and-reformat arg t)) + t) (defun message-point-in-header-p () "Return t if point is in the header." (save-excursion - (and - (not - (re-search-backward - (concat "^" (regexp-quote mail-header-separator) "\n") nil t)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n") nil t)))) + (save-restriction + (widen) + (let ((bound (+ (point-at-eol) 1)) case-fold-search) + (goto-char (point-min)) + (not (search-forward (concat "\n" mail-header-separator "\n") + bound t)))))) (defun message-do-auto-fill () "Like `do-auto-fill', but don't fill in message header." @@ -3854,15 +3706,11 @@ If REMOVE is non-nil, remove newlines, too. To use this automatically, you may add this function to `gnus-message-setup-hook'." (interactive "P") - (let ((citexp - (concat - "^\\(" - (when (boundp 'message-yank-cited-prefix) - (concat message-yank-cited-prefix "\\|")) - message-yank-prefix - "\\)+ *\n" - ))) - (gnus-message 8 "removing `%s'" citexp) + (let ((citexp (concat "^\\(" + (concat message-yank-cited-prefix "\\|") + message-yank-prefix + "\\)+ *\n"))) + (message "Removing `%s'" citexp) (save-excursion (message-goto-body) (while (re-search-forward citexp nil t) @@ -4020,8 +3868,13 @@ This function uses `mail-citation-hook' if that is non-nil." (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. +the From header and the Date header respectively. + +The optional TZ is omitted or nil for Emacs local time, t for +Universal Time, `wall' for system wall clock time, or a string as +in the TZ environment variable. It can also be a list (as from +`current-time-zone') or an integer (as from `decode-time') +applied without consideration for daylight saving time. See `message-citation-line-format'." ;; The optional args are for testing/debugging. They will disappear later. @@ -4112,7 +3965,7 @@ See `message-citation-line-format'." (>= i ?a))) (push i lst) (push (condition-case nil - (gmm-format-time-string (format "%%%c" i) time tz) + (format-time-string (format "%%%c" i) time tz) (error (format ">%c<" i))) lst)) (setq i (1+ i))) @@ -4283,7 +4136,7 @@ It should typically alter the sending method in some way or other." (or (eq message-allow-no-recipients 'always) (and (not (eq message-allow-no-recipients 'never)) (setq dont-barf-on-no-method - (gnus-y-or-n-p + (y-or-n-p (format "No receiver, perform %s anyway? " (cond ((and fcc gcc) "Fcc and Gcc") (fcc "Fcc") @@ -4353,14 +4206,14 @@ not have PROP." (nreverse regions))) (defcustom message-bogus-addresses - '("noreply" "nospam" "invalid" "@@" "[^[:ascii:]].*@" "[ \t]") + '("noreply" "nospam" "invalid" "@.*@" "[^[:ascii:]].*@" "[ \t]") "List of regexps of potentially bogus mail addresses. See `message-check-recipients' how to setup checking. This list should make it possible to catch typos or warn about spam-trap addresses. It doesn't aim to verify strict RFC conformance." - :version "23.1" ;; No Gnus + :version "26.1" ; @@ -> @.*@ :group 'message-headers :type '(choice (const :tag "None" nil) @@ -4369,10 +4222,9 @@ conformance." (const "noreply") (const "nospam") (const "invalid") - (const :tag "duplicate @" "@@") + (const :tag "duplicate @" "@.*@") (const :tag "non-ascii local part" "[^[:ascii:]].*@") - ;; Already caught by `message-valid-fqdn-regexp' - ;; (const :tag "`_' in domain part" "@.*_") + (const :tag "`_' in domain part" "@.*_") (const :tag "whitespace" "[ \t]")) (repeat :inline t :tag "Other" @@ -4418,7 +4270,7 @@ conformance." (point) 'no-illegible-text) (point-max)))) (setq char (char-after))) - (when (or (< (mm-char-int char) 128) + (when (or (< char 128) (and (mm-multibyte-p) (memq (char-charset char) '(eight-bit-control eight-bit-graphic @@ -4432,23 +4284,25 @@ conformance." (forward-char)) (when found (setq choice - (gnus-multiple-choice - (if nul-chars - "NUL characters found, which may cause problems. Continue sending?" - "Non-printable characters found. Continue sending?") - `((?d "Remove non-printable characters and send") - (?r ,(format - "Replace non-printable characters with \"%s\" and send" - message-replacement-char)) - (?s "Send as is without removing anything") - (?e "Continue editing")))) + (car + (read-multiple-choice + (if nul-chars + "NUL characters found, which may cause problems. Continue sending?" + "Non-printable characters found. Continue sending?") + `((?d "delete" "Remove non-printable characters and send") + (?r "replace" + ,(format + "Replace non-printable characters with \"%s\" and send" + message-replacement-char)) + (?s "send" "Send as is without removing anything") + (?e "edit" "Continue editing"))))) (if (eq choice ?e) (error "Non-printable characters")) (message-goto-body) (skip-chars-forward mm-7bit-chars) (while (not (eobp)) (when (let ((char (char-after))) - (or (< (mm-char-int char) 128) + (or (< char 128) (and (mm-multibyte-p) ;; FIXME: Wrong for Emacs 23 (unicode) and for ;; things like undecodable utf-8 (in Emacs 21?). @@ -4478,31 +4332,22 @@ conformance." RECIPIENTS is a mail header. Return a list of potentially bogus addresses. If none is found, return nil. -An address might be bogus if the domain part is not fully -qualified, see `message-valid-fqdn-regexp', or if there's a -matching entry in `message-bogus-addresses'." +An address might be bogus if if there's a matching entry in +`message-bogus-addresses'." ;; FIXME: How about "foo@subdomain", when the MTA adds ".domain.tld"? (let (found) (mapc (lambda (address) (setq address (or (cadr address) "")) - (when - (or (string= "" address) - (not - (or - (not (string-match "@" address)) - (string-match - (concat ".@.*\\(" - message-valid-fqdn-regexp "\\)\\'") address))) - (and message-bogus-addresses - (let ((re - (if (listp message-bogus-addresses) - (mapconcat 'identity - message-bogus-addresses - "\\|") - message-bogus-addresses))) - (string-match re address)))) + (when (or (string= "" address) + (and message-bogus-addresses + (let ((re + (if (listp message-bogus-addresses) + (mapconcat 'identity + message-bogus-addresses + "\\|") + message-bogus-addresses))) + (string-match re address)))) (push address found))) - ;; (mail-extract-address-components recipients t)) found)) @@ -4519,7 +4364,7 @@ This function could be useful in `message-setup-hook'." (dolist (bog (message-bogus-recipient-p addr)) (and bog (not (y-or-n-p - (gnus-format-message + (format-message "Address `%s'%s might be bogus. Continue? " bog ;; If the encoded version of the email address @@ -4634,7 +4479,7 @@ This function could be useful in `message-setup-hook'." (declare-function hashcash-wait-async "hashcash" (&optional buffer)) -(defun message-send-mail (&optional arg) +(defun message-send-mail (&optional _) (require 'mail-utils) (let* ((tembuf (message-generate-new-buffer-clone-locals " message temp")) (case-fold-search nil) @@ -4703,7 +4548,7 @@ This function could be useful in `message-setup-hook'." (setq message-options options) ;; Avoid copying text props (except hard newlines). (insert (with-current-buffer mailbuf - (mml-buffer-substring-no-properties-except-hard-newlines + (mml-buffer-substring-no-properties-except-some (point-min) (point-max)))) ;; Remove some headers. (message-encode-message-body) @@ -4791,6 +4636,8 @@ If you always want Gnus to send messages in one piece, set (push 'mail message-sent-message-via))) (defvar sendmail-program) +(defvar smtpmail-smtp-server) +(defvar smtpmail-smtp-service) (defvar smtpmail-smtp-user) (defun message-multi-smtp-send-mail () @@ -4970,6 +4817,8 @@ command evaluates `message-send-mail-hook' just before sending a message." (run-hooks 'message-send-mail-hook) (mailclient-send-it)) +(defvar sha1-maximum-internal-length) + (defun message-canlock-generate () "Return a string that is non-trivial to guess. Do not use this for anything important, it is cryptographically weak." @@ -5067,7 +4916,7 @@ Otherwise, generate and save a value for `canlock-password' first." ;; Avoid copying text props (except hard newlines). (insert (with-current-buffer messbuf - (mml-buffer-substring-no-properties-except-hard-newlines + (mml-buffer-substring-no-properties-except-some (point-min) (point-max)))) (message-encode-message-body) ;; Remove some headers. @@ -5452,7 +5301,7 @@ Otherwise, generate and save a value for `canlock-password' first." ;; Check for control characters. (message-check 'control-chars (if (re-search-forward - (mm-string-to-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]") + (string-to-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]") nil t) (y-or-n-p "The article contains control characters. Really post? ") @@ -5562,9 +5411,7 @@ Otherwise, generate and save a value for `canlock-password' first." (setq file (pop list)) (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file) ;; Pipe the article to the program in question. - (call-process-region (point-min) (point-max) shell-file-name - nil nil nil shell-command-switch - (match-string 1 file)) + (call-shell-region (point-min) (point-max) (match-string 1 file)) ;; Save the article. (setq file (expand-file-name file)) (unless (file-exists-p (file-name-directory file)) @@ -5818,10 +5665,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." "Make a From header." (let* ((style message-from-style) (login (or address (message-make-address))) - (fullname (or name - (and (boundp 'user-full-name) - user-full-name) - (user-full-name)))) + (fullname (or name user-full-name (user-full-name)))) (when (string= fullname "&") (setq fullname (user-login-name))) (with-temp-buffer @@ -5914,24 +5758,19 @@ give as trustworthy answer as possible." (cond ((and message-user-fqdn (stringp message-user-fqdn) - (string-match message-valid-fqdn-regexp message-user-fqdn) (not (string-match message-bogus-system-names message-user-fqdn))) ;; `message-user-fqdn' seems to be valid message-user-fqdn) - ((and (string-match message-valid-fqdn-regexp sysname) - (not (string-match message-bogus-system-names sysname))) + ((and (string-match message-bogus-system-names sysname)) ;; `system-name' returned the right result. sysname) ;; Try `mail-host-address'. - ((and (boundp 'mail-host-address) - (stringp mail-host-address) - (string-match message-valid-fqdn-regexp mail-host-address) + ((and (stringp mail-host-address) (not (string-match message-bogus-system-names mail-host-address))) mail-host-address) ;; We try `user-mail-address' as a backup. ((and user-domain (stringp user-domain) - (string-match message-valid-fqdn-regexp user-domain) (not (string-match message-bogus-system-names user-domain))) user-domain) ;; Default to this bogus thing. @@ -6005,7 +5844,7 @@ subscribed address (and not the additional To and Cc header contents)." ace) (when field (dolist (rhs - (mm-delete-duplicates + (delete-dups (mapcar (lambda (rhs) (or (cadr (split-string rhs "@")) "")) (mapcar 'downcase (mapcar @@ -6017,7 +5856,7 @@ subscribed address (and not the additional To and Cc header contents)." ;; the domain part, i.e., if it is a local user's address. (setq ace (if (string-match "\\`[[:ascii:]]*\\'" rhs) rhs - (downcase (idna-to-ascii rhs)))) + (downcase (puny-encode-domain rhs)))) (when (and (not (equal rhs ace)) (or (not (eq message-use-idna 'ask)) (y-or-n-p (format "Replace %s with %s in %s:? " @@ -6051,41 +5890,27 @@ See `message-idna-encode'." (message-idna-to-ascii-rhs-1 "Mail-Followup-To") (message-idna-to-ascii-rhs-1 "Cc"))))) -(defvar Date) -(defvar Message-ID) -(defvar Organization) -(defvar From) -(defvar Path) -(defvar Subject) -(defvar Newsgroups) -(defvar In-Reply-To) -(defvar References) -(defvar To) -(defvar Distribution) -(defvar Lines) -(defvar User-Agent) -(defvar Expires) - (defun message-generate-headers (headers) "Prepare article HEADERS. Headers already prepared in the buffer are not modified." (setq headers (append headers message-required-headers)) (save-restriction (message-narrow-to-headers) - (let* ((Date (message-make-date)) - (Message-ID (message-make-message-id)) - (Organization (message-make-organization)) - (From (message-make-from)) - (Path (message-make-path)) - (Subject nil) - (Newsgroups nil) - (In-Reply-To (message-make-in-reply-to)) - (References (message-make-references)) - (To nil) - (Distribution (message-make-distribution)) - (Lines (message-make-lines)) - (User-Agent message-newsreader) - (Expires (message-make-expires)) + (let* ((header-values + (list 'Date (message-make-date) + 'Message-ID (message-make-message-id) + 'Organization (message-make-organization) + 'From (message-make-from) + 'Path (message-make-path) + 'Subject nil + 'Newsgroups nil + 'In-Reply-To (message-make-in-reply-to) + 'References (message-make-references) + 'To nil + 'Distribution (message-make-distribution) + 'Lines (message-make-lines) + 'User-Agent message-newsreader + 'Expires (message-make-expires))) (case-fold-search t) (optionalp nil) header value elem header-string) @@ -6139,8 +5964,8 @@ Headers already prepared in the buffer are not modified." (setq header (cdr elem)) (or (and (functionp (cdr elem)) (funcall (cdr elem))) - (and (boundp (cdr elem)) - (symbol-value (cdr elem))))) + (and (symbolp (cdr elem)) + (plist-get header-values (cdr elem))))) ((consp elem) ;; The element is a cons. Either the cdr is a ;; string to be inserted verbatim, or it is a @@ -6150,11 +5975,11 @@ Headers already prepared in the buffer are not modified." (cdr elem)) (and (functionp (cdr elem)) (funcall (cdr elem))))) - ((and (boundp header) - (symbol-value header)) - ;; The element is a symbol. We insert the value - ;; of this symbol, if any. - (symbol-value header)) + ((and (symbolp header) + (plist-member header-values header)) + ;; The element is a symbol. We insert the value of + ;; this symbol, if any. + (plist-get header-values header)) ((not (message-check-element (intern (downcase (symbol-name header))))) ;; We couldn't generate a value for this header, @@ -6266,10 +6091,7 @@ Headers already prepared in the buffer are not modified." "Split current line, moving portion beyond point vertically down. If the current line has `message-yank-prefix', insert it on the new line." (interactive "*") - (condition-case nil - (split-line message-yank-prefix) ;; Emacs 22.1+ supports arg. - (error - (split-line)))) + (split-line message-yank-prefix)) (defun message-insert-header (header value) (insert (capitalize (symbol-name header)) @@ -6412,35 +6234,73 @@ they are." (defvar visual-line-mode) (declare-function beginning-of-visual-line "simple" (&optional n)) +(defun message-beginning-of-header (handle-folded) + "Move point to beginning of header’s value. + +When point is at the first header line, moves it after the colon +and spaces separating header name and header value. + +When point is in a continuation line of a folded header (i.e. the +line starts with a space), the behavior depends on HANDLE-FOLDED +argument. If it’s nil, function moves the point to the start of +the header continuation; otherwise, function locates the +beginning of the header and moves point past the colon as is the +case of single-line headers. + +No check whether point is inside of a header or body of the +message is performed. + +Returns point or nil if beginning of header’s value could not be +found. In the latter case, the point is still moved to the +beginning of line (possibly after attempting to move it to the +beginning of a folded header)." + ;; https://www.rfc-editor.org/rfc/rfc2822.txt, section 2.2.3. says that when + ;; unfolding a single WSP should be consumed. WSP is defined as a space + ;; character or a horizontal tab. + (beginning-of-line) + (when handle-folded + (while (and (> (point) (point-min)) + (or (eq (char-after) ?\s) (eq (char-after) ?\t))) + (beginning-of-line 0))) + (when (or (eq (char-after) ?\s) (eq (char-after) ?\t) + (search-forward ":" (point-at-eol) t)) + ;; We are a bit more lacks than the RFC and allow any positive number of WSP + ;; characters. + (skip-chars-forward " \t" (point-at-eol)) + (point))) + (defun message-beginning-of-line (&optional n) "Move point to beginning of header value or to beginning of line. The prefix argument N is passed directly to `beginning-of-line'. This command is identical to `beginning-of-line' if point is -outside the message header or if the option `message-beginning-of-line' -is nil. - -If point is in the message header and on a (non-continued) header -line, move point to the beginning of the header value or the beginning of line, -whichever is closer. If point is already at beginning of line, move point to -beginning of header value. Therefore, repeated calls will toggle point -between beginning of field and beginning of line." +outside the message header or if the option +`message-beginning-of-line' is nil. + +If point is in the message header and on a header line, move +point to the beginning of the header value or the beginning of +line, whichever is closer. If point is already at beginning of +line, move point to beginning of header value. Therefore, +repeated calls will toggle point between beginning of field and +beginning of line. + +When called without a prefix argument, header value spanning +multiple lines is treated as a single line. Otherwise, even if +N is 1, when point is on a continuation header line, it will be +moved to the beginning " (interactive "p") - (let ((zrs 'zmacs-region-stays)) - (when (and (featurep 'xemacs) (interactive-p) (boundp zrs)) - (set zrs t))) - (if (and message-beginning-of-line - (message-point-in-header-p)) - (let* ((here (point)) - (bol (progn (beginning-of-line n) (point))) - (eol (point-at-eol)) - (eoh (re-search-forward ": *" eol t))) - (goto-char - (if (and eoh (or (< eoh here) (= bol here))) - eoh bol))) - (if (and (boundp 'visual-line-mode) visual-line-mode) - (beginning-of-visual-line n) - (beginning-of-line n)))) + (cond + ;; Go to beginning of header or beginning of line. + ((and message-beginning-of-line (message-point-in-header-p)) + (let* ((point (point)) + (bol (progn (beginning-of-line n) (point))) + (boh (message-beginning-of-header visual-line-mode))) + (goto-char (if (and boh (or (< boh point) (= bol point))) boh bol)))) + ;; Go to beginning of visual line + (visual-line-mode + (beginning-of-visual-line n)) + ;; Go to beginning of line. + ((beginning-of-line n)))) (defun message-buffer-name (type &optional to group) "Return a new (unique) buffer name based on TYPE and TO." @@ -6507,7 +6367,7 @@ between beginning of field and beginning of line." (if window ;; Raise the frame already displaying the message buffer. (progn - (gnus-select-frame-set-input-focus (window-frame window)) + (select-frame-set-input-focus (window-frame window)) (select-window window)) (funcall (or switch-function #'pop-to-buffer) buffer) (set-buffer buffer)) @@ -6517,10 +6377,7 @@ between beginning of field and beginning of line." "Message already being composed; erase? ") (message nil)))) (error "Message being composed"))) - (funcall (or switch-function - (if (fboundp #'pop-to-buffer-same-window) - #'pop-to-buffer-same-window - #'pop-to-buffer)) + (funcall (or switch-function 'pop-to-buffer-same-window) name) (set-buffer name)) (erase-buffer) @@ -6938,9 +6795,20 @@ want to get rid of this query permanently."))) ;; Squeeze whitespace. (while (string-match "[ \t][ \t]+" recipients) (setq recipients (replace-match " " t t recipients))) - ;; Remove addresses that match `mail-dont-reply-to-names'. - (let ((mail-dont-reply-to-names (message-dont-reply-to-names))) - (setq recipients (mail-dont-reply-to recipients))) + ;; Remove addresses that match `message-dont-reply-to-names'. + (setq recipients + (cond ((functionp message-dont-reply-to-names) + (mapconcat + 'identity + (delq nil + (mapcar (lambda (mail) + (unless (funcall message-dont-reply-to-names + (mail-strip-quoted-names mail)) + mail)) + (message-tokenize-header recipients))) + ", ")) + (t (let ((mail-dont-reply-to-names (message-dont-reply-to-names))) + (mail-dont-reply-to recipients))))) ;; Perhaps "Mail-Copies-To: never" removed the only address? (if (string-equal recipients "") (setq recipients author)) @@ -7222,7 +7090,7 @@ want to get rid of this query permanently.")) If you have added `cancel-messages' to `message-shoot-gnksa-feet', all articles are yours except those that have Cancel-Lock header not belonging to you. Instead of shooting GNKSA feet, you should modify `message-alternative-emails' -regexp to match all of yours addresses." +to match all of yours addresses." ;; Canlock-logic as suggested by Per Abrahamsen ;; <abraham@dina.kvl.dk> ;; @@ -7254,12 +7122,14 @@ regexp to match all of yours addresses." (downcase (car (mail-header-parse-address (message-make-from)))))) ;; Email address in From field matches - ;; 'message-alternative-emails' regexp + ;; 'message-alternative-emails' regexp or function. (and from message-alternative-emails - (string-match - message-alternative-emails - (car (mail-header-parse-address from)))))))))) + (cond ((functionp message-alternative-emails) + (funcall message-alternative-emails + (mail-header-parse-address from))) + (t (string-match message-alternative-emails + (car (mail-header-parse-address from)))))))))))) ;;;###autoload (defun message-cancel-news (&optional arg) @@ -7339,7 +7209,7 @@ header line with the old Message-ID." (cond ((save-window-excursion (with-output-to-temp-buffer "*Directory*" (with-current-buffer standard-output - (fundamental-mode)) ; for Emacs 20.4+ + (fundamental-mode)) (buffer-disable-undo standard-output) (let ((default-directory "/")) (call-process @@ -7485,14 +7355,13 @@ Optional DIGEST will use digest to forward." (let ((b (point)) (contents (with-current-buffer forward-buffer (buffer-string))) e) - (unless (featurep 'xemacs) - (unless (mm-multibyte-string-p contents) - (error "Attempt to insert unibyte string from the buffer \"%s\"\ + (unless (multibyte-string-p contents) + (error "Attempt to insert unibyte string from the buffer \"%s\"\ to the multibyte buffer \"%s\"" - (if (bufferp forward-buffer) - (buffer-name forward-buffer) - forward-buffer) - (buffer-name)))) + (if (bufferp forward-buffer) + (buffer-name forward-buffer) + forward-buffer) + (buffer-name))) (insert (mm-with-multibyte-buffer (insert contents) (mime-to-mml) @@ -7549,14 +7418,13 @@ Optional DIGEST will use digest to forward." (let ((b (point)) e) (if (not message-forward-decoded-p) (let ((contents (with-current-buffer forward-buffer (buffer-string)))) - (unless (featurep 'xemacs) - (unless (mm-multibyte-string-p contents) - (error "Attempt to insert unibyte string from the buffer \"%s\"\ + (unless (multibyte-string-p contents) + (error "Attempt to insert unibyte string from the buffer \"%s\"\ to the multibyte buffer \"%s\"" - (if (bufferp forward-buffer) - (buffer-name forward-buffer) - forward-buffer) - (buffer-name)))) + (if (bufferp forward-buffer) + (buffer-name forward-buffer) + forward-buffer) + (buffer-name))) (insert (mm-with-multibyte-buffer (insert contents) (mime-to-mml) @@ -7688,10 +7556,8 @@ is for the internal use." (defun message-forward-rmail-make-body (forward-buffer) (save-window-excursion (set-buffer forward-buffer) - (if (rmail-msg-is-pruned) - (if (fboundp 'rmail-msg-restore-non-pruned-header) - (rmail-msg-restore-non-pruned-header) ; Emacs 22 - (rmail-toggle-header 0)))) ; Emacs 23 + (when (rmail-msg-is-pruned) + (rmail-toggle-header 0))) (message-forward-make-body forward-buffer)) ;; Fixme: Should have defcustom. @@ -7765,6 +7631,9 @@ is for the internal use." (let ((case-fold-search t)) (re-search-forward "^mime-version:" nil t))) (message-inhibit-ecomplete t) + ;; We don't want smtpmail.el to encode anything, either. + (sendmail-coding-system 'raw-text) + (select-safe-coding-system-function nil) message-required-mail-headers message-generate-hashcash rfc2047-encode-encoded-words) @@ -7941,12 +7810,10 @@ Pre-defined symbols include `message-tool-bar-gnome' and (defcustom message-tool-bar-gnome '((ispell-message "spell" nil :vert-only t - :visible (or (not (boundp 'flyspell-mode)) - (not flyspell-mode))) + :visible (not flyspell-mode)) (flyspell-buffer "spell" t :vert-only t - :visible (and (boundp 'flyspell-mode) - flyspell-mode) + :visible flyspell-mode :help "Flyspell whole buffer") (message-send-and-exit "mail/send" t :label "Send") (message-dont-send "mail/save-draft") @@ -8003,18 +7870,14 @@ See `gmm-tool-bar-from-list' for the format of the list." (defun message-make-tool-bar (&optional force) "Make a message mode tool bar from `message-tool-bar-list'. When FORCE, rebuild the tool bar." - (when (and (not (featurep 'xemacs)) - (boundp 'tool-bar-mode) + (when (and (boundp 'tool-bar-mode) tool-bar-mode (or (not message-tool-bar-map) force)) (setq message-tool-bar-map (let* ((load-path - (gmm-image-load-path-for-library "message" - "mail/save-draft.xpm" - nil t)) - (image-load-path (cons (car load-path) - (when (boundp 'image-load-path) - image-load-path)))) + (image-load-path-for-library + "message" "mail/save-draft.xpm" nil t)) + (image-load-path (cons (car load-path) image-load-path))) (gmm-tool-bar-from-list message-tool-bar message-tool-bar-zap-list 'message-mode-map)))) @@ -8048,7 +7911,7 @@ Each element is a symbol and can be `bbdb' or `eudc'." :type '(set (const bbdb) (const eudc))) (defcustom message-tab-body-function nil - "*Function to execute when `message-tab' (TAB) is executed in the body. + "Function to execute when `message-tab' (TAB) is executed in the body. If nil, the function bound in `text-mode-map' or `global-map' is executed." :version "22.1" :group 'message @@ -8065,10 +7928,8 @@ not in those headers. If that variable is nil, indent with the regular text mode tabbing command." (interactive) (cond - ((if (and (boundp 'completion-fail-discreetly) - (fboundp 'completion-at-point)) - (let ((completion-fail-discreetly t)) (completion-at-point)) - (funcall (or (message-completion-function) #'ignore))) + ((let ((completion-fail-discreetly t)) + (completion-at-point)) ;; Completion was performed; nothing else to do. nil) (message-tab-body-function (funcall message-tab-body-function)) @@ -8085,7 +7946,7 @@ regular text mode tabbing command." (not (mail-abbrev-in-expansion-header-p)))) (setq alist (cdr alist))) (when (cdar alist) - (lexical-let ((fun (cdar alist))) + (let ((fun (cdar alist))) ;; Even if completion fails, return a non-nil value, so as to avoid ;; falling back to message-tab-body-function. (lambda () (funcall fun) 'completion-attempted))))) @@ -8114,41 +7975,7 @@ regular text mode tabbing command." group) collection)) gnus-active-hashtb)) - (message-completion-in-region b e collection))) - -(defalias 'message-completion-in-region - (if (fboundp 'completion-in-region) - 'completion-in-region - (lambda (b e hashtb) - (let* ((string (buffer-substring b e)) - (completions (all-completions string hashtb)) - comp) - (delete-region b (point)) - (cond - ((= (length completions) 1) - (if (string= (car completions) string) - (progn - (insert string) - (message "Only matching group")) - (insert (car completions)))) - ((and (setq comp (try-completion string hashtb)) - (not (string= comp string))) - (insert comp)) - (t - (insert string) - (if (not comp) - (message "No matching groups") - (save-selected-window - (pop-to-buffer "*Completions*") - (buffer-disable-undo) - (let ((buffer-read-only nil)) - (erase-buffer) - (let ((standard-output (current-buffer))) - (display-completion-list (sort completions 'string<))) - (setq buffer-read-only nil) - (goto-char (point-min)) - (delete-region (point) - (progn (forward-line 3) (point)))))))))))) + (completion-in-region b e collection))) (defun message-expand-name () (cond ((and (memq 'eudc message-expand-name-databases) @@ -8177,7 +8004,7 @@ The following arguments may contain lists of values." (save-window-excursion (with-output-to-temp-buffer " *MESSAGE information message*" (with-current-buffer " *MESSAGE information message*" - (fundamental-mode) ; for Emacs 20.4+ + (fundamental-mode) (mapc 'princ text) (goto-char (point-min)))) (funcall ask question)) @@ -8270,13 +8097,9 @@ regexp VARSTR." (defun message-read-from-minibuffer (prompt &optional initial-contents) "Read from the minibuffer while providing abbrev expansion." - (if (fboundp 'mail-abbrevs-setup) - (let ((minibuffer-setup-hook 'mail-abbrevs-setup) - (minibuffer-local-map message-minibuffer-local-map)) - (read-from-minibuffer prompt initial-contents)) - (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook) - (minibuffer-local-map message-minibuffer-local-map)) - (read-string prompt initial-contents)))) + (let ((minibuffer-setup-hook 'mail-abbrevs-setup) + (minibuffer-local-map message-minibuffer-local-map)) + (read-from-minibuffer prompt initial-contents))) (defun message-use-alternative-email-as-from () "Set From field of the outgoing message to the first matching @@ -8285,16 +8108,14 @@ From headers in the original article." (require 'mail-utils) (let* ((fields '("To" "Cc" "From")) (emails - (split-string + (message-tokenize-header (mail-strip-quoted-names - (mapconcat 'message-fetch-reply-field fields ",")) - "[ \f\t\n\r\v,]+")) - email) - (while emails - (if (string-match message-alternative-emails (car emails)) - (setq email (car emails) - emails nil)) - (pop emails)) + (mapconcat 'message-fetch-reply-field fields ",")))) + (email (cond ((functionp message-alternative-emails) + (car (cl-remove-if-not message-alternative-emails emails))) + (t (loop for email in emails + if (string-match-p message-alternative-emails email) + return email))))) (unless (or (not email) (equal email user-mail-address)) (message-remove-header "From") (goto-char (point-max)) @@ -8381,8 +8202,9 @@ From headers in the original article." (let ((value (message-field-value header))) (dolist (string (mail-header-parse-addresses value 'raw)) (setq string - (gnus-replace-in-string - (gnus-replace-in-string string "^ +\\| +$" "") "\n" "")) + (replace-regexp-in-string + "\n" "" + (replace-regexp-in-string "^ +\\| +$" "" string))) (ecomplete-add-item 'mail (car (mail-header-parse-address string)) string)))) (ecomplete-save)) @@ -8493,7 +8315,7 @@ Header and body are separated by `mail-header-separator'." (when force (sit-for message-send-form-letter-delay)) (if (or force - (y-or-n-p (gnus-format-message "Send message to `%s'? " to))) + (y-or-n-p (format-message "Send message to `%s'? " to))) (progn (setq sent (1+ sent)) (message-send-and-exit)) @@ -8569,34 +8391,33 @@ Used in `message-simplify-recipients'." (defun message-toggle-image-thumbnails () "For any included image files, insert a thumbnail of that image." (interactive) - (let ((overlays (overlays-in (point-min) (point-max))) - (displayed nil)) - (while overlays - (let ((overlay (car overlays))) - (when (overlay-get overlay 'put-image) - (delete-overlay overlay) - (setq displayed t))) - (setq overlays (cdr overlays))) + (let ((displayed nil)) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when-let ((props (get-text-property (point) 'display))) + (when (and (consp props) + (eq (car props) 'image)) + (put-text-property (point) (1+ (point)) 'display nil) + (setq displayed t))) + (forward-char 1))) (unless displayed (save-excursion (goto-char (point-min)) - (while (re-search-forward "<img.*src=\"\\([^\"]+\\)" nil t) - (let ((file (match-string 1)) - (edges (message-window-inside-pixel-edges + (while (re-search-forward "<img.*src=\"\\([^\"]+\\).*>" nil t) + (let ((string (match-string 0)) + (file (match-string 1)) + (edges (window-inside-pixel-edges (get-buffer-window (current-buffer))))) - (put-image + (delete-region (match-beginning 0) (match-end 0)) + (insert-image (create-image file 'imagemagick nil :max-width (truncate (* 0.7 (- (nth 2 edges) (nth 0 edges)))) :max-height (truncate (* 0.5 (- (nth 3 edges) (nth 1 edges))))) - (match-beginning 0) - " "))))))) - -(when (featurep 'xemacs) - (require 'messagexmas) - (message-xmas-redefine)) + string))))))) (provide 'message) diff --git a/lisp/gnus/mm-archive.el b/lisp/gnus/mm-archive.el index 53b50ad268e..5ac8761f6b5 100644 --- a/lisp/gnus/mm-archive.el +++ b/lisp/gnus/mm-archive.el @@ -37,7 +37,7 @@ (defun mm-dissect-archive (handle) (let ((decoder (cddr (assoc (car (mm-handle-type handle)) mm-archive-decoders))) - (dir (mm-make-temp-file + (dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir))) (set-file-modes dir #o700) (unwind-protect diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el index 324f1806943..66b9ebd0cfc 100644 --- a/lisp/gnus/mm-bodies.el +++ b/lisp/gnus/mm-bodies.el @@ -86,15 +86,15 @@ If no encoding was done, nil is returned." (message-options-get 'mm-body-charset-encoding-alist) (message-options-set 'mm-body-charset-encoding-alist - (mm-read-coding-system "Charset used in the article: "))) + (read-coding-system "Charset used in the article: "))) ;; The logic in `mml-generate-mime-1' confirms that it's OK ;; to return nil here. nil))) (save-excursion (if charset (progn - (mm-encode-coding-region (point-min) (point-max) - (mm-charset-to-coding-system charset)) + (encode-coding-region (point-min) (point-max) + (mm-charset-to-coding-system charset)) charset) (goto-char (point-min)) (let ((charsets (mm-find-mime-charset-region (point-min) (point-max) @@ -110,8 +110,8 @@ If no encoding was done, nil is returned." (t (prog1 (setq charset (car charsets)) - (mm-encode-coding-region (point-min) (point-max) - (mm-charset-to-coding-system charset)))) + (encode-coding-region (point-min) (point-max) + (mm-charset-to-coding-system charset)))) )))))) (defun mm-long-lines-p (length) @@ -243,8 +243,7 @@ decoding. If it is nil, default to `mail-parse-charset'." (save-excursion (when encoding (mm-decode-content-transfer-encoding encoding type)) - (when (and (featurep 'mule) ;; Fixme: Wrong test for unibyte session. - (not (eq charset 'gnus-decoded))) + (when (not (eq charset 'gnus-decoded)) (let ((coding-system (mm-charset-to-coding-system ;; Allow overwrite using ;; `mm-charset-override-alist'. @@ -255,18 +254,11 @@ decoding. If it is nil, default to `mail-parse-charset'." (setq coding-system (mm-charset-to-coding-system mail-parse-charset))) (when (and charset coding-system - ;; buffer-file-coding-system - ;;Article buffer is nil coding system - ;;in XEmacs (mm-multibyte-p) (or (not (eq coding-system 'ascii)) (setq coding-system mail-parse-charset))) - (mm-decode-coding-region (point-min) (point-max) - coding-system)) - (setq buffer-file-coding-system - (if (boundp 'last-coding-system-used) - (symbol-value 'last-coding-system-used) - coding-system)))))) + (decode-coding-region (point-min) (point-max) coding-system)) + (setq buffer-file-coding-system last-coding-system-used))))) (defun mm-decode-string (string charset) "Decode STRING with CHARSET." @@ -278,22 +270,21 @@ decoding. If it is nil, default to `mail-parse-charset'." (memq charset mail-parse-ignored-charsets)) (setq charset mail-parse-charset)) (or - (when (featurep 'mule) - (let ((coding-system (mm-charset-to-coding-system - charset - ;; Allow overwrite using - ;; `mm-charset-override-alist'. - nil t))) - (if (and (not coding-system) - (listp mail-parse-ignored-charsets) - (memq 'gnus-unknown mail-parse-ignored-charsets)) - (setq coding-system - (mm-charset-to-coding-system mail-parse-charset))) - (when (and charset coding-system - (mm-multibyte-p) - (or (not (eq coding-system 'ascii)) - (setq coding-system mail-parse-charset))) - (mm-decode-coding-string string coding-system)))) + (let ((coding-system (mm-charset-to-coding-system + charset + ;; Allow overwrite using + ;; `mm-charset-override-alist'. + nil t))) + (if (and (not coding-system) + (listp mail-parse-ignored-charsets) + (memq 'gnus-unknown mail-parse-ignored-charsets)) + (setq coding-system + (mm-charset-to-coding-system mail-parse-charset))) + (when (and charset coding-system + (mm-multibyte-p) + (or (not (eq coding-system 'ascii)) + (setq coding-system mail-parse-charset))) + (decode-coding-string string coding-system))) string)) (provide 'mm-bodies) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 9f4529b951e..c3fdc75a4cc 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -28,9 +28,6 @@ (eval-when-compile (require 'cl)) (autoload 'gnus-map-function "gnus-util") -(autoload 'gnus-replace-in-string "gnus-util") -(autoload 'gnus-read-shell-command "gnus-util") -(autoload 'gnus-format-message "gnus-util") (autoload 'mm-inline-partial "mm-partial") (autoload 'mm-inline-external-body "mm-extern") @@ -291,10 +288,7 @@ before the external MIME handler is invoked." (mm-insert-part handle) (let ((image (ignore-errors - (if (fboundp 'create-image) - (create-image (buffer-string) 'imagemagick 'data-p) - (mm-create-image-xemacs - (mm-handle-media-subtype handle)))))) + (create-image (buffer-string) 'imagemagick 'data-p)))) (when image (setcar (cdr handle) (list "image/imagemagick")) (mm-image-fit-p handle))))))) @@ -388,12 +382,7 @@ enables you to choose manually one of two types those mails include." :type '(repeat regexp) ;; See `mm-preferred-alternative-precedence'. :group 'mime-display) -(defcustom mm-tmp-directory - (if (fboundp 'temp-directory) - (temp-directory) - (if (boundp 'temporary-file-directory) - temporary-file-directory - "/tmp/")) +(defcustom mm-tmp-directory temporary-file-directory "Where mm will store its temporary files." :type 'directory :group 'mime-display) @@ -436,13 +425,15 @@ functions), `mm-file-name-delete-whitespace', :group 'mime-display) -(defvar mm-path-name-rewrite-functions nil - "*List of functions for rewriting the full file names of MIME parts. +(defcustom mm-path-name-rewrite-functions nil + "List of functions for rewriting the full file names of MIME parts. This is used when viewing parts externally, and is meant for transforming the absolute name so that non-compliant programs can find the file where it's saved. -Each function takes a file name as input and returns a file name.") +Each function takes a file name as input and returns a file name." + :type '(repeat function) + :group 'mime-display) (defvar mm-file-name-replace-whitespace nil "String used for replacing whitespace characters; default is `\"_\"'.") @@ -778,7 +769,7 @@ MIME-Version header before proceeding." (with-current-buffer (generate-new-buffer " *mm*") ;; Preserve the data's unibyteness (for url-insert-file-contents). - (mm-set-buffer-multibyte mb) + (set-buffer-multibyte mb) (insert-buffer-substring obuf beg) (current-buffer)))) @@ -862,7 +853,7 @@ external if displayed external." (concat "using external program \"" (format method filename) "\"") - (gnus-format-message + (format-message "by calling `%s' on the contents)" method)) "? ")))))) (if external @@ -893,7 +884,7 @@ external if displayed external." (select-window win))) (switch-to-buffer (generate-new-buffer " *mm*"))) (buffer-disable-undo) - (mm-set-buffer-file-coding-system mm-binary-coding-system) + (set-buffer-file-coding-system mm-binary-coding-system) (insert-buffer-substring cur) (goto-char (point-min)) (when method @@ -920,7 +911,7 @@ external if displayed external." ;; The function is a string to be executed. (mm-insert-part handle) (mm-add-meta-html-tag handle) - (let* ((dir (mm-make-temp-file + (let* ((dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir)) (filename (or (mail-content-type-get @@ -950,8 +941,8 @@ external if displayed external." ;; `mailcap-mime-extensions'. (setq suffix (car (rassoc (mm-handle-media-type handle) mailcap-mime-extensions)))) - (setq file (mm-make-temp-file (expand-file-name "mm." dir) - nil suffix)))) + (setq file (make-temp-file (expand-file-name "mm." dir) + nil suffix)))) (let ((coding-system-for-write mm-binary-coding-system)) (write-region (point-min) (point-max) file nil 'nomesg)) ;; The file is deleted after the viewer exists. If the users edits @@ -1149,9 +1140,6 @@ external if displayed external." (ignore-errors (cond ;; Internally displayed part. - ((mm-annotationp object) - (if (featurep 'xemacs) - (delete-annotation object))) ((or (functionp object) (and (listp object) (eq (car object) 'lambda))) @@ -1315,7 +1303,7 @@ are ignored." (with-current-buffer (mm-handle-buffer handle) (buffer-string))) ((mm-multibyte-p) - (mm-string-to-multibyte (mm-get-part handle no-cache))) + (string-to-multibyte (mm-get-part handle no-cache))) (t (mm-get-part handle no-cache))))) (save-restriction @@ -1361,12 +1349,12 @@ string if you do not like underscores." (defun mm-file-name-delete-control (filename) "Delete control characters from FILENAME." - (gnus-replace-in-string filename "[\x00-\x1f\x7f]" "")) + (replace-regexp-in-string "[\x00-\x1f\x7f]" "" filename)) (defun mm-file-name-delete-gotchas (filename) "Delete shell gotchas from FILENAME." - (setq filename (gnus-replace-in-string filename "[<>|]" "")) - (gnus-replace-in-string filename "^[.-]+" "")) + (setq filename (replace-regexp-in-string "[<>|]" "" filename)) + (replace-regexp-in-string "^[.-]+" "" filename)) (defun mm-save-part (handle &optional prompt) "Write HANDLE to a file. @@ -1459,7 +1447,7 @@ text/\\(\\sw+\\)\\(?:;\\s-*charset=\\([^\"'>]+\\)\\)?[^>]*>" nil t) Use CMD as the process." (let ((name (mail-content-type-get (mm-handle-type handle) 'name)) (command (or cmd - (gnus-read-shell-command + (read-shell-command "Shell command on MIME part: " mm-last-shell-command)))) (mm-with-unibyte-buffer (mm-insert-part handle) @@ -1575,73 +1563,29 @@ be determined." (prog1 (setq spec (ignore-errors - ;; Avoid testing `make-glyph' since W3 may define - ;; a bogus version of it. - (if (fboundp 'create-image) - (create-image (buffer-string) - (or (mm-image-type-from-buffer) - (intern type)) - 'data-p) - (mm-create-image-xemacs type)))) + (create-image (buffer-string) + (or (mm-image-type-from-buffer) + (intern type)) + 'data-p))) (mm-handle-set-cache handle spec)))))) -(defun mm-create-image-xemacs (type) - (when (featurep 'xemacs) - (cond - ((equal type "xbm") - ;; xbm images require special handling, since - ;; the only way to create glyphs from these - ;; (without a ton of work) is to write them - ;; out to a file, and then create a file - ;; specifier. - (let ((file (mm-make-temp-file - (expand-file-name "emm" mm-tmp-directory) - nil ".xbm"))) - (unwind-protect - (progn - (write-region (point-min) (point-max) file) - (make-glyph (list (cons 'x file)))) - (ignore-errors - (delete-file file))))) - (t - (make-glyph - (vector - (or (mm-image-type-from-buffer) - (intern type)) - :data (buffer-string))))))) - (declare-function image-size "image.c" (spec &optional pixels frame)) (defun mm-image-fit-p (handle) "Say whether the image in HANDLE will fit the current window." (let ((image (mm-get-image handle))) (or (not image) - (if (featurep 'xemacs) - ;; XEmacs's glyphs can actually tell us about their width, so - ;; let's be nice and smart about them. - (or mm-inline-large-images - (and (<= (glyph-width image) (window-pixel-width)) - (<= (glyph-height image) (window-pixel-height)))) - (let* ((size (image-size image)) - (w (car size)) - (h (cdr size))) - (or mm-inline-large-images - (and (<= h (1- (window-height))) ; Don't include mode line. - (<= w (window-width))))))))) + (let* ((size (image-size image)) + (w (car size)) + (h (cdr size))) + (or mm-inline-large-images + (and (<= h (1- (window-height))) ; Don't include mode line. + (<= w (window-width)))))))) (defun mm-valid-image-format-p (format) "Say whether FORMAT can be displayed natively by Emacs." - (cond - ;; Handle XEmacs - ((fboundp 'valid-image-instantiator-format-p) - (valid-image-instantiator-format-p format)) - ;; Handle Emacs - ((fboundp 'image-type-available-p) - (and (display-graphic-p) - (image-type-available-p format))) - ;; Nobody else can do images yet. - (t - nil))) + (and (display-graphic-p) + (image-type-available-p format))) (defun mm-valid-and-fit-image-p (format handle) "Say whether FORMAT can be displayed natively and HANDLE fits the window." @@ -1839,8 +1783,7 @@ If RECURSIVE, search recursively." (defun mm-shr (handle) ;; Require since we bind its variables. (require 'shr) - (let ((shr-width (if (and (boundp 'shr-use-fonts) - shr-use-fonts) + (let ((shr-width (if shr-use-fonts nil fill-column)) (shr-content-function (lambda (id) @@ -1864,8 +1807,8 @@ If RECURSIVE, search recursively." (mm-charset-to-coding-system charset nil t)) (not (eq charset 'ascii))) - (mm-decode-coding-string (buffer-string) charset) - (mm-string-as-multibyte (buffer-string))) + (decode-coding-string (buffer-string) charset) + (string-as-multibyte (buffer-string))) (erase-buffer) (mm-enable-multibyte))) (goto-char (point-min)) @@ -1893,7 +1836,7 @@ If RECURSIVE, search recursively." (delete-region ,(point-min-marker) ,(point-max-marker)))))))) -(defvar shr-map) +(defvar shr-image-map) (autoload 'widget-convert-button "wid-edit") (defvar widget-keymap) @@ -1908,7 +1851,7 @@ If RECURSIVE, search recursively." (widget-convert-button 'url-link start end :help-echo (get-text-property start 'help-echo) - :keymap (setq keymap (copy-keymap shr-map)) + :keymap (setq keymap (copy-keymap shr-image-map)) (get-text-property start 'shr-url)) ;; Mask keys that launch `widget-button-click'. ;; Those bindings are provided by `widget-keymap' @@ -1916,6 +1859,10 @@ If RECURSIVE, search recursively." (dolist (key (where-is-internal #'widget-button-click widget-keymap)) (unless (lookup-key keymap key) (define-key keymap key #'ignore))) + ;; Avoid `shr-next-link' and `shr-previous-link' in `keymap' so + ;; TAB and M-TAB run `widget-forward' and `widget-backward' instead. + (substitute-key-definition 'shr-next-link nil keymap) + (substitute-key-definition 'shr-previous-link nil keymap) (dolist (overlay (overlays-at start)) (overlay-put overlay 'face nil)) (setq start end))))) diff --git a/lisp/gnus/mm-partial.el b/lisp/gnus/mm-partial.el index 1ad22d25529..e3e6f5d7805 100644 --- a/lisp/gnus/mm-partial.el +++ b/lisp/gnus/mm-partial.el @@ -136,13 +136,6 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing." handle `(lambda () (let (buffer-read-only) - (condition-case nil - ;; This is only valid on XEmacs. - (mapcar (lambda (prop) - (remove-specifier - (face-property 'default prop) (current-buffer))) - '(background background-pixmap foreground)) - (error nil)) (delete-region ,(point-min-marker) ,(point-max-marker)))))))))) (provide 'mm-partial) diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el index 2716a5bdc76..5c8f99b0483 100644 --- a/lisp/gnus/mm-url.el +++ b/lisp/gnus/mm-url.el @@ -45,7 +45,7 @@ (condition-case nil (require 'url) (error nil))) - "*If non-nil, use external grab program `mm-url-program'." + "If non-nil, use external grab program `mm-url-program'." :version "22.1" :type 'boolean :group 'mm-url) @@ -245,7 +245,7 @@ Likely values are `wget', `w3m', `lynx' and `curl'." ;; To be done ;; (shy . ????) ; soft hyphen ) - "*An assoc list of entity names and how to actually display them.") + "An assoc list of entity names and how to actually display them.") (defconst mm-url-unreserved-chars '( @@ -276,19 +276,10 @@ If `mm-url-use-external' is non-nil, use `mm-url-program'." (insert-file-contents (substring url (1- (match-end 0)))) (mm-url-insert-file-contents-external url)) (goto-char (point-min)) - (if (fboundp 'url-generic-parse-url) - (setq url-current-object - (url-generic-parse-url url))) + (setq url-current-object (url-generic-parse-url url)) (list url (buffer-size))) (mm-url-load-url) (let ((name buffer-file-name) - (url-request-extra-headers - ;; ISTM setting a Connection header was a workaround for - ;; older versions of url included with w3, but it does more - ;; harm than good with the one shipped with Emacs. --ansel - (if (not (and (boundp 'url-version) - (equal url-version "Emacs"))) - (list (cons "Connection" "Close")))) result) (setq result (url-insert-file-contents url)) (save-excursion @@ -296,10 +287,9 @@ If `mm-url-use-external' is non-nil, use `mm-url-program'." (while (re-search-forward "\r 1000\r ?" nil t) (replace-match ""))) (setq buffer-file-name name) - (if (and (fboundp 'url-generic-parse-url) - (listp result)) - (setq url-current-object (url-generic-parse-url - (car result)))) + (when (listp result) + (setq url-current-object + (url-generic-parse-url (car result)))) result))) ;;;###autoload @@ -364,7 +354,7 @@ If FOLLOW-REFRESH is non-nil, redirect refresh url in META." (string-to-number (substring entity 1))))) (setq c (or (cdr (assq c mm-extra-numeric-entities)) (mm-ucs-to-char c))) - (if (mm-char-or-char-int-p c) c ?#)) + (if (characterp c) c ?#)) (or (cdr (assq (intern entity) mm-url-html-entities)) ?#)))) @@ -399,10 +389,7 @@ spaces. Die Die Die." ((= char ? ) "+") ((memq char mm-url-unreserved-chars) (char-to-string char)) (t (upcase (format "%%%02x" char))))) - (mm-encode-coding-string chunk - (if (fboundp 'find-coding-systems-string) - (car (find-coding-systems-string chunk)) - buffer-file-coding-system)) + (encode-coding-string chunk (car (find-coding-systems-string chunk))) ""))) (defun mm-url-encode-www-form-urlencoded (pairs) @@ -415,43 +402,54 @@ spaces. Die Die Die." (autoload 'mml-compute-boundary "mml") -(defun mm-url-encode-multipart-form-data (pairs &optional boundary) - "Return PAIRS encoded in multipart/form-data." +(defun mm-url-encode-multipart-form-data (data &optional boundary) + "Return DATA encoded in multipart/form-data. +DATA is a list where the elements can have the following form: + (\"NAME\" . \"VALUE\") + (\"submit\") + (\"file\" . ((\"name\" . \"NAME\") + (\"filename\" . \"FILENAME\") + (\"content-type\" . \"CONTENT-TYPE\") + (\"filedata\" . \"FILEDATA\"))) +Lowercase strings above are literals and uppercase are not." ;; RFC1867 - ;; Get a good boundary + ;; Get a good boundary. (unless boundary (setq boundary (mml-compute-boundary '()))) - (concat - ;; Start with the boundary - "--" boundary "\r\n" - ;; Create name value pairs - (mapconcat - 'identity - ;; Delete any returned items that are empty - (delq nil - (mapcar (lambda (data) - (cond ((equal (car data) "file") - ;; For each pair - (format - ;; Encode the name - "Content-Disposition: form-data; name=%S; filename=%S\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Transfer-Encoding: binary\r\n\r\n%s" - (cdr (assoc "name" (cdr data))) (cdr (assoc "filename" (cdr data))) - (cond ((stringp (cdr (assoc "filedata" (cdr data)))) - (cdr (assoc "filedata" (cdr data)))) - ((integerp (cdr (assoc "filedata" (cdr data)))) - (number-to-string (cdr (assoc "filedata" (cdr data)))))))) - ((equal (car data) "submit") - "Content-Disposition: form-data; name=\"submit\"\r\n\r\nSubmit\r\n") - (t - (format - "Content-Disposition: form-data;name=%S\r\n\r\n%s\r\n" - (car data) (concat (mm-url-form-encode-xwfu (cdr data))) - )))) - pairs)) - ;; use the boundary as a separator - (concat "\r\n--" boundary "\r\n")) - ;; put a boundary at the end. - "--" boundary "--\r\n")) + (with-temp-buffer + (set-buffer-multibyte nil) + (dolist (elem data) + (let ((name (car elem)) + (value (cdr elem))) + (insert "--" boundary "\r\n") + (cond + ((equal name "file") + (insert (format + "Content-Disposition: form-data; name=%S; filename=%S\r\n" + (or (cdr (assoc "name" value)) name) + (cdr (assoc "filename" value)))) + (insert "Content-Transfer-Encoding: binary\r\n") + (insert (format "Content-Type: %s\r\n\r\n" + (or (cdr (assoc "content-type" value)) + "text/plain"))) + (let ((filedata (cdr (assoc "filedata" value)))) + (cond + ((stringp filedata) + (insert filedata)) + ;; How can this possibly be useful? + ((integerp filedata) + (insert (number-to-string filedata)))))) + ((equal name "submit") + (insert + "Content-Disposition: form-data; name=\"submit\"\r\n\r\nSubmit\r\n")) + (t + (insert (format "Content-Disposition: form-data; name=%S\r\n\r\n" + name)) + (insert value))) + (unless (bolp) + (insert "\r\n")))) + (insert "--" boundary "--\r\n") + (buffer-string))) (defun mm-url-remove-markup () "Remove all HTML markup, leaving just plain text." diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 25ecca69c58..89f397e3ed0 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -25,279 +25,24 @@ (eval-when-compile (require 'cl)) (require 'mail-prsvr) +(require 'timer) -(eval-and-compile - (if (featurep 'xemacs) - (unless (ignore-errors - (require 'timer-funcs)) - (require 'timer)) - (require 'timer))) - -(defvar mm-mime-mule-charset-alist ) -;; Note this is not presently used on Emacs >= 23, which is good, -;; since it means standalone message-mode (which requires mml and -;; hence mml-util) does not load gnus-util. -(autoload 'gnus-completing-read "gnus-util") - -;; Emulate functions that are not available in every (X)Emacs version. -;; The name of a function is prefixed with mm-, like `mm-char-int' for -;; `char-int' that is a native XEmacs function, not available in Emacs. -;; Gnus programs all should use mm- functions, not the original ones. -(eval-and-compile - (mapc - (lambda (elem) - (let ((nfunc (intern (format "mm-%s" (car elem))))) - (if (fboundp (car elem)) - (defalias nfunc (car elem)) - (defalias nfunc (cdr elem))))) - `(;; `coding-system-list' is not available in XEmacs 21.4 built - ;; without the `file-coding' feature. - (coding-system-list . ignore) - ;; `char-int' is an XEmacs function, not available in Emacs. - (char-int . identity) - ;; `coding-system-equal' is an Emacs function, not available in XEmacs. - (coding-system-equal . equal) - ;; `annotationp' is an XEmacs function, not available in Emacs. - (annotationp . ignore) - ;; `set-buffer-file-coding-system' is not available in XEmacs 21.4 - ;; built without the `file-coding' feature. - (set-buffer-file-coding-system . ignore) - ;; `read-charset' is an Emacs function, not available in XEmacs. - (read-charset - . ,(lambda (prompt) - "Return a charset." - (intern - (gnus-completing-read - prompt - (mapcar (lambda (e) (symbol-name (car e))) - mm-mime-mule-charset-alist) - t)))) - ;; `subst-char-in-string' is not available in XEmacs 21.4. - (subst-char-in-string - . ,(lambda (from to string &optional inplace) - ;; stolen (and renamed) from nnheader.el - "Replace characters in STRING from FROM to TO. - Unless optional argument INPLACE is non-nil, return a new string." - (let ((string (if inplace string (copy-sequence string))) - (len (length string)) - (idx 0)) - ;; Replace all occurrences of FROM with TO. - (while (< idx len) - (when (= (aref string idx) from) - (aset string idx to)) - (setq idx (1+ idx))) - string))) - ;; `replace-in-string' is an XEmacs function, not available in Emacs. - (replace-in-string - . ,(lambda (string regexp rep &optional literal) - "See `replace-regexp-in-string', only the order of args differs." - (replace-regexp-in-string regexp rep string nil literal))) - ;; `string-as-unibyte' is an Emacs function, not available in XEmacs. - (string-as-unibyte . identity) - ;; `string-make-unibyte' is an Emacs function, not available in XEmacs. - (string-make-unibyte . identity) - ;; string-as-multibyte often doesn't really do what you think it does. - ;; Example: - ;; (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201) - ;; (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300) - ;; (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300) - ;; (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201) - ;; but - ;; (aref (string-as-multibyte "\201\300") 0) -> 2240 - ;; (aref (string-as-multibyte "\201\300") 1) -> <error> - ;; Better use string-to-multibyte or encode-coding-string. - ;; If you really need string-as-multibyte somewhere it's usually - ;; because you're using the internal emacs-mule representation (maybe - ;; because you're using string-as-unibyte somewhere), which is - ;; generally a problem in itself. - ;; Here is an approximate equivalence table to help think about it: - ;; (string-as-multibyte s) ~= (decode-coding-string s 'emacs-mule) - ;; (string-to-multibyte s) ~= (decode-coding-string s 'binary) - ;; (string-make-multibyte s) ~= (decode-coding-string s locale-coding-system) - ;; `string-as-multibyte' is an Emacs function, not available in XEmacs. - (string-as-multibyte . identity) - ;; `multibyte-string-p' is an Emacs function, not available in XEmacs. - (multibyte-string-p . ignore) - ;; `insert-byte' is available only in Emacs 23.1 or greater. - (insert-byte . insert-char) - ;; `multibyte-char-to-unibyte' is an Emacs function, not available - ;; in XEmacs. - (multibyte-char-to-unibyte . identity) - ;; `set-buffer-multibyte' is an Emacs function, not available in XEmacs. - (set-buffer-multibyte . ignore) - ;; `substring-no-properties' is available only in Emacs 22.1 or greater. - (substring-no-properties - . ,(lambda (string &optional from to) - "Return a substring of STRING, without text properties. -It starts at index FROM and ending before TO. -TO may be nil or omitted; then the substring runs to the end of STRING. -If FROM is nil or omitted, the substring starts at the beginning of STRING. -If FROM or TO is negative, it counts from the end. - -With one argument, just copy STRING without its properties." - (setq string (substring string (or from 0) to)) - (set-text-properties 0 (length string) nil string) - string)) - ;; `line-number-at-pos' is available only in Emacs 22.1 or greater - ;; and XEmacs 21.5. - (line-number-at-pos - . ,(lambda (&optional pos) - "Return (narrowed) buffer line number at position POS. -If POS is nil, use current buffer location. -Counting starts at (point-min), so the value refers -to the contents of the accessible portion of the buffer." - (let ((opoint (or pos (point))) start) - (save-excursion - (goto-char (point-min)) - (setq start (point)) - (goto-char opoint) - (forward-line 0) - (1+ (count-lines start (point)))))))))) - -;; `special-display-p' is an Emacs function, not available in XEmacs. -(defalias 'mm-special-display-p - (if (featurep 'emacs) - 'special-display-p - (lambda (buffer-name) - "Returns non-nil if a buffer named BUFFER-NAME gets a special frame." - (and special-display-function - (or (and (member buffer-name special-display-buffer-names) t) - (cdr (assoc buffer-name special-display-buffer-names)) - (catch 'return - (dolist (elem special-display-regexps) - (and (stringp elem) - (string-match elem buffer-name) - (throw 'return t)) - (and (consp elem) - (stringp (car elem)) - (string-match (car elem) buffer-name) - (throw 'return (cdr elem)))))))))) - -;; `decode-coding-string', `encode-coding-string', `decode-coding-region' -;; and `encode-coding-region' are available in Emacs and XEmacs built with -;; the `file-coding' feature, but the XEmacs versions treat nil, that is -;; given as the `coding-system' argument, as the `binary' coding system. -(eval-and-compile - (if (featurep 'xemacs) - (if (featurep 'file-coding) - (progn - (defun mm-decode-coding-string (str coding-system) - (if coding-system - (decode-coding-string str coding-system) - str)) - (defun mm-encode-coding-string (str coding-system) - (if coding-system - (encode-coding-string str coding-system) - str)) - (defun mm-decode-coding-region (start end coding-system) - (if coding-system - (decode-coding-region start end coding-system))) - (defun mm-encode-coding-region (start end coding-system) - (if coding-system - (encode-coding-region start end coding-system)))) - (defun mm-decode-coding-string (str coding-system) str) - (defun mm-encode-coding-string (str coding-system) str) - (defalias 'mm-decode-coding-region 'ignore) - (defalias 'mm-encode-coding-region 'ignore)) - (defalias 'mm-decode-coding-string 'decode-coding-string) - (defalias 'mm-encode-coding-string 'encode-coding-string) - (defalias 'mm-decode-coding-region 'decode-coding-region) - (defalias 'mm-encode-coding-region 'encode-coding-region))) - -;; `string-to-multibyte' is available only in Emacs. -(defalias 'mm-string-to-multibyte (if (featurep 'xemacs) - 'identity - 'string-to-multibyte)) - -;; `char-or-char-int-p' is an XEmacs function, not available in Emacs. -(eval-and-compile - (defalias 'mm-char-or-char-int-p - (cond - ((fboundp 'char-or-char-int-p) 'char-or-char-int-p) - ((fboundp 'char-valid-p) 'char-valid-p) - (t 'identity)))) - -;; `ucs-to-char' is a function that Mule-UCS provides. -(eval-and-compile - (if (featurep 'xemacs) - (cond ((and (fboundp 'unicode-to-char) ;; XEmacs 21.5. - (subrp (symbol-function 'unicode-to-char))) - (if (featurep 'mule) - (defalias 'mm-ucs-to-char 'unicode-to-char) - (defun mm-ucs-to-char (codepoint) - "Convert Unicode codepoint to character." - (or (unicode-to-char codepoint) ?#)))) - ((featurep 'mule) - (defun mm-ucs-to-char (codepoint) - "Convert Unicode codepoint to character." - (if (fboundp 'ucs-to-char) ;; Mule-UCS is loaded. - (progn - (defalias 'mm-ucs-to-char - (lambda (codepoint) - "Convert Unicode codepoint to character." - (condition-case nil - (or (ucs-to-char codepoint) ?#) - (error ?#)))) - (mm-ucs-to-char codepoint)) - (condition-case nil - (or (int-to-char codepoint) ?#) - (error ?#))))) - (t - (defun mm-ucs-to-char (codepoint) - "Convert Unicode codepoint to character." - (condition-case nil - (or (int-to-char codepoint) ?#) - (error ?#))))) - (if (let ((char (make-char 'japanese-jisx0208 36 34))) - (eq char (decode-char 'ucs char))) - ;; Emacs 23. - (defalias 'mm-ucs-to-char 'identity) - (defun mm-ucs-to-char (codepoint) - "Convert Unicode codepoint to character." - (or (decode-char 'ucs codepoint) ?#))))) - -;; Fixme: This seems always to be used to read a MIME charset, so it -;; should be re-named and fixed (in Emacs) to offer completion only on -;; proper charset names (base coding systems which have a -;; mime-charset defined). XEmacs doesn't believe in mime-charset; -;; test with -;; `(or (coding-system-get 'iso-8859-1 'mime-charset) -;; (coding-system-get 'iso-8859-1 :mime-charset))' -;; Actually, there should be an `mm-coding-system-mime-charset'. -(eval-and-compile - (defalias 'mm-read-coding-system - (if (featurep 'emacs) 'read-coding-system - (cond - ((fboundp 'read-coding-system) - (if (and (featurep 'xemacs) - (<= (string-to-number emacs-version) 21.1)) - (lambda (prompt &optional default-coding-system) - (read-coding-system prompt)) - 'read-coding-system)) - (t (lambda (prompt &optional default-coding-system) - "Prompt the user for a coding system." - (gnus-completing-read - prompt (mapcar (lambda (s) (symbol-name (car s))) - mm-mime-mule-charset-alist)))))))) +(defvar mm-mime-mule-charset-alist) + +(defun mm-ucs-to-char (codepoint) + "Convert Unicode codepoint to character." + (or (decode-char 'ucs codepoint) ?#)) (defvar mm-coding-system-list nil) (defun mm-get-coding-system-list () "Get the coding system list." (or mm-coding-system-list - (setq mm-coding-system-list (mm-coding-system-list)))) + (setq mm-coding-system-list (coding-system-list)))) (defun mm-coding-system-p (cs) - "Return non-nil if CS is a symbol naming a coding system. -In XEmacs, also return non-nil if CS is a coding system object. -If CS is available, return CS itself in Emacs, and return a coding -system object in XEmacs." - (if (fboundp 'find-coding-system) - (and cs (find-coding-system cs)) - (if (fboundp 'coding-system-p) - (when (coding-system-p cs) - cs) - ;; no-MULE XEmacs: - (car (memq cs (mm-get-coding-system-list)))))) + "Return CS if CS is a coding system." + (and (coding-system-p cs) + cs)) (defvar mm-charset-synonym-alist `( @@ -343,170 +88,17 @@ system object in XEmacs." (mm-coding-system-p 'iso-8859-1)) '((iso_8859-1 . iso-8859-1))) ) - "A mapping from unknown or invalid charset names to the real charset names. - -See `mm-codepage-iso-8859-list' and `mm-codepage-ibm-list'.") - -(defun mm-codepage-setup (number &optional alias) - "Create a coding system cpNUMBER. -The coding system is created using `codepage-setup'. If ALIAS is -non-nil, an alias is created and added to -`mm-charset-synonym-alist'. If ALIAS is a string, it's used as -the alias. Else windows-NUMBER is used." - (interactive - (let ((completion-ignore-case t) - (candidates (if (fboundp 'cp-supported-codepages) - (cp-supported-codepages) - ;; Removed in Emacs 23 (unicode), so signal an error: - (error "`codepage-setup' not present in this Emacs version")))) - (list (gnus-completing-read "Setup DOS Codepage" candidates - t nil nil "437")))) - (when alias - (setq alias (if (stringp alias) - (intern alias) - (intern (format "windows-%s" number))))) - (let* ((cp (intern (format "cp%s" number)))) - (unless (mm-coding-system-p cp) - (if (fboundp 'codepage-setup) ; silence compiler - (codepage-setup number) - (error "`codepage-setup' not present in this Emacs version"))) - (when (and alias - ;; Don't add alias if setup of cp failed. - (mm-coding-system-p cp)) - (add-to-list 'mm-charset-synonym-alist (cons alias cp))))) - -(defcustom mm-codepage-iso-8859-list - (list 1250 ;; Windows-1250 is a variant of Latin-2 heavily used by Microsoft - ;; Outlook users in Czech republic. Use this to allow reading of - ;; their e-mails. - '(1252 . 1) ;; Windows-1252 is a superset of iso-8859-1 (West - ;; Europe). See also `gnus-article-dumbquotes-map'. - '(1254 . 9) ;; Windows-1254 is a superset of iso-8859-9 (Turkish). - '(1255 . 8));; Windows-1255 is a superset of iso-8859-8 (Hebrew). - "A list of Windows codepage numbers and iso-8859 charset numbers. - -If an element is a number corresponding to a supported windows -codepage, appropriate entries to `mm-charset-synonym-alist' are -added by `mm-setup-codepage-iso-8859'. An element may also be a -cons cell where the car is a codepage number and the cdr is the -corresponding number of an iso-8859 charset." - :type '(list (set :inline t - (const 1250 :tag "Central and East European") - (const (1252 . 1) :tag "West European") - (const (1254 . 9) :tag "Turkish") - (const (1255 . 8) :tag "Hebrew")) - (repeat :inline t - :tag "Other options" - (choice - (integer :tag "Windows codepage number") - (cons (integer :tag "Windows codepage number") - (integer :tag "iso-8859 charset number"))))) - :version "22.1" ;; Gnus 5.10.9 - :group 'mime) - -(defcustom mm-codepage-ibm-list - (list 437 ;; (US etc.) - 860 ;; (Portugal) - 861 ;; (Iceland) - 862 ;; (Israel) - 863 ;; (Canadian French) - 865 ;; (Nordic) - 852 ;; - 850 ;; (Latin 1) - 855 ;; (Cyrillic) - 866 ;; (Cyrillic - Russian) - 857 ;; (Turkish) - 864 ;; (Arabic) - 869 ;; (Greek) - 874);; (Thai) - ;; In Emacs 23 (unicode), cp... and ibm... are aliases. - ;; Cf. http://thread.gmane.org/v9lkng5nwy.fsf@marauder.physik.uni-ulm.de - "List of IBM codepage numbers. - -The codepage mappings slightly differ between IBM and other vendors. -See \"ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/IBM/README.TXT\". - -If an element is a number corresponding to a supported windows -codepage, appropriate entries to `mm-charset-synonym-alist' are -added by `mm-setup-codepage-ibm'." - :type '(list (set :inline t - (const 437 :tag "US etc.") - (const 860 :tag "Portugal") - (const 861 :tag "Iceland") - (const 862 :tag "Israel") - (const 863 :tag "Canadian French") - (const 865 :tag "Nordic") - (const 852) - (const 850 :tag "Latin 1") - (const 855 :tag "Cyrillic") - (const 866 :tag "Cyrillic - Russian") - (const 857 :tag "Turkish") - (const 864 :tag "Arabic") - (const 869 :tag "Greek") - (const 874 :tag "Thai")) - (repeat :inline t - :tag "Other options" - (integer :tag "Codepage number"))) - :version "22.1" ;; Gnus 5.10.9 - :group 'mime) - -(defun mm-setup-codepage-iso-8859 (&optional list) - "Add appropriate entries to `mm-charset-synonym-alist'. -Unless LIST is given, `mm-codepage-iso-8859-list' is used." - (unless list - (setq list mm-codepage-iso-8859-list)) - (dolist (i list) - (let (cp windows iso) - (if (consp i) - (setq cp (intern (format "cp%d" (car i))) - windows (intern (format "windows-%d" (car i))) - iso (intern (format "iso-8859-%d" (cdr i)))) - (setq cp (intern (format "cp%d" i)) - windows (intern (format "windows-%d" i)))) - (unless (mm-coding-system-p windows) - (if (mm-coding-system-p cp) - (add-to-list 'mm-charset-synonym-alist (cons windows cp)) - (add-to-list 'mm-charset-synonym-alist (cons windows iso))))))) - -(defun mm-setup-codepage-ibm (&optional list) - "Add appropriate entries to `mm-charset-synonym-alist'. -Unless LIST is given, `mm-codepage-ibm-list' is used." - (unless list - (setq list mm-codepage-ibm-list)) - (dolist (number list) - (let ((ibm (intern (format "ibm%d" number))) - (cp (intern (format "cp%d" number)))) - (when (and (not (mm-coding-system-p ibm)) - (mm-coding-system-p cp)) - (add-to-list 'mm-charset-synonym-alist (cons ibm cp)))))) - -;; Initialize: -(mm-setup-codepage-iso-8859) -(mm-setup-codepage-ibm) + "A mapping from unknown or invalid charset names to the real charset names.") ;; Note: this has to be defined before `mm-charset-to-coding-system'. -(defcustom mm-charset-eval-alist - (if (featurep 'xemacs) - nil ;; I don't know what would be useful for XEmacs. - '(;; Emacs 22 provides autoloads for 1250-1258 - ;; (i.e. `mm-codepage-setup' does nothing). - (windows-1250 . (mm-codepage-setup 1250 t)) - (windows-1251 . (mm-codepage-setup 1251 t)) - (windows-1253 . (mm-codepage-setup 1253 t)) - (windows-1257 . (mm-codepage-setup 1257 t)))) +(defcustom mm-charset-eval-alist nil "An alist of (CHARSET . FORM) pairs. If an article is encoded in an unknown CHARSET, FORM is evaluated. This allows the loading of additional libraries providing charsets on demand. If supported by your Emacs version, you could use `autoload-coding-system' here." :version "22.1" ;; Gnus 5.10.9 - :type '(list (set :inline t - (const (windows-1250 . (mm-codepage-setup 1250 t))) - (const (windows-1251 . (mm-codepage-setup 1251 t))) - (const (windows-1253 . (mm-codepage-setup 1253 t))) - (const (windows-1257 . (mm-codepage-setup 1257 t))) - (const (cp850 . (mm-codepage-setup 850 nil)))) - (repeat :inline t + :type '(list (repeat :inline t :tag "Other options" (cons (symbol :tag "charset") (symbol :tag "form")))) @@ -706,7 +298,7 @@ superset of iso-8859-1." ;; Fixme: some of the cars here aren't valid MIME charsets. That ;; should only matter with XEmacs, though. (defvar mm-mime-mule-charset-alist - `((us-ascii ascii) + '((us-ascii ascii) (iso-8859-1 latin-iso8859-1) (iso-8859-2 latin-iso8859-2) (iso-8859-3 latin-iso8859-3) @@ -756,56 +348,24 @@ superset of iso-8859-1." (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208 japanese-jisx0213-1 japanese-jisx0213-2) (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208) - ,(cond ((fboundp 'unicode-precedence-list) - (cons 'utf-8 (delq 'ascii (mapcar 'charset-name - (unicode-precedence-list))))) - ((or (not (fboundp 'charsetp)) ;; non-Mule case - (charsetp 'unicode-a) - (not (mm-coding-system-p 'mule-utf-8))) - '(utf-8 unicode-a unicode-b unicode-c unicode-d unicode-e)) - (t ;; If we have utf-8 we're in Mule 5+. - (append '(utf-8) - (delete 'ascii - (coding-system-get 'mule-utf-8 'safe-charsets)))))) + (utf-8)) "Alist of MIME-charset/MULE-charsets.") -(defun mm-enrich-utf-8-by-mule-ucs () - "Make the `utf-8' MIME charset usable by the Mule-UCS package. -This function will run when the `un-define' module is loaded under -XEmacs, and fill the `utf-8' entry in `mm-mime-mule-charset-alist' -with Mule charsets. It is completely useless for Emacs." - (when (boundp 'unicode-basic-translation-charset-order-list) - (condition-case nil - (let ((val (delq - 'ascii - (copy-sequence - (symbol-value - 'unicode-basic-translation-charset-order-list)))) - (elem (assq 'utf-8 mm-mime-mule-charset-alist))) - (if elem - (setcdr elem val) - (setq mm-mime-mule-charset-alist - (nconc mm-mime-mule-charset-alist - (list (cons 'utf-8 val)))))) - (error)))) - ;; Correct by construction, but should be unnecessary for Emacs: -(if (featurep 'xemacs) - (eval-after-load "un-define" '(mm-enrich-utf-8-by-mule-ucs)) - (when (and (fboundp 'coding-system-list) - (fboundp 'sort-coding-systems)) - (let ((css (sort-coding-systems (coding-system-list 'base-only))) - cs mime mule alist) - (while css - (setq cs (pop css) - mime (or (coding-system-get cs :mime-charset); Emacs 23 (unicode) - (coding-system-get cs 'mime-charset))) - (when (and mime - (not (eq t (setq mule - (coding-system-get cs 'safe-charsets)))) - (not (assq mime alist))) - (push (cons mime (delq 'ascii mule)) alist))) - (setq mm-mime-mule-charset-alist (nreverse alist))))) +(when (and (fboundp 'coding-system-list) + (fboundp 'sort-coding-systems)) + (let ((css (sort-coding-systems (coding-system-list 'base-only))) + cs mime mule alist) + (while css + (setq cs (pop css) + mime (or (coding-system-get cs :mime-charset) ; Emacs 23 (unicode) + (coding-system-get cs 'mime-charset))) + (when (and mime + (not (eq t (setq mule + (coding-system-get cs 'safe-charsets)))) + (not (assq mime alist))) + (push (cons mime (delq 'ascii mule)) alist))) + (setq mm-mime-mule-charset-alist (nreverse alist)))) (defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2) "A list of special charsets. @@ -838,16 +398,11 @@ Valid elements include: "A table of the difference character between ISO-8859-X and ISO-8859-15.") (defcustom mm-coding-system-priorities - (let ((lang (if (boundp 'current-language-environment) - (symbol-value 'current-language-environment)))) - (cond (;; XEmacs without Mule but with `file-coding'. - (not lang) nil) - ;; In XEmacs 21.5 it may be the one like "Japanese (UTF-8)". - ((string-match "\\`Japanese" lang) - ;; Japanese users prefer iso-2022-jp to others usually used - ;; for `buffer-file-coding-system', however iso-8859-1 should - ;; be used when there are only ASCII and Latin-1 characters. - '(iso-8859-1 iso-2022-jp utf-8)))) + (and (string-match "\\`Japanese" current-language-environment) + ;; Japanese users prefer iso-2022-jp to others usually used + ;; for `buffer-file-coding-system', however iso-8859-1 should + ;; be used when there are only ASCII and Latin-1 characters. + '(iso-8859-1 iso-2022-jp utf-8)) "Preferred coding systems for encoding outgoing messages. More than one suitable coding system may be found for some text. @@ -859,14 +414,13 @@ variable is set, it overrides the default priority." :group 'mime) ;; ?? -(defvar mm-use-find-coding-systems-region - (fboundp 'find-coding-systems-region) +(defvar mm-use-find-coding-systems-region t "Use `find-coding-systems-region' to find proper coding systems. Setting it to nil is useful on Emacsen supporting Unicode if sending mail with multiple parts is preferred to sending a Unicode one.") -(defvar mm-extra-numeric-entities +(defcustom mm-extra-numeric-entities (mapcar (lambda (item) (cons (car item) (mm-ucs-to-char (cdr item)))) @@ -879,7 +433,9 @@ mail with multiple parts is preferred to sending a Unicode one.") (#x9C . #x0153) (#x9E . #x017E) (#x9F . #x0178))) "*Alist of extra numeric entities and characters other than ISO 10646. This table is used for decoding extra numeric entities to characters, -like \"€\" to the euro sign, mainly in html messages.") +like \"€\" to the euro sign, mainly in html messages." + :type '(alist :key-type character :value-type character) + :group 'mime) ;;; Internal variables: @@ -887,45 +443,26 @@ like \"€\" to the euro sign, mainly in html messages.") (defun mm-mule-charset-to-mime-charset (charset) "Return the MIME charset corresponding to the given Mule CHARSET." - (if (and (fboundp 'find-coding-systems-for-charsets) - (fboundp 'sort-coding-systems)) - (let ((css (sort (sort-coding-systems - (find-coding-systems-for-charsets (list charset))) - 'mm-sort-coding-systems-predicate)) - cs mime) - (while (and (not mime) - css) - (when (setq cs (pop css)) - (setq mime (or (coding-system-get cs :mime-charset) - (coding-system-get cs 'mime-charset))))) - mime) - (let ((alist (mapcar (lambda (cs) - (assq cs mm-mime-mule-charset-alist)) - (sort (mapcar 'car mm-mime-mule-charset-alist) - 'mm-sort-coding-systems-predicate))) - out) - (while alist - (when (memq charset (cdar alist)) - (setq out (caar alist) - alist nil)) - (pop alist)) - out))) - -(eval-and-compile - (if (featurep 'xemacs) - (defalias 'mm-enable-multibyte 'ignore) - (defun mm-enable-multibyte () - "Set the multibyte flag of the current buffer. + (let ((css (sort (sort-coding-systems + (find-coding-systems-for-charsets (list charset))) + 'mm-sort-coding-systems-predicate)) + cs mime) + (while (and (not mime) + css) + (when (setq cs (pop css)) + (setq mime (or (coding-system-get cs :mime-charset) + (coding-system-get cs 'mime-charset))))) + mime)) + +(defun mm-enable-multibyte () + "Set the multibyte flag of the current buffer. Only do this if the default value of `enable-multibyte-characters' is -non-nil. This is a no-op in XEmacs." - (set-buffer-multibyte 'to))) +non-nil." + (set-buffer-multibyte 'to)) - (if (featurep 'xemacs) - (defalias 'mm-disable-multibyte 'ignore) - (defun mm-disable-multibyte () - "Unset the multibyte flag of in the current buffer. -This is a no-op in XEmacs." - (set-buffer-multibyte nil)))) +(defun mm-disable-multibyte () + "Unset the multibyte flag of in the current buffer." + (set-buffer-multibyte nil)) (defun mm-preferred-coding-system (charset) ;; A typo in some Emacs versions. @@ -939,8 +476,7 @@ This is a no-op in XEmacs." mail-parse-mule-charset ;; cached mule-charset (progn (setq mail-parse-mule-charset - (and (boundp 'current-language-environment) - (car (last + (and (car (last (assq 'charset (assoc current-language-environment language-info-alist)))))) @@ -956,94 +492,53 @@ This is a no-op in XEmacs." (defun mm-charset-after (&optional pos) "Return charset of a character in current buffer at position POS. If POS is nil, it defaults to the current point. -If POS is out of range, the value is nil. -If the charset is `composition', return the actual one." +If POS is out of range, the value is nil." (let ((char (char-after pos)) charset) - (if (< (mm-char-int char) 128) + (if (< char 128) (setq charset 'ascii) - ;; charset-after is fake in some Emacsen. - (setq charset (and (fboundp 'char-charset) (char-charset char))) - (if (eq charset 'composition) ; Mule 4 - (let ((p (or pos (point)))) - (cadr (find-charset-region p (1+ p)))) - (if (and charset (not (memq charset '(ascii eight-bit-control - eight-bit-graphic)))) - charset - (mm-guess-charset)))))) + (setq charset (char-charset char)) + (if (and charset (not (memq charset '(ascii eight-bit-control + eight-bit-graphic)))) + charset + (mm-guess-charset))))) (defun mm-mime-charset (charset) "Return the MIME charset corresponding to the given Mule CHARSET." - (if (eq charset 'unknown) - (error "The message contains non-printable characters, please use attachment")) - (if (and (fboundp 'coding-system-get) (fboundp 'get-charset-property)) - (or - (and (mm-preferred-coding-system charset) - (or (coding-system-get - (mm-preferred-coding-system charset) :mime-charset) - (coding-system-get - (mm-preferred-coding-system charset) 'mime-charset))) - (and (eq charset 'ascii) - 'us-ascii) - (mm-preferred-coding-system charset) - (mm-mule-charset-to-mime-charset charset)) - ;; This is for XEmacs. - (mm-mule-charset-to-mime-charset charset))) - -;; `delete-dups' is not available in XEmacs 21.4. -(if (fboundp 'delete-dups) - (defalias 'mm-delete-duplicates 'delete-dups) - (defun mm-delete-duplicates (list) - "Destructively remove `equal' duplicates from LIST. -Store the result in LIST and return it. LIST must be a proper list. -Of several `equal' occurrences of an element in LIST, the first -one is kept. - -This is a compatibility function for Emacsen without `delete-dups'." - ;; Code from `subr.el' in Emacs 22: - (let ((tail list)) - (while tail - (setcdr tail (delete (car tail) (cdr tail))) - (setq tail (cdr tail)))) - list)) + (when (eq charset 'unknown) + (error "The message contains non-printable characters, please use attachment")) + (or + (and (mm-preferred-coding-system charset) + (coding-system-get (mm-preferred-coding-system charset) 'mime-charset)) + (and (eq charset 'ascii) + 'us-ascii) + (mm-preferred-coding-system charset) + (mm-mule-charset-to-mime-charset charset))) ;; Fixme: This is used in places when it should be testing the -;; default multibyteness. See mm-default-multibyte-p. -(eval-and-compile - (if (and (not (featurep 'xemacs)) - (boundp 'enable-multibyte-characters)) - (defun mm-multibyte-p () - "Non-nil if multibyte is enabled in the current buffer." - enable-multibyte-characters) - (defun mm-multibyte-p () (featurep 'mule)))) - -(defun mm-default-multibyte-p () - "Return non-nil if the session is multibyte. -This affects whether coding conversion should be attempted generally." - (if (featurep 'mule) - (if (boundp 'enable-multibyte-characters) - (default-value 'enable-multibyte-characters) - t))) +;; default multibyteness. +(defun mm-multibyte-p () + "Non-nil if multibyte is enabled in the current buffer." + enable-multibyte-characters) (defun mm-iso-8859-x-to-15-region (&optional b e) - (if (fboundp 'char-charset) - (let (charset item c inconvertible) - (save-restriction - (if e (narrow-to-region b e)) - (goto-char (point-min)) - (skip-chars-forward "\0-\177") - (while (not (eobp)) - (cond - ((not (setq item (assq (char-charset (setq c (char-after))) - mm-iso-8859-x-to-15-table))) - (forward-char)) - ((memq c (cdr (cdr item))) - (setq inconvertible t) - (forward-char)) - (t - (insert-before-markers (prog1 (+ c (car (cdr item))) - (delete-char 1))))) - (skip-chars-forward "\0-\177"))) - (not inconvertible)))) + (let (charset item c inconvertible) + (save-restriction + (if e (narrow-to-region b e)) + (goto-char (point-min)) + (skip-chars-forward "\0-\177") + (while (not (eobp)) + (cond + ((not (setq item (assq (char-charset (setq c (char-after))) + mm-iso-8859-x-to-15-table))) + (forward-char)) + ((memq c (cdr (cdr item))) + (setq inconvertible t) + (forward-char)) + (t + (insert-before-markers (prog1 (+ c (car (cdr item))) + (delete-char 1))))) + (skip-chars-forward "\0-\177"))) + (not inconvertible))) (defun mm-sort-coding-systems-predicate (a b) (let ((priorities @@ -1058,85 +553,6 @@ This affects whether coding conversion should be attempted generally." (length (memq (coding-system-base b) priorities))) t)))) -(declare-function latin-unity-massage-name "ext:latin-unity") -(declare-function latin-unity-maybe-remap "ext:latin-unity") -(declare-function latin-unity-representations-feasible-region "ext:latin-unity") -(declare-function latin-unity-representations-present-region "ext:latin-unity") - -(defvar latin-unity-coding-systems) -(defvar latin-unity-ucs-list) - -(defun mm-xemacs-find-mime-charset-1 (begin end) - "Determine which MIME charset to use to send region as message. -This uses the XEmacs-specific latin-unity package to better handle the -case where identical characters from diverse ISO-8859-? character sets -can be encoded using a single one of the corresponding coding systems. - -It treats `mm-coding-system-priorities' as the list of preferred -coding systems; a useful example setting for this list in Western -Europe would be (iso-8859-1 iso-8859-15 utf-8), which would default -to the very standard Latin 1 coding system, and only move to coding -systems that are less supported as is necessary to encode the -characters that exist in the buffer. - -Latin Unity doesn't know about those non-ASCII Roman characters that -are available in various East Asian character sets. As such, its -behavior if you have a JIS 0212 LATIN SMALL LETTER A WITH ACUTE in a -buffer and it can otherwise be encoded as Latin 1, won't be ideal. -But this is very much a corner case, so don't worry about it." - (let ((systems mm-coding-system-priorities) csets psets curset) - - ;; Load the Latin Unity library, if available. - (when (and (not (featurep 'latin-unity)) (locate-library "latin-unity")) - (require 'latin-unity)) - - ;; Now, can we use it? - (if (featurep 'latin-unity) - (progn - (setq csets (latin-unity-representations-feasible-region begin end) - psets (latin-unity-representations-present-region begin end)) - - (catch 'done - - ;; Pass back the first coding system in the preferred list - ;; that can encode the whole region. - (dolist (curset systems) - (setq curset (latin-unity-massage-name 'buffer-default curset)) - - ;; If the coding system is a universal coding system, then - ;; it can certainly encode all the characters in the region. - (if (memq curset latin-unity-ucs-list) - (throw 'done (list curset))) - - ;; If a coding system isn't universal, and isn't in - ;; the list that latin unity knows about, we can't - ;; decide whether to use it here. Leave that until later - ;; in `mm-find-mime-charset-region' function, whence we - ;; have been called. - (unless (memq curset latin-unity-coding-systems) - (throw 'done nil)) - - ;; Right, we know about this coding system, and it may - ;; conceivably be able to encode all the characters in - ;; the region. - (if (latin-unity-maybe-remap begin end curset csets psets t) - (throw 'done (list curset)))) - - ;; Can't encode using anything from the - ;; `mm-coding-system-priorities' list. - ;; Leave `mm-find-mime-charset' to do most of the work. - nil)) - - ;; Right, latin unity isn't available; let `mm-find-charset-region' - ;; take its default action, which equally applies to GNU Emacs. - nil))) - -(defmacro mm-xemacs-find-mime-charset (begin end) - (when (featurep 'xemacs) - `(and (featurep 'mule) (mm-xemacs-find-mime-charset-1 ,begin ,end)))) - -(declare-function mm-delete-duplicates "mm-util" (list)) - (defun mm-find-mime-charset-region (b e &optional hack-charsets) "Return the MIME charsets needed to encode the region between B and E. nil means ASCII, a single-element list represents an appropriate MIME @@ -1178,16 +594,9 @@ charset, and a longer list means no appropriate charset." (setq systems nil charsets (list cs)))))) charsets)) - ;; If we're XEmacs, and some coding system is appropriate, - ;; mm-xemacs-find-mime-charset will return an appropriate list. - ;; Otherwise, we'll get nil, and the next setq will get invoked. - (setq charsets (mm-xemacs-find-mime-charset b e)) - - ;; Fixme: won't work for unibyte Emacs 23: - ;; We're not multibyte, or a single coding system won't cover it. (setq charsets - (mm-delete-duplicates + (delete-dups (mapcar 'mm-mime-charset (delq 'ascii (mm-find-charset-region b e)))))) @@ -1200,17 +609,6 @@ charset, and a longer list means no appropriate charset." (if (and (memq 'iso-2022-jp-2 charsets) (memq 'iso-2022-jp-2 hack-charsets)) (setq charsets (delq 'iso-2022-jp charsets))) - ;; Attempt to reduce the number of charsets if utf-8 is available. - (if (and (featurep 'xemacs) - (> (length charsets) 1) - (mm-coding-system-p 'utf-8)) - (let ((mm-coding-system-priorities - (cons 'utf-8 mm-coding-system-priorities))) - (setq charsets - (mm-delete-duplicates - (mapcar 'mm-mime-charset - (delq 'ascii - (mm-find-charset-region b e))))))) charsets)) (defmacro mm-with-unibyte-buffer (&rest forms) @@ -1233,7 +631,6 @@ Use multibyte mode for this." (defmacro mm-with-unibyte-current-buffer (&rest forms) "Evaluate FORMS with current buffer temporarily made unibyte. -Equivalent to `progn' in XEmacs. Note: We recommend not using this macro any more; there should be better ways to do a similar thing. The previous version of this macro @@ -1241,31 +638,27 @@ bound the default value of `enable-multibyte-characters' to nil while evaluating FORMS but it is no longer done. So, some programs assuming it if any may malfunction." (declare (obsolete nil "25.1") (indent 0) (debug t)) - (if (featurep 'xemacs) - `(progn ,@forms) - (let ((multibyte (make-symbol "multibyte"))) - `(let ((,multibyte enable-multibyte-characters)) + (let ((multibyte (make-symbol "multibyte"))) + `(let ((,multibyte enable-multibyte-characters)) + (when ,multibyte + (set-buffer-multibyte nil)) + (prog1 + (progn ,@forms) (when ,multibyte - (set-buffer-multibyte nil)) - (prog1 - (progn ,@forms) - (when ,multibyte - (set-buffer-multibyte t))))))) + (set-buffer-multibyte t)))))) (defun mm-find-charset-region (b e) "Return a list of Emacs charsets in the region B to E." (cond - ((and (mm-multibyte-p) - (fboundp 'find-charset-region)) + ((mm-multibyte-p) ;; Remove composition since the base charsets have been included. ;; Remove eight-bit-*, treat them as ascii. (let ((css (find-charset-region b e))) - (dolist (cs - '(composition eight-bit-control eight-bit-graphic control-1) - css) - (setq css (delq cs css))))) + (dolist (cs '(composition eight-bit-control eight-bit-graphic control-1)) + (setq css (delq cs css))) + css)) (t - ;; We are in a unibyte buffer or XEmacs non-mule, so we futz around a bit. + ;; We are in a unibyte buffer, so we futz around a bit. (save-excursion (save-restriction (narrow-to-region b e) @@ -1274,11 +667,9 @@ it if any may malfunction." (if (eobp) '(ascii) (let (charset) - (setq charset - (and (boundp 'current-language-environment) - (car (last (assq 'charset - (assoc current-language-environment - language-info-alist)))))) + (setq charset (car (last (assq 'charset + (assoc current-language-environment + language-info-alist))))) (if (eq charset 'ascii) (setq charset nil)) (or charset (setq charset @@ -1305,9 +696,9 @@ it if any may malfunction." "Like `insert-file-contents', but only reads in the file. A buffer may be modified in several ways after reading into the buffer due to advanced Emacs features, such as file-name-handlers, format decoding, -`find-file-hooks', etc. +`find-file-hook', etc. If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'. - This function ensures that none of these modifications will take place." +This function ensures that none of these modifications will take place." (letf* ((format-alist nil) (auto-mode-alist (if inhibit nil (mm-auto-mode-alist))) ((default-value 'major-mode) 'fundamental-mode) @@ -1322,14 +713,8 @@ If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'. (append mm-inhibit-file-name-handlers inhibit-file-name-handlers) inhibit-file-name-handlers)) - (ffh (if (boundp 'find-file-hook) - 'find-file-hook - 'find-file-hooks)) - (val (symbol-value ffh))) - (set ffh nil) - (unwind-protect - (insert-file-contents filename visit beg end replace) - (set ffh val)))) + (find-file-hook nil)) + (insert-file-contents filename visit beg end replace))) (defun mm-append-to-file (start end filename &optional codesys inhibit) "Append the contents of the region to the end of file FILENAME. @@ -1371,70 +756,8 @@ If INHIBIT is non-nil, inhibit `mm-inhibit-file-name-handlers'." inhibit-file-name-handlers))) (write-region start end filename append visit lockname))) -(autoload 'gmm-write-region "gmm-utils") - -;; It is not a MIME function, but some MIME functions use it. -(if (and (fboundp 'make-temp-file) - (ignore-errors - (let ((def (if (fboundp 'compiled-function-arglist) ;; XEmacs - (eval (list 'compiled-function-arglist - (symbol-function 'make-temp-file))) - (require 'help-fns) - (help-function-arglist 'make-temp-file t)))) - (and (>= (length def) 4) - (eq (nth 3 def) 'suffix))))) - (defalias 'mm-make-temp-file 'make-temp-file) - ;; Stolen (and modified for XEmacs) from Emacs 22. - (defun mm-make-temp-file (prefix &optional dir-flag suffix) - "Create a temporary file. -The returned file name (created by appending some random characters at the end -of PREFIX, and expanding against `temporary-file-directory' if necessary), -is guaranteed to point to a newly created empty file. -You can then use `write-region' to write new data into the file. - -If DIR-FLAG is non-nil, create a new empty directory instead of a file. - -If SUFFIX is non-nil, add that at the end of the file name." - (let ((umask (default-file-modes)) - file) - (unwind-protect - (progn - ;; Create temp files with strict access rights. It's easy to - ;; loosen them later, whereas it's impossible to close the - ;; time-window of loose permissions otherwise. - (set-default-file-modes 448) - (while (condition-case err - (progn - (setq file - (make-temp-name - (expand-file-name - prefix - (if (fboundp 'temp-directory) - ;; XEmacs - (temp-directory) - temporary-file-directory)))) - (if suffix - (setq file (concat file suffix))) - (if dir-flag - (make-directory file) - ;; NOTE: This is unsafe if Emacs 20 - ;; users and XEmacs users don't use - ;; a secure temp directory. - (gmm-write-region "" nil file nil 'silent - nil 'excl)) - nil) - (file-already-exists t) - ;; The XEmacs version of `make-directory' issues - ;; `file-error'. - (file-error (or (and (featurep 'xemacs) - (file-exists-p file)) - (signal (car err) (cdr err))))) - ;; the file was somehow created by someone else between - ;; `make-temp-name' and `write-region', let's try again. - nil) - file) - ;; Reset the umask. - (set-default-file-modes umask))))) +(defalias 'mm-make-temp-file 'make-temp-file) +(define-obsolete-function-alias 'mm-make-temp-file 'make-temp-file "26.1") (defvar mm-image-load-path-cache nil) @@ -1455,54 +778,23 @@ If SUFFIX is non-nil, add that at the end of the file name." result))) ;; Fixme: This doesn't look useful where it's used. -(if (fboundp 'detect-coding-region) - (defun mm-detect-coding-region (start end) - "Like `detect-coding-region' except returning the best one." - (let ((coding-systems - (detect-coding-region start end))) - (or (car-safe coding-systems) - coding-systems))) - (defun mm-detect-coding-region (start end) - (let ((point (point))) - (goto-char start) - (skip-chars-forward "\0-\177" end) - (prog1 - (if (eq (point) end) 'ascii (mm-guess-charset)) - (goto-char point))))) +(defun mm-detect-coding-region (start end) + "Like `detect-coding-region' except returning the best one." + (let ((coding-systems (detect-coding-region start end))) + (or (car-safe coding-systems) + coding-systems))) (declare-function mm-detect-coding-region "mm-util" (start end)) -(if (fboundp 'coding-system-get) - (defun mm-detect-mime-charset-region (start end) - "Detect MIME charset of the text in the region between START and END." - (let ((cs (mm-detect-coding-region start end))) - (or (coding-system-get cs :mime-charset) - (coding-system-get cs 'mime-charset)))) - (defun mm-detect-mime-charset-region (start end) - "Detect MIME charset of the text in the region between START and END." - (let ((cs (mm-detect-coding-region start end))) - cs))) - -(eval-when-compile - (unless (fboundp 'coding-system-to-mime-charset) - (defalias 'coding-system-to-mime-charset 'ignore))) +(defun mm-detect-mime-charset-region (start end) + "Detect MIME charset of the text in the region between START and END." + (let ((cs (mm-detect-coding-region start end))) + (coding-system-get cs 'mime-charset))) (defun mm-coding-system-to-mime-charset (coding-system) - "Return the MIME charset corresponding to CODING-SYSTEM. -To make this function work with XEmacs, the APEL package is required." - (when coding-system - (or (and (fboundp 'coding-system-get) - (or (coding-system-get coding-system :mime-charset) - (coding-system-get coding-system 'mime-charset))) - (and (featurep 'xemacs) - (or (and (fboundp 'coding-system-to-mime-charset) - (not (eq (symbol-function 'coding-system-to-mime-charset) - 'ignore))) - (and (condition-case nil - (require 'mcharset) - (error nil)) - (fboundp 'coding-system-to-mime-charset))) - (coding-system-to-mime-charset coding-system))))) + "Return the MIME charset corresponding to CODING-SYSTEM." + (and coding-system + (coding-system-get coding-system 'mime-charset))) (defvar jka-compr-acceptable-retval-list) (declare-function jka-compr-make-temp-name "jka-compr" (&optional local)) @@ -1571,14 +863,6 @@ decompressed data. The buffer's multibyteness must be turned off." (message "%s" (or err-msg (concat msg "done"))) retval))))) -(eval-when-compile - (unless (fboundp 'coding-system-name) - (defalias 'coding-system-name 'ignore)) - (unless (fboundp 'find-file-coding-system-for-read-from-filename) - (defalias 'find-file-coding-system-for-read-from-filename 'ignore)) - (unless (fboundp 'find-operation-coding-system) - (defalias 'find-operation-coding-system 'ignore))) - (defun mm-find-buffer-file-coding-system (&optional filename) "Find coding system used to decode the contents of the current buffer. This function looks for the coding system magic cookie or examines the @@ -1601,66 +885,16 @@ gzip, bzip2, etc. are allowed." (setq filename (file-name-sans-extension filename))) (goto-char (point-min)) (unwind-protect - (cond - ((boundp 'set-auto-coding-function) ;; Emacs - (if filename - (or (funcall (symbol-value 'set-auto-coding-function) - filename (- (point-max) (point-min))) - (car (find-operation-coding-system 'insert-file-contents - filename))) - (let (auto-coding-alist) - (condition-case nil - (funcall (symbol-value 'set-auto-coding-function) - nil (- (point-max) (point-min))) - (error nil))))) - ((and (featurep 'xemacs) (featurep 'file-coding)) ;; XEmacs - (let ((case-fold-search t) - (end (point-at-eol)) - codesys start) - (or - (and (re-search-forward "-\\*-+[\t ]*" end t) - (progn - (setq start (match-end 0)) - (re-search-forward "[\t ]*-+\\*-" end t)) - (progn - (setq end (match-beginning 0)) - (goto-char start) - (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)") - (re-search-forward - "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)" - end t))) - (find-coding-system (setq codesys - (intern (match-string 1)))) - codesys) - (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:" - nil t) - (progn - (setq start (match-end 0)) - (re-search-forward "^[\t ]*;+[\t ]*End:" nil t)) - (progn - (setq end (match-beginning 0)) - (goto-char start) - (re-search-forward - "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)" - end t)) - (find-coding-system (setq codesys - (intern (match-string 1)))) - codesys) - (and (progn - (goto-char (point-min)) - (setq case-fold-search nil) - (re-search-forward "^;;;coding system: " - ;;(+ (point-min) 3000) t)) - nil t)) - (looking-at "[^\t\n\r ]+") - (find-coding-system - (setq codesys (intern (match-string 0)))) - codesys) - (and filename - (setq codesys - (find-file-coding-system-for-read-from-filename - filename)) - (coding-system-name (coding-system-base codesys))))))) + (if filename + (or (funcall (symbol-value 'set-auto-coding-function) + filename (- (point-max) (point-min))) + (car (find-operation-coding-system 'insert-file-contents + filename))) + (let (auto-coding-alist) + (condition-case nil + (funcall (symbol-value 'set-auto-coding-function) + nil (- (point-max) (point-min))) + (error nil)))) (when decomp (kill-buffer (current-buffer))))))) diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index fecb2d5be0b..18322ecb4d1 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -43,7 +43,7 @@ (autoload 'yenc-extract-filename "yenc") (defcustom mm-uu-decode-function 'uudecode-decode-region - "*Function to uudecode. + "Function to uudecode. Internal function is done in Lisp by default, therefore decoding may appear to be horribly slow. You can make Gnus use an external decoder, such as uudecode." @@ -54,7 +54,7 @@ decoder, such as uudecode." :group 'gnus-article-mime) (defcustom mm-uu-binhex-decode-function 'binhex-decode-region - "*Function to binhex decode. + "Function to binhex decode. Internal function is done in elisp by default, therefore decoding may appear to be horribly slow . You can make Gnus use the external Unix decoder, such as hexbin." @@ -85,7 +85,7 @@ This can be either \"inline\" or \"attachment\".") :group 'gnus-article-mime) (defcustom mm-uu-tex-groups-regexp "\\.tex\\>" - "*Regexp matching TeX groups." + "Regexp matching TeX groups." :version "23.1" :type 'regexp :group 'gnus-article-mime) @@ -249,14 +249,7 @@ To disable dissecting shar codes, for instance, add (defsubst mm-uu-function-2 (entry) (nth 5 entry)) -;; In Emacs 22, we could use `min-colors' in the face definition. But Emacs -;; 21 and XEmacs don't support it. -(defcustom mm-uu-hide-markers - (< 16 (or (and (fboundp 'defined-colors) - (length (defined-colors))) - (and (fboundp 'device-color-cells) - (device-color-cells)) - 0)) +(defcustom mm-uu-hide-markers (< 16 (length (defined-colors))) "If non-nil, hide verbatim markers. The value should be nil on displays where the face `mm-uu-extract' isn't distinguishable to the face `default'." @@ -297,12 +290,8 @@ If PROPERTIES is non-nil, PROPERTIES are applied to the buffer, see `set-text-properties'. If PROPERTIES equals t, this means to apply the face `mm-uu-extract'." (let ((obuf (current-buffer)) - (multi (and (boundp 'enable-multibyte-characters) - enable-multibyte-characters)) - (coding-system - ;; Might not exist in non-MULE XEmacs - (when (boundp 'buffer-file-coding-system) - buffer-file-coding-system))) + (multi enable-multibyte-characters) + (coding-system buffer-file-coding-system)) (with-current-buffer (generate-new-buffer " *mm-uu*") (if multi (mm-enable-multibyte) (mm-disable-multibyte)) (setq buffer-file-coding-system coding-system) @@ -322,13 +311,13 @@ apply the face `mm-uu-extract'." (interactive) (if symbol (set-default symbol value)) (setq mm-uu-beginning-regexp nil) - (mapcar (lambda (entry) - (if (mm-uu-configure-p (mm-uu-type entry) 'disabled) + (mapcar (lambda (mm-uu-entry) + (if (mm-uu-configure-p (mm-uu-type mm-uu-entry) 'disabled) nil (setq mm-uu-beginning-regexp (concat mm-uu-beginning-regexp (if mm-uu-beginning-regexp "\\|") - (mm-uu-beginning-regexp entry))))) + (mm-uu-beginning-regexp mm-uu-entry))))) mm-uu-type-alist)) (mm-uu-configure) @@ -336,7 +325,7 @@ apply the face `mm-uu-extract'." (defvar file-name) (defvar start-point) (defvar end-point) -(defvar entry) +(defvar mm-uu-entry) (defun mm-uu-uu-filename () (if (looking-at ".+") @@ -523,7 +512,7 @@ apply the face `mm-uu-extract'." (when (and mml2015-use (null (mml2015-clear-verify-function))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details - (gnus-format-message + (format-message "Clear verification not supported by `%s'.\n" mml2015-use))) (mml2015-extract-cleartext-signature)) (list (mm-make-handle buf mm-uu-text-plain-type))))) @@ -587,11 +576,11 @@ apply the face `mm-uu-extract'." (not (eq charset 'ascii))) ;; Assume that buffer's multibyteness is turned off. ;; See `mml2015-pgg-clear-decrypt'. - (insert (mm-decode-coding-string (prog1 - (buffer-string) - (erase-buffer) - (mm-enable-multibyte)) - charset)) + (insert (decode-coding-string (prog1 + (buffer-string) + (erase-buffer) + (mm-enable-multibyte)) + charset)) (mm-enable-multibyte)) (list (mm-make-handle buf mm-uu-text-plain-type))) (list (mm-make-handle buf '("application/pgp-encrypted"))))))) @@ -612,10 +601,10 @@ apply the face `mm-uu-extract'." (defun mm-uu-gpg-key-skip-to-last () (let ((point (point)) - (end-regexp (mm-uu-end-regexp entry)) - (beginning-regexp (mm-uu-beginning-regexp entry))) + (end-regexp (mm-uu-end-regexp mm-uu-entry)) + (beginning-regexp (mm-uu-beginning-regexp mm-uu-entry))) (when (and end-regexp - (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))) + (not (mm-uu-configure-p (mm-uu-type mm-uu-entry) 'disabled))) (while (re-search-forward end-regexp nil t) (skip-chars-forward " \t\n\r") (if (looking-at beginning-regexp) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index e5859d002cf..dd64bfed60a 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -31,7 +31,6 @@ (require 'mml-smime) (autoload 'gnus-completing-read "gnus-util") -(autoload 'gnus-window-inside-pixel-edges "gnus-ems") (autoload 'gnus-article-prepare-display "gnus-art") (autoload 'vcard-parse-string "vcard") (autoload 'vcard-format-string "vcard") @@ -80,7 +79,7 @@ (autoload 'gnus-rescale-image "gnus-util") -(defun mm-inline-image-emacs (handle) +(defun mm-inline-image (handle) (let ((b (point-marker)) (inhibit-read-only t)) (put-image @@ -88,7 +87,7 @@ (if (eq mm-inline-large-images 'resize) (gnus-rescale-image image - (let ((edges (gnus-window-inside-pixel-edges + (let ((edges (window-inside-pixel-edges (get-buffer-window (current-buffer))))) (cons (truncate (* mm-inline-large-images-proportion (- (nth 2 edges) (nth 0 edges)))) @@ -105,27 +104,6 @@ (remove-images b b) (delete-region b (1+ b))))))) -(defun mm-inline-image-xemacs (handle) - (when (featurep 'xemacs) - (insert "\n") - (forward-char -1) - (let ((annot (make-annotation (mm-get-image handle) nil 'text)) - (inhibit-read-only t)) - (mm-handle-set-undisplayer - handle - `(lambda () - (let ((b ,(point-marker)) - (inhibit-read-only t)) - (delete-annotation ,annot) - (delete-region (1- b) b)))) - (set-extent-property annot 'mm t) - (set-extent-property annot 'duplicable t)))) - -(eval-and-compile - (if (featurep 'xemacs) - (defalias 'mm-inline-image 'mm-inline-image-xemacs) - (defalias 'mm-inline-image 'mm-inline-image-emacs))) - (defvar mm-w3m-setup nil "Whether gnus-article-mode has been setup to use emacs-w3m.") @@ -220,18 +198,19 @@ (delete-region ,(point-min-marker) ,(point-max-marker))))))))) -(defvar mm-w3m-standalone-supports-m17n-p (if (featurep 'mule) 'undecided) - "*T means the w3m command supports the m17n feature.") +(defcustom mm-w3m-standalone-supports-m17n-p 'undecided + "T means the w3m command supports the m17n feature." + :type '(choice (const nil) (const t) (other :tag "detect" undecided)) + :group 'mime-display) (defun mm-w3m-standalone-supports-m17n-p () "Say whether the w3m command supports the m17n feature." (cond ((eq mm-w3m-standalone-supports-m17n-p t) t) ((eq mm-w3m-standalone-supports-m17n-p nil) nil) - ((not (featurep 'mule)) (setq mm-w3m-standalone-supports-m17n-p nil)) ((condition-case nil (let ((coding-system-for-write 'iso-2022-jp) (coding-system-for-read 'iso-2022-jp) - (str (mm-decode-coding-string "\ + (str (decode-coding-string "\ \e$B#D#o#e#s!!#w#3#m!!#s#u#p#p#o#r#t!!#m#1#7#n!)\e(B" 'iso-2022-jp))) (mm-with-multibyte-buffer (insert str) @@ -283,7 +262,7 @@ (delete-region (match-beginning 0) (match-end 0)))) (defun mm-inline-wash-with-file (post-func cmd &rest args) - (let ((file (mm-make-temp-file + (let ((file (make-temp-file (expand-file-name "mm" mm-tmp-directory)))) (let ((coding-system-for-write 'binary)) (write-region (point-min) (point-max) file nil 'silent)) @@ -463,11 +442,6 @@ handle `(lambda () (let ((inhibit-read-only t)) - (if (fboundp 'remove-specifier) - ;; This is only valid on XEmacs. - (dolist (prop '(background background-pixmap foreground)) - (remove-specifier - (face-property 'default prop) (current-buffer)))) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) ;; Shut up byte-compiler. @@ -486,18 +460,14 @@ If MODE is not set, try to find mode automatically." (unless charset (setq coding-system (mm-find-buffer-file-coding-system))) (setq text (buffer-string)))) - ;; XEmacs @#$@ version of font-lock refuses to fully turn itself - ;; on for buffers whose name begins with " ". That's why we use - ;; `with-current-buffer'/`generate-new-buffer' rather than - ;; `with-temp-buffer'. - (with-current-buffer (generate-new-buffer "*fontification*") + (with-temp-buffer (buffer-disable-undo) (mm-enable-multibyte) (insert (cond ((eq charset 'gnus-decoded) (with-current-buffer (mm-handle-buffer handle) (buffer-string))) (coding-system - (mm-decode-coding-string text coding-system)) + (decode-coding-string text coding-system)) (charset (mm-decode-string text charset)) (t @@ -524,28 +494,16 @@ If MODE is not set, try to find mode automatically." ;; Do not fontify if the guess mode is fundamental. (unless (or font-lock-mode (eq major-mode 'fundamental-mode)) - (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. - (when (featurep 'xemacs) - (map-extents (lambda (ext ignored) - (set-extent-property ext 'duplicable t) - nil) - nil nil nil nil nil 'text-prop)) + (font-lock-ensure)))) (setq text (buffer-string)) ;; Set buffer unmodified to avoid confirmation when killing the ;; buffer. - (set-buffer-modified-p nil) - (kill-buffer (current-buffer))) + (set-buffer-modified-p nil)) (mm-insert-inline handle text))) ;; Shouldn't these functions check whether the user even wants to use -;; font-lock? At least under XEmacs, this fontification is pretty -;; much unconditional. Also, it would be nice to change for the size -;; of the fontified region. +;; font-lock? Also, it would be nice to change for the size of the +;; fontified region. (defun mm-display-patch-inline (handle) (mm-display-inline-fontify handle 'diff-mode)) diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index bd74f3862bf..57c371a65f4 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -27,6 +27,7 @@ (require 'gnus-util) (require 'epg) +(require 'epa) (require 'password-cache) (require 'mm-encode) @@ -46,6 +47,8 @@ (autoload 'mml-smime-verify "mml-smime") (autoload 'mml-smime-verify-test "mml-smime") (autoload 'epa--select-keys "epa") +(autoload 'message-options-get "message") +(autoload 'message-options-set "message") (declare-function message-options-set "message" (symbol value)) @@ -555,7 +558,7 @@ Return keys." (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) (curr-fprs (cdr (assoc name (cdr usage-prefs)))) (key-fprs (mapcar 'mml-secure-fingerprint keys)) - (new-fprs (gnus-union curr-fprs key-fprs :test 'equal))) + (new-fprs (cl-union curr-fprs key-fprs :test 'equal))) (if curr-fprs (setcdr (assoc name (cdr usage-prefs)) new-fprs) (setcdr usage-prefs (cons (cons name new-fprs) (cdr usage-prefs)))) @@ -623,7 +626,7 @@ Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead." The passphrase is read and cached." ;; Based on mml2015-epg-passphrase-callback. (if (eq key-id 'SYM) - (epg-passphrase-callback-function context key-id nil) + (epa-passphrase-callback-function context key-id nil) (let* ((password-cache-key-id (if (eq key-id 'PIN) "PIN" @@ -702,9 +705,9 @@ be present in the keyring." ;; In contrast, signing requires secret key. (mml-secure-secret-key-exists-p context subkey)) (or (not fingerprint) - (gnus-string-match-p (concat fingerprint "$") fpr) - (gnus-string-match-p (concat fingerprint "$") - (epg-sub-key-fingerprint subkey)))) + (string-match-p (concat fingerprint "$") fpr) + (string-match-p (concat fingerprint "$") + (epg-sub-key-fingerprint subkey)))) (throw 'break t))))))) (defun mml-secure-find-usable-keys (context name usage &optional justone) @@ -907,10 +910,10 @@ If no one is selected, symmetric encryption will be performed. " cipher signers) (when sign (setq signers (mml-secure-signers context signer-names)) - (epg-context-set-signers context signers)) + (setf (epg-context-signers context) signers)) (when (eq 'OpenPGP protocol) - (epg-context-set-armor context t) - (epg-context-set-textmode context t)) + (setf (epg-context-armor context) t) + (setf (epg-context-textmode context) t)) (when (mml-secure-cache-passphrase-p protocol) (epg-context-set-passphrase-callback context @@ -935,9 +938,9 @@ If no one is selected, symmetric encryption will be performed. " (signers (mml-secure-signers context signer-names)) signature micalg) (when (eq 'OpenPGP protocol) - (epg-context-set-armor context t) - (epg-context-set-textmode context t)) - (epg-context-set-signers context signers) + (setf (epg-context-armor context) t) + (setf (epg-context-textmode context) t)) + (setf (epg-context-signers context) signers) (when (mml-secure-cache-passphrase-p protocol) (epg-context-set-passphrase-callback context @@ -947,8 +950,9 @@ If no one is selected, symmetric encryption will be performed. " (if (eq 'OpenPGP protocol) (epg-sign-string context (buffer-string) mode) (epg-sign-string context - (mm-replace-in-string (buffer-string) - "\n" "\r\n") t)) + (replace-regexp-in-string + "\n" "\r\n" (buffer-string)) + t)) mml-secure-secret-key-id-list nil) (error (mml-secure-clear-secret-key-id-list) diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index dbdc1f9f94b..1821d1a49fc 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -32,17 +32,17 @@ (autoload 'message-narrow-to-headers "message") (autoload 'message-fetch-field "message") -;; Prefer epg over openssl if it is available as epg uses GnuPG's gpgsm, +;; Prefer epg over openssl as epg uses GnuPG's gpgsm, ;; which features full-fledged certificate management, while openssl requires ;; major manual efforts for certificate revocation and expiry and has bugs ;; as documented under man smime(1). -(ignore-errors (require 'epg)) +(require 'epg) -(defcustom mml-smime-use (if (featurep 'epg) 'epg 'openssl) +(defcustom mml-smime-use 'epg "Whether to use OpenSSL or EasyPG (EPG) to handle S/MIME messages. -Defaults to EPG if it's available. -If you think about using OpenSSL, please read the BUGS section in the manual -for the `smime' command coming with OpenSSL first. EasyPG is recommended." +If you're thinking about using OpenSSL, please first read the BUGS section +in the manual for the `smime' command that comes with OpenSSL. +We recommend EasyPG." :group 'mime-security :type '(choice (const :tag "EPG" epg) (const :tag "OpenSSL" openssl))) @@ -149,8 +149,7 @@ Whether the passphrase is cached at all is controlled by (if (not (and (not (file-exists-p tmp)) (get-buffer tmp))) (push tmp certfiles) - (setq file (mm-make-temp-file (expand-file-name "mml." - mm-tmp-directory))) + (setq file (make-temp-file (expand-file-name "mml." mm-tmp-directory))) (with-current-buffer tmp (write-region (point-min) (point-max) file)) (push file certfiles) @@ -176,15 +175,12 @@ Whether the passphrase is cached at all is controlled by (list 'keyfile (if (= (length smime-keys) 1) (cadar smime-keys) - (or (let ((from (cadr (funcall (if (boundp - 'gnus-extract-address-components) - gnus-extract-address-components - 'mail-extract-address-components) - (or (save-excursion - (save-restriction - (message-narrow-to-headers) - (message-fetch-field "from"))) - ""))))) + (or (let ((from (cadr (mail-extract-address-components + (or (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-fetch-field "from"))) + ""))))) (and from (smime-get-key-by-email from))) (smime-get-key-by-email (gnus-completing-read "Sign this part with what signature" @@ -205,18 +201,15 @@ Whether the passphrase is cached at all is controlled by (while (not result) (setq who (read-from-minibuffer (format "%sLookup certificate for: " (or bad "")) - (cadr (funcall (if (boundp - 'gnus-extract-address-components) - gnus-extract-address-components - 'mail-extract-address-components) - (or (save-excursion - (save-restriction - (message-narrow-to-headers) - (message-fetch-field "to"))) - ""))))) + (cadr (mail-extract-address-components + (or (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-fetch-field "to"))) + ""))))) (if (setq cert (smime-cert-by-dns who)) (setq result (list 'certfile (buffer-name cert))) - (setq bad (gnus-format-message "`%s' not found. " who)))) + (setq bad (format-message "`%s' not found. " who)))) (quit)) result)) @@ -235,7 +228,7 @@ Whether the passphrase is cached at all is controlled by ""))))) (if (setq cert (smime-cert-by-ldap who)) (setq result (list 'certfile (buffer-name cert))) - (setq bad (gnus-format-message "`%s' not found. " who)))) + (setq bad (format-message "`%s' not found. " who)))) (quit)) result)) @@ -421,7 +414,7 @@ Content-Disposition: attachment; filename=smime.p7m (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) - (setq part (mm-replace-in-string part "\n" "\r\n") + (setq part (replace-regexp-in-string "\n" "\r\n" part) context (epg-make-context 'CMS)) (condition-case error (setq plain (epg-verify-string context (mm-get-part signature) part)) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 17d2fb715f8..6d13d892b5a 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -29,13 +29,9 @@ (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' (autoload 'message-make-message-id "message") (declare-function gnus-setup-posting-charset "gnus-msg" (group)) -(autoload 'gnus-make-local-hook "gnus-util") (autoload 'gnus-completing-read "gnus-util") (autoload 'message-fetch-field "message") (autoload 'message-mark-active-p "message") @@ -50,7 +46,6 @@ (autoload 'message-mail-p "message") (defvar gnus-article-mime-handles) -(defvar gnus-mouse-2) (defvar gnus-newsrc-hashtb) (defvar message-default-charset) (defvar message-deletable-headers) @@ -63,7 +58,7 @@ (defcustom mml-content-type-parameters '(name access-type expiration size permission format) - "*A list of acceptable parameters in MML tag. + "A list of acceptable parameters in MML tag. These parameters are generated in Content-Type header if exists." :version "22.1" :type '(repeat (symbol :tag "Parameter")) @@ -71,7 +66,7 @@ These parameters are generated in Content-Type header if exists." (defcustom mml-content-disposition-parameters '(filename creation-date modification-date read-date) - "*A list of acceptable parameters in MML tag. + "A list of acceptable parameters in MML tag. These parameters are generated in Content-Disposition header if exists." :version "22.1" :type '(repeat (symbol :tag "Parameter")) @@ -153,17 +148,19 @@ is called. FUNCTION is a Lisp function which is called with the MML handle to tweak the part.") (defvar mml-externalize-attachments nil - "*If non-nil, local-file attachments are generated as external parts.") + "If non-nil, local-file attachments are generated as external parts.") -(defvar mml-generate-multipart-alist nil - "*Alist of multipart generation functions. +(defcustom mml-generate-multipart-alist nil + "Alist of multipart generation functions. Each entry has the form (NAME . FUNCTION), where NAME is a string containing the name of the part (without the leading \"/multipart/\"), FUNCTION is a Lisp function which is called to generate the part. The Lisp function has to supply the appropriate MIME headers and the -contents of this part.") +contents of this part." + :group 'message + :type '(alist :key-type string :value-type function)) (defvar mml-syntax-table (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) @@ -418,12 +415,21 @@ A message part needs to be split into %d charset parts. Really send? " (setq contents (append (list (cons 'tag-location orig-point)) contents)) (cons (intern name) (nreverse contents)))) -(defun mml-buffer-substring-no-properties-except-hard-newlines (start end) +(defun mml-buffer-substring-no-properties-except-some (start end) (let ((str (buffer-substring-no-properties start end)) - (bufstart start) tmp) - (while (setq tmp (text-property-any start end 'hard 't)) - (set-text-properties (- tmp bufstart) (- tmp bufstart -1) - '(hard t) str) + (bufstart start) + tmp) + ;; Copy over all hard newlines. + (while (setq tmp (text-property-any start end 'hard t)) + (put-text-property (- tmp bufstart) (- tmp bufstart -1) + 'hard t str) + (setq start (1+ tmp))) + ;; Copy over all `display' properties (which are usually images). + (setq start bufstart) + (while (setq tmp (text-property-not-all start end 'display nil)) + (put-text-property (- tmp bufstart) (- tmp bufstart -1) + 'display (get-text-property tmp 'display) + str) (setq start (1+ tmp))) str)) @@ -440,21 +446,21 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (if (re-search-forward "<#\\(/\\)?mml." nil t) (setq count (+ count (if (match-beginning 1) -1 1))) (goto-char (point-max)))) - (mml-buffer-substring-no-properties-except-hard-newlines + (mml-buffer-substring-no-properties-except-some beg (if (> count 0) (point) (match-beginning 0)))) (if (re-search-forward "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) (prog1 - (mml-buffer-substring-no-properties-except-hard-newlines + (mml-buffer-substring-no-properties-except-some beg (match-beginning 0)) (if (or (not (match-beginning 1)) (equal (match-string 2) "multipart")) (goto-char (match-beginning 0)) (when (looking-at "[ \t]*\n") (forward-line 1)))) - (mml-buffer-substring-no-properties-except-hard-newlines + (mml-buffer-substring-no-properties-except-some beg (goto-char (point-max))))))) (defvar mml-boundary nil) @@ -519,7 +525,9 @@ be \"related\" or \"alternate\"." (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)) + (push (list cid (url-filename parsed) + (get-text-property start 'display)) + new-parts)) (setq cid (1+ cid))))))) ;; We have local images that we want to include. (if (not new-parts) @@ -532,11 +540,41 @@ be \"related\" or \"alternate\"." (setq cont (nconc cont (list `(part (type . "image/png") - (filename . ,(nth 1 new-part)) + ,@(mml--possibly-alter-image + (nth 1 new-part) + (nth 2 new-part)) (id . ,(concat "<" (nth 0 new-part) ">"))))))) cont)))) +(defun mml--possibly-alter-image (file-name image) + (if (or (null image) + (not (consp image)) + (not (eq (car image) 'image)) + (not (image-property image :rotation)) + (not (executable-find "exiftool"))) + `((filename . ,file-name)) + `((filename . ,file-name) + (buffer + . + ,(with-current-buffer (mml-generate-new-buffer " *mml rotation*") + (set-buffer-multibyte nil) + (call-process "exiftool" + file-name + (list (current-buffer) nil) + nil + (format "-Orientation#=%d" + (cl-case (truncate + (image-property image :rotation)) + (0 0) + (90 6) + (180 3) + (270 8) + (otherwise 0))) + "-o" "-" + "-") + (current-buffer)))))) + (defun mml-generate-mime-1 (cont) (let ((mm-use-ultra-safe-encoding (or mm-use-ultra-safe-encoding (assq 'sign cont)))) @@ -636,6 +674,7 @@ be \"related\" or \"alternate\"." (let ((mm-coding-system-priorities (cons 'utf-8 mm-coding-system-priorities))) (setq charset (mm-encode-body)))) + (mm-disable-multibyte) (setq encoding (mm-body-encoding charset (cdr (assq 'encoding cont)))))) (setq coded (buffer-string))) @@ -645,7 +684,7 @@ be \"related\" or \"alternate\"." (mm-with-unibyte-buffer (cond ((cdr (assq 'buffer cont)) - (insert (mm-string-as-unibyte + (insert (string-as-unibyte (with-current-buffer (cdr (assq 'buffer cont)) (buffer-string))))) ((and filename @@ -658,9 +697,7 @@ be \"related\" or \"alternate\"." filename))))) (t (let ((contents (cdr (assq 'contents cont)))) - (if (if (featurep 'xemacs) - (string-match "[^\000-\377]" contents) - (mm-multibyte-string-p contents)) + (if (multibyte-string-p contents) (progn (mm-enable-multibyte) (insert contents) @@ -670,7 +707,7 @@ be \"related\" or \"alternate\"." (if (setq encoding (cdr (assq 'encoding cont))) (setq encoding (intern (downcase encoding)))) (setq encoding (mm-encode-buffer type encoding) - coded (mm-string-as-multibyte (buffer-string)))) + coded (string-as-multibyte (buffer-string)))) (mml-insert-mime-headers cont type charset encoding nil) (insert "\n" coded)))) ((eq (car cont) 'external) @@ -1109,57 +1146,42 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (easy-menu-define mml-menu mml-mode-map "" `("Attachments" - ["Attach File..." mml-attach-file - ,@(if (featurep 'xemacs) '(t) - '(:help "Attach a file at point"))] + ["Attach File..." mml-attach-file :help "Attach a file at point"] ["Attach Buffer..." mml-attach-buffer - ,@(if (featurep 'xemacs) '(t) - '(:help "Attach a buffer to the outgoing message"))] + :help "Attach a buffer to the outgoing message"] ["Attach External..." mml-attach-external - ,@(if (featurep 'xemacs) '(t) - '(:help "Attach reference to an external file"))] + :help "Attach reference to an external file"] ;; FIXME: Is it possible to do this without using ;; `gnus-gcc-externalize-attachments'? ["Externalize Attachments" (lambda () (interactive) - (if (not (and (boundp 'gnus-gcc-externalize-attachments) - (memq gnus-gcc-externalize-attachments - '(all t nil)))) - ;; Stupid workaround for XEmacs not honoring :visible. - (message "Can't handle this value of `gnus-gcc-externalize-attachments'") - (setq gnus-gcc-externalize-attachments - (not gnus-gcc-externalize-attachments)) - (message "gnus-gcc-externalize-attachments is `%s'." - gnus-gcc-externalize-attachments))) - ;; XEmacs barfs on :visible. - ,@(if (featurep 'xemacs) nil - '(:visible (and (boundp 'gnus-gcc-externalize-attachments) - (memq gnus-gcc-externalize-attachments - '(all t nil))))) + (setq gnus-gcc-externalize-attachments + (not gnus-gcc-externalize-attachments)) + (message "gnus-gcc-externalize-attachments is `%s'." + gnus-gcc-externalize-attachments)) + :visible (and (boundp 'gnus-gcc-externalize-attachments) + (memq gnus-gcc-externalize-attachments + '(all t nil))) :style toggle :selected gnus-gcc-externalize-attachments - ,@(if (featurep 'xemacs) nil - '(:help "Save attachments as external parts in Gcc copies"))] + :help "Save attachments as external parts in Gcc copies"] "----" ;; ("Change Security Method" ["PGP/MIME" (lambda () (interactive) (setq mml-secure-method "pgpmime")) - ,@(if (featurep 'xemacs) nil - '(:help "Set Security Method to PGP/MIME")) + :help "Set Security Method to PGP/MIME" :style radio :selected (equal mml-secure-method "pgpmime") ] ["S/MIME" (lambda () (interactive) (setq mml-secure-method "smime")) - ,@(if (featurep 'xemacs) nil - '(:help "Set Security Method to S/MIME")) + :help "Set Security Method to S/MIME" :style radio :selected (equal mml-secure-method "smime") ] ["Inline PGP" (lambda () (interactive) (setq mml-secure-method "pgp")) - ,@(if (featurep 'xemacs) nil - '(:help "Set Security Method to inline PGP")) + :help "Set Security Method to inline PGP" :style radio :selected (equal mml-secure-method "pgp") ] ) ;; @@ -1167,8 +1189,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ["Encrypt Message" mml-secure-message-encrypt t] ["Sign and Encrypt Message" mml-secure-message-sign-encrypt t] ["Encrypt/Sign off" mml-unsecure-message - ,@(if (featurep 'xemacs) '(t) - '(:help "Don't Encrypt/Sign Message"))] + :help "Don't Encrypt/Sign Message"] ;; Do we have separate encrypt and encrypt/sign commands for parts? ["Sign Part" mml-secure-sign t] ["Encrypt Part" mml-secure-encrypt t] @@ -1183,26 +1204,18 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ;;["Narrow" mml-narrow-to-part t] ["Quote MML in region" mml-quote-region :active (message-mark-active-p) - ,@(if (featurep 'xemacs) nil - '(:help "Quote MML tags in region"))] + :help "Quote MML tags in region"] ["Validate MML" mml-validate t] ["Preview" mml-preview t] "----" ["Emacs MIME manual" (lambda () (interactive) (message-info 4)) - ,@(if (featurep 'xemacs) '(t) - '(:help "Display the Emacs MIME manual"))] + :help "Display the Emacs MIME manual"] ["PGG manual" (lambda () (interactive) (message-info mml2015-use)) - ;; XEmacs barfs on :visible. - ,@(if (featurep 'xemacs) nil - '(:visible (and (boundp 'mml2015-use) (equal mml2015-use 'pgg)))) - ,@(if (featurep 'xemacs) '(t) - '(:help "Display the PGG manual"))] + :visible (and (boundp 'mml2015-use) (equal mml2015-use 'pgg)) + :help "Display the PGG manual"] ["EasyPG manual" (lambda () (interactive) (require 'mml2015) (message-info mml2015-use)) - ;; XEmacs barfs on :visible. - ,@(if (featurep 'xemacs) nil - '(:visible (and (boundp 'mml2015-use) (equal mml2015-use 'epg)))) - ,@(if (featurep 'xemacs) '(t) - '(:help "Display the EasyPG manual"))])) + :visible (and (boundp 'mml2015-use) (equal mml2015-use 'epg)) + :help "Display the EasyPG manual"])) (define-minor-mode mml-mode "Minor mode for editing MML. @@ -1379,7 +1392,7 @@ body) or \"attachment\" (separate from the body)." 'type type ;; icicles redefines read-file-name and returns a ;; string w/ text properties :-/ - 'filename (mm-substring-no-properties file) + 'filename (substring-no-properties file) 'disposition (or disposition "attachment") 'description description) ;; When using Mail mode, make sure it does the mime encoding @@ -1575,12 +1588,11 @@ or the `pop-to-buffer' function." (message-sort-headers) (mml-to-mime)) (if raw - (when (fboundp 'set-buffer-multibyte) - (let ((s (buffer-string))) - ;; Insert the content into unibyte buffer. - (erase-buffer) - (mm-disable-multibyte) - (insert s))) + (let ((s (buffer-string))) + ;; Insert the content into unibyte buffer. + (erase-buffer) + (mm-disable-multibyte) + (insert s)) (let ((gnus-newsgroup-charset (car message-posting-charset)) gnus-article-prepare-hook gnus-original-article-buffer gnus-displaying-mime) @@ -1591,7 +1603,6 @@ or the `pop-to-buffer' function." (gnus-article-prepare-display)))) ;; Disable article-mode-map. (use-local-map nil) - (gnus-make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook (lambda () (mm-destroy-parts gnus-article-mime-handles)) nil t) @@ -1602,14 +1613,14 @@ or the `pop-to-buffer' function." (lambda () (interactive) (widget-button-press (point)))) - (local-set-key gnus-mouse-2 + (local-set-key [mouse-2] (lambda (event) (interactive "@e") (widget-button-press (widget-event-point event) event))) ;; FIXME: Buffer is in article mode, but most tool bar commands won't ;; work. Maybe only keep the following icons: search, print, quit (goto-char (point-min)))) - (if (and (not (mm-special-display-p (buffer-name mml-preview-buffer))) + (if (and (not (special-display-p (buffer-name mml-preview-buffer))) (boundp 'gnus-buffer-configuration) (assq 'mml-preview gnus-buffer-configuration)) (let ((gnus-message-buffer (current-buffer))) diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el index 54ac790c9fb..0df908f2a2e 100644 --- a/lisp/gnus/mml1991.el +++ b/lisp/gnus/mml1991.el @@ -195,17 +195,20 @@ Whether the passphrase is cached at all is controlled by (pop-to-buffer pgg-errors-buffer) (error "Encrypt error")) (delete-region (point-min) (point-max)) - (mm-with-unibyte-current-buffer - (insert-buffer-substring pgg-output-buffer) - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" t t)) - (when cte - (mm-encode-content-transfer-encoding cte)) - (goto-char (point-min)) - (when headers - (insert headers)) - (insert "\n")) + (insert + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-buffer-substring pgg-output-buffer) + (goto-char (point-min)) + (while (re-search-forward "\r+$" nil t) + (replace-match "" t t)) + (when cte + (mm-encode-content-transfer-encoding cte)) + (goto-char (point-min)) + (when headers + (insert headers)) + (insert "\n") + (buffer-string))) t)) (defun mml1991-pgg-encrypt (cont &optional sign) @@ -275,17 +278,20 @@ Whether the passphrase is cached at all is controlled by (let* ((pair (mml-secure-epg-sign 'OpenPGP 'clear)) (signature (car pair))) (delete-region (point-min) (point-max)) - (mm-with-unibyte-current-buffer - (insert signature) - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" t t)) - (when cte - (mm-encode-content-transfer-encoding cte)) - (goto-char (point-min)) - (when headers - (insert headers)) - (insert "\n")) + (insert + (with-temp-buffer + (set-buffer-multibyte nil) + (insert signature) + (goto-char (point-min)) + (while (re-search-forward "\r+$" nil t) + (replace-match "" t t)) + (when cte + (mm-encode-content-transfer-encoding cte)) + (goto-char (point-min)) + (when headers + (insert headers)) + (insert "\n") + (buffer-string))) t))) (defun mml1991-epg-encrypt (cont &optional sign) diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 3319e0b9aa2..f973670e8e9 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -32,6 +32,7 @@ (require 'mm-util) (require 'mml) (require 'mml-sec) +(require 'epg-config) (defvar mc-pgp-always-sign) @@ -42,27 +43,7 @@ ;; Maybe this should be in eg mml-sec.el (and have a different name). ;; Then mml1991 would not need to require mml2015, and mml1991-use ;; could be removed. -(defvar mml2015-use (or - (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 - ;; (Emacs 24). - (when (and abs-file - (not (string-match "/obsolete/[^/]*\\'" - abs-file))) - (ignore-errors (require 'pgg)) - (and (fboundp 'pgg-sign-region) - 'pgg)))) - (progn (ignore-errors - (load "mc-toplev")) - (and (fboundp 'mc-encrypt-generic) - (fboundp 'mc-sign-generic) - (fboundp 'mc-cleanup-recipient-headers) - 'mailcrypt))) +(defvar mml2015-use 'epg "The package used for PGP/MIME. Valid packages include `epg', `pgg' and `mailcrypt'.") @@ -482,14 +463,17 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (or (y-or-n-p "Sign the message? ") 'not)))) 'never))) - (mm-with-unibyte-current-buffer - (mc-encrypt-generic - (or (message-options-get 'message-recipients) - (message-options-set 'message-recipients - (mc-cleanup-recipient-headers - (read-string "Recipients: ")))) - nil nil nil - (message-options-get 'message-sender)))) + (insert + (with-temp-buffer + (set-buffer-multibyte nil) + (mc-encrypt-generic + (or (message-options-get 'message-recipients) + (message-options-set 'message-recipients + (mc-cleanup-recipient-headers + (read-string "Recipients: ")))) + nil nil nil + (message-options-get 'message-sender)) + (buffer-string)))) (goto-char (point-min)) (unless (looking-at "-----BEGIN PGP MESSAGE-----") (error "Fail to encrypt the message")) @@ -614,7 +598,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (insert "\r")) (forward-line) (end-of-line)) - (with-temp-file (setq signature-file (mm-make-temp-file "pgg")) + (with-temp-file (setq signature-file (make-temp-file "pgg")) (mm-insert-part signature)) (if (condition-case err (prog1 @@ -655,7 +639,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (if (condition-case err (prog1 (mm-with-unibyte-buffer - (insert (mm-encode-coding-string text coding-system)) + (insert (encode-coding-string text coding-system)) (pgg-verify-region (point-min) (point-max) nil t)) (goto-char (point-min)) (while (search-forward "\r\n" nil t) @@ -775,12 +759,10 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (autoload 'epg-expand-group "epg-config") (autoload 'epa-select-keys "epa") -(autoload 'gnus-create-image "gnus-ems") - (defun mml2015-epg-key-image (key-id) "Return the image of a key, if any" (with-temp-buffer - (mm-set-buffer-multibyte nil) + (set-buffer-multibyte nil) (let* ((coding-system-for-write 'binary) (coding-system-for-read 'binary) (data (shell-command-to-string @@ -920,7 +902,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) - (setq part (mm-replace-in-string part "\n" "\r\n") + (setq part (replace-regexp-in-string "\n" "\r\n" part) signature (mm-get-part signature) context (epg-make-context)) (condition-case error @@ -943,8 +925,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (defun mml2015-epg-clear-verify () (let ((inhibit-redisplay t) (context (epg-make-context)) - (signature (mm-encode-coding-string (buffer-string) - coding-system-for-write)) + (signature (encode-coding-string (buffer-string) + coding-system-for-write)) plain) (condition-case error (setq plain (epg-verify-string context signature)) @@ -963,7 +945,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (mml2015-epg-verify-result-to-string (epg-context-result-for context 'verify))) (delete-region (point-min) (point-max)) - (insert (mm-decode-coding-string plain coding-system-for-read))) + (insert (decode-coding-string plain coding-system-for-read))) (mml2015-extract-cleartext-signature)))) (defun mml2015-epg-sign (cont) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index d46d0ed9e29..bed35b55b3a 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -88,16 +88,6 @@ (require 'gnus-start) (require 'gnus-sum) -;; Compatibility Functions ================================================= - -(eval-and-compile - (if (fboundp 'signal-error) - (defun nndiary-error (&rest args) - (apply #'signal-error 'nndiary args)) - (defun nndiary-error (&rest args) - (apply #'error args)))) - - ;; Back End behavior customization =========================================== (defgroup nndiary nil @@ -107,7 +97,7 @@ (defcustom nndiary-mail-sources `((file :path ,(expand-file-name "~/.nndiary"))) - "*NNDiary specific mail sources. + "NNDiary specific mail sources. This variable is used by nndiary in place of the standard `mail-sources' variable when `nndiary-get-new-mail' is set to non-nil. These sources must contain diary messages ONLY." @@ -116,7 +106,7 @@ must contain diary messages ONLY." :type 'sexp) (defcustom nndiary-split-methods '(("diary" "")) - "*NNDiary specific split methods. + "NNDiary specific split methods. This variable is used by nndiary in place of the standard `nnmail-split-methods' variable when `nndiary-get-new-mail' is set to non-nil." @@ -128,7 +118,7 @@ non-nil." (defcustom nndiary-reminders '((0 . day)) - "*Different times when you want to be reminded of your appointments. + "Different times when you want to be reminded of your appointments. Diary articles will appear again, as if they'd been just received. Entries look like (3 . day) which means something like \"Please @@ -174,7 +164,7 @@ In order to make this clear, here are some examples: (const :format "%v" year))))) (defcustom nndiary-week-starts-on-monday nil - "*Whether a week starts on monday (otherwise, sunday)." + "Whether a week starts on monday (otherwise, sunday)." :type 'boolean :group 'nndiary) @@ -182,7 +172,7 @@ In order to make this clear, here are some examples: (define-obsolete-variable-alias 'nndiary-request-create-group-hooks 'nndiary-request-create-group-functions "24.3") (defcustom nndiary-request-create-group-functions nil - "*Hook run after `nndiary-request-create-group' is executed. + "Hook run after `nndiary-request-create-group' is executed. The hook functions will be called with the full group name as argument." :group 'nndiary :type 'hook) @@ -190,7 +180,7 @@ The hook functions will be called with the full group name as argument." (define-obsolete-variable-alias 'nndiary-request-update-info-hooks 'nndiary-request-update-info-functions "24.3") (defcustom nndiary-request-update-info-functions nil - "*Hook run after `nndiary-request-update-info-group' is executed. + "Hook run after `nndiary-request-update-info-group' is executed. The hook functions will be called with the full group name as argument." :group 'nndiary :type 'hook) @@ -198,14 +188,14 @@ The hook functions will be called with the full group name as argument." (define-obsolete-variable-alias 'nndiary-request-accept-article-hooks 'nndiary-request-accept-article-functions "24.3") (defcustom nndiary-request-accept-article-functions nil - "*Hook run before accepting an article. + "Hook run before accepting an article. Executed near the beginning of `nndiary-request-accept-article'. The hook functions will be called with the article in the current buffer." :group 'nndiary :type 'hook) (defcustom nndiary-check-directory-twice t - "*If t, check directories twice to avoid NFS failures." + "If t, check directories twice to avoid NFS failures." :group 'nndiary :type 'boolean) @@ -1157,12 +1147,12 @@ all. This may very well take some time.") ;; within the specified bounds. ;; Signals are caught by `nndiary-schedule'. (if (not (string-match "^[ \t]*[0-9]+[ \t]*$" str)) - (nndiary-error "not an integer value") + (error "Not an integer value") ;; else (let ((val (string-to-number str))) (and (or (< val min) (and max (> val max))) - (nndiary-error "value out of range")) + (error "Value out of range")) val))) (defun nndiary-parse-schedule-value (str min-or-values max) @@ -1179,7 +1169,7 @@ all. This may very well take some time.") (match-string 1 str)))) (if (and val (setq val (assoc val min-or-values))) (list (cadr val)) - (nndiary-error "invalid syntax"))) + (error "Invalid syntax"))) ;; min-or-values is min (mapcar (lambda (val) @@ -1199,7 +1189,7 @@ all. This may very well take some time.") (t (cons end beg))))) (t - (nndiary-error "invalid syntax"))) + (error "Invalid syntax"))) )) (split-string str ","))) )) @@ -1214,7 +1204,7 @@ all. This may very well take some time.") (let ((header (format "^X-Diary-%s: \\(.*\\)$" head))) (goto-char (point-min)) (if (not (re-search-forward header nil t)) - (nndiary-error "header missing") + (error "Header missing") ;; else (nndiary-parse-schedule-value (match-string 1) min-or-values max)) )) @@ -1288,27 +1278,27 @@ all. This may very well take some time.") (while (setq reminder (pop reminders)) (push (cond ((eq (cdr reminder) 'minute) - (subtract-time + (time-subtract (apply 'encode-time 0 (nthcdr 1 date-elts)) (seconds-to-time (* (car reminder) 60.0)))) ((eq (cdr reminder) 'hour) - (subtract-time + (time-subtract (apply 'encode-time 0 0 (nthcdr 2 date-elts)) (seconds-to-time (* (car reminder) 3600.0)))) ((eq (cdr reminder) 'day) - (subtract-time + (time-subtract (apply 'encode-time 0 0 0 (nthcdr 3 date-elts)) (seconds-to-time (* (car reminder) 86400.0)))) ((eq (cdr reminder) 'week) - (subtract-time + (time-subtract (apply 'encode-time 0 0 0 monday (nthcdr 4 date-elts)) (seconds-to-time (* (car reminder) 604800.0)))) ((eq (cdr reminder) 'month) - (subtract-time + (time-subtract (apply 'encode-time 0 0 0 1 (nthcdr 4 date-elts)) (seconds-to-time (* (car reminder) 18748800.0)))) ((eq (cdr reminder) 'year) - (subtract-time + (time-subtract (apply 'encode-time 0 0 0 1 1 (nthcdr 5 date-elts)) (seconds-to-time (* (car reminder) 400861056.0))))) res)) diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index d5ed8f6b34e..f32a3e70c99 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -761,7 +761,7 @@ from the document.") (looking-at "JMF")) (defun nndoc-oe-dbx-type-p () - (looking-at (mm-string-to-multibyte "\317\255\022\376"))) + (looking-at (string-to-multibyte "\317\255\022\376"))) (defun nndoc-read-little-endian () (+ (prog1 (char-after) (forward-char 1)) diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index a88ecc0efd5..12a1b2b284a 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -43,10 +43,12 @@ "Where nndraft will store its files." nnmh-directory) -(defvar nndraft-required-headers '(Date) - "*Headers to be generated when saving a draft message. +(defcustom nndraft-required-headers '(Date) + "Headers to be generated when saving a draft message. The headers in this variable and the ones in `message-required-headers' -are generated if and only if they are also in `message-draft-headers'.") +are generated if and only if they are also in `message-draft-headers'." + :type '(repeat sexp) + :group 'message-headers) ; FIXME wrong group @@ -203,12 +205,7 @@ are generated if and only if they are also in `message-draft-headers'.") (setq buffer-file-name (expand-file-name file) buffer-auto-save-file-name (make-auto-save-file-name)) (clear-visited-file-modtime) - (let ((hook (if (boundp 'write-contents-functions) - 'write-contents-functions - 'write-contents-hooks))) - (gnus-make-local-hook hook) - (add-hook hook 'nndraft-generate-headers nil t)) - (gnus-make-local-hook 'after-save-hook) + (add-hook 'write-contents-functions 'nndraft-generate-headers nil t) (add-hook 'after-save-hook 'nndraft-update-unread-articles nil t) (message-add-action '(nndraft-update-unread-articles) 'exit 'postpone 'kill) diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el index ea0796bef21..6850cad2e60 100644 --- a/lisp/gnus/nneething.el +++ b/lisp/gnus/nneething.el @@ -284,7 +284,7 @@ included.") (defun nneething-encode-file-name (file &optional coding-system) "Encode the name of the FILE in CODING-SYSTEM." (let ((pos 0) buf) - (setq file (mm-encode-coding-string + (setq file (encode-coding-string file (or coding-system nnmail-pathname-coding-system))) (while (string-match "[^-0-9a-zA-Z_:/.]" file pos) (setq buf (cons (format "%%%02x" (aref file (match-beginning 0))) @@ -300,7 +300,7 @@ included.") (setq buf (cons (string (string-to-number (match-string 1 file) 16)) (cons (substring file pos (match-beginning 0)) buf)) pos (match-end 0))) - (mm-decode-coding-string + (decode-coding-string (apply (function concat) (nreverse (cons (substring file pos) buf))) (or coding-system nnmail-pathname-coding-system)))) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 5926977e6c5..18c92f9f77b 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -884,9 +884,7 @@ deleted. Point is left where the deleted region was." (active (or (cadr (assoc group nnfolder-group-alist)) (cons 1 0))) (scantime (assoc group nnfolder-scantime-alist)) - (minid (or (and (boundp 'most-positive-fixnum) - most-positive-fixnum) - (lsh -1 -1))) + (minid most-positive-fixnum) maxid start end newscantime novbuf articles newnum buffer-read-only) @@ -1061,7 +1059,7 @@ This command does not work if you use short group names." (defun nnfolder-group-pathname (group) "Make file name for GROUP." (setq group - (mm-encode-coding-string group nnmail-pathname-coding-system)) + (encode-coding-string group nnmail-pathname-coding-system)) (let ((dir (file-name-as-directory (expand-file-name nnfolder-directory)))) ;; If this file exists, we use it directly. (if (or nnmail-use-long-file-names diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 414d032a821..648485b4f61 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -40,6 +40,7 @@ (require 'mail-utils) (require 'mm-util) (require 'gnus-util) +(require 'subr-x) (autoload 'gnus-range-add "gnus-range") (autoload 'gnus-remove-from-range "gnus-range") ;; FIXME none of these are used explicitly in this file. @@ -62,18 +63,23 @@ they will keep on jabbering all the time." :group 'gnus-server :type 'boolean) -(defvar nnheader-max-head-length 8192 - "*Max length of the head of articles. +(defcustom nnheader-max-head-length 8192 + "Max length of the head of articles. Value is an integer, nil, or t. nil means read in chunks of a file indefinitely until a complete head is found; t means always read the entire file immediately, disregarding `nnheader-head-chop-length'. Integer values will in effect be rounded up to the nearest multiple of -`nnheader-head-chop-length'.") - -(defvar nnheader-head-chop-length 2048 - "*Length of each read operation when trying to fetch HEAD headers.") +`nnheader-head-chop-length'." + :group 'gnus-article-various ; FIXME? + :type '(choice integer (const :tag "Read chunks" nil) + (const :tag "Read entire file" t))) + +(defcustom nnheader-head-chop-length 2048 + "Length of each read operation when trying to fetch HEAD headers." + :group 'gnus-article-various ; FIXME? + :type 'integer) (defvar nnheader-read-timeout (if (string-match "windows-nt\\|os/2\\|cygwin" @@ -98,7 +104,7 @@ Integer values will in effect be rounded up to the nearest multiple of "How long nntp should wait between checking for the end of output. Shorter values mean quicker response, but are more CPU intensive.") -(defvar nnheader-file-name-translation-alist +(defcustom nnheader-file-name-translation-alist (let ((case-fold-search t)) (cond ((string-match "windows-nt\\|os/2\\|cygwin" @@ -110,15 +116,19 @@ Shorter values mean quicker response, but are more CPU intensive.") nil '((?+ . ?-))))) (t nil))) - "*Alist that says how to translate characters in file names. + "Alist that says how to translate characters in file names. For instance, if \":\" is invalid as a file character in file names on your system, you could say something like: -\(setq nnheader-file-name-translation-alist \\='((?: . ?_)))") +\(setq nnheader-file-name-translation-alist \\='((?: . ?_)))" + :group 'gnus-article-various ; FIXME? + :type '(alist :key-type character :value-type character)) -(defvar nnheader-directory-separator-character +(defcustom nnheader-directory-separator-character (string-to-char (substring (file-name-as-directory ".") -1)) - "*A character used to a directory separator.") + "A character used as a directory separator." + :group 'gnus-article-various ; FIXME? + :type 'character) (autoload 'nnmail-message-id "nnmail") (autoload 'mail-position-on-field "sendmail") @@ -621,8 +631,8 @@ the line could be found." (< beg nnheader-max-head-length)))) ;; Finally decode the contents. (when (mm-coding-system-p nnheader-file-coding-system) - (mm-decode-coding-region start (point-max) - nnheader-file-coding-system)))) + (decode-coding-region start (point-max) + nnheader-file-coding-system)))) t)) (defun nnheader-article-p () @@ -726,9 +736,7 @@ the line could be found." (string-match nnheader-numerical-short-files file) (string-to-number (match-string 0 file)))) -(defvar nnheader-directory-files-is-safe - (or (eq system-type 'windows-nt) - (not (featurep 'xemacs))) +(defvar nnheader-directory-files-is-safe (not (eq system-type 'windows-nt)) "If non-nil, Gnus believes `directory-files' is safe. It has been reported numerous times that `directory-files' fails with an alarming frequency on NFS mounted file systems. If it is nil, @@ -780,28 +788,8 @@ If FULL, translate everything." 2 0)) ;; We translate -- but only the file name. We leave the directory ;; alone. - (if (and (featurep 'xemacs) - (memq system-type '(windows-nt cygwin))) - ;; This is needed on NT and stuff, because - ;; file-name-nondirectory is not enough to split - ;; file names, containing ':', e.g. - ;; "d:\\Work\\News\\nntp+news.fido7.ru:fido7.ru.gnu.SCORE" - ;; - ;; we are trying to correctly split such names: - ;; "d:file.name" -> "a:" "file.name" - ;; "aaa:bbb.ccc" -> "" "aaa:bbb.ccc" - ;; "d:aaa\\bbb:ccc" -> "d:aaa\\" "bbb:ccc" - ;; etc. - ;; to translate then only the file name part. - (progn - (setq leaf file - path "") - (if (string-match "\\(^\\w:\\|[/\\]\\)\\([^/\\]+\\)$" file) - (setq leaf (substring file (match-beginning 2)) - path (substring file 0 (match-beginning 2))))) - ;; Emacs DTRT, says andrewi. - (setq leaf (file-name-nondirectory file) - path (file-name-directory file)))) + (setq leaf (file-name-nondirectory file) + path (file-name-directory file))) (setq len (length leaf)) (while (< i len) (when (setq trans (cdr (assq (aref leaf i) @@ -842,7 +830,7 @@ without formatting." t)) (defsubst nnheader-replace-chars-in-string (string from to) - (mm-subst-char-in-string from to string)) + (subst-char-in-string from to string)) (defun nnheader-replace-duplicate-chars-in-string (string from to) "Replace characters in STRING from FROM to TO." @@ -886,8 +874,10 @@ without formatting." (or (not (numberp gnus-verbose-backends)) (<= level gnus-verbose-backends))) -(defvar nnheader-pathname-coding-system 'iso-8859-1 - "*Coding system for file name.") +(defcustom nnheader-pathname-coding-system 'iso-8859-1 + "Coding system for file name." + :group 'gnus-article-various ; FIXME? + :type 'coding-system) (defun nnheader-group-pathname (group dir &optional file) "Make file name for GROUP." @@ -898,7 +888,7 @@ without formatting." (if (file-directory-p (concat dir group)) (expand-file-name group dir) ;; If not, we translate dots into slashes. - (expand-file-name (mm-encode-coding-string + (expand-file-name (encode-coding-string (nnheader-replace-chars-in-string group ?. ?/) nnheader-pathname-coding-system) dir)))) @@ -1002,14 +992,8 @@ See `find-file-noselect' for the arguments." (enable-local-eval nil) (coding-system-for-read nnheader-file-coding-system) (version-control 'never) - (ffh (if (boundp 'find-file-hook) - 'find-file-hook - 'find-file-hooks)) - (val (symbol-value ffh))) - (set ffh nil) - (unwind-protect - (apply 'find-file-noselect args) - (set ffh val)))) + (find-file-hook nil)) + (apply 'find-file-noselect args))) (defun nnheader-directory-regular-files (dir) "Return a list of all regular files in DIR." @@ -1098,16 +1082,14 @@ See `find-file-noselect' for the arguments." (defmacro nnheader-insert-buffer-substring (buffer &optional start end) "Copy string from unibyte buffer to multibyte current buffer." - (if (featurep 'xemacs) - `(insert-buffer-substring ,buffer ,start ,end) - `(if enable-multibyte-characters - (insert (with-current-buffer ,buffer - (mm-string-to-multibyte - ,(if (or start end) - `(buffer-substring (or ,start (point-min)) - (or ,end (point-max))) - '(buffer-string))))) - (insert-buffer-substring ,buffer ,start ,end)))) + `(if enable-multibyte-characters + (insert (with-current-buffer ,buffer + (string-to-multibyte + ,(if (or start end) + `(buffer-substring (or ,start (point-min)) + (or ,end (point-max))) + '(buffer-string))))) + (insert-buffer-substring ,buffer ,start ,end))) (defvar nnheader-last-message-time '(0 0)) (defun nnheader-message-maybe (&rest args) @@ -1116,9 +1098,6 @@ See `find-file-noselect' for the arguments." (setq nnheader-last-message-time now) (apply 'nnheader-message args)))) -(when (featurep 'xemacs) - (require 'nnheaderxm)) - (run-hooks 'nnheader-load-hook) (provide 'nnheader) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index dc970f826e5..700e86a0c57 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -26,13 +26,6 @@ ;;; Code: -(eval-and-compile - (require 'nnheader) - ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for - ;; `make-network-stream'. - (unless (fboundp 'open-protocol-stream) - (require 'proto-stream))) - (eval-when-compile (require 'cl)) @@ -164,7 +157,8 @@ textual parts.") (forward "gnus-forward"))) (defvar nnimap-quirks - '(("QRESYNC" "Zimbra" "QRESYNC "))) + '(("QRESYNC" "Zimbra" "QRESYNC ") + ("MOVE" "Dovecot" nil))) (defvar nnimap-inhibit-logging nil) @@ -234,7 +228,7 @@ textual parts.") (delete-region (+ (match-beginning 0) 2) (point)) (setq string (buffer-substring (point) (+ (point) size))) (delete-region (point) (+ (point) size)) - (insert (format "%S" (mm-subst-char-in-string ?\n ?\s string)))) + (insert (format "%S" (subst-char-in-string ?\n ?\s string)))) (beginning-of-line) (setq article (and (re-search-forward "UID \\([0-9]+\\)" (line-end-position) @@ -365,7 +359,7 @@ textual parts.") (with-current-buffer buffer (when (and nnimap-object (nnimap-last-command-time nnimap-object) - (> (gnus-float-time + (> (float-time (time-subtract now (nnimap-last-command-time nnimap-object))) @@ -424,7 +418,7 @@ textual parts.") (when nnimap-server-port (push nnimap-server-port ports)) (let* ((stream-list - (open-protocol-stream + (open-network-stream "*nnimap*" (current-buffer) nnimap-address (nnimap-map-port (car ports)) :type nnimap-stream @@ -437,7 +431,7 @@ textual parts.") :success " OK " :starttls-function (lambda (capabilities) - (when (gnus-string-match-p "STARTTLS" capabilities) + (when (string-match-p "STARTTLS" capabilities) "1 STARTTLS\r\n")))) (stream (car stream-list)) (props (cdr stream-list)) @@ -447,9 +441,7 @@ textual parts.") (when (and stream (not (memq (process-status stream) '(open run)))) (setq stream nil)) - (when (and (fboundp 'set-network-process-option) ;; Not in XEmacs. - (fboundp 'process-type) ;; Emacs 22 doesn't provide it. - (eq (process-type stream) 'network)) + (when (eq (process-type stream) 'network) ;; Use TCP-keepalive so that connections that pass through a NAT ;; router don't hang when left idle. (set-network-process-option stream :keepalive t)) @@ -461,15 +453,15 @@ textual parts.") (nnheader-report 'nnimap "Unable to contact %s:%s via %s" nnimap-address (car ports) nnimap-stream) 'no-connect) - (gnus-set-process-query-on-exit-flag stream nil) - (if (not (gnus-string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting)) + (set-process-query-on-exit-flag stream nil) + (if (not (string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting)) (nnheader-report 'nnimap "%s" greeting) ;; Store the greeting (for debugging purposes). (setf (nnimap-greeting nnimap-object) greeting) (setf (nnimap-capabilities nnimap-object) (mapcar #'upcase (split-string capabilities))) - (unless (gnus-string-match-p "[*.] PREAUTH" greeting) + (unless (string-match-p "[*.] PREAUTH" greeting) (if (not (setq credentials (if (eq nnimap-authenticator 'anonymous) (list "anonymous" @@ -922,7 +914,8 @@ textual parts.") t) (deffoo nnimap-request-move-article (article group server accept-form - &optional _last internal-move-group) + &optional _last + internal-move-group) (setq group (nnimap-decode-gnus-group group)) (when internal-move-group (setq internal-move-group (nnimap-decode-gnus-group internal-move-group))) @@ -932,17 +925,19 @@ textual parts.") 'nnimap-request-head 'nnimap-request-article) article group server (current-buffer)) - ;; If the move is internal (on the same server), just do it the easy - ;; way. + ;; If the move is internal (on the same server), just do it the + ;; easy way. (let ((message-id (message-field-value "message-id"))) (if internal-move-group (with-current-buffer (nnimap-buffer) - (let* ((can-move (nnimap-capability "MOVE")) - (command (if can-move - "UID MOVE %d %S" - "UID COPY %d %S")) - (result (nnimap-command command article - (utf7-encode internal-move-group t)))) + (let* ((can-move (and (nnimap-capability "MOVE") + (equal (nnimap-quirk "MOVE") "MOVE"))) + (command (if can-move + "UID MOVE %d %S" + "UID COPY %d %S")) + (result (nnimap-command + command article + (utf7-encode internal-move-group t)))) (when (and (car result) (not can-move)) (nnimap-delete-article article)) (cons internal-move-group @@ -951,11 +946,10 @@ textual parts.") internal-move-group server message-id nnimap-request-articles-find-limit))))) ;; Move the article to a different method. - (let ((result (eval accept-form))) - (when result - (nnimap-change-group group server) - (nnimap-delete-article article) - result))))))) + (when-let ((result (eval accept-form))) + (nnimap-change-group group server) + (nnimap-delete-article article) + result)))))) (deffoo nnimap-request-expire-articles (articles group &optional server force) (setq group (nnimap-decode-gnus-group group)) @@ -1003,7 +997,8 @@ textual parts.") (and (nnimap-change-group group server) (with-current-buffer (nnimap-buffer) (nnheader-message 7 "Expiring articles from %s: %s" group articles) - (let ((can-move (nnimap-capability "MOVE"))) + (let ((can-move (and (nnimap-capability "MOVE") + (equal (nnimap-quirk "MOVE") "MOVE")))) (nnimap-command (if can-move "UID MOVE %s %S" @@ -1887,9 +1882,7 @@ Return the server's response to the SELECT or EXAMINE command." (let ((name "*imap log*")) (or (get-buffer name) (with-current-buffer (get-buffer-create name) - (when (boundp 'window-point-insertion-type) - (make-local-variable 'window-point-insertion-type) - (setq window-point-insertion-type t)) + (setq-local window-point-insertion-type t) (current-buffer))))) (defun nnimap-log-command (command) @@ -2076,7 +2069,8 @@ Return the server's response to the SELECT or EXAMINE command." nnmail-split-fancy)) (nnmail-inhibit-default-split-group t) (groups (nnimap-get-groups)) - (can-move (nnimap-capability "MOVE")) + (can-move (and (nnimap-capability "MOVE") + (equal (nnimap-quirk "MOVE") "MOVE"))) new-articles) (erase-buffer) (nnimap-command "SELECT %S" nnimap-inbox) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index a490bc280d8..536474cabc6 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -294,14 +294,14 @@ is `(valuefunc member)'." :group 'gnus) (defcustom nnir-ignored-newsgroups "" - "*A regexp to match newsgroups in the active file that should + "A regexp to match newsgroups in the active file that should be skipped when searching." :version "24.1" :type '(regexp) :group 'nnir) (defcustom nnir-summary-line-format nil - "*The format specification of the lines in an nnir summary buffer. + "The format specification of the lines in an nnir summary buffer. All the items from `gnus-summary-line-format' are available, along with three items unique to nnir summary buffers: @@ -316,7 +316,7 @@ If nil this will use `gnus-summary-line-format'." :group 'nnir) (defcustom nnir-retrieve-headers-override-function nil - "*If non-nil, a function that accepts an article list and group + "If non-nil, a function that accepts an article list and group and populates the `nntp-server-buffer' with the retrieved headers. Must return either 'nov or 'headers indicating the retrieved header format. @@ -328,7 +328,7 @@ result, `gnus-retrieve-headers' will be called instead." :group 'nnir) (defcustom nnir-imap-default-search-key "whole message" - "*The default IMAP search key for an nnir search. Must be one of + "The default IMAP search key for an nnir search. Must be one of the keys in `nnir-imap-search-arguments'. To use raw imap queries by default set this to \"imap\"." :version "24.1" @@ -338,17 +338,17 @@ result, `gnus-retrieve-headers' will be called instead." (defcustom nnir-swish++-configuration-file (expand-file-name "~/Mail/swish++.conf") - "*Configuration file for swish++." + "Configuration file for swish++." :type '(file) :group 'nnir) (defcustom nnir-swish++-program "search" - "*Name of swish++ search executable." + "Name of swish++ search executable." :type '(string) :group 'nnir) (defcustom nnir-swish++-additional-switches '() - "*A list of strings, to be given as additional arguments to swish++. + "A list of strings, to be given as additional arguments to swish++. Note that this should be a list. I.e., do NOT use the following: (setq nnir-swish++-additional-switches \"-i -w\") ; wrong @@ -358,7 +358,7 @@ Instead, use this: :group 'nnir) (defcustom nnir-swish++-remove-prefix (concat (getenv "HOME") "/Mail/") - "*The prefix to remove from each file name returned by swish++ + "The prefix to remove from each file name returned by swish++ in order to get a group name (albeit with / instead of .). This is a regular expression. @@ -376,7 +376,7 @@ that it is for swish++, not Namazu." 'nnir-swish-e-index-files "Emacs 23.1") (defcustom nnir-swish-e-index-file (expand-file-name "~/Mail/index.swish-e") - "*Index file for swish-e. + "Index file for swish-e. This could be a server parameter. It is never consulted once `nnir-swish-e-index-files', which should be used instead, has been customized." @@ -385,19 +385,19 @@ used instead, has been customized." (defcustom nnir-swish-e-index-files (list nnir-swish-e-index-file) - "*List of index files for swish-e. + "List of index files for swish-e. This could be a server parameter." :type '(repeat (file)) :group 'nnir) (defcustom nnir-swish-e-program "swish-e" - "*Name of swish-e search executable. + "Name of swish-e search executable. This cannot be a server parameter." :type '(string) :group 'nnir) (defcustom nnir-swish-e-additional-switches '() - "*A list of strings, to be given as additional arguments to swish-e. + "A list of strings, to be given as additional arguments to swish-e. Note that this should be a list. I.e., do NOT use the following: (setq nnir-swish-e-additional-switches \"-i -w\") ; wrong @@ -409,7 +409,7 @@ This could be a server parameter." :group 'nnir) (defcustom nnir-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/") - "*The prefix to remove from each file name returned by swish-e + "The prefix to remove from each file name returned by swish-e in order to get a group name (albeit with / instead of .). This is a regular expression. @@ -423,12 +423,12 @@ This could be a server parameter." ;; HyREX engine, see <URL:http://ls6-www.cs.uni-dortmund.de/> (defcustom nnir-hyrex-program "nnir-search" - "*Name of the nnir-search executable." + "Name of the nnir-search executable." :type '(string) :group 'nnir) (defcustom nnir-hyrex-additional-switches '() - "*A list of strings, to be given as additional arguments for nnir-search. + "A list of strings, to be given as additional arguments for nnir-search. Note that this should be a list. I.e., do NOT use the following: (setq nnir-hyrex-additional-switches \"-ddl ddl.xml -c nnir\") ; wrong ! Instead, use this: @@ -437,12 +437,12 @@ Instead, use this: :group 'nnir) (defcustom nnir-hyrex-index-directory (getenv "HOME") - "*Index directory for HyREX." + "Index directory for HyREX." :type '(directory) :group 'nnir) (defcustom nnir-hyrex-remove-prefix (concat (getenv "HOME") "/Mail/") - "*The prefix to remove from each file name returned by HyREX + "The prefix to remove from each file name returned by HyREX in order to get a group name (albeit with / instead of .). For example, suppose that HyREX returns file names such as @@ -457,17 +457,17 @@ arrive at the correct group name, \"mail.misc\"." ;; Namazu engine, see <URL:http://www.namazu.org/> (defcustom nnir-namazu-program "namazu" - "*Name of Namazu search executable." + "Name of Namazu search executable." :type '(string) :group 'nnir) (defcustom nnir-namazu-index-directory (expand-file-name "~/Mail/namazu/") - "*Index directory for Namazu." + "Index directory for Namazu." :type '(directory) :group 'nnir) (defcustom nnir-namazu-additional-switches '() - "*A list of strings, to be given as additional arguments to namazu. + "A list of strings, to be given as additional arguments to namazu. The switches `-q', `-a', and `-s' are always used, very few other switches make any sense in this context. @@ -479,7 +479,7 @@ Instead, use this: :group 'nnir) (defcustom nnir-namazu-remove-prefix (concat (getenv "HOME") "/Mail/") - "*The prefix to remove from each file name returned by Namazu + "The prefix to remove from each file name returned by Namazu in order to get a group name (albeit with / instead of .). For example, suppose that Namazu returns file names such as @@ -492,13 +492,13 @@ arrive at the correct group name, \"mail.misc\"." :group 'nnir) (defcustom nnir-notmuch-program "notmuch" - "*Name of notmuch search executable." + "Name of notmuch search executable." :version "24.1" :type '(string) :group 'nnir) (defcustom nnir-notmuch-additional-switches '() - "*A list of strings, to be given as additional arguments to notmuch. + "A list of strings, to be given as additional arguments to notmuch. Note that this should be a list. I.e., do NOT use the following: (setq nnir-notmuch-additional-switches \"-i -w\") ; wrong @@ -509,7 +509,7 @@ Instead, use this: :group 'nnir) (defcustom nnir-notmuch-remove-prefix (concat (getenv "HOME") "/Mail/") - "*The prefix to remove from each file name returned by notmuch + "The prefix to remove from each file name returned by notmuch in order to get a group name (albeit with / instead of .). This is a regular expression. @@ -563,7 +563,7 @@ needs the variables `nnir-namazu-program', Add an entry here when adding a new search engine.") (defcustom nnir-method-default-engines '((nnimap . imap) (nntp . gmane)) - "*Alist of default search engines keyed by server method." + "Alist of default search engines keyed by server method." :version "24.1" :group 'nnir :type `(repeat (cons (choice (const nnimap) (const nntp) (const nnspool) @@ -928,9 +928,10 @@ ready to be added to the list of search results." ;; Set group to dirnam without any leading dots or slashes, ;; and with all subsequent slashes replaced by dots - (let ((group (gnus-replace-in-string - (gnus-replace-in-string dirnam "^[./\\]" "" t) - "[/\\]" "." t))) + (let ((group (replace-regexp-in-string + "[/\\]" "." + (replace-regexp-in-string "^[./\\]" "" dirnam nil t) + nil t))) (vector (gnus-group-full-name group server) (if (string-match "\\`nnmaildir:" (gnus-group-server server)) @@ -1340,9 +1341,10 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." ;; eliminate all ".", "/", "\" from beginning. Always matches. (string-match "^[./\\]*\\(.*\\)$" dirnam) ;; "/" -> "." - (setq group (gnus-replace-in-string (match-string 1 dirnam) "/" ".")) + (setq group (replace-regexp-in-string + "/" "." (match-string 1 dirnam))) ;; Windows "\\" -> "." - (setq group (gnus-replace-in-string group "\\\\" ".")) + (setq group (replace-regexp-in-string "\\\\" "." group)) (push (vector (gnus-group-full-name group server) (string-to-number artno) @@ -1414,7 +1416,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." (when (string-match prefix dirnam) (setq dirnam (replace-match "" t t dirnam))) (push (vector (gnus-group-full-name - (gnus-replace-in-string dirnam "/" ".") server) + (replace-regexp-in-string "/" "." dirnam) server) (string-to-number artno) (string-to-number score)) artlist)) @@ -1612,9 +1614,9 @@ actually)." group (if (file-directory-p (setq group - (gnus-replace-in-string - group - "\\." "/" t))) + (replace-regexp-in-string + "\\." "/" + group nil t))) group)))))) (unless group (error "Cannot locate directory for group")) @@ -1667,7 +1669,7 @@ actually)." (server (cadr (gnus-server-to-method srv))) (groupspec (mapconcat (lambda (x) - (if (gnus-string-match-p "gmane" x) + (if (string-match-p "gmane" x) (format "group:%s" (gnus-group-short-name x)) (error "Can't search non-gmane groups: %s" x))) groups " ")) @@ -1688,8 +1690,8 @@ actually)." (mm-url-encode-www-form-urlencoded `(("query" . ,search) ("HITSPERPAGE" . "999"))))) - (unless (featurep 'xemacs) (set-buffer-multibyte t)) - (mm-decode-coding-region (point-min) (point-max) 'utf-8) + (set-buffer-multibyte t) + (decode-coding-region (point-min) (point-max) 'utf-8) (goto-char (point-min)) (forward-line 1) (while (not (eobp)) @@ -1705,7 +1707,7 @@ actually)." (string-to-number (match-string 2 xref)) xscore) artlist))))) (forward-line 1))) - (apply 'vector (nreverse (mm-delete-duplicates artlist))))) + (apply 'vector (nreverse (delete-dups artlist))))) ;;; Util Code: @@ -1787,7 +1789,7 @@ article came from is also searched." (list (list (gnus-method-to-server (gnus-find-method-for-group gnus-newsgroup-name))))) (registry-group (and - (gnus-bound-and-true-p 'gnus-registry-enabled) + (bound-and-true-p gnus-registry-enabled) (car (gnus-registry-get-id-key (mail-header-id header) 'group)))) (registry-server @@ -1814,18 +1816,19 @@ article came from is also searched." (if (eq (car method) 'nntp) (while (not (eobp)) (ignore-errors - (push (mm-string-as-unibyte + (push (string-as-unibyte (gnus-group-full-name (buffer-substring (point) (progn (skip-chars-forward "^ \t") - (point))) method)) + (point))) + method)) groups)) (forward-line)) (while (not (eobp)) (ignore-errors - (push (mm-string-as-unibyte + (push (string-as-unibyte (if (eq (char-after) ?\") (gnus-group-full-name (read cur) method) (let ((p (point)) (name "")) @@ -1859,7 +1862,7 @@ article came from is also searched." (when (eq (car (gnus-find-method-for-group gnus-newsgroup-name)) 'nnir) (setq gnus-summary-line-format (or nnir-summary-line-format gnus-summary-line-format)) - (when (gnus-bound-and-true-p 'gnus-registry-enabled) + (when (bound-and-true-p gnus-registry-enabled) (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action t) (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action t) (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action t) diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index 29946ac8891..3f2e08171e0 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -76,7 +76,7 @@ :group 'nnmail) (defcustom nnmail-split-methods '(("mail.misc" "")) - "*Incoming mail will be split according to this variable. + "Incoming mail will be split according to this variable. If you'd like, for instance, one mail group for mail from the \"4ad-l\" mailing list, one group for junk mail and one for everything @@ -158,7 +158,7 @@ If nil, groups like \"mail.misc\" will end up in directories like :type 'integer) (defcustom nnmail-expiry-wait 7 - "*Expirable articles that are older than this will be expired. + "Expirable articles that are older than this will be expired. This variable can either be a number (which will be interpreted as a number of days) -- this doesn't have to be an integer. This variable can also be `immediate' and `never'." @@ -187,7 +187,7 @@ E.g.: (function :format "%v" nnmail-))) (defcustom nnmail-expiry-target 'delete - "*Variable that says where expired messages should end up. + "Variable that says where expired messages should end up. The default value is `delete' (which says to delete the messages), but it can also be a string or a function. If it is a string, expired messages end up in that group. If it is a function, the function is @@ -246,12 +246,12 @@ If non-nil, also update the cache when copy or move articles." ;; Variable removed in No Gnus v0.7 (defcustom nnmail-resplit-incoming nil - "*If non-nil, re-split incoming procmail sorted mail." + "If non-nil, re-split incoming procmail sorted mail." :group 'nnmail-procmail :type 'boolean) (defcustom nnmail-scan-directory-mail-source-once nil - "*If non-nil, scan all incoming procmail sorted mails once. + "If non-nil, scan all incoming procmail sorted mails once. It scans low-level sorted spools even when not required." :version "21.1" :group 'nnmail-procmail @@ -266,7 +266,7 @@ It scans low-level sorted spools even when not required." (if (string-match "windows-nt" (symbol-name system-type)) 'copy-file 'add-name-to-file) - "*Function called to create a copy of a file. + "Function called to create a copy of a file. This is `add-name-to-file' by default, which means that crossposts will use hard links. If your file system doesn't allow hard links, you could set this variable to `copy-file' instead." @@ -279,7 +279,7 @@ links, you could set this variable to `copy-file' instead." (if (eq system-type 'windows-nt) '(nnheader-ms-strip-cr) nil) - "*Hook that will be run after the incoming mail has been transferred. + "Hook that will be run after the incoming mail has been transferred. The incoming mail is moved from the specified spool file (which normally is something like \"/usr/spool/mail/$user\") to the user's home directory. This hook is called after the incoming mail box has been @@ -355,47 +355,20 @@ discarded after running the split process." :type 'hook) (defcustom nnmail-spool-hook nil - "*A hook called when a new article is spooled." + "A hook called when a new article is spooled." :version "22.1" :group 'nnmail :type 'hook) (defcustom nnmail-large-newsgroup 50 - "*The number of articles which indicates a large newsgroup or nil. + "The number of articles which indicates a large newsgroup or nil. If the number of articles is greater than the value, verbose messages will be shown to indicate the current status." :group 'nnmail-various :type '(choice (const :tag "infinite" nil) (number :tag "count"))) -(define-widget 'nnmail-lazy 'default - "Base widget for recursive data structures. - -This is copy of the `lazy' widget in Emacs 22.1 provided for compatibility." - :format "%{%t%}: %v" - :convert-widget 'widget-value-convert-widget - :value-create (lambda (widget) - (let ((value (widget-get widget :value)) - (type (widget-get widget :type))) - (widget-put widget :children - (list (widget-create-child-value - widget (widget-convert type) value))))) - :value-delete 'widget-children-value-delete - :value-get (lambda (widget) - (widget-value (car (widget-get widget :children)))) - :value-inline (lambda (widget) - (widget-apply (car (widget-get widget :children)) - :value-inline)) - :default-get (lambda (widget) - (widget-default-get - (widget-convert (widget-get widget :type)))) - :match (lambda (widget value) - (widget-apply (widget-convert (widget-get widget :type)) - :match value)) - :validate (lambda (widget) - (widget-apply (car (widget-get widget :children)) :validate))) - -(define-widget 'nnmail-split-fancy 'nnmail-lazy +(define-widget 'nnmail-split-fancy 'lazy "Widget for customizing splits in the variable of the same name." :tag "Split" :type '(menu-choice :value (any ".*value.*" "misc") @@ -516,12 +489,12 @@ Example: (from . "from\\|sender\\|resent-from") (nato . "to\\|cc\\|resent-to\\|resent-cc") (naany . "from\\|to\\|cc\\|sender\\|resent-from\\|resent-to\\|resent-cc")) - "*Alist of abbreviations allowed in `nnmail-split-fancy'." + "Alist of abbreviations allowed in `nnmail-split-fancy'." :group 'nnmail-split :type '(repeat (cons :format "%v" symbol regexp))) (defcustom nnmail-message-id-cache-length 1000 - "*The approximate number of Message-IDs nnmail will keep in its cache. + "The approximate number of Message-IDs nnmail will keep in its cache. If this variable is nil, no checking on duplicate messages will be performed." :group 'nnmail-duplicate @@ -536,7 +509,7 @@ performed." :type 'file) (defcustom nnmail-treat-duplicates 'warn - "*If non-nil, nnmail keep a cache of Message-IDs to discover mail duplicates. + "If non-nil, nnmail keep a cache of Message-IDs to discover mail duplicates. Three values are valid: nil, which means that nnmail is not to keep a Message-ID cache; `warn', which means that nnmail should insert extra headers to warn the user about the duplication (this is the default); @@ -628,15 +601,10 @@ using different case (i.e. mailing-list@domain vs Mailing-List@Domain)." mm-text-coding-system "Coding system used in reading inbox") -(defvar nnmail-pathname-coding-system - ;; This causes Emacs 22.2 and 22.3 to issue a useless warning. - ;;(if (and (featurep 'xemacs) (featurep 'file-coding)) - (if (featurep 'xemacs) - (if (featurep 'file-coding) - ;; Work around a bug in many XEmacs 21.5 betas. - ;; Cf. http://thread.gmane.org/gmane.emacs.gnus.general/68134 - (setq file-name-coding-system (coding-system-aliasee 'file-name)))) - "*Coding system for file name.") +(defcustom nnmail-pathname-coding-system nil + "Coding system for file name." + :group 'nnmail-various + :type 'coding-system) (defun nnmail-find-file (file) "Insert FILE in server buffer safely." @@ -697,15 +665,17 @@ nn*-request-list should have been called before calling this function." (setq group (symbol-name group))) (if (and (numberp (setq max (read buffer))) (numberp (setq min (read buffer)))) - (push (list (mm-string-as-unibyte group) (cons min max)) + (push (list (string-as-unibyte group) (cons min max)) group-assoc))) (error nil)) (widen) (forward-line 1)) group-assoc)) -(defvar nnmail-active-file-coding-system 'raw-text - "*Coding system for active file.") +(defcustom nnmail-active-file-coding-system 'raw-text + "Coding system for active file." + :group 'nnmail-various + :type 'coding-system) (defun nnmail-save-active (group-assoc file-name) "Save GROUP-ASSOC in ACTIVE-FILE." @@ -1173,7 +1143,7 @@ FUNC will be called with the group name to determine the article number." 5 "Error in `nnmail-split-methods'; using `bogus' mail group: %S" error-info) (sit-for 1) '("bogus"))))) - (setq split (mm-delete-duplicates split)) + (setq split (delete-dups split)) ;; The article may be "cross-posted" to `junk'. What ;; to do? Just remove the `junk' spec. Don't really ;; see anything else to do... @@ -1279,9 +1249,9 @@ Return the number of characters in the body." (insert (format "Xref: %s" (system-name))) (while group-alist (insert (if (mm-multibyte-p) - (mm-string-as-multibyte + (string-as-multibyte (format " %s:%d" (caar group-alist) (cdar group-alist))) - (mm-string-as-unibyte + (string-as-unibyte (format " %s:%d" (caar group-alist) (cdar group-alist))))) (setq group-alist (cdr group-alist))) (insert "\n"))) @@ -1402,7 +1372,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." ;; Builtin & operation. ((eq (car split) '&) - (apply 'nconc (mapcar 'nnmail-split-it (cdr split)))) + (mapcan 'nnmail-split-it (cdr split))) ;; Builtin | operation. ((eq (car split) '|) @@ -1957,10 +1927,8 @@ If TIME is nil, then return the cutoff time for oldness instead." ((and (equal header 'to-from) (or (string-match (cadr regexp-target-pair) from) (and (string-match (cadr regexp-target-pair) to) - (let* ((mail-dont-reply-to-names - (message-dont-reply-to-names)) - (rmail-dont-reply-to-names ; obsolete since 24.1 - mail-dont-reply-to-names)) + (let ((mail-dont-reply-to-names + (message-dont-reply-to-names))) (equal (if (fboundp 'rmail-dont-reply-to) (rmail-dont-reply-to from) (mail-dont-reply-to from)) ""))))) @@ -2054,13 +2022,13 @@ If TIME is nil, then return the cutoff time for oldness instead." (error "No current split history")) (with-output-to-temp-buffer "*nnmail split history*" (with-current-buffer standard-output - (fundamental-mode)) ; for Emacs 20.4+ - (dolist (elem nnmail-split-history) - (princ (mapconcat (lambda (ga) - (concat (car ga) ":" (int-to-string (cdr ga)))) - elem - ", ")) - (princ "\n")))) + (fundamental-mode)) + (dolist (elem nnmail-split-history) + (princ (mapconcat (lambda (ga) + (concat (car ga) ":" (int-to-string (cdr ga)))) + elem + ", ")) + (princ "\n")))) (defun nnmail-purge-split-history (group) "Remove all instances of GROUP from `nnmail-split-history'." diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 3d8926b6925..03cb445675c 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -97,14 +97,14 @@ See `nnmaildir-flag-mark-mapping'." (defun nnmaildir--ensure-suffix (filename) "Ensure that FILENAME contains the suffix \":2,\"." - (if (gnus-string-match-p ":2," filename) + (if (string-match-p ":2," filename) filename (concat filename ":2,"))) (defun nnmaildir--add-flag (flag suffix) "Return a copy of SUFFIX where FLAG is set. SUFFIX should start with \":2,\"." - (unless (gnus-string-match-p "^:2," suffix) + (unless (string-match-p "^:2," suffix) (error "Invalid suffix `%s'" suffix)) (let* ((flags (substring suffix 3)) (flags-as-list (append flags nil)) @@ -117,7 +117,7 @@ SUFFIX should start with \":2,\"." (defun nnmaildir--remove-flag (flag suffix) "Return a copy of SUFFIX where FLAG is cleared. SUFFIX should start with \":2,\"." - (unless (gnus-string-match-p "^:2," suffix) + (unless (string-match-p "^:2," suffix) (error "Invalid suffix `%s'" suffix)) (let* ((flags (substring suffix 3)) (flags-as-list (append flags nil)) @@ -125,8 +125,8 @@ SUFFIX should start with \":2,\"." (concat ":2," new-flags))) (defvar nnmaildir-article-file-name nil - "*The filename of the most recently requested article. This variable is set -by nnmaildir-request-article.") + "The filename of the most recently requested article. +This variable is set by `nnmaildir-request-article'.") ;; The filename of the article being moved/copied: (defvar nnmaildir--file nil) @@ -371,8 +371,7 @@ by nnmaildir-request-article.") (string= (downcase (caddr err)) "too many links"))) (defun nnmaildir--enoent-p (err) - (and (eq (car err) 'file-error) - (string= (downcase (caddr err)) "no such file or directory"))) + (eq (car err) 'file-missing)) (defun nnmaildir--eexist-p (err) (eq (car err) 'file-already-exists)) @@ -537,8 +536,8 @@ by nnmaildir-request-article.") (prin1 (vector storage-version num msgid nov) (current-buffer)) (setq file (concat novfile ":")) (nnmaildir--unlink file) - (gmm-write-region (point-min) (point-max) file nil 'no-message nil - 'excl)) + (write-region (point-min) (point-max) file nil 'no-message nil + 'excl)) (rename-file file novfile 'replace) (setf (nnmaildir--art-msgid article) msgid) nov))) @@ -656,13 +655,13 @@ by nnmaildir-request-article.") (if (zerop n) 1 (1- (lsh 1 (1+ (logb n)))))) (defun nnmaildir--system-name () - (gnus-replace-in-string - (gnus-replace-in-string - (gnus-replace-in-string - (system-name) - "\\\\" "\\134" 'literal) - "/" "\\057" 'literal) - ":" "\\072" 'literal)) + (replace-regexp-in-string + ":" "\\072" + (replace-regexp-in-string + "/" "\\057" + (replace-regexp-in-string "\\\\" "\\134" (system-name) nil 'literal) + nil 'literal) + nil 'literal)) (defun nnmaildir-request-type (_group &optional _article) 'mail) @@ -848,11 +847,11 @@ by nnmaildir-request-article.") (when (or ;; first look for marks in suffix, if it's valid... (when (and (stringp suffix) - (gnus-string-prefix-p ":2," suffix)) + (string-prefix-p ":2," suffix)) (or - (not (gnus-string-match-p + (not (string-match-p (string (nnmaildir--mark-to-flag 'read)) suffix)) - (gnus-string-match-p + (string-match-p (string (nnmaildir--mark-to-flag 'tick)) suffix))) ;; then look in marks directories (not (file-exists-p (concat cdir prefix))) @@ -955,8 +954,9 @@ by nnmaildir-request-article.") pgname (nnmaildir--pgname nnmaildir--cur-server pgname) group (symbol-value group) ro (nnmaildir--param pgname 'read-only)) - (insert (gnus-replace-in-string - (nnmaildir--grp-name group) " " "\\ " t) + (insert (replace-regexp-in-string + " " "\\ " + (nnmaildir--grp-name group) nil t) " ") (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) nntp-server-buffer) @@ -985,7 +985,7 @@ by nnmaildir-request-article.") (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) nntp-server-buffer) (insert " " - (gnus-replace-in-string gname " " "\\ " t) + (replace-regexp-in-string " " "\\ " gname nil t) "\n"))))) 'group) @@ -1116,7 +1116,7 @@ by nnmaildir-request-article.") (insert " ") (princ (nnmaildir--group-maxnum nnmaildir--cur-server group) nntp-server-buffer) - (insert " " (gnus-replace-in-string gname " " "\\ " t) "\n") + (insert " " (replace-regexp-in-string " " "\\ " gname nil t) "\n") t)))) (defun nnmaildir-request-create-group (gname &optional server _args) @@ -1278,7 +1278,7 @@ by nnmaildir-request-article.") (insert "\t" (nnmaildir--nov-get-beg nov) "\t" (nnmaildir--art-msgid article) "\t" (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " - (gnus-replace-in-string gname " " "\\ " t) ":") + (replace-regexp-in-string " " "\\ " gname nil t) ":") (princ num nntp-server-buffer) (insert "\t" (nnmaildir--nov-get-end nov) "\n")))) (catch 'return @@ -1396,8 +1396,8 @@ by nnmaildir-request-article.") (concat "File exists: " tmpfile)) (throw 'return nil)) (with-current-buffer buffer - (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil - 'excl)) + (write-region (point-min) (point-max) tmpfile nil 'no-message nil + 'excl)) (unix-sync) ;; no fsync :( (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace) t))) @@ -1490,8 +1490,8 @@ by nnmaildir-request-article.") (throw 'return nil)))) (condition-case nil (add-name-to-file nnmaildir--file tmpfile) (error - (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil - 'excl) + (write-region (point-min) (point-max) tmpfile nil 'no-message nil + 'excl) (when (fboundp 'unix-sync) (unix-sync)))) ;; no fsync :( (nnheader-cancel-timer 24h) diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index fbd70ccb004..a678a797439 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -147,11 +147,6 @@ ;;; === Keymaps -(eval-when-compile - (when (featurep 'xemacs) - ;; The `kbd' macro requires that the `read-kbd-macro' macro is available. - (require 'edmacro))) - ;; Group mode (defun nnmairix-group-mode-hook () "Nnmairix group mode keymap." @@ -1635,7 +1630,7 @@ search in raw mode." (defun nnmairix-determine-original-group-from-registry (mid) "Try to determine original group for message-id MID from the registry." - (when (gnus-bound-and-true-p 'gnus-registry-enabled) + (when (bound-and-true-p gnus-registry-enabled) (unless (string-match "^<" mid) (set mid (concat "<" mid))) (unless (string-match ">$" mid) diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index 54ea37919a2..bec174db86a 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -242,8 +242,8 @@ as unread by Gnus.") (file-truename (file-name-as-directory (expand-file-name nnmh-toplev)))) dir) - (mm-string-to-multibyte ;Why? Isn't it multibyte already? - (mm-encode-coding-string + (string-to-multibyte ;Why? Isn't it multibyte already? + (encode-coding-string (nnheader-replace-chars-in-string (substring dir (match-end 0)) ?/ ?.) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index 3430b34146c..b0c7bf41add 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -128,13 +128,13 @@ non-nil.") "Return a decoded group name of GROUP on SERVER-OR-METHOD." (if nnmail-group-names-not-encoded-p group - (mm-decode-coding-string + (decode-coding-string group (nnml-group-name-charset group server-or-method)))) (defun nnml-encoded-group-name (group &optional server-or-method) "Return an encoded group name of GROUP on SERVER-OR-METHOD." - (mm-encode-coding-string + (encode-coding-string group (nnml-group-name-charset group server-or-method))) @@ -1077,8 +1077,7 @@ Use the nov database for the current group if available." ;; 1/ Move the article to a new file: (let* ((oldfile (nnml-article-to-file old-number)) (newfile - (gnus-replace-in-string - oldfile + (replace-regexp-in-string ;; nnml-use-compressed-files might be any string, but ;; probably it's sufficient to take into account only ;; "\\.[a-z0-9]+". Note that we can't only use the @@ -1087,7 +1086,8 @@ Use the nov database for the current group if available." ;; value. (concat "\\(" old-number-string "\\)\\(\\(\\.[a-z0-9]+\\)?\\)$") - (concat new-number-string "\\2")))) + (concat new-number-string "\\2") + oldfile))) (with-current-buffer nntp-server-buffer (nnmail-find-file oldfile) ;; Update the Xref header in the article itself: diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 95c07efa203..8115057723c 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -37,10 +37,11 @@ (require 'mm-url) (require 'rfc2047) (require 'mml) -(eval-when-compile - (ignore-errors - (require 'xml))) -(eval '(require 'xml)) +(require 'xml) + +(defgroup nnrss nil + "RSS access for Gnus." + :group 'gnus) (nnoo-declare nnrss) @@ -89,14 +90,16 @@ The arguments are (ENTRY GROUP ARTICLE). ENTRY is the record of the current headline. GROUP is the group name. ARTICLE is the article number of the current headline.") -(defvar nnrss-file-coding-system mm-universal-coding-system - "*Coding system used when reading and writing files. +(defcustom nnrss-file-coding-system mm-universal-coding-system + "Coding system used when reading and writing files. If you run Gnus with various versions of Emacsen, the value of this variable should be the coding system that all those Emacsen support. Note that you have to regenerate all the nnrss groups if you change the value. Moreover, you should be patient even if you are made to read the same articles twice, that arises for the difference of the -versions of xml.el.") +versions of xml.el." + :group 'nnrss + :type 'coding-system) (defvar nnrss-compatible-encoding-alist (delq nil (mapcar (lambda (elem) @@ -114,11 +117,11 @@ for decoding when the cdr that the data specify is not available.") ;;; Interface functions (defsubst nnrss-format-string (string) - (gnus-replace-in-string string " *\n *" " ")) + (replace-regexp-in-string " *\n *" " " string)) (defun nnrss-decode-group-name (group) (if (and group (mm-coding-system-p 'utf-8)) - (setq group (mm-decode-coding-string group 'utf-8)) + (setq group (decode-coding-string group 'utf-8)) group)) (deffoo nnrss-retrieve-headers (articles &optional group server fetch-old) @@ -243,7 +246,6 @@ for decoding when the cdr that the data specify is not available.") (max 1 (/ (* (window-width window) 7) 8)))) (fill-region (point) (point-max)) (goto-char (point-max)) - ;; XEmacs version of `fill-region' inserts newline. (unless (bolp) (insert "\n")))) (when (or link enclosure) @@ -295,7 +297,7 @@ for decoding when the cdr that the data specify is not available.") (let ((rfc2047-encoding-type 'mime) rfc2047-encode-max-chars) (rfc2047-encode-string - (gnus-replace-in-string group "[\t\n ]+" "_"))))) + (replace-regexp-in-string "[\t\n ]+" "_" group))))) (when nnrss-content-function (funcall nnrss-content-function e group article)))) (cond @@ -372,8 +374,6 @@ for decoding when the cdr that the data specify is not available.") (nnoo-define-skeleton nnrss) ;;; Internal functions -(eval-when-compile (defun xml-rpc-method-call (&rest args))) - (defun nnrss-get-encoding () "Return an encoding attribute specified in the current xml contents. If `nnrss-compatible-encoding-alist' specifies the compatible encoding, @@ -417,7 +417,7 @@ otherwise return nil." ;; Decode text according to the encoding attribute. (when (setq cs (nnrss-get-encoding)) (insert (prog1 - (mm-decode-coding-string (buffer-string) cs) + (decode-coding-string (buffer-string) cs) (erase-buffer) (mm-enable-multibyte)))) (goto-char (point-min)) @@ -588,12 +588,11 @@ which RSS 2.0 allows." "") (defun nnrss-insert (url) - (mm-with-unibyte-current-buffer - (condition-case err - (mm-url-insert url) - (error (if (or debug-on-quit debug-on-error) - (signal (car err) (cdr err)) - (message "nnrss: Failed to fetch %s" url)))))) + (condition-case err + (mm-url-insert url) + (error (if (or debug-on-quit debug-on-error) + (signal (car err) (cdr err)) + (message "nnrss: Failed to fetch %s" url))))) (defun nnrss-decode-entities-string (string) (if string @@ -763,7 +762,7 @@ Read the file and attempt to subscribe to each Feed in the file." Export subscriptions to a buffer in OPML Format." (interactive) (with-current-buffer (get-buffer-create "*OPML Export*") - (mm-set-buffer-file-coding-system 'utf-8) + (set-buffer-file-coding-system 'utf-8) (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" "<!-- OPML generated by Emacs Gnus' nnrss.el -->\n" "<opml version=\"1.1\">\n" @@ -810,10 +809,11 @@ It is useful when `(setq nnrss-use-local t)'." (nnrss-node-just-text node) node)) (cleaned-text (if text - (gnus-replace-in-string - (gnus-replace-in-string - text "^[\000-\037\177]+\\|^ +\\| +$" "") - "\r\n" "\n")))) + (replace-regexp-in-string + "\r\n" "\n" + (replace-regexp-in-string + "^[\000-\037\177]+\\|^ +\\| +$" "" + text))))) (if (string-equal "" cleaned-text) nil cleaned-text))) @@ -959,6 +959,9 @@ Use Mark Pilgrim's `ultra-liberal rss locator'." ;; 4. check syndic8 (nnrss-find-rss-via-syndic8 url)))))))) +(declare-function xml-rpc-method-call "ext:xml-rpc" + (server-url method &rest params)) + (defun nnrss-find-rss-via-syndic8 (url) "Query syndic8 for the rss feeds it has for URL." (if (not (locate-library "xml-rpc")) diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index f64927164ec..1db0a4192a1 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -306,7 +306,7 @@ there.") "\\([^ ]+\\) +\\([0-9]+\\)[0-9][0-9][0-9] ")) (zerop (forward-line -1)))) ;; We require nnheader which requires gnus-util. - (let ((seconds (gnus-float-time (date-to-time date))) + (let ((seconds (float-time (date-to-time date))) groups) ;; Go through lines and add the latest groups to a list. (while (and (looking-at "\\([^ ]+\\) +[0-9]+ ") @@ -335,6 +335,7 @@ there.") (save-excursion (let* ((process-connection-type nil) ; t bugs out on Solaris (inews-buffer (generate-new-buffer " *nnspool post*")) + (buf (current-buffer)) (proc (condition-case err (apply 'start-process "*nnspool inews*" inews-buffer @@ -346,7 +347,11 @@ there.") () (nnheader-report 'nnspool "") (set-process-sentinel proc 'nnspool-inews-sentinel) - (mm-with-unibyte-current-buffer + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-buffer-substring buf) + (encode-coding-region (point-min) (point-max) + nnspool-file-coding-system) (process-send-region proc (point-min) (point-max))) ;; We slap a condition-case around this, because the process may ;; have exited already... diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 9dc795e41e2..a71f4c7b5dd 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -25,12 +25,6 @@ ;;; Code: -(eval-and-compile - ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for - ;; `make-network-stream'. - (unless (fboundp 'open-protocol-stream) - (require 'proto-stream))) - (require 'nnheader) (require 'nnoo) (require 'gnus-util) @@ -244,8 +238,7 @@ server there that you can connect to. See also (defvoo nntp-connection-timeout nil "*Number of seconds to wait before an nntp connection times out. -If this variable is nil, which is the default, no timers are set. -NOTE: This variable is never seen to work in Emacs 20 and XEmacs 21.") +If this variable is nil, which is the default, no timers are set.") (defvoo nntp-prepare-post-hook nil "*Hook run just before posting an article. It is supposed to be used @@ -259,8 +252,10 @@ update their active files often, this can help.") ;;; Internal variables. (defvoo nntp-retrieval-in-progress nil) -(defvar nntp-record-commands nil - "*If non-nil, nntp will record all commands in the \"*nntp-log*\" buffer.") +(defcustom nntp-record-commands nil + "If non-nil, nntp will record all commands in the \"*nntp-log*\" buffer." + :group 'nntp + :type 'boolean) (defvar nntp-have-messaged nil) @@ -344,16 +339,14 @@ retried once before actually displaying the error report." (defmacro nntp-copy-to-buffer (buffer start end) "Copy string from unibyte current buffer to multibyte buffer." - (if (featurep 'xemacs) - `(copy-to-buffer ,buffer ,start ,end) - `(let ((string (buffer-substring ,start ,end))) - (with-current-buffer ,buffer - (erase-buffer) - (insert (if enable-multibyte-characters - (mm-string-to-multibyte string) - string)) - (goto-char (point-min)) - nil)))) + `(let ((string (buffer-substring ,start ,end))) + (with-current-buffer ,buffer + (erase-buffer) + (insert (if enable-multibyte-characters + (string-to-multibyte string) + string)) + (goto-char (point-min)) + nil))) (defsubst nntp-wait-for (process wait-for buffer &optional decode discard) "Wait for WAIT-FOR to arrive from PROCESS." @@ -1269,7 +1262,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the (nntp-open-ssl-stream tls) (nntp-open-tls-stream tls)))) (if (assoc nntp-open-connection-function map) - (open-protocol-stream + (open-network-stream "nntpd" pbuffer nntp-address nntp-port-number :type (cadr (assoc nntp-open-connection-function map)) :end-of-command "^\\([2345]\\|[.]\\).*\n" @@ -1301,13 +1294,11 @@ If SEND-IF-FORCE, only send authinfo to the server if the (nntp-kill-buffer pbuffer)) (when (and (buffer-name pbuffer) process) - (when (and (fboundp 'set-network-process-option) ;; Unavailable in XEmacs. - (fboundp 'process-type) ;; Emacs 22 doesn't provide it. - (eq (process-type process) 'network)) + (when (eq (process-type process) 'network) ;; Use TCP-keepalive so that connections that pass through a NAT router ;; don't hang when left idle. (set-network-process-option process :keepalive t)) - (gnus-set-process-query-on-exit-flag process nil) + (set-process-query-on-exit-flag process nil) (if (and (nntp-wait-for process "^2.*\n" buffer nil t) (memq (process-status process) '(open run))) (prog1 diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index 1b678eaf037..8e5b20047f4 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -103,10 +103,9 @@ Valid types include `google', `dejanews', and `gmane'.") (with-current-buffer nntp-server-buffer (erase-buffer) (let (article header) - (mm-with-unibyte-current-buffer - (while (setq article (pop articles)) - (when (setq header (cadr (assq article nnweb-articles))) - (nnheader-insert-nov header)))) + (while (setq article (pop articles)) + (when (setq header (cadr (assq article nnweb-articles))) + (nnheader-insert-nov header))) 'nov))) (deffoo nnweb-request-scan (&optional group server) @@ -153,8 +152,7 @@ Valid types include `google', `dejanews', and `gmane'.") (let* ((header (cadr (assq article nnweb-articles))) (url (and header (mail-header-xref header)))) (when (or (and url - (mm-with-unibyte-current-buffer - (mm-url-insert url))) + (mm-url-insert url)) (and (stringp article) (nnweb-definition 'id t) (let ((fetch (nnweb-definition 'id)) @@ -164,8 +162,7 @@ Valid types include `google', `dejanews', and `gmane'.") (when (and fetch art) (setq url (format fetch (mm-url-form-encode-xwfu art))) - (mm-with-unibyte-current-buffer - (mm-url-insert url)) + (mm-url-insert url) (if (nnweb-definition 'reference t) (setq article (funcall (nnweb-definition @@ -215,17 +212,16 @@ Valid types include `google', `dejanews', and `gmane'.") (defun nnweb-read-overview (group) "Read the overview of GROUP and build the map." (when (file-exists-p (nnweb-overview-file group)) - (mm-with-unibyte-buffer - (nnheader-insert-file-contents (nnweb-overview-file group)) - (goto-char (point-min)) - (let (header) - (while (not (eobp)) - (setq header (nnheader-parse-nov)) - (forward-line 1) - (push (list (mail-header-number header) - header (mail-header-xref header)) - nnweb-articles) - (nnweb-set-hashtb header (car nnweb-articles))))))) + (nnheader-insert-file-contents (nnweb-overview-file group)) + (goto-char (point-min)) + (let (header) + (while (not (eobp)) + (setq header (nnheader-parse-nov)) + (forward-line 1) + (push (list (mail-header-number header) + header (mail-header-xref header)) + nnweb-articles) + (nnweb-set-hashtb header (car nnweb-articles)))))) (defun nnweb-write-overview (group) "Write the overview file for GROUP." @@ -386,8 +382,7 @@ Valid types include `google', `dejanews', and `gmane'.") (setq nnweb-articles (nconc nnweb-articles map)) (when (setq header (cadar map)) - (mm-with-unibyte-current-buffer - (mm-url-insert (mail-header-xref header))) + (mm-url-insert (mail-header-xref header)) (caar map)))) (defun nnweb-google-create-mapping () @@ -513,8 +508,8 @@ Valid types include `google', `dejanews', and `gmane'.") ;;("TOPDOC" . "1000") )))) (setq buffer-file-name nil) - (unless (featurep 'xemacs) (set-buffer-multibyte t)) - (mm-decode-coding-region (point-min) (point-max) 'utf-8) + (set-buffer-multibyte t) + (decode-coding-region (point-min) (point-max) 'utf-8) t) (defun nnweb-gmane-identity (url) diff --git a/lisp/gnus/plstore.el b/lisp/gnus/plstore.el deleted file mode 100644 index e7232f730ba..00000000000 --- a/lisp/gnus/plstore.el +++ /dev/null @@ -1,582 +0,0 @@ -;;; plstore.el --- secure plist store -*- lexical-binding: t -*- -;; Copyright (C) 2011-2017 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Keywords: PGP, GnuPG - -;; 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 - -;; Plist based data store providing search and partial encryption. -;; -;; Creating: -;; -;; ;; Open a new store associated with ~/.emacs.d/auth.plist. -;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist"))) -;; ;; Both `:host' and `:port' are public property. -;; (plstore-put store "foo" '(:host "foo.example.org" :port 80) nil) -;; ;; No encryption will be needed. -;; (plstore-save store) -;; -;; ;; `:user' is marked as secret. -;; (plstore-put store "bar" '(:host "bar.example.org") '(:user "test")) -;; ;; `:password' is marked as secret. -;; (plstore-put store "baz" '(:host "baz.example.org") '(:password "test")) -;; ;; Those secret properties are encrypted together. -;; (plstore-save store) -;; -;; ;; Kill the buffer visiting ~/.emacs.d/auth.plist. -;; (plstore-close store) -;; -;; Searching: -;; -;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist"))) -;; -;; ;; As the entry "foo" associated with "foo.example.org" has no -;; ;; secret properties, no need to decryption. -;; (plstore-find store '(:host ("foo.example.org"))) -;; -;; ;; As the entry "bar" associated with "bar.example.org" has a -;; ;; secret property `:user', Emacs tries to decrypt the secret (and -;; ;; thus you will need to input passphrase). -;; (plstore-find store '(:host ("bar.example.org"))) -;; -;; ;; While the entry "baz" associated with "baz.example.org" has also -;; ;; a secret property `:password', it is encrypted together with -;; ;; `:user' of "bar", so no need to decrypt the secret. -;; (plstore-find store '(:host ("bar.example.org"))) -;; -;; (plstore-close store) -;; -;; Editing: -;; -;; This file also provides `plstore-mode', a major mode for editing -;; the PLSTORE format file. Visit a non-existing file and put the -;; following line: -;; -;; (("foo" :host "foo.example.org" :secret-user "user")) -;; -;; where the prefixing `:secret-' means the property (without -;; `:secret-' prefix) is marked as secret. Thus, when you save the -;; buffer, the `:secret-user' property is encrypted as `:user'. -;; -;; You can toggle the view between encrypted form and the decrypted -;; form with C-c C-c. - -;;; Code: - -(require 'epg) - -(defgroup plstore nil - "Searchable, partially encrypted, persistent plist store" - :version "24.1" - :group 'files) - -(defcustom plstore-select-keys 'silent - "Control whether or not to pop up the key selection dialog. - -If t, always asks user to select recipients. -If nil, query user only when a file's default recipients are not -known (i.e. `plstore-encrypt-to' is not locally set in the buffer -visiting a plstore file). -If neither t nor nil, doesn't ask user." - :type '(choice (const :tag "Ask always" t) - (const :tag "Ask when recipients are not set" nil) - (const :tag "Don't ask" silent)) - :group 'plstore) - -(defvar plstore-encrypt-to nil - "*Recipient(s) used for encrypting secret entries. -May either be a string or a list of strings. If it is nil, -symmetric encryption will be used.") - -(put 'plstore-encrypt-to 'safe-local-variable - (lambda (val) - (or (stringp val) - (and (listp val) - (catch 'safe - (mapc (lambda (elt) - (unless (stringp elt) - (throw 'safe nil))) - val) - t))))) - -(put 'plstore-encrypt-to 'permanent-local t) - -(defvar plstore-encoded nil) - -(put 'plstore-encoded 'permanent-local t) - -(defvar plstore-cache-passphrase-for-symmetric-encryption nil) -(defvar plstore-passphrase-alist nil) - -(defun plstore-passphrase-callback-function (_context _key-id plstore) - (if plstore-cache-passphrase-for-symmetric-encryption - (let* ((file (file-truename (plstore-get-file plstore))) - (entry (assoc file plstore-passphrase-alist)) - passphrase) - (or (copy-sequence (cdr entry)) - (progn - (unless entry - (setq entry (list file) - plstore-passphrase-alist - (cons entry - plstore-passphrase-alist))) - (setq passphrase - (read-passwd (format "Passphrase for PLSTORE %s: " - (plstore--get-buffer plstore)))) - (setcdr entry (copy-sequence passphrase)) - passphrase))) - (read-passwd (format "Passphrase for PLSTORE %s: " - (plstore--get-buffer plstore))))) - -(defun plstore-progress-callback-function (_context _what _char current total - handback) - (if (= current total) - (message "%s...done" handback) - (message "%s...%d%%" handback - (if (> total 0) (floor (* (/ current (float total)) 100)) 0)))) - -(defun plstore--get-buffer (arg) - (aref arg 0)) - -(defun plstore--get-alist (arg) - (aref arg 1)) - -(defun plstore--get-encrypted-data (arg) - (aref arg 2)) - -(defun plstore--get-secret-alist (arg) - (aref arg 3)) - -(defun plstore--get-merged-alist (arg) - (aref arg 4)) - -(defun plstore--set-buffer (arg buffer) - (aset arg 0 buffer)) - -(defun plstore--set-alist (arg plist) - (aset arg 1 plist)) - -(defun plstore--set-encrypted-data (arg encrypted-data) - (aset arg 2 encrypted-data)) - -(defun plstore--set-secret-alist (arg secret-alist) - (aset arg 3 secret-alist)) - -(defun plstore--set-merged-alist (arg merged-alist) - (aset arg 4 merged-alist)) - -(defun plstore-get-file (arg) - (buffer-file-name (plstore--get-buffer arg))) - -(defun plstore--make (&optional buffer alist encrypted-data secret-alist - merged-alist) - (vector buffer alist encrypted-data secret-alist merged-alist)) - -(defun plstore--init-from-buffer (plstore) - (goto-char (point-min)) - (when (looking-at ";;; public entries") - (forward-line) - (plstore--set-alist plstore (read (point-marker))) - (forward-sexp) - (forward-char) - (when (looking-at ";;; secret entries") - (forward-line) - (plstore--set-encrypted-data plstore (read (point-marker)))) - (plstore--merge-secret plstore))) - -;;;###autoload -(defun plstore-open (file) - "Create a plstore instance associated with FILE." - (let* ((filename (file-truename file)) - (buffer (or (find-buffer-visiting filename) - (generate-new-buffer (format " plstore %s" filename)))) - (store (plstore--make buffer))) - (with-current-buffer buffer - (erase-buffer) - (condition-case nil - (insert-file-contents-literally file) - (error)) - (setq buffer-file-name (file-truename file)) - (set-buffer-modified-p nil) - (plstore--init-from-buffer store) - store))) - -(defun plstore-revert (plstore) - "Replace current data in PLSTORE with the file on disk." - (with-current-buffer (plstore--get-buffer plstore) - (revert-buffer t t) - (plstore--init-from-buffer plstore))) - -(defun plstore-close (plstore) - "Destroy a plstore instance PLSTORE." - (kill-buffer (plstore--get-buffer plstore))) - -(defun plstore--merge-secret (plstore) - (let ((alist (plstore--get-secret-alist plstore)) - modified-alist - modified-plist - modified-entry - entry - plist - placeholder) - (plstore--set-merged-alist - plstore - (copy-tree (plstore--get-alist plstore))) - (setq modified-alist (plstore--get-merged-alist plstore)) - (while alist - (setq entry (car alist) - alist (cdr alist) - plist (cdr entry) - modified-entry (assoc (car entry) modified-alist) - modified-plist (cdr modified-entry)) - (while plist - (setq placeholder - (plist-member - modified-plist - (intern (concat ":secret-" - (substring (symbol-name (car plist)) 1))))) - (if placeholder - (setcar placeholder (car plist))) - (setq modified-plist - (plist-put modified-plist (car plist) (car (cdr plist)))) - (setq plist (nthcdr 2 plist))) - (setcdr modified-entry modified-plist)))) - -(defun plstore--decrypt (plstore) - (if (plstore--get-encrypted-data plstore) - (let ((context (epg-make-context 'OpenPGP)) - plain) - (epg-context-set-passphrase-callback - context - (cons #'plstore-passphrase-callback-function - plstore)) - (epg-context-set-progress-callback - context - (cons #'plstore-progress-callback-function - (format "Decrypting %s" (plstore-get-file plstore)))) - (condition-case error - (setq plain - (epg-decrypt-string context - (plstore--get-encrypted-data plstore))) - (error - (let ((entry (assoc (plstore-get-file plstore) - plstore-passphrase-alist))) - (if entry - (setcdr entry nil))) - (signal (car error) (cdr error)))) - (plstore--set-secret-alist plstore (car (read-from-string plain))) - (plstore--merge-secret plstore) - (plstore--set-encrypted-data plstore nil)))) - -(defun plstore--match (entry keys skip-if-secret-found) - (let ((result t) key-name key-value prop-value secret-name) - (while keys - (setq key-name (car keys) - key-value (car (cdr keys)) - prop-value (plist-get (cdr entry) key-name)) - (unless (member prop-value key-value) - (if skip-if-secret-found - (progn - (setq secret-name - (intern (concat ":secret-" - (substring (symbol-name key-name) 1)))) - (if (plist-member (cdr entry) secret-name) - (setq result 'secret) - (setq result nil - keys nil))) - (setq result nil - keys nil))) - (setq keys (nthcdr 2 keys))) - result)) - -(defun plstore-find (plstore keys) - "Perform search on PLSTORE with KEYS. -KEYS is a plist." - (let (entries alist entry match decrypt plist) - ;; First, go through the merged plist alist and collect entries - ;; matched with keys. - (setq alist (plstore--get-merged-alist plstore)) - (while alist - (setq entry (car alist) - alist (cdr alist) - match (plstore--match entry keys t)) - (if (eq match 'secret) - (setq decrypt t) - (when match - (setq plist (cdr entry)) - (while plist - (if (string-match "\\`:secret-" (symbol-name (car plist))) - (setq decrypt t - plist nil)) - (setq plist (nthcdr 2 plist))) - (setq entries (cons entry entries))))) - ;; Second, decrypt the encrypted plist and try again. - (when decrypt - (setq entries nil) - (plstore--decrypt plstore) - (setq alist (plstore--get-merged-alist plstore)) - (while alist - (setq entry (car alist) - alist (cdr alist) - match (plstore--match entry keys nil)) - (if match - (setq entries (cons entry entries))))) - (nreverse entries))) - -(defun plstore-get (plstore name) - "Get an entry with NAME in PLSTORE." - (let ((entry (assoc name (plstore--get-merged-alist plstore))) - plist) - (setq plist (cdr entry)) - (while plist - (if (string-match "\\`:secret-" (symbol-name (car plist))) - (progn - (plstore--decrypt plstore) - (setq entry (assoc name (plstore--get-merged-alist plstore)) - plist nil)) - (setq plist (nthcdr 2 plist)))) - entry)) - -(defun plstore-put (plstore name keys secret-keys) - "Put an entry with NAME in PLSTORE. -KEYS is a plist containing non-secret data. -SECRET-KEYS is a plist containing secret data." - (let (entry - plist - secret-plist - symbol) - (if secret-keys - (plstore--decrypt plstore)) - (while secret-keys - (setq symbol - (intern (concat ":secret-" - (substring (symbol-name (car secret-keys)) 1)))) - (setq plist (plist-put plist symbol t) - secret-plist (plist-put secret-plist - (car secret-keys) (car (cdr secret-keys))) - secret-keys (nthcdr 2 secret-keys))) - (while keys - (setq symbol - (intern (concat ":secret-" - (substring (symbol-name (car keys)) 1)))) - (setq plist (plist-put plist (car keys) (car (cdr keys))) - keys (nthcdr 2 keys))) - (setq entry (assoc name (plstore--get-alist plstore))) - (if entry - (setcdr entry plist) - (plstore--set-alist - plstore - (cons (cons name plist) (plstore--get-alist plstore)))) - (when secret-plist - (setq entry (assoc name (plstore--get-secret-alist plstore))) - (if entry - (setcdr entry secret-plist) - (plstore--set-secret-alist - plstore - (cons (cons name secret-plist) (plstore--get-secret-alist plstore))))) - (plstore--merge-secret plstore))) - -(defun plstore-delete (plstore name) - "Delete an entry with NAME from PLSTORE." - (let ((entry (assoc name (plstore--get-alist plstore)))) - (if entry - (plstore--set-alist - plstore - (delq entry (plstore--get-alist plstore)))) - (setq entry (assoc name (plstore--get-secret-alist plstore))) - (if entry - (plstore--set-secret-alist - plstore - (delq entry (plstore--get-secret-alist plstore)))) - (setq entry (assoc name (plstore--get-merged-alist plstore))) - (if entry - (plstore--set-merged-alist - plstore - (delq entry (plstore--get-merged-alist plstore)))))) - -(defvar pp-escape-newlines) -(defun plstore--insert-buffer (plstore) - (insert ";;; public entries -*- mode: plstore -*- \n" - (pp-to-string (plstore--get-alist plstore))) - (if (plstore--get-secret-alist plstore) - (let ((context (epg-make-context 'OpenPGP)) - (pp-escape-newlines nil) - (recipients - (cond - ((listp plstore-encrypt-to) plstore-encrypt-to) - ((stringp plstore-encrypt-to) (list plstore-encrypt-to)))) - cipher) - (epg-context-set-armor context t) - (epg-context-set-passphrase-callback - context - (cons #'plstore-passphrase-callback-function - plstore)) - (setq cipher (epg-encrypt-string - context - (pp-to-string - (plstore--get-secret-alist plstore)) - (if (or (eq plstore-select-keys t) - (and (null plstore-select-keys) - (not (local-variable-p 'plstore-encrypt-to - (current-buffer))))) - (epa-select-keys - context - "Select recipients for encryption. -If no one is selected, symmetric encryption will be performed. " - recipients) - (if plstore-encrypt-to - (epg-list-keys context recipients))))) - (goto-char (point-max)) - (insert ";;; secret entries\n" (pp-to-string cipher))))) - -(defun plstore-save (plstore) - "Save the contents of PLSTORE associated with a FILE." - (with-current-buffer (plstore--get-buffer plstore) - (erase-buffer) - (plstore--insert-buffer plstore) - (save-buffer))) - -(defun plstore--encode (plstore) - (plstore--decrypt plstore) - (let ((merged-alist (plstore--get-merged-alist plstore))) - (concat "(" - (mapconcat - (lambda (entry) - (setq entry (copy-sequence entry)) - (let ((merged-plist (cdr (assoc (car entry) merged-alist))) - (plist (cdr entry))) - (while plist - (if (string-match "\\`:secret-" (symbol-name (car plist))) - (setcar (cdr plist) - (plist-get - merged-plist - (intern (concat ":" - (substring (symbol-name - (car plist)) - (match-end 0))))))) - (setq plist (nthcdr 2 plist))) - (prin1-to-string entry))) - (plstore--get-alist plstore) - "\n") - ")"))) - -(defun plstore--decode (string) - (let* ((alist (car (read-from-string string))) - (pointer alist) - secret-alist - plist - entry) - (while pointer - (unless (stringp (car (car pointer))) - (error "Invalid PLSTORE format %s" string)) - (setq plist (cdr (car pointer))) - (while plist - (when (string-match "\\`:secret-" (symbol-name (car plist))) - (setq entry (assoc (car (car pointer)) secret-alist)) - (unless entry - (setq entry (list (car (car pointer))) - secret-alist (cons entry secret-alist))) - (setcdr entry (plist-put (cdr entry) - (intern (concat ":" - (substring (symbol-name - (car plist)) - (match-end 0)))) - (car (cdr plist)))) - (setcar (cdr plist) t)) - (setq plist (nthcdr 2 plist))) - (setq pointer (cdr pointer))) - (plstore--make nil alist nil secret-alist))) - -(defun plstore--write-contents-functions () - (when plstore-encoded - (let ((store (plstore--decode (buffer-string))) - (file (buffer-file-name))) - (unwind-protect - (progn - (set-visited-file-name nil) - (with-temp-buffer - (plstore--insert-buffer store) - (write-region (buffer-string) nil file))) - (set-visited-file-name file) - (set-buffer-modified-p nil)) - t))) - -(defun plstore-mode-original () - "Show the original form of the this buffer." - (interactive) - (when plstore-encoded - (if (and (buffer-modified-p) - (y-or-n-p "Save buffer before reading the original form? ")) - (save-buffer)) - (erase-buffer) - (insert-file-contents-literally (buffer-file-name)) - (set-buffer-modified-p nil) - (setq plstore-encoded nil))) - -(defun plstore-mode-decoded () - "Show the decoded form of the this buffer." - (interactive) - (unless plstore-encoded - (if (and (buffer-modified-p) - (y-or-n-p "Save buffer before decoding? ")) - (save-buffer)) - (let ((store (plstore--make (current-buffer)))) - (plstore--init-from-buffer store) - (erase-buffer) - (insert - (substitute-command-keys "\ -;;; You are looking at the decoded form of the PLSTORE file.\n\ -;;; To see the original form content, do \\[plstore-mode-toggle-display]\n\n")) - (insert (plstore--encode store)) - (set-buffer-modified-p nil) - (setq plstore-encoded t)))) - -(defun plstore-mode-toggle-display () - "Toggle the display mode of PLSTORE between the original and decoded forms." - (interactive) - (if plstore-encoded - (plstore-mode-original) - (plstore-mode-decoded))) - -(eval-when-compile - (defmacro plstore-called-interactively-p (kind) - (condition-case nil - (progn - (eval '(called-interactively-p 'any)) - ;; Emacs >=23.2 - `(called-interactively-p ,kind)) - ;; Emacs <23.2 - (wrong-number-of-arguments '(called-interactively-p)) - ;; XEmacs - (void-function '(interactive-p))))) - -;;;###autoload -(define-derived-mode plstore-mode emacs-lisp-mode "PLSTORE" - "Major mode for editing PLSTORE files." - (make-local-variable 'plstore-encoded) - (add-hook 'write-contents-functions #'plstore--write-contents-functions) - (define-key plstore-mode-map "\C-c\C-c" #'plstore-mode-toggle-display) - ;; to create a new file with plstore-mode, mark it as already decoded - (if (plstore-called-interactively-p 'any) - (setq plstore-encoded t) - (plstore-mode-decoded))) - -(provide 'plstore) - -;;; plstore.el ends here diff --git a/lisp/gnus/pop3.el b/lisp/gnus/pop3.el deleted file mode 100644 index f2a22acb04b..00000000000 --- a/lisp/gnus/pop3.el +++ /dev/null @@ -1,929 +0,0 @@ -;;; pop3.el --- Post Office Protocol (RFC 1460) interface - -;; Copyright (C) 1996-2017 Free Software Foundation, Inc. - -;; Author: Richard L. Pieri <ratinox@peorth.gweep.net> -;; Maintainer: emacs-devel@gnu.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: - -;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands -;; are implemented. The LIST command has not been implemented due to lack -;; of actual usefulness. -;; The optional POP3 command TOP has not been implemented. - -;; This program was inspired by Kyle E. Jones's vm-pop program. - -;;; Code: - -(eval-when-compile (require 'cl)) - -(eval-and-compile - ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for - ;; `make-network-stream'. - (unless (fboundp 'open-protocol-stream) - (require 'proto-stream))) - -(require 'mail-utils) -(defvar parse-time-months) - -(defgroup pop3 nil - "Post Office Protocol." - :group 'mail - :group 'mail-source) - -(defcustom pop3-maildrop (or (user-login-name) - (getenv "LOGNAME") - (getenv "USER")) - "*POP3 maildrop." - :version "22.1" ;; Oort Gnus - :type 'string - :group 'pop3) - -(defcustom pop3-mailhost (or (getenv "MAILHOST") ;; nil -> mismatch - "pop3") - "*POP3 mailhost." - :version "22.1" ;; Oort Gnus - :type 'string - :group 'pop3) - -(defcustom pop3-port 110 - "*POP3 port." - :version "22.1" ;; Oort Gnus - :type 'number - :group 'pop3) - -(defcustom pop3-password-required t - "*Non-nil if a password is required when connecting to POP server." - :version "22.1" ;; Oort Gnus - :type 'boolean - :group 'pop3) - -;; Should this be customizable? -(defvar pop3-password nil - "*Password to use when connecting to POP server.") - -(defcustom pop3-authentication-scheme 'pass - "*POP3 authentication scheme. -Defaults to `pass', for the standard USER/PASS authentication. The other -valid value is `apop'." - :type '(choice (const :tag "Normal user/password" pass) - (const :tag "APOP" apop)) - :version "22.1" ;; Oort Gnus - :group 'pop3) - -(defcustom pop3-stream-length 100 - "How many messages should be requested at one time. -The lower the number, the more latency-sensitive the fetching -will be. If your pop3 server doesn't support streaming at all, -set this to 1." - :type 'number - :version "24.1" - :group 'pop3) - -(defcustom pop3-leave-mail-on-server nil - "Non-nil if the mail is to be left on the POP server after fetching. -Mails once fetched will never be fetched again by the UIDL control. - -If this is neither nil nor a number, all mails will be left on the -server. If this is a number, leave mails on the server for this many -days since you first checked new mails. If this is nil, mails will be -deleted on the server right after fetching. - -Gnus users should use the `:leave' keyword in a mail source to direct -the behavior per server, rather than directly modifying this value. - -Note that POP servers maintain no state information between sessions, -so what the client believes is there and what is actually there may -not match up. If they do not, then you may get duplicate mails or -the whole thing can fall apart and leave you with a corrupt mailbox." - :version "24.4" - :type '(choice (const :tag "Don't leave mails" nil) - (const :tag "Leave all mails" t) - (number :tag "Leave mails for this many days" :value 14)) - :group 'pop3) - -(defcustom pop3-uidl-file "~/.pop3-uidl" - "File used to save UIDL." - :version "24.4" - :type 'file - :group 'pop3) - -(defcustom pop3-uidl-file-backup '(0 9) - "How to backup the UIDL file `pop3-uidl-file' when updating. -If it is a list of numbers, the first one binds `kept-old-versions' and -the other binds `kept-new-versions' to keep number of oldest and newest -versions. Otherwise, the value binds `version-control' (which see). - -Note: Backup will take place whenever you check new mails on a server. -So, you may lose the backup files having been saved before a trouble -if you set it so as to make too few backups whereas you have access to -many servers." - :version "24.4" - :type '(choice (group :tag "Keep versions" :format "\n%v" :indent 3 - (number :tag "oldest") - (number :tag "newest")) - (sexp :format "%v" - :match (lambda (widget value) - (condition-case nil - (not (and (numberp (car value)) - (numberp (car (cdr value))))) - (error t))))) - :group 'pop3) - -(defvar pop3-timestamp nil - "Timestamp returned when initially connected to the POP server. -Used for APOP authentication.") - -(defvar pop3-read-point nil) -(defvar pop3-debug nil) - -;; Borrowed from nnheader-accept-process-output in nnheader.el. See the -;; comments there for explanations about the values. - -(eval-and-compile - (if (and (fboundp 'nnheader-accept-process-output) - (boundp 'nnheader-read-timeout)) - (defalias 'pop3-accept-process-output 'nnheader-accept-process-output) - ;; Borrowed from `nnheader.el': - (defvar pop3-read-timeout - (if (string-match "windows-nt\\|os/2\\|cygwin" - (symbol-name system-type)) - 1.0 - 0.01) - "How long pop3 should wait between checking for the end of output. -Shorter values mean quicker response, but are more CPU intensive.") - (defun pop3-accept-process-output (process) - (accept-process-output - process - (truncate pop3-read-timeout) - (truncate (* (- pop3-read-timeout - (truncate pop3-read-timeout)) - 1000)))))) - -(defvar pop3-uidl) -;; List of UIDLs of existing messages at present in the server: -;; ("UIDL1" "UIDL2" "UIDL3"...) - -(defvar pop3-uidl-saved) -;; Locally saved UIDL data; an alist of the server, the user, and the UIDL -;; and timestamp pairs: -;; (("SERVER_A" ("USER_A1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) -;; ("USER_A2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) -;; ...) -;; ("SERVER_B" ("USER_B1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) -;; ("USER_B2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) -;; ...)) -;; Where TIMESTAMP is the most significant two digits of an Emacs time, -;; i.e. the return value of `current-time'. - -;;;###autoload -(defun pop3-movemail (file) - "Transfer contents of a maildrop to the specified FILE. -Use streaming commands." - (let ((process (pop3-open-server pop3-mailhost pop3-port)) - messages total-size - pop3-uidl - pop3-uidl-saved) - (pop3-logon process) - (if pop3-leave-mail-on-server - (setq messages (pop3-uidl-stat process) - total-size (cadr messages) - messages (car messages)) - (let ((size (pop3-stat process))) - (dotimes (i (car size)) (push (1+ i) messages)) - (setq messages (nreverse messages) - total-size (cadr size)))) - (when messages - (with-current-buffer (process-buffer process) - (pop3-send-streaming-command process "RETR" messages total-size) - (pop3-write-to-file file messages) - (unless pop3-leave-mail-on-server - (pop3-send-streaming-command process "DELE" messages nil)))) - (if pop3-leave-mail-on-server - (when (prog1 (pop3-uidl-dele process) (pop3-quit process)) - (pop3-uidl-save)) - (pop3-quit process) - ;; Remove UIDL data for the account that got not to leave mails. - (setq pop3-uidl-saved (pop3-uidl-load)) - (let ((elt (assoc pop3-maildrop - (cdr (assoc pop3-mailhost pop3-uidl-saved))))) - (when elt - (setcdr elt nil) - (pop3-uidl-save)))) - t)) - -(defun pop3-send-streaming-command (process command messages total-size) - (erase-buffer) - (let ((count (length messages)) - (i 1) - (start-point (point-min)) - (waited-for 0)) - (while messages - (process-send-string process (format "%s %d\r\n" command (pop messages))) - ;; Only do 100 messages at a time to avoid pipe stalls. - (when (zerop (% i pop3-stream-length)) - (setq start-point - (pop3-wait-for-messages process pop3-stream-length - total-size start-point)) - (incf waited-for pop3-stream-length)) - (incf i)) - (pop3-wait-for-messages process (- count waited-for) - total-size start-point))) - -(defun pop3-wait-for-messages (process count total-size start-point) - (while (> count 0) - (goto-char start-point) - (while (or (and (re-search-forward "^\\+OK" nil t) - (or (not total-size) - (re-search-forward "^\\.\r?\n" nil t))) - (re-search-forward "^-ERR " nil t)) - (decf count) - (setq start-point (point))) - (unless (memq (process-status process) '(open run)) - (error "pop3 process died")) - (when total-size - (let ((size 0)) - (goto-char (point-min)) - (while (re-search-forward "^\\+OK.*\n" nil t) - (setq size (+ size (- (point)) - (if (re-search-forward "^\\.\r?\n" nil 'move) - (match-beginning 0) - (point))))) - (message "pop3 retrieved %dKB (%d%%)" - (truncate (/ size 1000)) - (truncate (* (/ (* size 1.0) total-size) 100))))) - (pop3-accept-process-output process)) - start-point) - -(defun pop3-write-to-file (file messages) - (let ((pop-buffer (current-buffer)) - (start (point-min)) - beg end - temp-buffer) - (with-temp-buffer - (setq temp-buffer (current-buffer)) - (with-current-buffer pop-buffer - (goto-char (point-min)) - (while (re-search-forward "^\\+OK" nil t) - (forward-line 1) - (setq beg (point)) - (when (re-search-forward "^\\.\r?\n" nil t) - (setq start (point)) - (forward-line -1) - (setq end (point))) - (with-current-buffer temp-buffer - (goto-char (point-max)) - (let ((hstart (point))) - (insert-buffer-substring pop-buffer beg end) - (pop3-clean-region hstart (point)) - (goto-char (point-max)) - (pop3-munge-message-separator hstart (point)) - (when pop3-leave-mail-on-server - (pop3-uidl-add-xheader hstart (pop messages))) - (goto-char (point-max)))))) - (let ((coding-system-for-write 'binary)) - (goto-char (point-min)) - ;; Check whether something inserted a newline at the start and - ;; delete it. - (when (eolp) - (delete-char 1)) - (write-region (point-min) (point-max) file nil 'nomesg))))) - -(defun pop3-logon (process) - (let ((pop3-password pop3-password)) - ;; for debugging only - (if pop3-debug (switch-to-buffer (process-buffer process))) - ;; query for password - (if (and pop3-password-required (not pop3-password)) - (setq pop3-password - (read-passwd (format "Password for %s: " pop3-maildrop)))) - (cond ((equal 'apop pop3-authentication-scheme) - (pop3-apop process pop3-maildrop)) - ((equal 'pass pop3-authentication-scheme) - (pop3-user process pop3-maildrop) - (pop3-pass process)) - (t (error "Invalid POP3 authentication scheme"))))) - -(defun pop3-get-message-count () - "Return the number of messages in the maildrop." - (let* ((process (pop3-open-server pop3-mailhost pop3-port)) - message-count - (pop3-password pop3-password)) - ;; for debugging only - (if pop3-debug (switch-to-buffer (process-buffer process))) - ;; query for password - (if (and pop3-password-required (not pop3-password)) - (setq pop3-password - (read-passwd (format "Password for %s: " pop3-maildrop)))) - (cond ((equal 'apop pop3-authentication-scheme) - (pop3-apop process pop3-maildrop)) - ((equal 'pass pop3-authentication-scheme) - (pop3-user process pop3-maildrop) - (pop3-pass process)) - (t (error "Invalid POP3 authentication scheme"))) - (setq message-count (car (pop3-stat process))) - (pop3-quit process) - message-count)) - -(defun pop3-uidl-stat (process) - "Return a list of unread message numbers and total size." - (pop3-send-command process "UIDL") - (let (err messages size) - (if (condition-case code - (progn - (pop3-read-response process) - t) - (error (setq err (error-message-string code)) - nil)) - (let ((start pop3-read-point) - saved list) - (with-current-buffer (process-buffer process) - (while (not (re-search-forward "^\\.\r\n" nil t)) - (unless (memq (process-status process) '(open run)) - (error "pop3 server closed the connection")) - (pop3-accept-process-output process) - (goto-char start)) - (setq pop3-read-point (point-marker) - pop3-uidl nil) - (while (progn (forward-line -1) (>= (point) start)) - (when (looking-at "[0-9]+ \\([^\n\r ]+\\)") - (push (match-string 1) pop3-uidl))) - (when pop3-uidl - (setq pop3-uidl-saved (pop3-uidl-load) - saved (cdr (assoc pop3-maildrop - (cdr (assoc pop3-mailhost - pop3-uidl-saved))))) - (let ((i (length pop3-uidl))) - (while (> i 0) - (unless (member (nth (1- i) pop3-uidl) saved) - (push i messages)) - (decf i))) - (when messages - (setq list (pop3-list process) - size 0) - (dolist (msg messages) - (setq size (+ size (cdr (assq msg list))))) - (list messages size))))) - (message "%s doesn't support UIDL (%s), so we try a regressive way..." - pop3-mailhost err) - (sit-for 1) - (setq size (pop3-stat process)) - (dotimes (i (car size)) (push (1+ i) messages)) - (setcar size (nreverse messages)) - size))) - -(defun pop3-uidl-dele (process) - "Delete messages according to `pop3-leave-mail-on-server'. -Return non-nil if it is necessary to update the local UIDL file." - (let* ((ctime (current-time)) - (srvr (assoc pop3-mailhost pop3-uidl-saved)) - (saved (assoc pop3-maildrop (cdr srvr))) - i uidl mod new tstamp dele) - (setcdr (cdr ctime) nil) - ;; Add new messages to the data to be saved. - (cond ((and pop3-uidl saved) - (setq i (1- (length pop3-uidl))) - (while (>= i 0) - (unless (member (setq uidl (nth i pop3-uidl)) (cdr saved)) - (push ctime new) - (push uidl new)) - (decf i))) - (pop3-uidl - (setq new (apply 'nconc (mapcar (lambda (elt) (list elt ctime)) - pop3-uidl))))) - (when new (setq mod t)) - ;; List expirable messages and delete them from the data to be saved. - (setq ctime (when (numberp pop3-leave-mail-on-server) - (/ (+ (* (car ctime) 65536.0) (cadr ctime)) 86400)) - i (1- (length saved))) - (while (> i 0) - (if (member (setq uidl (nth (1- i) saved)) pop3-uidl) - (progn - (setq tstamp (nth i saved)) - (if (and ctime - (> (- ctime (/ (+ (* (car tstamp) 65536.0) (cadr tstamp)) - 86400)) - pop3-leave-mail-on-server)) - ;; Mails to delete. - (progn - (setq mod t) - (push uidl dele)) - ;; Mails to keep. - (push tstamp new) - (push uidl new))) - ;; Mails having been deleted in the server. - (setq mod t)) - (decf i 2)) - (cond (saved - (setcdr saved new)) - (srvr - (setcdr (last srvr) (list (cons pop3-maildrop new)))) - (t - (add-to-list 'pop3-uidl-saved - (list pop3-mailhost (cons pop3-maildrop new)) - t))) - ;; Actually delete the messages in the server. - (when dele - (setq uidl nil - i (length pop3-uidl)) - (while (> i 0) - (when (member (nth (1- i) pop3-uidl) dele) - (push i uidl)) - (decf i)) - (when uidl - (pop3-send-streaming-command process "DELE" uidl nil))) - mod)) - -(defun pop3-uidl-load () - "Load saved UIDL." - (when (file-exists-p pop3-uidl-file) - (with-temp-buffer - (condition-case code - (progn - (insert-file-contents pop3-uidl-file) - (goto-char (point-min)) - (read (current-buffer))) - (error - (message "Error while loading %s (%s)" - pop3-uidl-file (error-message-string code)) - (sit-for 1) - nil))))) - -(defun pop3-uidl-save () - "Save UIDL." - (with-temp-buffer - (if pop3-uidl-saved - (progn - (insert "(") - (dolist (srvr pop3-uidl-saved) - (when (cdr srvr) - (insert "(\"" (pop srvr) "\"\n ") - (dolist (elt srvr) - (when (cdr elt) - (insert "(\"" (pop elt) "\"\n ") - (while elt - (insert (format "\"%s\" %s\n " (pop elt) (pop elt)))) - (delete-char -4) - (insert ")\n "))) - (delete-char -3) - (if (eq (char-before) ?\)) - (insert ")\n ") - (goto-char (1+ (point-at-bol))) - (delete-region (point) (point-max))))) - (when (eq (char-before) ? ) - (delete-char -2)) - (insert ")\n")) - (insert "()\n")) - (let ((buffer-file-name pop3-uidl-file) - (delete-old-versions t) - (kept-new-versions kept-new-versions) - (kept-old-versions kept-old-versions) - (version-control version-control)) - (if (consp pop3-uidl-file-backup) - (setq kept-new-versions (cadr pop3-uidl-file-backup) - kept-old-versions (car pop3-uidl-file-backup) - version-control t) - (setq version-control pop3-uidl-file-backup)) - (save-buffer)))) - -(defun pop3-uidl-add-xheader (start msgno) - "Add X-UIDL header." - (let ((case-fold-search t)) - (save-restriction - (narrow-to-region start (progn - (goto-char start) - (search-forward "\n\n" nil 'move) - (1- (point)))) - (goto-char start) - (while (re-search-forward "^x-uidl:" nil t) - (while (progn - (forward-line 1) - (memq (char-after) '(?\t ? )))) - (delete-region (match-beginning 0) (point))) - (goto-char (point-max)) - (insert "X-UIDL: " (nth (1- msgno) pop3-uidl) "\n")))) - -(defcustom pop3-stream-type nil - "*Transport security type for POP3 connections. -This may be either nil (plain connection), `ssl' (use an -SSL/TSL-secured stream) or `starttls' (use the starttls mechanism -to turn on TLS security after opening the stream). However, if -this is nil, `ssl' is assumed for connections to port -995 (pop3s)." - :version "23.1" ;; No Gnus - :group 'pop3 - :type '(choice (const :tag "Plain" nil) - (const :tag "SSL/TLS" ssl) - (const starttls))) - -(eval-and-compile - (if (fboundp 'set-process-query-on-exit-flag) - (defalias 'pop3-set-process-query-on-exit-flag - 'set-process-query-on-exit-flag) - (defalias 'pop3-set-process-query-on-exit-flag - 'process-kill-without-query))) - -(defun pop3-open-server (mailhost port) - "Open TCP connection to MAILHOST on PORT. -Returns the process associated with the connection." - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary) - result) - (with-current-buffer - (get-buffer-create (concat " trace of POP session to " - mailhost)) - (erase-buffer) - (setq pop3-read-point (point-min)) - (setq result - (open-protocol-stream - "POP" (current-buffer) mailhost port - :type (cond - ((or (eq pop3-stream-type 'ssl) - (and (not pop3-stream-type) - (member port '(995 "pop3s")))) - 'tls) - (t - (or pop3-stream-type 'network))) - :warn-unless-encrypted t - :capability-command "CAPA\r\n" - :end-of-command "^\\(-ERR\\|+OK\\).*\n" - :end-of-capability "^\\.\r?\n\\|^-ERR" - :success "^\\+OK.*\n" - :return-list t - :starttls-function - (lambda (capabilities) - (and (string-match "\\bSTLS\\b" capabilities) - "STLS\r\n")))) - (when result - (let ((response (plist-get (cdr result) :greeting))) - (setq pop3-timestamp - (substring response (or (string-match "<" response) 0) - (+ 1 (or (string-match ">" response) -1))))) - (pop3-set-process-query-on-exit-flag (car result) nil) - (erase-buffer) - (car result))))) - -;; Support functions - -(defun pop3-send-command (process command) - (set-buffer (process-buffer process)) - (goto-char (point-max)) - ;; (if (= (aref command 0) ?P) - ;; (insert "PASS <omitted>\r\n") - ;; (insert command "\r\n")) - (setq pop3-read-point (point)) - (goto-char (point-max)) - (process-send-string process (concat command "\r\n"))) - -(defun pop3-read-response (process &optional return) - "Read the response from the server. -Return the response string if optional second argument is non-nil." - (let ((case-fold-search nil) - match-end) - (with-current-buffer (process-buffer process) - (goto-char pop3-read-point) - (while (and (memq (process-status process) '(open run)) - (not (search-forward "\r\n" nil t))) - (pop3-accept-process-output process) - (goto-char pop3-read-point)) - (setq match-end (point)) - (goto-char pop3-read-point) - (if (looking-at "-ERR") - (error "%s" (buffer-substring (point) (- match-end 2))) - (if (not (looking-at "+OK")) - (progn (setq pop3-read-point match-end) nil) - (setq pop3-read-point match-end) - (if return - (buffer-substring (point) match-end) - t) - ))))) - -(defun pop3-clean-region (start end) - (setq end (set-marker (make-marker) end)) - (save-excursion - (goto-char start) - (while (and (< (point) end) (search-forward "\r\n" end t)) - (replace-match "\n" t t)) - (goto-char start) - (while (and (< (point) end) (re-search-forward "^\\." end t)) - (replace-match "" t t) - (forward-char))) - (set-marker end nil)) - -;; Copied from message-make-date. -(defun pop3-make-date (&optional now) - "Make a valid date header. -If NOW, use that time instead." - (require 'parse-time) - (let* ((now (or now (current-time))) - (zone (nth 8 (decode-time now))) - (sign "+")) - (when (< zone 0) - (setq sign "-") - (setq zone (- zone))) - (concat - (format-time-string "%d" now) - ;; The month name of the %b spec is locale-specific. Pfff. - (format " %s " - (capitalize (car (rassoc (nth 4 (decode-time now)) - parse-time-months)))) - (format-time-string "%Y %H:%M:%S " now) - ;; We do all of this because XEmacs doesn't have the %z spec. - (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60))))) - -(defun pop3-munge-message-separator (start end) - "Check to see if a message separator exists. If not, generate one." - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (if (not (or (looking-at "From .?") ; Unix mail - (looking-at "\001\001\001\001\n") ; MMDF - (looking-at "BABYL OPTIONS:") ; Babyl - )) - (let* ((from (mail-strip-quoted-names (mail-fetch-field "From"))) - (tdate (mail-fetch-field "Date")) - (date (split-string (or (and tdate - (not (string= "" tdate)) - tdate) - (pop3-make-date)) - " ")) - (From_)) - ;; sample date formats I have seen - ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT) - ;; Date: 08 Jul 1996 23:22:24 -0400 - ;; should be - ;; Tue Jul 9 09:04:21 1996 - - ;; Fixme: This should use timezone on the date field contents. - (setq date - (cond ((not date) - "Tue Jan 1 00:00:0 1900") - ((string-match "[A-Z]" (nth 0 date)) - (format "%s %s %s %s %s" - (nth 0 date) (nth 2 date) (nth 1 date) - (nth 4 date) (nth 3 date))) - (t - ;; this really needs to be better but I don't feel - ;; like writing a date to day converter. - (format "Sun %s %s %s %s" - (nth 1 date) (nth 0 date) - (nth 3 date) (nth 2 date))) - )) - (setq From_ (format "\nFrom %s %s\n" from date)) - (while (string-match "," From_) - (setq From_ (concat (substring From_ 0 (match-beginning 0)) - (substring From_ (match-end 0))))) - (goto-char (point-min)) - (insert From_) - (if (search-forward "\n\n" nil t) - nil - (goto-char (point-max)) - (insert "\n")) - (let ((size (- (point-max) (point)))) - (forward-line -1) - (insert (format "Content-Length: %s\n" size))) - ))))) - -;; The Command Set - -;; AUTHORIZATION STATE - -(defun pop3-user (process user) - "Send USER information to POP3 server." - (pop3-send-command process (format "USER %s" user)) - (let ((response (pop3-read-response process t))) - (if (not (and response (string-match "+OK" response))) - (error "USER %s not valid" user)))) - -(defun pop3-pass (process) - "Send authentication information to the server." - (pop3-send-command process (format "PASS %s" pop3-password)) - (let ((response (pop3-read-response process t))) - (if (not (and response (string-match "+OK" response))) - (pop3-quit process)))) - -(defun pop3-apop (process user) - "Send alternate authentication information to the server." - (let ((pass pop3-password)) - (if (and pop3-password-required (not pass)) - (setq pass - (read-passwd (format "Password for %s: " pop3-maildrop)))) - (if pass - (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary))) - (pop3-send-command process (format "APOP %s %s" user hash)) - (let ((response (pop3-read-response process t))) - (if (not (and response (string-match "+OK" response))) - (pop3-quit process))))) - )) - -;; TRANSACTION STATE - -(defun pop3-stat (process) - "Return the number of messages in the maildrop and the maildrop's size." - (pop3-send-command process "STAT") - (let ((response (pop3-read-response process t))) - (list (string-to-number (nth 1 (split-string response " "))) - (string-to-number (nth 2 (split-string response " ")))) - )) - -(defun pop3-list (process &optional msg) - "If MSG is nil, return an alist of (MESSAGE-ID . SIZE) pairs. -Otherwise, return the size of the message-id MSG" - (pop3-send-command process (if msg - (format "LIST %d" msg) - "LIST")) - (let ((response (pop3-read-response process t))) - (if msg - (string-to-number (nth 2 (split-string response " "))) - (let ((start pop3-read-point) end) - (with-current-buffer (process-buffer process) - (while (not (re-search-forward "^\\.\r\n" nil t)) - (pop3-accept-process-output process) - (goto-char start)) - (setq pop3-read-point (point-marker)) - (goto-char (match-beginning 0)) - (setq end (point-marker)) - (mapcar #'(lambda (s) (let ((split (split-string s " "))) - (cons (string-to-number (nth 0 split)) - (string-to-number (nth 1 split))))) - (split-string (buffer-substring start end) "\r\n" t))))))) - -(defun pop3-retr (process msg crashbuf) - "Retrieve message-id MSG to buffer CRASHBUF." - (pop3-send-command process (format "RETR %s" msg)) - (pop3-read-response process) - (let ((start pop3-read-point) end) - (with-current-buffer (process-buffer process) - (while (not (re-search-forward "^\\.\r\n" nil t)) - (unless (memq (process-status process) '(open run)) - (error "pop3 server closed the connection")) - (pop3-accept-process-output process) - (goto-char start)) - (setq pop3-read-point (point-marker)) - ;; this code does not seem to work for some POP servers... - ;; and I cannot figure out why not. - ;; (goto-char (match-beginning 0)) - ;; (backward-char 2) - ;; (if (not (looking-at "\r\n")) - ;; (insert "\r\n")) - ;; (re-search-forward "\\.\r\n") - (goto-char (match-beginning 0)) - (setq end (point-marker)) - (pop3-clean-region start end) - (pop3-munge-message-separator start end) - (with-current-buffer crashbuf - (erase-buffer)) - (copy-to-buffer crashbuf start end) - (delete-region start end) - ))) - -(defun pop3-dele (process msg) - "Mark message-id MSG as deleted." - (pop3-send-command process (format "DELE %s" msg)) - (pop3-read-response process)) - -(defun pop3-noop (process msg) - "No-operation." - (pop3-send-command process "NOOP") - (pop3-read-response process)) - -(defun pop3-last (process) - "Return highest accessed message-id number for the session." - (pop3-send-command process "LAST") - (let ((response (pop3-read-response process t))) - (string-to-number (nth 1 (split-string response " "))) - )) - -(defun pop3-rset (process) - "Remove all delete marks from current maildrop." - (pop3-send-command process "RSET") - (pop3-read-response process)) - -;; UPDATE - -(defun pop3-quit (process) - "Close connection to POP3 server. -Tell server to remove all messages marked as deleted, unlock the maildrop, -and close the connection." - (pop3-send-command process "QUIT") - (pop3-read-response process t) - (if process - (with-current-buffer (process-buffer process) - (goto-char (point-max)) - (delete-process process)))) - -;; Summary of POP3 (Post Office Protocol version 3) commands and responses - -;;; AUTHORIZATION STATE - -;; Initial TCP connection -;; Arguments: none -;; Restrictions: none -;; Possible responses: -;; +OK [POP3 server ready] - -;; USER name -;; Arguments: a server specific user-id (required) -;; Restrictions: authorization state [after unsuccessful USER or PASS -;; Possible responses: -;; +OK [valid user-id] -;; -ERR [invalid user-id] - -;; PASS string -;; Arguments: a server/user-id specific password (required) -;; Restrictions: authorization state, after successful USER -;; Possible responses: -;; +OK [maildrop locked and ready] -;; -ERR [invalid password] -;; -ERR [unable to lock maildrop] - -;; STLS (RFC 2595) -;; Arguments: none -;; Restrictions: Only permitted in AUTHORIZATION state. -;; Possible responses: -;; +OK -;; -ERR - -;;; TRANSACTION STATE - -;; STAT -;; Arguments: none -;; Restrictions: transaction state -;; Possible responses: -;; +OK nn mm [# of messages, size of maildrop] - -;; LIST [msg] -;; Arguments: a message-id (optional) -;; Restrictions: transaction state; msg must not be deleted -;; Possible responses: -;; +OK [scan listing follows] -;; -ERR [no such message] - -;; RETR msg -;; Arguments: a message-id (required) -;; Restrictions: transaction state; msg must not be deleted -;; Possible responses: -;; +OK [message contents follow] -;; -ERR [no such message] - -;; DELE msg -;; Arguments: a message-id (required) -;; Restrictions: transaction state; msg must not be deleted -;; Possible responses: -;; +OK [message deleted] -;; -ERR [no such message] - -;; NOOP -;; Arguments: none -;; Restrictions: transaction state -;; Possible responses: -;; +OK - -;; LAST -;; Arguments: none -;; Restrictions: transaction state -;; Possible responses: -;; +OK nn [highest numbered message accessed] - -;; RSET -;; Arguments: none -;; Restrictions: transaction state -;; Possible responses: -;; +OK [all delete marks removed] - -;; UIDL [msg] -;; Arguments: a message-id (optional) -;; Restrictions: transaction state; msg must not be deleted -;; Possible responses: -;; +OK [uidl listing follows] -;; -ERR [no such message] - -;;; UPDATE STATE - -;; QUIT -;; Arguments: none -;; Restrictions: none -;; Possible responses: -;; +OK [TCP connection closed] - -(provide 'pop3) - -;;; pop3.el ends here diff --git a/lisp/gnus/qp.el b/lisp/gnus/qp.el deleted file mode 100644 index 48fa49b2f25..00000000000 --- a/lisp/gnus/qp.el +++ /dev/null @@ -1,179 +0,0 @@ -;;; qp.el --- Quoted-Printable functions - -;; Copyright (C) 1998-2017 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Keywords: mail, extensions - -;; 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: - -;; Functions for encoding and decoding quoted-printable text as -;; defined in RFC 2045. - -;;; Code: - -(require 'mm-util) -(defvar mm-use-ultra-safe-encoding) - -;;;###autoload -(defun quoted-printable-decode-region (from to &optional coding-system) - "Decode quoted-printable in the region between FROM and TO, per RFC 2045. -If CODING-SYSTEM is non-nil, decode bytes into characters with that -coding-system. - -Interactively, you can supply the CODING-SYSTEM argument -with \\[universal-coding-system-argument]. - -The CODING-SYSTEM argument is a historical hangover and is deprecated. -QP encodes raw bytes and should be decoded into raw bytes. Decoding -them into characters should be done separately." - (interactive - ;; Let the user determine the coding system with "C-x RET c". - (list (region-beginning) (region-end) coding-system-for-read)) - (unless (mm-coding-system-p coding-system) ; e.g. `ascii' from Gnus - (setq coding-system nil)) - (save-excursion - (save-restriction - ;; RFC 2045: ``An "=" followed by two hexadecimal digits, one - ;; or both of which are lowercase letters in "abcdef", is - ;; formally illegal. A robust implementation might choose to - ;; recognize them as the corresponding uppercase letters.'' - (let ((case-fold-search t)) - (narrow-to-region from to) - ;; Do this in case we're called from Gnus, say, in a buffer - ;; which already contains non-ASCII characters which would - ;; then get doubly-decoded below. - (if coding-system - (mm-encode-coding-region (point-min) (point-max) coding-system)) - (goto-char (point-min)) - (while (and (skip-chars-forward "^=") - (not (eobp))) - (cond ((eq (char-after (1+ (point))) ?\n) - (delete-char 2)) - ((looking-at "\\(=[0-9A-F][0-9A-F]\\)+") - ;; Decode this sequence at once; i.e. by a single - ;; deletion and insertion. - (let* ((n (/ (- (match-end 0) (point)) 3)) - (str (make-string n 0))) - (dotimes (i n) - (let ((n1 (char-after (1+ (point)))) - (n2 (char-after (+ 2 (point))))) - (aset str i - (+ (* 16 (- n1 (if (<= n1 ?9) ?0 - (if (<= n1 ?F) (- ?A 10) - (- ?a 10))))) - (- n2 (if (<= n2 ?9) ?0 - (if (<= n2 ?F) (- ?A 10) - (- ?a 10))))))) - (forward-char 3)) - (delete-region (match-beginning 0) (match-end 0)) - (insert str))) - (t - (message "Malformed quoted-printable text") - (forward-char))))) - (if coding-system - (mm-decode-coding-region (point-min) (point-max) coding-system))))) - -(defun quoted-printable-decode-string (string &optional coding-system) - "Decode the quoted-printable encoded STRING and return the result. -If CODING-SYSTEM is non-nil, decode the string with coding-system. -Use of CODING-SYSTEM is deprecated; this function should deal with -raw bytes, and coding conversion should be done separately." - (mm-with-unibyte-buffer - (insert string) - (quoted-printable-decode-region (point-min) (point-max) coding-system) - (buffer-string))) - -(defun quoted-printable-encode-region (from to &optional fold class) - "Quoted-printable encode the region between FROM and TO per RFC 2045. - -If FOLD, fold long lines at 76 characters (as required by the RFC). -If CLASS is non-nil, translate the characters not matched by that -regexp class, which is in the form expected by `skip-chars-forward'. -You should probably avoid non-ASCII characters in this arg. - -If `mm-use-ultra-safe-encoding' is set, fold lines unconditionally and -encode lines starting with \"From\"." - (interactive "r") - (unless class - ;; Avoid using 8bit characters. = is \075. - ;; Equivalent to "^\000-\007\013\015-\037\200-\377=" - (setq class "\010-\012\014\040-\074\076-\177")) - (save-excursion - (goto-char from) - (if (re-search-forward (mm-string-to-multibyte "[^\x0-\x7f\x80-\xff]") - to t) - (error "Multibyte character in QP encoding region")) - (save-restriction - (narrow-to-region from to) - ;; Encode all the non-ascii and control characters. - (goto-char (point-min)) - (while (and (skip-chars-forward class) - (not (eobp))) - (insert - (prog1 - ;; To unibyte in case of Emacs 23 (unicode) eight-bit. - (format "=%02X" (mm-multibyte-char-to-unibyte (char-after))) - (delete-char 1)))) - ;; Encode white space at the end of lines. - (goto-char (point-min)) - (while (re-search-forward "[ \t]+$" nil t) - (goto-char (match-beginning 0)) - (while (not (eolp)) - (insert - (prog1 - (format "=%02X" (char-after)) - (delete-char 1))))) - (let ((mm-use-ultra-safe-encoding - (and (boundp 'mm-use-ultra-safe-encoding) - mm-use-ultra-safe-encoding))) - (when (or fold mm-use-ultra-safe-encoding) - (let ((tab-width 1) ; HTAB is one character. - (case-fold-search nil)) - (goto-char (point-min)) - (while (not (eobp)) - ;; In ultra-safe mode, encode "From " at the beginning - ;; of a line. - (when mm-use-ultra-safe-encoding - (if (looking-at "From ") - (replace-match "From=20" nil t) - (if (looking-at "-") - (replace-match "=2D" nil t)))) - (end-of-line) - ;; Fold long lines. - (while (> (current-column) 76) ; tab-width must be 1. - (beginning-of-line) - (forward-char 75) ; 75 chars plus an "=" - (search-backward "=" (- (point) 2) t) - (insert "=\n") - (end-of-line)) - (forward-line)))))))) - -(defun quoted-printable-encode-string (string) - "Encode the STRING as quoted-printable and return the result." - (with-temp-buffer - (if (mm-multibyte-string-p string) - (mm-enable-multibyte) - (mm-disable-multibyte)) - (insert string) - (quoted-printable-encode-region (point-min) (point-max)) - (buffer-string))) - -(provide 'qp) - -;;; qp.el ends here diff --git a/lisp/gnus/registry.el b/lisp/gnus/registry.el deleted file mode 100644 index 16f5d20dccf..00000000000 --- a/lisp/gnus/registry.el +++ /dev/null @@ -1,378 +0,0 @@ -;;; registry.el --- Track and remember data items by various fields - -;; Copyright (C) 2011-2017 Free Software Foundation, Inc. - -;; Author: Teodor Zlatanov <tzz@lifelogs.com> -;; Keywords: data - -;; 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: - -;; This library provides a general-purpose EIEIO-based registry -;; database with persistence, initialized with these fields: - -;; version: a float - -;; max-size: an integer, default most-positive-fixnum - -;; prune-factor: a float between 0 and 1, default 0.1 - -;; precious: a list of symbols - -;; tracked: a list of symbols - -;; tracker: a hashtable tuned for 100 symbols to track (you should -;; only access this with the :lookup2-function and the -;; :lookup2+-function) - -;; data: a hashtable with default size 10K and resize threshold 2.0 -;; (this reflects the expected usage so override it if you know better) - -;; ...plus methods to do all the work: `registry-search', -;; `registry-lookup', `registry-lookup-secondary', -;; `registry-lookup-secondary-value', `registry-insert', -;; `registry-delete', `registry-prune', `registry-size' which see - -;; and with the following properties: - -;; Every piece of data has a unique ID and some general-purpose fields -;; (F1=D1, F2=D2, F3=(a b c)...) expressed as an alist, e.g. - -;; ((F1 D1) (F2 D2) (F3 a b c)) - -;; Note that whether a field has one or many pieces of data, the data -;; is always a list of values. - -;; The user decides which fields are "precious", F2 for example. When -;; the registry is pruned, any entries without the F2 field will be -;; removed until the size is :max-size * :prune-factor _less_ than the -;; maximum database size. No entries with the F2 field will be removed -;; at PRUNE TIME, which means it may not be possible to prune back all -;; the way to the target size. - -;; When an entry is inserted, the registry will reject new entries if -;; they bring it over the :max-size limit, even if they have the F2 -;; field. - -;; The user decides which fields are "tracked", F1 for example. Any -;; new entry is then indexed by all the tracked fields so it can be -;; quickly looked up that way. The data is always a list (see example -;; above) and each list element is indexed. - -;; Precious and tracked field names must be symbols. All other -;; fields can be any other Emacs Lisp types. - -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'eieio) -(require 'eieio-base) - -;; The version number needs to be kept outside of the class definition -;; itself. The persistent-save process does *not* write to file any -;; slot values that are equal to the default :initform value. If a -;; database object is at the most recent version, therefore, its -;; version number will not be written to file. That makes it -;; difficult to know when a database needs to be upgraded. -(defvar registry-db-version 0.2 - "The current version of the registry format.") - -(defclass registry-db (eieio-persistent) - ((version :initarg :version - :initform nil - :type (or null float) - :documentation "The registry version.") - (max-size :initarg :max-size - ;; EIEIO's :initform is not 100% compatible with CLOS in - ;; that if the form is an atom, it assumes it's constant - ;; value rather than an expression, so in order to get the value - ;; of `most-positive-fixnum', we need to use an - ;; expression that's not just a symbol. - :initform (symbol-value 'most-positive-fixnum) - :type integer - :custom integer - :documentation "The maximum number of registry entries.") - (prune-factor - :initarg :prune-factor - :initform 0.1 - :type float - :custom float - :documentation "Prune to (:max-size * :prune-factor) less - than the :max-size limit. Should be a float between 0 and 1.") - (tracked :initarg :tracked - :initform nil - :type t - :documentation "The tracked (indexed) fields, a list of symbols.") - (precious :initarg :precious - :initform nil - :type t - :documentation "The precious fields, a list of symbols.") - (tracker :initarg :tracker - :type hash-table - :documentation "The field tracking hashtable.") - (data :initarg :data - :type hash-table - :documentation "The data hashtable."))) - -(defmethod initialize-instance :BEFORE ((this registry-db) slots) - "Check whether a registry object needs to be upgraded." - ;; Hardcoded upgrade routines. Version 0.1 to 0.2 requires the - ;; :max-soft slot to disappear, and the :max-hard slot to be renamed - ;; :max-size. - (let ((current-version - (and (plist-member slots :version) - (plist-get slots :version)))) - (when (or (null current-version) - (eql current-version 0.1)) - (setq slots - (plist-put slots :max-size (plist-get slots :max-hard))) - (setq slots - (plist-put slots :version registry-db-version)) - (cl-remf slots :max-hard) - (cl-remf slots :max-soft)))) - -(defmethod initialize-instance :AFTER ((this registry-db) slots) - "Set value of data slot of THIS after initialization." - (with-slots (data tracker) this - (unless (member :data slots) - (setq data - (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal))) - (unless (member :tracker slots) - (setq tracker (make-hash-table :size 100 :rehash-size 2.0))))) - -(defmethod registry-lookup ((db registry-db) keys) - "Search for KEYS in the registry-db THIS. -Returns an alist of the key followed by the entry in a list, not a cons cell." - (let ((data (oref db data))) - (delq nil - (mapcar - (lambda (k) - (when (gethash k data) - (list k (gethash k data)))) - keys)))) - -(defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys) - "Search for KEYS in the registry-db THIS. -Returns an alist of the key followed by the entry in a list, not a cons cell." - (let ((data (oref db data))) - (delq nil - (loop for key in keys - when (gethash key data) - collect (list key (gethash key data)))))) - -(defmethod registry-lookup-secondary ((db registry-db) tracksym - &optional create) - "Search for TRACKSYM in the registry-db THIS. -When CREATE is not nil, create the secondary index hashtable if needed." - (let ((h (gethash tracksym (oref db :tracker)))) - (if h - h - (when create - (puthash tracksym - (make-hash-table :size 800 :rehash-size 2.0 :test 'equal) - (oref db tracker)) - (gethash tracksym (oref db tracker)))))) - -(defmethod registry-lookup-secondary-value ((db registry-db) tracksym val - &optional set) - "Search for TRACKSYM with value VAL in the registry-db THIS. -When SET is not nil, set it for VAL (use t for an empty list)." - ;; either we're asked for creation or there should be an existing index - (when (or set (registry-lookup-secondary db tracksym)) - ;; set the entry if requested, - (when set - (puthash val (if (eq t set) '() set) - (registry-lookup-secondary db tracksym t))) - (gethash val (registry-lookup-secondary db tracksym)))) - -(defun registry--match (mode entry check-list) - ;; for all members - (when check-list - (let ((key (nth 0 (nth 0 check-list))) - (vals (cdr-safe (nth 0 check-list))) - found) - (while (and key vals (not found)) - (setq found (case mode - (:member - (member (car-safe vals) (cdr-safe (assoc key entry)))) - (:regex - (string-match (car vals) - (mapconcat - 'prin1-to-string - (cdr-safe (assoc key entry)) - "\0")))) - vals (cdr-safe vals))) - (or found - (registry--match mode entry (cdr-safe check-list)))))) - -(defmethod registry-search ((db registry-db) &rest spec) - "Search for SPEC across the registry-db THIS. -For example calling with `:member \\='(a 1 2)' will match entry \((a 3 1)). -Calling with `:all t' (any non-nil value) will match all. -Calling with `:regex \\='(a \"h.llo\")' will match entry \(a \"hullo\" \"bye\"). -The test order is to check :all first, then :member, then :regex." - (when db - (let ((all (plist-get spec :all)) - (member (plist-get spec :member)) - (regex (plist-get spec :regex))) - (loop for k being the hash-keys of (oref db data) - using (hash-values v) - when (or - ;; :all non-nil returns all - all - ;; member matching - (and member (registry--match :member v member)) - ;; regex matching - (and regex (registry--match :regex v regex))) - collect k)))) - -(defmethod registry-delete ((db registry-db) keys assert &rest spec) - "Delete KEYS from the registry-db THIS. -If KEYS is nil, use SPEC to do a search. -Updates the secondary ('tracked') indices as well. -With assert non-nil, errors out if the key does not exist already." - (let* ((data (oref db data)) - (keys (or keys - (apply 'registry-search db spec))) - (tracked (oref db tracked))) - - (dolist (key keys) - (let ((entry (gethash key data))) - (when assert - (assert entry nil - "Key %s does not exist in database" key)) - ;; clean entry from the secondary indices - (dolist (tr tracked) - ;; is this tracked symbol indexed? - (when (registry-lookup-secondary db tr) - ;; for every value in the entry under that key... - (dolist (val (cdr-safe (assq tr entry))) - (let* ((value-keys (registry-lookup-secondary-value - db tr val))) - (when (member key value-keys) - ;; override the previous value - (registry-lookup-secondary-value - db tr val - ;; with the indexed keys MINUS the current key - ;; (we pass t when the list is empty) - (or (delete key value-keys) t))))))) - (remhash key data))) - keys)) - -(defmethod registry-size ((db registry-db)) - "Returns the size of the registry-db object THIS. -This is the key count of the `data' slot." - (hash-table-count (oref db data))) - -(defmethod registry-full ((db registry-db)) - "Checks if registry-db THIS is full." - (>= (registry-size db) - (oref db max-size))) - -(defmethod registry-insert ((db registry-db) key entry) - "Insert ENTRY under KEY into the registry-db THIS. -Updates the secondary ('tracked') indices as well. -Errors out if the key exists already." - - (assert (not (gethash key (oref db data))) nil - "Key already exists in database") - - (assert (not (registry-full db)) - nil - "registry max-size limit reached") - - ;; store the entry - (puthash key entry (oref db data)) - - ;; store the secondary indices - (dolist (tr (oref db tracked)) - ;; for every value in the entry under that key... - (dolist (val (cdr-safe (assq tr entry))) - (let* ((value-keys (registry-lookup-secondary-value db tr val))) - (pushnew key value-keys :test 'equal) - (registry-lookup-secondary-value db tr val value-keys)))) - entry) - -(defmethod registry-reindex ((db registry-db)) - "Rebuild the secondary indices of registry-db THIS." - (let ((count 0) - (expected (* (length (oref db tracked)) (registry-size db)))) - (dolist (tr (oref db tracked)) - (let (values) - (maphash - (lambda (key v) - (incf count) - (when (and (< 0 expected) - (= 0 (mod count 1000))) - (message "reindexing: %d of %d (%.2f%%)" - count expected (/ (* 100.0 count) expected))) - (dolist (val (cdr-safe (assq tr v))) - (let* ((value-keys (registry-lookup-secondary-value db tr val))) - (push key value-keys) - (registry-lookup-secondary-value db tr val value-keys)))) - (oref db data)))))) - -(defmethod registry-prune ((db registry-db) &optional sortfunc) - "Prunes the registry-db object DB. - -Attempts to prune the number of entries down to \(* -:max-size :prune-factor) less than the max-size limit, so -pruning doesn't need to happen on every save. Removes only -entries without the :precious keys, so it may not be possible to -reach the target limit. - -Entries to be pruned are first sorted using SORTFUNC. Entries -from the front of the list are deleted first. - -Returns the number of deleted entries." - (let ((size (registry-size db)) - (target-size - (floor (- (oref db max-size) - (* (oref db max-size) - (oref db prune-factor))))) - candidates) - (if (registry-full db) - (progn - (setq candidates - (registry-collect-prune-candidates - db (- size target-size) sortfunc)) - (length (registry-delete db candidates nil))) - 0))) - -(defmethod registry-collect-prune-candidates ((db registry-db) limit sortfunc) - "Collects pruning candidates from the registry-db object DB. - -Proposes only entries without the :precious keys, and attempts to -return LIMIT such candidates. If SORTFUNC is provided, sort -entries first and return candidates from beginning of list." - (let* ((precious (oref db precious)) - (precious-p (lambda (entry-key) - (cdr (memq (car entry-key) precious)))) - (data (oref db data)) - (candidates (cl-loop for k being the hash-keys of data - using (hash-values v) - when (notany precious-p v) - collect (cons k v)))) - ;; We want the full entries for sorting, but should only return a - ;; list of entry keys. - (when sortfunc - (setq candidates (sort candidates sortfunc))) - (cl-subseq (mapcar #'car candidates) 0 (min limit (length candidates))))) - -(provide 'registry) -;;; registry.el ends here diff --git a/lisp/gnus/rfc1843.el b/lisp/gnus/rfc1843.el deleted file mode 100644 index ce7c22d6afb..00000000000 --- a/lisp/gnus/rfc1843.el +++ /dev/null @@ -1,189 +0,0 @@ -;;; rfc1843.el --- HZ (rfc1843) decoding - -;; Copyright (C) 1998-2017 Free Software Foundation, Inc. - -;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> -;; Keywords: news HZ HZ+ mail i18n - -;; 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: - -;; Usage: -;; (require 'rfc1843) -;; (rfc1843-gnus-setup) -;; -;; Test: -;; (rfc1843-decode-string "~{<:Ky2;S{#,NpJ)l6HK!#~}") - -;;; Code: - -(eval-when-compile (require 'cl)) -(require 'mm-util) - -(defvar gnus-decode-encoded-word-function) -(defvar gnus-decode-header-function) -(defvar gnus-newsgroup-name) - -(defvar rfc1843-word-regexp - "~\\({\\([\041-\167][\041-\176]\\| \\)+\\)\\(~}\\|$\\)") - -(defvar rfc1843-word-regexp-strictly - "~\\({\\([\041-\167][\041-\176]\\)+\\)\\(~}\\|$\\)") - -(defvar rfc1843-hzp-word-regexp - "~\\({\\([\041-\167][\041-\176]\\| \\)+\\|\ -[<>]\\([\041-\175][\041-\176]\\| \\)+\\)\\(~}\\|$\\)") - -(defvar rfc1843-hzp-word-regexp-strictly - "~\\({\\([\041-\167][\041-\176]\\)+\\|\ -[<>]\\([\041-\175][\041-\176]\\)+\\)\\(~}\\|$\\)") - -(defcustom rfc1843-decode-loosely nil - "Loosely check HZ encoding if non-nil. -When it is set non-nil, only buffers or strings with strictly -HZ-encoded are decoded." - :type 'boolean - :group 'mime) - -(defcustom rfc1843-decode-hzp t - "HZ+ decoding support if non-nil. -HZ+ specification (also known as HZP) is to provide a standardized -7-bit representation of mixed Big5, GB, and ASCII text for convenient -e-mail transmission, news posting, etc. -The document of HZ+ 0.78 specification can be found at -ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc" - :type 'boolean - :group 'mime) - -(defcustom rfc1843-newsgroups-regexp "chinese\\|hz" - "Regexp of newsgroups in which might be HZ encoded." - :type 'string - :group 'mime) - -(defun rfc1843-decode-region (from to) - "Decode HZ in the region between FROM and TO." - (interactive "r") - (let (str firstc) - (save-excursion - (goto-char from) - (if (or rfc1843-decode-loosely - (re-search-forward (if rfc1843-decode-hzp - rfc1843-hzp-word-regexp-strictly - rfc1843-word-regexp-strictly) to t)) - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (re-search-forward (if rfc1843-decode-hzp - rfc1843-hzp-word-regexp - rfc1843-word-regexp) (point-max) t) - ;;; Text with extents may cause XEmacs crash - (setq str (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))) - (setq firstc (aref str 0)) - (insert (mm-decode-coding-string - (rfc1843-decode - (prog1 - (substring str 1) - (delete-region (match-beginning 0) (match-end 0))) - firstc) - (if (eq firstc ?{) 'cn-gb-2312 'cn-big5)))) - (goto-char (point-min)) - (while (search-forward "~" (point-max) t) - (cond ((eq (char-after) ?\n) - (delete-char -1) - (delete-char 1)) - ((eq (char-after) ?~) - (delete-char 1))))))))) - -(defun rfc1843-decode-string (string) - "Decode HZ STRING and return the results." - (let ((m (mm-multibyte-p))) - (with-temp-buffer - (when m - (mm-enable-multibyte)) - (insert string) - (inline - (rfc1843-decode-region (point-min) (point-max))) - (buffer-string)))) - -(defun rfc1843-decode (word &optional firstc) - "Decode HZ WORD and return it." - (let ((i -1) (s (substring word 0)) v) - (if (or (not firstc) (eq firstc ?{)) - (while (< (incf i) (length s)) - (if (eq (setq v (aref s i)) ? ) nil - (aset s i (+ 128 v)))) - (while (< (incf i) (length s)) - (if (eq (setq v (aref s i)) ? ) nil - (setq v (+ (* 94 v) (aref s (1+ i)) -3135)) - (aset s i (+ (/ v 157) (if (eq firstc ?<) 201 161))) - (setq v (% v 157)) - (aset s (incf i) (+ v (if (< v 63) 64 98)))))) - s)) - -(autoload 'mail-header-parse-content-type "mail-parse") -(autoload 'message-narrow-to-head "message") -(declare-function message-fetch-field "message" (header &optional not-all)) - -(defun rfc1843-decode-article-body () - "Decode HZ encoded text in the article body." - (if (string-match (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>") - (or gnus-newsgroup-name "")) - (save-excursion - (save-restriction - (message-narrow-to-head) - (let* ((inhibit-point-motion-hooks t) - (case-fold-search t) - (ct (message-fetch-field "Content-Type" t)) - (ctl (and ct (mail-header-parse-content-type ct)))) - (if (and ctl (not (string-match "/" (car ctl)))) - (setq ctl nil)) - (goto-char (point-max)) - (widen) - (forward-line 1) - (narrow-to-region (point) (point-max)) - (when (or (not ctl) - (equal (car ctl) "text/plain")) - (rfc1843-decode-region (point) (point-max)))))))) - -(defvar gnus-decode-header-methods) -(defvar gnus-decode-encoded-word-methods) - -(defun rfc1843-gnus-setup () - "Setup HZ decoding for Gnus." - (require 'gnus-art) - (require 'gnus-sum) - (add-hook 'gnus-article-decode-hook 'rfc1843-decode-article-body t) - (setq gnus-decode-encoded-word-function - 'gnus-multi-decode-encoded-word-string - gnus-decode-header-function - 'gnus-multi-decode-header - gnus-decode-encoded-word-methods - (nconc gnus-decode-encoded-word-methods - (list - (cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>") - 'rfc1843-decode-string))) - gnus-decode-header-methods - (nconc gnus-decode-header-methods - (list - (cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>") - 'rfc1843-decode-region))))) - -(provide 'rfc1843) - -;;; rfc1843.el ends here diff --git a/lisp/gnus/rfc2045.el b/lisp/gnus/rfc2045.el deleted file mode 100644 index f6000500e11..00000000000 --- a/lisp/gnus/rfc2045.el +++ /dev/null @@ -1,41 +0,0 @@ -;;; rfc2045.el --- Functions for decoding rfc2045 headers - -;; Copyright (C) 1998-2017 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; 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/>. - -;; RFC 2045 is: "Multipurpose Internet Mail Extensions (MIME) Part -;; One: Format of Internet Message Bodies". - -;;; Commentary: - -;;; Code: - -(require 'ietf-drums) - -(defun rfc2045-encode-string (param value) - "Return and PARAM=VALUE string encoded according to RFC2045." - (if (or (string-match (concat "[" ietf-drums-no-ws-ctl-token "]") value) - (string-match (concat "[" ietf-drums-tspecials "]") value) - (string-match "[ \n\t]" value) - (not (string-match (concat "[" ietf-drums-text-token "]") value))) - (concat param "=" (format "%S" value)) - (concat param "=" value))) - -(provide 'rfc2045) - -;;; rfc2045.el ends here diff --git a/lisp/gnus/rfc2047.el b/lisp/gnus/rfc2047.el deleted file mode 100644 index e026647ccee..00000000000 --- a/lisp/gnus/rfc2047.el +++ /dev/null @@ -1,1175 +0,0 @@ -;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages - -;; Copyright (C) 1998-2017 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; MORIOKA Tomohiko <morioka@jaist.ac.jp> -;; 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: - -;; RFC 2047 is "MIME (Multipurpose Internet Mail Extensions) Part -;; Three: Message Header Extensions for Non-ASCII Text". - -;;; Code: - -(eval-when-compile - (require 'cl)) -(defvar message-posting-charset) - -(require 'mm-util) -(require 'ietf-drums) -;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus. -(require 'mail-prsvr) -(require 'rfc2045) ;; rfc2045-encode-string -(autoload 'mm-body-7-or-8 "mm-bodies") - -(defvar rfc2047-header-encoding-alist - '(("Newsgroups" . nil) - ("Followup-To" . nil) - ("Message-ID" . nil) - ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|\\(In-\\)?Reply-To\\|Sender\ -\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime) - (t . mime)) - "*Header/encoding method alist. -The list is traversed sequentially. The keys can either be -header regexps or t. - -The values can be: - -1) nil, in which case no encoding is done; -2) `mime', in which case the header will be encoded according to RFC2047; -3) `address-mime', like `mime', but takes account of the rules for address - fields (where quoted strings and comments must be treated separately); -4) a charset, in which case it will be encoded as that charset; -5) `default', in which case the field will be encoded as the rest - of the article.") - -(defvar rfc2047-charset-encoding-alist - '((us-ascii . nil) - (iso-8859-1 . Q) - (iso-8859-2 . Q) - (iso-8859-3 . Q) - (iso-8859-4 . Q) - (iso-8859-5 . B) - (koi8-r . B) - (iso-8859-7 . B) - (iso-8859-8 . B) - (iso-8859-9 . Q) - (iso-8859-14 . Q) - (iso-8859-15 . Q) - (iso-2022-jp . B) - (iso-2022-kr . B) - (gb2312 . B) - (gbk . B) - (gb18030 . B) - (big5 . B) - (cn-big5 . B) - (cn-gb . B) - (cn-gb-2312 . B) - (euc-kr . B) - (iso-2022-jp-2 . B) - (iso-2022-int-1 . B) - (viscii . Q)) - "Alist of MIME charsets to RFC2047 encodings. -Valid encodings are nil, `Q' and `B'. These indicate binary (no) encoding, -quoted-printable and base64 respectively.") - -(defvar rfc2047-encode-function-alist - '((Q . rfc2047-q-encode-string) - (B . rfc2047-b-encode-string) - (nil . identity)) - "Alist of RFC2047 encodings to encoding functions.") - -(defvar rfc2047-encode-encoded-words t - "Whether encoded words should be encoded again.") - -(defvar rfc2047-allow-irregular-q-encoded-words t - "*Whether to decode irregular Q-encoded words.") - -(eval-and-compile ;; Necessary to hard code them in `rfc2047-decode-region'. - (defconst rfc2047-encoded-word-regexp - "=\\?\\([^][\000-\040()<>@,;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\ -\\(B\\?[+/0-9A-Za-z]*=*\ -\\|Q\\?[ ->@-~]*\ -\\)\\?=" - "Regexp that matches encoded word." - ;; The patterns for the B encoding and the Q encoding, i.e. the ones - ;; beginning with "B" and "Q" respectively, are restricted into only - ;; the characters that those encodings may generally use. - ) - (defconst rfc2047-encoded-word-regexp-loose - "=\\?\\([^][\000-\040()<>@,;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\ -\\(B\\?[+/0-9A-Za-z]*=*\ -\\|Q\\?\\(?:\\?+[ -<>@-~]\\)?\\(?:[ ->@-~]+\\?+[ -<>@-~]\\)*[ ->@-~]*\\?*\ -\\)\\?=" - "Regexp that matches encoded word allowing loose Q encoding." - ;; The pattern for the Q encoding, i.e. the one beginning with "Q", - ;; is similar to: - ;; "Q\\?\\(\\?+[^\n=?]\\)?\\([^\n?]+\\?+[^\n=?]\\)*[^\n?]*\\?*" - ;; <--------1-------><----------2,3----------><--4--><-5-> - ;; They mean: - ;; 1. After "Q?", allow "?"s that follow a character other than "=". - ;; 2. Allow "=" after "Q?"; it isn't regarded as the terminator. - ;; 3. In the middle of an encoded word, allow "?"s that follow a - ;; character other than "=". - ;; 4. Allow any characters other than "?" in the middle of an - ;; encoded word. - ;; 5. At the end, allow "?"s. - )) - -;;; -;;; Functions for encoding RFC2047 messages -;;; - -(defun rfc2047-qp-or-base64 () - "Return the type with which to encode the buffer. -This is either `base64' or `quoted-printable'." - (save-excursion - (let ((limit (min (point-max) (+ 2000 (point-min)))) - (n8bit 0)) - (goto-char (point-min)) - (skip-chars-forward "\x20-\x7f\r\n\t" limit) - (while (< (point) limit) - (incf n8bit) - (forward-char 1) - (skip-chars-forward "\x20-\x7f\r\n\t" limit)) - (if (or (< (* 6 n8bit) (- limit (point-min))) - ;; Don't base64, say, a short line with a single - ;; non-ASCII char when splitting parts by charset. - (= n8bit 1)) - 'quoted-printable - 'base64)))) - -(defun rfc2047-narrow-to-field () - "Narrow the buffer to the header on the current line." - (beginning-of-line) - (narrow-to-region - (point) - (progn - (forward-line 1) - (if (re-search-forward "^[^ \n\t]" nil t) - (point-at-bol) - (point-max)))) - (goto-char (point-min))) - -(defun rfc2047-field-value () - "Return the value of the field at point." - (save-excursion - (save-restriction - (rfc2047-narrow-to-field) - (re-search-forward ":[ \t\n]*" nil t) - (buffer-substring-no-properties (point) (point-max))))) - -(defun rfc2047-quote-special-characters-in-quoted-strings (&optional - encodable-regexp) - "Quote special characters with `\\'s in quoted strings. -Quoting will not be done in a quoted string if it contains characters -matching ENCODABLE-REGEXP or it is within parentheses." - (goto-char (point-min)) - (let ((tspecials (concat "[" ietf-drums-tspecials "]")) - (start (point)) - beg end) - (with-syntax-table (standard-syntax-table) - (while (not (eobp)) - (if (ignore-errors - (forward-list 1) - (eq (char-before) ?\))) - (forward-list -1) - (goto-char (point-max))) - (save-restriction - (narrow-to-region start (point)) - (goto-char start) - (while (search-forward "\"" nil t) - (setq beg (match-beginning 0)) - (unless (eq (char-before beg) ?\\) - (goto-char beg) - (setq beg (1+ beg)) - (condition-case nil - (progn - (forward-sexp) - (setq end (1- (point))) - (goto-char beg) - (if (and encodable-regexp - (re-search-forward encodable-regexp end t)) - (goto-char (1+ end)) - (save-restriction - (narrow-to-region beg end) - (while (re-search-forward tspecials nil 'move) - (if (eq (char-before) ?\\) - (if (looking-at tspecials) ;; Already quoted. - (forward-char) - (insert "\\")) - (goto-char (match-beginning 0)) - (insert "\\") - (forward-char)))) - (forward-char))) - (error - (goto-char beg))))) - (goto-char (point-max))) - (forward-list 1) - (setq start (point)))))) - -(defvar rfc2047-encoding-type 'address-mime - "The type of encoding done by `rfc2047-encode-region'. -This should be dynamically bound around calls to -`rfc2047-encode-region' to either `mime' or `address-mime'. See -`rfc2047-header-encoding-alist', for definitions.") - -(defun rfc2047-encode-message-header () - "Encode the message header according to `rfc2047-header-encoding-alist'. -Should be called narrowed to the head of the message." - (interactive "*") - (save-excursion - (goto-char (point-min)) - (let (alist elem method charsets) - (while (not (eobp)) - (save-restriction - (rfc2047-narrow-to-field) - (setq method nil - alist rfc2047-header-encoding-alist - charsets (mm-find-mime-charset-region (point-min) (point-max))) - ;; M$ Outlook boycotts decoding of a header if it consists - ;; of two or more encoded words and those charsets differ; - ;; it seems to decode all words in a header from a charset - ;; found first in the header. So, we unify the charsets into - ;; a single one used for encoding the whole text in a header. - (let ((mm-coding-system-priorities - (if (= (length charsets) 1) - (cons (mm-charset-to-coding-system (car charsets)) - mm-coding-system-priorities) - mm-coding-system-priorities))) - (while (setq elem (pop alist)) - (when (or (and (stringp (car elem)) - (looking-at (car elem))) - (eq (car elem) t)) - (setq alist nil - method (cdr elem)))) - (if (not (rfc2047-encodable-p)) - (prog2 - (when (eq method 'address-mime) - (rfc2047-quote-special-characters-in-quoted-strings)) - (if (and (eq (mm-body-7-or-8) '8bit) - (mm-multibyte-p) - (mm-coding-system-p - (car message-posting-charset))) - ;; 8 bit must be decoded. - (mm-encode-coding-region - (point-min) (point-max) - (mm-charset-to-coding-system - (car message-posting-charset)))) - ;; No encoding necessary, but folding is nice - (when nil - (rfc2047-fold-region - (save-excursion - (goto-char (point-min)) - (skip-chars-forward "^:") - (when (looking-at ": ") - (forward-char 2)) - (point)) - (point-max)))) - ;; We found something that may perhaps be encoded. - (re-search-forward "^[^:]+: *" nil t) - (cond - ((eq method 'address-mime) - (rfc2047-encode-region (point) (point-max))) - ((eq method 'mime) - (let ((rfc2047-encoding-type 'mime)) - (rfc2047-encode-region (point) (point-max)))) - ((eq method 'default) - (if (and (featurep 'mule) - (if (boundp 'enable-multibyte-characters) - (default-value 'enable-multibyte-characters)) - mail-parse-charset) - (mm-encode-coding-region (point) (point-max) - mail-parse-charset))) - ;; We get this when CC'ing messages to newsgroups with - ;; 8-bit names. The group name mail copy just got - ;; unconditionally encoded. Previously, it would ask - ;; whether to encode, which was quite confusing for the - ;; user. If the new behavior is wrong, tell me. I have - ;; left the old code commented out below. - ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-07. - ;; Modified by Dave Love, with the commented-out code changed - ;; in accordance with changes elsewhere. - ((null method) - (rfc2047-encode-region (point) (point-max))) -;;; ((null method) -;;; (if (or (message-options-get -;;; 'rfc2047-encode-message-header-encode-any) -;;; (message-options-set -;;; 'rfc2047-encode-message-header-encode-any -;;; (y-or-n-p -;;; "Some texts are not encoded. Encode anyway?"))) -;;; (rfc2047-encode-region (point-min) (point-max)) -;;; (error "Cannot send unencoded text"))) - ((mm-coding-system-p method) - (if (or (and (featurep 'mule) - (if (boundp 'enable-multibyte-characters) - (default-value 'enable-multibyte-characters))) - (featurep 'file-coding)) - (mm-encode-coding-region (point) (point-max) method))) - ;; Hm. - (t))) - (goto-char (point-max)))))))) - -;; Fixme: This, and the require below may not be the Right Thing, but -;; should be safe just before release. -- fx 2001-02-08 - -(defun rfc2047-encodable-p () - "Return non-nil if any characters in current buffer need encoding in headers. -The buffer may be narrowed." - (require 'message) ; for message-posting-charset - (let ((charsets - (mm-find-mime-charset-region (point-min) (point-max)))) - (goto-char (point-min)) - (or (and rfc2047-encode-encoded-words - (prog1 - (re-search-forward rfc2047-encoded-word-regexp nil t) - (goto-char (point-min)))) - (and charsets - (not (equal charsets (list (car message-posting-charset)))))))) - -;; Use this syntax table when parsing into regions that may need -;; encoding. Double quotes are string delimiters, backslash is -;; character quoting, and all other RFC 2822 special characters are -;; treated as punctuation so we can use forward-sexp/forward-word to -;; skip to the end of regions appropriately. Nb. ietf-drums does -;; things differently. -(defconst rfc2047-syntax-table - ;; (make-char-table 'syntax-table '(2)) only works in Emacs. - (let ((table (make-syntax-table))) - ;; The following is done to work for setting all elements of the table; - ;; it appears to be the cleanest way. - ;; Play safe and don't assume the form of the word syntax entry -- - ;; copy it from ?a. - (if (featurep 'xemacs) - (put-char-table t (get-char-table ?a (standard-syntax-table)) table) - (set-char-table-range table t (aref (standard-syntax-table) ?a))) - (modify-syntax-entry ?\\ "\\" table) - (modify-syntax-entry ?\" "\"" table) - (modify-syntax-entry ?\( "(" table) - (modify-syntax-entry ?\) ")" table) - (modify-syntax-entry ?\< "." table) - (modify-syntax-entry ?\> "." table) - (modify-syntax-entry ?\[ "." table) - (modify-syntax-entry ?\] "." table) - (modify-syntax-entry ?: "." table) - (modify-syntax-entry ?\; "." table) - (modify-syntax-entry ?, "." table) - (modify-syntax-entry ?@ "." table) - table)) - -(defun rfc2047-encode-region (b e &optional dont-fold) - "Encode words in region B to E that need encoding. -By default, the region is treated as containing RFC2822 addresses. -Dynamically bind `rfc2047-encoding-type' to change that." - (save-restriction - (narrow-to-region b e) - (let ((encodable-regexp (if rfc2047-encode-encoded-words - "[^\000-\177]+\\|=\\?" - "[^\000-\177]+")) - start ; start of current token - end begin csyntax - ;; Whether there's an encoded word before the current token, - ;; either immediately or separated by space. - last-encoded - (orig-text (buffer-substring-no-properties b e))) - (if (eq 'mime rfc2047-encoding-type) - ;; Simple case. Continuous words in which all those contain - ;; non-ASCII characters are encoded collectively. Encoding - ;; ASCII words, including `Re:' used in Subject headers, is - ;; avoided for interoperability with non-MIME clients and - ;; for making it easy to find keywords. - (progn - (goto-char (point-min)) - (while (progn (skip-chars-forward " \t\n") - (not (eobp))) - (setq start (point)) - (while (and (looking-at "[ \t\n]*\\([^ \t\n]+\\)") - (progn - (setq end (match-end 0)) - (re-search-forward encodable-regexp end t))) - (goto-char end)) - (if (> (point) start) - (rfc2047-encode start (point)) - (goto-char end)))) - ;; `address-mime' case -- take care of quoted words, comments. - (rfc2047-quote-special-characters-in-quoted-strings encodable-regexp) - (with-syntax-table rfc2047-syntax-table - (goto-char (point-min)) - (condition-case err ; in case of unbalanced quotes - ;; Look for rfc2822-style: sequences of atoms, quoted - ;; strings, specials, whitespace. (Specials mustn't be - ;; encoded.) - (while (not (eobp)) - ;; Skip whitespace. - (skip-chars-forward " \t\n") - (setq start (point)) - (cond - ((not (char-after))) ; eob - ;; else token start - ((eq ?\" (setq csyntax (char-syntax (char-after)))) - ;; Quoted word. - (forward-sexp) - (setq end (point)) - ;; Does it need encoding? - (goto-char start) - (if (re-search-forward encodable-regexp end 'move) - ;; It needs encoding. Strip the quotes first, - ;; since encoded words can't occur in quotes. - (progn - (goto-char end) - (delete-char -1) - (goto-char start) - (delete-char 1) - (when last-encoded - ;; There was a preceding quoted word. We need - ;; to include any separating whitespace in this - ;; word to avoid it getting lost. - (skip-chars-backward " \t") - ;; A space is needed between the encoded words. - (insert ? ) - (setq start (point) - end (1+ end))) - ;; Adjust the end position for the deleted quotes. - (rfc2047-encode start (- end 2)) - (setq last-encoded t)) ; record that it was encoded - (setq last-encoded nil))) - ((eq ?. csyntax) - ;; Skip other delimiters, but record that they've - ;; potentially separated quoted words. - (forward-char) - (setq last-encoded nil)) - ((eq ?\) csyntax) - (error "Unbalanced parentheses")) - ((eq ?\( csyntax) - ;; Look for the end of parentheses. - (forward-list) - ;; Encode text as an unstructured field. - (let ((rfc2047-encoding-type 'mime)) - (rfc2047-encode-region (1+ start) (1- (point)))) - (skip-chars-forward ")")) - (t ; normal token/whitespace sequence - ;; Find the end. - ;; Skip one ASCII word, or encode continuous words - ;; in which all those contain non-ASCII characters. - (setq end nil) - (while (not (or end (eobp))) - (when (looking-at "[\000-\177]+") - (setq begin (point) - end (match-end 0)) - (when (progn - (while (and (or (re-search-forward - "[ \t\n]\\|\\Sw" end 'move) - (setq end nil)) - (eq ?\\ (char-syntax (char-before)))) - ;; Skip backslash-quoted characters. - (forward-char)) - end) - (setq end (match-beginning 0)) - (if rfc2047-encode-encoded-words - (progn - (goto-char begin) - (when (search-forward "=?" end 'move) - (goto-char (match-beginning 0)) - (setq end nil))) - (goto-char end)))) - ;; Where the value nil of `end' means there may be - ;; text to have to be encoded following the point. - ;; Otherwise, the point reached to the end of ASCII - ;; words separated by whitespace or a special char. - (unless end - (when (looking-at encodable-regexp) - (goto-char (setq begin (match-end 0))) - (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)") - (setq end (match-end 0)) - (progn - (while (re-search-forward - encodable-regexp end t)) - (< begin (point))) - (goto-char begin) - (or (not (re-search-forward "\\Sw" end t)) - (progn - (goto-char (match-beginning 0)) - nil))) - (goto-char end)) - (when (looking-at "[^ \t\n]+") - (setq end (match-end 0)) - (if (re-search-forward "\\Sw+" end t) - ;; There are special characters better - ;; to be encoded so that MTAs may parse - ;; them safely. - (cond ((= end (point))) - ((looking-at (concat "\\sw*\\(" - encodable-regexp - "\\)")) - (setq end nil)) - (t - (goto-char (1- (match-end 0))) - (unless (= (point) (match-beginning 0)) - ;; Separate encodable text and - ;; delimiter. - (insert " ")))) - (goto-char end) - (skip-chars-forward " \t\n") - (if (and (looking-at "[^ \t\n]+") - (string-match encodable-regexp - (match-string 0))) - (setq end nil) - (goto-char end))))))) - (skip-chars-backward " \t\n") - (setq end (point)) - (goto-char start) - (if (re-search-forward encodable-regexp end 'move) - (progn - (unless (memq (char-before start) '(nil ?\t ? )) - (if (progn - (goto-char start) - (skip-chars-backward "^ \t\n") - (and (looking-at "\\Sw+") - (= (match-end 0) start))) - ;; Also encode bogus delimiters. - (setq start (point)) - ;; Separate encodable text and delimiter. - (goto-char start) - (insert " ") - (setq start (1+ start) - end (1+ end)))) - (rfc2047-encode start end) - (setq last-encoded t)) - (setq last-encoded nil))))) - (error - (if (or debug-on-quit debug-on-error) - (signal (car err) (cdr err)) - (error "Invalid data for rfc2047 encoding: %s" - (mm-replace-in-string orig-text "[ \t\n]+" " ")))))))) - (unless dont-fold - (rfc2047-fold-region b (point))) - (goto-char (point-max)))) - -(defun rfc2047-encode-string (string &optional dont-fold) - "Encode words in STRING. -By default, the string is treated as containing addresses (see -`rfc2047-encoding-type')." - (mm-with-multibyte-buffer - (insert string) - (rfc2047-encode-region (point-min) (point-max) dont-fold) - (buffer-string))) - -;; From RFC 2047: -;; 2. Syntax of encoded-words -;; [...] -;; While there is no limit to the length of a multiple-line header -;; field, each line of a header field that contains one or more -;; 'encoded-word's is limited to 76 characters. -;; -;; In `rfc2047-encode-parameter' it is bound to nil, so don't defconst it. -(defvar rfc2047-encode-max-chars 76 - "Maximum characters of each header line that contain encoded-words. -According to RFC 2047, it is 76. If it is nil, encoded-words -will not be folded. Too small value may cause an error. You -should not change this value.") - -(defun rfc2047-encode-1 (column string cs encoder start crest tail - &optional eword) - "Subroutine used by `rfc2047-encode'." - (cond ((string-equal string "") - (or eword "")) - ((not rfc2047-encode-max-chars) - (concat start - (funcall encoder (if cs - (mm-encode-coding-string string cs) - string)) - "?=")) - ((>= column rfc2047-encode-max-chars) - (when eword - (cond ((string-match "\n[ \t]+\\'" eword) - ;; Remove a superfluous empty line. - (setq eword (substring eword 0 (match-beginning 0)))) - ((string-match "(+\\'" eword) - ;; Break the line before the open parenthesis. - (setq crest (concat crest (match-string 0 eword)) - eword (substring eword 0 (match-beginning 0)))))) - (rfc2047-encode-1 (length crest) string cs encoder start " " tail - (concat eword "\n" crest))) - (t - (let ((index 0) - (limit (1- (length string))) - (prev "") - next len) - (while (and prev - (<= index limit)) - (setq next (concat start - (funcall encoder - (if cs - (mm-encode-coding-string - (substring string 0 (1+ index)) - cs) - (substring string 0 (1+ index)))) - "?=") - len (+ column (length next))) - (if (> len rfc2047-encode-max-chars) - (setq next prev - prev nil) - (if (or (< index limit) - (<= (+ len (or (string-match "\n" tail) - (length tail))) - rfc2047-encode-max-chars)) - (setq prev next - index (1+ index)) - (if (string-match "\\`)+" tail) - ;; Break the line after the close parenthesis. - (setq tail (concat (substring tail 0 (match-end 0)) - "\n " - (substring tail (match-end 0))) - prev next - index (1+ index)) - (setq next prev - prev nil))))) - (if (> index limit) - (concat eword next tail) - (if (= 0 index) - (if (and eword - (string-match "(+\\'" eword)) - (setq crest (concat crest (match-string 0 eword)) - eword (substring eword 0 (match-beginning 0))) - (setq eword (concat eword next))) - (setq crest " " - eword (concat eword next))) - (when (string-match "\n[ \t]+\\'" eword) - ;; Remove a superfluous empty line. - (setq eword (substring eword 0 (match-beginning 0)))) - (rfc2047-encode-1 (length crest) (substring string index) - cs encoder start " " tail - (concat eword "\n" crest))))))) - -(defun rfc2047-encode (b e) - "Encode the word(s) in the region B to E. -Point moves to the end of the region." - (let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii))) - cs encoding tail crest eword) - ;; Use utf-8 as a last resort if determining charset of text fails. - (if (memq nil mime-charset) - (setq mime-charset (list 'utf-8))) - (cond ((> (length mime-charset) 1) - (error "Can't rfc2047-encode `%s'" - (buffer-substring-no-properties b e))) - ((= (length mime-charset) 1) - (setq mime-charset (car mime-charset) - cs (mm-charset-to-coding-system mime-charset)) - (unless (and (mm-multibyte-p) - (mm-coding-system-p cs)) - (setq cs nil)) - (save-restriction - (narrow-to-region b e) - (setq encoding - (or (cdr (assq mime-charset - rfc2047-charset-encoding-alist)) - ;; For the charsets that don't have a preferred - ;; encoding, choose the one that's shorter. - (if (eq (rfc2047-qp-or-base64) 'base64) - 'B - 'Q))) - (widen) - (goto-char e) - (skip-chars-forward "^ \t\n") - ;; `tail' may contain a close parenthesis. - (setq tail (buffer-substring-no-properties e (point))) - (goto-char b) - (setq b (point-marker) - e (set-marker (make-marker) e)) - (rfc2047-fold-region (point-at-bol) b) - (goto-char b) - (skip-chars-backward "^ \t\n") - (unless (= 0 (skip-chars-backward " \t")) - ;; `crest' may contain whitespace and an open parenthesis. - (setq crest (buffer-substring-no-properties (point) b))) - (setq eword (rfc2047-encode-1 - (- b (point-at-bol)) - (mm-replace-in-string - (buffer-substring-no-properties b e) - "\n\\([ \t]?\\)" "\\1") - cs - (or (cdr (assq encoding - rfc2047-encode-function-alist)) - 'identity) - (concat "=?" (downcase (symbol-name mime-charset)) - "?" (upcase (symbol-name encoding)) "?") - (or crest " ") - tail)) - (delete-region (if (eq (aref eword 0) ?\n) - (if (bolp) - ;; The line was folded before encoding. - (1- (point)) - (point)) - (goto-char b)) - (+ e (length tail))) - ;; `eword' contains `crest' and `tail'. - (insert eword) - (set-marker b nil) - (set-marker e nil) - (unless (or (/= 0 (length tail)) - (eobp) - (looking-at "[ \t\n)]")) - (insert " ")))) - (t - (goto-char e))))) - -(defun rfc2047-fold-field () - "Fold the current header field." - (save-excursion - (save-restriction - (rfc2047-narrow-to-field) - (rfc2047-fold-region (point-min) (point-max))))) - -(defun rfc2047-fold-region (b e) - "Fold long lines in region B to E." - (save-restriction - (narrow-to-region b e) - (goto-char (point-min)) - (let ((break nil) - (qword-break nil) - (first t) - (bol (save-restriction - (widen) - (point-at-bol)))) - (while (not (eobp)) - (when (and (or break qword-break) - (> (- (point) bol) 76)) - (goto-char (or break qword-break)) - (setq break nil - qword-break nil) - (skip-chars-backward " \t") - (if (looking-at "[ \t]") - (insert ?\n) - (insert "\n ")) - (setq bol (1- (point))) - ;; Don't break before the first non-LWSP characters. - (skip-chars-forward " \t") - (unless (eobp) - (forward-char 1))) - (cond - ((eq (char-after) ?\n) - (forward-char 1) - (setq bol (point) - break nil - qword-break nil) - (skip-chars-forward " \t") - (unless (or (eobp) (eq (char-after) ?\n)) - (forward-char 1))) - ((eq (char-after) ?\r) - (forward-char 1)) - ((memq (char-after) '(? ?\t)) - (skip-chars-forward " \t") - (unless first ;; Don't break just after the header name. - (setq break (point)))) - ((not break) - (if (not (looking-at "=\\?[^=]")) - (if (eq (char-after) ?=) - (forward-char 1) - (skip-chars-forward "^ \t\n\r=")) - ;; Don't break at the start of the field. - (unless (= (point) b) - (setq qword-break (point))) - (skip-chars-forward "^ \t\n\r"))) - (t - (skip-chars-forward "^ \t\n\r"))) - (setq first nil)) - (when (and (or break qword-break) - (> (- (point) bol) 76)) - (goto-char (or break qword-break)) - (setq break nil - qword-break nil) - (if (or (> 0 (skip-chars-backward " \t")) - (looking-at "[ \t]")) - (insert ?\n) - (insert "\n ")) - (setq bol (1- (point))) - ;; Don't break before the first non-LWSP characters. - (skip-chars-forward " \t") - (unless (eobp) - (forward-char 1)))))) - -(defun rfc2047-unfold-field () - "Fold the current line." - (save-excursion - (save-restriction - (rfc2047-narrow-to-field) - (rfc2047-unfold-region (point-min) (point-max))))) - -(defun rfc2047-unfold-region (b e) - "Unfold lines in region B to E." - (save-restriction - (narrow-to-region b e) - (goto-char (point-min)) - (let ((bol (save-restriction - (widen) - (point-at-bol))) - (eol (point-at-eol))) - (forward-line 1) - (while (not (eobp)) - (if (and (looking-at "[ \t]") - (< (- (point-at-eol) bol) 76)) - (delete-region eol (progn - (goto-char eol) - (skip-chars-forward "\r\n") - (point))) - (setq bol (point-at-bol))) - (setq eol (point-at-eol)) - (forward-line 1))))) - -(defun rfc2047-b-encode-string (string) - "Base64-encode the header contained in STRING." - (base64-encode-string string t)) - -(autoload 'quoted-printable-encode-region "qp") - -(defun rfc2047-q-encode-string (string) - "Quoted-printable-encode the header in STRING." - (mm-with-unibyte-buffer - (insert string) - (quoted-printable-encode-region - (point-min) (point-max) nil - ;; = (\075), _ (\137), ? (\077) are used in the encoded word. - ;; Avoid using 8bit characters. - ;; This list excludes `especials' (see the RFC2047 syntax), - ;; meaning that some characters in non-structured fields will - ;; get encoded when they con't need to be. The following is - ;; what it used to be. - ;;; ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?" - ;;; "\010\012\014\040-\074\076\100-\136\140-\177") - "-\b\n\f !#-'*+0-9A-Z\\^`-~\d") - (subst-char-in-region (point-min) (point-max) ? ?_) - (buffer-string))) - -(defun rfc2047-encode-parameter (param value) - "Return and PARAM=VALUE string encoded in the RFC2047-like style. -This is a substitution for the `rfc2231-encode-string' function, that -is the standard but many mailers don't support it." - (let ((rfc2047-encoding-type 'mime) - (rfc2047-encode-max-chars nil)) - (rfc2045-encode-string param (rfc2047-encode-string value t)))) - -;;; -;;; Functions for decoding RFC2047 messages -;;; - -(defvar rfc2047-quote-decoded-words-containing-tspecials nil - "If non-nil, quote decoded words containing special characters.") - -(defvar rfc2047-allow-incomplete-encoded-text t - "*Non-nil means allow incomplete encoded-text in successive encoded-words. -Dividing of encoded-text in the place other than character boundaries -violates RFC2047 section 5, while we have a capability to decode it. -If it is non-nil, the decoder will decode B- or Q-encoding in each -encoded-word, concatenate them, and decode it by charset. Otherwise, -the decoder will fully decode each encoded-word before concatenating -them.") - -(defun rfc2047-strip-backslashes-in-quoted-strings () - "Strip backslashes in quoted strings. `\\\"' remains." - (goto-char (point-min)) - (let (beg) - (with-syntax-table (standard-syntax-table) - (while (search-forward "\"" nil t) - (unless (eq (char-before) ?\\) - (setq beg (match-end 0)) - (goto-char (match-beginning 0)) - (condition-case nil - (progn - (forward-sexp) - (save-restriction - (narrow-to-region beg (1- (point))) - (goto-char beg) - (while (search-forward "\\" nil 'move) - (unless (memq (char-after) '(?\")) - (delete-char -1)) - (forward-char))) - (forward-char)) - (error - (goto-char beg)))))))) - -(defun rfc2047-charset-to-coding-system (charset &optional allow-override) - "Return coding-system corresponding to MIME CHARSET. -If your Emacs implementation can't decode CHARSET, return nil. - -If allow-override is given, use `mm-charset-override-alist' to -map undesired charset names to their replacement. This should -only be used for decoding, not for encoding." - (when (stringp charset) - (setq charset (intern (downcase charset)))) - (when (or (not charset) - (eq 'gnus-all mail-parse-ignored-charsets) - (memq 'gnus-all mail-parse-ignored-charsets) - (memq charset mail-parse-ignored-charsets)) - (setq charset mail-parse-charset)) - (let ((cs (mm-charset-to-coding-system charset nil allow-override))) - (cond ((eq cs 'ascii) - (setq cs (or (mm-charset-to-coding-system mail-parse-charset) - 'raw-text))) - ((mm-coding-system-p cs)) - ((and charset - (listp mail-parse-ignored-charsets) - (memq 'gnus-unknown mail-parse-ignored-charsets)) - (setq cs (mm-charset-to-coding-system mail-parse-charset)))) - (if (eq cs 'ascii) - 'raw-text - cs))) - -(autoload 'quoted-printable-decode-string "qp") - -(defun rfc2047-decode-encoded-words (words) - "Decode successive encoded-words in WORDS and return a decoded string. -Each element of WORDS looks like (CHARSET ENCODING ENCODED-TEXT -ENCODED-WORD)." - (let (word charset cs encoding text rest) - (while words - (setq word (pop words)) - (if (and (setq cs (rfc2047-charset-to-coding-system - (setq charset (car word)) t)) - (condition-case code - (cond ((char-equal ?B (nth 1 word)) - (setq text (base64-decode-string - (rfc2047-pad-base64 (nth 2 word))))) - ((char-equal ?Q (nth 1 word)) - (setq text (quoted-printable-decode-string - (mm-subst-char-in-string - ?_ ? (nth 2 word) t))))) - (error - (message "%s" (error-message-string code)) - nil))) - (if (and rfc2047-allow-incomplete-encoded-text - (eq cs (caar rest))) - ;; Concatenate text of which the charset is the same. - (setcdr (car rest) (concat (cdar rest) text)) - (push (cons cs text) rest)) - ;; Don't decode encoded-word. - (push (cons nil (nth 3 word)) rest))) - (while rest - (setq words (concat - (or (and (setq cs (caar rest)) - (condition-case code - (mm-decode-coding-string (cdar rest) cs) - (error - (message "%s" (error-message-string code)) - nil))) - (concat (when (cdr rest) " ") - (cdar rest) - (when (and words - (not (eq (string-to-char words) ? ))) - " "))) - words) - rest (cdr rest))) - words)) - -;; Fixme: This should decode in place, not cons intermediate strings. -;; Also check whether it needs to worry about delimiting fields like -;; encoding. - -;; In fact it's reported that (invalid) encoding of mailboxes in -;; addr-specs is in use, so delimiting fields might help. Probably -;; not decoding a word which isn't properly delimited is good enough -;; and worthwhile (is it more correct or not?), e.g. something like -;; `=?iso-8859-1?q?foo?=@'. - -(defun rfc2047-decode-region (start end &optional address-mime) - "Decode MIME-encoded words in region between START and END. -If ADDRESS-MIME is non-nil, strip backslashes which precede characters -other than `\"' and `\\' in quoted strings." - (interactive "r") - (let ((case-fold-search t) - (eword-regexp - (if rfc2047-allow-irregular-q-encoded-words - (eval-when-compile - (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp-loose "\\)")) - (eval-when-compile - (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp "\\)")))) - b e match words) - (save-excursion - (save-restriction - (narrow-to-region start end) - (when address-mime - (rfc2047-strip-backslashes-in-quoted-strings)) - (goto-char (setq b start)) - ;; Look for the encoded-words. - (while (setq match (re-search-forward eword-regexp nil t)) - (setq e (match-beginning 1) - end (match-end 0) - words nil) - (while match - (push (list (match-string 2) ;; charset - (char-after (match-beginning 3)) ;; encoding - (substring (match-string 3) 2) ;; encoded-text - (match-string 1)) ;; encoded-word - words) - ;; Look for the subsequent encoded-words. - (when (setq match (looking-at eword-regexp)) - (goto-char (setq end (match-end 0))))) - ;; Replace the encoded-words with the decoded one. - (delete-region e end) - (insert (rfc2047-decode-encoded-words (nreverse words))) - (save-restriction - (narrow-to-region e (point)) - (goto-char e) - ;; Remove newlines between decoded words, though such - ;; things essentially must not be there. - (while (re-search-forward "[\n\r]+" nil t) - (replace-match " ")) - (setq end (point-max)) - ;; Quote decoded words if there are special characters - ;; which might violate RFC2822. - (when (and rfc2047-quote-decoded-words-containing-tspecials - (let ((regexp (car (rassq - 'address-mime - rfc2047-header-encoding-alist)))) - (when regexp - (save-restriction - (widen) - (and - ;; Don't quote words if already quoted. - (not (and (eq (char-before e) ?\") - (eq (char-after end) ?\"))) - (progn - (beginning-of-line) - (while (and (memq (char-after) '(? ?\t)) - (zerop (forward-line -1)))) - (looking-at regexp))))))) - (let (quoted) - (goto-char e) - (skip-chars-forward " \t") - (setq start (point)) - (setq quoted (eq (char-after) ?\")) - (goto-char (point-max)) - (skip-chars-backward " \t" start) - (if (setq quoted (and quoted - (> (point) (1+ start)) - (eq (char-before) ?\"))) - (progn - (backward-char) - (setq start (1+ start) - end (point-marker))) - (setq end (point-marker))) - (goto-char start) - (while (search-forward "\"" end t) - (when (prog2 - (backward-char) - (zerop (% (skip-chars-backward "\\\\") 2)) - (goto-char (match-beginning 0))) - (insert "\\")) - (forward-char)) - (when (and (not quoted) - (progn - (goto-char start) - (re-search-forward - (concat "[" ietf-drums-tspecials "]") - end t))) - (goto-char start) - (insert "\"") - (goto-char end) - (insert "\"")) - (set-marker end nil))) - (goto-char (point-max))) - (when (and (mm-multibyte-p) - mail-parse-charset - (not (eq mail-parse-charset 'us-ascii)) - (not (eq mail-parse-charset 'gnus-decoded))) - (mm-decode-coding-region b e mail-parse-charset)) - (setq b (point))) - (when (and (mm-multibyte-p) - mail-parse-charset - (not (eq mail-parse-charset 'us-ascii)) - (not (eq mail-parse-charset 'gnus-decoded))) - (mm-decode-coding-region b (point-max) mail-parse-charset)))))) - -(defun rfc2047-decode-address-region (start end) - "Decode MIME-encoded words in region between START and END. -Backslashes which precede characters other than `\"' and `\\' in quoted -strings are stripped." - (rfc2047-decode-region start end t)) - -(defun rfc2047-decode-string (string &optional address-mime) - "Decode MIME-encoded STRING and return the result. -If ADDRESS-MIME is non-nil, strip backslashes which precede characters -other than `\"' and `\\' in quoted strings." - ;; (let ((m (mm-multibyte-p))) - (if (string-match "=\\?" string) - (with-temp-buffer - ;; We used to only call mm-enable-multibyte if `m' is non-nil, - ;; but this can't be the right criterion. Don't just revert this - ;; change if it encounters a bug. Please help me fix it - ;; right instead. --Stef - ;; The string returned should always be multibyte in a multibyte - ;; session, i.e. the buffer should be multibyte before - ;; `buffer-string' is called. - (mm-enable-multibyte) - (insert string) - (inline - (rfc2047-decode-region (point-min) (point-max) address-mime)) - (buffer-string)) - (when address-mime - (setq string - (with-temp-buffer - (when (mm-multibyte-string-p string) - (mm-enable-multibyte)) - (insert string) - (rfc2047-strip-backslashes-in-quoted-strings) - (buffer-string)))) - ;; Fixme: As above, `m' here is inappropriate. - (if (and ;; m - mail-parse-charset - (not (eq mail-parse-charset 'us-ascii)) - (not (eq mail-parse-charset 'gnus-decoded))) - ;; `decode-coding-string' in Emacs offers a third optional - ;; arg NOCOPY to avoid consing a new string if the decoding - ;; is "trivial". Unfortunately it currently doesn't - ;; consider anything else than a nil coding system - ;; trivial. - ;; `rfc2047-decode-string' is called multiple times for each - ;; article during summary buffer generation, and we really - ;; want to avoid unnecessary consing. So we bypass - ;; `decode-coding-string' if the string is purely ASCII. - (if (and (fboundp 'detect-coding-string) - ;; string is purely ASCII - (eq (detect-coding-string string t) 'undecided)) - string - (mm-decode-coding-string string mail-parse-charset)) - (mm-string-to-multibyte string)))) ;; ) - -(defun rfc2047-decode-address-string (string) - "Decode MIME-encoded STRING and return the result. -Backslashes which precede characters other than `\"' and `\\' in quoted -strings are stripped." - (rfc2047-decode-string string t)) - -(defun rfc2047-pad-base64 (string) - "Pad STRING to quartets." - ;; Be more liberal to accept buggy base64 strings. If - ;; base64-decode-string accepts buggy strings, this function could - ;; be aliased to identity. - (if (= 0 (mod (length string) 4)) - string - (when (string-match "=+$" string) - (setq string (substring string 0 (match-beginning 0)))) - (case (mod (length string) 4) - (0 string) - (1 string) ;; Error, don't pad it. - (2 (concat string "==")) - (3 (concat string "="))))) - -(provide 'rfc2047) - -;;; rfc2047.el ends here diff --git a/lisp/gnus/rfc2231.el b/lisp/gnus/rfc2231.el deleted file mode 100644 index 95f8215b92b..00000000000 --- a/lisp/gnus/rfc2231.el +++ /dev/null @@ -1,307 +0,0 @@ -;;; rfc2231.el --- Functions for decoding rfc2231 headers - -;; Copyright (C) 1998-2017 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; 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 'ietf-drums) -(require 'rfc2047) -(autoload 'mm-encode-body "mm-bodies") -(autoload 'mail-header-remove-whitespace "mail-parse") -(autoload 'mail-header-remove-comments "mail-parse") - -(defun rfc2231-get-value (ct attribute) - "Return the value of ATTRIBUTE from CT." - (cdr (assq attribute (cdr ct)))) - -(defun rfc2231-parse-qp-string (string) - "Parse QP-encoded string using `rfc2231-parse-string'. -N.B. This is in violation with RFC2047, but it seem to be in common use." - (rfc2231-parse-string (rfc2047-decode-string string))) - -(defun rfc2231-parse-string (string &optional signal-error) - "Parse STRING and return a list. -The list will be on the form - `(name (attribute . value) (attribute . value)...)'. - -If the optional SIGNAL-ERROR is non-nil, signal an error when this -function fails in parsing of parameters. Otherwise, this function -must never cause a Lisp error." - (with-temp-buffer - (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token)) - (stoken (ietf-drums-token-to-list ietf-drums-tspecials)) - (ntoken (ietf-drums-token-to-list "0-9")) - c type attribute encoded number parameters value) - (ietf-drums-init - (condition-case nil - (mail-header-remove-whitespace - (mail-header-remove-comments string)) - ;; The most likely cause of an error is unbalanced parentheses - ;; or double-quotes. If all parentheses and double-quotes are - ;; quoted meaninglessly with backslashes, removing them might - ;; make it parsable. Let's try... - (error - (let (mod) - (when (and (string-match "\\\\\"" string) - (not (string-match "\\`\"\\|[^\\]\"" string))) - (setq string (mm-replace-in-string string "\\\\\"" "\"") - mod t)) - (when (and (string-match "\\\\(" string) - (string-match "\\\\)" string) - (not (string-match "\\`(\\|[^\\][()]" string))) - (setq string (mm-replace-in-string string "\\\\\\([()]\\)" "\\1") - mod t)) - (or (and mod - (ignore-errors - (mail-header-remove-whitespace - (mail-header-remove-comments string)))) - ;; Finally, attempt to extract only type. - (if (string-match - (concat "\\`[\t\n ]*\\([^" ietf-drums-tspecials "\t\n ]+" - "\\(?:/[^" ietf-drums-tspecials - "\t\n ]+\\)?\\)\\(?:[\t\n ;]\\|\\'\\)") - string) - (match-string 1 string) - "")))))) - (let ((table (copy-syntax-table ietf-drums-syntax-table))) - (modify-syntax-entry ?\' "w" table) - (modify-syntax-entry ?* " " table) - (modify-syntax-entry ?\; " " table) - (modify-syntax-entry ?= " " table) - ;; The following isn't valid, but one should be liberal - ;; in what one receives. - (modify-syntax-entry ?\: "w" table) - (set-syntax-table table)) - (setq c (char-after)) - (when (and (memq c ttoken) - (not (memq c stoken)) - (setq type (ignore-errors - (downcase - (buffer-substring (point) (progn - (forward-sexp 1) - (point))))))) - ;; Do the params - (condition-case err - (progn - (while (not (eobp)) - (setq c (char-after)) - (unless (eq c ?\;) - (error "Invalid header: %s" string)) - (forward-char 1) - ;; If c in nil, then this is an invalid header, but - ;; since elm generates invalid headers on this form, - ;; we allow it. - (when (setq c (char-after)) - (if (and (memq c ttoken) - (not (memq c stoken))) - (setq attribute - (intern - (downcase - (buffer-substring - (point) (progn (forward-sexp 1) (point)))))) - (error "Invalid header: %s" string)) - (setq c (char-after)) - (if (eq c ?*) - (progn - (forward-char 1) - (setq c (char-after)) - (if (not (memq c ntoken)) - (setq encoded t - number nil) - (setq number - (string-to-number - (buffer-substring - (point) (progn (forward-sexp 1) (point))))) - (setq c (char-after)) - (when (eq c ?*) - (setq encoded t) - (forward-char 1) - (setq c (char-after))))) - (setq number nil - encoded nil)) - (unless (eq c ?=) - (error "Invalid header: %s" string)) - (forward-char 1) - (setq c (char-after)) - (cond - ((eq c ?\") - (setq value (buffer-substring (1+ (point)) - (progn - (forward-sexp 1) - (1- (point))))) - (when encoded - (setq value (mapconcat (lambda (c) (format "%%%02x" c)) - value "")))) - ((and (or (memq c ttoken) - ;; EXTENSION: Support non-ascii chars. - (> c ?\177)) - (not (memq c stoken))) - (setq value - (buffer-substring - (point) - (progn - ;; Jump over asterisk, non-ASCII - ;; and non-boundary characters. - (while (and c - (or (eq c ?*) - (> c ?\177) - (not (eq (char-syntax c) ? )))) - (forward-char 1) - (setq c (char-after))) - (point))))) - (t - (error "Invalid header: %s" string))) - (push (list attribute value number encoded) - parameters)))) - (error - (setq parameters nil) - (when signal-error - (signal (car err) (cdr err))))) - - ;; Now collect and concatenate continuation parameters. - (let ((cparams nil) - elem) - (loop for (attribute value part encoded) - in (sort parameters (lambda (e1 e2) - (< (or (caddr e1) 0) - (or (caddr e2) 0)))) - do (cond - ;; First part. - ((or (not (setq elem (assq attribute cparams))) - (and (numberp part) - (zerop part))) - (push (list attribute value encoded) cparams)) - ;; Repetition of a part; do nothing. - ((and elem - (null number)) - ) - ;; Concatenate continuation parts. - (t - (setcar (cdr elem) (concat (cadr elem) value))))) - ;; Finally decode encoded values. - (cons type (mapcar - (lambda (elem) - (cons (car elem) - (if (nth 2 elem) - (rfc2231-decode-encoded-string (nth 1 elem)) - (nth 1 elem)))) - (nreverse cparams)))))))) - -(defun rfc2231-decode-encoded-string (string) - "Decode an RFC2231-encoded string. -These look like: - \"us-ascii\\='en-us\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", - \"us-ascii\\='\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", - \"\\='en-us\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", - \"\\='\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", or - \"This is ***fun***\"." - (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string) - (let ((coding-system (mm-charset-to-coding-system - (match-string 1 string) nil t)) - ;;(language (match-string 2 string)) - (value (match-string 3 string))) - (mm-with-unibyte-buffer - (insert value) - (goto-char (point-min)) - (while (re-search-forward "%\\([0-9A-Fa-f][0-9A-Fa-f]\\)" nil t) - (insert - (prog1 - (string-to-number (match-string 1) 16) - (delete-region (match-beginning 0) (match-end 0))))) - ;; Decode using the charset, if any. - (if (memq coding-system '(nil ascii)) - (buffer-string) - (mm-decode-coding-string (buffer-string) coding-system))))) - -(defun rfc2231-encode-string (param value) - "Return and PARAM=VALUE string encoded according to RFC2231. -Use `mml-insert-parameter' or `mml-insert-parameter-string' to insert -the result of this function." - (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token)) - (tspecial (ietf-drums-token-to-list ietf-drums-tspecials)) - (special (ietf-drums-token-to-list "*'%\n\t")) - (ascii (ietf-drums-token-to-list ietf-drums-text-token)) - (num -1) - ;; Don't make lines exceeding 76 column. - (limit (- 74 (length param))) - spacep encodep charsetp charset broken) - (mm-with-multibyte-buffer - (insert value) - (goto-char (point-min)) - (while (not (eobp)) - (cond - ((or (memq (following-char) control) - (memq (following-char) tspecial) - (memq (following-char) special)) - (setq encodep t)) - ((eq (following-char) ? ) - (setq spacep t)) - ((not (memq (following-char) ascii)) - (setq charsetp t))) - (forward-char 1)) - (when charsetp - (setq charset (mm-encode-body))) - (mm-disable-multibyte) - (cond - ((or encodep charsetp - (progn - (end-of-line) - (> (current-column) (if spacep (- limit 2) limit)))) - (setq limit (- limit 6)) - (goto-char (point-min)) - (insert (symbol-name (or charset 'us-ascii)) "''") - (while (not (eobp)) - (if (or (not (memq (following-char) ascii)) - (memq (following-char) control) - (memq (following-char) tspecial) - (memq (following-char) special) - (eq (following-char) ? )) - (progn - (when (>= (current-column) (1- limit)) - (insert ";\n") - (setq broken t)) - (insert "%" (format "%02x" (following-char))) - (delete-char 1)) - (when (> (current-column) limit) - (insert ";\n") - (setq broken t)) - (forward-char 1))) - (goto-char (point-min)) - (if (not broken) - (insert param "*=") - (while (not (eobp)) - (insert (if (>= num 0) " " "") - param "*" (format "%d" (incf num)) "*=") - (forward-line 1)))) - (spacep - (goto-char (point-min)) - (insert param "=\"") - (goto-char (point-max)) - (insert "\"")) - (t - (goto-char (point-min)) - (insert param "="))) - (buffer-string)))) - -(provide 'rfc2231) - -;;; rfc2231.el ends here diff --git a/lisp/gnus/rtree.el b/lisp/gnus/rtree.el deleted file mode 100644 index b4c9d48b83c..00000000000 --- a/lisp/gnus/rtree.el +++ /dev/null @@ -1,281 +0,0 @@ -;;; rtree.el --- functions for manipulating range trees - -;; Copyright (C) 2010-2017 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> - -;; 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: - -;; A "range tree" is a binary tree that stores ranges. They are -;; similar to interval trees, but do not allow overlapping intervals. - -;; A range is an ordered list of number intervals, like this: - -;; ((10 . 25) 56 78 (98 . 201)) - -;; Common operations, like lookup, deletion and insertion are O(n) in -;; a range, but an rtree is O(log n) in all these operations. -;; Transformation between a range and an rtree is O(n). - -;; The rtrees are quite simple. The structure of each node is - -;; (cons (cons low high) (cons left right)) - -;; That is, they are three cons cells, where the car of the top cell -;; is the actual range, and the cdr has the left and right child. The -;; rtrees aren't automatically balanced, but are balanced when -;; created, and can be rebalanced when deemed necessary. - -;;; Code: - -(eval-when-compile - (require 'cl)) - -(defmacro rtree-make-node () - `(list (list nil) nil)) - -(defmacro rtree-set-left (node left) - `(setcar (cdr ,node) ,left)) - -(defmacro rtree-set-right (node right) - `(setcdr (cdr ,node) ,right)) - -(defmacro rtree-set-range (node range) - `(setcar ,node ,range)) - -(defmacro rtree-low (node) - `(caar ,node)) - -(defmacro rtree-high (node) - `(cdar ,node)) - -(defmacro rtree-set-low (node number) - `(setcar (car ,node) ,number)) - -(defmacro rtree-set-high (node number) - `(setcdr (car ,node) ,number)) - -(defmacro rtree-left (node) - `(cadr ,node)) - -(defmacro rtree-right (node) - `(cddr ,node)) - -(defmacro rtree-range (node) - `(car ,node)) - -(defsubst rtree-normalize-range (range) - (when (numberp range) - (setq range (cons range range))) - range) - -(define-obsolete-function-alias 'rtree-normalise-range - 'rtree-normalize-range "25.1") - -(defun rtree-make (range) - "Make an rtree from RANGE." - ;; Normalize the range. - (unless (listp (cdr-safe range)) - (setq range (list range))) - (rtree-make-1 (cons nil range) (length range))) - -(defun rtree-make-1 (range length) - (let ((mid (/ length 2)) - (node (rtree-make-node))) - (when (> mid 0) - (rtree-set-left node (rtree-make-1 range mid))) - (rtree-set-range node (rtree-normalize-range (cadr range))) - (setcdr range (cddr range)) - (when (> (- length mid 1) 0) - (rtree-set-right node (rtree-make-1 range (- length mid 1)))) - node)) - -(defun rtree-memq (tree number) - "Return non-nil if NUMBER is present in TREE." - (while (and tree - (not (and (>= number (rtree-low tree)) - (<= number (rtree-high tree))))) - (setq tree - (if (< number (rtree-low tree)) - (rtree-left tree) - (rtree-right tree)))) - tree) - -(defun rtree-add (tree number) - "Add NUMBER to TREE." - (while tree - (cond - ;; It's already present, so we don't have to do anything. - ((and (>= number (rtree-low tree)) - (<= number (rtree-high tree))) - (setq tree nil)) - ((< number (rtree-low tree)) - (cond - ;; Extend the low range. - ((= number (1- (rtree-low tree))) - (rtree-set-low tree number) - ;; Check whether we need to merge this node with the child. - (when (and (rtree-left tree) - (= (rtree-high (rtree-left tree)) (1- number))) - ;; Extend the range to the low from the child. - (rtree-set-low tree (rtree-low (rtree-left tree))) - ;; The child can't have a right child, so just transplant the - ;; child's left tree to our left tree. - (rtree-set-left tree (rtree-left (rtree-left tree)))) - (setq tree nil)) - ;; Descend further to the left. - ((rtree-left tree) - (setq tree (rtree-left tree))) - ;; Add a new node. - (t - (let ((new-node (rtree-make-node))) - (rtree-set-low new-node number) - (rtree-set-high new-node number) - (rtree-set-left tree new-node) - (setq tree nil))))) - (t - (cond - ;; Extend the high range. - ((= number (1+ (rtree-high tree))) - (rtree-set-high tree number) - ;; Check whether we need to merge this node with the child. - (when (and (rtree-right tree) - (= (rtree-low (rtree-right tree)) (1+ number))) - ;; Extend the range to the high from the child. - (rtree-set-high tree (rtree-high (rtree-right tree))) - ;; The child can't have a left child, so just transplant the - ;; child's left right to our right tree. - (rtree-set-right tree (rtree-right (rtree-right tree)))) - (setq tree nil)) - ;; Descend further to the right. - ((rtree-right tree) - (setq tree (rtree-right tree))) - ;; Add a new node. - (t - (let ((new-node (rtree-make-node))) - (rtree-set-low new-node number) - (rtree-set-high new-node number) - (rtree-set-right tree new-node) - (setq tree nil)))))))) - -(defun rtree-delq (tree number) - "Remove NUMBER from TREE destructively. Returns the new tree." - (let ((result tree) - prev) - (while tree - (cond - ((< number (rtree-low tree)) - (setq prev tree - tree (rtree-left tree))) - ((> number (rtree-high tree)) - (setq prev tree - tree (rtree-right tree))) - ;; The number is in this node. - (t - (cond - ;; The only entry; delete the node. - ((= (rtree-low tree) (rtree-high tree)) - (cond - ;; Two children. Replace with successor value. - ((and (rtree-left tree) (rtree-right tree)) - (let ((parent tree) - (successor (rtree-right tree))) - (while (rtree-left successor) - (setq parent successor - successor (rtree-left successor))) - ;; We now have the leftmost child of our right child. - (rtree-set-range tree (rtree-range successor)) - ;; Transplant the child (if any) to the parent. - (rtree-set-left parent (rtree-right successor)))) - (t - (let ((rest (or (rtree-left tree) - (rtree-right tree)))) - ;; One or zero children. Remove the node. - (cond - ((null prev) - (setq result rest)) - ((eq (rtree-left prev) tree) - (rtree-set-left prev rest)) - (t - (rtree-set-right prev rest))))))) - ;; The lowest in the range; just adjust. - ((= number (rtree-low tree)) - (rtree-set-low tree (1+ number))) - ;; The highest in the range; just adjust. - ((= number (rtree-high tree)) - (rtree-set-high tree (1- number))) - ;; We have to split this range. - (t - (let ((new-node (rtree-make-node))) - (rtree-set-low new-node (rtree-low tree)) - (rtree-set-high new-node (1- number)) - (rtree-set-low tree (1+ number)) - (cond - ;; Two children; insert the new node as the predecessor - ;; node. - ((and (rtree-left tree) (rtree-right tree)) - (let ((predecessor (rtree-left tree))) - (while (rtree-right predecessor) - (setq predecessor (rtree-right predecessor))) - (rtree-set-right predecessor new-node))) - ((rtree-left tree) - (rtree-set-right new-node tree) - (rtree-set-left new-node (rtree-left tree)) - (rtree-set-left tree nil) - (cond - ((null prev) - (setq result new-node)) - ((eq (rtree-left prev) tree) - (rtree-set-left prev new-node)) - (t - (rtree-set-right prev new-node)))) - (t - (rtree-set-left tree new-node)))))) - (setq tree nil)))) - result)) - -(defun rtree-extract (tree) - "Convert TREE to range form." - (let (stack result) - (while (or stack - tree) - (if tree - (progn - (push tree stack) - (setq tree (rtree-right tree))) - (setq tree (pop stack)) - (push (if (= (rtree-low tree) - (rtree-high tree)) - (rtree-low tree) - (rtree-range tree)) - result) - (setq tree (rtree-left tree)))) - result)) - -(defun rtree-length (tree) - "Return the number of numbers stored in TREE." - (if (null tree) - 0 - (+ (rtree-length (rtree-left tree)) - (1+ (- (rtree-high tree) - (rtree-low tree))) - (rtree-length (rtree-right tree))))) - -(provide 'rtree) - -;;; rtree.el ends here diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el index 622e65c541e..d106cf0c271 100644 --- a/lisp/gnus/score-mode.el +++ b/lisp/gnus/score-mode.el @@ -28,14 +28,20 @@ (require 'mm-util) ; for mm-universal-coding-system (require 'gnus-util) ; for gnus-pp, gnus-run-mode-hooks -(defvar gnus-score-edit-done-hook nil - "*Hook run at the end of closing the score buffer.") - -(defvar gnus-score-mode-hook nil - "*Hook run in score mode buffers.") - -(defvar gnus-score-menu-hook nil - "*Hook run after creating the score mode menu.") +(defcustom gnus-score-edit-done-hook nil + "Hook run at the end of closing the score buffer." + :group 'gnus-score + :type 'hook) + +(defcustom gnus-score-mode-hook nil + "Hook run in score mode buffers." + :group 'gnus-score + :type 'hook) + +(defcustom gnus-score-menu-hook nil + "Hook run after creating the score mode menu." + :group 'gnus-score + :type 'hook) (defvar gnus-score-edit-exit-function nil "Function run on exit from the score buffer.") diff --git a/lisp/gnus/sieve-manage.el b/lisp/gnus/sieve-manage.el deleted file mode 100644 index d0fad75afac..00000000000 --- a/lisp/gnus/sieve-manage.el +++ /dev/null @@ -1,576 +0,0 @@ -;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp - -;; Copyright (C) 2001-2017 Free Software Foundation, Inc. - -;; Author: Simon Josefsson <simon@josefsson.org> -;; Albert Krewinkel <tarleb@moltkeplatz.de> - -;; 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: - -;; This library provides an elisp API for the managesieve network -;; protocol. -;; -;; It uses the SASL library for authentication, which means it -;; supports DIGEST-MD5, CRAM-MD5, SCRAM-MD5, NTLM, PLAIN and LOGIN -;; methods. STARTTLS is not well tested, but should be easy to get to -;; work if someone wants. -;; -;; The API should be fairly obvious for anyone familiar with the -;; managesieve protocol, interface functions include: -;; -;; `sieve-manage-open' -;; open connection to managesieve server, returning a buffer to be -;; used by all other API functions. -;; -;; `sieve-manage-opened' -;; check if a server is open or not -;; -;; `sieve-manage-close' -;; close a server connection. -;; -;; `sieve-manage-listscripts' -;; `sieve-manage-deletescript' -;; `sieve-manage-getscript' -;; performs managesieve protocol actions -;; -;; and that's it. Example of a managesieve session in *scratch*: -;; -;; (with-current-buffer (sieve-manage-open "mail.example.com") -;; (sieve-manage-authenticate) -;; (sieve-manage-listscripts)) -;; -;; => ((active . "main") "vacation") -;; -;; References: -;; -;; draft-martin-managesieve-02.txt, -;; "A Protocol for Remotely Managing Sieve Scripts", -;; by Tim Martin. -;; -;; Release history: -;; -;; 2001-10-31 Committed to Oort Gnus. -;; 2002-07-27 Added DELETESCRIPT. Suggested by Ned Ludd. -;; 2002-08-03 Use SASL library. -;; 2013-06-05 Enabled STARTTLS support, fixed bit rot. - -;;; Code: - -(if (locate-library "password-cache") - (require 'password-cache) - (require 'password)) - -(eval-when-compile - (require 'cl) ; caddr - (require 'sasl) - (require 'starttls)) -(autoload 'sasl-find-mechanism "sasl") -(autoload 'auth-source-search "auth-source") - -;; User customizable variables: - -(defgroup sieve-manage nil - "Low-level Managesieve protocol issues." - :group 'mail - :prefix "sieve-") - -(defcustom sieve-manage-log "*sieve-manage-log*" - "Name of buffer for managesieve session trace." - :type 'string - :group 'sieve-manage) - -(defcustom sieve-manage-server-eol "\r\n" - "The EOL string sent from the server." - :type 'string - :group 'sieve-manage) - -(defcustom sieve-manage-client-eol "\r\n" - "The EOL string we send to the server." - :type 'string - :group 'sieve-manage) - -(defcustom sieve-manage-authenticators '(digest-md5 - cram-md5 - scram-md5 - ntlm - plain - login) - "Priority of authenticators to consider when authenticating to server." - ;; FIXME Improve this. It's not `set'. - ;; It's like (repeat (choice (const ...))), where each choice can - ;; only appear once. - :type '(repeat symbol) - :group 'sieve-manage) - -(defcustom sieve-manage-authenticator-alist - '((cram-md5 sieve-manage-cram-md5-p sieve-manage-cram-md5-auth) - (digest-md5 sieve-manage-digest-md5-p sieve-manage-digest-md5-auth) - (scram-md5 sieve-manage-scram-md5-p sieve-manage-scram-md5-auth) - (ntlm sieve-manage-ntlm-p sieve-manage-ntlm-auth) - (plain sieve-manage-plain-p sieve-manage-plain-auth) - (login sieve-manage-login-p sieve-manage-login-auth)) - "Definition of authenticators. - -\(NAME CHECK AUTHENTICATE) - -NAME names the authenticator. CHECK is a function returning non-nil if -the server support the authenticator and AUTHENTICATE is a function -for doing the actual authentication." - :type '(repeat (list (symbol :tag "Name") (function :tag "Check function") - (function :tag "Authentication function"))) - :group 'sieve-manage) - -(defcustom sieve-manage-default-port "sieve" - "Default port number or service name for managesieve protocol." - :type '(choice integer string) - :version "24.4" - :group 'sieve-manage) - -(defcustom sieve-manage-default-stream 'network - "Default stream type to use for `sieve-manage'." - :version "24.1" - :type 'symbol - :group 'sieve-manage) - -;; Internal variables: - -(defconst sieve-manage-local-variables '(sieve-manage-server - sieve-manage-port - sieve-manage-auth - sieve-manage-stream - sieve-manage-process - sieve-manage-client-eol - sieve-manage-server-eol - sieve-manage-capability)) -(defconst sieve-manage-coding-system-for-read 'binary) -(defconst sieve-manage-coding-system-for-write 'binary) -(defvar sieve-manage-stream nil) -(defvar sieve-manage-auth nil) -(defvar sieve-manage-server nil) -(defvar sieve-manage-port nil) -(defvar sieve-manage-state 'closed - "Managesieve state. -Valid states are `closed', `initial', `nonauth', and `auth'.") -(defvar sieve-manage-process nil) -(defvar sieve-manage-capability nil) - -;; Internal utility functions -(autoload 'mm-enable-multibyte "mm-util") - -(defun sieve-manage-make-process-buffer () - (with-current-buffer - (generate-new-buffer (format " *sieve %s:%s*" - sieve-manage-server - sieve-manage-port)) - (mapc 'make-local-variable sieve-manage-local-variables) - (mm-enable-multibyte) - (buffer-disable-undo) - (current-buffer))) - -(defun sieve-manage-erase (&optional p buffer) - (let ((buffer (or buffer (current-buffer)))) - (and sieve-manage-log - (with-current-buffer (get-buffer-create sieve-manage-log) - (mm-enable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer (with-current-buffer buffer - (point-min)) - (or p (with-current-buffer buffer - (point-max))))))) - (delete-region (point-min) (or p (point-max)))) - -(defun sieve-manage-open-server (server port &optional stream buffer) - "Open network connection to SERVER on PORT. -Return the buffer associated with the connection." - (with-current-buffer buffer - (sieve-manage-erase) - (setq sieve-manage-state 'initial) - (destructuring-bind (proc . props) - (open-protocol-stream - "SIEVE" buffer server port - :type stream - :capability-command "CAPABILITY\r\n" - :end-of-command "^\\(OK\\|NO\\).*\n" - :success "^OK.*\n" - :return-list t - :starttls-function - (lambda (capabilities) - (when (string-match "\\bSTARTTLS\\b" capabilities) - "STARTTLS\r\n"))) - (setq sieve-manage-process proc) - (setq sieve-manage-capability - (sieve-manage-parse-capability (plist-get props :capabilities))) - ;; Ignore new capabilities issues after successful STARTTLS - (when (and (memq stream '(nil network starttls)) - (eq (plist-get props :type) 'tls)) - (sieve-manage-drop-next-answer)) - (current-buffer)))) - -;; Authenticators -(defun sieve-sasl-auth (buffer mech) - "Login to server using the SASL MECH method." - (message "sieve: Authenticating using %s..." mech) - (with-current-buffer buffer - (let* ((auth-info (auth-source-search :host sieve-manage-server - :port "sieve" - :max 1 - :create t)) - (user-name (or (plist-get (nth 0 auth-info) :user) "")) - (user-password (or (plist-get (nth 0 auth-info) :secret) "")) - (user-password (if (functionp user-password) - (funcall user-password) - user-password)) - (client (sasl-make-client (sasl-find-mechanism (list mech)) - user-name "sieve" sieve-manage-server)) - (sasl-read-passphrase - ;; We *need* to copy the password, because sasl will modify it - ;; somehow. - `(lambda (prompt) ,(copy-sequence user-password))) - (step (sasl-next-step client nil)) - (tag (sieve-manage-send - (concat - "AUTHENTICATE \"" - mech - "\"" - (and (sasl-step-data step) - (concat - " \"" - (base64-encode-string - (sasl-step-data step) - 'no-line-break) - "\""))))) - data rsp) - (catch 'done - (while t - (setq rsp nil) - (goto-char (point-min)) - (while (null (or (progn - (setq rsp (sieve-manage-is-string)) - (if (not (and rsp (looking-at - sieve-manage-server-eol))) - (setq rsp nil) - (goto-char (match-end 0)) - rsp)) - (setq rsp (sieve-manage-is-okno)))) - (accept-process-output sieve-manage-process 1) - (goto-char (point-min))) - (sieve-manage-erase) - (when (sieve-manage-ok-p rsp) - (when (and (cadr rsp) - (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp))) - (sasl-step-set-data - step (base64-decode-string (match-string 1 (cadr rsp))))) - (if (and (setq step (sasl-next-step client step)) - (setq data (sasl-step-data step))) - ;; We got data for server but it's finished - (error "Server not ready for SASL data: %s" data) - ;; The authentication process is finished. - (throw 'done t))) - (unless (stringp rsp) - (error "Server aborted SASL authentication: %s" (caddr rsp))) - (sasl-step-set-data step (base64-decode-string rsp)) - (setq step (sasl-next-step client step)) - (sieve-manage-send - (if (sasl-step-data step) - (concat "\"" - (base64-encode-string (sasl-step-data step) - 'no-line-break) - "\"") - "")))) - (message "sieve: Login using %s...done" mech)))) - -(defun sieve-manage-cram-md5-p (buffer) - (sieve-manage-capability "SASL" "CRAM-MD5" buffer)) - -(defun sieve-manage-cram-md5-auth (buffer) - "Login to managesieve server using the CRAM-MD5 SASL method." - (sieve-sasl-auth buffer "CRAM-MD5")) - -(defun sieve-manage-digest-md5-p (buffer) - (sieve-manage-capability "SASL" "DIGEST-MD5" buffer)) - -(defun sieve-manage-digest-md5-auth (buffer) - "Login to managesieve server using the DIGEST-MD5 SASL method." - (sieve-sasl-auth buffer "DIGEST-MD5")) - -(defun sieve-manage-scram-md5-p (buffer) - (sieve-manage-capability "SASL" "SCRAM-MD5" buffer)) - -(defun sieve-manage-scram-md5-auth (buffer) - "Login to managesieve server using the SCRAM-MD5 SASL method." - (sieve-sasl-auth buffer "SCRAM-MD5")) - -(defun sieve-manage-ntlm-p (buffer) - (sieve-manage-capability "SASL" "NTLM" buffer)) - -(defun sieve-manage-ntlm-auth (buffer) - "Login to managesieve server using the NTLM SASL method." - (sieve-sasl-auth buffer "NTLM")) - -(defun sieve-manage-plain-p (buffer) - (sieve-manage-capability "SASL" "PLAIN" buffer)) - -(defun sieve-manage-plain-auth (buffer) - "Login to managesieve server using the PLAIN SASL method." - (sieve-sasl-auth buffer "PLAIN")) - -(defun sieve-manage-login-p (buffer) - (sieve-manage-capability "SASL" "LOGIN" buffer)) - -(defun sieve-manage-login-auth (buffer) - "Login to managesieve server using the LOGIN SASL method." - (sieve-sasl-auth buffer "LOGIN")) - -;; Managesieve API - -(defun sieve-manage-open (server &optional port stream auth buffer) - "Open a network connection to a managesieve SERVER (string). -Optional argument PORT is port number (integer) on remote server. -Optional argument STREAM is any of `sieve-manage-streams' (a symbol). -Optional argument AUTH indicates authenticator to use, see -`sieve-manage-authenticators' for available authenticators. -If nil, chooses the best stream the server is capable of. -Optional argument BUFFER is buffer (buffer, or string naming buffer) -to work in." - (setq sieve-manage-port (or port sieve-manage-default-port)) - (with-current-buffer (or buffer (sieve-manage-make-process-buffer)) - (setq sieve-manage-server (or server - sieve-manage-server) - sieve-manage-stream (or stream - sieve-manage-stream - sieve-manage-default-stream) - sieve-manage-auth (or auth - sieve-manage-auth)) - (message "sieve: Connecting to %s..." sieve-manage-server) - (sieve-manage-open-server sieve-manage-server - sieve-manage-port - sieve-manage-stream - (current-buffer)) - (when (sieve-manage-opened (current-buffer)) - ;; Choose authenticator - (when (and (null sieve-manage-auth) - (not (eq sieve-manage-state 'auth))) - (dolist (auth sieve-manage-authenticators) - (when (funcall (nth 1 (assq auth sieve-manage-authenticator-alist)) - buffer) - (setq sieve-manage-auth auth) - (return))) - (unless sieve-manage-auth - (error "Couldn't figure out authenticator for server"))) - (sieve-manage-erase) - (current-buffer)))) - -(defun sieve-manage-authenticate (&optional buffer) - "Authenticate on server in BUFFER. -Return `sieve-manage-state' value." - (with-current-buffer (or buffer (current-buffer)) - (if (eq sieve-manage-state 'nonauth) - (when (funcall (nth 2 (assq sieve-manage-auth - sieve-manage-authenticator-alist)) - (current-buffer)) - (setq sieve-manage-state 'auth)) - sieve-manage-state))) - -(defun sieve-manage-opened (&optional buffer) - "Return non-nil if connection to managesieve server in BUFFER is open. -If BUFFER is nil then the current buffer is used." - (and (setq buffer (get-buffer (or buffer (current-buffer)))) - (buffer-live-p buffer) - (with-current-buffer buffer - (and sieve-manage-process - (memq (process-status sieve-manage-process) '(open run)))))) - -(defun sieve-manage-close (&optional buffer) - "Close connection to managesieve server in BUFFER. -If BUFFER is nil, the current buffer is used." - (with-current-buffer (or buffer (current-buffer)) - (when (sieve-manage-opened) - (sieve-manage-send "LOGOUT") - (sit-for 1)) - (when (and sieve-manage-process - (memq (process-status sieve-manage-process) '(open run))) - (delete-process sieve-manage-process)) - (setq sieve-manage-process nil) - (sieve-manage-erase) - t)) - -(defun sieve-manage-capability (&optional name value buffer) - "Check if capability NAME of server BUFFER match VALUE. -If it does, return the server value of NAME. If not returns nil. -If VALUE is nil, do not check VALUE and return server value. -If NAME is nil, return the full server list of capabilities." - (with-current-buffer (or buffer (current-buffer)) - (if (null name) - sieve-manage-capability - (let ((server-value (cadr (assoc name sieve-manage-capability)))) - (when (or (null value) - (and server-value - (string-match value server-value))) - server-value))))) - -(defun sieve-manage-listscripts (&optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (sieve-manage-send "LISTSCRIPTS") - (sieve-manage-parse-listscripts))) - -(defun sieve-manage-havespace (name size &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (sieve-manage-send (format "HAVESPACE \"%s\" %s" name size)) - (sieve-manage-parse-okno))) - -(defun sieve-manage-putscript (name content &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (sieve-manage-send (format "PUTSCRIPT \"%s\" {%d+}%s%s" name - ;; Here we assume that the coding-system will - ;; replace each char with a single byte. - ;; This is always the case if `content' is - ;; a unibyte string. - (length content) - sieve-manage-client-eol content)) - (sieve-manage-parse-okno))) - -(defun sieve-manage-deletescript (name &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (sieve-manage-send (format "DELETESCRIPT \"%s\"" name)) - (sieve-manage-parse-okno))) - -(defun sieve-manage-getscript (name output-buffer &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (sieve-manage-send (format "GETSCRIPT \"%s\"" name)) - (let ((script (sieve-manage-parse-string))) - (sieve-manage-parse-crlf) - (with-current-buffer output-buffer - (insert script)) - (sieve-manage-parse-okno)))) - -(defun sieve-manage-setactive (name &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (sieve-manage-send (format "SETACTIVE \"%s\"" name)) - (sieve-manage-parse-okno))) - -;; Protocol parsing routines - -(defun sieve-manage-wait-for-answer () - (let ((pattern "^\\(OK\\|NO\\).*\n") - pos) - (while (not pos) - (setq pos (search-forward-regexp pattern nil t)) - (goto-char (point-min)) - (sleep-for 0 50)) - pos)) - -(defun sieve-manage-drop-next-answer () - (sieve-manage-wait-for-answer) - (sieve-manage-erase)) - -(defun sieve-manage-ok-p (rsp) - (string= (downcase (or (car-safe rsp) "")) "ok")) - -(defun sieve-manage-is-okno () - (when (looking-at (concat - "^\\(OK\\|NO\\)\\( (\\([^)]+\\))\\)?\\( \\(.*\\)\\)?" - sieve-manage-server-eol)) - (let ((status (match-string 1)) - (resp-code (match-string 3)) - (response (match-string 5))) - (when response - (goto-char (match-beginning 5)) - (setq response (sieve-manage-is-string))) - (list status resp-code response)))) - -(defun sieve-manage-parse-okno () - (let (rsp) - (while (null rsp) - (accept-process-output (get-buffer-process (current-buffer)) 1) - (goto-char (point-min)) - (setq rsp (sieve-manage-is-okno))) - (sieve-manage-erase) - rsp)) - -(defun sieve-manage-parse-capability (str) - "Parse managesieve capability string `STR'. -Set variable `sieve-manage-capability' to " - (let ((capas (delq nil - (mapcar #'split-string-and-unquote - (split-string str "\n"))))) - (when (string= "OK" (caar (last capas))) - (setq sieve-manage-state 'nonauth)) - capas)) - -(defun sieve-manage-is-string () - (cond ((looking-at "\"\\([^\"]+\\)\"") - (prog1 - (match-string 1) - (goto-char (match-end 0)))) - ((looking-at (concat "{\\([0-9]+\\+?\\)}" sieve-manage-server-eol)) - (let ((pos (match-end 0)) - (len (string-to-number (match-string 1)))) - (if (< (point-max) (+ pos len)) - nil - (goto-char (+ pos len)) - (buffer-substring pos (+ pos len))))))) - -(defun sieve-manage-parse-string () - (let (rsp) - (while (null rsp) - (accept-process-output (get-buffer-process (current-buffer)) 1) - (goto-char (point-min)) - (setq rsp (sieve-manage-is-string))) - (sieve-manage-erase (point)) - rsp)) - -(defun sieve-manage-parse-crlf () - (when (looking-at sieve-manage-server-eol) - (sieve-manage-erase (match-end 0)))) - -(defun sieve-manage-parse-listscripts () - (let (tmp rsp data) - (while (null rsp) - (while (null (or (setq rsp (sieve-manage-is-okno)) - (setq tmp (sieve-manage-is-string)))) - (accept-process-output (get-buffer-process (current-buffer)) 1) - (goto-char (point-min))) - (when tmp - (while (not (looking-at (concat "\\( ACTIVE\\)?" - sieve-manage-server-eol))) - (accept-process-output (get-buffer-process (current-buffer)) 1) - (goto-char (point-min))) - (if (match-string 1) - (push (cons 'active tmp) data) - (push tmp data)) - (goto-char (match-end 0)) - (setq tmp nil))) - (sieve-manage-erase) - (if (sieve-manage-ok-p rsp) - data - rsp))) - -(defun sieve-manage-send (cmdstr) - (setq cmdstr (concat cmdstr sieve-manage-client-eol)) - (and sieve-manage-log - (with-current-buffer (get-buffer-create sieve-manage-log) - (mm-enable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert cmdstr))) - (process-send-string sieve-manage-process cmdstr)) - -(provide 'sieve-manage) - -;; sieve-manage.el ends here diff --git a/lisp/gnus/sieve-mode.el b/lisp/gnus/sieve-mode.el deleted file mode 100644 index 9d916639331..00000000000 --- a/lisp/gnus/sieve-mode.el +++ /dev/null @@ -1,222 +0,0 @@ -;;; sieve-mode.el --- Sieve code editing commands for Emacs - -;; Copyright (C) 2001-2017 Free Software Foundation, Inc. - -;; Author: Simon Josefsson <simon@josefsson.org> - -;; 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: - -;; This file contain editing mode functions and font-lock support for -;; editing Sieve scripts. It sets up C-mode with support for -;; sieve-style #-comments and a lightly hacked syntax table. It was -;; strongly influenced by awk-mode.el. -;; -;; Put something similar to the following in your .emacs to use this file: -;; -;; (load "~/lisp/sieve") -;; (setq auto-mode-alist (cons '("\\.siv\\'" . sieve-mode) auto-mode-alist)) -;; -;; References: -;; -;; RFC 3028, -;; "Sieve: A Mail Filtering Language", -;; by Tim Showalter. -;; -;; Release history: -;; -;; 2001-03-02 version 1.0 posted to gnu.emacs.sources -;; version 1.1 change file extension into ".siv" (official one) -;; added keymap and menubar to hook into sieve-manage -;; 2001-10-31 version 1.2 committed to Oort Gnus - -;;; Code: - -(autoload 'sieve-manage "sieve") -(autoload 'sieve-upload "sieve") -(eval-when-compile - (require 'font-lock)) - -(defgroup sieve nil - "Sieve." - :group 'languages) - -(defcustom sieve-mode-hook nil - "Hook run in sieve mode buffers." - :group 'sieve - :type 'hook) - -;; Font-lock - -(defvar sieve-control-commands-face 'sieve-control-commands - "Face name used for Sieve Control Commands.") - -(defface sieve-control-commands - '((((type tty) (class color)) (:foreground "blue" :weight light)) - (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) - (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) - (((class color) (background light)) (:foreground "Orchid")) - (((class color) (background dark)) (:foreground "LightSteelBlue")) - (t (:bold t))) - "Face used for Sieve Control Commands." - :group 'sieve) -;; backward-compatibility alias -(put 'sieve-control-commands-face 'face-alias 'sieve-control-commands) -(put 'sieve-control-commands-face 'obsolete-face "22.1") - -(defvar sieve-action-commands-face 'sieve-action-commands - "Face name used for Sieve Action Commands.") - -(defface sieve-action-commands - '((((type tty) (class color)) (:foreground "blue" :weight bold)) - (((class color) (background light)) (:foreground "Blue")) - (((class color) (background dark)) (:foreground "LightSkyBlue")) - (t (:inverse-video t :bold t))) - "Face used for Sieve Action Commands." - :group 'sieve) -;; backward-compatibility alias -(put 'sieve-action-commands-face 'face-alias 'sieve-action-commands) -(put 'sieve-action-commands-face 'obsolete-face "22.1") - -(defvar sieve-test-commands-face 'sieve-test-commands - "Face name used for Sieve Test Commands.") - -(defface sieve-test-commands - '((((type tty) (class color)) (:foreground "magenta")) - (((class grayscale) (background light)) - (:foreground "LightGray" :bold t :underline t)) - (((class grayscale) (background dark)) - (:foreground "Gray50" :bold t :underline t)) - (((class color) (background light)) (:foreground "CadetBlue")) - (((class color) (background dark)) (:foreground "Aquamarine")) - (t (:bold t :underline t))) - "Face used for Sieve Test Commands." - :group 'sieve) -;; backward-compatibility alias -(put 'sieve-test-commands-face 'face-alias 'sieve-test-commands) -(put 'sieve-test-commands-face 'obsolete-face "22.1") - -(defvar sieve-tagged-arguments-face 'sieve-tagged-arguments - "Face name used for Sieve Tagged Arguments.") - -(defface sieve-tagged-arguments - '((((type tty) (class color)) (:foreground "cyan" :weight bold)) - (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) - (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) - (((class color) (background light)) (:foreground "Purple")) - (((class color) (background dark)) (:foreground "Cyan")) - (t (:bold t))) - "Face used for Sieve Tagged Arguments." - :group 'sieve) -;; backward-compatibility alias -(put 'sieve-tagged-arguments-face 'face-alias 'sieve-tagged-arguments) -(put 'sieve-tagged-arguments-face 'obsolete-face "22.1") - - -(defconst sieve-font-lock-keywords - (eval-when-compile - (list - ;; control commands - (cons (regexp-opt '("require" "if" "else" "elsif" "stop") - 'words) - 'sieve-control-commands-face) - ;; action commands - (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard") - 'words) - 'sieve-action-commands-face) - ;; test commands - (cons (regexp-opt '("address" "allof" "anyof" "exists" "false" - "true" "header" "not" "size" "envelope" - "body") - 'words) - 'sieve-test-commands-face) - (cons "\\Sw+:\\sw+" - 'sieve-tagged-arguments-face)))) - -;; Syntax table - -(defvar sieve-mode-syntax-table nil - "Syntax table in use in sieve-mode buffers.") - -(if sieve-mode-syntax-table - () - (setq sieve-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\\ "\\" sieve-mode-syntax-table) - (modify-syntax-entry ?\n "> " sieve-mode-syntax-table) - (modify-syntax-entry ?\f "> " sieve-mode-syntax-table) - (modify-syntax-entry ?\# "< " sieve-mode-syntax-table) - (modify-syntax-entry ?/ "." sieve-mode-syntax-table) - (modify-syntax-entry ?* "." sieve-mode-syntax-table) - (modify-syntax-entry ?+ "." sieve-mode-syntax-table) - (modify-syntax-entry ?- "." sieve-mode-syntax-table) - (modify-syntax-entry ?= "." sieve-mode-syntax-table) - (modify-syntax-entry ?% "." sieve-mode-syntax-table) - (modify-syntax-entry ?< "." sieve-mode-syntax-table) - (modify-syntax-entry ?> "." sieve-mode-syntax-table) - (modify-syntax-entry ?& "." sieve-mode-syntax-table) - (modify-syntax-entry ?| "." sieve-mode-syntax-table) - (modify-syntax-entry ?_ "_" sieve-mode-syntax-table) - (modify-syntax-entry ?\' "\"" sieve-mode-syntax-table)) - -;; Key map definition - -(defvar sieve-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-l" 'sieve-upload) - (define-key map "\C-c\C-c" 'sieve-upload-and-kill) - (define-key map "\C-c\C-m" 'sieve-manage) - map) - "Key map used in sieve mode.") - -;; Menu definition - -(defvar sieve-mode-menu nil - "Menubar used in sieve mode.") - -;; Code for Sieve editing mode. -(autoload 'easy-menu-add-item "easymenu") - -;;;###autoload -(define-derived-mode sieve-mode c-mode "Sieve" - "Major mode for editing Sieve code. -This is much like C mode except for the syntax of comments. Its keymap -inherits from C mode's and it has the same variables for customizing -indentation. It has its own abbrev table and its own syntax table. - -Turning on Sieve mode runs `sieve-mode-hook'." - (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter)) - (set (make-local-variable 'paragraph-separate) paragraph-start) - (set (make-local-variable 'comment-start) "#") - (set (make-local-variable 'comment-end) "") - ;;(set (make-local-variable 'comment-start-skip) "\\(^\\|\\s-\\);?#+ *") - (set (make-local-variable 'comment-start-skip) "#+ *") - (unless (featurep 'xemacs) - (set (make-local-variable 'font-lock-defaults) - '(sieve-font-lock-keywords nil nil ((?_ . "w"))))) - (easy-menu-add-item nil nil sieve-mode-menu)) - -;; Menu - -(easy-menu-define sieve-mode-menu sieve-mode-map - "Sieve Menu." - '("Sieve" - ["Upload script" sieve-upload t] - ["Manage scripts on server" sieve-manage t])) - -(provide 'sieve-mode) - -;; sieve-mode.el ends here diff --git a/lisp/gnus/sieve.el b/lisp/gnus/sieve.el deleted file mode 100644 index 6d45b189d2b..00000000000 --- a/lisp/gnus/sieve.el +++ /dev/null @@ -1,372 +0,0 @@ -;;; sieve.el --- Utilities to manage sieve scripts - -;; Copyright (C) 2001-2017 Free Software Foundation, Inc. - -;; Author: Simon Josefsson <simon@josefsson.org> - -;; 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: - -;; This file contain utilities to facilitate upload, download and -;; general management of sieve scripts. Currently only the -;; Managesieve protocol is supported (using sieve-manage.el), but when -;; (useful) alternatives become available, they might be supported as -;; well. -;; -;; The cursor navigation was inspired by biff-mode by Franklin Lee. -;; -;; Release history: -;; -;; 2001-10-31 Committed to Oort Gnus. -;; 2002-07-27 Fix down-mouse-2 and down-mouse-3 in manage-mode. Fix menubar -;; in manage-mode. Change some messages. Added sieve-deactivate*, -;; sieve-remove. Fixed help text in manage-mode. Suggested by -;; Ned Ludd. -;; -;; Todo: -;; -;; * Namespace? This file contains `sieve-manage' and -;; `sieve-manage-mode', but there is a sieve-manage.el file as well. -;; Can't think of a good solution though, this file need a *-mode, -;; and naming it `sieve-mode' would collide with sieve-mode.el. One -;; solution would be to come up with some better name that this file -;; can use that doesn't have the managesieve specific "manage" in -;; it. sieve-dired? i dunno. we could copy all off sieve.el into -;; sieve-manage.el too, but I'd like to separate the interface from -;; the protocol implementation since the backends are likely to -;; change (well). -;; -;; * Define servers? We could have a customize buffer to create a server, -;; with authentication/stream/etc parameters, much like Gnus, and then -;; only use names of defined servers when interacting with M-x sieve-*. -;; Right now you can't use STARTTLS, which sieve-manage.el provides - -;;; Code: - -(require 'sieve-manage) -(require 'sieve-mode) - -;; User customizable variables: - -(defgroup sieve nil - "Manage sieve scripts." - :version "22.1" - :group 'tools) - -(defcustom sieve-new-script "<new script>" - "Name of name script indicator." - :type 'string - :group 'sieve) - -(defcustom sieve-buffer "*sieve*" - "Name of sieve management buffer." - :type 'string - :group 'sieve) - -(defcustom sieve-template "\ -require \"fileinto\"; - -# Example script (remove comment character '#' to make it effective!): -# -# if header :contains \"from\" \"coyote\" { -# discard; -# } elsif header :contains [\"subject\"] [\"$$$\"] { -# discard; -# } else { -# fileinto \"INBOX\"; -# } -" - "Template sieve script." - :type 'string - :group 'sieve) - -;; Internal variables: - -(defvar sieve-manage-buffer nil) -(defvar sieve-buffer-header-end nil) -(defvar sieve-buffer-script-name nil - "The real script name of the buffer.") -(make-local-variable 'sieve-buffer-script-name) - -;; Sieve-manage mode: - -(defvar sieve-manage-mode-map - (let ((map (make-sparse-keymap))) - ;; various - (define-key map "?" 'sieve-help) - (define-key map "h" 'sieve-help) - ;; activating - (define-key map "m" 'sieve-activate) - (define-key map "u" 'sieve-deactivate) - (define-key map "\M-\C-?" 'sieve-deactivate-all) - ;; navigation keys - (define-key map "\C-p" 'sieve-prev-line) - (define-key map [up] 'sieve-prev-line) - (define-key map "\C-n" 'sieve-next-line) - (define-key map [down] 'sieve-next-line) - (define-key map " " 'sieve-next-line) - (define-key map "n" 'sieve-next-line) - (define-key map "p" 'sieve-prev-line) - (define-key map "\C-m" 'sieve-edit-script) - (define-key map "f" 'sieve-edit-script) - (define-key map "o" 'sieve-edit-script-other-window) - (define-key map "r" 'sieve-remove) - (define-key map "q" 'sieve-bury-buffer) - (define-key map "Q" 'sieve-manage-quit) - (define-key map [(down-mouse-2)] 'sieve-edit-script) - (define-key map [(down-mouse-3)] 'sieve-manage-mode-menu) - map) - "Keymap for `sieve-manage-mode'.") - -(easy-menu-define sieve-manage-mode-menu sieve-manage-mode-map - "Sieve Menu." - '("Manage Sieve" - ["Edit script" sieve-edit-script t] - ["Activate script" sieve-activate t] - ["Deactivate script" sieve-deactivate t])) - -(define-derived-mode sieve-manage-mode fundamental-mode "Sieve-manage" - "Mode used for sieve script management." - (buffer-disable-undo (current-buffer)) - (setq truncate-lines t) - (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map)) - -(put 'sieve-manage-mode 'mode-class 'special) - -;; Commands used in sieve-manage mode: - -(defun sieve-manage-quit () - "Quit Manage Sieve and close the connection." - (interactive) - (sieve-manage-close sieve-manage-buffer) - (kill-buffer sieve-manage-buffer) - (kill-buffer (current-buffer))) - -(defun sieve-bury-buffer () - "Bury the Manage Sieve buffer without closing the connection." - (interactive) - (bury-buffer)) - -(defun sieve-activate (&optional pos) - (interactive "d") - (let ((name (sieve-script-at-point)) err) - (when (or (null name) (string-equal name sieve-new-script)) - (error "No sieve script at point")) - (message "Activating script %s..." name) - (setq err (sieve-manage-setactive name sieve-manage-buffer)) - (sieve-refresh-scriptlist) - (if (sieve-manage-ok-p err) - (message "Activating script %s...done" name) - (message "Activating script %s...failed: %s" name (nth 2 err))))) - -(defun sieve-deactivate-all (&optional pos) - (interactive "d") - (let ((name (sieve-script-at-point)) err) - (message "Deactivating scripts...") - (setq err (sieve-manage-setactive "" sieve-manage-buffer)) - (sieve-refresh-scriptlist) - (if (sieve-manage-ok-p err) - (message "Deactivating scripts...done") - (message "Deactivating scripts...failed: %s" (nth 2 err))))) - -(defalias 'sieve-deactivate 'sieve-deactivate-all) - -(defun sieve-remove (&optional pos) - (interactive "d") - (let ((name (sieve-script-at-point)) err) - (when (or (null name) (string-equal name sieve-new-script)) - (error "No sieve script at point")) - (message "Removing sieve script %s..." name) - (setq err (sieve-manage-deletescript name sieve-manage-buffer)) - (unless (sieve-manage-ok-p err) - (error "Removing sieve script %s...failed: " err)) - (sieve-refresh-scriptlist) - (message "Removing sieve script %s...done" name))) - -(defun sieve-edit-script (&optional pos) - (interactive "d") - (let ((name (sieve-script-at-point))) - (unless name - (error "No sieve script at point")) - (if (not (string-equal name sieve-new-script)) - (let ((newbuf (generate-new-buffer name)) - err) - (setq err (sieve-manage-getscript name newbuf sieve-manage-buffer)) - (switch-to-buffer newbuf) - (unless (sieve-manage-ok-p err) - (error "Sieve download failed: %s" err))) - (switch-to-buffer (get-buffer-create "template.siv")) - (insert sieve-template)) - (sieve-mode) - (setq sieve-buffer-script-name name) - (goto-char (point-min)) - (message - (substitute-command-keys - "Press \\[sieve-upload] to upload script to server.")))) - -(defmacro sieve-change-region (&rest body) - "Turns off sieve-region before executing BODY, then re-enables it after. -Used to bracket operations which move point in the sieve-buffer." - `(progn - (sieve-highlight nil) - ,@body - (sieve-highlight t))) -(put 'sieve-change-region 'lisp-indent-function 0) - -(defun sieve-next-line (&optional arg) - (interactive) - (unless arg - (setq arg 1)) - (if (save-excursion - (forward-line arg) - (sieve-script-at-point)) - (sieve-change-region - (forward-line arg)) - (message "End of list"))) - -(defun sieve-prev-line (&optional arg) - (interactive) - (unless arg - (setq arg -1)) - (if (save-excursion - (forward-line arg) - (sieve-script-at-point)) - (sieve-change-region - (forward-line arg)) - (message "Beginning of list"))) - -(defun sieve-help () - "Display help for various sieve commands." - (interactive) - (if (eq last-command 'sieve-help) - ;; would need minor-mode for log-edit-mode - (describe-function 'sieve-mode) - (message "%s" (substitute-command-keys - "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove")))) - -;; Create buffer: - -(defun sieve-setup-buffer (server port) - (setq buffer-read-only nil) - (erase-buffer) - (buffer-disable-undo) - (let* ((port (or port sieve-manage-default-port)) - (header (format "Server : %s:%s\n\n" server port))) - (insert header)) - (set (make-local-variable 'sieve-buffer-header-end) - (point-max))) - -(defun sieve-script-at-point (&optional pos) - "Return name of sieve script at point POS, or nil." - (interactive "d") - (get-char-property (or pos (point)) 'script-name)) - -(defun sieve-highlight (on) - "Turn ON or off highlighting on the current language overlay." - (overlay-put (car (overlays-at (point))) 'face (if on 'highlight 'default))) - -(defun sieve-insert-scripts (scripts) - "Format and insert LANGUAGE-LIST strings into current buffer at point." - (while scripts - (let ((p (point)) - (ext nil) - (script (pop scripts))) - (if (consp script) - (insert (format " ACTIVE %s" (cdr script))) - (insert (format " %s" script))) - (setq ext (make-overlay p (point))) - (overlay-put ext 'mouse-face 'highlight) - (overlay-put ext 'script-name (if (consp script) - (cdr script) - script)) - (insert "\n")))) - -(defun sieve-open-server (server &optional port) - "Open SERVER (on PORT) and authenticate." - (with-current-buffer - (or ;; open server - (set (make-local-variable 'sieve-manage-buffer) - (sieve-manage-open server port)) - (error "Error opening server %s" server)) - (sieve-manage-authenticate))) - -(defun sieve-refresh-scriptlist () - (interactive) - (with-current-buffer sieve-buffer - (setq buffer-read-only nil) - (delete-region (or sieve-buffer-header-end (point-max)) (point-max)) - (goto-char (point-max)) - ;; get list of script names and print them - (let ((scripts (sieve-manage-listscripts sieve-manage-buffer))) - (if (null scripts) - (insert - (substitute-command-keys - (format - "No scripts on server, press \\[sieve-edit-script] on %s to create a new script.\n" - sieve-new-script))) - (insert - (substitute-command-keys - (format (concat "%d script%s on server, press \\[sieve-edit-script] on a script " - "name edits it, or\npress \\[sieve-edit-script] on %s to create " - "a new script.\n") (length scripts) - (if (eq (length scripts) 1) "" "s") - sieve-new-script)))) - (save-excursion - (sieve-insert-scripts (list sieve-new-script)) - (sieve-insert-scripts scripts))) - (sieve-highlight t) - (setq buffer-read-only t))) - -;;;###autoload -(defun sieve-manage (server &optional port) - (interactive "sServer: ") - (switch-to-buffer (get-buffer-create sieve-buffer)) - (sieve-manage-mode) - (sieve-setup-buffer server port) - (if (sieve-open-server server port) - (sieve-refresh-scriptlist) - (message "Could not open server %s" server))) - -;;;###autoload -(defun sieve-upload (&optional name) - (interactive) - (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage)) - (let ((script (buffer-string)) err) - (with-current-buffer (get-buffer sieve-buffer) - (setq err (sieve-manage-putscript - (or name sieve-buffer-script-name (buffer-name)) - script sieve-manage-buffer)) - (if (sieve-manage-ok-p err) - (message (substitute-command-keys - "Sieve upload done. Use \\[sieve-manage] to manage scripts.")) - (message "Sieve upload failed: %s" (nth 2 err))))))) - -;;;###autoload -(defun sieve-upload-and-bury (&optional name) - (interactive) - (sieve-upload name) - (bury-buffer)) - -;;;###autoload -(defun sieve-upload-and-kill (&optional name) - (interactive) - (sieve-upload name) - (kill-buffer)) - -(provide 'sieve) - -;; sieve.el ends here diff --git a/lisp/gnus/smiley.el b/lisp/gnus/smiley.el index d910006f9e5..763a1cd5be7 100644 --- a/lisp/gnus/smiley.el +++ b/lisp/gnus/smiley.el @@ -58,19 +58,17 @@ (defvar smiley-data-directory) (defcustom smiley-style - (if (or (and (fboundp 'face-attribute) - ;; In batch mode, attributes can be unspecified. - (condition-case nil - (>= (face-attribute 'default :height) 160) - (error nil))) - (and (fboundp 'face-height) - (>= (face-height 'default) 14))) + (if (and (fboundp 'face-attribute) + ;; In batch mode, attributes can be unspecified. + (condition-case nil + (>= (face-attribute 'default :height) 160) + (error nil))) 'medium 'low-color) "Smiley style." - :type '(choice (const :tag "small, 3 colors" low-color) ;; 13x14 - (const :tag "medium, ~10 colors" medium) ;; 16x16 - (const :tag "dull, grayscale" grayscale));; 14x14 + :type '(choice (const :tag "small, 3 colors" low-color) ;; 13x14 + (const :tag "medium, ~10 colors" medium) ;; 16x16 + (const :tag "dull, grayscale" grayscale)) ;; 14x14 :set (lambda (symbol value) (set-default symbol value) (setq smiley-data-directory (smiley-directory)) @@ -94,7 +92,7 @@ is nil, use `smiley-style'." ((eq smiley-style 'grayscale) "/grayscale"))))) (defcustom smiley-data-directory (smiley-directory) - "*Location of the smiley faces files." + "Location of the smiley faces files." :set (lambda (symbol value) (set-default symbol value) (smiley-update-cache)) @@ -118,7 +116,7 @@ is nil, use `smiley-style'." ("\\(:-D\\)\\W" 1 "grin") ;; "smile" must be come after "evil" ("\\(\\^?:-?)\\)\\W" 1 "smile")) - "*A list of regexps to map smilies to images. + "A list of regexps to map smilies to images. The elements are (REGEXP MATCH IMAGE), where MATCH is the submatch in regexp to replace with IMAGE. IMAGE is the name of an image file in `smiley-data-directory'." @@ -139,7 +137,7 @@ regexp to replace with IMAGE. IMAGE is the name of an image file in (when (gnus-image-type-available-p 'gif) (push "gif" types)) types) - "*List of suffixes on smiley file names to try." + "List of suffixes on smiley file names to try." :version "24.1" :type '(repeat string) :group 'smiley) @@ -179,7 +177,7 @@ regexp to replace with IMAGE. IMAGE is the name of an image file in "Replace in the region `smiley-regexp-alist' matches with corresponding images. A list of images is returned." (interactive "r") - (when (gnus-graphic-display-p) + (when (display-graphic-p) (unless smiley-cached-regexp-alist (smiley-update-cache)) (save-excursion diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index 97435524852..56c651fa7ad 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -120,31 +120,16 @@ (require 'dig) -(if (locate-library "password-cache") - (require 'password-cache) - (require 'password)) +(require 'password-cache) (eval-when-compile (require 'cl)) -(eval-and-compile - (cond - ((fboundp 'replace-in-string) - (defalias 'smime-replace-in-string 'replace-in-string)) - ((fboundp 'replace-regexp-in-string) - (defun smime-replace-in-string (string regexp newtext &optional literal) - "Replace all matches for REGEXP with NEWTEXT in STRING. -If LITERAL is non-nil, insert NEWTEXT literally. Return a new -string containing the replacements. - -This is a compatibility function for different Emacsen." - (replace-regexp-in-string regexp newtext string nil literal))))) - (defgroup smime nil "S/MIME configuration." :group 'mime) (defcustom smime-keys nil - "*Map mail addresses to a file containing Certificate (and private key). + "Map mail addresses to a file containing Certificate (and private key). The file is assumed to be in PEM format. You can also associate additional certificates to be sent with every message to each address." :type '(repeat (list (string :tag "Mail address") @@ -154,7 +139,7 @@ certificates to be sent with every message to each address." :group 'smime) (defcustom smime-CA-directory nil - "*Directory containing certificates for CAs you trust. + "Directory containing certificates for CAs you trust. Directory should contain files (in PEM format) named to the X.509 hash of the certificate. This can be done using OpenSSL such as: @@ -167,7 +152,7 @@ certificate." :group 'smime) (defcustom smime-CA-file nil - "*Files containing certificates for CAs you trust. + "Files containing certificates for CAs you trust. File should contain certificates in PEM format." :version "22.1" :type '(choice (const :tag "none" nil) @@ -175,7 +160,7 @@ File should contain certificates in PEM format." :group 'smime) (defcustom smime-certificate-directory "~/Mail/certs/" - "*Directory containing other people's certificates. + "Directory containing other people's certificates. It should contain files named to the X.509 hash of the certificate, and the files themselves should be in PEM format." ;The S/MIME library provide simple functionality for fetching @@ -189,14 +174,14 @@ and the files themselves should be in PEM format." (eq 0 (call-process "openssl" nil nil nil "version")) (error nil)) "openssl") - "*Name of OpenSSL binary." + "Name of OpenSSL binary." :type 'string :group 'smime) ;; OpenSSL option to select the encryption cipher (defcustom smime-encrypt-cipher "-des3" - "*Cipher algorithm used for encryption." + "Cipher algorithm used for encryption." :version "22.1" :type '(choice (const :tag "Triple DES" "-des3") (const :tag "DES" "-des") @@ -206,7 +191,7 @@ and the files themselves should be in PEM format." :group 'smime) (defcustom smime-crl-check nil - "*Check revocation status of signers certificate using CRLs. + "Check revocation status of signers certificate using CRLs. Enabling this will have OpenSSL check the signers certificate against a certificate revocation list (CRL). @@ -227,7 +212,7 @@ At least OpenSSL version 0.9.7 is required for this to work." :group 'smime) (defcustom smime-dns-server nil - "*DNS server to query certificates from. + "DNS server to query certificates from. If nil, use system defaults." :version "22.1" :type '(choice (const :tag "System defaults") @@ -244,21 +229,6 @@ must be set in `ldap-host-parameters-alist'." (defvar smime-details-buffer "*OpenSSL output*") -;; Use mm-util? -(eval-and-compile - (defalias 'smime-make-temp-file - (if (fboundp 'make-temp-file) - 'make-temp-file - (lambda (prefix &optional dir-flag) ;; Simple implementation - (expand-file-name - (make-temp-name prefix) - (if (fboundp 'temp-directory) - (temp-directory) - temporary-file-directory)))))) - -;; Password dialog function -(declare-function password-read-and-add "password-cache" (prompt &optional key)) - (defun smime-ask-passphrase (&optional cache-key) "Asks the passphrase to unlock the secret key. If `cache-key' and `password-cache' is non-nil then cache the @@ -301,7 +271,7 @@ key and certificate itself." (keyfile (or (car-safe keyfile) keyfile)) (buffer (generate-new-buffer " *smime*")) (passphrase (smime-ask-passphrase (expand-file-name keyfile))) - (tmpfile (smime-make-temp-file "smime"))) + (tmpfile (make-temp-file "smime"))) (if passphrase (setenv "GNUS_SMIME_PASSPHRASE" passphrase)) (prog1 @@ -335,7 +305,7 @@ have proper MIME tags. CERTFILES is a list of filenames, each file is expected to contain of a PEM encoded certificate." (smime-new-details-buffer) (let ((buffer (generate-new-buffer " *smime*")) - (tmpfile (smime-make-temp-file "smime"))) + (tmpfile (make-temp-file "smime"))) (prog1 (when (prog1 (apply 'smime-call-openssl-region b e (list buffer tmpfile) @@ -431,7 +401,7 @@ in the buffer specified by `smime-details-buffer'." (smime-new-details-buffer) (let ((buffer (generate-new-buffer " *smime*")) CAs (passphrase (smime-ask-passphrase (expand-file-name keyfile))) - (tmpfile (smime-make-temp-file "smime"))) + (tmpfile (make-temp-file "smime"))) (if passphrase (setenv "GNUS_SMIME_PASSPHRASE" passphrase)) (if (prog1 @@ -588,13 +558,9 @@ A string or a list of strings is returned." "Get certificate for MAIL from the ldap server at HOST." (let ((ldapresult (funcall - (if (featurep 'xemacs) - (progn - (require 'smime-ldap) - 'smime-ldap-search) - (progn - (require 'ldap) - 'ldap-search)) + (progn + (require 'ldap) + 'ldap-search) (concat "mail=" mail) host '("userCertificate") nil)) (retbuf (generate-new-buffer (format "*certificate for %s*" mail))) @@ -611,11 +577,11 @@ A string or a list of strings is returned." (string= (substring (cadaar ldapresult) 0 3) "MII")) (setq cert - (smime-replace-in-string - (cadaar ldapresult) + (replace-regexp-in-string (concat "\\(\n\\|\r\\|-----BEGIN CERTIFICATE-----\\|" "-----END CERTIFICATE-----\\)") - "" t)) + "" + (cadaar ldapresult) nil t)) (setq cert (base64-encode-string (cadaar ldapresult) t))) (insert "-----BEGIN CERTIFICATE-----\n") (let ((i 0) (len (length cert))) diff --git a/lisp/gnus/spam-report.el b/lisp/gnus/spam-report.el index feea5e84c5b..17a7f89ae91 100644 --- a/lisp/gnus/spam-report.el +++ b/lisp/gnus/spam-report.el @@ -162,13 +162,13 @@ submitted at once. Internal variable.") rpt-host (concat "/" - (gnus-replace-in-string - (gnus-replace-in-string - (gnus-replace-in-string - (mail-header-xref (gnus-summary-article-header article)) - "/raw" ":silent") - "^.*article.gmane.org/" "") - "/" ":")))) + (replace-regexp-in-string + "/" ":" + (replace-regexp-in-string + "^.*article.gmane.org/" "" + (replace-regexp-in-string + "/raw" ":silent" + (mail-header-xref (gnus-summary-article-header article)))))))) (spam-report-gmane-use-article-number (spam-report-url-ping rpt-host @@ -207,8 +207,8 @@ submitted at once. Internal variable.") (when host (when (string-equal "permalink.gmane.org" host) (setq host rpt-host) - (setq report (gnus-replace-in-string - report "/\\([0-9]+\\)$" ":\\1"))) + (setq report (replace-regexp-in-string "/\\([0-9]+\\)$" ":\\1" + report))) (setq url (format "http://%s%s" host report))) (if (not (and host report url)) (gnus-message @@ -227,7 +227,7 @@ the function specified by `spam-report-url-ping-function'." (defcustom spam-report-user-mail-address (and (stringp user-mail-address) - (gnus-replace-in-string user-mail-address "@" "<at>")) + (replace-regexp-in-string "@" "<at>" user-mail-address)) "Mail address of this user used for spam reports to Gmane. This is initialized based on `user-mail-address'." :type '(choice string @@ -255,7 +255,7 @@ This is initialized based on `user-mail-address'." 80)) (error "Could not open connection to %s" host)) (set-marker (process-mark tcp-connection) (point-min)) - (gnus-set-process-query-on-exit-flag tcp-connection nil) + (set-process-query-on-exit-flag tcp-connection nil) (process-send-string tcp-connection (format "GET %s HTTP/1.1\nUser-Agent: %s\nHost: %s\n\n" @@ -297,8 +297,7 @@ symbol `ask', query before flushing the queue file." (re-search-forward "http://\\([^/]+\\)\\(/.*\\) *$" (point-at-eol) t)) (let ((spam-report-gmane-wait - (zerop (% (mm-line-number-at-pos) - spam-report-gmane-max-requests)))) + (zerop (% (line-number-at-pos) spam-report-gmane-max-requests)))) (gnus-message 6 "Reporting %s%s..." (match-string 1) (match-string 2)) (funcall spam-report-url-ping-function @@ -307,7 +306,7 @@ symbol `ask', query before flushing the queue file." (if (or (eq keep nil) (and (eq keep 'ask) (y-or-n-p - (gnus-format-message + (format-message "Flush requests from `%s'? " (current-buffer))))) (progn (gnus-message 7 "Flushing request file `%s'" diff --git a/lisp/gnus/spam-stat.el b/lisp/gnus/spam-stat.el index 0fcc73343c9..5466cf9edd9 100644 --- a/lisp/gnus/spam-stat.el +++ b/lisp/gnus/spam-stat.el @@ -493,18 +493,6 @@ where DIFF is the difference between SCORE and 0.5." (setcdr (nthcdr 14 result) nil) result)) -(eval-when-compile - (defmacro spam-stat-called-interactively-p (kind) - (condition-case nil - (progn - (eval '(called-interactively-p 'any)) - ;; Emacs >=23.2 - `(called-interactively-p ,kind)) - ;; Emacs <23.2 - (wrong-number-of-arguments '(called-interactively-p)) - ;; XEmacs - (void-function '(interactive-p))))) - (defun spam-stat-score-buffer () "Return a score describing the spam-probability for this buffer. Add user supplied modifications if supplied." @@ -522,7 +510,7 @@ Add user supplied modifications if supplied." (error nil))) (ans (if score1s (+ score0 score1s) score0))) - (when (spam-stat-called-interactively-p 'any) + (when (called-interactively-p 'any) (message "%S" ans)) ans)) diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 694d3c2c322..5f0ea94b283 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -1199,19 +1199,19 @@ Note this has to be fast." (if header-content (cond ((eq header 'X-Spam-Status) - (string-to-number (gnus-replace-in-string - header-content + (string-to-number (replace-regexp-in-string spam-spamassassin-score-regexp - "\\1"))) + "\\1" + header-content))) ;; for CRM checking, it's probably faster to just do the string match ((string-match "( pR: \\([0-9.-]+\\)" header-content) (- (string-to-number (match-string 1 header-content)))) ((eq header 'X-Bogosity) - (string-to-number (gnus-replace-in-string - (gnus-replace-in-string - header-content - ".*spamicity=" "") - ",.*" ""))) + (string-to-number (replace-regexp-in-string + ",.*" "" + (replace-regexp-in-string + ".*spamicity=" "" + header-content)))) (t nil)) nil))) diff --git a/lisp/gnus/starttls.el b/lisp/gnus/starttls.el deleted file mode 100644 index fe451709bd8..00000000000 --- a/lisp/gnus/starttls.el +++ /dev/null @@ -1,311 +0,0 @@ -;;; starttls.el --- STARTTLS functions - -;; Copyright (C) 1999-2017 Free Software Foundation, Inc. - -;; Author: Daiki Ueno <ueno@unixuser.org> -;; Author: Simon Josefsson <simon@josefsson.org> -;; Created: 1999/11/20 -;; Keywords: TLS, SSL, OpenSSL, GnuTLS, mail, 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: - -;; This module defines some utility functions for STARTTLS profiles. - -;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" -;; by Chris Newman <chris.newman@innosoft.com> (1999/06) - -;; This file now contains a combination of the two previous -;; implementations both called "starttls.el". The first one is Daiki -;; Ueno's starttls.el which uses his own "starttls" command line tool, -;; and the second one is Simon Josefsson's starttls.el which uses -;; "gnutls-cli" from GnuTLS. -;; -;; If "starttls" is available, it is preferred by the code over -;; "gnutls-cli", for backwards compatibility. Use -;; `starttls-use-gnutls' to toggle between implementations if you have -;; both tools installed. It is recommended to use GnuTLS, though, as -;; it performs more verification of the certificates. - -;; The GnuTLS support requires GnuTLS 0.9.90 (released 2003-10-08) or -;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls" -;; from <ftp://ftp.opaopa.org/pub/elisp/>. - -;; Usage is similar to `open-network-stream'. For example: -;; -;; (when (setq tmp (starttls-open-stream -;; "test" (current-buffer) "yxa.extundo.com" 25)) -;; (accept-process-output tmp 15) -;; (process-send-string tmp "STARTTLS\n") -;; (accept-process-output tmp 15) -;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp)) -;; (process-send-string tmp "EHLO foo\n")) - -;; An example run yields the following output: -;; -;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65] -;; 220 2.0.0 Ready to start TLS -;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you -;; 250-ENHANCEDSTATUSCODES -;; 250-PIPELINING -;; 250-EXPN -;; 250-VERB -;; 250-8BITMIME -;; 250-SIZE -;; 250-DSN -;; 250-ETRN -;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN -;; 250-DELIVERBY -;; 250 HELP -;; nil -;; -;; With the message buffer containing: -;; -;; STARTTLS output: -;; *** Starting TLS handshake -;; - Server's trusted authorities: -;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; - Certificate type: X.509 -;; - Got a certificate list of 2 certificates. -;; -;; - Certificate[0] info: -;; # The hostname in the certificate matches 'yxa.extundo.com'. -;; # valid since: Wed May 26 12:16:00 CEST 2004 -;; # expires at: Wed Jul 26 12:16:00 CEST 2023 -;; # serial number: 04 -;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a -;; # version: #1 -;; # public key algorithm: RSA -;; # Modulus: 1024 bits -;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; -;; - Certificate[1] info: -;; # valid since: Sun May 23 11:35:00 CEST 2004 -;; # expires at: Sun Jul 23 11:35:00 CEST 2023 -;; # serial number: 00 -;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae -;; # version: #3 -;; # public key algorithm: RSA -;; # Modulus: 1024 bits -;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com -;; -;; - Peer's certificate issuer is unknown -;; - Peer's certificate is NOT trusted -;; - Version: TLS 1.0 -;; - Key Exchange: RSA -;; - Cipher: ARCFOUR 128 -;; - MAC: SHA -;; - Compression: NULL - -;;; Code: - -(defgroup starttls nil - "Support for `Transport Layer Security' protocol." - :version "21.1" - :group 'mail) - -(defcustom starttls-gnutls-program "gnutls-cli" - "Name of GnuTLS command line tool. -This program is used when GnuTLS is used, i.e. when -`starttls-use-gnutls' is non-nil." - :version "22.1" - :type 'string - :group 'starttls) - -(defcustom starttls-program "starttls" - "The program to run in a subprocess to open an TLSv1 connection. -This program is used when the `starttls' command is used, -i.e. when `starttls-use-gnutls' is nil." - :type 'string - :group 'starttls) - -(defcustom starttls-use-gnutls (not (executable-find starttls-program)) - "*Whether to use GnuTLS instead of the `starttls' command." - :version "22.1" - :type 'boolean - :group 'starttls) - -(defcustom starttls-extra-args nil - "Extra arguments to `starttls-program'. -These apply when the `starttls' command is used, i.e. when -`starttls-use-gnutls' is nil." - :type '(repeat string) - :group 'starttls) - -(defcustom starttls-extra-arguments nil - "Extra arguments to `starttls-gnutls-program'. -These apply when GnuTLS is used, i.e. when `starttls-use-gnutls' is non-nil. - -For example, non-TLS compliant servers may require -\(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to -find out which parameters are available." - :version "22.1" - :type '(repeat string) - :group 'starttls) - -(defcustom starttls-process-connection-type nil - "*Value for `process-connection-type' to use when starting STARTTLS process." - :version "22.1" - :type 'boolean - :group 'starttls) - -(defcustom starttls-connect "- Simple Client Mode:\n\n" - "*Regular expression indicating successful connection. -The default is what GnuTLS's \"gnutls-cli\" outputs." - ;; GnuTLS cli.c:main() prints this string when it is starting to run - ;; in the application read/write phase. If the logic, or the string - ;; itself, is modified, this must be updated. - :version "22.1" - :type 'regexp - :group 'starttls) - -(defcustom starttls-failure "\\*\\*\\* Handshake has failed" - "*Regular expression indicating failed TLS handshake. -The default is what GnuTLS's \"gnutls-cli\" outputs." - ;; GnuTLS cli.c:do_handshake() prints this string on failure. If the - ;; logic, or the string itself, is modified, this must be updated. - :version "22.1" - :type 'regexp - :group 'starttls) - -(defcustom starttls-success "- Compression: " - "*Regular expression indicating completed TLS handshakes. -The default is what GnuTLS's \"gnutls-cli\" outputs." - ;; GnuTLS cli.c:do_handshake() calls, on success, - ;; common.c:print_info(), that unconditionally print this string - ;; last. If that logic, or the string itself, is modified, this - ;; must be updated. - :version "22.1" - :type 'regexp - :group 'starttls) - -(defun starttls-negotiate-gnutls (process) - "Negotiate TLS on PROCESS opened by `open-starttls-stream'. -This should typically only be done once. It typically returns a -multi-line informational message with information about the -handshake, or nil on failure." - (let (buffer info old-max done-ok done-bad) - (if (null (setq buffer (process-buffer process))) - ;; XXX How to remove/extract the TLS negotiation junk? - (signal-process (process-id process) 'SIGALRM) - (with-current-buffer buffer - (save-excursion - (setq old-max (goto-char (point-max))) - (signal-process (process-id process) 'SIGALRM) - (while (and (processp process) - (eq (process-status process) 'run) - (save-excursion - (goto-char old-max) - (not (or (setq done-ok (re-search-forward - starttls-success nil t)) - (setq done-bad (re-search-forward - starttls-failure nil t)))))) - (accept-process-output process 1 100) - (sit-for 0.1)) - (setq info (buffer-substring-no-properties old-max (point-max))) - (delete-region old-max (point-max)) - (if (or (and done-ok (not done-bad)) - ;; Prevent mitm that fake success msg after failure msg. - (and done-ok done-bad (< done-ok done-bad))) - info - (message "STARTTLS negotiation failed: %s" info) - nil)))))) - -(defun starttls-negotiate (process) - (if starttls-use-gnutls - (starttls-negotiate-gnutls process) - (signal-process (process-id process) 'SIGALRM))) - -(eval-and-compile - (if (fboundp 'set-process-query-on-exit-flag) - (defalias 'starttls-set-process-query-on-exit-flag - 'set-process-query-on-exit-flag) - (defalias 'starttls-set-process-query-on-exit-flag - 'process-kill-without-query))) - -(defun starttls-open-stream-gnutls (name buffer host port) - (message "Opening STARTTLS connection to `%s:%s'..." host port) - (let* (done - (old-max (with-current-buffer buffer (point-max))) - (process-connection-type starttls-process-connection-type) - (process (apply #'start-process name buffer - starttls-gnutls-program "-s" host - "-p" (if (integerp port) - (int-to-string port) - port) - starttls-extra-arguments))) - (starttls-set-process-query-on-exit-flag process nil) - (while (and (processp process) - (eq (process-status process) 'run) - (with-current-buffer buffer - (goto-char old-max) - (not (setq done (re-search-forward - starttls-connect nil t))))) - (accept-process-output process 0 100) - (sit-for 0.1)) - (if done - (with-current-buffer buffer - (delete-region old-max done)) - (delete-process process) - (setq process nil)) - (message "Opening STARTTLS connection to `%s:%s'...%s" - host port (if done "done" "failed")) - process)) - -;;;###autoload -(defun starttls-open-stream (name buffer host port) - "Open a TLS connection for a port to a host. -Returns a subprocess object to represent the connection. -Input and output work as for subprocesses; `delete-process' closes it. -Args are NAME BUFFER HOST PORT. -NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer (or `buffer-name') to associate with the process. - Process output goes at end of that buffer, unless you specify - an output stream or filter function to handle the output. - BUFFER may be also nil, meaning that this process is not associated - with any buffer -Third arg is name of the host to connect to, or its IP address. -Fourth arg PORT is an integer specifying a port to connect to. -If `starttls-use-gnutls' is nil, this may also be a service name, but -GnuTLS requires a port number." - (if starttls-use-gnutls - (starttls-open-stream-gnutls name buffer host port) - (message "Opening STARTTLS connection to `%s:%s'" host (format "%s" port)) - (let* ((process-connection-type starttls-process-connection-type) - (process (apply #'start-process - name buffer starttls-program - host (format "%s" port) - starttls-extra-args))) - (starttls-set-process-query-on-exit-flag process nil) - process))) - -(defun starttls-available-p () - "Say whether the STARTTLS programs are available." - (and (not (memq system-type '(windows-nt ms-dos))) - (executable-find (if starttls-use-gnutls - starttls-gnutls-program - starttls-program)))) - -(defalias 'starttls-any-program-available 'starttls-available-p) -(make-obsolete 'starttls-any-program-available 'starttls-available-p - "2011-08-02") - -(provide 'starttls) - -;;; starttls.el ends here diff --git a/lisp/gnus/utf7.el b/lisp/gnus/utf7.el deleted file mode 100644 index f82b8947586..00000000000 --- a/lisp/gnus/utf7.el +++ /dev/null @@ -1,231 +0,0 @@ -;;; utf7.el --- UTF-7 encoding/decoding for Emacs -*-coding: utf-8;-*- - -;; Copyright (C) 1999-2017 Free Software Foundation, Inc. - -;; Author: Jon K Hellan <hellan@acm.org> -;; Maintainer: bugs@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: - -;; UTF-7 - A Mail-Safe Transformation Format of Unicode - RFC 2152 -;; This is a transformation format of Unicode that contains only 7-bit -;; ASCII octets and is intended to be readable by humans in the limiting -;; case that the document consists of characters from the US-ASCII -;; repertoire. -;; In short, runs of characters outside US-ASCII are encoded as base64 -;; inside delimiters. -;; A variation of UTF-7 is specified in IMAP 4rev1 (RFC 2060) as the way -;; to represent characters outside US-ASCII in mailbox names in IMAP. -;; This library supports both variants, but the IMAP variation was the -;; reason I wrote it. -;; The routines convert UTF-7 -> UTF-16 (16 bit encoding of Unicode) -;; -> current character set, and vice versa. -;; However, until Emacs supports Unicode, the only Emacs character set -;; supported here is ISO-8859.1, which can trivially be converted to/from -;; Unicode. -;; When decoding results in a character outside the Emacs character set, -;; an error is thrown. It is up to the application to recover. - -;; UTF-7 should be done by providing a coding system. Mule-UCS does -;; already, but I don't know if it does the IMAP version and it's not -;; clear whether that should really be a coding system. The UTF-16 -;; part of the conversion can be done with coding systems available -;; with Mule-UCS or some versions of Emacs. Unfortunately these were -;; done wrongly (regarding handling of byte-order marks and how the -;; variants were named), so we don't have a consistent name for the -;; necessary coding system. The code below doesn't seem to DTRT -;; generally. E.g.: -;; -;; (utf7-encode "a+£") -;; => "a+ACsAow-" -;; -;; $ echo "a+£"|iconv -f utf-8 -t utf-7 -;; a+-+AKM -;; -;; -- fx - - -;;; Code: - -(require 'base64) -(eval-when-compile (require 'cl)) -(require 'mm-util) - -(defconst utf7-direct-encoding-chars " -%'-*,-[]-}" - "Character ranges which do not need escaping in UTF-7.") - -(defconst utf7-imap-direct-encoding-chars - (concat utf7-direct-encoding-chars "+\\~") - "Character ranges which do not need escaping in the IMAP variant of UTF-7.") - -(defconst utf7-utf-16-coding-system - (cond ((mm-coding-system-p 'utf-16-be-no-signature) ; Mule-UCS - 'utf-16-be-no-signature) - ((and (mm-coding-system-p 'utf-16-be) ; Emacs - ;; Avoid versions with BOM. - (= 2 (length (encode-coding-string "a" 'utf-16-be)))) - 'utf-16-be) - ((mm-coding-system-p 'utf-16-be-nosig) ; ? - 'utf-16-be-nosig)) - "Coding system which encodes big endian UTF-16 without a BOM signature.") - -(defsubst utf7-imap-get-pad-length (len modulus) - "Return required length of padding for IMAP modified base64 fragment." - (mod (- len) modulus)) - -(defun utf7-encode-internal (&optional for-imap) - "Encode text in (temporary) buffer as UTF-7. -Use IMAP modification if FOR-IMAP is non-nil." - (let ((start (point-min)) - (end (point-max))) - (narrow-to-region start end) - (goto-char start) - (let* ((esc-char (if for-imap ?& ?+)) - (direct-encoding-chars - (if for-imap utf7-imap-direct-encoding-chars - utf7-direct-encoding-chars)) - (not-direct-encoding-chars (concat "^" direct-encoding-chars))) - (while (not (eobp)) - (skip-chars-forward direct-encoding-chars) - (unless (eobp) - (insert esc-char) - (let ((p (point)) - (fc (following-char)) - (run-length - (skip-chars-forward not-direct-encoding-chars))) - (if (and (= fc esc-char) - (= run-length 1)) ; Lone esc-char? - (delete-char -1) ; Now there's one too many - (utf7-fragment-encode p (point) for-imap)) - (insert "-"))))))) - -(defun utf7-fragment-encode (start end &optional for-imap) - "Encode text from START to END in buffer as UTF-7 escape fragment. -Use IMAP modification if FOR-IMAP is non-nil." - (save-restriction - (narrow-to-region start end) - (funcall (utf7-get-u16char-converter 'to-utf-16)) - (mm-with-unibyte-current-buffer - (base64-encode-region start (point-max))) - (goto-char start) - (let ((pm (point-max))) - (when for-imap - (while (search-forward "/" nil t) - (replace-match ","))) - (skip-chars-forward "^= \t\n" pm) - (delete-region (point) pm)))) - -(defun utf7-decode-internal (&optional for-imap) - "Decode UTF-7 text in (temporary) buffer. -Use IMAP modification if FOR-IMAP is non-nil." - (let ((start (point-min)) - (end (point-max))) - (goto-char start) - (let* ((esc-pattern (concat "^" (char-to-string (if for-imap ?& ?+)))) - (base64-chars (concat "A-Za-z0-9+" - (char-to-string (if for-imap ?, ?/))))) - (while (not (eobp)) - (skip-chars-forward esc-pattern) - (unless (eobp) - (forward-char) - (let ((p (point)) - (run-length (skip-chars-forward base64-chars))) - (when (and (not (eobp)) (= (following-char) ?-)) - (delete-char 1)) - (unless (= run-length 0) ; Encoded lone esc-char? - (save-excursion - (utf7-fragment-decode p (point) for-imap) - (goto-char p) - (delete-char -1))))))))) - -(defun utf7-fragment-decode (start end &optional for-imap) - "Decode base64 encoded fragment from START to END of UTF-7 text in buffer. -Use IMAP modification if FOR-IMAP is non-nil." - (save-restriction - (narrow-to-region start end) - (when for-imap - (goto-char start) - (while (search-forward "," nil 'move-to-end) (replace-match "/"))) - (let ((pl (utf7-imap-get-pad-length (- end start) 4))) - (insert (make-string pl ?=)) - (base64-decode-region start (+ end pl))) - (funcall (utf7-get-u16char-converter 'from-utf-16)))) - -(defun utf7-get-u16char-converter (which-way) - "Return a function to convert between UTF-16 and current character set." - (if utf7-utf-16-coding-system - (if (eq which-way 'to-utf-16) - (lambda () - (encode-coding-region (point-min) (point-max) - utf7-utf-16-coding-system)) - (lambda () - (decode-coding-region (point-min) (point-max) - utf7-utf-16-coding-system))) - ;; Add test to check if we are really Latin-1. - (if (eq which-way 'to-utf-16) - 'utf7-latin1-u16-char-converter - 'utf7-u16-latin1-char-converter))) - -(defun utf7-latin1-u16-char-converter () - "Convert latin 1 (ISO-8859.1) characters to 16 bit Unicode. -Characters are converted to raw byte pairs in narrowed buffer." - (mm-encode-coding-region (point-min) (point-max) 'iso-8859-1) - (mm-disable-multibyte) - (goto-char (point-min)) - (while (not (eobp)) - (insert 0) - (forward-char))) - -(defun utf7-u16-latin1-char-converter () - "Convert 16 bit Unicode characters to latin 1 (ISO-8859.1). -Characters are in raw byte pairs in narrowed buffer." - (goto-char (point-min)) - (while (not (eobp)) - (if (= 0 (following-char)) - (delete-char 1) - (error "Unable to convert from Unicode")) - (forward-char)) - (mm-decode-coding-region (point-min) (point-max) 'iso-8859-1) - (mm-enable-multibyte)) - -;;;###autoload -(defun utf7-encode (string &optional for-imap) - "Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil." - (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap)) - ;; Emacs 23 with proper support for IMAP - (encode-coding-string string (if for-imap 'utf-7-imap 'utf-7)) - (mm-with-multibyte-buffer - (insert string) - (utf7-encode-internal for-imap) - (buffer-string)))) - -(defun utf7-decode (string &optional for-imap) - "Decode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil." - (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap)) - ;; Emacs 23 with proper support for IMAP - (decode-coding-string string (if for-imap 'utf-7-imap 'utf-7)) - (mm-with-unibyte-buffer - (insert string) - (utf7-decode-internal for-imap) - (mm-enable-multibyte) - (buffer-string)))) - -(provide 'utf7) - -;;; utf7.el ends here diff --git a/lisp/gnus/yenc.el b/lisp/gnus/yenc.el deleted file mode 100644 index 5bb37e1b63a..00000000000 --- a/lisp/gnus/yenc.el +++ /dev/null @@ -1,139 +0,0 @@ -;;; yenc.el --- elisp native yenc decoder - -;; Copyright (C) 2002-2017 Free Software Foundation, Inc. - -;; Author: Jesper Harder <harder@ifa.au.dk> -;; Keywords: yenc 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: - -;; Functions for decoding yenc encoded messages. -;; -;; Limitations: -;; -;; * Does not handle multipart messages. -;; * No support for external decoders. -;; * Doesn't check the crc32 checksum (if present). - -;;; Code: - -(eval-when-compile (require 'cl)) - -(defconst yenc-begin-line - "^=ybegin.*$") - -(defconst yenc-decoding-vector - [214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 - 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 - 248 249 250 251 252 253 254 255 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 - 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 - 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 - 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 - 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 - 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 - 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 - 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 - 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 - 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 - 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 - 208 209 210 211 212 213]) - -(defun yenc-first-part-p () - "Say whether the buffer contains the first part of a yEnc file." - (save-excursion - (goto-char (point-min)) - (re-search-forward "^=ybegin part=1 " nil t))) - -(defun yenc-last-part-p () - "Say whether the buffer contains the last part of a yEnc file." - (save-excursion - (goto-char (point-min)) - (let (total-size end-size) - (when (re-search-forward "^=ybegin.*size=\\([0-9]+\\)" nil t) - (setq total-size (match-string 1))) - (when (re-search-forward "^=ypart.*end=\\([0-9]+\\)" nil t) - (setq end-size (match-string 1))) - (and total-size - end-size - (string= total-size end-size))))) - -;;;###autoload -(defun yenc-decode-region (start end) - "Yenc decode region between START and END using an internal decoder." - (interactive "r") - (let (work-buffer) - (unwind-protect - (save-excursion - (goto-char start) - (when (re-search-forward yenc-begin-line end t) - (let ((first (match-end 0)) - (header-alist (yenc-parse-line (match-string 0))) - bytes last footer-alist char) - (when (re-search-forward "^=ypart.*$" end t) - (setq first (match-end 0))) - (when (re-search-forward "^=yend.*$" end t) - (setq last (match-beginning 0)) - (setq footer-alist (yenc-parse-line (match-string 0))) - (setq work-buffer (generate-new-buffer " *yenc-work*")) - (unless (featurep 'xemacs) - (with-current-buffer work-buffer (set-buffer-multibyte nil))) - (while (< first last) - (setq char (char-after first)) - (cond ((or (eq char ?\r) - (eq char ?\n))) - ((eq char ?=) - (setq char (char-after (incf first))) - (with-current-buffer work-buffer - (insert-char (mod (- char 106) 256) 1))) - (t - (with-current-buffer work-buffer - ;;(insert-char (mod (- char 42) 256) 1) - (insert-char (aref yenc-decoding-vector char) 1)))) - (incf first)) - (setq bytes (buffer-size work-buffer)) - (unless (and (= (cdr (assq 'size header-alist)) bytes) - (= (cdr (assq 'size footer-alist)) bytes)) - (message "Warning: Size mismatch while decoding.")) - (goto-char start) - (delete-region start end) - (insert-buffer-substring work-buffer)))) - (and work-buffer (kill-buffer work-buffer)))))) - -;;;###autoload -(defun yenc-extract-filename () - "Extract file name from an yenc header." - (save-excursion - (when (re-search-forward yenc-begin-line nil t) - (cdr (assoc 'name (yenc-parse-line (match-string 0))))))) - -(defun yenc-parse-line (str) - "Extract file name and size from STR." - (let (result name) - (when (string-match "^=y.*size=\\([0-9]+\\)" str) - (push (cons 'size (string-to-number (match-string 1 str))) result)) - (when (string-match "^=y.*name=\\(.*\\)$" str) - (setq name (match-string 1 str)) - ;; Remove trailing white space - (when (string-match " +$" name) - (setq name (substring name 0 (match-beginning 0)))) - (push (cons 'name name) result)) - result)) - -(provide 'yenc) - -;;; yenc.el ends here |