├── .gitignore ├── README.org ├── dir ├── ebdb-com.el ├── ebdb-complete.el ├── ebdb-counsel.el ├── ebdb-format.el ├── ebdb-gnus.el ├── ebdb-helm.el ├── ebdb-html.el ├── ebdb-i18n-basic.el ├── ebdb-i18n-test.el ├── ebdb-i18n.el ├── ebdb-ispell.el ├── ebdb-latex.el ├── ebdb-message.el ├── ebdb-mhe.el ├── ebdb-migrate.el ├── ebdb-mu4e.el ├── ebdb-mua.el ├── ebdb-notmuch.el ├── ebdb-org.el ├── ebdb-pgp.el ├── ebdb-rmail.el ├── ebdb-roam.el ├── ebdb-snarf.el ├── ebdb-test.el ├── ebdb-vcard.el ├── ebdb-vm.el ├── ebdb-wl.el ├── ebdb.el ├── ebdb.info ├── ebdb.org └── ebdb.texi /.gitignore: -------------------------------------------------------------------------------- 1 | *.elc 2 | ebdb-autoloads.el 3 | ebdb-pkg.el 4 | ChangeLog 5 | Makefile 6 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | 2 | * EBDB 3 | EBDB is a contact management/addressbook package for Emacs. 4 | 5 | It's a re-write of the Insidious Big Brother Database ([[https://savannah.nongnu.org/projects/bbdb/][BBDB]]) using 6 | Emacs Lisp's (relatively new) object oriented libraries. The "E" is 7 | vaguely meant to signify "[[https://ericabrahamsen.net/tech/2016/feb/bbdb-eieio-object-oriented-elisp.html][EIEIO]]". 8 | 9 | It lives in both the ELPA repositories, and on Github at 10 | https://github.com/girzel/ebdb. It's best to [[https://www.emacswiki.org/emacs/InstallingPackages][install from ELPA]], but 11 | bug reports and pull requests on Github will also be attended to. 12 | Alternately, run ~report-emacs-bugs~, include "EBDB" somewhere in the 13 | subject line, and cc the maintainer. 14 | 15 | More EBDB-related packages are available in ELPA. 16 | 17 | See the [[https://github.com/girzel/ebdb/blob/master/ebdb.org#ebdb-manual][manual]] for usage details. 18 | -------------------------------------------------------------------------------- /dir: -------------------------------------------------------------------------------- 1 | This is the file .../info/dir, which contains the 2 | topmost node of the Info hierarchy, called (dir)Top. 3 | The first time you invoke Info you start off looking at this node. 4 |  5 | File: dir, Node: Top This is the top of the INFO tree 6 | 7 | This (the Directory node) gives a menu of major topics. 8 | Typing "q" exits, "H" lists all Info commands, "d" returns here, 9 | "h" gives a primer for first-timers, 10 | "mEmacs" visits the Emacs manual, etc. 11 | 12 | In Emacs, you can click mouse button 2 on a menu item or cross reference 13 | to select it. 14 | 15 | * Menu: 16 | 17 | Emacs 18 | * EBDB: (ebdb). Contact management package. 19 | -------------------------------------------------------------------------------- /ebdb-complete.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-complete.el --- Completion functionality for EBDB -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2017-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Feng Shu 6 | ;; Maintainer: Eric Abrahamsen 7 | ;; Keywords: mail, convenience 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;;; Commentary: 23 | 24 | ;; This file contains the function `ebdb-complete' which pops 25 | ;; up a full EBDB window as email-chooser, typically in mail 26 | ;; composition buffers. 27 | 28 | ;; The simplest installation method is to call: 29 | 30 | ;; (ebdb-complete-enable) 31 | 32 | ;; This will bind TAB in message-mode and mail-mode to 33 | ;; `ebdb-complete', which will pop up a full EBDB buffer as a contact 34 | ;; chooser. 35 | ;; 36 | ;; This can also be done manually, e.g.: 37 | ;; 38 | ;; (define-key ebdb-mode-map "q" 'ebdb-complete-bury-ebdb-buffer) 39 | ;; (define-key ebdb-mode-map "\C-c\C-c" 'ebdb-complete-push-mail) 40 | ;; (define-key ebdb-mode-map (kbd "RET") 'ebdb-complete-push-mail-and-bury-ebdb-buffer) 41 | ;; (define-key message-mode-map "\t" 'ebdb-complete-message-tab) 42 | ;; (define-key mail-mode-map "\t" 'ebdb-complete-message-tab) 43 | 44 | ;;; Code: 45 | (require 'ebdb-com) 46 | (require 'message) 47 | (require 'sendmail) 48 | 49 | ;;;###autoload 50 | 51 | (defvar ebdb-complete-info (make-hash-table) 52 | "A hashtable recording buffer, buffer-window and window-point") 53 | 54 | (defun ebdb-complete-push-mail (records &optional _ arg) 55 | "Push email-address(es) of `records' to buffer in `ebdb-complete-info'." 56 | (interactive (list (ebdb-do-records) nil 57 | (or (consp current-prefix-arg) 58 | current-prefix-arg))) 59 | (setq records (ebdb-record-list records)) 60 | (if (not records) 61 | (message "No records") 62 | (let ((to (mapconcat 63 | (lambda (r) 64 | (ebdb-dwim-mail r (ebdb-record-one-mail r arg))) 65 | records ", ")) 66 | (buffer (gethash :buffer ebdb-complete-info))) 67 | (when buffer 68 | (with-current-buffer buffer 69 | (when (not (string= "" to)) 70 | (when (save-excursion 71 | (let* ((end (point)) 72 | (begin (line-beginning-position)) 73 | (string (buffer-substring-no-properties 74 | begin end))) 75 | (and (string-match-p "@" string) 76 | (not (string-match-p ", *$" string))))) 77 | (insert ", ")) 78 | (insert to) 79 | (message "%s, will be push to buffer: \"%s\"" to buffer)) 80 | (puthash :window-point (point) ebdb-complete-info)))))) 81 | 82 | (define-obsolete-function-alias 83 | 'ebdb-complete-quit-window 84 | #'ebdb-complete-bury-ebdb-buffer "1.0.0") 85 | 86 | (defun ebdb-complete-bury-ebdb-buffer () 87 | "Hide EBDB buffer and switch to message buffer. 88 | Before switch, this command will do some clean jobs." 89 | (interactive) 90 | ;; Hide header line in EBDB window. 91 | (with-current-buffer (ebdb-make-buffer-name) 92 | (setq header-line-format nil)) 93 | ;; Hide ebdb buffer and update window point in Message window. 94 | (let ((buffer (gethash :buffer ebdb-complete-info)) 95 | (window (gethash :window ebdb-complete-info)) 96 | (window-point (gethash :window-point ebdb-complete-info))) 97 | (when (and (buffer-live-p buffer) 98 | (numberp window-point)) 99 | (switch-to-buffer buffer) 100 | (set-window-point 101 | (if (window-live-p window) 102 | window 103 | (get-buffer-window)) 104 | window-point))) 105 | ;; Clean hashtable `ebdb-complete-info' 106 | (setq ebdb-complete-info (clrhash ebdb-complete-info))) 107 | 108 | (define-obsolete-function-alias 109 | 'ebdb-complete-push-mail-and-quit-window 110 | #'ebdb-complete-push-mail-and-bury-ebdb-buffer "1.0.0") 111 | 112 | (defun ebdb-complete-push-mail-and-bury-ebdb-buffer () 113 | "Push email-address to Message window and hide EBDB buffer." 114 | (interactive) 115 | (if (gethash :buffer ebdb-complete-info) 116 | (progn (call-interactively 'ebdb-complete-push-mail) 117 | (ebdb-complete-bury-ebdb-buffer)) 118 | (message "Invalid push buffer, Do nothing!!"))) 119 | 120 | (defun ebdb-complete-grab-word () 121 | "Grab word at point, which used to build search string." 122 | (buffer-substring 123 | (point) 124 | (save-excursion 125 | (skip-syntax-backward "w_") 126 | (point)))) 127 | 128 | ;;;###autoload 129 | (defun ebdb-complete () 130 | "Open EBDB window as an email-address selector, 131 | if Word at point is found, EBDB will search this word 132 | and show search results in EBDB window. This command 133 | only useful in Message buffer." 134 | (interactive) 135 | (let ((buffer (current-buffer)) 136 | prefix-string) 137 | ;; Update `ebdb-complete-info' 138 | (if (or (derived-mode-p 'message-mode) 139 | (derived-mode-p 'mail-mode)) 140 | (progn 141 | (setq prefix-string (ebdb-complete-grab-word)) 142 | (puthash :buffer buffer ebdb-complete-info) 143 | (puthash :window (get-buffer-window) ebdb-complete-info) 144 | (puthash :window-point (point) ebdb-complete-info)) 145 | (setq ebdb-complete-info (clrhash ebdb-complete-info) 146 | prefix-string nil)) 147 | ;; Call ebdb 148 | (if (and prefix-string (> (length prefix-string) 0)) 149 | (progn 150 | (delete-char (- 0 (length prefix-string))) 151 | (puthash :window-point (point) ebdb-complete-info) 152 | (ebdb (ebdb-search-style) prefix-string)) 153 | (if (save-excursion 154 | (let* ((end (point)) 155 | (begin (line-beginning-position)) 156 | (string (buffer-substring-no-properties 157 | begin end))) 158 | (string-match-p "@.*>$" string))) 159 | ;; When point at "email@email.com>", 160 | ;; launch `ebdb-complete-mail'. 161 | (let ((ebdb-complete-mail-allow-cycling t)) 162 | (message "Cycling current user's email address!") 163 | (ebdb-complete-mail) 164 | ;; Close ebdb-buffer's window when complete with 165 | ;; `ebdb-complete-mail' 166 | (let ((window (get-buffer-window (ebdb-make-buffer-name)))) 167 | (if (window-live-p window) 168 | (quit-window nil window)))) 169 | (ebdb (ebdb-search-style) ""))) 170 | ;; Update `header-line-format' 171 | (when (or (derived-mode-p 'message-mode) 172 | (derived-mode-p 'mail-mode)) 173 | (with-current-buffer (ebdb-make-buffer-name) 174 | (setq header-line-format 175 | (format 176 | (substitute-command-keys 177 | (concat 178 | "## Type `\\[ebdb-complete-push-mail]' or `\\[ebdb-complete-push-mail-and-bury-ebdb-buffer]' " 179 | "to push email to buffer \"%s\". ##")) 180 | (buffer-name buffer))))))) 181 | 182 | (defun ebdb-complete-message-tab () 183 | "A command which will be bound to TAB key in message-mode, 184 | when in message headers, this command will launch `ebdb-complete', 185 | when in message body, this command will indent regular text." 186 | (interactive) 187 | (cond 188 | ;; Type TAB launch ebdb-complete when in header. 189 | ((and (save-excursion 190 | (let ((point (point))) 191 | (message-goto-body) 192 | (> (point) point))) 193 | (not (looking-back "^\\(Subject\\|From\\): *.*" 194 | (line-beginning-position))) 195 | (not (looking-back "^" (line-beginning-position)))) 196 | (ebdb-complete)) 197 | (message-tab-body-function (funcall message-tab-body-function)) 198 | (t (funcall (or (lookup-key text-mode-map "\t") 199 | (lookup-key global-map "\t") 200 | 'indent-relative))))) 201 | 202 | (defun ebdb-complete-keybinding-setup () 203 | "Setup ebdb-complete Keybindings." 204 | (define-key ebdb-mode-map "q" #'ebdb-complete-bury-ebdb-buffer) 205 | (define-key ebdb-mode-map "\C-c\C-c" #'ebdb-complete-push-mail) 206 | (define-key ebdb-mode-map (kbd "RET") #'ebdb-complete-push-mail-and-bury-ebdb-buffer)) 207 | 208 | ;;;###autoload 209 | (defun ebdb-complete-enable () 210 | "Enable ebdb-complete, it will rebind TAB key in `message-mode-map'." 211 | (interactive) 212 | (require 'message) 213 | (add-hook 'ebdb-mode-hook #'ebdb-complete-keybinding-setup) 214 | (define-key message-mode-map "\t" #'ebdb-complete-message-tab) 215 | (define-key mail-mode-map "\t" #'ebdb-complete-message-tab) 216 | (message "ebdb-complete: Override EBDB keybindings: `q', `C-c C-c' and `RET'")) 217 | 218 | (provide 'ebdb-complete) 219 | 220 | ;; Local Variables: 221 | ;; coding: utf-8-unix 222 | ;; End: 223 | 224 | ;;; ebdb-complete.el ends here 225 | -------------------------------------------------------------------------------- /ebdb-counsel.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-counsel.el --- Counsel integration for EBDB -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2019-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | ;; Maintainer: Eric Abrahamsen 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; Counsel/ivy integration for EBDB. 24 | 25 | ;;; Code: 26 | 27 | (require 'ebdb) 28 | 29 | (declare-function ivy-read "ext:ivy") 30 | 31 | ;;;###autoload 32 | (defun ebdb-counsel () 33 | "Select EBDB contacts using the ivy/counsel interface." 34 | (interactive) 35 | (ivy-read 36 | "Records: " 37 | (mapcar 38 | ;; This same lambda is used in helm-ebdb, refactor or maybe even 39 | ;; make customizable. Presumably we could use the :matcher 40 | ;; argument to provide a function that matched the name and mail 41 | ;; strings, but then you wouldn't actually see the mail strings in 42 | ;; the completion window, would you? 43 | (lambda (rec) 44 | (let* ((rec-string (ebdb-string rec)) 45 | (mails (ebdb-record-mail-canon rec)) 46 | (mail-list (when mails 47 | (mapconcat #'identity 48 | mails 49 | " ")))) 50 | (cons (if mail-list 51 | (concat rec-string 52 | " => " 53 | mail-list) 54 | rec-string) 55 | rec))) 56 | (ebdb-records)) 57 | :action 58 | '(1 59 | ("o" (lambda (r) 60 | (ebdb-display-records (list (cdr r)) nil t)) "display") 61 | ("m" (lambda (r) (ebdb-mail (cdr r))) "send mail") 62 | ("i" (lambda (r) (ebdb-cite-records-mail (cdr r))) "insert")))) 63 | 64 | (provide 'ebdb-counsel) 65 | ;;; ebdb-counsel.el ends here 66 | -------------------------------------------------------------------------------- /ebdb-format.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-format.el --- Formatting/exporting EBDB records -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; This file contains code for turning record objects into text, 23 | ;; somehow. It provides the basic framework that is used for creating 24 | ;; the *EBDB* buffer as well as exporting to vcard, latex, and html 25 | ;; formats. 26 | 27 | ;; The basic idea is: a formatter object controls which record fields 28 | ;; are selected, and ultimately how they're output as text. The 29 | ;; formatting routine first inserts the value of `ebdb-fmt-header', 30 | ;; then the value of `ebdb-fmt-record' for each record to be output, 31 | ;; then the value of `ebdb-fmt-footer'. 32 | 33 | ;; For each record, the method `ebdb-fmt-record' first collects its 34 | ;; fields using `ebdb-fmt-collect-fields', which are then sorted by 35 | ;; `ebdb-fmt-sort-fields', then processed with 36 | ;; `ebdb-fmt-process-fields' (this last means handling field 37 | ;; combination or collapse, etc). Then it splits header fields from 38 | ;; body fields, and formats the header fields with 39 | ;; `ebdb-fmt-record-header', and the body fields with 40 | ;; `ebdb-fmt-compose-fields'. It concats those two strings and 41 | ;; returns the result. 42 | 43 | ;; This file also provides the functions `ebdb-format-all-records' and 44 | ;; `ebdb-format-to-tmp-buffer', the difference being that the former 45 | ;; formats the whole database, and the latter only formats the 46 | ;; currently marked or displayed records. 47 | 48 | ;;; Code: 49 | 50 | (require 'ebdb) 51 | 52 | (declare-function csv-mode "ext:csv-mode") 53 | 54 | (defcustom ebdb-format-buffer-name "*EBDB Format*" 55 | "Default name of buffer in which to display formatted records." 56 | :type 'string 57 | :group 'ebdb-record-display) 58 | 59 | (defvar ebdb-formatter-tracker nil 60 | "Variable for holding all instantiated formatters.") 61 | 62 | (defclass ebdb-formatter (eieio-instance-tracker) 63 | ((label 64 | :initarg :label 65 | :type string 66 | :initform "") 67 | (tracking-symbol :initform 'ebdb-formatter-tracker) 68 | (format-buffer-name 69 | :initarg :format-buffer-name 70 | :type string 71 | :initform `,ebdb-format-buffer-name) 72 | (coding-system 73 | :type symbol 74 | :initarg :coding-system 75 | ;; "`," is used to trick EIEIO into evaluating the form. 76 | :initform `,buffer-file-coding-system 77 | :documentation "The coding system for the formatted 78 | file/buffer/stream.") 79 | (post-format-function 80 | :type (or null function) 81 | :initarg :post-format-function 82 | :initform nil 83 | :documentation "A function to be called after formatting is 84 | complete. Probably a major mode.")) 85 | :abstract t 86 | :documentation "Abstract base class for EBDB formatters. 87 | Subclass this to produce real formatters.") 88 | 89 | (defclass ebdb-formatter-freeform (ebdb-formatter) 90 | ((include 91 | :type list 92 | :initarg :include 93 | :initform nil 94 | :documentation "A list of field classes to include.") 95 | (exclude 96 | :type list 97 | :initarg :exclude 98 | :initform nil 99 | :documentation "A list of field classes to exclude. This 100 | slot is only honored if \"include\" is nil.") 101 | (sort 102 | :type list 103 | :initarg :sort 104 | :initform '(ebdb-field-mail 105 | ebdb-field-phone ebdb-field-address "_" ebdb-field-notes) 106 | :documentation "How field instances should be sorted. Field 107 | classes should be listed in their proper sort order. A \"_\" 108 | placeholder indicates where all other fields should go." ) 109 | (combine 110 | :type list 111 | :initarg :combine 112 | :initform nil 113 | :documentation "A list of field classes which should be 114 | output with all instances grouped together.") 115 | (collapse 116 | :type list 117 | :initarg :collapse 118 | :initform nil 119 | :documentation "A list of field classes which should be 120 | \"collapsed\". What this means is up to the formatter, but it 121 | generally indicates that most of the field contents will 122 | hidden unless the user takes some action, such as clicking or 123 | hitting . (Currently unimplemented.)") 124 | (header 125 | :type list 126 | :initarg :header 127 | :initform '((ebdb-record-person ebdb-field-role ebdb-field-image) 128 | (ebdb-record-organization ebdb-field-domain ebdb-field-role ebdb-field-image)) 129 | :documentation "A list of field classes which will be output 130 | in the header of the record, grouped by record class type.")) 131 | :abstract t 132 | :documentation "An abstract formatter for formats that can 133 | accept variable numbers and types of fields.") 134 | 135 | (defclass ebdb-formatter-constrained (ebdb-formatter) 136 | ((fields 137 | :type list 138 | :initarg :fields 139 | :initform nil 140 | :documentation "A list of the record fields to output. 141 | Fields will be output in the order listed.") 142 | (field-missing 143 | :type (or string symbol function) 144 | :initarg :field-missing 145 | :initform "none" 146 | :documentation "How to handle missing fields. Can be a 147 | string, which will be inserted in place of the missing field, 148 | a symbol, which will be raised as an error symbol, or a 149 | function, which will be called with three arguments: the 150 | formatter, the record, and the field spec.")) 151 | :abstract t 152 | :documentation "An abstract formatter for formats that require 153 | an exact specification of fields.") 154 | 155 | (defclass ebdb-formatter-tabular (ebdb-formatter-constrained) 156 | ((record-separator 157 | :type (or string character) 158 | :initarg :record-separator 159 | :initform "") 160 | (field-separator 161 | :type (or string character) 162 | :initarg :field-separator 163 | :initform "")) 164 | :documentation "A formatter for outputting records in tabular 165 | format.") 166 | 167 | (cl-defmethod ebdb-string ((fmt ebdb-formatter)) 168 | (slot-value fmt 'label)) 169 | 170 | (cl-defgeneric ebdb-fmt-header (fmt records) 171 | "Insert a string at the beginning of the list of records.") 172 | 173 | (cl-defgeneric ebdb-fmt-footer (fmt records) 174 | "Insert a string at the end of the list of records.") 175 | 176 | (cl-defgeneric ebdb-fmt-record (fmt record) 177 | "Handle the insertion of formatted RECORD. 178 | This method collects all the fields for RECORD, splits them into 179 | header and body fields, and then calls `ebdb-fmt-record-header' 180 | and `ebdb-fmt-compose-fields'.") 181 | 182 | (cl-defgeneric ebdb-fmt-record-header (fmt record fields) 183 | "Format a header for RECORD, using fields in FIELDS.") 184 | 185 | (cl-defgeneric ebdb-fmt-collect-fields (fmt record &optional fields) 186 | "Return a list of RECORD's FIELDS to be formatted.") 187 | 188 | (cl-defgeneric ebdb-fmt-process-fields (fmt record &optional fields) 189 | "Process the FIELDS belonging to RECORD. 190 | This means grouping them into lists containing various formatting 191 | information, mostly drawn from FMT's `combine' and `collapse' 192 | slots.") 193 | 194 | (cl-defgeneric ebdb-fmt-sort-fields (fmt record &optional fields) 195 | "Sort FIELDS belonging to RECORD according to FMT.") 196 | 197 | (cl-defgeneric ebdb-fmt-compose-fields (fmt object &optional field-list depth) 198 | "Compose the lists produced by `ebdb-fmt-process-fields'. 199 | The lists of class instances and formatting information are 200 | turned into indented strings, and the entire block is returned as 201 | a single string value. Optional argument DEPTH is used when 202 | recursively composing subfields of fields.") 203 | 204 | (cl-defgeneric ebdb-fmt-field (fmt field style record) 205 | "Format FIELD value of RECORD. 206 | This method only returns the string value of FIELD itself, 207 | possibly with text properties attached.") 208 | 209 | (cl-defgeneric ebdb-fmt-field-label (fmt field-or-class style &optional record) 210 | "Format a field label, using formatter FMT. 211 | FIELD-OR-CLASS is a field class or a field instance, and STYLE is 212 | a symbol indicating a style of some sort, such as \\='compact or 213 | \\='expanded.") 214 | 215 | ;;; Basic method implementations 216 | 217 | (cl-defmethod ebdb-fmt-header (_fmt _records) 218 | "") 219 | 220 | (cl-defmethod ebdb-fmt-footer (_fmt _records) 221 | "") 222 | 223 | (cl-defmethod ebdb-fmt-field-label ((_fmt ebdb-formatter) 224 | (cls (subclass ebdb-field)) 225 | _style 226 | &optional _record) 227 | (ebdb-field-readable-name cls)) 228 | 229 | (cl-defmethod ebdb-fmt-field-label ((_fmt ebdb-formatter) 230 | (field ebdb-field) 231 | _style 232 | &optional _record) 233 | (ebdb-field-readable-name field)) 234 | 235 | (cl-defmethod ebdb-fmt-field-label ((_fmt ebdb-formatter) 236 | (field ebdb-field-labeled) 237 | _style 238 | &optional _record) 239 | (ebdb-field-label field)) 240 | 241 | (cl-defmethod ebdb-fmt-field-label ((_fmt ebdb-formatter) 242 | (field ebdb-field-labeled) 243 | (_style (eql compact)) 244 | &optional _record) 245 | (ebdb-field-readable-name field)) 246 | 247 | (cl-defmethod ebdb-fmt-field ((fmt ebdb-formatter) 248 | (field ebdb-field-labeled) 249 | (_style (eql compact)) 250 | (record ebdb-record)) 251 | (let ((label (slot-value field 'label))) 252 | ;; The compact style shouldn't output a default label, only use it 253 | ;; if the field in question really has one. 254 | (concat 255 | (when label 256 | (format "(%s) " label)) 257 | (ebdb-fmt-field fmt field 'oneline record)))) 258 | 259 | (cl-defmethod ebdb-fmt-field ((_fmt ebdb-formatter) 260 | (field ebdb-field) 261 | (_style (eql oneline)) 262 | (_record ebdb-record)) 263 | (car (split-string (ebdb-string field) "\n"))) 264 | 265 | (cl-defmethod ebdb-fmt-field ((fmt ebdb-formatter) 266 | (field ebdb-field) 267 | (_style (eql collapse)) 268 | (record ebdb-record)) 269 | "For now, treat collapse the same as oneline." 270 | (ebdb-fmt-field fmt field 'oneline record)) 271 | 272 | (cl-defmethod ebdb-fmt-field ((_fmt ebdb-formatter) 273 | (field ebdb-field) 274 | _style 275 | (_record ebdb-record)) 276 | "The base implementation for FIELD simply returns the value of 277 | `ebdb-string'." 278 | (ebdb-string field)) 279 | 280 | (cl-defmethod ebdb-fmt-collect-fields ((fmt ebdb-formatter-freeform) 281 | (record ebdb-record) 282 | &optional field-list) 283 | "Collect all fields of RECORD, and filter according to FMT. 284 | Returns RECORD's field as a simple list." 285 | ;; Remove the `name' slot entry from the list. 286 | (let ((fields (append 287 | field-list 288 | (mapcar #'cdr 289 | (seq-remove 290 | ;; The or (null (cdr elt)) is there to 291 | ;; protect against an earlier bug with 292 | ;; timestamps and creation-dates, it could 293 | ;; be removed at some point. 294 | (lambda (elt) (or (eql (car elt) 'name) 295 | (null (cdr elt)))) 296 | (ebdb-record-current-fields record nil t)))))) 297 | (with-slots (exclude include) fmt 298 | (seq-filter 299 | (lambda (f) 300 | (if include 301 | (ebdb-foo-in-list-p f include) 302 | (null (ebdb-foo-in-list-p f exclude)))) 303 | fields)))) 304 | 305 | (cl-defmethod ebdb-fmt-collect-fields ((fmt ebdb-formatter-constrained) 306 | (record ebdb-record)) 307 | "Collect RECORD's fields according to FMT's `fields' slot. 308 | Return as a vector of field instances, with nil in place of 309 | missing fields." 310 | (let* ((fmt-fields (slot-value fmt 'fields)) 311 | (missing (slot-value fmt 'field-missing)) 312 | (fields (make-vector (length fmt-fields) nil))) 313 | (dotimes (i (length fields)) 314 | (aset fields i (or (ebdb-record-field record (nth i fmt-fields)) 315 | (cons (nth i fmt-fields) missing)))) 316 | fields)) 317 | 318 | (cl-defmethod ebdb-fmt-sort-fields ((_fmt ebdb-formatter-constrained) 319 | (_record ebdb-record) 320 | &optional fields) 321 | "Don't sort by default." 322 | fields) 323 | 324 | (cl-defmethod ebdb-fmt-process-fields ((_fmt ebdb-formatter-constrained) 325 | (_record ebdb-record) 326 | &optional fields) 327 | "Process fields for the \"constrained\" formatter class. 328 | At present, just makes sure that multiple field instances are 329 | combined into a single string." 330 | fields) 331 | 332 | (cl-defmethod ebdb-fmt-collect-fields ((fmt ebdb-formatter-freeform) 333 | (record ebdb-record-organization) 334 | &optional field-list) 335 | "Collect all role fields that point at this organization." 336 | (cl-call-next-method 337 | fmt record 338 | (append field-list (gethash (ebdb-record-uuid record) ebdb-org-hashtable)))) 339 | 340 | (cl-defmethod ebdb-fmt-collect-fields ((fmt ebdb-formatter-freeform) 341 | (record ebdb-record-person) 342 | &optional field-list) 343 | "Collect all relation fields that point at this person." 344 | (cl-call-next-method 345 | fmt record 346 | (append field-list (mapcar #'cdr (gethash (ebdb-record-uuid record) 347 | ebdb-relation-hashtable))))) 348 | 349 | (cl-defmethod ebdb-fmt-sort-fields ((fmt ebdb-formatter-freeform) 350 | (_record ebdb-record) 351 | field-list) 352 | "Sort FIELD-LIST using sort order from FMT. 353 | First sorts all fields with `ebdb-field-compare', then sorts 354 | again by the order of each field's class symbol in the \\='sort 355 | slot of FMT." 356 | (let* ((sort-order (slot-value fmt 'sort)) 357 | (catchall (or (seq-position sort-order "_") 358 | (length sort-order))) 359 | ;; This sorts by class type, what we also want is, if the 360 | ;; "plumbing" fields are present, to put them first. 361 | (sorted (seq-sort #'ebdb-field-compare field-list))) 362 | 363 | (when sort-order 364 | (setq sorted 365 | (seq-sort-by 366 | (lambda (f) 367 | (or (seq-position sort-order (eieio-object-class-name f)) 368 | catchall)) 369 | #'< sorted))) 370 | sorted)) 371 | 372 | (cl-defmethod ebdb-fmt-process-fields ((fmt ebdb-formatter-freeform) 373 | (_record ebdb-record) 374 | field-list) 375 | "Process FIELD-LIST for FMT. 376 | At present that means handling the combine and collapse slots of 377 | FMT. 378 | 379 | This method assumes that fields in FIELD-LIST have already been 380 | grouped by field class. 381 | 382 | The return value is a list of alists. Each alist has three keys: 383 | \\='class, holding a class symbol, \\='style, holding either the symbol 384 | `collapse' or the symbol `normal', and \\='inst, a list of all the 385 | instances in this bundle. The `combine' style works by putting 386 | multiple instances in a single alist." 387 | (let (outlist f acc) 388 | (with-slots (combine collapse) fmt 389 | (when combine 390 | (while (setq f (pop field-list)) 391 | (if (null (ebdb-foo-in-list-p f combine)) 392 | (push f outlist) 393 | (push f acc) 394 | (while (and field-list (same-class-p (car field-list) 395 | (eieio-object-class f))) 396 | (push (setq f (pop field-list)) acc)) 397 | (push `((class . ,(eieio-object-class-name f)) 398 | (style . compact) (inst . ,(nreverse acc))) 399 | outlist) 400 | (setq acc nil))) 401 | (setq field-list (nreverse outlist) 402 | outlist nil)) 403 | (dolist (f field-list) 404 | (if (listp f) 405 | (push f outlist) 406 | (push (list (cons 'class (eieio-object-class-name f)) 407 | (cons 'inst (list f)) 408 | (cons 'style 409 | (cond 410 | ((ebdb-foo-in-list-p f collapse) 'collapse) 411 | (t 'normal)))) 412 | outlist))) 413 | (nreverse outlist)))) 414 | 415 | (cl-defmethod ebdb-fmt-record ((fmt ebdb-formatter-freeform) 416 | (record ebdb-record)) 417 | (pcase-let* ((header-classes (cdr (assoc (eieio-object-class-name record) 418 | (slot-value fmt 'header)))) 419 | (record-uuid (ebdb-record-uuid record)) 420 | ((map header-fields body-fields) 421 | (seq-group-by 422 | (lambda (f) 423 | ;; FIXME: Consider doing the header/body split in 424 | ;; `ebdb-fmt-process-fields', we've already got the 425 | ;; formatter there. 426 | (let ((cls (alist-get 'class f)) 427 | (inst (car (alist-get 'inst f)))) 428 | (if (child-of-class-p cls 'ebdb-field-role) 429 | ;; This is all getting super hacky... If the 430 | ;; role field is "to" some other record, put 431 | ;; it in the header. If it's "to" this 432 | ;; record, put it in the body. 433 | (if (equal record-uuid (slot-value inst 'record-uuid)) 434 | 'header-fields 435 | 'body-fields) 436 | (if (ebdb-foo-in-list-p cls header-classes) 437 | 'header-fields 438 | 'body-fields)))) 439 | (ebdb-fmt-process-fields 440 | fmt record 441 | (ebdb-fmt-sort-fields 442 | fmt record 443 | (ebdb-fmt-collect-fields 444 | fmt record)))))) 445 | (concat 446 | (ebdb-fmt-record-header fmt record header-fields) 447 | (ebdb-fmt-compose-fields fmt record body-fields 1)))) 448 | 449 | ;; Tabular formatting 450 | 451 | (cl-defmethod ebdb-fmt-record ((fmt ebdb-formatter-tabular) 452 | (rec ebdb-record)) 453 | (let ((fields (ebdb-fmt-process-fields 454 | fmt rec 455 | (ebdb-fmt-sort-fields 456 | fmt rec 457 | (ebdb-fmt-collect-fields 458 | fmt rec)))) 459 | (rec-sep (slot-value fmt 'record-separator))) 460 | (concat 461 | (ebdb-fmt-compose-fields fmt rec fields) 462 | rec-sep))) 463 | 464 | (cl-defmethod ebdb-fmt-header ((fmt ebdb-formatter-tabular) 465 | _records) 466 | (with-slots (fields field-separator record-separator) fmt 467 | (concat 468 | "Name" 469 | field-separator 470 | (mapconcat 471 | (lambda (f) 472 | (cond 473 | ((stringp f) f) 474 | ((or (class-p f) 475 | (eieio-object-p f)) 476 | (ebdb-fmt-field-label fmt f 'normal)) 477 | ((symbolp f) 478 | (symbol-name f)))) 479 | fields 480 | field-separator)))) 481 | 482 | (cl-defmethod ebdb-fmt-compose-fields ((fmt ebdb-formatter-tabular) 483 | (rec ebdb-record) 484 | &optional field-list _depth) 485 | 486 | (with-slots (field-separator) fmt 487 | (concat 488 | (ebdb-record-name-string rec) 489 | field-separator 490 | (mapconcat 491 | (lambda (f) 492 | (if (eieio-object-p f) 493 | (ebdb-fmt-field fmt f 'compact rec) 494 | ;; See docs of 'field-missing slot of 495 | ;; `ebdb-formatter-constrained' for explanation of the 496 | ;; following behavior. 497 | (pcase f 498 | (`(,_ . ,(and (pred stringp) str)) str) 499 | (`(,spec . ,(and (pred symbolp) sym)) 500 | (signal sym (list rec spec))) 501 | (`(,spec . ,(and (pred functionp) fun)) 502 | (funcall fun fmt rec spec))))) 503 | field-list 504 | field-separator)))) 505 | 506 | (defclass ebdb-formatter-csv (ebdb-formatter-tabular) 507 | ((record-separator :initform "\n") 508 | (field-separator :initform ",") 509 | (post-format-function :initform (lambda () 510 | (when (fboundp 'csv-mode) 511 | (csv-mode)))))) 512 | 513 | (cl-defmethod ebdb-fmt-field ((fmt ebdb-formatter-csv) 514 | (_field ebdb-field) 515 | _style 516 | (_rec ebdb-record)) 517 | "Quote field strings containing the separator." 518 | (let ((sep (slot-value fmt 'field-separator)) 519 | (field (cl-call-next-method))) 520 | (if (and (stringp sep) 521 | (string-match-p sep field)) 522 | (format "\"%s\"" field) 523 | field))) 524 | 525 | (cl-defmethod ebdb-fmt-header ((_fmt ebdb-formatter-csv) 526 | _records) 527 | (concat (cl-call-next-method) "\n")) 528 | 529 | (defcustom ebdb-default-csv-formatter 530 | (make-instance 'ebdb-formatter-csv :label "csv" 531 | :fields '(mail-primary)) 532 | "Default CSV formatter." 533 | :group 'ebdb 534 | :type 'ebdb-formatter-csv) 535 | 536 | ;;; Basic export routines 537 | 538 | (defun ebdb-prompt-for-formatter () 539 | (interactive) 540 | (let ((collection 541 | (mapcar 542 | (lambda (formatter) 543 | (cons (slot-value formatter 'label) formatter)) 544 | ebdb-formatter-tracker))) 545 | (cdr (assoc (completing-read "Use formatter: " collection) 546 | collection)))) 547 | 548 | (provide 'ebdb-format) 549 | ;;; ebdb-format.el ends here 550 | -------------------------------------------------------------------------------- /ebdb-gnus.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-gnus.el --- Gnus interface to EBDB -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Code for interaction with Gnus. 23 | 24 | ;;; Code: 25 | 26 | (require 'ebdb-com) 27 | (require 'ebdb-mua) 28 | (require 'gnus-sum) 29 | (require 'gnus-msg) 30 | 31 | (autoload 'message-make-domain "message") 32 | 33 | (defgroup ebdb-mua-gnus nil 34 | "Gnus-specific EBDB customizations." 35 | :group 'ebdb-mua) 36 | (put 'ebdb-mua-gnus 'custom-loads '(ebdb-gnus)) 37 | 38 | (defcustom ebdb-gnus-auto-update-p ebdb-mua-reader-update-p 39 | "Gnus-specific value of `ebdb-mua-auto-update-p'." 40 | :type '(choice (const :tag "do nothing" nil) 41 | (const :tag "search for existing records" existing) 42 | (const :tag "update existing records" update) 43 | (const :tag "query for update or record creation" query) 44 | (const :tag "update or create automatically" create) 45 | (function :tag "User-defined function"))) 46 | 47 | (defcustom ebdb-gnus-window-size ebdb-default-window-size 48 | "Size of the EBDB buffer when popping up in Gnus. 49 | Size should be specified as a float between 0 and 1. Defaults to 50 | the value of `ebdb-default-window-size'." 51 | :type 'float) 52 | 53 | (defcustom ebdb-gnus-window-configuration nil 54 | "Symbol that names EBDB's Gnus window config. 55 | This option is nil by default, meaning Gnus will pop up the 56 | *EBDB-Gnus* window next to the *Article* buffer, with a 57 | width/height of `ebdb-gnus-window-size'. 58 | 59 | If more control is required, set this to a symbol name. This 60 | symbol will be entered into the `gnus-window-to-buffer' alist, 61 | and can be used as an entry in more complex Gnus buffer/window 62 | configurations. 63 | 64 | Note that this should be a different symbol from that used in 65 | Message-mode article composition window config." 66 | :type '(choice (const :tag nil) 67 | (symbol :tag "Window config name"))) 68 | 69 | (defcustom ebdb-gnus-post-style-function 70 | (lambda (_rec _mail) nil) 71 | "Callable used to determine Gnus group posting styles. 72 | The callable should accept a single record as a first argument, 73 | and a mail field instance as a second. Either return a Gnus 74 | group name as a string, which will be used to configure posting 75 | styles when composing a message to that record/mail, or return 76 | nil to use Gnus defaults. 77 | 78 | See `ebdb-record-field' or `ebdb-record-current-fields' for 79 | likely ways to extract information about the record." 80 | :type 'function) 81 | 82 | (defgroup ebdb-mua-gnus-scoring nil 83 | "Gnus-specific scoring EBDB customizations" 84 | :group 'ebdb-mua-gnus) 85 | (put 'ebdb-mua-gnus-scoring 'custom-loads '(ebdb-gnus)) 86 | 87 | (defgroup ebdb-mua-gnus-splitting nil 88 | "Gnus-specific splitting EBDB customizations" 89 | :group 'ebdb-mua-gnus) 90 | (put 'ebdb-mua-gnus-splitting 'custom-loads '(ebdb-gnus)) 91 | 92 | ;;; Gnus-specific field types. All should subclass 93 | ;;; `ebdb-field-user'. 94 | 95 | ;;;###autoload 96 | (defclass ebdb-gnus-score-field (ebdb-field-user) 97 | ((score 98 | :type (or null number) 99 | :initarg :score 100 | :initval nil)) 101 | :human-readable "gnus score") 102 | 103 | (cl-defmethod ebdb-read ((field (subclass ebdb-gnus-score-field)) &optional slots obj) 104 | (let ((score (string-to-number 105 | (ebdb-read-string 106 | "Score" (when obj (slot-value obj 'score)))))) 107 | (cl-call-next-method field (plist-put slots :score score) obj))) 108 | 109 | (cl-defmethod ebdb-string ((field ebdb-gnus-score-field)) 110 | (slot-value field 'score)) 111 | 112 | ;; Scoring 113 | 114 | (defcustom ebdb/gnus-score-default nil 115 | "If this is set, then every mail address in the EBDB that does not have 116 | an associated score field will be assigned this score. A value of nil 117 | implies a default score of zero." 118 | :group 'ebdb-mua-gnus-scoring 119 | :type '(choice (const :tag "Do not assign default score" nil) 120 | (integer :tag "Assign this default score" 0))) 121 | 122 | (defvar ebdb/gnus-score-default-internal nil 123 | "Internal variable for detecting changes to 124 | `ebdb/gnus-score-default'. You should not set this variable directly - 125 | set `ebdb/gnus-score-default' instead.") 126 | 127 | (defvar ebdb/gnus-score-alist nil 128 | "The text version of the scoring structure returned by 129 | ebdb/gnus-score. This is built automatically from the EBDB.") 130 | 131 | (defvar ebdb/gnus-score-rebuild-alist t 132 | "Set to t to rebuild ebdb/gnus-score-alist on the next call to 133 | ebdb/gnus-score. This will be set automatically if you change a EBDB 134 | record which contains a gnus-score field.") 135 | 136 | (defun ebdb/gnus-score-invalidate-alist (record) 137 | "This function is called through `ebdb-after-change-hook', 138 | and sets `ebdb/gnus-score-rebuild-alist' to t if the changed 139 | record contains a gnus-score field." 140 | (if (ebdb-record-user-field record 'ebdb-gnus-score-field) 141 | (setq ebdb/gnus-score-rebuild-alist t))) 142 | 143 | ;;;###autoload 144 | (defun ebdb/gnus-score (group) 145 | "Return a score alist for Gnus. 146 | A score pair will be made for every member of the mail field in 147 | records which also have a `gnus-score' field. This allows the 148 | EBDB to serve as a supplemental global score file, with the 149 | advantage that it can keep up with multiple and changing 150 | addresses better than the traditionally static global scorefile." 151 | (list (list 152 | (condition-case nil 153 | (read (ebdb/gnus-score-as-text group)) 154 | (error (setq ebdb/gnus-score-rebuild-alist t) 155 | (message "Problem building EBDB score table.") 156 | (ding) (sit-for 2) 157 | nil))))) 158 | 159 | (defun ebdb/gnus-score-as-text (_group) 160 | "Returns a SCORE file format string built from the EBDB." 161 | (cond ((or (cond ((/= (or ebdb/gnus-score-default 0) 162 | (or ebdb/gnus-score-default-internal 0)) 163 | (setq ebdb/gnus-score-default-internal 164 | ebdb/gnus-score-default) 165 | t)) 166 | (not ebdb/gnus-score-alist) 167 | ebdb/gnus-score-rebuild-alist) 168 | (setq ebdb/gnus-score-rebuild-alist nil) 169 | (setq ebdb/gnus-score-alist 170 | (concat "((touched nil) (\"from\"\n" 171 | (mapconcat 172 | (lambda (record) 173 | (let ((score (or (ebdb-record-user-field record 'ebdb-gnus-score-field) 174 | ebdb/gnus-score-default)) 175 | (mail (ebdb-record-mail record))) 176 | (when (and score mail) 177 | (mapconcat 178 | (lambda (address) 179 | (format "(\"%s\" %s)\n" (ebdb-string address) score)) 180 | mail "")))) 181 | ebdb-record-tracker "") 182 | "))")))) 183 | ebdb/gnus-score-alist) 184 | 185 | ;;; Gnus splitting support 186 | 187 | ;; First, catch and upgrade instances of `ebdb-gnus-private-field' and 188 | ;; `ebdb-gnus-imap-field'. These upgrade routines were put in place 189 | ;; September 3, 2017. Give it... a year? Two? Then delete them. 190 | 191 | ;;;###autoload 192 | (defclass ebdb-gnus-private-field (ebdb-field-user) 193 | ((group 194 | :initarg :group))) 195 | 196 | ;;;###autoload 197 | (defclass ebdb-gnus-imap-field (ebdb-field-user) 198 | ((group 199 | :initarg :group))) 200 | 201 | (cl-defmethod make-instance ((_cls (subclass ebdb-gnus-private-field)) &rest slots) 202 | (apply #'make-instance 'ebdb-field-mail-folder 203 | (list :folder (plist-get slots :group)))) 204 | 205 | (cl-defmethod make-instance ((_cls (subclass ebdb-gnus-imap-field)) &rest slots) 206 | (apply #'make-instance 'ebdb-field-mail-folder 207 | (list :folder (plist-get slots :group)))) 208 | 209 | (defun ebdb/gnus-split-folders-list () 210 | "Return a list of (\"From\" mail-regexp imap-folder-name) tuples 211 | based on the contents of the EBDB. 212 | 213 | Mail address elements are already `regexp-quote'-ed, so we just 214 | concat them. Please note: in order that this will work with the 215 | `nnimap-split-fancy' or `nnmail-split-fancy' methods you have to 216 | use a backquote template, in other words your Gnus server 217 | variable will look like: 218 | 219 | \(nnimap \"imap.example.com\" 220 | (nnimap-inbox \"INBOX\") 221 | (nnimap-split-fancy 222 | \\=`(| ,@(ebdb/gnus-split-folders-list) 223 | ... ))) 224 | 225 | Note that \\=`( is the backquote, NOT the quote \\='(." 226 | (mapcar 227 | (lambda (elt) 228 | (list "From" 229 | (mapconcat #'identity (cdr elt) "\\|") 230 | (car elt))) 231 | ebdb-mail-folder-list)) 232 | 233 | ;; 234 | ;; Insinuation 235 | ;; 236 | 237 | (defun ebdb-gnus-auto-update () 238 | (ebdb-mua-auto-update ebdb-gnus-auto-update-p)) 239 | 240 | (add-hook 'gnus-article-prepare-hook #'ebdb-gnus-auto-update) 241 | 242 | (add-hook 'gnus-startup-hook #'ebdb-insinuate-gnus) 243 | 244 | (defsubst ebdb-gnus-buffer-name () 245 | (format "*%s-Gnus*" ebdb-buffer-name)) 246 | 247 | 248 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode gnus-summary-mode)) 249 | "Produce a EBDB buffer name associated with Gnus." 250 | (ebdb-gnus-buffer-name)) 251 | 252 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode gnus-article-mode)) 253 | "Produce a EBDB buffer name associated with Gnus." 254 | (ebdb-gnus-buffer-name)) 255 | 256 | (cl-defmethod ebdb-popup-window (&context (major-mode gnus-summary-mode)) 257 | (let ((win 258 | (progn 259 | (unless (gnus-buffer-live-p gnus-article-buffer) 260 | (gnus-summary-show-article)) 261 | (get-buffer-window gnus-article-buffer)))) 262 | (list win ebdb-gnus-window-size))) 263 | 264 | (cl-defmethod ebdb-popup-window (&context (major-mode gnus-article-mode)) 265 | (list (get-buffer-window) ebdb-gnus-window-size)) 266 | 267 | ;; It seems that `gnus-fetch-field' fetches decoded content of 268 | ;; `gnus-visible-headers', ignoring `gnus-ignored-headers'. 269 | ;; Here we use instead `gnus-fetch-original-field' that fetches 270 | ;; the encoded content of `gnus-original-article-buffer'. 271 | ;; Decoding makes this possibly a bit slower, but something like 272 | ;; `ebdb-select-message' does not get fooled by an apparent 273 | ;; absence of some headers. 274 | ;; See http://permalink.gmane.org/gmane.emacs.gnus.general/78741 275 | 276 | (cl-defmethod ebdb-mua-message-header ((header string) 277 | &context (major-mode gnus-summary-mode)) 278 | "Return value of HEADER for current Gnus message." 279 | (set-buffer gnus-article-buffer) 280 | (gnus-fetch-original-field header)) 281 | 282 | ;; This is all a little goofy. 283 | (cl-defmethod ebdb-mua-message-header ((header string) 284 | &context (major-mode gnus-article-mode)) 285 | (set-buffer gnus-article-buffer) 286 | (gnus-fetch-original-field header)) 287 | 288 | (cl-defmethod ebdb-mua-message-header ((header string) 289 | &context (major-mode gnus-tree-mode)) 290 | (set-buffer gnus-article-buffer) 291 | (gnus-fetch-original-field header)) 292 | 293 | (cl-defmethod ebdb-mua-prepare-article (&context (major-mode gnus-summary-mode)) 294 | (gnus-summary-select-article)) 295 | 296 | (cl-defmethod ebdb-mua-prepare-article (&context (major-mode gnus-article-mode)) 297 | (gnus-summary-select-article)) 298 | 299 | (cl-defmethod ebdb-mua-article-body (&context (major-mode gnus-summary-mode)) 300 | "Return the current article body as a string. 301 | 302 | Must not include article headers, though can include headers in 303 | quoted replies." 304 | (gnus-with-article-buffer 305 | ;; This pretends that there's no such thing as mime parts, and 306 | ;; will probably fail horribly. 307 | (article-goto-body) 308 | (buffer-substring-no-properties (point) (point-max)))) 309 | 310 | (cl-defmethod ebdb-mua-article-body (&context (major-mode gnus-article-mode)) 311 | (gnus-with-article-buffer 312 | (article-goto-body) 313 | (buffer-substring-no-properties (point) (point-max)))) 314 | 315 | (cl-defmethod ebdb-mua-article-signature (&context (major-mode gnus-summary-mode)) 316 | (gnus-with-article-buffer 317 | (gnus-article-search-signature) 318 | (forward-line) 319 | (buffer-substring-no-properties 320 | (point) 321 | ;; Assume a blank line concludes a signature. 322 | (or (re-search-forward "\n\n" nil t) 323 | (point-max))))) 324 | 325 | (cl-defmethod ebdb-field-mail-compose ((record ebdb-record-entity) 326 | (mail ebdb-field-mail) 327 | &context (read-mail-command (eql gnus)) 328 | &rest args) 329 | "Compose a Gnus mail to RECORD's address MAIL. 330 | Gives the user a chance to set posting styles for a message 331 | composed to a certain record." 332 | (let ((group (funcall ebdb-gnus-post-style-function 333 | record mail))) 334 | (if group 335 | (let ((gnus-newsgroup-name group)) 336 | (gnus-setup-message 'message 337 | (apply #'message-mail (ebdb-dwim-mail record mail) args))) 338 | (cl-call-next-method)))) 339 | 340 | ;;;###autoload 341 | (defun ebdb-insinuate-gnus () 342 | "Hook EBDB into Gnus." 343 | (unless ebdb-db-list 344 | (ebdb-load)) 345 | ;; `ebdb-mua-display-sender' fails in *Article* buffers, where 346 | ;; `gnus-article-read-summary-keys' provides an additional wrapper 347 | ;; that restores the window configuration. 348 | (define-key gnus-summary-mode-map ";" ebdb-mua-keymap) 349 | (define-key gnus-article-mode-map ";" ebdb-mua-keymap) 350 | 351 | ;; If the user has set this to a symbol, it needs to be added to 352 | ;; Gnus' `gnus-window-to-buffer' list. 353 | (when ebdb-gnus-window-configuration 354 | (add-to-list 'gnus-window-to-buffer 355 | (cons ebdb-gnus-window-configuration 356 | (ebdb-gnus-buffer-name)))) 357 | 358 | ;; Versions of Gnus with the gnus-search.el library allow us to 359 | ;; perform contact auto-completion within search queries. 360 | (when (boundp 'gnus-search-contact-tables) 361 | (add-hook 'ebdb-after-load-hook 362 | (lambda () 363 | (push ebdb-hashtable gnus-search-contact-tables)))) 364 | 365 | ;; Set up user field for use in `gnus-summary-line-format' 366 | ;; (1) Big solution: use whole name 367 | (if ebdb-mua-summary-unify-format-letter 368 | (fset (intern (concat "gnus-user-format-function-" 369 | ebdb-mua-summary-unify-format-letter)) 370 | (lambda (header) 371 | (let ((from (mail-header-from header))) 372 | (or 373 | (and gnus-ignored-from-addresses 374 | (cond ((functionp gnus-ignored-from-addresses) 375 | (funcall gnus-ignored-from-addresses 376 | (mail-strip-quoted-names from))) 377 | (t (string-match (gnus-ignored-from-addresses) from))) 378 | (let ((extra-headers (mail-header-extra header)) 379 | to 380 | newsgroups) 381 | (cond 382 | ((setq to (cdr (assq 'To extra-headers))) 383 | (concat gnus-summary-to-prefix 384 | (ebdb-mua-summary-unify to))) 385 | ((setq newsgroups 386 | (or 387 | (cdr (assq 'Newsgroups extra-headers)) 388 | (and 389 | (memq 'Newsgroups gnus-extra-headers) 390 | (eq (car (gnus-find-method-for-group 391 | gnus-newsgroup-name)) 'nntp) 392 | (gnus-group-real-name gnus-newsgroup-name)))) 393 | (concat gnus-summary-newsgroup-prefix newsgroups))))) 394 | (ebdb-mua-summary-unify (mail-header-from header))))))) 395 | 396 | ;; (2) Small solution: a mark for messages whos sender is in EBDB. 397 | (if ebdb-mua-summary-mark-format-letter 398 | (fset (intern (concat "gnus-user-format-function-" 399 | ebdb-mua-summary-mark-format-letter)) 400 | (lambda (header) 401 | (ebdb-mua-summary-mark (mail-header-from header)))))) 402 | 403 | (provide 'ebdb-gnus) 404 | ;;; ebdb-gnus.el ends here 405 | ;;; 406 | -------------------------------------------------------------------------------- /ebdb-helm.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-helm.el --- Helm integration for EBDB -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2018-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Helm integration for EBDB. Provides the command `helm-ebdb'. 23 | 24 | ;;; Code: 25 | 26 | (require 'ebdb-com) 27 | 28 | (declare-function helm-other-buffer "ext:helm" 29 | (any-sources any-buffer)) 30 | 31 | (declare-function helm-marked-candidates "ext:helm") 32 | 33 | (defun ebdb-helm-candidates () 34 | "Return a list of all records in the database." 35 | (mapcar (lambda (rec) 36 | (let* ((rec-string (ebdb-string rec)) 37 | (mails (ebdb-record-mail-canon rec)) 38 | (mail-list (when mails 39 | (mapconcat #'identity 40 | mails 41 | " ")))) 42 | (cons (if mail-list 43 | (concat rec-string 44 | " => " 45 | mail-list) 46 | rec-string) 47 | rec))) 48 | (ebdb-records))) 49 | 50 | (defun ebdb-helm-display-records (_candidate) 51 | "Display marked candidate(s)." 52 | (ebdb-display-records 53 | (helm-marked-candidates) nil nil t nil 54 | (format "*%s*" ebdb-buffer-name))) 55 | 56 | (defun ebdb-helm-compose-mail (_candidate) 57 | "Compose mail to marked candidate(s)." 58 | (ebdb-mail (helm-marked-candidates) nil current-prefix-arg)) 59 | 60 | (defun ebdb-helm-cite-records (_candidate) 61 | "Insert mode-appropriate \"Name \" string candidate(s)." 62 | (ebdb-cite-records (helm-marked-candidates) current-prefix-arg)) 63 | 64 | (defvar helm-source-ebdb 65 | '((name . "EBDB") 66 | (candidates . ebdb-helm-candidates) 67 | (action . (("Display" . ebdb-helm-display-records) 68 | ("Send mail" . ebdb-helm-compose-mail) 69 | ("Insert name and address" . ebdb-helm-cite-records))))) 70 | 71 | ;;;###autoload 72 | (defun ebdb-helm () 73 | "Preconfigured `helm' for EBDB." 74 | (interactive) 75 | (helm-other-buffer 'helm-source-ebdb "*helm ebdb*")) 76 | 77 | (provide 'helm-ebdb) 78 | ;;; helm-ebdb.el ends here 79 | -------------------------------------------------------------------------------- /ebdb-html.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-html.el --- EBDB HTML integration -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2018-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | ;; Maintainer: Eric Abrahamsen 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; This file contains code for "doing HTML things" with EBDB records. 24 | ;; Right now that only means formatters for exporting EBDB records as 25 | ;; HTML. 26 | 27 | ;;; Code: 28 | 29 | (require 'ebdb-format) 30 | 31 | (defgroup ebdb-html nil 32 | "Customization options for EBDB with HTML." 33 | :group 'ebdb) 34 | 35 | (defclass ebdb-html-formatter (ebdb-formatter) 36 | ((post-format-function :initform #'html-mode)) 37 | :abstract t 38 | :documentation "Formatter responsible for HTML-specific field 39 | formatting.") 40 | 41 | (defclass ebdb-html-formatter-html5 (ebdb-html-formatter 42 | ebdb-formatter-freeform) 43 | ((header :initform '((ebdb-record-person ebdb-field-notes)))) 44 | :documentation "HTML formatter for \"block-style\" HTML 45 | formatting.") 46 | 47 | (cl-defmethod ebdb-fmt-record :around ((_fmt ebdb-html-formatter-html5) 48 | (_rec ebdb-record)) 49 | (concat 50 | "
\n" 51 | (cl-call-next-method) 52 | "\n
\n")) 53 | 54 | (cl-defmethod ebdb-fmt-record-header ((fmt ebdb-html-formatter-html5) 55 | (rec ebdb-record) 56 | header-fields) 57 | (concat 58 | "
\n" 59 | (format "

