diff options
| author | Lars Ingebrigtsen <larsi@gnus.org> | 2016-02-24 13:04:03 +1100 |
|---|---|---|
| committer | Lars Ingebrigtsen <larsi@gnus.org> | 2016-02-24 13:04:03 +1100 |
| commit | 21fe2ebec8b63d5fd0a570ed0c907802ab83f991 (patch) | |
| tree | f7fe7b6b4b2a21667cb66a1fdf7d470c7ec292a0 /lisp/gnus | |
| parent | e1d749bd7e0d68ab063eae3927caede6039a33cf (diff) | |
| download | emacs-21fe2ebec8b63d5fd0a570ed0c907802ab83f991.tar.gz | |
Move low-level library files from the lisp/gnus directory
The files moved from lisp/gnus are:
auth-source.el -> /
compface.el -> /image
ecomplete.el -> /
flow-fill.el -> /mail
gravatar.el -> /image
gssapi.el -> /net
html2text.el -> /net
ietf-drums.el -> /mail
mail-parse.el -> /mail
mail-prsvr.el -> /mail
mailcap.el -> /net
plstore.el -> /
pop3.el -> /net
qp.el -> /mail
registry.el -> /
rfc1843.el -> /international
rfc2045.el -> /mail
rfc2047.el -> /mail
rfc2231.el -> /mail
rtree.el -> /
sieve-manage.el -> /net
sieve-mode.el -> /net
sieve.el -> /net
starttls.el -> /net
utf7.el -> /international
yenc.el -> /mail
Diffstat (limited to 'lisp/gnus')
| -rw-r--r-- | lisp/gnus/auth-source.el | 2145 | ||||
| -rw-r--r-- | lisp/gnus/compface.el | 55 | ||||
| -rw-r--r-- | lisp/gnus/ecomplete.el | 158 | ||||
| -rw-r--r-- | lisp/gnus/flow-fill.el | 240 | ||||
| -rw-r--r-- | lisp/gnus/gravatar.el | 157 | ||||
| -rw-r--r-- | lisp/gnus/html2text.el | 461 | ||||
| -rw-r--r-- | lisp/gnus/ietf-drums.el | 291 | ||||
| -rw-r--r-- | lisp/gnus/mail-parse.el | 75 | ||||
| -rw-r--r-- | lisp/gnus/mail-prsvr.el | 43 | ||||
| -rw-r--r-- | lisp/gnus/mailcap.el | 1054 | ||||
| -rw-r--r-- | lisp/gnus/plstore.el | 570 | ||||
| -rw-r--r-- | lisp/gnus/pop3.el | 914 | ||||
| -rw-r--r-- | lisp/gnus/qp.el | 177 | ||||
| -rw-r--r-- | lisp/gnus/registry.el | 379 | ||||
| -rw-r--r-- | lisp/gnus/rfc1843.el | 131 | ||||
| -rw-r--r-- | lisp/gnus/rfc2045.el | 41 | ||||
| -rw-r--r-- | lisp/gnus/rfc2047.el | 1166 | ||||
| -rw-r--r-- | lisp/gnus/rfc2231.el | 308 | ||||
| -rw-r--r-- | lisp/gnus/rtree.el | 281 | ||||
| -rw-r--r-- | lisp/gnus/sieve-manage.el | 575 | ||||
| -rw-r--r-- | lisp/gnus/sieve-mode.el | 221 | ||||
| -rw-r--r-- | lisp/gnus/sieve.el | 372 | ||||
| -rw-r--r-- | lisp/gnus/starttls.el | 304 | ||||
| -rw-r--r-- | lisp/gnus/utf7.el | 236 | ||||
| -rw-r--r-- | lisp/gnus/yenc.el | 139 |
25 files changed, 0 insertions, 10493 deletions
diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el deleted file mode 100644 index cfd21a523cd..00000000000 --- a/lisp/gnus/auth-source.el +++ /dev/null @@ -1,2145 +0,0 @@ -;;; auth-source.el --- authentication sources for Gnus and Emacs - -;; Copyright (C) 2008-2016 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) - -(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 (read-char-choice full-prompt choices))) - 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") - (error - "%s: Unexpected `machine' token at line %d" - "auth-source-netrc-parse-entries" - (auth-source-current-line)) - (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 (delete-dups (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 - ;; Filter out ignored keys from the spec - (ignored-keys '(:create :delete :max :backend :label :host :port)) - ;; Build a search spec without the ignored keys - (search-keys (loop for i below (length spec) by 2 - unless (memq (nth i spec) ignored-keys) - collect (nth i spec))) - ;; If a search key value 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 (delete-dups (append - '(:host :login :port :secret) - search-keys))) - ;; Extract host and port from spec - (hosts (plist-get spec :host)) - (hosts (if (and hosts (listp hosts)) hosts `(,hosts))) - (ports (plist-get spec :port)) - (ports (if (and ports (listp ports)) ports `(,ports))) - ;; Loop through all combinations of host/port and pass each of these to - ;; auth-source-macos-keychain-search-items - (items (catch 'match - (dolist (host hosts) - (dolist (port ports) - (let* ((port (format "%S" port)) - (items (apply #'auth-source-macos-keychain-search-items - coll - type - max - host port - search-spec))) - (when items - (throw 'match 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-macos-keychain-search-items (coll _type _max - host port - &key label type - user - &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 (delete-dups (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/compface.el b/lisp/gnus/compface.el deleted file mode 100644 index e2f607b1be3..00000000000 --- a/lisp/gnus/compface.el +++ /dev/null @@ -1,55 +0,0 @@ -;;; compface.el --- functions for converting X-Face headers - -;; Copyright (C) 2002-2016 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 - (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") - ;; Emacs doesn't understand un-raw pbm files. - (eq 0 (call-process-region (point-min) (point-max) - "icontopbm" - 'delete '(t nil)))) - (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 cb50cce6056..00000000000 --- a/lisp/gnus/ecomplete.el +++ /dev/null @@ -1,158 +0,0 @@ -;;; ecomplete.el --- electric completion of addresses and the like - -;; Copyright (C) 2006-2016 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)) - -(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" (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 d2881422475..00000000000 --- a/lisp/gnus/flow-fill.el +++ /dev/null @@ -1,240 +0,0 @@ -;;; flow-fill.el --- interpret RFC2646 "flowed" text - -;; Copyright (C) 2000-2016 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)) - 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/gravatar.el b/lisp/gnus/gravatar.el deleted file mode 100644 index 81503b7d90a..00000000000 --- a/lisp/gnus/gravatar.el +++ /dev/null @@ -1,157 +0,0 @@ -;;; gravatar.el --- Get Gravatars - -;; Copyright (C) 2010-2016 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) -(require 'image) - -(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)))))) - -(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 - (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 2b1c2057bb4..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-2016 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 03349d12055..00000000000 --- a/lisp/gnus/ietf-drums.el +++ /dev/null @@ -1,291 +0,0 @@ -;;; ietf-drums.el --- Functions for parsing RFC822bis headers - -;; Copyright (C) 1998-2016 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)) - -(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) - 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 (aref token i)) - (incf i) - (cond - ((eq c ?-) - (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/mail-parse.el b/lisp/gnus/mail-parse.el deleted file mode 100644 index 4fc7e463595..00000000000 --- a/lisp/gnus/mail-parse.el +++ /dev/null @@ -1,75 +0,0 @@ -;;; mail-parse.el --- Interface functions for parsing mail - -;; Copyright (C) 1998-2016 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 789c0028f64..00000000000 --- a/lisp/gnus/mail-prsvr.el +++ /dev/null @@ -1,43 +0,0 @@ -;;; mail-prsvr.el --- Interface variables for parsing mail - -;; Copyright (C) 1999-2016 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/mailcap.el b/lisp/gnus/mailcap.el deleted file mode 100644 index 609a8f4d64b..00000000000 --- a/lisp/gnus/mailcap.el +++ /dev/null @@ -1,1054 +0,0 @@ -;;; mailcap.el --- MIME media types configuration - -;; Copyright (C) 1998-2016 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") - -(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.") - -(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) - (delete-dups - (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 - (delete-dups - (mapcar (lambda (file) - (mailcap-extension-to-mime - (file-name-extension file t))) - files))) - (all-mime-info - ;; All MIME info lists - (delete-dups - (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 - (delete-dups - (delq nil (mapcar - (lambda (mime-info) - (let ((command (cdr (assoc 'viewer mime-info)))) - (if (stringp command) - (replace-regexp-in-string - ;; Replace mailcap's `%s' placeholder - ;; with dired's `?' placeholder - "%s" "?" - (replace-regexp-in-string - ;; Remove the final filename placeholder - "[ \t\n]*\\('\\)?%s\\1?[ \t\n]*\\'" "" - command nil t) - nil 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/plstore.el b/lisp/gnus/plstore.el deleted file mode 100644 index 62c50c0f4a1..00000000000 --- a/lisp/gnus/plstore.el +++ /dev/null @@ -1,570 +0,0 @@ -;;; plstore.el --- secure plist store -*- lexical-binding: t -*- -;; Copyright (C) 2011-2016 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) - (setf (epg-context-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))) - -;;;###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 (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 1695bbd3a40..00000000000 --- a/lisp/gnus/pop3.el +++ /dev/null @@ -1,914 +0,0 @@ -;;; pop3.el --- Post Office Protocol (RFC 1460) interface - -;; Copyright (C) 1996-2016 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)) - -(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))) - -(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-network-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))))) - (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 %z" now)))) - -(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 a295e0c2d8e..00000000000 --- a/lisp/gnus/qp.el +++ /dev/null @@ -1,177 +0,0 @@ -;;; qp.el --- Quoted-Printable functions - -;; Copyright (C) 1998-2016 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: - -;;;###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)) - (when (and coding-system - (not (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 - (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 - (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." - (with-temp-buffer - (set-buffer-multibyte nil) - (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 (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 - (format "=%02X" (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 ((ultra - (and (boundp 'mm-use-ultra-safe-encoding) - mm-use-ultra-safe-encoding))) - (when (or fold ultra) - (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 ultra - (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 (multibyte-string-p string) - (set-buffer-multibyte 'to) - (set-buffer-multibyte nil)) - (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 e8bc6f5545a..00000000000 --- a/lisp/gnus/registry.el +++ /dev/null @@ -1,379 +0,0 @@ -;;; registry.el --- Track and remember data items by various fields - -;; Copyright (C) 2011-2016 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."))) - -(cl-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)))) - -(cl-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))))) - -(cl-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)))) - -(cl-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)))))) - -(cl-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)))))) - -(cl-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)))))) - -(cl-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)))) - -(cl-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)) - -(cl-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))) - -(cl-defmethod registry-full ((db registry-db)) - "Checks if registry-db THIS is full." - (>= (registry-size db) - (oref db max-size))) - -(cl-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) - -(cl-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)))))) - -(cl-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))) - -(cl-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 508629fb062..00000000000 --- a/lisp/gnus/rfc1843.el +++ /dev/null @@ -1,131 +0,0 @@ -;;; rfc1843.el --- HZ (rfc1843) decoding - -;; 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: - -;; Test: -;; (rfc1843-decode-string "~{<:Ky2;S{#,NpJ)l6HK!#~}") - -;;; Code: - -(eval-when-compile (require 'cl)) - -(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) - (setq str (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))) - (setq firstc (aref str 0)) - (insert (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 enable-multibyte-characters)) - (with-temp-buffer - (when m - (set-buffer-multibyte 'to)) - (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)) - -(provide 'rfc1843) - -;;; rfc1843.el ends here diff --git a/lisp/gnus/rfc2045.el b/lisp/gnus/rfc2045.el deleted file mode 100644 index c2ddf906d06..00000000000 --- a/lisp/gnus/rfc2045.el +++ /dev/null @@ -1,41 +0,0 @@ -;;; rfc2045.el --- Functions for decoding rfc2045 headers - -;; Copyright (C) 1998-2016 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 4cb10e54393..00000000000 --- a/lisp/gnus/rfc2047.el +++ /dev/null @@ -1,1166 +0,0 @@ -;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages - -;; Copyright (C) 1998-2016 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. - (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 (default-value 'enable-multibyte-characters) - mail-parse-charset) - (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) - (when (default-value 'enable-multibyte-characters) - (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. - (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" - (replace-regexp-in-string "[ \t\n]+" " " orig-text)))))))) - (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 - (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 - (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)) - (replace-regexp-in-string - "\n\\([ \t]?\\)" "\\1" - (buffer-substring-no-properties b e)) - 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 - (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 - (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))) - (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))) - (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." - (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 (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 (eq (detect-coding-string string t) 'undecided) - ;; string is purely ASCII - string - (decode-coding-string string mail-parse-charset)) - (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 128779ab4c6..00000000000 --- a/lisp/gnus/rfc2231.el +++ /dev/null @@ -1,308 +0,0 @@ -;;; rfc2231.el --- Functions for decoding rfc2231 headers - -;; Copyright (C) 1998-2016 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 (replace-regexp-in-string "\\\\\"" "\"" string) - mod t)) - (when (and (string-match "\\\\(" string) - (string-match "\\\\)" string) - (not (string-match "\\`(\\|[^\\][()]" string))) - (setq string (replace-regexp-in-string - "\\\\\\([()]\\)" "\\1" string) - 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) - (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 662e043669a..00000000000 --- a/lisp/gnus/rtree.el +++ /dev/null @@ -1,281 +0,0 @@ -;;; rtree.el --- functions for manipulating range trees - -;; Copyright (C) 2010-2016 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/sieve-manage.el b/lisp/gnus/sieve-manage.el deleted file mode 100644 index 695bbd860de..00000000000 --- a/lisp/gnus/sieve-manage.el +++ /dev/null @@ -1,575 +0,0 @@ -;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp - -;; Copyright (C) 2001-2016 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)) -(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-network-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 7575ba67c5e..00000000000 --- a/lisp/gnus/sieve-mode.el +++ /dev/null @@ -1,221 +0,0 @@ -;;; sieve-mode.el --- Sieve code editing commands for Emacs - -;; Copyright (C) 2001-2016 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) "#+ *") - (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 2046e53697d..00000000000 --- a/lisp/gnus/sieve.el +++ /dev/null @@ -1,372 +0,0 @@ -;;; sieve.el --- Utilities to manage sieve scripts - -;; Copyright (C) 2001-2016 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/starttls.el b/lisp/gnus/starttls.el deleted file mode 100644 index 096ed2adc0d..00000000000 --- a/lisp/gnus/starttls.el +++ /dev/null @@ -1,304 +0,0 @@ -;;; starttls.el --- STARTTLS functions - -;; Copyright (C) 1999-2016 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))) - -(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))) - (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))) - (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 bd04eba2fae..00000000000 --- a/lisp/gnus/utf7.el +++ /dev/null @@ -1,236 +0,0 @@ -;;; utf7.el --- UTF-7 encoding/decoding for Emacs -*-coding: utf-8;-*- - -;; Copyright (C) 1999-2016 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 - (let* ((buf (current-buffer)) - (base (with-temp-buffer - (set-buffer-multibyte nil) - (insert-buffer-substring buf start end) - (funcall (utf7-get-u16char-converter 'to-utf-16)) - (base64-encode-region (point-min) (point-max)) - (buffer-string)))) - (narrow-to-region start end) - (delete-region (point-min) (point-max)) - (insert base)) - (goto-char (point-min)) - (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." - (encode-coding-region (point-min) (point-max) 'iso-8859-1) - (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)) - (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 a4ebd0db15b..00000000000 --- a/lisp/gnus/yenc.el +++ /dev/null @@ -1,139 +0,0 @@ -;;; yenc.el --- elisp native yenc decoder - -;; Copyright (C) 2002-2016 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*")) - (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 |