]> git.notmuchmail.org Git - notmuch/blob - emacs/notmuch-lib.el
emacs: update search sort order help to match code
[notmuch] / emacs / notmuch-lib.el
1 ;; notmuch-lib.el --- common variables, functions and function declarations
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 <http://www.gnu.org/licenses/>.
19 ;;
20 ;; Authors: Carl Worth <cworth@cworth.org>
21
22 ;; This is an part of an emacs-based interface to the notmuch mail system.
23
24 (require 'mm-view)
25 (require 'mm-decode)
26 (require 'json)
27 (require 'cl)
28
29 (defvar notmuch-command "notmuch"
30   "Command to run the notmuch binary.")
31
32 (defgroup notmuch nil
33   "Notmuch mail reader for Emacs."
34   :group 'mail)
35
36 (defgroup notmuch-hello nil
37   "Overview of saved searches, tags, etc."
38   :group 'notmuch)
39
40 (defgroup notmuch-search nil
41   "Searching and sorting mail."
42   :group 'notmuch)
43
44 (defgroup notmuch-show nil
45   "Showing messages and threads."
46   :group 'notmuch)
47
48 (defgroup notmuch-send nil
49   "Sending messages from Notmuch."
50   :group 'notmuch)
51
52 (custom-add-to-group 'notmuch-send 'message 'custom-group)
53
54 (defgroup notmuch-crypto nil
55   "Processing and display of cryptographic MIME parts."
56   :group 'notmuch)
57
58 (defgroup notmuch-hooks nil
59   "Running custom code on well-defined occasions."
60   :group 'notmuch)
61
62 (defgroup notmuch-external nil
63   "Running external commands from within Notmuch."
64   :group 'notmuch)
65
66 (defgroup notmuch-faces nil
67   "Graphical attributes for displaying text"
68   :group 'notmuch)
69
70 (defcustom notmuch-search-oldest-first t
71   "Show the oldest mail first when searching.
72
73 This variable defines the default sort order for displaying
74 search results. Note that any filtered searches created by
75 `notmuch-search-filter' retain the search order of the parent
76 search."
77   :type 'boolean
78   :group 'notmuch-search)
79
80 ;;
81
82 (defvar notmuch-search-history nil
83   "Variable to store notmuch searches history.")
84
85 (defcustom notmuch-saved-searches '(("inbox" . "tag:inbox")
86                                     ("unread" . "tag:unread"))
87   "A list of saved searches to display."
88   :type '(alist :key-type string :value-type string)
89   :group 'notmuch-hello)
90
91 (defcustom notmuch-archive-tags '("-inbox")
92   "List of tag changes to apply to a message or a thread when it is archived.
93
94 Tags starting with \"+\" (or not starting with either \"+\" or
95 \"-\") in the list will be added, and tags starting with \"-\"
96 will be removed from the message or thread being archived.
97
98 For example, if you wanted to remove an \"inbox\" tag and add an
99 \"archived\" tag, you would set:
100     (\"-inbox\" \"+archived\")"
101   :type '(repeat string)
102   :group 'notmuch-search
103   :group 'notmuch-show)
104
105 ;; By default clicking on a button does not select the window
106 ;; containing the button (as opposed to clicking on a widget which
107 ;; does). This means that the button action is then executed in the
108 ;; current selected window which can cause problems if the button
109 ;; changes the buffer (e.g., id: links) or moves point.
110 ;;
111 ;; This provides a button type which overrides mouse-action so that
112 ;; the button's window is selected before the action is run. Other
113 ;; notmuch buttons can get the same behaviour by inheriting from this
114 ;; button type.
115 (define-button-type 'notmuch-button-type
116   'mouse-action (lambda (button)
117                   (select-window (posn-window (event-start last-input-event)))
118                   (button-activate button)))
119
120 (defun notmuch-command-to-string (&rest args)
121   "Synchronously invoke \"notmuch\" with the given list of arguments.
122
123 If notmuch exits with a non-zero status, output from the process
124 will appear in a buffer named \"*Notmuch errors*\" and an error
125 will be signaled.
126
127 Otherwise the output will be returned"
128   (with-temp-buffer
129     (let* ((status (apply #'call-process notmuch-command nil t nil args))
130            (output (buffer-string)))
131       (notmuch-check-exit-status status (cons notmuch-command args) output)
132       output)))
133
134 (defun notmuch-version ()
135   "Return a string with the notmuch version number."
136   (let ((long-string
137          ;; Trim off the trailing newline.
138          (substring (notmuch-command-to-string "--version") 0 -1)))
139     (if (string-match "^notmuch\\( version\\)? \\(.*\\)$"
140                       long-string)
141         (match-string 2 long-string)
142       "unknown")))
143
144 (defun notmuch-config-get (item)
145   "Return a value from the notmuch configuration."
146   ;; Trim off the trailing newline
147   (substring (notmuch-command-to-string "config" "get" item) 0 -1))
148
149 (defun notmuch-database-path ()
150   "Return the database.path value from the notmuch configuration."
151   (notmuch-config-get "database.path"))
152
153 (defun notmuch-user-name ()
154   "Return the user.name value from the notmuch configuration."
155   (notmuch-config-get "user.name"))
156
157 (defun notmuch-user-primary-email ()
158   "Return the user.primary_email value from the notmuch configuration."
159   (notmuch-config-get "user.primary_email"))
160
161 (defun notmuch-user-other-email ()
162   "Return the user.other_email value (as a list) from the notmuch configuration."
163   (split-string (notmuch-config-get "user.other_email") "\n"))
164
165 (defun notmuch-kill-this-buffer ()
166   "Kill the current buffer."
167   (interactive)
168   (kill-buffer (current-buffer)))
169
170 (defun notmuch-prettify-subject (subject)
171   ;; This function is used by `notmuch-search-process-filter' which
172   ;; requires that we not disrupt its' matching state.
173   (save-match-data
174     (if (and subject
175              (string-match "^[ \t]*$" subject))
176         "[No Subject]"
177       subject)))
178
179 (defun notmuch-escape-boolean-term (term)
180   "Escape a boolean term for use in a query.
181
182 The caller is responsible for prepending the term prefix and a
183 colon.  This performs minimal escaping in order to produce
184 user-friendly queries."
185
186   (save-match-data
187     (if (or (equal term "")
188             (string-match "[ ()]\\|^\"" term))
189         ;; Requires escaping
190         (concat "\"" (replace-regexp-in-string "\"" "\"\"" term t t) "\"")
191       term)))
192
193 (defun notmuch-id-to-query (id)
194   "Return a query that matches the message with id ID."
195   (concat "id:" (notmuch-escape-boolean-term id)))
196
197 ;;
198
199 (defun notmuch-common-do-stash (text)
200   "Common function to stash text in kill ring, and display in minibuffer."
201   (if text
202       (progn
203         (kill-new text)
204         (message "Stashed: %s" text))
205     ;; There is nothing to stash so stash an empty string so the user
206     ;; doesn't accidentally paste something else somewhere.
207     (kill-new "")
208     (message "Nothing to stash!")))
209
210 ;;
211
212 (defun notmuch-remove-if-not (predicate list)
213   "Return a copy of LIST with all items not satisfying PREDICATE removed."
214   (let (out)
215     (while list
216       (when (funcall predicate (car list))
217         (push (car list) out))
218       (setq list (cdr list)))
219     (nreverse out)))
220
221 (defun notmuch-split-content-type (content-type)
222   "Split content/type into 'content' and 'type'"
223   (split-string content-type "/"))
224
225 (defun notmuch-match-content-type (t1 t2)
226   "Return t if t1 and t2 are matching content types, taking wildcards into account"
227   (let ((st1 (notmuch-split-content-type t1))
228         (st2 (notmuch-split-content-type t2)))
229     (if (or (string= (cadr st1) "*")
230             (string= (cadr st2) "*"))
231         ;; Comparison of content types should be case insensitive.
232         (string= (downcase (car st1)) (downcase (car st2)))
233       (string= (downcase t1) (downcase t2)))))
234
235 (defvar notmuch-multipart/alternative-discouraged
236   '(
237     ;; Avoid HTML parts.
238     "text/html"
239     ;; multipart/related usually contain a text/html part and some associated graphics.
240     "multipart/related"
241     ))
242
243 (defun notmuch-multipart/alternative-choose (types)
244   "Return a list of preferred types from the given list of types"
245   ;; Based on `mm-preferred-alternative-precedence'.
246   (let ((seq types))
247     (dolist (pref (reverse notmuch-multipart/alternative-discouraged))
248       (dolist (elem (copy-sequence seq))
249         (when (string-match pref elem)
250           (setq seq (nconc (delete elem seq) (list elem))))))
251     seq))
252
253 (defun notmuch-parts-filter-by-type (parts type)
254   "Given a list of message parts, return a list containing the ones matching
255 the given type."
256   (remove-if-not
257    (lambda (part) (notmuch-match-content-type (plist-get part :content-type) type))
258    parts))
259
260 ;; Helper for parts which are generally not included in the default
261 ;; JSON output.
262 (defun notmuch-get-bodypart-internal (query part-number process-crypto)
263   (let ((args '("show" "--format=raw"))
264         (part-arg (format "--part=%s" part-number)))
265     (setq args (append args (list part-arg)))
266     (if process-crypto
267         (setq args (append args '("--decrypt"))))
268     (setq args (append args (list query)))
269     (with-temp-buffer
270       (let ((coding-system-for-read 'no-conversion))
271         (progn
272           (apply 'call-process (append (list notmuch-command nil (list t nil) nil) args))
273           (buffer-string))))))
274
275 (defun notmuch-get-bodypart-content (msg part nth process-crypto)
276   (or (plist-get part :content)
277       (notmuch-get-bodypart-internal (notmuch-id-to-query (plist-get msg :id)) nth process-crypto)))
278
279 ;; Workaround: The call to `mm-display-part' below triggers a bug in
280 ;; Emacs 24 if it attempts to use the shr renderer to display an HTML
281 ;; part with images in it (demonstrated in 24.1 and 24.2 on Debian and
282 ;; Fedora 17, though unreproducable in other configurations).
283 ;; `mm-shr' references the variable `gnus-inhibit-images' without
284 ;; first loading gnus-art, which defines it, resulting in a
285 ;; void-variable error.  Hence, we advise `mm-shr' to ensure gnus-art
286 ;; is loaded.
287 (if (>= emacs-major-version 24)
288     (defadvice mm-shr (before load-gnus-arts activate)
289       (require 'gnus-art nil t)
290       (ad-disable-advice 'mm-shr 'before 'load-gnus-arts)))
291
292 (defun notmuch-mm-display-part-inline (msg part nth content-type process-crypto)
293   "Use the mm-decode/mm-view functions to display a part in the
294 current buffer, if possible."
295   (let ((display-buffer (current-buffer)))
296     (with-temp-buffer
297       ;; In case there is :content, the content string is already converted
298       ;; into emacs internal format. `gnus-decoded' is a fake charset,
299       ;; which means no further decoding (to be done by mm- functions).
300       (let* ((charset (if (plist-member part :content)
301                           'gnus-decoded
302                         (plist-get part :content-charset)))
303              (handle (mm-make-handle (current-buffer) `(,content-type (charset . ,charset)))))
304         ;; If the user wants the part inlined, insert the content and
305         ;; test whether we are able to inline it (which includes both
306         ;; capability and suitability tests).
307         (when (mm-inlined-p handle)
308           (insert (notmuch-get-bodypart-content msg part nth process-crypto))
309           (when (mm-inlinable-p handle)
310             (set-buffer display-buffer)
311             (mm-display-part handle)
312             t))))))
313
314 ;; Converts a plist of headers to an alist of headers. The input plist should
315 ;; have symbols of the form :Header as keys, and the resulting alist will have
316 ;; symbols of the form 'Header as keys.
317 (defun notmuch-headers-plist-to-alist (plist)
318   (loop for (key value . rest) on plist by #'cddr
319         collect (cons (intern (substring (symbol-name key) 1)) value)))
320
321 (defun notmuch-face-ensure-list-form (face)
322   "Return FACE in face list form.
323
324 If FACE is already a face list, it will be returned as-is.  If
325 FACE is a face name or face plist, it will be returned as a
326 single element face list."
327   (if (and (listp face) (not (keywordp (car face))))
328       face
329     (list face)))
330
331 (defun notmuch-combine-face-text-property (start end face &optional below object)
332   "Combine FACE into the 'face text property between START and END.
333
334 This function combines FACE with any existing faces between START
335 and END in OBJECT (which defaults to the current buffer).
336 Attributes specified by FACE take precedence over existing
337 attributes unless BELOW is non-nil.  FACE must be a face name (a
338 symbol or string), a property list of face attributes, or a list
339 of these.  For convenience when applied to strings, this returns
340 OBJECT."
341
342   ;; A face property can have three forms: a face name (a string or
343   ;; symbol), a property list, or a list of these two forms.  In the
344   ;; list case, the faces will be combined, with the earlier faces
345   ;; taking precedent.  Here we canonicalize everything to list form
346   ;; to make it easy to combine.
347   (let ((pos start)
348         (face-list (notmuch-face-ensure-list-form face)))
349     (while (< pos end)
350       (let* ((cur (get-text-property pos 'face object))
351              (cur-list (notmuch-face-ensure-list-form cur))
352              (new (cond ((null cur-list) face)
353                         (below (append cur-list face-list))
354                         (t (append face-list cur-list))))
355              (next (next-single-property-change pos 'face object end)))
356         (put-text-property pos next 'face new object)
357         (setq pos next))))
358   object)
359
360 (defun notmuch-combine-face-text-property-string (string face &optional below)
361   (notmuch-combine-face-text-property
362    0
363    (length string)
364    face
365    below
366    string))
367
368 (defun notmuch-map-text-property (start end prop func &optional object)
369   "Transform text property PROP using FUNC.
370
371 Applies FUNC to each distinct value of the text property PROP
372 between START and END of OBJECT, setting PROP to the value
373 returned by FUNC."
374   (while (< start end)
375     (let ((value (get-text-property start prop object))
376           (next (next-single-property-change start prop object end)))
377       (put-text-property start next prop (funcall func value) object)
378       (setq start next))))
379
380 (defun notmuch-logged-error (msg &optional extra)
381   "Log MSG and EXTRA to *Notmuch errors* and signal MSG.
382
383 This logs MSG and EXTRA to the *Notmuch errors* buffer and
384 signals MSG as an error.  If EXTRA is non-nil, text referring the
385 user to the *Notmuch errors* buffer will be appended to the
386 signaled error.  This function does not return."
387
388   (with-current-buffer (get-buffer-create "*Notmuch errors*")
389     (goto-char (point-max))
390     (unless (bobp)
391       (newline))
392     (save-excursion
393       (insert "[" (current-time-string) "]\n" msg)
394       (unless (bolp)
395         (newline))
396       (when extra
397         (insert extra)
398         (unless (bolp)
399           (newline)))))
400   (error "%s" (concat msg (when extra
401                             " (see *Notmuch errors* for more details)"))))
402
403 (defun notmuch-check-async-exit-status (proc msg &optional command err-file)
404   "If PROC exited abnormally, pop up an error buffer and signal an error.
405
406 This is a wrapper around `notmuch-check-exit-status' for
407 asynchronous process sentinels.  PROC and MSG must be the
408 arguments passed to the sentinel.  COMMAND and ERR-FILE, if
409 provided, are passed to `notmuch-check-exit-status'.  If COMMAND
410 is not provided, it is taken from `process-command'."
411   (let ((exit-status
412          (case (process-status proc)
413            ((exit) (process-exit-status proc))
414            ((signal) msg))))
415     (when exit-status
416       (notmuch-check-exit-status exit-status (or command (process-command proc))
417                                  nil err-file))))
418
419 (defun notmuch-check-exit-status (exit-status command &optional output err-file)
420   "If EXIT-STATUS is non-zero, pop up an error buffer and signal an error.
421
422 If EXIT-STATUS is non-zero, pop up a notmuch error buffer
423 describing the error and signal an Elisp error.  EXIT-STATUS must
424 be a number indicating the exit status code of a process or a
425 string describing the signal that terminated the process (such as
426 returned by `call-process').  COMMAND must be a list giving the
427 command and its arguments.  OUTPUT, if provided, is a string
428 giving the output of command.  ERR-FILE, if provided, is the name
429 of a file containing the error output of command.  OUTPUT and the
430 contents of ERR-FILE will be included in the error message."
431
432   (cond
433    ((eq exit-status 0) t)
434    ((eq exit-status 20)
435     (notmuch-logged-error "notmuch CLI version mismatch
436 Emacs requested an older output format than supported by the notmuch CLI.
437 You may need to restart Emacs or upgrade your notmuch Emacs package."))
438    ((eq exit-status 21)
439     (notmuch-logged-error "notmuch CLI version mismatch
440 Emacs requested a newer output format than supported by the notmuch CLI.
441 You may need to restart Emacs or upgrade your notmuch package."))
442    (t
443     (let* ((err (when err-file
444                   (with-temp-buffer
445                     (insert-file-contents err-file)
446                     (unless (eobp)
447                       (buffer-string)))))
448            (extra
449             (concat
450              "command: " (mapconcat #'shell-quote-argument command " ") "\n"
451              (if (integerp exit-status)
452                  (format "exit status: %s\n" exit-status)
453                (format "exit signal: %s\n" exit-status))
454              (when err
455                (concat "stderr:\n" err))
456              (when output
457                (concat "stdout:\n" output)))))
458         (if err
459             ;; We have an error message straight from the CLI.
460             (notmuch-logged-error
461              (replace-regexp-in-string "[ \n\r\t\f]*\\'" "" err) extra)
462           ;; We only have combined output from the CLI; don't inundate
463           ;; the user with it.  Mimic `process-lines'.
464           (notmuch-logged-error (format "%s exited with status %s"
465                                         (car command) exit-status)
466                                 extra))
467         ;; `notmuch-logged-error' does not return.
468         ))))
469
470 (defun notmuch-call-notmuch-json (&rest args)
471   "Invoke `notmuch-command' with ARGS and return the parsed JSON output.
472
473 The returned output will represent objects using property lists
474 and arrays as lists.  If notmuch exits with a non-zero status,
475 this will pop up a buffer containing notmuch's output and signal
476 an error."
477
478   (with-temp-buffer
479     (let ((err-file (make-temp-file "nmerr")))
480       (unwind-protect
481           (let ((status (apply #'call-process
482                                notmuch-command nil (list t err-file) nil args)))
483             (notmuch-check-exit-status status (cons notmuch-command args)
484                                        (buffer-string) err-file)
485             (goto-char (point-min))
486             (let ((json-object-type 'plist)
487                   (json-array-type 'list)
488                   (json-false 'nil))
489               (json-read)))
490         (delete-file err-file)))))
491
492 (defun notmuch-start-notmuch (name buffer sentinel &rest args)
493   "Start and return an asynchronous notmuch command.
494
495 This starts and returns an asynchronous process running
496 `notmuch-command' with ARGS.  The exit status is checked via
497 `notmuch-check-async-exit-status'.  Output written to stderr is
498 redirected and displayed when the process exits (even if the
499 process exits successfully).  NAME and BUFFER are the same as in
500 `start-process'.  SENTINEL is a process sentinel function to call
501 when the process exits, or nil for none.  The caller must *not*
502 invoke `set-process-sentinel' directly on the returned process,
503 as that will interfere with the handling of stderr and the exit
504 status."
505
506   ;; There is no way (as of Emacs 24.3) to capture stdout and stderr
507   ;; separately for asynchronous processes, or even to redirect stderr
508   ;; to a file, so we use a trivial shell wrapper to send stderr to a
509   ;; temporary file and clean things up in the sentinel.
510   (let* ((err-file (make-temp-file "nmerr"))
511          ;; Use a pipe
512          (process-connection-type nil)
513          ;; Find notmuch using Emacs' `exec-path'
514          (command (or (executable-find notmuch-command)
515                       (error "command not found: %s" notmuch-command)))
516          (proc (apply #'start-process name buffer
517                       "/bin/sh" "-c"
518                       "exec 2>\"$1\"; shift; exec \"$0\" \"$@\""
519                       command err-file args)))
520     (process-put proc 'err-file err-file)
521     (process-put proc 'sub-sentinel sentinel)
522     (process-put proc 'real-command (cons notmuch-command args))
523     (set-process-sentinel proc #'notmuch-start-notmuch-sentinel)
524     proc))
525
526 (defun notmuch-start-notmuch-sentinel (proc event)
527   (let ((err-file (process-get proc 'err-file))
528         (sub-sentinel (process-get proc 'sub-sentinel))
529         (real-command (process-get proc 'real-command)))
530     (condition-case err
531         (progn
532           ;; Invoke the sub-sentinel, if any
533           (when sub-sentinel
534             (funcall sub-sentinel proc event))
535           ;; Check the exit status.  This will signal an error if the
536           ;; exit status is non-zero.  Don't do this if the process
537           ;; buffer is dead since that means Emacs killed the process
538           ;; and there's no point in telling the user that (but we
539           ;; still check for and report stderr output below).
540           (when (buffer-live-p (process-buffer proc))
541             (notmuch-check-async-exit-status proc event real-command err-file))
542           ;; If that didn't signal an error, then any error output was
543           ;; really warning output.  Show warnings, if any.
544           (let ((warnings
545                  (with-temp-buffer
546                    (unless (= (second (insert-file-contents err-file)) 0)
547                      (end-of-line)
548                      ;; Show first line; stuff remaining lines in the
549                      ;; errors buffer.
550                      (let ((l1 (buffer-substring (point-min) (point))))
551                        (skip-chars-forward "\n")
552                        (cons l1 (unless (eobp)
553                                   (buffer-substring (point) (point-max)))))))))
554             (when warnings
555               (notmuch-logged-error (car warnings) (cdr warnings)))))
556       (error
557        ;; Emacs behaves strangely if an error escapes from a sentinel,
558        ;; so turn errors into messages.
559        (message "%s" (error-message-string err))))
560     (ignore-errors (delete-file err-file))))
561
562 ;; This variable is used only buffer local, but it needs to be
563 ;; declared globally first to avoid compiler warnings.
564 (defvar notmuch-show-process-crypto nil)
565 (make-variable-buffer-local 'notmuch-show-process-crypto)
566
567 ;; Incremental JSON parsing
568
569 ;; These two variables are internal variables to the parsing
570 ;; routines. They are always used buffer local but need to be declared
571 ;; globally to avoid compiler warnings.
572
573 (defvar notmuch-json-parser nil
574   "Internal incremental JSON parser object: local to the buffer being parsed.")
575
576 (defvar notmuch-json-state nil
577   "State of the internal JSON parser: local to the buffer being parsed.")
578
579 (defun notmuch-json-create-parser (buffer)
580   "Return a streaming JSON parser that consumes input from BUFFER.
581
582 This parser is designed to read streaming JSON whose structure is
583 known to the caller.  Like a typical JSON parsing interface, it
584 provides a function to read a complete JSON value from the input.
585 However, it extends this with an additional function that
586 requires the next value in the input to be a compound value and
587 descends into it, allowing its elements to be read one at a time
588 or further descended into.  Both functions can return 'retry to
589 indicate that not enough input is available.
590
591 The parser always consumes input from BUFFER's point.  Hence, the
592 caller is allowed to delete and data before point and may
593 resynchronize after an error by moving point."
594
595   (list buffer
596         ;; Terminator stack: a stack of characters that indicate the
597         ;; end of the compound values enclosing point
598         '()
599         ;; Next: One of
600         ;; * 'expect-value if the next token must be a value, but a
601         ;;   value has not yet been reached
602         ;; * 'value if point is at the beginning of a value
603         ;; * 'expect-comma if the next token must be a comma
604         'expect-value
605         ;; Allow terminator: non-nil if the next token may be a
606         ;; terminator
607         nil
608         ;; Partial parse position: If state is 'value, a marker for
609         ;; the position of the partial parser or nil if no partial
610         ;; parsing has happened yet
611         nil
612         ;; Partial parse state: If state is 'value, the current
613         ;; `parse-partial-sexp' state
614         nil))
615
616 (defmacro notmuch-json-buffer (jp) `(first ,jp))
617 (defmacro notmuch-json-term-stack (jp) `(second ,jp))
618 (defmacro notmuch-json-next (jp) `(third ,jp))
619 (defmacro notmuch-json-allow-term (jp) `(fourth ,jp))
620 (defmacro notmuch-json-partial-pos (jp) `(fifth ,jp))
621 (defmacro notmuch-json-partial-state (jp) `(sixth ,jp))
622
623 (defvar notmuch-json-syntax-table
624   (let ((table (make-syntax-table)))
625     ;; The standard syntax table is what we need except that "." needs
626     ;; to have word syntax instead of punctuation syntax.
627     (modify-syntax-entry ?. "w" table)
628     table)
629   "Syntax table used for incremental JSON parsing.")
630
631 (defun notmuch-json-scan-to-value (jp)
632   ;; Helper function that consumes separators, terminators, and
633   ;; whitespace from point.  Returns nil if it successfully reached
634   ;; the beginning of a value, 'end if it consumed a terminator, or
635   ;; 'retry if not enough input was available to reach a value.  Upon
636   ;; nil return, (notmuch-json-next jp) is always 'value.
637
638   (if (eq (notmuch-json-next jp) 'value)
639       ;; We're already at a value
640       nil
641     ;; Drive the state toward 'expect-value
642     (skip-chars-forward " \t\r\n")
643     (or (when (eobp) 'retry)
644         ;; Test for the terminator for the current compound
645         (when (and (notmuch-json-allow-term jp)
646                    (eq (char-after) (car (notmuch-json-term-stack jp))))
647           ;; Consume it and expect a comma or terminator next
648           (forward-char)
649           (setf (notmuch-json-term-stack jp) (cdr (notmuch-json-term-stack jp))
650                 (notmuch-json-next jp) 'expect-comma
651                 (notmuch-json-allow-term jp) t)
652           'end)
653         ;; Test for a separator
654         (when (eq (notmuch-json-next jp) 'expect-comma)
655           (when (/= (char-after) ?,)
656             (signal 'json-readtable-error (list "expected ','")))
657           ;; Consume it, switch to 'expect-value, and disallow a
658           ;; terminator
659           (forward-char)
660           (skip-chars-forward " \t\r\n")
661           (setf (notmuch-json-next jp) 'expect-value
662                 (notmuch-json-allow-term jp) nil)
663           ;; We moved point, so test for eobp again and fall through
664           ;; to the next test if there's more input
665           (when (eobp) 'retry))
666         ;; Next must be 'expect-value and we know this isn't
667         ;; whitespace, EOB, or a terminator, so point must be on a
668         ;; value
669         (progn
670           (assert (eq (notmuch-json-next jp) 'expect-value))
671           (setf (notmuch-json-next jp) 'value)
672           nil))))
673
674 (defun notmuch-json-begin-compound (jp)
675   "Parse the beginning of a compound value and traverse inside it.
676
677 Returns 'retry if there is insufficient input to parse the
678 beginning of the compound.  If this is able to parse the
679 beginning of a compound, it moves point past the token that opens
680 the compound and returns t.  Later calls to `notmuch-json-read'
681 will return the compound's elements.
682
683 Entering JSON objects is currently unimplemented."
684
685   (with-current-buffer (notmuch-json-buffer jp)
686     ;; Disallow terminators
687     (setf (notmuch-json-allow-term jp) nil)
688     ;; Save "next" so we can restore it if there's a syntax error
689     (let ((saved-next (notmuch-json-next jp)))
690       (or (notmuch-json-scan-to-value jp)
691           (if (/= (char-after) ?\[)
692               (progn
693                 (setf (notmuch-json-next jp) saved-next)
694                 (signal 'json-readtable-error (list "expected '['")))
695             (forward-char)
696             (push ?\] (notmuch-json-term-stack jp))
697             ;; Expect a value or terminator next
698             (setf (notmuch-json-next jp) 'expect-value
699                   (notmuch-json-allow-term jp) t)
700             t)))))
701
702 (defun notmuch-json-read (jp)
703   "Parse the value at point in JP's buffer.
704
705 Returns 'retry if there is insufficient input to parse a complete
706 JSON value (though it may still move point over separators or
707 whitespace).  If the parser is currently inside a compound value
708 and the next token ends the list or object, this moves point just
709 past the terminator and returns 'end.  Otherwise, this moves
710 point to just past the end of the value and returns the value."
711
712   (with-current-buffer (notmuch-json-buffer jp)
713     (or
714      ;; Get to a value state
715      (notmuch-json-scan-to-value jp)
716
717      ;; Can we parse a complete value?
718      (let ((complete
719             (if (looking-at "[-+0-9tfn]")
720                 ;; This is a number or a keyword, so the partial
721                 ;; parser isn't going to help us because a truncated
722                 ;; number or keyword looks like a complete symbol to
723                 ;; it.  Look for something that clearly ends it.
724                 (save-excursion
725                   (skip-chars-forward "^]},: \t\r\n")
726                   (not (eobp)))
727
728               ;; We're looking at a string, object, or array, which we
729               ;; can partial parse.  If we just reached the value, set
730               ;; up the partial parser.
731               (when (null (notmuch-json-partial-state jp))
732                 (setf (notmuch-json-partial-pos jp) (point-marker)))
733
734               ;; Extend the partial parse until we either reach EOB or
735               ;; get the whole value
736               (save-excursion
737                 (let ((pstate
738                        (with-syntax-table notmuch-json-syntax-table
739                          (parse-partial-sexp
740                           (notmuch-json-partial-pos jp) (point-max) 0 nil
741                           (notmuch-json-partial-state jp)))))
742                   ;; A complete value is available if we've reached
743                   ;; depth 0 or less and encountered a complete
744                   ;; subexpression.
745                   (if (and (<= (first pstate) 0) (third pstate))
746                       t
747                     ;; Not complete.  Update the partial parser state
748                     (setf (notmuch-json-partial-pos jp) (point-marker)
749                           (notmuch-json-partial-state jp) pstate)
750                     nil))))))
751
752        (if (not complete)
753            'retry
754          ;; We have a value.  Reset the partial parse state and expect
755          ;; a comma or terminator after the value.
756          (setf (notmuch-json-next jp) 'expect-comma
757                (notmuch-json-allow-term jp) t
758                (notmuch-json-partial-pos jp) nil
759                (notmuch-json-partial-state jp) nil)
760          ;; Parse the value
761          (let ((json-object-type 'plist)
762                (json-array-type 'list)
763                (json-false nil))
764            (json-read)))))))
765
766 (defun notmuch-json-eof (jp)
767   "Signal a json-error if there is more data in JP's buffer.
768
769 Moves point to the beginning of any trailing data or to the end
770 of the buffer if there is only trailing whitespace."
771
772   (with-current-buffer (notmuch-json-buffer jp)
773     (skip-chars-forward " \t\r\n")
774     (unless (eobp)
775       (signal 'json-error (list "Trailing garbage following JSON data")))))
776
777 (defun notmuch-json-parse-partial-list (result-function error-function results-buf)
778   "Parse a partial JSON list from current buffer.
779
780 This function consumes a JSON list from the current buffer,
781 applying RESULT-FUNCTION in buffer RESULT-BUFFER to each complete
782 value in the list.  It operates incrementally and should be
783 called whenever the buffer has been extended with additional
784 data.
785
786 If there is a syntax error, this will attempt to resynchronize
787 with the input and will apply ERROR-FUNCTION in buffer
788 RESULT-BUFFER to any input that was skipped.
789
790 It sets up all the needed internal variables: the caller just
791 needs to call it with point in the same place that the parser
792 left it."
793   (let (done)
794     (unless (local-variable-p 'notmuch-json-parser)
795       (set (make-local-variable 'notmuch-json-parser)
796            (notmuch-json-create-parser (current-buffer)))
797       (set (make-local-variable 'notmuch-json-state) 'begin))
798     (while (not done)
799       (condition-case nil
800           (case notmuch-json-state
801                 ((begin)
802                  ;; Enter the results list
803                  (if (eq (notmuch-json-begin-compound
804                           notmuch-json-parser) 'retry)
805                      (setq done t)
806                    (setq notmuch-json-state 'result)))
807                 ((result)
808                  ;; Parse a result
809                  (let ((result (notmuch-json-read notmuch-json-parser)))
810                    (case result
811                          ((retry) (setq done t))
812                          ((end) (setq notmuch-json-state 'end))
813                          (otherwise (with-current-buffer results-buf
814                                       (funcall result-function result))))))
815                 ((end)
816                  ;; Any trailing data is unexpected
817                  (notmuch-json-eof notmuch-json-parser)
818                  (setq done t)))
819         (json-error
820          ;; Do our best to resynchronize and ensure forward
821          ;; progress
822          (let ((bad (buffer-substring (line-beginning-position)
823                                       (line-end-position))))
824            (forward-line)
825            (with-current-buffer results-buf
826              (funcall error-function "%s" bad))))))
827     ;; Clear out what we've parsed
828     (delete-region (point-min) (point))))
829
830
831
832
833 (provide 'notmuch-lib)
834
835 ;; Local Variables:
836 ;; byte-compile-warnings: (not cl-functions)
837 ;; End: