1;;; notmuch-lib.el --- common variables, functions and function declarations -*- lexical-binding: t -*- 2;; 3;; Copyright © Carl Worth 4;; 5;; This file is part of Notmuch. 6;; 7;; Notmuch is free software: you can redistribute it and/or modify it 8;; 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;; Notmuch is distributed in the hope that it will be useful, but 13;; WITHOUT ANY WARRANTY; without even the implied warranty of 14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15;; General Public License for more details. 16;; 17;; You should have received a copy of the GNU General Public License 18;; along with Notmuch. If not, see <https://www.gnu.org/licenses/>. 19;; 20;; Authors: Carl Worth <cworth@cworth.org> 21 22;;; Code: 23 24(require 'cl-lib) 25(require 'pcase) 26(require 'subr-x) 27 28(require 'mm-util) 29(require 'mm-view) 30(require 'mm-decode) 31 32(require 'notmuch-compat) 33 34(unless (require 'notmuch-version nil t) 35 (defconst notmuch-emacs-version "unknown" 36 "Placeholder variable when notmuch-version.el[c] is not available.")) 37 38;;; Groups 39 40(defgroup notmuch nil 41 "Notmuch mail reader for Emacs." 42 :group 'mail) 43 44(defgroup notmuch-hello nil 45 "Overview of saved searches, tags, etc." 46 :group 'notmuch) 47 48(defgroup notmuch-search nil 49 "Searching and sorting mail." 50 :group 'notmuch) 51 52(defgroup notmuch-show nil 53 "Showing messages and threads." 54 :group 'notmuch) 55 56(defgroup notmuch-send nil 57 "Sending messages from Notmuch." 58 :group 'notmuch 59 :group 'message) 60 61(defgroup notmuch-tag nil 62 "Tags and tagging in Notmuch." 63 :group 'notmuch) 64 65(defgroup notmuch-crypto nil 66 "Processing and display of cryptographic MIME parts." 67 :group 'notmuch) 68 69(defgroup notmuch-hooks nil 70 "Running custom code on well-defined occasions." 71 :group 'notmuch) 72 73(defgroup notmuch-external nil 74 "Running external commands from within Notmuch." 75 :group 'notmuch) 76 77(defgroup notmuch-address nil 78 "Address completion." 79 :group 'notmuch) 80 81(defgroup notmuch-faces nil 82 "Graphical attributes for displaying text" 83 :group 'notmuch) 84 85;;; Options 86 87(defcustom notmuch-command "notmuch" 88 "Name of the notmuch binary. 89 90This can be a relative or absolute path to the notmuch binary. 91If this is a relative path, it will be searched for in all of the 92directories given in `exec-path' (which is, by default, based on 93$PATH)." 94 :type 'string 95 :group 'notmuch-external) 96 97(defcustom notmuch-search-oldest-first t 98 "Show the oldest mail first when searching. 99 100This variable defines the default sort order for displaying 101search results. Note that any filtered searches created by 102`notmuch-search-filter' retain the search order of the parent 103search." 104 :type 'boolean 105 :group 'notmuch-search) 106(make-variable-buffer-local 'notmuch-search-oldest-first) 107 108(defcustom notmuch-poll-script nil 109 "[Deprecated] Command to run to incorporate new mail into the notmuch database. 110 111This option has been deprecated in favor of \"notmuch new\" 112hooks (see man notmuch-hooks). To change the path to the notmuch 113binary, customize `notmuch-command'. 114 115This variable controls the action invoked by 116`notmuch-poll-and-refresh-this-buffer' (bound by default to 'G') 117to incorporate new mail into the notmuch database. 118 119If set to nil (the default), new mail is processed by invoking 120\"notmuch new\". Otherwise, this should be set to a string that 121gives the name of an external script that processes new mail. If 122set to the empty string, no command will be run. 123 124The external script could do any of the following depending on 125the user's needs: 126 1271. Invoke a program to transfer mail to the local mail store 1282. Invoke \"notmuch new\" to incorporate the new mail 1293. Invoke one or more \"notmuch tag\" commands to classify the mail" 130 :type '(choice (const :tag "notmuch new" nil) 131 (const :tag "Disabled" "") 132 (string :tag "Custom script")) 133 :group 'notmuch-external) 134 135(defcustom notmuch-archive-tags '("-inbox") 136 "List of tag changes to apply to a message or a thread when it is archived. 137 138Tags starting with \"+\" (or not starting with either \"+\" or 139\"-\") in the list will be added, and tags starting with \"-\" 140will be removed from the message or thread being archived. 141 142For example, if you wanted to remove an \"inbox\" tag and add an 143\"archived\" tag, you would set: 144 (\"-inbox\" \"+archived\")" 145 :type '(repeat string) 146 :group 'notmuch-search 147 :group 'notmuch-show) 148 149;;; Variables 150 151(defvar notmuch-search-history nil 152 "Variable to store notmuch searches history.") 153 154(defvar notmuch-common-keymap 155 (let ((map (make-sparse-keymap))) 156 (define-key map "?" 'notmuch-help) 157 (define-key map "v" 'notmuch-version) 158 (define-key map "q" 'notmuch-bury-or-kill-this-buffer) 159 (define-key map "s" 'notmuch-search) 160 (define-key map "t" 'notmuch-search-by-tag) 161 (define-key map "z" 'notmuch-tree) 162 (define-key map "u" 'notmuch-unthreaded) 163 (define-key map "m" 'notmuch-mua-new-mail) 164 (define-key map "g" 'notmuch-refresh-this-buffer) 165 (define-key map "=" 'notmuch-refresh-this-buffer) 166 (define-key map (kbd "M-=") 'notmuch-refresh-all-buffers) 167 (define-key map "G" 'notmuch-poll-and-refresh-this-buffer) 168 (define-key map "j" 'notmuch-jump-search) 169 map) 170 "Keymap shared by all notmuch modes.") 171 172;; By default clicking on a button does not select the window 173;; containing the button (as opposed to clicking on a widget which 174;; does). This means that the button action is then executed in the 175;; current selected window which can cause problems if the button 176;; changes the buffer (e.g., id: links) or moves point. 177;; 178;; This provides a button type which overrides mouse-action so that 179;; the button's window is selected before the action is run. Other 180;; notmuch buttons can get the same behaviour by inheriting from this 181;; button type. 182(define-button-type 'notmuch-button-type 183 'mouse-action (lambda (button) 184 (select-window (posn-window (event-start last-input-event))) 185 (button-activate button))) 186 187;;; CLI Utilities 188 189(defun notmuch-command-to-string (&rest args) 190 "Synchronously invoke \"notmuch\" with the given list of arguments. 191 192If notmuch exits with a non-zero status, output from the process 193will appear in a buffer named \"*Notmuch errors*\" and an error 194will be signaled. 195 196Otherwise the output will be returned." 197 (with-temp-buffer 198 (let ((status (apply #'notmuch--call-process notmuch-command nil t nil args)) 199 (output (buffer-string))) 200 (notmuch-check-exit-status status (cons notmuch-command args) output) 201 output))) 202 203(defvar notmuch--cli-sane-p nil 204 "Cache whether the CLI seems to be configured sanely.") 205 206(defun notmuch-cli-sane-p () 207 "Return t if the cli seems to be configured sanely." 208 (unless notmuch--cli-sane-p 209 (let ((status (notmuch--call-process notmuch-command nil nil nil 210 "config" "get" "user.primary_email"))) 211 (setq notmuch--cli-sane-p (= status 0)))) 212 notmuch--cli-sane-p) 213 214(defun notmuch-assert-cli-sane () 215 (unless (notmuch-cli-sane-p) 216 (notmuch-logged-error 217 "notmuch cli seems misconfigured or unconfigured." 218 "Perhaps you haven't run \"notmuch setup\" yet? Try running this 219on the command line, and then retry your notmuch command"))) 220 221(defun notmuch-cli-version () 222 "Return a string with the notmuch cli command version number." 223 (let ((long-string 224 ;; Trim off the trailing newline. 225 (substring (notmuch-command-to-string "--version") 0 -1))) 226 (if (string-match "^notmuch\\( version\\)? \\(.*\\)$" 227 long-string) 228 (match-string 2 long-string) 229 "unknown"))) 230 231(defvar notmuch-emacs-version) 232 233(defun notmuch-version () 234 "Display the notmuch version. 235The versions of the Emacs package and the `notmuch' executable 236should match, but if and only if they don't, then this command 237displays both values separately." 238 (interactive) 239 (let ((cli-version (notmuch-cli-version))) 240 (message "notmuch version %s" 241 (if (string= notmuch-emacs-version cli-version) 242 cli-version 243 (concat cli-version 244 " (emacs mua version " notmuch-emacs-version ")"))))) 245 246;;; Notmuch Configuration 247 248(defun notmuch-config-get (item) 249 "Return a value from the notmuch configuration." 250 (let* ((val (notmuch-command-to-string "config" "get" item)) 251 (len (length val))) 252 ;; Trim off the trailing newline (if the value is empty or not 253 ;; configured, there will be no newline). 254 (if (and (> len 0) 255 (= (aref val (- len 1)) ?\n)) 256 (substring val 0 -1) 257 val))) 258 259(defun notmuch-database-path () 260 "Return the database.path value from the notmuch configuration." 261 (notmuch-config-get "database.path")) 262 263(defun notmuch-user-name () 264 "Return the user.name value from the notmuch configuration." 265 (notmuch-config-get "user.name")) 266 267(defun notmuch-user-primary-email () 268 "Return the user.primary_email value from the notmuch configuration." 269 (notmuch-config-get "user.primary_email")) 270 271(defun notmuch-user-other-email () 272 "Return the user.other_email value (as a list) from the notmuch configuration." 273 (split-string (notmuch-config-get "user.other_email") "\n" t)) 274 275(defun notmuch-user-emails () 276 (cons (notmuch-user-primary-email) (notmuch-user-other-email))) 277 278;;; Commands 279 280(defun notmuch-poll () 281 "Run \"notmuch new\" or an external script to import mail. 282 283Invokes `notmuch-poll-script', \"notmuch new\", or does nothing 284depending on the value of `notmuch-poll-script'." 285 (interactive) 286 (message "Polling mail...") 287 (if (stringp notmuch-poll-script) 288 (unless (string-empty-p notmuch-poll-script) 289 (unless (equal (notmuch--call-process notmuch-poll-script nil nil) 0) 290 (error "Notmuch: poll script `%s' failed!" notmuch-poll-script))) 291 (notmuch-call-notmuch-process "new")) 292 (message "Polling mail...done")) 293 294(defun notmuch-bury-or-kill-this-buffer () 295 "Undisplay the current buffer. 296 297Bury the current buffer, unless there is only one window showing 298it, in which case it is killed." 299 (interactive) 300 (if (> (length (get-buffer-window-list nil nil t)) 1) 301 (bury-buffer) 302 (kill-buffer))) 303 304;;; Describe Key Bindings 305 306(defun notmuch-prefix-key-description (key) 307 "Given a prefix key code, return a human-readable string representation. 308 309This is basically just `format-kbd-macro' but we also convert ESC to M-." 310 (let* ((key-vector (if (vectorp key) key (vector key))) 311 (desc (format-kbd-macro key-vector))) 312 (if (string= desc "ESC") 313 "M-" 314 (concat desc " ")))) 315 316(defun notmuch-describe-key (actual-key binding prefix ua-keys tail) 317 "Prepend cons cells describing prefix-arg ACTUAL-KEY and ACTUAL-KEY to TAIL. 318 319It does not prepend if ACTUAL-KEY is already listed in TAIL." 320 (let ((key-string (concat prefix (key-description actual-key)))) 321 ;; We don't include documentation if the key-binding is 322 ;; over-ridden. Note, over-riding a binding automatically hides the 323 ;; prefixed version too. 324 (unless (assoc key-string tail) 325 (when (and ua-keys (symbolp binding) 326 (get binding 'notmuch-prefix-doc)) 327 ;; Documentation for prefixed command 328 (let ((ua-desc (key-description ua-keys))) 329 (push (cons (concat ua-desc " " prefix (format-kbd-macro actual-key)) 330 (get binding 'notmuch-prefix-doc)) 331 tail))) 332 ;; Documentation for command 333 (push (cons key-string 334 (or (and (symbolp binding) 335 (get binding 'notmuch-doc)) 336 (and (functionp binding) 337 (let ((doc (documentation binding))) 338 (and doc 339 (string-match "\\`.+" doc) 340 (match-string 0 doc)))))) 341 tail))) 342 tail) 343 344(defun notmuch-describe-remaps (remap-keymap ua-keys base-keymap prefix tail) 345 ;; Remappings are represented as a binding whose first "event" is 346 ;; 'remap. Hence, if the keymap has any remappings, it will have a 347 ;; binding whose "key" is 'remap, and whose "binding" is itself a 348 ;; keymap that maps not from keys to commands, but from old (remapped) 349 ;; functions to the commands to use in their stead. 350 (map-keymap (lambda (command binding) 351 (mapc (lambda (actual-key) 352 (setq tail 353 (notmuch-describe-key actual-key binding 354 prefix ua-keys tail))) 355 (where-is-internal command base-keymap))) 356 remap-keymap) 357 tail) 358 359(defun notmuch-describe-keymap (keymap ua-keys base-keymap &optional prefix tail) 360 "Return a list of cons cells, each describing one binding in KEYMAP. 361 362Each cons cell consists of a string giving a human-readable 363description of the key, and a one-line description of the bound 364function. See `notmuch-help' for an overview of how this 365documentation is extracted. 366 367UA-KEYS should be a key sequence bound to `universal-argument'. 368It will be used to describe bindings of commands that support a 369prefix argument. PREFIX and TAIL are used internally." 370 (map-keymap 371 (lambda (key binding) 372 (cond ((mouse-event-p key) nil) 373 ((keymapp binding) 374 (setq tail 375 (if (eq key 'remap) 376 (notmuch-describe-remaps 377 binding ua-keys base-keymap prefix tail) 378 (notmuch-describe-keymap 379 binding ua-keys base-keymap 380 (notmuch-prefix-key-description key) 381 tail)))) 382 (binding 383 (setq tail 384 (notmuch-describe-key (vector key) 385 binding prefix ua-keys tail))))) 386 keymap) 387 tail) 388 389(defun notmuch-substitute-command-keys (doc) 390 "Like `substitute-command-keys' but with documentation, not function names." 391 (let ((beg 0)) 392 (while (string-match "\\\\{\\([^}[:space:]]*\\)}" doc beg) 393 (let ((desc 394 (save-match-data 395 (let* ((keymap-name (substring doc 396 (match-beginning 1) 397 (match-end 1))) 398 (keymap (symbol-value (intern keymap-name))) 399 (ua-keys (where-is-internal 'universal-argument keymap t)) 400 (desc-alist (notmuch-describe-keymap keymap ua-keys keymap)) 401 (desc-list (mapcar (lambda (arg) 402 (concat (car arg) "\t" (cdr arg))) 403 desc-alist))) 404 (mapconcat #'identity desc-list "\n"))))) 405 (setq doc (replace-match desc 1 1 doc))) 406 (setq beg (match-end 0))) 407 doc)) 408 409(defun notmuch-help () 410 "Display help for the current notmuch mode. 411 412This is similar to `describe-function' for the current major 413mode, but bindings tables are shown with documentation strings 414rather than command names. By default, this uses the first line 415of each command's documentation string. A command can override 416this by setting the 'notmuch-doc property of its command symbol. 417A command that supports a prefix argument can explicitly document 418its prefixed behavior by setting the 'notmuch-prefix-doc property 419of its command symbol." 420 (interactive) 421 (let ((doc (substitute-command-keys 422 (notmuch-substitute-command-keys 423 (documentation major-mode t))))) 424 (with-current-buffer (generate-new-buffer "*notmuch-help*") 425 (insert doc) 426 (goto-char (point-min)) 427 (set-buffer-modified-p nil) 428 (view-buffer (current-buffer) 'kill-buffer-if-not-modified)))) 429 430(defun notmuch-subkeymap-help () 431 "Show help for a subkeymap." 432 (interactive) 433 (let* ((key (this-command-keys-vector)) 434 (prefix (make-vector (1- (length key)) nil)) 435 (i 0)) 436 (while (< i (length prefix)) 437 (aset prefix i (aref key i)) 438 (cl-incf i)) 439 (let* ((subkeymap (key-binding prefix)) 440 (ua-keys (where-is-internal 'universal-argument nil t)) 441 (prefix-string (notmuch-prefix-key-description prefix)) 442 (desc-alist (notmuch-describe-keymap 443 subkeymap ua-keys subkeymap prefix-string)) 444 (desc-list (mapcar (lambda (arg) (concat (car arg) "\t" (cdr arg))) 445 desc-alist)) 446 (desc (mapconcat #'identity desc-list "\n"))) 447 (with-help-window (help-buffer) 448 (with-current-buffer standard-output 449 (insert "\nPress 'q' to quit this window.\n\n") 450 (insert desc))) 451 (pop-to-buffer (help-buffer))))) 452 453;;; Refreshing Buffers 454 455(defvar-local notmuch-buffer-refresh-function nil 456 "Function to call to refresh the current buffer.") 457 458(defun notmuch-refresh-this-buffer () 459 "Refresh the current buffer." 460 (interactive) 461 (when notmuch-buffer-refresh-function 462 ;; Pass prefix argument, etc. 463 (call-interactively notmuch-buffer-refresh-function))) 464 465(defun notmuch-poll-and-refresh-this-buffer () 466 "Invoke `notmuch-poll' to import mail, then refresh the current buffer." 467 (interactive) 468 (notmuch-poll) 469 (notmuch-refresh-this-buffer)) 470 471(defun notmuch-refresh-all-buffers () 472 "Invoke `notmuch-refresh-this-buffer' on all notmuch major-mode buffers. 473 474The buffers are silently refreshed, i.e. they are not forced to 475be displayed." 476 (interactive) 477 (dolist (buffer (buffer-list)) 478 (let ((buffer-mode (buffer-local-value 'major-mode buffer))) 479 (when (memq buffer-mode '(notmuch-show-mode 480 notmuch-tree-mode 481 notmuch-search-mode 482 notmuch-hello-mode)) 483 (with-current-buffer buffer 484 (notmuch-refresh-this-buffer)))))) 485 486;;; String Utilities 487 488(defun notmuch-prettify-subject (subject) 489 ;; This function is used by `notmuch-search-process-filter', 490 ;; which requires that we not disrupt its matching state. 491 (save-match-data 492 (if (and subject 493 (string-match "^[ \t]*$" subject)) 494 "[No Subject]" 495 subject))) 496 497(defun notmuch-sanitize (str) 498 "Sanitize control character in STR. 499 500This includes newlines, tabs, and other funny characters." 501 (replace-regexp-in-string "[[:cntrl:]\x7f\u2028\u2029]+" " " str)) 502 503(defun notmuch-escape-boolean-term (term) 504 "Escape a boolean term for use in a query. 505 506The caller is responsible for prepending the term prefix and a 507colon. This performs minimal escaping in order to produce 508user-friendly queries." 509 (save-match-data 510 (if (or (equal term "") 511 ;; To be pessimistic, only pass through terms composed 512 ;; entirely of ASCII printing characters other than ", (, 513 ;; and ). 514 (string-match "[^!#-'*-~]" term)) 515 ;; Requires escaping 516 (concat "\"" (replace-regexp-in-string "\"" "\"\"" term t t) "\"") 517 term))) 518 519(defun notmuch-id-to-query (id) 520 "Return a query that matches the message with id ID." 521 (concat "id:" (notmuch-escape-boolean-term id))) 522 523(defun notmuch-hex-encode (str) 524 "Hex-encode STR (e.g., as used by batch tagging). 525 526This replaces spaces, percents, and double quotes in STR with 527%NN where NN is the hexadecimal value of the character." 528 (replace-regexp-in-string 529 "[ %\"]" (lambda (match) (format "%%%02x" (aref match 0))) str)) 530 531(defun notmuch-common-do-stash (text) 532 "Common function to stash text in kill ring, and display in minibuffer." 533 (if text 534 (progn 535 (kill-new text) 536 (message "Stashed: %s" text)) 537 ;; There is nothing to stash so stash an empty string so the user 538 ;; doesn't accidentally paste something else somewhere. 539 (kill-new "") 540 (message "Nothing to stash!"))) 541 542;;; Generic Utilities 543 544(defun notmuch-plist-delete (plist property) 545 (let (p) 546 (while plist 547 (unless (eq property (car plist)) 548 (setq p (plist-put p (car plist) (cadr plist)))) 549 (setq plist (cddr plist))) 550 p)) 551 552;;; MML Utilities 553 554(defun notmuch-match-content-type (t1 t2) 555 "Return t if t1 and t2 are matching content types. 556Take wildcards into account." 557 (and (stringp t1) 558 (stringp t2) 559 (let ((st1 (split-string t1 "/")) 560 (st2 (split-string t2 "/"))) 561 (if (or (string= (cadr st1) "*") 562 (string= (cadr st2) "*")) 563 ;; Comparison of content types should be case insensitive. 564 (string= (downcase (car st1)) 565 (downcase (car st2))) 566 (string= (downcase t1) 567 (downcase t2)))))) 568 569(defvar notmuch-multipart/alternative-discouraged 570 '(;; Avoid HTML parts. 571 "text/html" 572 ;; multipart/related usually contain a text/html part and some 573 ;; associated graphics. 574 "multipart/related")) 575 576(defun notmuch-multipart/alternative-determine-discouraged (msg) 577 "Return the discouraged alternatives for the specified message." 578 ;; If a function, return the result of calling it. 579 (if (functionp notmuch-multipart/alternative-discouraged) 580 (funcall notmuch-multipart/alternative-discouraged msg) 581 ;; Otherwise simply return the value of the variable, which is 582 ;; assumed to be a list of discouraged alternatives. This is the 583 ;; default behaviour. 584 notmuch-multipart/alternative-discouraged)) 585 586(defun notmuch-multipart/alternative-choose (msg types) 587 "Return a list of preferred types from the given list of types 588for this message, if present." 589 ;; Based on `mm-preferred-alternative-precedence'. 590 (let ((discouraged (notmuch-multipart/alternative-determine-discouraged msg)) 591 (seq types)) 592 (dolist (pref (reverse discouraged)) 593 (dolist (elem (copy-sequence seq)) 594 (when (string-match pref elem) 595 (setq seq (nconc (delete elem seq) (list elem)))))) 596 seq)) 597 598(defun notmuch-parts-filter-by-type (parts type) 599 "Given a list of message parts, return a list containing the ones matching 600the given type." 601 (cl-remove-if-not 602 (lambda (part) (notmuch-match-content-type (plist-get part :content-type) type)) 603 parts)) 604 605(defun notmuch--get-bodypart-raw (msg part process-crypto binaryp cache) 606 (let* ((plist-elem (if binaryp :content-binary :content)) 607 (data (or (plist-get part plist-elem) 608 (with-temp-buffer 609 ;; Emacs internally uses a UTF-8-like multibyte string 610 ;; representation by default (regardless of the coding 611 ;; system, which only affects how it goes from outside data 612 ;; to this internal representation). This *almost* never 613 ;; matters. Annoyingly, it does matter if we use this data 614 ;; in an image descriptor, since Emacs will use its internal 615 ;; data buffer directly and this multibyte representation 616 ;; corrupts binary image formats. Since the caller is 617 ;; asking for binary data, a unibyte string is a more 618 ;; appropriate representation anyway. 619 (when binaryp 620 (set-buffer-multibyte nil)) 621 (let ((args `("show" "--format=raw" 622 ,(format "--part=%s" (plist-get part :id)) 623 ,@(and process-crypto '("--decrypt=true")) 624 ,(notmuch-id-to-query (plist-get msg :id)))) 625 (coding-system-for-read 626 (if binaryp 627 'no-conversion 628 (let ((coding-system 629 (mm-charset-to-coding-system 630 (plist-get part :content-charset)))) 631 ;; Sadly, 632 ;; `mm-charset-to-coding-system' seems 633 ;; to return things that are not 634 ;; considered acceptable values for 635 ;; `coding-system-for-read'. 636 (if (coding-system-p coding-system) 637 coding-system 638 ;; RFC 2047 says that the default 639 ;; charset is US-ASCII. RFC6657 640 ;; complicates this somewhat. 641 'us-ascii))))) 642 (apply #'notmuch--call-process 643 notmuch-command nil '(t nil) nil args) 644 (buffer-string)))))) 645 (when (and cache data) 646 (plist-put part plist-elem data)) 647 data)) 648 649(defun notmuch-get-bodypart-binary (msg part process-crypto &optional cache) 650 "Return the unprocessed content of PART in MSG as a unibyte string. 651 652This returns the \"raw\" content of the given part after content 653transfer decoding, but with no further processing (see the 654discussion of --format=raw in man notmuch-show). In particular, 655this does no charset conversion. 656 657If CACHE is non-nil, the content of this part will be saved in 658MSG (if it isn't already)." 659 (notmuch--get-bodypart-raw msg part process-crypto t cache)) 660 661(defun notmuch-get-bodypart-text (msg part process-crypto &optional cache) 662 "Return the text content of PART in MSG. 663 664This returns the content of the given part as a multibyte Lisp 665string after performing content transfer decoding and any 666necessary charset decoding. 667 668If CACHE is non-nil, the content of this part will be saved in 669MSG (if it isn't already)." 670 (notmuch--get-bodypart-raw msg part process-crypto nil cache)) 671 672(defun notmuch-mm-display-part-inline (msg part content-type process-crypto) 673 "Use the mm-decode/mm-view functions to display a part in the 674current buffer, if possible." 675 (let ((display-buffer (current-buffer))) 676 (with-temp-buffer 677 ;; In case we already have :content, use it and tell mm-* that 678 ;; it's already been charset-decoded by using the fake 679 ;; `gnus-decoded' charset. Otherwise, we'll fetch the binary 680 ;; part content and let mm-* decode it. 681 (let* ((have-content (plist-member part :content)) 682 (charset (if have-content 683 'gnus-decoded 684 (plist-get part :content-charset))) 685 (handle (mm-make-handle (current-buffer) 686 `(,content-type (charset . ,charset))))) 687 ;; If the user wants the part inlined, insert the content and 688 ;; test whether we are able to inline it (which includes both 689 ;; capability and suitability tests). 690 (when (mm-inlined-p handle) 691 (if have-content 692 (insert (notmuch-get-bodypart-text msg part process-crypto)) 693 (insert (notmuch-get-bodypart-binary msg part process-crypto))) 694 (when (mm-inlinable-p handle) 695 (set-buffer display-buffer) 696 (mm-display-part handle) 697 t)))))) 698 699;;; Generic Utilities 700 701;; Converts a plist of headers to an alist of headers. The input plist should 702;; have symbols of the form :Header as keys, and the resulting alist will have 703;; symbols of the form 'Header as keys. 704(defun notmuch-headers-plist-to-alist (plist) 705 (cl-loop for (key value . rest) on plist by #'cddr 706 collect (cons (intern (substring (symbol-name key) 1)) value))) 707 708(defun notmuch-face-ensure-list-form (face) 709 "Return FACE in face list form. 710 711If FACE is already a face list, it will be returned as-is. If 712FACE is a face name or face plist, it will be returned as a 713single element face list." 714 (if (and (listp face) (not (keywordp (car face)))) 715 face 716 (list face))) 717 718(defun notmuch-apply-face (object face &optional below start end) 719 "Combine FACE into the 'face text property of OBJECT between START and END. 720 721This function combines FACE with any existing faces between START 722and END in OBJECT. Attributes specified by FACE take precedence 723over existing attributes unless BELOW is non-nil. 724 725OBJECT may be a string, a buffer, or nil (which means the current 726buffer). If object is a string, START and END are 0-based; 727otherwise they are buffer positions (integers or markers). FACE 728must be a face name (a symbol or string), a property list of face 729attributes, or a list of these. If START and/or END are omitted, 730they default to the beginning/end of OBJECT. For convenience 731when applied to strings, this returns OBJECT." 732 ;; A face property can have three forms: a face name (a string or 733 ;; symbol), a property list, or a list of these two forms. In the 734 ;; list case, the faces will be combined, with the earlier faces 735 ;; taking precedent. Here we canonicalize everything to list form 736 ;; to make it easy to combine. 737 (let ((pos (cond (start start) 738 ((stringp object) 0) 739 (t 1))) 740 (end (cond (end end) 741 ((stringp object) (length object)) 742 (t (1+ (buffer-size object))))) 743 (face-list (notmuch-face-ensure-list-form face))) 744 (while (< pos end) 745 (let* ((cur (get-text-property pos 'face object)) 746 (cur-list (notmuch-face-ensure-list-form cur)) 747 (new (cond ((null cur-list) face) 748 (below (append cur-list face-list)) 749 (t (append face-list cur-list)))) 750 (next (next-single-property-change pos 'face object end))) 751 (put-text-property pos next 'face new object) 752 (setq pos next)))) 753 object) 754 755(defun notmuch-map-text-property (start end prop func &optional object) 756 "Transform text property PROP using FUNC. 757 758Applies FUNC to each distinct value of the text property PROP 759between START and END of OBJECT, setting PROP to the value 760returned by FUNC." 761 (while (< start end) 762 (let ((value (get-text-property start prop object)) 763 (next (next-single-property-change start prop object end))) 764 (put-text-property start next prop (funcall func value) object) 765 (setq start next)))) 766 767;;; Running Notmuch 768 769(defun notmuch-logged-error (msg &optional extra) 770 "Log MSG and EXTRA to *Notmuch errors* and signal MSG. 771 772This logs MSG and EXTRA to the *Notmuch errors* buffer and 773signals MSG as an error. If EXTRA is non-nil, text referring the 774user to the *Notmuch errors* buffer will be appended to the 775signaled error. This function does not return." 776 (with-current-buffer (get-buffer-create "*Notmuch errors*") 777 (goto-char (point-max)) 778 (unless (bobp) 779 (newline)) 780 (save-excursion 781 (insert "[" (current-time-string) "]\n" msg) 782 (unless (bolp) 783 (newline)) 784 (when extra 785 (insert extra) 786 (unless (bolp) 787 (newline))))) 788 (error "%s%s" msg (if extra " (see *Notmuch errors* for more details)" ""))) 789 790(defun notmuch-check-async-exit-status (proc msg &optional command err) 791 "If PROC exited abnormally, pop up an error buffer and signal an error. 792 793This is a wrapper around `notmuch-check-exit-status' for 794asynchronous process sentinels. PROC and MSG must be the 795arguments passed to the sentinel. COMMAND and ERR, if provided, 796are passed to `notmuch-check-exit-status'. If COMMAND is not 797provided, it is taken from `process-command'." 798 (let ((exit-status 799 (cl-case (process-status proc) 800 ((exit) (process-exit-status proc)) 801 ((signal) msg)))) 802 (when exit-status 803 (notmuch-check-exit-status exit-status 804 (or command (process-command proc)) 805 nil err)))) 806 807(defun notmuch-check-exit-status (exit-status command &optional output err) 808 "If EXIT-STATUS is non-zero, pop up an error buffer and signal an error. 809 810If EXIT-STATUS is non-zero, pop up a notmuch error buffer 811describing the error and signal an Elisp error. EXIT-STATUS must 812be a number indicating the exit status code of a process or a 813string describing the signal that terminated the process (such as 814returned by `call-process'). COMMAND must be a list giving the 815command and its arguments. OUTPUT, if provided, is a string 816giving the output of command. ERR, if provided, is the error 817output of command. OUTPUT and ERR will be included in the error 818message." 819 (cond 820 ((eq exit-status 0) t) 821 ((eq exit-status 20) 822 (notmuch-logged-error "notmuch CLI version mismatch 823Emacs requested an older output format than supported by the notmuch CLI. 824You may need to restart Emacs or upgrade your notmuch Emacs package.")) 825 ((eq exit-status 21) 826 (notmuch-logged-error "notmuch CLI version mismatch 827Emacs requested a newer output format than supported by the notmuch CLI. 828You may need to restart Emacs or upgrade your notmuch package.")) 829 (t 830 (pcase-let* 831 ((`(,command . ,args) command) 832 (command (if (equal (file-name-nondirectory command) 833 notmuch-command) 834 notmuch-command 835 command)) 836 (command-string 837 (mapconcat (lambda (arg) 838 (shell-quote-argument 839 (cond ((stringp arg) arg) 840 ((symbolp arg) (symbol-name arg)) 841 (t "*UNKNOWN ARGUMENT*")))) 842 (cons command args) 843 " ")) 844 (extra 845 (concat "command: " command-string "\n" 846 (if (integerp exit-status) 847 (format "exit status: %s\n" exit-status) 848 (format "exit signal: %s\n" exit-status)) 849 (and err (concat "stderr:\n" err)) 850 (and output (concat "stdout:\n" output))))) 851 (if err 852 ;; We have an error message straight from the CLI. 853 (notmuch-logged-error 854 (replace-regexp-in-string "[ \n\r\t\f]*\\'" "" err) extra) 855 ;; We only have combined output from the CLI; don't inundate 856 ;; the user with it. Mimic `process-lines'. 857 (notmuch-logged-error (format "%s exited with status %s" 858 command exit-status) 859 extra)) 860 ;; `notmuch-logged-error' does not return. 861 )))) 862 863(defmacro notmuch--apply-with-env (func &rest args) 864 `(let ((default-directory "~")) 865 (apply ,func ,@args))) 866 867(defun notmuch--process-lines (program &rest args) 868 "Wrap process-lines, binding DEFAULT-DIRECTORY to a safe 869default" 870 (notmuch--apply-with-env #'process-lines program args)) 871 872(defun notmuch--make-process (&rest args) 873 "Wrap make-process, binding DEFAULT-DIRECTORY to a safe 874default" 875 (notmuch--apply-with-env #'make-process args)) 876 877(defun notmuch--call-process-region (start end program 878 &optional delete buffer display 879 &rest args) 880 "Wrap call-process-region, binding DEFAULT-DIRECTORY to a safe 881default" 882 (notmuch--apply-with-env 883 #'call-process-region start end program delete buffer display args)) 884 885(defun notmuch--call-process (program &optional infile destination display &rest args) 886 "Wrap call-process, binding DEFAULT-DIRECTORY to a safe default" 887 (notmuch--apply-with-env #'call-process program infile destination display args)) 888 889(defun notmuch-call-notmuch--helper (destination args) 890 "Helper for synchronous notmuch invocation commands. 891 892This wraps `call-process'. DESTINATION has the same meaning as 893for `call-process'. ARGS is as described for 894`notmuch-call-notmuch-process'." 895 (let (stdin-string) 896 (while (keywordp (car args)) 897 (cl-case (car args) 898 (:stdin-string (setq stdin-string (cadr args)) 899 (setq args (cddr args))) 900 (otherwise 901 (error "Unknown keyword argument: %s" (car args))))) 902 (if (null stdin-string) 903 (apply #'notmuch--call-process notmuch-command nil destination nil args) 904 (insert stdin-string) 905 (apply #'notmuch--call-process-region (point-min) (point-max) 906 notmuch-command t destination nil args)))) 907 908(defun notmuch-call-notmuch-process (&rest args) 909 "Synchronously invoke `notmuch-command' with ARGS. 910 911The caller may provide keyword arguments before ARGS. Currently 912supported keyword arguments are: 913 914 :stdin-string STRING - Write STRING to stdin 915 916If notmuch exits with a non-zero status, output from the process 917will appear in a buffer named \"*Notmuch errors*\" and an error 918will be signaled." 919 (with-temp-buffer 920 (let ((status (notmuch-call-notmuch--helper t args))) 921 (notmuch-check-exit-status status (cons notmuch-command args) 922 (buffer-string))))) 923 924(defun notmuch-call-notmuch-sexp (&rest args) 925 "Invoke `notmuch-command' with ARGS and return the parsed S-exp output. 926 927This is equivalent to `notmuch-call-notmuch-process', but parses 928notmuch's output as an S-expression and returns the parsed value. 929Like `notmuch-call-notmuch-process', if notmuch exits with a 930non-zero status, this will report its output and signal an 931error." 932 (with-temp-buffer 933 (let ((err-file (make-temp-file "nmerr"))) 934 (unwind-protect 935 (let ((status (notmuch-call-notmuch--helper (list t err-file) args)) 936 (err (with-temp-buffer 937 (insert-file-contents err-file) 938 (unless (eobp) 939 (buffer-string))))) 940 (notmuch-check-exit-status status (cons notmuch-command args) 941 (buffer-string) err) 942 (goto-char (point-min)) 943 (read (current-buffer))) 944 (delete-file err-file))))) 945 946(defun notmuch-start-notmuch (name buffer sentinel &rest args) 947 "Start and return an asynchronous notmuch command. 948 949This starts and returns an asynchronous process running 950`notmuch-command' with ARGS. The exit status is checked via 951`notmuch-check-async-exit-status'. Output written to stderr is 952redirected and displayed when the process exits (even if the 953process exits successfully). NAME and BUFFER are the same as in 954`start-process'. SENTINEL is a process sentinel function to call 955when the process exits, or nil for none. The caller must *not* 956invoke `set-process-sentinel' directly on the returned process, 957as that will interfere with the handling of stderr and the exit 958status." 959 (let* ((command (or (executable-find notmuch-command) 960 (error "Command not found: %s" notmuch-command))) 961 (err-buffer (generate-new-buffer " *notmuch-stderr*")) 962 (proc (notmuch--make-process 963 :name name 964 :buffer buffer 965 :command (cons command args) 966 :connection-type 'pipe 967 :stderr err-buffer)) 968 (err-proc (get-buffer-process err-buffer))) 969 (process-put proc 'err-buffer err-buffer) 970 (process-put proc 'sub-sentinel sentinel) 971 (set-process-sentinel proc #'notmuch-start-notmuch-sentinel) 972 (set-process-sentinel err-proc #'notmuch-start-notmuch-error-sentinel) 973 proc)) 974 975(defun notmuch-start-notmuch-sentinel (proc event) 976 "Process sentinel function used by `notmuch-start-notmuch'." 977 (let* ((err-buffer (process-get proc 'err-buffer)) 978 (err (and (buffer-live-p err-buffer) 979 (not (zerop (buffer-size err-buffer))) 980 (with-current-buffer err-buffer (buffer-string)))) 981 (sub-sentinel (process-get proc 'sub-sentinel))) 982 (condition-case err 983 (progn 984 ;; Invoke the sub-sentinel, if any 985 (when sub-sentinel 986 (funcall sub-sentinel proc event)) 987 ;; Check the exit status. This will signal an error if the 988 ;; exit status is non-zero. Don't do this if the process 989 ;; buffer is dead since that means Emacs killed the process 990 ;; and there's no point in telling the user that (but we 991 ;; still check for and report stderr output below). 992 (when (buffer-live-p (process-buffer proc)) 993 (notmuch-check-async-exit-status proc event nil err)) 994 ;; If that didn't signal an error, then any error output was 995 ;; really warning output. Show warnings, if any. 996 (let ((warnings 997 (and err 998 (with-current-buffer err-buffer 999 (goto-char (point-min)) 1000 (end-of-line) 1001 ;; Show first line; stuff remaining lines in the 1002 ;; errors buffer. 1003 (let ((l1 (buffer-substring (point-min) (point)))) 1004 (skip-chars-forward "\n") 1005 (cons l1 (and (not (eobp)) 1006 (buffer-substring (point) 1007 (point-max))))))))) 1008 (when warnings 1009 (notmuch-logged-error (car warnings) (cdr warnings))))) 1010 (error 1011 ;; Emacs behaves strangely if an error escapes from a sentinel, 1012 ;; so turn errors into messages. 1013 (message "%s" (error-message-string err)))))) 1014 1015(defun notmuch-start-notmuch-error-sentinel (proc _event) 1016 (unless (process-live-p proc) 1017 (let ((buffer (process-buffer proc))) 1018 (when (buffer-live-p buffer) 1019 (kill-buffer buffer))))) 1020 1021(defvar-local notmuch-show-process-crypto nil) 1022 1023;;; Generic Utilities 1024 1025(defun notmuch-interactive-region () 1026 "Return the bounds of the current interactive region. 1027 1028This returns (BEG END), where BEG and END are the bounds of the 1029region if the region is active, or both `point' otherwise." 1030 (if (region-active-p) 1031 (list (region-beginning) (region-end)) 1032 (list (point) (point)))) 1033 1034(define-obsolete-function-alias 1035 'notmuch-search-interactive-region 1036 'notmuch-interactive-region 1037 "notmuch 0.29") 1038 1039;;; _ 1040 1041(provide 'notmuch-lib) 1042 1043;;; notmuch-lib.el ends here 1044