From: Lars Ingebrigtsen Date: Wed, 24 Feb 2016 02:04:03 +0000 (+1100) Subject: Move low-level library files from the lisp/gnus directory X-Git-Tag: emacs-26.0.90~2477 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=21fe2ebec8b63d5fd0a570ed0c907802ab83f991;p=emacs.git 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 --- diff --git a/lisp/auth-source.el b/lisp/auth-source.el new file mode 100644 index 00000000000..cfd21a523cd --- /dev/null +++ b/lisp/auth-source.el @@ -0,0 +1,2145 @@ +;;; auth-source.el --- authentication sources for Gnus and Emacs + +;; Copyright (C) 2008-2016 Free Software Foundation, Inc. + +;; Author: Ted Zlatanov +;; 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 . + +;;; 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 ="AppleID" + ((looking-at "^[ ]+0x00000007 =\"\\(.+\\)\"") + (setq ret (auth-source-macos-keychain-result-append + ret + keychain-generic + "label" + (match-string 1)))) + ;; match "crtr"="aapl" + ;; match "svce"="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/ecomplete.el b/lisp/ecomplete.el new file mode 100644 index 00000000000..cb50cce6056 --- /dev/null +++ b/lisp/ecomplete.el @@ -0,0 +1,158 @@ +;;; ecomplete.el --- electric completion of addresses and the like + +;; Copyright (C) 2006-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 . + +;;; 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/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 -;; 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 . - -;;; 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 ="AppleID" - ((looking-at "^[ ]+0x00000007 =\"\\(.+\\)\"") - (setq ret (auth-source-macos-keychain-result-append - ret - keychain-generic - "label" - (match-string 1)))) - ;; match "crtr"="aapl" - ;; match "svce"="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 -;; 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 . - -;;; 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 -;; 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 . - -;;; 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 -;; 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 . - -;;; 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 -;; 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 . - -;;; 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 - -;; 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 . - -;;; 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: - -;; -;; -;; - -(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 big .\" - -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: - -\" This is bold text \" - ^ ^ ^ ^ - | | | | -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.") - -;; -;; -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; -;; - - -(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)) - -;; -;; -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; i.e. -;; - -(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)) - -;; -;; -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; -;; -(defun html2text-clean-list-items (p1 p2 list-type) - (goto-char p1) - (let ((item-nr 0) - (items 0)) - (while (search-forward "
  • " p2 t) - (setq items (1+ items))) - (goto-char p1) - (while (< item-nr items) - (setq item-nr (1+ item-nr)) - (search-forward "
  • " (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 "
    " p2 t) - (setq items (1+ items))) - (goto-char p1) - (while (< item-nr items) - (setq item-nr (1+ item-nr)) - (re-search-forward "
    \\([ ]*\\)" (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 "\\([ ]*\\)\\(
    \\|
    \\)" (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)))) - -;; -;; -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; -;; - -(defun html2text-fix-paragraph (p1 p2) - (goto-char p1) - (let ((refill-start) - (refill-stop)) - (when (re-search-forward "
    $" 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 "
    " 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 - "
    " "" - refill-start (point)))) - ;; (message "Point = %s refill-stop = %s" (point) refill-stop) - ;; (sleep-for 4) - (fill-region refill-start refill-stop)))) - (html2text-replace-string "
    " "" 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 "^
    $" nil t) - (delete-region (match-beginning 0) (match-end 0))) - ;; Removing lonely
    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))))) - -;; -;;     -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; -;; - -(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 "\\(]*>\\)" 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 "" tag) (point-max) t) - (goto-char p2) - (insert (format "" tag))) - (setq p4 (point)) - (search-backward "]*\\)?>\\)" 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)))) - -;; -;; -;; -(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 -;; 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 . - -;;; 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. - -;; -;; (ietf-drums-parse-address "'foo' ") -;; => ("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 -;; 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 . - -;;; 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 -;; 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 . - -;;; 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 -;; Lars Magne Ingebrigtsen -;; 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 . - -;;; 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\" . )) - (\"text\" - (\"plain\" . ))) - -Where 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 - ;; %{ -;; 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 . - -;;; 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 -;; 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 . - -;;; 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 \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 -;; 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 . - -;;; 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 -;; 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 . - -;;; 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 -;; 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 . - -;;; 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 -;; 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 . - -;; 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 -;; MORIOKA Tomohiko -;; 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 . - -;;; 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 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 -;; 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 . - -;;; 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 - -;; 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 . - -;;; 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 -;; Albert Krewinkel - -;; 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 . - -;;; 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 - -;; 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 . - -;;; 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 - -;; 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 . - -;;; 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 "" - "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 -;; Author: Simon Josefsson -;; 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 . - -;;; Commentary: - -;; This module defines some utility functions for STARTTLS profiles. - -;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" -;; by Chris Newman (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 , or "starttls" -;; from . - -;; 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 -;; 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 . - -;;; 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 -;; 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 . - -;;; 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 diff --git a/lisp/image/compface.el b/lisp/image/compface.el new file mode 100644 index 00000000000..e2f607b1be3 --- /dev/null +++ b/lisp/image/compface.el @@ -0,0 +1,55 @@ +;;; compface.el --- functions for converting X-Face headers + +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 . + +;;; 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/image/gravatar.el b/lisp/image/gravatar.el new file mode 100644 index 00000000000..81503b7d90a --- /dev/null +++ b/lisp/image/gravatar.el @@ -0,0 +1,157 @@ +;;; gravatar.el --- Get Gravatars + +;; Copyright (C) 2010-2016 Free Software Foundation, Inc. + +;; Author: Julien Danjou +;; 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 . + +;;; 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/international/rfc1843.el b/lisp/international/rfc1843.el new file mode 100644 index 00000000000..508629fb062 --- /dev/null +++ b/lisp/international/rfc1843.el @@ -0,0 +1,131 @@ +;;; rfc1843.el --- HZ (rfc1843) decoding + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Shenghuo Zhu +;; 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 . + +;;; 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/international/utf7.el b/lisp/international/utf7.el new file mode 100644 index 00000000000..bd04eba2fae --- /dev/null +++ b/lisp/international/utf7.el @@ -0,0 +1,236 @@ +;;; utf7.el --- UTF-7 encoding/decoding for Emacs -*-coding: utf-8;-*- + +;; Copyright (C) 1999-2016 Free Software Foundation, Inc. + +;; Author: Jon K Hellan +;; 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 . + +;;; 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/mail/flow-fill.el b/lisp/mail/flow-fill.el new file mode 100644 index 00000000000..d2881422475 --- /dev/null +++ b/lisp/mail/flow-fill.el @@ -0,0 +1,240 @@ +;;; flow-fill.el --- interpret RFC2646 "flowed" text + +;; Copyright (C) 2000-2016 Free Software Foundation, Inc. + +;; Author: Simon Josefsson +;; 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 . + +;;; 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/mail/ietf-drums.el b/lisp/mail/ietf-drums.el new file mode 100644 index 00000000000..03349d12055 --- /dev/null +++ b/lisp/mail/ietf-drums.el @@ -0,0 +1,291 @@ +;;; ietf-drums.el --- Functions for parsing RFC822bis headers + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 . + +;;; 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. + +;; +;; (ietf-drums-parse-address "'foo' ") +;; => ("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/mail/mail-parse.el b/lisp/mail/mail-parse.el new file mode 100644 index 00000000000..4fc7e463595 --- /dev/null +++ b/lisp/mail/mail-parse.el @@ -0,0 +1,75 @@ +;;; mail-parse.el --- Interface functions for parsing mail + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 . + +;;; 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/mail/mail-prsvr.el b/lisp/mail/mail-prsvr.el new file mode 100644 index 00000000000..789c0028f64 --- /dev/null +++ b/lisp/mail/mail-prsvr.el @@ -0,0 +1,43 @@ +;;; mail-prsvr.el --- Interface variables for parsing mail + +;; Copyright (C) 1999-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 . + +;;; 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/mail/qp.el b/lisp/mail/qp.el new file mode 100644 index 00000000000..a295e0c2d8e --- /dev/null +++ b/lisp/mail/qp.el @@ -0,0 +1,177 @@ +;;; qp.el --- Quoted-Printable functions + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 . + +;;; 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/mail/rfc2045.el b/lisp/mail/rfc2045.el new file mode 100644 index 00000000000..c2ddf906d06 --- /dev/null +++ b/lisp/mail/rfc2045.el @@ -0,0 +1,41 @@ +;;; rfc2045.el --- Functions for decoding rfc2045 headers + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 . + +;; 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/mail/rfc2047.el b/lisp/mail/rfc2047.el new file mode 100644 index 00000000000..4cb10e54393 --- /dev/null +++ b/lisp/mail/rfc2047.el @@ -0,0 +1,1166 @@ +;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; MORIOKA Tomohiko +;; 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 . + +;;; 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 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/mail/rfc2231.el b/lisp/mail/rfc2231.el new file mode 100644 index 00000000000..128779ab4c6 --- /dev/null +++ b/lisp/mail/rfc2231.el @@ -0,0 +1,308 @@ +;;; rfc2231.el --- Functions for decoding rfc2231 headers + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 . + +;;; 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/mail/yenc.el b/lisp/mail/yenc.el new file mode 100644 index 00000000000..a4ebd0db15b --- /dev/null +++ b/lisp/mail/yenc.el @@ -0,0 +1,139 @@ +;;; yenc.el --- elisp native yenc decoder + +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. + +;; Author: Jesper Harder +;; 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 . + +;;; 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 diff --git a/lisp/net/html2text.el b/lisp/net/html2text.el new file mode 100644 index 00000000000..2b1c2057bb4 --- /dev/null +++ b/lisp/net/html2text.el @@ -0,0 +1,461 @@ +;;; html2text.el --- a simple html to plain text converter -*- coding: utf-8 -*- + +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. + +;; Author: Joakim Hove + +;; 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 . + +;;; 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: + +;; +;; +;; + +(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 big .\" + +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: + +\" This is bold text \" + ^ ^ ^ ^ + | | | | +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.") + +;; +;; +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; +;; + + +(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)) + +;; +;; +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; i.e. +;; + +(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)) + +;; +;; +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; +;; +(defun html2text-clean-list-items (p1 p2 list-type) + (goto-char p1) + (let ((item-nr 0) + (items 0)) + (while (search-forward "
  • " p2 t) + (setq items (1+ items))) + (goto-char p1) + (while (< item-nr items) + (setq item-nr (1+ item-nr)) + (search-forward "
  • " (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 "
    " p2 t) + (setq items (1+ items))) + (goto-char p1) + (while (< item-nr items) + (setq item-nr (1+ item-nr)) + (re-search-forward "
    \\([ ]*\\)" (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 "\\([ ]*\\)\\(
    \\|
    \\)" (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)))) + +;; +;; +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; +;; + +(defun html2text-fix-paragraph (p1 p2) + (goto-char p1) + (let ((refill-start) + (refill-stop)) + (when (re-search-forward "
    $" 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 "
    " 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 + "
    " "" + refill-start (point)))) + ;; (message "Point = %s refill-stop = %s" (point) refill-stop) + ;; (sleep-for 4) + (fill-region refill-start refill-stop)))) + (html2text-replace-string "
    " "" 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 "^
    $" nil t) + (delete-region (match-beginning 0) (match-end 0))) + ;; Removing lonely
    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))))) + +;; +;;     +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; +;; + +(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 "\\(]*>\\)" 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 "" tag) (point-max) t) + (goto-char p2) + (insert (format "" tag))) + (setq p4 (point)) + (search-backward "]*\\)?>\\)" 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)))) + +;; +;; +;; +(provide 'html2text) + +;;; html2text.el ends here diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el new file mode 100644 index 00000000000..609a8f4d64b --- /dev/null +++ b/lisp/net/mailcap.el @@ -0,0 +1,1054 @@ +;;; mailcap.el --- MIME media types configuration + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: William M. Perry +;; Lars Magne Ingebrigtsen +;; 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 . + +;;; 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\" . )) + (\"text\" + (\"plain\" . ))) + +Where 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 + ;; %{ +;; 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 . + +;;; 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 \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/net/sieve-manage.el b/lisp/net/sieve-manage.el new file mode 100644 index 00000000000..695bbd860de --- /dev/null +++ b/lisp/net/sieve-manage.el @@ -0,0 +1,575 @@ +;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp + +;; Copyright (C) 2001-2016 Free Software Foundation, Inc. + +;; Author: Simon Josefsson +;; Albert Krewinkel + +;; 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 . + +;;; 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/net/sieve-mode.el b/lisp/net/sieve-mode.el new file mode 100644 index 00000000000..7575ba67c5e --- /dev/null +++ b/lisp/net/sieve-mode.el @@ -0,0 +1,221 @@ +;;; sieve-mode.el --- Sieve code editing commands for Emacs + +;; Copyright (C) 2001-2016 Free Software Foundation, Inc. + +;; Author: Simon Josefsson + +;; 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 . + +;;; 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/net/sieve.el b/lisp/net/sieve.el new file mode 100644 index 00000000000..2046e53697d --- /dev/null +++ b/lisp/net/sieve.el @@ -0,0 +1,372 @@ +;;; sieve.el --- Utilities to manage sieve scripts + +;; Copyright (C) 2001-2016 Free Software Foundation, Inc. + +;; Author: Simon Josefsson + +;; 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 . + +;;; 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 "" + "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/net/starttls.el b/lisp/net/starttls.el new file mode 100644 index 00000000000..096ed2adc0d --- /dev/null +++ b/lisp/net/starttls.el @@ -0,0 +1,304 @@ +;;; starttls.el --- STARTTLS functions + +;; Copyright (C) 1999-2016 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Author: Simon Josefsson +;; 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 . + +;;; Commentary: + +;; This module defines some utility functions for STARTTLS profiles. + +;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" +;; by Chris Newman (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 , or "starttls" +;; from . + +;; 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/plstore.el b/lisp/plstore.el new file mode 100644 index 00000000000..62c50c0f4a1 --- /dev/null +++ b/lisp/plstore.el @@ -0,0 +1,570 @@ +;;; plstore.el --- secure plist store -*- lexical-binding: t -*- +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; 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 . + +;;; 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/registry.el b/lisp/registry.el new file mode 100644 index 00000000000..e8bc6f5545a --- /dev/null +++ b/lisp/registry.el @@ -0,0 +1,379 @@ +;;; registry.el --- Track and remember data items by various fields + +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + +;; Author: Teodor Zlatanov +;; 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 . + +;;; 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/rtree.el b/lisp/rtree.el new file mode 100644 index 00000000000..662e043669a --- /dev/null +++ b/lisp/rtree.el @@ -0,0 +1,281 @@ +;;; rtree.el --- functions for manipulating range trees + +;; Copyright (C) 2010-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen + +;; 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 . + +;;; 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/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el new file mode 100644 index 00000000000..5faa1fe20bf --- /dev/null +++ b/test/lisp/auth-source-tests.el @@ -0,0 +1,223 @@ +;;; auth-source-tests.el --- Tests for auth-source.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Damien Cassou , +;; Nicolas Petton + +;; 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 . + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'auth-source) + +(defvar secrets-enabled t + "Enable the secrets backend to test its features.") + +(defun auth-source-validate-backend (source validation-alist) + (let ((backend (auth-source-backend-parse source))) + (should (auth-source-backend-p backend)) + (dolist (pair validation-alist) + (should (equal (eieio-oref backend (car pair)) (cdr pair)))))) + +(ert-deftest auth-source-backend-parse-macos-keychain () + (auth-source-validate-backend '(:source (:macos-keychain-generic foobar)) + '((:source . "foobar") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-generic-string () + (auth-source-validate-backend "macos-keychain-generic:foobar" + '((:source . "foobar") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-string () + (auth-source-validate-backend "macos-keychain-internet:foobar" + '((:source . "foobar") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-symbol () + (auth-source-validate-backend 'macos-keychain-internet + '((:source . "default") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-generic-symbol () + (auth-source-validate-backend 'macos-keychain-generic + '((:source . "default") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-default-string () + (auth-source-validate-backend 'macos-keychain-internet + '((:source . "default") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-plstore () + (auth-source-validate-backend '(:source "foo.plist") + '((:source . "foo.plist") + (:type . plstore) + (:search-function . auth-source-plstore-search) + (:create-function . auth-source-plstore-create)))) + +(ert-deftest auth-source-backend-parse-netrc () + (auth-source-validate-backend '(:source "foo") + '((:source . "foo") + (:type . netrc) + (:search-function . auth-source-netrc-search) + (:create-function . auth-source-netrc-create)))) + +(ert-deftest auth-source-backend-parse-netrc-string () + (auth-source-validate-backend "foo" + '((:source . "foo") + (:type . netrc) + (:search-function . auth-source-netrc-search) + (:create-function . auth-source-netrc-create)))) + +(ert-deftest auth-source-backend-parse-secrets () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source (:secrets "foo")) + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-strings () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend "secrets:foo" + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-nil-source () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source (:secrets nil)) + '((:source . "session") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-alias () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'foo to "foo" + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) + (auth-source-validate-backend '(:source (:secrets foo)) + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +(ert-deftest auth-source-backend-parse-secrets-symbol () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'default to "foo" + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) + (auth-source-validate-backend 'default + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +(ert-deftest auth-source-backend-parse-secrets-no-alias () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'foo to nil (so that + ;; "Login" is used by default + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) nil))) + (auth-source-validate-backend '(:source (:secrets foo)) + '((:source . "Login") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +;; TODO This test shows suspicious behavior of auth-source: the +;; "secrets" source is used even though nothing in the input indicates +;; that is what we want +(ert-deftest auth-source-backend-parse-secrets-no-source () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source '(foo)) + '((:source . "session") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(defun auth-source--test-netrc-parse-entry (entry host user port) + "Parse a netrc entry from buffer." + (auth-source-forget-all-cached) + (setq port (auth-source-ensure-strings port)) + (with-temp-buffer + (insert entry) + (goto-char (point-min)) + (let* ((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))))) + (entries (auth-source-netrc-parse-entries check 1))) + entries))) + +(ert-deftest auth-source-test-netrc-parse-entry () + (should (equal (auth-source--test-netrc-parse-entry + "machine mymachine1 login user1 password pass1\n" t t t) + '((("password" . "pass1") + ("login" . "user1") + ("machine" . "mymachine1"))))) + (should (equal (auth-source--test-netrc-parse-entry + "machine mymachine1 login user1 password pass1 port 100\n" + t t t) + '((("port" . "100") + ("password" . "pass1") + ("login" . "user1") + ("machine" . "mymachine1")))))) + +(provide 'auth-source-tests) +;;; auth-source-tests.el ends here diff --git a/test/lisp/gnus/auth-source-tests.el b/test/lisp/gnus/auth-source-tests.el deleted file mode 100644 index 5faa1fe20bf..00000000000 --- a/test/lisp/gnus/auth-source-tests.el +++ /dev/null @@ -1,223 +0,0 @@ -;;; auth-source-tests.el --- Tests for auth-source.el -*- lexical-binding: t; -*- - -;; Copyright (C) 2015-2016 Free Software Foundation, Inc. - -;; Author: Damien Cassou , -;; Nicolas Petton - -;; 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 . - -;;; Commentary: - -;; - -;;; Code: - -(require 'ert) -(require 'auth-source) - -(defvar secrets-enabled t - "Enable the secrets backend to test its features.") - -(defun auth-source-validate-backend (source validation-alist) - (let ((backend (auth-source-backend-parse source))) - (should (auth-source-backend-p backend)) - (dolist (pair validation-alist) - (should (equal (eieio-oref backend (car pair)) (cdr pair)))))) - -(ert-deftest auth-source-backend-parse-macos-keychain () - (auth-source-validate-backend '(:source (:macos-keychain-generic foobar)) - '((:source . "foobar") - (:type . macos-keychain-generic) - (:search-function . auth-source-macos-keychain-search) - (:create-function . auth-source-macos-keychain-create)))) - -(ert-deftest auth-source-backend-parse-macos-keychain-generic-string () - (auth-source-validate-backend "macos-keychain-generic:foobar" - '((:source . "foobar") - (:type . macos-keychain-generic) - (:search-function . auth-source-macos-keychain-search) - (:create-function . auth-source-macos-keychain-create)))) - -(ert-deftest auth-source-backend-parse-macos-keychain-internet-string () - (auth-source-validate-backend "macos-keychain-internet:foobar" - '((:source . "foobar") - (:type . macos-keychain-internet) - (:search-function . auth-source-macos-keychain-search) - (:create-function . auth-source-macos-keychain-create)))) - -(ert-deftest auth-source-backend-parse-macos-keychain-internet-symbol () - (auth-source-validate-backend 'macos-keychain-internet - '((:source . "default") - (:type . macos-keychain-internet) - (:search-function . auth-source-macos-keychain-search) - (:create-function . auth-source-macos-keychain-create)))) - -(ert-deftest auth-source-backend-parse-macos-keychain-generic-symbol () - (auth-source-validate-backend 'macos-keychain-generic - '((:source . "default") - (:type . macos-keychain-generic) - (:search-function . auth-source-macos-keychain-search) - (:create-function . auth-source-macos-keychain-create)))) - -(ert-deftest auth-source-backend-parse-macos-keychain-internet-default-string () - (auth-source-validate-backend 'macos-keychain-internet - '((:source . "default") - (:type . macos-keychain-internet) - (:search-function . auth-source-macos-keychain-search) - (:create-function . auth-source-macos-keychain-create)))) - -(ert-deftest auth-source-backend-parse-plstore () - (auth-source-validate-backend '(:source "foo.plist") - '((:source . "foo.plist") - (:type . plstore) - (:search-function . auth-source-plstore-search) - (:create-function . auth-source-plstore-create)))) - -(ert-deftest auth-source-backend-parse-netrc () - (auth-source-validate-backend '(:source "foo") - '((:source . "foo") - (:type . netrc) - (:search-function . auth-source-netrc-search) - (:create-function . auth-source-netrc-create)))) - -(ert-deftest auth-source-backend-parse-netrc-string () - (auth-source-validate-backend "foo" - '((:source . "foo") - (:type . netrc) - (:search-function . auth-source-netrc-search) - (:create-function . auth-source-netrc-create)))) - -(ert-deftest auth-source-backend-parse-secrets () - (provide 'secrets) ; simulates the presence of the `secrets' package - (let ((secrets-enabled t)) - (auth-source-validate-backend '(:source (:secrets "foo")) - '((:source . "foo") - (:type . secrets) - (:search-function . auth-source-secrets-search) - (:create-function . auth-source-secrets-create))))) - -(ert-deftest auth-source-backend-parse-secrets-strings () - (provide 'secrets) ; simulates the presence of the `secrets' package - (let ((secrets-enabled t)) - (auth-source-validate-backend "secrets:foo" - '((:source . "foo") - (:type . secrets) - (:search-function . auth-source-secrets-search) - (:create-function . auth-source-secrets-create))))) - -(ert-deftest auth-source-backend-parse-secrets-nil-source () - (provide 'secrets) ; simulates the presence of the `secrets' package - (let ((secrets-enabled t)) - (auth-source-validate-backend '(:source (:secrets nil)) - '((:source . "session") - (:type . secrets) - (:search-function . auth-source-secrets-search) - (:create-function . auth-source-secrets-create))))) - -(ert-deftest auth-source-backend-parse-secrets-alias () - (provide 'secrets) ; simulates the presence of the `secrets' package - (let ((secrets-enabled t)) - ;; Redefine `secrets-get-alias' to map 'foo to "foo" - (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) - (auth-source-validate-backend '(:source (:secrets foo)) - '((:source . "foo") - (:type . secrets) - (:search-function . auth-source-secrets-search) - (:create-function . auth-source-secrets-create)))))) - -(ert-deftest auth-source-backend-parse-secrets-symbol () - (provide 'secrets) ; simulates the presence of the `secrets' package - (let ((secrets-enabled t)) - ;; Redefine `secrets-get-alias' to map 'default to "foo" - (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) - (auth-source-validate-backend 'default - '((:source . "foo") - (:type . secrets) - (:search-function . auth-source-secrets-search) - (:create-function . auth-source-secrets-create)))))) - -(ert-deftest auth-source-backend-parse-secrets-no-alias () - (provide 'secrets) ; simulates the presence of the `secrets' package - (let ((secrets-enabled t)) - ;; Redefine `secrets-get-alias' to map 'foo to nil (so that - ;; "Login" is used by default - (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) nil))) - (auth-source-validate-backend '(:source (:secrets foo)) - '((:source . "Login") - (:type . secrets) - (:search-function . auth-source-secrets-search) - (:create-function . auth-source-secrets-create)))))) - -;; TODO This test shows suspicious behavior of auth-source: the -;; "secrets" source is used even though nothing in the input indicates -;; that is what we want -(ert-deftest auth-source-backend-parse-secrets-no-source () - (provide 'secrets) ; simulates the presence of the `secrets' package - (let ((secrets-enabled t)) - (auth-source-validate-backend '(:source '(foo)) - '((:source . "session") - (:type . secrets) - (:search-function . auth-source-secrets-search) - (:create-function . auth-source-secrets-create))))) - -(defun auth-source--test-netrc-parse-entry (entry host user port) - "Parse a netrc entry from buffer." - (auth-source-forget-all-cached) - (setq port (auth-source-ensure-strings port)) - (with-temp-buffer - (insert entry) - (goto-char (point-min)) - (let* ((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))))) - (entries (auth-source-netrc-parse-entries check 1))) - entries))) - -(ert-deftest auth-source-test-netrc-parse-entry () - (should (equal (auth-source--test-netrc-parse-entry - "machine mymachine1 login user1 password pass1\n" t t t) - '((("password" . "pass1") - ("login" . "user1") - ("machine" . "mymachine1"))))) - (should (equal (auth-source--test-netrc-parse-entry - "machine mymachine1 login user1 password pass1 port 100\n" - t t t) - '((("port" . "100") - ("password" . "pass1") - ("login" . "user1") - ("machine" . "mymachine1")))))) - -(provide 'auth-source-tests) -;;; auth-source-tests.el ends here