code.delx.au - gnu-emacs/blob - lisp/net/mairix.el

   1 ;;; mairix.el --- Mairix interface for Emacs
   2
   3 ;; Copyright (C) 2008-2015 Free Software Foundation, Inc.
   4
   5 ;; Author: David Engster <dengste@eml.cc>
   6 ;; Keywords: mail searching
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This is an interface to the mairix mail search engine.  Mairix is
  26 ;; written by Richard Curnow and is licensed under the GPL.  See the
  27 ;; home page for details:
  28 ;;
  29 ;; http://www.rpcurnow.force9.co.uk/mairix/
  30 ;;
  31 ;; Features of mairix.el:
  32 ;;
  33 ;; * Query mairix with a search term.
  34 ;; * Currently supported Emacs mail programs: RMail, Gnus (mbox only),
  35 ;;   and VM.
  36 ;; * Generate search queries using graphical widgets.
  37 ;; * Generate search queries based on currently displayed mail.
  38 ;; * Save regularly used searches in your .emacs customize section.
  39 ;; * Major mode for viewing, editing and querying saved searches.
  40 ;; * Update mairix database.
  41 ;;
  42 ;; Please note: There are currently no pre-defined key bindings, since
  43 ;; I guess these would depend on the used mail program.  See the docs
  44 ;; for an overview of the provided interactive functions.
  45 ;;
  46 ;; Attention Gnus users: If you use Gnus with maildir or nnml, you
  47 ;; should use the native Gnus back end nnmairix.el instead, since it
  48 ;; has more features and is better integrated with Gnus.  This
  49 ;; interface is essentially a stripped down version of nnmairix.el.
  50 ;;
  51 ;; Currently, RMail, Gnus (with mbox files), and VM are supported as
  52 ;; mail programs, but it is pretty easy to interface it with other
  53 ;; ones as well.  Please see the docs and the source for details.
  54 ;; In a nutshell: include your favorite mail program in
  55 ;; `mairix-mail-program' and write functions for
  56 ;; `mairix-display-functions' and `mairix-get-mail-header-functions'.
  57 ;; If you have written such functions for your Emacs mail program of
  58 ;; choice, please let me know, so that I can eventually include them
  59 ;; in future version of mairix.el.
  60
  61 ;;; History:
  62
  63 ;; 07/28/2008: version 0.2. Added VM interface, written by Ulrich
  64 ;; Mueller.
  65
  66 ;; 07/14/2008: Initial release
  67
  68 ;;; Code:
  69
  70 (require 'widget)
  71 (require 'cus-edit)
  72
  73
  74 ;;; Keymappings
  75
  76 ;; (currently none - please create them yourself)
  77
  78 ;;; Customizable variables
  79
  80 (defgroup mairix nil
  81   "Mairix interface for Emacs."
  82   :group 'mail)
  83
  84 (defcustom mairix-file-path "~/"
  85   "Path where output files produced by Mairix should be stored."
  86   :type 'directory
  87   :group 'mairix)
  88
  89 (defcustom mairix-search-file "mairixsearch.mbox"
  90   "Name of the default file for storing the searches.
  91 Note that this will be prefixed by `mairix-file-path'."
  92   :type 'string
  93   :group 'mairix)
  94
  95 (defcustom mairix-command "mairix"
  96   "Command for calling mairix.
  97 You can add further options here if you want to, but better use
  98 `mairix-update-options' instead."
  99   :type 'string
 100   :group 'mairix)
 101
 102 (defcustom mairix-output-buffer "*mairix output*"
 103   "Name of the buffer for the output of the mairix binary."
 104   :type 'string
 105   :group 'mairix)
 106
 107 (defcustom mairix-customize-query-buffer "*mairix query*"
 108   "Name of the buffer for customizing a search query."
 109   :type 'string
 110   :group 'mairix)
 111
 112 (defcustom mairix-saved-searches-buffer "*mairix searches*"
 113   "Name of the buffer for displaying saved searches."
 114   :type 'string
 115   :group 'mairix)
 116
 117 (defcustom mairix-update-options '("-F" "-Q")
 118   "Options when calling mairix for updating the database.
 119 The default is '-F' and '-Q' for making updates faster.  You
 120 should call mairix without these options from time to
 121 time (e.g. via cron job)."
 122   :type '(repeat string)
 123   :group 'mairix)
 124
 125 (defcustom mairix-search-options '("-Q")
 126   "Options when calling mairix for searching.
 127 The default is '-Q' for making searching faster."
 128   :type '(repeat string)
 129   :group 'mairix)
 130
 131 (defcustom mairix-synchronous-update nil
 132   "Defines if Emacs should wait for the mairix database update."
 133   :type 'boolean
 134   :group 'mairix)
 135
 136 (defcustom mairix-saved-searches nil
 137   "Saved mairix searches.
 138 The entries are: Name of the search, Mairix query string, Name of
 139 the file (nil: use `mairix-search-file' as default), Search whole
 140 threads (nil or t).  Note that the file will be prefixed by
 141 `mairix-file-path'."
 142   :type '(repeat (list (string :tag "Name")
 143                        (string :tag "Query")
 144                        (choice :tag "File"
 145                                (const :tag "default")
 146                                file)
 147                        (boolean :tag "Threads")))
 148   :group 'mairix)
 149
 150 (defcustom mairix-mail-program 'rmail
 151   "Mail program used to display search results.
 152 Currently RMail, Gnus (mbox), and VM are supported.  If you use Gnus
 153 with maildir, use nnmairix.el instead."
 154   :type '(choice (const :tag "RMail" rmail)
 155                  (const :tag "Gnus mbox" gnus)
 156                  (const :tag "VM" vm))
 157   :group 'mairix)
 158
 159 (defcustom mairix-display-functions
 160   '((rmail mairix-rmail-display)
 161     (gnus mairix-gnus-ephemeral-nndoc)
 162     (vm mairix-vm-display))
 163   "Specifies which function should be called for displaying search results.
 164 This is an alist where each entry consists of a symbol from
 165 `mairix-mail-program' and the corresponding function for
 166 displaying the search results.  The function will be called with
 167 the mailbox file produced by mairix as the single argument."
 168   :type '(repeat (list (symbol :tag "Mail program")
 169                        (function)))
 170   :group 'mairix)
 171
 172 (defcustom mairix-get-mail-header-functions
 173   '((rmail mairix-rmail-fetch-field)
 174     (gnus mairix-gnus-fetch-field)
 175     (vm mairix-vm-fetch-field))
 176   "Specifies function for obtaining a header field from the current mail.
 177 This is an alist where each entry consists of a symbol from
 178 `mairix-mail-program' and the corresponding function for
 179 obtaining a header field from the current displayed mail.  The
 180 function will be called with the mail header string as single
 181 argument.  You can use nil if you do not have such a function for
 182 your mail program, but then searches based on the current mail
 183 won't work."
 184   :type '(repeat (list (symbol :tag "Mail program")
 185                        (choice :tag "Header function"
 186                                (const :tag "none")
 187                                function)))
 188   :group 'mairix)
 189
 190 (defcustom mairix-widget-select-window-function
 191   (lambda () (select-window (get-largest-window)))
 192   "Function for selecting the window for customizing the mairix query.
 193 The default chooses the largest window in the current frame."
 194   :type 'function
 195   :group 'mairix)
 196
 197 ;; Other variables
 198
 199 (defvar mairix-widget-fields-list
 200   '(("from" "f" "From") ("to" "t" "To") ("cc" "c" "Cc")
 201     ("subject" "s" "Subject")  ("to" "tc" "To or Cc")
 202     ("from" "a" "Address") (nil "b" "Body") (nil "n" "Attachment")
 203     ("Message-ID" "m" "Message ID") (nil "s" "Size") (nil "d" "Date"))
 204   "Fields that should be editable during interactive query customization.
 205 Header, corresponding mairix command and description for editable
 206 fields in interactive query customization.  The header specifies
 207 which header contents should be inserted into the editable field
 208 when creating a Mairix query based on the current message (can be
 209 nil for disabling this).")
 210
 211 (defvar mairix-widget-other
 212   '(threads flags)
 213   "Other editable mairix commands when using customization widgets.
 214 Currently there are 'threads and 'flags.")
 215
 216 ;;;; Internal variables
 217
 218 (defvar mairix-last-search nil)
 219 (defvar mairix-searches-changed nil)
 220
 221 ;;;; Interface functions for Emacs mail programs
 222
 223 ;;; RMail
 224
 225 (declare-function rmail-summary-displayed "rmail" ())
 226 (declare-function rmail-summary "rmailsum" ()) ; autoloaded in rmail
 227
 228 (defun mairix-rmail-display (folder)
 229   "Display mbox file FOLDER with RMail."
 230   (require 'rmail)
 231   (let (show-summary)
 232     ;; If it exists, select existing RMail window
 233     (when (and (boundp 'rmail-buffer)
 234                rmail-buffer)
 235       (set-buffer rmail-buffer)
 236       (when (get-buffer-window rmail-buffer)
 237         (select-window (get-buffer-window rmail-buffer))
 238         (setq show-summary (rmail-summary-displayed))))
 239     ;; check if folder is already open and if so, kill it
 240     (when (get-buffer (file-name-nondirectory folder))
 241       (set-buffer
 242        (get-buffer (file-name-nondirectory folder)))
 243       (set-buffer-modified-p nil)
 244       (kill-buffer nil))
 245     (rmail folder)
 246     ;; Update summary if necessary
 247     (when show-summary
 248       (rmail-summary))))
 249
 250 (defvar rmail-buffer)
 251
 252 ;; Fetching mail header field:
 253 (defun mairix-rmail-fetch-field (field)
 254   "Get mail header FIELD for current message using RMail."
 255   (unless (and (boundp 'rmail-buffer)
 256                rmail-buffer)
 257     (error "No RMail buffer available"))
 258   ;; At this point, we are in rmail mode, so the rmail funcs are loaded.
 259   (if (fboundp 'rmail-get-header)       ; Emacs 23
 260       (rmail-get-header field)
 261     (with-current-buffer rmail-buffer
 262       (save-restriction
 263         ;; Don't warn about this when compiling Emacs 23.
 264         (with-no-warnings (rmail-narrow-to-non-pruned-header))
 265         (mail-fetch-field field)))))
 266
 267 ;;; Gnus
 268 (eval-when-compile
 269   (defvar gnus-article-buffer)
 270   (autoload 'gnus-summary-toggle-header "gnus-sum")
 271   (autoload 'gnus-buffer-exists-p "gnus-util")
 272   (autoload 'message-field-value "message")
 273   (autoload 'gnus-group-read-ephemeral-group "gnus-group")
 274   (autoload 'gnus-alive-p "gnus-util"))
 275
 276 ;; Display function:
 277 (defun mairix-gnus-ephemeral-nndoc (folder)
 278   "Create ephemeral nndoc group for reading mbox file FOLDER in Gnus."
 279   (unless (gnus-alive-p)
 280     (error "Gnus is not running"))
 281   (gnus-group-read-ephemeral-group
 282    ;; add randomness to group string to prevent Gnus from using a
 283    ;; cached version
 284    (format "mairix.%s" (number-to-string (random 10000)))
 285    `(nndoc "mairix"
 286            (nndoc-address ,folder)
 287            (nndoc-article-type mbox))))
 288
 289 ;; Fetching mail header field:
 290 (defun mairix-gnus-fetch-field (field)
 291   "Get mail header FIELD for current message using Gnus."
 292   (unless (gnus-alive-p)
 293     (error "Gnus is not running"))
 294   (unless (gnus-buffer-exists-p gnus-article-buffer)
 295     (error "No article buffer available"))
 296   (with-current-buffer gnus-article-buffer
 297     (gnus-summary-toggle-header 1)
 298     (message-field-value field)))
 299
 300 ;;; VM
 301 ;;; written by Ulrich Mueller
 302
 303 (eval-when-compile
 304   (autoload 'vm-quit "vm-folder")
 305   (autoload 'vm-visit-folder "vm")
 306   (autoload 'vm-select-folder-buffer "vm-macro")
 307   (autoload 'vm-check-for-killed-summary "vm-misc")
 308   (autoload 'vm-get-header-contents "vm-summary")
 309   (autoload 'vm-check-for-killed-summary "vm-misc")
 310   (autoload 'vm-error-if-folder-empty "vm-misc")
 311   (autoload 'vm-select-marked-or-prefixed-messages "vm-folder"))
 312
 313 ;; Display function
 314 (defun mairix-vm-display (folder)
 315   "Display mbox file FOLDER with VM."
 316   (require 'vm)
 317   ;; check if folder is already open and if so, kill it
 318   (let ((buf (get-file-buffer folder)))
 319     (when buf
 320       (set-buffer buf)
 321       (set-buffer-modified-p nil)
 322       (condition-case nil
 323           (vm-quit t)
 324         (error nil))
 325       (kill-buffer buf)))
 326   (vm-visit-folder folder t))
 327
 328 ;; Fetching mail header field
 329 (defun mairix-vm-fetch-field (field)
 330   "Get mail header FIELD for current message using VM."
 331   (save-excursion
 332     (vm-select-folder-buffer)
 333     (vm-check-for-killed-summary)
 334     (vm-error-if-folder-empty)
 335     (vm-get-header-contents
 336      (car (vm-select-marked-or-prefixed-messages 1)) field)))
 337
 338 ;;;; Main interactive functions
 339
 340 (defun mairix-search (search threads)
 341   "Call Mairix with SEARCH.
 342 If THREADS is non-nil, also display whole threads of found
 343 messages.  Results will be put into the default search file."
 344   (interactive
 345    (list
 346     (read-string "Query: ")
 347     (y-or-n-p "Include threads? ")))
 348   (when (mairix-call-mairix
 349          (split-string search)
 350          nil
 351          threads)
 352     (mairix-show-folder mairix-search-file)))
 353
 354 (defun mairix-use-saved-search ()
 355   "Use a saved search for querying Mairix."
 356   (interactive)
 357   (let* ((completions
 358           (mapcar (lambda (el) (list (car el))) mairix-saved-searches))
 359          (search (completing-read "Name of search: " completions))
 360          (query (assoc search mairix-saved-searches))
 361          (folder (nth 2 query)))
 362     (when (not folder)
 363       (setq folder mairix-search-file))
 364     (when query
 365       (mairix-call-mairix
 366        (split-string (nth 1 query))
 367        folder
 368        (car (last query)))
 369       (mairix-show-folder folder))))
 370
 371 (defun mairix-save-search ()
 372   "Save the last search."
 373   (interactive)
 374   (let* ((name (read-string "Name of the search: "))
 375          (exist (assoc name mairix-saved-searches)))
 376     (if (not exist)
 377         (add-to-list 'mairix-saved-searches
 378                      (append (list name) mairix-last-search))
 379       (when
 380           (y-or-n-p
 381            "There is already a search with this name.  \
 382 Overwrite existing entry? ")
 383         (setcdr (assoc name mairix-saved-searches) mairix-last-search))))
 384   (mairix-select-save))
 385
 386 (defun mairix-edit-saved-searches-customize ()
 387   "Edit the list of saved searches in a customization buffer."
 388   (interactive)
 389   (custom-buffer-create (list (list 'mairix-saved-searches 'custom-variable))
 390                         "*Customize Mairix Query*"
 391                                 (concat "\n\n" (make-string 65 ?=)
 392 "\nYou can now customize your saved Mairix searches by modifying\n\
 393 the variable mairix-saved-searches. Don't forget to save your\nchanges \
 394 in your .emacs by pressing 'Save for Future Sessions'.\n"
 395 (make-string 65 ?=) "\n")))
 396
 397 (autoload 'mail-strip-quoted-names "mail-utils")
 398 (defun mairix-search-from-this-article (threads)
 399   "Search messages from sender of the current article.
 400 This is effectively a shortcut for calling `mairix-search' with
 401 f:current_from.  If prefix THREADS is non-nil, include whole
 402 threads."
 403   (interactive "P")
 404   (let ((get-mail-header
 405          (cadr (assq mairix-mail-program mairix-get-mail-header-functions))))
 406     (if get-mail-header
 407         (mairix-search
 408          (format "f:%s"
 409                  (mail-strip-quoted-names
 410                   (funcall get-mail-header "from")))
 411          threads)
 412       (error "No function for obtaining mail header specified"))))
 413
 414 (defun mairix-search-thread-this-article ()
 415   "Search thread for the current article.
 416 This is effectively a shortcut for calling `mairix-search'
 417 with m:msgid of the current article and enabled threads."
 418   (interactive)
 419   (let ((get-mail-header
 420          (cadr (assq mairix-mail-program mairix-get-mail-header-functions)))
 421         mid)
 422     (unless get-mail-header
 423       (error "No function for obtaining mail header specified"))
 424     (setq mid (funcall get-mail-header "message-id"))
 425     (while (string-match "[<>]" mid)
 426       (setq mid (replace-match "" t t mid)))
 427     ;; mairix somehow does not like '$' in message-id
 428     (when (string-match "\\$" mid)
 429       (setq mid (concat mid "=")))
 430     (while (string-match "\\$" mid)
 431       (setq mid (replace-match "=," t t mid)))
 432     (mairix-search
 433      (format "m:%s" mid) t)))
 434
 435 (defun mairix-widget-search-based-on-article ()
 436   "Create mairix query based on current article using widgets."
 437   (interactive)
 438   (mairix-widget-search
 439    (mairix-widget-get-values)))
 440
 441 (defun mairix-edit-saved-searches ()
 442   "Edit current mairix searches."
 443   (interactive)
 444   (switch-to-buffer mairix-saved-searches-buffer)
 445   (erase-buffer)
 446   (setq mairix-searches-changed nil)
 447   (mairix-build-search-list)
 448   (mairix-searches-mode)
 449   (hl-line-mode))
 450
 451 (defvar mairix-widgets)
 452
 453 (defun mairix-widget-search (&optional mvalues)
 454   "Create mairix query interactively using graphical widgets.
 455 MVALUES may contain values from current article."
 456   (interactive)
 457   ;; Select window for mairix customization
 458   (funcall mairix-widget-select-window-function)
 459   ;; generate widgets
 460   (mairix-widget-create-query mvalues)
 461   ;; generate Buttons
 462   (widget-create 'push-button
 463                  :notify
 464                  (lambda (&rest ignore)
 465                    (mairix-widget-send-query mairix-widgets))
 466                  "Send Query")
 467   (widget-insert "   ")
 468   (widget-create 'push-button
 469                  :notify
 470                  (lambda (&rest ignore)
 471                    (mairix-widget-save-search mairix-widgets))
 472                  "Save search")
 473   (widget-insert "   ")
 474   (widget-create 'push-button
 475                  :notify (lambda (&rest ignore)
 476                            (kill-buffer mairix-customize-query-buffer))
 477                  "Cancel")
 478   (use-local-map widget-keymap)
 479   (widget-setup)
 480   (goto-char (point-min)))
 481
 482 (defun mairix-update-database ()
 483   "Call mairix for updating the database for SERVERS.
 484 Mairix will be called asynchronously unless
 485 `mairix-synchronous-update' is t.  Mairix will be called with
 486 `mairix-update-options'."
 487   (interactive)
 488   (let ((commandsplit (split-string mairix-command))
 489         args)
 490     (if mairix-synchronous-update
 491         (progn
 492           (setq args (append (list (car commandsplit) nil
 493                                    (get-buffer-create mairix-output-buffer)
 494                                    nil)))
 495           (if (> (length commandsplit) 1)
 496               (setq args (append args
 497                                  (cdr commandsplit)
 498                                  mairix-update-options))
 499             (setq args (append args mairix-update-options)))
 500           (apply 'call-process args))
 501       (progn
 502         (message "Updating mairix database...")
 503         (setq args (append (list "mairixupdate" (get-buffer-create mairix-output-buffer)
 504                                  (car commandsplit))))
 505         (if (> (length commandsplit) 1)
 506             (setq args (append args (cdr commandsplit) mairix-update-options))
 507           (setq args (append args mairix-update-options)))
 508         (set-process-sentinel
 509          (apply 'start-process args)
 510          'mairix-sentinel-mairix-update-finished)))))
 511
 512
 513 ;;;; Helper functions
 514
 515 (defun mairix-show-folder (folder)
 516   "Display mail FOLDER with mail program.
 517 The mail program is given by `mairix-mail-program'."
 518   (let ((display-function
 519          (cadr (assq mairix-mail-program mairix-display-functions))))
 520     (if display-function
 521         (funcall display-function
 522                  (concat
 523                   (file-name-as-directory
 524                    (expand-file-name mairix-file-path))
 525                   folder))
 526       (error "No mail program set"))))
 527
 528 (defun mairix-call-mairix (query file threads)
 529   "Call Mairix with QUERY and output FILE.
 530 If FILE is nil, use default.  If THREADS is non-nil, also return
 531 whole threads.  Function returns t if messages were found."
 532   (let* ((commandsplit (split-string mairix-command))
 533          (args (cons (car commandsplit)
 534                      `(nil ,(get-buffer-create mairix-output-buffer) nil)))
 535          rval)
 536     (with-current-buffer mairix-output-buffer
 537       (erase-buffer))
 538     (when (> (length commandsplit) 1)
 539       (setq args (append args (cdr commandsplit))))
 540     (when threads
 541       (setq args (append args '("-t"))))
 542     (when (stringp query)
 543       (setq query (split-string query)))
 544     (setq mairix-last-search (list (mapconcat 'identity query " ")
 545                                      file threads))
 546     (when (not file)
 547       (setq file mairix-search-file))
 548     (setq file
 549           (concat
 550            (file-name-as-directory
 551             (expand-file-name
 552              mairix-file-path))
 553            file))
 554     (setq rval
 555           (apply 'call-process
 556                  (append args (list "-o" file) query)))
 557     (if (zerop rval)
 558         (with-current-buffer mairix-output-buffer
 559           (goto-char (point-min))
 560           (re-search-forward "^Matched.*messages")
 561           (message (match-string 0)))
 562       (if (and (= rval 1)
 563                (with-current-buffer mairix-output-buffer
 564                  (goto-char (point-min))
 565                  (looking-at "^Matched 0 messages")))
 566           (message "No messages found")
 567         (error "Error running Mairix.  See buffer %s for details"
 568                mairix-output-buffer)))
 569     (zerop rval)))
 570
 571 (defun mairix-replace-invalid-chars (header)
 572   "Replace invalid characters in HEADER for mairix query."
 573   (when header
 574     (while (string-match "[^-.@/,^=~& [:alnum:]]" header)
 575       (setq header (replace-match "" t t header)))
 576     (while (string-match "[& ]" header)
 577       (setq header (replace-match "," t t header)))
 578   header))
 579
 580 (defun mairix-sentinel-mairix-update-finished (proc status)
 581   "Sentinel for mairix update process PROC with STATUS."
 582   (if (equal status "finished\n")
 583       (message "Updating mairix database... done")
 584     (error "There was an error updating the mairix database.  \
 585 See %s for details" mairix-output-buffer)))
 586
 587
 588 ;;;; Widget stuff
 589
 590
 591
 592 (defun mairix-widget-send-query (widgets)
 593   "Send query from WIDGETS to mairix binary."
 594   (mairix-search
 595    (mairix-widget-make-query-from-widgets widgets)
 596    (if (widget-value (cadr (assoc "Threads" widgets))) t))
 597   (kill-buffer mairix-customize-query-buffer))
 598
 599 (defun mairix-widget-save-search (widgets)
 600   "Save search based on WIDGETS for future use."
 601   (let ((mairix-last-search
 602          `( ,(mairix-widget-make-query-from-widgets widgets)
 603             nil
 604             ,(widget-value (cadr (assoc "Threads" widgets))))))
 605         (mairix-save-search)
 606         (kill-buffer mairix-customize-query-buffer)))
 607
 608 (defun mairix-widget-make-query-from-widgets (widgets)
 609   "Create mairix query from widget values WIDGETS."
 610   (let (query temp flag)
 611     ;; first we do the editable fields
 612     (dolist (cur mairix-widget-fields-list)
 613       ;; See if checkbox is checked
 614       (when (widget-value
 615              (cadr (assoc (concat "c" (car (cddr cur))) widgets)))
 616         ;; create query for the field
 617         (push
 618          (concat
 619           (nth 1 cur)
 620           ":"
 621           (mairix-replace-invalid-chars
 622            (widget-value
 623            (cadr (assoc (concat "e" (car (cddr cur))) widgets)))))
 624          query)))
 625     ;; Flags
 626     (when (member 'flags mairix-widget-other)
 627       (setq flag
 628             (mapconcat
 629              (function
 630               (lambda (flag)
 631                 (setq temp
 632                       (widget-value (cadr (assoc (car flag) mairix-widgets))))
 633                 (if (string= "yes" temp)
 634                     (cadr flag)
 635                   (if (string= "no" temp)
 636                       (concat "-" (cadr flag))))))
 637              '(("seen" "s") ("replied" "r") ("flagged" "f")) ""))
 638       (when (not (zerop (length flag)))
 639         (push (concat "F:" flag) query)))
 640     ;; return query string
 641     (mapconcat 'identity query " ")))
 642
 643 (defun mairix-widget-create-query (&optional values)
 644   "Create widgets for creating mairix queries.
 645 Fill in VALUES if based on an article."
 646   (let (allwidgets)
 647     (when (get-buffer mairix-customize-query-buffer)
 648       (kill-buffer mairix-customize-query-buffer))
 649     (switch-to-buffer mairix-customize-query-buffer)
 650     (kill-all-local-variables)
 651     (erase-buffer)
 652     (widget-insert
 653      "Specify your query for Mairix using check boxes for activating fields.\n\n")
 654     (widget-insert
 655      (concat "Use ~word        to match messages "
 656              (propertize "not" 'face 'italic)
 657              " containing the word)\n"
 658              "    substring=   to match words containing the substring\n"
 659              "    substring=N  to match words containing the substring, allowing\n"
 660              "                  up to N errors(missing/extra/different letters)\n"
 661              "    ^substring=  to match the substring at the beginning of a word.\n"))
 662     (widget-insert
 663      "Whitespace will be converted to ',' (i.e. AND).  Use '/' for OR.\n\n")
 664     (setq mairix-widgets (mairix-widget-build-editable-fields values))
 665     (when (member 'flags mairix-widget-other)
 666       (widget-insert "\nFlags:\n      Seen:     ")
 667       (mairix-widget-add "seen"
 668                            'menu-choice
 669                            :value "ignore"
 670                            '(item "yes") '(item "no") '(item "ignore"))
 671       (widget-insert "      Replied:  ")
 672       (mairix-widget-add "replied"
 673                            'menu-choice
 674                            :value "ignore"
 675                            '(item "yes") '(item "no") '(item "ignore"))
 676       (widget-insert "      Ticked:   ")
 677       (mairix-widget-add "flagged"
 678                            'menu-choice
 679                            :value "ignore"
 680                            '(item "yes") '(item "no") '(item "ignore")))
 681     (when (member 'threads mairix-widget-other)
 682       (widget-insert "\n")
 683       (mairix-widget-add "Threads" 'checkbox nil))
 684       (widget-insert " Show full threads\n\n")))
 685
 686 (defun mairix-widget-build-editable-fields (values)
 687   "Build editable field widgets in `nnmairix-widget-fields-list'.
 688 VALUES may contain values for editable fields from current article."
 689   (let ((ret))
 690     (mapc
 691      (function
 692       (lambda (field)
 693         (setq field (car (cddr field)))
 694         (setq
 695          ret
 696          (nconc
 697           (list
 698            (list
 699             (concat "c" field)
 700             (widget-create 'checkbox
 701                            :tag field
 702                            :notify (lambda (widget &rest ignore)
 703                                      (mairix-widget-toggle-activate widget))
 704                            nil)))
 705           (list
 706            (list
 707             (concat "e" field)
 708             (widget-create 'editable-field
 709                            :size 60
 710                            :format (concat " " field ":"
 711                                            (make-string
 712                                             (- 11 (length field)) ?\ )
 713                                            "%v")
 714                            :value (or (cadr (assoc field values)) ""))))
 715           ret))
 716         (widget-insert "\n")
 717         ;; Deactivate editable field
 718         (widget-apply (cadr (nth 1 ret)) :deactivate)))
 719      mairix-widget-fields-list)
 720     ret))
 721
 722 (defun mairix-widget-add (name &rest args)
 723   "Add a widget NAME with optional ARGS."
 724   (push
 725    (list name
 726          (apply 'widget-create args))
 727    mairix-widgets))
 728
 729 (defun mairix-widget-toggle-activate (widget)
 730   "Toggle activation status of WIDGET depending on checkbox value."
 731   (let ((field (widget-get widget :tag)))
 732     (if (widget-value widget)
 733         (widget-apply
 734          (cadr (assoc (concat "e" field) mairix-widgets))
 735          :activate)
 736       (widget-apply
 737        (cadr (assoc (concat "e" field) mairix-widgets))
 738        :deactivate)))
 739   (widget-setup))
 740
 741
 742 ;;;; Major mode for editing/deleting/saving searches
 743
 744 (defvar mairix-searches-mode-map
 745   (let ((map (make-keymap)))
 746     (define-key map [(return)] 'mairix-select-search)
 747     (define-key map [(down)] 'mairix-next-search)
 748     (define-key map [(up)] 'mairix-previous-search)
 749     (define-key map [(right)] 'mairix-next-search)
 750     (define-key map [(left)] 'mairix-previous-search)
 751     (define-key map "\C-p" 'mairix-previous-search)
 752     (define-key map "\C-n" 'mairix-next-search)
 753     (define-key map [(q)] 'mairix-select-quit)
 754     (define-key map [(e)] 'mairix-select-edit)
 755     (define-key map [(d)] 'mairix-select-delete)
 756     (define-key map [(s)] 'mairix-select-save)
 757     map)
 758   "'mairix-searches-mode' keymap.")
 759
 760 (defvar mairix-searches-mode-font-lock-keywords
 761   '(("^\\([0-9]+\\)"
 762      (1 font-lock-constant-face))
 763     ("^[0-9 ]+\\(Name:\\) \\(.*\\)"
 764      (1 font-lock-keyword-face) (2 font-lock-string-face))
 765     ("^[ ]+\\(Query:\\) \\(.*\\) , "
 766      (1 font-lock-keyword-face) (2 font-lock-string-face))
 767     (", \\(Threads:\\) \\(.*\\)"
 768      (1 font-lock-keyword-face) (2 font-lock-constant-face))
 769     ("^\\([A-Z].*\\)$"
 770      (1 font-lock-comment-face))
 771     ("^[ ]+\\(Folder:\\) \\(.*\\)"
 772      (1 font-lock-keyword-face) (2 font-lock-string-face))))
 773
 774 (define-derived-mode mairix-searches-mode fundamental-mode "mairix-searches"
 775   "Major mode for editing mairix searches."
 776   :syntax-table text-mode-syntax-table
 777   (setq-local font-lock-defaults '(mairix-searches-mode-font-lock-keywords)))
 778
 779 (defun mairix-build-search-list ()
 780   "Display saved searches in current buffer."
 781   (insert "These are your current saved mairix searches.\n\
 782 You may use the following keys in this buffer: \n\
 783 Return: execute search, e: edit, d: delete, s: save, q: quit\n\
 784 Use cursor keys or C-n,C-p to select next/previous search.\n\n")
 785   (let ((num 0)
 786         (beg (point))
 787         current)
 788     (while (< num (length mairix-saved-searches))
 789       (setq current (nth num mairix-saved-searches))
 790       (setq num (1+ num))
 791       (mairix-insert-search-line num current)
 792       (insert "\n"))
 793     (goto-char beg)))
 794
 795 (defun mairix-insert-search-line (number field)
 796   "Insert new mairix query with NUMBER and values FIELD in buffer."
 797   (insert
 798    (format "%d Name: %s\n   Query: %s , Threads: %s\n   Folder: %s\n"
 799            number
 800            (car field)
 801            (nth 1 field)
 802            (if (nth 3 field)
 803                "Yes"
 804              "No")
 805            (if (nth 2 field)
 806                (nth 2 field)
 807              "Default"))))
 808
 809 (defun mairix-select-search ()
 810   "Call mairix with currently selected search."
 811   (interactive)
 812   (beginning-of-line)
 813   (if (not (looking-at "[0-9]+ Name"))
 814       (progn
 815         (ding)
 816         (message "Put cursor on a line with a search name first"))
 817     (progn
 818       (let* ((query (nth
 819                     (1- (read (current-buffer)))
 820                     mairix-saved-searches))
 821             (folder (nth 2 query)))
 822         (when (not folder)
 823           (setq folder mairix-search-file))
 824         (mairix-call-mairix
 825          (split-string (nth 1 query))
 826          folder
 827          (car (last query)))
 828         (mairix-select-quit)
 829         (mairix-show-folder folder)))))
 830
 831 (defun mairix-next-search ()
 832   "Jump to next search."
 833   (interactive)
 834   (if (search-forward-regexp "^[0-9]+"
 835                              (point-max)
 836                              t
 837                              2)
 838       (beginning-of-line)
 839     (ding)))
 840
 841 (defun mairix-previous-search ()
 842   "Jump to previous search."
 843   (interactive)
 844   (if (search-backward-regexp "^[0-9]+"
 845                              (point-min)
 846                              t)
 847       (beginning-of-line)
 848     (ding)))
 849
 850 (defun mairix-select-quit ()
 851   "Quit mairix search mode."
 852   (interactive)
 853   (when mairix-searches-changed
 854     (mairix-select-save))
 855   (kill-buffer nil))
 856
 857 (defun mairix-select-save ()
 858   "Save current mairix searches."
 859   (interactive)
 860   (when (y-or-n-p "Save mairix searches permanently in your .emacs? ")
 861     (customize-save-variable 'mairix-saved-searches mairix-saved-searches)))
 862
 863 (defun mairix-select-edit ()
 864   "Edit currently selected mairix search."
 865   (interactive)
 866   (beginning-of-line)
 867   (if (not (looking-at "[0-9]+ Name"))
 868       (error "Put cursor on a line with a search name first")
 869     (progn
 870       (let* ((number (1- (read (current-buffer))))
 871              (query (nth number mairix-saved-searches))
 872              (folder (nth 2 query))
 873              newname newquery newfolder threads)
 874         (backward-char)
 875         (setq newname (read-string "Name of the search: " (car query)))
 876         (when (assoc newname (remq (nth number mairix-saved-searches)
 877                                    mairix-saved-searches))
 878           (error "This name does already exist"))
 879         (setq newquery (read-string "Query: " (nth 1 query)))
 880         (setq threads (y-or-n-p "Include whole threads? "))
 881         (setq newfolder
 882               (read-string "Mail folder (use empty string for default): "
 883                            folder))
 884         (when (zerop (length newfolder))
 885           (setq newfolder nil))
 886         ;; set new values
 887         (setcar (nth number mairix-saved-searches) newname)
 888         (setcdr (nth number mairix-saved-searches)
 889                 (list newquery newfolder threads))
 890         (setq mairix-searches-changed t)
 891         (let ((beg (point)))
 892           (forward-line 3)
 893           (end-of-line)
 894           (delete-region beg (point))
 895           (mairix-insert-search-line (1+ number)
 896                                      (nth number mairix-saved-searches))
 897           (goto-char beg))))))
 898
 899 (defun mairix-select-delete ()
 900   "Delete currently selected mairix search."
 901   (interactive)
 902   (if (not (looking-at "[0-9]+ Name"))
 903       (error "Put cursor on a line with a search name first")
 904     (progn
 905       (let* ((number (1- (read (current-buffer))))
 906              (query (nth number mairix-saved-searches))
 907              beg)
 908         (backward-char)
 909         (when (y-or-n-p (format "Delete search %s ? " (car query)))
 910           (setq mairix-saved-searches
 911                 (delq query mairix-saved-searches))
 912           (setq mairix-searches-changed t)
 913           (setq beg (point))
 914           (forward-line 4)
 915           (beginning-of-line)
 916           (delete-region beg (point))
 917           (while (search-forward-regexp "^[0-9]+"
 918                                         (point-max)
 919                                         t
 920                                         1)
 921             (replace-match (number-to-string
 922                             (setq number (1+ number)))))))
 923       (beginning-of-line))))
 924
 925 (defun mairix-widget-get-values ()
 926   "Create values for editable fields from current article."
 927   (let ((get-mail-header
 928          (cadr (assq mairix-mail-program mairix-get-mail-header-functions))))
 929     (if get-mail-header
 930         (save-excursion
 931           (save-restriction
 932             (mapcar
 933              (function
 934               (lambda (field)
 935                 (list (car (cddr field))
 936                       (if (car field)
 937                           (mairix-replace-invalid-chars
 938                            (funcall get-mail-header (car field)))
 939                         nil))))
 940              mairix-widget-fields-list)))
 941       (error "No function for obtaining mail header specified"))))
 942
 943
 944 (provide 'mairix)
 945
 946 ;;; mairix.el ends here