%s

\n" (ebdb-record-name-string rec)) 60 | (mapconcat 61 | (pcase-lambda ((map style inst _class)) 62 | (format "

%s

" (mapconcat (lambda (f) (ebdb-fmt-field fmt f style rec)) inst ", "))) 63 | header-fields 64 | "\n") 65 | "
\n")) 66 | 67 | (cl-defmethod ebdb-fmt-compose-fields ((fmt ebdb-html-formatter-html5) 68 | (rec ebdb-record) 69 | &optional field-list _depth) 70 | "This particular implementation uses description lists (
)." 71 | (when field-list 72 | (concat 73 | "
\n" 74 | (mapconcat 75 | (pcase-lambda ((map style inst class)) 76 | (concat 77 | (format "
%s
" (ebdb-fmt-field-label 78 | fmt 79 | (if (= 1 (length inst)) 80 | (car inst) 81 | class) 82 | style 83 | rec)) 84 | (mapconcat 85 | (lambda (f) 86 | (format "
%s
" (ebdb-fmt-field fmt f style rec))) 87 | inst 88 | "\n"))) 89 | field-list "\n") 90 | "
\n"))) 91 | 92 | (cl-defmethod ebdb-fmt-field ((_fmt ebdb-html-formatter) 93 | (field ebdb-field-mail) 94 | _style 95 | (_rec ebdb-record)) 96 | (with-slots (mail aka) field 97 | (format "%s" mail (or aka mail)))) 98 | 99 | (defclass ebdb-html-formatter-tabular (ebdb-formatter-tabular 100 | ebdb-html-formatter) 101 | ;; We put the elements in manually. 102 | ((record-separator :initform "") 103 | (field-separator :initform ""))) 104 | 105 | (defcustom ebdb-html-default-formatter-tabular 106 | (make-instance 'ebdb-html-formatter-tabular 107 | :label "html table" 108 | :fields '(mail-primary)) 109 | "The default HTML table formatter." 110 | :type 'ebdb-html-formatter-tabular) 111 | 112 | (defcustom ebdb-html-default-formatter-html5 113 | (make-instance 'ebdb-html-formatter-html5 114 | :label "html5 block" 115 | :include '(mail-primary ebdb-field-phone ebdb-field-address ebdb-field-notes)) 116 | "The default HTML5 block formatter." 117 | :type 'ebdb-html-formatter-html5) 118 | 119 | (cl-defmethod ebdb-fmt-header ((fmt ebdb-html-formatter-tabular) 120 | _records) 121 | (with-slots (fields) fmt 122 | (concat 123 | "\n\n"))) 136 | 137 | (cl-defmethod ebdb-fmt-footer ((_fmt ebdb-html-formatter-tabular) 138 | _records) 139 | "\n
Name" 124 | (mapconcat 125 | (lambda (f) 126 | (cond 127 | ((stringp f) f) 128 | ((or (class-p f) 129 | (eieio-object-p f)) 130 | (ebdb-fmt-field-label fmt f 'normal)) 131 | ((symbolp f) 132 | (symbol-name f)))) 133 | fields 134 | "") 135 | "
") 140 | 141 | (cl-defmethod ebdb-fmt-record ((_fmt ebdb-html-formatter-tabular) 142 | (_rec ebdb-record)) 143 | "Wrap records in elements. 144 | This is done in lieu of a `record-separator' slot, since it's 145 | around each record, not between records." 146 | (concat "" 147 | (cl-call-next-method) 148 | "")) 149 | 150 | (cl-defmethod ebdb-fmt-compose-fields :around ((_fmt ebdb-html-formatter-tabular) 151 | (_rec ebdb-record) 152 | &optional _field-list _depth) 153 | (concat "" 154 | (cl-call-next-method) 155 | "")) 156 | 157 | (provide 'ebdb-html) 158 | ;;; ebdb-html.el ends here 159 | -------------------------------------------------------------------------------- /ebdb-i18n-basic.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-i18n-basic.el --- Basic internationalization methods for EBDB -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2017-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; This file provides internationalized methods for a few common 23 | ;; countries, "common" here meaning what used to be in 24 | ;; `ebdb-address-format-list'. 25 | 26 | ;;; Code: 27 | 28 | (eval-when-compile 29 | ;; For `with-slots'. 30 | (require 'eieio)) 31 | 32 | (declare-function ebdb-i18n-countries "ebdb-i18n") 33 | (declare-function ebdb-with-exit "ebdb") 34 | (declare-function ebdb-address-region "ebdb") 35 | (declare-function ebdb-read-string "ebdb") 36 | 37 | ;;; USA 38 | 39 | (defvar ebdb-i18n-usa-states 40 | '(("Alabama" . "AL") 41 | ("Alaska" . "AK") 42 | ("American Samoa " . "AS") 43 | ("Arizona" . "AZ") 44 | ("Arkansas" . "AR") 45 | ("California" . "CA") 46 | ("Colorado" . "CO") 47 | ("Connecticut" . "CT") 48 | ("Delaware" . "DE") 49 | ("Dist. of Columbia" . "DC") 50 | ("Florida" . "FL") 51 | ("Georgia" . "GA") 52 | ("Guam" . "GU") 53 | ("Hawaii" . "HI") 54 | ("Idaho" . "ID") 55 | ("Illinois" . "IL") 56 | ("Indiana" . "IN") 57 | ("Iowa" . "IA") 58 | ("Kansas" . "KS") 59 | ("Kentucky" . "KY") 60 | ("Louisiana" . "LA") 61 | ("Maine" . "ME") 62 | ("Maryland" . "MD") 63 | ("Marshall Islands" . "MH") 64 | ("Massachusetts" . "MA") 65 | ("Michigan" . "MI") 66 | ("Micronesia" . "FM") 67 | ("Minnesota" . "MN") 68 | ("Mississippi" . "MS") 69 | ("Missouri" . "MO") 70 | ("Montana" . "MT") 71 | ("Nebraska" . "NE") 72 | ("Nevada" . "NV") 73 | ("New Hampshire" . "NH") 74 | ("New Jersey" . "NJ") 75 | ("New Mexico" . "NM") 76 | ("New York" . "NY") 77 | ("North Carolina" . "NC") 78 | ("North Dakota" . "ND") 79 | ("Northern Marianas" . "MP") 80 | ("Ohio" . "OH") 81 | ("Oklahoma" . "OK") 82 | ("Oregon" . "OR") 83 | ("Palau" . "PW") 84 | ("Pennsylvania" . "PA") 85 | ("Puerto Rico" . "PR") 86 | ("Rhode Island" . "RI") 87 | ("South Carolina" . "SC") 88 | ("South Dakota" . "SD") 89 | ("Tennessee" . "TN") 90 | ("Texas" . "TX") 91 | ("Utah" . "UT") 92 | ("Vermont" . "VT") 93 | ("Virginia" . "VA") 94 | ("Virgin Islands" . "VI") 95 | ("Washington" . "WA") 96 | ("West Virginia" . "WV") 97 | ("Wisconsin" . "WI") 98 | ("Wyoming" . "WY")) 99 | "All the states in the US, for use with completion.") 100 | 101 | (cl-defmethod ebdb-parse-i18n ((_class (subclass ebdb-field-phone)) 102 | (str string) 103 | (_cc (eql 1)) 104 | &optional slots) 105 | "Parse a US phone number. 106 | Uses first three digits as the area code, next seven as the 107 | number, and any remaining as an extension." 108 | (let ((numstr (replace-regexp-in-string "[^[:digit:]]+" "" str))) 109 | (unless (plist-get slots :area-code) 110 | (setq slots 111 | (plist-put slots :area-code 112 | (string-to-number (substring numstr 0 3))) 113 | numstr (substring numstr 3))) 114 | (setq slots (plist-put slots :number (substring numstr 0 7)) 115 | numstr (substring numstr 7)) 116 | (condition-case nil 117 | (setq slots (plist-put 118 | slots 119 | :extension 120 | (when (and (null (string-empty-p numstr)) 121 | (string-match-p "[[:digit:]]+" numstr)) 122 | (string-to-number numstr)))) 123 | (args-out-of-range nil)) 124 | slots)) 125 | 126 | ;; Defined in `ebdb.el' 127 | (defvar ebdb-default-phone-country) 128 | 129 | (cl-defmethod ebdb-string-i18n ((phone ebdb-field-phone) 130 | (_cc (eql 1))) 131 | (with-slots (area-code number extension) phone 132 | (format "%s(%d) %s-%s%s" 133 | (if (eql ebdb-default-phone-country 1) 134 | "" "+1 ") 135 | area-code 136 | (substring number 0 3) 137 | (substring number 3) 138 | (if extension (format "X%d" extension) "")))) 139 | 140 | (cl-defmethod ebdb-read-i18n ((_class (subclass ebdb-field-address)) 141 | (_cc (eql usa)) 142 | &optional slots obj) 143 | (unless (plist-member slots :region) 144 | (setq slots 145 | (plist-put 146 | slots :region 147 | (cdr (assoc-string 148 | (ebdb-read-string 149 | "Address state" 150 | (when obj (rassoc (ebdb-address-region obj) 151 | ebdb-i18n-usa-states)) 152 | ebdb-i18n-usa-states t) 153 | ebdb-i18n-usa-states))))) 154 | slots) 155 | 156 | (cl-defmethod ebdb-parse-i18n ((_class (subclass ebdb-field-address)) 157 | (str string) 158 | (_cc (eql usa)) 159 | &optional slots) 160 | (let ((states (mapcar #'cdr ebdb-i18n-usa-states))) 161 | (unless (plist-member slots :country) 162 | (setq slots (plist-put slots :country 'usa))) 163 | (with-temp-buffer 164 | (insert str) 165 | (when (re-search-backward "[[:digit:]]\\{5\\}\\(?:-[[:digit:]]\\{4\\}\\)?" 166 | nil t) 167 | (setq slots (plist-put slots :postcode (match-string 0)))) 168 | (when (re-search-backward (concat "\\(" (regexp-opt states) "\\)[ ,]+") 169 | (line-beginning-position) t) 170 | (setq slots (plist-put slots :region (match-string 1)))) 171 | (when (re-search-backward "\\(?:^\\|, \\)\\([[:alpha:].-]+ ?[[:alpha:].-]+\\)[ ,]+" 172 | (line-beginning-position) t) 173 | (setq slots (plist-put slots :locality (match-string 1)))) 174 | (setq slots (plist-put slots :streets 175 | (split-string (buffer-substring (point-min) (point)) 176 | "[,\n]" t "[[:blank:]]")))) 177 | slots)) 178 | 179 | ;;; France 180 | 181 | (cl-defmethod ebdb-string-i18n ((phone ebdb-field-phone) 182 | (_cc (eql 33))) 183 | (with-slots (area-code number extension) phone 184 | (concat 185 | (unless (eql ebdb-default-phone-country 33) 186 | "+33 ") 187 | (when area-code 188 | (format "%02d" area-code)) 189 | (apply #'format "%s%s %s%s %s%s %s%s" 190 | (split-string number "" t)) 191 | (when extension 192 | (format "X%d" extension))))) 193 | 194 | ;;; Germany 195 | 196 | (cl-defmethod ebdb-string-i18n ((phone ebdb-field-phone) 197 | (_cc (eql 49))) 198 | "Display a German phone number." 199 | (let ((is-default (eql ebdb-default-phone-country 49)) 200 | num-len) 201 | (with-slots (area-code number extension) phone 202 | (setq num-len (length number)) 203 | (concat 204 | (unless is-default 205 | "+49 ") 206 | (when area-code 207 | (format (if is-default "(%03d) " "%d ") area-code)) 208 | (if (>= 4 num-len) 209 | number 210 | (mapconcat #'identity 211 | (seq-partition number 212 | (if (= 0 (mod num-len 3)) 213 | 3 4)) 214 | " ")) 215 | (when extension 216 | (format "-%d" extension)))))) 217 | 218 | (cl-defmethod ebdb-parse-i18n ((_class (subclass ebdb-field-phone)) 219 | (str string) 220 | (_cc (eql 49)) 221 | &optional slots) 222 | "Parse a German phone number. 223 | Uses first block of digits as the area code, anything following a 224 | hyphen as the extension, and everything in between as the number 225 | itself." 226 | (let ((area-code-regexp "^(?\\([[:digit:]]+\\))? +") 227 | (extension-regexp "-\\([[:digit:]]+\\)\\'")) 228 | (setq slots 229 | (plist-put slots :area-code 230 | (when (string-match area-code-regexp str) 231 | (prog1 232 | (string-to-number (match-string 1 str)) 233 | (setq str (replace-regexp-in-string 234 | area-code-regexp "" str))))) 235 | slots 236 | (plist-put slots :extension 237 | (when (string-match extension-regexp str) 238 | (prog1 239 | (string-to-number (match-string 1 str)) 240 | (setq str (replace-regexp-in-string 241 | extension-regexp "" str)))))) 242 | 243 | (setq slots (plist-put 244 | slots 245 | :number 246 | (replace-regexp-in-string 247 | "[^[:digit:]]" "" str))) 248 | slots)) 249 | 250 | (defvar ebdb-i18n-german-states 251 | '(("Baden-Württemberg" . "BW") 252 | ("Bayern" . "BY") 253 | ("Berlin" . "BE") 254 | ("Brandenburg" . "BB") 255 | ("Bremen" . "HB") 256 | ("Hamburg" . "HH") 257 | ("Hessen" . "HE") 258 | ("Mecklenburg-Vorpommern" . "MV") 259 | ("Niedersachsen" . "NI") 260 | ("Nordrhein-Westfalen" . "NW") 261 | ("Rheinland-Pfalz" . "RP") 262 | ("Saarland" . "SL") 263 | ("Sachsen" . "SN") 264 | ("Sachsen-Anhalt" . "ST") 265 | ("Schleswig-Holstein" . "SH") 266 | ("Thüringen" . "TH")) 267 | "All the states in Germany, for use with completion.") 268 | 269 | (cl-defmethod ebdb-read-i18n ((_class (subclass ebdb-field-address)) 270 | (_cc (eql deu)) 271 | &optional slots obj) 272 | (unless (plist-member slots :region) 273 | (let ((state (ebdb-with-exit 274 | (ebdb-read-string 275 | "State" 276 | (when obj (ebdb-address-region obj)) 277 | ebdb-i18n-german-states t)))) 278 | (setq slots 279 | (plist-put 280 | slots :region 281 | (if state 282 | (cdr (assoc-string state ebdb-i18n-german-states)) 283 | ""))))) 284 | slots) 285 | 286 | (cl-defmethod ebdb-string-i18n ((address ebdb-field-address) 287 | (_cc (eql deu))) 288 | (with-slots (streets neighborhood locality region postcode) address 289 | (concat 290 | (when streets 291 | (concat (mapconcat #'identity streets "\n") "\n")) 292 | (when postcode 293 | (format "%s " postcode)) 294 | locality 295 | "\n" 296 | (car-safe (rassq 'deu (ebdb-i18n-countries)))))) 297 | 298 | ;;; India 299 | 300 | (defvar ebdb-i18n-india-states 301 | '("Andhra Pradesh" 302 | "Arunachal Pradesh" 303 | "Assam" 304 | "Bihar" 305 | "Chhattisgarh" 306 | "Goa" 307 | "Gujarat" 308 | "Haryana" 309 | "Himachal Pradesh" 310 | "Jammu and Kashmir" 311 | "Jharkhand" 312 | "Karnataka" 313 | "Kerala" 314 | "Madhya Pradesh" 315 | "Maharashtra" 316 | "Manipur" 317 | "Meghalaya" 318 | "Mizoram" 319 | "Nagaland" 320 | "Odisha" 321 | "Punjab" 322 | "Rajasthan" 323 | "Sikkim" 324 | "Tamil Nadu" 325 | "Telangana" 326 | "Tripura" 327 | "Uttar Pradesh" 328 | "Uttarakhand" 329 | "West Bengal") 330 | "A list of states in India, for completion.") 331 | 332 | (cl-defmethod ebdb-read-i18n ((_class (subclass ebdb-field-address)) 333 | (_cc (eql ind)) 334 | &optional slots obj) 335 | (unless (plist-member slots :region) 336 | (setq slots 337 | (plist-put 338 | slots :region 339 | (cdr (assoc-string 340 | (ebdb-read-string 341 | "State" 342 | (when obj (ebdb-address-region obj)) 343 | ebdb-i18n-india-states t) 344 | ebdb-i18n-india-states))))) 345 | slots) 346 | 347 | ;;; Russia 348 | 349 | (cl-defmethod ebdb-string-i18n ((phone ebdb-field-phone) 350 | (_cc (eql 8))) 351 | (with-slots (area-code number extension) phone 352 | (concat 353 | (unless (eql ebdb-default-phone-country 8) 354 | "+8 ") 355 | (when area-code (format "%d " area-code)) 356 | (apply #'format 357 | (cl-case (length number) 358 | (5 "%s-%s%s-%s%s") 359 | (6 "%s%s-%s%s-%s%s") 360 | (7 "%s%s%s-%s%s-%s%s")) 361 | (split-string number "" t)) 362 | (when extension (format " X%s" extension))))) 363 | 364 | ;;; Singapore 365 | 366 | (cl-defmethod ebdb-read-i18n ((_cls (subclass ebdb-field-address)) 367 | (_cc (eql sgp)) 368 | &optional slots _obj) 369 | "Singapore doesn't have localities, cities, or neighborhoods." 370 | (setq slots (plist-put slots :locality "") 371 | slots (plist-put slots :neighborhood "") 372 | slots (plist-put slots :region "")) 373 | slots) 374 | 375 | (provide 'ebdb-i18n-basic) 376 | ;;; ebdb-i18n-basic.el ends here 377 | -------------------------------------------------------------------------------- /ebdb-i18n-test.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-i18n-test.el --- Tests for EBDB's internationalization support -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2017-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; This file obviously depends on ebdb-i18n and all region-specific 23 | ;; files that come with EBDB, and if you run the tests in an 24 | ;; interactive session it will load those files. If you had EBDB 25 | ;; running as a normal user, loading these tests might change EBDB's 26 | ;; behavior. 27 | 28 | ;;; Code: 29 | 30 | (require 'ert) 31 | (require 'ebdb-i18n) 32 | 33 | ;; Basic name parsing. 34 | 35 | ;; Regular latin names shouldn't be parsed any differently with the 36 | ;; i18n files loaded. 37 | 38 | (ert-deftest ebdb-i18n-parse-name () 39 | (let ((max (ebdb-parse 'ebdb-field-name-complex "Max von Sydow")) 40 | (brigitte (ebdb-parse 'ebdb-field-name-complex "Brigitte Bardot"))) 41 | (should (string= (ebdb-name-last max) "von Sydow")) 42 | (should (string= (ebdb-name-last brigitte) "Bardot")))) 43 | 44 | (ert-deftest ebdb-i18n-parse-unhandled-name () 45 | "Parse a name for which there is no `ebdb-i18n-parse' method 46 | defined. 47 | 48 | This should fall back to the regular `ebdb-parse' method." 49 | ;; At present there's nothing defined for Arabic, update as 50 | ;; necessary. I think this is only a surname, anyhow, I just copied 51 | ;; something off the internet. 52 | (let ((arabic-name "عامر")) 53 | (should (eieio-object-p 54 | (ebdb-parse 'ebdb-field-name-complex arabic-name))))) 55 | 56 | ;; Sanity tests for other fields. 57 | (ert-deftest ebdb-i18n-parse-unhandled-phone () 58 | "Parse a phone number for which no `ebdb-i18n-parse' method is 59 | defined." 60 | ;; There is currently no USA-specific phone parsing method, so this 61 | ;; should fall back to the default. 62 | (let ((phone-str "+1 (206) 555-5555")) 63 | (should (equal (slot-value 64 | (ebdb-parse 'ebdb-field-phone phone-str) 65 | 'area-code) 66 | 206)))) 67 | 68 | (provide 'ebdb-i18n-test) 69 | ;;; ebdb-i18n-test.el ends here 70 | -------------------------------------------------------------------------------- /ebdb-ispell.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-ispell.el --- Add EBDB contact names to personal dictionaries -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Copied from bbdb-ispell.el, originally written by Ivan Kanis. 23 | 24 | ;;; Code: 25 | 26 | (require 'ispell) 27 | (require 'ebdb) 28 | 29 | (defcustom ebdb-ispell-min-word-length 2 30 | "Words with fewer characters are ignored." 31 | :group 'ebdb-utilities-ispell 32 | :type 'number) 33 | 34 | (defcustom ebdb-ispell-ignore-re "[^[:alpha:]]" 35 | "Words matching this regexp are ignored." 36 | :group 'ebdb-utilities-ispell 37 | :type 'regexp) 38 | 39 | ;;;###autoload 40 | (defun ebdb-ispell-export () 41 | "Export EBDB records to ispell personal dictionaries." 42 | (interactive) 43 | (message "Exporting 0 words to personal dictionary...") 44 | ;; Collect words from EBDB records. 45 | (let ((word-list 46 | (seq-mapcat 47 | (lambda (r) 48 | (ebdb-ispell-collect-words 49 | (cons (ebdb-record-name-string r) 50 | (ebdb-record-alt-names r)))) 51 | (ebdb-records))) 52 | (count 0)) 53 | 54 | ;; Initialize variables and dicts alists 55 | (ispell-set-spellchecker-params) 56 | (ispell-init-process) 57 | ;; put in verbose mode 58 | (ispell-send-string "%\n") 59 | (let (new) 60 | (dolist (word (delete-dups word-list)) 61 | (ispell-send-string (concat "^" word "\n")) 62 | (while (progn 63 | (ispell-accept-output) 64 | (not (string= "" (car ispell-filter))))) 65 | ;; remove extra \n 66 | (setq ispell-filter (cdr ispell-filter)) 67 | (when (and ispell-filter 68 | (listp ispell-filter) 69 | (not (eq (ispell-parse-output (car ispell-filter)) t))) 70 | ;; ok the word doesn't exist, add it 71 | (ispell-send-string (concat "*" word "\n")) 72 | (message "Exporting %d words to personal dictionary..." 73 | (cl-incf count)) 74 | (setq new t))) 75 | (when new 76 | ;; Save dictionary: 77 | ;; aspell doesn't tell us when it completed the saving. 78 | ;; So we send it another word for spellchecking. 79 | (ispell-send-string "#\n^hello\n") 80 | (while (progn 81 | (ispell-accept-output) 82 | (not (string= "" (car ispell-filter))))))) 83 | (message "Exporting %d words to personal dictionary...done" count))) 84 | 85 | (defun ebdb-ispell-collect-words (strings) 86 | "Find all individual words in STRINGS and filter. 87 | Removes strings that are too short 88 | \(`ebdb-ispell-min-word-length') or explicitly ignored 89 | \(`ebdb-ispell-ignore-re')." 90 | (seq-filter 91 | (lambda (word) 92 | (and (>= (length word) ebdb-ispell-min-word-length) 93 | (not (string-match ebdb-ispell-ignore-re word)))) 94 | (seq-mapcat 95 | (lambda (s) 96 | (split-string s "[ ,]")) 97 | strings))) 98 | 99 | (provide 'ebdb-ispell) 100 | ;;; ebdb-ispell.el ends here 101 | -------------------------------------------------------------------------------- /ebdb-latex.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-latex.el --- LaTex formatting routines for EBDB -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2018-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | ;; Maintainer: Eric Abrahamsen 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; This file contains routines for formatting EBDB records as LaTeX. 24 | 25 | ;;; Code: 26 | 27 | (require 'ebdb-format) 28 | 29 | (defgroup ebdb-latex nil 30 | "Options for EBDB and LaTeX." 31 | :group 'ebdb) 32 | 33 | (defclass ebdb-latex-formatter (ebdb-formatter) 34 | ((post-format-function :initform #'latex-mode)) 35 | :abstract t 36 | :documentation "") 37 | 38 | (cl-defmethod ebdb-fmt-field ((_fmt ebdb-latex-formatter) 39 | (field ebdb-field-mail) 40 | _style 41 | (_rec ebdb-record)) 42 | (with-slots (mail aka) field 43 | (format "\\href{mailto:%s}{%s}" mail (or aka mail)))) 44 | 45 | (defclass ebdb-latex-formatter-tabular (ebdb-latex-formatter 46 | ebdb-formatter-tabular) 47 | ((record-separator :initform " \\\\\n") 48 | (field-separator :initform " & ") 49 | (table-environment :initform "tabular") 50 | (table-spec 51 | :type (or string null) 52 | :initarg :table-spec 53 | :initform nil))) 54 | 55 | (cl-defmethod ebdb-fmt-field ((_fmt ebdb-latex-formatter-tabular) 56 | (_field ebdb-field) 57 | _style 58 | (_rec ebdb-record)) 59 | "Escape column separators in field strings." 60 | (replace-regexp-in-string "\\([^\\]\\)&" "\\1\\\\&" 61 | (cl-call-next-method))) 62 | 63 | (cl-defmethod ebdb-fmt-header ((fmt ebdb-latex-formatter-tabular) 64 | _recs) 65 | (with-slots (table-environment table-spec) fmt 66 | (concat (format "\\begin{%s}" table-environment) 67 | (when table-spec 68 | (format "%s" table-spec)) 69 | "\n"))) 70 | 71 | (cl-defmethod ebdb-fmt-footer ((fmt ebdb-latex-formatter-tabular) 72 | _recs) 73 | (with-slots (table-environment) fmt 74 | (format "\\end{%s}" table-environment))) 75 | 76 | (defcustom ebdb-latex-default-tabular-formatter 77 | (make-instance 'ebdb-latex-formatter-tabular 78 | :label "latex table" 79 | :fields '(mail-primary)) 80 | "Default LaTeX tabular formatter." 81 | :type 'ebdb-formatter-tabular) 82 | 83 | (provide 'ebdb-latex) 84 | ;;; ebdb-latex.el ends here 85 | -------------------------------------------------------------------------------- /ebdb-message.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-message.el --- EBDB interface to mail composition packages -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Code for interaction with message composition and sending packages. 23 | 24 | ;;; Code: 25 | 26 | 27 | (require 'ebdb-mua) 28 | (require 'ebdb-com) 29 | (require 'message) 30 | (require 'sendmail) 31 | 32 | (defvar gnus-window-to-buffer) 33 | 34 | (defgroup ebdb-mua-message nil 35 | "Message-specific EBDB customizations" 36 | :group 'ebdb-mua) 37 | (put 'ebdb-mua-message 'custom-loads '(ebdb-message)) 38 | 39 | (defcustom ebdb-message-auto-update-p ebdb-mua-sender-update-p 40 | "Message-specific value of `ebdb-mua-auto-update-p'." 41 | :type '(choice (const :tag "do nothing" nil) 42 | (const :tag "search for existing records" existing) 43 | (const :tag "update existing records" update) 44 | (const :tag "query for update or record creation" query) 45 | (const :tag "update or create automatically" create) 46 | (function :tag "User-defined function"))) 47 | 48 | (defcustom ebdb-message-window-size ebdb-default-window-size 49 | "Size of the EBDB buffer when popping up in message-mode. 50 | Size should be specified as a float between 0 and 1. Defaults to 51 | the value of `ebdb-default-window-size'." 52 | :type 'float) 53 | 54 | (defcustom ebdb-message-window-configuration nil 55 | "Symbol that names EBDB's Message reply window config. 56 | This option is nil by default, meaning Gnus will pop up the 57 | *EBDB-Message* buffer next to the message composition buffer, 58 | with width/height of `ebdb-message-window-size'. 59 | 60 | If more control is required, set this to a symbol name. This 61 | symbol will be entered into the `gnus-window-to-buffer' alist, 62 | and can be used as an entry in more complex Gnus buffer/window 63 | configurations. 64 | 65 | Note that this should be a different symbol from that used in 66 | Gnus's article-reading config." 67 | :type '(choice (const nil) 68 | (symbol :tag "Window config name"))) 69 | 70 | (make-obsolete-variable 'ebdb-message-reply-yank-window-config 71 | 'ebdb-message-window-configuration 72 | "0.6.23") 73 | 74 | ;; Suggestions welcome: What are good keybindings for the following 75 | ;; commands that do not collide with existing bindings? 76 | ;; (define-key message-mode-map "'" 'ebdb-mua-display-recipients) 77 | ;; (define-key message-mode-map ";" 'ebdb-mua-edit-field-recipients) 78 | ;; (define-key message-mode-map "/" 'ebdb) 79 | 80 | (defsubst ebdb-message-buffer-name () 81 | (format "*%s-Message*" ebdb-buffer-name)) 82 | 83 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode message-mode)) 84 | "Produce a EBDB buffer name associated with Message mode." 85 | (ebdb-message-buffer-name)) 86 | 87 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode mail-mode)) 88 | "Produce a EBDB buffer name associated with Mail mode." 89 | (ebdb-message-buffer-name)) 90 | 91 | (cl-defmethod ebdb-mua-message-header ((header string) 92 | &context (major-mode message-mode)) 93 | (message-field-value header)) 94 | 95 | (cl-defmethod ebdb-mua-message-header ((header string) 96 | &context (major-mode notmuch-message-mode)) 97 | (message-field-value header)) 98 | 99 | (cl-defmethod ebdb-mua-message-header ((header string) 100 | &context (major-mode mail-mode)) 101 | (message-field-value header)) 102 | 103 | (cl-defmethod ebdb-popup-window (&context (major-mode message-mode)) 104 | (list (get-buffer-window) ebdb-message-window-size)) 105 | 106 | (cl-defmethod ebdb-popup-window (&context (major-mode mail-mode)) 107 | (list (get-buffer-window) ebdb-message-window-size)) 108 | 109 | (defun ebdb-message-complete-mail-cleanup (str _buffer pos &rest _) 110 | "Call `ebdb-complete-mail-cleanup' after capf completion." 111 | (ebdb-complete-mail-cleanup str pos)) 112 | 113 | (defun ebdb-message-quit-ebdb () 114 | "Remove the EBDB window if the user kills the message buffer. 115 | Also fires when postponing a draft." 116 | (let ((win (get-buffer-window (ebdb-message-buffer-name)))) 117 | (when win 118 | (quit-window nil win)))) 119 | 120 | (defun ebdb-insinuate-message () 121 | ;; We don't currently bind the `ebdb-mua-keymap'. 122 | (unless ebdb-db-list 123 | (ebdb-load)) 124 | (pcase ebdb-complete-mail 125 | ('capf (progn (add-hook 126 | 'completion-at-point-functions 127 | #'ebdb-mail-dwim-completion-at-point-function nil t) 128 | ;; Kind of hacky way of mimicking 129 | ;; `ebdb-complete-mail' behavior, but for capf. 130 | (add-hook 131 | 'choose-completion-string-functions 132 | #'ebdb-message-complete-mail-cleanup 133 | nil t))) 134 | ('nil nil) 135 | (_ 136 | (cl-pushnew '("^\\(Resent-\\)?\\(To\\|B?Cc\\|Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):" . ebdb-complete-mail) 137 | message-completion-alist 138 | :test #'equal))) 139 | 140 | (when ebdb-message-window-configuration 141 | (add-to-list 'gnus-window-to-buffer 142 | (cons ebdb-message-window-configuration 143 | (ebdb-message-buffer-name)))) 144 | (message-add-action 145 | #'ebdb-message-quit-ebdb 'exit 'postpone 'kill) 146 | ;; Other MUAs clear the EBDB buffer before displaying (in 147 | ;; `ebdb-mua-auto-update', the call to `ebdb-display-records' does 148 | ;; not pass the "append" flag). Displaying in message-mode does 149 | ;; pass the "append" flag (in `ebdb-complete-mail-cleanup'), so we 150 | ;; do the undisplay manually. 151 | (ebdb-undisplay-records)) 152 | 153 | ;;;###autoload 154 | (defun ebdb-insinuate-mail () 155 | "Hook EBDB into Mail Mode." 156 | ;; We don't currently bind the `ebdb-mua-keymap'. 157 | (unless ebdb-db-list 158 | (ebdb-load)) 159 | (pcase ebdb-complete-mail 160 | ('capf (progn (add-hook 161 | 'completion-at-point-functions 162 | #'ebdb-mail-dwim-completion-at-point-function nil t) 163 | ;; See above. 164 | (add-hook 165 | 'choose-completion-string-functions 166 | #'ebdb-message-complete-mail-cleanup 167 | nil t))) 168 | ('nil nil) 169 | (_ (define-key mail-mode-map "\M-\t" #'ebdb-complete-mail))) 170 | 171 | (when ebdb-message-window-configuration 172 | (add-to-list 'gnus-window-to-buffer 173 | (cons ebdb-message-window-configuration 174 | (ebdb-message-buffer-name)))) 175 | 176 | (ebdb-undisplay-records)) 177 | 178 | ;;;###autoload 179 | (defun ebdb-message-auto-update () 180 | (ebdb-mua-auto-update ebdb-message-auto-update-p)) 181 | 182 | (defun ebdb-message-display-only () 183 | (ebdb-mua-auto-update 'existing)) 184 | 185 | (add-hook 'message-mode-hook #'ebdb-insinuate-message) 186 | (add-hook 'mail-setup-hook #'ebdb-insinuate-mail) 187 | (add-hook 'message-send-hook #'ebdb-message-auto-update) 188 | (add-hook 'mail-send-hook #'ebdb-message-auto-update) 189 | 190 | (provide 'ebdb-message) 191 | ;;; ebdb-message.el ends here 192 | -------------------------------------------------------------------------------- /ebdb-mhe.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-mhe.el --- EBDB interface to mh-e -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; This program is free software; you can redistribute it and/or modify 6 | ;; it under the terms of the GNU General Public License as published by 7 | ;; the Free Software Foundation, either version 3 of the License, or 8 | ;; (at your option) any later version. 9 | 10 | ;; This program is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;; GNU General Public License for more details. 14 | 15 | ;; You should have received a copy of the GNU General Public License 16 | ;; along with this program. If not, see . 17 | 18 | ;;; Commentary: 19 | 20 | ;; EBDB interface to mh-e. This was copied from the file bbdb-mhe.el, 21 | ;; written by Todd Kaufman with contributions from Fritz Knabe and 22 | ;; Jack Repenning. 23 | 24 | ;;; Code: 25 | 26 | (require 'ebdb-com) 27 | (require 'ebdb-mua) 28 | (require 'mh-e) 29 | (if (fboundp 'mh-version) 30 | (require 'mh-comp)) ; For mh-e 4.x 31 | 32 | (defgroup ebdb-mua-mhe nil 33 | "EBDB customizations for mhe." 34 | :group 'ebdb-mua) 35 | 36 | (defcustom ebdb-mhe-auto-update-p ebdb-mua-reader-update-p 37 | "Mh-e-specific value of `ebdb-mua-auto-update-p'." 38 | :type '(choice (const :tag "do nothing" nil) 39 | (const :tag "search for existing records" existing) 40 | (const :tag "update existing records" update) 41 | (const :tag "query for update or record creation" query) 42 | (const :tag "update or create automatically" create) 43 | (function :tag "User-defined function"))) 44 | 45 | (defcustom ebdb-mhe-window-size ebdb-default-window-size 46 | "Size of the EBDB buffer when popping up in mh-e. 47 | Size should be specified as a float between 0 and 1. Defaults to 48 | the value of `ebdb-default-window-size'." 49 | :type 'float) 50 | 51 | ;; A simplified `mail-fetch-field'. We could use instead (like rmail): 52 | ;; (mail-header (intern-soft (downcase header)) (mail-header-extract)) 53 | (defun ebdb/mh-header (header) 54 | "Find and return the value of HEADER in the current buffer. 55 | Returns the empty string if HEADER is not in the message." 56 | (let ((case-fold-search t)) 57 | (if mh-show-buffer (set-buffer mh-show-buffer)) 58 | (goto-char (point-min)) 59 | ;; This will be fooled if HEADER appears in the body of the message. 60 | ;; Also, it fails if HEADER appears more than once. 61 | (cond ((not (re-search-forward header nil t)) "") 62 | ((looking-at "[\t ]*$") "") 63 | (t (re-search-forward "[ \t]*\\([^ \t\n].*\\)$" nil t) 64 | (let ((start (match-beginning 1))) 65 | (while (progn (forward-line 1) 66 | (looking-at "[ \t]"))) 67 | (backward-char 1) 68 | (buffer-substring-no-properties start (point))))))) 69 | 70 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode mhe-mode)) 71 | "Produce a EBDB buffer name associated with mh-hmode." 72 | (format "*%s-MHE*" ebdb-buffer-name)) 73 | 74 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode mhe-summary-mode)) 75 | "Produce a EBDB buffer name associated with mh-hmode." 76 | (format "*%s-MHE*" ebdb-buffer-name)) 77 | 78 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode mhe-folder-mode)) 79 | "Produce a EBDB buffer name associated with mh-hmode." 80 | (format "*%s-MHE*" ebdb-buffer-name)) 81 | 82 | (cl-defmethod ebdb-popup-buffer (&context (major-mode mhe-summary-mode)) 83 | (list (get-buffer-window) ebdb-mhe-window-size)) 84 | 85 | (cl-defmethod ebdb-mua-message-header ((header string) 86 | &context (major-mode mhe-mode)) 87 | (ebdb/mh-header header)) 88 | 89 | (cl-defmethod ebdb-mua-message-header ((header string) 90 | &context (major-mode mhe-summary-mode)) 91 | (ebdb/mh-header header)) 92 | 93 | (cl-defmethod ebdb-mua-message-header ((header string) 94 | &context (major-mode mhe-folder-mode)) 95 | (ebdb/mh-header header)) 96 | 97 | (cl-defmethod ebdb-mua-prepare-article (&context (major-mode mhe-mode)) 98 | (mh-show)) 99 | 100 | (cl-defmethod ebdb-mua-prepare-article (&context (major-mode mhe-summary-mode)) 101 | (mh-show)) 102 | 103 | (cl-defmethod ebdb-mua-prepare-article (&context (major-mode mhe-folder-mode)) 104 | (mh-show)) 105 | 106 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 107 | ;; Use EBDB for interactive spec of MH-E commands 108 | 109 | (advice-add 'mh-send :before #'ebdb--mh-send-completion) 110 | (defun ebdb--mh-send-completion (&rest _) 111 | (interactive 112 | (list (ebdb-completing-read-mails "To: ") 113 | (ebdb-completing-read-mails "Cc: ") 114 | (read-string "Subject: "))) 115 | nil) 116 | 117 | (advice-add 'mh-send-other-window :before #'ebdb--mh-send-completion) 118 | 119 | (advice-add 'mh-forward :before #'ebdb--mh-forward-completion) 120 | (defun ebdb--mh-forward-completion (&rest _) 121 | (interactive 122 | (list (ebdb-completing-read-mails "To: ") 123 | (ebdb-completing-read-mails "Cc: ") 124 | (if current-prefix-arg 125 | (mh-read-seq-default "Forward" t) 126 | (mh-get-msg-num t)))) 127 | nil) 128 | 129 | (advice-add 'mh-redistribute :before #'ebdb--mh-redistribute-completion) 130 | (defun ebdb--mh-redistribute-completion (&rest _) 131 | (interactive 132 | (list (ebdb-completing-read-mails "Redist-To: ") 133 | (ebdb-completing-read-mails "Redist-Cc: ") 134 | (mh-get-msg-num t))) 135 | nil) 136 | 137 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 138 | 139 | ;;;###autoload 140 | (defun ebdb-insinuate-mh () 141 | "Hook EBDB into MH-E." 142 | (unless ebdb-db-list 143 | (ebdb-load)) 144 | (define-key mh-folder-mode-map ";" ebdb-mua-keymap) 145 | (when ebdb-complete-mail 146 | (define-key mh-letter-mode-map "\M-;" #'ebdb-complete-mail) 147 | (define-key mh-letter-mode-map "\e\t" #'ebdb-complete-mail))) 148 | 149 | ;;;###autoload 150 | (defun ebdb-mhe-auto-update () 151 | (ebdb-mua-auto-update ebdb-mhe-auto-update-p)) 152 | 153 | (add-hook 'mh-show-hook #'ebdb-mhe-auto-update) 154 | 155 | (add-hook 'mh-folder-mode-hook #'ebdb-insinuate-mh) 156 | 157 | (provide 'ebdb-mhe) 158 | ;;; ebdb-mhe.el ends here 159 | -------------------------------------------------------------------------------- /ebdb-mu4e.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-mu4e.el --- EBDB interface for mu4e -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; EBDB interface to mu4e. This file was copied from bbdb-mu4e.el, 23 | ;; originally written by David Sterratt. 24 | 25 | ;;; Code: 26 | 27 | (require 'ebdb-mua) 28 | (require 'ebdb-message) 29 | (if t (require 'mu4e-view)) 30 | 31 | (defvar mu4e~view-buffer-name) 32 | (defvar mu4e-view-mode-map) 33 | (declare-function message-field-value "message") 34 | 35 | (defgroup ebdb-mua-mu4e nil 36 | "Mu4e-specific EBDB customizations." 37 | :group 'ebdb-mua) 38 | 39 | (defcustom ebdb-mu4e-auto-update-p ebdb-mua-reader-update-p 40 | "Mu4e-specific value of `ebdb-mua-auto-update-p'." 41 | :type '(choice (const :tag "do nothing" nil) 42 | (const :tag "search for existing records" existing) 43 | (const :tag "update existing records" update) 44 | (const :tag "query for update or record creation" query) 45 | (const :tag "update or create automatically" create) 46 | (function :tag "User-defined function"))) 47 | 48 | (defcustom ebdb-mu4e-window-size ebdb-default-window-size 49 | "Size of the EBDB buffer when popping up in mu4e. 50 | Size should be specified as a float between 0 and 1. Defaults to 51 | the value of `ebdb-default-window-size'." 52 | :type 'float) 53 | 54 | ;; Tackle `mu4e-headers-mode' later 55 | 56 | (cl-defmethod ebdb-mua-message-header ((header string) 57 | &context (major-mode mu4e-view-mode)) 58 | (set-buffer (if (bound-and-true-p mu4e-view-use-old) 59 | mu4e~view-buffer-name 60 | gnus-article-buffer)) 61 | (message-field-value header)) 62 | 63 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode mu4e-view-mode)) 64 | "Produce a EBDB buffer name associated with mu4e mode." 65 | (format "*%s-mu4e*" ebdb-buffer-name)) 66 | 67 | (cl-defmethod ebdb-popup-window (&context (major-mode mu4e-view-mode)) 68 | (list (get-buffer-window) ebdb-mu4e-window-size)) 69 | 70 | ;;;###autoload 71 | (defun ebdb-insinuate-mu4e () 72 | "Hook EBDB into mu4e." 73 | ;; Tackle headers later 74 | (unless ebdb-db-list 75 | (ebdb-load)) 76 | (define-key mu4e-view-mode-map ";" ebdb-mua-keymap) 77 | (add-hook 'message-sent-hook 78 | (lambda () 79 | (let ((win (get-buffer-window (ebdb-message-buffer-name)))) 80 | (when (and win 81 | (window-live-p win)) 82 | (quit-window nil win)))))) 83 | 84 | ;; Why wasn't `ebdb-mua-auto-update' ever hooked in to mu4e? 85 | 86 | (add-hook 'mu4e-main-mode-hook #'ebdb-insinuate-mu4e) 87 | 88 | (provide 'ebdb-mu4e) 89 | ;;; ebdb-mu4e.el ends here 90 | -------------------------------------------------------------------------------- /ebdb-notmuch.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-notmuch.el --- EBDB interface to Notmuch -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2019-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | ;; Maintainer: Eric Abrahamsen 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; EBDB's interface to the Notmuch mail client. 24 | 25 | ;;; Code: 26 | 27 | (require 'ebdb-mua) 28 | 29 | (declare-function notmuch-show-get-header "notmuch-show") 30 | (defvar notmuch-show-mode-map) 31 | (defvar notmuch-message-mode-map) 32 | 33 | (defgroup ebdb-mua-notmuch nil 34 | "Options for EBDB's interaction with Notmuch" 35 | :group 'ebdb-mua) 36 | 37 | (defcustom ebdb-notmuch-auto-update-p ebdb-mua-reader-update-p 38 | "Notmuch-specific value of `ebdb-mua-auto-update-p'." 39 | :type '(choice (const :tag "do nothing" nil) 40 | (const :tag "search for existing records" existing) 41 | (const :tag "update existing records" update) 42 | (const :tag "query for update or record creation" query) 43 | (const :tag "update or create automatically" create) 44 | (function :tag "User-defined function"))) 45 | 46 | (defcustom ebdb-notmuch-window-size ebdb-default-window-size 47 | "Size of the EBDB buffer when popping up in Notmuch. 48 | Size should be specified as a float between 0 and 1. Defaults to 49 | the value of `ebdb-default-window-size'." 50 | :type 'float) 51 | 52 | (cl-defmethod ebdb-mua-message-header ((header string) 53 | &context (major-mode notmuch-show-mode)) 54 | "Extract a message header in Notmuch." 55 | (notmuch-show-get-header 56 | ;; Yuck, is there no better way to turn a string into a keyword? 57 | (intern (format ":%s" (capitalize header))))) 58 | 59 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode notmuch-show-mode)) 60 | (format "*%s-Notmuch*" ebdb-buffer-name)) 61 | 62 | (cl-defmethod ebdb-popup-window (&context (major-mode notmuch-show-mode)) 63 | (list (get-buffer-window) ebdb-notmuch-window-size)) 64 | 65 | ;;;###autoload 66 | (defun ebdb-insinuate-notmuch-show () 67 | "Hook EBDB into Notmuch's `notmuch-show-mode'." 68 | (unless ebdb-db-list 69 | (ebdb-load)) 70 | (define-key notmuch-show-mode-map ";" ebdb-mua-keymap)) 71 | 72 | ;;;###autoload 73 | (defun ebdb-insinuate-notmuch-message () 74 | "Hook EBDB into Notmuch's `notmuch-message-mode'." 75 | (unless ebdb-db-list 76 | (ebdb-load)) 77 | (when ebdb-complete-mail 78 | (define-key notmuch-message-mode-map (kbd "TAB") #'ebdb-complete-mail))) 79 | 80 | (add-hook 'notmuch-show-mode-hook #'ebdb-insinuate-notmuch-show) 81 | (add-hook 'notmuch-message-mode-hook #'ebdb-insinuate-notmuch-message) 82 | 83 | (provide 'ebdb-notmuch) 84 | ;;; ebdb-notmuch.el ends here 85 | -------------------------------------------------------------------------------- /ebdb-org.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-org.el --- Org mode integration for EBDB -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | ;; Keywords: 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; Org mode integration for EBDB. At present this just defines a link 24 | ;; type; at some point we'll reproduce the Agenda anniversary 25 | ;; mechanisms from org-bbdb.el. 26 | 27 | ;; EBDB links can come in several varieties. A plain string is 28 | ;; matched against record names in the database. Otherwise, the 29 | ;; string can be prefixed with a field type, to search only on those 30 | ;; field values. The prefix is separated with a forward slash. 31 | ;; Examples: 32 | 33 | ;; 1. "ebdb:uuid/af1373d6-4ba1-46a7-aa4b-845db01bc2ab" (link to unique 34 | ;; record) 35 | 36 | ;; 2. "ebdb:mail/google.com" (all records with google.com email 37 | ;; addresses). These field name "shorthands" include "uuid", "mail", 38 | ;; "phone", "address", "notes", and "tags" (this last for the 39 | ;; `ebdb-org-field-tags' class defined in this file). 40 | 41 | ;; 3. "ebdb:ebdb-field-foobar/baz" (search on a particular field 42 | ;; class) 43 | 44 | ;; Valid prefixes include all the values accepted by 45 | ;; `ebdb-record-field', as well as the names of field classes. 46 | 47 | ;; When calling `org-store-link' on a contact, a "ebdb:uuid/" style 48 | ;; link is created by default. 49 | 50 | ;; This file also defines a "tags" field class, for tagging EBDB 51 | ;; contacts with Org tags. 52 | 53 | ;;; Code: 54 | 55 | (require 'ebdb-com) 56 | (require 'ebdb-format) 57 | (require 'org) 58 | (require 'org-agenda) 59 | 60 | (defgroup ebdb-org nil 61 | "Custom group for EBDB Org options." 62 | :group 'ebdb) 63 | 64 | (if (fboundp 'org-link-set-parameters) 65 | (org-link-set-parameters "ebdb" 66 | :follow 'ebdb-org-open 67 | :complete (lambda () 68 | (format 69 | "ebdb:uuid/%s" 70 | (ebdb-record-uuid (ebdb-prompt-for-record (ebdb-records))))) 71 | :store 'ebdb-org-store-link 72 | :export 'ebdb-org-export) 73 | (with-no-warnings ;; I know it's obsolete. 74 | (org-add-link-type "ebdb" #'ebdb-org-open #'ebdb-org-export) 75 | (add-hook 'org-store-link-functions #'ebdb-org-store-link))) 76 | 77 | ;; TODO: Put a custom keymap on the links (or else expand 78 | ;; `ebdb-org-open') so that users can choose what to do with the 79 | ;; linked record: display, email, etc. 80 | 81 | (defun ebdb-org-store-link () 82 | "Store a link to an EBDB contact." 83 | (when (eq major-mode 'ebdb-mode) 84 | (let* ((rec (ebdb-current-record)) 85 | (uuid (ebdb-record-uuid rec)) 86 | (name (ebdb-record-name-string rec)) 87 | (link (format "ebdb:uuid/%s" uuid))) 88 | (with-no-warnings 89 | (funcall (if (fboundp 'org-link-store-props) 90 | #'org-link-store-props 91 | #'org-store-link-props) 92 | :type "ebdb" :name name 93 | :link link :description name)) 94 | link))) 95 | 96 | (defun ebdb-org-open (link) 97 | "Follow a EBDB link." 98 | (let ((records (ebdb-org-retrieve link))) 99 | (if records 100 | (ebdb-display-records records nil nil nil (ebdb-popup-window)) 101 | (message "No records found")))) 102 | 103 | (defun ebdb-org-retrieve (link) 104 | (pcase (split-string link "/" t) 105 | (`("uuid" ,key) (list (ebdb-gethash key 'uuid))) 106 | (`(,key) (ebdb-search (ebdb-records) `((ebdb-field-name ,key)))) 107 | (`("mail" ,key) (ebdb-search (ebdb-records) `((ebdb-field-mail ,key)))) 108 | (`("phone" ,key) (ebdb-search (ebdb-records) `((ebdb-field-phone ,key)))) 109 | (`("address" ,key) (ebdb-search (ebdb-records) `((ebdb-field-address ,key)))) 110 | (`("notes" ,key) (ebdb-search (ebdb-records) `((ebdb-field-notes ,key)))) 111 | (`("tags" ,key) (ebdb-search (ebdb-records) `((ebdb-field-tags ,key)))) 112 | (`(,(and field 113 | (let field-sym (intern-soft field)) 114 | (and field-sym 115 | (guard (child-of-class-p field-sym 'ebdb-field)))) 116 | ,key) 117 | (ebdb-search (ebdb-records) `((,field-sym ,key)))) 118 | (`(,other _) (error "Unknown field search prefix: %s" other)))) 119 | 120 | (defun ebdb-org-export (path desc format) 121 | "Create the export version of a EBDB link specified by PATH or DESC. 122 | If exporting to either HTML or LaTeX FORMAT the link will be 123 | italicized, in all other cases it is left unchanged." 124 | (when (string= desc (format "ebdb:%s" path)) 125 | (setq desc path)) 126 | (cond 127 | ((eq format 'html) (format "%s" desc)) 128 | ((eq format 'latex) (format "\\textit{%s}" desc)) 129 | ((eq format 'odt) 130 | (format "%s" desc)) 131 | (t desc))) 132 | 133 | ;; It was a mistake to make this a separate field class -- this 134 | ;; library should have just provided a new `ebdb-read' method for the 135 | ;; underlying `ebdb-field-tags' class. I'm overriding `make-instance' 136 | ;; to redirect to `ebdb-field-tags', and will leave this override in 137 | ;; place for a year or so, then remove this class altogether some time 138 | ;; around Feb 2021. 139 | ;;;###autoload 140 | (defclass ebdb-org-field-tags (ebdb-field-tags) 141 | nil 142 | :human-readable "org tags") 143 | 144 | (cl-defmethod make-instance :around ((_cls (subclass ebdb-org-field-tags)) 145 | &rest slots) 146 | "Return an instance of `ebdb-field-tags' instead." 147 | (apply #'cl-call-next-method 'ebdb-field-tags slots)) 148 | 149 | (cl-defmethod ebdb-read ((field (subclass ebdb-field-tags)) &optional slots obj) 150 | (let* ((crm-separator (cadr (assq 'ebdb-field-tags ebdb-separator-alist))) 151 | (val (completing-read-multiple 152 | (format "Tags (separate with \"%s\"): " crm-separator) 153 | (org--tag-add-to-alist 154 | (org--tag-add-to-alist 155 | (org--tag-add-to-alist 156 | (org-global-tags-completion-table) 157 | org-tag-alist) 158 | org-tag-persistent-alist) 159 | ebdb-tags) 160 | nil nil 161 | (when obj (ebdb-string obj)) 'org-tags-history))) 162 | (cl-call-next-method field (plist-put slots :tags val)))) 163 | 164 | ;;;###autoload 165 | (defun ebdb-org-agenda-popup (&optional inter) 166 | "Pop up an *EBDB* buffer from an Org Agenda tags search. 167 | Uses the tags searched for in the Agenda buffer to do an 168 | equivalent tags search of EBDB records. 169 | 170 | To do this automatically for every search, add this function to 171 | `org-agenda-mode-hook'." 172 | (interactive "p") 173 | (if (null (and (derived-mode-p 'org-agenda-mode) 174 | (eql org-agenda-type 'tags))) 175 | (when inter 176 | (message "Not in an Org Agenda tags search buffer")) 177 | (let* ((func (cdr (org-make-tags-matcher org-agenda-query-string))) 178 | (records (ebdb-search (ebdb-records) 179 | `((ebdb-field-tags ,func))))) 180 | (ebdb-display-records records nil nil nil (ebdb-popup-window))))) 181 | 182 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode org-mode)) 183 | "Use a separate EBDB buffer for Org-related contacts." 184 | (format "*%s-Org*" ebdb-buffer-name)) 185 | 186 | ;;; Formatters 187 | 188 | (defclass ebdb-org-formatter (ebdb-formatter) 189 | ((post-format-function :initform #'org-mode)) 190 | :abstract t 191 | :documentation "Formatter responsible for Org-specific field 192 | formatting.") 193 | 194 | (cl-defmethod ebdb-fmt-field ((_fmt ebdb-org-formatter) 195 | (_field ebdb-field-mail) 196 | _style 197 | (_rec ebdb-record)) 198 | (concat "mailto:" (cl-call-next-method))) 199 | 200 | (defun ebdb-org-table-post-format () 201 | "Align the formatted Org table." 202 | (org-mode) 203 | (goto-char (point-min)) 204 | (forward-char) 205 | (org-table-align)) 206 | 207 | (defclass ebdb-org-formatter-tabular (ebdb-formatter-tabular 208 | ebdb-org-formatter) 209 | ((record-separator :initform "\n") 210 | (field-separator :initform " | ") 211 | (post-format-function :initform #'ebdb-org-table-post-format))) 212 | 213 | (cl-defmethod ebdb-fmt-header :around ((_fmt ebdb-org-formatter-tabular) 214 | _records) 215 | (concat "| " 216 | (cl-call-next-method) 217 | " |\n" 218 | "|---|\n")) 219 | 220 | (cl-defmethod ebdb-fmt-compose-fields :around ((_fmt ebdb-org-formatter-tabular) 221 | (_rec ebdb-record) 222 | &optional _field-list _depth) 223 | (concat "| " 224 | (cl-call-next-method) 225 | " |")) 226 | 227 | (defcustom ebdb-org-default-tabular-formatter 228 | (make-instance 'ebdb-org-formatter-tabular 229 | :label "org table" 230 | :fields '(mail-primary)) 231 | "Default Org table formatter." 232 | :type 'ebdb-formatter-tabular) 233 | 234 | (provide 'ebdb-org) 235 | ;;; ebdb-org.el ends here 236 | -------------------------------------------------------------------------------- /ebdb-pgp.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-pgp.el --- Interaction between EBDB and PGP -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Interaction between EDBD and PGP encryption/signing. This file was 23 | ;; copied from bbdb-pgp.el, originally written by Kevin Davidson and 24 | ;; Gijs Hillenius. 25 | 26 | ;;; Code: 27 | 28 | (require 'message) 29 | (require 'ebdb-com) 30 | 31 | (declare-function ebdb-mua-message-header "ebdb-mua") 32 | 33 | (defcustom ebdb-pgp-default-action nil 34 | "Default action when sending a message and the recipients are not in EBDB. 35 | This should be one of the following symbols: 36 | nil Do nothing 37 | sign Sign the message 38 | sign-query Query whether to sign the message 39 | encrypt Encrypt the message 40 | encrypt-query Query whether to encrypt the message 41 | See info node `(message)security'." 42 | :type '(choice 43 | (const :tag "Do Nothing" nil) 44 | (const :tag "Encrypt" encrypt) 45 | (const :tag "Query encryption" encrypt-query) 46 | (const :tag "Sign" sign) 47 | (const :tag "Query signing" sign-query)) 48 | :group 'ebdb-utilities-pgp) 49 | 50 | (defcustom ebdb-pgp-ranked-actions 51 | '(encrypt-query sign-query encrypt sign) 52 | "Ranked list of actions when sending a message. 53 | If a message has multiple recipients such that their EBDB records specify 54 | different actions for this message, `ebdb-pgp' will perform the action 55 | which appears first in `ebdb-pgp-ranked-actions'. 56 | This list should include the following four symbols: 57 | sign Sign the message 58 | sign-query Query whether to sign the message 59 | encrypt Encrypt the message 60 | encrypt-query Query whether to encrypt the message." 61 | :type '(repeat (symbol :tag "Action")) 62 | :group 'ebdb-utilities-pgp) 63 | 64 | (defcustom ebdb-pgp-headers '("To" "Cc") 65 | "Message headers to look at." 66 | :type '(repeat (string :tag "Message header")) 67 | :group 'ebdb-utilities-pgp) 68 | 69 | (defcustom ebdb-pgp-method 'pgpmime 70 | "Default method for signing and encrypting messages. 71 | It should be one of the keys of `ebdb-pgp-method-alist'. 72 | The default methods include 73 | pgp Add MML tags for PGP format 74 | pgpauto Add MML tags for PGP-auto format 75 | pgpmime Add MML tags for PGP/MIME 76 | smime Add MML tags for S/MIME 77 | See info node `(message)security'." 78 | :type '(choice 79 | (const :tag "MML PGP" pgp) 80 | (const :tag "MML PGP-auto" pgpauto) 81 | (const :tag "MML PGP/MIME" pgpmime) 82 | (const :tag "MML S/MIME" smime) 83 | (symbol :tag "Custom")) 84 | :group 'ebdb-utilities-pgp) 85 | 86 | (defcustom ebdb-pgp-method-alist 87 | '((pgp mml-secure-message-sign-pgp 88 | mml-secure-message-encrypt-pgp) 89 | (pgpmime mml-secure-message-sign-pgpmime 90 | mml-secure-message-encrypt-pgpmime) 91 | (smime mml-secure-message-sign-smime 92 | mml-secure-message-encrypt-smime) 93 | (pgpauto mml-secure-message-sign-pgpauto 94 | mml-secure-message-encrypt-pgpauto)) 95 | "Alist of methods for signing and encrypting a message with `ebdb-pgp'. 96 | Each method is a list (KEY SIGN ENCRYPT). 97 | The symbol KEY identifies the method. The function SIGN signs the message; 98 | the function ENCRYPT encrypts it. These functions take no arguments. 99 | The default methods include 100 | pgp Add MML tags for PGP format 101 | pgpauto Add MML tags for PGP-auto format 102 | pgpmime Add MML tags for PGP/MIME 103 | smime Add MML tags for S/MIME 104 | See info node `(message)security'." 105 | :type '(repeat (list (symbol :tag "Key") 106 | (symbol :tag "Sign method") 107 | (symbol :tag "Encrypt method"))) 108 | :group 'ebdb-utilities-pgp) 109 | 110 | ;;;###autoload 111 | (defclass ebdb-field-pgp (ebdb-field-user) 112 | ((action 113 | :initarg :action 114 | :type symbol 115 | :custom (choice 116 | (const :tag "Encrypt" encrypt) 117 | (const :tag "Query encryption" encrypt-query) 118 | (const :tag "Sign" sign) 119 | (const :tag "Query signing" sign-query)) 120 | :documentation 121 | "A symbol indicating what action to take when sending a 122 | message to this contact.")) 123 | :documentation "A field defining a default signing/encryption 124 | action for a record. This action is taken by calling 125 | `ebdb-pgp' in a message/mail composition buffer, or by adding 126 | that function to the message/mail-send-hook." 127 | :human-readable "pgp action") 128 | 129 | (cl-defmethod ebdb-string ((field ebdb-field-pgp)) 130 | (symbol-name (slot-value field 'action))) 131 | 132 | (cl-defmethod ebdb-read ((class (subclass ebdb-field-pgp)) &optional slots obj) 133 | (let ((val (intern (ebdb-read-string 134 | "PGP action" (when obj (slot-value obj 'action)) 135 | ebdb-pgp-ranked-actions t)))) 136 | (cl-call-next-method class (plist-put slots :action val) obj))) 137 | 138 | ;;;###autoload 139 | (defun ebdb-pgp () 140 | "Add PGP MML tags to a message according to the recipients' EBDB records. 141 | 142 | Use it by adding a \"pgp action\" field to one or more records. 143 | 144 | When sending a message to those records (ie, the records appear 145 | in `ebdb-pgp-headers' headers), this grabs the action from their 146 | `ebdb-field-pgp' field. If multiple records propose different 147 | actions, perform the action which appears first in 148 | `ebdb-pgp-ranked-actions'. If this proposes no action at all, 149 | use `ebdb-pgp-default-action'. The variable `ebdb-pgp-method' 150 | defines the method which is actually used for signing and 151 | encrypting. 152 | 153 | This command works with both `mail-mode' and `message-mode' to send 154 | signed or encrypted mail. 155 | 156 | This file does not automatically set up hooks for signing and 157 | encryption, see Info node `(message)Signing and encryption' for 158 | reasons why. Instead, you might want to call the command 159 | `ebdb-pgp' manually, then call `mml-preview'. 160 | 161 | If you do decide to set up automatic signing/encryption hooks, 162 | use one of the following, as appropriate: 163 | 164 | (add-hook \\='message-send-hook #\\='ebdb-pgp) 165 | (add-hook \\='mail-send-hook #\\='ebdb-pgp)" 166 | (interactive) 167 | (save-excursion 168 | (save-restriction 169 | (widen) 170 | (message-narrow-to-headers) 171 | (when mail-aliases 172 | ;; (sendmail-sync-aliases) ; needed? 173 | (expand-mail-aliases (point-min) (point-max))) 174 | (let* (field 175 | (actions 176 | (or (delq nil 177 | (delete-dups 178 | (mapcar 179 | (lambda (record) 180 | (when (setq 181 | field (car-safe (ebdb-record-field 182 | record 'ebdb-field-pgp))) 183 | (slot-value field 'action))) 184 | (delete-dups 185 | (apply #'nconc 186 | (mapcar 187 | (lambda (address) 188 | (ebdb-message-search (car address) 189 | (cadr address))) 190 | (ebdb-extract-address-components 191 | (mapconcat 192 | (lambda (header) 193 | (ebdb-mua-message-header header)) 194 | ebdb-pgp-headers ", ") 195 | t))))))) 196 | (and ebdb-pgp-default-action 197 | (list ebdb-pgp-default-action))))) 198 | (when actions 199 | (widen) ; after analyzing the headers 200 | (let ((ranked-actions ebdb-pgp-ranked-actions) 201 | action) 202 | (while ranked-actions 203 | (if (memq (setq action (pop ranked-actions)) actions) 204 | (cond ((or (eq action 'sign) 205 | (and (eq action 'sign-query) 206 | (y-or-n-p "Sign message? "))) 207 | (funcall (nth 1 (assq ebdb-pgp-method 208 | ebdb-pgp-method-alist))) 209 | (setq ranked-actions nil)) 210 | ((or (eq action 'encrypt) 211 | (and (eq action 'encrypt-query) 212 | (y-or-n-p "Encrypt message? "))) 213 | (funcall (nth 2 (assq ebdb-pgp-method 214 | ebdb-pgp-method-alist))) 215 | (setq ranked-actions nil))))))))))) 216 | 217 | (provide 'ebdb-pgp) 218 | ;;; ebdb-pgp.el ends here 219 | -------------------------------------------------------------------------------- /ebdb-rmail.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-rmail.el --- EBDB interface to Rmail -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; EBDB's interaction with the Rmail MUA. 23 | 24 | ;;; Code: 25 | 26 | (require 'ebdb-com) 27 | (require 'ebdb-mua) 28 | (require 'rmail) 29 | (require 'rmailsum) 30 | (require 'mailheader) 31 | 32 | (defgroup ebdb-mua-rmail nil 33 | "EBDB customization for rmail." 34 | :group 'ebdb-mua) 35 | 36 | (defcustom ebdb-rmail-auto-update-p ebdb-mua-reader-update-p 37 | "Rmail-specific value of `ebdb-mua-auto-update-p'." 38 | :type '(choice (const :tag "do nothing" nil) 39 | (const :tag "search for existing records" existing) 40 | (const :tag "update existing records" update) 41 | (const :tag "query for update or record creation" query) 42 | (const :tag "update or create automatically" create) 43 | (function :tag "User-defined function"))) 44 | 45 | (defcustom ebdb-rmail-window-size ebdb-default-window-size 46 | "Size of the EBDB buffer when popping up in rmail. 47 | Size should be specified as a float between 0 and 1. Defaults to 48 | the value of `ebdb-default-window-size'." 49 | :type 'float) 50 | 51 | (defun ebdb/rmail-new-flag () 52 | "Returns t if the current message in buffer BUF is new." 53 | (rmail-message-labels-p rmail-current-message ", ?\\(unseen\\),")) 54 | 55 | (defun ebdb/rmail-header (header) 56 | "Pull HEADER out of Rmail header." 57 | (with-current-buffer rmail-buffer 58 | (if (fboundp 'rmail-get-header) ; Emacs 23 59 | (rmail-get-header header) 60 | (save-restriction 61 | (with-no-warnings (rmail-narrow-to-non-pruned-header)) 62 | (mail-header (intern-soft (downcase header)) 63 | (mail-header-extract)))))) 64 | 65 | (cl-defmethod ebdb-mua-message-header ((header string) 66 | &context (major-mode rmail-mode)) 67 | (ebdb/rmail-header header)) 68 | 69 | (cl-defmethod ebdb-mua-message-header ((header string) 70 | &context (major-mode rmail-summary-mode)) 71 | (ebdb/rmail-header header)) 72 | 73 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode rmail-mode)) 74 | (format "*%s-Rmail*" ebdb-buffer-name)) 75 | 76 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode rmail-summary-mode)) 77 | (format "*%s-Rmail*" ebdb-buffer-name)) 78 | 79 | (cl-defmethod ebdb-popup-buffer (&context (major-mode rmail-summary-mode)) 80 | (list (get-buffer-window) ebdb-rmail-window-size)) 81 | 82 | ;;;###autoload 83 | (defun ebdb-insinuate-rmail () 84 | "Hook EBDB into RMAIL." 85 | (unless ebdb-db-list 86 | (ebdb-load)) 87 | (define-key rmail-mode-map ";" ebdb-mua-keymap)) 88 | 89 | ;;;###autoload 90 | (defun ebdb-rmail-auto-update () 91 | (ebdb-mua-auto-update ebdb-rmail-auto-update-p)) 92 | 93 | (add-hook 'rmail-mode-hook #'ebdb-insinuate-rmail) 94 | 95 | (add-hook 'rmail-show-message-hook #'ebdb-rmail-auto-update) 96 | 97 | (provide 'ebdb-rmail) 98 | ;;; ebdb-rmail.el ends here 99 | -------------------------------------------------------------------------------- /ebdb-roam.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-roam.el --- Org-Roam integration for EBDB -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2024 Free Software Foundation, Inc. 4 | 5 | ;; Authors: Samuel W. Flint , hokreb 6 | ;; Keywords: 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;;; Code: 24 | 25 | (require 'ebdb) 26 | (require 'ebdb-com) 27 | (require 'ebdb-format) 28 | (require 'org-roam-node nil t) ; It's normal if this package is missing! 29 | (declare-function org-roam-db-query "org-roam") 30 | (declare-function org-roam-node-id "org-node") 31 | (declare-function org-roam-node-from-id "org-node") 32 | (declare-function org-roam-node-p "org-node") 33 | (declare-function magit-insert-section "magit-section") 34 | (declare-function magit-insert-heading "magit-section") 35 | 36 | 37 | ;; org-roam-buffer Section 38 | 39 | (defun ebdb-roam--get-links (node &optional link-type) 40 | "Get EBDB links of LINK-TYPE for Org Roam NODE. 41 | 42 | NODE can be either an instance of `org-roam-node' or an Org Roam 43 | node id (i.e., a UUID). LINK-TYPE can be any valid EBDB link 44 | type, if none, uuid links are searched for." 45 | (let* ((node (if (org-roam-node-p node) 46 | node 47 | (org-roam-node-from-id node))) 48 | (uuid (org-roam-node-id node)) 49 | (query-result-links (org-roam-db-query [:select [dest] 50 | :from links 51 | :where (and (= type "ebdb") 52 | (= source $s1))] 53 | uuid)) 54 | (query-result-refs (org-roam-db-query [:select [ref] 55 | :from refs 56 | :where (and (= type "ebdb") 57 | (= node_id $s1))] 58 | uuid)) 59 | (query-results (append query-result-refs query-result-links)) 60 | (desired-type (or link-type "uuid"))) 61 | (cl-remove-duplicates 62 | (delq nil 63 | (mapcar (lambda (row) 64 | (unless (null row) 65 | (let* ((dest (car row)) 66 | (split-dest (split-string dest "/")) 67 | (dest-type (car split-dest)) 68 | (dest-address (cadr split-dest))) 69 | (and (string-equal dest-type desired-type) dest-address)))) 70 | query-results)) 71 | :test #'string=))) 72 | 73 | ;;;###autoload 74 | (cl-defun ebdb-roam-section (node &key (heading "Address Book Entries") 75 | (record-formatter ebdb-default-multiline-formatter)) 76 | "Show EBDB entries for current NODE. 77 | 78 | Appearance can be controlled with the HEADING and 79 | RECORD-FORMATTER keyword arguments. The former is a string to be 80 | inserted (defaults to \"Address Book Entries\"). The latter 81 | should be an instance of `ebdb-formatter', with a default of 82 | `ebdb-default-multiline-formatter'." 83 | (when-let ((uuid-list (ebdb-roam--get-links node))) 84 | (with-suppressed-warnings ((free-vars org-roam-ebdb-section)) 85 | (magit-insert-section org-roam-ebdb-section 86 | (magit-insert-heading heading) 87 | (dolist (uuid uuid-list) 88 | (when-let ((entry (ebdb-gethash uuid 'uuid))) 89 | (insert (ebdb-fmt-record record-formatter entry)))) 90 | (insert "\n"))))) 91 | 92 | (provide 'ebdb-roam) 93 | ;;; ebdb-roam.el ends here 94 | -------------------------------------------------------------------------------- /ebdb-snarf.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-snarf.el --- Creating or displaying records based on free-form pieces of text -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | ;; Keywords: mail 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; This file provides functions for reading arbitrary bits of text, 24 | ;; interpreting them as records and fields, and then using them to 25 | ;; search/display/update/create records. 26 | 27 | ;; The main entry point is the interactive command `ebdb-snarf'. It 28 | ;; figures out what text we're dealing with, puts the text in a temp 29 | ;; buffer, and calls three nested functions: `ebdb-snarf-collect', 30 | ;; which finds likely field-related strings in the buffer and groups 31 | ;; them, then `ebdb-snarf-collapse', which tries to match that 32 | ;; information to existing records, and finally `ebdb-snarf-query', 33 | ;; which queries the user about how to handle leftover 34 | ;; information. Any resulting records are then displayed. 35 | 36 | ;; The option `ebdb-snarf-routines' contains regexps that can be used 37 | ;; to construct field instances. `ebdb-snarf-collect' uses the 38 | ;; elements of this list to search for relevant strings. 39 | 40 | ;; Country-specific internationalization libraries are highly 41 | ;; encouraged to add values to `ebdb-snarf-routines', locating field 42 | ;; information specific to that country/region/language. 43 | 44 | ;;; Code: 45 | 46 | (require 'ebdb-com) 47 | 48 | (defcustom ebdb-snarf-routines 49 | `((ebdb-field-mail "[[:blank:]([<\"]*\\([[:alnum:]][^[:space:]\":\n<[]+@[^]:[:space:])>\"\n]+[[:alnum:]]\\)") 50 | (ebdb-field-url ,(concat "\\(" 51 | (regexp-opt ebdb-url-valid-schemes) 52 | "//[^ \n\t]+\\)")) 53 | (ebdb-field-phone "\\(\\+?[[:digit:]]\\{1,3\\}[ )-.]?[[:digit:] -.()]\\{6,\\}\\)")) 54 | 55 | "An alist of EBDB field classes and related regexps. 56 | Each alist element is an EBDB field class symbol, followed by a 57 | list of regular expressions that can be used to produce instances 58 | of that class when passed to `ebdb-parse'. Each regular 59 | expression should contain at least one parenthetical group: the 60 | `ebdb-parse' method of the class will receive the results of 61 | \(match-string 1)." 62 | 63 | :group 'ebdb-snarf 64 | :type '(repeat (symbol string))) 65 | 66 | (defcustom ebdb-snarf-name-re 67 | (list "\\(?:[[:upper:]][[:lower:]'-]+[,.[:blank:]]*\\)\\{2,\\}") 68 | 69 | "A list of regular expressions matching names. 70 | This is a separate option from `ebdb-snarf-routines' because 71 | snarfing doesn't search for names separately, only in conjunction 72 | with other field types. 73 | 74 | Regular expressions in this list should not include parenthetical 75 | groups." 76 | 77 | :group 'ebdb-snarf 78 | :type '(repeat string)) 79 | 80 | ;;;###autoload 81 | (defun ebdb-snarf (&optional string start end recs ret) 82 | "Snarf text and attempt to display/update/create a record from it. 83 | If STRING is given, snarf the string. If START and END are given 84 | in addition to STRING, assume they are 0-based indices into it. 85 | If STRING is nil but START and END are given, assume they are 86 | buffer positions, and snarf the region between. If all three 87 | arguments are nil, snarf the entire current buffer. 88 | 89 | If RECORDS is present, it is a list of records that we assume may 90 | be relevant to snarfed field data. 91 | 92 | If RET is non-nil, return the records. Otherwise display them." 93 | (interactive) 94 | (let* ((str 95 | (cond ((use-region-p) 96 | (buffer-substring-no-properties 97 | (region-beginning) (region-end))) 98 | ((and (or start end) string) 99 | (substring string start end)) 100 | ((and start end (null string)) 101 | (buffer-substring-no-properties start end)) 102 | (string 103 | string) 104 | (t 105 | (buffer-string)))) 106 | (records 107 | (ebdb-snarf-query 108 | (ebdb-snarf-collapse 109 | (ebdb-snarf-collect str recs))))) 110 | 111 | (if (null ret) 112 | (if records 113 | (ebdb-display-records records nil t nil (list (selected-window))) 114 | (message "No snarfable data found")) 115 | records))) 116 | 117 | (defun ebdb-snarf-collect (str &optional records) 118 | "Collect EBDB record information from string STR. 119 | This function will find everything that looks like field 120 | information, and do its best to organize it into likely groups. 121 | If RECORDS is given, it should be a list of records that we think 122 | have something to do with the text in the string. 123 | 124 | This function returns a list of vectors. Each vector contains 125 | three elements: a record, a list of name-class instances, and a 126 | list of other field instances. Any of the three elements can be 127 | nil." 128 | (let ((case-fold-search nil) 129 | ;; BUNDLES is the list of vectors. If RECORDS is given, then 130 | ;; we have something to start with. 131 | (bundles (when records 132 | (mapcar (lambda (r) 133 | (vector r nil nil)) 134 | records))) 135 | ;; We are looking for text like this: 136 | 137 | ;; John Bob 138 | 139 | ;; Try calling John Bob: (555) 555-5555 140 | 141 | ;; John Bob 142 | ;; John@bob.com 143 | ;; (555) 555-5555 144 | ;; 1111 Upsidedown Drive 145 | ;; Nowhere, Massachusetts, 55555 146 | 147 | ;; (Also see the snarfing tests in ebdb-test.el.) 148 | 149 | ;; The tactic is: Make a big regexp that finds a big blob of 150 | ;; probable field data. Once there's a hit, search 151 | ;; *backwards* for a name, and *forwards* for more fields. 152 | ;; All contiguous field data is grouped into the same bundle. 153 | 154 | ;; Snarfing mail message data is very common, it would be nice 155 | ;; to somehow disregard left-hand quotation characters and 156 | ;; indentation. See `mail-citation-prefix-regexp'. A problem 157 | ;; for another day. 158 | (big-re 159 | (concat 160 | "\\(?:" 161 | (mapconcat 162 | (lambda (r) 163 | (if (stringp (cadr r)) 164 | (cadr r) 165 | (mapconcat #'identity (cadr r) "\\|"))) 166 | ebdb-snarf-routines 167 | "\\|*") 168 | "\\)+")) 169 | (name-re (concat 170 | "\"?\\(" 171 | (mapconcat #'identity 172 | ebdb-snarf-name-re "\\|") 173 | "\\)[-\n\" ,:]*")) 174 | field seen-fields) 175 | 176 | (with-temp-buffer 177 | ;; Snarfing mail buffers is very common, try deleting citation 178 | ;; prefixes from the buffer first. 179 | (insert (replace-regexp-in-string 180 | (concat "^" mail-citation-prefix-regexp "[[:blank:]]+") 181 | "" str)) 182 | (goto-char (point-min)) 183 | ;; SOMETHING from the big-re matched. 184 | (while (re-search-forward big-re nil t) 185 | (goto-char (match-beginning 0)) 186 | (let* ((bound (match-end 0)) 187 | (name (save-excursion 188 | (when (re-search-backward 189 | name-re 190 | (line-beginning-position 191 | (when (bolp) 0)) 192 | t) 193 | ;; If something goes wrong with the 194 | ;; name, don't worry about it. 195 | (ignore-errors 196 | (ebdb-parse 197 | 'ebdb-field-name 198 | (string-trim (match-string-no-properties 0))))))) 199 | (bundle (or (and 200 | name 201 | ;; If NAME matches one of the records that 202 | ;; are already in BUNDLES, then assume we 203 | ;; should be working with that record. 204 | (catch 'match 205 | (dolist (b bundles) 206 | (when (and (aref b 0) 207 | (ebdb-record-search 208 | (aref b 0) 209 | 'ebdb-field-name 210 | (ebdb-string name))) 211 | (throw 'match b))))) 212 | (make-vector 3 nil)))) 213 | 214 | (when (and name (null (aref bundle 0))) 215 | (push name (aref bundle 1))) 216 | 217 | ;; Now find out exactly what matched, and make a field. 218 | (dolist (class ebdb-snarf-routines) 219 | (dolist (re (cdr class)) 220 | (save-excursion 221 | (while (re-search-forward re bound t) 222 | (condition-case nil 223 | (progn 224 | ;; Discard field if it's been found already. 225 | (setq field (ebdb-parse (car class) 226 | (match-string-no-properties 1))) 227 | (unless (member field seen-fields) 228 | (push field (aref bundle 2)) 229 | (push field seen-fields))) 230 | 231 | ;; If a regular expression matches but the result is 232 | ;; unparseable, that means the regexp is bad and should be 233 | ;; changed. Later, report these errors if `ebdb-debug' is 234 | ;; true. 235 | (ebdb-unparseable nil)))))) 236 | (when (or (aref bundle 0) (aref bundle 1) (aref bundle 2)) 237 | (push bundle bundles)) 238 | (goto-char bound)))) 239 | bundles)) 240 | 241 | (defun ebdb-snarf-collapse (input) 242 | "Process INPUT, which is a list of bundled field information. 243 | INPUT is probably produced by `ebdb-snarf-collect'. It should be 244 | a list of vectors, each with three elements: a single record, a 245 | list of name field instances, and a list of other field 246 | instances. Any of the three elements can be nil. 247 | 248 | Compare each bundle against the database, and where possible find 249 | existing records that match information in the bundle. Discard 250 | redundant fields, or fields that are incompatible with the record 251 | they're grouped with. Return the same list of (possibly altered) 252 | vectors, usually to `ebdb-snarf-query'." 253 | (let (output rec) 254 | (pcase-dolist (`[,record ,names ,fields] input) 255 | (let (out-fields out-names) 256 | (unless record 257 | (when (setq rec (car-safe 258 | (ebdb-search 259 | (ebdb-records) 260 | (mapcar 261 | (lambda (f) 262 | (list (eieio-object-class-name f) 263 | (ebdb-string f))) 264 | (append fields names))))) 265 | (setq record rec))) 266 | (if record 267 | (progn 268 | ;; If there's a record, make sure the record can accept 269 | ;; the fields and names, and doesn't already have them. 270 | (dolist (f fields) 271 | (condition-case nil 272 | (when (and (car-safe (ebdb-record-field-slot-query 273 | (eieio-object-class record) 274 | `(nil . ,(eieio-object-class f)))) 275 | (null (ebdb-record-search 276 | record 277 | (eieio-object-class f) 278 | (ebdb-string f)))) 279 | (push f out-fields)) 280 | (ebdb-unacceptable-field nil))) 281 | (dolist (name names) 282 | (unless (ebdb-record-search 283 | record 'ebdb-field-name (ebdb-string name)) 284 | (push name out-names)))) 285 | ;; If no record, dump all the fields and names into the 286 | ;; query process. 287 | (setq out-names names 288 | out-fields fields)) 289 | (push (vector record out-names out-fields) output))) 290 | output)) 291 | 292 | (defun ebdb-snarf-query (input) 293 | "Query the user about handling INPUT. 294 | INPUT is a list of vectors of bundled information representing 295 | records. 296 | 297 | Ask about field instances that we haven't been able to handle 298 | automatically." 299 | (let (leftovers records record) 300 | (pcase-dolist (`[,record ,names ,fields] input) 301 | (unless record 302 | ;; There's no record, query-create a new one. 303 | (when (yes-or-no-p 304 | (format "Create new record%s? " 305 | (if (or fields names) 306 | (format " for fields %s" 307 | (mapconcat #'ebdb-string 308 | (append fields names) 309 | "/")) 310 | ""))) 311 | ;; Which name do we use? 312 | (let* ((name-alist 313 | (when names 314 | (mapcar (lambda (n) 315 | (cons (ebdb-string n) 316 | n)) 317 | names))) 318 | (name 319 | ;; I hate completing read. 320 | (cond ((= 1 (length name-alist)) 321 | (cdar name-alist)) 322 | (name-alist 323 | (cdr 324 | (assoc-string 325 | (completing-read 326 | "Use name: " 327 | name-alist) 328 | name-alist))) 329 | (t nil))) 330 | (db (ebdb-prompt-for-db nil t))) 331 | (setq record 332 | (make-instance 333 | (slot-value db 'record-class) 334 | :name (ebdb-read 335 | ebdb-default-name-class nil 336 | name))) 337 | (when name 338 | (setq names (delq name names))) 339 | (run-hook-with-args 'ebdb-create-hook record) 340 | (run-hook-with-args 'ebdb-change-hook record) 341 | (ebdb-db-add-record db record) 342 | (ebdb-init-record record)))) 343 | (if record 344 | ;; We have a record, which of the fields and names should we 345 | ;; add to it? 346 | (progn (dolist (elt fields) 347 | (if (yes-or-no-p (format "Add %s to %s? " 348 | (ebdb-string elt) 349 | (ebdb-string record))) 350 | (condition-case nil 351 | (progn 352 | (ebdb-record-insert-field 353 | record elt) 354 | (ebdb-init-field elt record)) 355 | (ebdb-unacceptable-field nil)) 356 | (push elt leftovers))) 357 | (dolist (n names) 358 | (if (yes-or-no-p (format "Add %s as an aka for %s? " 359 | (ebdb-string n) 360 | (ebdb-string record))) 361 | (progn (ebdb-record-insert-field 362 | record n 'aka) 363 | (ebdb-init-field n record)) 364 | (push n leftovers))) 365 | (run-hook-with-args 'ebdb-after-change-hook record)) 366 | ;; We have no record, dump all the fields into LEFTOVERS. 367 | (setq leftovers (append fields names leftovers) 368 | fields nil 369 | names nil)) 370 | (when record 371 | (push record records))) 372 | ;; Handle fields in LEFTOVERS. 373 | (dolist (f (delete-dups leftovers)) 374 | (when (setq record 375 | (cond ((yes-or-no-p 376 | (format "Add %s to existing record? " 377 | (ebdb-string f))) 378 | (ebdb-prompt-for-record)) 379 | ((yes-or-no-p 380 | (format "Add %s to new record? " 381 | (ebdb-string f))) 382 | (let* ((db (ebdb-prompt-for-db nil t)) 383 | (rec (ebdb-read 384 | (slot-value db 'record-class)))) 385 | (run-hook-with-args 'ebdb-create-hook rec) 386 | (run-hook-with-args 'ebdb-change-hook rec) 387 | (ebdb-init-record 388 | (ebdb-db-add-record db rec)))) 389 | (t nil))) 390 | (condition-case nil 391 | (progn 392 | (ebdb-record-insert-field record f) 393 | (ebdb-init-field f record) 394 | (push record records)) 395 | (ebdb-unacceptable-field nil)))) 396 | records)) 397 | 398 | (provide 'ebdb-snarf) 399 | ;;; ebdb-snarf.el ends here 400 | -------------------------------------------------------------------------------- /ebdb-test.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-test.el --- Tests for EBDB -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2017-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; Tests for EBDB. Tests for EBDB's internationalization support are 23 | ;; in a separate file, since loading ebdb-i18n.el overloads a bunch of 24 | ;; methods, and un-overloading them is difficult. 25 | 26 | ;;; Code: 27 | 28 | (require 'ert) 29 | (require 'ebdb) 30 | (require 'ebdb-com) 31 | (require 'ebdb-snarf) 32 | (require 'ebdb-vcard) 33 | 34 | ;; Testing macros. 35 | 36 | (defmacro ebdb-test-with-database (db-and-filename &rest body) 37 | "Macro providing a temporary database to work with." 38 | (declare (indent 1) (debug ((symbolp symbolp) body))) 39 | `(let ((,(car db-and-filename) (make-instance 'ebdb-db-file 40 | :file ,(nth 1 db-and-filename) 41 | :dirty t)) 42 | ebdb-db-list) 43 | ;; Save sets sync-time. 44 | (ebdb-db-save ,(car db-and-filename) nil t) 45 | ;; Load adds to `ebdb-db-list'. 46 | (ebdb-db-load ,(car db-and-filename)) 47 | ;; `ebdb-db-load' used to add db to `ebdb-db-list', but now that 48 | ;; happens in `edbd-load'. Do it manually. 49 | (push ,(car db-and-filename) ebdb-db-list) 50 | (unwind-protect 51 | (progn 52 | ,@body) 53 | (delete-file ,(nth 1 db-and-filename))))) 54 | 55 | (defmacro ebdb-test-with-records (&rest body) 56 | "Don't let EBDB tests pollute `ebdb-record-tracker'." 57 | (declare (indent 0) (debug t)) 58 | `(let ((ebdb-hashtable (make-hash-table :test 'equal)) 59 | (ebdb-org-hashtable (make-hash-table :test 'equal)) 60 | ebdb-record-tracker) 61 | ,@body)) 62 | 63 | ;; Test database file name. 64 | (defvar ebdb-test-database-1 (make-temp-name 65 | (expand-file-name 66 | "emacs-ebdb-test-db-1-" 67 | temporary-file-directory))) 68 | 69 | (defvar ebdb-test-database-2 (make-temp-name 70 | (expand-file-name 71 | "emacs-ebdb-test-db-2-" 72 | temporary-file-directory))) 73 | 74 | (ert-deftest ebdb-make-database () 75 | "Make a database and save it to disk." 76 | (ebdb-test-with-database (db ebdb-test-database-1) 77 | (should (file-exists-p ebdb-test-database-1)) 78 | (should (null (slot-value db 'dirty))))) 79 | 80 | (ert-deftest ebdb-read-database () 81 | "Read a database from file." 82 | (ebdb-test-with-database (db ebdb-test-database-1) 83 | (let ((reloaded 84 | (eieio-persistent-read ebdb-test-database-1 'ebdb-db t))) 85 | (should (object-of-class-p reloaded 'ebdb-db-file))))) 86 | 87 | (ert-deftest ebdb-database-unsynced () 88 | "Make sure database knows it's unsynced." 89 | (ebdb-test-with-database (db ebdb-test-database-1) 90 | ;; Apparently the call to `ebdb-db-load' and the test are too 91 | ;; close together to register a difference in time, which I find 92 | ;; weird. 93 | (sit-for 0.1) 94 | (append-to-file "\n;; Junk string" nil (slot-value db 'file)) 95 | (should (ebdb-db-unsynced db)))) 96 | 97 | (ert-deftest ebdb-make-record () 98 | (ebdb-test-with-records 99 | (let ((rec (make-instance ebdb-default-record-class))) 100 | (should (object-of-class-p rec 'ebdb-record))))) 101 | 102 | (ert-deftest ebdb-add-record () 103 | "Create a record, add it to DB, and make sure it has a UUID." 104 | (ebdb-test-with-records 105 | (ebdb-test-with-database (db ebdb-test-database-1) 106 | (let ((rec (make-instance 'ebdb-record-person))) 107 | (should (null (ebdb-record-uuid rec))) 108 | (ebdb-db-add-record db rec) 109 | (should (stringp (ebdb-record-uuid rec))) 110 | (should (ebdb-gethash (ebdb-record-uuid rec) 'uuid)))))) 111 | 112 | (ert-deftest ebdb-load-record-multiple-databases () 113 | "Test loading of a record into multiple databases." 114 | (ebdb-test-with-records 115 | (ebdb-test-with-database (db1 ebdb-test-database-1) 116 | (ebdb-test-with-database (db2 ebdb-test-database-2) 117 | (let ((rec (make-instance 'ebdb-record-person))) 118 | (ebdb-db-add-record db1 rec) 119 | (ebdb-db-add-record db2 rec) 120 | (should (= 1 (length ebdb-record-tracker))) 121 | (should (equal rec (ebdb-gethash (ebdb-record-uuid rec) 'uuid)))))))) 122 | 123 | (ert-deftest ebdb-load-record-multiple-databases-error () 124 | "Test that record can't be edited when one of its databases is 125 | read-only." 126 | (ebdb-test-with-records 127 | (ebdb-test-with-database (db1 ebdb-test-database-1) 128 | (ebdb-test-with-database (db2 ebdb-test-database-2) 129 | (let ((rec (make-instance 'ebdb-record-person))) 130 | (ebdb-db-add-record db1 rec) 131 | (ebdb-db-add-record db2 rec) 132 | (setf (slot-value db1 'read-only) t) 133 | (should-error 134 | (ebdb-record-insert-field 135 | rec (ebdb-parse 'ebdb-field-mail "none@such.com")) 136 | :type 'ebdb-readonly-db)))))) 137 | 138 | (ert-deftest ebdb-auto-insert-timestamp-creation () 139 | "Test the creation of timestamp and creation-date fields. 140 | Actually exercises the `initialize-instance' methods of records." 141 | (ebdb-test-with-records 142 | (ebdb-test-with-database (db ebdb-test-database-1) 143 | (let* ((r1 (make-instance ebdb-default-record-class)) 144 | (r2 (make-instance ebdb-default-record-class 145 | :timestamp nil 146 | :creation-date nil)) 147 | (r2-date (slot-value (slot-value r2 'creation-date) 'timestamp))) 148 | ;; `make-instance' with no :timestamp or :creation-date values 149 | ;; should get the fields correctly. 150 | (should (and (stringp (ebdb-string (slot-value r1 'timestamp))) 151 | (stringp (ebdb-string (slot-value r1 'creation-date))))) 152 | (delete-instance r1) 153 | ;; `make-instance' with tags set to nil should still get 154 | ;; correct fields (can happen in migration). 155 | (should (and (stringp (ebdb-string (slot-value r2 'timestamp))) 156 | (stringp (ebdb-string (slot-value r2 'creation-date))))) 157 | ;; Creating a record, saving it to the database, then 158 | ;; re-loading it shouldn't change the creation date. 159 | (ebdb-db-add-record db r2) 160 | (ebdb-db-save db) 161 | (sleep-for 2) 162 | (ebdb-db-unload db) 163 | (setq db (eieio-persistent-read (slot-value db 'file) 'ebdb-db t)) 164 | (should (equal r2-date 165 | (slot-value 166 | (slot-value 167 | (car ebdb-record-tracker) 168 | 'creation-date) 169 | 'timestamp))))))) 170 | 171 | (ert-deftest ebdb-cant-find-related-role () 172 | "Find org record from a role field. 173 | If it doesn't exist, raise `ebdb-related-unfound'." 174 | (ebdb-test-with-records 175 | (let ((rec (make-instance 176 | 'ebdb-record-person 177 | :uuid (make-instance 'ebdb-field-uuid :uuid "bob"))) 178 | (role 179 | (make-instance 180 | 'ebdb-field-role :record-uuid "bob" 181 | :org-uuid "bogus"))) 182 | (ebdb-record-insert-field rec role) 183 | (should-error 184 | (ebdb-record-related rec role) 185 | :type 'ebdb-related-unfound)))) 186 | 187 | (ert-deftest ebdb-unload-db-with-relations () 188 | "Cross-db relations break correctly when a db is unloaded." 189 | (ebdb-test-with-records 190 | (ebdb-test-with-database (db1 ebdb-test-database-1) 191 | (ebdb-test-with-database (db2 ebdb-test-database-2) 192 | (let ((rec1 (make-instance 'ebdb-record-person)) 193 | (rec2 (make-instance 'ebdb-record-person)) 194 | rel-f) 195 | (ebdb-db-add-record db1 rec1) 196 | (ebdb-db-add-record db2 rec2) 197 | (setq rel-f (make-instance 198 | 'ebdb-field-relation :rel-uuid (ebdb-record-uuid rec2))) 199 | (ebdb-record-insert-field rec1 rel-f) 200 | (ebdb-db-unload db2) 201 | (should-error 202 | (ebdb-record-related rec1 rel-f) 203 | :type 'ebdb-related-unfound) 204 | (should 205 | (string= 206 | (ebdb-fmt-field 207 | ebdb-default-multiline-formatter 208 | rel-f 'oneline rec1) 209 | "record not loaded"))))))) 210 | 211 | (ert-deftest ebdb-test-with-record-edits () 212 | "Test the `ebdb-with-record-edits' macro." 213 | (ebdb-test-with-records 214 | (ebdb-test-with-database (db1 ebdb-test-database-1) 215 | (ebdb-test-with-database (db2 ebdb-test-database-2) 216 | (let ((rec1 (make-instance 'ebdb-record-person)) 217 | (rec2 (make-instance 'ebdb-record-person))) 218 | (ebdb-db-add-record db1 rec1) 219 | (ebdb-db-add-record db2 rec1) 220 | (ebdb-db-add-record db1 rec2) 221 | (setf (slot-value db2 'read-only) t) 222 | (dolist (rec (list rec1 rec2)) 223 | (ebdb-with-record-edits rec 224 | (ebdb-record-insert-field 225 | rec (ebdb-parse 'ebdb-field-mail "none@such.com")))) 226 | ;; Field insertion should have silently failed for rec1. 227 | (should-not 228 | (slot-value rec1 'mail))))))) 229 | 230 | ;; Test adding, deleting and changing fields. 231 | 232 | (ert-deftest ebdb-add-delete-record-field () 233 | "Add and delete fields." 234 | (ebdb-test-with-records 235 | (let ((rec (make-instance 'ebdb-record-person)) 236 | (mail (ebdb-parse ebdb-default-mail-class 237 | "bogus@nosuchaddress.com")) 238 | (phone (ebdb-parse ebdb-default-phone-class 239 | "+1 (555) 555-5555"))) 240 | ;; Pass slot explicitly. 241 | (ebdb-record-insert-field rec mail 'mail) 242 | ;; Let the method find the slot. 243 | (ebdb-record-insert-field rec phone) 244 | (should (object-of-class-p 245 | (car (ebdb-record-phone rec)) 246 | 'ebdb-field-phone)) 247 | (should (object-of-class-p 248 | (car (ebdb-record-mail rec)) 249 | 'ebdb-field-mail)) 250 | (ebdb-record-delete-field rec mail) 251 | (ebdb-record-delete-field rec phone 'phone) 252 | (should (null (ebdb-record-mail rec))) 253 | (should (null (ebdb-record-phone rec)))))) 254 | 255 | (ert-deftest ebdb-insert-unacceptable () 256 | "Make sure records reject unacceptable fields." 257 | (ebdb-test-with-records 258 | (let ((rec (make-instance 'ebdb-record-person)) 259 | (field (make-instance 'ebdb-field-domain :domain "gnu.org"))) 260 | (should-error (ebdb-record-field-slot-query 261 | 'ebdb-record-person (cons nil 'ebdb-field-domain)) 262 | :type 'ebdb-unacceptable-field) 263 | (should-error (ebdb-record-insert-field rec field) 264 | :type 'ebdb-unacceptable-field)))) 265 | 266 | (ert-deftest ebdb-change-record-field () 267 | "Change record's field." 268 | (ebdb-test-with-records 269 | (let ((rec (make-instance 'ebdb-record-person)) 270 | (mail (ebdb-parse ebdb-default-mail-class 271 | "bogus@nosuchaddress.com")) 272 | (mail2 (ebdb-parse ebdb-default-mail-class 273 | "no@such.address"))) 274 | (ebdb-record-insert-field rec mail) 275 | (should (string= (ebdb-string (ebdb-record-one-mail rec)) 276 | "bogus@nosuchaddress.com")) 277 | (ebdb-record-change-field rec mail mail2) 278 | (should (string= (ebdb-string (ebdb-record-one-mail rec)) 279 | "no@such.address"))))) 280 | 281 | ;; Field instance parse tests. 282 | 283 | ;; Test `ebdb-decompose-ebdb-address' 284 | 285 | (ert-deftest ebdb-address-decompose () 286 | "Test `ebdb-decompose-ebdb-address'." 287 | (should (equal '("Charles Lamb" "charlie@lamb.com") 288 | (ebdb-decompose-ebdb-address 289 | "Charles Lamb "))) 290 | 291 | (should (equal '("Charles Lamb" "charlie@lamb.com") 292 | (ebdb-decompose-ebdb-address 293 | "Charles Lamb mailto:charlie@lamb.com"))) 294 | 295 | (should (equal '("Charles Lamb" "charlie@lamb.com") 296 | (ebdb-decompose-ebdb-address 297 | "\"Charles Lamb\" charlie@lamb.com"))) 298 | 299 | (should (equal '("Charles Lamb" "charlie@lamb.com") 300 | (ebdb-decompose-ebdb-address 301 | "charlie@lamb.com (Charles Lamb)"))) 302 | 303 | (should (equal '(nil "charlie@lamb.com") 304 | (ebdb-decompose-ebdb-address 305 | "\"charlie@lamb.com\" charlie@lamb.com"))) 306 | 307 | (should (equal '(nil "charlie@lamb.com") 308 | (ebdb-decompose-ebdb-address 309 | ""))) 310 | 311 | (should (equal '(nil "charlie@lamb.com") 312 | (ebdb-decompose-ebdb-address 313 | "charlie@lamb.com "))) 314 | 315 | (should (equal '("Charles Lamb" nil) 316 | (ebdb-decompose-ebdb-address 317 | "Charles Lamb")))) 318 | 319 | (ert-deftest ebdb-parse-mail () 320 | "Parse various strings as mail fields." 321 | (should (equal 322 | (slot-value 323 | (ebdb-parse 'ebdb-field-mail "William Hazlitt ") 324 | 'aka) 325 | "William Hazlitt")) 326 | (should (equal 327 | (slot-value 328 | (ebdb-parse 'ebdb-field-mail "William Hazlitt ") 329 | 'mail) 330 | "bill@theexaminer.com")) 331 | (should-error (ebdb-parse 'ebdb-field-mail "William Hazlitt") 332 | :type 'ebdb-unparseable)) 333 | 334 | (ert-deftest ebdb-parse-name () 335 | "Parse various strings as name fields." 336 | (should (equal 337 | (slot-value 338 | (ebdb-parse 'ebdb-field-name-complex "Eric Abrahamsen") 339 | 'surname) 340 | "Abrahamsen")) 341 | (should (equal 342 | (slot-value 343 | (ebdb-parse 'ebdb-field-name-complex "Eric P. Abrahamsen") 344 | 'given-names) 345 | '("Eric" "P."))) 346 | (should (equal 347 | (slot-value 348 | (ebdb-parse 'ebdb-field-name-complex "Eric Abrahamsen, III") 349 | 'suffix) 350 | "III")) 351 | (should (equal 352 | (slot-value 353 | (ebdb-parse 'ebdb-field-name-complex "Albus Percival Wulfric Brian Dumbledore") 354 | 'given-names) 355 | '("Albus" "Percival" "Wulfric" "Brian"))) 356 | (should (equal 357 | (slot-value 358 | (ebdb-parse 'ebdb-field-name-complex "MURAKAMI Haruki") 359 | 'surname) 360 | "Murakami")) 361 | (should (equal 362 | (slot-value 363 | (ebdb-parse 'ebdb-field-name-complex "John Reddemann") 364 | 'surname) 365 | "Reddemann")) 366 | (should (equal 367 | (slot-value 368 | (ebdb-parse 'ebdb-field-name-complex "Fintan O'Toole") 369 | 'surname) 370 | "O'Toole")) 371 | (should (equal 372 | (slot-value 373 | (ebdb-parse 'ebdb-field-name-complex "O'Toole, Fintan") 374 | 'surname) 375 | "O'Toole")) 376 | (should (equal 377 | (slot-value 378 | (ebdb-parse 'ebdb-field-name-complex "O'TOOLE Fintan") 379 | 'surname) 380 | "O'Toole")) 381 | (should (equal 382 | (slot-value 383 | (ebdb-parse 'ebdb-field-name-complex "Daniel Michael Blake Day-Lewis") 384 | 'surname) 385 | "Day-Lewis"))) 386 | 387 | (ert-deftest ebdb-parse-phone () 388 | "Parse various strings as phone fields." 389 | (let ((parsed (ebdb-parse 'ebdb-field-phone "+1 (226) 697-5852 ext. 22")) 390 | (parsed2 (ebdb-parse 'ebdb-field-phone "+1 (226) 697 58 52X22"))) 391 | (should (eql (slot-value parsed 'country-code) 1)) 392 | (should (eql (slot-value parsed 'area-code) 226)) 393 | (should (equal (slot-value parsed 'number) "6975852")) 394 | (should (eql (slot-value parsed 'extension) 22)) 395 | (should (equal (slot-value parsed2 'number) "6975852")) 396 | (should (eql (slot-value parsed2 'extension) 22)))) 397 | 398 | ;; Snarf testing. 399 | 400 | (ert-deftest ebdb-snarf-mail-and-name () 401 | (let ((test-texts 402 | '("Eric Abrahamsen " 403 | "Eric Abrahamsen eric@ericabrahamsen.net" 404 | "Eric Abrahamsen (eric@ericabrahamsen.net)" 405 | "Eric Abrahamsen \n" 406 | "Eric Abrahamsen can't hold his drink\n is where you can write and tell him so.")) 407 | result) 408 | (dolist (text test-texts) 409 | (setq result (car (ebdb-snarf-collect text))) 410 | (pcase result 411 | (`[nil (,name) (,mail)] 412 | (unless (string= (ebdb-string name) "Eric Abrahamsen") 413 | (ert-fail (list (format "Parsing \"%s\" resulted in name %s" 414 | text (ebdb-string name))))) 415 | (unless (string= (ebdb-string mail) "eric@ericabrahamsen.net") 416 | (ert-fail (list (format "Parsing \"%s\" resulted in mail %s" 417 | text (ebdb-string mail)))))) 418 | (_ (ert-fail (list (format "Parsing \"%s\" resulted in %s" 419 | text result)))))))) 420 | 421 | ;; Search testing. 422 | 423 | (ert-deftest ebdb-message-search () 424 | "Test the `ebdb-message-search' function." 425 | (ebdb-test-with-records 426 | (ebdb-test-with-database (db ebdb-test-database-1) 427 | (let ((rec (make-instance 428 | 'ebdb-record-person 429 | :name (ebdb-parse 'ebdb-field-name-complex "Spongebob Squarepants") 430 | :mail (list (ebdb-parse 'ebdb-field-mail "spob@thepants.com"))))) 431 | (ebdb-db-add-record db rec) 432 | ;; Must init in order to get the record hashed, 433 | ;; `ebdb-message-search' relies on that. 434 | (ebdb-init-record rec) 435 | (should (equal (car (ebdb-message-search "Spongebob Squarepants" nil)) 436 | rec)) 437 | (should (equal (car (ebdb-message-search nil "spob@thepants.com")) 438 | rec)) 439 | (should (null (ebdb-message-search "Spongebob" nil))) 440 | (should (null (ebdb-message-search nil "thepants.com"))) 441 | (ebdb-delete-record rec))))) 442 | 443 | (ert-deftest ebdb-general-search () 444 | "Test some of the general search functions." 445 | (ebdb-test-with-records 446 | (ebdb-test-with-database (db ebdb-test-database-1) 447 | (let ((rec (make-instance 448 | 'ebdb-record-person 449 | :name (ebdb-parse 'ebdb-field-name-complex 450 | "Spongebob Squarepants") 451 | :mail (list (ebdb-parse 'ebdb-field-mail 452 | "spob@thepants.com")) 453 | :notes (ebdb-parse 'ebdb-field-notes 454 | "World's greatest cartoon.")))) 455 | (ebdb-db-add-record db rec) 456 | (ebdb-init-record rec) 457 | ;; Name is name. 458 | (should (equal (car 459 | (ebdb-search 460 | (ebdb-records) 461 | '((ebdb-field-name "Squarepants")))) 462 | rec)) 463 | ;; Mail is mail. 464 | (should (equal (car 465 | (ebdb-search 466 | (ebdb-records) 467 | '((ebdb-field-mail "thepants.com")))) 468 | rec)) 469 | ;; Mail is not notes. 470 | (should (null (car 471 | (ebdb-search 472 | (ebdb-records) 473 | '((ebdb-field-notes "thepants.com")))))) 474 | ;; Notes are notes. 475 | (should (equal (car 476 | (ebdb-search 477 | (ebdb-records) 478 | '((ebdb-field-notes "cartoon")))) 479 | rec)) 480 | ;; Notes inverted are not notes. 481 | (should (null (car 482 | (ebdb-search 483 | (ebdb-records) 484 | '((ebdb-field-notes "cartoon")) 485 | t)))) 486 | ;; Not notes inverted are. 487 | (should (equal (car 488 | (ebdb-search 489 | (ebdb-records) 490 | '((ebdb-field-notes "carton")) 491 | t)) 492 | rec)))))) 493 | 494 | ;; Test search folding and transform functions. 495 | 496 | (ert-deftest ebdb-search-transform-and-fold () 497 | (ebdb-test-with-records 498 | (let ((recs 499 | (list (make-instance 500 | 'ebdb-record-person 501 | :name (ebdb-parse 'ebdb-field-name-complex "Björk Jónsdóttir"))))) 502 | (ebdb-initialize recs) 503 | (let ((ebdb-case-fold-search nil) 504 | (ebdb-char-fold-search nil) 505 | (ebdb-search-transform-functions nil)) 506 | (should-not (ebdb-search 507 | recs 508 | '((ebdb-field-name "Bjork")))) 509 | (should-not (ebdb-search 510 | recs 511 | '((ebdb-field-name "björk")))) 512 | (should (ebdb-search 513 | recs 514 | '((ebdb-field-name "Björk"))))) 515 | 516 | (let ((ebdb-case-fold-search t) 517 | (ebdb-char-fold-search nil) 518 | (ebdb-search-transform-functions nil)) 519 | (should-not (ebdb-search 520 | recs 521 | '((ebdb-field-name "Bjork")))) 522 | (should (ebdb-search 523 | recs 524 | '((ebdb-field-name "björk")))) 525 | (should (ebdb-search 526 | recs 527 | '((ebdb-field-name "Björk"))))) 528 | 529 | (let ((ebdb-case-fold-search nil) 530 | (ebdb-char-fold-search t) 531 | (ebdb-search-transform-functions nil)) 532 | (should (ebdb-search 533 | recs 534 | '((ebdb-field-name "Bjork")))) 535 | (should-not (ebdb-search 536 | recs 537 | '((ebdb-field-name "björk")))) 538 | (should (ebdb-search 539 | recs 540 | '((ebdb-field-name "Björk"))))) 541 | 542 | (let ((ebdb-case-fold-search t) 543 | (ebdb-char-fold-search t) 544 | (ebdb-search-transform-functions nil)) 545 | (should (ebdb-search 546 | recs 547 | '((ebdb-field-name "Bjork")))) 548 | (should (ebdb-search 549 | recs 550 | '((ebdb-field-name "björk")))) 551 | (should (ebdb-search 552 | recs 553 | '((ebdb-field-name "Björk")))) 554 | 555 | (let ((ebdb-case-fold-search nil) 556 | (ebdb-char-fold-search nil) 557 | (ebdb-search-transform-functions 558 | (list (lambda (str) 559 | (concat str " Jonsdottir"))))) 560 | (should-not (ebdb-search 561 | recs 562 | '((ebdb-field-name "Björk"))))) 563 | 564 | (let ((ebdb-case-fold-search nil) 565 | (ebdb-char-fold-search t) 566 | (ebdb-search-transform-functions 567 | (list (lambda (str) 568 | (concat str " Jonsdottir"))))) 569 | (should (ebdb-search 570 | recs 571 | '((ebdb-field-name "Björk"))))))))) 572 | 573 | ;; Vcard testing. 574 | 575 | (ert-deftest ebdb-vcard-escape/unescape () 576 | "Test the escaping and unescaping routines." 577 | (should (equal (ebdb-vcard-escape "Nothing.to \"escape\"!") 578 | "Nothing.to \"escape\"!")) 579 | 580 | (should (equal (ebdb-vcard-escape "Marry, nuncle") 581 | "Marry\\, nuncle")) 582 | 583 | (should (equal (ebdb-vcard-escape "Mine uncle; nay!") 584 | "Mine uncle\\; nay!")) 585 | 586 | ;; Don't double-escape 587 | (should (equal (ebdb-vcard-escape "Marry\\, uncle") 588 | "Marry\\, uncle")) 589 | 590 | ;; Don't double-escape, part II 591 | (should (equal (ebdb-vcard-escape "Marry\\n uncle!") 592 | "Marry\\n uncle!")) 593 | 594 | (should (equal (ebdb-vcard-escape "Mine 595 | uncle") 596 | "Mine \\nuncle")) 597 | 598 | (should (equal (ebdb-vcard-unescape "Marry\\, nuncle!") 599 | "Marry, nuncle!")) 600 | 601 | (should (equal (ebdb-vcard-unescape "Marry \\nuncle") 602 | "Marry 603 | uncle")) 604 | 605 | (should (equal (ebdb-vcard-unescape 606 | (ebdb-vcard-escape 607 | "Look, a bog; dogs.")) 608 | "Look, a bog; dogs."))) 609 | 610 | (ert-deftest ebdb-vcard-fold/unfold () 611 | "Test line-length folding/unfolding." 612 | (let ((short-lines "For sale: 613 | Baby shoes, 614 | Never used.") 615 | (long-lines 616 | "Turns out seventy five bytes is a lot of bytes when you just have to keep typing and typing 617 | and typing.") 618 | (multibyte-lines 619 | "然后还要用中文写一行没完没了的话。 620 | 其实先要来一个短的，然后一行特别长的，那就是现在这行， 621 | 然后可以再有一个短的")) 622 | (should (equal (ebdb-vcard-fold-lines short-lines) 623 | "For sale: 624 | Baby shoes, 625 | Never used.")) 626 | (should (equal (ebdb-vcard-unfold-lines 627 | (ebdb-vcard-fold-lines short-lines)) 628 | short-lines)) 629 | (should 630 | (equal (ebdb-vcard-fold-lines long-lines) 631 | "Turns out seventy five bytes is a lot of bytes when you just have to keep t 632 | yping and typing 633 | and typing.")) 634 | (should 635 | (equal (ebdb-vcard-unfold-lines 636 | (ebdb-vcard-fold-lines long-lines)) 637 | long-lines)) 638 | (should 639 | (equal (ebdb-vcard-fold-lines multibyte-lines) 640 | "然后还要用中文写一行没完没了的话。 641 | 其实先要来一个短的，然后一行特别长的，那就是现在这 642 | 行， 643 | 然后可以再有一个短的")) 644 | (should 645 | (equal (ebdb-vcard-unfold-lines 646 | (ebdb-vcard-fold-lines multibyte-lines)) 647 | multibyte-lines)))) 648 | 649 | (ert-deftest ebdb-vcard-export-dont-explode () 650 | "Can we export a record to Vcard without immediate disaster?" 651 | (ebdb-test-with-records 652 | (let ((rec (make-instance ebdb-default-record-class 653 | :name (ebdb-field-name-complex 654 | :surname "Barleycorn" 655 | :given-names '("John")) 656 | :uuid (ebdb-field-uuid 657 | :uuid "asdfasdfadsf") 658 | :mail (list (ebdb-field-mail 659 | :mail "jb@barleycorn.com")) 660 | :phone (list (ebdb-field-phone 661 | :label "home" 662 | :country-code 1 663 | :area-code 555 664 | :number "5555555")) 665 | :notes (ebdb-field-notes 666 | :notes "He's in the fields"))) 667 | (fmt-4 668 | (ebdb-formatter-vcard-40 669 | :combine nil 670 | :collapse nil 671 | :include '(ebdb-field-uuid 672 | ebdb-field-name 673 | ebdb-field-mail 674 | ebdb-field-phone 675 | ebdb-field-mail))) 676 | (fmt-3 677 | (ebdb-formatter-vcard-30 678 | :combine nil 679 | :collapse nil 680 | :include '(ebdb-field-uuid 681 | ebdb-field-name 682 | ebdb-field-mail 683 | ebdb-field-phone 684 | ebdb-field-mail)))) 685 | 686 | (should (ebdb-fmt-record fmt-4 rec)) 687 | 688 | (should (ebdb-fmt-record fmt-3 rec))))) 689 | 690 | (provide 'ebdb-test) 691 | ;;; ebdb-test.el ends here 692 | -------------------------------------------------------------------------------- /ebdb-vcard.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-vcard.el --- vCard export and import routine for EBDB -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; This file contains formatting and parsing functions used to export 23 | ;; EBDB contacts to vcard format, and to create contacts from vcard 24 | ;; files. It only supports VCard versions 3.0 and 4.0. 25 | 26 | ;; https://tools.ietf.org/html/rfc6350 27 | 28 | ;;; Code: 29 | 30 | (require 'ebdb-format) 31 | 32 | (autoload 'calendar-gregorian-from-absolute "calendar") 33 | 34 | (defclass ebdb-formatter-vcard (ebdb-formatter-freeform) 35 | ((coding-system :initform 'utf-8-dos) 36 | (version-string 37 | :type string 38 | :allocation :class 39 | :documentation "The string to insert for this formatter's 40 | version.")) 41 | :abstract t 42 | :documentation "Base formatter for vCard export.") 43 | 44 | (defclass ebdb-formatter-vcard-30 (ebdb-formatter-vcard) 45 | ((version-string 46 | :initform "3.0")) 47 | :documentation "Formatter for vCard format 3.0.") 48 | 49 | (defclass ebdb-formatter-vcard-40 (ebdb-formatter-vcard) 50 | ((version-string 51 | :initform "4.0")) 52 | :documentation "Formatter for vCard format 4.0.") 53 | 54 | (defgroup ebdb-vcard nil 55 | "Customization options for EBDB vCard support." 56 | :group 'ebdb) 57 | 58 | (defcustom ebdb-vcard-default-40-formatter 59 | (make-instance 'ebdb-formatter-vcard-40 60 | :label "VCard 4.0 (default)" 61 | :combine nil 62 | :collapse nil 63 | :include '(ebdb-field-uuid 64 | ebdb-field-timestamp 65 | ebdb-field-mail 66 | ebdb-field-name 67 | ebdb-field-address 68 | ebdb-field-url 69 | ebdb-field-role 70 | ebdb-field-anniversary 71 | ebdb-field-relation 72 | ebdb-field-phone 73 | ebdb-field-notes 74 | ebdb-field-tags) 75 | :header nil) 76 | "The default formatter for VCard 4.0 exportation." 77 | :type 'ebdb-formatter-vcard) 78 | 79 | (defcustom ebdb-vcard-default-30-formatter 80 | (make-instance 'ebdb-formatter-vcard-30 81 | :label "VCard 3.0 (default)" 82 | :combine nil 83 | :collapse nil 84 | :include '(ebdb-field-uuid 85 | ebdb-field-timestamp 86 | ebdb-field-mail 87 | ebdb-field-name 88 | ebdb-field-address 89 | ebdb-field-url 90 | ebdb-field-role 91 | ebdb-field-anniversary 92 | ebdb-field-relation 93 | ebdb-field-phone 94 | ebdb-field-notes 95 | ebdb-field-tags) 96 | :header nil) 97 | "The default formatter for VCard 3.0 exportation." 98 | :type 'ebdb-formatter-vcard) 99 | 100 | (defcustom ebdb-vcard-label-alist 101 | '(("REV" . ebdb-field-timestamp) 102 | ("NOTE" . ebdb-field-notes) 103 | ("X-CREATION-DATE" . ebdb-field-creation-date) 104 | ("UID" . ebdb-field-uuid) 105 | ("EMAIL" . ebdb-field-mail) 106 | ("TEL" . ebdb-field-phone) 107 | ("RELATED" . ebdb-field-relation) 108 | ("CATEGORIES" . ebdb-field-tags) 109 | ("BDAY" . ebdb-field-anniversary) 110 | ("ANNIVERSARY" . ebdb-field-anniversary) 111 | ("URL" . ebdb-field-url) 112 | ("ADR" . ebdb-field-address) 113 | ("NICKNAME" . ebdb-field-name-complex)) 114 | "Correspondences between VCard properties and EBDB field classes. 115 | 116 | This alist is neither exhaustive nor authoritative. It's purpose 117 | is to simplify property labeling during the export process, and 118 | to classify properties during import. The import process does 119 | not always respect these headings." 120 | :type '(repeat 121 | (cons string symbol))) 122 | 123 | (defsubst ebdb-vcard-escape (str) 124 | "Escape commas, semi-colons and newlines in STR." 125 | (replace-regexp-in-string 126 | "\\([^\\]\\)\\([\n]+\\)" "\\1\\\\n" 127 | (replace-regexp-in-string "\\([^\\]\\)\\([,;]\\)" "\\1\\\\\\2" str))) 128 | 129 | (defsubst ebdb-vcard-unescape (str) 130 | "Unescape escaped commas, semicolons and newlines in STR." 131 | (replace-regexp-in-string 132 | "\\\\n" "\n" 133 | (replace-regexp-in-string 134 | "\\\\\\([,;]\\)" "\\1" str))) 135 | 136 | ;; The RFC says fold any lines longer than 75 octets, excluding the 137 | ;; line break. Folded lines are delineated by a CRLF plus a space or 138 | ;; tab. Multibyte characters must not be broken. 139 | 140 | ;; TODO: This implementation assumes that Emacs' internal coding 141 | ;; system is similar enough to the utf-8 that the file will eventually 142 | ;; be written in that `string-bytes' (which returns a length according 143 | ;; to Emacs' own coding) will map accurately to what eventually goes 144 | ;; in the file. Eli notes this is not really true, and could result 145 | ;; in unexpected behavior, and he recommends using 146 | ;; `filepos-to-bufferpos' instead. Presumably that would involve 147 | ;; /first/ writing the vcf file, then backtracking and checking for 148 | ;; correctness. 149 | (defun ebdb-vcard-fold-lines (text) 150 | "Fold lines in TEXT, which represents a vCard contact." 151 | (let ((lines (split-string text "\n")) 152 | outlines) 153 | (dolist (l lines) 154 | (while (> (string-bytes l) 75) ; Line is too long. 155 | (if (> (string-bytes l) (length l)) 156 | ;; Multibyte characters. 157 | (let ((acc (string-to-vector l))) 158 | (setq l nil) 159 | (while (> (string-bytes (concat acc)) 75) 160 | ;; Pop characters off the end of acc and stick them 161 | ;; back in l, until acc is short enough to go in 162 | ;; outlines. Probably hideously inefficient. 163 | (push (aref acc (1- (length acc))) l) 164 | (setq acc (substring acc 0 -1))) 165 | (push acc outlines) 166 | (setq l (concat " " l))) 167 | ;; No multibyte characters. 168 | (push (substring l 0 75) outlines) 169 | (setq l (concat " " (substring l 75))))) 170 | (push l outlines)) 171 | (mapconcat #'identity (nreverse outlines) "\n"))) 172 | 173 | (defun ebdb-vcard-unfold-lines (text) 174 | "Unfold lines in TEXT, which represents a vCard contact." 175 | (replace-regexp-in-string "\n[\s\t]" "" text)) 176 | 177 | (cl-defmethod ebdb-fmt-process-fields ((_f ebdb-formatter-vcard) 178 | (_record ebdb-record) 179 | field-list) 180 | field-list) 181 | 182 | (cl-defmethod ebdb-fmt-process-fields ((fmt ebdb-formatter-vcard) 183 | (record ebdb-record-person) 184 | field-list) 185 | "Process fields in FIELD-LIST. 186 | 187 | All this does is split role instances into multiple fields." 188 | (let (org out-list) 189 | (dolist (f field-list) 190 | (if (object-of-class-p f 'ebdb-field-role) 191 | ;; Split it apart. 192 | (with-slots (org-uuid mail fields defunct) f 193 | (unless defunct 194 | (setq org (ebdb-gethash org-uuid 'uuid)) 195 | ;; Store the name of the organization in the TYPE 196 | ;; parameter of the various properties. I'd rather 197 | ;; stick a UUID somewhere, but haven't immediately 198 | ;; figured out how that would be done. 199 | (push (cons "ORG" 200 | (ebdb-record-name-string org)) 201 | out-list) 202 | (push (cons (format "TITLE;TYPE=\"%s\"" 203 | (ebdb-record-name-string org)) 204 | (slot-value f 'label)) 205 | out-list) 206 | (when (or mail fields) 207 | (dolist (elt (cons mail fields)) 208 | (push (cons 209 | (format 210 | "%s;%s" 211 | (ebdb-fmt-field-label fmt elt 'normal record) 212 | (format "TYPE=\"%s\"" (ebdb-record-name-string org))) 213 | (ebdb-fmt-field fmt elt 'normal record)) 214 | out-list))))) 215 | (push f out-list))) 216 | out-list)) 217 | 218 | (cl-defmethod ebdb-fmt-record ((f ebdb-formatter-vcard) 219 | (r ebdb-record)) 220 | "Format a single record R in VCARD format." 221 | ;; Because of the simplicity of the VCARD format, we only collect 222 | ;; the fields, there's no need to sort them, and the only processing 223 | ;; that happens is for role fields. 224 | (let ((fields (ebdb-fmt-process-fields 225 | f r 226 | (ebdb-fmt-collect-fields f r))) 227 | header-fields body-fields) 228 | (setq header-fields 229 | (list (slot-value r 'name)) 230 | body-fields 231 | (mapcar 232 | (lambda (fld) 233 | ;; This is a silly hack, but... 234 | (if (consp fld) 235 | fld 236 | (cons (ebdb-fmt-field-label f fld 'normal r) 237 | (ebdb-fmt-field f fld 'normal r)))) 238 | fields)) 239 | (concat 240 | (format "BEGIN:VCARD\nVERSION:%s\n" 241 | (slot-value f 'version-string)) 242 | (ebdb-fmt-record-header f r header-fields) 243 | (ebdb-fmt-record-body f r body-fields) 244 | "\nEND:VCARD\n"))) 245 | 246 | (cl-defmethod ebdb-fmt-record-header ((f ebdb-formatter-vcard) 247 | (r ebdb-record) 248 | (fields list)) 249 | "Format the header of a VCARD record. 250 | 251 | VCARDs don't really have the concept of a \"header\", so this 252 | method is just responsible for formatting the record name." 253 | (let ((name (car fields))) 254 | (concat 255 | (format "FN:%s\n" (ebdb-string name)) 256 | (format "N;SORT-AS=\"%s\":%s\n" 257 | (ebdb-record-sortkey r) 258 | (ebdb-fmt-field f name 'normal r))))) 259 | 260 | (cl-defmethod ebdb-fmt-record-body ((_f ebdb-formatter-vcard) 261 | (_r ebdb-record) 262 | (fields list)) 263 | (mapconcat 264 | (lambda (f) 265 | (format "%s:%s" 266 | (car f) (cdr f))) 267 | fields 268 | "\n")) 269 | 270 | (cl-defmethod ebdb-fmt-record-body :around ((_f ebdb-formatter-vcard-40) 271 | (_r ebdb-record-person) 272 | (_fields list)) 273 | (let ((str (cl-call-next-method))) 274 | (concat str "\nKIND:individual"))) 275 | 276 | (cl-defmethod ebdb-fmt-record-body :around ((_f ebdb-formatter-vcard-40) 277 | (_r ebdb-record-organization) 278 | (_fields list)) 279 | (let ((str (cl-call-next-method))) 280 | (concat str "\nKIND:org"))) 281 | 282 | (cl-defmethod ebdb-fmt-field ((_f ebdb-formatter-vcard) 283 | (field ebdb-field) 284 | _style 285 | _record) 286 | (ebdb-vcard-escape (ebdb-string field))) 287 | 288 | (cl-defmethod ebdb-fmt-field-label ((_f ebdb-formatter-vcard) 289 | (field ebdb-field) 290 | _style 291 | _record) 292 | (car (rassoc (eieio-class-name 293 | (eieio-object-class field)) 294 | ebdb-vcard-label-alist))) 295 | 296 | (cl-defmethod ebdb-fmt-field ((_f ebdb-formatter-vcard) 297 | (mail ebdb-field-mail) 298 | _style 299 | _record) 300 | (slot-value mail 'mail)) 301 | 302 | (cl-defmethod ebdb-fmt-field ((_f ebdb-formatter-vcard) 303 | (ts ebdb-field-timestamp) 304 | _style 305 | _record) 306 | (format-time-string "%Y%m%dT%H%M%S%z" (slot-value ts 'timestamp) t)) 307 | 308 | (cl-defmethod ebdb-fmt-field ((_f ebdb-formatter-vcard) 309 | (name ebdb-field-name-complex) 310 | _style 311 | _record) 312 | (with-slots (surname given-names prefix suffix) name 313 | (format 314 | "%s;%s;%s;%s" 315 | (or surname "") 316 | (if given-names (mapconcat #'identity given-names ",")) 317 | (or prefix "") 318 | (or suffix "")))) 319 | 320 | (cl-defmethod ebdb-fmt-field-label ((_f ebdb-formatter-vcard) 321 | (_field ebdb-field-uuid) 322 | _style 323 | _record) 324 | (concat (cl-call-next-method) ":urn:uuid")) 325 | 326 | (cl-defmethod ebdb-fmt-field-label ((_f ebdb-formatter-vcard) 327 | (mail ebdb-field-mail) 328 | _style 329 | _record) 330 | (with-slots (priority) mail 331 | (concat 332 | (cl-call-next-method) 333 | (pcase priority 334 | ('primary ";PREF=1") 335 | ('normal ";PREF=10") 336 | ('defunct ";PREF=100") 337 | (_ ""))))) 338 | 339 | (cl-defmethod ebdb-fmt-field-label ((_f ebdb-formatter-vcard) 340 | (field ebdb-field-labeled) 341 | _style 342 | _record) 343 | (let ((ret (cl-call-next-method)) 344 | (lab (slot-value field 'label))) 345 | (if lab 346 | (concat ret 347 | ";TYPE=" (ebdb-vcard-escape lab)) 348 | ret))) 349 | 350 | (cl-defmethod ebdb-fmt-field ((_f ebdb-formatter-vcard) 351 | (addr ebdb-field-address) 352 | _style 353 | _record) 354 | (with-slots (streets locality region postcode country) addr 355 | (concat ";;" 356 | (mapconcat 357 | #'ebdb-vcard-escape 358 | streets ",") 359 | (format 360 | ";%s;%s;%s;%s" 361 | (or locality "") 362 | (or region "") 363 | (or postcode "") 364 | (or country ""))))) 365 | 366 | (cl-defmethod ebdb-fmt-field ((_f ebdb-formatter-vcard) 367 | (rel ebdb-field-relation) 368 | _style 369 | _record) 370 | (concat "urn:uuid:" (slot-value rel 'rel-uuid))) 371 | 372 | (cl-defmethod ebdb-fmt-field ((_f ebdb-formatter-vcard) 373 | (tags ebdb-field-tags) 374 | _style 375 | _record) 376 | (ebdb-concat "," (slot-value tags 'tags))) 377 | 378 | (cl-defmethod ebdb-fmt-field-label ((_f ebdb-formatter-vcard) 379 | (ann ebdb-field-anniversary) 380 | _style 381 | _record) 382 | (let* ((label (slot-value ann 'label)) 383 | (label-string 384 | (if (string= label "birthday") 385 | "BDAY" 386 | (concat "ANNIVERSARY;TYPE=" label)))) 387 | (concat label-string (format ";CALSCALE=%s" 388 | (slot-value ann 'calendar))))) 389 | 390 | (cl-defmethod ebdb-fmt-field ((_f ebdb-formatter-vcard) 391 | (ann ebdb-field-anniversary) 392 | _style 393 | _record) 394 | (pcase-let ((`(,month ,day ,year) 395 | (slot-value ann 'date))) 396 | (if (integerp year) 397 | (format "%d%02d%02d" year month day) 398 | (format "%02d%02d" month day)))) 399 | 400 | (provide 'ebdb-vcard) 401 | ;;; ebdb-vcard.el ends here 402 | -------------------------------------------------------------------------------- /ebdb-vm.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-vm.el --- EBDB interface to VM -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; EBDB's interface to VM. 23 | 24 | ;;; Code: 25 | 26 | (require 'ebdb-mua) 27 | 28 | (declare-function vm-check-for-killed-summary "ext:vm-misc") 29 | (declare-function vm-error-if-folder-empty "ext:vm-misc") 30 | (declare-function vm-get-header-contents "ext:vm-summary") 31 | (declare-function vm-su-to-names "ext:vm-summary") 32 | (declare-function vm-su-from "ext:vm-summary") 33 | (declare-function vm-su-to "ext:vm-summary") 34 | (declare-function vm-su-full-name "ext:vm-summary") 35 | (declare-function vm-su-interesting-full-name "ext:vm-summary") 36 | (declare-function vm-decode-mime-encoded-words-in-string "ext:vm-mime") 37 | (declare-function vm-follow-summary-cursor "ext:vm-motion") 38 | (declare-function vm-add-message-labels "ext:vm-undo") 39 | 40 | (defvar vm-summary-function-B) 41 | (defvar vm-summary-uninteresting-senders) 42 | (defvar vm-summary-uninteresting-senders-arrow) 43 | (defvar vm-message-pointer) 44 | (defvar vm-auto-folder-alist) 45 | (defvar vm-virtual-folder-alist) 46 | (defvar vm-folder-directory) 47 | (defvar vm-primary-inbox) 48 | (defvar vm-mode-map) 49 | 50 | (defgroup ebdb-mua-vm nil 51 | "VM-specific EBDB customizations" 52 | :group 'ebdb-mua) 53 | (put 'ebdb-mua-vm 'custom-loads '(ebdb-vm)) 54 | 55 | (defcustom ebdb-vm-auto-update-p ebdb-mua-reader-update-p 56 | "VM-specific value of `ebdb-mua-auto-update-p'." 57 | :type '(choice (const :tag "do nothing" nil) 58 | (const :tag "search for existing records" existing) 59 | (const :tag "update existing records" update) 60 | (const :tag "query for update or record creation" query) 61 | (const :tag "update or create automatically" create) 62 | (function :tag "User-defined function"))) 63 | 64 | (defun ebdb/vm-header (header) 65 | (save-current-buffer 66 | (with-no-warnings 67 | ;; This is a defsubst, and will cause compiler warnings if the 68 | ;; user doesn't actually have vm installed. 69 | (vm-select-folder-buffer)) 70 | (vm-check-for-killed-summary) 71 | (vm-error-if-folder-empty) 72 | (let ((enable-local-variables t)) 73 | (vm-get-header-contents (car vm-message-pointer) 74 | (concat header ":"))))) 75 | 76 | 77 | ;; By Alastair Burt 78 | ;; vm 5.40 and newer support a new summary format, %U, to call 79 | ;; a user-provided function. Use "%-17.17UB" instead of "%-17.17F" to 80 | ;; have your VM summary buffers display EBDB's idea of the sender's full 81 | ;; name instead of the name (or lack thereof) in the message itself. 82 | 83 | ;; RW: this is a VM-specific version of `ebdb-mua-summary-unify' 84 | ;; which respects `vm-summary-uninteresting-senders'. 85 | 86 | (defun vm-summary-function-B (m) 87 | "For VM message M return the EBDB name of the sender. 88 | Respect `vm-summary-uninteresting-senders'." 89 | (if vm-summary-uninteresting-senders 90 | (if (let ((case-fold-search t)) 91 | (string-match vm-summary-uninteresting-senders (vm-su-from m))) 92 | (concat vm-summary-uninteresting-senders-arrow 93 | (or (ebdb/vm-alternate-full-name (vm-su-to m)) 94 | (vm-decode-mime-encoded-words-in-string 95 | (vm-su-to-names m)))) 96 | (or (ebdb/vm-alternate-full-name (vm-su-from m)) 97 | (vm-su-full-name m))) 98 | (or (ebdb/vm-alternate-full-name (vm-su-from m)) 99 | (vm-decode-mime-encoded-words-in-string (vm-su-full-name m))))) 100 | 101 | (defun ebdb/vm-alternate-full-name (address) 102 | (if address 103 | (let* ((data (ebdb-extract-address-components address)) 104 | (record (car (ebdb-message-search (car data) (cadr data))))) 105 | (if record 106 | (or (slot-value (ebdb-record-one-mail record) 'aka) 107 | (ebdb-record-name-string record)))))) 108 | 109 | 110 | 111 | (defcustom ebdb-vm-window-size ebdb-default-window-size 112 | "Size of the EBDB buffer when popping up in VM. 113 | Size should be specified as a float between 0 and 1. Defaults to 114 | the value of `ebdb-default-window-size'." 115 | :type 'float) 116 | 117 | ;;;###autoload 118 | (defcustom ebdb/vm-auto-folder-headers '("From:" "To:" "CC:") 119 | "The headers used by `ebdb/vm-auto-folder'. 120 | The order in this list is the order how matching will be performed." 121 | :type '(repeat (string :tag "header name"))) 122 | 123 | ;;;###autoload 124 | (defcustom ebdb/vm-auto-folder-field "vm-folder" 125 | "The xfield which `ebdb/vm-auto-folder' searches for." 126 | :type 'symbol) 127 | 128 | ;;;###autoload 129 | (defcustom ebdb/vm-virtual-folder-field "vm-virtual" 130 | "The xfield which `ebdb/vm-virtual-folder' searches for." 131 | :type 'symbol) 132 | 133 | ;;;###autoload 134 | (defcustom ebdb/vm-virtual-real-folders nil 135 | "Real folders used for defining virtual folders. 136 | If nil use `vm-primary-inbox'." 137 | :type '(choice (const :tag "Use vm-primary-inbox" nil) 138 | (repeat (string :tag "Real folder")))) 139 | 140 | ;;;###autoload 141 | (defun ebdb/vm-auto-folder () 142 | "Add entries to `vm-auto-folder-alist' for the records in EBDB. 143 | For each record that has a `vm-folder' field, add an element 144 | \(MAIL-REGEXP . FOLDER-NAME) to `vm-auto-folder-alist'. 145 | The element gets added to the sublists of `vm-auto-folder-alist' 146 | specified in `ebdb/vm-auto-folder-headers'. 147 | MAIL-REGEXP matches the mail addresses of the EBDB record. 148 | The value of the `vm-folder' field becomes FOLDER-NAME. 149 | The `vm-folder' field is defined via `ebdb/vm-auto-folder-field'. 150 | 151 | Add this function to `ebdb-before-save-hook' and your .vm." 152 | (interactive) 153 | (let ((records ; Collect EBDB records with a vm-folder field. 154 | (delq nil 155 | (mapcar (lambda (r) 156 | (if (ebdb-record-field r ebdb/vm-auto-folder-field) 157 | r)) 158 | (ebdb-records)))) 159 | folder-list folder-name mail-regexp) 160 | ;; Add (MAIL-REGEXP . FOLDER-NAME) pair to this sublist of `vm-auto-folder-alist' 161 | (dolist (header ebdb/vm-auto-folder-headers) 162 | ;; create the folder-list in `vm-auto-folder-alist' if it does not exist 163 | (unless (setq folder-list (assoc header vm-auto-folder-alist)) 164 | (push (list header) vm-auto-folder-alist) 165 | (setq folder-list (assoc header vm-auto-folder-alist))) 166 | (dolist (record records) 167 | ;; Ignore everything past a comma 168 | (setq folder-name (car (ebdb-record-field 169 | record ebdb/vm-auto-folder-field)) 170 | ;; quote all the mail addresses for the record and join them 171 | mail-regexp (regexp-opt (ebdb-record-mail record))) 172 | ;; In general, the values of fields are strings (required for editing). 173 | ;; If we could set the value of `ebdb/vm-auto-folder-field' to a symbol, 174 | ;; it could be a function that is called with arg record to calculate 175 | ;; the value of folder-name. 176 | ;; (if (functionp folder-name) 177 | ;; (setq folder-name (funcall folder-name record))) 178 | (unless (or (string= "" mail-regexp) 179 | (assoc mail-regexp folder-list)) 180 | ;; Convert relative into absolute file names using 181 | ;; `vm-folder-directory'. 182 | (unless (file-name-absolute-p folder-name) 183 | (setq folder-name (abbreviate-file-name 184 | (expand-file-name folder-name 185 | vm-folder-directory)))) 186 | ;; nconc modifies the list in place 187 | (nconc folder-list (list (cons mail-regexp folder-name)))))))) 188 | 189 | ;;;###autoload 190 | (defun ebdb/vm-virtual-folder () 191 | "Create `vm-virtual-folder-alist' according to the records in EBDB. 192 | For each record that has a `vm-virtual' field, add or modify the 193 | corresponding VIRTUAL-FOLDER-NAME element of `vm-virtual-folder-alist'. 194 | 195 | (VIRTUAL-FOLDER-NAME ((FOLDER-NAME ...) 196 | (author-or-recipient MAIL-REGEXP))) 197 | 198 | VIRTUAL-FOLDER-NAME is the first element of the `vm-virtual' field. 199 | FOLDER-NAME ... are either the remaining elements of the `vm-virtual' field, 200 | or `ebdb/vm-virtual-real-folders' or `vm-primary-inbox'. 201 | MAIL-REGEXP matches the mail addresses of the EBDB record. 202 | The `vm-virtual' field is defined via `ebdb/vm-virtual-folder-field'. 203 | 204 | Add this function to `ebdb-before-save-hook' and your .vm." 205 | (interactive) 206 | (let (real-folders mail-regexp folder val tmp) 207 | (dolist (record (ebdb-records)) 208 | (when (setq val (ebdb-record-field 209 | record ebdb/vm-virtual-folder-field)) 210 | (setq mail-regexp (regexp-opt (ebdb-record-mail record))) 211 | (unless (string= "" mail-regexp) 212 | (setq folder (car val) 213 | real-folders (mapcar 214 | (lambda (f) 215 | (if (file-name-absolute-p f) f 216 | (abbreviate-file-name 217 | (expand-file-name f vm-folder-directory)))) 218 | (or (cdr val) ebdb/vm-virtual-real-folders 219 | (list vm-primary-inbox))) 220 | ;; Either extend the definition of an already defined 221 | ;; virtual folder or define a new virtual folder 222 | tmp (or (assoc folder vm-virtual-folder-alist) 223 | (car (push (list folder) vm-virtual-folder-alist))) 224 | tmp (or (assoc real-folders (cdr tmp)) 225 | (car (setcdr tmp (cons (list real-folders) 226 | (cdr tmp))))) 227 | tmp (or (assoc 'author-or-recipient (cdr tmp)) 228 | (car (setcdr tmp (cons (list 'author-or-recipient) 229 | (cdr tmp)))))) 230 | (cond ((not (cdr tmp)) 231 | (setcdr tmp (list mail-regexp))) 232 | ((not (string-match (regexp-quote mail-regexp) 233 | (cadr tmp))) 234 | (setcdr tmp (list (concat (cadr tmp) "\\|" mail-regexp)))))))))) 235 | 236 | 237 | ;; RW: Adding custom labels to VM messages allows one to create, 238 | ;; for example, virtual folders. The following code creates 239 | ;; the required labels in a rather simplistic way, checking merely 240 | ;; whether the sender's EBDB record uses a certain mail alias. 241 | ;; (Note that `ebdb/vm-virtual-folder' can achieve the same goal, 242 | ;; yet this requires a second field that must be kept up-to-date, too.) 243 | ;; To make auto labels yet more useful, the code could allow more 244 | ;; sophisticated schemes, too. Are there real-world applications 245 | ;; for this? 246 | 247 | ;;; Howard Melman, contributed Jun 16 2000 248 | (defcustom ebdb/vm-auto-add-label-list nil 249 | "List used by `ebdb/vm-auto-add-label' to automatically label VM messages. 250 | Its elements may be strings used both as the field value to check for 251 | and as the label to apply to the message. 252 | If an element is a cons pair (VALUE . LABEL), VALUE is the field value 253 | to search for and LABEL is the label to apply." 254 | :type '(repeat string)) 255 | 256 | (defcustom ebdb/vm-auto-add-label-field 'ebdb-mail-alias-field 257 | "Fields used by `ebdb/vm-auto-add-label' to automatically label messages. 258 | This is either a single EBDB field or a list of fields that 259 | `ebdb/vm-auto-add-label' uses to check for labels to apply to a message. 260 | Defaults to `ebdb-mail-alias-field' which defaults to `mail-alias'." 261 | :type '(choice symbol (repeat symbol))) 262 | 263 | (defun ebdb/vm-auto-add-label (record) 264 | "Automatically add labels to VM messages. 265 | Add this to `ebdb-notice-record-hook' to check the messages noticed by EBDB. 266 | If the value of `ebdb/vm-auto-add-label-field' in the sender's EBDB record 267 | matches a value in `ebdb/vm-auto-add-label-list' then a VM label will be added 268 | to the message. Such VM labels can be used, e.g., to mark messages via 269 | `vm-mark-matching-messages' or to define virtual folders via 270 | `vm-create-virtual-folder' 271 | 272 | Typically `ebdb/vm-auto-add-label-field' and `ebdb/vm-auto-add-label-list' 273 | refer to mail aliases FOO used with multiple records. This adds a label FOO 274 | to all incoming messages matching FOO. Then VM can create a virtual folder 275 | for these messages. The concept of combining multiple recipients of an 276 | outgoing message in one mail alias thus gets extended to incoming messages 277 | from different senders." 278 | ;; This could go into `vm-arrived-message-hook' to check messages only once. 279 | (if (eq major-mode 'vm-mode) 280 | (let* ((xvalues 281 | ;; Inspect the relevant fields of RECORD 282 | (append 283 | (mapcar (lambda (field) 284 | (ebdb-record-field record field)) 285 | (cond ((listp ebdb/vm-auto-add-label-field) 286 | ebdb/vm-auto-add-label-field) 287 | ((stringp ebdb/vm-auto-add-label-field) 288 | (list ebdb/vm-auto-add-label-field)) 289 | (t (error "Bad value for ebdb/vm-auto-add-label-field")))))) 290 | ;; Collect the relevant labels from `ebdb/vm-auto-add-label-list' 291 | (labels 292 | (delq nil 293 | (mapcar (lambda (l) 294 | (cond ((stringp l) 295 | (if (member l xvalues) 296 | l)) 297 | ((and (consp l) 298 | (stringp (car l)) 299 | (stringp (cdr l))) 300 | (if (member (car l) xvalues) 301 | (cdr l))) 302 | (t 303 | (error "Malformed ebdb/vm-auto-add-label-list")))) 304 | ebdb/vm-auto-add-label-list)))) 305 | (if labels 306 | (vm-add-message-labels 307 | (mapconcat #'identity labels " ") 1))))) 308 | 309 | 310 | 311 | ;;; If vm has set up its various modes using `define-derived-mode' we 312 | ;;; should be able to collapse all these various methods into one that 313 | ;;; checks `derived-mode-p'. Check how to do that with &context. 314 | 315 | (cl-defmethod ebdb-popup-window (&context (major-mode vm-mode)) 316 | (let ((win [WHAT??])) 317 | (list win ebdb-vm-window-size))) 318 | 319 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode vm-mode)) 320 | "Produce a EBDB buffer name associated with VM mode." 321 | (format "*%s-VM*" ebdb-buffer-name)) 322 | 323 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode vm-presentation-mode)) 324 | "Produce a EBDB buffer name associated with VM mode." 325 | (format "*%s-VM*" ebdb-buffer-name)) 326 | 327 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode vm-summary-mode)) 328 | "Produce a EBDB buffer name associated with VM mode." 329 | (format "*%s-VM*" ebdb-buffer-name)) 330 | 331 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode vm-virtual-mode)) 332 | "Produce a EBDB buffer name associated with VM mode." 333 | (format "*%s-VM*" ebdb-buffer-name)) 334 | 335 | (cl-defmethod ebdb-mua-message-header ((header string) 336 | &context (major-mode vm-mode)) 337 | (ebdb/vm-header header)) 338 | 339 | (cl-defmethod ebdb-mua-message-header ((header string) 340 | &context (major-mode vm-virtual-mode)) 341 | (ebdb/vm-header header)) 342 | 343 | (cl-defmethod ebdb-mua-message-header ((header string) 344 | &context (major-mode vm-summary-mode)) 345 | (ebdb/vm-header header)) 346 | 347 | (cl-defmethod ebdb-mua-message-header ((header string) 348 | &context (major-mode vm-presentation-mode)) 349 | (ebdb/vm-header header)) 350 | 351 | (cl-defmethod ebdb-mua-prepare-article (&context (major-mode vm-mode)) 352 | (vm-follow-summary-cursor)) 353 | 354 | (cl-defmethod ebdb-mua-prepare-article (&context (major-mode vm-virtual-mode)) 355 | (vm-follow-summary-cursor)) 356 | 357 | (cl-defmethod ebdb-mua-prepare-article (&context (major-mode vm-summary-mode)) 358 | (vm-follow-summary-cursor)) 359 | 360 | (cl-defmethod ebdb-mua-prepare-article (&context (major-mode vm-presentation-mode)) 361 | (vm-follow-summary-cursor)) 362 | 363 | ;;;###autoload 364 | (defun ebdb-insinuate-vm () 365 | "Hook EBDB into VM." 366 | (unless ebdb-db-list 367 | (ebdb-load)) 368 | (define-key vm-mode-map ";" ebdb-mua-keymap) 369 | (define-key vm-mode-map "/" #'ebdb) 370 | ;; `mail-mode-map' is the parent of `vm-mail-mode-map'. 371 | ;; So the following is also done by `ebdb-insinuate-mail'. 372 | (if (and ebdb-complete-mail (boundp 'vm-mail-mode-map)) 373 | (define-key vm-mail-mode-map "\M-\t" #'ebdb-complete-mail)) 374 | 375 | ;; Set up user field for use in `vm-summary-format' 376 | ;; (1) Big solution: use whole name 377 | (if ebdb-mua-summary-unify-format-letter 378 | (fset (intern (concat "vm-summary-function-" 379 | ebdb-mua-summary-unify-format-letter)) 380 | (lambda (m) (ebdb-mua-summary-unify 381 | ;; VM does not give us the original From header. 382 | ;; So we have to work backwards. 383 | (let ((name (vm-decode-mime-encoded-words-in-string 384 | (vm-su-interesting-full-name m))) 385 | (mail (vm-su-from m))) 386 | (if (string= name mail) mail 387 | (format "\"%s\" <%s>" name mail))))))) 388 | 389 | ;; (2) Small solution: a mark for messages whos sender is in EBDB. 390 | (if ebdb-mua-summary-mark-format-letter 391 | (fset (intern (concat "vm-summary-function-" 392 | ebdb-mua-summary-mark-format-letter)) 393 | ;; VM does not give us the original From header. 394 | ;; So we assume that the mail address is sufficient to identify 395 | ;; the EBDB record of the sender. 396 | (lambda (m) (ebdb-mua-summary-mark (vm-su-from m)))))) 397 | 398 | ;;;###autoload 399 | (defun ebdb-vm-auto-update () 400 | (ebdb-mua-auto-update ebdb-vm-auto-update-p)) 401 | 402 | (add-hook 'vm-mode-hook #'ebdb-insinuate-vm) 403 | 404 | (add-hook 'vm-select-message-hook #'ebdb-vm-auto-update) 405 | 406 | (provide 'ebdb-vm) 407 | ;;; ebdb-vm.el ends here 408 | -------------------------------------------------------------------------------- /ebdb-wl.el: -------------------------------------------------------------------------------- 1 | ;;; ebdb-wl.el --- EBDB interface to Wanderlust -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2017-2024 Free Software Foundation, Inc. 4 | 5 | ;; Author: Eric Abrahamsen 6 | 7 | ;; This program is free software; you can redistribute it and/or modify 8 | ;; it under the terms of the GNU General Public License as published by 9 | ;; the Free Software Foundation, either version 3 of the License, or 10 | ;; (at your option) any later version. 11 | 12 | ;; This program is distributed in the hope that it will be useful, 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | ;; GNU General Public License for more details. 16 | 17 | ;; You should have received a copy of the GNU General Public License 18 | ;; along with this program. If not, see . 19 | 20 | ;;; Commentary: 21 | 22 | ;; EBDB's interface to the Wanderlust email client. 23 | 24 | ;;; Code: 25 | 26 | (require 'ebdb-mua) 27 | 28 | (autoload 'elmo-message-entity-field "ext:elmo-msgdb") 29 | (autoload 'elmo-message-entity "ext:elmo") 30 | (autoload 'wl-summary-message-number "ext:wl-summary") 31 | (autoload 'wl-summary-set-message-buffer-or-redisplay "ext:wl-summary") 32 | 33 | (defvar wl-current-summary-buffer) 34 | (defvar wl-summary-buffer-elmo-folder) 35 | (defvar wl-message-buffer) 36 | (defvar wl-summary-mode-map) 37 | (defvar wl-draft-mode-map) 38 | (defvar wl-folder-buffer-name) 39 | (defvar wl-highlight-signature-separator) 40 | (defvar mime-view-mode-default-map) 41 | 42 | (defgroup ebdb-mua-wl nil 43 | "Options for EBDB's interaction with Wanderlust." 44 | :group 'ebdb-mua) 45 | 46 | (defcustom ebdb-wl-auto-update-p ebdb-mua-reader-update-p 47 | "Wl-specific value of `ebdb-mua-auto-update-p'." 48 | :type '(choice (const :tag "do nothing" nil) 49 | (const :tag "search for existing records" existing) 50 | (const :tag "update existing records" update) 51 | (const :tag "query for update or record creation" query) 52 | (const :tag "update or create automatically" create) 53 | (function :tag "User-defined function"))) 54 | 55 | (defcustom ebdb-wl-window-size ebdb-default-window-size 56 | "Size of the EBDB buffer when popping up in Wanderlust. 57 | Size should be specified as a float between 0 and 1. Defaults to 58 | the value of `ebdb-default-window-size'." 59 | :type 'float) 60 | 61 | (cl-defmethod ebdb-mua-message-header ((header string) 62 | &context (major-mode mime-view-mode)) 63 | "Extract a message header in Wanderlust." 64 | (elmo-message-entity-field 65 | ;; It's possibly not safe to assume `wl-current-summary-buffer' is live? 66 | (with-current-buffer wl-current-summary-buffer 67 | (elmo-message-entity wl-summary-buffer-elmo-folder 68 | (wl-summary-message-number))) 69 | (intern (downcase header)) 'string)) 70 | 71 | (cl-defmethod ebdb-mua-message-header ((header string) 72 | &context (major-mode wl-summary-mode)) 73 | "Extract a message header in Wanderlust." 74 | (elmo-message-entity-field 75 | ;; It's possibly not safe to assume `wl-current-summary-buffer' is live? 76 | (with-current-buffer wl-current-summary-buffer 77 | (elmo-message-entity wl-summary-buffer-elmo-folder 78 | (wl-summary-message-number))) 79 | (intern (downcase header)) 'string)) 80 | 81 | (cl-defmethod ebdb-mua-prepare-article (&context (major-mode wl-summary-mode)) 82 | (wl-summary-set-message-buffer-or-redisplay)) 83 | 84 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode mime-view-mode)) 85 | (format "*%s-Wl*" ebdb-buffer-name)) 86 | 87 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode wl-summary-mode)) 88 | (format "*%s-Wl*" ebdb-buffer-name)) 89 | 90 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode wl-folder-mode)) 91 | (format "*%s-Wl*" ebdb-buffer-name)) 92 | 93 | (cl-defmethod ebdb-make-buffer-name (&context (major-mode wl-draft-mode)) 94 | (format "*%s-Wl-Draft*" ebdb-buffer-name)) 95 | 96 | (cl-defmethod ebdb-popup-window (&context (major-mode mime-view-mode)) 97 | (list (get-buffer-window) ebdb-wl-window-size)) 98 | 99 | (defsubst ebdb-wl-goto-signature (&optional beginning) 100 | "Goto the signature in the current message buffer. 101 | Leaves point at the end (or, with non-nil BEGINNING, the 102 | beginning) of the signature separator." 103 | (re-search-forward 104 | (mapconcat 105 | #'identity 106 | (cons "\n==+\n" wl-highlight-signature-separator) 107 | "\\|") 108 | (point-max) t) 109 | (when beginning 110 | (goto-char (match-beginning 0))) 111 | (point)) 112 | 113 | (cl-defmethod ebdb-mua-article-body (&context (major-mode wl-summary-mode)) 114 | (with-current-buffer wl-message-buffer 115 | (when (re-search-forward "^$" (point-max) t) 116 | (buffer-substring-no-properties 117 | (point) 118 | (or (ebdb-wl-goto-signature t) 119 | (point-max)))))) 120 | 121 | (cl-defmethod ebdb-mua-article-signature (&context (major-mode wl-summary-mode)) 122 | (with-current-buffer wl-message-buffer 123 | (when (re-search-forward "^$" (point-max) t) 124 | (or (and (ebdb-wl-goto-signature) 125 | (buffer-substring-no-properties (point) (point-max))) 126 | "")))) 127 | 128 | (defun ebdb-wl-quit-window () 129 | "Quit EBDB window when quitting WL summary buffer." 130 | ;; This runs in a hook, which are run in no buffer: we need to be in 131 | ;; a WL buffer in order to get back the correct EBDB buffer name. 132 | (with-current-buffer wl-folder-buffer-name 133 | (let ((win (get-buffer-window (ebdb-make-buffer-name)))) 134 | (when win 135 | (quit-window nil win))))) 136 | 137 | ;;;###autoload 138 | (defun ebdb-insinuate-wl () 139 | "Hook EBDB into Wanderlust." 140 | (unless ebdb-db-list 141 | (ebdb-load)) 142 | (define-key wl-summary-mode-map ";" ebdb-mua-keymap) 143 | (define-key mime-view-mode-default-map ";" ebdb-mua-keymap) 144 | (when ebdb-complete-mail 145 | (define-key wl-draft-mode-map (kbd "TAB") #'ebdb-complete-mail)) 146 | (add-hook 'wl-summary-exit-hook #'ebdb-wl-quit-window)) 147 | 148 | ;;;###autoload 149 | (defun ebdb-wl-auto-update () 150 | (ebdb-mua-auto-update ebdb-wl-auto-update-p)) 151 | 152 | (add-hook 'wl-folder-mode-hook #'ebdb-insinuate-wl) 153 | 154 | (add-hook 'wl-summary-redisplay-hook #'ebdb-wl-auto-update) 155 | 156 | (provide 'ebdb-wl) 157 | ;;; ebdb-wl.el ends here 158 | --------------------------------------------------------------------------------