--- /dev/null
+;;; auth-source.el --- authentication sources for Gnus and Emacs
+
+;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
+
+;; Author: Ted Zlatanov <tzz@lifelogs.com>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is the auth-source.el package. It lets users tell Gnus how to
+;; authenticate in a single place. Simplicity is the goal. Instead
+;; of providing 5000 options, we'll stick to simple, easy to
+;; understand options.
+
+;; See the auth.info Info documentation for details.
+
+;; TODO:
+
+;; - never decode the backend file unless it's necessary
+;; - a more generic way to match backends and search backend contents
+;; - absorb netrc.el and simplify it
+;; - protect passwords better
+;; - allow creating and changing netrc lines (not files) e.g. change a password
+
+;;; Code:
+
+(require 'password-cache)
+
+(eval-when-compile (require 'cl))
+(require 'eieio)
+
+(autoload 'secrets-create-item "secrets")
+(autoload 'secrets-delete-item "secrets")
+(autoload 'secrets-get-alias "secrets")
+(autoload 'secrets-get-attributes "secrets")
+(autoload 'secrets-get-secret "secrets")
+(autoload 'secrets-list-collections "secrets")
+(autoload 'secrets-search-items "secrets")
+
+(autoload 'rfc2104-hash "rfc2104")
+
+(autoload 'plstore-open "plstore")
+(autoload 'plstore-find "plstore")
+(autoload 'plstore-put "plstore")
+(autoload 'plstore-delete "plstore")
+(autoload 'plstore-save "plstore")
+(autoload 'plstore-get-file "plstore")
+
+(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor'
+(autoload 'epg-make-context "epg")
+(autoload 'epg-context-set-passphrase-callback "epg")
+(autoload 'epg-decrypt-string "epg")
+(autoload 'epg-encrypt-string "epg")
+
+(autoload 'help-mode "help-mode" nil t)
+
+(defvar secrets-enabled)
+
+(defgroup auth-source nil
+ "Authentication sources."
+ :version "23.1" ;; No Gnus
+ :group 'gnus)
+
+;;;###autoload
+(defcustom auth-source-cache-expiry 7200
+ "How many seconds passwords are cached, or nil to disable
+expiring. Overrides `password-cache-expiry' through a
+let-binding."
+ :version "24.1"
+ :group 'auth-source
+ :type '(choice (const :tag "Never" nil)
+ (const :tag "All Day" 86400)
+ (const :tag "2 Hours" 7200)
+ (const :tag "30 Minutes" 1800)
+ (integer :tag "Seconds")))
+
+;; The slots below correspond with the `auth-source-search' spec,
+;; so a backend with :host set, for instance, would match only
+;; searches for that host. Normally they are nil.
+(defclass auth-source-backend ()
+ ((type :initarg :type
+ :initform 'netrc
+ :type symbol
+ :custom symbol
+ :documentation "The backend type.")
+ (source :initarg :source
+ :type string
+ :custom string
+ :documentation "The backend source.")
+ (host :initarg :host
+ :initform t
+ :type t
+ :custom string
+ :documentation "The backend host.")
+ (user :initarg :user
+ :initform t
+ :type t
+ :custom string
+ :documentation "The backend user.")
+ (port :initarg :port
+ :initform t
+ :type t
+ :custom string
+ :documentation "The backend protocol.")
+ (data :initarg :data
+ :initform nil
+ :documentation "Internal backend data.")
+ (create-function :initarg :create-function
+ :initform ignore
+ :type function
+ :custom function
+ :documentation "The create function.")
+ (search-function :initarg :search-function
+ :initform ignore
+ :type function
+ :custom function
+ :documentation "The search function.")))
+
+(defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
+ (pop3 "pop3" "pop" "pop3s" "110" "995")
+ (ssh "ssh" "22")
+ (sftp "sftp" "115")
+ (smtp "smtp" "25"))
+ "List of authentication protocols and their names"
+
+ :group 'auth-source
+ :version "23.2" ;; No Gnus
+ :type '(repeat :tag "Authentication Protocols"
+ (cons :tag "Protocol Entry"
+ (symbol :tag "Protocol")
+ (repeat :tag "Names"
+ (string :tag "Name")))))
+
+;; Generate all the protocols in a format Customize can use.
+;; TODO: generate on the fly from auth-source-protocols
+(defconst auth-source-protocols-customize
+ (mapcar (lambda (a)
+ (let ((p (car-safe a)))
+ (list 'const
+ :tag (upcase (symbol-name p))
+ p)))
+ auth-source-protocols))
+
+(defvar auth-source-creation-defaults nil
+ ;; FIXME: AFAICT this is not set (or let-bound) anywhere!
+ "Defaults for creating token values. Usually let-bound.")
+
+(defvar auth-source-creation-prompts nil
+ "Default prompts for token values. Usually let-bound.")
+
+(make-obsolete 'auth-source-hide-passwords nil "Emacs 24.1")
+
+(defcustom auth-source-save-behavior 'ask
+ "If set, auth-source will respect it for save behavior."
+ :group 'auth-source
+ :version "23.2" ;; No Gnus
+ :type `(choice
+ :tag "auth-source new token save behavior"
+ (const :tag "Always save" t)
+ (const :tag "Never save" nil)
+ (const :tag "Ask" ask)))
+
+;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car epa-file-auto-mode-alist-entry) "\\.gpg\\'") never) (t gpg)))
+;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never)
+
+(defcustom auth-source-netrc-use-gpg-tokens 'never
+ "Set this to tell auth-source when to create GPG password
+tokens in netrc files. It's either an alist or `never'.
+Note that if EPA/EPG is not available, this should NOT be used."
+ :group 'auth-source
+ :version "23.2" ;; No Gnus
+ :type `(choice
+ (const :tag "Always use GPG password tokens" (t gpg))
+ (const :tag "Never use GPG password tokens" never)
+ (repeat :tag "Use a lookup list"
+ (list
+ (choice :tag "Matcher"
+ (const :tag "Match anything" t)
+ (const :tag "The EPA encrypted file extensions"
+ ,(if (boundp 'epa-file-auto-mode-alist-entry)
+ (car epa-file-auto-mode-alist-entry)
+ "\\.gpg\\'"))
+ (regexp :tag "Regular expression"))
+ (choice :tag "What to do"
+ (const :tag "Save GPG-encrypted password tokens" gpg)
+ (const :tag "Don't encrypt tokens" never))))))
+
+(defvar auth-source-magic "auth-source-magic ")
+
+(defcustom auth-source-do-cache t
+ "Whether auth-source should cache information with `password-cache'."
+ :group 'auth-source
+ :version "23.2" ;; No Gnus
+ :type `boolean)
+
+(defcustom auth-source-debug nil
+ "Whether auth-source should log debug messages.
+
+If the value is nil, debug messages are not logged.
+
+If the value is t, debug messages are logged with `message'. In
+that case, your authentication data will be in the clear (except
+for passwords).
+
+If the value is a function, debug messages are logged by calling
+ that function using the same arguments as `message'."
+ :group 'auth-source
+ :version "23.2" ;; No Gnus
+ :type `(choice
+ :tag "auth-source debugging mode"
+ (const :tag "Log using `message' to the *Messages* buffer" t)
+ (const :tag "Log all trivia with `message' to the *Messages* buffer"
+ trivia)
+ (function :tag "Function that takes arguments like `message'")
+ (const :tag "Don't log anything" nil)))
+
+(defcustom auth-sources '("~/.authinfo" "~/.authinfo.gpg" "~/.netrc")
+ "List of authentication sources.
+Each entry is the authentication type with optional properties.
+Entries are tried in the order in which they appear.
+See Info node `(auth)Help for users' for details.
+
+If an entry names a file with the \".gpg\" extension and you have
+EPA/EPG set up, the file will be encrypted and decrypted
+automatically. See Info node `(epa)Encrypting/decrypting gpg files'
+for details.
+
+It's best to customize this with `\\[customize-variable]' because the choices
+can get pretty complex."
+ :group 'auth-source
+ :version "24.1" ;; No Gnus
+ :type `(repeat :tag "Authentication Sources"
+ (choice
+ (string :tag "Just a file")
+ (const :tag "Default Secrets API Collection" default)
+ (const :tag "Login Secrets API Collection" "secrets:Login")
+ (const :tag "Temp Secrets API Collection" "secrets:session")
+
+ (const :tag "Default internet Mac OS Keychain"
+ macos-keychain-internet)
+
+ (const :tag "Default generic Mac OS Keychain"
+ macos-keychain-generic)
+
+ (list :tag "Source definition"
+ (const :format "" :value :source)
+ (choice :tag "Authentication backend choice"
+ (string :tag "Authentication Source (file)")
+ (list
+ :tag "Secret Service API/KWallet/GNOME Keyring"
+ (const :format "" :value :secrets)
+ (choice :tag "Collection to use"
+ (string :tag "Collection name")
+ (const :tag "Default" default)
+ (const :tag "Login" "Login")
+ (const
+ :tag "Temporary" "session")))
+ (list
+ :tag "Mac OS internet Keychain"
+ (const :format ""
+ :value :macos-keychain-internet)
+ (choice :tag "Collection to use"
+ (string :tag "internet Keychain path")
+ (const :tag "default" default)))
+ (list
+ :tag "Mac OS generic Keychain"
+ (const :format ""
+ :value :macos-keychain-generic)
+ (choice :tag "Collection to use"
+ (string :tag "generic Keychain path")
+ (const :tag "default" default))))
+ (repeat :tag "Extra Parameters" :inline t
+ (choice :tag "Extra parameter"
+ (list
+ :tag "Host"
+ (const :format "" :value :host)
+ (choice :tag "Host (machine) choice"
+ (const :tag "Any" t)
+ (regexp
+ :tag "Regular expression")))
+ (list
+ :tag "Protocol"
+ (const :format "" :value :port)
+ (choice
+ :tag "Protocol"
+ (const :tag "Any" t)
+ ,@auth-source-protocols-customize))
+ (list :tag "User" :inline t
+ (const :format "" :value :user)
+ (choice
+ :tag "Personality/Username"
+ (const :tag "Any" t)
+ (string
+ :tag "Name")))))))))
+
+(defcustom auth-source-gpg-encrypt-to t
+ "List of recipient keys that `authinfo.gpg' encrypted to.
+If the value is not a list, symmetric encryption will be used."
+ :group 'auth-source
+ :version "24.1" ;; No Gnus
+ :type '(choice (const :tag "Symmetric encryption" t)
+ (repeat :tag "Recipient public keys"
+ (string :tag "Recipient public key"))))
+
+;; temp for debugging
+;; (unintern 'auth-source-protocols)
+;; (unintern 'auth-sources)
+;; (customize-variable 'auth-sources)
+;; (setq auth-sources nil)
+;; (format "%S" auth-sources)
+;; (customize-variable 'auth-source-protocols)
+;; (setq auth-source-protocols nil)
+;; (format "%S" auth-source-protocols)
+;; (auth-source-pick nil :host "a" :port 'imap)
+;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
+;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
+;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
+;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
+;; (auth-source-protocol-defaults 'imap)
+
+;; (let ((auth-source-debug 'debug)) (auth-source-do-debug "hello"))
+;; (let ((auth-source-debug t)) (auth-source-do-debug "hello"))
+;; (let ((auth-source-debug nil)) (auth-source-do-debug "hello"))
+(defun auth-source-do-debug (&rest msg)
+ (when auth-source-debug
+ (apply #'auth-source-do-warn msg)))
+
+(defun auth-source-do-trivia (&rest msg)
+ (when (or (eq auth-source-debug 'trivia)
+ (functionp auth-source-debug))
+ (apply #'auth-source-do-warn msg)))
+
+(defun auth-source-do-warn (&rest msg)
+ (apply
+ ;; set logger to either the function in auth-source-debug or 'message
+ ;; note that it will be 'message if auth-source-debug is nil
+ (if (functionp auth-source-debug)
+ auth-source-debug
+ 'message)
+ msg))
+
+
+;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q))
+(defun auth-source-read-char-choice (prompt choices)
+ "Read one of CHOICES by `read-char-choice', or `read-char'.
+`dropdown-list' support is disabled because it doesn't work reliably.
+Only one of CHOICES will be returned. The PROMPT is augmented
+with \"[a/b/c] \" if CHOICES is \(?a ?b ?c)."
+ (when choices
+ (let* ((prompt-choices
+ (apply #'concat (loop for c in choices
+ collect (format "%c/" c))))
+ (prompt-choices (concat "[" (substring prompt-choices 0 -1) "] "))
+ (full-prompt (concat prompt prompt-choices))
+ k)
+
+ (while (not (memq k choices))
+ (setq k (read-char-choice full-prompt choices)))
+ k)))
+
+;; (auth-source-pick nil :host "any" :port 'imap :user "joe")
+;; (auth-source-pick t :host "any" :port 'imap :user "joe")
+;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe")
+;; (:source (:secrets "session") :host t :port t :user "joe")
+;; (:source (:secrets "Login") :host t :port t)
+;; (:source "~/.authinfo.gpg" :host t :port t)))
+
+;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe")
+;; (:source (:secrets "session") :host t :port t :user "joe")
+;; (:source (:secrets "Login") :host t :port t)
+;; ))
+
+;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :port t)))
+
+;; (auth-source-backend-parse "myfile.gpg")
+;; (auth-source-backend-parse 'default)
+;; (auth-source-backend-parse "secrets:Login")
+;; (auth-source-backend-parse 'macos-keychain-internet)
+;; (auth-source-backend-parse 'macos-keychain-generic)
+;; (auth-source-backend-parse "macos-keychain-internet:/path/here.keychain")
+;; (auth-source-backend-parse "macos-keychain-generic:/path/here.keychain")
+
+(defun auth-source-backend-parse (entry)
+ "Creates an auth-source-backend from an ENTRY in `auth-sources'."
+ (auth-source-backend-parse-parameters
+ entry
+ (cond
+ ;; take 'default and recurse to get it as a Secrets API default collection
+ ;; matching any user, host, and protocol
+ ((eq entry 'default)
+ (auth-source-backend-parse '(:source (:secrets default))))
+ ;; take secrets:XYZ and recurse to get it as Secrets API collection "XYZ"
+ ;; matching any user, host, and protocol
+ ((and (stringp entry) (string-match "^secrets:\\(.+\\)" entry))
+ (auth-source-backend-parse `(:source (:secrets ,(match-string 1 entry)))))
+
+ ;; take 'macos-keychain-internet and recurse to get it as a Mac OS
+ ;; Keychain collection matching any user, host, and protocol
+ ((eq entry 'macos-keychain-internet)
+ (auth-source-backend-parse '(:source (:macos-keychain-internet default))))
+ ;; take 'macos-keychain-generic and recurse to get it as a Mac OS
+ ;; Keychain collection matching any user, host, and protocol
+ ((eq entry 'macos-keychain-generic)
+ (auth-source-backend-parse '(:source (:macos-keychain-generic default))))
+ ;; take macos-keychain-internet:XYZ and recurse to get it as MacOS
+ ;; Keychain "XYZ" matching any user, host, and protocol
+ ((and (stringp entry) (string-match "^macos-keychain-internet:\\(.+\\)"
+ entry))
+ (auth-source-backend-parse `(:source (:macos-keychain-internet
+ ,(match-string 1 entry)))))
+ ;; take macos-keychain-generic:XYZ and recurse to get it as MacOS
+ ;; Keychain "XYZ" matching any user, host, and protocol
+ ((and (stringp entry) (string-match "^macos-keychain-generic:\\(.+\\)"
+ entry))
+ (auth-source-backend-parse `(:source (:macos-keychain-generic
+ ,(match-string 1 entry)))))
+
+ ;; take just a file name and recurse to get it as a netrc file
+ ;; matching any user, host, and protocol
+ ((stringp entry)
+ (auth-source-backend-parse `(:source ,entry)))
+
+ ;; a file name with parameters
+ ((stringp (plist-get entry :source))
+ (if (equal (file-name-extension (plist-get entry :source)) "plist")
+ (auth-source-backend
+ (plist-get entry :source)
+ :source (plist-get entry :source)
+ :type 'plstore
+ :search-function #'auth-source-plstore-search
+ :create-function #'auth-source-plstore-create
+ :data (plstore-open (plist-get entry :source)))
+ (auth-source-backend
+ (plist-get entry :source)
+ :source (plist-get entry :source)
+ :type 'netrc
+ :search-function #'auth-source-netrc-search
+ :create-function #'auth-source-netrc-create)))
+
+ ;; the MacOS Keychain
+ ((and
+ (not (null (plist-get entry :source))) ; the source must not be nil
+ (listp (plist-get entry :source)) ; and it must be a list
+ (or
+ (plist-get (plist-get entry :source) :macos-keychain-generic)
+ (plist-get (plist-get entry :source) :macos-keychain-internet)))
+
+ (let* ((source-spec (plist-get entry :source))
+ (keychain-generic (plist-get source-spec :macos-keychain-generic))
+ (keychain-type (if keychain-generic
+ 'macos-keychain-generic
+ 'macos-keychain-internet))
+ (source (plist-get source-spec (if keychain-generic
+ :macos-keychain-generic
+ :macos-keychain-internet))))
+
+ (when (symbolp source)
+ (setq source (symbol-name source)))
+
+ (auth-source-backend
+ (format "Mac OS Keychain (%s)" source)
+ :source source
+ :type keychain-type
+ :search-function #'auth-source-macos-keychain-search
+ :create-function #'auth-source-macos-keychain-create)))
+
+ ;; the Secrets API. We require the package, in order to have a
+ ;; defined value for `secrets-enabled'.
+ ((and
+ (not (null (plist-get entry :source))) ; the source must not be nil
+ (listp (plist-get entry :source)) ; and it must be a list
+ (require 'secrets nil t) ; and we must load the Secrets API
+ secrets-enabled) ; and that API must be enabled
+
+ ;; the source is either the :secrets key in ENTRY or
+ ;; if that's missing or nil, it's "session"
+ (let ((source (or (plist-get (plist-get entry :source) :secrets)
+ "session")))
+
+ ;; if the source is a symbol, we look for the alias named so,
+ ;; and if that alias is missing, we use "Login"
+ (when (symbolp source)
+ (setq source (or (secrets-get-alias (symbol-name source))
+ "Login")))
+
+ (if (featurep 'secrets)
+ (auth-source-backend
+ (format "Secrets API (%s)" source)
+ :source source
+ :type 'secrets
+ :search-function #'auth-source-secrets-search
+ :create-function #'auth-source-secrets-create)
+ (auth-source-do-warn
+ "auth-source-backend-parse: no Secrets API, ignoring spec: %S" entry)
+ (auth-source-backend
+ (format "Ignored Secrets API (%s)" source)
+ :source ""
+ :type 'ignore))))
+
+ ;; none of them
+ (t
+ (auth-source-do-warn
+ "auth-source-backend-parse: invalid backend spec: %S" entry)
+ (make-instance 'auth-source-backend
+ :source ""
+ :type 'ignore)))))
+
+(defun auth-source-backend-parse-parameters (entry backend)
+ "Fills in the extra auth-source-backend parameters of ENTRY.
+Using the plist ENTRY, get the :host, :port, and :user search
+parameters."
+ (let ((entry (if (stringp entry)
+ nil
+ entry))
+ val)
+ (when (setq val (plist-get entry :host))
+ (oset backend host val))
+ (when (setq val (plist-get entry :user))
+ (oset backend user val))
+ (when (setq val (plist-get entry :port))
+ (oset backend port val)))
+ backend)
+
+;; (mapcar 'auth-source-backend-parse auth-sources)
+
+(defun* auth-source-search (&rest spec
+ &key max
+ require create delete
+ &allow-other-keys)
+ "Search or modify authentication backends according to SPEC.
+
+This function parses `auth-sources' for matches of the SPEC
+plist. It can optionally create or update an authentication
+token if requested. A token is just a standard Emacs property
+list with a :secret property that can be a function; all the
+other properties will always hold scalar values.
+
+Typically the :secret property, if present, contains a password.
+
+Common search keys are :max, :host, :port, and :user. In
+addition, :create specifies if and how tokens will be created.
+Finally, :type can specify which backend types you want to check.
+
+A string value is always matched literally. A symbol is matched
+as its string value, literally. All the SPEC values can be
+single values (symbol or string) or lists thereof (in which case
+any of the search terms matches).
+
+:create t means to create a token if possible.
+
+A new token will be created if no matching tokens were found.
+The new token will have only the keys the backend requires. For
+the netrc backend, for instance, that's the user, host, and
+port keys.
+
+Here's an example:
+
+\(let ((auth-source-creation-defaults \\='((user . \"defaultUser\")
+ (A . \"default A\"))))
+ (auth-source-search :host \"mine\" :type \\='netrc :max 1
+ :P \"pppp\" :Q \"qqqq\"
+ :create t))
+
+which says:
+
+\"Search for any entry matching host `mine' in backends of type
+ `netrc', maximum one result.
+
+ Create a new entry if you found none. The netrc backend will
+ automatically require host, user, and port. The host will be
+ `mine'. We prompt for the user with default `defaultUser' and
+ for the port without a default. We will not prompt for A, Q,
+ or P. The resulting token will only have keys user, host, and
+ port.\"
+
+:create \\='(A B C) also means to create a token if possible.
+
+The behavior is like :create t but if the list contains any
+parameter, that parameter will be required in the resulting
+token. The value for that parameter will be obtained from the
+search parameters or from user input. If any queries are needed,
+the alist `auth-source-creation-defaults' will be checked for the
+default value. If the user, host, or port are missing, the alist
+`auth-source-creation-prompts' will be used to look up the
+prompts IN THAT ORDER (so the `user' prompt will be queried first,
+then `host', then `port', and finally `secret'). Each prompt string
+can use %u, %h, and %p to show the user, host, and port.
+
+Here's an example:
+
+\(let ((auth-source-creation-defaults \\='((user . \"defaultUser\")
+ (A . \"default A\")))
+ (auth-source-creation-prompts
+ \\='((password . \"Enter IMAP password for %h:%p: \"))))
+ (auth-source-search :host \\='(\"nonesuch\" \"twosuch\") :type \\='netrc :max 1
+ :P \"pppp\" :Q \"qqqq\"
+ :create \\='(A B Q)))
+
+which says:
+
+\"Search for any entry matching host `nonesuch'
+ or `twosuch' in backends of type `netrc', maximum one result.
+
+ Create a new entry if you found none. The netrc backend will
+ automatically require host, user, and port. The host will be
+ `nonesuch' and Q will be `qqqq'. We prompt for the password
+ with the shown prompt. We will not prompt for Q. The resulting
+ token will have keys user, host, port, A, B, and Q. It will not
+ have P with any value, even though P is used in the search to
+ find only entries that have P set to `pppp'.\"
+
+When multiple values are specified in the search parameter, the
+user is prompted for which one. So :host (X Y Z) would ask the
+user to choose between X, Y, and Z.
+
+This creation can fail if the search was not specific enough to
+create a new token (it's up to the backend to decide that). You
+should `catch' the backend-specific error as usual. Some
+backends (netrc, at least) will prompt the user rather than throw
+an error.
+
+:require (A B C) means that only results that contain those
+tokens will be returned. Thus for instance requiring :secret
+will ensure that any results will actually have a :secret
+property.
+
+:delete t means to delete any found entries. nil by default.
+Use `auth-source-delete' in ELisp code instead of calling
+`auth-source-search' directly with this parameter.
+
+:type (X Y Z) will check only those backend types. `netrc' and
+`secrets' are the only ones supported right now.
+
+:max N means to try to return at most N items (defaults to 1).
+More than N items may be returned, depending on the search and
+the backend.
+
+When :max is 0 the function will return just t or nil to indicate
+if any matches were found.
+
+:host (X Y Z) means to match only hosts X, Y, or Z according to
+the match rules above. Defaults to t.
+
+:user (X Y Z) means to match only users X, Y, or Z according to
+the match rules above. Defaults to t.
+
+:port (P Q R) means to match only protocols P, Q, or R.
+Defaults to t.
+
+:K (V1 V2 V3) for any other key K will match values V1, V2, or
+V3 (note the match rules above).
+
+The return value is a list with at most :max tokens. Each token
+is a plist with keys :backend :host :port :user, plus any other
+keys provided by the backend (notably :secret). But note the
+exception for :max 0, which see above.
+
+The token can hold a :save-function key. If you call that, the
+user will be prompted to save the data to the backend. You can't
+request that this should happen right after creation, because
+`auth-source-search' has no way of knowing if the token is
+actually useful. So the caller must arrange to call this function.
+
+The token's :secret key can hold a function. In that case you
+must call it to obtain the actual value."
+ (let* ((backends (mapcar #'auth-source-backend-parse auth-sources))
+ (max (or max 1))
+ (ignored-keys '(:require :create :delete :max))
+ (keys (loop for i below (length spec) by 2
+ unless (memq (nth i spec) ignored-keys)
+ collect (nth i spec)))
+ (cached (auth-source-remembered-p spec))
+ ;; note that we may have cached results but found is still nil
+ ;; (there were no results from the search)
+ (found (auth-source-recall spec))
+ filtered-backends)
+
+ (if (and cached auth-source-do-cache)
+ (auth-source-do-debug
+ "auth-source-search: found %d CACHED results matching %S"
+ (length found) spec)
+
+ (assert
+ (or (eq t create) (listp create)) t
+ "Invalid auth-source :create parameter (must be t or a list): %s %s")
+
+ (assert
+ (listp require) t
+ "Invalid auth-source :require parameter (must be a list): %s")
+
+ (setq filtered-backends (copy-sequence backends))
+ (dolist (backend backends)
+ (dolist (key keys)
+ ;; ignore invalid slots
+ (condition-case nil
+ (unless (auth-source-search-collection
+ (plist-get spec key)
+ (slot-value backend key))
+ (setq filtered-backends (delq backend filtered-backends))
+ (return))
+ (invalid-slot-name nil))))
+
+ (auth-source-do-trivia
+ "auth-source-search: found %d backends matching %S"
+ (length filtered-backends) spec)
+
+ ;; (debug spec "filtered" filtered-backends)
+ ;; First go through all the backends without :create, so we can
+ ;; query them all.
+ (setq found (auth-source-search-backends filtered-backends
+ spec
+ ;; to exit early
+ max
+ ;; create is always nil here
+ nil delete
+ require))
+
+ (auth-source-do-debug
+ "auth-source-search: found %d results (max %d) matching %S"
+ (length found) max spec)
+
+ ;; If we didn't find anything, then we allow the backend(s) to
+ ;; create the entries.
+ (when (and create
+ (not found))
+ (setq found (auth-source-search-backends filtered-backends
+ spec
+ ;; to exit early
+ max
+ create delete
+ require))
+ (auth-source-do-debug
+ "auth-source-search: CREATED %d results (max %d) matching %S"
+ (length found) max spec))
+
+ ;; note we remember the lack of result too, if it's applicable
+ (when auth-source-do-cache
+ (auth-source-remember spec found)))
+
+ (if (zerop max)
+ (not (null found))
+ found)))
+
+(defun auth-source-search-backends (backends spec max create delete require)
+ (let ((max (if (zerop max) 1 max)) ; stop with 1 match if we're asked for zero
+ matches)
+ (dolist (backend backends)
+ (when (> max (length matches)) ; if we need more matches...
+ (let* ((bmatches (apply
+ (slot-value backend 'search-function)
+ :backend backend
+ :type (slot-value backend 'type)
+ ;; note we're overriding whatever the spec
+ ;; has for :max, :require, :create, and :delete
+ :max max
+ :require require
+ :create create
+ :delete delete
+ spec)))
+ (when bmatches
+ (auth-source-do-trivia
+ "auth-source-search-backend: got %d (max %d) in %s:%s matching %S"
+ (length bmatches) max
+ (slot-value backend 'type)
+ (slot-value backend 'source)
+ spec)
+ (setq matches (append matches bmatches))))))
+ matches))
+
+;; (auth-source-search :max 0)
+;; (auth-source-search :max 1)
+;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret))
+;; (auth-source-search :host "nonesuch" :type 'netrc :K 1)
+;; (auth-source-search :host "nonesuch" :type 'secrets)
+
+(defun auth-source-delete (&rest spec)
+ "Delete entries from the authentication backends according to SPEC.
+Calls `auth-source-search' with the :delete property in SPEC set to t.
+The backend may not actually delete the entries.
+
+Returns the deleted entries."
+ (auth-source-search (plist-put spec :delete t)))
+
+(defun auth-source-search-collection (collection value)
+ "Returns t is VALUE is t or COLLECTION is t or COLLECTION contains VALUE."
+ (when (and (atom collection) (not (eq t collection)))
+ (setq collection (list collection)))
+
+ ;; (debug :collection collection :value value)
+ (or (eq collection t)
+ (eq value t)
+ (equal collection value)
+ (member value collection)))
+
+(defvar auth-source-netrc-cache nil)
+
+(defun auth-source-forget-all-cached ()
+ "Forget all cached auth-source data."
+ (interactive)
+ (loop for sym being the symbols of password-data
+ ;; when the symbol name starts with auth-source-magic
+ when (string-match (concat "^" auth-source-magic)
+ (symbol-name sym))
+ ;; remove that key
+ do (password-cache-remove (symbol-name sym)))
+ (setq auth-source-netrc-cache nil))
+
+(defun auth-source-format-cache-entry (spec)
+ "Format SPEC entry to put it in the password cache."
+ (concat auth-source-magic (format "%S" spec)))
+
+(defun auth-source-remember (spec found)
+ "Remember FOUND search results for SPEC."
+ (let ((password-cache-expiry auth-source-cache-expiry))
+ (password-cache-add
+ (auth-source-format-cache-entry spec) found)))
+
+(defun auth-source-recall (spec)
+ "Recall FOUND search results for SPEC."
+ (password-read-from-cache (auth-source-format-cache-entry spec)))
+
+(defun auth-source-remembered-p (spec)
+ "Check if SPEC is remembered."
+ (password-in-cache-p
+ (auth-source-format-cache-entry spec)))
+
+(defun auth-source-forget (spec)
+ "Forget any cached data matching SPEC exactly.
+
+This is the same SPEC you passed to `auth-source-search'.
+Returns t or nil for forgotten or not found."
+ (password-cache-remove (auth-source-format-cache-entry spec)))
+
+;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym))
+
+;; (auth-source-remember '(:host "wedd") '(4 5 6))
+;; (auth-source-remembered-p '(:host "wedd"))
+;; (auth-source-remember '(:host "xedd") '(1 2 3))
+;; (auth-source-remembered-p '(:host "xedd"))
+;; (auth-source-remembered-p '(:host "zedd"))
+;; (auth-source-recall '(:host "xedd"))
+;; (auth-source-recall '(:host t))
+;; (auth-source-forget+ :host t)
+
+(defun auth-source-forget+ (&rest spec)
+ "Forget any cached data matching SPEC. Returns forgotten count.
+
+This is not a full `auth-source-search' spec but works similarly.
+For instance, \(:host \"myhost\" \"yourhost\") would find all the
+cached data that was found with a search for those two hosts,
+while \(:host t) would find all host entries."
+ (let ((count 0)
+ sname)
+ (loop for sym being the symbols of password-data
+ ;; when the symbol name matches with auth-source-magic
+ when (and (setq sname (symbol-name sym))
+ (string-match (concat "^" auth-source-magic "\\(.+\\)")
+ sname)
+ ;; and the spec matches what was stored in the cache
+ (auth-source-specmatchp spec (read (match-string 1 sname))))
+ ;; remove that key
+ do (progn
+ (password-cache-remove sname)
+ (incf count)))
+ count))
+
+(defun auth-source-specmatchp (spec stored)
+ (let ((keys (loop for i below (length spec) by 2
+ collect (nth i spec))))
+ (not (eq
+ (dolist (key keys)
+ (unless (auth-source-search-collection (plist-get stored key)
+ (plist-get spec key))
+ (return 'no)))
+ 'no))))
+
+;; (auth-source-pick-first-password :host "z.lifelogs.com")
+;; (auth-source-pick-first-password :port "imap")
+(defun auth-source-pick-first-password (&rest spec)
+ "Pick the first secret found from applying SPEC to `auth-source-search'."
+ (let* ((result (nth 0 (apply #'auth-source-search (plist-put spec :max 1))))
+ (secret (plist-get result :secret)))
+
+ (if (functionp secret)
+ (funcall secret)
+ secret)))
+
+;; (auth-source-format-prompt "test %u %h %p" '((?u "user") (?h "host")))
+(defun auth-source-format-prompt (prompt alist)
+ "Format PROMPT using %x (for any character x) specifiers in ALIST."
+ (dolist (cell alist)
+ (let ((c (nth 0 cell))
+ (v (nth 1 cell)))
+ (when (and c v)
+ (setq prompt (replace-regexp-in-string (format "%%%c" c)
+ (format "%s" v)
+ prompt nil t)))))
+ prompt)
+
+(defun auth-source-ensure-strings (values)
+ (if (eq values t)
+ values
+ (unless (listp values)
+ (setq values (list values)))
+ (mapcar (lambda (value)
+ (if (numberp value)
+ (format "%s" value)
+ value))
+ values)))
+
+;;; Backend specific parsing: netrc/authinfo backend
+
+(defun auth-source--aput-1 (alist key val)
+ (let ((seen ())
+ (rest alist))
+ (while (and (consp rest) (not (equal key (caar rest))))
+ (push (pop rest) seen))
+ (cons (cons key val)
+ (if (null rest) alist
+ (nconc (nreverse seen)
+ (if (equal key (caar rest)) (cdr rest) rest))))))
+(defmacro auth-source--aput (var key val)
+ `(setq ,var (auth-source--aput-1 ,var ,key ,val)))
+
+(defun auth-source--aget (alist key)
+ (cdr (assoc key alist)))
+
+;; (auth-source-netrc-parse :file "~/.authinfo.gpg")
+(defun* auth-source-netrc-parse (&key file max host user port require
+ &allow-other-keys)
+ "Parse FILE and return a list of all entries in the file.
+Note that the MAX parameter is used so we can exit the parse early."
+ (if (listp file)
+ ;; We got already parsed contents; just return it.
+ file
+ (when (file-exists-p file)
+ (setq port (auth-source-ensure-strings port))
+ (with-temp-buffer
+ (let* ((max (or max 5000)) ; sanity check: default to stop at 5K
+ (modified 0)
+ (cached (cdr-safe (assoc file auth-source-netrc-cache)))
+ (cached-mtime (plist-get cached :mtime))
+ (cached-secrets (plist-get cached :secret))
+ (check (lambda(alist)
+ (and alist
+ (auth-source-search-collection
+ host
+ (or
+ (auth-source--aget alist "machine")
+ (auth-source--aget alist "host")
+ t))
+ (auth-source-search-collection
+ user
+ (or
+ (auth-source--aget alist "login")
+ (auth-source--aget alist "account")
+ (auth-source--aget alist "user")
+ t))
+ (auth-source-search-collection
+ port
+ (or
+ (auth-source--aget alist "port")
+ (auth-source--aget alist "protocol")
+ t))
+ (or
+ ;; the required list of keys is nil, or
+ (null require)
+ ;; every element of require is in n(ormalized)
+ (let ((n (nth 0 (auth-source-netrc-normalize
+ (list alist) file))))
+ (loop for req in require
+ always (plist-get n req)))))))
+ result)
+
+ (if (and (functionp cached-secrets)
+ (equal cached-mtime
+ (nth 5 (file-attributes file))))
+ (progn
+ (auth-source-do-trivia
+ "auth-source-netrc-parse: using CACHED file data for %s"
+ file)
+ (insert (funcall cached-secrets)))
+ (insert-file-contents file)
+ ;; cache all netrc files (used to be just .gpg files)
+ ;; Store the contents of the file heavily encrypted in memory.
+ ;; (note for the irony-impaired: they are just obfuscated)
+ (auth-source--aput
+ auth-source-netrc-cache file
+ (list :mtime (nth 5 (file-attributes file))
+ :secret (lexical-let ((v (mapcar #'1+ (buffer-string))))
+ (lambda () (apply #'string (mapcar #'1- v)))))))
+ (goto-char (point-min))
+ (let ((entries (auth-source-netrc-parse-entries check max))
+ alist)
+ (while (setq alist (pop entries))
+ (push (nreverse alist) result)))
+
+ (when (< 0 modified)
+ (when auth-source-gpg-encrypt-to
+ ;; (see bug#7487) making `epa-file-encrypt-to' local to
+ ;; this buffer lets epa-file skip the key selection query
+ ;; (see the `local-variable-p' check in
+ ;; `epa-file-write-region').
+ (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
+ (make-local-variable 'epa-file-encrypt-to))
+ (if (listp auth-source-gpg-encrypt-to)
+ (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
+
+ ;; ask AFTER we've successfully opened the file
+ (when (y-or-n-p (format "Save file %s? (%d deletions)"
+ file modified))
+ (write-region (point-min) (point-max) file nil 'silent)
+ (auth-source-do-debug
+ "auth-source-netrc-parse: modified %d lines in %s"
+ modified file)))
+
+ (nreverse result))))))
+
+(defun auth-source-netrc-parse-next-interesting ()
+ "Advance to the next interesting position in the current buffer."
+ ;; If we're looking at a comment or are at the end of the line, move forward
+ (while (or (looking-at "#")
+ (and (eolp)
+ (not (eobp))))
+ (forward-line 1))
+ (skip-chars-forward "\t "))
+
+(defun auth-source-netrc-parse-one ()
+ "Read one thing from the current buffer."
+ (auth-source-netrc-parse-next-interesting)
+
+ (when (or (looking-at "'\\([^']*\\)'")
+ (looking-at "\"\\([^\"]*\\)\"")
+ (looking-at "\\([^ \t\n]+\\)"))
+ (forward-char (length (match-string 0)))
+ (auth-source-netrc-parse-next-interesting)
+ (match-string-no-properties 1)))
+
+;; with thanks to org-mode
+(defsubst auth-source-current-line (&optional pos)
+ (save-excursion
+ (and pos (goto-char pos))
+ ;; works also in narrowed buffer, because we start at 1, not point-min
+ (+ (if (bolp) 1 0) (count-lines 1 (point)))))
+
+(defun auth-source-netrc-parse-entries(check max)
+ "Parse up to MAX netrc entries, passed by CHECK, from the current buffer."
+ (let ((adder (lambda(check alist all)
+ (when (and
+ alist
+ (> max (length all))
+ (funcall check alist))
+ (push alist all))
+ all))
+ item item2 all alist default)
+ (while (setq item (auth-source-netrc-parse-one))
+ (setq default (equal item "default"))
+ ;; We're starting a new machine. Save the old one.
+ (when (and alist
+ (or default
+ (equal item "machine")))
+ ;; (auth-source-do-trivia
+ ;; "auth-source-netrc-parse-entries: got entry %S" alist)
+ (setq all (funcall adder check alist all)
+ alist nil))
+ ;; In default entries, we don't have a next token.
+ ;; We store them as ("machine" . t)
+ (if default
+ (push (cons "machine" t) alist)
+ ;; Not a default entry. Grab the next item.
+ (when (setq item2 (auth-source-netrc-parse-one))
+ ;; Did we get a "machine" value?
+ (if (equal item2 "machine")
+ (error
+ "%s: Unexpected `machine' token at line %d"
+ "auth-source-netrc-parse-entries"
+ (auth-source-current-line))
+ (push (cons item item2) alist)))))
+
+ ;; Clean up: if there's an entry left over, use it.
+ (when alist
+ (setq all (funcall adder check alist all))
+ ;; (auth-source-do-trivia
+ ;; "auth-source-netrc-parse-entries: got2 entry %S" alist)
+ )
+ (nreverse all)))
+
+(defvar auth-source-passphrase-alist nil)
+
+(defun auth-source-token-passphrase-callback-function (_context _key-id file)
+ (let* ((file (file-truename file))
+ (entry (assoc file auth-source-passphrase-alist))
+ passphrase)
+ ;; return the saved passphrase, calling a function if needed
+ (or (copy-sequence (if (functionp (cdr entry))
+ (funcall (cdr entry))
+ (cdr entry)))
+ (progn
+ (unless entry
+ (setq entry (list file))
+ (push entry auth-source-passphrase-alist))
+ (setq passphrase
+ (read-passwd
+ (format "Passphrase for %s tokens: " file)
+ t))
+ (setcdr entry (lexical-let ((p (copy-sequence passphrase)))
+ (lambda () p)))
+ passphrase))))
+
+;; (auth-source-epa-extract-gpg-token "gpg:LS0tLS1CRUdJTiBQR1AgTUVTU0FHRS0tLS0tClZlcnNpb246IEdudVBHIHYxLjQuMTEgKEdOVS9MaW51eCkKCmpBMEVBd01DT25qMjB1ak9rZnRneVI3K21iNm9aZWhuLzRad3cySkdlbnVaKzRpeEswWDY5di9icDI1U1dsQT0KPS9yc2wKLS0tLS1FTkQgUEdQIE1FU1NBR0UtLS0tLQo=" "~/.netrc")
+(defun auth-source-epa-extract-gpg-token (secret file)
+ "Pass either the decoded SECRET or the gpg:BASE64DATA version.
+FILE is the file from which we obtained this token."
+ (when (string-match "^gpg:\\(.+\\)" secret)
+ (setq secret (base64-decode-string (match-string 1 secret))))
+ (let ((context (epg-make-context 'OpenPGP)))
+ (epg-context-set-passphrase-callback
+ context
+ (cons #'auth-source-token-passphrase-callback-function
+ file))
+ (epg-decrypt-string context secret)))
+
+(defvar pp-escape-newlines)
+
+;; (insert (auth-source-epa-make-gpg-token "mysecret" "~/.netrc"))
+(defun auth-source-epa-make-gpg-token (secret file)
+ (let ((context (epg-make-context 'OpenPGP))
+ (pp-escape-newlines nil)
+ cipher)
+ (setf (epg-context-armor context) t)
+ (epg-context-set-passphrase-callback
+ context
+ (cons #'auth-source-token-passphrase-callback-function
+ file))
+ (setq cipher (epg-encrypt-string context secret nil))
+ (with-temp-buffer
+ (insert cipher)
+ (base64-encode-region (point-min) (point-max) t)
+ (concat "gpg:" (buffer-substring-no-properties
+ (point-min)
+ (point-max))))))
+
+(defun auto-source--symbol-keyword (symbol)
+ (intern (format ":%s" symbol)))
+
+(defun auth-source-netrc-normalize (alist filename)
+ (mapcar (lambda (entry)
+ (let (ret item)
+ (while (setq item (pop entry))
+ (let ((k (car item))
+ (v (cdr item)))
+
+ ;; apply key aliases
+ (setq k (cond ((member k '("machine")) "host")
+ ((member k '("login" "account")) "user")
+ ((member k '("protocol")) "port")
+ ((member k '("password")) "secret")
+ (t k)))
+
+ ;; send back the secret in a function (lexical binding)
+ (when (equal k "secret")
+ (setq v (lexical-let ((lexv v)
+ (token-decoder nil))
+ (when (string-match "^gpg:" lexv)
+ ;; it's a GPG token: create a token decoder
+ ;; which unsets itself once
+ (setq token-decoder
+ (lambda (val)
+ (prog1
+ (auth-source-epa-extract-gpg-token
+ val
+ filename)
+ (setq token-decoder nil)))))
+ (lambda ()
+ (when token-decoder
+ (setq lexv (funcall token-decoder lexv)))
+ lexv))))
+ (setq ret (plist-put ret
+ (auto-source--symbol-keyword k)
+ v))))
+ ret))
+ alist))
+
+;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret))
+;; (funcall secret)
+
+(defun* auth-source-netrc-search (&rest
+ spec
+ &key backend require create
+ type max host user port
+ &allow-other-keys)
+ "Given a property list SPEC, return search matches from the :backend.
+See `auth-source-search' for details on SPEC."
+ ;; just in case, check that the type is correct (null or same as the backend)
+ (assert (or (null type) (eq type (oref backend type)))
+ t "Invalid netrc search: %s %s")
+
+ (let ((results (auth-source-netrc-normalize
+ (auth-source-netrc-parse
+ :max max
+ :require require
+ :file (oref backend source)
+ :host (or host t)
+ :user (or user t)
+ :port (or port t))
+ (oref backend source))))
+
+ ;; if we need to create an entry AND none were found to match
+ (when (and create
+ (not results))
+
+ ;; create based on the spec and record the value
+ (setq results (or
+ ;; if the user did not want to create the entry
+ ;; in the file, it will be returned
+ (apply (slot-value backend 'create-function) spec)
+ ;; if not, we do the search again without :create
+ ;; to get the updated data.
+
+ ;; the result will be returned, even if the search fails
+ (apply #'auth-source-netrc-search
+ (plist-put spec :create nil)))))
+ results))
+
+(defun auth-source-netrc-element-or-first (v)
+ (if (listp v)
+ (nth 0 v)
+ v))
+
+;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t)
+;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B)))
+
+(defun* auth-source-netrc-create (&rest spec
+ &key backend
+ host port create
+ &allow-other-keys)
+ (let* ((base-required '(host user port secret))
+ ;; we know (because of an assertion in auth-source-search) that the
+ ;; :create parameter is either t or a list (which includes nil)
+ (create-extra (if (eq t create) nil create))
+ (current-data (car (auth-source-search :max 1
+ :host host
+ :port port)))
+ (required (append base-required create-extra))
+ (file (oref backend source))
+ (add "")
+ ;; `valist' is an alist
+ valist
+ ;; `artificial' will be returned if no creation is needed
+ artificial)
+
+ ;; only for base required elements (defined as function parameters):
+ ;; fill in the valist with whatever data we may have from the search
+ ;; we complete the first value if it's a list and use the value otherwise
+ (dolist (br base-required)
+ (let ((val (plist-get spec (auto-source--symbol-keyword br))))
+ (when val
+ (let ((br-choice (cond
+ ;; all-accepting choice (predicate is t)
+ ((eq t val) nil)
+ ;; just the value otherwise
+ (t val))))
+ (when br-choice
+ (auth-source--aput valist br br-choice))))))
+
+ ;; for extra required elements, see if the spec includes a value for them
+ (dolist (er create-extra)
+ (let ((k (auto-source--symbol-keyword er))
+ (keys (loop for i below (length spec) by 2
+ collect (nth i spec))))
+ (when (memq k keys)
+ (auth-source--aput valist er (plist-get spec k)))))
+
+ ;; for each required element
+ (dolist (r required)
+ (let* ((data (auth-source--aget valist r))
+ ;; take the first element if the data is a list
+ (data (or (auth-source-netrc-element-or-first data)
+ (plist-get current-data
+ (auto-source--symbol-keyword r))))
+ ;; this is the default to be offered
+ (given-default (auth-source--aget
+ auth-source-creation-defaults r))
+ ;; the default supplementals are simple:
+ ;; for the user, try `given-default' and then (user-login-name);
+ ;; otherwise take `given-default'
+ (default (cond
+ ((and (not given-default) (eq r 'user))
+ (user-login-name))
+ (t given-default)))
+ (printable-defaults (list
+ (cons 'user
+ (or
+ (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'user))
+ (plist-get artificial :user)
+ "[any user]"))
+ (cons 'host
+ (or
+ (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'host))
+ (plist-get artificial :host)
+ "[any host]"))
+ (cons 'port
+ (or
+ (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'port))
+ (plist-get artificial :port)
+ "[any port]"))))
+ (prompt (or (auth-source--aget auth-source-creation-prompts r)
+ (case r
+ (secret "%p password for %u@%h: ")
+ (user "%p user name for %h: ")
+ (host "%p host name for user %u: ")
+ (port "%p port for %u@%h: "))
+ (format "Enter %s (%%u@%%h:%%p): " r)))
+ (prompt (auth-source-format-prompt
+ prompt
+ `((?u ,(auth-source--aget printable-defaults 'user))
+ (?h ,(auth-source--aget printable-defaults 'host))
+ (?p ,(auth-source--aget printable-defaults 'port))))))
+
+ ;; Store the data, prompting for the password if needed.
+ (setq data (or data
+ (if (eq r 'secret)
+ ;; Special case prompt for passwords.
+ ;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car epa-file-auto-mode-alist-entry) "\\.gpg\\'") nil) (t gpg)))
+ ;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never)
+ (let* ((ep (format "Use GPG password tokens in %s?" file))
+ (gpg-encrypt
+ (cond
+ ((eq auth-source-netrc-use-gpg-tokens 'never)
+ 'never)
+ ((listp auth-source-netrc-use-gpg-tokens)
+ (let ((check (copy-sequence
+ auth-source-netrc-use-gpg-tokens))
+ item ret)
+ (while check
+ (setq item (pop check))
+ (when (or (eq (car item) t)
+ (string-match (car item) file))
+ (setq ret (cdr item))
+ (setq check nil)))
+ ;; FIXME: `ret' unused.
+ ;; Should we return it here?
+ ))
+ (t 'never)))
+ (plain (or (eval default) (read-passwd prompt))))
+ ;; ask if we don't know what to do (in which case
+ ;; auth-source-netrc-use-gpg-tokens must be a list)
+ (unless gpg-encrypt
+ (setq gpg-encrypt (if (y-or-n-p ep) 'gpg 'never))
+ ;; TODO: save the defcustom now? or ask?
+ (setq auth-source-netrc-use-gpg-tokens
+ (cons `(,file ,gpg-encrypt)
+ auth-source-netrc-use-gpg-tokens)))
+ (if (eq gpg-encrypt 'gpg)
+ (auth-source-epa-make-gpg-token plain file)
+ plain))
+ (if (stringp default)
+ (read-string (if (string-match ": *\\'" prompt)
+ (concat (substring prompt 0 (match-beginning 0))
+ " (default " default "): ")
+ (concat prompt "(default " default ") "))
+ nil nil default)
+ (eval default)))))
+
+ (when data
+ (setq artificial (plist-put artificial
+ (auto-source--symbol-keyword r)
+ (if (eq r 'secret)
+ (lexical-let ((data data))
+ (lambda () data))
+ data))))
+
+ ;; When r is not an empty string...
+ (when (and (stringp data)
+ (< 0 (length data)))
+ ;; this function is not strictly necessary but I think it
+ ;; makes the code clearer -tzz
+ (let ((printer (lambda ()
+ ;; append the key (the symbol name of r)
+ ;; and the value in r
+ (format "%s%s %s"
+ ;; prepend a space
+ (if (zerop (length add)) "" " ")
+ ;; remap auth-source tokens to netrc
+ (case r
+ (user "login")
+ (host "machine")
+ (secret "password")
+ (port "port") ; redundant but clearer
+ (t (symbol-name r)))
+ (if (string-match "[\"# ]" data)
+ (format "%S" data)
+ data)))))
+ (setq add (concat add (funcall printer)))))))
+
+ (plist-put
+ artificial
+ :save-function
+ (lexical-let ((file file)
+ (add add))
+ (lambda () (auth-source-netrc-saver file add))))
+
+ (list artificial)))
+
+;;(funcall (plist-get (nth 0 (auth-source-search :host '("nonesuch2") :user "tzz" :port "imap" :create t :max 1)) :save-function))
+(defun auth-source-netrc-saver (file add)
+ "Save a line ADD in FILE, prompting along the way.
+Respects `auth-source-save-behavior'. Uses
+`auth-source-netrc-cache' to avoid prompting more than once."
+ (let* ((key (format "%s %s" file (rfc2104-hash 'md5 64 16 file add)))
+ (cached (assoc key auth-source-netrc-cache)))
+
+ (if cached
+ (auth-source-do-trivia
+ "auth-source-netrc-saver: found previous run for key %s, returning"
+ key)
+ (with-temp-buffer
+ (when (file-exists-p file)
+ (insert-file-contents file))
+ (when auth-source-gpg-encrypt-to
+ ;; (see bug#7487) making `epa-file-encrypt-to' local to
+ ;; this buffer lets epa-file skip the key selection query
+ ;; (see the `local-variable-p' check in
+ ;; `epa-file-write-region').
+ (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
+ (make-local-variable 'epa-file-encrypt-to))
+ (if (listp auth-source-gpg-encrypt-to)
+ (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
+ ;; we want the new data to be found first, so insert at beginning
+ (goto-char (point-min))
+
+ ;; Ask AFTER we've successfully opened the file.
+ (let ((prompt (format "Save auth info to file %s? " file))
+ (done (not (eq auth-source-save-behavior 'ask)))
+ (bufname "*auth-source Help*")
+ k)
+ (while (not done)
+ (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ?e ??)))
+ (case k
+ (?y (setq done t))
+ (?? (save-excursion
+ (with-output-to-temp-buffer bufname
+ (princ
+ (concat "(y)es, save\n"
+ "(n)o but use the info\n"
+ "(N)o and don't ask to save again\n"
+ "(e)dit the line\n"
+ "(?) for help as you can see.\n"))
+ ;; Why? Doesn't with-output-to-temp-buffer already do
+ ;; the exact same thing anyway? --Stef
+ (set-buffer standard-output)
+ (help-mode))))
+ (?n (setq add ""
+ done t))
+ (?N
+ (setq add ""
+ done t)
+ (customize-save-variable 'auth-source-save-behavior nil))
+ (?e (setq add (read-string "Line to add: " add)))
+ (t nil)))
+
+ (when (get-buffer-window bufname)
+ (delete-window (get-buffer-window bufname)))
+
+ ;; Make sure the info is not saved.
+ (when (null auth-source-save-behavior)
+ (setq add ""))
+
+ (when (< 0 (length add))
+ (progn
+ (unless (bolp)
+ (insert "\n"))
+ (insert add "\n")
+ (write-region (point-min) (point-max) file nil 'silent)
+ ;; Make the .authinfo file non-world-readable.
+ (set-file-modes file #o600)
+ (auth-source-do-debug
+ "auth-source-netrc-create: wrote 1 new line to %s"
+ file)
+ (message "Saved new authentication information to %s" file)
+ nil))))
+ (auth-source--aput auth-source-netrc-cache key "ran"))))
+
+;;; Backend specific parsing: Secrets API backend
+
+;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t))
+;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t))
+;; (let ((auth-sources '(default))) (auth-source-search :max 1))
+;; (let ((auth-sources '(default))) (auth-source-search))
+;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1))
+;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git"))
+
+(defun auth-source-secrets-listify-pattern (pattern)
+ "Convert a pattern with lists to a list of string patterns.
+
+auth-source patterns can have values of the form :foo (\"bar\"
+\"qux\"), which means to match any secret with :foo equal to
+\"bar\" or :foo equal to \"qux\". The secrets backend supports
+only string values for patterns, so this routine returns a list
+of patterns that is equivalent to the single original pattern
+when interpreted such that if a secret matches any pattern in the
+list, it matches the original pattern."
+ (if (null pattern)
+ '(nil)
+ (let* ((key (pop pattern))
+ (value (pop pattern))
+ (tails (auth-source-secrets-listify-pattern pattern))
+ (heads (if (stringp value)
+ (list (list key value))
+ (mapcar (lambda (v) (list key v)) value))))
+ (loop
+ for h in heads
+ nconc
+ (loop
+ for tl in tails
+ collect (append h tl))))))
+
+(defun* auth-source-secrets-search (&rest
+ spec
+ &key backend create delete label max
+ &allow-other-keys)
+ "Search the Secrets API; spec is like `auth-source'.
+
+The :label key specifies the item's label. It is the only key
+that can specify a substring. Any :label value besides a string
+will allow any label.
+
+All other search keys must match exactly. If you need substring
+matching, do a wider search and narrow it down yourself.
+
+You'll get back all the properties of the token as a plist.
+
+Here's an example that looks for the first item in the `Login'
+Secrets collection:
+
+ (let ((auth-sources \\='(\"secrets:Login\")))
+ (auth-source-search :max 1)
+
+Here's another that looks for the first item in the `Login'
+Secrets collection whose label contains `gnus':
+
+ (let ((auth-sources \\='(\"secrets:Login\")))
+ (auth-source-search :max 1 :label \"gnus\")
+
+And this one looks for the first item in the `Login' Secrets
+collection that's a Google Chrome entry for the git.gnus.org site
+authentication tokens:
+
+ (let ((auth-sources \\='(\"secrets:Login\")))
+ (auth-source-search :max 1 :signon_realm \"https://git.gnus.org/Git\"))
+"
+
+ ;; TODO
+ (assert (not create) nil
+ "The Secrets API auth-source backend doesn't support creation yet")
+ ;; TODO
+ ;; (secrets-delete-item coll elt)
+ (assert (not delete) nil
+ "The Secrets API auth-source backend doesn't support deletion yet")
+
+ (let* ((coll (oref backend source))
+ (max (or max 5000)) ; sanity check: default to stop at 5K
+ (ignored-keys '(:create :delete :max :backend :label :require :type))
+ (search-keys (loop for i below (length spec) by 2
+ unless (memq (nth i spec) ignored-keys)
+ collect (nth i spec)))
+ ;; build a search spec without the ignored keys
+ ;; if a search key is nil or t (match anything), we skip it
+ (search-specs (auth-source-secrets-listify-pattern
+ (apply #'append (mapcar
+ (lambda (k)
+ (if (or (null (plist-get spec k))
+ (eq t (plist-get spec k)))
+ nil
+ (list k (plist-get spec k))))
+ search-keys))))
+ ;; needed keys (always including host, login, port, and secret)
+ (returned-keys (delete-dups (append
+ '(:host :login :port :secret)
+ search-keys)))
+ (items
+ (loop for search-spec in search-specs
+ nconc
+ (loop for item in (apply #'secrets-search-items coll search-spec)
+ unless (and (stringp label)
+ (not (string-match label item)))
+ collect item)))
+ ;; TODO: respect max in `secrets-search-items', not after the fact
+ (items (butlast items (- (length items) max)))
+ ;; convert the item name to a full plist
+ (items (mapcar (lambda (item)
+ (append
+ ;; make an entry for the secret (password) element
+ (list
+ :secret
+ (lexical-let ((v (secrets-get-secret coll item)))
+ (lambda () v)))
+ ;; rewrite the entry from ((k1 v1) (k2 v2)) to plist
+ (apply #'append
+ (mapcar (lambda (entry)
+ (list (car entry) (cdr entry)))
+ (secrets-get-attributes coll item)))))
+ items))
+ ;; ensure each item has each key in `returned-keys'
+ (items (mapcar (lambda (plist)
+ (append
+ (apply #'append
+ (mapcar (lambda (req)
+ (if (plist-get plist req)
+ nil
+ (list req nil)))
+ returned-keys))
+ plist))
+ items)))
+ items))
+
+(defun auth-source-secrets-create (&rest spec)
+ ;; TODO
+ ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec)
+ (debug spec))
+
+;;; Backend specific parsing: Mac OS Keychain (using /usr/bin/security) backend
+
+;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1 :create t))
+;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1 :delete t))
+;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1))
+;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search))
+
+;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1 :create t))
+;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1 :delete t))
+;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1))
+;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search))
+
+;; (let ((auth-sources '("macos-keychain-internet:/Users/tzz/Library/Keychains/login.keychain"))) (auth-source-search :max 1))
+;; (let ((auth-sources '("macos-keychain-generic:Login"))) (auth-source-search :max 1 :host "git.gnus.org"))
+;; (let ((auth-sources '("macos-keychain-generic:Login"))) (auth-source-search :max 1))
+
+(defun* auth-source-macos-keychain-search (&rest
+ spec
+ &key backend create delete
+ type max
+ &allow-other-keys)
+ "Search the MacOS Keychain; spec is like `auth-source'.
+
+All search keys must match exactly. If you need substring
+matching, do a wider search and narrow it down yourself.
+
+You'll get back all the properties of the token as a plist.
+
+The :type key is either `macos-keychain-internet' or
+`macos-keychain-generic'.
+
+For the internet keychain type, the :label key searches the
+item's labels (\"-l LABEL\" passed to \"/usr/bin/security\").
+Similarly, :host maps to \"-s HOST\", :user maps to \"-a USER\",
+and :port maps to \"-P PORT\" or \"-r PROT\"
+\(note PROT has to be a 4-character string).
+
+For the generic keychain type, the :label key searches the item's
+labels (\"-l LABEL\" passed to \"/usr/bin/security\").
+Similarly, :host maps to \"-c HOST\" (the \"creator\" keychain
+field), :user maps to \"-a USER\", and :port maps to \"-s PORT\".
+
+Here's an example that looks for the first item in the default
+generic MacOS Keychain:
+
+ (let ((auth-sources \\='(macos-keychain-generic)))
+ (auth-source-search :max 1)
+
+Here's another that looks for the first item in the internet
+MacOS Keychain collection whose label is `gnus':
+
+ (let ((auth-sources \\='(macos-keychain-internet)))
+ (auth-source-search :max 1 :label \"gnus\")
+
+And this one looks for the first item in the internet keychain
+entries for git.gnus.org:
+
+ (let ((auth-sources \\='(macos-keychain-internet\")))
+ (auth-source-search :max 1 :host \"git.gnus.org\"))
+"
+ ;; TODO
+ (assert (not create) nil
+ "The MacOS Keychain auth-source backend doesn't support creation yet")
+ ;; TODO
+ ;; (macos-keychain-delete-item coll elt)
+ (assert (not delete) nil
+ "The MacOS Keychain auth-source backend doesn't support deletion yet")
+
+ (let* ((coll (oref backend source))
+ (max (or max 5000)) ; sanity check: default to stop at 5K
+ ;; Filter out ignored keys from the spec
+ (ignored-keys '(:create :delete :max :backend :label :host :port))
+ ;; Build a search spec without the ignored keys
+ (search-keys (loop for i below (length spec) by 2
+ unless (memq (nth i spec) ignored-keys)
+ collect (nth i spec)))
+ ;; If a search key value is nil or t (match anything), we skip it
+ (search-spec (apply #'append (mapcar
+ (lambda (k)
+ (if (or (null (plist-get spec k))
+ (eq t (plist-get spec k)))
+ nil
+ (list k (plist-get spec k))))
+ search-keys)))
+ ;; needed keys (always including host, login, port, and secret)
+ (returned-keys (delete-dups (append
+ '(:host :login :port :secret)
+ search-keys)))
+ ;; Extract host and port from spec
+ (hosts (plist-get spec :host))
+ (hosts (if (and hosts (listp hosts)) hosts `(,hosts)))
+ (ports (plist-get spec :port))
+ (ports (if (and ports (listp ports)) ports `(,ports)))
+ ;; Loop through all combinations of host/port and pass each of these to
+ ;; auth-source-macos-keychain-search-items
+ (items (catch 'match
+ (dolist (host hosts)
+ (dolist (port ports)
+ (let* ((port (format "%S" port))
+ (items (apply #'auth-source-macos-keychain-search-items
+ coll
+ type
+ max
+ host port
+ search-spec)))
+ (when items
+ (throw 'match items)))))))
+
+ ;; ensure each item has each key in `returned-keys'
+ (items (mapcar (lambda (plist)
+ (append
+ (apply #'append
+ (mapcar (lambda (req)
+ (if (plist-get plist req)
+ nil
+ (list req nil)))
+ returned-keys))
+ plist))
+ items)))
+ items))
+
+(defun* auth-source-macos-keychain-search-items (coll _type _max
+ host port
+ &key label type
+ user
+ &allow-other-keys)
+
+ (let* ((keychain-generic (eq type 'macos-keychain-generic))
+ (args `(,(if keychain-generic
+ "find-generic-password"
+ "find-internet-password")
+ "-g"))
+ (ret (list :type type)))
+ (when label
+ (setq args (append args (list "-l" label))))
+ (when host
+ (setq args (append args (list (if keychain-generic "-c" "-s") host))))
+ (when user
+ (setq args (append args (list "-a" user))))
+
+ (when port
+ (if keychain-generic
+ (setq args (append args (list "-s" port)))
+ (setq args (append args (list
+ (if (string-match "[0-9]+" port) "-P" "-r")
+ port)))))
+
+ (unless (equal coll "default")
+ (setq args (append args (list coll))))
+
+ (with-temp-buffer
+ (apply #'call-process "/usr/bin/security" nil t nil args)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (cond
+ ((looking-at "^password: \"\\(.+\\)\"$")
+ (setq ret (auth-source-macos-keychain-result-append
+ ret
+ keychain-generic
+ "secret"
+ (lexical-let ((v (match-string 1)))
+ (lambda () v)))))
+ ;; TODO: check if this is really the label
+ ;; match 0x00000007 <blob>="AppleID"
+ ((looking-at "^[ ]+0x00000007 <blob>=\"\\(.+\\)\"")
+ (setq ret (auth-source-macos-keychain-result-append
+ ret
+ keychain-generic
+ "label"
+ (match-string 1))))
+ ;; match "crtr"<uint32>="aapl"
+ ;; match "svce"<blob>="AppleID"
+ ((looking-at "^[ ]+\"\\([a-z]+\\)\"[^=]+=\"\\(.+\\)\"")
+ (setq ret (auth-source-macos-keychain-result-append
+ ret
+ keychain-generic
+ (match-string 1)
+ (match-string 2)))))
+ (forward-line)))
+ ;; return `ret' iff it has the :secret key
+ (and (plist-get ret :secret) (list ret))))
+
+(defun auth-source-macos-keychain-result-append (result generic k v)
+ (push v result)
+ (push (auto-source--symbol-keyword
+ (cond
+ ((equal k "acct") "user")
+ ;; for generic keychains, creator is host, service is port
+ ((and generic (equal k "crtr")) "host")
+ ((and generic (equal k "svce")) "port")
+ ;; for internet keychains, protocol is port, server is host
+ ((and (not generic) (equal k "ptcl")) "port")
+ ((and (not generic) (equal k "srvr")) "host")
+ (t k)))
+ result))
+
+(defun auth-source-macos-keychain-create (&rest spec)
+ ;; TODO
+ (debug spec))
+
+;;; Backend specific parsing: PLSTORE backend
+
+(defun* auth-source-plstore-search (&rest
+ spec
+ &key backend create delete
+ max
+ &allow-other-keys)
+ "Search the PLSTORE; spec is like `auth-source'."
+ (let* ((store (oref backend data))
+ (max (or max 5000)) ; sanity check: default to stop at 5K
+ (ignored-keys '(:create :delete :max :backend :label :require :type))
+ (search-keys (loop for i below (length spec) by 2
+ unless (memq (nth i spec) ignored-keys)
+ collect (nth i spec)))
+ ;; build a search spec without the ignored keys
+ ;; if a search key is nil or t (match anything), we skip it
+ (search-spec (apply #'append (mapcar
+ (lambda (k)
+ (let ((v (plist-get spec k)))
+ (if (or (null v)
+ (eq t v))
+ nil
+ (if (stringp v)
+ (setq v (list v)))
+ (list k v))))
+ search-keys)))
+ ;; needed keys (always including host, login, port, and secret)
+ (returned-keys (delete-dups (append
+ '(:host :login :port :secret)
+ search-keys)))
+ (items (plstore-find store search-spec))
+ (item-names (mapcar #'car items))
+ (items (butlast items (- (length items) max)))
+ ;; convert the item to a full plist
+ (items (mapcar (lambda (item)
+ (let* ((plist (copy-tree (cdr item)))
+ (secret (plist-member plist :secret)))
+ (if secret
+ (setcar
+ (cdr secret)
+ (lexical-let ((v (car (cdr secret))))
+ (lambda () v))))
+ plist))
+ items))
+ ;; ensure each item has each key in `returned-keys'
+ (items (mapcar (lambda (plist)
+ (append
+ (apply #'append
+ (mapcar (lambda (req)
+ (if (plist-get plist req)
+ nil
+ (list req nil)))
+ returned-keys))
+ plist))
+ items)))
+ (cond
+ ;; if we need to create an entry AND none were found to match
+ ((and create
+ (not items))
+
+ ;; create based on the spec and record the value
+ (setq items (or
+ ;; if the user did not want to create the entry
+ ;; in the file, it will be returned
+ (apply (slot-value backend 'create-function) spec)
+ ;; if not, we do the search again without :create
+ ;; to get the updated data.
+
+ ;; the result will be returned, even if the search fails
+ (apply #'auth-source-plstore-search
+ (plist-put spec :create nil)))))
+ ((and delete
+ item-names)
+ (dolist (item-name item-names)
+ (plstore-delete store item-name))
+ (plstore-save store)))
+ items))
+
+(defun* auth-source-plstore-create (&rest spec
+ &key backend
+ host port create
+ &allow-other-keys)
+ (let* ((base-required '(host user port secret))
+ (base-secret '(secret))
+ ;; we know (because of an assertion in auth-source-search) that the
+ ;; :create parameter is either t or a list (which includes nil)
+ (create-extra (if (eq t create) nil create))
+ (current-data (car (auth-source-search :max 1
+ :host host
+ :port port)))
+ (required (append base-required create-extra))
+ ;; `valist' is an alist
+ valist
+ ;; `artificial' will be returned if no creation is needed
+ artificial
+ secret-artificial)
+
+ ;; only for base required elements (defined as function parameters):
+ ;; fill in the valist with whatever data we may have from the search
+ ;; we complete the first value if it's a list and use the value otherwise
+ (dolist (br base-required)
+ (let ((val (plist-get spec (auto-source--symbol-keyword br))))
+ (when val
+ (let ((br-choice (cond
+ ;; all-accepting choice (predicate is t)
+ ((eq t val) nil)
+ ;; just the value otherwise
+ (t val))))
+ (when br-choice
+ (auth-source--aput valist br br-choice))))))
+
+ ;; for extra required elements, see if the spec includes a value for them
+ (dolist (er create-extra)
+ (let ((k (auto-source--symbol-keyword er))
+ (keys (loop for i below (length spec) by 2
+ collect (nth i spec))))
+ (when (memq k keys)
+ (auth-source--aput valist er (plist-get spec k)))))
+
+ ;; for each required element
+ (dolist (r required)
+ (let* ((data (auth-source--aget valist r))
+ ;; take the first element if the data is a list
+ (data (or (auth-source-netrc-element-or-first data)
+ (plist-get current-data
+ (auto-source--symbol-keyword r))))
+ ;; this is the default to be offered
+ (given-default (auth-source--aget
+ auth-source-creation-defaults r))
+ ;; the default supplementals are simple:
+ ;; for the user, try `given-default' and then (user-login-name);
+ ;; otherwise take `given-default'
+ (default (cond
+ ((and (not given-default) (eq r 'user))
+ (user-login-name))
+ (t given-default)))
+ (printable-defaults (list
+ (cons 'user
+ (or
+ (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'user))
+ (plist-get artificial :user)
+ "[any user]"))
+ (cons 'host
+ (or
+ (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'host))
+ (plist-get artificial :host)
+ "[any host]"))
+ (cons 'port
+ (or
+ (auth-source-netrc-element-or-first
+ (auth-source--aget valist 'port))
+ (plist-get artificial :port)
+ "[any port]"))))
+ (prompt (or (auth-source--aget auth-source-creation-prompts r)
+ (case r
+ (secret "%p password for %u@%h: ")
+ (user "%p user name for %h: ")
+ (host "%p host name for user %u: ")
+ (port "%p port for %u@%h: "))
+ (format "Enter %s (%%u@%%h:%%p): " r)))
+ (prompt (auth-source-format-prompt
+ prompt
+ `((?u ,(auth-source--aget printable-defaults 'user))
+ (?h ,(auth-source--aget printable-defaults 'host))
+ (?p ,(auth-source--aget printable-defaults 'port))))))
+
+ ;; Store the data, prompting for the password if needed.
+ (setq data (or data
+ (if (eq r 'secret)
+ (or (eval default) (read-passwd prompt))
+ (if (stringp default)
+ (read-string
+ (if (string-match ": *\\'" prompt)
+ (concat (substring prompt 0 (match-beginning 0))
+ " (default " default "): ")
+ (concat prompt "(default " default ") "))
+ nil nil default)
+ (eval default)))))
+
+ (when data
+ (if (member r base-secret)
+ (setq secret-artificial
+ (plist-put secret-artificial
+ (auto-source--symbol-keyword r)
+ data))
+ (setq artificial (plist-put artificial
+ (auto-source--symbol-keyword r)
+ data))))))
+ (plstore-put (oref backend data)
+ (sha1 (format "%s@%s:%s"
+ (plist-get artificial :user)
+ (plist-get artificial :host)
+ (plist-get artificial :port)))
+ artificial secret-artificial)
+ (if (y-or-n-p (format "Save auth info to file %s? "
+ (plstore-get-file (oref backend data))))
+ (plstore-save (oref backend data)))))
+
+;;; older API
+
+;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")
+
+;; deprecate the old interface
+(make-obsolete 'auth-source-user-or-password
+ 'auth-source-search "Emacs 24.1")
+(make-obsolete 'auth-source-forget-user-or-password
+ 'auth-source-forget "Emacs 24.1")
+
+(defun auth-source-user-or-password
+ (mode host port &optional username create-missing delete-existing)
+ "Find MODE (string or list of strings) matching HOST and PORT.
+
+DEPRECATED in favor of `auth-source-search'!
+
+USERNAME is optional and will be used as \"login\" in a search
+across the Secret Service API (see secrets.el) if the resulting
+items don't have a username. This means that if you search for
+username \"joe\" and it matches an item but the item doesn't have
+a :user attribute, the username \"joe\" will be returned.
+
+A non nil DELETE-EXISTING means deleting any matching password
+entry in the respective sources. This is useful only when
+CREATE-MISSING is non nil as well; the intended use case is to
+remove wrong password entries.
+
+If no matching entry is found, and CREATE-MISSING is non nil,
+the password will be retrieved interactively, and it will be
+stored in the password database which matches best (see
+`auth-sources').
+
+MODE can be \"login\" or \"password\"."
+ (auth-source-do-debug
+ "auth-source-user-or-password: DEPRECATED get %s for %s (%s) + user=%s"
+ mode host port username)
+
+ (let* ((listy (listp mode))
+ (mode (if listy mode (list mode)))
+ ;; (cname (if username
+ ;; (format "%s %s:%s %s" mode host port username)
+ ;; (format "%s %s:%s" mode host port)))
+ (search (list :host host :port port))
+ (search (if username (append search (list :user username)) search))
+ (search (if create-missing
+ (append search (list :create t))
+ search))
+ (search (if delete-existing
+ (append search (list :delete t))
+ search))
+ ;; (found (if (not delete-existing)
+ ;; (gethash cname auth-source-cache)
+ ;; (remhash cname auth-source-cache)
+ ;; nil)))
+ (found nil))
+ (if found
+ (progn
+ (auth-source-do-debug
+ "auth-source-user-or-password: DEPRECATED cached %s=%s for %s (%s) + %s"
+ mode
+ ;; don't show the password
+ (if (and (member "password" mode) t)
+ "SECRET"
+ found)
+ host port username)
+ found) ; return the found data
+ ;; else, if not found, search with a max of 1
+ (let ((choice (nth 0 (apply #'auth-source-search
+ (append '(:max 1) search)))))
+ (when choice
+ (dolist (m mode)
+ (cond
+ ((equal "password" m)
+ (push (if (plist-get choice :secret)
+ (funcall (plist-get choice :secret))
+ nil) found))
+ ((equal "login" m)
+ (push (plist-get choice :user) found)))))
+ (setq found (nreverse found))
+ (setq found (if listy found (car-safe found)))))
+
+ found))
+
+(defun auth-source-user-and-password (host &optional user)
+ (let* ((auth-info (car
+ (if user
+ (auth-source-search
+ :host host
+ :user "yourusername"
+ :max 1
+ :require '(:user :secret)
+ :create nil)
+ (auth-source-search
+ :host host
+ :max 1
+ :require '(:user :secret)
+ :create nil))))
+ (user (plist-get auth-info :user))
+ (password (plist-get auth-info :secret)))
+ (when (functionp password)
+ (setq password (funcall password)))
+ (list user password auth-info)))
+
+(provide 'auth-source)
+
+;;; auth-source.el ends here
--- /dev/null
+;;; ecomplete.el --- electric completion of addresses and the like
+
+;; Copyright (C) 2006-2016 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+(defgroup ecomplete nil
+ "Electric completion of email addresses and the like."
+ :group 'mail)
+
+(defcustom ecomplete-database-file "~/.ecompleterc"
+ "*The name of the file to store the ecomplete data."
+ :group 'ecomplete
+ :type 'file)
+
+(defcustom ecomplete-database-file-coding-system 'iso-2022-7bit
+ "Coding system used for writing the ecomplete database file."
+ :type '(symbol :tag "Coding system")
+ :group 'ecomplete)
+
+;;; Internal variables.
+
+(defvar ecomplete-database nil)
+
+;;;###autoload
+(defun ecomplete-setup ()
+ (when (file-exists-p ecomplete-database-file)
+ (with-temp-buffer
+ (let ((coding-system-for-read ecomplete-database-file-coding-system))
+ (insert-file-contents ecomplete-database-file)
+ (setq ecomplete-database (read (current-buffer)))))))
+
+(defun ecomplete-add-item (type key text)
+ (let ((elems (assq type ecomplete-database))
+ (now (string-to-number (format "%.0f" (float-time))))
+ entry)
+ (unless elems
+ (push (setq elems (list type)) ecomplete-database))
+ (if (setq entry (assoc key (cdr elems)))
+ (setcdr entry (list (1+ (cadr entry)) now text))
+ (nconc elems (list (list key 1 now text))))))
+
+(defun ecomplete-get-item (type key)
+ (assoc key (cdr (assq type ecomplete-database))))
+
+(defun ecomplete-save ()
+ (with-temp-buffer
+ (let ((coding-system-for-write ecomplete-database-file-coding-system))
+ (insert "(")
+ (loop for (type . elems) in ecomplete-database
+ do
+ (insert (format "(%s\n" type))
+ (dolist (entry elems)
+ (prin1 entry (current-buffer))
+ (insert "\n"))
+ (insert ")\n"))
+ (insert ")")
+ (write-region (point-min) (point-max)
+ ecomplete-database-file nil 'silent))))
+
+(defun ecomplete-get-matches (type match)
+ (let* ((elems (cdr (assq type ecomplete-database)))
+ (match (regexp-quote match))
+ (candidates
+ (sort
+ (loop for (key count time text) in elems
+ when (string-match match text)
+ collect (list count time text))
+ (lambda (l1 l2)
+ (> (car l1) (car l2))))))
+ (when (> (length candidates) 10)
+ (setcdr (nthcdr 10 candidates) nil))
+ (unless (zerop (length candidates))
+ (with-temp-buffer
+ (dolist (candidate candidates)
+ (insert (caddr candidate) "\n"))
+ (goto-char (point-min))
+ (put-text-property (point) (1+ (point)) 'ecomplete t)
+ (while (re-search-forward match nil t)
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'face 'isearch))
+ (buffer-string)))))
+
+(defun ecomplete-display-matches (type word &optional choose)
+ (let* ((matches (ecomplete-get-matches type word))
+ (line 0)
+ (max-lines (when matches (- (length (split-string matches "\n")) 2)))
+ (message-log-max nil)
+ command highlight)
+ (if (not matches)
+ (progn
+ (message "No ecomplete matches")
+ nil)
+ (if (not choose)
+ (progn
+ (message "%s" matches)
+ nil)
+ (setq highlight (ecomplete-highlight-match-line matches line))
+ (let ((local-map (make-sparse-keymap))
+ selected)
+ (define-key local-map (kbd "RET")
+ (lambda () (setq selected (nth line (split-string matches "\n")))))
+ (define-key local-map (kbd "M-n")
+ (lambda () (setq line (min (1+ line) max-lines))))
+ (define-key local-map (kbd "M-p")
+ (lambda () (setq line (max (1- line) 0))))
+ (let ((overriding-local-map local-map))
+ (while (and (null selected)
+ (setq command (read-key-sequence highlight))
+ (lookup-key local-map command))
+ (apply (key-binding command) nil)
+ (setq highlight (ecomplete-highlight-match-line matches line))))
+ (if selected
+ (message selected)
+ (message "Abort"))
+ selected)))))
+
+(defun ecomplete-highlight-match-line (matches line)
+ (with-temp-buffer
+ (insert matches)
+ (goto-char (point-min))
+ (forward-line line)
+ (save-restriction
+ (narrow-to-region (point) (point-at-eol))
+ (while (not (eobp))
+ ;; Put the 'region face on any characters on this line that
+ ;; aren't already highlighted.
+ (unless (get-text-property (point) 'face)
+ (put-text-property (point) (1+ (point)) 'face 'highlight))
+ (forward-char 1)))
+ (buffer-string)))
+
+(provide 'ecomplete)
+
+;;; ecomplete.el ends here
+++ /dev/null
-;;; auth-source.el --- authentication sources for Gnus and Emacs
-
-;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
-
-;; Author: Ted Zlatanov <tzz@lifelogs.com>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This is the auth-source.el package. It lets users tell Gnus how to
-;; authenticate in a single place. Simplicity is the goal. Instead
-;; of providing 5000 options, we'll stick to simple, easy to
-;; understand options.
-
-;; See the auth.info Info documentation for details.
-
-;; TODO:
-
-;; - never decode the backend file unless it's necessary
-;; - a more generic way to match backends and search backend contents
-;; - absorb netrc.el and simplify it
-;; - protect passwords better
-;; - allow creating and changing netrc lines (not files) e.g. change a password
-
-;;; Code:
-
-(require 'password-cache)
-
-(eval-when-compile (require 'cl))
-(require 'eieio)
-
-(autoload 'secrets-create-item "secrets")
-(autoload 'secrets-delete-item "secrets")
-(autoload 'secrets-get-alias "secrets")
-(autoload 'secrets-get-attributes "secrets")
-(autoload 'secrets-get-secret "secrets")
-(autoload 'secrets-list-collections "secrets")
-(autoload 'secrets-search-items "secrets")
-
-(autoload 'rfc2104-hash "rfc2104")
-
-(autoload 'plstore-open "plstore")
-(autoload 'plstore-find "plstore")
-(autoload 'plstore-put "plstore")
-(autoload 'plstore-delete "plstore")
-(autoload 'plstore-save "plstore")
-(autoload 'plstore-get-file "plstore")
-
-(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor'
-(autoload 'epg-make-context "epg")
-(autoload 'epg-context-set-passphrase-callback "epg")
-(autoload 'epg-decrypt-string "epg")
-(autoload 'epg-encrypt-string "epg")
-
-(autoload 'help-mode "help-mode" nil t)
-
-(defvar secrets-enabled)
-
-(defgroup auth-source nil
- "Authentication sources."
- :version "23.1" ;; No Gnus
- :group 'gnus)
-
-;;;###autoload
-(defcustom auth-source-cache-expiry 7200
- "How many seconds passwords are cached, or nil to disable
-expiring. Overrides `password-cache-expiry' through a
-let-binding."
- :version "24.1"
- :group 'auth-source
- :type '(choice (const :tag "Never" nil)
- (const :tag "All Day" 86400)
- (const :tag "2 Hours" 7200)
- (const :tag "30 Minutes" 1800)
- (integer :tag "Seconds")))
-
-;; The slots below correspond with the `auth-source-search' spec,
-;; so a backend with :host set, for instance, would match only
-;; searches for that host. Normally they are nil.
-(defclass auth-source-backend ()
- ((type :initarg :type
- :initform 'netrc
- :type symbol
- :custom symbol
- :documentation "The backend type.")
- (source :initarg :source
- :type string
- :custom string
- :documentation "The backend source.")
- (host :initarg :host
- :initform t
- :type t
- :custom string
- :documentation "The backend host.")
- (user :initarg :user
- :initform t
- :type t
- :custom string
- :documentation "The backend user.")
- (port :initarg :port
- :initform t
- :type t
- :custom string
- :documentation "The backend protocol.")
- (data :initarg :data
- :initform nil
- :documentation "Internal backend data.")
- (create-function :initarg :create-function
- :initform ignore
- :type function
- :custom function
- :documentation "The create function.")
- (search-function :initarg :search-function
- :initform ignore
- :type function
- :custom function
- :documentation "The search function.")))
-
-(defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
- (pop3 "pop3" "pop" "pop3s" "110" "995")
- (ssh "ssh" "22")
- (sftp "sftp" "115")
- (smtp "smtp" "25"))
- "List of authentication protocols and their names"
-
- :group 'auth-source
- :version "23.2" ;; No Gnus
- :type '(repeat :tag "Authentication Protocols"
- (cons :tag "Protocol Entry"
- (symbol :tag "Protocol")
- (repeat :tag "Names"
- (string :tag "Name")))))
-
-;; Generate all the protocols in a format Customize can use.
-;; TODO: generate on the fly from auth-source-protocols
-(defconst auth-source-protocols-customize
- (mapcar (lambda (a)
- (let ((p (car-safe a)))
- (list 'const
- :tag (upcase (symbol-name p))
- p)))
- auth-source-protocols))
-
-(defvar auth-source-creation-defaults nil
- ;; FIXME: AFAICT this is not set (or let-bound) anywhere!
- "Defaults for creating token values. Usually let-bound.")
-
-(defvar auth-source-creation-prompts nil
- "Default prompts for token values. Usually let-bound.")
-
-(make-obsolete 'auth-source-hide-passwords nil "Emacs 24.1")
-
-(defcustom auth-source-save-behavior 'ask
- "If set, auth-source will respect it for save behavior."
- :group 'auth-source
- :version "23.2" ;; No Gnus
- :type `(choice
- :tag "auth-source new token save behavior"
- (const :tag "Always save" t)
- (const :tag "Never save" nil)
- (const :tag "Ask" ask)))
-
-;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car epa-file-auto-mode-alist-entry) "\\.gpg\\'") never) (t gpg)))
-;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never)
-
-(defcustom auth-source-netrc-use-gpg-tokens 'never
- "Set this to tell auth-source when to create GPG password
-tokens in netrc files. It's either an alist or `never'.
-Note that if EPA/EPG is not available, this should NOT be used."
- :group 'auth-source
- :version "23.2" ;; No Gnus
- :type `(choice
- (const :tag "Always use GPG password tokens" (t gpg))
- (const :tag "Never use GPG password tokens" never)
- (repeat :tag "Use a lookup list"
- (list
- (choice :tag "Matcher"
- (const :tag "Match anything" t)
- (const :tag "The EPA encrypted file extensions"
- ,(if (boundp 'epa-file-auto-mode-alist-entry)
- (car epa-file-auto-mode-alist-entry)
- "\\.gpg\\'"))
- (regexp :tag "Regular expression"))
- (choice :tag "What to do"
- (const :tag "Save GPG-encrypted password tokens" gpg)
- (const :tag "Don't encrypt tokens" never))))))
-
-(defvar auth-source-magic "auth-source-magic ")
-
-(defcustom auth-source-do-cache t
- "Whether auth-source should cache information with `password-cache'."
- :group 'auth-source
- :version "23.2" ;; No Gnus
- :type `boolean)
-
-(defcustom auth-source-debug nil
- "Whether auth-source should log debug messages.
-
-If the value is nil, debug messages are not logged.
-
-If the value is t, debug messages are logged with `message'. In
-that case, your authentication data will be in the clear (except
-for passwords).
-
-If the value is a function, debug messages are logged by calling
- that function using the same arguments as `message'."
- :group 'auth-source
- :version "23.2" ;; No Gnus
- :type `(choice
- :tag "auth-source debugging mode"
- (const :tag "Log using `message' to the *Messages* buffer" t)
- (const :tag "Log all trivia with `message' to the *Messages* buffer"
- trivia)
- (function :tag "Function that takes arguments like `message'")
- (const :tag "Don't log anything" nil)))
-
-(defcustom auth-sources '("~/.authinfo" "~/.authinfo.gpg" "~/.netrc")
- "List of authentication sources.
-Each entry is the authentication type with optional properties.
-Entries are tried in the order in which they appear.
-See Info node `(auth)Help for users' for details.
-
-If an entry names a file with the \".gpg\" extension and you have
-EPA/EPG set up, the file will be encrypted and decrypted
-automatically. See Info node `(epa)Encrypting/decrypting gpg files'
-for details.
-
-It's best to customize this with `\\[customize-variable]' because the choices
-can get pretty complex."
- :group 'auth-source
- :version "24.1" ;; No Gnus
- :type `(repeat :tag "Authentication Sources"
- (choice
- (string :tag "Just a file")
- (const :tag "Default Secrets API Collection" default)
- (const :tag "Login Secrets API Collection" "secrets:Login")
- (const :tag "Temp Secrets API Collection" "secrets:session")
-
- (const :tag "Default internet Mac OS Keychain"
- macos-keychain-internet)
-
- (const :tag "Default generic Mac OS Keychain"
- macos-keychain-generic)
-
- (list :tag "Source definition"
- (const :format "" :value :source)
- (choice :tag "Authentication backend choice"
- (string :tag "Authentication Source (file)")
- (list
- :tag "Secret Service API/KWallet/GNOME Keyring"
- (const :format "" :value :secrets)
- (choice :tag "Collection to use"
- (string :tag "Collection name")
- (const :tag "Default" default)
- (const :tag "Login" "Login")
- (const
- :tag "Temporary" "session")))
- (list
- :tag "Mac OS internet Keychain"
- (const :format ""
- :value :macos-keychain-internet)
- (choice :tag "Collection to use"
- (string :tag "internet Keychain path")
- (const :tag "default" default)))
- (list
- :tag "Mac OS generic Keychain"
- (const :format ""
- :value :macos-keychain-generic)
- (choice :tag "Collection to use"
- (string :tag "generic Keychain path")
- (const :tag "default" default))))
- (repeat :tag "Extra Parameters" :inline t
- (choice :tag "Extra parameter"
- (list
- :tag "Host"
- (const :format "" :value :host)
- (choice :tag "Host (machine) choice"
- (const :tag "Any" t)
- (regexp
- :tag "Regular expression")))
- (list
- :tag "Protocol"
- (const :format "" :value :port)
- (choice
- :tag "Protocol"
- (const :tag "Any" t)
- ,@auth-source-protocols-customize))
- (list :tag "User" :inline t
- (const :format "" :value :user)
- (choice
- :tag "Personality/Username"
- (const :tag "Any" t)
- (string
- :tag "Name")))))))))
-
-(defcustom auth-source-gpg-encrypt-to t
- "List of recipient keys that `authinfo.gpg' encrypted to.
-If the value is not a list, symmetric encryption will be used."
- :group 'auth-source
- :version "24.1" ;; No Gnus
- :type '(choice (const :tag "Symmetric encryption" t)
- (repeat :tag "Recipient public keys"
- (string :tag "Recipient public key"))))
-
-;; temp for debugging
-;; (unintern 'auth-source-protocols)
-;; (unintern 'auth-sources)
-;; (customize-variable 'auth-sources)
-;; (setq auth-sources nil)
-;; (format "%S" auth-sources)
-;; (customize-variable 'auth-source-protocols)
-;; (setq auth-source-protocols nil)
-;; (format "%S" auth-source-protocols)
-;; (auth-source-pick nil :host "a" :port 'imap)
-;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
-;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
-;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
-;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
-;; (auth-source-protocol-defaults 'imap)
-
-;; (let ((auth-source-debug 'debug)) (auth-source-do-debug "hello"))
-;; (let ((auth-source-debug t)) (auth-source-do-debug "hello"))
-;; (let ((auth-source-debug nil)) (auth-source-do-debug "hello"))
-(defun auth-source-do-debug (&rest msg)
- (when auth-source-debug
- (apply #'auth-source-do-warn msg)))
-
-(defun auth-source-do-trivia (&rest msg)
- (when (or (eq auth-source-debug 'trivia)
- (functionp auth-source-debug))
- (apply #'auth-source-do-warn msg)))
-
-(defun auth-source-do-warn (&rest msg)
- (apply
- ;; set logger to either the function in auth-source-debug or 'message
- ;; note that it will be 'message if auth-source-debug is nil
- (if (functionp auth-source-debug)
- auth-source-debug
- 'message)
- msg))
-
-
-;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q))
-(defun auth-source-read-char-choice (prompt choices)
- "Read one of CHOICES by `read-char-choice', or `read-char'.
-`dropdown-list' support is disabled because it doesn't work reliably.
-Only one of CHOICES will be returned. The PROMPT is augmented
-with \"[a/b/c] \" if CHOICES is \(?a ?b ?c)."
- (when choices
- (let* ((prompt-choices
- (apply #'concat (loop for c in choices
- collect (format "%c/" c))))
- (prompt-choices (concat "[" (substring prompt-choices 0 -1) "] "))
- (full-prompt (concat prompt prompt-choices))
- k)
-
- (while (not (memq k choices))
- (setq k (read-char-choice full-prompt choices)))
- k)))
-
-;; (auth-source-pick nil :host "any" :port 'imap :user "joe")
-;; (auth-source-pick t :host "any" :port 'imap :user "joe")
-;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe")
-;; (:source (:secrets "session") :host t :port t :user "joe")
-;; (:source (:secrets "Login") :host t :port t)
-;; (:source "~/.authinfo.gpg" :host t :port t)))
-
-;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe")
-;; (:source (:secrets "session") :host t :port t :user "joe")
-;; (:source (:secrets "Login") :host t :port t)
-;; ))
-
-;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :port t)))
-
-;; (auth-source-backend-parse "myfile.gpg")
-;; (auth-source-backend-parse 'default)
-;; (auth-source-backend-parse "secrets:Login")
-;; (auth-source-backend-parse 'macos-keychain-internet)
-;; (auth-source-backend-parse 'macos-keychain-generic)
-;; (auth-source-backend-parse "macos-keychain-internet:/path/here.keychain")
-;; (auth-source-backend-parse "macos-keychain-generic:/path/here.keychain")
-
-(defun auth-source-backend-parse (entry)
- "Creates an auth-source-backend from an ENTRY in `auth-sources'."
- (auth-source-backend-parse-parameters
- entry
- (cond
- ;; take 'default and recurse to get it as a Secrets API default collection
- ;; matching any user, host, and protocol
- ((eq entry 'default)
- (auth-source-backend-parse '(:source (:secrets default))))
- ;; take secrets:XYZ and recurse to get it as Secrets API collection "XYZ"
- ;; matching any user, host, and protocol
- ((and (stringp entry) (string-match "^secrets:\\(.+\\)" entry))
- (auth-source-backend-parse `(:source (:secrets ,(match-string 1 entry)))))
-
- ;; take 'macos-keychain-internet and recurse to get it as a Mac OS
- ;; Keychain collection matching any user, host, and protocol
- ((eq entry 'macos-keychain-internet)
- (auth-source-backend-parse '(:source (:macos-keychain-internet default))))
- ;; take 'macos-keychain-generic and recurse to get it as a Mac OS
- ;; Keychain collection matching any user, host, and protocol
- ((eq entry 'macos-keychain-generic)
- (auth-source-backend-parse '(:source (:macos-keychain-generic default))))
- ;; take macos-keychain-internet:XYZ and recurse to get it as MacOS
- ;; Keychain "XYZ" matching any user, host, and protocol
- ((and (stringp entry) (string-match "^macos-keychain-internet:\\(.+\\)"
- entry))
- (auth-source-backend-parse `(:source (:macos-keychain-internet
- ,(match-string 1 entry)))))
- ;; take macos-keychain-generic:XYZ and recurse to get it as MacOS
- ;; Keychain "XYZ" matching any user, host, and protocol
- ((and (stringp entry) (string-match "^macos-keychain-generic:\\(.+\\)"
- entry))
- (auth-source-backend-parse `(:source (:macos-keychain-generic
- ,(match-string 1 entry)))))
-
- ;; take just a file name and recurse to get it as a netrc file
- ;; matching any user, host, and protocol
- ((stringp entry)
- (auth-source-backend-parse `(:source ,entry)))
-
- ;; a file name with parameters
- ((stringp (plist-get entry :source))
- (if (equal (file-name-extension (plist-get entry :source)) "plist")
- (auth-source-backend
- (plist-get entry :source)
- :source (plist-get entry :source)
- :type 'plstore
- :search-function #'auth-source-plstore-search
- :create-function #'auth-source-plstore-create
- :data (plstore-open (plist-get entry :source)))
- (auth-source-backend
- (plist-get entry :source)
- :source (plist-get entry :source)
- :type 'netrc
- :search-function #'auth-source-netrc-search
- :create-function #'auth-source-netrc-create)))
-
- ;; the MacOS Keychain
- ((and
- (not (null (plist-get entry :source))) ; the source must not be nil
- (listp (plist-get entry :source)) ; and it must be a list
- (or
- (plist-get (plist-get entry :source) :macos-keychain-generic)
- (plist-get (plist-get entry :source) :macos-keychain-internet)))
-
- (let* ((source-spec (plist-get entry :source))
- (keychain-generic (plist-get source-spec :macos-keychain-generic))
- (keychain-type (if keychain-generic
- 'macos-keychain-generic
- 'macos-keychain-internet))
- (source (plist-get source-spec (if keychain-generic
- :macos-keychain-generic
- :macos-keychain-internet))))
-
- (when (symbolp source)
- (setq source (symbol-name source)))
-
- (auth-source-backend
- (format "Mac OS Keychain (%s)" source)
- :source source
- :type keychain-type
- :search-function #'auth-source-macos-keychain-search
- :create-function #'auth-source-macos-keychain-create)))
-
- ;; the Secrets API. We require the package, in order to have a
- ;; defined value for `secrets-enabled'.
- ((and
- (not (null (plist-get entry :source))) ; the source must not be nil
- (listp (plist-get entry :source)) ; and it must be a list
- (require 'secrets nil t) ; and we must load the Secrets API
- secrets-enabled) ; and that API must be enabled
-
- ;; the source is either the :secrets key in ENTRY or
- ;; if that's missing or nil, it's "session"
- (let ((source (or (plist-get (plist-get entry :source) :secrets)
- "session")))
-
- ;; if the source is a symbol, we look for the alias named so,
- ;; and if that alias is missing, we use "Login"
- (when (symbolp source)
- (setq source (or (secrets-get-alias (symbol-name source))
- "Login")))
-
- (if (featurep 'secrets)
- (auth-source-backend
- (format "Secrets API (%s)" source)
- :source source
- :type 'secrets
- :search-function #'auth-source-secrets-search
- :create-function #'auth-source-secrets-create)
- (auth-source-do-warn
- "auth-source-backend-parse: no Secrets API, ignoring spec: %S" entry)
- (auth-source-backend
- (format "Ignored Secrets API (%s)" source)
- :source ""
- :type 'ignore))))
-
- ;; none of them
- (t
- (auth-source-do-warn
- "auth-source-backend-parse: invalid backend spec: %S" entry)
- (make-instance 'auth-source-backend
- :source ""
- :type 'ignore)))))
-
-(defun auth-source-backend-parse-parameters (entry backend)
- "Fills in the extra auth-source-backend parameters of ENTRY.
-Using the plist ENTRY, get the :host, :port, and :user search
-parameters."
- (let ((entry (if (stringp entry)
- nil
- entry))
- val)
- (when (setq val (plist-get entry :host))
- (oset backend host val))
- (when (setq val (plist-get entry :user))
- (oset backend user val))
- (when (setq val (plist-get entry :port))
- (oset backend port val)))
- backend)
-
-;; (mapcar 'auth-source-backend-parse auth-sources)
-
-(defun* auth-source-search (&rest spec
- &key max
- require create delete
- &allow-other-keys)
- "Search or modify authentication backends according to SPEC.
-
-This function parses `auth-sources' for matches of the SPEC
-plist. It can optionally create or update an authentication
-token if requested. A token is just a standard Emacs property
-list with a :secret property that can be a function; all the
-other properties will always hold scalar values.
-
-Typically the :secret property, if present, contains a password.
-
-Common search keys are :max, :host, :port, and :user. In
-addition, :create specifies if and how tokens will be created.
-Finally, :type can specify which backend types you want to check.
-
-A string value is always matched literally. A symbol is matched
-as its string value, literally. All the SPEC values can be
-single values (symbol or string) or lists thereof (in which case
-any of the search terms matches).
-
-:create t means to create a token if possible.
-
-A new token will be created if no matching tokens were found.
-The new token will have only the keys the backend requires. For
-the netrc backend, for instance, that's the user, host, and
-port keys.
-
-Here's an example:
-
-\(let ((auth-source-creation-defaults \\='((user . \"defaultUser\")
- (A . \"default A\"))))
- (auth-source-search :host \"mine\" :type \\='netrc :max 1
- :P \"pppp\" :Q \"qqqq\"
- :create t))
-
-which says:
-
-\"Search for any entry matching host `mine' in backends of type
- `netrc', maximum one result.
-
- Create a new entry if you found none. The netrc backend will
- automatically require host, user, and port. The host will be
- `mine'. We prompt for the user with default `defaultUser' and
- for the port without a default. We will not prompt for A, Q,
- or P. The resulting token will only have keys user, host, and
- port.\"
-
-:create \\='(A B C) also means to create a token if possible.
-
-The behavior is like :create t but if the list contains any
-parameter, that parameter will be required in the resulting
-token. The value for that parameter will be obtained from the
-search parameters or from user input. If any queries are needed,
-the alist `auth-source-creation-defaults' will be checked for the
-default value. If the user, host, or port are missing, the alist
-`auth-source-creation-prompts' will be used to look up the
-prompts IN THAT ORDER (so the `user' prompt will be queried first,
-then `host', then `port', and finally `secret'). Each prompt string
-can use %u, %h, and %p to show the user, host, and port.
-
-Here's an example:
-
-\(let ((auth-source-creation-defaults \\='((user . \"defaultUser\")
- (A . \"default A\")))
- (auth-source-creation-prompts
- \\='((password . \"Enter IMAP password for %h:%p: \"))))
- (auth-source-search :host \\='(\"nonesuch\" \"twosuch\") :type \\='netrc :max 1
- :P \"pppp\" :Q \"qqqq\"
- :create \\='(A B Q)))
-
-which says:
-
-\"Search for any entry matching host `nonesuch'
- or `twosuch' in backends of type `netrc', maximum one result.
-
- Create a new entry if you found none. The netrc backend will
- automatically require host, user, and port. The host will be
- `nonesuch' and Q will be `qqqq'. We prompt for the password
- with the shown prompt. We will not prompt for Q. The resulting
- token will have keys user, host, port, A, B, and Q. It will not
- have P with any value, even though P is used in the search to
- find only entries that have P set to `pppp'.\"
-
-When multiple values are specified in the search parameter, the
-user is prompted for which one. So :host (X Y Z) would ask the
-user to choose between X, Y, and Z.
-
-This creation can fail if the search was not specific enough to
-create a new token (it's up to the backend to decide that). You
-should `catch' the backend-specific error as usual. Some
-backends (netrc, at least) will prompt the user rather than throw
-an error.
-
-:require (A B C) means that only results that contain those
-tokens will be returned. Thus for instance requiring :secret
-will ensure that any results will actually have a :secret
-property.
-
-:delete t means to delete any found entries. nil by default.
-Use `auth-source-delete' in ELisp code instead of calling
-`auth-source-search' directly with this parameter.
-
-:type (X Y Z) will check only those backend types. `netrc' and
-`secrets' are the only ones supported right now.
-
-:max N means to try to return at most N items (defaults to 1).
-More than N items may be returned, depending on the search and
-the backend.
-
-When :max is 0 the function will return just t or nil to indicate
-if any matches were found.
-
-:host (X Y Z) means to match only hosts X, Y, or Z according to
-the match rules above. Defaults to t.
-
-:user (X Y Z) means to match only users X, Y, or Z according to
-the match rules above. Defaults to t.
-
-:port (P Q R) means to match only protocols P, Q, or R.
-Defaults to t.
-
-:K (V1 V2 V3) for any other key K will match values V1, V2, or
-V3 (note the match rules above).
-
-The return value is a list with at most :max tokens. Each token
-is a plist with keys :backend :host :port :user, plus any other
-keys provided by the backend (notably :secret). But note the
-exception for :max 0, which see above.
-
-The token can hold a :save-function key. If you call that, the
-user will be prompted to save the data to the backend. You can't
-request that this should happen right after creation, because
-`auth-source-search' has no way of knowing if the token is
-actually useful. So the caller must arrange to call this function.
-
-The token's :secret key can hold a function. In that case you
-must call it to obtain the actual value."
- (let* ((backends (mapcar #'auth-source-backend-parse auth-sources))
- (max (or max 1))
- (ignored-keys '(:require :create :delete :max))
- (keys (loop for i below (length spec) by 2
- unless (memq (nth i spec) ignored-keys)
- collect (nth i spec)))
- (cached (auth-source-remembered-p spec))
- ;; note that we may have cached results but found is still nil
- ;; (there were no results from the search)
- (found (auth-source-recall spec))
- filtered-backends)
-
- (if (and cached auth-source-do-cache)
- (auth-source-do-debug
- "auth-source-search: found %d CACHED results matching %S"
- (length found) spec)
-
- (assert
- (or (eq t create) (listp create)) t
- "Invalid auth-source :create parameter (must be t or a list): %s %s")
-
- (assert
- (listp require) t
- "Invalid auth-source :require parameter (must be a list): %s")
-
- (setq filtered-backends (copy-sequence backends))
- (dolist (backend backends)
- (dolist (key keys)
- ;; ignore invalid slots
- (condition-case nil
- (unless (auth-source-search-collection
- (plist-get spec key)
- (slot-value backend key))
- (setq filtered-backends (delq backend filtered-backends))
- (return))
- (invalid-slot-name nil))))
-
- (auth-source-do-trivia
- "auth-source-search: found %d backends matching %S"
- (length filtered-backends) spec)
-
- ;; (debug spec "filtered" filtered-backends)
- ;; First go through all the backends without :create, so we can
- ;; query them all.
- (setq found (auth-source-search-backends filtered-backends
- spec
- ;; to exit early
- max
- ;; create is always nil here
- nil delete
- require))
-
- (auth-source-do-debug
- "auth-source-search: found %d results (max %d) matching %S"
- (length found) max spec)
-
- ;; If we didn't find anything, then we allow the backend(s) to
- ;; create the entries.
- (when (and create
- (not found))
- (setq found (auth-source-search-backends filtered-backends
- spec
- ;; to exit early
- max
- create delete
- require))
- (auth-source-do-debug
- "auth-source-search: CREATED %d results (max %d) matching %S"
- (length found) max spec))
-
- ;; note we remember the lack of result too, if it's applicable
- (when auth-source-do-cache
- (auth-source-remember spec found)))
-
- (if (zerop max)
- (not (null found))
- found)))
-
-(defun auth-source-search-backends (backends spec max create delete require)
- (let ((max (if (zerop max) 1 max)) ; stop with 1 match if we're asked for zero
- matches)
- (dolist (backend backends)
- (when (> max (length matches)) ; if we need more matches...
- (let* ((bmatches (apply
- (slot-value backend 'search-function)
- :backend backend
- :type (slot-value backend 'type)
- ;; note we're overriding whatever the spec
- ;; has for :max, :require, :create, and :delete
- :max max
- :require require
- :create create
- :delete delete
- spec)))
- (when bmatches
- (auth-source-do-trivia
- "auth-source-search-backend: got %d (max %d) in %s:%s matching %S"
- (length bmatches) max
- (slot-value backend 'type)
- (slot-value backend 'source)
- spec)
- (setq matches (append matches bmatches))))))
- matches))
-
-;; (auth-source-search :max 0)
-;; (auth-source-search :max 1)
-;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret))
-;; (auth-source-search :host "nonesuch" :type 'netrc :K 1)
-;; (auth-source-search :host "nonesuch" :type 'secrets)
-
-(defun auth-source-delete (&rest spec)
- "Delete entries from the authentication backends according to SPEC.
-Calls `auth-source-search' with the :delete property in SPEC set to t.
-The backend may not actually delete the entries.
-
-Returns the deleted entries."
- (auth-source-search (plist-put spec :delete t)))
-
-(defun auth-source-search-collection (collection value)
- "Returns t is VALUE is t or COLLECTION is t or COLLECTION contains VALUE."
- (when (and (atom collection) (not (eq t collection)))
- (setq collection (list collection)))
-
- ;; (debug :collection collection :value value)
- (or (eq collection t)
- (eq value t)
- (equal collection value)
- (member value collection)))
-
-(defvar auth-source-netrc-cache nil)
-
-(defun auth-source-forget-all-cached ()
- "Forget all cached auth-source data."
- (interactive)
- (loop for sym being the symbols of password-data
- ;; when the symbol name starts with auth-source-magic
- when (string-match (concat "^" auth-source-magic)
- (symbol-name sym))
- ;; remove that key
- do (password-cache-remove (symbol-name sym)))
- (setq auth-source-netrc-cache nil))
-
-(defun auth-source-format-cache-entry (spec)
- "Format SPEC entry to put it in the password cache."
- (concat auth-source-magic (format "%S" spec)))
-
-(defun auth-source-remember (spec found)
- "Remember FOUND search results for SPEC."
- (let ((password-cache-expiry auth-source-cache-expiry))
- (password-cache-add
- (auth-source-format-cache-entry spec) found)))
-
-(defun auth-source-recall (spec)
- "Recall FOUND search results for SPEC."
- (password-read-from-cache (auth-source-format-cache-entry spec)))
-
-(defun auth-source-remembered-p (spec)
- "Check if SPEC is remembered."
- (password-in-cache-p
- (auth-source-format-cache-entry spec)))
-
-(defun auth-source-forget (spec)
- "Forget any cached data matching SPEC exactly.
-
-This is the same SPEC you passed to `auth-source-search'.
-Returns t or nil for forgotten or not found."
- (password-cache-remove (auth-source-format-cache-entry spec)))
-
-;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym))
-
-;; (auth-source-remember '(:host "wedd") '(4 5 6))
-;; (auth-source-remembered-p '(:host "wedd"))
-;; (auth-source-remember '(:host "xedd") '(1 2 3))
-;; (auth-source-remembered-p '(:host "xedd"))
-;; (auth-source-remembered-p '(:host "zedd"))
-;; (auth-source-recall '(:host "xedd"))
-;; (auth-source-recall '(:host t))
-;; (auth-source-forget+ :host t)
-
-(defun auth-source-forget+ (&rest spec)
- "Forget any cached data matching SPEC. Returns forgotten count.
-
-This is not a full `auth-source-search' spec but works similarly.
-For instance, \(:host \"myhost\" \"yourhost\") would find all the
-cached data that was found with a search for those two hosts,
-while \(:host t) would find all host entries."
- (let ((count 0)
- sname)
- (loop for sym being the symbols of password-data
- ;; when the symbol name matches with auth-source-magic
- when (and (setq sname (symbol-name sym))
- (string-match (concat "^" auth-source-magic "\\(.+\\)")
- sname)
- ;; and the spec matches what was stored in the cache
- (auth-source-specmatchp spec (read (match-string 1 sname))))
- ;; remove that key
- do (progn
- (password-cache-remove sname)
- (incf count)))
- count))
-
-(defun auth-source-specmatchp (spec stored)
- (let ((keys (loop for i below (length spec) by 2
- collect (nth i spec))))
- (not (eq
- (dolist (key keys)
- (unless (auth-source-search-collection (plist-get stored key)
- (plist-get spec key))
- (return 'no)))
- 'no))))
-
-;; (auth-source-pick-first-password :host "z.lifelogs.com")
-;; (auth-source-pick-first-password :port "imap")
-(defun auth-source-pick-first-password (&rest spec)
- "Pick the first secret found from applying SPEC to `auth-source-search'."
- (let* ((result (nth 0 (apply #'auth-source-search (plist-put spec :max 1))))
- (secret (plist-get result :secret)))
-
- (if (functionp secret)
- (funcall secret)
- secret)))
-
-;; (auth-source-format-prompt "test %u %h %p" '((?u "user") (?h "host")))
-(defun auth-source-format-prompt (prompt alist)
- "Format PROMPT using %x (for any character x) specifiers in ALIST."
- (dolist (cell alist)
- (let ((c (nth 0 cell))
- (v (nth 1 cell)))
- (when (and c v)
- (setq prompt (replace-regexp-in-string (format "%%%c" c)
- (format "%s" v)
- prompt nil t)))))
- prompt)
-
-(defun auth-source-ensure-strings (values)
- (if (eq values t)
- values
- (unless (listp values)
- (setq values (list values)))
- (mapcar (lambda (value)
- (if (numberp value)
- (format "%s" value)
- value))
- values)))
-
-;;; Backend specific parsing: netrc/authinfo backend
-
-(defun auth-source--aput-1 (alist key val)
- (let ((seen ())
- (rest alist))
- (while (and (consp rest) (not (equal key (caar rest))))
- (push (pop rest) seen))
- (cons (cons key val)
- (if (null rest) alist
- (nconc (nreverse seen)
- (if (equal key (caar rest)) (cdr rest) rest))))))
-(defmacro auth-source--aput (var key val)
- `(setq ,var (auth-source--aput-1 ,var ,key ,val)))
-
-(defun auth-source--aget (alist key)
- (cdr (assoc key alist)))
-
-;; (auth-source-netrc-parse :file "~/.authinfo.gpg")
-(defun* auth-source-netrc-parse (&key file max host user port require
- &allow-other-keys)
- "Parse FILE and return a list of all entries in the file.
-Note that the MAX parameter is used so we can exit the parse early."
- (if (listp file)
- ;; We got already parsed contents; just return it.
- file
- (when (file-exists-p file)
- (setq port (auth-source-ensure-strings port))
- (with-temp-buffer
- (let* ((max (or max 5000)) ; sanity check: default to stop at 5K
- (modified 0)
- (cached (cdr-safe (assoc file auth-source-netrc-cache)))
- (cached-mtime (plist-get cached :mtime))
- (cached-secrets (plist-get cached :secret))
- (check (lambda(alist)
- (and alist
- (auth-source-search-collection
- host
- (or
- (auth-source--aget alist "machine")
- (auth-source--aget alist "host")
- t))
- (auth-source-search-collection
- user
- (or
- (auth-source--aget alist "login")
- (auth-source--aget alist "account")
- (auth-source--aget alist "user")
- t))
- (auth-source-search-collection
- port
- (or
- (auth-source--aget alist "port")
- (auth-source--aget alist "protocol")
- t))
- (or
- ;; the required list of keys is nil, or
- (null require)
- ;; every element of require is in n(ormalized)
- (let ((n (nth 0 (auth-source-netrc-normalize
- (list alist) file))))
- (loop for req in require
- always (plist-get n req)))))))
- result)
-
- (if (and (functionp cached-secrets)
- (equal cached-mtime
- (nth 5 (file-attributes file))))
- (progn
- (auth-source-do-trivia
- "auth-source-netrc-parse: using CACHED file data for %s"
- file)
- (insert (funcall cached-secrets)))
- (insert-file-contents file)
- ;; cache all netrc files (used to be just .gpg files)
- ;; Store the contents of the file heavily encrypted in memory.
- ;; (note for the irony-impaired: they are just obfuscated)
- (auth-source--aput
- auth-source-netrc-cache file
- (list :mtime (nth 5 (file-attributes file))
- :secret (lexical-let ((v (mapcar #'1+ (buffer-string))))
- (lambda () (apply #'string (mapcar #'1- v)))))))
- (goto-char (point-min))
- (let ((entries (auth-source-netrc-parse-entries check max))
- alist)
- (while (setq alist (pop entries))
- (push (nreverse alist) result)))
-
- (when (< 0 modified)
- (when auth-source-gpg-encrypt-to
- ;; (see bug#7487) making `epa-file-encrypt-to' local to
- ;; this buffer lets epa-file skip the key selection query
- ;; (see the `local-variable-p' check in
- ;; `epa-file-write-region').
- (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
- (make-local-variable 'epa-file-encrypt-to))
- (if (listp auth-source-gpg-encrypt-to)
- (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
-
- ;; ask AFTER we've successfully opened the file
- (when (y-or-n-p (format "Save file %s? (%d deletions)"
- file modified))
- (write-region (point-min) (point-max) file nil 'silent)
- (auth-source-do-debug
- "auth-source-netrc-parse: modified %d lines in %s"
- modified file)))
-
- (nreverse result))))))
-
-(defun auth-source-netrc-parse-next-interesting ()
- "Advance to the next interesting position in the current buffer."
- ;; If we're looking at a comment or are at the end of the line, move forward
- (while (or (looking-at "#")
- (and (eolp)
- (not (eobp))))
- (forward-line 1))
- (skip-chars-forward "\t "))
-
-(defun auth-source-netrc-parse-one ()
- "Read one thing from the current buffer."
- (auth-source-netrc-parse-next-interesting)
-
- (when (or (looking-at "'\\([^']*\\)'")
- (looking-at "\"\\([^\"]*\\)\"")
- (looking-at "\\([^ \t\n]+\\)"))
- (forward-char (length (match-string 0)))
- (auth-source-netrc-parse-next-interesting)
- (match-string-no-properties 1)))
-
-;; with thanks to org-mode
-(defsubst auth-source-current-line (&optional pos)
- (save-excursion
- (and pos (goto-char pos))
- ;; works also in narrowed buffer, because we start at 1, not point-min
- (+ (if (bolp) 1 0) (count-lines 1 (point)))))
-
-(defun auth-source-netrc-parse-entries(check max)
- "Parse up to MAX netrc entries, passed by CHECK, from the current buffer."
- (let ((adder (lambda(check alist all)
- (when (and
- alist
- (> max (length all))
- (funcall check alist))
- (push alist all))
- all))
- item item2 all alist default)
- (while (setq item (auth-source-netrc-parse-one))
- (setq default (equal item "default"))
- ;; We're starting a new machine. Save the old one.
- (when (and alist
- (or default
- (equal item "machine")))
- ;; (auth-source-do-trivia
- ;; "auth-source-netrc-parse-entries: got entry %S" alist)
- (setq all (funcall adder check alist all)
- alist nil))
- ;; In default entries, we don't have a next token.
- ;; We store them as ("machine" . t)
- (if default
- (push (cons "machine" t) alist)
- ;; Not a default entry. Grab the next item.
- (when (setq item2 (auth-source-netrc-parse-one))
- ;; Did we get a "machine" value?
- (if (equal item2 "machine")
- (error
- "%s: Unexpected `machine' token at line %d"
- "auth-source-netrc-parse-entries"
- (auth-source-current-line))
- (push (cons item item2) alist)))))
-
- ;; Clean up: if there's an entry left over, use it.
- (when alist
- (setq all (funcall adder check alist all))
- ;; (auth-source-do-trivia
- ;; "auth-source-netrc-parse-entries: got2 entry %S" alist)
- )
- (nreverse all)))
-
-(defvar auth-source-passphrase-alist nil)
-
-(defun auth-source-token-passphrase-callback-function (_context _key-id file)
- (let* ((file (file-truename file))
- (entry (assoc file auth-source-passphrase-alist))
- passphrase)
- ;; return the saved passphrase, calling a function if needed
- (or (copy-sequence (if (functionp (cdr entry))
- (funcall (cdr entry))
- (cdr entry)))
- (progn
- (unless entry
- (setq entry (list file))
- (push entry auth-source-passphrase-alist))
- (setq passphrase
- (read-passwd
- (format "Passphrase for %s tokens: " file)
- t))
- (setcdr entry (lexical-let ((p (copy-sequence passphrase)))
- (lambda () p)))
- passphrase))))
-
-;; (auth-source-epa-extract-gpg-token "gpg:LS0tLS1CRUdJTiBQR1AgTUVTU0FHRS0tLS0tClZlcnNpb246IEdudVBHIHYxLjQuMTEgKEdOVS9MaW51eCkKCmpBMEVBd01DT25qMjB1ak9rZnRneVI3K21iNm9aZWhuLzRad3cySkdlbnVaKzRpeEswWDY5di9icDI1U1dsQT0KPS9yc2wKLS0tLS1FTkQgUEdQIE1FU1NBR0UtLS0tLQo=" "~/.netrc")
-(defun auth-source-epa-extract-gpg-token (secret file)
- "Pass either the decoded SECRET or the gpg:BASE64DATA version.
-FILE is the file from which we obtained this token."
- (when (string-match "^gpg:\\(.+\\)" secret)
- (setq secret (base64-decode-string (match-string 1 secret))))
- (let ((context (epg-make-context 'OpenPGP)))
- (epg-context-set-passphrase-callback
- context
- (cons #'auth-source-token-passphrase-callback-function
- file))
- (epg-decrypt-string context secret)))
-
-(defvar pp-escape-newlines)
-
-;; (insert (auth-source-epa-make-gpg-token "mysecret" "~/.netrc"))
-(defun auth-source-epa-make-gpg-token (secret file)
- (let ((context (epg-make-context 'OpenPGP))
- (pp-escape-newlines nil)
- cipher)
- (setf (epg-context-armor context) t)
- (epg-context-set-passphrase-callback
- context
- (cons #'auth-source-token-passphrase-callback-function
- file))
- (setq cipher (epg-encrypt-string context secret nil))
- (with-temp-buffer
- (insert cipher)
- (base64-encode-region (point-min) (point-max) t)
- (concat "gpg:" (buffer-substring-no-properties
- (point-min)
- (point-max))))))
-
-(defun auto-source--symbol-keyword (symbol)
- (intern (format ":%s" symbol)))
-
-(defun auth-source-netrc-normalize (alist filename)
- (mapcar (lambda (entry)
- (let (ret item)
- (while (setq item (pop entry))
- (let ((k (car item))
- (v (cdr item)))
-
- ;; apply key aliases
- (setq k (cond ((member k '("machine")) "host")
- ((member k '("login" "account")) "user")
- ((member k '("protocol")) "port")
- ((member k '("password")) "secret")
- (t k)))
-
- ;; send back the secret in a function (lexical binding)
- (when (equal k "secret")
- (setq v (lexical-let ((lexv v)
- (token-decoder nil))
- (when (string-match "^gpg:" lexv)
- ;; it's a GPG token: create a token decoder
- ;; which unsets itself once
- (setq token-decoder
- (lambda (val)
- (prog1
- (auth-source-epa-extract-gpg-token
- val
- filename)
- (setq token-decoder nil)))))
- (lambda ()
- (when token-decoder
- (setq lexv (funcall token-decoder lexv)))
- lexv))))
- (setq ret (plist-put ret
- (auto-source--symbol-keyword k)
- v))))
- ret))
- alist))
-
-;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret))
-;; (funcall secret)
-
-(defun* auth-source-netrc-search (&rest
- spec
- &key backend require create
- type max host user port
- &allow-other-keys)
- "Given a property list SPEC, return search matches from the :backend.
-See `auth-source-search' for details on SPEC."
- ;; just in case, check that the type is correct (null or same as the backend)
- (assert (or (null type) (eq type (oref backend type)))
- t "Invalid netrc search: %s %s")
-
- (let ((results (auth-source-netrc-normalize
- (auth-source-netrc-parse
- :max max
- :require require
- :file (oref backend source)
- :host (or host t)
- :user (or user t)
- :port (or port t))
- (oref backend source))))
-
- ;; if we need to create an entry AND none were found to match
- (when (and create
- (not results))
-
- ;; create based on the spec and record the value
- (setq results (or
- ;; if the user did not want to create the entry
- ;; in the file, it will be returned
- (apply (slot-value backend 'create-function) spec)
- ;; if not, we do the search again without :create
- ;; to get the updated data.
-
- ;; the result will be returned, even if the search fails
- (apply #'auth-source-netrc-search
- (plist-put spec :create nil)))))
- results))
-
-(defun auth-source-netrc-element-or-first (v)
- (if (listp v)
- (nth 0 v)
- v))
-
-;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t)
-;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B)))
-
-(defun* auth-source-netrc-create (&rest spec
- &key backend
- host port create
- &allow-other-keys)
- (let* ((base-required '(host user port secret))
- ;; we know (because of an assertion in auth-source-search) that the
- ;; :create parameter is either t or a list (which includes nil)
- (create-extra (if (eq t create) nil create))
- (current-data (car (auth-source-search :max 1
- :host host
- :port port)))
- (required (append base-required create-extra))
- (file (oref backend source))
- (add "")
- ;; `valist' is an alist
- valist
- ;; `artificial' will be returned if no creation is needed
- artificial)
-
- ;; only for base required elements (defined as function parameters):
- ;; fill in the valist with whatever data we may have from the search
- ;; we complete the first value if it's a list and use the value otherwise
- (dolist (br base-required)
- (let ((val (plist-get spec (auto-source--symbol-keyword br))))
- (when val
- (let ((br-choice (cond
- ;; all-accepting choice (predicate is t)
- ((eq t val) nil)
- ;; just the value otherwise
- (t val))))
- (when br-choice
- (auth-source--aput valist br br-choice))))))
-
- ;; for extra required elements, see if the spec includes a value for them
- (dolist (er create-extra)
- (let ((k (auto-source--symbol-keyword er))
- (keys (loop for i below (length spec) by 2
- collect (nth i spec))))
- (when (memq k keys)
- (auth-source--aput valist er (plist-get spec k)))))
-
- ;; for each required element
- (dolist (r required)
- (let* ((data (auth-source--aget valist r))
- ;; take the first element if the data is a list
- (data (or (auth-source-netrc-element-or-first data)
- (plist-get current-data
- (auto-source--symbol-keyword r))))
- ;; this is the default to be offered
- (given-default (auth-source--aget
- auth-source-creation-defaults r))
- ;; the default supplementals are simple:
- ;; for the user, try `given-default' and then (user-login-name);
- ;; otherwise take `given-default'
- (default (cond
- ((and (not given-default) (eq r 'user))
- (user-login-name))
- (t given-default)))
- (printable-defaults (list
- (cons 'user
- (or
- (auth-source-netrc-element-or-first
- (auth-source--aget valist 'user))
- (plist-get artificial :user)
- "[any user]"))
- (cons 'host
- (or
- (auth-source-netrc-element-or-first
- (auth-source--aget valist 'host))
- (plist-get artificial :host)
- "[any host]"))
- (cons 'port
- (or
- (auth-source-netrc-element-or-first
- (auth-source--aget valist 'port))
- (plist-get artificial :port)
- "[any port]"))))
- (prompt (or (auth-source--aget auth-source-creation-prompts r)
- (case r
- (secret "%p password for %u@%h: ")
- (user "%p user name for %h: ")
- (host "%p host name for user %u: ")
- (port "%p port for %u@%h: "))
- (format "Enter %s (%%u@%%h:%%p): " r)))
- (prompt (auth-source-format-prompt
- prompt
- `((?u ,(auth-source--aget printable-defaults 'user))
- (?h ,(auth-source--aget printable-defaults 'host))
- (?p ,(auth-source--aget printable-defaults 'port))))))
-
- ;; Store the data, prompting for the password if needed.
- (setq data (or data
- (if (eq r 'secret)
- ;; Special case prompt for passwords.
- ;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car epa-file-auto-mode-alist-entry) "\\.gpg\\'") nil) (t gpg)))
- ;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never)
- (let* ((ep (format "Use GPG password tokens in %s?" file))
- (gpg-encrypt
- (cond
- ((eq auth-source-netrc-use-gpg-tokens 'never)
- 'never)
- ((listp auth-source-netrc-use-gpg-tokens)
- (let ((check (copy-sequence
- auth-source-netrc-use-gpg-tokens))
- item ret)
- (while check
- (setq item (pop check))
- (when (or (eq (car item) t)
- (string-match (car item) file))
- (setq ret (cdr item))
- (setq check nil)))
- ;; FIXME: `ret' unused.
- ;; Should we return it here?
- ))
- (t 'never)))
- (plain (or (eval default) (read-passwd prompt))))
- ;; ask if we don't know what to do (in which case
- ;; auth-source-netrc-use-gpg-tokens must be a list)
- (unless gpg-encrypt
- (setq gpg-encrypt (if (y-or-n-p ep) 'gpg 'never))
- ;; TODO: save the defcustom now? or ask?
- (setq auth-source-netrc-use-gpg-tokens
- (cons `(,file ,gpg-encrypt)
- auth-source-netrc-use-gpg-tokens)))
- (if (eq gpg-encrypt 'gpg)
- (auth-source-epa-make-gpg-token plain file)
- plain))
- (if (stringp default)
- (read-string (if (string-match ": *\\'" prompt)
- (concat (substring prompt 0 (match-beginning 0))
- " (default " default "): ")
- (concat prompt "(default " default ") "))
- nil nil default)
- (eval default)))))
-
- (when data
- (setq artificial (plist-put artificial
- (auto-source--symbol-keyword r)
- (if (eq r 'secret)
- (lexical-let ((data data))
- (lambda () data))
- data))))
-
- ;; When r is not an empty string...
- (when (and (stringp data)
- (< 0 (length data)))
- ;; this function is not strictly necessary but I think it
- ;; makes the code clearer -tzz
- (let ((printer (lambda ()
- ;; append the key (the symbol name of r)
- ;; and the value in r
- (format "%s%s %s"
- ;; prepend a space
- (if (zerop (length add)) "" " ")
- ;; remap auth-source tokens to netrc
- (case r
- (user "login")
- (host "machine")
- (secret "password")
- (port "port") ; redundant but clearer
- (t (symbol-name r)))
- (if (string-match "[\"# ]" data)
- (format "%S" data)
- data)))))
- (setq add (concat add (funcall printer)))))))
-
- (plist-put
- artificial
- :save-function
- (lexical-let ((file file)
- (add add))
- (lambda () (auth-source-netrc-saver file add))))
-
- (list artificial)))
-
-;;(funcall (plist-get (nth 0 (auth-source-search :host '("nonesuch2") :user "tzz" :port "imap" :create t :max 1)) :save-function))
-(defun auth-source-netrc-saver (file add)
- "Save a line ADD in FILE, prompting along the way.
-Respects `auth-source-save-behavior'. Uses
-`auth-source-netrc-cache' to avoid prompting more than once."
- (let* ((key (format "%s %s" file (rfc2104-hash 'md5 64 16 file add)))
- (cached (assoc key auth-source-netrc-cache)))
-
- (if cached
- (auth-source-do-trivia
- "auth-source-netrc-saver: found previous run for key %s, returning"
- key)
- (with-temp-buffer
- (when (file-exists-p file)
- (insert-file-contents file))
- (when auth-source-gpg-encrypt-to
- ;; (see bug#7487) making `epa-file-encrypt-to' local to
- ;; this buffer lets epa-file skip the key selection query
- ;; (see the `local-variable-p' check in
- ;; `epa-file-write-region').
- (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
- (make-local-variable 'epa-file-encrypt-to))
- (if (listp auth-source-gpg-encrypt-to)
- (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
- ;; we want the new data to be found first, so insert at beginning
- (goto-char (point-min))
-
- ;; Ask AFTER we've successfully opened the file.
- (let ((prompt (format "Save auth info to file %s? " file))
- (done (not (eq auth-source-save-behavior 'ask)))
- (bufname "*auth-source Help*")
- k)
- (while (not done)
- (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ?e ??)))
- (case k
- (?y (setq done t))
- (?? (save-excursion
- (with-output-to-temp-buffer bufname
- (princ
- (concat "(y)es, save\n"
- "(n)o but use the info\n"
- "(N)o and don't ask to save again\n"
- "(e)dit the line\n"
- "(?) for help as you can see.\n"))
- ;; Why? Doesn't with-output-to-temp-buffer already do
- ;; the exact same thing anyway? --Stef
- (set-buffer standard-output)
- (help-mode))))
- (?n (setq add ""
- done t))
- (?N
- (setq add ""
- done t)
- (customize-save-variable 'auth-source-save-behavior nil))
- (?e (setq add (read-string "Line to add: " add)))
- (t nil)))
-
- (when (get-buffer-window bufname)
- (delete-window (get-buffer-window bufname)))
-
- ;; Make sure the info is not saved.
- (when (null auth-source-save-behavior)
- (setq add ""))
-
- (when (< 0 (length add))
- (progn
- (unless (bolp)
- (insert "\n"))
- (insert add "\n")
- (write-region (point-min) (point-max) file nil 'silent)
- ;; Make the .authinfo file non-world-readable.
- (set-file-modes file #o600)
- (auth-source-do-debug
- "auth-source-netrc-create: wrote 1 new line to %s"
- file)
- (message "Saved new authentication information to %s" file)
- nil))))
- (auth-source--aput auth-source-netrc-cache key "ran"))))
-
-;;; Backend specific parsing: Secrets API backend
-
-;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t))
-;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t))
-;; (let ((auth-sources '(default))) (auth-source-search :max 1))
-;; (let ((auth-sources '(default))) (auth-source-search))
-;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1))
-;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git"))
-
-(defun auth-source-secrets-listify-pattern (pattern)
- "Convert a pattern with lists to a list of string patterns.
-
-auth-source patterns can have values of the form :foo (\"bar\"
-\"qux\"), which means to match any secret with :foo equal to
-\"bar\" or :foo equal to \"qux\". The secrets backend supports
-only string values for patterns, so this routine returns a list
-of patterns that is equivalent to the single original pattern
-when interpreted such that if a secret matches any pattern in the
-list, it matches the original pattern."
- (if (null pattern)
- '(nil)
- (let* ((key (pop pattern))
- (value (pop pattern))
- (tails (auth-source-secrets-listify-pattern pattern))
- (heads (if (stringp value)
- (list (list key value))
- (mapcar (lambda (v) (list key v)) value))))
- (loop
- for h in heads
- nconc
- (loop
- for tl in tails
- collect (append h tl))))))
-
-(defun* auth-source-secrets-search (&rest
- spec
- &key backend create delete label max
- &allow-other-keys)
- "Search the Secrets API; spec is like `auth-source'.
-
-The :label key specifies the item's label. It is the only key
-that can specify a substring. Any :label value besides a string
-will allow any label.
-
-All other search keys must match exactly. If you need substring
-matching, do a wider search and narrow it down yourself.
-
-You'll get back all the properties of the token as a plist.
-
-Here's an example that looks for the first item in the `Login'
-Secrets collection:
-
- (let ((auth-sources \\='(\"secrets:Login\")))
- (auth-source-search :max 1)
-
-Here's another that looks for the first item in the `Login'
-Secrets collection whose label contains `gnus':
-
- (let ((auth-sources \\='(\"secrets:Login\")))
- (auth-source-search :max 1 :label \"gnus\")
-
-And this one looks for the first item in the `Login' Secrets
-collection that's a Google Chrome entry for the git.gnus.org site
-authentication tokens:
-
- (let ((auth-sources \\='(\"secrets:Login\")))
- (auth-source-search :max 1 :signon_realm \"https://git.gnus.org/Git\"))
-"
-
- ;; TODO
- (assert (not create) nil
- "The Secrets API auth-source backend doesn't support creation yet")
- ;; TODO
- ;; (secrets-delete-item coll elt)
- (assert (not delete) nil
- "The Secrets API auth-source backend doesn't support deletion yet")
-
- (let* ((coll (oref backend source))
- (max (or max 5000)) ; sanity check: default to stop at 5K
- (ignored-keys '(:create :delete :max :backend :label :require :type))
- (search-keys (loop for i below (length spec) by 2
- unless (memq (nth i spec) ignored-keys)
- collect (nth i spec)))
- ;; build a search spec without the ignored keys
- ;; if a search key is nil or t (match anything), we skip it
- (search-specs (auth-source-secrets-listify-pattern
- (apply #'append (mapcar
- (lambda (k)
- (if (or (null (plist-get spec k))
- (eq t (plist-get spec k)))
- nil
- (list k (plist-get spec k))))
- search-keys))))
- ;; needed keys (always including host, login, port, and secret)
- (returned-keys (delete-dups (append
- '(:host :login :port :secret)
- search-keys)))
- (items
- (loop for search-spec in search-specs
- nconc
- (loop for item in (apply #'secrets-search-items coll search-spec)
- unless (and (stringp label)
- (not (string-match label item)))
- collect item)))
- ;; TODO: respect max in `secrets-search-items', not after the fact
- (items (butlast items (- (length items) max)))
- ;; convert the item name to a full plist
- (items (mapcar (lambda (item)
- (append
- ;; make an entry for the secret (password) element
- (list
- :secret
- (lexical-let ((v (secrets-get-secret coll item)))
- (lambda () v)))
- ;; rewrite the entry from ((k1 v1) (k2 v2)) to plist
- (apply #'append
- (mapcar (lambda (entry)
- (list (car entry) (cdr entry)))
- (secrets-get-attributes coll item)))))
- items))
- ;; ensure each item has each key in `returned-keys'
- (items (mapcar (lambda (plist)
- (append
- (apply #'append
- (mapcar (lambda (req)
- (if (plist-get plist req)
- nil
- (list req nil)))
- returned-keys))
- plist))
- items)))
- items))
-
-(defun auth-source-secrets-create (&rest spec)
- ;; TODO
- ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec)
- (debug spec))
-
-;;; Backend specific parsing: Mac OS Keychain (using /usr/bin/security) backend
-
-;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1 :create t))
-;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1 :delete t))
-;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1))
-;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search))
-
-;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1 :create t))
-;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1 :delete t))
-;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1))
-;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search))
-
-;; (let ((auth-sources '("macos-keychain-internet:/Users/tzz/Library/Keychains/login.keychain"))) (auth-source-search :max 1))
-;; (let ((auth-sources '("macos-keychain-generic:Login"))) (auth-source-search :max 1 :host "git.gnus.org"))
-;; (let ((auth-sources '("macos-keychain-generic:Login"))) (auth-source-search :max 1))
-
-(defun* auth-source-macos-keychain-search (&rest
- spec
- &key backend create delete
- type max
- &allow-other-keys)
- "Search the MacOS Keychain; spec is like `auth-source'.
-
-All search keys must match exactly. If you need substring
-matching, do a wider search and narrow it down yourself.
-
-You'll get back all the properties of the token as a plist.
-
-The :type key is either `macos-keychain-internet' or
-`macos-keychain-generic'.
-
-For the internet keychain type, the :label key searches the
-item's labels (\"-l LABEL\" passed to \"/usr/bin/security\").
-Similarly, :host maps to \"-s HOST\", :user maps to \"-a USER\",
-and :port maps to \"-P PORT\" or \"-r PROT\"
-\(note PROT has to be a 4-character string).
-
-For the generic keychain type, the :label key searches the item's
-labels (\"-l LABEL\" passed to \"/usr/bin/security\").
-Similarly, :host maps to \"-c HOST\" (the \"creator\" keychain
-field), :user maps to \"-a USER\", and :port maps to \"-s PORT\".
-
-Here's an example that looks for the first item in the default
-generic MacOS Keychain:
-
- (let ((auth-sources \\='(macos-keychain-generic)))
- (auth-source-search :max 1)
-
-Here's another that looks for the first item in the internet
-MacOS Keychain collection whose label is `gnus':
-
- (let ((auth-sources \\='(macos-keychain-internet)))
- (auth-source-search :max 1 :label \"gnus\")
-
-And this one looks for the first item in the internet keychain
-entries for git.gnus.org:
-
- (let ((auth-sources \\='(macos-keychain-internet\")))
- (auth-source-search :max 1 :host \"git.gnus.org\"))
-"
- ;; TODO
- (assert (not create) nil
- "The MacOS Keychain auth-source backend doesn't support creation yet")
- ;; TODO
- ;; (macos-keychain-delete-item coll elt)
- (assert (not delete) nil
- "The MacOS Keychain auth-source backend doesn't support deletion yet")
-
- (let* ((coll (oref backend source))
- (max (or max 5000)) ; sanity check: default to stop at 5K
- ;; Filter out ignored keys from the spec
- (ignored-keys '(:create :delete :max :backend :label :host :port))
- ;; Build a search spec without the ignored keys
- (search-keys (loop for i below (length spec) by 2
- unless (memq (nth i spec) ignored-keys)
- collect (nth i spec)))
- ;; If a search key value is nil or t (match anything), we skip it
- (search-spec (apply #'append (mapcar
- (lambda (k)
- (if (or (null (plist-get spec k))
- (eq t (plist-get spec k)))
- nil
- (list k (plist-get spec k))))
- search-keys)))
- ;; needed keys (always including host, login, port, and secret)
- (returned-keys (delete-dups (append
- '(:host :login :port :secret)
- search-keys)))
- ;; Extract host and port from spec
- (hosts (plist-get spec :host))
- (hosts (if (and hosts (listp hosts)) hosts `(,hosts)))
- (ports (plist-get spec :port))
- (ports (if (and ports (listp ports)) ports `(,ports)))
- ;; Loop through all combinations of host/port and pass each of these to
- ;; auth-source-macos-keychain-search-items
- (items (catch 'match
- (dolist (host hosts)
- (dolist (port ports)
- (let* ((port (format "%S" port))
- (items (apply #'auth-source-macos-keychain-search-items
- coll
- type
- max
- host port
- search-spec)))
- (when items
- (throw 'match items)))))))
-
- ;; ensure each item has each key in `returned-keys'
- (items (mapcar (lambda (plist)
- (append
- (apply #'append
- (mapcar (lambda (req)
- (if (plist-get plist req)
- nil
- (list req nil)))
- returned-keys))
- plist))
- items)))
- items))
-
-(defun* auth-source-macos-keychain-search-items (coll _type _max
- host port
- &key label type
- user
- &allow-other-keys)
-
- (let* ((keychain-generic (eq type 'macos-keychain-generic))
- (args `(,(if keychain-generic
- "find-generic-password"
- "find-internet-password")
- "-g"))
- (ret (list :type type)))
- (when label
- (setq args (append args (list "-l" label))))
- (when host
- (setq args (append args (list (if keychain-generic "-c" "-s") host))))
- (when user
- (setq args (append args (list "-a" user))))
-
- (when port
- (if keychain-generic
- (setq args (append args (list "-s" port)))
- (setq args (append args (list
- (if (string-match "[0-9]+" port) "-P" "-r")
- port)))))
-
- (unless (equal coll "default")
- (setq args (append args (list coll))))
-
- (with-temp-buffer
- (apply #'call-process "/usr/bin/security" nil t nil args)
- (goto-char (point-min))
- (while (not (eobp))
- (cond
- ((looking-at "^password: \"\\(.+\\)\"$")
- (setq ret (auth-source-macos-keychain-result-append
- ret
- keychain-generic
- "secret"
- (lexical-let ((v (match-string 1)))
- (lambda () v)))))
- ;; TODO: check if this is really the label
- ;; match 0x00000007 <blob>="AppleID"
- ((looking-at "^[ ]+0x00000007 <blob>=\"\\(.+\\)\"")
- (setq ret (auth-source-macos-keychain-result-append
- ret
- keychain-generic
- "label"
- (match-string 1))))
- ;; match "crtr"<uint32>="aapl"
- ;; match "svce"<blob>="AppleID"
- ((looking-at "^[ ]+\"\\([a-z]+\\)\"[^=]+=\"\\(.+\\)\"")
- (setq ret (auth-source-macos-keychain-result-append
- ret
- keychain-generic
- (match-string 1)
- (match-string 2)))))
- (forward-line)))
- ;; return `ret' iff it has the :secret key
- (and (plist-get ret :secret) (list ret))))
-
-(defun auth-source-macos-keychain-result-append (result generic k v)
- (push v result)
- (push (auto-source--symbol-keyword
- (cond
- ((equal k "acct") "user")
- ;; for generic keychains, creator is host, service is port
- ((and generic (equal k "crtr")) "host")
- ((and generic (equal k "svce")) "port")
- ;; for internet keychains, protocol is port, server is host
- ((and (not generic) (equal k "ptcl")) "port")
- ((and (not generic) (equal k "srvr")) "host")
- (t k)))
- result))
-
-(defun auth-source-macos-keychain-create (&rest spec)
- ;; TODO
- (debug spec))
-
-;;; Backend specific parsing: PLSTORE backend
-
-(defun* auth-source-plstore-search (&rest
- spec
- &key backend create delete
- max
- &allow-other-keys)
- "Search the PLSTORE; spec is like `auth-source'."
- (let* ((store (oref backend data))
- (max (or max 5000)) ; sanity check: default to stop at 5K
- (ignored-keys '(:create :delete :max :backend :label :require :type))
- (search-keys (loop for i below (length spec) by 2
- unless (memq (nth i spec) ignored-keys)
- collect (nth i spec)))
- ;; build a search spec without the ignored keys
- ;; if a search key is nil or t (match anything), we skip it
- (search-spec (apply #'append (mapcar
- (lambda (k)
- (let ((v (plist-get spec k)))
- (if (or (null v)
- (eq t v))
- nil
- (if (stringp v)
- (setq v (list v)))
- (list k v))))
- search-keys)))
- ;; needed keys (always including host, login, port, and secret)
- (returned-keys (delete-dups (append
- '(:host :login :port :secret)
- search-keys)))
- (items (plstore-find store search-spec))
- (item-names (mapcar #'car items))
- (items (butlast items (- (length items) max)))
- ;; convert the item to a full plist
- (items (mapcar (lambda (item)
- (let* ((plist (copy-tree (cdr item)))
- (secret (plist-member plist :secret)))
- (if secret
- (setcar
- (cdr secret)
- (lexical-let ((v (car (cdr secret))))
- (lambda () v))))
- plist))
- items))
- ;; ensure each item has each key in `returned-keys'
- (items (mapcar (lambda (plist)
- (append
- (apply #'append
- (mapcar (lambda (req)
- (if (plist-get plist req)
- nil
- (list req nil)))
- returned-keys))
- plist))
- items)))
- (cond
- ;; if we need to create an entry AND none were found to match
- ((and create
- (not items))
-
- ;; create based on the spec and record the value
- (setq items (or
- ;; if the user did not want to create the entry
- ;; in the file, it will be returned
- (apply (slot-value backend 'create-function) spec)
- ;; if not, we do the search again without :create
- ;; to get the updated data.
-
- ;; the result will be returned, even if the search fails
- (apply #'auth-source-plstore-search
- (plist-put spec :create nil)))))
- ((and delete
- item-names)
- (dolist (item-name item-names)
- (plstore-delete store item-name))
- (plstore-save store)))
- items))
-
-(defun* auth-source-plstore-create (&rest spec
- &key backend
- host port create
- &allow-other-keys)
- (let* ((base-required '(host user port secret))
- (base-secret '(secret))
- ;; we know (because of an assertion in auth-source-search) that the
- ;; :create parameter is either t or a list (which includes nil)
- (create-extra (if (eq t create) nil create))
- (current-data (car (auth-source-search :max 1
- :host host
- :port port)))
- (required (append base-required create-extra))
- ;; `valist' is an alist
- valist
- ;; `artificial' will be returned if no creation is needed
- artificial
- secret-artificial)
-
- ;; only for base required elements (defined as function parameters):
- ;; fill in the valist with whatever data we may have from the search
- ;; we complete the first value if it's a list and use the value otherwise
- (dolist (br base-required)
- (let ((val (plist-get spec (auto-source--symbol-keyword br))))
- (when val
- (let ((br-choice (cond
- ;; all-accepting choice (predicate is t)
- ((eq t val) nil)
- ;; just the value otherwise
- (t val))))
- (when br-choice
- (auth-source--aput valist br br-choice))))))
-
- ;; for extra required elements, see if the spec includes a value for them
- (dolist (er create-extra)
- (let ((k (auto-source--symbol-keyword er))
- (keys (loop for i below (length spec) by 2
- collect (nth i spec))))
- (when (memq k keys)
- (auth-source--aput valist er (plist-get spec k)))))
-
- ;; for each required element
- (dolist (r required)
- (let* ((data (auth-source--aget valist r))
- ;; take the first element if the data is a list
- (data (or (auth-source-netrc-element-or-first data)
- (plist-get current-data
- (auto-source--symbol-keyword r))))
- ;; this is the default to be offered
- (given-default (auth-source--aget
- auth-source-creation-defaults r))
- ;; the default supplementals are simple:
- ;; for the user, try `given-default' and then (user-login-name);
- ;; otherwise take `given-default'
- (default (cond
- ((and (not given-default) (eq r 'user))
- (user-login-name))
- (t given-default)))
- (printable-defaults (list
- (cons 'user
- (or
- (auth-source-netrc-element-or-first
- (auth-source--aget valist 'user))
- (plist-get artificial :user)
- "[any user]"))
- (cons 'host
- (or
- (auth-source-netrc-element-or-first
- (auth-source--aget valist 'host))
- (plist-get artificial :host)
- "[any host]"))
- (cons 'port
- (or
- (auth-source-netrc-element-or-first
- (auth-source--aget valist 'port))
- (plist-get artificial :port)
- "[any port]"))))
- (prompt (or (auth-source--aget auth-source-creation-prompts r)
- (case r
- (secret "%p password for %u@%h: ")
- (user "%p user name for %h: ")
- (host "%p host name for user %u: ")
- (port "%p port for %u@%h: "))
- (format "Enter %s (%%u@%%h:%%p): " r)))
- (prompt (auth-source-format-prompt
- prompt
- `((?u ,(auth-source--aget printable-defaults 'user))
- (?h ,(auth-source--aget printable-defaults 'host))
- (?p ,(auth-source--aget printable-defaults 'port))))))
-
- ;; Store the data, prompting for the password if needed.
- (setq data (or data
- (if (eq r 'secret)
- (or (eval default) (read-passwd prompt))
- (if (stringp default)
- (read-string
- (if (string-match ": *\\'" prompt)
- (concat (substring prompt 0 (match-beginning 0))
- " (default " default "): ")
- (concat prompt "(default " default ") "))
- nil nil default)
- (eval default)))))
-
- (when data
- (if (member r base-secret)
- (setq secret-artificial
- (plist-put secret-artificial
- (auto-source--symbol-keyword r)
- data))
- (setq artificial (plist-put artificial
- (auto-source--symbol-keyword r)
- data))))))
- (plstore-put (oref backend data)
- (sha1 (format "%s@%s:%s"
- (plist-get artificial :user)
- (plist-get artificial :host)
- (plist-get artificial :port)))
- artificial secret-artificial)
- (if (y-or-n-p (format "Save auth info to file %s? "
- (plstore-get-file (oref backend data))))
- (plstore-save (oref backend data)))))
-
-;;; older API
-
-;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")
-
-;; deprecate the old interface
-(make-obsolete 'auth-source-user-or-password
- 'auth-source-search "Emacs 24.1")
-(make-obsolete 'auth-source-forget-user-or-password
- 'auth-source-forget "Emacs 24.1")
-
-(defun auth-source-user-or-password
- (mode host port &optional username create-missing delete-existing)
- "Find MODE (string or list of strings) matching HOST and PORT.
-
-DEPRECATED in favor of `auth-source-search'!
-
-USERNAME is optional and will be used as \"login\" in a search
-across the Secret Service API (see secrets.el) if the resulting
-items don't have a username. This means that if you search for
-username \"joe\" and it matches an item but the item doesn't have
-a :user attribute, the username \"joe\" will be returned.
-
-A non nil DELETE-EXISTING means deleting any matching password
-entry in the respective sources. This is useful only when
-CREATE-MISSING is non nil as well; the intended use case is to
-remove wrong password entries.
-
-If no matching entry is found, and CREATE-MISSING is non nil,
-the password will be retrieved interactively, and it will be
-stored in the password database which matches best (see
-`auth-sources').
-
-MODE can be \"login\" or \"password\"."
- (auth-source-do-debug
- "auth-source-user-or-password: DEPRECATED get %s for %s (%s) + user=%s"
- mode host port username)
-
- (let* ((listy (listp mode))
- (mode (if listy mode (list mode)))
- ;; (cname (if username
- ;; (format "%s %s:%s %s" mode host port username)
- ;; (format "%s %s:%s" mode host port)))
- (search (list :host host :port port))
- (search (if username (append search (list :user username)) search))
- (search (if create-missing
- (append search (list :create t))
- search))
- (search (if delete-existing
- (append search (list :delete t))
- search))
- ;; (found (if (not delete-existing)
- ;; (gethash cname auth-source-cache)
- ;; (remhash cname auth-source-cache)
- ;; nil)))
- (found nil))
- (if found
- (progn
- (auth-source-do-debug
- "auth-source-user-or-password: DEPRECATED cached %s=%s for %s (%s) + %s"
- mode
- ;; don't show the password
- (if (and (member "password" mode) t)
- "SECRET"
- found)
- host port username)
- found) ; return the found data
- ;; else, if not found, search with a max of 1
- (let ((choice (nth 0 (apply #'auth-source-search
- (append '(:max 1) search)))))
- (when choice
- (dolist (m mode)
- (cond
- ((equal "password" m)
- (push (if (plist-get choice :secret)
- (funcall (plist-get choice :secret))
- nil) found))
- ((equal "login" m)
- (push (plist-get choice :user) found)))))
- (setq found (nreverse found))
- (setq found (if listy found (car-safe found)))))
-
- found))
-
-(defun auth-source-user-and-password (host &optional user)
- (let* ((auth-info (car
- (if user
- (auth-source-search
- :host host
- :user "yourusername"
- :max 1
- :require '(:user :secret)
- :create nil)
- (auth-source-search
- :host host
- :max 1
- :require '(:user :secret)
- :create nil))))
- (user (plist-get auth-info :user))
- (password (plist-get auth-info :secret)))
- (when (functionp password)
- (setq password (funcall password)))
- (list user password auth-info)))
-
-(provide 'auth-source)
-
-;;; auth-source.el ends here
+++ /dev/null
-;;; compface.el --- functions for converting X-Face headers
-
-;; Copyright (C) 2002-2016 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-;;;###
-(defun uncompface (face)
- "Convert FACE to pbm.
-Requires the external programs `uncompface', and `icontopbm'. On a
-GNU/Linux system these might be in packages with names like `compface'
-or `faces-xface' and `netpbm' or `libgr-progs', for instance."
- (with-temp-buffer
- (set-buffer-multibyte nil)
- (insert face)
- (let ((coding-system-for-read 'raw-text)
- ;; At least "icontopbm" doesn't work with Windows because
- ;; the line-break code is converted into CRLF by default.
- (coding-system-for-write 'binary))
- (and (eq 0 (apply 'call-process-region (point-min) (point-max)
- "uncompface"
- 'delete '(t nil) nil))
- (progn
- (goto-char (point-min))
- (insert "/* Format_version=1, Width=48, Height=48, Depth=1,\
- Valid_bits_per_item=16 */\n")
- ;; Emacs doesn't understand un-raw pbm files.
- (eq 0 (call-process-region (point-min) (point-max)
- "icontopbm"
- 'delete '(t nil))))
- (buffer-string)))))
-
-(provide 'compface)
-
-;;; compface.el ends here
+++ /dev/null
-;;; ecomplete.el --- electric completion of addresses and the like
-
-;; Copyright (C) 2006-2016 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: mail
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile
- (require 'cl))
-
-(defgroup ecomplete nil
- "Electric completion of email addresses and the like."
- :group 'mail)
-
-(defcustom ecomplete-database-file "~/.ecompleterc"
- "*The name of the file to store the ecomplete data."
- :group 'ecomplete
- :type 'file)
-
-(defcustom ecomplete-database-file-coding-system 'iso-2022-7bit
- "Coding system used for writing the ecomplete database file."
- :type '(symbol :tag "Coding system")
- :group 'ecomplete)
-
-;;; Internal variables.
-
-(defvar ecomplete-database nil)
-
-;;;###autoload
-(defun ecomplete-setup ()
- (when (file-exists-p ecomplete-database-file)
- (with-temp-buffer
- (let ((coding-system-for-read ecomplete-database-file-coding-system))
- (insert-file-contents ecomplete-database-file)
- (setq ecomplete-database (read (current-buffer)))))))
-
-(defun ecomplete-add-item (type key text)
- (let ((elems (assq type ecomplete-database))
- (now (string-to-number (format "%.0f" (float-time))))
- entry)
- (unless elems
- (push (setq elems (list type)) ecomplete-database))
- (if (setq entry (assoc key (cdr elems)))
- (setcdr entry (list (1+ (cadr entry)) now text))
- (nconc elems (list (list key 1 now text))))))
-
-(defun ecomplete-get-item (type key)
- (assoc key (cdr (assq type ecomplete-database))))
-
-(defun ecomplete-save ()
- (with-temp-buffer
- (let ((coding-system-for-write ecomplete-database-file-coding-system))
- (insert "(")
- (loop for (type . elems) in ecomplete-database
- do
- (insert (format "(%s\n" type))
- (dolist (entry elems)
- (prin1 entry (current-buffer))
- (insert "\n"))
- (insert ")\n"))
- (insert ")")
- (write-region (point-min) (point-max)
- ecomplete-database-file nil 'silent))))
-
-(defun ecomplete-get-matches (type match)
- (let* ((elems (cdr (assq type ecomplete-database)))
- (match (regexp-quote match))
- (candidates
- (sort
- (loop for (key count time text) in elems
- when (string-match match text)
- collect (list count time text))
- (lambda (l1 l2)
- (> (car l1) (car l2))))))
- (when (> (length candidates) 10)
- (setcdr (nthcdr 10 candidates) nil))
- (unless (zerop (length candidates))
- (with-temp-buffer
- (dolist (candidate candidates)
- (insert (caddr candidate) "\n"))
- (goto-char (point-min))
- (put-text-property (point) (1+ (point)) 'ecomplete t)
- (while (re-search-forward match nil t)
- (put-text-property (match-beginning 0) (match-end 0)
- 'face 'isearch))
- (buffer-string)))))
-
-(defun ecomplete-display-matches (type word &optional choose)
- (let* ((matches (ecomplete-get-matches type word))
- (line 0)
- (max-lines (when matches (- (length (split-string matches "\n")) 2)))
- (message-log-max nil)
- command highlight)
- (if (not matches)
- (progn
- (message "No ecomplete matches")
- nil)
- (if (not choose)
- (progn
- (message "%s" matches)
- nil)
- (setq highlight (ecomplete-highlight-match-line matches line))
- (let ((local-map (make-sparse-keymap))
- selected)
- (define-key local-map (kbd "RET")
- (lambda () (setq selected (nth line (split-string matches "\n")))))
- (define-key local-map (kbd "M-n")
- (lambda () (setq line (min (1+ line) max-lines))))
- (define-key local-map (kbd "M-p")
- (lambda () (setq line (max (1- line) 0))))
- (let ((overriding-local-map local-map))
- (while (and (null selected)
- (setq command (read-key-sequence highlight))
- (lookup-key local-map command))
- (apply (key-binding command) nil)
- (setq highlight (ecomplete-highlight-match-line matches line))))
- (if selected
- (message selected)
- (message "Abort"))
- selected)))))
-
-(defun ecomplete-highlight-match-line (matches line)
- (with-temp-buffer
- (insert matches)
- (goto-char (point-min))
- (forward-line line)
- (save-restriction
- (narrow-to-region (point) (point-at-eol))
- (while (not (eobp))
- ;; Put the 'region face on any characters on this line that
- ;; aren't already highlighted.
- (unless (get-text-property (point) 'face)
- (put-text-property (point) (1+ (point)) 'face 'highlight))
- (forward-char 1)))
- (buffer-string)))
-
-(provide 'ecomplete)
-
-;;; ecomplete.el ends here
+++ /dev/null
-;;; flow-fill.el --- interpret RFC2646 "flowed" text
-
-;; Copyright (C) 2000-2016 Free Software Foundation, Inc.
-
-;; Author: Simon Josefsson <jas@pdc.kth.se>
-;; Keywords: mail
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This implement decoding of RFC2646 formatted text, including the
-;; quoted-depth wins rules.
-
-;; Theory of operation: search for lines ending with SPC, save quote
-;; length of line, remove SPC and concatenate line with the following
-;; line if quote length of following line matches current line.
-
-;; When no further concatenations are possible, we've found a
-;; paragraph and we let `fill-region' fill the long line into several
-;; lines with the quote prefix as `fill-prefix'.
-
-;; Todo: implement basic `fill-region' (Emacs and XEmacs
-;; implementations differ..)
-
-;;; History:
-
-;; 2000-02-17 posted on ding mailing list
-;; 2000-02-19 use `point-at-{b,e}ol' in XEmacs
-;; 2000-03-11 no compile warnings for point-at-bol stuff
-;; 2000-03-26 committed to gnus cvs
-;; 2000-10-23 don't flow "-- " lines, make "quote-depth wins" rule
-;; work when first line is at level 0.
-;; 2002-01-12 probably incomplete encoding support
-;; 2003-12-08 started working on test harness.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(defcustom fill-flowed-display-column 'fill-column
- "Column beyond which format=flowed lines are wrapped, when displayed.
-This can be a Lisp expression or an integer."
- :version "22.1"
- :group 'mime-display
- :type '(choice (const :tag "Standard `fill-column'" fill-column)
- (const :tag "Fit Window" (- (window-width) 5))
- (sexp)
- (integer)))
-
-(defcustom fill-flowed-encode-column 66
- "Column beyond which format=flowed lines are wrapped, in outgoing messages.
-This can be a Lisp expression or an integer.
-RFC 2646 suggests 66 characters for readability."
- :version "22.1"
- :group 'mime-display
- :type '(choice (const :tag "Standard fill-column" fill-column)
- (const :tag "RFC 2646 default (66)" 66)
- (sexp)
- (integer)))
-
-;;;###autoload
-(defun fill-flowed-encode (&optional buffer)
- (with-current-buffer (or buffer (current-buffer))
- ;; No point in doing this unless hard newlines is used.
- (when use-hard-newlines
- (let ((start (point-min)) end)
- ;; Go through each paragraph, filling it and adding SPC
- ;; as the last character on each line.
- (while (setq end (text-property-any start (point-max) 'hard 't))
- (save-restriction
- (narrow-to-region start end)
- (let ((fill-column (eval fill-flowed-encode-column)))
- (fill-flowed-fill-buffer))
- (goto-char (point-min))
- (while (re-search-forward "\n" nil t)
- (replace-match " \n" t t))
- (goto-char (setq start (1+ (point-max)))))))
- t)))
-
-(defun fill-flowed-fill-buffer ()
- (let ((prefix nil)
- (prev-prefix nil)
- (start (point-min)))
- (goto-char (point-min))
- (while (not (eobp))
- (setq prefix (and (looking-at "[> ]+")
- (match-string 0)))
- (if (equal prefix prev-prefix)
- (forward-line 1)
- (save-restriction
- (narrow-to-region start (point))
- (let ((fill-prefix prev-prefix))
- (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop))
- (goto-char (point-max)))
- (setq prev-prefix prefix
- start (point))))
- (save-restriction
- (narrow-to-region start (point))
- (let ((fill-prefix prev-prefix))
- (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop)))))
-
-;;;###autoload
-(defun fill-flowed (&optional buffer delete-space)
- (with-current-buffer (or (current-buffer) buffer)
- (goto-char (point-min))
- ;; Remove space stuffing.
- (while (re-search-forward "^\\( \\|>+ $\\)" nil t)
- (delete-char -1)
- (forward-line 1))
- (goto-char (point-min))
- (while (re-search-forward " $" nil t)
- (when (save-excursion
- (beginning-of-line)
- (looking-at "^\\(>*\\)\\( ?\\)"))
- (let ((quote (match-string 1))
- sig)
- (if (string= quote "")
- (setq quote nil))
- (when (and quote (string= (match-string 2) ""))
- (save-excursion
- ;; insert SP after quote for pleasant reading of quoted lines
- (beginning-of-line)
- (when (> (skip-chars-forward ">") 0)
- (insert " "))))
- ;; XXX slightly buggy handling of "-- "
- (while (and (save-excursion
- (ignore-errors (backward-char 3))
- (setq sig (looking-at "-- "))
- (looking-at "[^-][^-] "))
- (save-excursion
- (unless (eobp)
- (forward-char 1)
- (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)"
- (or quote " ?"))))))
- (save-excursion
- (replace-match (if (string= (match-string 2) " ")
- "" "\\2")))
- (backward-delete-char -1)
- (when delete-space
- (delete-char -1))
- (end-of-line))
- (unless sig
- (condition-case nil
- (let ((fill-prefix (when quote (concat quote " ")))
- (fill-column (eval fill-flowed-display-column))
- adaptive-fill-mode)
- (fill-region (point-at-bol)
- (min (1+ (point-at-eol))
- (point-max))
- 'left 'nosqueeze))
- (error
- (forward-line 1)
- nil))))))))
-
-;; Test vectors.
-
-(defvar show-trailing-whitespace)
-
-(defvar fill-flowed-encode-tests
- `(
- ;; The syntax of each list element is:
- ;; (INPUT . EXPECTED-OUTPUT)
- (,(concat
- "> Thou villainous ill-breeding spongy dizzy-eyed \n"
- "> reeky elf-skinned pigeon-egg! \n"
- ">> Thou artless swag-bellied milk-livered \n"
- ">> dismal-dreaming idle-headed scut!\n"
- ">>> Thou errant folly-fallen spleeny reeling-ripe \n"
- ">>> unmuzzled ratsbane!\n"
- ">>>> Henceforth, the coding style is to be strictly \n"
- ">>>> enforced, including the use of only upper case.\n"
- ">>>>> I've noticed a lack of adherence to the coding \n"
- ">>>>> styles, of late.\n"
- ">>>>>> Any complaints?")
- .
- ,(concat
- "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned\n"
- "> pigeon-egg! \n"
- ">> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed\n"
- ">> scut!\n"
- ">>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!\n"
- ">>>> Henceforth, the coding style is to be strictly enforced,\n"
- ">>>> including the use of only upper case.\n"
- ">>>>> I've noticed a lack of adherence to the coding styles, of late.\n"
- ">>>>>> Any complaints?\n"
- ))
- ;; (,(concat
- ;; "\n"
- ;; "> foo\n"
- ;; "> \n"
- ;; "> \n"
- ;; "> bar\n")
- ;; .
- ;; ,(concat
- ;; "\n"
- ;; "> foo bar\n"))
- ))
-
-(defun fill-flowed-test ()
- (interactive "")
- (switch-to-buffer (get-buffer-create "*Format=Flowed test output*"))
- (erase-buffer)
- (setq show-trailing-whitespace t)
- (dolist (test fill-flowed-encode-tests)
- (let (start output)
- (insert "***** BEGIN TEST INPUT *****\n")
- (insert (car test))
- (insert "***** END TEST INPUT *****\n\n")
- (insert "***** BEGIN TEST OUTPUT *****\n")
- (setq start (point))
- (insert (car test))
- (save-restriction
- (narrow-to-region start (point))
- (fill-flowed))
- (setq output (buffer-substring start (point-max)))
- (insert "***** END TEST OUTPUT *****\n")
- (unless (string= output (cdr test))
- (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n")
- (insert (cdr test))
- (insert "***** END TEST EXPECTED OUTPUT *****\n"))
- (insert "\n\n")))
- (goto-char (point-max)))
-
-(provide 'flow-fill)
-
-;;; flow-fill.el ends here
+++ /dev/null
-;;; gravatar.el --- Get Gravatars
-
-;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
-
-;; Author: Julien Danjou <julien@danjou.info>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(require 'url)
-(require 'url-cache)
-(require 'image)
-
-(defgroup gravatar nil
- "Gravatar."
- :version "24.1"
- :group 'comm)
-
-(defcustom gravatar-automatic-caching t
- "Whether to cache retrieved gravatars."
- :type 'boolean
- :group 'gravatar)
-
-;; FIXME a time value is not the nicest format for a custom variable.
-(defcustom gravatar-cache-ttl (days-to-time 30)
- "Time to live for gravatar cache entries."
- :type '(repeat integer)
- :group 'gravatar)
-
-;; FIXME Doc is tautological. What are the options?
-(defcustom gravatar-rating "g"
- "Default rating for gravatar."
- :type 'string
- :group 'gravatar)
-
-(defcustom gravatar-size 32
- "Default size in pixels for gravatars."
- :type 'integer
- :group 'gravatar)
-
-(defconst gravatar-base-url
- "http://www.gravatar.com/avatar"
- "Base URL for getting gravatars.")
-
-(defun gravatar-hash (mail-address)
- "Create an hash from MAIL-ADDRESS."
- (md5 (downcase mail-address)))
-
-(defun gravatar-build-url (mail-address)
- "Return an URL to retrieve MAIL-ADDRESS gravatar."
- (format "%s/%s?d=404&r=%s&s=%d"
- gravatar-base-url
- (gravatar-hash mail-address)
- gravatar-rating
- gravatar-size))
-
-(defun gravatar-cache-expired (url)
- "Check if URL is cached for more than `gravatar-cache-ttl'."
- (cond (url-standalone-mode
- (not (file-exists-p (url-cache-create-filename url))))
- (t (let ((cache-time (url-is-cached url)))
- (if cache-time
- (time-less-p
- (time-add
- cache-time
- gravatar-cache-ttl)
- (current-time))
- t)))))
-
-(defun gravatar-get-data ()
- "Get data from current buffer."
- (save-excursion
- (goto-char (point-min))
- (when (re-search-forward "^HTTP/.+ 200 OK$" nil (line-end-position))
- (when (search-forward "\n\n" nil t)
- (buffer-substring (point) (point-max))))))
-
-(defun gravatar-data->image ()
- "Get data of current buffer and return an image.
-If no image available, return 'error."
- (let ((data (gravatar-get-data)))
- (if data
- (create-image data nil t)
- 'error)))
-
-(autoload 'help-function-arglist "help-fns")
-
-;;;###autoload
-(defun gravatar-retrieve (mail-address cb &optional cbargs)
- "Retrieve MAIL-ADDRESS gravatar and call CB on retrieval.
-You can provide a list of argument to pass to CB in CBARGS."
- (let ((url (gravatar-build-url mail-address)))
- (if (gravatar-cache-expired url)
- (let ((args (list url
- 'gravatar-retrieved
- (list cb (when cbargs cbargs)))))
- (when (> (length (if (featurep 'xemacs)
- (cdr (split-string (function-arglist 'url-retrieve)))
- (help-function-arglist 'url-retrieve)))
- 4)
- (setq args (nconc args (list t))))
- (apply #'url-retrieve args))
- (apply cb
- (with-temp-buffer
- (mm-disable-multibyte)
- (url-cache-extract (url-cache-create-filename url))
- (gravatar-data->image))
- cbargs))))
-
-;;;###autoload
-(defun gravatar-retrieve-synchronously (mail-address)
- "Retrieve MAIL-ADDRESS gravatar and returns it."
- (let ((url (gravatar-build-url mail-address)))
- (if (gravatar-cache-expired url)
- (with-current-buffer (url-retrieve-synchronously url)
- (when gravatar-automatic-caching
- (url-store-in-cache (current-buffer)))
- (let ((data (gravatar-data->image)))
- (kill-buffer (current-buffer))
- data))
- (with-temp-buffer
- (mm-disable-multibyte)
- (url-cache-extract (url-cache-create-filename url))
- (gravatar-data->image)))))
-
-
-(defun gravatar-retrieved (status cb &optional cbargs)
- "Callback function used by `gravatar-retrieve'."
- ;; Store gravatar?
- (when gravatar-automatic-caching
- (url-store-in-cache (current-buffer)))
- (if (plist-get status :error)
- ;; Error happened.
- (apply cb 'error cbargs)
- (apply cb (gravatar-data->image) cbargs))
- (kill-buffer (current-buffer)))
-
-(provide 'gravatar)
-
-;;; gravatar.el ends here
+++ /dev/null
-;;; html2text.el --- a simple html to plain text converter -*- coding: utf-8 -*-
-
-;; Copyright (C) 2002-2016 Free Software Foundation, Inc.
-
-;; Author: Joakim Hove <hove@phys.ntnu.no>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; These functions provide a simple way to wash/clean html infected
-;; mails. Definitely do not work in all cases, but some improvement
-;; in readability is generally obtained. Formatting is only done in
-;; the buffer, so the next time you enter the article it will be
-;; "re-htmlized".
-;;
-;; The main function is `html2text'.
-
-;;; Code:
-
-;;
-;; <Global variables>
-;;
-
-(eval-when-compile
- (require 'cl))
-
-(defvar html2text-format-single-element-list '(("hr" . html2text-clean-hr)))
-
-(defvar html2text-replace-list
- '(("´" . "`")
- ("&" . "&")
- ("'" . "'")
- ("¦" . "|")
- ("¢" . "c")
- ("ˆ" . "^")
- ("©" . "(C)")
- ("¤" . "(#)")
- ("°" . "degree")
- ("÷" . "/")
- ("€" . "e")
- ("½" . "1/2")
- (">" . ">")
- ("¿" . "?")
- ("«" . "<<")
- ("&ldquo" . "\"")
- ("‹" . "(")
- ("‘" . "`")
- ("<" . "<")
- ("—" . "--")
- (" " . " ")
- ("–" . "-")
- ("‰" . "%%")
- ("±" . "+-")
- ("£" . "£")
- (""" . "\"")
- ("»" . ">>")
- ("&rdquo" . "\"")
- ("®" . "(R)")
- ("›" . ")")
- ("’" . "'")
- ("§" . "§")
- ("¹" . "^1")
- ("²" . "^2")
- ("³" . "^3")
- ("˜" . "~"))
- "The map of entity to text.
-
-This is an alist were each element is a dotted pair consisting of an
-old string, and a replacement string. This replacement is done by the
-function `html2text-substitute' which basically performs a
-`replace-string' operation for every element in the list. This is
-completely verbatim - without any use of REGEXP.")
-
-(defvar html2text-remove-tag-list
- '("html" "body" "p" "img" "dir" "head" "div" "br" "font" "title" "meta")
- "A list of removable tags.
-
-This is a list of tags which should be removed, without any
-formatting. Note that tags in the list are presented *without*
-any \"<\" or \">\". All occurrences of a tag appearing in this
-list are removed, irrespective of whether it is a closing or
-opening tag, or if the tag has additional attributes. The
-deletion is done by the function `html2text-remove-tags'.
-
-For instance the text:
-
-\"Here comes something <font size\"+3\" face=\"Helvetica\"> big </font>.\"
-
-will be reduced to:
-
-\"Here comes something big.\"
-
-If this list contains the element \"font\".")
-
-(defvar html2text-format-tag-list
- '(("b" . html2text-clean-bold)
- ("strong" . html2text-clean-bold)
- ("u" . html2text-clean-underline)
- ("i" . html2text-clean-italic)
- ("em" . html2text-clean-italic)
- ("blockquote" . html2text-clean-blockquote)
- ("a" . html2text-clean-anchor)
- ("ul" . html2text-clean-ul)
- ("ol" . html2text-clean-ol)
- ("dl" . html2text-clean-dl)
- ("center" . html2text-clean-center))
- "An alist of tags and processing functions.
-
-This is an alist where each dotted pair consists of a tag, and then
-the name of a function to be called when this tag is found. The
-function is called with the arguments p1, p2, p3 and p4. These are
-demonstrated below:
-
-\"<b> This is bold text </b>\"
- ^ ^ ^ ^
- | | | |
-p1 p2 p3 p4
-
-Then the called function will typically format the text somewhat and
-remove the tags.")
-
-(defvar html2text-remove-tag-list2 '("li" "dt" "dd" "meta")
- "Another list of removable tags.
-
-This is a list of tags which are removed similarly to the list
-`html2text-remove-tag-list' - but these tags are retained for the
-formatting, and then moved afterward.")
-
-;;
-;; </Global variables>
-;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;
-;; <Utility functions>
-;;
-
-
-(defun html2text-replace-string (from-string to-string min max)
- "Replace FROM-STRING with TO-STRING in region from MIN to MAX."
- (goto-char min)
- (let ((delta (- (string-width to-string) (string-width from-string)))
- (change 0))
- (while (search-forward from-string max t)
- (replace-match to-string)
- (setq change (+ change delta)))
- change))
-
-;;
-;; </Utility functions>
-;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;
-;; <Functions related to attributes> i.e. <font size=+3>
-;;
-
-(defun html2text-attr-value (list attribute)
- "Get value of ATTRIBUTE from LIST."
- (nth 1 (assoc attribute list)))
-
-(defun html2text-get-attr (p1 p2)
- (goto-char p1)
- (re-search-forward "\\s-+" p2 t)
- (let (attr-list)
- (while (re-search-forward "[-a-z0-9._]+" p2 t)
- (setq attr-list
- (cons
- (list (match-string 0)
- (when (looking-at "\\s-*=")
- (goto-char (match-end 0))
- (skip-chars-forward "[:space:]")
- (when (or (looking-at "\"[^\"]*\"\\|'[^']*'")
- (looking-at "[-a-z0-9._:]+"))
- (goto-char (match-end 0))
- (match-string 0))))
- attr-list)))
- attr-list))
-
-;;
-;; </Functions related to attributes>
-;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;
-;; <Functions to be called to format a tag-pair>
-;;
-(defun html2text-clean-list-items (p1 p2 list-type)
- (goto-char p1)
- (let ((item-nr 0)
- (items 0))
- (while (search-forward "<li>" p2 t)
- (setq items (1+ items)))
- (goto-char p1)
- (while (< item-nr items)
- (setq item-nr (1+ item-nr))
- (search-forward "<li>" (point-max) t)
- (cond
- ((string= list-type "ul") (insert " o "))
- ((string= list-type "ol") (insert (format " %s: " item-nr)))
- (t (insert " x "))))))
-
-(defun html2text-clean-dtdd (p1 p2)
- (goto-char p1)
- (let ((items 0)
- (item-nr 0))
- (while (search-forward "<dt>" p2 t)
- (setq items (1+ items)))
- (goto-char p1)
- (while (< item-nr items)
- (setq item-nr (1+ item-nr))
- (re-search-forward "<dt>\\([ ]*\\)" (point-max) t)
- (when (match-string 1)
- (delete-region (point) (- (point) (string-width (match-string 1)))))
- (let ((def-p1 (point))
- (def-p2 0))
- (re-search-forward "\\([ ]*\\)\\(</dt>\\|<dd>\\)" (point-max) t)
- (if (match-string 1)
- (progn
- (let* ((mw1 (string-width (match-string 1)))
- (mw2 (string-width (match-string 2)))
- (mw (+ mw1 mw2)))
- (goto-char (- (point) mw))
- (delete-region (point) (+ (point) mw1))
- (setq def-p2 (point))))
- (setq def-p2 (- (point) (string-width (match-string 2)))))
- (put-text-property def-p1 def-p2 'face 'bold)))))
-
-(defun html2text-delete-tags (p1 p2 p3 p4)
- (delete-region p1 p2)
- (delete-region (- p3 (- p2 p1)) (- p4 (- p2 p1))))
-
-(defun html2text-delete-single-tag (p1 p2)
- (delete-region p1 p2))
-
-(defun html2text-clean-hr (p1 p2)
- (html2text-delete-single-tag p1 p2)
- (goto-char p1)
- (newline 1)
- (insert (make-string fill-column ?-)))
-
-(defun html2text-clean-ul (p1 p2 p3 p4)
- (html2text-delete-tags p1 p2 p3 p4)
- (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ul"))
-
-(defun html2text-clean-ol (p1 p2 p3 p4)
- (html2text-delete-tags p1 p2 p3 p4)
- (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ol"))
-
-(defun html2text-clean-dl (p1 p2 p3 p4)
- (html2text-delete-tags p1 p2 p3 p4)
- (html2text-clean-dtdd p1 (- p3 (- p1 p2))))
-
-(defun html2text-clean-center (p1 p2 p3 p4)
- (html2text-delete-tags p1 p2 p3 p4)
- (center-region p1 (- p3 (- p2 p1))))
-
-(defun html2text-clean-bold (p1 p2 p3 p4)
- (put-text-property p2 p3 'face 'bold)
- (html2text-delete-tags p1 p2 p3 p4))
-
-(defun html2text-clean-title (p1 p2 p3 p4)
- (put-text-property p2 p3 'face 'bold)
- (html2text-delete-tags p1 p2 p3 p4))
-
-(defun html2text-clean-underline (p1 p2 p3 p4)
- (put-text-property p2 p3 'face 'underline)
- (html2text-delete-tags p1 p2 p3 p4))
-
-(defun html2text-clean-italic (p1 p2 p3 p4)
- (put-text-property p2 p3 'face 'italic)
- (html2text-delete-tags p1 p2 p3 p4))
-
-(defun html2text-clean-font (p1 p2 p3 p4)
- (html2text-delete-tags p1 p2 p3 p4))
-
-(defun html2text-clean-blockquote (p1 p2 p3 p4)
- (html2text-delete-tags p1 p2 p3 p4))
-
-(defun html2text-clean-anchor (p1 p2 p3 p4)
- ;; If someone can explain how to make the URL clickable I will surely
- ;; improve upon this.
- ;; Maybe `goto-addr.el' can be used here.
- (let* ((attr-list (html2text-get-attr p1 p2))
- (href (html2text-attr-value attr-list "href")))
- (delete-region p1 p4)
- (when href
- (goto-char p1)
- (insert (if (string-match "\\`['\"].*['\"]\\'" href)
- (substring href 1 -1) href))
- (put-text-property p1 (point) 'face 'bold))))
-
-;;
-;; </Functions to be called to format a tag-pair>
-;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;
-;; <Functions to be called to fix up paragraphs>
-;;
-
-(defun html2text-fix-paragraph (p1 p2)
- (goto-char p1)
- (let ((refill-start)
- (refill-stop))
- (when (re-search-forward "<br>$" p2 t)
- (goto-char p1)
- (when (re-search-forward ".+[^<][^b][^r][^>]$" p2 t)
- (beginning-of-line)
- (setq refill-start (point))
- (goto-char p2)
- (re-search-backward ".+[^<][^b][^r][^>]$" refill-start t)
- (forward-line 1)
- (end-of-line)
- ;; refill-stop should ideally be adjusted to
- ;; accommodate the "<br>" strings which are removed
- ;; between refill-start and refill-stop. Can simply
- ;; be returned from my-replace-string
- (setq refill-stop (+ (point)
- (html2text-replace-string
- "<br>" ""
- refill-start (point))))
- ;; (message "Point = %s refill-stop = %s" (point) refill-stop)
- ;; (sleep-for 4)
- (fill-region refill-start refill-stop))))
- (html2text-replace-string "<br>" "" p1 p2))
-
-;;
-;; This one is interactive ...
-;;
-(defun html2text-fix-paragraphs ()
- "This _tries_ to fix up the paragraphs - this is done in quite a ad-hook
-fashion, quite close to pure guess-work. It does work in some cases though."
- (interactive)
- (goto-char (point-min))
- (while (re-search-forward "^<br>$" nil t)
- (delete-region (match-beginning 0) (match-end 0)))
- ;; Removing lonely <br> on a single line, if they are left intact we
- ;; don't have any paragraphs at all.
- (goto-char (point-min))
- (while (not (eobp))
- (let ((p1 (point)))
- (forward-paragraph 1)
- ;;(message "Kaller fix med p1=%s p2=%s " p1 (1- (point))) (sleep-for 5)
- (html2text-fix-paragraph p1 (1- (point)))
- (goto-char p1)
- (when (not (eobp))
- (forward-paragraph 1)))))
-
-;;
-;; </Functions to be called to fix up paragraphs>
-;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;
-;; <Interactive functions>
-;;
-
-(defun html2text-remove-tags (tag-list)
- "Removes the tags listed in the list `html2text-remove-tag-list'.
-See the documentation for that variable."
- (interactive)
- (dolist (tag tag-list)
- (goto-char (point-min))
- (while (re-search-forward (format "\\(</?%s[^>]*>\\)" tag) (point-max) t)
- (delete-region (match-beginning 0) (match-end 0)))))
-
-(defun html2text-format-tags ()
- "See the variable `html2text-format-tag-list' for documentation."
- (interactive)
- (dolist (tag-and-function html2text-format-tag-list)
- (let ((tag (car tag-and-function))
- (function (cdr tag-and-function)))
- (goto-char (point-min))
- (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag)
- (point-max) t)
- (let ((p1)
- (p2 (point))
- (p3) (p4))
- (search-backward "<" (point-min) t)
- (setq p1 (point))
- (unless (search-forward (format "</%s>" tag) (point-max) t)
- (goto-char p2)
- (insert (format "</%s>" tag)))
- (setq p4 (point))
- (search-backward "</" (point-min) t)
- (setq p3 (point))
- (funcall function p1 p2 p3 p4)
- (goto-char p1))))))
-
-(defun html2text-substitute ()
- "See the variable `html2text-replace-list' for documentation."
- (interactive)
- (dolist (e html2text-replace-list)
- (goto-char (point-min))
- (let ((old-string (car e))
- (new-string (cdr e)))
- (html2text-replace-string old-string new-string (point-min) (point-max)))))
-
-(defun html2text-format-single-elements ()
- (interactive)
- (dolist (tag-and-function html2text-format-single-element-list)
- (let ((tag (car tag-and-function))
- (function (cdr tag-and-function)))
- (goto-char (point-min))
- (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag)
- (point-max) t)
- (let ((p1)
- (p2 (point)))
- (search-backward "<" (point-min) t)
- (setq p1 (point))
- (funcall function p1 p2))))))
-
-;;
-;; Main function
-;;
-
-;;;###autoload
-(defun html2text ()
- "Convert HTML to plain text in the current buffer."
- (interactive)
- (save-excursion
- (let ((case-fold-search t)
- (buffer-read-only))
- (html2text-remove-tags html2text-remove-tag-list)
- (html2text-format-tags)
- (html2text-remove-tags html2text-remove-tag-list2)
- (html2text-substitute)
- (html2text-format-single-elements)
- (html2text-fix-paragraphs))))
-
-;;
-;; </Interactive functions>
-;;
-(provide 'html2text)
-
-;;; html2text.el ends here
+++ /dev/null
-;;; ietf-drums.el --- Functions for parsing RFC822bis headers
-
-;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; DRUMS is an IETF Working Group that works (or worked) on the
-;; successor to RFC822, "Standard For The Format Of Arpa Internet Text
-;; Messages". This library is based on
-;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05.
-
-;; Pending a real regression self test suite, Simon Josefsson added
-;; various self test expressions snipped from bug reports, and their
-;; expected value, below. I you believe it could be useful, please
-;; add your own test cases, or write a real self test suite, or just
-;; remove this.
-
-;; <m3oekvfd50.fsf@whitebox.m5r.de>
-;; (ietf-drums-parse-address "'foo' <foo@example.com>")
-;; => ("foo@example.com" . "'foo'")
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177"
- "US-ASCII control characters excluding CR, LF and white space.")
-(defvar ietf-drums-text-token "\001-\011\013\014\016-\177"
- "US-ASCII characters excluding CR and LF.")
-(defvar ietf-drums-specials-token "()<>[]:;@\\,.\""
- "Special characters.")
-(defvar ietf-drums-quote-token "\\"
- "Quote character.")
-(defvar ietf-drums-wsp-token " \t"
- "White space.")
-(defvar ietf-drums-fws-regexp
- (concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+")
- "Folding white space.")
-(defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~"
- "Textual token.")
-(defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~."
- "Textual token including full stop.")
-(defvar ietf-drums-qtext-token
- (concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177")
- "Non-white-space control characters, plus the rest of ASCII excluding
-backslash and doublequote.")
-(defvar ietf-drums-tspecials "][()<>@,;:\\\"/?="
- "Tspecials.")
-
-(defvar ietf-drums-syntax-table
- (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
- (modify-syntax-entry ?\\ "/" table)
- (modify-syntax-entry ?< "(" table)
- (modify-syntax-entry ?> ")" table)
- (modify-syntax-entry ?@ "w" table)
- (modify-syntax-entry ?/ "w" table)
- (modify-syntax-entry ?* "_" table)
- (modify-syntax-entry ?\; "_" table)
- (modify-syntax-entry ?\' "_" table)
- table))
-
-(defun ietf-drums-token-to-list (token)
- "Translate TOKEN into a list of characters."
- (let ((i 0)
- b e c out range)
- (while (< i (length token))
- (setq c (aref token i))
- (incf i)
- (cond
- ((eq c ?-)
- (if b
- (setq range t)
- (push c out)))
- (range
- (while (<= b c)
- (push (make-char 'ascii b) out)
- (incf b))
- (setq range nil))
- ((= i (length token))
- (push (make-char 'ascii c) out))
- (t
- (when b
- (push (make-char 'ascii b) out))
- (setq b c))))
- (nreverse out)))
-
-(defsubst ietf-drums-init (string)
- (set-syntax-table ietf-drums-syntax-table)
- (insert string)
- (ietf-drums-unfold-fws)
- (goto-char (point-min)))
-
-(defun ietf-drums-remove-comments (string)
- "Remove comments from STRING."
- (with-temp-buffer
- (let (c)
- (ietf-drums-init string)
- (while (not (eobp))
- (setq c (char-after))
- (cond
- ((eq c ?\")
- (condition-case err
- (forward-sexp 1)
- (error (goto-char (point-max)))))
- ((eq c ?\()
- (delete-region
- (point)
- (condition-case nil
- (with-syntax-table (copy-syntax-table ietf-drums-syntax-table)
- (modify-syntax-entry ?\" "w")
- (forward-sexp 1)
- (point))
- (error (point-max)))))
- (t
- (forward-char 1))))
- (buffer-string))))
-
-(defun ietf-drums-remove-whitespace (string)
- "Remove whitespace from STRING."
- (with-temp-buffer
- (ietf-drums-init string)
- (let (c)
- (while (not (eobp))
- (setq c (char-after))
- (cond
- ((eq c ?\")
- (forward-sexp 1))
- ((eq c ?\()
- (forward-sexp 1))
- ((memq c '(?\ ?\t ?\n))
- (delete-char 1))
- (t
- (forward-char 1))))
- (buffer-string))))
-
-(defun ietf-drums-get-comment (string)
- "Return the first comment in STRING."
- (with-temp-buffer
- (ietf-drums-init string)
- (let (result c)
- (while (not (eobp))
- (setq c (char-after))
- (cond
- ((eq c ?\")
- (forward-sexp 1))
- ((eq c ?\()
- (setq result
- (buffer-substring
- (1+ (point))
- (progn (forward-sexp 1) (1- (point))))))
- (t
- (forward-char 1))))
- result)))
-
-(defun ietf-drums-strip (string)
- "Remove comments and whitespace from STRING."
- (ietf-drums-remove-whitespace (ietf-drums-remove-comments string)))
-
-(defun ietf-drums-parse-address (string)
- "Parse STRING and return a MAILBOX / DISPLAY-NAME pair."
- (with-temp-buffer
- (let (display-name mailbox c display-string)
- (ietf-drums-init string)
- (while (not (eobp))
- (setq c (char-after))
- (cond
- ((or (eq c ? )
- (eq c ?\t))
- (forward-char 1))
- ((eq c ?\()
- (forward-sexp 1))
- ((eq c ?\")
- (push (buffer-substring
- (1+ (point)) (progn (forward-sexp 1) (1- (point))))
- display-name))
- ((looking-at (concat "[" ietf-drums-atext-token "@" "]"))
- (push (buffer-substring (point) (progn (forward-sexp 1) (point)))
- display-name))
- ((eq c ?<)
- (setq mailbox
- (ietf-drums-remove-whitespace
- (ietf-drums-remove-comments
- (buffer-substring
- (1+ (point))
- (progn (forward-sexp 1) (1- (point))))))))
- (t
- (forward-char 1))))
- ;; If we found no display-name, then we look for comments.
- (if display-name
- (setq display-string
- (mapconcat 'identity (reverse display-name) " "))
- (setq display-string (ietf-drums-get-comment string)))
- (if (not mailbox)
- (when (and display-string
- (string-match "@" display-string))
- (cons
- (mapconcat 'identity (nreverse display-name) "")
- (ietf-drums-get-comment string)))
- (cons mailbox display-string)))))
-
-(defun ietf-drums-parse-addresses (string &optional rawp)
- "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs.
-If RAWP, don't actually parse the addresses, but instead return
-a list of address strings."
- (if (null string)
- nil
- (with-temp-buffer
- (ietf-drums-init string)
- (let ((beg (point))
- pairs c address)
- (while (not (eobp))
- (setq c (char-after))
- (cond
- ((memq c '(?\" ?< ?\())
- (condition-case nil
- (forward-sexp 1)
- (error
- (skip-chars-forward "^,"))))
- ((eq c ?,)
- (setq address
- (if rawp
- (buffer-substring beg (point))
- (condition-case nil
- (ietf-drums-parse-address
- (buffer-substring beg (point)))
- (error nil))))
- (if address (push address pairs))
- (forward-char 1)
- (setq beg (point)))
- (t
- (forward-char 1))))
- (setq address
- (if rawp
- (buffer-substring beg (point))
- (condition-case nil
- (ietf-drums-parse-address
- (buffer-substring beg (point)))
- (error nil))))
- (if address (push address pairs))
- (nreverse pairs)))))
-
-(defun ietf-drums-unfold-fws ()
- "Unfold folding white space in the current buffer."
- (goto-char (point-min))
- (while (re-search-forward ietf-drums-fws-regexp nil t)
- (replace-match " " t t))
- (goto-char (point-min)))
-
-(defun ietf-drums-parse-date (string)
- "Return an Emacs time spec from STRING."
- (apply 'encode-time (parse-time-string string)))
-
-(defun ietf-drums-narrow-to-header ()
- "Narrow to the header section in the current buffer."
- (narrow-to-region
- (goto-char (point-min))
- (if (re-search-forward "^\r?$" nil 1)
- (match-beginning 0)
- (point-max)))
- (goto-char (point-min)))
-
-(defun ietf-drums-quote-string (string)
- "Quote string if it needs quoting to be displayed in a header."
- (if (string-match (concat "[^" ietf-drums-atext-token "]") string)
- (concat "\"" string "\"")
- string))
-
-(defun ietf-drums-make-address (name address)
- (if name
- (concat (ietf-drums-quote-string name) " <" address ">")
- address))
-
-(provide 'ietf-drums)
-
-;;; ietf-drums.el ends here
+++ /dev/null
-;;; mail-parse.el --- Interface functions for parsing mail
-
-;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file contains wrapper functions for a wide range of mail
-;; parsing functions. The idea is that there are low-level libraries
-;; that implement according to various specs (RFC2231, DRUMS, USEFOR),
-;; but that programmers that want to parse some header (say,
-;; Content-Type) will want to use the latest spec.
-;;
-;; So while each low-level library (rfc2231.el, for instance) decodes
-;; faithfully according to that (proposed) standard, this library is
-;; the interface library. If some later RFC supersedes RFC2231, one
-;; would just have to write a new low-level library, adjust the
-;; aliases in this library, and the users and programmers won't notice
-;; any changes.
-
-;;; Code:
-
-(require 'mail-prsvr)
-(require 'ietf-drums)
-(require 'rfc2231)
-(require 'rfc2047)
-(require 'rfc2045)
-
-(defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string)
-(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string)
-(defalias 'mail-content-type-get 'rfc2231-get-value)
-(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter)
-
-(defalias 'mail-header-remove-comments 'ietf-drums-remove-comments)
-(defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace)
-(defalias 'mail-header-strip 'ietf-drums-strip)
-(defalias 'mail-header-get-comment 'ietf-drums-get-comment)
-(defalias 'mail-header-parse-address 'ietf-drums-parse-address)
-(defalias 'mail-header-parse-addresses 'ietf-drums-parse-addresses)
-(defalias 'mail-header-parse-date 'ietf-drums-parse-date)
-(defalias 'mail-narrow-to-head 'ietf-drums-narrow-to-header)
-(defalias 'mail-quote-string 'ietf-drums-quote-string)
-(defalias 'mail-header-make-address 'ietf-drums-make-address)
-
-(defalias 'mail-header-fold-field 'rfc2047-fold-field)
-(defalias 'mail-header-unfold-field 'rfc2047-unfold-field)
-(defalias 'mail-header-narrow-to-field 'rfc2047-narrow-to-field)
-(defalias 'mail-header-field-value 'rfc2047-field-value)
-
-(defalias 'mail-encode-encoded-word-region 'rfc2047-encode-region)
-(defalias 'mail-encode-encoded-word-buffer 'rfc2047-encode-message-header)
-(defalias 'mail-encode-encoded-word-string 'rfc2047-encode-string)
-(defalias 'mail-decode-encoded-word-region 'rfc2047-decode-region)
-(defalias 'mail-decode-encoded-word-string 'rfc2047-decode-string)
-(defalias 'mail-decode-encoded-address-region 'rfc2047-decode-address-region)
-(defalias 'mail-decode-encoded-address-string 'rfc2047-decode-address-string)
-
-(provide 'mail-parse)
-
-;;; mail-parse.el ends here
+++ /dev/null
-;;; mail-prsvr.el --- Interface variables for parsing mail
-
-;; Copyright (C) 1999-2016 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(defvar mail-parse-charset nil
- "Default charset used by low-level libraries.
-This variable should never be set. Instead, it should be bound by
-functions that wish to call mail-parse functions and let them know
-what the desired charset is to be.")
-
-(defvar mail-parse-mule-charset nil
- "Default MULE charset used by low-level libraries.
-This variable should never be set.")
-
-(defvar mail-parse-ignored-charsets nil
- "Ignored charsets used by low-level libraries.
-This variable should never be set. Instead, it should be bound by
-functions that wish to call mail-parse functions and let them know
-what the desired charsets is to be ignored.")
-
-(provide 'mail-prsvr)
-
-;;; mail-prsvr.el ends here
+++ /dev/null
-;;; mailcap.el --- MIME media types configuration
-
-;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
-
-;; Author: William M. Perry <wmperry@aventail.com>
-;; Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news, mail, multimedia
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Provides configuration of MIME media types from directly from Lisp
-;; and via the usual mailcap mechanism (RFC 1524). Deals with
-;; mime.types similarly.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(autoload 'mail-header-parse-content-type "mail-parse")
-
-(defgroup mailcap nil
- "Definition of viewers for MIME types."
- :version "21.1"
- :group 'mime)
-
-(defvar mailcap-parse-args-syntax-table
- (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
- (modify-syntax-entry ?' "\"" table)
- (modify-syntax-entry ?` "\"" table)
- (modify-syntax-entry ?{ "(" table)
- (modify-syntax-entry ?} ")" table)
- table)
- "A syntax table for parsing SGML attributes.")
-
-(defvar mailcap-print-command
- (mapconcat 'identity
- (cons (if (boundp 'lpr-command)
- lpr-command
- "lpr")
- (when (boundp 'lpr-switches)
- (if (stringp lpr-switches)
- (list lpr-switches)
- lpr-switches)))
- " ")
- "Shell command (including switches) used to print PostScript files.")
-
-;; Postpone using defcustom for this as it's so big and we essentially
-;; have to have two copies of the data around then. Perhaps just
-;; customize the Lisp viewers and rely on the normal configuration
-;; files for the rest? -- fx
-(defvar mailcap-mime-data
- `(("application"
- ("vnd\\.ms-excel"
- (viewer . "gnumeric %s")
- (test . (getenv "DISPLAY"))
- (type . "application/vnd.ms-excel"))
- ("x-x509-ca-cert"
- (viewer . ssl-view-site-cert)
- (type . "application/x-x509-ca-cert"))
- ("x-x509-user-cert"
- (viewer . ssl-view-user-cert)
- (type . "application/x-x509-user-cert"))
- ("octet-stream"
- (viewer . mailcap-save-binary-file)
- (non-viewer . t)
- (type . "application/octet-stream"))
- ("dvi"
- (viewer . "xdvi -safer %s")
- (test . (eq window-system 'x))
- ("needsx11")
- (type . "application/dvi")
- ("print" . "dvips -qRP %s"))
- ("dvi"
- (viewer . "dvitty %s")
- (test . (not (getenv "DISPLAY")))
- (type . "application/dvi")
- ("print" . "dvips -qRP %s"))
- ("emacs-lisp"
- (viewer . mailcap-maybe-eval)
- (type . "application/emacs-lisp"))
- ("x-emacs-lisp"
- (viewer . mailcap-maybe-eval)
- (type . "application/x-emacs-lisp"))
- ("x-tar"
- (viewer . mailcap-save-binary-file)
- (non-viewer . t)
- (type . "application/x-tar"))
- ("x-latex"
- (viewer . tex-mode)
- (type . "application/x-latex"))
- ("x-tex"
- (viewer . tex-mode)
- (type . "application/x-tex"))
- ("latex"
- (viewer . tex-mode)
- (type . "application/latex"))
- ("tex"
- (viewer . tex-mode)
- (type . "application/tex"))
- ("texinfo"
- (viewer . texinfo-mode)
- (type . "application/tex"))
- ("zip"
- (viewer . mailcap-save-binary-file)
- (non-viewer . t)
- (type . "application/zip")
- ("copiousoutput"))
- ("pdf"
- (viewer . pdf-view-mode)
- (type . "application/pdf")
- (test . (eq window-system 'x)))
- ("pdf"
- (viewer . doc-view-mode)
- (type . "application/pdf")
- (test . (eq window-system 'x)))
- ("pdf"
- (viewer . "gv -safer %s")
- (type . "application/pdf")
- (test . window-system)
- ("print" . ,(concat "pdf2ps %s - | " mailcap-print-command)))
- ("pdf"
- (viewer . "gpdf %s")
- (type . "application/pdf")
- ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
- (test . (eq window-system 'x)))
- ("pdf"
- (viewer . "xpdf %s")
- (type . "application/pdf")
- ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
- (test . (eq window-system 'x)))
- ("pdf"
- (viewer . ,(concat "pdftotext %s -"))
- (type . "application/pdf")
- ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
- ("copiousoutput"))
- ("postscript"
- (viewer . "gv -safer %s")
- (type . "application/postscript")
- (test . window-system)
- ("print" . ,(concat mailcap-print-command " %s"))
- ("needsx11"))
- ("postscript"
- (viewer . "ghostview -dSAFER %s")
- (type . "application/postscript")
- (test . (eq window-system 'x))
- ("print" . ,(concat mailcap-print-command " %s"))
- ("needsx11"))
- ("postscript"
- (viewer . "ps2ascii %s")
- (type . "application/postscript")
- (test . (not (getenv "DISPLAY")))
- ("print" . ,(concat mailcap-print-command " %s"))
- ("copiousoutput"))
- ("sieve"
- (viewer . sieve-mode)
- (type . "application/sieve"))
- ("pgp-keys"
- (viewer . "gpg --import --interactive --verbose")
- (type . "application/pgp-keys")
- ("needsterminal")))
- ("audio"
- ("x-mpeg"
- (viewer . "maplay %s")
- (type . "audio/x-mpeg"))
- (".*"
- (viewer . "showaudio")
- (type . "audio/*")))
- ("message"
- ("rfc-*822"
- (viewer . mm-view-message)
- (test . (and (featurep 'gnus)
- (gnus-alive-p)))
- (type . "message/rfc822"))
- ("rfc-*822"
- (viewer . vm-mode)
- (type . "message/rfc822"))
- ("rfc-*822"
- (viewer . view-mode)
- (type . "message/rfc822")))
- ("image"
- ("x-xwd"
- (viewer . "xwud -in %s")
- (type . "image/x-xwd")
- ("compose" . "xwd -frame > %s")
- (test . (eq window-system 'x))
- ("needsx11"))
- ("x11-dump"
- (viewer . "xwud -in %s")
- (type . "image/x-xwd")
- ("compose" . "xwd -frame > %s")
- (test . (eq window-system 'x))
- ("needsx11"))
- ("windowdump"
- (viewer . "xwud -in %s")
- (type . "image/x-xwd")
- ("compose" . "xwd -frame > %s")
- (test . (eq window-system 'x))
- ("needsx11"))
- (".*"
- (viewer . "display %s")
- (type . "image/*")
- (test . (eq window-system 'x))
- ("needsx11"))
- (".*"
- (viewer . "ee %s")
- (type . "image/*")
- (test . (eq window-system 'x))
- ("needsx11")))
- ("text"
- ("plain"
- (viewer . view-mode)
- (type . "text/plain"))
- ("plain"
- (viewer . fundamental-mode)
- (type . "text/plain"))
- ("enriched"
- (viewer . enriched-decode)
- (type . "text/enriched"))
- ("dns"
- (viewer . dns-mode)
- (type . "text/dns")))
- ("video"
- ("mpeg"
- (viewer . "mpeg_play %s")
- (type . "video/mpeg")
- (test . (eq window-system 'x))
- ("needsx11")))
- ("x-world"
- ("x-vrml"
- (viewer . "webspace -remote %s -URL %u")
- (type . "x-world/x-vrml")
- ("description"
- "VRML document")))
- ("archive"
- ("tar"
- (viewer . tar-mode)
- (type . "archive/tar"))))
- "The mailcap structure is an assoc list of assoc lists.
-1st assoc list is keyed on the major content-type
-2nd assoc list is keyed on the minor content-type (which can be a regexp)
-
-Which looks like:
------------------
- ((\"application\"
- (\"postscript\" . <info>))
- (\"text\"
- (\"plain\" . <info>)))
-
-Where <info> is another assoc list of the various information
-related to the mailcap RFC 1524. This is keyed on the lowercase
-attribute name (viewer, test, etc). This looks like:
- ((viewer . VIEWERINFO)
- (test . TESTINFO)
- (xxxx . \"STRING\")
- FLAG)
-
-Where VIEWERINFO specifies how the content-type is viewed. Can be
-a string, in which case it is run through a shell, with appropriate
-parameters, or a symbol, in which case the symbol is `funcall'ed if
-and only if it exists as a function, with the buffer as an argument.
-
-TESTINFO is a test for the viewer's applicability, or nil. If nil, it
-means the viewer is always valid. If it is a Lisp function, it is
-called with a list of items from any extra fields from the
-Content-Type header as argument to return a boolean value for the
-validity. Otherwise, if it is a non-function Lisp symbol or list
-whose car is a symbol, it is `eval'led to yield the validity. If it
-is a string or list of strings, it represents a shell command to run
-to return a true or false shell value for the validity.")
-(put 'mailcap-mime-data 'risky-local-variable t)
-
-(defcustom mailcap-download-directory nil
- "*Directory to which `mailcap-save-binary-file' downloads files by default.
-nil means your home directory."
- :type '(choice (const :tag "Home directory" nil)
- directory)
- :group 'mailcap)
-
-(defvar mailcap-poor-system-types
- '(ms-dos windows-nt)
- "Systems that don't have a Unix-like directory hierarchy.")
-
-;;;
-;;; Utility functions
-;;;
-
-(defun mailcap-save-binary-file ()
- (goto-char (point-min))
- (unwind-protect
- (let ((file (read-file-name
- "Filename to save as: "
- (or mailcap-download-directory "~/")))
- (require-final-newline nil))
- (write-region (point-min) (point-max) file))
- (kill-buffer (current-buffer))))
-
-(defvar mailcap-maybe-eval-warning
- "*** WARNING ***
-
-This MIME part contains untrusted and possibly harmful content.
-If you evaluate the Emacs Lisp code contained in it, a lot of nasty
-things can happen. Please examine the code very carefully before you
-instruct Emacs to evaluate it. You can browse the buffer containing
-the code using \\[scroll-other-window].
-
-If you are unsure what to do, please answer \"no\"."
- "Text of warning message displayed by `mailcap-maybe-eval'.
-Make sure that this text consists only of few text lines. Otherwise,
-Gnus might fail to display all of it.")
-
-(defun mailcap-maybe-eval ()
- "Maybe evaluate a buffer of Emacs Lisp code."
- (let ((lisp-buffer (current-buffer)))
- (goto-char (point-min))
- (when
- (save-window-excursion
- (delete-other-windows)
- (let ((buffer (get-buffer-create (generate-new-buffer-name
- "*Warning*"))))
- (unwind-protect
- (with-current-buffer buffer
- (insert (substitute-command-keys
- mailcap-maybe-eval-warning))
- (goto-char (point-min))
- (display-buffer buffer)
- (yes-or-no-p "This is potentially dangerous emacs-lisp code, evaluate it? "))
- (kill-buffer buffer))))
- (eval-buffer (current-buffer)))
- (when (buffer-live-p lisp-buffer)
- (with-current-buffer lisp-buffer
- (emacs-lisp-mode)))))
-
-
-;;;
-;;; The mailcap parser
-;;;
-
-(defun mailcap-replace-regexp (regexp to-string)
- ;; Quiet replace-regexp.
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (replace-match to-string t nil)))
-
-(defvar mailcap-parsed-p nil)
-
-(defun mailcap-parse-mailcaps (&optional path force)
- "Parse out all the mailcaps specified in a path string PATH.
-Components of PATH are separated by the `path-separator' character
-appropriate for this system. If FORCE, re-parse even if already
-parsed. If PATH is omitted, use the value of environment variable
-MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus
-/usr/local/etc/mailcap."
- (interactive (list nil t))
- (when (or (not mailcap-parsed-p)
- force)
- (cond
- (path nil)
- ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
- ((memq system-type mailcap-poor-system-types)
- (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap")))
- (t (setq path
- ;; This is per RFC 1524, specifically
- ;; with /usr before /usr/local.
- '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap"
- "/usr/local/etc/mailcap"))))
- (let ((fnames (reverse
- (if (stringp path)
- (split-string path path-separator t)
- path)))
- fname)
- (while fnames
- (setq fname (car fnames))
- (if (and (file-readable-p fname)
- (file-regular-p fname))
- (mailcap-parse-mailcap fname))
- (setq fnames (cdr fnames))))
- (setq mailcap-parsed-p t)))
-
-(defun mailcap-parse-mailcap (fname)
- "Parse out the mailcap file specified by FNAME."
- (let (major ; The major mime type (image/audio/etc)
- minor ; The minor mime type (gif, basic, etc)
- save-pos ; Misc saved positions used in parsing
- viewer ; How to view this mime type
- info ; Misc info about this mime type
- )
- (with-temp-buffer
- (insert-file-contents fname)
- (set-syntax-table mailcap-parse-args-syntax-table)
- (mailcap-replace-regexp "#.*" "") ; Remove all comments
- (mailcap-replace-regexp "\\\\[ \t]*\n" " ") ; And collapse spaces
- (mailcap-replace-regexp "\n+" "\n") ; And blank lines
- (goto-char (point-max))
- (skip-chars-backward " \t\n")
- (delete-region (point) (point-max))
- (while (not (bobp))
- (skip-chars-backward " \t\n")
- (beginning-of-line)
- (setq save-pos (point)
- info nil)
- (skip-chars-forward "^/; \t\n")
- (downcase-region save-pos (point))
- (setq major (buffer-substring save-pos (point)))
- (skip-chars-forward " \t")
- (setq minor "")
- (when (eq (char-after) ?/)
- (forward-char)
- (skip-chars-forward " \t")
- (setq save-pos (point))
- (skip-chars-forward "^; \t\n")
- (downcase-region save-pos (point))
- (setq minor
- (cond
- ((eq ?* (or (char-after save-pos) 0)) ".*")
- ((= (point) save-pos) ".*")
- (t (regexp-quote (buffer-substring save-pos (point)))))))
- (skip-chars-forward " \t")
- ;;; Got the major/minor chunks, now for the viewers/etc
- ;;; The first item _must_ be a viewer, according to the
- ;;; RFC for mailcap files (#1524)
- (setq viewer "")
- (when (eq (char-after) ?\;)
- (forward-char)
- (skip-chars-forward " \t")
- (setq save-pos (point))
- (skip-chars-forward "^;\n")
- ;; skip \;
- (while (eq (char-before) ?\\)
- (backward-delete-char 1)
- (forward-char)
- (skip-chars-forward "^;\n"))
- (if (eq (or (char-after save-pos) 0) ?')
- (setq viewer (progn
- (narrow-to-region (1+ save-pos) (point))
- (goto-char (point-min))
- (prog1
- (read (current-buffer))
- (goto-char (point-max))
- (widen))))
- (setq viewer (buffer-substring save-pos (point)))))
- (setq save-pos (point))
- (end-of-line)
- (unless (equal viewer "")
- (setq info (nconc (list (cons 'viewer viewer)
- (cons 'type (concat major "/"
- (if (string= minor ".*")
- "*" minor))))
- (mailcap-parse-mailcap-extras save-pos (point))))
- (mailcap-mailcap-entry-passes-test info)
- (mailcap-add-mailcap-entry major minor info))
- (beginning-of-line)))))
-
-(defun mailcap-parse-mailcap-extras (st nd)
- "Grab all the extra stuff from a mailcap entry."
- (let (
- name ; From name=
- value ; its value
- results ; Assoc list of results
- name-pos ; Start of XXXX= position
- val-pos ; Start of value position
- done ; Found end of \'d ;s?
- )
- (save-restriction
- (narrow-to-region st nd)
- (goto-char (point-min))
- (skip-chars-forward " \n\t;")
- (while (not (eobp))
- (setq done nil)
- (setq name-pos (point))
- (skip-chars-forward "^ \n\t=;")
- (downcase-region name-pos (point))
- (setq name (buffer-substring name-pos (point)))
- (skip-chars-forward " \t\n")
- (if (not (eq (char-after (point)) ?=)) ; There is no value
- (setq value t)
- (skip-chars-forward " \t\n=")
- (setq val-pos (point))
- (if (memq (char-after val-pos) '(?\" ?'))
- (progn
- (setq val-pos (1+ val-pos))
- (condition-case nil
- (progn
- (forward-sexp 1)
- (backward-char 1))
- (error (goto-char (point-max)))))
- (while (not done)
- (skip-chars-forward "^;")
- (if (eq (char-after (1- (point))) ?\\ )
- (progn
- (subst-char-in-region (1- (point)) (point) ?\\ ? )
- (skip-chars-forward ";"))
- (setq done t))))
- (setq value (buffer-substring val-pos (point))))
- ;; `test' as symbol, others like "copiousoutput" and "needsx11" as
- ;; strings
- (setq results (cons (cons (if (string-equal name "test")
- 'test
- name)
- value) results))
- (skip-chars-forward " \";\n\t"))
- results)))
-
-(defun mailcap-mailcap-entry-passes-test (info)
- "Replace the test clause of INFO itself with a boolean for some cases.
-This function supports only `test -n $DISPLAY' and `test -z $DISPLAY',
-replaces them with t or nil. As for others or if INFO has a interactive
-spec (needsterm, needsterminal, or needsx11) but DISPLAY is not set,
-the test clause will be unchanged."
- (let ((test (assq 'test info)) ; The test clause
- status)
- (setq status (and test (split-string (cdr test) " ")))
- (if (and (or (assoc "needsterm" info)
- (assoc "needsterminal" info)
- (assoc "needsx11" info))
- (not (getenv "DISPLAY")))
- (setq status nil)
- (cond
- ((and (equal (nth 0 status) "test")
- (equal (nth 1 status) "-n")
- (or (equal (nth 2 status) "$DISPLAY")
- (equal (nth 2 status) "\"$DISPLAY\"")))
- (setq status (if (getenv "DISPLAY") t nil)))
- ((and (equal (nth 0 status) "test")
- (equal (nth 1 status) "-z")
- (or (equal (nth 2 status) "$DISPLAY")
- (equal (nth 2 status) "\"$DISPLAY\"")))
- (setq status (if (getenv "DISPLAY") nil t)))
- (test nil)
- (t nil)))
- (and test (listp test) (setcdr test status))))
-
-;;;
-;;; The action routines.
-;;;
-
-(defun mailcap-possible-viewers (major minor)
- "Return a list of possible viewers from MAJOR for minor type MINOR."
- (let ((exact '())
- (wildcard '()))
- (while major
- (cond
- ((equal (car (car major)) minor)
- (setq exact (cons (cdr (car major)) exact)))
- ((and minor (string-match (concat "^" (car (car major)) "$") minor))
- (setq wildcard (cons (cdr (car major)) wildcard))))
- (setq major (cdr major)))
- (nconc exact wildcard)))
-
-(defun mailcap-unescape-mime-test (test type-info)
- (let (save-pos save-chr subst)
- (cond
- ((symbolp test) test)
- ((and (listp test) (symbolp (car test))) test)
- ((or (stringp test)
- (and (listp test) (stringp (car test))
- (setq test (mapconcat 'identity test " "))))
- (with-temp-buffer
- (insert test)
- (goto-char (point-min))
- (while (not (eobp))
- (skip-chars-forward "^%")
- (if (/= (- (point)
- (progn (skip-chars-backward "\\\\")
- (point)))
- 0) ; It is an escaped %
- (progn
- (delete-char 1)
- (skip-chars-forward "%."))
- (setq save-pos (point))
- (skip-chars-forward "%")
- (setq save-chr (char-after (point)))
- ;; Escapes:
- ;; %s: name of a file for the body data
- ;; %t: content-type
- ;; %{<parameter name}: value of parameter in mailcap entry
- ;; %n: number of sub-parts for multipart content-type
- ;; %F: a set of content-type/filename pairs for multiparts
- (cond
- ((null save-chr) nil)
- ((= save-chr ?t)
- (delete-region save-pos (progn (forward-char 1) (point)))
- (insert (or (cdr (assq 'type type-info)) "\"\"")))
- ((memq save-chr '(?M ?n ?F))
- (delete-region save-pos (progn (forward-char 1) (point)))
- (insert "\"\""))
- ((= save-chr ?{)
- (forward-char 1)
- (skip-chars-forward "^}")
- (downcase-region (+ 2 save-pos) (point))
- (setq subst (buffer-substring (+ 2 save-pos) (point)))
- (delete-region save-pos (1+ (point)))
- (insert (or (cdr (assoc subst type-info)) "\"\"")))
- (t nil))))
- (buffer-string)))
- (t (error "Bad value to mailcap-unescape-mime-test: %s" test)))))
-
-(defvar mailcap-viewer-test-cache nil)
-
-(defun mailcap-viewer-passes-test (viewer-info type-info)
- "Return non-nil if viewer specified by VIEWER-INFO passes its test clause.
-Also return non-nil if it has no test clause. TYPE-INFO is an argument
-to supply to the test."
- (let* ((test-info (assq 'test viewer-info))
- (test (cdr test-info))
- (otest test)
- (viewer (cdr (assq 'viewer viewer-info)))
- (default-directory (expand-file-name "~/"))
- status parsed-test cache result)
- (cond ((not (or (stringp viewer) (fboundp viewer)))
- nil) ; Non-existent Lisp function
- ((setq cache (assoc test mailcap-viewer-test-cache))
- (cadr cache))
- ((not test-info) t) ; No test clause
- (t
- (setq
- result
- (cond
- ((not test) nil) ; Already failed test
- ((eq test t) t) ; Already passed test
- ((functionp test) ; Lisp function as test
- (funcall test type-info))
- ((and (symbolp test) ; Lisp variable as test
- (boundp test))
- (symbol-value test))
- ((and (listp test) ; List to be eval'd
- (symbolp (car test)))
- (eval test))
- (t
- (setq test (mailcap-unescape-mime-test test type-info)
- test (list shell-file-name nil nil nil
- shell-command-switch test)
- status (apply 'call-process test))
- (eq 0 status))))
- (push (list otest result) mailcap-viewer-test-cache)
- result))))
-
-(defun mailcap-add-mailcap-entry (major minor info)
- (let ((old-major (assoc major mailcap-mime-data)))
- (if (null old-major) ; New major area
- (setq mailcap-mime-data
- (cons (cons major (list (cons minor info)))
- mailcap-mime-data))
- (let ((cur-minor (assoc minor old-major)))
- (cond
- ((or (null cur-minor) ; New minor area, or
- (assq 'test info)) ; Has a test, insert at beginning
- (setcdr old-major (cons (cons minor info) (cdr old-major))))
- ((and (not (assq 'test info)) ; No test info, replace completely
- (not (assq 'test cur-minor))
- (equal (assq 'viewer info) ; Keep alternative viewer
- (assq 'viewer cur-minor)))
- (setcdr cur-minor info))
- (t
- (setcdr old-major (cons (cons minor info) (cdr old-major))))))
- )))
-
-(defun mailcap-add (type viewer &optional test)
- "Add VIEWER as a handler for TYPE.
-If TEST is not given, it defaults to t."
- (let ((tl (split-string type "/")))
- (when (or (not (car tl))
- (not (cadr tl)))
- (error "%s is not a valid MIME type" type))
- (mailcap-add-mailcap-entry
- (car tl) (cadr tl)
- `((viewer . ,viewer)
- (test . ,(if test test t))
- (type . ,type)))))
-
-;;;
-;;; The main whabbo
-;;;
-
-(defun mailcap-viewer-lessp (x y)
- "Return t if viewer X is more desirable than viewer Y."
- (let ((x-wild (string-match "[*?]" (or (cdr-safe (assq 'type x)) "")))
- (y-wild (string-match "[*?]" (or (cdr-safe (assq 'type y)) "")))
- (x-lisp (not (stringp (or (cdr-safe (assq 'viewer x)) ""))))
- (y-lisp (not (stringp (or (cdr-safe (assq 'viewer y)) "")))))
- (cond
- ((and x-wild (not y-wild))
- nil)
- ((and (not x-wild) y-wild)
- t)
- ((and (not y-lisp) x-lisp)
- t)
- (t nil))))
-
-(defun mailcap-mime-info (string &optional request no-decode)
- "Get the MIME viewer command for STRING, return nil if none found.
-Expects a complete content-type header line as its argument.
-
-Second argument REQUEST specifies what information to return. If it is
-nil or the empty string, the viewer (second field of the mailcap
-entry) will be returned. If it is a string, then the mailcap field
-corresponding to that string will be returned (print, description,
-whatever). If a number, then all the information for this specific
-viewer is returned. If `all', then all possible viewers for
-this type is returned.
-
-If NO-DECODE is non-nil, don't decode STRING."
- ;; NO-DECODE avoids calling `mail-header-parse-content-type' from
- ;; `mail-parse.el'
- (let (
- major ; Major encoding (text, etc)
- minor ; Minor encoding (html, etc)
- info ; Other info
- save-pos ; Misc. position during parse
- major-info ; (assoc major mailcap-mime-data)
- minor-info ; (assoc minor major-info)
- test ; current test proc.
- viewers ; Possible viewers
- passed ; Viewers that passed the test
- viewer ; The one and only viewer
- ctl)
- (save-excursion
- (setq ctl
- (if no-decode
- (list (or string "text/plain"))
- (mail-header-parse-content-type (or string "text/plain"))))
- (setq major (split-string (car ctl) "/"))
- (setq minor (cadr major)
- major (car major))
- (when (setq major-info (cdr (assoc major mailcap-mime-data)))
- (when (setq viewers (mailcap-possible-viewers major-info minor))
- (setq info (mapcar (lambda (a) (cons (symbol-name (car a))
- (cdr a)))
- (cdr ctl)))
- (while viewers
- (if (mailcap-viewer-passes-test (car viewers) info)
- (setq passed (cons (car viewers) passed)))
- (setq viewers (cdr viewers)))
- (setq passed (sort passed 'mailcap-viewer-lessp))
- (setq viewer (car passed))))
- (when (and (stringp (cdr (assq 'viewer viewer)))
- passed)
- (setq viewer (car passed)))
- (cond
- ((and (null viewer) (not (equal major "default")) request)
- (mailcap-mime-info "default" request no-decode))
- ((or (null request) (equal request ""))
- (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info))
- ((stringp request)
- (mailcap-unescape-mime-test
- (cdr-safe (assoc request viewer)) info))
- ((eq request 'all)
- passed)
- (t
- ;; MUST make a copy *sigh*, else we modify mailcap-mime-data
- (setq viewer (copy-sequence viewer))
- (let ((view (assq 'viewer viewer))
- (test (assq 'test viewer)))
- (if view (setcdr view (mailcap-unescape-mime-test (cdr view) info)))
- (if test (setcdr test (mailcap-unescape-mime-test (cdr test) info))))
- viewer)))))
-
-;;;
-;;; Experimental MIME-types parsing
-;;;
-
-(defvar mailcap-mime-extensions
- '(("" . "text/plain")
- (".1" . "text/plain") ;; Manual pages
- (".3" . "text/plain")
- (".8" . "text/plain")
- (".abs" . "audio/x-mpeg")
- (".aif" . "audio/aiff")
- (".aifc" . "audio/aiff")
- (".aiff" . "audio/aiff")
- (".ano" . "application/x-annotator")
- (".au" . "audio/ulaw")
- (".avi" . "video/x-msvideo")
- (".bcpio" . "application/x-bcpio")
- (".bin" . "application/octet-stream")
- (".cdf" . "application/x-netcdr")
- (".cpio" . "application/x-cpio")
- (".csh" . "application/x-csh")
- (".css" . "text/css")
- (".dvi" . "application/x-dvi")
- (".diff" . "text/x-patch")
- (".dpatch". "test/x-patch")
- (".el" . "application/emacs-lisp")
- (".eps" . "application/postscript")
- (".etx" . "text/x-setext")
- (".exe" . "application/octet-stream")
- (".fax" . "image/x-fax")
- (".gif" . "image/gif")
- (".hdf" . "application/x-hdf")
- (".hqx" . "application/mac-binhex40")
- (".htm" . "text/html")
- (".html" . "text/html")
- (".icon" . "image/x-icon")
- (".ief" . "image/ief")
- (".jpg" . "image/jpeg")
- (".macp" . "image/x-macpaint")
- (".man" . "application/x-troff-man")
- (".me" . "application/x-troff-me")
- (".mif" . "application/mif")
- (".mov" . "video/quicktime")
- (".movie" . "video/x-sgi-movie")
- (".mp2" . "audio/x-mpeg")
- (".mp3" . "audio/x-mpeg")
- (".mp2a" . "audio/x-mpeg2")
- (".mpa" . "audio/x-mpeg")
- (".mpa2" . "audio/x-mpeg2")
- (".mpe" . "video/mpeg")
- (".mpeg" . "video/mpeg")
- (".mpega" . "audio/x-mpeg")
- (".mpegv" . "video/mpeg")
- (".mpg" . "video/mpeg")
- (".mpv" . "video/mpeg")
- (".ms" . "application/x-troff-ms")
- (".nc" . "application/x-netcdf")
- (".nc" . "application/x-netcdf")
- (".oda" . "application/oda")
- (".patch" . "text/x-patch")
- (".pbm" . "image/x-portable-bitmap")
- (".pdf" . "application/pdf")
- (".pgm" . "image/portable-graymap")
- (".pict" . "image/pict")
- (".png" . "image/png")
- (".pnm" . "image/x-portable-anymap")
- (".pod" . "text/plain")
- (".ppm" . "image/portable-pixmap")
- (".ps" . "application/postscript")
- (".qt" . "video/quicktime")
- (".ras" . "image/x-raster")
- (".rgb" . "image/x-rgb")
- (".rtf" . "application/rtf")
- (".rtx" . "text/richtext")
- (".sh" . "application/x-sh")
- (".sit" . "application/x-stuffit")
- (".siv" . "application/sieve")
- (".snd" . "audio/basic")
- (".soa" . "text/dns")
- (".src" . "application/x-wais-source")
- (".tar" . "archive/tar")
- (".tcl" . "application/x-tcl")
- (".tex" . "application/x-tex")
- (".texi" . "application/texinfo")
- (".tga" . "image/x-targa")
- (".tif" . "image/tiff")
- (".tiff" . "image/tiff")
- (".tr" . "application/x-troff")
- (".troff" . "application/x-troff")
- (".tsv" . "text/tab-separated-values")
- (".txt" . "text/plain")
- (".vbs" . "video/mpeg")
- (".vox" . "audio/basic")
- (".vrml" . "x-world/x-vrml")
- (".wav" . "audio/x-wav")
- (".xls" . "application/vnd.ms-excel")
- (".wrl" . "x-world/x-vrml")
- (".xbm" . "image/xbm")
- (".xpm" . "image/xpm")
- (".xwd" . "image/windowdump")
- (".zip" . "application/zip")
- (".ai" . "application/postscript")
- (".jpe" . "image/jpeg")
- (".jpeg" . "image/jpeg")
- (".org" . "text/x-org"))
- "An alist of file extensions and corresponding MIME content-types.
-This exists for you to customize the information in Lisp. It is
-merged with values from mailcap files by `mailcap-parse-mimetypes'.")
-
-(defvar mailcap-mimetypes-parsed-p nil)
-
-(defun mailcap-parse-mimetypes (&optional path force)
- "Parse out all the mimetypes specified in a Unix-style path string PATH.
-Components of PATH are separated by the `path-separator' character
-appropriate for this system. If PATH is omitted, use the value of
-environment variable MIMETYPES if set; otherwise use a default path.
-If FORCE, re-parse even if already parsed."
- (interactive (list nil t))
- (when (or (not mailcap-mimetypes-parsed-p)
- force)
- (cond
- (path nil)
- ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
- ((memq system-type mailcap-poor-system-types)
- (setq path '("~/mime.typ" "~/etc/mime.typ")))
- (t (setq path
- ;; mime.types seems to be the normal name, definitely so
- ;; on current GNUish systems. The search order follows
- ;; that for mailcap.
- '("~/.mime.types"
- "/etc/mime.types"
- "/usr/etc/mime.types"
- "/usr/local/etc/mime.types"
- "/usr/local/www/conf/mime.types"
- "~/.mime-types"
- "/etc/mime-types"
- "/usr/etc/mime-types"
- "/usr/local/etc/mime-types"
- "/usr/local/www/conf/mime-types"))))
- (let ((fnames (reverse (if (stringp path)
- (split-string path path-separator t)
- path)))
- fname)
- (while fnames
- (setq fname (car fnames))
- (if (and (file-readable-p fname))
- (mailcap-parse-mimetype-file fname))
- (setq fnames (cdr fnames))))
- (setq mailcap-mimetypes-parsed-p t)))
-
-(defun mailcap-parse-mimetype-file (fname)
- "Parse out a mime-types file FNAME."
- (let (type ; The MIME type for this line
- extns ; The extensions for this line
- save-pos ; Misc. saved buffer positions
- )
- (with-temp-buffer
- (insert-file-contents fname)
- (mailcap-replace-regexp "#.*" "")
- (mailcap-replace-regexp "\n+" "\n")
- (mailcap-replace-regexp "[ \t]+$" "")
- (goto-char (point-max))
- (skip-chars-backward " \t\n")
- (delete-region (point) (point-max))
- (goto-char (point-min))
- (while (not (eobp))
- (skip-chars-forward " \t\n")
- (setq save-pos (point))
- (skip-chars-forward "^ \t\n")
- (downcase-region save-pos (point))
- (setq type (buffer-substring save-pos (point)))
- (while (not (eolp))
- (skip-chars-forward " \t")
- (setq save-pos (point))
- (skip-chars-forward "^ \t\n")
- (setq extns (cons (buffer-substring save-pos (point)) extns)))
- (while extns
- (setq mailcap-mime-extensions
- (cons
- (cons (if (= (string-to-char (car extns)) ?.)
- (car extns)
- (concat "." (car extns))) type)
- mailcap-mime-extensions)
- extns (cdr extns)))))))
-
-(defun mailcap-extension-to-mime (extn)
- "Return the MIME content type of the file extensions EXTN."
- (mailcap-parse-mimetypes)
- (if (and (stringp extn)
- (not (eq (string-to-char extn) ?.)))
- (setq extn (concat "." extn)))
- (cdr (assoc (downcase extn) mailcap-mime-extensions)))
-
-;; Unused?
-(defalias 'mailcap-command-p 'executable-find)
-
-(defun mailcap-mime-types ()
- "Return a list of MIME media types."
- (mailcap-parse-mimetypes)
- (delete-dups
- (nconc
- (mapcar 'cdr mailcap-mime-extensions)
- (apply
- 'nconc
- (mapcar
- (lambda (l)
- (delq nil
- (mapcar
- (lambda (m)
- (let ((type (cdr (assq 'type (cdr m)))))
- (if (equal (cadr (split-string type "/"))
- "*")
- nil
- type)))
- (cdr l))))
- mailcap-mime-data)))))
-
-;;;
-;;; Useful supplementary functions
-;;;
-
-(defun mailcap-file-default-commands (files)
- "Return a list of default commands for FILES."
- (mailcap-parse-mailcaps)
- (mailcap-parse-mimetypes)
- (let* ((all-mime-type
- ;; All unique MIME types from file extensions
- (delete-dups
- (mapcar (lambda (file)
- (mailcap-extension-to-mime
- (file-name-extension file t)))
- files)))
- (all-mime-info
- ;; All MIME info lists
- (delete-dups
- (mapcar (lambda (mime-type)
- (mailcap-mime-info mime-type 'all))
- all-mime-type)))
- (common-mime-info
- ;; Intersection of mime-infos from different mime-types;
- ;; or just the first MIME info for a single MIME type
- (if (cdr all-mime-info)
- (delq nil (mapcar (lambda (mi1)
- (unless (memq nil (mapcar
- (lambda (mi2)
- (member mi1 mi2))
- (cdr all-mime-info)))
- mi1))
- (car all-mime-info)))
- (car all-mime-info)))
- (commands
- ;; Command strings from `viewer' field of the MIME info
- (delete-dups
- (delq nil (mapcar
- (lambda (mime-info)
- (let ((command (cdr (assoc 'viewer mime-info))))
- (if (stringp command)
- (replace-regexp-in-string
- ;; Replace mailcap's `%s' placeholder
- ;; with dired's `?' placeholder
- "%s" "?"
- (replace-regexp-in-string
- ;; Remove the final filename placeholder
- "[ \t\n]*\\('\\)?%s\\1?[ \t\n]*\\'" ""
- command nil t)
- nil t))))
- common-mime-info)))))
- commands))
-
-(defun mailcap-view-mime (type)
- "View the data in the current buffer that has MIME type TYPE.
-`mailcap-mime-data' determines the method to use."
- (let ((method (mailcap-mime-info type)))
- (if (stringp method)
- (shell-command-on-region (point-min) (point-max)
- ;; Use stdin as the "%s".
- (format method "-")
- (current-buffer)
- t)
- (funcall method))))
-
-(provide 'mailcap)
-
-;;; mailcap.el ends here
+++ /dev/null
-;;; plstore.el --- secure plist store -*- lexical-binding: t -*-
-;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
-
-;; Author: Daiki Ueno <ueno@unixuser.org>
-;; Keywords: PGP, GnuPG
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary
-
-;; Plist based data store providing search and partial encryption.
-;;
-;; Creating:
-;;
-;; ;; Open a new store associated with ~/.emacs.d/auth.plist.
-;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist")))
-;; ;; Both `:host' and `:port' are public property.
-;; (plstore-put store "foo" '(:host "foo.example.org" :port 80) nil)
-;; ;; No encryption will be needed.
-;; (plstore-save store)
-;;
-;; ;; `:user' is marked as secret.
-;; (plstore-put store "bar" '(:host "bar.example.org") '(:user "test"))
-;; ;; `:password' is marked as secret.
-;; (plstore-put store "baz" '(:host "baz.example.org") '(:password "test"))
-;; ;; Those secret properties are encrypted together.
-;; (plstore-save store)
-;;
-;; ;; Kill the buffer visiting ~/.emacs.d/auth.plist.
-;; (plstore-close store)
-;;
-;; Searching:
-;;
-;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist")))
-;;
-;; ;; As the entry "foo" associated with "foo.example.org" has no
-;; ;; secret properties, no need to decryption.
-;; (plstore-find store '(:host ("foo.example.org")))
-;;
-;; ;; As the entry "bar" associated with "bar.example.org" has a
-;; ;; secret property `:user', Emacs tries to decrypt the secret (and
-;; ;; thus you will need to input passphrase).
-;; (plstore-find store '(:host ("bar.example.org")))
-;;
-;; ;; While the entry "baz" associated with "baz.example.org" has also
-;; ;; a secret property `:password', it is encrypted together with
-;; ;; `:user' of "bar", so no need to decrypt the secret.
-;; (plstore-find store '(:host ("bar.example.org")))
-;;
-;; (plstore-close store)
-;;
-;; Editing:
-;;
-;; This file also provides `plstore-mode', a major mode for editing
-;; the PLSTORE format file. Visit a non-existing file and put the
-;; following line:
-;;
-;; (("foo" :host "foo.example.org" :secret-user "user"))
-;;
-;; where the prefixing `:secret-' means the property (without
-;; `:secret-' prefix) is marked as secret. Thus, when you save the
-;; buffer, the `:secret-user' property is encrypted as `:user'.
-;;
-;; You can toggle the view between encrypted form and the decrypted
-;; form with C-c C-c.
-
-;;; Code:
-
-(require 'epg)
-
-(defgroup plstore nil
- "Searchable, partially encrypted, persistent plist store"
- :version "24.1"
- :group 'files)
-
-(defcustom plstore-select-keys 'silent
- "Control whether or not to pop up the key selection dialog.
-
-If t, always asks user to select recipients.
-If nil, query user only when a file's default recipients are not
-known (i.e. `plstore-encrypt-to' is not locally set in the buffer
-visiting a plstore file).
-If neither t nor nil, doesn't ask user."
- :type '(choice (const :tag "Ask always" t)
- (const :tag "Ask when recipients are not set" nil)
- (const :tag "Don't ask" silent))
- :group 'plstore)
-
-(defvar plstore-encrypt-to nil
- "*Recipient(s) used for encrypting secret entries.
-May either be a string or a list of strings. If it is nil,
-symmetric encryption will be used.")
-
-(put 'plstore-encrypt-to 'safe-local-variable
- (lambda (val)
- (or (stringp val)
- (and (listp val)
- (catch 'safe
- (mapc (lambda (elt)
- (unless (stringp elt)
- (throw 'safe nil)))
- val)
- t)))))
-
-(put 'plstore-encrypt-to 'permanent-local t)
-
-(defvar plstore-encoded nil)
-
-(put 'plstore-encoded 'permanent-local t)
-
-(defvar plstore-cache-passphrase-for-symmetric-encryption nil)
-(defvar plstore-passphrase-alist nil)
-
-(defun plstore-passphrase-callback-function (_context _key-id plstore)
- (if plstore-cache-passphrase-for-symmetric-encryption
- (let* ((file (file-truename (plstore-get-file plstore)))
- (entry (assoc file plstore-passphrase-alist))
- passphrase)
- (or (copy-sequence (cdr entry))
- (progn
- (unless entry
- (setq entry (list file)
- plstore-passphrase-alist
- (cons entry
- plstore-passphrase-alist)))
- (setq passphrase
- (read-passwd (format "Passphrase for PLSTORE %s: "
- (plstore--get-buffer plstore))))
- (setcdr entry (copy-sequence passphrase))
- passphrase)))
- (read-passwd (format "Passphrase for PLSTORE %s: "
- (plstore--get-buffer plstore)))))
-
-(defun plstore-progress-callback-function (_context _what _char current total
- handback)
- (if (= current total)
- (message "%s...done" handback)
- (message "%s...%d%%" handback
- (if (> total 0) (floor (* (/ current (float total)) 100)) 0))))
-
-(defun plstore--get-buffer (arg)
- (aref arg 0))
-
-(defun plstore--get-alist (arg)
- (aref arg 1))
-
-(defun plstore--get-encrypted-data (arg)
- (aref arg 2))
-
-(defun plstore--get-secret-alist (arg)
- (aref arg 3))
-
-(defun plstore--get-merged-alist (arg)
- (aref arg 4))
-
-(defun plstore--set-buffer (arg buffer)
- (aset arg 0 buffer))
-
-(defun plstore--set-alist (arg plist)
- (aset arg 1 plist))
-
-(defun plstore--set-encrypted-data (arg encrypted-data)
- (aset arg 2 encrypted-data))
-
-(defun plstore--set-secret-alist (arg secret-alist)
- (aset arg 3 secret-alist))
-
-(defun plstore--set-merged-alist (arg merged-alist)
- (aset arg 4 merged-alist))
-
-(defun plstore-get-file (arg)
- (buffer-file-name (plstore--get-buffer arg)))
-
-(defun plstore--make (&optional buffer alist encrypted-data secret-alist
- merged-alist)
- (vector buffer alist encrypted-data secret-alist merged-alist))
-
-(defun plstore--init-from-buffer (plstore)
- (goto-char (point-min))
- (when (looking-at ";;; public entries")
- (forward-line)
- (plstore--set-alist plstore (read (point-marker)))
- (forward-sexp)
- (forward-char)
- (when (looking-at ";;; secret entries")
- (forward-line)
- (plstore--set-encrypted-data plstore (read (point-marker))))
- (plstore--merge-secret plstore)))
-
-;;;###autoload
-(defun plstore-open (file)
- "Create a plstore instance associated with FILE."
- (let* ((filename (file-truename file))
- (buffer (or (find-buffer-visiting filename)
- (generate-new-buffer (format " plstore %s" filename))))
- (store (plstore--make buffer)))
- (with-current-buffer buffer
- (erase-buffer)
- (condition-case nil
- (insert-file-contents-literally file)
- (error))
- (setq buffer-file-name (file-truename file))
- (set-buffer-modified-p nil)
- (plstore--init-from-buffer store)
- store)))
-
-(defun plstore-revert (plstore)
- "Replace current data in PLSTORE with the file on disk."
- (with-current-buffer (plstore--get-buffer plstore)
- (revert-buffer t t)
- (plstore--init-from-buffer plstore)))
-
-(defun plstore-close (plstore)
- "Destroy a plstore instance PLSTORE."
- (kill-buffer (plstore--get-buffer plstore)))
-
-(defun plstore--merge-secret (plstore)
- (let ((alist (plstore--get-secret-alist plstore))
- modified-alist
- modified-plist
- modified-entry
- entry
- plist
- placeholder)
- (plstore--set-merged-alist
- plstore
- (copy-tree (plstore--get-alist plstore)))
- (setq modified-alist (plstore--get-merged-alist plstore))
- (while alist
- (setq entry (car alist)
- alist (cdr alist)
- plist (cdr entry)
- modified-entry (assoc (car entry) modified-alist)
- modified-plist (cdr modified-entry))
- (while plist
- (setq placeholder
- (plist-member
- modified-plist
- (intern (concat ":secret-"
- (substring (symbol-name (car plist)) 1)))))
- (if placeholder
- (setcar placeholder (car plist)))
- (setq modified-plist
- (plist-put modified-plist (car plist) (car (cdr plist))))
- (setq plist (nthcdr 2 plist)))
- (setcdr modified-entry modified-plist))))
-
-(defun plstore--decrypt (plstore)
- (if (plstore--get-encrypted-data plstore)
- (let ((context (epg-make-context 'OpenPGP))
- plain)
- (epg-context-set-passphrase-callback
- context
- (cons #'plstore-passphrase-callback-function
- plstore))
- (epg-context-set-progress-callback
- context
- (cons #'plstore-progress-callback-function
- (format "Decrypting %s" (plstore-get-file plstore))))
- (condition-case error
- (setq plain
- (epg-decrypt-string context
- (plstore--get-encrypted-data plstore)))
- (error
- (let ((entry (assoc (plstore-get-file plstore)
- plstore-passphrase-alist)))
- (if entry
- (setcdr entry nil)))
- (signal (car error) (cdr error))))
- (plstore--set-secret-alist plstore (car (read-from-string plain)))
- (plstore--merge-secret plstore)
- (plstore--set-encrypted-data plstore nil))))
-
-(defun plstore--match (entry keys skip-if-secret-found)
- (let ((result t) key-name key-value prop-value secret-name)
- (while keys
- (setq key-name (car keys)
- key-value (car (cdr keys))
- prop-value (plist-get (cdr entry) key-name))
- (unless (member prop-value key-value)
- (if skip-if-secret-found
- (progn
- (setq secret-name
- (intern (concat ":secret-"
- (substring (symbol-name key-name) 1))))
- (if (plist-member (cdr entry) secret-name)
- (setq result 'secret)
- (setq result nil
- keys nil)))
- (setq result nil
- keys nil)))
- (setq keys (nthcdr 2 keys)))
- result))
-
-(defun plstore-find (plstore keys)
- "Perform search on PLSTORE with KEYS.
-KEYS is a plist."
- (let (entries alist entry match decrypt plist)
- ;; First, go through the merged plist alist and collect entries
- ;; matched with keys.
- (setq alist (plstore--get-merged-alist plstore))
- (while alist
- (setq entry (car alist)
- alist (cdr alist)
- match (plstore--match entry keys t))
- (if (eq match 'secret)
- (setq decrypt t)
- (when match
- (setq plist (cdr entry))
- (while plist
- (if (string-match "\\`:secret-" (symbol-name (car plist)))
- (setq decrypt t
- plist nil))
- (setq plist (nthcdr 2 plist)))
- (setq entries (cons entry entries)))))
- ;; Second, decrypt the encrypted plist and try again.
- (when decrypt
- (setq entries nil)
- (plstore--decrypt plstore)
- (setq alist (plstore--get-merged-alist plstore))
- (while alist
- (setq entry (car alist)
- alist (cdr alist)
- match (plstore--match entry keys nil))
- (if match
- (setq entries (cons entry entries)))))
- (nreverse entries)))
-
-(defun plstore-get (plstore name)
- "Get an entry with NAME in PLSTORE."
- (let ((entry (assoc name (plstore--get-merged-alist plstore)))
- plist)
- (setq plist (cdr entry))
- (while plist
- (if (string-match "\\`:secret-" (symbol-name (car plist)))
- (progn
- (plstore--decrypt plstore)
- (setq entry (assoc name (plstore--get-merged-alist plstore))
- plist nil))
- (setq plist (nthcdr 2 plist))))
- entry))
-
-(defun plstore-put (plstore name keys secret-keys)
- "Put an entry with NAME in PLSTORE.
-KEYS is a plist containing non-secret data.
-SECRET-KEYS is a plist containing secret data."
- (let (entry
- plist
- secret-plist
- symbol)
- (if secret-keys
- (plstore--decrypt plstore))
- (while secret-keys
- (setq symbol
- (intern (concat ":secret-"
- (substring (symbol-name (car secret-keys)) 1))))
- (setq plist (plist-put plist symbol t)
- secret-plist (plist-put secret-plist
- (car secret-keys) (car (cdr secret-keys)))
- secret-keys (nthcdr 2 secret-keys)))
- (while keys
- (setq symbol
- (intern (concat ":secret-"
- (substring (symbol-name (car keys)) 1))))
- (setq plist (plist-put plist (car keys) (car (cdr keys)))
- keys (nthcdr 2 keys)))
- (setq entry (assoc name (plstore--get-alist plstore)))
- (if entry
- (setcdr entry plist)
- (plstore--set-alist
- plstore
- (cons (cons name plist) (plstore--get-alist plstore))))
- (when secret-plist
- (setq entry (assoc name (plstore--get-secret-alist plstore)))
- (if entry
- (setcdr entry secret-plist)
- (plstore--set-secret-alist
- plstore
- (cons (cons name secret-plist) (plstore--get-secret-alist plstore)))))
- (plstore--merge-secret plstore)))
-
-(defun plstore-delete (plstore name)
- "Delete an entry with NAME from PLSTORE."
- (let ((entry (assoc name (plstore--get-alist plstore))))
- (if entry
- (plstore--set-alist
- plstore
- (delq entry (plstore--get-alist plstore))))
- (setq entry (assoc name (plstore--get-secret-alist plstore)))
- (if entry
- (plstore--set-secret-alist
- plstore
- (delq entry (plstore--get-secret-alist plstore))))
- (setq entry (assoc name (plstore--get-merged-alist plstore)))
- (if entry
- (plstore--set-merged-alist
- plstore
- (delq entry (plstore--get-merged-alist plstore))))))
-
-(defvar pp-escape-newlines)
-(defun plstore--insert-buffer (plstore)
- (insert ";;; public entries -*- mode: plstore -*- \n"
- (pp-to-string (plstore--get-alist plstore)))
- (if (plstore--get-secret-alist plstore)
- (let ((context (epg-make-context 'OpenPGP))
- (pp-escape-newlines nil)
- (recipients
- (cond
- ((listp plstore-encrypt-to) plstore-encrypt-to)
- ((stringp plstore-encrypt-to) (list plstore-encrypt-to))))
- cipher)
- (setf (epg-context-armor context) t)
- (epg-context-set-passphrase-callback
- context
- (cons #'plstore-passphrase-callback-function
- plstore))
- (setq cipher (epg-encrypt-string
- context
- (pp-to-string
- (plstore--get-secret-alist plstore))
- (if (or (eq plstore-select-keys t)
- (and (null plstore-select-keys)
- (not (local-variable-p 'plstore-encrypt-to
- (current-buffer)))))
- (epa-select-keys
- context
- "Select recipients for encryption.
-If no one is selected, symmetric encryption will be performed. "
- recipients)
- (if plstore-encrypt-to
- (epg-list-keys context recipients)))))
- (goto-char (point-max))
- (insert ";;; secret entries\n" (pp-to-string cipher)))))
-
-(defun plstore-save (plstore)
- "Save the contents of PLSTORE associated with a FILE."
- (with-current-buffer (plstore--get-buffer plstore)
- (erase-buffer)
- (plstore--insert-buffer plstore)
- (save-buffer)))
-
-(defun plstore--encode (plstore)
- (plstore--decrypt plstore)
- (let ((merged-alist (plstore--get-merged-alist plstore)))
- (concat "("
- (mapconcat
- (lambda (entry)
- (setq entry (copy-sequence entry))
- (let ((merged-plist (cdr (assoc (car entry) merged-alist)))
- (plist (cdr entry)))
- (while plist
- (if (string-match "\\`:secret-" (symbol-name (car plist)))
- (setcar (cdr plist)
- (plist-get
- merged-plist
- (intern (concat ":"
- (substring (symbol-name
- (car plist))
- (match-end 0)))))))
- (setq plist (nthcdr 2 plist)))
- (prin1-to-string entry)))
- (plstore--get-alist plstore)
- "\n")
- ")")))
-
-(defun plstore--decode (string)
- (let* ((alist (car (read-from-string string)))
- (pointer alist)
- secret-alist
- plist
- entry)
- (while pointer
- (unless (stringp (car (car pointer)))
- (error "Invalid PLSTORE format %s" string))
- (setq plist (cdr (car pointer)))
- (while plist
- (when (string-match "\\`:secret-" (symbol-name (car plist)))
- (setq entry (assoc (car (car pointer)) secret-alist))
- (unless entry
- (setq entry (list (car (car pointer)))
- secret-alist (cons entry secret-alist)))
- (setcdr entry (plist-put (cdr entry)
- (intern (concat ":"
- (substring (symbol-name
- (car plist))
- (match-end 0))))
- (car (cdr plist))))
- (setcar (cdr plist) t))
- (setq plist (nthcdr 2 plist)))
- (setq pointer (cdr pointer)))
- (plstore--make nil alist nil secret-alist)))
-
-(defun plstore--write-contents-functions ()
- (when plstore-encoded
- (let ((store (plstore--decode (buffer-string)))
- (file (buffer-file-name)))
- (unwind-protect
- (progn
- (set-visited-file-name nil)
- (with-temp-buffer
- (plstore--insert-buffer store)
- (write-region (buffer-string) nil file)))
- (set-visited-file-name file)
- (set-buffer-modified-p nil))
- t)))
-
-(defun plstore-mode-original ()
- "Show the original form of the this buffer."
- (interactive)
- (when plstore-encoded
- (if (and (buffer-modified-p)
- (y-or-n-p "Save buffer before reading the original form? "))
- (save-buffer))
- (erase-buffer)
- (insert-file-contents-literally (buffer-file-name))
- (set-buffer-modified-p nil)
- (setq plstore-encoded nil)))
-
-(defun plstore-mode-decoded ()
- "Show the decoded form of the this buffer."
- (interactive)
- (unless plstore-encoded
- (if (and (buffer-modified-p)
- (y-or-n-p "Save buffer before decoding? "))
- (save-buffer))
- (let ((store (plstore--make (current-buffer))))
- (plstore--init-from-buffer store)
- (erase-buffer)
- (insert
- (substitute-command-keys "\
-;;; You are looking at the decoded form of the PLSTORE file.\n\
-;;; To see the original form content, do \\[plstore-mode-toggle-display]\n\n"))
- (insert (plstore--encode store))
- (set-buffer-modified-p nil)
- (setq plstore-encoded t))))
-
-(defun plstore-mode-toggle-display ()
- "Toggle the display mode of PLSTORE between the original and decoded forms."
- (interactive)
- (if plstore-encoded
- (plstore-mode-original)
- (plstore-mode-decoded)))
-
-;;;###autoload
-(define-derived-mode plstore-mode emacs-lisp-mode "PLSTORE"
- "Major mode for editing PLSTORE files."
- (make-local-variable 'plstore-encoded)
- (add-hook 'write-contents-functions #'plstore--write-contents-functions)
- (define-key plstore-mode-map "\C-c\C-c" #'plstore-mode-toggle-display)
- ;; to create a new file with plstore-mode, mark it as already decoded
- (if (called-interactively-p 'any)
- (setq plstore-encoded t)
- (plstore-mode-decoded)))
-
-(provide 'plstore)
-
-;;; plstore.el ends here
+++ /dev/null
-;;; pop3.el --- Post Office Protocol (RFC 1460) interface
-
-;; Copyright (C) 1996-2016 Free Software Foundation, Inc.
-
-;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
-;; Maintainer: emacs-devel@gnu.org
-;; Keywords: mail
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands
-;; are implemented. The LIST command has not been implemented due to lack
-;; of actual usefulness.
-;; The optional POP3 command TOP has not been implemented.
-
-;; This program was inspired by Kyle E. Jones's vm-pop program.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'mail-utils)
-(defvar parse-time-months)
-
-(defgroup pop3 nil
- "Post Office Protocol."
- :group 'mail
- :group 'mail-source)
-
-(defcustom pop3-maildrop (or (user-login-name)
- (getenv "LOGNAME")
- (getenv "USER"))
- "*POP3 maildrop."
- :version "22.1" ;; Oort Gnus
- :type 'string
- :group 'pop3)
-
-(defcustom pop3-mailhost (or (getenv "MAILHOST") ;; nil -> mismatch
- "pop3")
- "*POP3 mailhost."
- :version "22.1" ;; Oort Gnus
- :type 'string
- :group 'pop3)
-
-(defcustom pop3-port 110
- "*POP3 port."
- :version "22.1" ;; Oort Gnus
- :type 'number
- :group 'pop3)
-
-(defcustom pop3-password-required t
- "*Non-nil if a password is required when connecting to POP server."
- :version "22.1" ;; Oort Gnus
- :type 'boolean
- :group 'pop3)
-
-;; Should this be customizable?
-(defvar pop3-password nil
- "*Password to use when connecting to POP server.")
-
-(defcustom pop3-authentication-scheme 'pass
- "*POP3 authentication scheme.
-Defaults to `pass', for the standard USER/PASS authentication. The other
-valid value is `apop'."
- :type '(choice (const :tag "Normal user/password" pass)
- (const :tag "APOP" apop))
- :version "22.1" ;; Oort Gnus
- :group 'pop3)
-
-(defcustom pop3-stream-length 100
- "How many messages should be requested at one time.
-The lower the number, the more latency-sensitive the fetching
-will be. If your pop3 server doesn't support streaming at all,
-set this to 1."
- :type 'number
- :version "24.1"
- :group 'pop3)
-
-(defcustom pop3-leave-mail-on-server nil
- "Non-nil if the mail is to be left on the POP server after fetching.
-Mails once fetched will never be fetched again by the UIDL control.
-
-If this is neither nil nor a number, all mails will be left on the
-server. If this is a number, leave mails on the server for this many
-days since you first checked new mails. If this is nil, mails will be
-deleted on the server right after fetching.
-
-Gnus users should use the `:leave' keyword in a mail source to direct
-the behavior per server, rather than directly modifying this value.
-
-Note that POP servers maintain no state information between sessions,
-so what the client believes is there and what is actually there may
-not match up. If they do not, then you may get duplicate mails or
-the whole thing can fall apart and leave you with a corrupt mailbox."
- :version "24.4"
- :type '(choice (const :tag "Don't leave mails" nil)
- (const :tag "Leave all mails" t)
- (number :tag "Leave mails for this many days" :value 14))
- :group 'pop3)
-
-(defcustom pop3-uidl-file "~/.pop3-uidl"
- "File used to save UIDL."
- :version "24.4"
- :type 'file
- :group 'pop3)
-
-(defcustom pop3-uidl-file-backup '(0 9)
- "How to backup the UIDL file `pop3-uidl-file' when updating.
-If it is a list of numbers, the first one binds `kept-old-versions' and
-the other binds `kept-new-versions' to keep number of oldest and newest
-versions. Otherwise, the value binds `version-control' (which see).
-
-Note: Backup will take place whenever you check new mails on a server.
-So, you may lose the backup files having been saved before a trouble
-if you set it so as to make too few backups whereas you have access to
-many servers."
- :version "24.4"
- :type '(choice (group :tag "Keep versions" :format "\n%v" :indent 3
- (number :tag "oldest")
- (number :tag "newest"))
- (sexp :format "%v"
- :match (lambda (widget value)
- (condition-case nil
- (not (and (numberp (car value))
- (numberp (car (cdr value)))))
- (error t)))))
- :group 'pop3)
-
-(defvar pop3-timestamp nil
- "Timestamp returned when initially connected to the POP server.
-Used for APOP authentication.")
-
-(defvar pop3-read-point nil)
-(defvar pop3-debug nil)
-
-;; Borrowed from nnheader-accept-process-output in nnheader.el. See the
-;; comments there for explanations about the values.
-
-(eval-and-compile
- (if (and (fboundp 'nnheader-accept-process-output)
- (boundp 'nnheader-read-timeout))
- (defalias 'pop3-accept-process-output 'nnheader-accept-process-output)
- ;; Borrowed from `nnheader.el':
- (defvar pop3-read-timeout
- (if (string-match "windows-nt\\|os/2\\|cygwin"
- (symbol-name system-type))
- 1.0
- 0.01)
- "How long pop3 should wait between checking for the end of output.
-Shorter values mean quicker response, but are more CPU intensive.")
- (defun pop3-accept-process-output (process)
- (accept-process-output
- process
- (truncate pop3-read-timeout)
- (truncate (* (- pop3-read-timeout
- (truncate pop3-read-timeout))
- 1000))))))
-
-(defvar pop3-uidl)
-;; List of UIDLs of existing messages at present in the server:
-;; ("UIDL1" "UIDL2" "UIDL3"...)
-
-(defvar pop3-uidl-saved)
-;; Locally saved UIDL data; an alist of the server, the user, and the UIDL
-;; and timestamp pairs:
-;; (("SERVER_A" ("USER_A1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...)
-;; ("USER_A2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...)
-;; ...)
-;; ("SERVER_B" ("USER_B1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...)
-;; ("USER_B2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...)
-;; ...))
-;; Where TIMESTAMP is the most significant two digits of an Emacs time,
-;; i.e. the return value of `current-time'.
-
-;;;###autoload
-(defun pop3-movemail (file)
- "Transfer contents of a maildrop to the specified FILE.
-Use streaming commands."
- (let ((process (pop3-open-server pop3-mailhost pop3-port))
- messages total-size
- pop3-uidl
- pop3-uidl-saved)
- (pop3-logon process)
- (if pop3-leave-mail-on-server
- (setq messages (pop3-uidl-stat process)
- total-size (cadr messages)
- messages (car messages))
- (let ((size (pop3-stat process)))
- (dotimes (i (car size)) (push (1+ i) messages))
- (setq messages (nreverse messages)
- total-size (cadr size))))
- (when messages
- (with-current-buffer (process-buffer process)
- (pop3-send-streaming-command process "RETR" messages total-size)
- (pop3-write-to-file file messages)
- (unless pop3-leave-mail-on-server
- (pop3-send-streaming-command process "DELE" messages nil))))
- (if pop3-leave-mail-on-server
- (when (prog1 (pop3-uidl-dele process) (pop3-quit process))
- (pop3-uidl-save))
- (pop3-quit process)
- ;; Remove UIDL data for the account that got not to leave mails.
- (setq pop3-uidl-saved (pop3-uidl-load))
- (let ((elt (assoc pop3-maildrop
- (cdr (assoc pop3-mailhost pop3-uidl-saved)))))
- (when elt
- (setcdr elt nil)
- (pop3-uidl-save))))
- t))
-
-(defun pop3-send-streaming-command (process command messages total-size)
- (erase-buffer)
- (let ((count (length messages))
- (i 1)
- (start-point (point-min))
- (waited-for 0))
- (while messages
- (process-send-string process (format "%s %d\r\n" command (pop messages)))
- ;; Only do 100 messages at a time to avoid pipe stalls.
- (when (zerop (% i pop3-stream-length))
- (setq start-point
- (pop3-wait-for-messages process pop3-stream-length
- total-size start-point))
- (incf waited-for pop3-stream-length))
- (incf i))
- (pop3-wait-for-messages process (- count waited-for)
- total-size start-point)))
-
-(defun pop3-wait-for-messages (process count total-size start-point)
- (while (> count 0)
- (goto-char start-point)
- (while (or (and (re-search-forward "^\\+OK" nil t)
- (or (not total-size)
- (re-search-forward "^\\.\r?\n" nil t)))
- (re-search-forward "^-ERR " nil t))
- (decf count)
- (setq start-point (point)))
- (unless (memq (process-status process) '(open run))
- (error "pop3 process died"))
- (when total-size
- (let ((size 0))
- (goto-char (point-min))
- (while (re-search-forward "^\\+OK.*\n" nil t)
- (setq size (+ size (- (point))
- (if (re-search-forward "^\\.\r?\n" nil 'move)
- (match-beginning 0)
- (point)))))
- (message "pop3 retrieved %dKB (%d%%)"
- (truncate (/ size 1000))
- (truncate (* (/ (* size 1.0) total-size) 100)))))
- (pop3-accept-process-output process))
- start-point)
-
-(defun pop3-write-to-file (file messages)
- (let ((pop-buffer (current-buffer))
- (start (point-min))
- beg end
- temp-buffer)
- (with-temp-buffer
- (setq temp-buffer (current-buffer))
- (with-current-buffer pop-buffer
- (goto-char (point-min))
- (while (re-search-forward "^\\+OK" nil t)
- (forward-line 1)
- (setq beg (point))
- (when (re-search-forward "^\\.\r?\n" nil t)
- (setq start (point))
- (forward-line -1)
- (setq end (point)))
- (with-current-buffer temp-buffer
- (goto-char (point-max))
- (let ((hstart (point)))
- (insert-buffer-substring pop-buffer beg end)
- (pop3-clean-region hstart (point))
- (goto-char (point-max))
- (pop3-munge-message-separator hstart (point))
- (when pop3-leave-mail-on-server
- (pop3-uidl-add-xheader hstart (pop messages)))
- (goto-char (point-max))))))
- (let ((coding-system-for-write 'binary))
- (goto-char (point-min))
- ;; Check whether something inserted a newline at the start and
- ;; delete it.
- (when (eolp)
- (delete-char 1))
- (write-region (point-min) (point-max) file nil 'nomesg)))))
-
-(defun pop3-logon (process)
- (let ((pop3-password pop3-password))
- ;; for debugging only
- (if pop3-debug (switch-to-buffer (process-buffer process)))
- ;; query for password
- (if (and pop3-password-required (not pop3-password))
- (setq pop3-password
- (read-passwd (format "Password for %s: " pop3-maildrop))))
- (cond ((equal 'apop pop3-authentication-scheme)
- (pop3-apop process pop3-maildrop))
- ((equal 'pass pop3-authentication-scheme)
- (pop3-user process pop3-maildrop)
- (pop3-pass process))
- (t (error "Invalid POP3 authentication scheme")))))
-
-(defun pop3-get-message-count ()
- "Return the number of messages in the maildrop."
- (let* ((process (pop3-open-server pop3-mailhost pop3-port))
- message-count
- (pop3-password pop3-password))
- ;; for debugging only
- (if pop3-debug (switch-to-buffer (process-buffer process)))
- ;; query for password
- (if (and pop3-password-required (not pop3-password))
- (setq pop3-password
- (read-passwd (format "Password for %s: " pop3-maildrop))))
- (cond ((equal 'apop pop3-authentication-scheme)
- (pop3-apop process pop3-maildrop))
- ((equal 'pass pop3-authentication-scheme)
- (pop3-user process pop3-maildrop)
- (pop3-pass process))
- (t (error "Invalid POP3 authentication scheme")))
- (setq message-count (car (pop3-stat process)))
- (pop3-quit process)
- message-count))
-
-(defun pop3-uidl-stat (process)
- "Return a list of unread message numbers and total size."
- (pop3-send-command process "UIDL")
- (let (err messages size)
- (if (condition-case code
- (progn
- (pop3-read-response process)
- t)
- (error (setq err (error-message-string code))
- nil))
- (let ((start pop3-read-point)
- saved list)
- (with-current-buffer (process-buffer process)
- (while (not (re-search-forward "^\\.\r\n" nil t))
- (unless (memq (process-status process) '(open run))
- (error "pop3 server closed the connection"))
- (pop3-accept-process-output process)
- (goto-char start))
- (setq pop3-read-point (point-marker)
- pop3-uidl nil)
- (while (progn (forward-line -1) (>= (point) start))
- (when (looking-at "[0-9]+ \\([^\n\r ]+\\)")
- (push (match-string 1) pop3-uidl)))
- (when pop3-uidl
- (setq pop3-uidl-saved (pop3-uidl-load)
- saved (cdr (assoc pop3-maildrop
- (cdr (assoc pop3-mailhost
- pop3-uidl-saved)))))
- (let ((i (length pop3-uidl)))
- (while (> i 0)
- (unless (member (nth (1- i) pop3-uidl) saved)
- (push i messages))
- (decf i)))
- (when messages
- (setq list (pop3-list process)
- size 0)
- (dolist (msg messages)
- (setq size (+ size (cdr (assq msg list)))))
- (list messages size)))))
- (message "%s doesn't support UIDL (%s), so we try a regressive way..."
- pop3-mailhost err)
- (sit-for 1)
- (setq size (pop3-stat process))
- (dotimes (i (car size)) (push (1+ i) messages))
- (setcar size (nreverse messages))
- size)))
-
-(defun pop3-uidl-dele (process)
- "Delete messages according to `pop3-leave-mail-on-server'.
-Return non-nil if it is necessary to update the local UIDL file."
- (let* ((ctime (current-time))
- (srvr (assoc pop3-mailhost pop3-uidl-saved))
- (saved (assoc pop3-maildrop (cdr srvr)))
- i uidl mod new tstamp dele)
- (setcdr (cdr ctime) nil)
- ;; Add new messages to the data to be saved.
- (cond ((and pop3-uidl saved)
- (setq i (1- (length pop3-uidl)))
- (while (>= i 0)
- (unless (member (setq uidl (nth i pop3-uidl)) (cdr saved))
- (push ctime new)
- (push uidl new))
- (decf i)))
- (pop3-uidl
- (setq new (apply 'nconc (mapcar (lambda (elt) (list elt ctime))
- pop3-uidl)))))
- (when new (setq mod t))
- ;; List expirable messages and delete them from the data to be saved.
- (setq ctime (when (numberp pop3-leave-mail-on-server)
- (/ (+ (* (car ctime) 65536.0) (cadr ctime)) 86400))
- i (1- (length saved)))
- (while (> i 0)
- (if (member (setq uidl (nth (1- i) saved)) pop3-uidl)
- (progn
- (setq tstamp (nth i saved))
- (if (and ctime
- (> (- ctime (/ (+ (* (car tstamp) 65536.0) (cadr tstamp))
- 86400))
- pop3-leave-mail-on-server))
- ;; Mails to delete.
- (progn
- (setq mod t)
- (push uidl dele))
- ;; Mails to keep.
- (push tstamp new)
- (push uidl new)))
- ;; Mails having been deleted in the server.
- (setq mod t))
- (decf i 2))
- (cond (saved
- (setcdr saved new))
- (srvr
- (setcdr (last srvr) (list (cons pop3-maildrop new))))
- (t
- (add-to-list 'pop3-uidl-saved
- (list pop3-mailhost (cons pop3-maildrop new))
- t)))
- ;; Actually delete the messages in the server.
- (when dele
- (setq uidl nil
- i (length pop3-uidl))
- (while (> i 0)
- (when (member (nth (1- i) pop3-uidl) dele)
- (push i uidl))
- (decf i))
- (when uidl
- (pop3-send-streaming-command process "DELE" uidl nil)))
- mod))
-
-(defun pop3-uidl-load ()
- "Load saved UIDL."
- (when (file-exists-p pop3-uidl-file)
- (with-temp-buffer
- (condition-case code
- (progn
- (insert-file-contents pop3-uidl-file)
- (goto-char (point-min))
- (read (current-buffer)))
- (error
- (message "Error while loading %s (%s)"
- pop3-uidl-file (error-message-string code))
- (sit-for 1)
- nil)))))
-
-(defun pop3-uidl-save ()
- "Save UIDL."
- (with-temp-buffer
- (if pop3-uidl-saved
- (progn
- (insert "(")
- (dolist (srvr pop3-uidl-saved)
- (when (cdr srvr)
- (insert "(\"" (pop srvr) "\"\n ")
- (dolist (elt srvr)
- (when (cdr elt)
- (insert "(\"" (pop elt) "\"\n ")
- (while elt
- (insert (format "\"%s\" %s\n " (pop elt) (pop elt))))
- (delete-char -4)
- (insert ")\n ")))
- (delete-char -3)
- (if (eq (char-before) ?\))
- (insert ")\n ")
- (goto-char (1+ (point-at-bol)))
- (delete-region (point) (point-max)))))
- (when (eq (char-before) ? )
- (delete-char -2))
- (insert ")\n"))
- (insert "()\n"))
- (let ((buffer-file-name pop3-uidl-file)
- (delete-old-versions t)
- (kept-new-versions kept-new-versions)
- (kept-old-versions kept-old-versions)
- (version-control version-control))
- (if (consp pop3-uidl-file-backup)
- (setq kept-new-versions (cadr pop3-uidl-file-backup)
- kept-old-versions (car pop3-uidl-file-backup)
- version-control t)
- (setq version-control pop3-uidl-file-backup))
- (save-buffer))))
-
-(defun pop3-uidl-add-xheader (start msgno)
- "Add X-UIDL header."
- (let ((case-fold-search t))
- (save-restriction
- (narrow-to-region start (progn
- (goto-char start)
- (search-forward "\n\n" nil 'move)
- (1- (point))))
- (goto-char start)
- (while (re-search-forward "^x-uidl:" nil t)
- (while (progn
- (forward-line 1)
- (memq (char-after) '(?\t ? ))))
- (delete-region (match-beginning 0) (point)))
- (goto-char (point-max))
- (insert "X-UIDL: " (nth (1- msgno) pop3-uidl) "\n"))))
-
-(defcustom pop3-stream-type nil
- "*Transport security type for POP3 connections.
-This may be either nil (plain connection), `ssl' (use an
-SSL/TSL-secured stream) or `starttls' (use the starttls mechanism
-to turn on TLS security after opening the stream). However, if
-this is nil, `ssl' is assumed for connections to port
-995 (pop3s)."
- :version "23.1" ;; No Gnus
- :group 'pop3
- :type '(choice (const :tag "Plain" nil)
- (const :tag "SSL/TLS" ssl)
- (const starttls)))
-
-(defun pop3-open-server (mailhost port)
- "Open TCP connection to MAILHOST on PORT.
-Returns the process associated with the connection."
- (let ((coding-system-for-read 'binary)
- (coding-system-for-write 'binary)
- result)
- (with-current-buffer
- (get-buffer-create (concat " trace of POP session to "
- mailhost))
- (erase-buffer)
- (setq pop3-read-point (point-min))
- (setq result
- (open-network-stream
- "POP" (current-buffer) mailhost port
- :type (cond
- ((or (eq pop3-stream-type 'ssl)
- (and (not pop3-stream-type)
- (member port '(995 "pop3s"))))
- 'tls)
- (t
- (or pop3-stream-type 'network)))
- :warn-unless-encrypted t
- :capability-command "CAPA\r\n"
- :end-of-command "^\\(-ERR\\|+OK\\).*\n"
- :end-of-capability "^\\.\r?\n\\|^-ERR"
- :success "^\\+OK.*\n"
- :return-list t
- :starttls-function
- (lambda (capabilities)
- (and (string-match "\\bSTLS\\b" capabilities)
- "STLS\r\n"))))
- (when result
- (let ((response (plist-get (cdr result) :greeting)))
- (setq pop3-timestamp
- (substring response (or (string-match "<" response) 0)
- (+ 1 (or (string-match ">" response) -1)))))
- (set-process-query-on-exit-flag (car result) nil)
- (erase-buffer)
- (car result)))))
-
-;; Support functions
-
-(defun pop3-send-command (process command)
- (set-buffer (process-buffer process))
- (goto-char (point-max))
- ;; (if (= (aref command 0) ?P)
- ;; (insert "PASS <omitted>\r\n")
- ;; (insert command "\r\n"))
- (setq pop3-read-point (point))
- (goto-char (point-max))
- (process-send-string process (concat command "\r\n")))
-
-(defun pop3-read-response (process &optional return)
- "Read the response from the server.
-Return the response string if optional second argument is non-nil."
- (let ((case-fold-search nil)
- match-end)
- (with-current-buffer (process-buffer process)
- (goto-char pop3-read-point)
- (while (and (memq (process-status process) '(open run))
- (not (search-forward "\r\n" nil t)))
- (pop3-accept-process-output process)
- (goto-char pop3-read-point))
- (setq match-end (point))
- (goto-char pop3-read-point)
- (if (looking-at "-ERR")
- (error "%s" (buffer-substring (point) (- match-end 2)))
- (if (not (looking-at "+OK"))
- (progn (setq pop3-read-point match-end) nil)
- (setq pop3-read-point match-end)
- (if return
- (buffer-substring (point) match-end)
- t)
- )))))
-
-(defun pop3-clean-region (start end)
- (setq end (set-marker (make-marker) end))
- (save-excursion
- (goto-char start)
- (while (and (< (point) end) (search-forward "\r\n" end t))
- (replace-match "\n" t t))
- (goto-char start)
- (while (and (< (point) end) (re-search-forward "^\\." end t))
- (replace-match "" t t)
- (forward-char)))
- (set-marker end nil))
-
-;; Copied from message-make-date.
-(defun pop3-make-date (&optional now)
- "Make a valid date header.
-If NOW, use that time instead."
- (require 'parse-time)
- (let* ((now (or now (current-time)))
- (zone (nth 8 (decode-time now)))
- (sign "+"))
- (when (< zone 0)
- (setq sign "-")
- (setq zone (- zone)))
- (concat
- (format-time-string "%d" now)
- ;; The month name of the %b spec is locale-specific. Pfff.
- (format " %s "
- (capitalize (car (rassoc (nth 4 (decode-time now))
- parse-time-months))))
- (format-time-string "%Y %H:%M:%S %z" now))))
-
-(defun pop3-munge-message-separator (start end)
- "Check to see if a message separator exists. If not, generate one."
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (goto-char (point-min))
- (if (not (or (looking-at "From .?") ; Unix mail
- (looking-at "\001\001\001\001\n") ; MMDF
- (looking-at "BABYL OPTIONS:") ; Babyl
- ))
- (let* ((from (mail-strip-quoted-names (mail-fetch-field "From")))
- (tdate (mail-fetch-field "Date"))
- (date (split-string (or (and tdate
- (not (string= "" tdate))
- tdate)
- (pop3-make-date))
- " "))
- (From_))
- ;; sample date formats I have seen
- ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT)
- ;; Date: 08 Jul 1996 23:22:24 -0400
- ;; should be
- ;; Tue Jul 9 09:04:21 1996
-
- ;; Fixme: This should use timezone on the date field contents.
- (setq date
- (cond ((not date)
- "Tue Jan 1 00:00:0 1900")
- ((string-match "[A-Z]" (nth 0 date))
- (format "%s %s %s %s %s"
- (nth 0 date) (nth 2 date) (nth 1 date)
- (nth 4 date) (nth 3 date)))
- (t
- ;; this really needs to be better but I don't feel
- ;; like writing a date to day converter.
- (format "Sun %s %s %s %s"
- (nth 1 date) (nth 0 date)
- (nth 3 date) (nth 2 date)))
- ))
- (setq From_ (format "\nFrom %s %s\n" from date))
- (while (string-match "," From_)
- (setq From_ (concat (substring From_ 0 (match-beginning 0))
- (substring From_ (match-end 0)))))
- (goto-char (point-min))
- (insert From_)
- (if (search-forward "\n\n" nil t)
- nil
- (goto-char (point-max))
- (insert "\n"))
- (let ((size (- (point-max) (point))))
- (forward-line -1)
- (insert (format "Content-Length: %s\n" size)))
- )))))
-
-;; The Command Set
-
-;; AUTHORIZATION STATE
-
-(defun pop3-user (process user)
- "Send USER information to POP3 server."
- (pop3-send-command process (format "USER %s" user))
- (let ((response (pop3-read-response process t)))
- (if (not (and response (string-match "+OK" response)))
- (error "USER %s not valid" user))))
-
-(defun pop3-pass (process)
- "Send authentication information to the server."
- (pop3-send-command process (format "PASS %s" pop3-password))
- (let ((response (pop3-read-response process t)))
- (if (not (and response (string-match "+OK" response)))
- (pop3-quit process))))
-
-(defun pop3-apop (process user)
- "Send alternate authentication information to the server."
- (let ((pass pop3-password))
- (if (and pop3-password-required (not pass))
- (setq pass
- (read-passwd (format "Password for %s: " pop3-maildrop))))
- (if pass
- (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary)))
- (pop3-send-command process (format "APOP %s %s" user hash))
- (let ((response (pop3-read-response process t)))
- (if (not (and response (string-match "+OK" response)))
- (pop3-quit process)))))
- ))
-
-;; TRANSACTION STATE
-
-(defun pop3-stat (process)
- "Return the number of messages in the maildrop and the maildrop's size."
- (pop3-send-command process "STAT")
- (let ((response (pop3-read-response process t)))
- (list (string-to-number (nth 1 (split-string response " ")))
- (string-to-number (nth 2 (split-string response " "))))
- ))
-
-(defun pop3-list (process &optional msg)
- "If MSG is nil, return an alist of (MESSAGE-ID . SIZE) pairs.
-Otherwise, return the size of the message-id MSG"
- (pop3-send-command process (if msg
- (format "LIST %d" msg)
- "LIST"))
- (let ((response (pop3-read-response process t)))
- (if msg
- (string-to-number (nth 2 (split-string response " ")))
- (let ((start pop3-read-point) end)
- (with-current-buffer (process-buffer process)
- (while (not (re-search-forward "^\\.\r\n" nil t))
- (pop3-accept-process-output process)
- (goto-char start))
- (setq pop3-read-point (point-marker))
- (goto-char (match-beginning 0))
- (setq end (point-marker))
- (mapcar #'(lambda (s) (let ((split (split-string s " ")))
- (cons (string-to-number (nth 0 split))
- (string-to-number (nth 1 split)))))
- (split-string (buffer-substring start end) "\r\n" t)))))))
-
-(defun pop3-retr (process msg crashbuf)
- "Retrieve message-id MSG to buffer CRASHBUF."
- (pop3-send-command process (format "RETR %s" msg))
- (pop3-read-response process)
- (let ((start pop3-read-point) end)
- (with-current-buffer (process-buffer process)
- (while (not (re-search-forward "^\\.\r\n" nil t))
- (unless (memq (process-status process) '(open run))
- (error "pop3 server closed the connection"))
- (pop3-accept-process-output process)
- (goto-char start))
- (setq pop3-read-point (point-marker))
- ;; this code does not seem to work for some POP servers...
- ;; and I cannot figure out why not.
- ;; (goto-char (match-beginning 0))
- ;; (backward-char 2)
- ;; (if (not (looking-at "\r\n"))
- ;; (insert "\r\n"))
- ;; (re-search-forward "\\.\r\n")
- (goto-char (match-beginning 0))
- (setq end (point-marker))
- (pop3-clean-region start end)
- (pop3-munge-message-separator start end)
- (with-current-buffer crashbuf
- (erase-buffer))
- (copy-to-buffer crashbuf start end)
- (delete-region start end)
- )))
-
-(defun pop3-dele (process msg)
- "Mark message-id MSG as deleted."
- (pop3-send-command process (format "DELE %s" msg))
- (pop3-read-response process))
-
-(defun pop3-noop (process msg)
- "No-operation."
- (pop3-send-command process "NOOP")
- (pop3-read-response process))
-
-(defun pop3-last (process)
- "Return highest accessed message-id number for the session."
- (pop3-send-command process "LAST")
- (let ((response (pop3-read-response process t)))
- (string-to-number (nth 1 (split-string response " ")))
- ))
-
-(defun pop3-rset (process)
- "Remove all delete marks from current maildrop."
- (pop3-send-command process "RSET")
- (pop3-read-response process))
-
-;; UPDATE
-
-(defun pop3-quit (process)
- "Close connection to POP3 server.
-Tell server to remove all messages marked as deleted, unlock the maildrop,
-and close the connection."
- (pop3-send-command process "QUIT")
- (pop3-read-response process t)
- (if process
- (with-current-buffer (process-buffer process)
- (goto-char (point-max))
- (delete-process process))))
-\f
-;; 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
+++ /dev/null
-;;; qp.el --- Quoted-Printable functions
-
-;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: mail, extensions
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Functions for encoding and decoding quoted-printable text as
-;; defined in RFC 2045.
-
-;;; Code:
-
-;;;###autoload
-(defun quoted-printable-decode-region (from to &optional coding-system)
- "Decode quoted-printable in the region between FROM and TO, per RFC 2045.
-If CODING-SYSTEM is non-nil, decode bytes into characters with that
-coding-system.
-
-Interactively, you can supply the CODING-SYSTEM argument
-with \\[universal-coding-system-argument].
-
-The CODING-SYSTEM argument is a historical hangover and is deprecated.
-QP encodes raw bytes and should be decoded into raw bytes. Decoding
-them into characters should be done separately."
- (interactive
- ;; Let the user determine the coding system with "C-x RET c".
- (list (region-beginning) (region-end) coding-system-for-read))
- (when (and coding-system
- (not (coding-system-p coding-system))) ; e.g. `ascii' from Gnus
- (setq coding-system nil))
- (save-excursion
- (save-restriction
- ;; RFC 2045: ``An "=" followed by two hexadecimal digits, one
- ;; or both of which are lowercase letters in "abcdef", is
- ;; formally illegal. A robust implementation might choose to
- ;; recognize them as the corresponding uppercase letters.''
- (let ((case-fold-search t))
- (narrow-to-region from to)
- ;; Do this in case we're called from Gnus, say, in a buffer
- ;; which already contains non-ASCII characters which would
- ;; then get doubly-decoded below.
- (if coding-system
- (encode-coding-region (point-min) (point-max) coding-system))
- (goto-char (point-min))
- (while (and (skip-chars-forward "^=")
- (not (eobp)))
- (cond ((eq (char-after (1+ (point))) ?\n)
- (delete-char 2))
- ((looking-at "\\(=[0-9A-F][0-9A-F]\\)+")
- ;; Decode this sequence at once; i.e. by a single
- ;; deletion and insertion.
- (let* ((n (/ (- (match-end 0) (point)) 3))
- (str (make-string n 0)))
- (dotimes (i n)
- (let ((n1 (char-after (1+ (point))))
- (n2 (char-after (+ 2 (point)))))
- (aset str i
- (+ (* 16 (- n1 (if (<= n1 ?9) ?0
- (if (<= n1 ?F) (- ?A 10)
- (- ?a 10)))))
- (- n2 (if (<= n2 ?9) ?0
- (if (<= n2 ?F) (- ?A 10)
- (- ?a 10)))))))
- (forward-char 3))
- (delete-region (match-beginning 0) (match-end 0))
- (insert str)))
- (t
- (message "Malformed quoted-printable text")
- (forward-char)))))
- (if coding-system
- (decode-coding-region (point-min) (point-max) coding-system)))))
-
-(defun quoted-printable-decode-string (string &optional coding-system)
- "Decode the quoted-printable encoded STRING and return the result.
-If CODING-SYSTEM is non-nil, decode the string with coding-system.
-Use of CODING-SYSTEM is deprecated; this function should deal with
-raw bytes, and coding conversion should be done separately."
- (with-temp-buffer
- (set-buffer-multibyte nil)
- (insert string)
- (quoted-printable-decode-region (point-min) (point-max) coding-system)
- (buffer-string)))
-
-(defun quoted-printable-encode-region (from to &optional fold class)
- "Quoted-printable encode the region between FROM and TO per RFC 2045.
-
-If FOLD, fold long lines at 76 characters (as required by the RFC).
-If CLASS is non-nil, translate the characters not matched by that
-regexp class, which is in the form expected by `skip-chars-forward'.
-You should probably avoid non-ASCII characters in this arg.
-
-If `mm-use-ultra-safe-encoding' is set, fold lines unconditionally and
-encode lines starting with \"From\"."
- (interactive "r")
- (unless class
- ;; Avoid using 8bit characters. = is \075.
- ;; Equivalent to "^\000-\007\013\015-\037\200-\377="
- (setq class "\010-\012\014\040-\074\076-\177"))
- (save-excursion
- (goto-char from)
- (if (re-search-forward (string-to-multibyte "[^\x0-\x7f\x80-\xff]")
- to t)
- (error "Multibyte character in QP encoding region"))
- (save-restriction
- (narrow-to-region from to)
- ;; Encode all the non-ascii and control characters.
- (goto-char (point-min))
- (while (and (skip-chars-forward class)
- (not (eobp)))
- (insert
- (prog1
- (format "=%02X" (char-after))
- (delete-char 1))))
- ;; Encode white space at the end of lines.
- (goto-char (point-min))
- (while (re-search-forward "[ \t]+$" nil t)
- (goto-char (match-beginning 0))
- (while (not (eolp))
- (insert
- (prog1
- (format "=%02X" (char-after))
- (delete-char 1)))))
- (let ((ultra
- (and (boundp 'mm-use-ultra-safe-encoding)
- mm-use-ultra-safe-encoding)))
- (when (or fold ultra)
- (let ((tab-width 1) ; HTAB is one character.
- (case-fold-search nil))
- (goto-char (point-min))
- (while (not (eobp))
- ;; In ultra-safe mode, encode "From " at the beginning
- ;; of a line.
- (when ultra
- (if (looking-at "From ")
- (replace-match "From=20" nil t)
- (if (looking-at "-")
- (replace-match "=2D" nil t))))
- (end-of-line)
- ;; Fold long lines.
- (while (> (current-column) 76) ; tab-width must be 1.
- (beginning-of-line)
- (forward-char 75) ; 75 chars plus an "="
- (search-backward "=" (- (point) 2) t)
- (insert "=\n")
- (end-of-line))
- (forward-line))))))))
-
-(defun quoted-printable-encode-string (string)
- "Encode the STRING as quoted-printable and return the result."
- (with-temp-buffer
- (if (multibyte-string-p string)
- (set-buffer-multibyte 'to)
- (set-buffer-multibyte nil))
- (insert string)
- (quoted-printable-encode-region (point-min) (point-max))
- (buffer-string)))
-
-(provide 'qp)
-
-;;; qp.el ends here
+++ /dev/null
-;;; registry.el --- Track and remember data items by various fields
-
-;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
-
-;; Author: Teodor Zlatanov <tzz@lifelogs.com>
-;; Keywords: data
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This library provides a general-purpose EIEIO-based registry
-;; database with persistence, initialized with these fields:
-
-;; version: a float
-
-;; max-size: an integer, default most-positive-fixnum
-
-;; prune-factor: a float between 0 and 1, default 0.1
-
-;; precious: a list of symbols
-
-;; tracked: a list of symbols
-
-;; tracker: a hashtable tuned for 100 symbols to track (you should
-;; only access this with the :lookup2-function and the
-;; :lookup2+-function)
-
-;; data: a hashtable with default size 10K and resize threshold 2.0
-;; (this reflects the expected usage so override it if you know better)
-
-;; ...plus methods to do all the work: `registry-search',
-;; `registry-lookup', `registry-lookup-secondary',
-;; `registry-lookup-secondary-value', `registry-insert',
-;; `registry-delete', `registry-prune', `registry-size' which see
-
-;; and with the following properties:
-
-;; Every piece of data has a unique ID and some general-purpose fields
-;; (F1=D1, F2=D2, F3=(a b c)...) expressed as an alist, e.g.
-
-;; ((F1 D1) (F2 D2) (F3 a b c))
-
-;; Note that whether a field has one or many pieces of data, the data
-;; is always a list of values.
-
-;; The user decides which fields are "precious", F2 for example. When
-;; the registry is pruned, any entries without the F2 field will be
-;; removed until the size is :max-size * :prune-factor _less_ than the
-;; maximum database size. No entries with the F2 field will be removed
-;; at PRUNE TIME, which means it may not be possible to prune back all
-;; the way to the target size.
-
-;; When an entry is inserted, the registry will reject new entries if
-;; they bring it over the :max-size limit, even if they have the F2
-;; field.
-
-;; The user decides which fields are "tracked", F1 for example. Any
-;; new entry is then indexed by all the tracked fields so it can be
-;; quickly looked up that way. The data is always a list (see example
-;; above) and each list element is indexed.
-
-;; Precious and tracked field names must be symbols. All other
-;; fields can be any other Emacs Lisp types.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(require 'eieio)
-(require 'eieio-base)
-
-;; The version number needs to be kept outside of the class definition
-;; itself. The persistent-save process does *not* write to file any
-;; slot values that are equal to the default :initform value. If a
-;; database object is at the most recent version, therefore, its
-;; version number will not be written to file. That makes it
-;; difficult to know when a database needs to be upgraded.
-(defvar registry-db-version 0.2
- "The current version of the registry format.")
-
-(defclass registry-db (eieio-persistent)
- ((version :initarg :version
- :initform nil
- :type (or null float)
- :documentation "The registry version.")
- (max-size :initarg :max-size
- ;; EIEIO's :initform is not 100% compatible with CLOS in
- ;; that if the form is an atom, it assumes it's constant
- ;; value rather than an expression, so in order to get the value
- ;; of `most-positive-fixnum', we need to use an
- ;; expression that's not just a symbol.
- :initform (symbol-value 'most-positive-fixnum)
- :type integer
- :custom integer
- :documentation "The maximum number of registry entries.")
- (prune-factor
- :initarg :prune-factor
- :initform 0.1
- :type float
- :custom float
- :documentation "Prune to (:max-size * :prune-factor) less
- than the :max-size limit. Should be a float between 0 and 1.")
- (tracked :initarg :tracked
- :initform nil
- :type t
- :documentation "The tracked (indexed) fields, a list of symbols.")
- (precious :initarg :precious
- :initform nil
- :type t
- :documentation "The precious fields, a list of symbols.")
- (tracker :initarg :tracker
- :type hash-table
- :documentation "The field tracking hashtable.")
- (data :initarg :data
- :type hash-table
- :documentation "The data hashtable.")))
-
-(cl-defmethod initialize-instance :before ((this registry-db) slots)
- "Check whether a registry object needs to be upgraded."
- ;; Hardcoded upgrade routines. Version 0.1 to 0.2 requires the
- ;; :max-soft slot to disappear, and the :max-hard slot to be renamed
- ;; :max-size.
- (let ((current-version
- (and (plist-member slots :version)
- (plist-get slots :version))))
- (when (or (null current-version)
- (eql current-version 0.1))
- (setq slots
- (plist-put slots :max-size (plist-get slots :max-hard)))
- (setq slots
- (plist-put slots :version registry-db-version))
- (cl-remf slots :max-hard)
- (cl-remf slots :max-soft))))
-
-(cl-defmethod initialize-instance :after ((this registry-db) slots)
- "Set value of data slot of THIS after initialization."
- (with-slots (data tracker) this
- (unless (member :data slots)
- (setq data
- (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)))
- (unless (member :tracker slots)
- (setq tracker (make-hash-table :size 100 :rehash-size 2.0)))))
-
-(cl-defmethod registry-lookup ((db registry-db) keys)
- "Search for KEYS in the registry-db THIS.
-Returns an alist of the key followed by the entry in a list, not a cons cell."
- (let ((data (oref db data)))
- (delq nil
- (mapcar
- (lambda (k)
- (when (gethash k data)
- (list k (gethash k data))))
- keys))))
-
-(cl-defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys)
- "Search for KEYS in the registry-db THIS.
-Returns an alist of the key followed by the entry in a list, not a cons cell."
- (let ((data (oref db data)))
- (delq nil
- (loop for key in keys
- when (gethash key data)
- collect (list key (gethash key data))))))
-
-(cl-defmethod registry-lookup-secondary ((db registry-db) tracksym
- &optional create)
- "Search for TRACKSYM in the registry-db THIS.
-When CREATE is not nil, create the secondary index hashtable if needed."
- (let ((h (gethash tracksym (oref db tracker))))
- (if h
- h
- (when create
- (puthash tracksym
- (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
- (oref db tracker))
- (gethash tracksym (oref db tracker))))))
-
-(cl-defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
- &optional set)
- "Search for TRACKSYM with value VAL in the registry-db THIS.
-When SET is not nil, set it for VAL (use t for an empty list)."
- ;; either we're asked for creation or there should be an existing index
- (when (or set (registry-lookup-secondary db tracksym))
- ;; set the entry if requested,
- (when set
- (puthash val (if (eq t set) '() set)
- (registry-lookup-secondary db tracksym t)))
- (gethash val (registry-lookup-secondary db tracksym))))
-
-(defun registry--match (mode entry check-list)
- ;; for all members
- (when check-list
- (let ((key (nth 0 (nth 0 check-list)))
- (vals (cdr-safe (nth 0 check-list)))
- found)
- (while (and key vals (not found))
- (setq found (case mode
- (:member
- (member (car-safe vals) (cdr-safe (assoc key entry))))
- (:regex
- (string-match (car vals)
- (mapconcat
- 'prin1-to-string
- (cdr-safe (assoc key entry))
- "\0"))))
- vals (cdr-safe vals)))
- (or found
- (registry--match mode entry (cdr-safe check-list))))))
-
-(cl-defmethod registry-search ((db registry-db) &rest spec)
- "Search for SPEC across the registry-db THIS.
-For example calling with `:member \\='(a 1 2)' will match entry \((a 3 1)).
-Calling with `:all t' (any non-nil value) will match all.
-Calling with `:regex \\='(a \"h.llo\")' will match entry \(a \"hullo\" \"bye\").
-The test order is to check :all first, then :member, then :regex."
- (when db
- (let ((all (plist-get spec :all))
- (member (plist-get spec :member))
- (regex (plist-get spec :regex)))
- (loop for k being the hash-keys of (oref db data)
- using (hash-values v)
- when (or
- ;; :all non-nil returns all
- all
- ;; member matching
- (and member (registry--match :member v member))
- ;; regex matching
- (and regex (registry--match :regex v regex)))
- collect k))))
-
-(cl-defmethod registry-delete ((db registry-db) keys assert &rest spec)
- "Delete KEYS from the registry-db THIS.
-If KEYS is nil, use SPEC to do a search.
-Updates the secondary ('tracked') indices as well.
-With assert non-nil, errors out if the key does not exist already."
- (let* ((data (oref db data))
- (keys (or keys
- (apply 'registry-search db spec)))
- (tracked (oref db tracked)))
-
- (dolist (key keys)
- (let ((entry (gethash key data)))
- (when assert
- (assert entry nil
- "Key %s does not exist in database" key))
- ;; clean entry from the secondary indices
- (dolist (tr tracked)
- ;; is this tracked symbol indexed?
- (when (registry-lookup-secondary db tr)
- ;; for every value in the entry under that key...
- (dolist (val (cdr-safe (assq tr entry)))
- (let* ((value-keys (registry-lookup-secondary-value
- db tr val)))
- (when (member key value-keys)
- ;; override the previous value
- (registry-lookup-secondary-value
- db tr val
- ;; with the indexed keys MINUS the current key
- ;; (we pass t when the list is empty)
- (or (delete key value-keys) t)))))))
- (remhash key data)))
- keys))
-
-(cl-defmethod registry-size ((db registry-db))
- "Returns the size of the registry-db object THIS.
-This is the key count of the `data' slot."
- (hash-table-count (oref db data)))
-
-(cl-defmethod registry-full ((db registry-db))
- "Checks if registry-db THIS is full."
- (>= (registry-size db)
- (oref db max-size)))
-
-(cl-defmethod registry-insert ((db registry-db) key entry)
- "Insert ENTRY under KEY into the registry-db THIS.
-Updates the secondary ('tracked') indices as well.
-Errors out if the key exists already."
-
- (assert (not (gethash key (oref db data))) nil
- "Key already exists in database")
-
- (assert (not (registry-full db))
- nil
- "registry max-size limit reached")
-
- ;; store the entry
- (puthash key entry (oref db data))
-
- ;; store the secondary indices
- (dolist (tr (oref db tracked))
- ;; for every value in the entry under that key...
- (dolist (val (cdr-safe (assq tr entry)))
- (let* ((value-keys (registry-lookup-secondary-value db tr val)))
- (pushnew key value-keys :test 'equal)
- (registry-lookup-secondary-value db tr val value-keys))))
- entry)
-
-(cl-defmethod registry-reindex ((db registry-db))
- "Rebuild the secondary indices of registry-db THIS."
- (let ((count 0)
- (expected (* (length (oref db tracked)) (registry-size db))))
- (dolist (tr (oref db tracked))
- (let (values)
- (maphash
- (lambda (key v)
- (incf count)
- (when (and (< 0 expected)
- (= 0 (mod count 1000)))
- (message "reindexing: %d of %d (%.2f%%)"
- count expected (/ (* 100.0 count) expected)))
- (dolist (val (cdr-safe (assq tr v)))
- (let* ((value-keys (registry-lookup-secondary-value db tr val)))
- (push key value-keys)
- (registry-lookup-secondary-value db tr val value-keys))))
- (oref db data))))))
-
-(cl-defmethod registry-prune ((db registry-db) &optional sortfunc)
- "Prunes the registry-db object DB.
-
-Attempts to prune the number of entries down to \(*
-:max-size :prune-factor) less than the max-size limit, so
-pruning doesn't need to happen on every save. Removes only
-entries without the :precious keys, so it may not be possible to
-reach the target limit.
-
-Entries to be pruned are first sorted using SORTFUNC. Entries
-from the front of the list are deleted first.
-
-Returns the number of deleted entries."
- (let ((size (registry-size db))
- (target-size
- (floor (- (oref db max-size)
- (* (oref db max-size)
- (oref db prune-factor)))))
- candidates)
- (if (registry-full db)
- (progn
- (setq candidates
- (registry-collect-prune-candidates
- db (- size target-size) sortfunc))
- (length (registry-delete db candidates nil)))
- 0)))
-
-(cl-defmethod registry-collect-prune-candidates ((db registry-db)
- limit sortfunc)
- "Collects pruning candidates from the registry-db object DB.
-
-Proposes only entries without the :precious keys, and attempts to
-return LIMIT such candidates. If SORTFUNC is provided, sort
-entries first and return candidates from beginning of list."
- (let* ((precious (oref db precious))
- (precious-p (lambda (entry-key)
- (cdr (memq (car entry-key) precious))))
- (data (oref db data))
- (candidates (cl-loop for k being the hash-keys of data
- using (hash-values v)
- when (notany precious-p v)
- collect (cons k v))))
- ;; We want the full entries for sorting, but should only return a
- ;; list of entry keys.
- (when sortfunc
- (setq candidates (sort candidates sortfunc)))
- (cl-subseq (mapcar #'car candidates) 0 (min limit (length candidates)))))
-
-(provide 'registry)
-;;; registry.el ends here
+++ /dev/null
-;;; rfc1843.el --- HZ (rfc1843) decoding
-
-;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
-
-;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
-;; Keywords: news HZ HZ+ mail i18n
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Test:
-;; (rfc1843-decode-string "~{<:Ky2;S{#,NpJ)l6HK!#~}")
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(defvar rfc1843-word-regexp
- "~\\({\\([\041-\167][\041-\176]\\| \\)+\\)\\(~}\\|$\\)")
-
-(defvar rfc1843-word-regexp-strictly
- "~\\({\\([\041-\167][\041-\176]\\)+\\)\\(~}\\|$\\)")
-
-(defvar rfc1843-hzp-word-regexp
- "~\\({\\([\041-\167][\041-\176]\\| \\)+\\|\
-[<>]\\([\041-\175][\041-\176]\\| \\)+\\)\\(~}\\|$\\)")
-
-(defvar rfc1843-hzp-word-regexp-strictly
- "~\\({\\([\041-\167][\041-\176]\\)+\\|\
-[<>]\\([\041-\175][\041-\176]\\)+\\)\\(~}\\|$\\)")
-
-(defcustom rfc1843-decode-loosely nil
- "Loosely check HZ encoding if non-nil.
-When it is set non-nil, only buffers or strings with strictly
-HZ-encoded are decoded."
- :type 'boolean
- :group 'mime)
-
-(defcustom rfc1843-decode-hzp t
- "HZ+ decoding support if non-nil.
-HZ+ specification (also known as HZP) is to provide a standardized
-7-bit representation of mixed Big5, GB, and ASCII text for convenient
-e-mail transmission, news posting, etc.
-The document of HZ+ 0.78 specification can be found at
-ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc"
- :type 'boolean
- :group 'mime)
-
-(defcustom rfc1843-newsgroups-regexp "chinese\\|hz"
- "Regexp of newsgroups in which might be HZ encoded."
- :type 'string
- :group 'mime)
-
-(defun rfc1843-decode-region (from to)
- "Decode HZ in the region between FROM and TO."
- (interactive "r")
- (let (str firstc)
- (save-excursion
- (goto-char from)
- (if (or rfc1843-decode-loosely
- (re-search-forward (if rfc1843-decode-hzp
- rfc1843-hzp-word-regexp-strictly
- rfc1843-word-regexp-strictly) to t))
- (save-restriction
- (narrow-to-region from to)
- (goto-char (point-min))
- (while (re-search-forward (if rfc1843-decode-hzp
- rfc1843-hzp-word-regexp
- rfc1843-word-regexp) (point-max) t)
- (setq str (buffer-substring-no-properties
- (match-beginning 1)
- (match-end 1)))
- (setq firstc (aref str 0))
- (insert (decode-coding-string
- (rfc1843-decode
- (prog1
- (substring str 1)
- (delete-region (match-beginning 0) (match-end 0)))
- firstc)
- (if (eq firstc ?{) 'cn-gb-2312 'cn-big5))))
- (goto-char (point-min))
- (while (search-forward "~" (point-max) t)
- (cond ((eq (char-after) ?\n)
- (delete-char -1)
- (delete-char 1))
- ((eq (char-after) ?~)
- (delete-char 1)))))))))
-
-(defun rfc1843-decode-string (string)
- "Decode HZ STRING and return the results."
- (let ((m enable-multibyte-characters))
- (with-temp-buffer
- (when m
- (set-buffer-multibyte 'to))
- (insert string)
- (inline
- (rfc1843-decode-region (point-min) (point-max)))
- (buffer-string))))
-
-(defun rfc1843-decode (word &optional firstc)
- "Decode HZ WORD and return it."
- (let ((i -1) (s (substring word 0)) v)
- (if (or (not firstc) (eq firstc ?{))
- (while (< (incf i) (length s))
- (if (eq (setq v (aref s i)) ? ) nil
- (aset s i (+ 128 v))))
- (while (< (incf i) (length s))
- (if (eq (setq v (aref s i)) ? ) nil
- (setq v (+ (* 94 v) (aref s (1+ i)) -3135))
- (aset s i (+ (/ v 157) (if (eq firstc ?<) 201 161)))
- (setq v (% v 157))
- (aset s (incf i) (+ v (if (< v 63) 64 98))))))
- s))
-
-(provide 'rfc1843)
-
-;;; rfc1843.el ends here
+++ /dev/null
-;;; rfc2045.el --- Functions for decoding rfc2045 headers
-
-;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;; RFC 2045 is: "Multipurpose Internet Mail Extensions (MIME) Part
-;; One: Format of Internet Message Bodies".
-
-;;; Commentary:
-
-;;; Code:
-
-(require 'ietf-drums)
-
-(defun rfc2045-encode-string (param value)
- "Return and PARAM=VALUE string encoded according to RFC2045."
- (if (or (string-match (concat "[" ietf-drums-no-ws-ctl-token "]") value)
- (string-match (concat "[" ietf-drums-tspecials "]") value)
- (string-match "[ \n\t]" value)
- (not (string-match (concat "[" ietf-drums-text-token "]") value)))
- (concat param "=" (format "%S" value))
- (concat param "=" value)))
-
-(provide 'rfc2045)
-
-;;; rfc2045.el ends here
+++ /dev/null
-;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
-
-;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; RFC 2047 is "MIME (Multipurpose Internet Mail Extensions) Part
-;; Three: Message Header Extensions for Non-ASCII Text".
-
-;;; Code:
-
-(eval-when-compile
- (require 'cl))
-(defvar message-posting-charset)
-
-(require 'mm-util)
-(require 'ietf-drums)
-;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus.
-(require 'mail-prsvr)
-(require 'rfc2045) ;; rfc2045-encode-string
-(autoload 'mm-body-7-or-8 "mm-bodies")
-
-(defvar rfc2047-header-encoding-alist
- '(("Newsgroups" . nil)
- ("Followup-To" . nil)
- ("Message-ID" . nil)
- ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|\\(In-\\)?Reply-To\\|Sender\
-\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime)
- (t . mime))
- "*Header/encoding method alist.
-The list is traversed sequentially. The keys can either be
-header regexps or t.
-
-The values can be:
-
-1) nil, in which case no encoding is done;
-2) `mime', in which case the header will be encoded according to RFC2047;
-3) `address-mime', like `mime', but takes account of the rules for address
- fields (where quoted strings and comments must be treated separately);
-4) a charset, in which case it will be encoded as that charset;
-5) `default', in which case the field will be encoded as the rest
- of the article.")
-
-(defvar rfc2047-charset-encoding-alist
- '((us-ascii . nil)
- (iso-8859-1 . Q)
- (iso-8859-2 . Q)
- (iso-8859-3 . Q)
- (iso-8859-4 . Q)
- (iso-8859-5 . B)
- (koi8-r . B)
- (iso-8859-7 . B)
- (iso-8859-8 . B)
- (iso-8859-9 . Q)
- (iso-8859-14 . Q)
- (iso-8859-15 . Q)
- (iso-2022-jp . B)
- (iso-2022-kr . B)
- (gb2312 . B)
- (gbk . B)
- (gb18030 . B)
- (big5 . B)
- (cn-big5 . B)
- (cn-gb . B)
- (cn-gb-2312 . B)
- (euc-kr . B)
- (iso-2022-jp-2 . B)
- (iso-2022-int-1 . B)
- (viscii . Q))
- "Alist of MIME charsets to RFC2047 encodings.
-Valid encodings are nil, `Q' and `B'. These indicate binary (no) encoding,
-quoted-printable and base64 respectively.")
-
-(defvar rfc2047-encode-function-alist
- '((Q . rfc2047-q-encode-string)
- (B . rfc2047-b-encode-string)
- (nil . identity))
- "Alist of RFC2047 encodings to encoding functions.")
-
-(defvar rfc2047-encode-encoded-words t
- "Whether encoded words should be encoded again.")
-
-(defvar rfc2047-allow-irregular-q-encoded-words t
- "*Whether to decode irregular Q-encoded words.")
-
-(eval-and-compile ;; Necessary to hard code them in `rfc2047-decode-region'.
- (defconst rfc2047-encoded-word-regexp
- "=\\?\\([^][\000-\040()<>@,;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\
-\\(B\\?[+/0-9A-Za-z]*=*\
-\\|Q\\?[ ->@-~]*\
-\\)\\?="
- "Regexp that matches encoded word."
- ;; The patterns for the B encoding and the Q encoding, i.e. the ones
- ;; beginning with "B" and "Q" respectively, are restricted into only
- ;; the characters that those encodings may generally use.
- )
- (defconst rfc2047-encoded-word-regexp-loose
- "=\\?\\([^][\000-\040()<>@,;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\
-\\(B\\?[+/0-9A-Za-z]*=*\
-\\|Q\\?\\(?:\\?+[ -<>@-~]\\)?\\(?:[ ->@-~]+\\?+[ -<>@-~]\\)*[ ->@-~]*\\?*\
-\\)\\?="
- "Regexp that matches encoded word allowing loose Q encoding."
- ;; The pattern for the Q encoding, i.e. the one beginning with "Q",
- ;; is similar to:
- ;; "Q\\?\\(\\?+[^\n=?]\\)?\\([^\n?]+\\?+[^\n=?]\\)*[^\n?]*\\?*"
- ;; <--------1-------><----------2,3----------><--4--><-5->
- ;; They mean:
- ;; 1. After "Q?", allow "?"s that follow a character other than "=".
- ;; 2. Allow "=" after "Q?"; it isn't regarded as the terminator.
- ;; 3. In the middle of an encoded word, allow "?"s that follow a
- ;; character other than "=".
- ;; 4. Allow any characters other than "?" in the middle of an
- ;; encoded word.
- ;; 5. At the end, allow "?"s.
- ))
-
-;;;
-;;; Functions for encoding RFC2047 messages
-;;;
-
-(defun rfc2047-qp-or-base64 ()
- "Return the type with which to encode the buffer.
-This is either `base64' or `quoted-printable'."
- (save-excursion
- (let ((limit (min (point-max) (+ 2000 (point-min))))
- (n8bit 0))
- (goto-char (point-min))
- (skip-chars-forward "\x20-\x7f\r\n\t" limit)
- (while (< (point) limit)
- (incf n8bit)
- (forward-char 1)
- (skip-chars-forward "\x20-\x7f\r\n\t" limit))
- (if (or (< (* 6 n8bit) (- limit (point-min)))
- ;; Don't base64, say, a short line with a single
- ;; non-ASCII char when splitting parts by charset.
- (= n8bit 1))
- 'quoted-printable
- 'base64))))
-
-(defun rfc2047-narrow-to-field ()
- "Narrow the buffer to the header on the current line."
- (beginning-of-line)
- (narrow-to-region
- (point)
- (progn
- (forward-line 1)
- (if (re-search-forward "^[^ \n\t]" nil t)
- (point-at-bol)
- (point-max))))
- (goto-char (point-min)))
-
-(defun rfc2047-field-value ()
- "Return the value of the field at point."
- (save-excursion
- (save-restriction
- (rfc2047-narrow-to-field)
- (re-search-forward ":[ \t\n]*" nil t)
- (buffer-substring-no-properties (point) (point-max)))))
-
-(defun rfc2047-quote-special-characters-in-quoted-strings (&optional
- encodable-regexp)
- "Quote special characters with `\\'s in quoted strings.
-Quoting will not be done in a quoted string if it contains characters
-matching ENCODABLE-REGEXP or it is within parentheses."
- (goto-char (point-min))
- (let ((tspecials (concat "[" ietf-drums-tspecials "]"))
- (start (point))
- beg end)
- (with-syntax-table (standard-syntax-table)
- (while (not (eobp))
- (if (ignore-errors
- (forward-list 1)
- (eq (char-before) ?\)))
- (forward-list -1)
- (goto-char (point-max)))
- (save-restriction
- (narrow-to-region start (point))
- (goto-char start)
- (while (search-forward "\"" nil t)
- (setq beg (match-beginning 0))
- (unless (eq (char-before beg) ?\\)
- (goto-char beg)
- (setq beg (1+ beg))
- (condition-case nil
- (progn
- (forward-sexp)
- (setq end (1- (point)))
- (goto-char beg)
- (if (and encodable-regexp
- (re-search-forward encodable-regexp end t))
- (goto-char (1+ end))
- (save-restriction
- (narrow-to-region beg end)
- (while (re-search-forward tspecials nil 'move)
- (if (eq (char-before) ?\\)
- (if (looking-at tspecials) ;; Already quoted.
- (forward-char)
- (insert "\\"))
- (goto-char (match-beginning 0))
- (insert "\\")
- (forward-char))))
- (forward-char)))
- (error
- (goto-char beg)))))
- (goto-char (point-max)))
- (forward-list 1)
- (setq start (point))))))
-
-(defvar rfc2047-encoding-type 'address-mime
- "The type of encoding done by `rfc2047-encode-region'.
-This should be dynamically bound around calls to
-`rfc2047-encode-region' to either `mime' or `address-mime'. See
-`rfc2047-header-encoding-alist', for definitions.")
-
-(defun rfc2047-encode-message-header ()
- "Encode the message header according to `rfc2047-header-encoding-alist'.
-Should be called narrowed to the head of the message."
- (interactive "*")
- (save-excursion
- (goto-char (point-min))
- (let (alist elem method charsets)
- (while (not (eobp))
- (save-restriction
- (rfc2047-narrow-to-field)
- (setq method nil
- alist rfc2047-header-encoding-alist
- charsets (mm-find-mime-charset-region (point-min) (point-max)))
- ;; M$ Outlook boycotts decoding of a header if it consists
- ;; of two or more encoded words and those charsets differ;
- ;; it seems to decode all words in a header from a charset
- ;; found first in the header. So, we unify the charsets into
- ;; a single one used for encoding the whole text in a header.
- (let ((mm-coding-system-priorities
- (if (= (length charsets) 1)
- (cons (mm-charset-to-coding-system (car charsets))
- mm-coding-system-priorities)
- mm-coding-system-priorities)))
- (while (setq elem (pop alist))
- (when (or (and (stringp (car elem))
- (looking-at (car elem)))
- (eq (car elem) t))
- (setq alist nil
- method (cdr elem))))
- (if (not (rfc2047-encodable-p))
- (prog2
- (when (eq method 'address-mime)
- (rfc2047-quote-special-characters-in-quoted-strings))
- (if (and (eq (mm-body-7-or-8) '8bit)
- (mm-multibyte-p)
- (mm-coding-system-p
- (car message-posting-charset)))
- ;; 8 bit must be decoded.
- (encode-coding-region
- (point-min) (point-max)
- (mm-charset-to-coding-system
- (car message-posting-charset))))
- ;; No encoding necessary, but folding is nice
- (when nil
- (rfc2047-fold-region
- (save-excursion
- (goto-char (point-min))
- (skip-chars-forward "^:")
- (when (looking-at ": ")
- (forward-char 2))
- (point))
- (point-max))))
- ;; We found something that may perhaps be encoded.
- (re-search-forward "^[^:]+: *" nil t)
- (cond
- ((eq method 'address-mime)
- (rfc2047-encode-region (point) (point-max)))
- ((eq method 'mime)
- (let ((rfc2047-encoding-type 'mime))
- (rfc2047-encode-region (point) (point-max))))
- ((eq method 'default)
- (if (and (default-value 'enable-multibyte-characters)
- mail-parse-charset)
- (encode-coding-region (point) (point-max)
- mail-parse-charset)))
- ;; We get this when CC'ing messages to newsgroups with
- ;; 8-bit names. The group name mail copy just got
- ;; unconditionally encoded. Previously, it would ask
- ;; whether to encode, which was quite confusing for the
- ;; user. If the new behavior is wrong, tell me. I have
- ;; left the old code commented out below.
- ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-07.
- ;; Modified by Dave Love, with the commented-out code changed
- ;; in accordance with changes elsewhere.
- ((null method)
- (rfc2047-encode-region (point) (point-max)))
-;;; ((null method)
-;;; (if (or (message-options-get
-;;; 'rfc2047-encode-message-header-encode-any)
-;;; (message-options-set
-;;; 'rfc2047-encode-message-header-encode-any
-;;; (y-or-n-p
-;;; "Some texts are not encoded. Encode anyway?")))
-;;; (rfc2047-encode-region (point-min) (point-max))
-;;; (error "Cannot send unencoded text")))
- ((mm-coding-system-p method)
- (when (default-value 'enable-multibyte-characters)
- (encode-coding-region (point) (point-max) method)))
- ;; Hm.
- (t)))
- (goto-char (point-max))))))))
-
-;; Fixme: This, and the require below may not be the Right Thing, but
-;; should be safe just before release. -- fx 2001-02-08
-
-(defun rfc2047-encodable-p ()
- "Return non-nil if any characters in current buffer need encoding in headers.
-The buffer may be narrowed."
- (require 'message) ; for message-posting-charset
- (let ((charsets
- (mm-find-mime-charset-region (point-min) (point-max))))
- (goto-char (point-min))
- (or (and rfc2047-encode-encoded-words
- (prog1
- (re-search-forward rfc2047-encoded-word-regexp nil t)
- (goto-char (point-min))))
- (and charsets
- (not (equal charsets (list (car message-posting-charset))))))))
-
-;; Use this syntax table when parsing into regions that may need
-;; encoding. Double quotes are string delimiters, backslash is
-;; character quoting, and all other RFC 2822 special characters are
-;; treated as punctuation so we can use forward-sexp/forward-word to
-;; skip to the end of regions appropriately. Nb. ietf-drums does
-;; things differently.
-(defconst rfc2047-syntax-table
- ;; (make-char-table 'syntax-table '(2)) only works in Emacs.
- (let ((table (make-syntax-table)))
- ;; The following is done to work for setting all elements of the table;
- ;; it appears to be the cleanest way.
- ;; Play safe and don't assume the form of the word syntax entry --
- ;; copy it from ?a.
- (set-char-table-range table t (aref (standard-syntax-table) ?a))
- (modify-syntax-entry ?\\ "\\" table)
- (modify-syntax-entry ?\" "\"" table)
- (modify-syntax-entry ?\( "(" table)
- (modify-syntax-entry ?\) ")" table)
- (modify-syntax-entry ?\< "." table)
- (modify-syntax-entry ?\> "." table)
- (modify-syntax-entry ?\[ "." table)
- (modify-syntax-entry ?\] "." table)
- (modify-syntax-entry ?: "." table)
- (modify-syntax-entry ?\; "." table)
- (modify-syntax-entry ?, "." table)
- (modify-syntax-entry ?@ "." table)
- table))
-
-(defun rfc2047-encode-region (b e &optional dont-fold)
- "Encode words in region B to E that need encoding.
-By default, the region is treated as containing RFC2822 addresses.
-Dynamically bind `rfc2047-encoding-type' to change that."
- (save-restriction
- (narrow-to-region b e)
- (let ((encodable-regexp (if rfc2047-encode-encoded-words
- "[^\000-\177]+\\|=\\?"
- "[^\000-\177]+"))
- start ; start of current token
- end begin csyntax
- ;; Whether there's an encoded word before the current token,
- ;; either immediately or separated by space.
- last-encoded
- (orig-text (buffer-substring-no-properties b e)))
- (if (eq 'mime rfc2047-encoding-type)
- ;; Simple case. Continuous words in which all those contain
- ;; non-ASCII characters are encoded collectively. Encoding
- ;; ASCII words, including `Re:' used in Subject headers, is
- ;; avoided for interoperability with non-MIME clients and
- ;; for making it easy to find keywords.
- (progn
- (goto-char (point-min))
- (while (progn (skip-chars-forward " \t\n")
- (not (eobp)))
- (setq start (point))
- (while (and (looking-at "[ \t\n]*\\([^ \t\n]+\\)")
- (progn
- (setq end (match-end 0))
- (re-search-forward encodable-regexp end t)))
- (goto-char end))
- (if (> (point) start)
- (rfc2047-encode start (point))
- (goto-char end))))
- ;; `address-mime' case -- take care of quoted words, comments.
- (rfc2047-quote-special-characters-in-quoted-strings encodable-regexp)
- (with-syntax-table rfc2047-syntax-table
- (goto-char (point-min))
- (condition-case err ; in case of unbalanced quotes
- ;; Look for rfc2822-style: sequences of atoms, quoted
- ;; strings, specials, whitespace. (Specials mustn't be
- ;; encoded.)
- (while (not (eobp))
- ;; Skip whitespace.
- (skip-chars-forward " \t\n")
- (setq start (point))
- (cond
- ((not (char-after))) ; eob
- ;; else token start
- ((eq ?\" (setq csyntax (char-syntax (char-after))))
- ;; Quoted word.
- (forward-sexp)
- (setq end (point))
- ;; Does it need encoding?
- (goto-char start)
- (if (re-search-forward encodable-regexp end 'move)
- ;; It needs encoding. Strip the quotes first,
- ;; since encoded words can't occur in quotes.
- (progn
- (goto-char end)
- (delete-char -1)
- (goto-char start)
- (delete-char 1)
- (when last-encoded
- ;; There was a preceding quoted word. We need
- ;; to include any separating whitespace in this
- ;; word to avoid it getting lost.
- (skip-chars-backward " \t")
- ;; A space is needed between the encoded words.
- (insert ? )
- (setq start (point)
- end (1+ end)))
- ;; Adjust the end position for the deleted quotes.
- (rfc2047-encode start (- end 2))
- (setq last-encoded t)) ; record that it was encoded
- (setq last-encoded nil)))
- ((eq ?. csyntax)
- ;; Skip other delimiters, but record that they've
- ;; potentially separated quoted words.
- (forward-char)
- (setq last-encoded nil))
- ((eq ?\) csyntax)
- (error "Unbalanced parentheses"))
- ((eq ?\( csyntax)
- ;; Look for the end of parentheses.
- (forward-list)
- ;; Encode text as an unstructured field.
- (let ((rfc2047-encoding-type 'mime))
- (rfc2047-encode-region (1+ start) (1- (point))))
- (skip-chars-forward ")"))
- (t ; normal token/whitespace sequence
- ;; Find the end.
- ;; Skip one ASCII word, or encode continuous words
- ;; in which all those contain non-ASCII characters.
- (setq end nil)
- (while (not (or end (eobp)))
- (when (looking-at "[\000-\177]+")
- (setq begin (point)
- end (match-end 0))
- (when (progn
- (while (and (or (re-search-forward
- "[ \t\n]\\|\\Sw" end 'move)
- (setq end nil))
- (eq ?\\ (char-syntax (char-before))))
- ;; Skip backslash-quoted characters.
- (forward-char))
- end)
- (setq end (match-beginning 0))
- (if rfc2047-encode-encoded-words
- (progn
- (goto-char begin)
- (when (search-forward "=?" end 'move)
- (goto-char (match-beginning 0))
- (setq end nil)))
- (goto-char end))))
- ;; Where the value nil of `end' means there may be
- ;; text to have to be encoded following the point.
- ;; Otherwise, the point reached to the end of ASCII
- ;; words separated by whitespace or a special char.
- (unless end
- (when (looking-at encodable-regexp)
- (goto-char (setq begin (match-end 0)))
- (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)")
- (setq end (match-end 0))
- (progn
- (while (re-search-forward
- encodable-regexp end t))
- (< begin (point)))
- (goto-char begin)
- (or (not (re-search-forward "\\Sw" end t))
- (progn
- (goto-char (match-beginning 0))
- nil)))
- (goto-char end))
- (when (looking-at "[^ \t\n]+")
- (setq end (match-end 0))
- (if (re-search-forward "\\Sw+" end t)
- ;; There are special characters better
- ;; to be encoded so that MTAs may parse
- ;; them safely.
- (cond ((= end (point)))
- ((looking-at (concat "\\sw*\\("
- encodable-regexp
- "\\)"))
- (setq end nil))
- (t
- (goto-char (1- (match-end 0)))
- (unless (= (point) (match-beginning 0))
- ;; Separate encodable text and
- ;; delimiter.
- (insert " "))))
- (goto-char end)
- (skip-chars-forward " \t\n")
- (if (and (looking-at "[^ \t\n]+")
- (string-match encodable-regexp
- (match-string 0)))
- (setq end nil)
- (goto-char end)))))))
- (skip-chars-backward " \t\n")
- (setq end (point))
- (goto-char start)
- (if (re-search-forward encodable-regexp end 'move)
- (progn
- (unless (memq (char-before start) '(nil ?\t ? ))
- (if (progn
- (goto-char start)
- (skip-chars-backward "^ \t\n")
- (and (looking-at "\\Sw+")
- (= (match-end 0) start)))
- ;; Also encode bogus delimiters.
- (setq start (point))
- ;; Separate encodable text and delimiter.
- (goto-char start)
- (insert " ")
- (setq start (1+ start)
- end (1+ end))))
- (rfc2047-encode start end)
- (setq last-encoded t))
- (setq last-encoded nil)))))
- (error
- (if (or debug-on-quit debug-on-error)
- (signal (car err) (cdr err))
- (error "Invalid data for rfc2047 encoding: %s"
- (replace-regexp-in-string "[ \t\n]+" " " orig-text))))))))
- (unless dont-fold
- (rfc2047-fold-region b (point)))
- (goto-char (point-max))))
-
-(defun rfc2047-encode-string (string &optional dont-fold)
- "Encode words in STRING.
-By default, the string is treated as containing addresses (see
-`rfc2047-encoding-type')."
- (mm-with-multibyte-buffer
- (insert string)
- (rfc2047-encode-region (point-min) (point-max) dont-fold)
- (buffer-string)))
-
-;; From RFC 2047:
-;; 2. Syntax of encoded-words
-;; [...]
-;; While there is no limit to the length of a multiple-line header
-;; field, each line of a header field that contains one or more
-;; 'encoded-word's is limited to 76 characters.
-;;
-;; In `rfc2047-encode-parameter' it is bound to nil, so don't defconst it.
-(defvar rfc2047-encode-max-chars 76
- "Maximum characters of each header line that contain encoded-words.
-According to RFC 2047, it is 76. If it is nil, encoded-words
-will not be folded. Too small value may cause an error. You
-should not change this value.")
-
-(defun rfc2047-encode-1 (column string cs encoder start crest tail
- &optional eword)
- "Subroutine used by `rfc2047-encode'."
- (cond ((string-equal string "")
- (or eword ""))
- ((not rfc2047-encode-max-chars)
- (concat start
- (funcall encoder (if cs
- (encode-coding-string string cs)
- string))
- "?="))
- ((>= column rfc2047-encode-max-chars)
- (when eword
- (cond ((string-match "\n[ \t]+\\'" eword)
- ;; Remove a superfluous empty line.
- (setq eword (substring eword 0 (match-beginning 0))))
- ((string-match "(+\\'" eword)
- ;; Break the line before the open parenthesis.
- (setq crest (concat crest (match-string 0 eword))
- eword (substring eword 0 (match-beginning 0))))))
- (rfc2047-encode-1 (length crest) string cs encoder start " " tail
- (concat eword "\n" crest)))
- (t
- (let ((index 0)
- (limit (1- (length string)))
- (prev "")
- next len)
- (while (and prev
- (<= index limit))
- (setq next (concat start
- (funcall encoder
- (if cs
- (encode-coding-string
- (substring string 0 (1+ index))
- cs)
- (substring string 0 (1+ index))))
- "?=")
- len (+ column (length next)))
- (if (> len rfc2047-encode-max-chars)
- (setq next prev
- prev nil)
- (if (or (< index limit)
- (<= (+ len (or (string-match "\n" tail)
- (length tail)))
- rfc2047-encode-max-chars))
- (setq prev next
- index (1+ index))
- (if (string-match "\\`)+" tail)
- ;; Break the line after the close parenthesis.
- (setq tail (concat (substring tail 0 (match-end 0))
- "\n "
- (substring tail (match-end 0)))
- prev next
- index (1+ index))
- (setq next prev
- prev nil)))))
- (if (> index limit)
- (concat eword next tail)
- (if (= 0 index)
- (if (and eword
- (string-match "(+\\'" eword))
- (setq crest (concat crest (match-string 0 eword))
- eword (substring eword 0 (match-beginning 0)))
- (setq eword (concat eword next)))
- (setq crest " "
- eword (concat eword next)))
- (when (string-match "\n[ \t]+\\'" eword)
- ;; Remove a superfluous empty line.
- (setq eword (substring eword 0 (match-beginning 0))))
- (rfc2047-encode-1 (length crest) (substring string index)
- cs encoder start " " tail
- (concat eword "\n" crest)))))))
-
-(defun rfc2047-encode (b e)
- "Encode the word(s) in the region B to E.
-Point moves to the end of the region."
- (let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii)))
- cs encoding tail crest eword)
- ;; Use utf-8 as a last resort if determining charset of text fails.
- (if (memq nil mime-charset)
- (setq mime-charset (list 'utf-8)))
- (cond ((> (length mime-charset) 1)
- (error "Can't rfc2047-encode `%s'"
- (buffer-substring-no-properties b e)))
- ((= (length mime-charset) 1)
- (setq mime-charset (car mime-charset)
- cs (mm-charset-to-coding-system mime-charset))
- (unless (and (mm-multibyte-p)
- (mm-coding-system-p cs))
- (setq cs nil))
- (save-restriction
- (narrow-to-region b e)
- (setq encoding
- (or (cdr (assq mime-charset
- rfc2047-charset-encoding-alist))
- ;; For the charsets that don't have a preferred
- ;; encoding, choose the one that's shorter.
- (if (eq (rfc2047-qp-or-base64) 'base64)
- 'B
- 'Q)))
- (widen)
- (goto-char e)
- (skip-chars-forward "^ \t\n")
- ;; `tail' may contain a close parenthesis.
- (setq tail (buffer-substring-no-properties e (point)))
- (goto-char b)
- (setq b (point-marker)
- e (set-marker (make-marker) e))
- (rfc2047-fold-region (point-at-bol) b)
- (goto-char b)
- (skip-chars-backward "^ \t\n")
- (unless (= 0 (skip-chars-backward " \t"))
- ;; `crest' may contain whitespace and an open parenthesis.
- (setq crest (buffer-substring-no-properties (point) b)))
- (setq eword (rfc2047-encode-1
- (- b (point-at-bol))
- (replace-regexp-in-string
- "\n\\([ \t]?\\)" "\\1"
- (buffer-substring-no-properties b e))
- cs
- (or (cdr (assq encoding
- rfc2047-encode-function-alist))
- 'identity)
- (concat "=?" (downcase (symbol-name mime-charset))
- "?" (upcase (symbol-name encoding)) "?")
- (or crest " ")
- tail))
- (delete-region (if (eq (aref eword 0) ?\n)
- (if (bolp)
- ;; The line was folded before encoding.
- (1- (point))
- (point))
- (goto-char b))
- (+ e (length tail)))
- ;; `eword' contains `crest' and `tail'.
- (insert eword)
- (set-marker b nil)
- (set-marker e nil)
- (unless (or (/= 0 (length tail))
- (eobp)
- (looking-at "[ \t\n)]"))
- (insert " "))))
- (t
- (goto-char e)))))
-
-(defun rfc2047-fold-field ()
- "Fold the current header field."
- (save-excursion
- (save-restriction
- (rfc2047-narrow-to-field)
- (rfc2047-fold-region (point-min) (point-max)))))
-
-(defun rfc2047-fold-region (b e)
- "Fold long lines in region B to E."
- (save-restriction
- (narrow-to-region b e)
- (goto-char (point-min))
- (let ((break nil)
- (qword-break nil)
- (first t)
- (bol (save-restriction
- (widen)
- (point-at-bol))))
- (while (not (eobp))
- (when (and (or break qword-break)
- (> (- (point) bol) 76))
- (goto-char (or break qword-break))
- (setq break nil
- qword-break nil)
- (skip-chars-backward " \t")
- (if (looking-at "[ \t]")
- (insert ?\n)
- (insert "\n "))
- (setq bol (1- (point)))
- ;; Don't break before the first non-LWSP characters.
- (skip-chars-forward " \t")
- (unless (eobp)
- (forward-char 1)))
- (cond
- ((eq (char-after) ?\n)
- (forward-char 1)
- (setq bol (point)
- break nil
- qword-break nil)
- (skip-chars-forward " \t")
- (unless (or (eobp) (eq (char-after) ?\n))
- (forward-char 1)))
- ((eq (char-after) ?\r)
- (forward-char 1))
- ((memq (char-after) '(? ?\t))
- (skip-chars-forward " \t")
- (unless first ;; Don't break just after the header name.
- (setq break (point))))
- ((not break)
- (if (not (looking-at "=\\?[^=]"))
- (if (eq (char-after) ?=)
- (forward-char 1)
- (skip-chars-forward "^ \t\n\r="))
- ;; Don't break at the start of the field.
- (unless (= (point) b)
- (setq qword-break (point)))
- (skip-chars-forward "^ \t\n\r")))
- (t
- (skip-chars-forward "^ \t\n\r")))
- (setq first nil))
- (when (and (or break qword-break)
- (> (- (point) bol) 76))
- (goto-char (or break qword-break))
- (setq break nil
- qword-break nil)
- (if (or (> 0 (skip-chars-backward " \t"))
- (looking-at "[ \t]"))
- (insert ?\n)
- (insert "\n "))
- (setq bol (1- (point)))
- ;; Don't break before the first non-LWSP characters.
- (skip-chars-forward " \t")
- (unless (eobp)
- (forward-char 1))))))
-
-(defun rfc2047-unfold-field ()
- "Fold the current line."
- (save-excursion
- (save-restriction
- (rfc2047-narrow-to-field)
- (rfc2047-unfold-region (point-min) (point-max)))))
-
-(defun rfc2047-unfold-region (b e)
- "Unfold lines in region B to E."
- (save-restriction
- (narrow-to-region b e)
- (goto-char (point-min))
- (let ((bol (save-restriction
- (widen)
- (point-at-bol)))
- (eol (point-at-eol)))
- (forward-line 1)
- (while (not (eobp))
- (if (and (looking-at "[ \t]")
- (< (- (point-at-eol) bol) 76))
- (delete-region eol (progn
- (goto-char eol)
- (skip-chars-forward "\r\n")
- (point)))
- (setq bol (point-at-bol)))
- (setq eol (point-at-eol))
- (forward-line 1)))))
-
-(defun rfc2047-b-encode-string (string)
- "Base64-encode the header contained in STRING."
- (base64-encode-string string t))
-
-(autoload 'quoted-printable-encode-region "qp")
-
-(defun rfc2047-q-encode-string (string)
- "Quoted-printable-encode the header in STRING."
- (mm-with-unibyte-buffer
- (insert string)
- (quoted-printable-encode-region
- (point-min) (point-max) nil
- ;; = (\075), _ (\137), ? (\077) are used in the encoded word.
- ;; Avoid using 8bit characters.
- ;; This list excludes `especials' (see the RFC2047 syntax),
- ;; meaning that some characters in non-structured fields will
- ;; get encoded when they con't need to be. The following is
- ;; what it used to be.
- ;;; ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"
- ;;; "\010\012\014\040-\074\076\100-\136\140-\177")
- "-\b\n\f !#-'*+0-9A-Z\\^`-~\d")
- (subst-char-in-region (point-min) (point-max) ? ?_)
- (buffer-string)))
-
-(defun rfc2047-encode-parameter (param value)
- "Return and PARAM=VALUE string encoded in the RFC2047-like style.
-This is a substitution for the `rfc2231-encode-string' function, that
-is the standard but many mailers don't support it."
- (let ((rfc2047-encoding-type 'mime)
- (rfc2047-encode-max-chars nil))
- (rfc2045-encode-string param (rfc2047-encode-string value t))))
-
-;;;
-;;; Functions for decoding RFC2047 messages
-;;;
-
-(defvar rfc2047-quote-decoded-words-containing-tspecials nil
- "If non-nil, quote decoded words containing special characters.")
-
-(defvar rfc2047-allow-incomplete-encoded-text t
- "*Non-nil means allow incomplete encoded-text in successive encoded-words.
-Dividing of encoded-text in the place other than character boundaries
-violates RFC2047 section 5, while we have a capability to decode it.
-If it is non-nil, the decoder will decode B- or Q-encoding in each
-encoded-word, concatenate them, and decode it by charset. Otherwise,
-the decoder will fully decode each encoded-word before concatenating
-them.")
-
-(defun rfc2047-strip-backslashes-in-quoted-strings ()
- "Strip backslashes in quoted strings. `\\\"' remains."
- (goto-char (point-min))
- (let (beg)
- (with-syntax-table (standard-syntax-table)
- (while (search-forward "\"" nil t)
- (unless (eq (char-before) ?\\)
- (setq beg (match-end 0))
- (goto-char (match-beginning 0))
- (condition-case nil
- (progn
- (forward-sexp)
- (save-restriction
- (narrow-to-region beg (1- (point)))
- (goto-char beg)
- (while (search-forward "\\" nil 'move)
- (unless (memq (char-after) '(?\"))
- (delete-char -1))
- (forward-char)))
- (forward-char))
- (error
- (goto-char beg))))))))
-
-(defun rfc2047-charset-to-coding-system (charset &optional allow-override)
- "Return coding-system corresponding to MIME CHARSET.
-If your Emacs implementation can't decode CHARSET, return nil.
-
-If allow-override is given, use `mm-charset-override-alist' to
-map undesired charset names to their replacement. This should
-only be used for decoding, not for encoding."
- (when (stringp charset)
- (setq charset (intern (downcase charset))))
- (when (or (not charset)
- (eq 'gnus-all mail-parse-ignored-charsets)
- (memq 'gnus-all mail-parse-ignored-charsets)
- (memq charset mail-parse-ignored-charsets))
- (setq charset mail-parse-charset))
- (let ((cs (mm-charset-to-coding-system charset nil allow-override)))
- (cond ((eq cs 'ascii)
- (setq cs (or (mm-charset-to-coding-system mail-parse-charset)
- 'raw-text)))
- ((mm-coding-system-p cs))
- ((and charset
- (listp mail-parse-ignored-charsets)
- (memq 'gnus-unknown mail-parse-ignored-charsets))
- (setq cs (mm-charset-to-coding-system mail-parse-charset))))
- (if (eq cs 'ascii)
- 'raw-text
- cs)))
-
-(autoload 'quoted-printable-decode-string "qp")
-
-(defun rfc2047-decode-encoded-words (words)
- "Decode successive encoded-words in WORDS and return a decoded string.
-Each element of WORDS looks like (CHARSET ENCODING ENCODED-TEXT
-ENCODED-WORD)."
- (let (word charset cs encoding text rest)
- (while words
- (setq word (pop words))
- (if (and (setq cs (rfc2047-charset-to-coding-system
- (setq charset (car word)) t))
- (condition-case code
- (cond ((char-equal ?B (nth 1 word))
- (setq text (base64-decode-string
- (rfc2047-pad-base64 (nth 2 word)))))
- ((char-equal ?Q (nth 1 word))
- (setq text (quoted-printable-decode-string
- (subst-char-in-string
- ?_ ? (nth 2 word) t)))))
- (error
- (message "%s" (error-message-string code))
- nil)))
- (if (and rfc2047-allow-incomplete-encoded-text
- (eq cs (caar rest)))
- ;; Concatenate text of which the charset is the same.
- (setcdr (car rest) (concat (cdar rest) text))
- (push (cons cs text) rest))
- ;; Don't decode encoded-word.
- (push (cons nil (nth 3 word)) rest)))
- (while rest
- (setq words (concat
- (or (and (setq cs (caar rest))
- (condition-case code
- (decode-coding-string (cdar rest) cs)
- (error
- (message "%s" (error-message-string code))
- nil)))
- (concat (when (cdr rest) " ")
- (cdar rest)
- (when (and words
- (not (eq (string-to-char words) ? )))
- " ")))
- words)
- rest (cdr rest)))
- words))
-
-;; Fixme: This should decode in place, not cons intermediate strings.
-;; Also check whether it needs to worry about delimiting fields like
-;; encoding.
-
-;; In fact it's reported that (invalid) encoding of mailboxes in
-;; addr-specs is in use, so delimiting fields might help. Probably
-;; not decoding a word which isn't properly delimited is good enough
-;; and worthwhile (is it more correct or not?), e.g. something like
-;; `=?iso-8859-1?q?foo?=@'.
-
-(defun rfc2047-decode-region (start end &optional address-mime)
- "Decode MIME-encoded words in region between START and END.
-If ADDRESS-MIME is non-nil, strip backslashes which precede characters
-other than `\"' and `\\' in quoted strings."
- (interactive "r")
- (let ((case-fold-search t)
- (eword-regexp
- (if rfc2047-allow-irregular-q-encoded-words
- (eval-when-compile
- (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp-loose "\\)"))
- (eval-when-compile
- (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp "\\)"))))
- b e match words)
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (when address-mime
- (rfc2047-strip-backslashes-in-quoted-strings))
- (goto-char (setq b start))
- ;; Look for the encoded-words.
- (while (setq match (re-search-forward eword-regexp nil t))
- (setq e (match-beginning 1)
- end (match-end 0)
- words nil)
- (while match
- (push (list (match-string 2) ;; charset
- (char-after (match-beginning 3)) ;; encoding
- (substring (match-string 3) 2) ;; encoded-text
- (match-string 1)) ;; encoded-word
- words)
- ;; Look for the subsequent encoded-words.
- (when (setq match (looking-at eword-regexp))
- (goto-char (setq end (match-end 0)))))
- ;; Replace the encoded-words with the decoded one.
- (delete-region e end)
- (insert (rfc2047-decode-encoded-words (nreverse words)))
- (save-restriction
- (narrow-to-region e (point))
- (goto-char e)
- ;; Remove newlines between decoded words, though such
- ;; things essentially must not be there.
- (while (re-search-forward "[\n\r]+" nil t)
- (replace-match " "))
- (setq end (point-max))
- ;; Quote decoded words if there are special characters
- ;; which might violate RFC2822.
- (when (and rfc2047-quote-decoded-words-containing-tspecials
- (let ((regexp (car (rassq
- 'address-mime
- rfc2047-header-encoding-alist))))
- (when regexp
- (save-restriction
- (widen)
- (and
- ;; Don't quote words if already quoted.
- (not (and (eq (char-before e) ?\")
- (eq (char-after end) ?\")))
- (progn
- (beginning-of-line)
- (while (and (memq (char-after) '(? ?\t))
- (zerop (forward-line -1))))
- (looking-at regexp)))))))
- (let (quoted)
- (goto-char e)
- (skip-chars-forward " \t")
- (setq start (point))
- (setq quoted (eq (char-after) ?\"))
- (goto-char (point-max))
- (skip-chars-backward " \t" start)
- (if (setq quoted (and quoted
- (> (point) (1+ start))
- (eq (char-before) ?\")))
- (progn
- (backward-char)
- (setq start (1+ start)
- end (point-marker)))
- (setq end (point-marker)))
- (goto-char start)
- (while (search-forward "\"" end t)
- (when (prog2
- (backward-char)
- (zerop (% (skip-chars-backward "\\\\") 2))
- (goto-char (match-beginning 0)))
- (insert "\\"))
- (forward-char))
- (when (and (not quoted)
- (progn
- (goto-char start)
- (re-search-forward
- (concat "[" ietf-drums-tspecials "]")
- end t)))
- (goto-char start)
- (insert "\"")
- (goto-char end)
- (insert "\""))
- (set-marker end nil)))
- (goto-char (point-max)))
- (when (and (mm-multibyte-p)
- mail-parse-charset
- (not (eq mail-parse-charset 'us-ascii))
- (not (eq mail-parse-charset 'gnus-decoded)))
- (decode-coding-region b e mail-parse-charset))
- (setq b (point)))
- (when (and (mm-multibyte-p)
- mail-parse-charset
- (not (eq mail-parse-charset 'us-ascii))
- (not (eq mail-parse-charset 'gnus-decoded)))
- (decode-coding-region b (point-max) mail-parse-charset))))))
-
-(defun rfc2047-decode-address-region (start end)
- "Decode MIME-encoded words in region between START and END.
-Backslashes which precede characters other than `\"' and `\\' in quoted
-strings are stripped."
- (rfc2047-decode-region start end t))
-
-(defun rfc2047-decode-string (string &optional address-mime)
- "Decode MIME-encoded STRING and return the result.
-If ADDRESS-MIME is non-nil, strip backslashes which precede characters
-other than `\"' and `\\' in quoted strings."
- (if (string-match "=\\?" string)
- (with-temp-buffer
- ;; We used to only call mm-enable-multibyte if `m' is non-nil,
- ;; but this can't be the right criterion. Don't just revert this
- ;; change if it encounters a bug. Please help me fix it
- ;; right instead. --Stef
- ;; The string returned should always be multibyte in a multibyte
- ;; session, i.e. the buffer should be multibyte before
- ;; `buffer-string' is called.
- (mm-enable-multibyte)
- (insert string)
- (inline
- (rfc2047-decode-region (point-min) (point-max) address-mime))
- (buffer-string))
- (when address-mime
- (setq string
- (with-temp-buffer
- (when (multibyte-string-p string)
- (mm-enable-multibyte))
- (insert string)
- (rfc2047-strip-backslashes-in-quoted-strings)
- (buffer-string))))
- ;; Fixme: As above, `m' here is inappropriate.
- (if (and ;; m
- mail-parse-charset
- (not (eq mail-parse-charset 'us-ascii))
- (not (eq mail-parse-charset 'gnus-decoded)))
- ;; `decode-coding-string' in Emacs offers a third optional
- ;; arg NOCOPY to avoid consing a new string if the decoding
- ;; is "trivial". Unfortunately it currently doesn't
- ;; consider anything else than a nil coding system
- ;; trivial.
- ;; `rfc2047-decode-string' is called multiple times for each
- ;; article during summary buffer generation, and we really
- ;; want to avoid unnecessary consing. So we bypass
- ;; `decode-coding-string' if the string is purely ASCII.
- (if (eq (detect-coding-string string t) 'undecided)
- ;; string is purely ASCII
- string
- (decode-coding-string string mail-parse-charset))
- (string-to-multibyte string))))
-
-(defun rfc2047-decode-address-string (string)
- "Decode MIME-encoded STRING and return the result.
-Backslashes which precede characters other than `\"' and `\\' in quoted
-strings are stripped."
- (rfc2047-decode-string string t))
-
-(defun rfc2047-pad-base64 (string)
- "Pad STRING to quartets."
- ;; Be more liberal to accept buggy base64 strings. If
- ;; base64-decode-string accepts buggy strings, this function could
- ;; be aliased to identity.
- (if (= 0 (mod (length string) 4))
- string
- (when (string-match "=+$" string)
- (setq string (substring string 0 (match-beginning 0))))
- (case (mod (length string) 4)
- (0 string)
- (1 string) ;; Error, don't pad it.
- (2 (concat string "=="))
- (3 (concat string "=")))))
-
-(provide 'rfc2047)
-
-;;; rfc2047.el ends here
+++ /dev/null
-;;; rfc2231.el --- Functions for decoding rfc2231 headers
-
-;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'ietf-drums)
-(require 'rfc2047)
-(autoload 'mm-encode-body "mm-bodies")
-(autoload 'mail-header-remove-whitespace "mail-parse")
-(autoload 'mail-header-remove-comments "mail-parse")
-
-(defun rfc2231-get-value (ct attribute)
- "Return the value of ATTRIBUTE from CT."
- (cdr (assq attribute (cdr ct))))
-
-(defun rfc2231-parse-qp-string (string)
- "Parse QP-encoded string using `rfc2231-parse-string'.
-N.B. This is in violation with RFC2047, but it seem to be in common use."
- (rfc2231-parse-string (rfc2047-decode-string string)))
-
-(defun rfc2231-parse-string (string &optional signal-error)
- "Parse STRING and return a list.
-The list will be on the form
- `(name (attribute . value) (attribute . value)...)'.
-
-If the optional SIGNAL-ERROR is non-nil, signal an error when this
-function fails in parsing of parameters. Otherwise, this function
-must never cause a Lisp error."
- (with-temp-buffer
- (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token))
- (stoken (ietf-drums-token-to-list ietf-drums-tspecials))
- (ntoken (ietf-drums-token-to-list "0-9"))
- c type attribute encoded number parameters value)
- (ietf-drums-init
- (condition-case nil
- (mail-header-remove-whitespace
- (mail-header-remove-comments string))
- ;; The most likely cause of an error is unbalanced parentheses
- ;; or double-quotes. If all parentheses and double-quotes are
- ;; quoted meaninglessly with backslashes, removing them might
- ;; make it parsable. Let's try...
- (error
- (let (mod)
- (when (and (string-match "\\\\\"" string)
- (not (string-match "\\`\"\\|[^\\]\"" string)))
- (setq string (replace-regexp-in-string "\\\\\"" "\"" string)
- mod t))
- (when (and (string-match "\\\\(" string)
- (string-match "\\\\)" string)
- (not (string-match "\\`(\\|[^\\][()]" string)))
- (setq string (replace-regexp-in-string
- "\\\\\\([()]\\)" "\\1" string)
- mod t))
- (or (and mod
- (ignore-errors
- (mail-header-remove-whitespace
- (mail-header-remove-comments string))))
- ;; Finally, attempt to extract only type.
- (if (string-match
- (concat "\\`[\t\n ]*\\([^" ietf-drums-tspecials "\t\n ]+"
- "\\(?:/[^" ietf-drums-tspecials
- "\t\n ]+\\)?\\)\\(?:[\t\n ;]\\|\\'\\)")
- string)
- (match-string 1 string)
- ""))))))
- (let ((table (copy-syntax-table ietf-drums-syntax-table)))
- (modify-syntax-entry ?\' "w" table)
- (modify-syntax-entry ?* " " table)
- (modify-syntax-entry ?\; " " table)
- (modify-syntax-entry ?= " " table)
- ;; The following isn't valid, but one should be liberal
- ;; in what one receives.
- (modify-syntax-entry ?\: "w" table)
- (set-syntax-table table))
- (setq c (char-after))
- (when (and (memq c ttoken)
- (not (memq c stoken))
- (setq type (ignore-errors
- (downcase
- (buffer-substring (point) (progn
- (forward-sexp 1)
- (point)))))))
- ;; Do the params
- (condition-case err
- (progn
- (while (not (eobp))
- (setq c (char-after))
- (unless (eq c ?\;)
- (error "Invalid header: %s" string))
- (forward-char 1)
- ;; If c in nil, then this is an invalid header, but
- ;; since elm generates invalid headers on this form,
- ;; we allow it.
- (when (setq c (char-after))
- (if (and (memq c ttoken)
- (not (memq c stoken)))
- (setq attribute
- (intern
- (downcase
- (buffer-substring
- (point) (progn (forward-sexp 1) (point))))))
- (error "Invalid header: %s" string))
- (setq c (char-after))
- (if (eq c ?*)
- (progn
- (forward-char 1)
- (setq c (char-after))
- (if (not (memq c ntoken))
- (setq encoded t
- number nil)
- (setq number
- (string-to-number
- (buffer-substring
- (point) (progn (forward-sexp 1) (point)))))
- (setq c (char-after))
- (when (eq c ?*)
- (setq encoded t)
- (forward-char 1)
- (setq c (char-after)))))
- (setq number nil
- encoded nil))
- (unless (eq c ?=)
- (error "Invalid header: %s" string))
- (forward-char 1)
- (setq c (char-after))
- (cond
- ((eq c ?\")
- (setq value (buffer-substring (1+ (point))
- (progn
- (forward-sexp 1)
- (1- (point)))))
- (when encoded
- (setq value (mapconcat (lambda (c) (format "%%%02x" c))
- value ""))))
- ((and (or (memq c ttoken)
- ;; EXTENSION: Support non-ascii chars.
- (> c ?\177))
- (not (memq c stoken)))
- (setq value
- (buffer-substring
- (point)
- (progn
- ;; Jump over asterisk, non-ASCII
- ;; and non-boundary characters.
- (while (and c
- (or (eq c ?*)
- (> c ?\177)
- (not (eq (char-syntax c) ? ))))
- (forward-char 1)
- (setq c (char-after)))
- (point)))))
- (t
- (error "Invalid header: %s" string)))
- (push (list attribute value number encoded)
- parameters))))
- (error
- (setq parameters nil)
- (when signal-error
- (signal (car err) (cdr err)))))
-
- ;; Now collect and concatenate continuation parameters.
- (let ((cparams nil)
- elem)
- (loop for (attribute value part encoded)
- in (sort parameters (lambda (e1 e2)
- (< (or (caddr e1) 0)
- (or (caddr e2) 0))))
- do (cond
- ;; First part.
- ((or (not (setq elem (assq attribute cparams)))
- (and (numberp part)
- (zerop part)))
- (push (list attribute value encoded) cparams))
- ;; Repetition of a part; do nothing.
- ((and elem
- (null number))
- )
- ;; Concatenate continuation parts.
- (t
- (setcar (cdr elem) (concat (cadr elem) value)))))
- ;; Finally decode encoded values.
- (cons type (mapcar
- (lambda (elem)
- (cons (car elem)
- (if (nth 2 elem)
- (rfc2231-decode-encoded-string (nth 1 elem))
- (nth 1 elem))))
- (nreverse cparams))))))))
-
-(defun rfc2231-decode-encoded-string (string)
- "Decode an RFC2231-encoded string.
-These look like:
- \"us-ascii\\='en-us\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\",
- \"us-ascii\\='\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\",
- \"\\='en-us\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\",
- \"\\='\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", or
- \"This is ***fun***\"."
- (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string)
- (let ((coding-system (mm-charset-to-coding-system
- (match-string 1 string) nil t))
- ;;(language (match-string 2 string))
- (value (match-string 3 string)))
- (mm-with-unibyte-buffer
- (insert value)
- (goto-char (point-min))
- (while (re-search-forward "%\\([0-9A-Fa-f][0-9A-Fa-f]\\)" nil t)
- (insert
- (prog1
- (string-to-number (match-string 1) 16)
- (delete-region (match-beginning 0) (match-end 0)))))
- ;; Decode using the charset, if any.
- (if (memq coding-system '(nil ascii))
- (buffer-string)
- (decode-coding-string (buffer-string) coding-system)))))
-
-(defun rfc2231-encode-string (param value)
- "Return and PARAM=VALUE string encoded according to RFC2231.
-Use `mml-insert-parameter' or `mml-insert-parameter-string' to insert
-the result of this function."
- (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token))
- (tspecial (ietf-drums-token-to-list ietf-drums-tspecials))
- (special (ietf-drums-token-to-list "*'%\n\t"))
- (ascii (ietf-drums-token-to-list ietf-drums-text-token))
- (num -1)
- ;; Don't make lines exceeding 76 column.
- (limit (- 74 (length param)))
- spacep encodep charsetp charset broken)
- (mm-with-multibyte-buffer
- (insert value)
- (goto-char (point-min))
- (while (not (eobp))
- (cond
- ((or (memq (following-char) control)
- (memq (following-char) tspecial)
- (memq (following-char) special))
- (setq encodep t))
- ((eq (following-char) ? )
- (setq spacep t))
- ((not (memq (following-char) ascii))
- (setq charsetp t)))
- (forward-char 1))
- (when charsetp
- (setq charset (mm-encode-body)))
- (mm-disable-multibyte)
- (cond
- ((or encodep charsetp
- (progn
- (end-of-line)
- (> (current-column) (if spacep (- limit 2) limit))))
- (setq limit (- limit 6))
- (goto-char (point-min))
- (insert (symbol-name (or charset 'us-ascii)) "''")
- (while (not (eobp))
- (if (or (not (memq (following-char) ascii))
- (memq (following-char) control)
- (memq (following-char) tspecial)
- (memq (following-char) special)
- (eq (following-char) ? ))
- (progn
- (when (>= (current-column) (1- limit))
- (insert ";\n")
- (setq broken t))
- (insert "%" (format "%02x" (following-char)))
- (delete-char 1))
- (when (> (current-column) limit)
- (insert ";\n")
- (setq broken t))
- (forward-char 1)))
- (goto-char (point-min))
- (if (not broken)
- (insert param "*=")
- (while (not (eobp))
- (insert (if (>= num 0) " " "")
- param "*" (format "%d" (incf num)) "*=")
- (forward-line 1))))
- (spacep
- (goto-char (point-min))
- (insert param "=\"")
- (goto-char (point-max))
- (insert "\""))
- (t
- (goto-char (point-min))
- (insert param "=")))
- (buffer-string))))
-
-(provide 'rfc2231)
-
-;;; rfc2231.el ends here
+++ /dev/null
-;;; rtree.el --- functions for manipulating range trees
-
-;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; A "range tree" is a binary tree that stores ranges. They are
-;; similar to interval trees, but do not allow overlapping intervals.
-
-;; A range is an ordered list of number intervals, like this:
-
-;; ((10 . 25) 56 78 (98 . 201))
-
-;; Common operations, like lookup, deletion and insertion are O(n) in
-;; a range, but an rtree is O(log n) in all these operations.
-;; Transformation between a range and an rtree is O(n).
-
-;; The rtrees are quite simple. The structure of each node is
-
-;; (cons (cons low high) (cons left right))
-
-;; That is, they are three cons cells, where the car of the top cell
-;; is the actual range, and the cdr has the left and right child. The
-;; rtrees aren't automatically balanced, but are balanced when
-;; created, and can be rebalanced when deemed necessary.
-
-;;; Code:
-
-(eval-when-compile
- (require 'cl))
-
-(defmacro rtree-make-node ()
- `(list (list nil) nil))
-
-(defmacro rtree-set-left (node left)
- `(setcar (cdr ,node) ,left))
-
-(defmacro rtree-set-right (node right)
- `(setcdr (cdr ,node) ,right))
-
-(defmacro rtree-set-range (node range)
- `(setcar ,node ,range))
-
-(defmacro rtree-low (node)
- `(caar ,node))
-
-(defmacro rtree-high (node)
- `(cdar ,node))
-
-(defmacro rtree-set-low (node number)
- `(setcar (car ,node) ,number))
-
-(defmacro rtree-set-high (node number)
- `(setcdr (car ,node) ,number))
-
-(defmacro rtree-left (node)
- `(cadr ,node))
-
-(defmacro rtree-right (node)
- `(cddr ,node))
-
-(defmacro rtree-range (node)
- `(car ,node))
-
-(defsubst rtree-normalize-range (range)
- (when (numberp range)
- (setq range (cons range range)))
- range)
-
-(define-obsolete-function-alias 'rtree-normalise-range
- 'rtree-normalize-range "25.1")
-
-(defun rtree-make (range)
- "Make an rtree from RANGE."
- ;; Normalize the range.
- (unless (listp (cdr-safe range))
- (setq range (list range)))
- (rtree-make-1 (cons nil range) (length range)))
-
-(defun rtree-make-1 (range length)
- (let ((mid (/ length 2))
- (node (rtree-make-node)))
- (when (> mid 0)
- (rtree-set-left node (rtree-make-1 range mid)))
- (rtree-set-range node (rtree-normalize-range (cadr range)))
- (setcdr range (cddr range))
- (when (> (- length mid 1) 0)
- (rtree-set-right node (rtree-make-1 range (- length mid 1))))
- node))
-
-(defun rtree-memq (tree number)
- "Return non-nil if NUMBER is present in TREE."
- (while (and tree
- (not (and (>= number (rtree-low tree))
- (<= number (rtree-high tree)))))
- (setq tree
- (if (< number (rtree-low tree))
- (rtree-left tree)
- (rtree-right tree))))
- tree)
-
-(defun rtree-add (tree number)
- "Add NUMBER to TREE."
- (while tree
- (cond
- ;; It's already present, so we don't have to do anything.
- ((and (>= number (rtree-low tree))
- (<= number (rtree-high tree)))
- (setq tree nil))
- ((< number (rtree-low tree))
- (cond
- ;; Extend the low range.
- ((= number (1- (rtree-low tree)))
- (rtree-set-low tree number)
- ;; Check whether we need to merge this node with the child.
- (when (and (rtree-left tree)
- (= (rtree-high (rtree-left tree)) (1- number)))
- ;; Extend the range to the low from the child.
- (rtree-set-low tree (rtree-low (rtree-left tree)))
- ;; The child can't have a right child, so just transplant the
- ;; child's left tree to our left tree.
- (rtree-set-left tree (rtree-left (rtree-left tree))))
- (setq tree nil))
- ;; Descend further to the left.
- ((rtree-left tree)
- (setq tree (rtree-left tree)))
- ;; Add a new node.
- (t
- (let ((new-node (rtree-make-node)))
- (rtree-set-low new-node number)
- (rtree-set-high new-node number)
- (rtree-set-left tree new-node)
- (setq tree nil)))))
- (t
- (cond
- ;; Extend the high range.
- ((= number (1+ (rtree-high tree)))
- (rtree-set-high tree number)
- ;; Check whether we need to merge this node with the child.
- (when (and (rtree-right tree)
- (= (rtree-low (rtree-right tree)) (1+ number)))
- ;; Extend the range to the high from the child.
- (rtree-set-high tree (rtree-high (rtree-right tree)))
- ;; The child can't have a left child, so just transplant the
- ;; child's left right to our right tree.
- (rtree-set-right tree (rtree-right (rtree-right tree))))
- (setq tree nil))
- ;; Descend further to the right.
- ((rtree-right tree)
- (setq tree (rtree-right tree)))
- ;; Add a new node.
- (t
- (let ((new-node (rtree-make-node)))
- (rtree-set-low new-node number)
- (rtree-set-high new-node number)
- (rtree-set-right tree new-node)
- (setq tree nil))))))))
-
-(defun rtree-delq (tree number)
- "Remove NUMBER from TREE destructively. Returns the new tree."
- (let ((result tree)
- prev)
- (while tree
- (cond
- ((< number (rtree-low tree))
- (setq prev tree
- tree (rtree-left tree)))
- ((> number (rtree-high tree))
- (setq prev tree
- tree (rtree-right tree)))
- ;; The number is in this node.
- (t
- (cond
- ;; The only entry; delete the node.
- ((= (rtree-low tree) (rtree-high tree))
- (cond
- ;; Two children. Replace with successor value.
- ((and (rtree-left tree) (rtree-right tree))
- (let ((parent tree)
- (successor (rtree-right tree)))
- (while (rtree-left successor)
- (setq parent successor
- successor (rtree-left successor)))
- ;; We now have the leftmost child of our right child.
- (rtree-set-range tree (rtree-range successor))
- ;; Transplant the child (if any) to the parent.
- (rtree-set-left parent (rtree-right successor))))
- (t
- (let ((rest (or (rtree-left tree)
- (rtree-right tree))))
- ;; One or zero children. Remove the node.
- (cond
- ((null prev)
- (setq result rest))
- ((eq (rtree-left prev) tree)
- (rtree-set-left prev rest))
- (t
- (rtree-set-right prev rest)))))))
- ;; The lowest in the range; just adjust.
- ((= number (rtree-low tree))
- (rtree-set-low tree (1+ number)))
- ;; The highest in the range; just adjust.
- ((= number (rtree-high tree))
- (rtree-set-high tree (1- number)))
- ;; We have to split this range.
- (t
- (let ((new-node (rtree-make-node)))
- (rtree-set-low new-node (rtree-low tree))
- (rtree-set-high new-node (1- number))
- (rtree-set-low tree (1+ number))
- (cond
- ;; Two children; insert the new node as the predecessor
- ;; node.
- ((and (rtree-left tree) (rtree-right tree))
- (let ((predecessor (rtree-left tree)))
- (while (rtree-right predecessor)
- (setq predecessor (rtree-right predecessor)))
- (rtree-set-right predecessor new-node)))
- ((rtree-left tree)
- (rtree-set-right new-node tree)
- (rtree-set-left new-node (rtree-left tree))
- (rtree-set-left tree nil)
- (cond
- ((null prev)
- (setq result new-node))
- ((eq (rtree-left prev) tree)
- (rtree-set-left prev new-node))
- (t
- (rtree-set-right prev new-node))))
- (t
- (rtree-set-left tree new-node))))))
- (setq tree nil))))
- result))
-
-(defun rtree-extract (tree)
- "Convert TREE to range form."
- (let (stack result)
- (while (or stack
- tree)
- (if tree
- (progn
- (push tree stack)
- (setq tree (rtree-right tree)))
- (setq tree (pop stack))
- (push (if (= (rtree-low tree)
- (rtree-high tree))
- (rtree-low tree)
- (rtree-range tree))
- result)
- (setq tree (rtree-left tree))))
- result))
-
-(defun rtree-length (tree)
- "Return the number of numbers stored in TREE."
- (if (null tree)
- 0
- (+ (rtree-length (rtree-left tree))
- (1+ (- (rtree-high tree)
- (rtree-low tree)))
- (rtree-length (rtree-right tree)))))
-
-(provide 'rtree)
-
-;;; rtree.el ends here
+++ /dev/null
-;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp
-
-;; Copyright (C) 2001-2016 Free Software Foundation, Inc.
-
-;; Author: Simon Josefsson <simon@josefsson.org>
-;; Albert Krewinkel <tarleb@moltkeplatz.de>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This library provides an elisp API for the managesieve network
-;; protocol.
-;;
-;; It uses the SASL library for authentication, which means it
-;; supports DIGEST-MD5, CRAM-MD5, SCRAM-MD5, NTLM, PLAIN and LOGIN
-;; methods. STARTTLS is not well tested, but should be easy to get to
-;; work if someone wants.
-;;
-;; The API should be fairly obvious for anyone familiar with the
-;; managesieve protocol, interface functions include:
-;;
-;; `sieve-manage-open'
-;; open connection to managesieve server, returning a buffer to be
-;; used by all other API functions.
-;;
-;; `sieve-manage-opened'
-;; check if a server is open or not
-;;
-;; `sieve-manage-close'
-;; close a server connection.
-;;
-;; `sieve-manage-listscripts'
-;; `sieve-manage-deletescript'
-;; `sieve-manage-getscript'
-;; performs managesieve protocol actions
-;;
-;; and that's it. Example of a managesieve session in *scratch*:
-;;
-;; (with-current-buffer (sieve-manage-open "mail.example.com")
-;; (sieve-manage-authenticate)
-;; (sieve-manage-listscripts))
-;;
-;; => ((active . "main") "vacation")
-;;
-;; References:
-;;
-;; draft-martin-managesieve-02.txt,
-;; "A Protocol for Remotely Managing Sieve Scripts",
-;; by Tim Martin.
-;;
-;; Release history:
-;;
-;; 2001-10-31 Committed to Oort Gnus.
-;; 2002-07-27 Added DELETESCRIPT. Suggested by Ned Ludd.
-;; 2002-08-03 Use SASL library.
-;; 2013-06-05 Enabled STARTTLS support, fixed bit rot.
-
-;;; Code:
-
-(if (locate-library "password-cache")
- (require 'password-cache)
- (require 'password))
-
-(eval-when-compile (require 'cl))
-(require 'sasl)
-(require 'starttls)
-(autoload 'sasl-find-mechanism "sasl")
-(autoload 'auth-source-search "auth-source")
-
-;; User customizable variables:
-
-(defgroup sieve-manage nil
- "Low-level Managesieve protocol issues."
- :group 'mail
- :prefix "sieve-")
-
-(defcustom sieve-manage-log "*sieve-manage-log*"
- "Name of buffer for managesieve session trace."
- :type 'string
- :group 'sieve-manage)
-
-(defcustom sieve-manage-server-eol "\r\n"
- "The EOL string sent from the server."
- :type 'string
- :group 'sieve-manage)
-
-(defcustom sieve-manage-client-eol "\r\n"
- "The EOL string we send to the server."
- :type 'string
- :group 'sieve-manage)
-
-(defcustom sieve-manage-authenticators '(digest-md5
- cram-md5
- scram-md5
- ntlm
- plain
- login)
- "Priority of authenticators to consider when authenticating to server."
- ;; FIXME Improve this. It's not `set'.
- ;; It's like (repeat (choice (const ...))), where each choice can
- ;; only appear once.
- :type '(repeat symbol)
- :group 'sieve-manage)
-
-(defcustom sieve-manage-authenticator-alist
- '((cram-md5 sieve-manage-cram-md5-p sieve-manage-cram-md5-auth)
- (digest-md5 sieve-manage-digest-md5-p sieve-manage-digest-md5-auth)
- (scram-md5 sieve-manage-scram-md5-p sieve-manage-scram-md5-auth)
- (ntlm sieve-manage-ntlm-p sieve-manage-ntlm-auth)
- (plain sieve-manage-plain-p sieve-manage-plain-auth)
- (login sieve-manage-login-p sieve-manage-login-auth))
- "Definition of authenticators.
-
-\(NAME CHECK AUTHENTICATE)
-
-NAME names the authenticator. CHECK is a function returning non-nil if
-the server support the authenticator and AUTHENTICATE is a function
-for doing the actual authentication."
- :type '(repeat (list (symbol :tag "Name") (function :tag "Check function")
- (function :tag "Authentication function")))
- :group 'sieve-manage)
-
-(defcustom sieve-manage-default-port "sieve"
- "Default port number or service name for managesieve protocol."
- :type '(choice integer string)
- :version "24.4"
- :group 'sieve-manage)
-
-(defcustom sieve-manage-default-stream 'network
- "Default stream type to use for `sieve-manage'."
- :version "24.1"
- :type 'symbol
- :group 'sieve-manage)
-
-;; Internal variables:
-
-(defconst sieve-manage-local-variables '(sieve-manage-server
- sieve-manage-port
- sieve-manage-auth
- sieve-manage-stream
- sieve-manage-process
- sieve-manage-client-eol
- sieve-manage-server-eol
- sieve-manage-capability))
-(defconst sieve-manage-coding-system-for-read 'binary)
-(defconst sieve-manage-coding-system-for-write 'binary)
-(defvar sieve-manage-stream nil)
-(defvar sieve-manage-auth nil)
-(defvar sieve-manage-server nil)
-(defvar sieve-manage-port nil)
-(defvar sieve-manage-state 'closed
- "Managesieve state.
-Valid states are `closed', `initial', `nonauth', and `auth'.")
-(defvar sieve-manage-process nil)
-(defvar sieve-manage-capability nil)
-
-;; Internal utility functions
-(autoload 'mm-enable-multibyte "mm-util")
-
-(defun sieve-manage-make-process-buffer ()
- (with-current-buffer
- (generate-new-buffer (format " *sieve %s:%s*"
- sieve-manage-server
- sieve-manage-port))
- (mapc 'make-local-variable sieve-manage-local-variables)
- (mm-enable-multibyte)
- (buffer-disable-undo)
- (current-buffer)))
-
-(defun sieve-manage-erase (&optional p buffer)
- (let ((buffer (or buffer (current-buffer))))
- (and sieve-manage-log
- (with-current-buffer (get-buffer-create sieve-manage-log)
- (mm-enable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer (with-current-buffer buffer
- (point-min))
- (or p (with-current-buffer buffer
- (point-max)))))))
- (delete-region (point-min) (or p (point-max))))
-
-(defun sieve-manage-open-server (server port &optional stream buffer)
- "Open network connection to SERVER on PORT.
-Return the buffer associated with the connection."
- (with-current-buffer buffer
- (sieve-manage-erase)
- (setq sieve-manage-state 'initial)
- (destructuring-bind (proc . props)
- (open-network-stream
- "SIEVE" buffer server port
- :type stream
- :capability-command "CAPABILITY\r\n"
- :end-of-command "^\\(OK\\|NO\\).*\n"
- :success "^OK.*\n"
- :return-list t
- :starttls-function
- (lambda (capabilities)
- (when (string-match "\\bSTARTTLS\\b" capabilities)
- "STARTTLS\r\n")))
- (setq sieve-manage-process proc)
- (setq sieve-manage-capability
- (sieve-manage-parse-capability (plist-get props :capabilities)))
- ;; Ignore new capabilities issues after successful STARTTLS
- (when (and (memq stream '(nil network starttls))
- (eq (plist-get props :type) 'tls))
- (sieve-manage-drop-next-answer))
- (current-buffer))))
-
-;; Authenticators
-(defun sieve-sasl-auth (buffer mech)
- "Login to server using the SASL MECH method."
- (message "sieve: Authenticating using %s..." mech)
- (with-current-buffer buffer
- (let* ((auth-info (auth-source-search :host sieve-manage-server
- :port "sieve"
- :max 1
- :create t))
- (user-name (or (plist-get (nth 0 auth-info) :user) ""))
- (user-password (or (plist-get (nth 0 auth-info) :secret) ""))
- (user-password (if (functionp user-password)
- (funcall user-password)
- user-password))
- (client (sasl-make-client (sasl-find-mechanism (list mech))
- user-name "sieve" sieve-manage-server))
- (sasl-read-passphrase
- ;; We *need* to copy the password, because sasl will modify it
- ;; somehow.
- `(lambda (prompt) ,(copy-sequence user-password)))
- (step (sasl-next-step client nil))
- (tag (sieve-manage-send
- (concat
- "AUTHENTICATE \""
- mech
- "\""
- (and (sasl-step-data step)
- (concat
- " \""
- (base64-encode-string
- (sasl-step-data step)
- 'no-line-break)
- "\"")))))
- data rsp)
- (catch 'done
- (while t
- (setq rsp nil)
- (goto-char (point-min))
- (while (null (or (progn
- (setq rsp (sieve-manage-is-string))
- (if (not (and rsp (looking-at
- sieve-manage-server-eol)))
- (setq rsp nil)
- (goto-char (match-end 0))
- rsp))
- (setq rsp (sieve-manage-is-okno))))
- (accept-process-output sieve-manage-process 1)
- (goto-char (point-min)))
- (sieve-manage-erase)
- (when (sieve-manage-ok-p rsp)
- (when (and (cadr rsp)
- (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp)))
- (sasl-step-set-data
- step (base64-decode-string (match-string 1 (cadr rsp)))))
- (if (and (setq step (sasl-next-step client step))
- (setq data (sasl-step-data step)))
- ;; We got data for server but it's finished
- (error "Server not ready for SASL data: %s" data)
- ;; The authentication process is finished.
- (throw 'done t)))
- (unless (stringp rsp)
- (error "Server aborted SASL authentication: %s" (caddr rsp)))
- (sasl-step-set-data step (base64-decode-string rsp))
- (setq step (sasl-next-step client step))
- (sieve-manage-send
- (if (sasl-step-data step)
- (concat "\""
- (base64-encode-string (sasl-step-data step)
- 'no-line-break)
- "\"")
- ""))))
- (message "sieve: Login using %s...done" mech))))
-
-(defun sieve-manage-cram-md5-p (buffer)
- (sieve-manage-capability "SASL" "CRAM-MD5" buffer))
-
-(defun sieve-manage-cram-md5-auth (buffer)
- "Login to managesieve server using the CRAM-MD5 SASL method."
- (sieve-sasl-auth buffer "CRAM-MD5"))
-
-(defun sieve-manage-digest-md5-p (buffer)
- (sieve-manage-capability "SASL" "DIGEST-MD5" buffer))
-
-(defun sieve-manage-digest-md5-auth (buffer)
- "Login to managesieve server using the DIGEST-MD5 SASL method."
- (sieve-sasl-auth buffer "DIGEST-MD5"))
-
-(defun sieve-manage-scram-md5-p (buffer)
- (sieve-manage-capability "SASL" "SCRAM-MD5" buffer))
-
-(defun sieve-manage-scram-md5-auth (buffer)
- "Login to managesieve server using the SCRAM-MD5 SASL method."
- (sieve-sasl-auth buffer "SCRAM-MD5"))
-
-(defun sieve-manage-ntlm-p (buffer)
- (sieve-manage-capability "SASL" "NTLM" buffer))
-
-(defun sieve-manage-ntlm-auth (buffer)
- "Login to managesieve server using the NTLM SASL method."
- (sieve-sasl-auth buffer "NTLM"))
-
-(defun sieve-manage-plain-p (buffer)
- (sieve-manage-capability "SASL" "PLAIN" buffer))
-
-(defun sieve-manage-plain-auth (buffer)
- "Login to managesieve server using the PLAIN SASL method."
- (sieve-sasl-auth buffer "PLAIN"))
-
-(defun sieve-manage-login-p (buffer)
- (sieve-manage-capability "SASL" "LOGIN" buffer))
-
-(defun sieve-manage-login-auth (buffer)
- "Login to managesieve server using the LOGIN SASL method."
- (sieve-sasl-auth buffer "LOGIN"))
-
-;; Managesieve API
-
-(defun sieve-manage-open (server &optional port stream auth buffer)
- "Open a network connection to a managesieve SERVER (string).
-Optional argument PORT is port number (integer) on remote server.
-Optional argument STREAM is any of `sieve-manage-streams' (a symbol).
-Optional argument AUTH indicates authenticator to use, see
-`sieve-manage-authenticators' for available authenticators.
-If nil, chooses the best stream the server is capable of.
-Optional argument BUFFER is buffer (buffer, or string naming buffer)
-to work in."
- (setq sieve-manage-port (or port sieve-manage-default-port))
- (with-current-buffer (or buffer (sieve-manage-make-process-buffer))
- (setq sieve-manage-server (or server
- sieve-manage-server)
- sieve-manage-stream (or stream
- sieve-manage-stream
- sieve-manage-default-stream)
- sieve-manage-auth (or auth
- sieve-manage-auth))
- (message "sieve: Connecting to %s..." sieve-manage-server)
- (sieve-manage-open-server sieve-manage-server
- sieve-manage-port
- sieve-manage-stream
- (current-buffer))
- (when (sieve-manage-opened (current-buffer))
- ;; Choose authenticator
- (when (and (null sieve-manage-auth)
- (not (eq sieve-manage-state 'auth)))
- (dolist (auth sieve-manage-authenticators)
- (when (funcall (nth 1 (assq auth sieve-manage-authenticator-alist))
- buffer)
- (setq sieve-manage-auth auth)
- (return)))
- (unless sieve-manage-auth
- (error "Couldn't figure out authenticator for server")))
- (sieve-manage-erase)
- (current-buffer))))
-
-(defun sieve-manage-authenticate (&optional buffer)
- "Authenticate on server in BUFFER.
-Return `sieve-manage-state' value."
- (with-current-buffer (or buffer (current-buffer))
- (if (eq sieve-manage-state 'nonauth)
- (when (funcall (nth 2 (assq sieve-manage-auth
- sieve-manage-authenticator-alist))
- (current-buffer))
- (setq sieve-manage-state 'auth))
- sieve-manage-state)))
-
-(defun sieve-manage-opened (&optional buffer)
- "Return non-nil if connection to managesieve server in BUFFER is open.
-If BUFFER is nil then the current buffer is used."
- (and (setq buffer (get-buffer (or buffer (current-buffer))))
- (buffer-live-p buffer)
- (with-current-buffer buffer
- (and sieve-manage-process
- (memq (process-status sieve-manage-process) '(open run))))))
-
-(defun sieve-manage-close (&optional buffer)
- "Close connection to managesieve server in BUFFER.
-If BUFFER is nil, the current buffer is used."
- (with-current-buffer (or buffer (current-buffer))
- (when (sieve-manage-opened)
- (sieve-manage-send "LOGOUT")
- (sit-for 1))
- (when (and sieve-manage-process
- (memq (process-status sieve-manage-process) '(open run)))
- (delete-process sieve-manage-process))
- (setq sieve-manage-process nil)
- (sieve-manage-erase)
- t))
-
-(defun sieve-manage-capability (&optional name value buffer)
- "Check if capability NAME of server BUFFER match VALUE.
-If it does, return the server value of NAME. If not returns nil.
-If VALUE is nil, do not check VALUE and return server value.
-If NAME is nil, return the full server list of capabilities."
- (with-current-buffer (or buffer (current-buffer))
- (if (null name)
- sieve-manage-capability
- (let ((server-value (cadr (assoc name sieve-manage-capability))))
- (when (or (null value)
- (and server-value
- (string-match value server-value)))
- server-value)))))
-
-(defun sieve-manage-listscripts (&optional buffer)
- (with-current-buffer (or buffer (current-buffer))
- (sieve-manage-send "LISTSCRIPTS")
- (sieve-manage-parse-listscripts)))
-
-(defun sieve-manage-havespace (name size &optional buffer)
- (with-current-buffer (or buffer (current-buffer))
- (sieve-manage-send (format "HAVESPACE \"%s\" %s" name size))
- (sieve-manage-parse-okno)))
-
-(defun sieve-manage-putscript (name content &optional buffer)
- (with-current-buffer (or buffer (current-buffer))
- (sieve-manage-send (format "PUTSCRIPT \"%s\" {%d+}%s%s" name
- ;; Here we assume that the coding-system will
- ;; replace each char with a single byte.
- ;; This is always the case if `content' is
- ;; a unibyte string.
- (length content)
- sieve-manage-client-eol content))
- (sieve-manage-parse-okno)))
-
-(defun sieve-manage-deletescript (name &optional buffer)
- (with-current-buffer (or buffer (current-buffer))
- (sieve-manage-send (format "DELETESCRIPT \"%s\"" name))
- (sieve-manage-parse-okno)))
-
-(defun sieve-manage-getscript (name output-buffer &optional buffer)
- (with-current-buffer (or buffer (current-buffer))
- (sieve-manage-send (format "GETSCRIPT \"%s\"" name))
- (let ((script (sieve-manage-parse-string)))
- (sieve-manage-parse-crlf)
- (with-current-buffer output-buffer
- (insert script))
- (sieve-manage-parse-okno))))
-
-(defun sieve-manage-setactive (name &optional buffer)
- (with-current-buffer (or buffer (current-buffer))
- (sieve-manage-send (format "SETACTIVE \"%s\"" name))
- (sieve-manage-parse-okno)))
-
-;; Protocol parsing routines
-
-(defun sieve-manage-wait-for-answer ()
- (let ((pattern "^\\(OK\\|NO\\).*\n")
- pos)
- (while (not pos)
- (setq pos (search-forward-regexp pattern nil t))
- (goto-char (point-min))
- (sleep-for 0 50))
- pos))
-
-(defun sieve-manage-drop-next-answer ()
- (sieve-manage-wait-for-answer)
- (sieve-manage-erase))
-
-(defun sieve-manage-ok-p (rsp)
- (string= (downcase (or (car-safe rsp) "")) "ok"))
-
-(defun sieve-manage-is-okno ()
- (when (looking-at (concat
- "^\\(OK\\|NO\\)\\( (\\([^)]+\\))\\)?\\( \\(.*\\)\\)?"
- sieve-manage-server-eol))
- (let ((status (match-string 1))
- (resp-code (match-string 3))
- (response (match-string 5)))
- (when response
- (goto-char (match-beginning 5))
- (setq response (sieve-manage-is-string)))
- (list status resp-code response))))
-
-(defun sieve-manage-parse-okno ()
- (let (rsp)
- (while (null rsp)
- (accept-process-output (get-buffer-process (current-buffer)) 1)
- (goto-char (point-min))
- (setq rsp (sieve-manage-is-okno)))
- (sieve-manage-erase)
- rsp))
-
-(defun sieve-manage-parse-capability (str)
- "Parse managesieve capability string `STR'.
-Set variable `sieve-manage-capability' to "
- (let ((capas (delq nil
- (mapcar #'split-string-and-unquote
- (split-string str "\n")))))
- (when (string= "OK" (caar (last capas)))
- (setq sieve-manage-state 'nonauth))
- capas))
-
-(defun sieve-manage-is-string ()
- (cond ((looking-at "\"\\([^\"]+\\)\"")
- (prog1
- (match-string 1)
- (goto-char (match-end 0))))
- ((looking-at (concat "{\\([0-9]+\\+?\\)}" sieve-manage-server-eol))
- (let ((pos (match-end 0))
- (len (string-to-number (match-string 1))))
- (if (< (point-max) (+ pos len))
- nil
- (goto-char (+ pos len))
- (buffer-substring pos (+ pos len)))))))
-
-(defun sieve-manage-parse-string ()
- (let (rsp)
- (while (null rsp)
- (accept-process-output (get-buffer-process (current-buffer)) 1)
- (goto-char (point-min))
- (setq rsp (sieve-manage-is-string)))
- (sieve-manage-erase (point))
- rsp))
-
-(defun sieve-manage-parse-crlf ()
- (when (looking-at sieve-manage-server-eol)
- (sieve-manage-erase (match-end 0))))
-
-(defun sieve-manage-parse-listscripts ()
- (let (tmp rsp data)
- (while (null rsp)
- (while (null (or (setq rsp (sieve-manage-is-okno))
- (setq tmp (sieve-manage-is-string))))
- (accept-process-output (get-buffer-process (current-buffer)) 1)
- (goto-char (point-min)))
- (when tmp
- (while (not (looking-at (concat "\\( ACTIVE\\)?"
- sieve-manage-server-eol)))
- (accept-process-output (get-buffer-process (current-buffer)) 1)
- (goto-char (point-min)))
- (if (match-string 1)
- (push (cons 'active tmp) data)
- (push tmp data))
- (goto-char (match-end 0))
- (setq tmp nil)))
- (sieve-manage-erase)
- (if (sieve-manage-ok-p rsp)
- data
- rsp)))
-
-(defun sieve-manage-send (cmdstr)
- (setq cmdstr (concat cmdstr sieve-manage-client-eol))
- (and sieve-manage-log
- (with-current-buffer (get-buffer-create sieve-manage-log)
- (mm-enable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert cmdstr)))
- (process-send-string sieve-manage-process cmdstr))
-
-(provide 'sieve-manage)
-
-;; sieve-manage.el ends here
+++ /dev/null
-;;; sieve-mode.el --- Sieve code editing commands for Emacs
-
-;; Copyright (C) 2001-2016 Free Software Foundation, Inc.
-
-;; Author: Simon Josefsson <simon@josefsson.org>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file contain editing mode functions and font-lock support for
-;; editing Sieve scripts. It sets up C-mode with support for
-;; sieve-style #-comments and a lightly hacked syntax table. It was
-;; strongly influenced by awk-mode.el.
-;;
-;; Put something similar to the following in your .emacs to use this file:
-;;
-;; (load "~/lisp/sieve")
-;; (setq auto-mode-alist (cons '("\\.siv\\'" . sieve-mode) auto-mode-alist))
-;;
-;; References:
-;;
-;; RFC 3028,
-;; "Sieve: A Mail Filtering Language",
-;; by Tim Showalter.
-;;
-;; Release history:
-;;
-;; 2001-03-02 version 1.0 posted to gnu.emacs.sources
-;; version 1.1 change file extension into ".siv" (official one)
-;; added keymap and menubar to hook into sieve-manage
-;; 2001-10-31 version 1.2 committed to Oort Gnus
-
-;;; Code:
-
-(autoload 'sieve-manage "sieve")
-(autoload 'sieve-upload "sieve")
-(eval-when-compile
- (require 'font-lock))
-
-(defgroup sieve nil
- "Sieve."
- :group 'languages)
-
-(defcustom sieve-mode-hook nil
- "Hook run in sieve mode buffers."
- :group 'sieve
- :type 'hook)
-
-;; Font-lock
-
-(defvar sieve-control-commands-face 'sieve-control-commands
- "Face name used for Sieve Control Commands.")
-
-(defface sieve-control-commands
- '((((type tty) (class color)) (:foreground "blue" :weight light))
- (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
- (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
- (((class color) (background light)) (:foreground "Orchid"))
- (((class color) (background dark)) (:foreground "LightSteelBlue"))
- (t (:bold t)))
- "Face used for Sieve Control Commands."
- :group 'sieve)
-;; backward-compatibility alias
-(put 'sieve-control-commands-face 'face-alias 'sieve-control-commands)
-(put 'sieve-control-commands-face 'obsolete-face "22.1")
-
-(defvar sieve-action-commands-face 'sieve-action-commands
- "Face name used for Sieve Action Commands.")
-
-(defface sieve-action-commands
- '((((type tty) (class color)) (:foreground "blue" :weight bold))
- (((class color) (background light)) (:foreground "Blue"))
- (((class color) (background dark)) (:foreground "LightSkyBlue"))
- (t (:inverse-video t :bold t)))
- "Face used for Sieve Action Commands."
- :group 'sieve)
-;; backward-compatibility alias
-(put 'sieve-action-commands-face 'face-alias 'sieve-action-commands)
-(put 'sieve-action-commands-face 'obsolete-face "22.1")
-
-(defvar sieve-test-commands-face 'sieve-test-commands
- "Face name used for Sieve Test Commands.")
-
-(defface sieve-test-commands
- '((((type tty) (class color)) (:foreground "magenta"))
- (((class grayscale) (background light))
- (:foreground "LightGray" :bold t :underline t))
- (((class grayscale) (background dark))
- (:foreground "Gray50" :bold t :underline t))
- (((class color) (background light)) (:foreground "CadetBlue"))
- (((class color) (background dark)) (:foreground "Aquamarine"))
- (t (:bold t :underline t)))
- "Face used for Sieve Test Commands."
- :group 'sieve)
-;; backward-compatibility alias
-(put 'sieve-test-commands-face 'face-alias 'sieve-test-commands)
-(put 'sieve-test-commands-face 'obsolete-face "22.1")
-
-(defvar sieve-tagged-arguments-face 'sieve-tagged-arguments
- "Face name used for Sieve Tagged Arguments.")
-
-(defface sieve-tagged-arguments
- '((((type tty) (class color)) (:foreground "cyan" :weight bold))
- (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
- (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
- (((class color) (background light)) (:foreground "Purple"))
- (((class color) (background dark)) (:foreground "Cyan"))
- (t (:bold t)))
- "Face used for Sieve Tagged Arguments."
- :group 'sieve)
-;; backward-compatibility alias
-(put 'sieve-tagged-arguments-face 'face-alias 'sieve-tagged-arguments)
-(put 'sieve-tagged-arguments-face 'obsolete-face "22.1")
-
-
-(defconst sieve-font-lock-keywords
- (eval-when-compile
- (list
- ;; control commands
- (cons (regexp-opt '("require" "if" "else" "elsif" "stop")
- 'words)
- 'sieve-control-commands-face)
- ;; action commands
- (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard")
- 'words)
- 'sieve-action-commands-face)
- ;; test commands
- (cons (regexp-opt '("address" "allof" "anyof" "exists" "false"
- "true" "header" "not" "size" "envelope"
- "body")
- 'words)
- 'sieve-test-commands-face)
- (cons "\\Sw+:\\sw+"
- 'sieve-tagged-arguments-face))))
-
-;; Syntax table
-
-(defvar sieve-mode-syntax-table nil
- "Syntax table in use in sieve-mode buffers.")
-
-(if sieve-mode-syntax-table
- ()
- (setq sieve-mode-syntax-table (make-syntax-table))
- (modify-syntax-entry ?\\ "\\" sieve-mode-syntax-table)
- (modify-syntax-entry ?\n "> " sieve-mode-syntax-table)
- (modify-syntax-entry ?\f "> " sieve-mode-syntax-table)
- (modify-syntax-entry ?\# "< " sieve-mode-syntax-table)
- (modify-syntax-entry ?/ "." sieve-mode-syntax-table)
- (modify-syntax-entry ?* "." sieve-mode-syntax-table)
- (modify-syntax-entry ?+ "." sieve-mode-syntax-table)
- (modify-syntax-entry ?- "." sieve-mode-syntax-table)
- (modify-syntax-entry ?= "." sieve-mode-syntax-table)
- (modify-syntax-entry ?% "." sieve-mode-syntax-table)
- (modify-syntax-entry ?< "." sieve-mode-syntax-table)
- (modify-syntax-entry ?> "." sieve-mode-syntax-table)
- (modify-syntax-entry ?& "." sieve-mode-syntax-table)
- (modify-syntax-entry ?| "." sieve-mode-syntax-table)
- (modify-syntax-entry ?_ "_" sieve-mode-syntax-table)
- (modify-syntax-entry ?\' "\"" sieve-mode-syntax-table))
-
-;; Key map definition
-
-(defvar sieve-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-l" 'sieve-upload)
- (define-key map "\C-c\C-c" 'sieve-upload-and-kill)
- (define-key map "\C-c\C-m" 'sieve-manage)
- map)
- "Key map used in sieve mode.")
-
-;; Menu definition
-
-(defvar sieve-mode-menu nil
- "Menubar used in sieve mode.")
-
-;; Code for Sieve editing mode.
-(autoload 'easy-menu-add-item "easymenu")
-
-;;;###autoload
-(define-derived-mode sieve-mode c-mode "Sieve"
- "Major mode for editing Sieve code.
-This is much like C mode except for the syntax of comments. Its keymap
-inherits from C mode's and it has the same variables for customizing
-indentation. It has its own abbrev table and its own syntax table.
-
-Turning on Sieve mode runs `sieve-mode-hook'."
- (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter))
- (set (make-local-variable 'paragraph-separate) paragraph-start)
- (set (make-local-variable 'comment-start) "#")
- (set (make-local-variable 'comment-end) "")
- ;;(set (make-local-variable 'comment-start-skip) "\\(^\\|\\s-\\);?#+ *")
- (set (make-local-variable 'comment-start-skip) "#+ *")
- (set (make-local-variable 'font-lock-defaults)
- '(sieve-font-lock-keywords nil nil ((?_ . "w"))))
- (easy-menu-add-item nil nil sieve-mode-menu))
-
-;; Menu
-
-(easy-menu-define sieve-mode-menu sieve-mode-map
- "Sieve Menu."
- '("Sieve"
- ["Upload script" sieve-upload t]
- ["Manage scripts on server" sieve-manage t]))
-
-(provide 'sieve-mode)
-
-;; sieve-mode.el ends here
+++ /dev/null
-;;; sieve.el --- Utilities to manage sieve scripts
-
-;; Copyright (C) 2001-2016 Free Software Foundation, Inc.
-
-;; Author: Simon Josefsson <simon@josefsson.org>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This file contain utilities to facilitate upload, download and
-;; general management of sieve scripts. Currently only the
-;; Managesieve protocol is supported (using sieve-manage.el), but when
-;; (useful) alternatives become available, they might be supported as
-;; well.
-;;
-;; The cursor navigation was inspired by biff-mode by Franklin Lee.
-;;
-;; Release history:
-;;
-;; 2001-10-31 Committed to Oort Gnus.
-;; 2002-07-27 Fix down-mouse-2 and down-mouse-3 in manage-mode. Fix menubar
-;; in manage-mode. Change some messages. Added sieve-deactivate*,
-;; sieve-remove. Fixed help text in manage-mode. Suggested by
-;; Ned Ludd.
-;;
-;; Todo:
-;;
-;; * Namespace? This file contains `sieve-manage' and
-;; `sieve-manage-mode', but there is a sieve-manage.el file as well.
-;; Can't think of a good solution though, this file need a *-mode,
-;; and naming it `sieve-mode' would collide with sieve-mode.el. One
-;; solution would be to come up with some better name that this file
-;; can use that doesn't have the managesieve specific "manage" in
-;; it. sieve-dired? i dunno. we could copy all off sieve.el into
-;; sieve-manage.el too, but I'd like to separate the interface from
-;; the protocol implementation since the backends are likely to
-;; change (well).
-;;
-;; * Define servers? We could have a customize buffer to create a server,
-;; with authentication/stream/etc parameters, much like Gnus, and then
-;; only use names of defined servers when interacting with M-x sieve-*.
-;; Right now you can't use STARTTLS, which sieve-manage.el provides
-
-;;; Code:
-
-(require 'sieve-manage)
-(require 'sieve-mode)
-
-;; User customizable variables:
-
-(defgroup sieve nil
- "Manage sieve scripts."
- :version "22.1"
- :group 'tools)
-
-(defcustom sieve-new-script "<new script>"
- "Name of name script indicator."
- :type 'string
- :group 'sieve)
-
-(defcustom sieve-buffer "*sieve*"
- "Name of sieve management buffer."
- :type 'string
- :group 'sieve)
-
-(defcustom sieve-template "\
-require \"fileinto\";
-
-# Example script (remove comment character '#' to make it effective!):
-#
-# if header :contains \"from\" \"coyote\" {
-# discard;
-# } elsif header :contains [\"subject\"] [\"$$$\"] {
-# discard;
-# } else {
-# fileinto \"INBOX\";
-# }
-"
- "Template sieve script."
- :type 'string
- :group 'sieve)
-
-;; Internal variables:
-
-(defvar sieve-manage-buffer nil)
-(defvar sieve-buffer-header-end nil)
-(defvar sieve-buffer-script-name nil
- "The real script name of the buffer.")
-(make-local-variable 'sieve-buffer-script-name)
-
-;; Sieve-manage mode:
-
-(defvar sieve-manage-mode-map
- (let ((map (make-sparse-keymap)))
- ;; various
- (define-key map "?" 'sieve-help)
- (define-key map "h" 'sieve-help)
- ;; activating
- (define-key map "m" 'sieve-activate)
- (define-key map "u" 'sieve-deactivate)
- (define-key map "\M-\C-?" 'sieve-deactivate-all)
- ;; navigation keys
- (define-key map "\C-p" 'sieve-prev-line)
- (define-key map [up] 'sieve-prev-line)
- (define-key map "\C-n" 'sieve-next-line)
- (define-key map [down] 'sieve-next-line)
- (define-key map " " 'sieve-next-line)
- (define-key map "n" 'sieve-next-line)
- (define-key map "p" 'sieve-prev-line)
- (define-key map "\C-m" 'sieve-edit-script)
- (define-key map "f" 'sieve-edit-script)
- (define-key map "o" 'sieve-edit-script-other-window)
- (define-key map "r" 'sieve-remove)
- (define-key map "q" 'sieve-bury-buffer)
- (define-key map "Q" 'sieve-manage-quit)
- (define-key map [(down-mouse-2)] 'sieve-edit-script)
- (define-key map [(down-mouse-3)] 'sieve-manage-mode-menu)
- map)
- "Keymap for `sieve-manage-mode'.")
-
-(easy-menu-define sieve-manage-mode-menu sieve-manage-mode-map
- "Sieve Menu."
- '("Manage Sieve"
- ["Edit script" sieve-edit-script t]
- ["Activate script" sieve-activate t]
- ["Deactivate script" sieve-deactivate t]))
-
-(define-derived-mode sieve-manage-mode fundamental-mode "Sieve-manage"
- "Mode used for sieve script management."
- (buffer-disable-undo (current-buffer))
- (setq truncate-lines t)
- (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map))
-
-(put 'sieve-manage-mode 'mode-class 'special)
-
-;; Commands used in sieve-manage mode:
-
-(defun sieve-manage-quit ()
- "Quit Manage Sieve and close the connection."
- (interactive)
- (sieve-manage-close sieve-manage-buffer)
- (kill-buffer sieve-manage-buffer)
- (kill-buffer (current-buffer)))
-
-(defun sieve-bury-buffer ()
- "Bury the Manage Sieve buffer without closing the connection."
- (interactive)
- (bury-buffer))
-
-(defun sieve-activate (&optional pos)
- (interactive "d")
- (let ((name (sieve-script-at-point)) err)
- (when (or (null name) (string-equal name sieve-new-script))
- (error "No sieve script at point"))
- (message "Activating script %s..." name)
- (setq err (sieve-manage-setactive name sieve-manage-buffer))
- (sieve-refresh-scriptlist)
- (if (sieve-manage-ok-p err)
- (message "Activating script %s...done" name)
- (message "Activating script %s...failed: %s" name (nth 2 err)))))
-
-(defun sieve-deactivate-all (&optional pos)
- (interactive "d")
- (let ((name (sieve-script-at-point)) err)
- (message "Deactivating scripts...")
- (setq err (sieve-manage-setactive "" sieve-manage-buffer))
- (sieve-refresh-scriptlist)
- (if (sieve-manage-ok-p err)
- (message "Deactivating scripts...done")
- (message "Deactivating scripts...failed: %s" (nth 2 err)))))
-
-(defalias 'sieve-deactivate 'sieve-deactivate-all)
-
-(defun sieve-remove (&optional pos)
- (interactive "d")
- (let ((name (sieve-script-at-point)) err)
- (when (or (null name) (string-equal name sieve-new-script))
- (error "No sieve script at point"))
- (message "Removing sieve script %s..." name)
- (setq err (sieve-manage-deletescript name sieve-manage-buffer))
- (unless (sieve-manage-ok-p err)
- (error "Removing sieve script %s...failed: " err))
- (sieve-refresh-scriptlist)
- (message "Removing sieve script %s...done" name)))
-
-(defun sieve-edit-script (&optional pos)
- (interactive "d")
- (let ((name (sieve-script-at-point)))
- (unless name
- (error "No sieve script at point"))
- (if (not (string-equal name sieve-new-script))
- (let ((newbuf (generate-new-buffer name))
- err)
- (setq err (sieve-manage-getscript name newbuf sieve-manage-buffer))
- (switch-to-buffer newbuf)
- (unless (sieve-manage-ok-p err)
- (error "Sieve download failed: %s" err)))
- (switch-to-buffer (get-buffer-create "template.siv"))
- (insert sieve-template))
- (sieve-mode)
- (setq sieve-buffer-script-name name)
- (goto-char (point-min))
- (message
- (substitute-command-keys
- "Press \\[sieve-upload] to upload script to server."))))
-
-(defmacro sieve-change-region (&rest body)
- "Turns off sieve-region before executing BODY, then re-enables it after.
-Used to bracket operations which move point in the sieve-buffer."
- `(progn
- (sieve-highlight nil)
- ,@body
- (sieve-highlight t)))
-(put 'sieve-change-region 'lisp-indent-function 0)
-
-(defun sieve-next-line (&optional arg)
- (interactive)
- (unless arg
- (setq arg 1))
- (if (save-excursion
- (forward-line arg)
- (sieve-script-at-point))
- (sieve-change-region
- (forward-line arg))
- (message "End of list")))
-
-(defun sieve-prev-line (&optional arg)
- (interactive)
- (unless arg
- (setq arg -1))
- (if (save-excursion
- (forward-line arg)
- (sieve-script-at-point))
- (sieve-change-region
- (forward-line arg))
- (message "Beginning of list")))
-
-(defun sieve-help ()
- "Display help for various sieve commands."
- (interactive)
- (if (eq last-command 'sieve-help)
- ;; would need minor-mode for log-edit-mode
- (describe-function 'sieve-mode)
- (message "%s" (substitute-command-keys
- "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove"))))
-
-;; Create buffer:
-
-(defun sieve-setup-buffer (server port)
- (setq buffer-read-only nil)
- (erase-buffer)
- (buffer-disable-undo)
- (let* ((port (or port sieve-manage-default-port))
- (header (format "Server : %s:%s\n\n" server port)))
- (insert header))
- (set (make-local-variable 'sieve-buffer-header-end)
- (point-max)))
-
-(defun sieve-script-at-point (&optional pos)
- "Return name of sieve script at point POS, or nil."
- (interactive "d")
- (get-char-property (or pos (point)) 'script-name))
-
-(defun sieve-highlight (on)
- "Turn ON or off highlighting on the current language overlay."
- (overlay-put (car (overlays-at (point))) 'face (if on 'highlight 'default)))
-
-(defun sieve-insert-scripts (scripts)
- "Format and insert LANGUAGE-LIST strings into current buffer at point."
- (while scripts
- (let ((p (point))
- (ext nil)
- (script (pop scripts)))
- (if (consp script)
- (insert (format " ACTIVE %s" (cdr script)))
- (insert (format " %s" script)))
- (setq ext (make-overlay p (point)))
- (overlay-put ext 'mouse-face 'highlight)
- (overlay-put ext 'script-name (if (consp script)
- (cdr script)
- script))
- (insert "\n"))))
-
-(defun sieve-open-server (server &optional port)
- "Open SERVER (on PORT) and authenticate."
- (with-current-buffer
- (or ;; open server
- (set (make-local-variable 'sieve-manage-buffer)
- (sieve-manage-open server port))
- (error "Error opening server %s" server))
- (sieve-manage-authenticate)))
-
-(defun sieve-refresh-scriptlist ()
- (interactive)
- (with-current-buffer sieve-buffer
- (setq buffer-read-only nil)
- (delete-region (or sieve-buffer-header-end (point-max)) (point-max))
- (goto-char (point-max))
- ;; get list of script names and print them
- (let ((scripts (sieve-manage-listscripts sieve-manage-buffer)))
- (if (null scripts)
- (insert
- (substitute-command-keys
- (format
- "No scripts on server, press \\[sieve-edit-script] on %s to create a new script.\n"
- sieve-new-script)))
- (insert
- (substitute-command-keys
- (format (concat "%d script%s on server, press \\[sieve-edit-script] on a script "
- "name edits it, or\npress \\[sieve-edit-script] on %s to create "
- "a new script.\n") (length scripts)
- (if (eq (length scripts) 1) "" "s")
- sieve-new-script))))
- (save-excursion
- (sieve-insert-scripts (list sieve-new-script))
- (sieve-insert-scripts scripts)))
- (sieve-highlight t)
- (setq buffer-read-only t)))
-
-;;;###autoload
-(defun sieve-manage (server &optional port)
- (interactive "sServer: ")
- (switch-to-buffer (get-buffer-create sieve-buffer))
- (sieve-manage-mode)
- (sieve-setup-buffer server port)
- (if (sieve-open-server server port)
- (sieve-refresh-scriptlist)
- (message "Could not open server %s" server)))
-
-;;;###autoload
-(defun sieve-upload (&optional name)
- (interactive)
- (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage))
- (let ((script (buffer-string)) err)
- (with-current-buffer (get-buffer sieve-buffer)
- (setq err (sieve-manage-putscript
- (or name sieve-buffer-script-name (buffer-name))
- script sieve-manage-buffer))
- (if (sieve-manage-ok-p err)
- (message (substitute-command-keys
- "Sieve upload done. Use \\[sieve-manage] to manage scripts."))
- (message "Sieve upload failed: %s" (nth 2 err)))))))
-
-;;;###autoload
-(defun sieve-upload-and-bury (&optional name)
- (interactive)
- (sieve-upload name)
- (bury-buffer))
-
-;;;###autoload
-(defun sieve-upload-and-kill (&optional name)
- (interactive)
- (sieve-upload name)
- (kill-buffer))
-
-(provide 'sieve)
-
-;; sieve.el ends here
+++ /dev/null
-;;; starttls.el --- STARTTLS functions
-
-;; Copyright (C) 1999-2016 Free Software Foundation, Inc.
-
-;; Author: Daiki Ueno <ueno@unixuser.org>
-;; Author: Simon Josefsson <simon@josefsson.org>
-;; Created: 1999/11/20
-;; Keywords: TLS, SSL, OpenSSL, GnuTLS, mail, news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This module defines some utility functions for STARTTLS profiles.
-
-;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
-;; by Chris Newman <chris.newman@innosoft.com> (1999/06)
-
-;; This file now contains a combination of the two previous
-;; implementations both called "starttls.el". The first one is Daiki
-;; Ueno's starttls.el which uses his own "starttls" command line tool,
-;; and the second one is Simon Josefsson's starttls.el which uses
-;; "gnutls-cli" from GnuTLS.
-;;
-;; If "starttls" is available, it is preferred by the code over
-;; "gnutls-cli", for backwards compatibility. Use
-;; `starttls-use-gnutls' to toggle between implementations if you have
-;; both tools installed. It is recommended to use GnuTLS, though, as
-;; it performs more verification of the certificates.
-
-;; The GnuTLS support requires GnuTLS 0.9.90 (released 2003-10-08) or
-;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls"
-;; from <ftp://ftp.opaopa.org/pub/elisp/>.
-
-;; Usage is similar to `open-network-stream'. For example:
-;;
-;; (when (setq tmp (starttls-open-stream
-;; "test" (current-buffer) "yxa.extundo.com" 25))
-;; (accept-process-output tmp 15)
-;; (process-send-string tmp "STARTTLS\n")
-;; (accept-process-output tmp 15)
-;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp))
-;; (process-send-string tmp "EHLO foo\n"))
-
-;; An example run yields the following output:
-;;
-;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65]
-;; 220 2.0.0 Ready to start TLS
-;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you
-;; 250-ENHANCEDSTATUSCODES
-;; 250-PIPELINING
-;; 250-EXPN
-;; 250-VERB
-;; 250-8BITMIME
-;; 250-SIZE
-;; 250-DSN
-;; 250-ETRN
-;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN
-;; 250-DELIVERBY
-;; 250 HELP
-;; nil
-;;
-;; With the message buffer containing:
-;;
-;; STARTTLS output:
-;; *** Starting TLS handshake
-;; - Server's trusted authorities:
-;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
-;; - Certificate type: X.509
-;; - Got a certificate list of 2 certificates.
-;;
-;; - Certificate[0] info:
-;; # The hostname in the certificate matches 'yxa.extundo.com'.
-;; # valid since: Wed May 26 12:16:00 CEST 2004
-;; # expires at: Wed Jul 26 12:16:00 CEST 2023
-;; # serial number: 04
-;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a
-;; # version: #1
-;; # public key algorithm: RSA
-;; # Modulus: 1024 bits
-;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
-;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
-;;
-;; - Certificate[1] info:
-;; # valid since: Sun May 23 11:35:00 CEST 2004
-;; # expires at: Sun Jul 23 11:35:00 CEST 2023
-;; # serial number: 00
-;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae
-;; # version: #3
-;; # public key algorithm: RSA
-;; # Modulus: 1024 bits
-;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
-;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
-;;
-;; - Peer's certificate issuer is unknown
-;; - Peer's certificate is NOT trusted
-;; - Version: TLS 1.0
-;; - Key Exchange: RSA
-;; - Cipher: ARCFOUR 128
-;; - MAC: SHA
-;; - Compression: NULL
-
-;;; Code:
-
-(defgroup starttls nil
- "Support for `Transport Layer Security' protocol."
- :version "21.1"
- :group 'mail)
-
-(defcustom starttls-gnutls-program "gnutls-cli"
- "Name of GnuTLS command line tool.
-This program is used when GnuTLS is used, i.e. when
-`starttls-use-gnutls' is non-nil."
- :version "22.1"
- :type 'string
- :group 'starttls)
-
-(defcustom starttls-program "starttls"
- "The program to run in a subprocess to open an TLSv1 connection.
-This program is used when the `starttls' command is used,
-i.e. when `starttls-use-gnutls' is nil."
- :type 'string
- :group 'starttls)
-
-(defcustom starttls-use-gnutls (not (executable-find starttls-program))
- "*Whether to use GnuTLS instead of the `starttls' command."
- :version "22.1"
- :type 'boolean
- :group 'starttls)
-
-(defcustom starttls-extra-args nil
- "Extra arguments to `starttls-program'.
-These apply when the `starttls' command is used, i.e. when
-`starttls-use-gnutls' is nil."
- :type '(repeat string)
- :group 'starttls)
-
-(defcustom starttls-extra-arguments nil
- "Extra arguments to `starttls-gnutls-program'.
-These apply when GnuTLS is used, i.e. when `starttls-use-gnutls' is non-nil.
-
-For example, non-TLS compliant servers may require
-'(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to
-find out which parameters are available."
- :version "22.1"
- :type '(repeat string)
- :group 'starttls)
-
-(defcustom starttls-process-connection-type nil
- "*Value for `process-connection-type' to use when starting STARTTLS process."
- :version "22.1"
- :type 'boolean
- :group 'starttls)
-
-(defcustom starttls-connect "- Simple Client Mode:\n\n"
- "*Regular expression indicating successful connection.
-The default is what GnuTLS's \"gnutls-cli\" outputs."
- ;; GnuTLS cli.c:main() prints this string when it is starting to run
- ;; in the application read/write phase. If the logic, or the string
- ;; itself, is modified, this must be updated.
- :version "22.1"
- :type 'regexp
- :group 'starttls)
-
-(defcustom starttls-failure "\\*\\*\\* Handshake has failed"
- "*Regular expression indicating failed TLS handshake.
-The default is what GnuTLS's \"gnutls-cli\" outputs."
- ;; GnuTLS cli.c:do_handshake() prints this string on failure. If the
- ;; logic, or the string itself, is modified, this must be updated.
- :version "22.1"
- :type 'regexp
- :group 'starttls)
-
-(defcustom starttls-success "- Compression: "
- "*Regular expression indicating completed TLS handshakes.
-The default is what GnuTLS's \"gnutls-cli\" outputs."
- ;; GnuTLS cli.c:do_handshake() calls, on success,
- ;; common.c:print_info(), that unconditionally print this string
- ;; last. If that logic, or the string itself, is modified, this
- ;; must be updated.
- :version "22.1"
- :type 'regexp
- :group 'starttls)
-
-(defun starttls-negotiate-gnutls (process)
- "Negotiate TLS on PROCESS opened by `open-starttls-stream'.
-This should typically only be done once. It typically returns a
-multi-line informational message with information about the
-handshake, or nil on failure."
- (let (buffer info old-max done-ok done-bad)
- (if (null (setq buffer (process-buffer process)))
- ;; XXX How to remove/extract the TLS negotiation junk?
- (signal-process (process-id process) 'SIGALRM)
- (with-current-buffer buffer
- (save-excursion
- (setq old-max (goto-char (point-max)))
- (signal-process (process-id process) 'SIGALRM)
- (while (and (processp process)
- (eq (process-status process) 'run)
- (save-excursion
- (goto-char old-max)
- (not (or (setq done-ok (re-search-forward
- starttls-success nil t))
- (setq done-bad (re-search-forward
- starttls-failure nil t))))))
- (accept-process-output process 1 100)
- (sit-for 0.1))
- (setq info (buffer-substring-no-properties old-max (point-max)))
- (delete-region old-max (point-max))
- (if (or (and done-ok (not done-bad))
- ;; Prevent mitm that fake success msg after failure msg.
- (and done-ok done-bad (< done-ok done-bad)))
- info
- (message "STARTTLS negotiation failed: %s" info)
- nil))))))
-
-(defun starttls-negotiate (process)
- (if starttls-use-gnutls
- (starttls-negotiate-gnutls process)
- (signal-process (process-id process) 'SIGALRM)))
-
-(defun starttls-open-stream-gnutls (name buffer host port)
- (message "Opening STARTTLS connection to `%s:%s'..." host port)
- (let* (done
- (old-max (with-current-buffer buffer (point-max)))
- (process-connection-type starttls-process-connection-type)
- (process (apply #'start-process name buffer
- starttls-gnutls-program "-s" host
- "-p" (if (integerp port)
- (int-to-string port)
- port)
- starttls-extra-arguments)))
- (set-process-query-on-exit-flag process nil)
- (while (and (processp process)
- (eq (process-status process) 'run)
- (with-current-buffer buffer
- (goto-char old-max)
- (not (setq done (re-search-forward
- starttls-connect nil t)))))
- (accept-process-output process 0 100)
- (sit-for 0.1))
- (if done
- (with-current-buffer buffer
- (delete-region old-max done))
- (delete-process process)
- (setq process nil))
- (message "Opening STARTTLS connection to `%s:%s'...%s"
- host port (if done "done" "failed"))
- process))
-
-;;;###autoload
-(defun starttls-open-stream (name buffer host port)
- "Open a TLS connection for a port to a host.
-Returns a subprocess object to represent the connection.
-Input and output work as for subprocesses; `delete-process' closes it.
-Args are NAME BUFFER HOST PORT.
-NAME is name for process. It is modified if necessary to make it unique.
-BUFFER is the buffer (or `buffer-name') to associate with the process.
- Process output goes at end of that buffer, unless you specify
- an output stream or filter function to handle the output.
- BUFFER may be also nil, meaning that this process is not associated
- with any buffer
-Third arg is name of the host to connect to, or its IP address.
-Fourth arg PORT is an integer specifying a port to connect to.
-If `starttls-use-gnutls' is nil, this may also be a service name, but
-GnuTLS requires a port number."
- (if starttls-use-gnutls
- (starttls-open-stream-gnutls name buffer host port)
- (message "Opening STARTTLS connection to `%s:%s'" host (format "%s" port))
- (let* ((process-connection-type starttls-process-connection-type)
- (process (apply #'start-process
- name buffer starttls-program
- host (format "%s" port)
- starttls-extra-args)))
- (set-process-query-on-exit-flag process nil)
- process)))
-
-(defun starttls-available-p ()
- "Say whether the STARTTLS programs are available."
- (and (not (memq system-type '(windows-nt ms-dos)))
- (executable-find (if starttls-use-gnutls
- starttls-gnutls-program
- starttls-program))))
-
-(defalias 'starttls-any-program-available 'starttls-available-p)
-(make-obsolete 'starttls-any-program-available 'starttls-available-p
- "2011-08-02")
-
-(provide 'starttls)
-
-;;; starttls.el ends here
+++ /dev/null
-;;; utf7.el --- UTF-7 encoding/decoding for Emacs -*-coding: utf-8;-*-
-
-;; Copyright (C) 1999-2016 Free Software Foundation, Inc.
-
-;; Author: Jon K Hellan <hellan@acm.org>
-;; Maintainer: bugs@gnus.org
-;; Keywords: mail
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; UTF-7 - A Mail-Safe Transformation Format of Unicode - RFC 2152
-;; This is a transformation format of Unicode that contains only 7-bit
-;; ASCII octets and is intended to be readable by humans in the limiting
-;; case that the document consists of characters from the US-ASCII
-;; repertoire.
-;; In short, runs of characters outside US-ASCII are encoded as base64
-;; inside delimiters.
-;; A variation of UTF-7 is specified in IMAP 4rev1 (RFC 2060) as the way
-;; to represent characters outside US-ASCII in mailbox names in IMAP.
-;; This library supports both variants, but the IMAP variation was the
-;; reason I wrote it.
-;; The routines convert UTF-7 -> UTF-16 (16 bit encoding of Unicode)
-;; -> current character set, and vice versa.
-;; However, until Emacs supports Unicode, the only Emacs character set
-;; supported here is ISO-8859.1, which can trivially be converted to/from
-;; Unicode.
-;; When decoding results in a character outside the Emacs character set,
-;; an error is thrown. It is up to the application to recover.
-
-;; UTF-7 should be done by providing a coding system. Mule-UCS does
-;; already, but I don't know if it does the IMAP version and it's not
-;; clear whether that should really be a coding system. The UTF-16
-;; part of the conversion can be done with coding systems available
-;; with Mule-UCS or some versions of Emacs. Unfortunately these were
-;; done wrongly (regarding handling of byte-order marks and how the
-;; variants were named), so we don't have a consistent name for the
-;; necessary coding system. The code below doesn't seem to DTRT
-;; generally. E.g.:
-;;
-;; (utf7-encode "a+£")
-;; => "a+ACsAow-"
-;;
-;; $ echo "a+£"|iconv -f utf-8 -t utf-7
-;; a+-+AKM
-;;
-;; -- fx
-
-
-;;; Code:
-
-(require 'base64)
-(eval-when-compile (require 'cl))
-(require 'mm-util)
-
-(defconst utf7-direct-encoding-chars " -%'-*,-[]-}"
- "Character ranges which do not need escaping in UTF-7.")
-
-(defconst utf7-imap-direct-encoding-chars
- (concat utf7-direct-encoding-chars "+\\~")
- "Character ranges which do not need escaping in the IMAP variant of UTF-7.")
-
-(defconst utf7-utf-16-coding-system
- (cond ((mm-coding-system-p 'utf-16-be-no-signature) ; Mule-UCS
- 'utf-16-be-no-signature)
- ((and (mm-coding-system-p 'utf-16-be) ; Emacs
- ;; Avoid versions with BOM.
- (= 2 (length (encode-coding-string "a" 'utf-16-be))))
- 'utf-16-be)
- ((mm-coding-system-p 'utf-16-be-nosig) ; ?
- 'utf-16-be-nosig))
- "Coding system which encodes big endian UTF-16 without a BOM signature.")
-
-(defsubst utf7-imap-get-pad-length (len modulus)
- "Return required length of padding for IMAP modified base64 fragment."
- (mod (- len) modulus))
-
-(defun utf7-encode-internal (&optional for-imap)
- "Encode text in (temporary) buffer as UTF-7.
-Use IMAP modification if FOR-IMAP is non-nil."
- (let ((start (point-min))
- (end (point-max)))
- (narrow-to-region start end)
- (goto-char start)
- (let* ((esc-char (if for-imap ?& ?+))
- (direct-encoding-chars
- (if for-imap utf7-imap-direct-encoding-chars
- utf7-direct-encoding-chars))
- (not-direct-encoding-chars (concat "^" direct-encoding-chars)))
- (while (not (eobp))
- (skip-chars-forward direct-encoding-chars)
- (unless (eobp)
- (insert esc-char)
- (let ((p (point))
- (fc (following-char))
- (run-length
- (skip-chars-forward not-direct-encoding-chars)))
- (if (and (= fc esc-char)
- (= run-length 1)) ; Lone esc-char?
- (delete-char -1) ; Now there's one too many
- (utf7-fragment-encode p (point) for-imap))
- (insert "-")))))))
-
-(defun utf7-fragment-encode (start end &optional for-imap)
- "Encode text from START to END in buffer as UTF-7 escape fragment.
-Use IMAP modification if FOR-IMAP is non-nil."
- (save-restriction
- (let* ((buf (current-buffer))
- (base (with-temp-buffer
- (set-buffer-multibyte nil)
- (insert-buffer-substring buf start end)
- (funcall (utf7-get-u16char-converter 'to-utf-16))
- (base64-encode-region (point-min) (point-max))
- (buffer-string))))
- (narrow-to-region start end)
- (delete-region (point-min) (point-max))
- (insert base))
- (goto-char (point-min))
- (let ((pm (point-max)))
- (when for-imap
- (while (search-forward "/" nil t)
- (replace-match ",")))
- (skip-chars-forward "^= \t\n" pm)
- (delete-region (point) pm))))
-
-(defun utf7-decode-internal (&optional for-imap)
- "Decode UTF-7 text in (temporary) buffer.
-Use IMAP modification if FOR-IMAP is non-nil."
- (let ((start (point-min))
- (end (point-max)))
- (goto-char start)
- (let* ((esc-pattern (concat "^" (char-to-string (if for-imap ?& ?+))))
- (base64-chars (concat "A-Za-z0-9+"
- (char-to-string (if for-imap ?, ?/)))))
- (while (not (eobp))
- (skip-chars-forward esc-pattern)
- (unless (eobp)
- (forward-char)
- (let ((p (point))
- (run-length (skip-chars-forward base64-chars)))
- (when (and (not (eobp)) (= (following-char) ?-))
- (delete-char 1))
- (unless (= run-length 0) ; Encoded lone esc-char?
- (save-excursion
- (utf7-fragment-decode p (point) for-imap)
- (goto-char p)
- (delete-char -1)))))))))
-
-(defun utf7-fragment-decode (start end &optional for-imap)
- "Decode base64 encoded fragment from START to END of UTF-7 text in buffer.
-Use IMAP modification if FOR-IMAP is non-nil."
- (save-restriction
- (narrow-to-region start end)
- (when for-imap
- (goto-char start)
- (while (search-forward "," nil 'move-to-end) (replace-match "/")))
- (let ((pl (utf7-imap-get-pad-length (- end start) 4)))
- (insert (make-string pl ?=))
- (base64-decode-region start (+ end pl)))
- (funcall (utf7-get-u16char-converter 'from-utf-16))))
-
-(defun utf7-get-u16char-converter (which-way)
- "Return a function to convert between UTF-16 and current character set."
- (if utf7-utf-16-coding-system
- (if (eq which-way 'to-utf-16)
- (lambda ()
- (encode-coding-region (point-min) (point-max)
- utf7-utf-16-coding-system))
- (lambda ()
- (decode-coding-region (point-min) (point-max)
- utf7-utf-16-coding-system)))
- ;; Add test to check if we are really Latin-1.
- (if (eq which-way 'to-utf-16)
- 'utf7-latin1-u16-char-converter
- 'utf7-u16-latin1-char-converter)))
-
-(defun utf7-latin1-u16-char-converter ()
- "Convert latin 1 (ISO-8859.1) characters to 16 bit Unicode.
-Characters are converted to raw byte pairs in narrowed buffer."
- (encode-coding-region (point-min) (point-max) 'iso-8859-1)
- (goto-char (point-min))
- (while (not (eobp))
- (insert 0)
- (forward-char)))
-
-(defun utf7-u16-latin1-char-converter ()
- "Convert 16 bit Unicode characters to latin 1 (ISO-8859.1).
-Characters are in raw byte pairs in narrowed buffer."
- (goto-char (point-min))
- (while (not (eobp))
- (if (= 0 (following-char))
- (delete-char 1)
- (error "Unable to convert from Unicode"))
- (forward-char))
- (decode-coding-region (point-min) (point-max) 'iso-8859-1)
- (mm-enable-multibyte))
-
-;;;###autoload
-(defun utf7-encode (string &optional for-imap)
- "Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil."
- (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap))
- ;; Emacs 23 with proper support for IMAP
- (encode-coding-string string (if for-imap 'utf-7-imap 'utf-7))
- (mm-with-multibyte-buffer
- (insert string)
- (utf7-encode-internal for-imap)
- (buffer-string))))
-
-(defun utf7-decode (string &optional for-imap)
- "Decode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil."
- (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap))
- ;; Emacs 23 with proper support for IMAP
- (decode-coding-string string (if for-imap 'utf-7-imap 'utf-7))
- (mm-with-unibyte-buffer
- (insert string)
- (utf7-decode-internal for-imap)
- (mm-enable-multibyte)
- (buffer-string))))
-
-(provide 'utf7)
-
-;;; utf7.el ends here
+++ /dev/null
-;;; yenc.el --- elisp native yenc decoder
-
-;; Copyright (C) 2002-2016 Free Software Foundation, Inc.
-
-;; Author: Jesper Harder <harder@ifa.au.dk>
-;; Keywords: yenc news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Functions for decoding yenc encoded messages.
-;;
-;; Limitations:
-;;
-;; * Does not handle multipart messages.
-;; * No support for external decoders.
-;; * Doesn't check the crc32 checksum (if present).
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-
-(defconst yenc-begin-line
- "^=ybegin.*$")
-
-(defconst yenc-decoding-vector
- [214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230
- 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
- 248 249 250 251 252 253 254 255 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
- 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
- 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
- 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
- 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
- 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
- 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139
- 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
- 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173
- 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190
- 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
- 208 209 210 211 212 213])
-
-(defun yenc-first-part-p ()
- "Say whether the buffer contains the first part of a yEnc file."
- (save-excursion
- (goto-char (point-min))
- (re-search-forward "^=ybegin part=1 " nil t)))
-
-(defun yenc-last-part-p ()
- "Say whether the buffer contains the last part of a yEnc file."
- (save-excursion
- (goto-char (point-min))
- (let (total-size end-size)
- (when (re-search-forward "^=ybegin.*size=\\([0-9]+\\)" nil t)
- (setq total-size (match-string 1)))
- (when (re-search-forward "^=ypart.*end=\\([0-9]+\\)" nil t)
- (setq end-size (match-string 1)))
- (and total-size
- end-size
- (string= total-size end-size)))))
-
-;;;###autoload
-(defun yenc-decode-region (start end)
- "Yenc decode region between START and END using an internal decoder."
- (interactive "r")
- (let (work-buffer)
- (unwind-protect
- (save-excursion
- (goto-char start)
- (when (re-search-forward yenc-begin-line end t)
- (let ((first (match-end 0))
- (header-alist (yenc-parse-line (match-string 0)))
- bytes last footer-alist char)
- (when (re-search-forward "^=ypart.*$" end t)
- (setq first (match-end 0)))
- (when (re-search-forward "^=yend.*$" end t)
- (setq last (match-beginning 0))
- (setq footer-alist (yenc-parse-line (match-string 0)))
- (setq work-buffer (generate-new-buffer " *yenc-work*"))
- (with-current-buffer work-buffer
- (set-buffer-multibyte nil))
- (while (< first last)
- (setq char (char-after first))
- (cond ((or (eq char ?\r)
- (eq char ?\n)))
- ((eq char ?=)
- (setq char (char-after (incf first)))
- (with-current-buffer work-buffer
- (insert-char (mod (- char 106) 256) 1)))
- (t
- (with-current-buffer work-buffer
- ;;(insert-char (mod (- char 42) 256) 1)
- (insert-char (aref yenc-decoding-vector char) 1))))
- (incf first))
- (setq bytes (buffer-size work-buffer))
- (unless (and (= (cdr (assq 'size header-alist)) bytes)
- (= (cdr (assq 'size footer-alist)) bytes))
- (message "Warning: Size mismatch while decoding."))
- (goto-char start)
- (delete-region start end)
- (insert-buffer-substring work-buffer))))
- (and work-buffer (kill-buffer work-buffer))))))
-
-;;;###autoload
-(defun yenc-extract-filename ()
- "Extract file name from an yenc header."
- (save-excursion
- (when (re-search-forward yenc-begin-line nil t)
- (cdr (assoc 'name (yenc-parse-line (match-string 0)))))))
-
-(defun yenc-parse-line (str)
- "Extract file name and size from STR."
- (let (result name)
- (when (string-match "^=y.*size=\\([0-9]+\\)" str)
- (push (cons 'size (string-to-number (match-string 1 str))) result))
- (when (string-match "^=y.*name=\\(.*\\)$" str)
- (setq name (match-string 1 str))
- ;; Remove trailing white space
- (when (string-match " +$" name)
- (setq name (substring name 0 (match-beginning 0))))
- (push (cons 'name name) result))
- result))
-
-(provide 'yenc)
-
-;;; yenc.el ends here
--- /dev/null
+;;; compface.el --- functions for converting X-Face headers
+
+;; Copyright (C) 2002-2016 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+;;;###
+(defun uncompface (face)
+ "Convert FACE to pbm.
+Requires the external programs `uncompface', and `icontopbm'. On a
+GNU/Linux system these might be in packages with names like `compface'
+or `faces-xface' and `netpbm' or `libgr-progs', for instance."
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert face)
+ (let ((coding-system-for-read 'raw-text)
+ ;; At least "icontopbm" doesn't work with Windows because
+ ;; the line-break code is converted into CRLF by default.
+ (coding-system-for-write 'binary))
+ (and (eq 0 (apply 'call-process-region (point-min) (point-max)
+ "uncompface"
+ 'delete '(t nil) nil))
+ (progn
+ (goto-char (point-min))
+ (insert "/* Format_version=1, Width=48, Height=48, Depth=1,\
+ Valid_bits_per_item=16 */\n")
+ ;; Emacs doesn't understand un-raw pbm files.
+ (eq 0 (call-process-region (point-min) (point-max)
+ "icontopbm"
+ 'delete '(t nil))))
+ (buffer-string)))))
+
+(provide 'compface)
+
+;;; compface.el ends here
--- /dev/null
+;;; gravatar.el --- Get Gravatars
+
+;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
+
+;; Author: Julien Danjou <julien@danjou.info>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'url)
+(require 'url-cache)
+(require 'image)
+
+(defgroup gravatar nil
+ "Gravatar."
+ :version "24.1"
+ :group 'comm)
+
+(defcustom gravatar-automatic-caching t
+ "Whether to cache retrieved gravatars."
+ :type 'boolean
+ :group 'gravatar)
+
+;; FIXME a time value is not the nicest format for a custom variable.
+(defcustom gravatar-cache-ttl (days-to-time 30)
+ "Time to live for gravatar cache entries."
+ :type '(repeat integer)
+ :group 'gravatar)
+
+;; FIXME Doc is tautological. What are the options?
+(defcustom gravatar-rating "g"
+ "Default rating for gravatar."
+ :type 'string
+ :group 'gravatar)
+
+(defcustom gravatar-size 32
+ "Default size in pixels for gravatars."
+ :type 'integer
+ :group 'gravatar)
+
+(defconst gravatar-base-url
+ "http://www.gravatar.com/avatar"
+ "Base URL for getting gravatars.")
+
+(defun gravatar-hash (mail-address)
+ "Create an hash from MAIL-ADDRESS."
+ (md5 (downcase mail-address)))
+
+(defun gravatar-build-url (mail-address)
+ "Return an URL to retrieve MAIL-ADDRESS gravatar."
+ (format "%s/%s?d=404&r=%s&s=%d"
+ gravatar-base-url
+ (gravatar-hash mail-address)
+ gravatar-rating
+ gravatar-size))
+
+(defun gravatar-cache-expired (url)
+ "Check if URL is cached for more than `gravatar-cache-ttl'."
+ (cond (url-standalone-mode
+ (not (file-exists-p (url-cache-create-filename url))))
+ (t (let ((cache-time (url-is-cached url)))
+ (if cache-time
+ (time-less-p
+ (time-add
+ cache-time
+ gravatar-cache-ttl)
+ (current-time))
+ t)))))
+
+(defun gravatar-get-data ()
+ "Get data from current buffer."
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward "^HTTP/.+ 200 OK$" nil (line-end-position))
+ (when (search-forward "\n\n" nil t)
+ (buffer-substring (point) (point-max))))))
+
+(defun gravatar-data->image ()
+ "Get data of current buffer and return an image.
+If no image available, return 'error."
+ (let ((data (gravatar-get-data)))
+ (if data
+ (create-image data nil t)
+ 'error)))
+
+(autoload 'help-function-arglist "help-fns")
+
+;;;###autoload
+(defun gravatar-retrieve (mail-address cb &optional cbargs)
+ "Retrieve MAIL-ADDRESS gravatar and call CB on retrieval.
+You can provide a list of argument to pass to CB in CBARGS."
+ (let ((url (gravatar-build-url mail-address)))
+ (if (gravatar-cache-expired url)
+ (let ((args (list url
+ 'gravatar-retrieved
+ (list cb (when cbargs cbargs)))))
+ (when (> (length (if (featurep 'xemacs)
+ (cdr (split-string (function-arglist 'url-retrieve)))
+ (help-function-arglist 'url-retrieve)))
+ 4)
+ (setq args (nconc args (list t))))
+ (apply #'url-retrieve args))
+ (apply cb
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (url-cache-extract (url-cache-create-filename url))
+ (gravatar-data->image))
+ cbargs))))
+
+;;;###autoload
+(defun gravatar-retrieve-synchronously (mail-address)
+ "Retrieve MAIL-ADDRESS gravatar and returns it."
+ (let ((url (gravatar-build-url mail-address)))
+ (if (gravatar-cache-expired url)
+ (with-current-buffer (url-retrieve-synchronously url)
+ (when gravatar-automatic-caching
+ (url-store-in-cache (current-buffer)))
+ (let ((data (gravatar-data->image)))
+ (kill-buffer (current-buffer))
+ data))
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (url-cache-extract (url-cache-create-filename url))
+ (gravatar-data->image)))))
+
+
+(defun gravatar-retrieved (status cb &optional cbargs)
+ "Callback function used by `gravatar-retrieve'."
+ ;; Store gravatar?
+ (when gravatar-automatic-caching
+ (url-store-in-cache (current-buffer)))
+ (if (plist-get status :error)
+ ;; Error happened.
+ (apply cb 'error cbargs)
+ (apply cb (gravatar-data->image) cbargs))
+ (kill-buffer (current-buffer)))
+
+(provide 'gravatar)
+
+;;; gravatar.el ends here
--- /dev/null
+;;; rfc1843.el --- HZ (rfc1843) decoding
+
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
+
+;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
+;; Keywords: news HZ HZ+ mail i18n
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Test:
+;; (rfc1843-decode-string "~{<:Ky2;S{#,NpJ)l6HK!#~}")
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(defvar rfc1843-word-regexp
+ "~\\({\\([\041-\167][\041-\176]\\| \\)+\\)\\(~}\\|$\\)")
+
+(defvar rfc1843-word-regexp-strictly
+ "~\\({\\([\041-\167][\041-\176]\\)+\\)\\(~}\\|$\\)")
+
+(defvar rfc1843-hzp-word-regexp
+ "~\\({\\([\041-\167][\041-\176]\\| \\)+\\|\
+[<>]\\([\041-\175][\041-\176]\\| \\)+\\)\\(~}\\|$\\)")
+
+(defvar rfc1843-hzp-word-regexp-strictly
+ "~\\({\\([\041-\167][\041-\176]\\)+\\|\
+[<>]\\([\041-\175][\041-\176]\\)+\\)\\(~}\\|$\\)")
+
+(defcustom rfc1843-decode-loosely nil
+ "Loosely check HZ encoding if non-nil.
+When it is set non-nil, only buffers or strings with strictly
+HZ-encoded are decoded."
+ :type 'boolean
+ :group 'mime)
+
+(defcustom rfc1843-decode-hzp t
+ "HZ+ decoding support if non-nil.
+HZ+ specification (also known as HZP) is to provide a standardized
+7-bit representation of mixed Big5, GB, and ASCII text for convenient
+e-mail transmission, news posting, etc.
+The document of HZ+ 0.78 specification can be found at
+ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc"
+ :type 'boolean
+ :group 'mime)
+
+(defcustom rfc1843-newsgroups-regexp "chinese\\|hz"
+ "Regexp of newsgroups in which might be HZ encoded."
+ :type 'string
+ :group 'mime)
+
+(defun rfc1843-decode-region (from to)
+ "Decode HZ in the region between FROM and TO."
+ (interactive "r")
+ (let (str firstc)
+ (save-excursion
+ (goto-char from)
+ (if (or rfc1843-decode-loosely
+ (re-search-forward (if rfc1843-decode-hzp
+ rfc1843-hzp-word-regexp-strictly
+ rfc1843-word-regexp-strictly) to t))
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (re-search-forward (if rfc1843-decode-hzp
+ rfc1843-hzp-word-regexp
+ rfc1843-word-regexp) (point-max) t)
+ (setq str (buffer-substring-no-properties
+ (match-beginning 1)
+ (match-end 1)))
+ (setq firstc (aref str 0))
+ (insert (decode-coding-string
+ (rfc1843-decode
+ (prog1
+ (substring str 1)
+ (delete-region (match-beginning 0) (match-end 0)))
+ firstc)
+ (if (eq firstc ?{) 'cn-gb-2312 'cn-big5))))
+ (goto-char (point-min))
+ (while (search-forward "~" (point-max) t)
+ (cond ((eq (char-after) ?\n)
+ (delete-char -1)
+ (delete-char 1))
+ ((eq (char-after) ?~)
+ (delete-char 1)))))))))
+
+(defun rfc1843-decode-string (string)
+ "Decode HZ STRING and return the results."
+ (let ((m enable-multibyte-characters))
+ (with-temp-buffer
+ (when m
+ (set-buffer-multibyte 'to))
+ (insert string)
+ (inline
+ (rfc1843-decode-region (point-min) (point-max)))
+ (buffer-string))))
+
+(defun rfc1843-decode (word &optional firstc)
+ "Decode HZ WORD and return it."
+ (let ((i -1) (s (substring word 0)) v)
+ (if (or (not firstc) (eq firstc ?{))
+ (while (< (incf i) (length s))
+ (if (eq (setq v (aref s i)) ? ) nil
+ (aset s i (+ 128 v))))
+ (while (< (incf i) (length s))
+ (if (eq (setq v (aref s i)) ? ) nil
+ (setq v (+ (* 94 v) (aref s (1+ i)) -3135))
+ (aset s i (+ (/ v 157) (if (eq firstc ?<) 201 161)))
+ (setq v (% v 157))
+ (aset s (incf i) (+ v (if (< v 63) 64 98))))))
+ s))
+
+(provide 'rfc1843)
+
+;;; rfc1843.el ends here
--- /dev/null
+;;; utf7.el --- UTF-7 encoding/decoding for Emacs -*-coding: utf-8;-*-
+
+;; Copyright (C) 1999-2016 Free Software Foundation, Inc.
+
+;; Author: Jon K Hellan <hellan@acm.org>
+;; Maintainer: bugs@gnus.org
+;; Keywords: mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; UTF-7 - A Mail-Safe Transformation Format of Unicode - RFC 2152
+;; This is a transformation format of Unicode that contains only 7-bit
+;; ASCII octets and is intended to be readable by humans in the limiting
+;; case that the document consists of characters from the US-ASCII
+;; repertoire.
+;; In short, runs of characters outside US-ASCII are encoded as base64
+;; inside delimiters.
+;; A variation of UTF-7 is specified in IMAP 4rev1 (RFC 2060) as the way
+;; to represent characters outside US-ASCII in mailbox names in IMAP.
+;; This library supports both variants, but the IMAP variation was the
+;; reason I wrote it.
+;; The routines convert UTF-7 -> UTF-16 (16 bit encoding of Unicode)
+;; -> current character set, and vice versa.
+;; However, until Emacs supports Unicode, the only Emacs character set
+;; supported here is ISO-8859.1, which can trivially be converted to/from
+;; Unicode.
+;; When decoding results in a character outside the Emacs character set,
+;; an error is thrown. It is up to the application to recover.
+
+;; UTF-7 should be done by providing a coding system. Mule-UCS does
+;; already, but I don't know if it does the IMAP version and it's not
+;; clear whether that should really be a coding system. The UTF-16
+;; part of the conversion can be done with coding systems available
+;; with Mule-UCS or some versions of Emacs. Unfortunately these were
+;; done wrongly (regarding handling of byte-order marks and how the
+;; variants were named), so we don't have a consistent name for the
+;; necessary coding system. The code below doesn't seem to DTRT
+;; generally. E.g.:
+;;
+;; (utf7-encode "a+£")
+;; => "a+ACsAow-"
+;;
+;; $ echo "a+£"|iconv -f utf-8 -t utf-7
+;; a+-+AKM
+;;
+;; -- fx
+
+
+;;; Code:
+
+(require 'base64)
+(eval-when-compile (require 'cl))
+(require 'mm-util)
+
+(defconst utf7-direct-encoding-chars " -%'-*,-[]-}"
+ "Character ranges which do not need escaping in UTF-7.")
+
+(defconst utf7-imap-direct-encoding-chars
+ (concat utf7-direct-encoding-chars "+\\~")
+ "Character ranges which do not need escaping in the IMAP variant of UTF-7.")
+
+(defconst utf7-utf-16-coding-system
+ (cond ((mm-coding-system-p 'utf-16-be-no-signature) ; Mule-UCS
+ 'utf-16-be-no-signature)
+ ((and (mm-coding-system-p 'utf-16-be) ; Emacs
+ ;; Avoid versions with BOM.
+ (= 2 (length (encode-coding-string "a" 'utf-16-be))))
+ 'utf-16-be)
+ ((mm-coding-system-p 'utf-16-be-nosig) ; ?
+ 'utf-16-be-nosig))
+ "Coding system which encodes big endian UTF-16 without a BOM signature.")
+
+(defsubst utf7-imap-get-pad-length (len modulus)
+ "Return required length of padding for IMAP modified base64 fragment."
+ (mod (- len) modulus))
+
+(defun utf7-encode-internal (&optional for-imap)
+ "Encode text in (temporary) buffer as UTF-7.
+Use IMAP modification if FOR-IMAP is non-nil."
+ (let ((start (point-min))
+ (end (point-max)))
+ (narrow-to-region start end)
+ (goto-char start)
+ (let* ((esc-char (if for-imap ?& ?+))
+ (direct-encoding-chars
+ (if for-imap utf7-imap-direct-encoding-chars
+ utf7-direct-encoding-chars))
+ (not-direct-encoding-chars (concat "^" direct-encoding-chars)))
+ (while (not (eobp))
+ (skip-chars-forward direct-encoding-chars)
+ (unless (eobp)
+ (insert esc-char)
+ (let ((p (point))
+ (fc (following-char))
+ (run-length
+ (skip-chars-forward not-direct-encoding-chars)))
+ (if (and (= fc esc-char)
+ (= run-length 1)) ; Lone esc-char?
+ (delete-char -1) ; Now there's one too many
+ (utf7-fragment-encode p (point) for-imap))
+ (insert "-")))))))
+
+(defun utf7-fragment-encode (start end &optional for-imap)
+ "Encode text from START to END in buffer as UTF-7 escape fragment.
+Use IMAP modification if FOR-IMAP is non-nil."
+ (save-restriction
+ (let* ((buf (current-buffer))
+ (base (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert-buffer-substring buf start end)
+ (funcall (utf7-get-u16char-converter 'to-utf-16))
+ (base64-encode-region (point-min) (point-max))
+ (buffer-string))))
+ (narrow-to-region start end)
+ (delete-region (point-min) (point-max))
+ (insert base))
+ (goto-char (point-min))
+ (let ((pm (point-max)))
+ (when for-imap
+ (while (search-forward "/" nil t)
+ (replace-match ",")))
+ (skip-chars-forward "^= \t\n" pm)
+ (delete-region (point) pm))))
+
+(defun utf7-decode-internal (&optional for-imap)
+ "Decode UTF-7 text in (temporary) buffer.
+Use IMAP modification if FOR-IMAP is non-nil."
+ (let ((start (point-min))
+ (end (point-max)))
+ (goto-char start)
+ (let* ((esc-pattern (concat "^" (char-to-string (if for-imap ?& ?+))))
+ (base64-chars (concat "A-Za-z0-9+"
+ (char-to-string (if for-imap ?, ?/)))))
+ (while (not (eobp))
+ (skip-chars-forward esc-pattern)
+ (unless (eobp)
+ (forward-char)
+ (let ((p (point))
+ (run-length (skip-chars-forward base64-chars)))
+ (when (and (not (eobp)) (= (following-char) ?-))
+ (delete-char 1))
+ (unless (= run-length 0) ; Encoded lone esc-char?
+ (save-excursion
+ (utf7-fragment-decode p (point) for-imap)
+ (goto-char p)
+ (delete-char -1)))))))))
+
+(defun utf7-fragment-decode (start end &optional for-imap)
+ "Decode base64 encoded fragment from START to END of UTF-7 text in buffer.
+Use IMAP modification if FOR-IMAP is non-nil."
+ (save-restriction
+ (narrow-to-region start end)
+ (when for-imap
+ (goto-char start)
+ (while (search-forward "," nil 'move-to-end) (replace-match "/")))
+ (let ((pl (utf7-imap-get-pad-length (- end start) 4)))
+ (insert (make-string pl ?=))
+ (base64-decode-region start (+ end pl)))
+ (funcall (utf7-get-u16char-converter 'from-utf-16))))
+
+(defun utf7-get-u16char-converter (which-way)
+ "Return a function to convert between UTF-16 and current character set."
+ (if utf7-utf-16-coding-system
+ (if (eq which-way 'to-utf-16)
+ (lambda ()
+ (encode-coding-region (point-min) (point-max)
+ utf7-utf-16-coding-system))
+ (lambda ()
+ (decode-coding-region (point-min) (point-max)
+ utf7-utf-16-coding-system)))
+ ;; Add test to check if we are really Latin-1.
+ (if (eq which-way 'to-utf-16)
+ 'utf7-latin1-u16-char-converter
+ 'utf7-u16-latin1-char-converter)))
+
+(defun utf7-latin1-u16-char-converter ()
+ "Convert latin 1 (ISO-8859.1) characters to 16 bit Unicode.
+Characters are converted to raw byte pairs in narrowed buffer."
+ (encode-coding-region (point-min) (point-max) 'iso-8859-1)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (insert 0)
+ (forward-char)))
+
+(defun utf7-u16-latin1-char-converter ()
+ "Convert 16 bit Unicode characters to latin 1 (ISO-8859.1).
+Characters are in raw byte pairs in narrowed buffer."
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (= 0 (following-char))
+ (delete-char 1)
+ (error "Unable to convert from Unicode"))
+ (forward-char))
+ (decode-coding-region (point-min) (point-max) 'iso-8859-1)
+ (mm-enable-multibyte))
+
+;;;###autoload
+(defun utf7-encode (string &optional for-imap)
+ "Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil."
+ (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap))
+ ;; Emacs 23 with proper support for IMAP
+ (encode-coding-string string (if for-imap 'utf-7-imap 'utf-7))
+ (mm-with-multibyte-buffer
+ (insert string)
+ (utf7-encode-internal for-imap)
+ (buffer-string))))
+
+(defun utf7-decode (string &optional for-imap)
+ "Decode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil."
+ (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap))
+ ;; Emacs 23 with proper support for IMAP
+ (decode-coding-string string (if for-imap 'utf-7-imap 'utf-7))
+ (mm-with-unibyte-buffer
+ (insert string)
+ (utf7-decode-internal for-imap)
+ (mm-enable-multibyte)
+ (buffer-string))))
+
+(provide 'utf7)
+
+;;; utf7.el ends here
--- /dev/null
+;;; flow-fill.el --- interpret RFC2646 "flowed" text
+
+;; Copyright (C) 2000-2016 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <jas@pdc.kth.se>
+;; Keywords: mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This implement decoding of RFC2646 formatted text, including the
+;; quoted-depth wins rules.
+
+;; Theory of operation: search for lines ending with SPC, save quote
+;; length of line, remove SPC and concatenate line with the following
+;; line if quote length of following line matches current line.
+
+;; When no further concatenations are possible, we've found a
+;; paragraph and we let `fill-region' fill the long line into several
+;; lines with the quote prefix as `fill-prefix'.
+
+;; Todo: implement basic `fill-region' (Emacs and XEmacs
+;; implementations differ..)
+
+;;; History:
+
+;; 2000-02-17 posted on ding mailing list
+;; 2000-02-19 use `point-at-{b,e}ol' in XEmacs
+;; 2000-03-11 no compile warnings for point-at-bol stuff
+;; 2000-03-26 committed to gnus cvs
+;; 2000-10-23 don't flow "-- " lines, make "quote-depth wins" rule
+;; work when first line is at level 0.
+;; 2002-01-12 probably incomplete encoding support
+;; 2003-12-08 started working on test harness.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(defcustom fill-flowed-display-column 'fill-column
+ "Column beyond which format=flowed lines are wrapped, when displayed.
+This can be a Lisp expression or an integer."
+ :version "22.1"
+ :group 'mime-display
+ :type '(choice (const :tag "Standard `fill-column'" fill-column)
+ (const :tag "Fit Window" (- (window-width) 5))
+ (sexp)
+ (integer)))
+
+(defcustom fill-flowed-encode-column 66
+ "Column beyond which format=flowed lines are wrapped, in outgoing messages.
+This can be a Lisp expression or an integer.
+RFC 2646 suggests 66 characters for readability."
+ :version "22.1"
+ :group 'mime-display
+ :type '(choice (const :tag "Standard fill-column" fill-column)
+ (const :tag "RFC 2646 default (66)" 66)
+ (sexp)
+ (integer)))
+
+;;;###autoload
+(defun fill-flowed-encode (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ ;; No point in doing this unless hard newlines is used.
+ (when use-hard-newlines
+ (let ((start (point-min)) end)
+ ;; Go through each paragraph, filling it and adding SPC
+ ;; as the last character on each line.
+ (while (setq end (text-property-any start (point-max) 'hard 't))
+ (save-restriction
+ (narrow-to-region start end)
+ (let ((fill-column (eval fill-flowed-encode-column)))
+ (fill-flowed-fill-buffer))
+ (goto-char (point-min))
+ (while (re-search-forward "\n" nil t)
+ (replace-match " \n" t t))
+ (goto-char (setq start (1+ (point-max)))))))
+ t)))
+
+(defun fill-flowed-fill-buffer ()
+ (let ((prefix nil)
+ (prev-prefix nil)
+ (start (point-min)))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq prefix (and (looking-at "[> ]+")
+ (match-string 0)))
+ (if (equal prefix prev-prefix)
+ (forward-line 1)
+ (save-restriction
+ (narrow-to-region start (point))
+ (let ((fill-prefix prev-prefix))
+ (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop))
+ (goto-char (point-max)))
+ (setq prev-prefix prefix
+ start (point))))
+ (save-restriction
+ (narrow-to-region start (point))
+ (let ((fill-prefix prev-prefix))
+ (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop)))))
+
+;;;###autoload
+(defun fill-flowed (&optional buffer delete-space)
+ (with-current-buffer (or (current-buffer) buffer)
+ (goto-char (point-min))
+ ;; Remove space stuffing.
+ (while (re-search-forward "^\\( \\|>+ $\\)" nil t)
+ (delete-char -1)
+ (forward-line 1))
+ (goto-char (point-min))
+ (while (re-search-forward " $" nil t)
+ (when (save-excursion
+ (beginning-of-line)
+ (looking-at "^\\(>*\\)\\( ?\\)"))
+ (let ((quote (match-string 1))
+ sig)
+ (if (string= quote "")
+ (setq quote nil))
+ (when (and quote (string= (match-string 2) ""))
+ (save-excursion
+ ;; insert SP after quote for pleasant reading of quoted lines
+ (beginning-of-line)
+ (when (> (skip-chars-forward ">") 0)
+ (insert " "))))
+ ;; XXX slightly buggy handling of "-- "
+ (while (and (save-excursion
+ (ignore-errors (backward-char 3))
+ (setq sig (looking-at "-- "))
+ (looking-at "[^-][^-] "))
+ (save-excursion
+ (unless (eobp)
+ (forward-char 1)
+ (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)"
+ (or quote " ?"))))))
+ (save-excursion
+ (replace-match (if (string= (match-string 2) " ")
+ "" "\\2")))
+ (backward-delete-char -1)
+ (when delete-space
+ (delete-char -1))
+ (end-of-line))
+ (unless sig
+ (condition-case nil
+ (let ((fill-prefix (when quote (concat quote " ")))
+ (fill-column (eval fill-flowed-display-column))
+ adaptive-fill-mode)
+ (fill-region (point-at-bol)
+ (min (1+ (point-at-eol))
+ (point-max))
+ 'left 'nosqueeze))
+ (error
+ (forward-line 1)
+ nil))))))))
+
+;; Test vectors.
+
+(defvar show-trailing-whitespace)
+
+(defvar fill-flowed-encode-tests
+ `(
+ ;; The syntax of each list element is:
+ ;; (INPUT . EXPECTED-OUTPUT)
+ (,(concat
+ "> Thou villainous ill-breeding spongy dizzy-eyed \n"
+ "> reeky elf-skinned pigeon-egg! \n"
+ ">> Thou artless swag-bellied milk-livered \n"
+ ">> dismal-dreaming idle-headed scut!\n"
+ ">>> Thou errant folly-fallen spleeny reeling-ripe \n"
+ ">>> unmuzzled ratsbane!\n"
+ ">>>> Henceforth, the coding style is to be strictly \n"
+ ">>>> enforced, including the use of only upper case.\n"
+ ">>>>> I've noticed a lack of adherence to the coding \n"
+ ">>>>> styles, of late.\n"
+ ">>>>>> Any complaints?")
+ .
+ ,(concat
+ "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned\n"
+ "> pigeon-egg! \n"
+ ">> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed\n"
+ ">> scut!\n"
+ ">>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!\n"
+ ">>>> Henceforth, the coding style is to be strictly enforced,\n"
+ ">>>> including the use of only upper case.\n"
+ ">>>>> I've noticed a lack of adherence to the coding styles, of late.\n"
+ ">>>>>> Any complaints?\n"
+ ))
+ ;; (,(concat
+ ;; "\n"
+ ;; "> foo\n"
+ ;; "> \n"
+ ;; "> \n"
+ ;; "> bar\n")
+ ;; .
+ ;; ,(concat
+ ;; "\n"
+ ;; "> foo bar\n"))
+ ))
+
+(defun fill-flowed-test ()
+ (interactive "")
+ (switch-to-buffer (get-buffer-create "*Format=Flowed test output*"))
+ (erase-buffer)
+ (setq show-trailing-whitespace t)
+ (dolist (test fill-flowed-encode-tests)
+ (let (start output)
+ (insert "***** BEGIN TEST INPUT *****\n")
+ (insert (car test))
+ (insert "***** END TEST INPUT *****\n\n")
+ (insert "***** BEGIN TEST OUTPUT *****\n")
+ (setq start (point))
+ (insert (car test))
+ (save-restriction
+ (narrow-to-region start (point))
+ (fill-flowed))
+ (setq output (buffer-substring start (point-max)))
+ (insert "***** END TEST OUTPUT *****\n")
+ (unless (string= output (cdr test))
+ (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n")
+ (insert (cdr test))
+ (insert "***** END TEST EXPECTED OUTPUT *****\n"))
+ (insert "\n\n")))
+ (goto-char (point-max)))
+
+(provide 'flow-fill)
+
+;;; flow-fill.el ends here
--- /dev/null
+;;; ietf-drums.el --- Functions for parsing RFC822bis headers
+
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; DRUMS is an IETF Working Group that works (or worked) on the
+;; successor to RFC822, "Standard For The Format Of Arpa Internet Text
+;; Messages". This library is based on
+;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05.
+
+;; Pending a real regression self test suite, Simon Josefsson added
+;; various self test expressions snipped from bug reports, and their
+;; expected value, below. I you believe it could be useful, please
+;; add your own test cases, or write a real self test suite, or just
+;; remove this.
+
+;; <m3oekvfd50.fsf@whitebox.m5r.de>
+;; (ietf-drums-parse-address "'foo' <foo@example.com>")
+;; => ("foo@example.com" . "'foo'")
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177"
+ "US-ASCII control characters excluding CR, LF and white space.")
+(defvar ietf-drums-text-token "\001-\011\013\014\016-\177"
+ "US-ASCII characters excluding CR and LF.")
+(defvar ietf-drums-specials-token "()<>[]:;@\\,.\""
+ "Special characters.")
+(defvar ietf-drums-quote-token "\\"
+ "Quote character.")
+(defvar ietf-drums-wsp-token " \t"
+ "White space.")
+(defvar ietf-drums-fws-regexp
+ (concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+")
+ "Folding white space.")
+(defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~"
+ "Textual token.")
+(defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~."
+ "Textual token including full stop.")
+(defvar ietf-drums-qtext-token
+ (concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177")
+ "Non-white-space control characters, plus the rest of ASCII excluding
+backslash and doublequote.")
+(defvar ietf-drums-tspecials "][()<>@,;:\\\"/?="
+ "Tspecials.")
+
+(defvar ietf-drums-syntax-table
+ (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
+ (modify-syntax-entry ?\\ "/" table)
+ (modify-syntax-entry ?< "(" table)
+ (modify-syntax-entry ?> ")" table)
+ (modify-syntax-entry ?@ "w" table)
+ (modify-syntax-entry ?/ "w" table)
+ (modify-syntax-entry ?* "_" table)
+ (modify-syntax-entry ?\; "_" table)
+ (modify-syntax-entry ?\' "_" table)
+ table))
+
+(defun ietf-drums-token-to-list (token)
+ "Translate TOKEN into a list of characters."
+ (let ((i 0)
+ b e c out range)
+ (while (< i (length token))
+ (setq c (aref token i))
+ (incf i)
+ (cond
+ ((eq c ?-)
+ (if b
+ (setq range t)
+ (push c out)))
+ (range
+ (while (<= b c)
+ (push (make-char 'ascii b) out)
+ (incf b))
+ (setq range nil))
+ ((= i (length token))
+ (push (make-char 'ascii c) out))
+ (t
+ (when b
+ (push (make-char 'ascii b) out))
+ (setq b c))))
+ (nreverse out)))
+
+(defsubst ietf-drums-init (string)
+ (set-syntax-table ietf-drums-syntax-table)
+ (insert string)
+ (ietf-drums-unfold-fws)
+ (goto-char (point-min)))
+
+(defun ietf-drums-remove-comments (string)
+ "Remove comments from STRING."
+ (with-temp-buffer
+ (let (c)
+ (ietf-drums-init string)
+ (while (not (eobp))
+ (setq c (char-after))
+ (cond
+ ((eq c ?\")
+ (condition-case err
+ (forward-sexp 1)
+ (error (goto-char (point-max)))))
+ ((eq c ?\()
+ (delete-region
+ (point)
+ (condition-case nil
+ (with-syntax-table (copy-syntax-table ietf-drums-syntax-table)
+ (modify-syntax-entry ?\" "w")
+ (forward-sexp 1)
+ (point))
+ (error (point-max)))))
+ (t
+ (forward-char 1))))
+ (buffer-string))))
+
+(defun ietf-drums-remove-whitespace (string)
+ "Remove whitespace from STRING."
+ (with-temp-buffer
+ (ietf-drums-init string)
+ (let (c)
+ (while (not (eobp))
+ (setq c (char-after))
+ (cond
+ ((eq c ?\")
+ (forward-sexp 1))
+ ((eq c ?\()
+ (forward-sexp 1))
+ ((memq c '(?\ ?\t ?\n))
+ (delete-char 1))
+ (t
+ (forward-char 1))))
+ (buffer-string))))
+
+(defun ietf-drums-get-comment (string)
+ "Return the first comment in STRING."
+ (with-temp-buffer
+ (ietf-drums-init string)
+ (let (result c)
+ (while (not (eobp))
+ (setq c (char-after))
+ (cond
+ ((eq c ?\")
+ (forward-sexp 1))
+ ((eq c ?\()
+ (setq result
+ (buffer-substring
+ (1+ (point))
+ (progn (forward-sexp 1) (1- (point))))))
+ (t
+ (forward-char 1))))
+ result)))
+
+(defun ietf-drums-strip (string)
+ "Remove comments and whitespace from STRING."
+ (ietf-drums-remove-whitespace (ietf-drums-remove-comments string)))
+
+(defun ietf-drums-parse-address (string)
+ "Parse STRING and return a MAILBOX / DISPLAY-NAME pair."
+ (with-temp-buffer
+ (let (display-name mailbox c display-string)
+ (ietf-drums-init string)
+ (while (not (eobp))
+ (setq c (char-after))
+ (cond
+ ((or (eq c ? )
+ (eq c ?\t))
+ (forward-char 1))
+ ((eq c ?\()
+ (forward-sexp 1))
+ ((eq c ?\")
+ (push (buffer-substring
+ (1+ (point)) (progn (forward-sexp 1) (1- (point))))
+ display-name))
+ ((looking-at (concat "[" ietf-drums-atext-token "@" "]"))
+ (push (buffer-substring (point) (progn (forward-sexp 1) (point)))
+ display-name))
+ ((eq c ?<)
+ (setq mailbox
+ (ietf-drums-remove-whitespace
+ (ietf-drums-remove-comments
+ (buffer-substring
+ (1+ (point))
+ (progn (forward-sexp 1) (1- (point))))))))
+ (t
+ (forward-char 1))))
+ ;; If we found no display-name, then we look for comments.
+ (if display-name
+ (setq display-string
+ (mapconcat 'identity (reverse display-name) " "))
+ (setq display-string (ietf-drums-get-comment string)))
+ (if (not mailbox)
+ (when (and display-string
+ (string-match "@" display-string))
+ (cons
+ (mapconcat 'identity (nreverse display-name) "")
+ (ietf-drums-get-comment string)))
+ (cons mailbox display-string)))))
+
+(defun ietf-drums-parse-addresses (string &optional rawp)
+ "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs.
+If RAWP, don't actually parse the addresses, but instead return
+a list of address strings."
+ (if (null string)
+ nil
+ (with-temp-buffer
+ (ietf-drums-init string)
+ (let ((beg (point))
+ pairs c address)
+ (while (not (eobp))
+ (setq c (char-after))
+ (cond
+ ((memq c '(?\" ?< ?\())
+ (condition-case nil
+ (forward-sexp 1)
+ (error
+ (skip-chars-forward "^,"))))
+ ((eq c ?,)
+ (setq address
+ (if rawp
+ (buffer-substring beg (point))
+ (condition-case nil
+ (ietf-drums-parse-address
+ (buffer-substring beg (point)))
+ (error nil))))
+ (if address (push address pairs))
+ (forward-char 1)
+ (setq beg (point)))
+ (t
+ (forward-char 1))))
+ (setq address
+ (if rawp
+ (buffer-substring beg (point))
+ (condition-case nil
+ (ietf-drums-parse-address
+ (buffer-substring beg (point)))
+ (error nil))))
+ (if address (push address pairs))
+ (nreverse pairs)))))
+
+(defun ietf-drums-unfold-fws ()
+ "Unfold folding white space in the current buffer."
+ (goto-char (point-min))
+ (while (re-search-forward ietf-drums-fws-regexp nil t)
+ (replace-match " " t t))
+ (goto-char (point-min)))
+
+(defun ietf-drums-parse-date (string)
+ "Return an Emacs time spec from STRING."
+ (apply 'encode-time (parse-time-string string)))
+
+(defun ietf-drums-narrow-to-header ()
+ "Narrow to the header section in the current buffer."
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (re-search-forward "^\r?$" nil 1)
+ (match-beginning 0)
+ (point-max)))
+ (goto-char (point-min)))
+
+(defun ietf-drums-quote-string (string)
+ "Quote string if it needs quoting to be displayed in a header."
+ (if (string-match (concat "[^" ietf-drums-atext-token "]") string)
+ (concat "\"" string "\"")
+ string))
+
+(defun ietf-drums-make-address (name address)
+ (if name
+ (concat (ietf-drums-quote-string name) " <" address ">")
+ address))
+
+(provide 'ietf-drums)
+
+;;; ietf-drums.el ends here
--- /dev/null
+;;; mail-parse.el --- Interface functions for parsing mail
+
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file contains wrapper functions for a wide range of mail
+;; parsing functions. The idea is that there are low-level libraries
+;; that implement according to various specs (RFC2231, DRUMS, USEFOR),
+;; but that programmers that want to parse some header (say,
+;; Content-Type) will want to use the latest spec.
+;;
+;; So while each low-level library (rfc2231.el, for instance) decodes
+;; faithfully according to that (proposed) standard, this library is
+;; the interface library. If some later RFC supersedes RFC2231, one
+;; would just have to write a new low-level library, adjust the
+;; aliases in this library, and the users and programmers won't notice
+;; any changes.
+
+;;; Code:
+
+(require 'mail-prsvr)
+(require 'ietf-drums)
+(require 'rfc2231)
+(require 'rfc2047)
+(require 'rfc2045)
+
+(defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string)
+(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string)
+(defalias 'mail-content-type-get 'rfc2231-get-value)
+(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter)
+
+(defalias 'mail-header-remove-comments 'ietf-drums-remove-comments)
+(defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace)
+(defalias 'mail-header-strip 'ietf-drums-strip)
+(defalias 'mail-header-get-comment 'ietf-drums-get-comment)
+(defalias 'mail-header-parse-address 'ietf-drums-parse-address)
+(defalias 'mail-header-parse-addresses 'ietf-drums-parse-addresses)
+(defalias 'mail-header-parse-date 'ietf-drums-parse-date)
+(defalias 'mail-narrow-to-head 'ietf-drums-narrow-to-header)
+(defalias 'mail-quote-string 'ietf-drums-quote-string)
+(defalias 'mail-header-make-address 'ietf-drums-make-address)
+
+(defalias 'mail-header-fold-field 'rfc2047-fold-field)
+(defalias 'mail-header-unfold-field 'rfc2047-unfold-field)
+(defalias 'mail-header-narrow-to-field 'rfc2047-narrow-to-field)
+(defalias 'mail-header-field-value 'rfc2047-field-value)
+
+(defalias 'mail-encode-encoded-word-region 'rfc2047-encode-region)
+(defalias 'mail-encode-encoded-word-buffer 'rfc2047-encode-message-header)
+(defalias 'mail-encode-encoded-word-string 'rfc2047-encode-string)
+(defalias 'mail-decode-encoded-word-region 'rfc2047-decode-region)
+(defalias 'mail-decode-encoded-word-string 'rfc2047-decode-string)
+(defalias 'mail-decode-encoded-address-region 'rfc2047-decode-address-region)
+(defalias 'mail-decode-encoded-address-string 'rfc2047-decode-address-string)
+
+(provide 'mail-parse)
+
+;;; mail-parse.el ends here
--- /dev/null
+;;; mail-prsvr.el --- Interface variables for parsing mail
+
+;; Copyright (C) 1999-2016 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(defvar mail-parse-charset nil
+ "Default charset used by low-level libraries.
+This variable should never be set. Instead, it should be bound by
+functions that wish to call mail-parse functions and let them know
+what the desired charset is to be.")
+
+(defvar mail-parse-mule-charset nil
+ "Default MULE charset used by low-level libraries.
+This variable should never be set.")
+
+(defvar mail-parse-ignored-charsets nil
+ "Ignored charsets used by low-level libraries.
+This variable should never be set. Instead, it should be bound by
+functions that wish to call mail-parse functions and let them know
+what the desired charsets is to be ignored.")
+
+(provide 'mail-prsvr)
+
+;;; mail-prsvr.el ends here
--- /dev/null
+;;; qp.el --- Quoted-Printable functions
+
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: mail, extensions
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Functions for encoding and decoding quoted-printable text as
+;; defined in RFC 2045.
+
+;;; Code:
+
+;;;###autoload
+(defun quoted-printable-decode-region (from to &optional coding-system)
+ "Decode quoted-printable in the region between FROM and TO, per RFC 2045.
+If CODING-SYSTEM is non-nil, decode bytes into characters with that
+coding-system.
+
+Interactively, you can supply the CODING-SYSTEM argument
+with \\[universal-coding-system-argument].
+
+The CODING-SYSTEM argument is a historical hangover and is deprecated.
+QP encodes raw bytes and should be decoded into raw bytes. Decoding
+them into characters should be done separately."
+ (interactive
+ ;; Let the user determine the coding system with "C-x RET c".
+ (list (region-beginning) (region-end) coding-system-for-read))
+ (when (and coding-system
+ (not (coding-system-p coding-system))) ; e.g. `ascii' from Gnus
+ (setq coding-system nil))
+ (save-excursion
+ (save-restriction
+ ;; RFC 2045: ``An "=" followed by two hexadecimal digits, one
+ ;; or both of which are lowercase letters in "abcdef", is
+ ;; formally illegal. A robust implementation might choose to
+ ;; recognize them as the corresponding uppercase letters.''
+ (let ((case-fold-search t))
+ (narrow-to-region from to)
+ ;; Do this in case we're called from Gnus, say, in a buffer
+ ;; which already contains non-ASCII characters which would
+ ;; then get doubly-decoded below.
+ (if coding-system
+ (encode-coding-region (point-min) (point-max) coding-system))
+ (goto-char (point-min))
+ (while (and (skip-chars-forward "^=")
+ (not (eobp)))
+ (cond ((eq (char-after (1+ (point))) ?\n)
+ (delete-char 2))
+ ((looking-at "\\(=[0-9A-F][0-9A-F]\\)+")
+ ;; Decode this sequence at once; i.e. by a single
+ ;; deletion and insertion.
+ (let* ((n (/ (- (match-end 0) (point)) 3))
+ (str (make-string n 0)))
+ (dotimes (i n)
+ (let ((n1 (char-after (1+ (point))))
+ (n2 (char-after (+ 2 (point)))))
+ (aset str i
+ (+ (* 16 (- n1 (if (<= n1 ?9) ?0
+ (if (<= n1 ?F) (- ?A 10)
+ (- ?a 10)))))
+ (- n2 (if (<= n2 ?9) ?0
+ (if (<= n2 ?F) (- ?A 10)
+ (- ?a 10)))))))
+ (forward-char 3))
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert str)))
+ (t
+ (message "Malformed quoted-printable text")
+ (forward-char)))))
+ (if coding-system
+ (decode-coding-region (point-min) (point-max) coding-system)))))
+
+(defun quoted-printable-decode-string (string &optional coding-system)
+ "Decode the quoted-printable encoded STRING and return the result.
+If CODING-SYSTEM is non-nil, decode the string with coding-system.
+Use of CODING-SYSTEM is deprecated; this function should deal with
+raw bytes, and coding conversion should be done separately."
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert string)
+ (quoted-printable-decode-region (point-min) (point-max) coding-system)
+ (buffer-string)))
+
+(defun quoted-printable-encode-region (from to &optional fold class)
+ "Quoted-printable encode the region between FROM and TO per RFC 2045.
+
+If FOLD, fold long lines at 76 characters (as required by the RFC).
+If CLASS is non-nil, translate the characters not matched by that
+regexp class, which is in the form expected by `skip-chars-forward'.
+You should probably avoid non-ASCII characters in this arg.
+
+If `mm-use-ultra-safe-encoding' is set, fold lines unconditionally and
+encode lines starting with \"From\"."
+ (interactive "r")
+ (unless class
+ ;; Avoid using 8bit characters. = is \075.
+ ;; Equivalent to "^\000-\007\013\015-\037\200-\377="
+ (setq class "\010-\012\014\040-\074\076-\177"))
+ (save-excursion
+ (goto-char from)
+ (if (re-search-forward (string-to-multibyte "[^\x0-\x7f\x80-\xff]")
+ to t)
+ (error "Multibyte character in QP encoding region"))
+ (save-restriction
+ (narrow-to-region from to)
+ ;; Encode all the non-ascii and control characters.
+ (goto-char (point-min))
+ (while (and (skip-chars-forward class)
+ (not (eobp)))
+ (insert
+ (prog1
+ (format "=%02X" (char-after))
+ (delete-char 1))))
+ ;; Encode white space at the end of lines.
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+$" nil t)
+ (goto-char (match-beginning 0))
+ (while (not (eolp))
+ (insert
+ (prog1
+ (format "=%02X" (char-after))
+ (delete-char 1)))))
+ (let ((ultra
+ (and (boundp 'mm-use-ultra-safe-encoding)
+ mm-use-ultra-safe-encoding)))
+ (when (or fold ultra)
+ (let ((tab-width 1) ; HTAB is one character.
+ (case-fold-search nil))
+ (goto-char (point-min))
+ (while (not (eobp))
+ ;; In ultra-safe mode, encode "From " at the beginning
+ ;; of a line.
+ (when ultra
+ (if (looking-at "From ")
+ (replace-match "From=20" nil t)
+ (if (looking-at "-")
+ (replace-match "=2D" nil t))))
+ (end-of-line)
+ ;; Fold long lines.
+ (while (> (current-column) 76) ; tab-width must be 1.
+ (beginning-of-line)
+ (forward-char 75) ; 75 chars plus an "="
+ (search-backward "=" (- (point) 2) t)
+ (insert "=\n")
+ (end-of-line))
+ (forward-line))))))))
+
+(defun quoted-printable-encode-string (string)
+ "Encode the STRING as quoted-printable and return the result."
+ (with-temp-buffer
+ (if (multibyte-string-p string)
+ (set-buffer-multibyte 'to)
+ (set-buffer-multibyte nil))
+ (insert string)
+ (quoted-printable-encode-region (point-min) (point-max))
+ (buffer-string)))
+
+(provide 'qp)
+
+;;; qp.el ends here
--- /dev/null
+;;; rfc2045.el --- Functions for decoding rfc2045 headers
+
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;; RFC 2045 is: "Multipurpose Internet Mail Extensions (MIME) Part
+;; One: Format of Internet Message Bodies".
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ietf-drums)
+
+(defun rfc2045-encode-string (param value)
+ "Return and PARAM=VALUE string encoded according to RFC2045."
+ (if (or (string-match (concat "[" ietf-drums-no-ws-ctl-token "]") value)
+ (string-match (concat "[" ietf-drums-tspecials "]") value)
+ (string-match "[ \n\t]" value)
+ (not (string-match (concat "[" ietf-drums-text-token "]") value)))
+ (concat param "=" (format "%S" value))
+ (concat param "=" value)))
+
+(provide 'rfc2045)
+
+;;; rfc2045.el ends here
--- /dev/null
+;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
+
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; RFC 2047 is "MIME (Multipurpose Internet Mail Extensions) Part
+;; Three: Message Header Extensions for Non-ASCII Text".
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+(defvar message-posting-charset)
+
+(require 'mm-util)
+(require 'ietf-drums)
+;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus.
+(require 'mail-prsvr)
+(require 'rfc2045) ;; rfc2045-encode-string
+(autoload 'mm-body-7-or-8 "mm-bodies")
+
+(defvar rfc2047-header-encoding-alist
+ '(("Newsgroups" . nil)
+ ("Followup-To" . nil)
+ ("Message-ID" . nil)
+ ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|\\(In-\\)?Reply-To\\|Sender\
+\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime)
+ (t . mime))
+ "*Header/encoding method alist.
+The list is traversed sequentially. The keys can either be
+header regexps or t.
+
+The values can be:
+
+1) nil, in which case no encoding is done;
+2) `mime', in which case the header will be encoded according to RFC2047;
+3) `address-mime', like `mime', but takes account of the rules for address
+ fields (where quoted strings and comments must be treated separately);
+4) a charset, in which case it will be encoded as that charset;
+5) `default', in which case the field will be encoded as the rest
+ of the article.")
+
+(defvar rfc2047-charset-encoding-alist
+ '((us-ascii . nil)
+ (iso-8859-1 . Q)
+ (iso-8859-2 . Q)
+ (iso-8859-3 . Q)
+ (iso-8859-4 . Q)
+ (iso-8859-5 . B)
+ (koi8-r . B)
+ (iso-8859-7 . B)
+ (iso-8859-8 . B)
+ (iso-8859-9 . Q)
+ (iso-8859-14 . Q)
+ (iso-8859-15 . Q)
+ (iso-2022-jp . B)
+ (iso-2022-kr . B)
+ (gb2312 . B)
+ (gbk . B)
+ (gb18030 . B)
+ (big5 . B)
+ (cn-big5 . B)
+ (cn-gb . B)
+ (cn-gb-2312 . B)
+ (euc-kr . B)
+ (iso-2022-jp-2 . B)
+ (iso-2022-int-1 . B)
+ (viscii . Q))
+ "Alist of MIME charsets to RFC2047 encodings.
+Valid encodings are nil, `Q' and `B'. These indicate binary (no) encoding,
+quoted-printable and base64 respectively.")
+
+(defvar rfc2047-encode-function-alist
+ '((Q . rfc2047-q-encode-string)
+ (B . rfc2047-b-encode-string)
+ (nil . identity))
+ "Alist of RFC2047 encodings to encoding functions.")
+
+(defvar rfc2047-encode-encoded-words t
+ "Whether encoded words should be encoded again.")
+
+(defvar rfc2047-allow-irregular-q-encoded-words t
+ "*Whether to decode irregular Q-encoded words.")
+
+(eval-and-compile ;; Necessary to hard code them in `rfc2047-decode-region'.
+ (defconst rfc2047-encoded-word-regexp
+ "=\\?\\([^][\000-\040()<>@,;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\
+\\(B\\?[+/0-9A-Za-z]*=*\
+\\|Q\\?[ ->@-~]*\
+\\)\\?="
+ "Regexp that matches encoded word."
+ ;; The patterns for the B encoding and the Q encoding, i.e. the ones
+ ;; beginning with "B" and "Q" respectively, are restricted into only
+ ;; the characters that those encodings may generally use.
+ )
+ (defconst rfc2047-encoded-word-regexp-loose
+ "=\\?\\([^][\000-\040()<>@,;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\
+\\(B\\?[+/0-9A-Za-z]*=*\
+\\|Q\\?\\(?:\\?+[ -<>@-~]\\)?\\(?:[ ->@-~]+\\?+[ -<>@-~]\\)*[ ->@-~]*\\?*\
+\\)\\?="
+ "Regexp that matches encoded word allowing loose Q encoding."
+ ;; The pattern for the Q encoding, i.e. the one beginning with "Q",
+ ;; is similar to:
+ ;; "Q\\?\\(\\?+[^\n=?]\\)?\\([^\n?]+\\?+[^\n=?]\\)*[^\n?]*\\?*"
+ ;; <--------1-------><----------2,3----------><--4--><-5->
+ ;; They mean:
+ ;; 1. After "Q?", allow "?"s that follow a character other than "=".
+ ;; 2. Allow "=" after "Q?"; it isn't regarded as the terminator.
+ ;; 3. In the middle of an encoded word, allow "?"s that follow a
+ ;; character other than "=".
+ ;; 4. Allow any characters other than "?" in the middle of an
+ ;; encoded word.
+ ;; 5. At the end, allow "?"s.
+ ))
+
+;;;
+;;; Functions for encoding RFC2047 messages
+;;;
+
+(defun rfc2047-qp-or-base64 ()
+ "Return the type with which to encode the buffer.
+This is either `base64' or `quoted-printable'."
+ (save-excursion
+ (let ((limit (min (point-max) (+ 2000 (point-min))))
+ (n8bit 0))
+ (goto-char (point-min))
+ (skip-chars-forward "\x20-\x7f\r\n\t" limit)
+ (while (< (point) limit)
+ (incf n8bit)
+ (forward-char 1)
+ (skip-chars-forward "\x20-\x7f\r\n\t" limit))
+ (if (or (< (* 6 n8bit) (- limit (point-min)))
+ ;; Don't base64, say, a short line with a single
+ ;; non-ASCII char when splitting parts by charset.
+ (= n8bit 1))
+ 'quoted-printable
+ 'base64))))
+
+(defun rfc2047-narrow-to-field ()
+ "Narrow the buffer to the header on the current line."
+ (beginning-of-line)
+ (narrow-to-region
+ (point)
+ (progn
+ (forward-line 1)
+ (if (re-search-forward "^[^ \n\t]" nil t)
+ (point-at-bol)
+ (point-max))))
+ (goto-char (point-min)))
+
+(defun rfc2047-field-value ()
+ "Return the value of the field at point."
+ (save-excursion
+ (save-restriction
+ (rfc2047-narrow-to-field)
+ (re-search-forward ":[ \t\n]*" nil t)
+ (buffer-substring-no-properties (point) (point-max)))))
+
+(defun rfc2047-quote-special-characters-in-quoted-strings (&optional
+ encodable-regexp)
+ "Quote special characters with `\\'s in quoted strings.
+Quoting will not be done in a quoted string if it contains characters
+matching ENCODABLE-REGEXP or it is within parentheses."
+ (goto-char (point-min))
+ (let ((tspecials (concat "[" ietf-drums-tspecials "]"))
+ (start (point))
+ beg end)
+ (with-syntax-table (standard-syntax-table)
+ (while (not (eobp))
+ (if (ignore-errors
+ (forward-list 1)
+ (eq (char-before) ?\)))
+ (forward-list -1)
+ (goto-char (point-max)))
+ (save-restriction
+ (narrow-to-region start (point))
+ (goto-char start)
+ (while (search-forward "\"" nil t)
+ (setq beg (match-beginning 0))
+ (unless (eq (char-before beg) ?\\)
+ (goto-char beg)
+ (setq beg (1+ beg))
+ (condition-case nil
+ (progn
+ (forward-sexp)
+ (setq end (1- (point)))
+ (goto-char beg)
+ (if (and encodable-regexp
+ (re-search-forward encodable-regexp end t))
+ (goto-char (1+ end))
+ (save-restriction
+ (narrow-to-region beg end)
+ (while (re-search-forward tspecials nil 'move)
+ (if (eq (char-before) ?\\)
+ (if (looking-at tspecials) ;; Already quoted.
+ (forward-char)
+ (insert "\\"))
+ (goto-char (match-beginning 0))
+ (insert "\\")
+ (forward-char))))
+ (forward-char)))
+ (error
+ (goto-char beg)))))
+ (goto-char (point-max)))
+ (forward-list 1)
+ (setq start (point))))))
+
+(defvar rfc2047-encoding-type 'address-mime
+ "The type of encoding done by `rfc2047-encode-region'.
+This should be dynamically bound around calls to
+`rfc2047-encode-region' to either `mime' or `address-mime'. See
+`rfc2047-header-encoding-alist', for definitions.")
+
+(defun rfc2047-encode-message-header ()
+ "Encode the message header according to `rfc2047-header-encoding-alist'.
+Should be called narrowed to the head of the message."
+ (interactive "*")
+ (save-excursion
+ (goto-char (point-min))
+ (let (alist elem method charsets)
+ (while (not (eobp))
+ (save-restriction
+ (rfc2047-narrow-to-field)
+ (setq method nil
+ alist rfc2047-header-encoding-alist
+ charsets (mm-find-mime-charset-region (point-min) (point-max)))
+ ;; M$ Outlook boycotts decoding of a header if it consists
+ ;; of two or more encoded words and those charsets differ;
+ ;; it seems to decode all words in a header from a charset
+ ;; found first in the header. So, we unify the charsets into
+ ;; a single one used for encoding the whole text in a header.
+ (let ((mm-coding-system-priorities
+ (if (= (length charsets) 1)
+ (cons (mm-charset-to-coding-system (car charsets))
+ mm-coding-system-priorities)
+ mm-coding-system-priorities)))
+ (while (setq elem (pop alist))
+ (when (or (and (stringp (car elem))
+ (looking-at (car elem)))
+ (eq (car elem) t))
+ (setq alist nil
+ method (cdr elem))))
+ (if (not (rfc2047-encodable-p))
+ (prog2
+ (when (eq method 'address-mime)
+ (rfc2047-quote-special-characters-in-quoted-strings))
+ (if (and (eq (mm-body-7-or-8) '8bit)
+ (mm-multibyte-p)
+ (mm-coding-system-p
+ (car message-posting-charset)))
+ ;; 8 bit must be decoded.
+ (encode-coding-region
+ (point-min) (point-max)
+ (mm-charset-to-coding-system
+ (car message-posting-charset))))
+ ;; No encoding necessary, but folding is nice
+ (when nil
+ (rfc2047-fold-region
+ (save-excursion
+ (goto-char (point-min))
+ (skip-chars-forward "^:")
+ (when (looking-at ": ")
+ (forward-char 2))
+ (point))
+ (point-max))))
+ ;; We found something that may perhaps be encoded.
+ (re-search-forward "^[^:]+: *" nil t)
+ (cond
+ ((eq method 'address-mime)
+ (rfc2047-encode-region (point) (point-max)))
+ ((eq method 'mime)
+ (let ((rfc2047-encoding-type 'mime))
+ (rfc2047-encode-region (point) (point-max))))
+ ((eq method 'default)
+ (if (and (default-value 'enable-multibyte-characters)
+ mail-parse-charset)
+ (encode-coding-region (point) (point-max)
+ mail-parse-charset)))
+ ;; We get this when CC'ing messages to newsgroups with
+ ;; 8-bit names. The group name mail copy just got
+ ;; unconditionally encoded. Previously, it would ask
+ ;; whether to encode, which was quite confusing for the
+ ;; user. If the new behavior is wrong, tell me. I have
+ ;; left the old code commented out below.
+ ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-07.
+ ;; Modified by Dave Love, with the commented-out code changed
+ ;; in accordance with changes elsewhere.
+ ((null method)
+ (rfc2047-encode-region (point) (point-max)))
+;;; ((null method)
+;;; (if (or (message-options-get
+;;; 'rfc2047-encode-message-header-encode-any)
+;;; (message-options-set
+;;; 'rfc2047-encode-message-header-encode-any
+;;; (y-or-n-p
+;;; "Some texts are not encoded. Encode anyway?")))
+;;; (rfc2047-encode-region (point-min) (point-max))
+;;; (error "Cannot send unencoded text")))
+ ((mm-coding-system-p method)
+ (when (default-value 'enable-multibyte-characters)
+ (encode-coding-region (point) (point-max) method)))
+ ;; Hm.
+ (t)))
+ (goto-char (point-max))))))))
+
+;; Fixme: This, and the require below may not be the Right Thing, but
+;; should be safe just before release. -- fx 2001-02-08
+
+(defun rfc2047-encodable-p ()
+ "Return non-nil if any characters in current buffer need encoding in headers.
+The buffer may be narrowed."
+ (require 'message) ; for message-posting-charset
+ (let ((charsets
+ (mm-find-mime-charset-region (point-min) (point-max))))
+ (goto-char (point-min))
+ (or (and rfc2047-encode-encoded-words
+ (prog1
+ (re-search-forward rfc2047-encoded-word-regexp nil t)
+ (goto-char (point-min))))
+ (and charsets
+ (not (equal charsets (list (car message-posting-charset))))))))
+
+;; Use this syntax table when parsing into regions that may need
+;; encoding. Double quotes are string delimiters, backslash is
+;; character quoting, and all other RFC 2822 special characters are
+;; treated as punctuation so we can use forward-sexp/forward-word to
+;; skip to the end of regions appropriately. Nb. ietf-drums does
+;; things differently.
+(defconst rfc2047-syntax-table
+ ;; (make-char-table 'syntax-table '(2)) only works in Emacs.
+ (let ((table (make-syntax-table)))
+ ;; The following is done to work for setting all elements of the table;
+ ;; it appears to be the cleanest way.
+ ;; Play safe and don't assume the form of the word syntax entry --
+ ;; copy it from ?a.
+ (set-char-table-range table t (aref (standard-syntax-table) ?a))
+ (modify-syntax-entry ?\\ "\\" table)
+ (modify-syntax-entry ?\" "\"" table)
+ (modify-syntax-entry ?\( "(" table)
+ (modify-syntax-entry ?\) ")" table)
+ (modify-syntax-entry ?\< "." table)
+ (modify-syntax-entry ?\> "." table)
+ (modify-syntax-entry ?\[ "." table)
+ (modify-syntax-entry ?\] "." table)
+ (modify-syntax-entry ?: "." table)
+ (modify-syntax-entry ?\; "." table)
+ (modify-syntax-entry ?, "." table)
+ (modify-syntax-entry ?@ "." table)
+ table))
+
+(defun rfc2047-encode-region (b e &optional dont-fold)
+ "Encode words in region B to E that need encoding.
+By default, the region is treated as containing RFC2822 addresses.
+Dynamically bind `rfc2047-encoding-type' to change that."
+ (save-restriction
+ (narrow-to-region b e)
+ (let ((encodable-regexp (if rfc2047-encode-encoded-words
+ "[^\000-\177]+\\|=\\?"
+ "[^\000-\177]+"))
+ start ; start of current token
+ end begin csyntax
+ ;; Whether there's an encoded word before the current token,
+ ;; either immediately or separated by space.
+ last-encoded
+ (orig-text (buffer-substring-no-properties b e)))
+ (if (eq 'mime rfc2047-encoding-type)
+ ;; Simple case. Continuous words in which all those contain
+ ;; non-ASCII characters are encoded collectively. Encoding
+ ;; ASCII words, including `Re:' used in Subject headers, is
+ ;; avoided for interoperability with non-MIME clients and
+ ;; for making it easy to find keywords.
+ (progn
+ (goto-char (point-min))
+ (while (progn (skip-chars-forward " \t\n")
+ (not (eobp)))
+ (setq start (point))
+ (while (and (looking-at "[ \t\n]*\\([^ \t\n]+\\)")
+ (progn
+ (setq end (match-end 0))
+ (re-search-forward encodable-regexp end t)))
+ (goto-char end))
+ (if (> (point) start)
+ (rfc2047-encode start (point))
+ (goto-char end))))
+ ;; `address-mime' case -- take care of quoted words, comments.
+ (rfc2047-quote-special-characters-in-quoted-strings encodable-regexp)
+ (with-syntax-table rfc2047-syntax-table
+ (goto-char (point-min))
+ (condition-case err ; in case of unbalanced quotes
+ ;; Look for rfc2822-style: sequences of atoms, quoted
+ ;; strings, specials, whitespace. (Specials mustn't be
+ ;; encoded.)
+ (while (not (eobp))
+ ;; Skip whitespace.
+ (skip-chars-forward " \t\n")
+ (setq start (point))
+ (cond
+ ((not (char-after))) ; eob
+ ;; else token start
+ ((eq ?\" (setq csyntax (char-syntax (char-after))))
+ ;; Quoted word.
+ (forward-sexp)
+ (setq end (point))
+ ;; Does it need encoding?
+ (goto-char start)
+ (if (re-search-forward encodable-regexp end 'move)
+ ;; It needs encoding. Strip the quotes first,
+ ;; since encoded words can't occur in quotes.
+ (progn
+ (goto-char end)
+ (delete-char -1)
+ (goto-char start)
+ (delete-char 1)
+ (when last-encoded
+ ;; There was a preceding quoted word. We need
+ ;; to include any separating whitespace in this
+ ;; word to avoid it getting lost.
+ (skip-chars-backward " \t")
+ ;; A space is needed between the encoded words.
+ (insert ? )
+ (setq start (point)
+ end (1+ end)))
+ ;; Adjust the end position for the deleted quotes.
+ (rfc2047-encode start (- end 2))
+ (setq last-encoded t)) ; record that it was encoded
+ (setq last-encoded nil)))
+ ((eq ?. csyntax)
+ ;; Skip other delimiters, but record that they've
+ ;; potentially separated quoted words.
+ (forward-char)
+ (setq last-encoded nil))
+ ((eq ?\) csyntax)
+ (error "Unbalanced parentheses"))
+ ((eq ?\( csyntax)
+ ;; Look for the end of parentheses.
+ (forward-list)
+ ;; Encode text as an unstructured field.
+ (let ((rfc2047-encoding-type 'mime))
+ (rfc2047-encode-region (1+ start) (1- (point))))
+ (skip-chars-forward ")"))
+ (t ; normal token/whitespace sequence
+ ;; Find the end.
+ ;; Skip one ASCII word, or encode continuous words
+ ;; in which all those contain non-ASCII characters.
+ (setq end nil)
+ (while (not (or end (eobp)))
+ (when (looking-at "[\000-\177]+")
+ (setq begin (point)
+ end (match-end 0))
+ (when (progn
+ (while (and (or (re-search-forward
+ "[ \t\n]\\|\\Sw" end 'move)
+ (setq end nil))
+ (eq ?\\ (char-syntax (char-before))))
+ ;; Skip backslash-quoted characters.
+ (forward-char))
+ end)
+ (setq end (match-beginning 0))
+ (if rfc2047-encode-encoded-words
+ (progn
+ (goto-char begin)
+ (when (search-forward "=?" end 'move)
+ (goto-char (match-beginning 0))
+ (setq end nil)))
+ (goto-char end))))
+ ;; Where the value nil of `end' means there may be
+ ;; text to have to be encoded following the point.
+ ;; Otherwise, the point reached to the end of ASCII
+ ;; words separated by whitespace or a special char.
+ (unless end
+ (when (looking-at encodable-regexp)
+ (goto-char (setq begin (match-end 0)))
+ (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)")
+ (setq end (match-end 0))
+ (progn
+ (while (re-search-forward
+ encodable-regexp end t))
+ (< begin (point)))
+ (goto-char begin)
+ (or (not (re-search-forward "\\Sw" end t))
+ (progn
+ (goto-char (match-beginning 0))
+ nil)))
+ (goto-char end))
+ (when (looking-at "[^ \t\n]+")
+ (setq end (match-end 0))
+ (if (re-search-forward "\\Sw+" end t)
+ ;; There are special characters better
+ ;; to be encoded so that MTAs may parse
+ ;; them safely.
+ (cond ((= end (point)))
+ ((looking-at (concat "\\sw*\\("
+ encodable-regexp
+ "\\)"))
+ (setq end nil))
+ (t
+ (goto-char (1- (match-end 0)))
+ (unless (= (point) (match-beginning 0))
+ ;; Separate encodable text and
+ ;; delimiter.
+ (insert " "))))
+ (goto-char end)
+ (skip-chars-forward " \t\n")
+ (if (and (looking-at "[^ \t\n]+")
+ (string-match encodable-regexp
+ (match-string 0)))
+ (setq end nil)
+ (goto-char end)))))))
+ (skip-chars-backward " \t\n")
+ (setq end (point))
+ (goto-char start)
+ (if (re-search-forward encodable-regexp end 'move)
+ (progn
+ (unless (memq (char-before start) '(nil ?\t ? ))
+ (if (progn
+ (goto-char start)
+ (skip-chars-backward "^ \t\n")
+ (and (looking-at "\\Sw+")
+ (= (match-end 0) start)))
+ ;; Also encode bogus delimiters.
+ (setq start (point))
+ ;; Separate encodable text and delimiter.
+ (goto-char start)
+ (insert " ")
+ (setq start (1+ start)
+ end (1+ end))))
+ (rfc2047-encode start end)
+ (setq last-encoded t))
+ (setq last-encoded nil)))))
+ (error
+ (if (or debug-on-quit debug-on-error)
+ (signal (car err) (cdr err))
+ (error "Invalid data for rfc2047 encoding: %s"
+ (replace-regexp-in-string "[ \t\n]+" " " orig-text))))))))
+ (unless dont-fold
+ (rfc2047-fold-region b (point)))
+ (goto-char (point-max))))
+
+(defun rfc2047-encode-string (string &optional dont-fold)
+ "Encode words in STRING.
+By default, the string is treated as containing addresses (see
+`rfc2047-encoding-type')."
+ (mm-with-multibyte-buffer
+ (insert string)
+ (rfc2047-encode-region (point-min) (point-max) dont-fold)
+ (buffer-string)))
+
+;; From RFC 2047:
+;; 2. Syntax of encoded-words
+;; [...]
+;; While there is no limit to the length of a multiple-line header
+;; field, each line of a header field that contains one or more
+;; 'encoded-word's is limited to 76 characters.
+;;
+;; In `rfc2047-encode-parameter' it is bound to nil, so don't defconst it.
+(defvar rfc2047-encode-max-chars 76
+ "Maximum characters of each header line that contain encoded-words.
+According to RFC 2047, it is 76. If it is nil, encoded-words
+will not be folded. Too small value may cause an error. You
+should not change this value.")
+
+(defun rfc2047-encode-1 (column string cs encoder start crest tail
+ &optional eword)
+ "Subroutine used by `rfc2047-encode'."
+ (cond ((string-equal string "")
+ (or eword ""))
+ ((not rfc2047-encode-max-chars)
+ (concat start
+ (funcall encoder (if cs
+ (encode-coding-string string cs)
+ string))
+ "?="))
+ ((>= column rfc2047-encode-max-chars)
+ (when eword
+ (cond ((string-match "\n[ \t]+\\'" eword)
+ ;; Remove a superfluous empty line.
+ (setq eword (substring eword 0 (match-beginning 0))))
+ ((string-match "(+\\'" eword)
+ ;; Break the line before the open parenthesis.
+ (setq crest (concat crest (match-string 0 eword))
+ eword (substring eword 0 (match-beginning 0))))))
+ (rfc2047-encode-1 (length crest) string cs encoder start " " tail
+ (concat eword "\n" crest)))
+ (t
+ (let ((index 0)
+ (limit (1- (length string)))
+ (prev "")
+ next len)
+ (while (and prev
+ (<= index limit))
+ (setq next (concat start
+ (funcall encoder
+ (if cs
+ (encode-coding-string
+ (substring string 0 (1+ index))
+ cs)
+ (substring string 0 (1+ index))))
+ "?=")
+ len (+ column (length next)))
+ (if (> len rfc2047-encode-max-chars)
+ (setq next prev
+ prev nil)
+ (if (or (< index limit)
+ (<= (+ len (or (string-match "\n" tail)
+ (length tail)))
+ rfc2047-encode-max-chars))
+ (setq prev next
+ index (1+ index))
+ (if (string-match "\\`)+" tail)
+ ;; Break the line after the close parenthesis.
+ (setq tail (concat (substring tail 0 (match-end 0))
+ "\n "
+ (substring tail (match-end 0)))
+ prev next
+ index (1+ index))
+ (setq next prev
+ prev nil)))))
+ (if (> index limit)
+ (concat eword next tail)
+ (if (= 0 index)
+ (if (and eword
+ (string-match "(+\\'" eword))
+ (setq crest (concat crest (match-string 0 eword))
+ eword (substring eword 0 (match-beginning 0)))
+ (setq eword (concat eword next)))
+ (setq crest " "
+ eword (concat eword next)))
+ (when (string-match "\n[ \t]+\\'" eword)
+ ;; Remove a superfluous empty line.
+ (setq eword (substring eword 0 (match-beginning 0))))
+ (rfc2047-encode-1 (length crest) (substring string index)
+ cs encoder start " " tail
+ (concat eword "\n" crest)))))))
+
+(defun rfc2047-encode (b e)
+ "Encode the word(s) in the region B to E.
+Point moves to the end of the region."
+ (let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii)))
+ cs encoding tail crest eword)
+ ;; Use utf-8 as a last resort if determining charset of text fails.
+ (if (memq nil mime-charset)
+ (setq mime-charset (list 'utf-8)))
+ (cond ((> (length mime-charset) 1)
+ (error "Can't rfc2047-encode `%s'"
+ (buffer-substring-no-properties b e)))
+ ((= (length mime-charset) 1)
+ (setq mime-charset (car mime-charset)
+ cs (mm-charset-to-coding-system mime-charset))
+ (unless (and (mm-multibyte-p)
+ (mm-coding-system-p cs))
+ (setq cs nil))
+ (save-restriction
+ (narrow-to-region b e)
+ (setq encoding
+ (or (cdr (assq mime-charset
+ rfc2047-charset-encoding-alist))
+ ;; For the charsets that don't have a preferred
+ ;; encoding, choose the one that's shorter.
+ (if (eq (rfc2047-qp-or-base64) 'base64)
+ 'B
+ 'Q)))
+ (widen)
+ (goto-char e)
+ (skip-chars-forward "^ \t\n")
+ ;; `tail' may contain a close parenthesis.
+ (setq tail (buffer-substring-no-properties e (point)))
+ (goto-char b)
+ (setq b (point-marker)
+ e (set-marker (make-marker) e))
+ (rfc2047-fold-region (point-at-bol) b)
+ (goto-char b)
+ (skip-chars-backward "^ \t\n")
+ (unless (= 0 (skip-chars-backward " \t"))
+ ;; `crest' may contain whitespace and an open parenthesis.
+ (setq crest (buffer-substring-no-properties (point) b)))
+ (setq eword (rfc2047-encode-1
+ (- b (point-at-bol))
+ (replace-regexp-in-string
+ "\n\\([ \t]?\\)" "\\1"
+ (buffer-substring-no-properties b e))
+ cs
+ (or (cdr (assq encoding
+ rfc2047-encode-function-alist))
+ 'identity)
+ (concat "=?" (downcase (symbol-name mime-charset))
+ "?" (upcase (symbol-name encoding)) "?")
+ (or crest " ")
+ tail))
+ (delete-region (if (eq (aref eword 0) ?\n)
+ (if (bolp)
+ ;; The line was folded before encoding.
+ (1- (point))
+ (point))
+ (goto-char b))
+ (+ e (length tail)))
+ ;; `eword' contains `crest' and `tail'.
+ (insert eword)
+ (set-marker b nil)
+ (set-marker e nil)
+ (unless (or (/= 0 (length tail))
+ (eobp)
+ (looking-at "[ \t\n)]"))
+ (insert " "))))
+ (t
+ (goto-char e)))))
+
+(defun rfc2047-fold-field ()
+ "Fold the current header field."
+ (save-excursion
+ (save-restriction
+ (rfc2047-narrow-to-field)
+ (rfc2047-fold-region (point-min) (point-max)))))
+
+(defun rfc2047-fold-region (b e)
+ "Fold long lines in region B to E."
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char (point-min))
+ (let ((break nil)
+ (qword-break nil)
+ (first t)
+ (bol (save-restriction
+ (widen)
+ (point-at-bol))))
+ (while (not (eobp))
+ (when (and (or break qword-break)
+ (> (- (point) bol) 76))
+ (goto-char (or break qword-break))
+ (setq break nil
+ qword-break nil)
+ (skip-chars-backward " \t")
+ (if (looking-at "[ \t]")
+ (insert ?\n)
+ (insert "\n "))
+ (setq bol (1- (point)))
+ ;; Don't break before the first non-LWSP characters.
+ (skip-chars-forward " \t")
+ (unless (eobp)
+ (forward-char 1)))
+ (cond
+ ((eq (char-after) ?\n)
+ (forward-char 1)
+ (setq bol (point)
+ break nil
+ qword-break nil)
+ (skip-chars-forward " \t")
+ (unless (or (eobp) (eq (char-after) ?\n))
+ (forward-char 1)))
+ ((eq (char-after) ?\r)
+ (forward-char 1))
+ ((memq (char-after) '(? ?\t))
+ (skip-chars-forward " \t")
+ (unless first ;; Don't break just after the header name.
+ (setq break (point))))
+ ((not break)
+ (if (not (looking-at "=\\?[^=]"))
+ (if (eq (char-after) ?=)
+ (forward-char 1)
+ (skip-chars-forward "^ \t\n\r="))
+ ;; Don't break at the start of the field.
+ (unless (= (point) b)
+ (setq qword-break (point)))
+ (skip-chars-forward "^ \t\n\r")))
+ (t
+ (skip-chars-forward "^ \t\n\r")))
+ (setq first nil))
+ (when (and (or break qword-break)
+ (> (- (point) bol) 76))
+ (goto-char (or break qword-break))
+ (setq break nil
+ qword-break nil)
+ (if (or (> 0 (skip-chars-backward " \t"))
+ (looking-at "[ \t]"))
+ (insert ?\n)
+ (insert "\n "))
+ (setq bol (1- (point)))
+ ;; Don't break before the first non-LWSP characters.
+ (skip-chars-forward " \t")
+ (unless (eobp)
+ (forward-char 1))))))
+
+(defun rfc2047-unfold-field ()
+ "Fold the current line."
+ (save-excursion
+ (save-restriction
+ (rfc2047-narrow-to-field)
+ (rfc2047-unfold-region (point-min) (point-max)))))
+
+(defun rfc2047-unfold-region (b e)
+ "Unfold lines in region B to E."
+ (save-restriction
+ (narrow-to-region b e)
+ (goto-char (point-min))
+ (let ((bol (save-restriction
+ (widen)
+ (point-at-bol)))
+ (eol (point-at-eol)))
+ (forward-line 1)
+ (while (not (eobp))
+ (if (and (looking-at "[ \t]")
+ (< (- (point-at-eol) bol) 76))
+ (delete-region eol (progn
+ (goto-char eol)
+ (skip-chars-forward "\r\n")
+ (point)))
+ (setq bol (point-at-bol)))
+ (setq eol (point-at-eol))
+ (forward-line 1)))))
+
+(defun rfc2047-b-encode-string (string)
+ "Base64-encode the header contained in STRING."
+ (base64-encode-string string t))
+
+(autoload 'quoted-printable-encode-region "qp")
+
+(defun rfc2047-q-encode-string (string)
+ "Quoted-printable-encode the header in STRING."
+ (mm-with-unibyte-buffer
+ (insert string)
+ (quoted-printable-encode-region
+ (point-min) (point-max) nil
+ ;; = (\075), _ (\137), ? (\077) are used in the encoded word.
+ ;; Avoid using 8bit characters.
+ ;; This list excludes `especials' (see the RFC2047 syntax),
+ ;; meaning that some characters in non-structured fields will
+ ;; get encoded when they con't need to be. The following is
+ ;; what it used to be.
+ ;;; ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?"
+ ;;; "\010\012\014\040-\074\076\100-\136\140-\177")
+ "-\b\n\f !#-'*+0-9A-Z\\^`-~\d")
+ (subst-char-in-region (point-min) (point-max) ? ?_)
+ (buffer-string)))
+
+(defun rfc2047-encode-parameter (param value)
+ "Return and PARAM=VALUE string encoded in the RFC2047-like style.
+This is a substitution for the `rfc2231-encode-string' function, that
+is the standard but many mailers don't support it."
+ (let ((rfc2047-encoding-type 'mime)
+ (rfc2047-encode-max-chars nil))
+ (rfc2045-encode-string param (rfc2047-encode-string value t))))
+
+;;;
+;;; Functions for decoding RFC2047 messages
+;;;
+
+(defvar rfc2047-quote-decoded-words-containing-tspecials nil
+ "If non-nil, quote decoded words containing special characters.")
+
+(defvar rfc2047-allow-incomplete-encoded-text t
+ "*Non-nil means allow incomplete encoded-text in successive encoded-words.
+Dividing of encoded-text in the place other than character boundaries
+violates RFC2047 section 5, while we have a capability to decode it.
+If it is non-nil, the decoder will decode B- or Q-encoding in each
+encoded-word, concatenate them, and decode it by charset. Otherwise,
+the decoder will fully decode each encoded-word before concatenating
+them.")
+
+(defun rfc2047-strip-backslashes-in-quoted-strings ()
+ "Strip backslashes in quoted strings. `\\\"' remains."
+ (goto-char (point-min))
+ (let (beg)
+ (with-syntax-table (standard-syntax-table)
+ (while (search-forward "\"" nil t)
+ (unless (eq (char-before) ?\\)
+ (setq beg (match-end 0))
+ (goto-char (match-beginning 0))
+ (condition-case nil
+ (progn
+ (forward-sexp)
+ (save-restriction
+ (narrow-to-region beg (1- (point)))
+ (goto-char beg)
+ (while (search-forward "\\" nil 'move)
+ (unless (memq (char-after) '(?\"))
+ (delete-char -1))
+ (forward-char)))
+ (forward-char))
+ (error
+ (goto-char beg))))))))
+
+(defun rfc2047-charset-to-coding-system (charset &optional allow-override)
+ "Return coding-system corresponding to MIME CHARSET.
+If your Emacs implementation can't decode CHARSET, return nil.
+
+If allow-override is given, use `mm-charset-override-alist' to
+map undesired charset names to their replacement. This should
+only be used for decoding, not for encoding."
+ (when (stringp charset)
+ (setq charset (intern (downcase charset))))
+ (when (or (not charset)
+ (eq 'gnus-all mail-parse-ignored-charsets)
+ (memq 'gnus-all mail-parse-ignored-charsets)
+ (memq charset mail-parse-ignored-charsets))
+ (setq charset mail-parse-charset))
+ (let ((cs (mm-charset-to-coding-system charset nil allow-override)))
+ (cond ((eq cs 'ascii)
+ (setq cs (or (mm-charset-to-coding-system mail-parse-charset)
+ 'raw-text)))
+ ((mm-coding-system-p cs))
+ ((and charset
+ (listp mail-parse-ignored-charsets)
+ (memq 'gnus-unknown mail-parse-ignored-charsets))
+ (setq cs (mm-charset-to-coding-system mail-parse-charset))))
+ (if (eq cs 'ascii)
+ 'raw-text
+ cs)))
+
+(autoload 'quoted-printable-decode-string "qp")
+
+(defun rfc2047-decode-encoded-words (words)
+ "Decode successive encoded-words in WORDS and return a decoded string.
+Each element of WORDS looks like (CHARSET ENCODING ENCODED-TEXT
+ENCODED-WORD)."
+ (let (word charset cs encoding text rest)
+ (while words
+ (setq word (pop words))
+ (if (and (setq cs (rfc2047-charset-to-coding-system
+ (setq charset (car word)) t))
+ (condition-case code
+ (cond ((char-equal ?B (nth 1 word))
+ (setq text (base64-decode-string
+ (rfc2047-pad-base64 (nth 2 word)))))
+ ((char-equal ?Q (nth 1 word))
+ (setq text (quoted-printable-decode-string
+ (subst-char-in-string
+ ?_ ? (nth 2 word) t)))))
+ (error
+ (message "%s" (error-message-string code))
+ nil)))
+ (if (and rfc2047-allow-incomplete-encoded-text
+ (eq cs (caar rest)))
+ ;; Concatenate text of which the charset is the same.
+ (setcdr (car rest) (concat (cdar rest) text))
+ (push (cons cs text) rest))
+ ;; Don't decode encoded-word.
+ (push (cons nil (nth 3 word)) rest)))
+ (while rest
+ (setq words (concat
+ (or (and (setq cs (caar rest))
+ (condition-case code
+ (decode-coding-string (cdar rest) cs)
+ (error
+ (message "%s" (error-message-string code))
+ nil)))
+ (concat (when (cdr rest) " ")
+ (cdar rest)
+ (when (and words
+ (not (eq (string-to-char words) ? )))
+ " ")))
+ words)
+ rest (cdr rest)))
+ words))
+
+;; Fixme: This should decode in place, not cons intermediate strings.
+;; Also check whether it needs to worry about delimiting fields like
+;; encoding.
+
+;; In fact it's reported that (invalid) encoding of mailboxes in
+;; addr-specs is in use, so delimiting fields might help. Probably
+;; not decoding a word which isn't properly delimited is good enough
+;; and worthwhile (is it more correct or not?), e.g. something like
+;; `=?iso-8859-1?q?foo?=@'.
+
+(defun rfc2047-decode-region (start end &optional address-mime)
+ "Decode MIME-encoded words in region between START and END.
+If ADDRESS-MIME is non-nil, strip backslashes which precede characters
+other than `\"' and `\\' in quoted strings."
+ (interactive "r")
+ (let ((case-fold-search t)
+ (eword-regexp
+ (if rfc2047-allow-irregular-q-encoded-words
+ (eval-when-compile
+ (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp-loose "\\)"))
+ (eval-when-compile
+ (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp "\\)"))))
+ b e match words)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (when address-mime
+ (rfc2047-strip-backslashes-in-quoted-strings))
+ (goto-char (setq b start))
+ ;; Look for the encoded-words.
+ (while (setq match (re-search-forward eword-regexp nil t))
+ (setq e (match-beginning 1)
+ end (match-end 0)
+ words nil)
+ (while match
+ (push (list (match-string 2) ;; charset
+ (char-after (match-beginning 3)) ;; encoding
+ (substring (match-string 3) 2) ;; encoded-text
+ (match-string 1)) ;; encoded-word
+ words)
+ ;; Look for the subsequent encoded-words.
+ (when (setq match (looking-at eword-regexp))
+ (goto-char (setq end (match-end 0)))))
+ ;; Replace the encoded-words with the decoded one.
+ (delete-region e end)
+ (insert (rfc2047-decode-encoded-words (nreverse words)))
+ (save-restriction
+ (narrow-to-region e (point))
+ (goto-char e)
+ ;; Remove newlines between decoded words, though such
+ ;; things essentially must not be there.
+ (while (re-search-forward "[\n\r]+" nil t)
+ (replace-match " "))
+ (setq end (point-max))
+ ;; Quote decoded words if there are special characters
+ ;; which might violate RFC2822.
+ (when (and rfc2047-quote-decoded-words-containing-tspecials
+ (let ((regexp (car (rassq
+ 'address-mime
+ rfc2047-header-encoding-alist))))
+ (when regexp
+ (save-restriction
+ (widen)
+ (and
+ ;; Don't quote words if already quoted.
+ (not (and (eq (char-before e) ?\")
+ (eq (char-after end) ?\")))
+ (progn
+ (beginning-of-line)
+ (while (and (memq (char-after) '(? ?\t))
+ (zerop (forward-line -1))))
+ (looking-at regexp)))))))
+ (let (quoted)
+ (goto-char e)
+ (skip-chars-forward " \t")
+ (setq start (point))
+ (setq quoted (eq (char-after) ?\"))
+ (goto-char (point-max))
+ (skip-chars-backward " \t" start)
+ (if (setq quoted (and quoted
+ (> (point) (1+ start))
+ (eq (char-before) ?\")))
+ (progn
+ (backward-char)
+ (setq start (1+ start)
+ end (point-marker)))
+ (setq end (point-marker)))
+ (goto-char start)
+ (while (search-forward "\"" end t)
+ (when (prog2
+ (backward-char)
+ (zerop (% (skip-chars-backward "\\\\") 2))
+ (goto-char (match-beginning 0)))
+ (insert "\\"))
+ (forward-char))
+ (when (and (not quoted)
+ (progn
+ (goto-char start)
+ (re-search-forward
+ (concat "[" ietf-drums-tspecials "]")
+ end t)))
+ (goto-char start)
+ (insert "\"")
+ (goto-char end)
+ (insert "\""))
+ (set-marker end nil)))
+ (goto-char (point-max)))
+ (when (and (mm-multibyte-p)
+ mail-parse-charset
+ (not (eq mail-parse-charset 'us-ascii))
+ (not (eq mail-parse-charset 'gnus-decoded)))
+ (decode-coding-region b e mail-parse-charset))
+ (setq b (point)))
+ (when (and (mm-multibyte-p)
+ mail-parse-charset
+ (not (eq mail-parse-charset 'us-ascii))
+ (not (eq mail-parse-charset 'gnus-decoded)))
+ (decode-coding-region b (point-max) mail-parse-charset))))))
+
+(defun rfc2047-decode-address-region (start end)
+ "Decode MIME-encoded words in region between START and END.
+Backslashes which precede characters other than `\"' and `\\' in quoted
+strings are stripped."
+ (rfc2047-decode-region start end t))
+
+(defun rfc2047-decode-string (string &optional address-mime)
+ "Decode MIME-encoded STRING and return the result.
+If ADDRESS-MIME is non-nil, strip backslashes which precede characters
+other than `\"' and `\\' in quoted strings."
+ (if (string-match "=\\?" string)
+ (with-temp-buffer
+ ;; We used to only call mm-enable-multibyte if `m' is non-nil,
+ ;; but this can't be the right criterion. Don't just revert this
+ ;; change if it encounters a bug. Please help me fix it
+ ;; right instead. --Stef
+ ;; The string returned should always be multibyte in a multibyte
+ ;; session, i.e. the buffer should be multibyte before
+ ;; `buffer-string' is called.
+ (mm-enable-multibyte)
+ (insert string)
+ (inline
+ (rfc2047-decode-region (point-min) (point-max) address-mime))
+ (buffer-string))
+ (when address-mime
+ (setq string
+ (with-temp-buffer
+ (when (multibyte-string-p string)
+ (mm-enable-multibyte))
+ (insert string)
+ (rfc2047-strip-backslashes-in-quoted-strings)
+ (buffer-string))))
+ ;; Fixme: As above, `m' here is inappropriate.
+ (if (and ;; m
+ mail-parse-charset
+ (not (eq mail-parse-charset 'us-ascii))
+ (not (eq mail-parse-charset 'gnus-decoded)))
+ ;; `decode-coding-string' in Emacs offers a third optional
+ ;; arg NOCOPY to avoid consing a new string if the decoding
+ ;; is "trivial". Unfortunately it currently doesn't
+ ;; consider anything else than a nil coding system
+ ;; trivial.
+ ;; `rfc2047-decode-string' is called multiple times for each
+ ;; article during summary buffer generation, and we really
+ ;; want to avoid unnecessary consing. So we bypass
+ ;; `decode-coding-string' if the string is purely ASCII.
+ (if (eq (detect-coding-string string t) 'undecided)
+ ;; string is purely ASCII
+ string
+ (decode-coding-string string mail-parse-charset))
+ (string-to-multibyte string))))
+
+(defun rfc2047-decode-address-string (string)
+ "Decode MIME-encoded STRING and return the result.
+Backslashes which precede characters other than `\"' and `\\' in quoted
+strings are stripped."
+ (rfc2047-decode-string string t))
+
+(defun rfc2047-pad-base64 (string)
+ "Pad STRING to quartets."
+ ;; Be more liberal to accept buggy base64 strings. If
+ ;; base64-decode-string accepts buggy strings, this function could
+ ;; be aliased to identity.
+ (if (= 0 (mod (length string) 4))
+ string
+ (when (string-match "=+$" string)
+ (setq string (substring string 0 (match-beginning 0))))
+ (case (mod (length string) 4)
+ (0 string)
+ (1 string) ;; Error, don't pad it.
+ (2 (concat string "=="))
+ (3 (concat string "=")))))
+
+(provide 'rfc2047)
+
+;;; rfc2047.el ends here
--- /dev/null
+;;; rfc2231.el --- Functions for decoding rfc2231 headers
+
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'ietf-drums)
+(require 'rfc2047)
+(autoload 'mm-encode-body "mm-bodies")
+(autoload 'mail-header-remove-whitespace "mail-parse")
+(autoload 'mail-header-remove-comments "mail-parse")
+
+(defun rfc2231-get-value (ct attribute)
+ "Return the value of ATTRIBUTE from CT."
+ (cdr (assq attribute (cdr ct))))
+
+(defun rfc2231-parse-qp-string (string)
+ "Parse QP-encoded string using `rfc2231-parse-string'.
+N.B. This is in violation with RFC2047, but it seem to be in common use."
+ (rfc2231-parse-string (rfc2047-decode-string string)))
+
+(defun rfc2231-parse-string (string &optional signal-error)
+ "Parse STRING and return a list.
+The list will be on the form
+ `(name (attribute . value) (attribute . value)...)'.
+
+If the optional SIGNAL-ERROR is non-nil, signal an error when this
+function fails in parsing of parameters. Otherwise, this function
+must never cause a Lisp error."
+ (with-temp-buffer
+ (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token))
+ (stoken (ietf-drums-token-to-list ietf-drums-tspecials))
+ (ntoken (ietf-drums-token-to-list "0-9"))
+ c type attribute encoded number parameters value)
+ (ietf-drums-init
+ (condition-case nil
+ (mail-header-remove-whitespace
+ (mail-header-remove-comments string))
+ ;; The most likely cause of an error is unbalanced parentheses
+ ;; or double-quotes. If all parentheses and double-quotes are
+ ;; quoted meaninglessly with backslashes, removing them might
+ ;; make it parsable. Let's try...
+ (error
+ (let (mod)
+ (when (and (string-match "\\\\\"" string)
+ (not (string-match "\\`\"\\|[^\\]\"" string)))
+ (setq string (replace-regexp-in-string "\\\\\"" "\"" string)
+ mod t))
+ (when (and (string-match "\\\\(" string)
+ (string-match "\\\\)" string)
+ (not (string-match "\\`(\\|[^\\][()]" string)))
+ (setq string (replace-regexp-in-string
+ "\\\\\\([()]\\)" "\\1" string)
+ mod t))
+ (or (and mod
+ (ignore-errors
+ (mail-header-remove-whitespace
+ (mail-header-remove-comments string))))
+ ;; Finally, attempt to extract only type.
+ (if (string-match
+ (concat "\\`[\t\n ]*\\([^" ietf-drums-tspecials "\t\n ]+"
+ "\\(?:/[^" ietf-drums-tspecials
+ "\t\n ]+\\)?\\)\\(?:[\t\n ;]\\|\\'\\)")
+ string)
+ (match-string 1 string)
+ ""))))))
+ (let ((table (copy-syntax-table ietf-drums-syntax-table)))
+ (modify-syntax-entry ?\' "w" table)
+ (modify-syntax-entry ?* " " table)
+ (modify-syntax-entry ?\; " " table)
+ (modify-syntax-entry ?= " " table)
+ ;; The following isn't valid, but one should be liberal
+ ;; in what one receives.
+ (modify-syntax-entry ?\: "w" table)
+ (set-syntax-table table))
+ (setq c (char-after))
+ (when (and (memq c ttoken)
+ (not (memq c stoken))
+ (setq type (ignore-errors
+ (downcase
+ (buffer-substring (point) (progn
+ (forward-sexp 1)
+ (point)))))))
+ ;; Do the params
+ (condition-case err
+ (progn
+ (while (not (eobp))
+ (setq c (char-after))
+ (unless (eq c ?\;)
+ (error "Invalid header: %s" string))
+ (forward-char 1)
+ ;; If c in nil, then this is an invalid header, but
+ ;; since elm generates invalid headers on this form,
+ ;; we allow it.
+ (when (setq c (char-after))
+ (if (and (memq c ttoken)
+ (not (memq c stoken)))
+ (setq attribute
+ (intern
+ (downcase
+ (buffer-substring
+ (point) (progn (forward-sexp 1) (point))))))
+ (error "Invalid header: %s" string))
+ (setq c (char-after))
+ (if (eq c ?*)
+ (progn
+ (forward-char 1)
+ (setq c (char-after))
+ (if (not (memq c ntoken))
+ (setq encoded t
+ number nil)
+ (setq number
+ (string-to-number
+ (buffer-substring
+ (point) (progn (forward-sexp 1) (point)))))
+ (setq c (char-after))
+ (when (eq c ?*)
+ (setq encoded t)
+ (forward-char 1)
+ (setq c (char-after)))))
+ (setq number nil
+ encoded nil))
+ (unless (eq c ?=)
+ (error "Invalid header: %s" string))
+ (forward-char 1)
+ (setq c (char-after))
+ (cond
+ ((eq c ?\")
+ (setq value (buffer-substring (1+ (point))
+ (progn
+ (forward-sexp 1)
+ (1- (point)))))
+ (when encoded
+ (setq value (mapconcat (lambda (c) (format "%%%02x" c))
+ value ""))))
+ ((and (or (memq c ttoken)
+ ;; EXTENSION: Support non-ascii chars.
+ (> c ?\177))
+ (not (memq c stoken)))
+ (setq value
+ (buffer-substring
+ (point)
+ (progn
+ ;; Jump over asterisk, non-ASCII
+ ;; and non-boundary characters.
+ (while (and c
+ (or (eq c ?*)
+ (> c ?\177)
+ (not (eq (char-syntax c) ? ))))
+ (forward-char 1)
+ (setq c (char-after)))
+ (point)))))
+ (t
+ (error "Invalid header: %s" string)))
+ (push (list attribute value number encoded)
+ parameters))))
+ (error
+ (setq parameters nil)
+ (when signal-error
+ (signal (car err) (cdr err)))))
+
+ ;; Now collect and concatenate continuation parameters.
+ (let ((cparams nil)
+ elem)
+ (loop for (attribute value part encoded)
+ in (sort parameters (lambda (e1 e2)
+ (< (or (caddr e1) 0)
+ (or (caddr e2) 0))))
+ do (cond
+ ;; First part.
+ ((or (not (setq elem (assq attribute cparams)))
+ (and (numberp part)
+ (zerop part)))
+ (push (list attribute value encoded) cparams))
+ ;; Repetition of a part; do nothing.
+ ((and elem
+ (null number))
+ )
+ ;; Concatenate continuation parts.
+ (t
+ (setcar (cdr elem) (concat (cadr elem) value)))))
+ ;; Finally decode encoded values.
+ (cons type (mapcar
+ (lambda (elem)
+ (cons (car elem)
+ (if (nth 2 elem)
+ (rfc2231-decode-encoded-string (nth 1 elem))
+ (nth 1 elem))))
+ (nreverse cparams))))))))
+
+(defun rfc2231-decode-encoded-string (string)
+ "Decode an RFC2231-encoded string.
+These look like:
+ \"us-ascii\\='en-us\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\",
+ \"us-ascii\\='\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\",
+ \"\\='en-us\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\",
+ \"\\='\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", or
+ \"This is ***fun***\"."
+ (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string)
+ (let ((coding-system (mm-charset-to-coding-system
+ (match-string 1 string) nil t))
+ ;;(language (match-string 2 string))
+ (value (match-string 3 string)))
+ (mm-with-unibyte-buffer
+ (insert value)
+ (goto-char (point-min))
+ (while (re-search-forward "%\\([0-9A-Fa-f][0-9A-Fa-f]\\)" nil t)
+ (insert
+ (prog1
+ (string-to-number (match-string 1) 16)
+ (delete-region (match-beginning 0) (match-end 0)))))
+ ;; Decode using the charset, if any.
+ (if (memq coding-system '(nil ascii))
+ (buffer-string)
+ (decode-coding-string (buffer-string) coding-system)))))
+
+(defun rfc2231-encode-string (param value)
+ "Return and PARAM=VALUE string encoded according to RFC2231.
+Use `mml-insert-parameter' or `mml-insert-parameter-string' to insert
+the result of this function."
+ (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token))
+ (tspecial (ietf-drums-token-to-list ietf-drums-tspecials))
+ (special (ietf-drums-token-to-list "*'%\n\t"))
+ (ascii (ietf-drums-token-to-list ietf-drums-text-token))
+ (num -1)
+ ;; Don't make lines exceeding 76 column.
+ (limit (- 74 (length param)))
+ spacep encodep charsetp charset broken)
+ (mm-with-multibyte-buffer
+ (insert value)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (cond
+ ((or (memq (following-char) control)
+ (memq (following-char) tspecial)
+ (memq (following-char) special))
+ (setq encodep t))
+ ((eq (following-char) ? )
+ (setq spacep t))
+ ((not (memq (following-char) ascii))
+ (setq charsetp t)))
+ (forward-char 1))
+ (when charsetp
+ (setq charset (mm-encode-body)))
+ (mm-disable-multibyte)
+ (cond
+ ((or encodep charsetp
+ (progn
+ (end-of-line)
+ (> (current-column) (if spacep (- limit 2) limit))))
+ (setq limit (- limit 6))
+ (goto-char (point-min))
+ (insert (symbol-name (or charset 'us-ascii)) "''")
+ (while (not (eobp))
+ (if (or (not (memq (following-char) ascii))
+ (memq (following-char) control)
+ (memq (following-char) tspecial)
+ (memq (following-char) special)
+ (eq (following-char) ? ))
+ (progn
+ (when (>= (current-column) (1- limit))
+ (insert ";\n")
+ (setq broken t))
+ (insert "%" (format "%02x" (following-char)))
+ (delete-char 1))
+ (when (> (current-column) limit)
+ (insert ";\n")
+ (setq broken t))
+ (forward-char 1)))
+ (goto-char (point-min))
+ (if (not broken)
+ (insert param "*=")
+ (while (not (eobp))
+ (insert (if (>= num 0) " " "")
+ param "*" (format "%d" (incf num)) "*=")
+ (forward-line 1))))
+ (spacep
+ (goto-char (point-min))
+ (insert param "=\"")
+ (goto-char (point-max))
+ (insert "\""))
+ (t
+ (goto-char (point-min))
+ (insert param "=")))
+ (buffer-string))))
+
+(provide 'rfc2231)
+
+;;; rfc2231.el ends here
--- /dev/null
+;;; yenc.el --- elisp native yenc decoder
+
+;; Copyright (C) 2002-2016 Free Software Foundation, Inc.
+
+;; Author: Jesper Harder <harder@ifa.au.dk>
+;; Keywords: yenc news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Functions for decoding yenc encoded messages.
+;;
+;; Limitations:
+;;
+;; * Does not handle multipart messages.
+;; * No support for external decoders.
+;; * Doesn't check the crc32 checksum (if present).
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(defconst yenc-begin-line
+ "^=ybegin.*$")
+
+(defconst yenc-decoding-vector
+ [214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230
+ 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
+ 248 249 250 251 252 253 254 255 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
+ 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
+ 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
+ 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
+ 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
+ 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
+ 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139
+ 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
+ 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173
+ 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190
+ 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
+ 208 209 210 211 212 213])
+
+(defun yenc-first-part-p ()
+ "Say whether the buffer contains the first part of a yEnc file."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "^=ybegin part=1 " nil t)))
+
+(defun yenc-last-part-p ()
+ "Say whether the buffer contains the last part of a yEnc file."
+ (save-excursion
+ (goto-char (point-min))
+ (let (total-size end-size)
+ (when (re-search-forward "^=ybegin.*size=\\([0-9]+\\)" nil t)
+ (setq total-size (match-string 1)))
+ (when (re-search-forward "^=ypart.*end=\\([0-9]+\\)" nil t)
+ (setq end-size (match-string 1)))
+ (and total-size
+ end-size
+ (string= total-size end-size)))))
+
+;;;###autoload
+(defun yenc-decode-region (start end)
+ "Yenc decode region between START and END using an internal decoder."
+ (interactive "r")
+ (let (work-buffer)
+ (unwind-protect
+ (save-excursion
+ (goto-char start)
+ (when (re-search-forward yenc-begin-line end t)
+ (let ((first (match-end 0))
+ (header-alist (yenc-parse-line (match-string 0)))
+ bytes last footer-alist char)
+ (when (re-search-forward "^=ypart.*$" end t)
+ (setq first (match-end 0)))
+ (when (re-search-forward "^=yend.*$" end t)
+ (setq last (match-beginning 0))
+ (setq footer-alist (yenc-parse-line (match-string 0)))
+ (setq work-buffer (generate-new-buffer " *yenc-work*"))
+ (with-current-buffer work-buffer
+ (set-buffer-multibyte nil))
+ (while (< first last)
+ (setq char (char-after first))
+ (cond ((or (eq char ?\r)
+ (eq char ?\n)))
+ ((eq char ?=)
+ (setq char (char-after (incf first)))
+ (with-current-buffer work-buffer
+ (insert-char (mod (- char 106) 256) 1)))
+ (t
+ (with-current-buffer work-buffer
+ ;;(insert-char (mod (- char 42) 256) 1)
+ (insert-char (aref yenc-decoding-vector char) 1))))
+ (incf first))
+ (setq bytes (buffer-size work-buffer))
+ (unless (and (= (cdr (assq 'size header-alist)) bytes)
+ (= (cdr (assq 'size footer-alist)) bytes))
+ (message "Warning: Size mismatch while decoding."))
+ (goto-char start)
+ (delete-region start end)
+ (insert-buffer-substring work-buffer))))
+ (and work-buffer (kill-buffer work-buffer))))))
+
+;;;###autoload
+(defun yenc-extract-filename ()
+ "Extract file name from an yenc header."
+ (save-excursion
+ (when (re-search-forward yenc-begin-line nil t)
+ (cdr (assoc 'name (yenc-parse-line (match-string 0)))))))
+
+(defun yenc-parse-line (str)
+ "Extract file name and size from STR."
+ (let (result name)
+ (when (string-match "^=y.*size=\\([0-9]+\\)" str)
+ (push (cons 'size (string-to-number (match-string 1 str))) result))
+ (when (string-match "^=y.*name=\\(.*\\)$" str)
+ (setq name (match-string 1 str))
+ ;; Remove trailing white space
+ (when (string-match " +$" name)
+ (setq name (substring name 0 (match-beginning 0))))
+ (push (cons 'name name) result))
+ result))
+
+(provide 'yenc)
+
+;;; yenc.el ends here
--- /dev/null
+;;; html2text.el --- a simple html to plain text converter -*- coding: utf-8 -*-
+
+;; Copyright (C) 2002-2016 Free Software Foundation, Inc.
+
+;; Author: Joakim Hove <hove@phys.ntnu.no>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; These functions provide a simple way to wash/clean html infected
+;; mails. Definitely do not work in all cases, but some improvement
+;; in readability is generally obtained. Formatting is only done in
+;; the buffer, so the next time you enter the article it will be
+;; "re-htmlized".
+;;
+;; The main function is `html2text'.
+
+;;; Code:
+
+;;
+;; <Global variables>
+;;
+
+(eval-when-compile
+ (require 'cl))
+
+(defvar html2text-format-single-element-list '(("hr" . html2text-clean-hr)))
+
+(defvar html2text-replace-list
+ '(("´" . "`")
+ ("&" . "&")
+ ("'" . "'")
+ ("¦" . "|")
+ ("¢" . "c")
+ ("ˆ" . "^")
+ ("©" . "(C)")
+ ("¤" . "(#)")
+ ("°" . "degree")
+ ("÷" . "/")
+ ("€" . "e")
+ ("½" . "1/2")
+ (">" . ">")
+ ("¿" . "?")
+ ("«" . "<<")
+ ("&ldquo" . "\"")
+ ("‹" . "(")
+ ("‘" . "`")
+ ("<" . "<")
+ ("—" . "--")
+ (" " . " ")
+ ("–" . "-")
+ ("‰" . "%%")
+ ("±" . "+-")
+ ("£" . "£")
+ (""" . "\"")
+ ("»" . ">>")
+ ("&rdquo" . "\"")
+ ("®" . "(R)")
+ ("›" . ")")
+ ("’" . "'")
+ ("§" . "§")
+ ("¹" . "^1")
+ ("²" . "^2")
+ ("³" . "^3")
+ ("˜" . "~"))
+ "The map of entity to text.
+
+This is an alist were each element is a dotted pair consisting of an
+old string, and a replacement string. This replacement is done by the
+function `html2text-substitute' which basically performs a
+`replace-string' operation for every element in the list. This is
+completely verbatim - without any use of REGEXP.")
+
+(defvar html2text-remove-tag-list
+ '("html" "body" "p" "img" "dir" "head" "div" "br" "font" "title" "meta")
+ "A list of removable tags.
+
+This is a list of tags which should be removed, without any
+formatting. Note that tags in the list are presented *without*
+any \"<\" or \">\". All occurrences of a tag appearing in this
+list are removed, irrespective of whether it is a closing or
+opening tag, or if the tag has additional attributes. The
+deletion is done by the function `html2text-remove-tags'.
+
+For instance the text:
+
+\"Here comes something <font size\"+3\" face=\"Helvetica\"> big </font>.\"
+
+will be reduced to:
+
+\"Here comes something big.\"
+
+If this list contains the element \"font\".")
+
+(defvar html2text-format-tag-list
+ '(("b" . html2text-clean-bold)
+ ("strong" . html2text-clean-bold)
+ ("u" . html2text-clean-underline)
+ ("i" . html2text-clean-italic)
+ ("em" . html2text-clean-italic)
+ ("blockquote" . html2text-clean-blockquote)
+ ("a" . html2text-clean-anchor)
+ ("ul" . html2text-clean-ul)
+ ("ol" . html2text-clean-ol)
+ ("dl" . html2text-clean-dl)
+ ("center" . html2text-clean-center))
+ "An alist of tags and processing functions.
+
+This is an alist where each dotted pair consists of a tag, and then
+the name of a function to be called when this tag is found. The
+function is called with the arguments p1, p2, p3 and p4. These are
+demonstrated below:
+
+\"<b> This is bold text </b>\"
+ ^ ^ ^ ^
+ | | | |
+p1 p2 p3 p4
+
+Then the called function will typically format the text somewhat and
+remove the tags.")
+
+(defvar html2text-remove-tag-list2 '("li" "dt" "dd" "meta")
+ "Another list of removable tags.
+
+This is a list of tags which are removed similarly to the list
+`html2text-remove-tag-list' - but these tags are retained for the
+formatting, and then moved afterward.")
+
+;;
+;; </Global variables>
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;
+;; <Utility functions>
+;;
+
+
+(defun html2text-replace-string (from-string to-string min max)
+ "Replace FROM-STRING with TO-STRING in region from MIN to MAX."
+ (goto-char min)
+ (let ((delta (- (string-width to-string) (string-width from-string)))
+ (change 0))
+ (while (search-forward from-string max t)
+ (replace-match to-string)
+ (setq change (+ change delta)))
+ change))
+
+;;
+;; </Utility functions>
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;
+;; <Functions related to attributes> i.e. <font size=+3>
+;;
+
+(defun html2text-attr-value (list attribute)
+ "Get value of ATTRIBUTE from LIST."
+ (nth 1 (assoc attribute list)))
+
+(defun html2text-get-attr (p1 p2)
+ (goto-char p1)
+ (re-search-forward "\\s-+" p2 t)
+ (let (attr-list)
+ (while (re-search-forward "[-a-z0-9._]+" p2 t)
+ (setq attr-list
+ (cons
+ (list (match-string 0)
+ (when (looking-at "\\s-*=")
+ (goto-char (match-end 0))
+ (skip-chars-forward "[:space:]")
+ (when (or (looking-at "\"[^\"]*\"\\|'[^']*'")
+ (looking-at "[-a-z0-9._:]+"))
+ (goto-char (match-end 0))
+ (match-string 0))))
+ attr-list)))
+ attr-list))
+
+;;
+;; </Functions related to attributes>
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;
+;; <Functions to be called to format a tag-pair>
+;;
+(defun html2text-clean-list-items (p1 p2 list-type)
+ (goto-char p1)
+ (let ((item-nr 0)
+ (items 0))
+ (while (search-forward "<li>" p2 t)
+ (setq items (1+ items)))
+ (goto-char p1)
+ (while (< item-nr items)
+ (setq item-nr (1+ item-nr))
+ (search-forward "<li>" (point-max) t)
+ (cond
+ ((string= list-type "ul") (insert " o "))
+ ((string= list-type "ol") (insert (format " %s: " item-nr)))
+ (t (insert " x "))))))
+
+(defun html2text-clean-dtdd (p1 p2)
+ (goto-char p1)
+ (let ((items 0)
+ (item-nr 0))
+ (while (search-forward "<dt>" p2 t)
+ (setq items (1+ items)))
+ (goto-char p1)
+ (while (< item-nr items)
+ (setq item-nr (1+ item-nr))
+ (re-search-forward "<dt>\\([ ]*\\)" (point-max) t)
+ (when (match-string 1)
+ (delete-region (point) (- (point) (string-width (match-string 1)))))
+ (let ((def-p1 (point))
+ (def-p2 0))
+ (re-search-forward "\\([ ]*\\)\\(</dt>\\|<dd>\\)" (point-max) t)
+ (if (match-string 1)
+ (progn
+ (let* ((mw1 (string-width (match-string 1)))
+ (mw2 (string-width (match-string 2)))
+ (mw (+ mw1 mw2)))
+ (goto-char (- (point) mw))
+ (delete-region (point) (+ (point) mw1))
+ (setq def-p2 (point))))
+ (setq def-p2 (- (point) (string-width (match-string 2)))))
+ (put-text-property def-p1 def-p2 'face 'bold)))))
+
+(defun html2text-delete-tags (p1 p2 p3 p4)
+ (delete-region p1 p2)
+ (delete-region (- p3 (- p2 p1)) (- p4 (- p2 p1))))
+
+(defun html2text-delete-single-tag (p1 p2)
+ (delete-region p1 p2))
+
+(defun html2text-clean-hr (p1 p2)
+ (html2text-delete-single-tag p1 p2)
+ (goto-char p1)
+ (newline 1)
+ (insert (make-string fill-column ?-)))
+
+(defun html2text-clean-ul (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4)
+ (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ul"))
+
+(defun html2text-clean-ol (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4)
+ (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ol"))
+
+(defun html2text-clean-dl (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4)
+ (html2text-clean-dtdd p1 (- p3 (- p1 p2))))
+
+(defun html2text-clean-center (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4)
+ (center-region p1 (- p3 (- p2 p1))))
+
+(defun html2text-clean-bold (p1 p2 p3 p4)
+ (put-text-property p2 p3 'face 'bold)
+ (html2text-delete-tags p1 p2 p3 p4))
+
+(defun html2text-clean-title (p1 p2 p3 p4)
+ (put-text-property p2 p3 'face 'bold)
+ (html2text-delete-tags p1 p2 p3 p4))
+
+(defun html2text-clean-underline (p1 p2 p3 p4)
+ (put-text-property p2 p3 'face 'underline)
+ (html2text-delete-tags p1 p2 p3 p4))
+
+(defun html2text-clean-italic (p1 p2 p3 p4)
+ (put-text-property p2 p3 'face 'italic)
+ (html2text-delete-tags p1 p2 p3 p4))
+
+(defun html2text-clean-font (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4))
+
+(defun html2text-clean-blockquote (p1 p2 p3 p4)
+ (html2text-delete-tags p1 p2 p3 p4))
+
+(defun html2text-clean-anchor (p1 p2 p3 p4)
+ ;; If someone can explain how to make the URL clickable I will surely
+ ;; improve upon this.
+ ;; Maybe `goto-addr.el' can be used here.
+ (let* ((attr-list (html2text-get-attr p1 p2))
+ (href (html2text-attr-value attr-list "href")))
+ (delete-region p1 p4)
+ (when href
+ (goto-char p1)
+ (insert (if (string-match "\\`['\"].*['\"]\\'" href)
+ (substring href 1 -1) href))
+ (put-text-property p1 (point) 'face 'bold))))
+
+;;
+;; </Functions to be called to format a tag-pair>
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;
+;; <Functions to be called to fix up paragraphs>
+;;
+
+(defun html2text-fix-paragraph (p1 p2)
+ (goto-char p1)
+ (let ((refill-start)
+ (refill-stop))
+ (when (re-search-forward "<br>$" p2 t)
+ (goto-char p1)
+ (when (re-search-forward ".+[^<][^b][^r][^>]$" p2 t)
+ (beginning-of-line)
+ (setq refill-start (point))
+ (goto-char p2)
+ (re-search-backward ".+[^<][^b][^r][^>]$" refill-start t)
+ (forward-line 1)
+ (end-of-line)
+ ;; refill-stop should ideally be adjusted to
+ ;; accommodate the "<br>" strings which are removed
+ ;; between refill-start and refill-stop. Can simply
+ ;; be returned from my-replace-string
+ (setq refill-stop (+ (point)
+ (html2text-replace-string
+ "<br>" ""
+ refill-start (point))))
+ ;; (message "Point = %s refill-stop = %s" (point) refill-stop)
+ ;; (sleep-for 4)
+ (fill-region refill-start refill-stop))))
+ (html2text-replace-string "<br>" "" p1 p2))
+
+;;
+;; This one is interactive ...
+;;
+(defun html2text-fix-paragraphs ()
+ "This _tries_ to fix up the paragraphs - this is done in quite a ad-hook
+fashion, quite close to pure guess-work. It does work in some cases though."
+ (interactive)
+ (goto-char (point-min))
+ (while (re-search-forward "^<br>$" nil t)
+ (delete-region (match-beginning 0) (match-end 0)))
+ ;; Removing lonely <br> on a single line, if they are left intact we
+ ;; don't have any paragraphs at all.
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let ((p1 (point)))
+ (forward-paragraph 1)
+ ;;(message "Kaller fix med p1=%s p2=%s " p1 (1- (point))) (sleep-for 5)
+ (html2text-fix-paragraph p1 (1- (point)))
+ (goto-char p1)
+ (when (not (eobp))
+ (forward-paragraph 1)))))
+
+;;
+;; </Functions to be called to fix up paragraphs>
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;
+;; <Interactive functions>
+;;
+
+(defun html2text-remove-tags (tag-list)
+ "Removes the tags listed in the list `html2text-remove-tag-list'.
+See the documentation for that variable."
+ (interactive)
+ (dolist (tag tag-list)
+ (goto-char (point-min))
+ (while (re-search-forward (format "\\(</?%s[^>]*>\\)" tag) (point-max) t)
+ (delete-region (match-beginning 0) (match-end 0)))))
+
+(defun html2text-format-tags ()
+ "See the variable `html2text-format-tag-list' for documentation."
+ (interactive)
+ (dolist (tag-and-function html2text-format-tag-list)
+ (let ((tag (car tag-and-function))
+ (function (cdr tag-and-function)))
+ (goto-char (point-min))
+ (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag)
+ (point-max) t)
+ (let ((p1)
+ (p2 (point))
+ (p3) (p4))
+ (search-backward "<" (point-min) t)
+ (setq p1 (point))
+ (unless (search-forward (format "</%s>" tag) (point-max) t)
+ (goto-char p2)
+ (insert (format "</%s>" tag)))
+ (setq p4 (point))
+ (search-backward "</" (point-min) t)
+ (setq p3 (point))
+ (funcall function p1 p2 p3 p4)
+ (goto-char p1))))))
+
+(defun html2text-substitute ()
+ "See the variable `html2text-replace-list' for documentation."
+ (interactive)
+ (dolist (e html2text-replace-list)
+ (goto-char (point-min))
+ (let ((old-string (car e))
+ (new-string (cdr e)))
+ (html2text-replace-string old-string new-string (point-min) (point-max)))))
+
+(defun html2text-format-single-elements ()
+ (interactive)
+ (dolist (tag-and-function html2text-format-single-element-list)
+ (let ((tag (car tag-and-function))
+ (function (cdr tag-and-function)))
+ (goto-char (point-min))
+ (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag)
+ (point-max) t)
+ (let ((p1)
+ (p2 (point)))
+ (search-backward "<" (point-min) t)
+ (setq p1 (point))
+ (funcall function p1 p2))))))
+
+;;
+;; Main function
+;;
+
+;;;###autoload
+(defun html2text ()
+ "Convert HTML to plain text in the current buffer."
+ (interactive)
+ (save-excursion
+ (let ((case-fold-search t)
+ (buffer-read-only))
+ (html2text-remove-tags html2text-remove-tag-list)
+ (html2text-format-tags)
+ (html2text-remove-tags html2text-remove-tag-list2)
+ (html2text-substitute)
+ (html2text-format-single-elements)
+ (html2text-fix-paragraphs))))
+
+;;
+;; </Interactive functions>
+;;
+(provide 'html2text)
+
+;;; html2text.el ends here
--- /dev/null
+;;; mailcap.el --- MIME media types configuration
+
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
+
+;; Author: William M. Perry <wmperry@aventail.com>
+;; Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: news, mail, multimedia
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Provides configuration of MIME media types from directly from Lisp
+;; and via the usual mailcap mechanism (RFC 1524). Deals with
+;; mime.types similarly.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(autoload 'mail-header-parse-content-type "mail-parse")
+
+(defgroup mailcap nil
+ "Definition of viewers for MIME types."
+ :version "21.1"
+ :group 'mime)
+
+(defvar mailcap-parse-args-syntax-table
+ (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
+ (modify-syntax-entry ?' "\"" table)
+ (modify-syntax-entry ?` "\"" table)
+ (modify-syntax-entry ?{ "(" table)
+ (modify-syntax-entry ?} ")" table)
+ table)
+ "A syntax table for parsing SGML attributes.")
+
+(defvar mailcap-print-command
+ (mapconcat 'identity
+ (cons (if (boundp 'lpr-command)
+ lpr-command
+ "lpr")
+ (when (boundp 'lpr-switches)
+ (if (stringp lpr-switches)
+ (list lpr-switches)
+ lpr-switches)))
+ " ")
+ "Shell command (including switches) used to print PostScript files.")
+
+;; Postpone using defcustom for this as it's so big and we essentially
+;; have to have two copies of the data around then. Perhaps just
+;; customize the Lisp viewers and rely on the normal configuration
+;; files for the rest? -- fx
+(defvar mailcap-mime-data
+ `(("application"
+ ("vnd\\.ms-excel"
+ (viewer . "gnumeric %s")
+ (test . (getenv "DISPLAY"))
+ (type . "application/vnd.ms-excel"))
+ ("x-x509-ca-cert"
+ (viewer . ssl-view-site-cert)
+ (type . "application/x-x509-ca-cert"))
+ ("x-x509-user-cert"
+ (viewer . ssl-view-user-cert)
+ (type . "application/x-x509-user-cert"))
+ ("octet-stream"
+ (viewer . mailcap-save-binary-file)
+ (non-viewer . t)
+ (type . "application/octet-stream"))
+ ("dvi"
+ (viewer . "xdvi -safer %s")
+ (test . (eq window-system 'x))
+ ("needsx11")
+ (type . "application/dvi")
+ ("print" . "dvips -qRP %s"))
+ ("dvi"
+ (viewer . "dvitty %s")
+ (test . (not (getenv "DISPLAY")))
+ (type . "application/dvi")
+ ("print" . "dvips -qRP %s"))
+ ("emacs-lisp"
+ (viewer . mailcap-maybe-eval)
+ (type . "application/emacs-lisp"))
+ ("x-emacs-lisp"
+ (viewer . mailcap-maybe-eval)
+ (type . "application/x-emacs-lisp"))
+ ("x-tar"
+ (viewer . mailcap-save-binary-file)
+ (non-viewer . t)
+ (type . "application/x-tar"))
+ ("x-latex"
+ (viewer . tex-mode)
+ (type . "application/x-latex"))
+ ("x-tex"
+ (viewer . tex-mode)
+ (type . "application/x-tex"))
+ ("latex"
+ (viewer . tex-mode)
+ (type . "application/latex"))
+ ("tex"
+ (viewer . tex-mode)
+ (type . "application/tex"))
+ ("texinfo"
+ (viewer . texinfo-mode)
+ (type . "application/tex"))
+ ("zip"
+ (viewer . mailcap-save-binary-file)
+ (non-viewer . t)
+ (type . "application/zip")
+ ("copiousoutput"))
+ ("pdf"
+ (viewer . pdf-view-mode)
+ (type . "application/pdf")
+ (test . (eq window-system 'x)))
+ ("pdf"
+ (viewer . doc-view-mode)
+ (type . "application/pdf")
+ (test . (eq window-system 'x)))
+ ("pdf"
+ (viewer . "gv -safer %s")
+ (type . "application/pdf")
+ (test . window-system)
+ ("print" . ,(concat "pdf2ps %s - | " mailcap-print-command)))
+ ("pdf"
+ (viewer . "gpdf %s")
+ (type . "application/pdf")
+ ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
+ (test . (eq window-system 'x)))
+ ("pdf"
+ (viewer . "xpdf %s")
+ (type . "application/pdf")
+ ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
+ (test . (eq window-system 'x)))
+ ("pdf"
+ (viewer . ,(concat "pdftotext %s -"))
+ (type . "application/pdf")
+ ("print" . ,(concat "pdftops %s - | " mailcap-print-command))
+ ("copiousoutput"))
+ ("postscript"
+ (viewer . "gv -safer %s")
+ (type . "application/postscript")
+ (test . window-system)
+ ("print" . ,(concat mailcap-print-command " %s"))
+ ("needsx11"))
+ ("postscript"
+ (viewer . "ghostview -dSAFER %s")
+ (type . "application/postscript")
+ (test . (eq window-system 'x))
+ ("print" . ,(concat mailcap-print-command " %s"))
+ ("needsx11"))
+ ("postscript"
+ (viewer . "ps2ascii %s")
+ (type . "application/postscript")
+ (test . (not (getenv "DISPLAY")))
+ ("print" . ,(concat mailcap-print-command " %s"))
+ ("copiousoutput"))
+ ("sieve"
+ (viewer . sieve-mode)
+ (type . "application/sieve"))
+ ("pgp-keys"
+ (viewer . "gpg --import --interactive --verbose")
+ (type . "application/pgp-keys")
+ ("needsterminal")))
+ ("audio"
+ ("x-mpeg"
+ (viewer . "maplay %s")
+ (type . "audio/x-mpeg"))
+ (".*"
+ (viewer . "showaudio")
+ (type . "audio/*")))
+ ("message"
+ ("rfc-*822"
+ (viewer . mm-view-message)
+ (test . (and (featurep 'gnus)
+ (gnus-alive-p)))
+ (type . "message/rfc822"))
+ ("rfc-*822"
+ (viewer . vm-mode)
+ (type . "message/rfc822"))
+ ("rfc-*822"
+ (viewer . view-mode)
+ (type . "message/rfc822")))
+ ("image"
+ ("x-xwd"
+ (viewer . "xwud -in %s")
+ (type . "image/x-xwd")
+ ("compose" . "xwd -frame > %s")
+ (test . (eq window-system 'x))
+ ("needsx11"))
+ ("x11-dump"
+ (viewer . "xwud -in %s")
+ (type . "image/x-xwd")
+ ("compose" . "xwd -frame > %s")
+ (test . (eq window-system 'x))
+ ("needsx11"))
+ ("windowdump"
+ (viewer . "xwud -in %s")
+ (type . "image/x-xwd")
+ ("compose" . "xwd -frame > %s")
+ (test . (eq window-system 'x))
+ ("needsx11"))
+ (".*"
+ (viewer . "display %s")
+ (type . "image/*")
+ (test . (eq window-system 'x))
+ ("needsx11"))
+ (".*"
+ (viewer . "ee %s")
+ (type . "image/*")
+ (test . (eq window-system 'x))
+ ("needsx11")))
+ ("text"
+ ("plain"
+ (viewer . view-mode)
+ (type . "text/plain"))
+ ("plain"
+ (viewer . fundamental-mode)
+ (type . "text/plain"))
+ ("enriched"
+ (viewer . enriched-decode)
+ (type . "text/enriched"))
+ ("dns"
+ (viewer . dns-mode)
+ (type . "text/dns")))
+ ("video"
+ ("mpeg"
+ (viewer . "mpeg_play %s")
+ (type . "video/mpeg")
+ (test . (eq window-system 'x))
+ ("needsx11")))
+ ("x-world"
+ ("x-vrml"
+ (viewer . "webspace -remote %s -URL %u")
+ (type . "x-world/x-vrml")
+ ("description"
+ "VRML document")))
+ ("archive"
+ ("tar"
+ (viewer . tar-mode)
+ (type . "archive/tar"))))
+ "The mailcap structure is an assoc list of assoc lists.
+1st assoc list is keyed on the major content-type
+2nd assoc list is keyed on the minor content-type (which can be a regexp)
+
+Which looks like:
+-----------------
+ ((\"application\"
+ (\"postscript\" . <info>))
+ (\"text\"
+ (\"plain\" . <info>)))
+
+Where <info> is another assoc list of the various information
+related to the mailcap RFC 1524. This is keyed on the lowercase
+attribute name (viewer, test, etc). This looks like:
+ ((viewer . VIEWERINFO)
+ (test . TESTINFO)
+ (xxxx . \"STRING\")
+ FLAG)
+
+Where VIEWERINFO specifies how the content-type is viewed. Can be
+a string, in which case it is run through a shell, with appropriate
+parameters, or a symbol, in which case the symbol is `funcall'ed if
+and only if it exists as a function, with the buffer as an argument.
+
+TESTINFO is a test for the viewer's applicability, or nil. If nil, it
+means the viewer is always valid. If it is a Lisp function, it is
+called with a list of items from any extra fields from the
+Content-Type header as argument to return a boolean value for the
+validity. Otherwise, if it is a non-function Lisp symbol or list
+whose car is a symbol, it is `eval'led to yield the validity. If it
+is a string or list of strings, it represents a shell command to run
+to return a true or false shell value for the validity.")
+(put 'mailcap-mime-data 'risky-local-variable t)
+
+(defcustom mailcap-download-directory nil
+ "*Directory to which `mailcap-save-binary-file' downloads files by default.
+nil means your home directory."
+ :type '(choice (const :tag "Home directory" nil)
+ directory)
+ :group 'mailcap)
+
+(defvar mailcap-poor-system-types
+ '(ms-dos windows-nt)
+ "Systems that don't have a Unix-like directory hierarchy.")
+
+;;;
+;;; Utility functions
+;;;
+
+(defun mailcap-save-binary-file ()
+ (goto-char (point-min))
+ (unwind-protect
+ (let ((file (read-file-name
+ "Filename to save as: "
+ (or mailcap-download-directory "~/")))
+ (require-final-newline nil))
+ (write-region (point-min) (point-max) file))
+ (kill-buffer (current-buffer))))
+
+(defvar mailcap-maybe-eval-warning
+ "*** WARNING ***
+
+This MIME part contains untrusted and possibly harmful content.
+If you evaluate the Emacs Lisp code contained in it, a lot of nasty
+things can happen. Please examine the code very carefully before you
+instruct Emacs to evaluate it. You can browse the buffer containing
+the code using \\[scroll-other-window].
+
+If you are unsure what to do, please answer \"no\"."
+ "Text of warning message displayed by `mailcap-maybe-eval'.
+Make sure that this text consists only of few text lines. Otherwise,
+Gnus might fail to display all of it.")
+
+(defun mailcap-maybe-eval ()
+ "Maybe evaluate a buffer of Emacs Lisp code."
+ (let ((lisp-buffer (current-buffer)))
+ (goto-char (point-min))
+ (when
+ (save-window-excursion
+ (delete-other-windows)
+ (let ((buffer (get-buffer-create (generate-new-buffer-name
+ "*Warning*"))))
+ (unwind-protect
+ (with-current-buffer buffer
+ (insert (substitute-command-keys
+ mailcap-maybe-eval-warning))
+ (goto-char (point-min))
+ (display-buffer buffer)
+ (yes-or-no-p "This is potentially dangerous emacs-lisp code, evaluate it? "))
+ (kill-buffer buffer))))
+ (eval-buffer (current-buffer)))
+ (when (buffer-live-p lisp-buffer)
+ (with-current-buffer lisp-buffer
+ (emacs-lisp-mode)))))
+
+
+;;;
+;;; The mailcap parser
+;;;
+
+(defun mailcap-replace-regexp (regexp to-string)
+ ;; Quiet replace-regexp.
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (replace-match to-string t nil)))
+
+(defvar mailcap-parsed-p nil)
+
+(defun mailcap-parse-mailcaps (&optional path force)
+ "Parse out all the mailcaps specified in a path string PATH.
+Components of PATH are separated by the `path-separator' character
+appropriate for this system. If FORCE, re-parse even if already
+parsed. If PATH is omitted, use the value of environment variable
+MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus
+/usr/local/etc/mailcap."
+ (interactive (list nil t))
+ (when (or (not mailcap-parsed-p)
+ force)
+ (cond
+ (path nil)
+ ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS")))
+ ((memq system-type mailcap-poor-system-types)
+ (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap")))
+ (t (setq path
+ ;; This is per RFC 1524, specifically
+ ;; with /usr before /usr/local.
+ '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap"
+ "/usr/local/etc/mailcap"))))
+ (let ((fnames (reverse
+ (if (stringp path)
+ (split-string path path-separator t)
+ path)))
+ fname)
+ (while fnames
+ (setq fname (car fnames))
+ (if (and (file-readable-p fname)
+ (file-regular-p fname))
+ (mailcap-parse-mailcap fname))
+ (setq fnames (cdr fnames))))
+ (setq mailcap-parsed-p t)))
+
+(defun mailcap-parse-mailcap (fname)
+ "Parse out the mailcap file specified by FNAME."
+ (let (major ; The major mime type (image/audio/etc)
+ minor ; The minor mime type (gif, basic, etc)
+ save-pos ; Misc saved positions used in parsing
+ viewer ; How to view this mime type
+ info ; Misc info about this mime type
+ )
+ (with-temp-buffer
+ (insert-file-contents fname)
+ (set-syntax-table mailcap-parse-args-syntax-table)
+ (mailcap-replace-regexp "#.*" "") ; Remove all comments
+ (mailcap-replace-regexp "\\\\[ \t]*\n" " ") ; And collapse spaces
+ (mailcap-replace-regexp "\n+" "\n") ; And blank lines
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n")
+ (delete-region (point) (point-max))
+ (while (not (bobp))
+ (skip-chars-backward " \t\n")
+ (beginning-of-line)
+ (setq save-pos (point)
+ info nil)
+ (skip-chars-forward "^/; \t\n")
+ (downcase-region save-pos (point))
+ (setq major (buffer-substring save-pos (point)))
+ (skip-chars-forward " \t")
+ (setq minor "")
+ (when (eq (char-after) ?/)
+ (forward-char)
+ (skip-chars-forward " \t")
+ (setq save-pos (point))
+ (skip-chars-forward "^; \t\n")
+ (downcase-region save-pos (point))
+ (setq minor
+ (cond
+ ((eq ?* (or (char-after save-pos) 0)) ".*")
+ ((= (point) save-pos) ".*")
+ (t (regexp-quote (buffer-substring save-pos (point)))))))
+ (skip-chars-forward " \t")
+ ;;; Got the major/minor chunks, now for the viewers/etc
+ ;;; The first item _must_ be a viewer, according to the
+ ;;; RFC for mailcap files (#1524)
+ (setq viewer "")
+ (when (eq (char-after) ?\;)
+ (forward-char)
+ (skip-chars-forward " \t")
+ (setq save-pos (point))
+ (skip-chars-forward "^;\n")
+ ;; skip \;
+ (while (eq (char-before) ?\\)
+ (backward-delete-char 1)
+ (forward-char)
+ (skip-chars-forward "^;\n"))
+ (if (eq (or (char-after save-pos) 0) ?')
+ (setq viewer (progn
+ (narrow-to-region (1+ save-pos) (point))
+ (goto-char (point-min))
+ (prog1
+ (read (current-buffer))
+ (goto-char (point-max))
+ (widen))))
+ (setq viewer (buffer-substring save-pos (point)))))
+ (setq save-pos (point))
+ (end-of-line)
+ (unless (equal viewer "")
+ (setq info (nconc (list (cons 'viewer viewer)
+ (cons 'type (concat major "/"
+ (if (string= minor ".*")
+ "*" minor))))
+ (mailcap-parse-mailcap-extras save-pos (point))))
+ (mailcap-mailcap-entry-passes-test info)
+ (mailcap-add-mailcap-entry major minor info))
+ (beginning-of-line)))))
+
+(defun mailcap-parse-mailcap-extras (st nd)
+ "Grab all the extra stuff from a mailcap entry."
+ (let (
+ name ; From name=
+ value ; its value
+ results ; Assoc list of results
+ name-pos ; Start of XXXX= position
+ val-pos ; Start of value position
+ done ; Found end of \'d ;s?
+ )
+ (save-restriction
+ (narrow-to-region st nd)
+ (goto-char (point-min))
+ (skip-chars-forward " \n\t;")
+ (while (not (eobp))
+ (setq done nil)
+ (setq name-pos (point))
+ (skip-chars-forward "^ \n\t=;")
+ (downcase-region name-pos (point))
+ (setq name (buffer-substring name-pos (point)))
+ (skip-chars-forward " \t\n")
+ (if (not (eq (char-after (point)) ?=)) ; There is no value
+ (setq value t)
+ (skip-chars-forward " \t\n=")
+ (setq val-pos (point))
+ (if (memq (char-after val-pos) '(?\" ?'))
+ (progn
+ (setq val-pos (1+ val-pos))
+ (condition-case nil
+ (progn
+ (forward-sexp 1)
+ (backward-char 1))
+ (error (goto-char (point-max)))))
+ (while (not done)
+ (skip-chars-forward "^;")
+ (if (eq (char-after (1- (point))) ?\\ )
+ (progn
+ (subst-char-in-region (1- (point)) (point) ?\\ ? )
+ (skip-chars-forward ";"))
+ (setq done t))))
+ (setq value (buffer-substring val-pos (point))))
+ ;; `test' as symbol, others like "copiousoutput" and "needsx11" as
+ ;; strings
+ (setq results (cons (cons (if (string-equal name "test")
+ 'test
+ name)
+ value) results))
+ (skip-chars-forward " \";\n\t"))
+ results)))
+
+(defun mailcap-mailcap-entry-passes-test (info)
+ "Replace the test clause of INFO itself with a boolean for some cases.
+This function supports only `test -n $DISPLAY' and `test -z $DISPLAY',
+replaces them with t or nil. As for others or if INFO has a interactive
+spec (needsterm, needsterminal, or needsx11) but DISPLAY is not set,
+the test clause will be unchanged."
+ (let ((test (assq 'test info)) ; The test clause
+ status)
+ (setq status (and test (split-string (cdr test) " ")))
+ (if (and (or (assoc "needsterm" info)
+ (assoc "needsterminal" info)
+ (assoc "needsx11" info))
+ (not (getenv "DISPLAY")))
+ (setq status nil)
+ (cond
+ ((and (equal (nth 0 status) "test")
+ (equal (nth 1 status) "-n")
+ (or (equal (nth 2 status) "$DISPLAY")
+ (equal (nth 2 status) "\"$DISPLAY\"")))
+ (setq status (if (getenv "DISPLAY") t nil)))
+ ((and (equal (nth 0 status) "test")
+ (equal (nth 1 status) "-z")
+ (or (equal (nth 2 status) "$DISPLAY")
+ (equal (nth 2 status) "\"$DISPLAY\"")))
+ (setq status (if (getenv "DISPLAY") nil t)))
+ (test nil)
+ (t nil)))
+ (and test (listp test) (setcdr test status))))
+
+;;;
+;;; The action routines.
+;;;
+
+(defun mailcap-possible-viewers (major minor)
+ "Return a list of possible viewers from MAJOR for minor type MINOR."
+ (let ((exact '())
+ (wildcard '()))
+ (while major
+ (cond
+ ((equal (car (car major)) minor)
+ (setq exact (cons (cdr (car major)) exact)))
+ ((and minor (string-match (concat "^" (car (car major)) "$") minor))
+ (setq wildcard (cons (cdr (car major)) wildcard))))
+ (setq major (cdr major)))
+ (nconc exact wildcard)))
+
+(defun mailcap-unescape-mime-test (test type-info)
+ (let (save-pos save-chr subst)
+ (cond
+ ((symbolp test) test)
+ ((and (listp test) (symbolp (car test))) test)
+ ((or (stringp test)
+ (and (listp test) (stringp (car test))
+ (setq test (mapconcat 'identity test " "))))
+ (with-temp-buffer
+ (insert test)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward "^%")
+ (if (/= (- (point)
+ (progn (skip-chars-backward "\\\\")
+ (point)))
+ 0) ; It is an escaped %
+ (progn
+ (delete-char 1)
+ (skip-chars-forward "%."))
+ (setq save-pos (point))
+ (skip-chars-forward "%")
+ (setq save-chr (char-after (point)))
+ ;; Escapes:
+ ;; %s: name of a file for the body data
+ ;; %t: content-type
+ ;; %{<parameter name}: value of parameter in mailcap entry
+ ;; %n: number of sub-parts for multipart content-type
+ ;; %F: a set of content-type/filename pairs for multiparts
+ (cond
+ ((null save-chr) nil)
+ ((= save-chr ?t)
+ (delete-region save-pos (progn (forward-char 1) (point)))
+ (insert (or (cdr (assq 'type type-info)) "\"\"")))
+ ((memq save-chr '(?M ?n ?F))
+ (delete-region save-pos (progn (forward-char 1) (point)))
+ (insert "\"\""))
+ ((= save-chr ?{)
+ (forward-char 1)
+ (skip-chars-forward "^}")
+ (downcase-region (+ 2 save-pos) (point))
+ (setq subst (buffer-substring (+ 2 save-pos) (point)))
+ (delete-region save-pos (1+ (point)))
+ (insert (or (cdr (assoc subst type-info)) "\"\"")))
+ (t nil))))
+ (buffer-string)))
+ (t (error "Bad value to mailcap-unescape-mime-test: %s" test)))))
+
+(defvar mailcap-viewer-test-cache nil)
+
+(defun mailcap-viewer-passes-test (viewer-info type-info)
+ "Return non-nil if viewer specified by VIEWER-INFO passes its test clause.
+Also return non-nil if it has no test clause. TYPE-INFO is an argument
+to supply to the test."
+ (let* ((test-info (assq 'test viewer-info))
+ (test (cdr test-info))
+ (otest test)
+ (viewer (cdr (assq 'viewer viewer-info)))
+ (default-directory (expand-file-name "~/"))
+ status parsed-test cache result)
+ (cond ((not (or (stringp viewer) (fboundp viewer)))
+ nil) ; Non-existent Lisp function
+ ((setq cache (assoc test mailcap-viewer-test-cache))
+ (cadr cache))
+ ((not test-info) t) ; No test clause
+ (t
+ (setq
+ result
+ (cond
+ ((not test) nil) ; Already failed test
+ ((eq test t) t) ; Already passed test
+ ((functionp test) ; Lisp function as test
+ (funcall test type-info))
+ ((and (symbolp test) ; Lisp variable as test
+ (boundp test))
+ (symbol-value test))
+ ((and (listp test) ; List to be eval'd
+ (symbolp (car test)))
+ (eval test))
+ (t
+ (setq test (mailcap-unescape-mime-test test type-info)
+ test (list shell-file-name nil nil nil
+ shell-command-switch test)
+ status (apply 'call-process test))
+ (eq 0 status))))
+ (push (list otest result) mailcap-viewer-test-cache)
+ result))))
+
+(defun mailcap-add-mailcap-entry (major minor info)
+ (let ((old-major (assoc major mailcap-mime-data)))
+ (if (null old-major) ; New major area
+ (setq mailcap-mime-data
+ (cons (cons major (list (cons minor info)))
+ mailcap-mime-data))
+ (let ((cur-minor (assoc minor old-major)))
+ (cond
+ ((or (null cur-minor) ; New minor area, or
+ (assq 'test info)) ; Has a test, insert at beginning
+ (setcdr old-major (cons (cons minor info) (cdr old-major))))
+ ((and (not (assq 'test info)) ; No test info, replace completely
+ (not (assq 'test cur-minor))
+ (equal (assq 'viewer info) ; Keep alternative viewer
+ (assq 'viewer cur-minor)))
+ (setcdr cur-minor info))
+ (t
+ (setcdr old-major (cons (cons minor info) (cdr old-major))))))
+ )))
+
+(defun mailcap-add (type viewer &optional test)
+ "Add VIEWER as a handler for TYPE.
+If TEST is not given, it defaults to t."
+ (let ((tl (split-string type "/")))
+ (when (or (not (car tl))
+ (not (cadr tl)))
+ (error "%s is not a valid MIME type" type))
+ (mailcap-add-mailcap-entry
+ (car tl) (cadr tl)
+ `((viewer . ,viewer)
+ (test . ,(if test test t))
+ (type . ,type)))))
+
+;;;
+;;; The main whabbo
+;;;
+
+(defun mailcap-viewer-lessp (x y)
+ "Return t if viewer X is more desirable than viewer Y."
+ (let ((x-wild (string-match "[*?]" (or (cdr-safe (assq 'type x)) "")))
+ (y-wild (string-match "[*?]" (or (cdr-safe (assq 'type y)) "")))
+ (x-lisp (not (stringp (or (cdr-safe (assq 'viewer x)) ""))))
+ (y-lisp (not (stringp (or (cdr-safe (assq 'viewer y)) "")))))
+ (cond
+ ((and x-wild (not y-wild))
+ nil)
+ ((and (not x-wild) y-wild)
+ t)
+ ((and (not y-lisp) x-lisp)
+ t)
+ (t nil))))
+
+(defun mailcap-mime-info (string &optional request no-decode)
+ "Get the MIME viewer command for STRING, return nil if none found.
+Expects a complete content-type header line as its argument.
+
+Second argument REQUEST specifies what information to return. If it is
+nil or the empty string, the viewer (second field of the mailcap
+entry) will be returned. If it is a string, then the mailcap field
+corresponding to that string will be returned (print, description,
+whatever). If a number, then all the information for this specific
+viewer is returned. If `all', then all possible viewers for
+this type is returned.
+
+If NO-DECODE is non-nil, don't decode STRING."
+ ;; NO-DECODE avoids calling `mail-header-parse-content-type' from
+ ;; `mail-parse.el'
+ (let (
+ major ; Major encoding (text, etc)
+ minor ; Minor encoding (html, etc)
+ info ; Other info
+ save-pos ; Misc. position during parse
+ major-info ; (assoc major mailcap-mime-data)
+ minor-info ; (assoc minor major-info)
+ test ; current test proc.
+ viewers ; Possible viewers
+ passed ; Viewers that passed the test
+ viewer ; The one and only viewer
+ ctl)
+ (save-excursion
+ (setq ctl
+ (if no-decode
+ (list (or string "text/plain"))
+ (mail-header-parse-content-type (or string "text/plain"))))
+ (setq major (split-string (car ctl) "/"))
+ (setq minor (cadr major)
+ major (car major))
+ (when (setq major-info (cdr (assoc major mailcap-mime-data)))
+ (when (setq viewers (mailcap-possible-viewers major-info minor))
+ (setq info (mapcar (lambda (a) (cons (symbol-name (car a))
+ (cdr a)))
+ (cdr ctl)))
+ (while viewers
+ (if (mailcap-viewer-passes-test (car viewers) info)
+ (setq passed (cons (car viewers) passed)))
+ (setq viewers (cdr viewers)))
+ (setq passed (sort passed 'mailcap-viewer-lessp))
+ (setq viewer (car passed))))
+ (when (and (stringp (cdr (assq 'viewer viewer)))
+ passed)
+ (setq viewer (car passed)))
+ (cond
+ ((and (null viewer) (not (equal major "default")) request)
+ (mailcap-mime-info "default" request no-decode))
+ ((or (null request) (equal request ""))
+ (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info))
+ ((stringp request)
+ (mailcap-unescape-mime-test
+ (cdr-safe (assoc request viewer)) info))
+ ((eq request 'all)
+ passed)
+ (t
+ ;; MUST make a copy *sigh*, else we modify mailcap-mime-data
+ (setq viewer (copy-sequence viewer))
+ (let ((view (assq 'viewer viewer))
+ (test (assq 'test viewer)))
+ (if view (setcdr view (mailcap-unescape-mime-test (cdr view) info)))
+ (if test (setcdr test (mailcap-unescape-mime-test (cdr test) info))))
+ viewer)))))
+
+;;;
+;;; Experimental MIME-types parsing
+;;;
+
+(defvar mailcap-mime-extensions
+ '(("" . "text/plain")
+ (".1" . "text/plain") ;; Manual pages
+ (".3" . "text/plain")
+ (".8" . "text/plain")
+ (".abs" . "audio/x-mpeg")
+ (".aif" . "audio/aiff")
+ (".aifc" . "audio/aiff")
+ (".aiff" . "audio/aiff")
+ (".ano" . "application/x-annotator")
+ (".au" . "audio/ulaw")
+ (".avi" . "video/x-msvideo")
+ (".bcpio" . "application/x-bcpio")
+ (".bin" . "application/octet-stream")
+ (".cdf" . "application/x-netcdr")
+ (".cpio" . "application/x-cpio")
+ (".csh" . "application/x-csh")
+ (".css" . "text/css")
+ (".dvi" . "application/x-dvi")
+ (".diff" . "text/x-patch")
+ (".dpatch". "test/x-patch")
+ (".el" . "application/emacs-lisp")
+ (".eps" . "application/postscript")
+ (".etx" . "text/x-setext")
+ (".exe" . "application/octet-stream")
+ (".fax" . "image/x-fax")
+ (".gif" . "image/gif")
+ (".hdf" . "application/x-hdf")
+ (".hqx" . "application/mac-binhex40")
+ (".htm" . "text/html")
+ (".html" . "text/html")
+ (".icon" . "image/x-icon")
+ (".ief" . "image/ief")
+ (".jpg" . "image/jpeg")
+ (".macp" . "image/x-macpaint")
+ (".man" . "application/x-troff-man")
+ (".me" . "application/x-troff-me")
+ (".mif" . "application/mif")
+ (".mov" . "video/quicktime")
+ (".movie" . "video/x-sgi-movie")
+ (".mp2" . "audio/x-mpeg")
+ (".mp3" . "audio/x-mpeg")
+ (".mp2a" . "audio/x-mpeg2")
+ (".mpa" . "audio/x-mpeg")
+ (".mpa2" . "audio/x-mpeg2")
+ (".mpe" . "video/mpeg")
+ (".mpeg" . "video/mpeg")
+ (".mpega" . "audio/x-mpeg")
+ (".mpegv" . "video/mpeg")
+ (".mpg" . "video/mpeg")
+ (".mpv" . "video/mpeg")
+ (".ms" . "application/x-troff-ms")
+ (".nc" . "application/x-netcdf")
+ (".nc" . "application/x-netcdf")
+ (".oda" . "application/oda")
+ (".patch" . "text/x-patch")
+ (".pbm" . "image/x-portable-bitmap")
+ (".pdf" . "application/pdf")
+ (".pgm" . "image/portable-graymap")
+ (".pict" . "image/pict")
+ (".png" . "image/png")
+ (".pnm" . "image/x-portable-anymap")
+ (".pod" . "text/plain")
+ (".ppm" . "image/portable-pixmap")
+ (".ps" . "application/postscript")
+ (".qt" . "video/quicktime")
+ (".ras" . "image/x-raster")
+ (".rgb" . "image/x-rgb")
+ (".rtf" . "application/rtf")
+ (".rtx" . "text/richtext")
+ (".sh" . "application/x-sh")
+ (".sit" . "application/x-stuffit")
+ (".siv" . "application/sieve")
+ (".snd" . "audio/basic")
+ (".soa" . "text/dns")
+ (".src" . "application/x-wais-source")
+ (".tar" . "archive/tar")
+ (".tcl" . "application/x-tcl")
+ (".tex" . "application/x-tex")
+ (".texi" . "application/texinfo")
+ (".tga" . "image/x-targa")
+ (".tif" . "image/tiff")
+ (".tiff" . "image/tiff")
+ (".tr" . "application/x-troff")
+ (".troff" . "application/x-troff")
+ (".tsv" . "text/tab-separated-values")
+ (".txt" . "text/plain")
+ (".vbs" . "video/mpeg")
+ (".vox" . "audio/basic")
+ (".vrml" . "x-world/x-vrml")
+ (".wav" . "audio/x-wav")
+ (".xls" . "application/vnd.ms-excel")
+ (".wrl" . "x-world/x-vrml")
+ (".xbm" . "image/xbm")
+ (".xpm" . "image/xpm")
+ (".xwd" . "image/windowdump")
+ (".zip" . "application/zip")
+ (".ai" . "application/postscript")
+ (".jpe" . "image/jpeg")
+ (".jpeg" . "image/jpeg")
+ (".org" . "text/x-org"))
+ "An alist of file extensions and corresponding MIME content-types.
+This exists for you to customize the information in Lisp. It is
+merged with values from mailcap files by `mailcap-parse-mimetypes'.")
+
+(defvar mailcap-mimetypes-parsed-p nil)
+
+(defun mailcap-parse-mimetypes (&optional path force)
+ "Parse out all the mimetypes specified in a Unix-style path string PATH.
+Components of PATH are separated by the `path-separator' character
+appropriate for this system. If PATH is omitted, use the value of
+environment variable MIMETYPES if set; otherwise use a default path.
+If FORCE, re-parse even if already parsed."
+ (interactive (list nil t))
+ (when (or (not mailcap-mimetypes-parsed-p)
+ force)
+ (cond
+ (path nil)
+ ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES")))
+ ((memq system-type mailcap-poor-system-types)
+ (setq path '("~/mime.typ" "~/etc/mime.typ")))
+ (t (setq path
+ ;; mime.types seems to be the normal name, definitely so
+ ;; on current GNUish systems. The search order follows
+ ;; that for mailcap.
+ '("~/.mime.types"
+ "/etc/mime.types"
+ "/usr/etc/mime.types"
+ "/usr/local/etc/mime.types"
+ "/usr/local/www/conf/mime.types"
+ "~/.mime-types"
+ "/etc/mime-types"
+ "/usr/etc/mime-types"
+ "/usr/local/etc/mime-types"
+ "/usr/local/www/conf/mime-types"))))
+ (let ((fnames (reverse (if (stringp path)
+ (split-string path path-separator t)
+ path)))
+ fname)
+ (while fnames
+ (setq fname (car fnames))
+ (if (and (file-readable-p fname))
+ (mailcap-parse-mimetype-file fname))
+ (setq fnames (cdr fnames))))
+ (setq mailcap-mimetypes-parsed-p t)))
+
+(defun mailcap-parse-mimetype-file (fname)
+ "Parse out a mime-types file FNAME."
+ (let (type ; The MIME type for this line
+ extns ; The extensions for this line
+ save-pos ; Misc. saved buffer positions
+ )
+ (with-temp-buffer
+ (insert-file-contents fname)
+ (mailcap-replace-regexp "#.*" "")
+ (mailcap-replace-regexp "\n+" "\n")
+ (mailcap-replace-regexp "[ \t]+$" "")
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n")
+ (delete-region (point) (point-max))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward " \t\n")
+ (setq save-pos (point))
+ (skip-chars-forward "^ \t\n")
+ (downcase-region save-pos (point))
+ (setq type (buffer-substring save-pos (point)))
+ (while (not (eolp))
+ (skip-chars-forward " \t")
+ (setq save-pos (point))
+ (skip-chars-forward "^ \t\n")
+ (setq extns (cons (buffer-substring save-pos (point)) extns)))
+ (while extns
+ (setq mailcap-mime-extensions
+ (cons
+ (cons (if (= (string-to-char (car extns)) ?.)
+ (car extns)
+ (concat "." (car extns))) type)
+ mailcap-mime-extensions)
+ extns (cdr extns)))))))
+
+(defun mailcap-extension-to-mime (extn)
+ "Return the MIME content type of the file extensions EXTN."
+ (mailcap-parse-mimetypes)
+ (if (and (stringp extn)
+ (not (eq (string-to-char extn) ?.)))
+ (setq extn (concat "." extn)))
+ (cdr (assoc (downcase extn) mailcap-mime-extensions)))
+
+;; Unused?
+(defalias 'mailcap-command-p 'executable-find)
+
+(defun mailcap-mime-types ()
+ "Return a list of MIME media types."
+ (mailcap-parse-mimetypes)
+ (delete-dups
+ (nconc
+ (mapcar 'cdr mailcap-mime-extensions)
+ (apply
+ 'nconc
+ (mapcar
+ (lambda (l)
+ (delq nil
+ (mapcar
+ (lambda (m)
+ (let ((type (cdr (assq 'type (cdr m)))))
+ (if (equal (cadr (split-string type "/"))
+ "*")
+ nil
+ type)))
+ (cdr l))))
+ mailcap-mime-data)))))
+
+;;;
+;;; Useful supplementary functions
+;;;
+
+(defun mailcap-file-default-commands (files)
+ "Return a list of default commands for FILES."
+ (mailcap-parse-mailcaps)
+ (mailcap-parse-mimetypes)
+ (let* ((all-mime-type
+ ;; All unique MIME types from file extensions
+ (delete-dups
+ (mapcar (lambda (file)
+ (mailcap-extension-to-mime
+ (file-name-extension file t)))
+ files)))
+ (all-mime-info
+ ;; All MIME info lists
+ (delete-dups
+ (mapcar (lambda (mime-type)
+ (mailcap-mime-info mime-type 'all))
+ all-mime-type)))
+ (common-mime-info
+ ;; Intersection of mime-infos from different mime-types;
+ ;; or just the first MIME info for a single MIME type
+ (if (cdr all-mime-info)
+ (delq nil (mapcar (lambda (mi1)
+ (unless (memq nil (mapcar
+ (lambda (mi2)
+ (member mi1 mi2))
+ (cdr all-mime-info)))
+ mi1))
+ (car all-mime-info)))
+ (car all-mime-info)))
+ (commands
+ ;; Command strings from `viewer' field of the MIME info
+ (delete-dups
+ (delq nil (mapcar
+ (lambda (mime-info)
+ (let ((command (cdr (assoc 'viewer mime-info))))
+ (if (stringp command)
+ (replace-regexp-in-string
+ ;; Replace mailcap's `%s' placeholder
+ ;; with dired's `?' placeholder
+ "%s" "?"
+ (replace-regexp-in-string
+ ;; Remove the final filename placeholder
+ "[ \t\n]*\\('\\)?%s\\1?[ \t\n]*\\'" ""
+ command nil t)
+ nil t))))
+ common-mime-info)))))
+ commands))
+
+(defun mailcap-view-mime (type)
+ "View the data in the current buffer that has MIME type TYPE.
+`mailcap-mime-data' determines the method to use."
+ (let ((method (mailcap-mime-info type)))
+ (if (stringp method)
+ (shell-command-on-region (point-min) (point-max)
+ ;; Use stdin as the "%s".
+ (format method "-")
+ (current-buffer)
+ t)
+ (funcall method))))
+
+(provide 'mailcap)
+
+;;; mailcap.el ends here
--- /dev/null
+;;; pop3.el --- Post Office Protocol (RFC 1460) interface
+
+;; Copyright (C) 1996-2016 Free Software Foundation, Inc.
+
+;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
+;; Maintainer: emacs-devel@gnu.org
+;; Keywords: mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands
+;; are implemented. The LIST command has not been implemented due to lack
+;; of actual usefulness.
+;; The optional POP3 command TOP has not been implemented.
+
+;; This program was inspired by Kyle E. Jones's vm-pop program.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'mail-utils)
+(defvar parse-time-months)
+
+(defgroup pop3 nil
+ "Post Office Protocol."
+ :group 'mail
+ :group 'mail-source)
+
+(defcustom pop3-maildrop (or (user-login-name)
+ (getenv "LOGNAME")
+ (getenv "USER"))
+ "*POP3 maildrop."
+ :version "22.1" ;; Oort Gnus
+ :type 'string
+ :group 'pop3)
+
+(defcustom pop3-mailhost (or (getenv "MAILHOST") ;; nil -> mismatch
+ "pop3")
+ "*POP3 mailhost."
+ :version "22.1" ;; Oort Gnus
+ :type 'string
+ :group 'pop3)
+
+(defcustom pop3-port 110
+ "*POP3 port."
+ :version "22.1" ;; Oort Gnus
+ :type 'number
+ :group 'pop3)
+
+(defcustom pop3-password-required t
+ "*Non-nil if a password is required when connecting to POP server."
+ :version "22.1" ;; Oort Gnus
+ :type 'boolean
+ :group 'pop3)
+
+;; Should this be customizable?
+(defvar pop3-password nil
+ "*Password to use when connecting to POP server.")
+
+(defcustom pop3-authentication-scheme 'pass
+ "*POP3 authentication scheme.
+Defaults to `pass', for the standard USER/PASS authentication. The other
+valid value is `apop'."
+ :type '(choice (const :tag "Normal user/password" pass)
+ (const :tag "APOP" apop))
+ :version "22.1" ;; Oort Gnus
+ :group 'pop3)
+
+(defcustom pop3-stream-length 100
+ "How many messages should be requested at one time.
+The lower the number, the more latency-sensitive the fetching
+will be. If your pop3 server doesn't support streaming at all,
+set this to 1."
+ :type 'number
+ :version "24.1"
+ :group 'pop3)
+
+(defcustom pop3-leave-mail-on-server nil
+ "Non-nil if the mail is to be left on the POP server after fetching.
+Mails once fetched will never be fetched again by the UIDL control.
+
+If this is neither nil nor a number, all mails will be left on the
+server. If this is a number, leave mails on the server for this many
+days since you first checked new mails. If this is nil, mails will be
+deleted on the server right after fetching.
+
+Gnus users should use the `:leave' keyword in a mail source to direct
+the behavior per server, rather than directly modifying this value.
+
+Note that POP servers maintain no state information between sessions,
+so what the client believes is there and what is actually there may
+not match up. If they do not, then you may get duplicate mails or
+the whole thing can fall apart and leave you with a corrupt mailbox."
+ :version "24.4"
+ :type '(choice (const :tag "Don't leave mails" nil)
+ (const :tag "Leave all mails" t)
+ (number :tag "Leave mails for this many days" :value 14))
+ :group 'pop3)
+
+(defcustom pop3-uidl-file "~/.pop3-uidl"
+ "File used to save UIDL."
+ :version "24.4"
+ :type 'file
+ :group 'pop3)
+
+(defcustom pop3-uidl-file-backup '(0 9)
+ "How to backup the UIDL file `pop3-uidl-file' when updating.
+If it is a list of numbers, the first one binds `kept-old-versions' and
+the other binds `kept-new-versions' to keep number of oldest and newest
+versions. Otherwise, the value binds `version-control' (which see).
+
+Note: Backup will take place whenever you check new mails on a server.
+So, you may lose the backup files having been saved before a trouble
+if you set it so as to make too few backups whereas you have access to
+many servers."
+ :version "24.4"
+ :type '(choice (group :tag "Keep versions" :format "\n%v" :indent 3
+ (number :tag "oldest")
+ (number :tag "newest"))
+ (sexp :format "%v"
+ :match (lambda (widget value)
+ (condition-case nil
+ (not (and (numberp (car value))
+ (numberp (car (cdr value)))))
+ (error t)))))
+ :group 'pop3)
+
+(defvar pop3-timestamp nil
+ "Timestamp returned when initially connected to the POP server.
+Used for APOP authentication.")
+
+(defvar pop3-read-point nil)
+(defvar pop3-debug nil)
+
+;; Borrowed from nnheader-accept-process-output in nnheader.el. See the
+;; comments there for explanations about the values.
+
+(eval-and-compile
+ (if (and (fboundp 'nnheader-accept-process-output)
+ (boundp 'nnheader-read-timeout))
+ (defalias 'pop3-accept-process-output 'nnheader-accept-process-output)
+ ;; Borrowed from `nnheader.el':
+ (defvar pop3-read-timeout
+ (if (string-match "windows-nt\\|os/2\\|cygwin"
+ (symbol-name system-type))
+ 1.0
+ 0.01)
+ "How long pop3 should wait between checking for the end of output.
+Shorter values mean quicker response, but are more CPU intensive.")
+ (defun pop3-accept-process-output (process)
+ (accept-process-output
+ process
+ (truncate pop3-read-timeout)
+ (truncate (* (- pop3-read-timeout
+ (truncate pop3-read-timeout))
+ 1000))))))
+
+(defvar pop3-uidl)
+;; List of UIDLs of existing messages at present in the server:
+;; ("UIDL1" "UIDL2" "UIDL3"...)
+
+(defvar pop3-uidl-saved)
+;; Locally saved UIDL data; an alist of the server, the user, and the UIDL
+;; and timestamp pairs:
+;; (("SERVER_A" ("USER_A1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...)
+;; ("USER_A2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...)
+;; ...)
+;; ("SERVER_B" ("USER_B1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...)
+;; ("USER_B2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...)
+;; ...))
+;; Where TIMESTAMP is the most significant two digits of an Emacs time,
+;; i.e. the return value of `current-time'.
+
+;;;###autoload
+(defun pop3-movemail (file)
+ "Transfer contents of a maildrop to the specified FILE.
+Use streaming commands."
+ (let ((process (pop3-open-server pop3-mailhost pop3-port))
+ messages total-size
+ pop3-uidl
+ pop3-uidl-saved)
+ (pop3-logon process)
+ (if pop3-leave-mail-on-server
+ (setq messages (pop3-uidl-stat process)
+ total-size (cadr messages)
+ messages (car messages))
+ (let ((size (pop3-stat process)))
+ (dotimes (i (car size)) (push (1+ i) messages))
+ (setq messages (nreverse messages)
+ total-size (cadr size))))
+ (when messages
+ (with-current-buffer (process-buffer process)
+ (pop3-send-streaming-command process "RETR" messages total-size)
+ (pop3-write-to-file file messages)
+ (unless pop3-leave-mail-on-server
+ (pop3-send-streaming-command process "DELE" messages nil))))
+ (if pop3-leave-mail-on-server
+ (when (prog1 (pop3-uidl-dele process) (pop3-quit process))
+ (pop3-uidl-save))
+ (pop3-quit process)
+ ;; Remove UIDL data for the account that got not to leave mails.
+ (setq pop3-uidl-saved (pop3-uidl-load))
+ (let ((elt (assoc pop3-maildrop
+ (cdr (assoc pop3-mailhost pop3-uidl-saved)))))
+ (when elt
+ (setcdr elt nil)
+ (pop3-uidl-save))))
+ t))
+
+(defun pop3-send-streaming-command (process command messages total-size)
+ (erase-buffer)
+ (let ((count (length messages))
+ (i 1)
+ (start-point (point-min))
+ (waited-for 0))
+ (while messages
+ (process-send-string process (format "%s %d\r\n" command (pop messages)))
+ ;; Only do 100 messages at a time to avoid pipe stalls.
+ (when (zerop (% i pop3-stream-length))
+ (setq start-point
+ (pop3-wait-for-messages process pop3-stream-length
+ total-size start-point))
+ (incf waited-for pop3-stream-length))
+ (incf i))
+ (pop3-wait-for-messages process (- count waited-for)
+ total-size start-point)))
+
+(defun pop3-wait-for-messages (process count total-size start-point)
+ (while (> count 0)
+ (goto-char start-point)
+ (while (or (and (re-search-forward "^\\+OK" nil t)
+ (or (not total-size)
+ (re-search-forward "^\\.\r?\n" nil t)))
+ (re-search-forward "^-ERR " nil t))
+ (decf count)
+ (setq start-point (point)))
+ (unless (memq (process-status process) '(open run))
+ (error "pop3 process died"))
+ (when total-size
+ (let ((size 0))
+ (goto-char (point-min))
+ (while (re-search-forward "^\\+OK.*\n" nil t)
+ (setq size (+ size (- (point))
+ (if (re-search-forward "^\\.\r?\n" nil 'move)
+ (match-beginning 0)
+ (point)))))
+ (message "pop3 retrieved %dKB (%d%%)"
+ (truncate (/ size 1000))
+ (truncate (* (/ (* size 1.0) total-size) 100)))))
+ (pop3-accept-process-output process))
+ start-point)
+
+(defun pop3-write-to-file (file messages)
+ (let ((pop-buffer (current-buffer))
+ (start (point-min))
+ beg end
+ temp-buffer)
+ (with-temp-buffer
+ (setq temp-buffer (current-buffer))
+ (with-current-buffer pop-buffer
+ (goto-char (point-min))
+ (while (re-search-forward "^\\+OK" nil t)
+ (forward-line 1)
+ (setq beg (point))
+ (when (re-search-forward "^\\.\r?\n" nil t)
+ (setq start (point))
+ (forward-line -1)
+ (setq end (point)))
+ (with-current-buffer temp-buffer
+ (goto-char (point-max))
+ (let ((hstart (point)))
+ (insert-buffer-substring pop-buffer beg end)
+ (pop3-clean-region hstart (point))
+ (goto-char (point-max))
+ (pop3-munge-message-separator hstart (point))
+ (when pop3-leave-mail-on-server
+ (pop3-uidl-add-xheader hstart (pop messages)))
+ (goto-char (point-max))))))
+ (let ((coding-system-for-write 'binary))
+ (goto-char (point-min))
+ ;; Check whether something inserted a newline at the start and
+ ;; delete it.
+ (when (eolp)
+ (delete-char 1))
+ (write-region (point-min) (point-max) file nil 'nomesg)))))
+
+(defun pop3-logon (process)
+ (let ((pop3-password pop3-password))
+ ;; for debugging only
+ (if pop3-debug (switch-to-buffer (process-buffer process)))
+ ;; query for password
+ (if (and pop3-password-required (not pop3-password))
+ (setq pop3-password
+ (read-passwd (format "Password for %s: " pop3-maildrop))))
+ (cond ((equal 'apop pop3-authentication-scheme)
+ (pop3-apop process pop3-maildrop))
+ ((equal 'pass pop3-authentication-scheme)
+ (pop3-user process pop3-maildrop)
+ (pop3-pass process))
+ (t (error "Invalid POP3 authentication scheme")))))
+
+(defun pop3-get-message-count ()
+ "Return the number of messages in the maildrop."
+ (let* ((process (pop3-open-server pop3-mailhost pop3-port))
+ message-count
+ (pop3-password pop3-password))
+ ;; for debugging only
+ (if pop3-debug (switch-to-buffer (process-buffer process)))
+ ;; query for password
+ (if (and pop3-password-required (not pop3-password))
+ (setq pop3-password
+ (read-passwd (format "Password for %s: " pop3-maildrop))))
+ (cond ((equal 'apop pop3-authentication-scheme)
+ (pop3-apop process pop3-maildrop))
+ ((equal 'pass pop3-authentication-scheme)
+ (pop3-user process pop3-maildrop)
+ (pop3-pass process))
+ (t (error "Invalid POP3 authentication scheme")))
+ (setq message-count (car (pop3-stat process)))
+ (pop3-quit process)
+ message-count))
+
+(defun pop3-uidl-stat (process)
+ "Return a list of unread message numbers and total size."
+ (pop3-send-command process "UIDL")
+ (let (err messages size)
+ (if (condition-case code
+ (progn
+ (pop3-read-response process)
+ t)
+ (error (setq err (error-message-string code))
+ nil))
+ (let ((start pop3-read-point)
+ saved list)
+ (with-current-buffer (process-buffer process)
+ (while (not (re-search-forward "^\\.\r\n" nil t))
+ (unless (memq (process-status process) '(open run))
+ (error "pop3 server closed the connection"))
+ (pop3-accept-process-output process)
+ (goto-char start))
+ (setq pop3-read-point (point-marker)
+ pop3-uidl nil)
+ (while (progn (forward-line -1) (>= (point) start))
+ (when (looking-at "[0-9]+ \\([^\n\r ]+\\)")
+ (push (match-string 1) pop3-uidl)))
+ (when pop3-uidl
+ (setq pop3-uidl-saved (pop3-uidl-load)
+ saved (cdr (assoc pop3-maildrop
+ (cdr (assoc pop3-mailhost
+ pop3-uidl-saved)))))
+ (let ((i (length pop3-uidl)))
+ (while (> i 0)
+ (unless (member (nth (1- i) pop3-uidl) saved)
+ (push i messages))
+ (decf i)))
+ (when messages
+ (setq list (pop3-list process)
+ size 0)
+ (dolist (msg messages)
+ (setq size (+ size (cdr (assq msg list)))))
+ (list messages size)))))
+ (message "%s doesn't support UIDL (%s), so we try a regressive way..."
+ pop3-mailhost err)
+ (sit-for 1)
+ (setq size (pop3-stat process))
+ (dotimes (i (car size)) (push (1+ i) messages))
+ (setcar size (nreverse messages))
+ size)))
+
+(defun pop3-uidl-dele (process)
+ "Delete messages according to `pop3-leave-mail-on-server'.
+Return non-nil if it is necessary to update the local UIDL file."
+ (let* ((ctime (current-time))
+ (srvr (assoc pop3-mailhost pop3-uidl-saved))
+ (saved (assoc pop3-maildrop (cdr srvr)))
+ i uidl mod new tstamp dele)
+ (setcdr (cdr ctime) nil)
+ ;; Add new messages to the data to be saved.
+ (cond ((and pop3-uidl saved)
+ (setq i (1- (length pop3-uidl)))
+ (while (>= i 0)
+ (unless (member (setq uidl (nth i pop3-uidl)) (cdr saved))
+ (push ctime new)
+ (push uidl new))
+ (decf i)))
+ (pop3-uidl
+ (setq new (apply 'nconc (mapcar (lambda (elt) (list elt ctime))
+ pop3-uidl)))))
+ (when new (setq mod t))
+ ;; List expirable messages and delete them from the data to be saved.
+ (setq ctime (when (numberp pop3-leave-mail-on-server)
+ (/ (+ (* (car ctime) 65536.0) (cadr ctime)) 86400))
+ i (1- (length saved)))
+ (while (> i 0)
+ (if (member (setq uidl (nth (1- i) saved)) pop3-uidl)
+ (progn
+ (setq tstamp (nth i saved))
+ (if (and ctime
+ (> (- ctime (/ (+ (* (car tstamp) 65536.0) (cadr tstamp))
+ 86400))
+ pop3-leave-mail-on-server))
+ ;; Mails to delete.
+ (progn
+ (setq mod t)
+ (push uidl dele))
+ ;; Mails to keep.
+ (push tstamp new)
+ (push uidl new)))
+ ;; Mails having been deleted in the server.
+ (setq mod t))
+ (decf i 2))
+ (cond (saved
+ (setcdr saved new))
+ (srvr
+ (setcdr (last srvr) (list (cons pop3-maildrop new))))
+ (t
+ (add-to-list 'pop3-uidl-saved
+ (list pop3-mailhost (cons pop3-maildrop new))
+ t)))
+ ;; Actually delete the messages in the server.
+ (when dele
+ (setq uidl nil
+ i (length pop3-uidl))
+ (while (> i 0)
+ (when (member (nth (1- i) pop3-uidl) dele)
+ (push i uidl))
+ (decf i))
+ (when uidl
+ (pop3-send-streaming-command process "DELE" uidl nil)))
+ mod))
+
+(defun pop3-uidl-load ()
+ "Load saved UIDL."
+ (when (file-exists-p pop3-uidl-file)
+ (with-temp-buffer
+ (condition-case code
+ (progn
+ (insert-file-contents pop3-uidl-file)
+ (goto-char (point-min))
+ (read (current-buffer)))
+ (error
+ (message "Error while loading %s (%s)"
+ pop3-uidl-file (error-message-string code))
+ (sit-for 1)
+ nil)))))
+
+(defun pop3-uidl-save ()
+ "Save UIDL."
+ (with-temp-buffer
+ (if pop3-uidl-saved
+ (progn
+ (insert "(")
+ (dolist (srvr pop3-uidl-saved)
+ (when (cdr srvr)
+ (insert "(\"" (pop srvr) "\"\n ")
+ (dolist (elt srvr)
+ (when (cdr elt)
+ (insert "(\"" (pop elt) "\"\n ")
+ (while elt
+ (insert (format "\"%s\" %s\n " (pop elt) (pop elt))))
+ (delete-char -4)
+ (insert ")\n ")))
+ (delete-char -3)
+ (if (eq (char-before) ?\))
+ (insert ")\n ")
+ (goto-char (1+ (point-at-bol)))
+ (delete-region (point) (point-max)))))
+ (when (eq (char-before) ? )
+ (delete-char -2))
+ (insert ")\n"))
+ (insert "()\n"))
+ (let ((buffer-file-name pop3-uidl-file)
+ (delete-old-versions t)
+ (kept-new-versions kept-new-versions)
+ (kept-old-versions kept-old-versions)
+ (version-control version-control))
+ (if (consp pop3-uidl-file-backup)
+ (setq kept-new-versions (cadr pop3-uidl-file-backup)
+ kept-old-versions (car pop3-uidl-file-backup)
+ version-control t)
+ (setq version-control pop3-uidl-file-backup))
+ (save-buffer))))
+
+(defun pop3-uidl-add-xheader (start msgno)
+ "Add X-UIDL header."
+ (let ((case-fold-search t))
+ (save-restriction
+ (narrow-to-region start (progn
+ (goto-char start)
+ (search-forward "\n\n" nil 'move)
+ (1- (point))))
+ (goto-char start)
+ (while (re-search-forward "^x-uidl:" nil t)
+ (while (progn
+ (forward-line 1)
+ (memq (char-after) '(?\t ? ))))
+ (delete-region (match-beginning 0) (point)))
+ (goto-char (point-max))
+ (insert "X-UIDL: " (nth (1- msgno) pop3-uidl) "\n"))))
+
+(defcustom pop3-stream-type nil
+ "*Transport security type for POP3 connections.
+This may be either nil (plain connection), `ssl' (use an
+SSL/TSL-secured stream) or `starttls' (use the starttls mechanism
+to turn on TLS security after opening the stream). However, if
+this is nil, `ssl' is assumed for connections to port
+995 (pop3s)."
+ :version "23.1" ;; No Gnus
+ :group 'pop3
+ :type '(choice (const :tag "Plain" nil)
+ (const :tag "SSL/TLS" ssl)
+ (const starttls)))
+
+(defun pop3-open-server (mailhost port)
+ "Open TCP connection to MAILHOST on PORT.
+Returns the process associated with the connection."
+ (let ((coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ result)
+ (with-current-buffer
+ (get-buffer-create (concat " trace of POP session to "
+ mailhost))
+ (erase-buffer)
+ (setq pop3-read-point (point-min))
+ (setq result
+ (open-network-stream
+ "POP" (current-buffer) mailhost port
+ :type (cond
+ ((or (eq pop3-stream-type 'ssl)
+ (and (not pop3-stream-type)
+ (member port '(995 "pop3s"))))
+ 'tls)
+ (t
+ (or pop3-stream-type 'network)))
+ :warn-unless-encrypted t
+ :capability-command "CAPA\r\n"
+ :end-of-command "^\\(-ERR\\|+OK\\).*\n"
+ :end-of-capability "^\\.\r?\n\\|^-ERR"
+ :success "^\\+OK.*\n"
+ :return-list t
+ :starttls-function
+ (lambda (capabilities)
+ (and (string-match "\\bSTLS\\b" capabilities)
+ "STLS\r\n"))))
+ (when result
+ (let ((response (plist-get (cdr result) :greeting)))
+ (setq pop3-timestamp
+ (substring response (or (string-match "<" response) 0)
+ (+ 1 (or (string-match ">" response) -1)))))
+ (set-process-query-on-exit-flag (car result) nil)
+ (erase-buffer)
+ (car result)))))
+
+;; Support functions
+
+(defun pop3-send-command (process command)
+ (set-buffer (process-buffer process))
+ (goto-char (point-max))
+ ;; (if (= (aref command 0) ?P)
+ ;; (insert "PASS <omitted>\r\n")
+ ;; (insert command "\r\n"))
+ (setq pop3-read-point (point))
+ (goto-char (point-max))
+ (process-send-string process (concat command "\r\n")))
+
+(defun pop3-read-response (process &optional return)
+ "Read the response from the server.
+Return the response string if optional second argument is non-nil."
+ (let ((case-fold-search nil)
+ match-end)
+ (with-current-buffer (process-buffer process)
+ (goto-char pop3-read-point)
+ (while (and (memq (process-status process) '(open run))
+ (not (search-forward "\r\n" nil t)))
+ (pop3-accept-process-output process)
+ (goto-char pop3-read-point))
+ (setq match-end (point))
+ (goto-char pop3-read-point)
+ (if (looking-at "-ERR")
+ (error "%s" (buffer-substring (point) (- match-end 2)))
+ (if (not (looking-at "+OK"))
+ (progn (setq pop3-read-point match-end) nil)
+ (setq pop3-read-point match-end)
+ (if return
+ (buffer-substring (point) match-end)
+ t)
+ )))))
+
+(defun pop3-clean-region (start end)
+ (setq end (set-marker (make-marker) end))
+ (save-excursion
+ (goto-char start)
+ (while (and (< (point) end) (search-forward "\r\n" end t))
+ (replace-match "\n" t t))
+ (goto-char start)
+ (while (and (< (point) end) (re-search-forward "^\\." end t))
+ (replace-match "" t t)
+ (forward-char)))
+ (set-marker end nil))
+
+;; Copied from message-make-date.
+(defun pop3-make-date (&optional now)
+ "Make a valid date header.
+If NOW, use that time instead."
+ (require 'parse-time)
+ (let* ((now (or now (current-time)))
+ (zone (nth 8 (decode-time now)))
+ (sign "+"))
+ (when (< zone 0)
+ (setq sign "-")
+ (setq zone (- zone)))
+ (concat
+ (format-time-string "%d" now)
+ ;; The month name of the %b spec is locale-specific. Pfff.
+ (format " %s "
+ (capitalize (car (rassoc (nth 4 (decode-time now))
+ parse-time-months))))
+ (format-time-string "%Y %H:%M:%S %z" now))))
+
+(defun pop3-munge-message-separator (start end)
+ "Check to see if a message separator exists. If not, generate one."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (if (not (or (looking-at "From .?") ; Unix mail
+ (looking-at "\001\001\001\001\n") ; MMDF
+ (looking-at "BABYL OPTIONS:") ; Babyl
+ ))
+ (let* ((from (mail-strip-quoted-names (mail-fetch-field "From")))
+ (tdate (mail-fetch-field "Date"))
+ (date (split-string (or (and tdate
+ (not (string= "" tdate))
+ tdate)
+ (pop3-make-date))
+ " "))
+ (From_))
+ ;; sample date formats I have seen
+ ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT)
+ ;; Date: 08 Jul 1996 23:22:24 -0400
+ ;; should be
+ ;; Tue Jul 9 09:04:21 1996
+
+ ;; Fixme: This should use timezone on the date field contents.
+ (setq date
+ (cond ((not date)
+ "Tue Jan 1 00:00:0 1900")
+ ((string-match "[A-Z]" (nth 0 date))
+ (format "%s %s %s %s %s"
+ (nth 0 date) (nth 2 date) (nth 1 date)
+ (nth 4 date) (nth 3 date)))
+ (t
+ ;; this really needs to be better but I don't feel
+ ;; like writing a date to day converter.
+ (format "Sun %s %s %s %s"
+ (nth 1 date) (nth 0 date)
+ (nth 3 date) (nth 2 date)))
+ ))
+ (setq From_ (format "\nFrom %s %s\n" from date))
+ (while (string-match "," From_)
+ (setq From_ (concat (substring From_ 0 (match-beginning 0))
+ (substring From_ (match-end 0)))))
+ (goto-char (point-min))
+ (insert From_)
+ (if (search-forward "\n\n" nil t)
+ nil
+ (goto-char (point-max))
+ (insert "\n"))
+ (let ((size (- (point-max) (point))))
+ (forward-line -1)
+ (insert (format "Content-Length: %s\n" size)))
+ )))))
+
+;; The Command Set
+
+;; AUTHORIZATION STATE
+
+(defun pop3-user (process user)
+ "Send USER information to POP3 server."
+ (pop3-send-command process (format "USER %s" user))
+ (let ((response (pop3-read-response process t)))
+ (if (not (and response (string-match "+OK" response)))
+ (error "USER %s not valid" user))))
+
+(defun pop3-pass (process)
+ "Send authentication information to the server."
+ (pop3-send-command process (format "PASS %s" pop3-password))
+ (let ((response (pop3-read-response process t)))
+ (if (not (and response (string-match "+OK" response)))
+ (pop3-quit process))))
+
+(defun pop3-apop (process user)
+ "Send alternate authentication information to the server."
+ (let ((pass pop3-password))
+ (if (and pop3-password-required (not pass))
+ (setq pass
+ (read-passwd (format "Password for %s: " pop3-maildrop))))
+ (if pass
+ (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary)))
+ (pop3-send-command process (format "APOP %s %s" user hash))
+ (let ((response (pop3-read-response process t)))
+ (if (not (and response (string-match "+OK" response)))
+ (pop3-quit process)))))
+ ))
+
+;; TRANSACTION STATE
+
+(defun pop3-stat (process)
+ "Return the number of messages in the maildrop and the maildrop's size."
+ (pop3-send-command process "STAT")
+ (let ((response (pop3-read-response process t)))
+ (list (string-to-number (nth 1 (split-string response " ")))
+ (string-to-number (nth 2 (split-string response " "))))
+ ))
+
+(defun pop3-list (process &optional msg)
+ "If MSG is nil, return an alist of (MESSAGE-ID . SIZE) pairs.
+Otherwise, return the size of the message-id MSG"
+ (pop3-send-command process (if msg
+ (format "LIST %d" msg)
+ "LIST"))
+ (let ((response (pop3-read-response process t)))
+ (if msg
+ (string-to-number (nth 2 (split-string response " ")))
+ (let ((start pop3-read-point) end)
+ (with-current-buffer (process-buffer process)
+ (while (not (re-search-forward "^\\.\r\n" nil t))
+ (pop3-accept-process-output process)
+ (goto-char start))
+ (setq pop3-read-point (point-marker))
+ (goto-char (match-beginning 0))
+ (setq end (point-marker))
+ (mapcar #'(lambda (s) (let ((split (split-string s " ")))
+ (cons (string-to-number (nth 0 split))
+ (string-to-number (nth 1 split)))))
+ (split-string (buffer-substring start end) "\r\n" t)))))))
+
+(defun pop3-retr (process msg crashbuf)
+ "Retrieve message-id MSG to buffer CRASHBUF."
+ (pop3-send-command process (format "RETR %s" msg))
+ (pop3-read-response process)
+ (let ((start pop3-read-point) end)
+ (with-current-buffer (process-buffer process)
+ (while (not (re-search-forward "^\\.\r\n" nil t))
+ (unless (memq (process-status process) '(open run))
+ (error "pop3 server closed the connection"))
+ (pop3-accept-process-output process)
+ (goto-char start))
+ (setq pop3-read-point (point-marker))
+ ;; this code does not seem to work for some POP servers...
+ ;; and I cannot figure out why not.
+ ;; (goto-char (match-beginning 0))
+ ;; (backward-char 2)
+ ;; (if (not (looking-at "\r\n"))
+ ;; (insert "\r\n"))
+ ;; (re-search-forward "\\.\r\n")
+ (goto-char (match-beginning 0))
+ (setq end (point-marker))
+ (pop3-clean-region start end)
+ (pop3-munge-message-separator start end)
+ (with-current-buffer crashbuf
+ (erase-buffer))
+ (copy-to-buffer crashbuf start end)
+ (delete-region start end)
+ )))
+
+(defun pop3-dele (process msg)
+ "Mark message-id MSG as deleted."
+ (pop3-send-command process (format "DELE %s" msg))
+ (pop3-read-response process))
+
+(defun pop3-noop (process msg)
+ "No-operation."
+ (pop3-send-command process "NOOP")
+ (pop3-read-response process))
+
+(defun pop3-last (process)
+ "Return highest accessed message-id number for the session."
+ (pop3-send-command process "LAST")
+ (let ((response (pop3-read-response process t)))
+ (string-to-number (nth 1 (split-string response " ")))
+ ))
+
+(defun pop3-rset (process)
+ "Remove all delete marks from current maildrop."
+ (pop3-send-command process "RSET")
+ (pop3-read-response process))
+
+;; UPDATE
+
+(defun pop3-quit (process)
+ "Close connection to POP3 server.
+Tell server to remove all messages marked as deleted, unlock the maildrop,
+and close the connection."
+ (pop3-send-command process "QUIT")
+ (pop3-read-response process t)
+ (if process
+ (with-current-buffer (process-buffer process)
+ (goto-char (point-max))
+ (delete-process process))))
+\f
+;; 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
--- /dev/null
+;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp
+
+;; Copyright (C) 2001-2016 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+;; Albert Krewinkel <tarleb@moltkeplatz.de>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library provides an elisp API for the managesieve network
+;; protocol.
+;;
+;; It uses the SASL library for authentication, which means it
+;; supports DIGEST-MD5, CRAM-MD5, SCRAM-MD5, NTLM, PLAIN and LOGIN
+;; methods. STARTTLS is not well tested, but should be easy to get to
+;; work if someone wants.
+;;
+;; The API should be fairly obvious for anyone familiar with the
+;; managesieve protocol, interface functions include:
+;;
+;; `sieve-manage-open'
+;; open connection to managesieve server, returning a buffer to be
+;; used by all other API functions.
+;;
+;; `sieve-manage-opened'
+;; check if a server is open or not
+;;
+;; `sieve-manage-close'
+;; close a server connection.
+;;
+;; `sieve-manage-listscripts'
+;; `sieve-manage-deletescript'
+;; `sieve-manage-getscript'
+;; performs managesieve protocol actions
+;;
+;; and that's it. Example of a managesieve session in *scratch*:
+;;
+;; (with-current-buffer (sieve-manage-open "mail.example.com")
+;; (sieve-manage-authenticate)
+;; (sieve-manage-listscripts))
+;;
+;; => ((active . "main") "vacation")
+;;
+;; References:
+;;
+;; draft-martin-managesieve-02.txt,
+;; "A Protocol for Remotely Managing Sieve Scripts",
+;; by Tim Martin.
+;;
+;; Release history:
+;;
+;; 2001-10-31 Committed to Oort Gnus.
+;; 2002-07-27 Added DELETESCRIPT. Suggested by Ned Ludd.
+;; 2002-08-03 Use SASL library.
+;; 2013-06-05 Enabled STARTTLS support, fixed bit rot.
+
+;;; Code:
+
+(if (locate-library "password-cache")
+ (require 'password-cache)
+ (require 'password))
+
+(eval-when-compile (require 'cl))
+(require 'sasl)
+(require 'starttls)
+(autoload 'sasl-find-mechanism "sasl")
+(autoload 'auth-source-search "auth-source")
+
+;; User customizable variables:
+
+(defgroup sieve-manage nil
+ "Low-level Managesieve protocol issues."
+ :group 'mail
+ :prefix "sieve-")
+
+(defcustom sieve-manage-log "*sieve-manage-log*"
+ "Name of buffer for managesieve session trace."
+ :type 'string
+ :group 'sieve-manage)
+
+(defcustom sieve-manage-server-eol "\r\n"
+ "The EOL string sent from the server."
+ :type 'string
+ :group 'sieve-manage)
+
+(defcustom sieve-manage-client-eol "\r\n"
+ "The EOL string we send to the server."
+ :type 'string
+ :group 'sieve-manage)
+
+(defcustom sieve-manage-authenticators '(digest-md5
+ cram-md5
+ scram-md5
+ ntlm
+ plain
+ login)
+ "Priority of authenticators to consider when authenticating to server."
+ ;; FIXME Improve this. It's not `set'.
+ ;; It's like (repeat (choice (const ...))), where each choice can
+ ;; only appear once.
+ :type '(repeat symbol)
+ :group 'sieve-manage)
+
+(defcustom sieve-manage-authenticator-alist
+ '((cram-md5 sieve-manage-cram-md5-p sieve-manage-cram-md5-auth)
+ (digest-md5 sieve-manage-digest-md5-p sieve-manage-digest-md5-auth)
+ (scram-md5 sieve-manage-scram-md5-p sieve-manage-scram-md5-auth)
+ (ntlm sieve-manage-ntlm-p sieve-manage-ntlm-auth)
+ (plain sieve-manage-plain-p sieve-manage-plain-auth)
+ (login sieve-manage-login-p sieve-manage-login-auth))
+ "Definition of authenticators.
+
+\(NAME CHECK AUTHENTICATE)
+
+NAME names the authenticator. CHECK is a function returning non-nil if
+the server support the authenticator and AUTHENTICATE is a function
+for doing the actual authentication."
+ :type '(repeat (list (symbol :tag "Name") (function :tag "Check function")
+ (function :tag "Authentication function")))
+ :group 'sieve-manage)
+
+(defcustom sieve-manage-default-port "sieve"
+ "Default port number or service name for managesieve protocol."
+ :type '(choice integer string)
+ :version "24.4"
+ :group 'sieve-manage)
+
+(defcustom sieve-manage-default-stream 'network
+ "Default stream type to use for `sieve-manage'."
+ :version "24.1"
+ :type 'symbol
+ :group 'sieve-manage)
+
+;; Internal variables:
+
+(defconst sieve-manage-local-variables '(sieve-manage-server
+ sieve-manage-port
+ sieve-manage-auth
+ sieve-manage-stream
+ sieve-manage-process
+ sieve-manage-client-eol
+ sieve-manage-server-eol
+ sieve-manage-capability))
+(defconst sieve-manage-coding-system-for-read 'binary)
+(defconst sieve-manage-coding-system-for-write 'binary)
+(defvar sieve-manage-stream nil)
+(defvar sieve-manage-auth nil)
+(defvar sieve-manage-server nil)
+(defvar sieve-manage-port nil)
+(defvar sieve-manage-state 'closed
+ "Managesieve state.
+Valid states are `closed', `initial', `nonauth', and `auth'.")
+(defvar sieve-manage-process nil)
+(defvar sieve-manage-capability nil)
+
+;; Internal utility functions
+(autoload 'mm-enable-multibyte "mm-util")
+
+(defun sieve-manage-make-process-buffer ()
+ (with-current-buffer
+ (generate-new-buffer (format " *sieve %s:%s*"
+ sieve-manage-server
+ sieve-manage-port))
+ (mapc 'make-local-variable sieve-manage-local-variables)
+ (mm-enable-multibyte)
+ (buffer-disable-undo)
+ (current-buffer)))
+
+(defun sieve-manage-erase (&optional p buffer)
+ (let ((buffer (or buffer (current-buffer))))
+ (and sieve-manage-log
+ (with-current-buffer (get-buffer-create sieve-manage-log)
+ (mm-enable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert-buffer-substring buffer (with-current-buffer buffer
+ (point-min))
+ (or p (with-current-buffer buffer
+ (point-max)))))))
+ (delete-region (point-min) (or p (point-max))))
+
+(defun sieve-manage-open-server (server port &optional stream buffer)
+ "Open network connection to SERVER on PORT.
+Return the buffer associated with the connection."
+ (with-current-buffer buffer
+ (sieve-manage-erase)
+ (setq sieve-manage-state 'initial)
+ (destructuring-bind (proc . props)
+ (open-network-stream
+ "SIEVE" buffer server port
+ :type stream
+ :capability-command "CAPABILITY\r\n"
+ :end-of-command "^\\(OK\\|NO\\).*\n"
+ :success "^OK.*\n"
+ :return-list t
+ :starttls-function
+ (lambda (capabilities)
+ (when (string-match "\\bSTARTTLS\\b" capabilities)
+ "STARTTLS\r\n")))
+ (setq sieve-manage-process proc)
+ (setq sieve-manage-capability
+ (sieve-manage-parse-capability (plist-get props :capabilities)))
+ ;; Ignore new capabilities issues after successful STARTTLS
+ (when (and (memq stream '(nil network starttls))
+ (eq (plist-get props :type) 'tls))
+ (sieve-manage-drop-next-answer))
+ (current-buffer))))
+
+;; Authenticators
+(defun sieve-sasl-auth (buffer mech)
+ "Login to server using the SASL MECH method."
+ (message "sieve: Authenticating using %s..." mech)
+ (with-current-buffer buffer
+ (let* ((auth-info (auth-source-search :host sieve-manage-server
+ :port "sieve"
+ :max 1
+ :create t))
+ (user-name (or (plist-get (nth 0 auth-info) :user) ""))
+ (user-password (or (plist-get (nth 0 auth-info) :secret) ""))
+ (user-password (if (functionp user-password)
+ (funcall user-password)
+ user-password))
+ (client (sasl-make-client (sasl-find-mechanism (list mech))
+ user-name "sieve" sieve-manage-server))
+ (sasl-read-passphrase
+ ;; We *need* to copy the password, because sasl will modify it
+ ;; somehow.
+ `(lambda (prompt) ,(copy-sequence user-password)))
+ (step (sasl-next-step client nil))
+ (tag (sieve-manage-send
+ (concat
+ "AUTHENTICATE \""
+ mech
+ "\""
+ (and (sasl-step-data step)
+ (concat
+ " \""
+ (base64-encode-string
+ (sasl-step-data step)
+ 'no-line-break)
+ "\"")))))
+ data rsp)
+ (catch 'done
+ (while t
+ (setq rsp nil)
+ (goto-char (point-min))
+ (while (null (or (progn
+ (setq rsp (sieve-manage-is-string))
+ (if (not (and rsp (looking-at
+ sieve-manage-server-eol)))
+ (setq rsp nil)
+ (goto-char (match-end 0))
+ rsp))
+ (setq rsp (sieve-manage-is-okno))))
+ (accept-process-output sieve-manage-process 1)
+ (goto-char (point-min)))
+ (sieve-manage-erase)
+ (when (sieve-manage-ok-p rsp)
+ (when (and (cadr rsp)
+ (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp)))
+ (sasl-step-set-data
+ step (base64-decode-string (match-string 1 (cadr rsp)))))
+ (if (and (setq step (sasl-next-step client step))
+ (setq data (sasl-step-data step)))
+ ;; We got data for server but it's finished
+ (error "Server not ready for SASL data: %s" data)
+ ;; The authentication process is finished.
+ (throw 'done t)))
+ (unless (stringp rsp)
+ (error "Server aborted SASL authentication: %s" (caddr rsp)))
+ (sasl-step-set-data step (base64-decode-string rsp))
+ (setq step (sasl-next-step client step))
+ (sieve-manage-send
+ (if (sasl-step-data step)
+ (concat "\""
+ (base64-encode-string (sasl-step-data step)
+ 'no-line-break)
+ "\"")
+ ""))))
+ (message "sieve: Login using %s...done" mech))))
+
+(defun sieve-manage-cram-md5-p (buffer)
+ (sieve-manage-capability "SASL" "CRAM-MD5" buffer))
+
+(defun sieve-manage-cram-md5-auth (buffer)
+ "Login to managesieve server using the CRAM-MD5 SASL method."
+ (sieve-sasl-auth buffer "CRAM-MD5"))
+
+(defun sieve-manage-digest-md5-p (buffer)
+ (sieve-manage-capability "SASL" "DIGEST-MD5" buffer))
+
+(defun sieve-manage-digest-md5-auth (buffer)
+ "Login to managesieve server using the DIGEST-MD5 SASL method."
+ (sieve-sasl-auth buffer "DIGEST-MD5"))
+
+(defun sieve-manage-scram-md5-p (buffer)
+ (sieve-manage-capability "SASL" "SCRAM-MD5" buffer))
+
+(defun sieve-manage-scram-md5-auth (buffer)
+ "Login to managesieve server using the SCRAM-MD5 SASL method."
+ (sieve-sasl-auth buffer "SCRAM-MD5"))
+
+(defun sieve-manage-ntlm-p (buffer)
+ (sieve-manage-capability "SASL" "NTLM" buffer))
+
+(defun sieve-manage-ntlm-auth (buffer)
+ "Login to managesieve server using the NTLM SASL method."
+ (sieve-sasl-auth buffer "NTLM"))
+
+(defun sieve-manage-plain-p (buffer)
+ (sieve-manage-capability "SASL" "PLAIN" buffer))
+
+(defun sieve-manage-plain-auth (buffer)
+ "Login to managesieve server using the PLAIN SASL method."
+ (sieve-sasl-auth buffer "PLAIN"))
+
+(defun sieve-manage-login-p (buffer)
+ (sieve-manage-capability "SASL" "LOGIN" buffer))
+
+(defun sieve-manage-login-auth (buffer)
+ "Login to managesieve server using the LOGIN SASL method."
+ (sieve-sasl-auth buffer "LOGIN"))
+
+;; Managesieve API
+
+(defun sieve-manage-open (server &optional port stream auth buffer)
+ "Open a network connection to a managesieve SERVER (string).
+Optional argument PORT is port number (integer) on remote server.
+Optional argument STREAM is any of `sieve-manage-streams' (a symbol).
+Optional argument AUTH indicates authenticator to use, see
+`sieve-manage-authenticators' for available authenticators.
+If nil, chooses the best stream the server is capable of.
+Optional argument BUFFER is buffer (buffer, or string naming buffer)
+to work in."
+ (setq sieve-manage-port (or port sieve-manage-default-port))
+ (with-current-buffer (or buffer (sieve-manage-make-process-buffer))
+ (setq sieve-manage-server (or server
+ sieve-manage-server)
+ sieve-manage-stream (or stream
+ sieve-manage-stream
+ sieve-manage-default-stream)
+ sieve-manage-auth (or auth
+ sieve-manage-auth))
+ (message "sieve: Connecting to %s..." sieve-manage-server)
+ (sieve-manage-open-server sieve-manage-server
+ sieve-manage-port
+ sieve-manage-stream
+ (current-buffer))
+ (when (sieve-manage-opened (current-buffer))
+ ;; Choose authenticator
+ (when (and (null sieve-manage-auth)
+ (not (eq sieve-manage-state 'auth)))
+ (dolist (auth sieve-manage-authenticators)
+ (when (funcall (nth 1 (assq auth sieve-manage-authenticator-alist))
+ buffer)
+ (setq sieve-manage-auth auth)
+ (return)))
+ (unless sieve-manage-auth
+ (error "Couldn't figure out authenticator for server")))
+ (sieve-manage-erase)
+ (current-buffer))))
+
+(defun sieve-manage-authenticate (&optional buffer)
+ "Authenticate on server in BUFFER.
+Return `sieve-manage-state' value."
+ (with-current-buffer (or buffer (current-buffer))
+ (if (eq sieve-manage-state 'nonauth)
+ (when (funcall (nth 2 (assq sieve-manage-auth
+ sieve-manage-authenticator-alist))
+ (current-buffer))
+ (setq sieve-manage-state 'auth))
+ sieve-manage-state)))
+
+(defun sieve-manage-opened (&optional buffer)
+ "Return non-nil if connection to managesieve server in BUFFER is open.
+If BUFFER is nil then the current buffer is used."
+ (and (setq buffer (get-buffer (or buffer (current-buffer))))
+ (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (and sieve-manage-process
+ (memq (process-status sieve-manage-process) '(open run))))))
+
+(defun sieve-manage-close (&optional buffer)
+ "Close connection to managesieve server in BUFFER.
+If BUFFER is nil, the current buffer is used."
+ (with-current-buffer (or buffer (current-buffer))
+ (when (sieve-manage-opened)
+ (sieve-manage-send "LOGOUT")
+ (sit-for 1))
+ (when (and sieve-manage-process
+ (memq (process-status sieve-manage-process) '(open run)))
+ (delete-process sieve-manage-process))
+ (setq sieve-manage-process nil)
+ (sieve-manage-erase)
+ t))
+
+(defun sieve-manage-capability (&optional name value buffer)
+ "Check if capability NAME of server BUFFER match VALUE.
+If it does, return the server value of NAME. If not returns nil.
+If VALUE is nil, do not check VALUE and return server value.
+If NAME is nil, return the full server list of capabilities."
+ (with-current-buffer (or buffer (current-buffer))
+ (if (null name)
+ sieve-manage-capability
+ (let ((server-value (cadr (assoc name sieve-manage-capability))))
+ (when (or (null value)
+ (and server-value
+ (string-match value server-value)))
+ server-value)))))
+
+(defun sieve-manage-listscripts (&optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send "LISTSCRIPTS")
+ (sieve-manage-parse-listscripts)))
+
+(defun sieve-manage-havespace (name size &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send (format "HAVESPACE \"%s\" %s" name size))
+ (sieve-manage-parse-okno)))
+
+(defun sieve-manage-putscript (name content &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send (format "PUTSCRIPT \"%s\" {%d+}%s%s" name
+ ;; Here we assume that the coding-system will
+ ;; replace each char with a single byte.
+ ;; This is always the case if `content' is
+ ;; a unibyte string.
+ (length content)
+ sieve-manage-client-eol content))
+ (sieve-manage-parse-okno)))
+
+(defun sieve-manage-deletescript (name &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send (format "DELETESCRIPT \"%s\"" name))
+ (sieve-manage-parse-okno)))
+
+(defun sieve-manage-getscript (name output-buffer &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send (format "GETSCRIPT \"%s\"" name))
+ (let ((script (sieve-manage-parse-string)))
+ (sieve-manage-parse-crlf)
+ (with-current-buffer output-buffer
+ (insert script))
+ (sieve-manage-parse-okno))))
+
+(defun sieve-manage-setactive (name &optional buffer)
+ (with-current-buffer (or buffer (current-buffer))
+ (sieve-manage-send (format "SETACTIVE \"%s\"" name))
+ (sieve-manage-parse-okno)))
+
+;; Protocol parsing routines
+
+(defun sieve-manage-wait-for-answer ()
+ (let ((pattern "^\\(OK\\|NO\\).*\n")
+ pos)
+ (while (not pos)
+ (setq pos (search-forward-regexp pattern nil t))
+ (goto-char (point-min))
+ (sleep-for 0 50))
+ pos))
+
+(defun sieve-manage-drop-next-answer ()
+ (sieve-manage-wait-for-answer)
+ (sieve-manage-erase))
+
+(defun sieve-manage-ok-p (rsp)
+ (string= (downcase (or (car-safe rsp) "")) "ok"))
+
+(defun sieve-manage-is-okno ()
+ (when (looking-at (concat
+ "^\\(OK\\|NO\\)\\( (\\([^)]+\\))\\)?\\( \\(.*\\)\\)?"
+ sieve-manage-server-eol))
+ (let ((status (match-string 1))
+ (resp-code (match-string 3))
+ (response (match-string 5)))
+ (when response
+ (goto-char (match-beginning 5))
+ (setq response (sieve-manage-is-string)))
+ (list status resp-code response))))
+
+(defun sieve-manage-parse-okno ()
+ (let (rsp)
+ (while (null rsp)
+ (accept-process-output (get-buffer-process (current-buffer)) 1)
+ (goto-char (point-min))
+ (setq rsp (sieve-manage-is-okno)))
+ (sieve-manage-erase)
+ rsp))
+
+(defun sieve-manage-parse-capability (str)
+ "Parse managesieve capability string `STR'.
+Set variable `sieve-manage-capability' to "
+ (let ((capas (delq nil
+ (mapcar #'split-string-and-unquote
+ (split-string str "\n")))))
+ (when (string= "OK" (caar (last capas)))
+ (setq sieve-manage-state 'nonauth))
+ capas))
+
+(defun sieve-manage-is-string ()
+ (cond ((looking-at "\"\\([^\"]+\\)\"")
+ (prog1
+ (match-string 1)
+ (goto-char (match-end 0))))
+ ((looking-at (concat "{\\([0-9]+\\+?\\)}" sieve-manage-server-eol))
+ (let ((pos (match-end 0))
+ (len (string-to-number (match-string 1))))
+ (if (< (point-max) (+ pos len))
+ nil
+ (goto-char (+ pos len))
+ (buffer-substring pos (+ pos len)))))))
+
+(defun sieve-manage-parse-string ()
+ (let (rsp)
+ (while (null rsp)
+ (accept-process-output (get-buffer-process (current-buffer)) 1)
+ (goto-char (point-min))
+ (setq rsp (sieve-manage-is-string)))
+ (sieve-manage-erase (point))
+ rsp))
+
+(defun sieve-manage-parse-crlf ()
+ (when (looking-at sieve-manage-server-eol)
+ (sieve-manage-erase (match-end 0))))
+
+(defun sieve-manage-parse-listscripts ()
+ (let (tmp rsp data)
+ (while (null rsp)
+ (while (null (or (setq rsp (sieve-manage-is-okno))
+ (setq tmp (sieve-manage-is-string))))
+ (accept-process-output (get-buffer-process (current-buffer)) 1)
+ (goto-char (point-min)))
+ (when tmp
+ (while (not (looking-at (concat "\\( ACTIVE\\)?"
+ sieve-manage-server-eol)))
+ (accept-process-output (get-buffer-process (current-buffer)) 1)
+ (goto-char (point-min)))
+ (if (match-string 1)
+ (push (cons 'active tmp) data)
+ (push tmp data))
+ (goto-char (match-end 0))
+ (setq tmp nil)))
+ (sieve-manage-erase)
+ (if (sieve-manage-ok-p rsp)
+ data
+ rsp)))
+
+(defun sieve-manage-send (cmdstr)
+ (setq cmdstr (concat cmdstr sieve-manage-client-eol))
+ (and sieve-manage-log
+ (with-current-buffer (get-buffer-create sieve-manage-log)
+ (mm-enable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (insert cmdstr)))
+ (process-send-string sieve-manage-process cmdstr))
+
+(provide 'sieve-manage)
+
+;; sieve-manage.el ends here
--- /dev/null
+;;; sieve-mode.el --- Sieve code editing commands for Emacs
+
+;; Copyright (C) 2001-2016 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file contain editing mode functions and font-lock support for
+;; editing Sieve scripts. It sets up C-mode with support for
+;; sieve-style #-comments and a lightly hacked syntax table. It was
+;; strongly influenced by awk-mode.el.
+;;
+;; Put something similar to the following in your .emacs to use this file:
+;;
+;; (load "~/lisp/sieve")
+;; (setq auto-mode-alist (cons '("\\.siv\\'" . sieve-mode) auto-mode-alist))
+;;
+;; References:
+;;
+;; RFC 3028,
+;; "Sieve: A Mail Filtering Language",
+;; by Tim Showalter.
+;;
+;; Release history:
+;;
+;; 2001-03-02 version 1.0 posted to gnu.emacs.sources
+;; version 1.1 change file extension into ".siv" (official one)
+;; added keymap and menubar to hook into sieve-manage
+;; 2001-10-31 version 1.2 committed to Oort Gnus
+
+;;; Code:
+
+(autoload 'sieve-manage "sieve")
+(autoload 'sieve-upload "sieve")
+(eval-when-compile
+ (require 'font-lock))
+
+(defgroup sieve nil
+ "Sieve."
+ :group 'languages)
+
+(defcustom sieve-mode-hook nil
+ "Hook run in sieve mode buffers."
+ :group 'sieve
+ :type 'hook)
+
+;; Font-lock
+
+(defvar sieve-control-commands-face 'sieve-control-commands
+ "Face name used for Sieve Control Commands.")
+
+(defface sieve-control-commands
+ '((((type tty) (class color)) (:foreground "blue" :weight light))
+ (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
+ (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
+ (((class color) (background light)) (:foreground "Orchid"))
+ (((class color) (background dark)) (:foreground "LightSteelBlue"))
+ (t (:bold t)))
+ "Face used for Sieve Control Commands."
+ :group 'sieve)
+;; backward-compatibility alias
+(put 'sieve-control-commands-face 'face-alias 'sieve-control-commands)
+(put 'sieve-control-commands-face 'obsolete-face "22.1")
+
+(defvar sieve-action-commands-face 'sieve-action-commands
+ "Face name used for Sieve Action Commands.")
+
+(defface sieve-action-commands
+ '((((type tty) (class color)) (:foreground "blue" :weight bold))
+ (((class color) (background light)) (:foreground "Blue"))
+ (((class color) (background dark)) (:foreground "LightSkyBlue"))
+ (t (:inverse-video t :bold t)))
+ "Face used for Sieve Action Commands."
+ :group 'sieve)
+;; backward-compatibility alias
+(put 'sieve-action-commands-face 'face-alias 'sieve-action-commands)
+(put 'sieve-action-commands-face 'obsolete-face "22.1")
+
+(defvar sieve-test-commands-face 'sieve-test-commands
+ "Face name used for Sieve Test Commands.")
+
+(defface sieve-test-commands
+ '((((type tty) (class color)) (:foreground "magenta"))
+ (((class grayscale) (background light))
+ (:foreground "LightGray" :bold t :underline t))
+ (((class grayscale) (background dark))
+ (:foreground "Gray50" :bold t :underline t))
+ (((class color) (background light)) (:foreground "CadetBlue"))
+ (((class color) (background dark)) (:foreground "Aquamarine"))
+ (t (:bold t :underline t)))
+ "Face used for Sieve Test Commands."
+ :group 'sieve)
+;; backward-compatibility alias
+(put 'sieve-test-commands-face 'face-alias 'sieve-test-commands)
+(put 'sieve-test-commands-face 'obsolete-face "22.1")
+
+(defvar sieve-tagged-arguments-face 'sieve-tagged-arguments
+ "Face name used for Sieve Tagged Arguments.")
+
+(defface sieve-tagged-arguments
+ '((((type tty) (class color)) (:foreground "cyan" :weight bold))
+ (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
+ (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
+ (((class color) (background light)) (:foreground "Purple"))
+ (((class color) (background dark)) (:foreground "Cyan"))
+ (t (:bold t)))
+ "Face used for Sieve Tagged Arguments."
+ :group 'sieve)
+;; backward-compatibility alias
+(put 'sieve-tagged-arguments-face 'face-alias 'sieve-tagged-arguments)
+(put 'sieve-tagged-arguments-face 'obsolete-face "22.1")
+
+
+(defconst sieve-font-lock-keywords
+ (eval-when-compile
+ (list
+ ;; control commands
+ (cons (regexp-opt '("require" "if" "else" "elsif" "stop")
+ 'words)
+ 'sieve-control-commands-face)
+ ;; action commands
+ (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard")
+ 'words)
+ 'sieve-action-commands-face)
+ ;; test commands
+ (cons (regexp-opt '("address" "allof" "anyof" "exists" "false"
+ "true" "header" "not" "size" "envelope"
+ "body")
+ 'words)
+ 'sieve-test-commands-face)
+ (cons "\\Sw+:\\sw+"
+ 'sieve-tagged-arguments-face))))
+
+;; Syntax table
+
+(defvar sieve-mode-syntax-table nil
+ "Syntax table in use in sieve-mode buffers.")
+
+(if sieve-mode-syntax-table
+ ()
+ (setq sieve-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\\ "\\" sieve-mode-syntax-table)
+ (modify-syntax-entry ?\n "> " sieve-mode-syntax-table)
+ (modify-syntax-entry ?\f "> " sieve-mode-syntax-table)
+ (modify-syntax-entry ?\# "< " sieve-mode-syntax-table)
+ (modify-syntax-entry ?/ "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?* "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?+ "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?- "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?= "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?% "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?< "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?> "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?& "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?| "." sieve-mode-syntax-table)
+ (modify-syntax-entry ?_ "_" sieve-mode-syntax-table)
+ (modify-syntax-entry ?\' "\"" sieve-mode-syntax-table))
+
+;; Key map definition
+
+(defvar sieve-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-c\C-l" 'sieve-upload)
+ (define-key map "\C-c\C-c" 'sieve-upload-and-kill)
+ (define-key map "\C-c\C-m" 'sieve-manage)
+ map)
+ "Key map used in sieve mode.")
+
+;; Menu definition
+
+(defvar sieve-mode-menu nil
+ "Menubar used in sieve mode.")
+
+;; Code for Sieve editing mode.
+(autoload 'easy-menu-add-item "easymenu")
+
+;;;###autoload
+(define-derived-mode sieve-mode c-mode "Sieve"
+ "Major mode for editing Sieve code.
+This is much like C mode except for the syntax of comments. Its keymap
+inherits from C mode's and it has the same variables for customizing
+indentation. It has its own abbrev table and its own syntax table.
+
+Turning on Sieve mode runs `sieve-mode-hook'."
+ (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter))
+ (set (make-local-variable 'paragraph-separate) paragraph-start)
+ (set (make-local-variable 'comment-start) "#")
+ (set (make-local-variable 'comment-end) "")
+ ;;(set (make-local-variable 'comment-start-skip) "\\(^\\|\\s-\\);?#+ *")
+ (set (make-local-variable 'comment-start-skip) "#+ *")
+ (set (make-local-variable 'font-lock-defaults)
+ '(sieve-font-lock-keywords nil nil ((?_ . "w"))))
+ (easy-menu-add-item nil nil sieve-mode-menu))
+
+;; Menu
+
+(easy-menu-define sieve-mode-menu sieve-mode-map
+ "Sieve Menu."
+ '("Sieve"
+ ["Upload script" sieve-upload t]
+ ["Manage scripts on server" sieve-manage t]))
+
+(provide 'sieve-mode)
+
+;; sieve-mode.el ends here
--- /dev/null
+;;; sieve.el --- Utilities to manage sieve scripts
+
+;; Copyright (C) 2001-2016 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file contain utilities to facilitate upload, download and
+;; general management of sieve scripts. Currently only the
+;; Managesieve protocol is supported (using sieve-manage.el), but when
+;; (useful) alternatives become available, they might be supported as
+;; well.
+;;
+;; The cursor navigation was inspired by biff-mode by Franklin Lee.
+;;
+;; Release history:
+;;
+;; 2001-10-31 Committed to Oort Gnus.
+;; 2002-07-27 Fix down-mouse-2 and down-mouse-3 in manage-mode. Fix menubar
+;; in manage-mode. Change some messages. Added sieve-deactivate*,
+;; sieve-remove. Fixed help text in manage-mode. Suggested by
+;; Ned Ludd.
+;;
+;; Todo:
+;;
+;; * Namespace? This file contains `sieve-manage' and
+;; `sieve-manage-mode', but there is a sieve-manage.el file as well.
+;; Can't think of a good solution though, this file need a *-mode,
+;; and naming it `sieve-mode' would collide with sieve-mode.el. One
+;; solution would be to come up with some better name that this file
+;; can use that doesn't have the managesieve specific "manage" in
+;; it. sieve-dired? i dunno. we could copy all off sieve.el into
+;; sieve-manage.el too, but I'd like to separate the interface from
+;; the protocol implementation since the backends are likely to
+;; change (well).
+;;
+;; * Define servers? We could have a customize buffer to create a server,
+;; with authentication/stream/etc parameters, much like Gnus, and then
+;; only use names of defined servers when interacting with M-x sieve-*.
+;; Right now you can't use STARTTLS, which sieve-manage.el provides
+
+;;; Code:
+
+(require 'sieve-manage)
+(require 'sieve-mode)
+
+;; User customizable variables:
+
+(defgroup sieve nil
+ "Manage sieve scripts."
+ :version "22.1"
+ :group 'tools)
+
+(defcustom sieve-new-script "<new script>"
+ "Name of name script indicator."
+ :type 'string
+ :group 'sieve)
+
+(defcustom sieve-buffer "*sieve*"
+ "Name of sieve management buffer."
+ :type 'string
+ :group 'sieve)
+
+(defcustom sieve-template "\
+require \"fileinto\";
+
+# Example script (remove comment character '#' to make it effective!):
+#
+# if header :contains \"from\" \"coyote\" {
+# discard;
+# } elsif header :contains [\"subject\"] [\"$$$\"] {
+# discard;
+# } else {
+# fileinto \"INBOX\";
+# }
+"
+ "Template sieve script."
+ :type 'string
+ :group 'sieve)
+
+;; Internal variables:
+
+(defvar sieve-manage-buffer nil)
+(defvar sieve-buffer-header-end nil)
+(defvar sieve-buffer-script-name nil
+ "The real script name of the buffer.")
+(make-local-variable 'sieve-buffer-script-name)
+
+;; Sieve-manage mode:
+
+(defvar sieve-manage-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; various
+ (define-key map "?" 'sieve-help)
+ (define-key map "h" 'sieve-help)
+ ;; activating
+ (define-key map "m" 'sieve-activate)
+ (define-key map "u" 'sieve-deactivate)
+ (define-key map "\M-\C-?" 'sieve-deactivate-all)
+ ;; navigation keys
+ (define-key map "\C-p" 'sieve-prev-line)
+ (define-key map [up] 'sieve-prev-line)
+ (define-key map "\C-n" 'sieve-next-line)
+ (define-key map [down] 'sieve-next-line)
+ (define-key map " " 'sieve-next-line)
+ (define-key map "n" 'sieve-next-line)
+ (define-key map "p" 'sieve-prev-line)
+ (define-key map "\C-m" 'sieve-edit-script)
+ (define-key map "f" 'sieve-edit-script)
+ (define-key map "o" 'sieve-edit-script-other-window)
+ (define-key map "r" 'sieve-remove)
+ (define-key map "q" 'sieve-bury-buffer)
+ (define-key map "Q" 'sieve-manage-quit)
+ (define-key map [(down-mouse-2)] 'sieve-edit-script)
+ (define-key map [(down-mouse-3)] 'sieve-manage-mode-menu)
+ map)
+ "Keymap for `sieve-manage-mode'.")
+
+(easy-menu-define sieve-manage-mode-menu sieve-manage-mode-map
+ "Sieve Menu."
+ '("Manage Sieve"
+ ["Edit script" sieve-edit-script t]
+ ["Activate script" sieve-activate t]
+ ["Deactivate script" sieve-deactivate t]))
+
+(define-derived-mode sieve-manage-mode fundamental-mode "Sieve-manage"
+ "Mode used for sieve script management."
+ (buffer-disable-undo (current-buffer))
+ (setq truncate-lines t)
+ (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map))
+
+(put 'sieve-manage-mode 'mode-class 'special)
+
+;; Commands used in sieve-manage mode:
+
+(defun sieve-manage-quit ()
+ "Quit Manage Sieve and close the connection."
+ (interactive)
+ (sieve-manage-close sieve-manage-buffer)
+ (kill-buffer sieve-manage-buffer)
+ (kill-buffer (current-buffer)))
+
+(defun sieve-bury-buffer ()
+ "Bury the Manage Sieve buffer without closing the connection."
+ (interactive)
+ (bury-buffer))
+
+(defun sieve-activate (&optional pos)
+ (interactive "d")
+ (let ((name (sieve-script-at-point)) err)
+ (when (or (null name) (string-equal name sieve-new-script))
+ (error "No sieve script at point"))
+ (message "Activating script %s..." name)
+ (setq err (sieve-manage-setactive name sieve-manage-buffer))
+ (sieve-refresh-scriptlist)
+ (if (sieve-manage-ok-p err)
+ (message "Activating script %s...done" name)
+ (message "Activating script %s...failed: %s" name (nth 2 err)))))
+
+(defun sieve-deactivate-all (&optional pos)
+ (interactive "d")
+ (let ((name (sieve-script-at-point)) err)
+ (message "Deactivating scripts...")
+ (setq err (sieve-manage-setactive "" sieve-manage-buffer))
+ (sieve-refresh-scriptlist)
+ (if (sieve-manage-ok-p err)
+ (message "Deactivating scripts...done")
+ (message "Deactivating scripts...failed: %s" (nth 2 err)))))
+
+(defalias 'sieve-deactivate 'sieve-deactivate-all)
+
+(defun sieve-remove (&optional pos)
+ (interactive "d")
+ (let ((name (sieve-script-at-point)) err)
+ (when (or (null name) (string-equal name sieve-new-script))
+ (error "No sieve script at point"))
+ (message "Removing sieve script %s..." name)
+ (setq err (sieve-manage-deletescript name sieve-manage-buffer))
+ (unless (sieve-manage-ok-p err)
+ (error "Removing sieve script %s...failed: " err))
+ (sieve-refresh-scriptlist)
+ (message "Removing sieve script %s...done" name)))
+
+(defun sieve-edit-script (&optional pos)
+ (interactive "d")
+ (let ((name (sieve-script-at-point)))
+ (unless name
+ (error "No sieve script at point"))
+ (if (not (string-equal name sieve-new-script))
+ (let ((newbuf (generate-new-buffer name))
+ err)
+ (setq err (sieve-manage-getscript name newbuf sieve-manage-buffer))
+ (switch-to-buffer newbuf)
+ (unless (sieve-manage-ok-p err)
+ (error "Sieve download failed: %s" err)))
+ (switch-to-buffer (get-buffer-create "template.siv"))
+ (insert sieve-template))
+ (sieve-mode)
+ (setq sieve-buffer-script-name name)
+ (goto-char (point-min))
+ (message
+ (substitute-command-keys
+ "Press \\[sieve-upload] to upload script to server."))))
+
+(defmacro sieve-change-region (&rest body)
+ "Turns off sieve-region before executing BODY, then re-enables it after.
+Used to bracket operations which move point in the sieve-buffer."
+ `(progn
+ (sieve-highlight nil)
+ ,@body
+ (sieve-highlight t)))
+(put 'sieve-change-region 'lisp-indent-function 0)
+
+(defun sieve-next-line (&optional arg)
+ (interactive)
+ (unless arg
+ (setq arg 1))
+ (if (save-excursion
+ (forward-line arg)
+ (sieve-script-at-point))
+ (sieve-change-region
+ (forward-line arg))
+ (message "End of list")))
+
+(defun sieve-prev-line (&optional arg)
+ (interactive)
+ (unless arg
+ (setq arg -1))
+ (if (save-excursion
+ (forward-line arg)
+ (sieve-script-at-point))
+ (sieve-change-region
+ (forward-line arg))
+ (message "Beginning of list")))
+
+(defun sieve-help ()
+ "Display help for various sieve commands."
+ (interactive)
+ (if (eq last-command 'sieve-help)
+ ;; would need minor-mode for log-edit-mode
+ (describe-function 'sieve-mode)
+ (message "%s" (substitute-command-keys
+ "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove"))))
+
+;; Create buffer:
+
+(defun sieve-setup-buffer (server port)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (buffer-disable-undo)
+ (let* ((port (or port sieve-manage-default-port))
+ (header (format "Server : %s:%s\n\n" server port)))
+ (insert header))
+ (set (make-local-variable 'sieve-buffer-header-end)
+ (point-max)))
+
+(defun sieve-script-at-point (&optional pos)
+ "Return name of sieve script at point POS, or nil."
+ (interactive "d")
+ (get-char-property (or pos (point)) 'script-name))
+
+(defun sieve-highlight (on)
+ "Turn ON or off highlighting on the current language overlay."
+ (overlay-put (car (overlays-at (point))) 'face (if on 'highlight 'default)))
+
+(defun sieve-insert-scripts (scripts)
+ "Format and insert LANGUAGE-LIST strings into current buffer at point."
+ (while scripts
+ (let ((p (point))
+ (ext nil)
+ (script (pop scripts)))
+ (if (consp script)
+ (insert (format " ACTIVE %s" (cdr script)))
+ (insert (format " %s" script)))
+ (setq ext (make-overlay p (point)))
+ (overlay-put ext 'mouse-face 'highlight)
+ (overlay-put ext 'script-name (if (consp script)
+ (cdr script)
+ script))
+ (insert "\n"))))
+
+(defun sieve-open-server (server &optional port)
+ "Open SERVER (on PORT) and authenticate."
+ (with-current-buffer
+ (or ;; open server
+ (set (make-local-variable 'sieve-manage-buffer)
+ (sieve-manage-open server port))
+ (error "Error opening server %s" server))
+ (sieve-manage-authenticate)))
+
+(defun sieve-refresh-scriptlist ()
+ (interactive)
+ (with-current-buffer sieve-buffer
+ (setq buffer-read-only nil)
+ (delete-region (or sieve-buffer-header-end (point-max)) (point-max))
+ (goto-char (point-max))
+ ;; get list of script names and print them
+ (let ((scripts (sieve-manage-listscripts sieve-manage-buffer)))
+ (if (null scripts)
+ (insert
+ (substitute-command-keys
+ (format
+ "No scripts on server, press \\[sieve-edit-script] on %s to create a new script.\n"
+ sieve-new-script)))
+ (insert
+ (substitute-command-keys
+ (format (concat "%d script%s on server, press \\[sieve-edit-script] on a script "
+ "name edits it, or\npress \\[sieve-edit-script] on %s to create "
+ "a new script.\n") (length scripts)
+ (if (eq (length scripts) 1) "" "s")
+ sieve-new-script))))
+ (save-excursion
+ (sieve-insert-scripts (list sieve-new-script))
+ (sieve-insert-scripts scripts)))
+ (sieve-highlight t)
+ (setq buffer-read-only t)))
+
+;;;###autoload
+(defun sieve-manage (server &optional port)
+ (interactive "sServer: ")
+ (switch-to-buffer (get-buffer-create sieve-buffer))
+ (sieve-manage-mode)
+ (sieve-setup-buffer server port)
+ (if (sieve-open-server server port)
+ (sieve-refresh-scriptlist)
+ (message "Could not open server %s" server)))
+
+;;;###autoload
+(defun sieve-upload (&optional name)
+ (interactive)
+ (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage))
+ (let ((script (buffer-string)) err)
+ (with-current-buffer (get-buffer sieve-buffer)
+ (setq err (sieve-manage-putscript
+ (or name sieve-buffer-script-name (buffer-name))
+ script sieve-manage-buffer))
+ (if (sieve-manage-ok-p err)
+ (message (substitute-command-keys
+ "Sieve upload done. Use \\[sieve-manage] to manage scripts."))
+ (message "Sieve upload failed: %s" (nth 2 err)))))))
+
+;;;###autoload
+(defun sieve-upload-and-bury (&optional name)
+ (interactive)
+ (sieve-upload name)
+ (bury-buffer))
+
+;;;###autoload
+(defun sieve-upload-and-kill (&optional name)
+ (interactive)
+ (sieve-upload name)
+ (kill-buffer))
+
+(provide 'sieve)
+
+;; sieve.el ends here
--- /dev/null
+;;; starttls.el --- STARTTLS functions
+
+;; Copyright (C) 1999-2016 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Author: Simon Josefsson <simon@josefsson.org>
+;; Created: 1999/11/20
+;; Keywords: TLS, SSL, OpenSSL, GnuTLS, mail, news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module defines some utility functions for STARTTLS profiles.
+
+;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
+;; by Chris Newman <chris.newman@innosoft.com> (1999/06)
+
+;; This file now contains a combination of the two previous
+;; implementations both called "starttls.el". The first one is Daiki
+;; Ueno's starttls.el which uses his own "starttls" command line tool,
+;; and the second one is Simon Josefsson's starttls.el which uses
+;; "gnutls-cli" from GnuTLS.
+;;
+;; If "starttls" is available, it is preferred by the code over
+;; "gnutls-cli", for backwards compatibility. Use
+;; `starttls-use-gnutls' to toggle between implementations if you have
+;; both tools installed. It is recommended to use GnuTLS, though, as
+;; it performs more verification of the certificates.
+
+;; The GnuTLS support requires GnuTLS 0.9.90 (released 2003-10-08) or
+;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls"
+;; from <ftp://ftp.opaopa.org/pub/elisp/>.
+
+;; Usage is similar to `open-network-stream'. For example:
+;;
+;; (when (setq tmp (starttls-open-stream
+;; "test" (current-buffer) "yxa.extundo.com" 25))
+;; (accept-process-output tmp 15)
+;; (process-send-string tmp "STARTTLS\n")
+;; (accept-process-output tmp 15)
+;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp))
+;; (process-send-string tmp "EHLO foo\n"))
+
+;; An example run yields the following output:
+;;
+;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65]
+;; 220 2.0.0 Ready to start TLS
+;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you
+;; 250-ENHANCEDSTATUSCODES
+;; 250-PIPELINING
+;; 250-EXPN
+;; 250-VERB
+;; 250-8BITMIME
+;; 250-SIZE
+;; 250-DSN
+;; 250-ETRN
+;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN
+;; 250-DELIVERBY
+;; 250 HELP
+;; nil
+;;
+;; With the message buffer containing:
+;;
+;; STARTTLS output:
+;; *** Starting TLS handshake
+;; - Server's trusted authorities:
+;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;; - Certificate type: X.509
+;; - Got a certificate list of 2 certificates.
+;;
+;; - Certificate[0] info:
+;; # The hostname in the certificate matches 'yxa.extundo.com'.
+;; # valid since: Wed May 26 12:16:00 CEST 2004
+;; # expires at: Wed Jul 26 12:16:00 CEST 2023
+;; # serial number: 04
+;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a
+;; # version: #1
+;; # public key algorithm: RSA
+;; # Modulus: 1024 bits
+;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;;
+;; - Certificate[1] info:
+;; # valid since: Sun May 23 11:35:00 CEST 2004
+;; # expires at: Sun Jul 23 11:35:00 CEST 2023
+;; # serial number: 00
+;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae
+;; # version: #3
+;; # public key algorithm: RSA
+;; # Modulus: 1024 bits
+;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;;
+;; - Peer's certificate issuer is unknown
+;; - Peer's certificate is NOT trusted
+;; - Version: TLS 1.0
+;; - Key Exchange: RSA
+;; - Cipher: ARCFOUR 128
+;; - MAC: SHA
+;; - Compression: NULL
+
+;;; Code:
+
+(defgroup starttls nil
+ "Support for `Transport Layer Security' protocol."
+ :version "21.1"
+ :group 'mail)
+
+(defcustom starttls-gnutls-program "gnutls-cli"
+ "Name of GnuTLS command line tool.
+This program is used when GnuTLS is used, i.e. when
+`starttls-use-gnutls' is non-nil."
+ :version "22.1"
+ :type 'string
+ :group 'starttls)
+
+(defcustom starttls-program "starttls"
+ "The program to run in a subprocess to open an TLSv1 connection.
+This program is used when the `starttls' command is used,
+i.e. when `starttls-use-gnutls' is nil."
+ :type 'string
+ :group 'starttls)
+
+(defcustom starttls-use-gnutls (not (executable-find starttls-program))
+ "*Whether to use GnuTLS instead of the `starttls' command."
+ :version "22.1"
+ :type 'boolean
+ :group 'starttls)
+
+(defcustom starttls-extra-args nil
+ "Extra arguments to `starttls-program'.
+These apply when the `starttls' command is used, i.e. when
+`starttls-use-gnutls' is nil."
+ :type '(repeat string)
+ :group 'starttls)
+
+(defcustom starttls-extra-arguments nil
+ "Extra arguments to `starttls-gnutls-program'.
+These apply when GnuTLS is used, i.e. when `starttls-use-gnutls' is non-nil.
+
+For example, non-TLS compliant servers may require
+'(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to
+find out which parameters are available."
+ :version "22.1"
+ :type '(repeat string)
+ :group 'starttls)
+
+(defcustom starttls-process-connection-type nil
+ "*Value for `process-connection-type' to use when starting STARTTLS process."
+ :version "22.1"
+ :type 'boolean
+ :group 'starttls)
+
+(defcustom starttls-connect "- Simple Client Mode:\n\n"
+ "*Regular expression indicating successful connection.
+The default is what GnuTLS's \"gnutls-cli\" outputs."
+ ;; GnuTLS cli.c:main() prints this string when it is starting to run
+ ;; in the application read/write phase. If the logic, or the string
+ ;; itself, is modified, this must be updated.
+ :version "22.1"
+ :type 'regexp
+ :group 'starttls)
+
+(defcustom starttls-failure "\\*\\*\\* Handshake has failed"
+ "*Regular expression indicating failed TLS handshake.
+The default is what GnuTLS's \"gnutls-cli\" outputs."
+ ;; GnuTLS cli.c:do_handshake() prints this string on failure. If the
+ ;; logic, or the string itself, is modified, this must be updated.
+ :version "22.1"
+ :type 'regexp
+ :group 'starttls)
+
+(defcustom starttls-success "- Compression: "
+ "*Regular expression indicating completed TLS handshakes.
+The default is what GnuTLS's \"gnutls-cli\" outputs."
+ ;; GnuTLS cli.c:do_handshake() calls, on success,
+ ;; common.c:print_info(), that unconditionally print this string
+ ;; last. If that logic, or the string itself, is modified, this
+ ;; must be updated.
+ :version "22.1"
+ :type 'regexp
+ :group 'starttls)
+
+(defun starttls-negotiate-gnutls (process)
+ "Negotiate TLS on PROCESS opened by `open-starttls-stream'.
+This should typically only be done once. It typically returns a
+multi-line informational message with information about the
+handshake, or nil on failure."
+ (let (buffer info old-max done-ok done-bad)
+ (if (null (setq buffer (process-buffer process)))
+ ;; XXX How to remove/extract the TLS negotiation junk?
+ (signal-process (process-id process) 'SIGALRM)
+ (with-current-buffer buffer
+ (save-excursion
+ (setq old-max (goto-char (point-max)))
+ (signal-process (process-id process) 'SIGALRM)
+ (while (and (processp process)
+ (eq (process-status process) 'run)
+ (save-excursion
+ (goto-char old-max)
+ (not (or (setq done-ok (re-search-forward
+ starttls-success nil t))
+ (setq done-bad (re-search-forward
+ starttls-failure nil t))))))
+ (accept-process-output process 1 100)
+ (sit-for 0.1))
+ (setq info (buffer-substring-no-properties old-max (point-max)))
+ (delete-region old-max (point-max))
+ (if (or (and done-ok (not done-bad))
+ ;; Prevent mitm that fake success msg after failure msg.
+ (and done-ok done-bad (< done-ok done-bad)))
+ info
+ (message "STARTTLS negotiation failed: %s" info)
+ nil))))))
+
+(defun starttls-negotiate (process)
+ (if starttls-use-gnutls
+ (starttls-negotiate-gnutls process)
+ (signal-process (process-id process) 'SIGALRM)))
+
+(defun starttls-open-stream-gnutls (name buffer host port)
+ (message "Opening STARTTLS connection to `%s:%s'..." host port)
+ (let* (done
+ (old-max (with-current-buffer buffer (point-max)))
+ (process-connection-type starttls-process-connection-type)
+ (process (apply #'start-process name buffer
+ starttls-gnutls-program "-s" host
+ "-p" (if (integerp port)
+ (int-to-string port)
+ port)
+ starttls-extra-arguments)))
+ (set-process-query-on-exit-flag process nil)
+ (while (and (processp process)
+ (eq (process-status process) 'run)
+ (with-current-buffer buffer
+ (goto-char old-max)
+ (not (setq done (re-search-forward
+ starttls-connect nil t)))))
+ (accept-process-output process 0 100)
+ (sit-for 0.1))
+ (if done
+ (with-current-buffer buffer
+ (delete-region old-max done))
+ (delete-process process)
+ (setq process nil))
+ (message "Opening STARTTLS connection to `%s:%s'...%s"
+ host port (if done "done" "failed"))
+ process))
+
+;;;###autoload
+(defun starttls-open-stream (name buffer host port)
+ "Open a TLS connection for a port to a host.
+Returns a subprocess object to represent the connection.
+Input and output work as for subprocesses; `delete-process' closes it.
+Args are NAME BUFFER HOST PORT.
+NAME is name for process. It is modified if necessary to make it unique.
+BUFFER is the buffer (or `buffer-name') to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may be also nil, meaning that this process is not associated
+ with any buffer
+Third arg is name of the host to connect to, or its IP address.
+Fourth arg PORT is an integer specifying a port to connect to.
+If `starttls-use-gnutls' is nil, this may also be a service name, but
+GnuTLS requires a port number."
+ (if starttls-use-gnutls
+ (starttls-open-stream-gnutls name buffer host port)
+ (message "Opening STARTTLS connection to `%s:%s'" host (format "%s" port))
+ (let* ((process-connection-type starttls-process-connection-type)
+ (process (apply #'start-process
+ name buffer starttls-program
+ host (format "%s" port)
+ starttls-extra-args)))
+ (set-process-query-on-exit-flag process nil)
+ process)))
+
+(defun starttls-available-p ()
+ "Say whether the STARTTLS programs are available."
+ (and (not (memq system-type '(windows-nt ms-dos)))
+ (executable-find (if starttls-use-gnutls
+ starttls-gnutls-program
+ starttls-program))))
+
+(defalias 'starttls-any-program-available 'starttls-available-p)
+(make-obsolete 'starttls-any-program-available 'starttls-available-p
+ "2011-08-02")
+
+(provide 'starttls)
+
+;;; starttls.el ends here
--- /dev/null
+;;; plstore.el --- secure plist store -*- lexical-binding: t -*-
+;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
+
+;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Keywords: PGP, GnuPG
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary
+
+;; Plist based data store providing search and partial encryption.
+;;
+;; Creating:
+;;
+;; ;; Open a new store associated with ~/.emacs.d/auth.plist.
+;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist")))
+;; ;; Both `:host' and `:port' are public property.
+;; (plstore-put store "foo" '(:host "foo.example.org" :port 80) nil)
+;; ;; No encryption will be needed.
+;; (plstore-save store)
+;;
+;; ;; `:user' is marked as secret.
+;; (plstore-put store "bar" '(:host "bar.example.org") '(:user "test"))
+;; ;; `:password' is marked as secret.
+;; (plstore-put store "baz" '(:host "baz.example.org") '(:password "test"))
+;; ;; Those secret properties are encrypted together.
+;; (plstore-save store)
+;;
+;; ;; Kill the buffer visiting ~/.emacs.d/auth.plist.
+;; (plstore-close store)
+;;
+;; Searching:
+;;
+;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist")))
+;;
+;; ;; As the entry "foo" associated with "foo.example.org" has no
+;; ;; secret properties, no need to decryption.
+;; (plstore-find store '(:host ("foo.example.org")))
+;;
+;; ;; As the entry "bar" associated with "bar.example.org" has a
+;; ;; secret property `:user', Emacs tries to decrypt the secret (and
+;; ;; thus you will need to input passphrase).
+;; (plstore-find store '(:host ("bar.example.org")))
+;;
+;; ;; While the entry "baz" associated with "baz.example.org" has also
+;; ;; a secret property `:password', it is encrypted together with
+;; ;; `:user' of "bar", so no need to decrypt the secret.
+;; (plstore-find store '(:host ("bar.example.org")))
+;;
+;; (plstore-close store)
+;;
+;; Editing:
+;;
+;; This file also provides `plstore-mode', a major mode for editing
+;; the PLSTORE format file. Visit a non-existing file and put the
+;; following line:
+;;
+;; (("foo" :host "foo.example.org" :secret-user "user"))
+;;
+;; where the prefixing `:secret-' means the property (without
+;; `:secret-' prefix) is marked as secret. Thus, when you save the
+;; buffer, the `:secret-user' property is encrypted as `:user'.
+;;
+;; You can toggle the view between encrypted form and the decrypted
+;; form with C-c C-c.
+
+;;; Code:
+
+(require 'epg)
+
+(defgroup plstore nil
+ "Searchable, partially encrypted, persistent plist store"
+ :version "24.1"
+ :group 'files)
+
+(defcustom plstore-select-keys 'silent
+ "Control whether or not to pop up the key selection dialog.
+
+If t, always asks user to select recipients.
+If nil, query user only when a file's default recipients are not
+known (i.e. `plstore-encrypt-to' is not locally set in the buffer
+visiting a plstore file).
+If neither t nor nil, doesn't ask user."
+ :type '(choice (const :tag "Ask always" t)
+ (const :tag "Ask when recipients are not set" nil)
+ (const :tag "Don't ask" silent))
+ :group 'plstore)
+
+(defvar plstore-encrypt-to nil
+ "*Recipient(s) used for encrypting secret entries.
+May either be a string or a list of strings. If it is nil,
+symmetric encryption will be used.")
+
+(put 'plstore-encrypt-to 'safe-local-variable
+ (lambda (val)
+ (or (stringp val)
+ (and (listp val)
+ (catch 'safe
+ (mapc (lambda (elt)
+ (unless (stringp elt)
+ (throw 'safe nil)))
+ val)
+ t)))))
+
+(put 'plstore-encrypt-to 'permanent-local t)
+
+(defvar plstore-encoded nil)
+
+(put 'plstore-encoded 'permanent-local t)
+
+(defvar plstore-cache-passphrase-for-symmetric-encryption nil)
+(defvar plstore-passphrase-alist nil)
+
+(defun plstore-passphrase-callback-function (_context _key-id plstore)
+ (if plstore-cache-passphrase-for-symmetric-encryption
+ (let* ((file (file-truename (plstore-get-file plstore)))
+ (entry (assoc file plstore-passphrase-alist))
+ passphrase)
+ (or (copy-sequence (cdr entry))
+ (progn
+ (unless entry
+ (setq entry (list file)
+ plstore-passphrase-alist
+ (cons entry
+ plstore-passphrase-alist)))
+ (setq passphrase
+ (read-passwd (format "Passphrase for PLSTORE %s: "
+ (plstore--get-buffer plstore))))
+ (setcdr entry (copy-sequence passphrase))
+ passphrase)))
+ (read-passwd (format "Passphrase for PLSTORE %s: "
+ (plstore--get-buffer plstore)))))
+
+(defun plstore-progress-callback-function (_context _what _char current total
+ handback)
+ (if (= current total)
+ (message "%s...done" handback)
+ (message "%s...%d%%" handback
+ (if (> total 0) (floor (* (/ current (float total)) 100)) 0))))
+
+(defun plstore--get-buffer (arg)
+ (aref arg 0))
+
+(defun plstore--get-alist (arg)
+ (aref arg 1))
+
+(defun plstore--get-encrypted-data (arg)
+ (aref arg 2))
+
+(defun plstore--get-secret-alist (arg)
+ (aref arg 3))
+
+(defun plstore--get-merged-alist (arg)
+ (aref arg 4))
+
+(defun plstore--set-buffer (arg buffer)
+ (aset arg 0 buffer))
+
+(defun plstore--set-alist (arg plist)
+ (aset arg 1 plist))
+
+(defun plstore--set-encrypted-data (arg encrypted-data)
+ (aset arg 2 encrypted-data))
+
+(defun plstore--set-secret-alist (arg secret-alist)
+ (aset arg 3 secret-alist))
+
+(defun plstore--set-merged-alist (arg merged-alist)
+ (aset arg 4 merged-alist))
+
+(defun plstore-get-file (arg)
+ (buffer-file-name (plstore--get-buffer arg)))
+
+(defun plstore--make (&optional buffer alist encrypted-data secret-alist
+ merged-alist)
+ (vector buffer alist encrypted-data secret-alist merged-alist))
+
+(defun plstore--init-from-buffer (plstore)
+ (goto-char (point-min))
+ (when (looking-at ";;; public entries")
+ (forward-line)
+ (plstore--set-alist plstore (read (point-marker)))
+ (forward-sexp)
+ (forward-char)
+ (when (looking-at ";;; secret entries")
+ (forward-line)
+ (plstore--set-encrypted-data plstore (read (point-marker))))
+ (plstore--merge-secret plstore)))
+
+;;;###autoload
+(defun plstore-open (file)
+ "Create a plstore instance associated with FILE."
+ (let* ((filename (file-truename file))
+ (buffer (or (find-buffer-visiting filename)
+ (generate-new-buffer (format " plstore %s" filename))))
+ (store (plstore--make buffer)))
+ (with-current-buffer buffer
+ (erase-buffer)
+ (condition-case nil
+ (insert-file-contents-literally file)
+ (error))
+ (setq buffer-file-name (file-truename file))
+ (set-buffer-modified-p nil)
+ (plstore--init-from-buffer store)
+ store)))
+
+(defun plstore-revert (plstore)
+ "Replace current data in PLSTORE with the file on disk."
+ (with-current-buffer (plstore--get-buffer plstore)
+ (revert-buffer t t)
+ (plstore--init-from-buffer plstore)))
+
+(defun plstore-close (plstore)
+ "Destroy a plstore instance PLSTORE."
+ (kill-buffer (plstore--get-buffer plstore)))
+
+(defun plstore--merge-secret (plstore)
+ (let ((alist (plstore--get-secret-alist plstore))
+ modified-alist
+ modified-plist
+ modified-entry
+ entry
+ plist
+ placeholder)
+ (plstore--set-merged-alist
+ plstore
+ (copy-tree (plstore--get-alist plstore)))
+ (setq modified-alist (plstore--get-merged-alist plstore))
+ (while alist
+ (setq entry (car alist)
+ alist (cdr alist)
+ plist (cdr entry)
+ modified-entry (assoc (car entry) modified-alist)
+ modified-plist (cdr modified-entry))
+ (while plist
+ (setq placeholder
+ (plist-member
+ modified-plist
+ (intern (concat ":secret-"
+ (substring (symbol-name (car plist)) 1)))))
+ (if placeholder
+ (setcar placeholder (car plist)))
+ (setq modified-plist
+ (plist-put modified-plist (car plist) (car (cdr plist))))
+ (setq plist (nthcdr 2 plist)))
+ (setcdr modified-entry modified-plist))))
+
+(defun plstore--decrypt (plstore)
+ (if (plstore--get-encrypted-data plstore)
+ (let ((context (epg-make-context 'OpenPGP))
+ plain)
+ (epg-context-set-passphrase-callback
+ context
+ (cons #'plstore-passphrase-callback-function
+ plstore))
+ (epg-context-set-progress-callback
+ context
+ (cons #'plstore-progress-callback-function
+ (format "Decrypting %s" (plstore-get-file plstore))))
+ (condition-case error
+ (setq plain
+ (epg-decrypt-string context
+ (plstore--get-encrypted-data plstore)))
+ (error
+ (let ((entry (assoc (plstore-get-file plstore)
+ plstore-passphrase-alist)))
+ (if entry
+ (setcdr entry nil)))
+ (signal (car error) (cdr error))))
+ (plstore--set-secret-alist plstore (car (read-from-string plain)))
+ (plstore--merge-secret plstore)
+ (plstore--set-encrypted-data plstore nil))))
+
+(defun plstore--match (entry keys skip-if-secret-found)
+ (let ((result t) key-name key-value prop-value secret-name)
+ (while keys
+ (setq key-name (car keys)
+ key-value (car (cdr keys))
+ prop-value (plist-get (cdr entry) key-name))
+ (unless (member prop-value key-value)
+ (if skip-if-secret-found
+ (progn
+ (setq secret-name
+ (intern (concat ":secret-"
+ (substring (symbol-name key-name) 1))))
+ (if (plist-member (cdr entry) secret-name)
+ (setq result 'secret)
+ (setq result nil
+ keys nil)))
+ (setq result nil
+ keys nil)))
+ (setq keys (nthcdr 2 keys)))
+ result))
+
+(defun plstore-find (plstore keys)
+ "Perform search on PLSTORE with KEYS.
+KEYS is a plist."
+ (let (entries alist entry match decrypt plist)
+ ;; First, go through the merged plist alist and collect entries
+ ;; matched with keys.
+ (setq alist (plstore--get-merged-alist plstore))
+ (while alist
+ (setq entry (car alist)
+ alist (cdr alist)
+ match (plstore--match entry keys t))
+ (if (eq match 'secret)
+ (setq decrypt t)
+ (when match
+ (setq plist (cdr entry))
+ (while plist
+ (if (string-match "\\`:secret-" (symbol-name (car plist)))
+ (setq decrypt t
+ plist nil))
+ (setq plist (nthcdr 2 plist)))
+ (setq entries (cons entry entries)))))
+ ;; Second, decrypt the encrypted plist and try again.
+ (when decrypt
+ (setq entries nil)
+ (plstore--decrypt plstore)
+ (setq alist (plstore--get-merged-alist plstore))
+ (while alist
+ (setq entry (car alist)
+ alist (cdr alist)
+ match (plstore--match entry keys nil))
+ (if match
+ (setq entries (cons entry entries)))))
+ (nreverse entries)))
+
+(defun plstore-get (plstore name)
+ "Get an entry with NAME in PLSTORE."
+ (let ((entry (assoc name (plstore--get-merged-alist plstore)))
+ plist)
+ (setq plist (cdr entry))
+ (while plist
+ (if (string-match "\\`:secret-" (symbol-name (car plist)))
+ (progn
+ (plstore--decrypt plstore)
+ (setq entry (assoc name (plstore--get-merged-alist plstore))
+ plist nil))
+ (setq plist (nthcdr 2 plist))))
+ entry))
+
+(defun plstore-put (plstore name keys secret-keys)
+ "Put an entry with NAME in PLSTORE.
+KEYS is a plist containing non-secret data.
+SECRET-KEYS is a plist containing secret data."
+ (let (entry
+ plist
+ secret-plist
+ symbol)
+ (if secret-keys
+ (plstore--decrypt plstore))
+ (while secret-keys
+ (setq symbol
+ (intern (concat ":secret-"
+ (substring (symbol-name (car secret-keys)) 1))))
+ (setq plist (plist-put plist symbol t)
+ secret-plist (plist-put secret-plist
+ (car secret-keys) (car (cdr secret-keys)))
+ secret-keys (nthcdr 2 secret-keys)))
+ (while keys
+ (setq symbol
+ (intern (concat ":secret-"
+ (substring (symbol-name (car keys)) 1))))
+ (setq plist (plist-put plist (car keys) (car (cdr keys)))
+ keys (nthcdr 2 keys)))
+ (setq entry (assoc name (plstore--get-alist plstore)))
+ (if entry
+ (setcdr entry plist)
+ (plstore--set-alist
+ plstore
+ (cons (cons name plist) (plstore--get-alist plstore))))
+ (when secret-plist
+ (setq entry (assoc name (plstore--get-secret-alist plstore)))
+ (if entry
+ (setcdr entry secret-plist)
+ (plstore--set-secret-alist
+ plstore
+ (cons (cons name secret-plist) (plstore--get-secret-alist plstore)))))
+ (plstore--merge-secret plstore)))
+
+(defun plstore-delete (plstore name)
+ "Delete an entry with NAME from PLSTORE."
+ (let ((entry (assoc name (plstore--get-alist plstore))))
+ (if entry
+ (plstore--set-alist
+ plstore
+ (delq entry (plstore--get-alist plstore))))
+ (setq entry (assoc name (plstore--get-secret-alist plstore)))
+ (if entry
+ (plstore--set-secret-alist
+ plstore
+ (delq entry (plstore--get-secret-alist plstore))))
+ (setq entry (assoc name (plstore--get-merged-alist plstore)))
+ (if entry
+ (plstore--set-merged-alist
+ plstore
+ (delq entry (plstore--get-merged-alist plstore))))))
+
+(defvar pp-escape-newlines)
+(defun plstore--insert-buffer (plstore)
+ (insert ";;; public entries -*- mode: plstore -*- \n"
+ (pp-to-string (plstore--get-alist plstore)))
+ (if (plstore--get-secret-alist plstore)
+ (let ((context (epg-make-context 'OpenPGP))
+ (pp-escape-newlines nil)
+ (recipients
+ (cond
+ ((listp plstore-encrypt-to) plstore-encrypt-to)
+ ((stringp plstore-encrypt-to) (list plstore-encrypt-to))))
+ cipher)
+ (setf (epg-context-armor context) t)
+ (epg-context-set-passphrase-callback
+ context
+ (cons #'plstore-passphrase-callback-function
+ plstore))
+ (setq cipher (epg-encrypt-string
+ context
+ (pp-to-string
+ (plstore--get-secret-alist plstore))
+ (if (or (eq plstore-select-keys t)
+ (and (null plstore-select-keys)
+ (not (local-variable-p 'plstore-encrypt-to
+ (current-buffer)))))
+ (epa-select-keys
+ context
+ "Select recipients for encryption.
+If no one is selected, symmetric encryption will be performed. "
+ recipients)
+ (if plstore-encrypt-to
+ (epg-list-keys context recipients)))))
+ (goto-char (point-max))
+ (insert ";;; secret entries\n" (pp-to-string cipher)))))
+
+(defun plstore-save (plstore)
+ "Save the contents of PLSTORE associated with a FILE."
+ (with-current-buffer (plstore--get-buffer plstore)
+ (erase-buffer)
+ (plstore--insert-buffer plstore)
+ (save-buffer)))
+
+(defun plstore--encode (plstore)
+ (plstore--decrypt plstore)
+ (let ((merged-alist (plstore--get-merged-alist plstore)))
+ (concat "("
+ (mapconcat
+ (lambda (entry)
+ (setq entry (copy-sequence entry))
+ (let ((merged-plist (cdr (assoc (car entry) merged-alist)))
+ (plist (cdr entry)))
+ (while plist
+ (if (string-match "\\`:secret-" (symbol-name (car plist)))
+ (setcar (cdr plist)
+ (plist-get
+ merged-plist
+ (intern (concat ":"
+ (substring (symbol-name
+ (car plist))
+ (match-end 0)))))))
+ (setq plist (nthcdr 2 plist)))
+ (prin1-to-string entry)))
+ (plstore--get-alist plstore)
+ "\n")
+ ")")))
+
+(defun plstore--decode (string)
+ (let* ((alist (car (read-from-string string)))
+ (pointer alist)
+ secret-alist
+ plist
+ entry)
+ (while pointer
+ (unless (stringp (car (car pointer)))
+ (error "Invalid PLSTORE format %s" string))
+ (setq plist (cdr (car pointer)))
+ (while plist
+ (when (string-match "\\`:secret-" (symbol-name (car plist)))
+ (setq entry (assoc (car (car pointer)) secret-alist))
+ (unless entry
+ (setq entry (list (car (car pointer)))
+ secret-alist (cons entry secret-alist)))
+ (setcdr entry (plist-put (cdr entry)
+ (intern (concat ":"
+ (substring (symbol-name
+ (car plist))
+ (match-end 0))))
+ (car (cdr plist))))
+ (setcar (cdr plist) t))
+ (setq plist (nthcdr 2 plist)))
+ (setq pointer (cdr pointer)))
+ (plstore--make nil alist nil secret-alist)))
+
+(defun plstore--write-contents-functions ()
+ (when plstore-encoded
+ (let ((store (plstore--decode (buffer-string)))
+ (file (buffer-file-name)))
+ (unwind-protect
+ (progn
+ (set-visited-file-name nil)
+ (with-temp-buffer
+ (plstore--insert-buffer store)
+ (write-region (buffer-string) nil file)))
+ (set-visited-file-name file)
+ (set-buffer-modified-p nil))
+ t)))
+
+(defun plstore-mode-original ()
+ "Show the original form of the this buffer."
+ (interactive)
+ (when plstore-encoded
+ (if (and (buffer-modified-p)
+ (y-or-n-p "Save buffer before reading the original form? "))
+ (save-buffer))
+ (erase-buffer)
+ (insert-file-contents-literally (buffer-file-name))
+ (set-buffer-modified-p nil)
+ (setq plstore-encoded nil)))
+
+(defun plstore-mode-decoded ()
+ "Show the decoded form of the this buffer."
+ (interactive)
+ (unless plstore-encoded
+ (if (and (buffer-modified-p)
+ (y-or-n-p "Save buffer before decoding? "))
+ (save-buffer))
+ (let ((store (plstore--make (current-buffer))))
+ (plstore--init-from-buffer store)
+ (erase-buffer)
+ (insert
+ (substitute-command-keys "\
+;;; You are looking at the decoded form of the PLSTORE file.\n\
+;;; To see the original form content, do \\[plstore-mode-toggle-display]\n\n"))
+ (insert (plstore--encode store))
+ (set-buffer-modified-p nil)
+ (setq plstore-encoded t))))
+
+(defun plstore-mode-toggle-display ()
+ "Toggle the display mode of PLSTORE between the original and decoded forms."
+ (interactive)
+ (if plstore-encoded
+ (plstore-mode-original)
+ (plstore-mode-decoded)))
+
+;;;###autoload
+(define-derived-mode plstore-mode emacs-lisp-mode "PLSTORE"
+ "Major mode for editing PLSTORE files."
+ (make-local-variable 'plstore-encoded)
+ (add-hook 'write-contents-functions #'plstore--write-contents-functions)
+ (define-key plstore-mode-map "\C-c\C-c" #'plstore-mode-toggle-display)
+ ;; to create a new file with plstore-mode, mark it as already decoded
+ (if (called-interactively-p 'any)
+ (setq plstore-encoded t)
+ (plstore-mode-decoded)))
+
+(provide 'plstore)
+
+;;; plstore.el ends here
--- /dev/null
+;;; registry.el --- Track and remember data items by various fields
+
+;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
+
+;; Author: Teodor Zlatanov <tzz@lifelogs.com>
+;; Keywords: data
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library provides a general-purpose EIEIO-based registry
+;; database with persistence, initialized with these fields:
+
+;; version: a float
+
+;; max-size: an integer, default most-positive-fixnum
+
+;; prune-factor: a float between 0 and 1, default 0.1
+
+;; precious: a list of symbols
+
+;; tracked: a list of symbols
+
+;; tracker: a hashtable tuned for 100 symbols to track (you should
+;; only access this with the :lookup2-function and the
+;; :lookup2+-function)
+
+;; data: a hashtable with default size 10K and resize threshold 2.0
+;; (this reflects the expected usage so override it if you know better)
+
+;; ...plus methods to do all the work: `registry-search',
+;; `registry-lookup', `registry-lookup-secondary',
+;; `registry-lookup-secondary-value', `registry-insert',
+;; `registry-delete', `registry-prune', `registry-size' which see
+
+;; and with the following properties:
+
+;; Every piece of data has a unique ID and some general-purpose fields
+;; (F1=D1, F2=D2, F3=(a b c)...) expressed as an alist, e.g.
+
+;; ((F1 D1) (F2 D2) (F3 a b c))
+
+;; Note that whether a field has one or many pieces of data, the data
+;; is always a list of values.
+
+;; The user decides which fields are "precious", F2 for example. When
+;; the registry is pruned, any entries without the F2 field will be
+;; removed until the size is :max-size * :prune-factor _less_ than the
+;; maximum database size. No entries with the F2 field will be removed
+;; at PRUNE TIME, which means it may not be possible to prune back all
+;; the way to the target size.
+
+;; When an entry is inserted, the registry will reject new entries if
+;; they bring it over the :max-size limit, even if they have the F2
+;; field.
+
+;; The user decides which fields are "tracked", F1 for example. Any
+;; new entry is then indexed by all the tracked fields so it can be
+;; quickly looked up that way. The data is always a list (see example
+;; above) and each list element is indexed.
+
+;; Precious and tracked field names must be symbols. All other
+;; fields can be any other Emacs Lisp types.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+(require 'eieio)
+(require 'eieio-base)
+
+;; The version number needs to be kept outside of the class definition
+;; itself. The persistent-save process does *not* write to file any
+;; slot values that are equal to the default :initform value. If a
+;; database object is at the most recent version, therefore, its
+;; version number will not be written to file. That makes it
+;; difficult to know when a database needs to be upgraded.
+(defvar registry-db-version 0.2
+ "The current version of the registry format.")
+
+(defclass registry-db (eieio-persistent)
+ ((version :initarg :version
+ :initform nil
+ :type (or null float)
+ :documentation "The registry version.")
+ (max-size :initarg :max-size
+ ;; EIEIO's :initform is not 100% compatible with CLOS in
+ ;; that if the form is an atom, it assumes it's constant
+ ;; value rather than an expression, so in order to get the value
+ ;; of `most-positive-fixnum', we need to use an
+ ;; expression that's not just a symbol.
+ :initform (symbol-value 'most-positive-fixnum)
+ :type integer
+ :custom integer
+ :documentation "The maximum number of registry entries.")
+ (prune-factor
+ :initarg :prune-factor
+ :initform 0.1
+ :type float
+ :custom float
+ :documentation "Prune to (:max-size * :prune-factor) less
+ than the :max-size limit. Should be a float between 0 and 1.")
+ (tracked :initarg :tracked
+ :initform nil
+ :type t
+ :documentation "The tracked (indexed) fields, a list of symbols.")
+ (precious :initarg :precious
+ :initform nil
+ :type t
+ :documentation "The precious fields, a list of symbols.")
+ (tracker :initarg :tracker
+ :type hash-table
+ :documentation "The field tracking hashtable.")
+ (data :initarg :data
+ :type hash-table
+ :documentation "The data hashtable.")))
+
+(cl-defmethod initialize-instance :before ((this registry-db) slots)
+ "Check whether a registry object needs to be upgraded."
+ ;; Hardcoded upgrade routines. Version 0.1 to 0.2 requires the
+ ;; :max-soft slot to disappear, and the :max-hard slot to be renamed
+ ;; :max-size.
+ (let ((current-version
+ (and (plist-member slots :version)
+ (plist-get slots :version))))
+ (when (or (null current-version)
+ (eql current-version 0.1))
+ (setq slots
+ (plist-put slots :max-size (plist-get slots :max-hard)))
+ (setq slots
+ (plist-put slots :version registry-db-version))
+ (cl-remf slots :max-hard)
+ (cl-remf slots :max-soft))))
+
+(cl-defmethod initialize-instance :after ((this registry-db) slots)
+ "Set value of data slot of THIS after initialization."
+ (with-slots (data tracker) this
+ (unless (member :data slots)
+ (setq data
+ (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal)))
+ (unless (member :tracker slots)
+ (setq tracker (make-hash-table :size 100 :rehash-size 2.0)))))
+
+(cl-defmethod registry-lookup ((db registry-db) keys)
+ "Search for KEYS in the registry-db THIS.
+Returns an alist of the key followed by the entry in a list, not a cons cell."
+ (let ((data (oref db data)))
+ (delq nil
+ (mapcar
+ (lambda (k)
+ (when (gethash k data)
+ (list k (gethash k data))))
+ keys))))
+
+(cl-defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys)
+ "Search for KEYS in the registry-db THIS.
+Returns an alist of the key followed by the entry in a list, not a cons cell."
+ (let ((data (oref db data)))
+ (delq nil
+ (loop for key in keys
+ when (gethash key data)
+ collect (list key (gethash key data))))))
+
+(cl-defmethod registry-lookup-secondary ((db registry-db) tracksym
+ &optional create)
+ "Search for TRACKSYM in the registry-db THIS.
+When CREATE is not nil, create the secondary index hashtable if needed."
+ (let ((h (gethash tracksym (oref db tracker))))
+ (if h
+ h
+ (when create
+ (puthash tracksym
+ (make-hash-table :size 800 :rehash-size 2.0 :test 'equal)
+ (oref db tracker))
+ (gethash tracksym (oref db tracker))))))
+
+(cl-defmethod registry-lookup-secondary-value ((db registry-db) tracksym val
+ &optional set)
+ "Search for TRACKSYM with value VAL in the registry-db THIS.
+When SET is not nil, set it for VAL (use t for an empty list)."
+ ;; either we're asked for creation or there should be an existing index
+ (when (or set (registry-lookup-secondary db tracksym))
+ ;; set the entry if requested,
+ (when set
+ (puthash val (if (eq t set) '() set)
+ (registry-lookup-secondary db tracksym t)))
+ (gethash val (registry-lookup-secondary db tracksym))))
+
+(defun registry--match (mode entry check-list)
+ ;; for all members
+ (when check-list
+ (let ((key (nth 0 (nth 0 check-list)))
+ (vals (cdr-safe (nth 0 check-list)))
+ found)
+ (while (and key vals (not found))
+ (setq found (case mode
+ (:member
+ (member (car-safe vals) (cdr-safe (assoc key entry))))
+ (:regex
+ (string-match (car vals)
+ (mapconcat
+ 'prin1-to-string
+ (cdr-safe (assoc key entry))
+ "\0"))))
+ vals (cdr-safe vals)))
+ (or found
+ (registry--match mode entry (cdr-safe check-list))))))
+
+(cl-defmethod registry-search ((db registry-db) &rest spec)
+ "Search for SPEC across the registry-db THIS.
+For example calling with `:member \\='(a 1 2)' will match entry \((a 3 1)).
+Calling with `:all t' (any non-nil value) will match all.
+Calling with `:regex \\='(a \"h.llo\")' will match entry \(a \"hullo\" \"bye\").
+The test order is to check :all first, then :member, then :regex."
+ (when db
+ (let ((all (plist-get spec :all))
+ (member (plist-get spec :member))
+ (regex (plist-get spec :regex)))
+ (loop for k being the hash-keys of (oref db data)
+ using (hash-values v)
+ when (or
+ ;; :all non-nil returns all
+ all
+ ;; member matching
+ (and member (registry--match :member v member))
+ ;; regex matching
+ (and regex (registry--match :regex v regex)))
+ collect k))))
+
+(cl-defmethod registry-delete ((db registry-db) keys assert &rest spec)
+ "Delete KEYS from the registry-db THIS.
+If KEYS is nil, use SPEC to do a search.
+Updates the secondary ('tracked') indices as well.
+With assert non-nil, errors out if the key does not exist already."
+ (let* ((data (oref db data))
+ (keys (or keys
+ (apply 'registry-search db spec)))
+ (tracked (oref db tracked)))
+
+ (dolist (key keys)
+ (let ((entry (gethash key data)))
+ (when assert
+ (assert entry nil
+ "Key %s does not exist in database" key))
+ ;; clean entry from the secondary indices
+ (dolist (tr tracked)
+ ;; is this tracked symbol indexed?
+ (when (registry-lookup-secondary db tr)
+ ;; for every value in the entry under that key...
+ (dolist (val (cdr-safe (assq tr entry)))
+ (let* ((value-keys (registry-lookup-secondary-value
+ db tr val)))
+ (when (member key value-keys)
+ ;; override the previous value
+ (registry-lookup-secondary-value
+ db tr val
+ ;; with the indexed keys MINUS the current key
+ ;; (we pass t when the list is empty)
+ (or (delete key value-keys) t)))))))
+ (remhash key data)))
+ keys))
+
+(cl-defmethod registry-size ((db registry-db))
+ "Returns the size of the registry-db object THIS.
+This is the key count of the `data' slot."
+ (hash-table-count (oref db data)))
+
+(cl-defmethod registry-full ((db registry-db))
+ "Checks if registry-db THIS is full."
+ (>= (registry-size db)
+ (oref db max-size)))
+
+(cl-defmethod registry-insert ((db registry-db) key entry)
+ "Insert ENTRY under KEY into the registry-db THIS.
+Updates the secondary ('tracked') indices as well.
+Errors out if the key exists already."
+
+ (assert (not (gethash key (oref db data))) nil
+ "Key already exists in database")
+
+ (assert (not (registry-full db))
+ nil
+ "registry max-size limit reached")
+
+ ;; store the entry
+ (puthash key entry (oref db data))
+
+ ;; store the secondary indices
+ (dolist (tr (oref db tracked))
+ ;; for every value in the entry under that key...
+ (dolist (val (cdr-safe (assq tr entry)))
+ (let* ((value-keys (registry-lookup-secondary-value db tr val)))
+ (pushnew key value-keys :test 'equal)
+ (registry-lookup-secondary-value db tr val value-keys))))
+ entry)
+
+(cl-defmethod registry-reindex ((db registry-db))
+ "Rebuild the secondary indices of registry-db THIS."
+ (let ((count 0)
+ (expected (* (length (oref db tracked)) (registry-size db))))
+ (dolist (tr (oref db tracked))
+ (let (values)
+ (maphash
+ (lambda (key v)
+ (incf count)
+ (when (and (< 0 expected)
+ (= 0 (mod count 1000)))
+ (message "reindexing: %d of %d (%.2f%%)"
+ count expected (/ (* 100.0 count) expected)))
+ (dolist (val (cdr-safe (assq tr v)))
+ (let* ((value-keys (registry-lookup-secondary-value db tr val)))
+ (push key value-keys)
+ (registry-lookup-secondary-value db tr val value-keys))))
+ (oref db data))))))
+
+(cl-defmethod registry-prune ((db registry-db) &optional sortfunc)
+ "Prunes the registry-db object DB.
+
+Attempts to prune the number of entries down to \(*
+:max-size :prune-factor) less than the max-size limit, so
+pruning doesn't need to happen on every save. Removes only
+entries without the :precious keys, so it may not be possible to
+reach the target limit.
+
+Entries to be pruned are first sorted using SORTFUNC. Entries
+from the front of the list are deleted first.
+
+Returns the number of deleted entries."
+ (let ((size (registry-size db))
+ (target-size
+ (floor (- (oref db max-size)
+ (* (oref db max-size)
+ (oref db prune-factor)))))
+ candidates)
+ (if (registry-full db)
+ (progn
+ (setq candidates
+ (registry-collect-prune-candidates
+ db (- size target-size) sortfunc))
+ (length (registry-delete db candidates nil)))
+ 0)))
+
+(cl-defmethod registry-collect-prune-candidates ((db registry-db)
+ limit sortfunc)
+ "Collects pruning candidates from the registry-db object DB.
+
+Proposes only entries without the :precious keys, and attempts to
+return LIMIT such candidates. If SORTFUNC is provided, sort
+entries first and return candidates from beginning of list."
+ (let* ((precious (oref db precious))
+ (precious-p (lambda (entry-key)
+ (cdr (memq (car entry-key) precious))))
+ (data (oref db data))
+ (candidates (cl-loop for k being the hash-keys of data
+ using (hash-values v)
+ when (notany precious-p v)
+ collect (cons k v))))
+ ;; We want the full entries for sorting, but should only return a
+ ;; list of entry keys.
+ (when sortfunc
+ (setq candidates (sort candidates sortfunc)))
+ (cl-subseq (mapcar #'car candidates) 0 (min limit (length candidates)))))
+
+(provide 'registry)
+;;; registry.el ends here
--- /dev/null
+;;; rtree.el --- functions for manipulating range trees
+
+;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; A "range tree" is a binary tree that stores ranges. They are
+;; similar to interval trees, but do not allow overlapping intervals.
+
+;; A range is an ordered list of number intervals, like this:
+
+;; ((10 . 25) 56 78 (98 . 201))
+
+;; Common operations, like lookup, deletion and insertion are O(n) in
+;; a range, but an rtree is O(log n) in all these operations.
+;; Transformation between a range and an rtree is O(n).
+
+;; The rtrees are quite simple. The structure of each node is
+
+;; (cons (cons low high) (cons left right))
+
+;; That is, they are three cons cells, where the car of the top cell
+;; is the actual range, and the cdr has the left and right child. The
+;; rtrees aren't automatically balanced, but are balanced when
+;; created, and can be rebalanced when deemed necessary.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+(defmacro rtree-make-node ()
+ `(list (list nil) nil))
+
+(defmacro rtree-set-left (node left)
+ `(setcar (cdr ,node) ,left))
+
+(defmacro rtree-set-right (node right)
+ `(setcdr (cdr ,node) ,right))
+
+(defmacro rtree-set-range (node range)
+ `(setcar ,node ,range))
+
+(defmacro rtree-low (node)
+ `(caar ,node))
+
+(defmacro rtree-high (node)
+ `(cdar ,node))
+
+(defmacro rtree-set-low (node number)
+ `(setcar (car ,node) ,number))
+
+(defmacro rtree-set-high (node number)
+ `(setcdr (car ,node) ,number))
+
+(defmacro rtree-left (node)
+ `(cadr ,node))
+
+(defmacro rtree-right (node)
+ `(cddr ,node))
+
+(defmacro rtree-range (node)
+ `(car ,node))
+
+(defsubst rtree-normalize-range (range)
+ (when (numberp range)
+ (setq range (cons range range)))
+ range)
+
+(define-obsolete-function-alias 'rtree-normalise-range
+ 'rtree-normalize-range "25.1")
+
+(defun rtree-make (range)
+ "Make an rtree from RANGE."
+ ;; Normalize the range.
+ (unless (listp (cdr-safe range))
+ (setq range (list range)))
+ (rtree-make-1 (cons nil range) (length range)))
+
+(defun rtree-make-1 (range length)
+ (let ((mid (/ length 2))
+ (node (rtree-make-node)))
+ (when (> mid 0)
+ (rtree-set-left node (rtree-make-1 range mid)))
+ (rtree-set-range node (rtree-normalize-range (cadr range)))
+ (setcdr range (cddr range))
+ (when (> (- length mid 1) 0)
+ (rtree-set-right node (rtree-make-1 range (- length mid 1))))
+ node))
+
+(defun rtree-memq (tree number)
+ "Return non-nil if NUMBER is present in TREE."
+ (while (and tree
+ (not (and (>= number (rtree-low tree))
+ (<= number (rtree-high tree)))))
+ (setq tree
+ (if (< number (rtree-low tree))
+ (rtree-left tree)
+ (rtree-right tree))))
+ tree)
+
+(defun rtree-add (tree number)
+ "Add NUMBER to TREE."
+ (while tree
+ (cond
+ ;; It's already present, so we don't have to do anything.
+ ((and (>= number (rtree-low tree))
+ (<= number (rtree-high tree)))
+ (setq tree nil))
+ ((< number (rtree-low tree))
+ (cond
+ ;; Extend the low range.
+ ((= number (1- (rtree-low tree)))
+ (rtree-set-low tree number)
+ ;; Check whether we need to merge this node with the child.
+ (when (and (rtree-left tree)
+ (= (rtree-high (rtree-left tree)) (1- number)))
+ ;; Extend the range to the low from the child.
+ (rtree-set-low tree (rtree-low (rtree-left tree)))
+ ;; The child can't have a right child, so just transplant the
+ ;; child's left tree to our left tree.
+ (rtree-set-left tree (rtree-left (rtree-left tree))))
+ (setq tree nil))
+ ;; Descend further to the left.
+ ((rtree-left tree)
+ (setq tree (rtree-left tree)))
+ ;; Add a new node.
+ (t
+ (let ((new-node (rtree-make-node)))
+ (rtree-set-low new-node number)
+ (rtree-set-high new-node number)
+ (rtree-set-left tree new-node)
+ (setq tree nil)))))
+ (t
+ (cond
+ ;; Extend the high range.
+ ((= number (1+ (rtree-high tree)))
+ (rtree-set-high tree number)
+ ;; Check whether we need to merge this node with the child.
+ (when (and (rtree-right tree)
+ (= (rtree-low (rtree-right tree)) (1+ number)))
+ ;; Extend the range to the high from the child.
+ (rtree-set-high tree (rtree-high (rtree-right tree)))
+ ;; The child can't have a left child, so just transplant the
+ ;; child's left right to our right tree.
+ (rtree-set-right tree (rtree-right (rtree-right tree))))
+ (setq tree nil))
+ ;; Descend further to the right.
+ ((rtree-right tree)
+ (setq tree (rtree-right tree)))
+ ;; Add a new node.
+ (t
+ (let ((new-node (rtree-make-node)))
+ (rtree-set-low new-node number)
+ (rtree-set-high new-node number)
+ (rtree-set-right tree new-node)
+ (setq tree nil))))))))
+
+(defun rtree-delq (tree number)
+ "Remove NUMBER from TREE destructively. Returns the new tree."
+ (let ((result tree)
+ prev)
+ (while tree
+ (cond
+ ((< number (rtree-low tree))
+ (setq prev tree
+ tree (rtree-left tree)))
+ ((> number (rtree-high tree))
+ (setq prev tree
+ tree (rtree-right tree)))
+ ;; The number is in this node.
+ (t
+ (cond
+ ;; The only entry; delete the node.
+ ((= (rtree-low tree) (rtree-high tree))
+ (cond
+ ;; Two children. Replace with successor value.
+ ((and (rtree-left tree) (rtree-right tree))
+ (let ((parent tree)
+ (successor (rtree-right tree)))
+ (while (rtree-left successor)
+ (setq parent successor
+ successor (rtree-left successor)))
+ ;; We now have the leftmost child of our right child.
+ (rtree-set-range tree (rtree-range successor))
+ ;; Transplant the child (if any) to the parent.
+ (rtree-set-left parent (rtree-right successor))))
+ (t
+ (let ((rest (or (rtree-left tree)
+ (rtree-right tree))))
+ ;; One or zero children. Remove the node.
+ (cond
+ ((null prev)
+ (setq result rest))
+ ((eq (rtree-left prev) tree)
+ (rtree-set-left prev rest))
+ (t
+ (rtree-set-right prev rest)))))))
+ ;; The lowest in the range; just adjust.
+ ((= number (rtree-low tree))
+ (rtree-set-low tree (1+ number)))
+ ;; The highest in the range; just adjust.
+ ((= number (rtree-high tree))
+ (rtree-set-high tree (1- number)))
+ ;; We have to split this range.
+ (t
+ (let ((new-node (rtree-make-node)))
+ (rtree-set-low new-node (rtree-low tree))
+ (rtree-set-high new-node (1- number))
+ (rtree-set-low tree (1+ number))
+ (cond
+ ;; Two children; insert the new node as the predecessor
+ ;; node.
+ ((and (rtree-left tree) (rtree-right tree))
+ (let ((predecessor (rtree-left tree)))
+ (while (rtree-right predecessor)
+ (setq predecessor (rtree-right predecessor)))
+ (rtree-set-right predecessor new-node)))
+ ((rtree-left tree)
+ (rtree-set-right new-node tree)
+ (rtree-set-left new-node (rtree-left tree))
+ (rtree-set-left tree nil)
+ (cond
+ ((null prev)
+ (setq result new-node))
+ ((eq (rtree-left prev) tree)
+ (rtree-set-left prev new-node))
+ (t
+ (rtree-set-right prev new-node))))
+ (t
+ (rtree-set-left tree new-node))))))
+ (setq tree nil))))
+ result))
+
+(defun rtree-extract (tree)
+ "Convert TREE to range form."
+ (let (stack result)
+ (while (or stack
+ tree)
+ (if tree
+ (progn
+ (push tree stack)
+ (setq tree (rtree-right tree)))
+ (setq tree (pop stack))
+ (push (if (= (rtree-low tree)
+ (rtree-high tree))
+ (rtree-low tree)
+ (rtree-range tree))
+ result)
+ (setq tree (rtree-left tree))))
+ result))
+
+(defun rtree-length (tree)
+ "Return the number of numbers stored in TREE."
+ (if (null tree)
+ 0
+ (+ (rtree-length (rtree-left tree))
+ (1+ (- (rtree-high tree)
+ (rtree-low tree)))
+ (rtree-length (rtree-right tree)))))
+
+(provide 'rtree)
+
+;;; rtree.el ends here
--- /dev/null
+;;; auth-source-tests.el --- Tests for auth-source.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
+
+;; Author: Damien Cassou <damien@cassou.me>,
+;; Nicolas Petton <nicolas@petton.fr>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(require '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
+++ /dev/null
-;;; auth-source-tests.el --- Tests for auth-source.el -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
-
-;; Author: Damien Cassou <damien@cassou.me>,
-;; Nicolas Petton <nicolas@petton.fr>
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;
-
-;;; Code:
-
-(require '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
projects / emacs.git / commitdiff