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
 269 ;; For gnus-buffer-exists-p, although it seems that could be replaced by:
 270 ;; (and buffer (get-buffer buffer))
 271 (eval-when-compile (require 'gnus-util))
 272 (defvar gnus-article-buffer)
 273 (declare-function gnus-group-read-ephemeral-group "gnus-group"
 274                   (group method &optional activate quit-config
 275                   request-only select-articles parameters number))
 276 (declare-function gnus-summary-toggle-header "gnus-sum" (&optional arg))
 277 (declare-function message-field-value "message" (header &optional not-all))
 278
 279 ;; Display function:
 280 (defun mairix-gnus-ephemeral-nndoc (folder)
 281   "Create ephemeral nndoc group for reading mbox file FOLDER in Gnus."
 282   (unless (and (fboundp 'gnus-alive-p)
 283                (gnus-alive-p))
 284     (error "Gnus is not running"))
 285   (gnus-group-read-ephemeral-group
 286    ;; add randomness to group string to prevent Gnus from using a
 287    ;; cached version
 288    (format "mairix.%s" (number-to-string (random 10000)))
 289    `(nndoc "mairix"
 290            (nndoc-address ,folder)
 291            (nndoc-article-type mbox))))
 292
 293 ;; Fetching mail header field:
 294 (defun mairix-gnus-fetch-field (field)
 295   "Get mail header FIELD for current message using Gnus."
 296   (unless (and (fboundp 'gnus-alive-p)
 297                (gnus-alive-p))
 298     (error "Gnus is not running"))
 299   (unless (gnus-buffer-exists-p gnus-article-buffer)
 300     (error "No article buffer available"))
 301   (with-current-buffer gnus-article-buffer
 302     ;; gnus-art requires gnus-sum and message.
 303     (gnus-summary-toggle-header 1)
 304     (message-field-value field)))
 305
 306 ;;; VM
 307 ;;; written by Ulrich Mueller
 308
 309 (declare-function vm-quit "ext:vm-folder" (&optional no-change))
 310 (declare-function vm-visit-folder "ext:vm-startup"
 311                   (folder &optional read-only))
 312 (declare-function vm-select-folder-buffer "ext:vm-macro" ()) ; defsubst
 313 (declare-function vm-check-for-killed-summary "ext:vm-misc" ())
 314 (declare-function vm-error-if-folder-empty "ext:vm-misc" ())
 315 (declare-function vm-get-header-contents "ext:vm-summary"
 316                   (message header-name-regexp &optional clump-sep))
 317 (declare-function vm-select-marked-or-prefixed-messages "ext:vm-folder"
 318                   (prefix))
 319
 320 ;; Display function
 321 (defun mairix-vm-display (folder)
 322   "Display mbox file FOLDER with VM."
 323   (require 'vm)
 324   ;; check if folder is already open and if so, kill it
 325   (let ((buf (get-file-buffer folder)))
 326     (when buf
 327       (set-buffer buf)
 328       (set-buffer-modified-p nil)
 329       (condition-case nil
 330           (vm-quit t)
 331         (error nil))
 332       (kill-buffer buf)))
 333   (vm-visit-folder folder t))
 334
 335 ;; Fetching mail header field
 336 (defun mairix-vm-fetch-field (field)
 337   "Get mail header FIELD for current message using VM."
 338   (save-excursion
 339     (vm-select-folder-buffer)
 340     (vm-check-for-killed-summary)
 341     (vm-error-if-folder-empty)
 342     (vm-get-header-contents
 343      (car (vm-select-marked-or-prefixed-messages 1)) field)))
 344
 345 ;;;; Main interactive functions
 346
 347 (defun mairix-search (search threads)
 348   "Call Mairix with SEARCH.
 349 If THREADS is non-nil, also display whole threads of found
 350 messages.  Results will be put into the default search file."
 351   (interactive
 352    (list
 353     (read-string "Query: ")
 354     (y-or-n-p "Include threads? ")))
 355   (when (mairix-call-mairix
 356          (split-string search)
 357          nil
 358          threads)
 359     (mairix-show-folder mairix-search-file)))
 360
 361 (defun mairix-use-saved-search ()
 362   "Use a saved search for querying Mairix."
 363   (interactive)
 364   (let* ((completions
 365           (mapcar (lambda (el) (list (car el))) mairix-saved-searches))
 366          (search (completing-read "Name of search: " completions))
 367          (query (assoc search mairix-saved-searches))
 368          (folder (nth 2 query)))
 369     (when (not folder)
 370       (setq folder mairix-search-file))
 371     (when query
 372       (mairix-call-mairix
 373        (split-string (nth 1 query))
 374        folder
 375        (car (last query)))
 376       (mairix-show-folder folder))))
 377
 378 (defun mairix-save-search ()
 379   "Save the last search."
 380   (interactive)
 381   (let* ((name (read-string "Name of the search: "))
 382          (exist (assoc name mairix-saved-searches)))
 383     (if (not exist)
 384         (add-to-list 'mairix-saved-searches
 385                      (append (list name) mairix-last-search))
 386       (when
 387           (y-or-n-p
 388            "There is already a search with this name.  \
 389 Overwrite existing entry? ")
 390         (setcdr (assoc name mairix-saved-searches) mairix-last-search))))
 391   (mairix-select-save))
 392
 393 (defun mairix-edit-saved-searches-customize ()
 394   "Edit the list of saved searches in a customization buffer."
 395   (interactive)
 396   (custom-buffer-create (list (list 'mairix-saved-searches 'custom-variable))
 397                         "*Customize Mairix Query*"
 398                                 (concat "\n\n" (make-string 65 ?=)
 399 "\nYou can now customize your saved Mairix searches by modifying\n\
 400 the variable mairix-saved-searches. Don't forget to save your\nchanges \
 401 in your .emacs by pressing `Save for Future Sessions'.\n"
 402 (make-string 65 ?=) "\n")))
 403
 404 (autoload 'mail-strip-quoted-names "mail-utils")
 405 (defun mairix-search-from-this-article (threads)
 406   "Search messages from sender of the current article.
 407 This is effectively a shortcut for calling `mairix-search' with
 408 f:current_from.  If prefix THREADS is non-nil, include whole
 409 threads."
 410   (interactive "P")
 411   (let ((get-mail-header
 412          (cadr (assq mairix-mail-program mairix-get-mail-header-functions))))
 413     (if get-mail-header
 414         (mairix-search
 415          (format "f:%s"
 416                  (mail-strip-quoted-names
 417                   (funcall get-mail-header "from")))
 418          threads)
 419       (error "No function for obtaining mail header specified"))))
 420
 421 (defun mairix-search-thread-this-article ()
 422   "Search thread for the current article.
 423 This is effectively a shortcut for calling `mairix-search'
 424 with m:msgid of the current article and enabled threads."
 425   (interactive)
 426   (let ((get-mail-header
 427          (cadr (assq mairix-mail-program mairix-get-mail-header-functions)))
 428         mid)
 429     (unless get-mail-header
 430       (error "No function for obtaining mail header specified"))
 431     (setq mid (funcall get-mail-header "message-id"))
 432     (while (string-match "[<>]" mid)
 433       (setq mid (replace-match "" t t mid)))
 434     ;; mairix somehow does not like '$' in message-id
 435     (when (string-match "\\$" mid)
 436       (setq mid (concat mid "=")))
 437     (while (string-match "\\$" mid)
 438       (setq mid (replace-match "=," t t mid)))
 439     (mairix-search
 440      (format "m:%s" mid) t)))
 441
 442 (defun mairix-widget-search-based-on-article ()
 443   "Create mairix query based on current article using widgets."
 444   (interactive)
 445   (mairix-widget-search
 446    (mairix-widget-get-values)))
 447
 448 (defun mairix-edit-saved-searches ()
 449   "Edit current mairix searches."
 450   (interactive)
 451   (switch-to-buffer mairix-saved-searches-buffer)
 452   (erase-buffer)
 453   (setq mairix-searches-changed nil)
 454   (mairix-build-search-list)
 455   (mairix-searches-mode)
 456   (hl-line-mode))
 457
 458 (defvar mairix-widgets)
 459
 460 (defun mairix-widget-search (&optional mvalues)
 461   "Create mairix query interactively using graphical widgets.
 462 MVALUES may contain values from current article."
 463   (interactive)
 464   ;; Select window for mairix customization
 465   (funcall mairix-widget-select-window-function)
 466   ;; generate widgets
 467   (mairix-widget-create-query mvalues)
 468   ;; generate Buttons
 469   (widget-create 'push-button
 470                  :notify
 471                  (lambda (&rest ignore)
 472                    (mairix-widget-send-query mairix-widgets))
 473                  "Send Query")
 474   (widget-insert "   ")
 475   (widget-create 'push-button
 476                  :notify
 477                  (lambda (&rest ignore)
 478                    (mairix-widget-save-search mairix-widgets))
 479                  "Save search")
 480   (widget-insert "   ")
 481   (widget-create 'push-button
 482                  :notify (lambda (&rest ignore)
 483                            (kill-buffer mairix-customize-query-buffer))
 484                  "Cancel")
 485   (use-local-map widget-keymap)
 486   (widget-setup)
 487   (goto-char (point-min)))
 488
 489 (defun mairix-update-database ()
 490   "Call mairix for updating the database for SERVERS.
 491 Mairix will be called asynchronously unless
 492 `mairix-synchronous-update' is t.  Mairix will be called with
 493 `mairix-update-options'."
 494   (interactive)
 495   (let ((commandsplit (split-string mairix-command))
 496         args)
 497     (if mairix-synchronous-update
 498         (progn
 499           (setq args (append (list (car commandsplit) nil
 500                                    (get-buffer-create mairix-output-buffer)
 501                                    nil)))
 502           (if (> (length commandsplit) 1)
 503               (setq args (append args
 504                                  (cdr commandsplit)
 505                                  mairix-update-options))
 506             (setq args (append args mairix-update-options)))
 507           (apply 'call-process args))
 508       (progn
 509         (message "Updating mairix database...")
 510         (setq args (append (list "mairixupdate" (get-buffer-create mairix-output-buffer)
 511                                  (car commandsplit))))
 512         (if (> (length commandsplit) 1)
 513             (setq args (append args (cdr commandsplit) mairix-update-options))
 514           (setq args (append args mairix-update-options)))
 515         (set-process-sentinel
 516          (apply 'start-process args)
 517          'mairix-sentinel-mairix-update-finished)))))
 518
 519
 520 ;;;; Helper functions
 521
 522 (defun mairix-show-folder (folder)
 523   "Display mail FOLDER with mail program.
 524 The mail program is given by `mairix-mail-program'."
 525   (let ((display-function
 526          (cadr (assq mairix-mail-program mairix-display-functions))))
 527     (if display-function
 528         (funcall display-function
 529                  (concat
 530                   (file-name-as-directory
 531                    (expand-file-name mairix-file-path))
 532                   folder))
 533       (error "No mail program set"))))
 534
 535 (defun mairix-call-mairix (query file threads)
 536   "Call Mairix with QUERY and output FILE.
 537 If FILE is nil, use default.  If THREADS is non-nil, also return
 538 whole threads.  Function returns t if messages were found."
 539   (let* ((commandsplit (split-string mairix-command))
 540          (args (cons (car commandsplit)
 541                      `(nil ,(get-buffer-create mairix-output-buffer) nil)))
 542          rval)
 543     (with-current-buffer mairix-output-buffer
 544       (erase-buffer))
 545     (when (> (length commandsplit) 1)
 546       (setq args (append args (cdr commandsplit))))
 547     (when threads
 548       (setq args (append args '("-t"))))
 549     (when (stringp query)
 550       (setq query (split-string query)))
 551     (setq mairix-last-search (list (mapconcat 'identity query " ")
 552                                      file threads))
 553     (when (not file)
 554       (setq file mairix-search-file))
 555     (setq file
 556           (concat
 557            (file-name-as-directory
 558             (expand-file-name
 559              mairix-file-path))
 560            file))
 561     (setq rval
 562           (apply 'call-process
 563                  (append args (list "-o" file) query)))
 564     (if (zerop rval)
 565         (with-current-buffer mairix-output-buffer
 566           (goto-char (point-min))
 567           (re-search-forward "^Matched.*messages")
 568           (message (match-string 0)))
 569       (if (and (= rval 1)
 570                (with-current-buffer mairix-output-buffer
 571                  (goto-char (point-min))
 572                  (looking-at "^Matched 0 messages")))
 573           (message "No messages found")
 574         (error "Error running Mairix.  See buffer %s for details"
 575                mairix-output-buffer)))
 576     (zerop rval)))
 577
 578 (defun mairix-replace-invalid-chars (header)
 579   "Replace invalid characters in HEADER for mairix query."
 580   (when header
 581     (while (string-match "[^-.@/,^=~& [:alnum:]]" header)
 582       (setq header (replace-match "" t t header)))
 583     (while (string-match "[& ]" header)
 584       (setq header (replace-match "," t t header)))
 585   header))
 586
 587 (defun mairix-sentinel-mairix-update-finished (proc status)
 588   "Sentinel for mairix update process PROC with STATUS."
 589   (if (equal status "finished\n")
 590       (message "Updating mairix database... done")
 591     (error "There was an error updating the mairix database.  \
 592 See %s for details" mairix-output-buffer)))
 593
 594
 595 ;;;; Widget stuff
 596
 597
 598
 599 (defun mairix-widget-send-query (widgets)
 600   "Send query from WIDGETS to mairix binary."
 601   (mairix-search
 602    (mairix-widget-make-query-from-widgets widgets)
 603    (if (widget-value (cadr (assoc "Threads" widgets))) t))
 604   (kill-buffer mairix-customize-query-buffer))
 605
 606 (defun mairix-widget-save-search (widgets)
 607   "Save search based on WIDGETS for future use."
 608   (let ((mairix-last-search
 609          `( ,(mairix-widget-make-query-from-widgets widgets)
 610             nil
 611             ,(widget-value (cadr (assoc "Threads" widgets))))))
 612         (mairix-save-search)
 613         (kill-buffer mairix-customize-query-buffer)))
 614
 615 (defun mairix-widget-make-query-from-widgets (widgets)
 616   "Create mairix query from widget values WIDGETS."
 617   (let (query temp flag)
 618     ;; first we do the editable fields
 619     (dolist (cur mairix-widget-fields-list)
 620       ;; See if checkbox is checked
 621       (when (widget-value
 622              (cadr (assoc (concat "c" (car (cddr cur))) widgets)))
 623         ;; create query for the field
 624         (push
 625          (concat
 626           (nth 1 cur)
 627           ":"
 628           (mairix-replace-invalid-chars
 629            (widget-value
 630            (cadr (assoc (concat "e" (car (cddr cur))) widgets)))))
 631          query)))
 632     ;; Flags
 633     (when (member 'flags mairix-widget-other)
 634       (setq flag
 635             (mapconcat
 636              (function
 637               (lambda (flag)
 638                 (setq temp
 639                       (widget-value (cadr (assoc (car flag) mairix-widgets))))
 640                 (if (string= "yes" temp)
 641                     (cadr flag)
 642                   (if (string= "no" temp)
 643                       (concat "-" (cadr flag))))))
 644              '(("seen" "s") ("replied" "r") ("flagged" "f")) ""))
 645       (when (not (zerop (length flag)))
 646         (push (concat "F:" flag) query)))
 647     ;; return query string
 648     (mapconcat 'identity query " ")))
 649
 650 (defun mairix-widget-create-query (&optional values)
 651   "Create widgets for creating mairix queries.
 652 Fill in VALUES if based on an article."
 653   (let (allwidgets)
 654     (when (get-buffer mairix-customize-query-buffer)
 655       (kill-buffer mairix-customize-query-buffer))
 656     (switch-to-buffer mairix-customize-query-buffer)
 657     (kill-all-local-variables)
 658     (erase-buffer)
 659     (widget-insert
 660      "Specify your query for Mairix using check boxes for activating fields.\n\n")
 661     (widget-insert
 662      (concat "Use ~word        to match messages "
 663              (propertize "not" 'face 'italic)
 664              " containing the word)\n"
 665              "    substring=   to match words containing the substring\n"
 666              "    substring=N  to match words containing the substring, allowing\n"
 667              "                  up to N errors(missing/extra/different letters)\n"
 668              "    ^substring=  to match the substring at the beginning of a word.\n"))
 669     (widget-insert
 670      (format-message
 671       "Whitespace will be converted to `,' (i.e. AND).  Use `/' for OR.\n\n"))
 672     (setq mairix-widgets (mairix-widget-build-editable-fields values))
 673     (when (member 'flags mairix-widget-other)
 674       (widget-insert "\nFlags:\n      Seen:     ")
 675       (mairix-widget-add "seen"
 676                            'menu-choice
 677                            :value "ignore"
 678                            '(item "yes") '(item "no") '(item "ignore"))
 679       (widget-insert "      Replied:  ")
 680       (mairix-widget-add "replied"
 681                            'menu-choice
 682                            :value "ignore"
 683                            '(item "yes") '(item "no") '(item "ignore"))
 684       (widget-insert "      Ticked:   ")
 685       (mairix-widget-add "flagged"
 686                            'menu-choice
 687                            :value "ignore"
 688                            '(item "yes") '(item "no") '(item "ignore")))
 689     (when (member 'threads mairix-widget-other)
 690       (widget-insert "\n")
 691       (mairix-widget-add "Threads" 'checkbox nil))
 692       (widget-insert " Show full threads\n\n")))
 693
 694 (defun mairix-widget-build-editable-fields (values)
 695   "Build editable field widgets in `nnmairix-widget-fields-list'.
 696 VALUES may contain values for editable fields from current article."
 697   (let ((ret))
 698     (mapc
 699      (function
 700       (lambda (field)
 701         (setq field (car (cddr field)))
 702         (setq
 703          ret
 704          (nconc
 705           (list
 706            (list
 707             (concat "c" field)
 708             (widget-create 'checkbox
 709                            :tag field
 710                            :notify (lambda (widget &rest ignore)
 711                                      (mairix-widget-toggle-activate widget))
 712                            nil)))
 713           (list
 714            (list
 715             (concat "e" field)
 716             (widget-create 'editable-field
 717                            :size 60
 718                            :format (concat " " field ":"
 719                                            (make-string
 720                                             (- 11 (length field)) ?\ )
 721                                            "%v")
 722                            :value (or (cadr (assoc field values)) ""))))
 723           ret))
 724         (widget-insert "\n")
 725         ;; Deactivate editable field
 726         (widget-apply (cadr (nth 1 ret)) :deactivate)))
 727      mairix-widget-fields-list)
 728     ret))
 729
 730 (defun mairix-widget-add (name &rest args)
 731   "Add a widget NAME with optional ARGS."
 732   (push
 733    (list name
 734          (apply 'widget-create args))
 735    mairix-widgets))
 736
 737 (defun mairix-widget-toggle-activate (widget)
 738   "Toggle activation status of WIDGET depending on checkbox value."
 739   (let ((field (widget-get widget :tag)))
 740     (if (widget-value widget)
 741         (widget-apply
 742          (cadr (assoc (concat "e" field) mairix-widgets))
 743          :activate)
 744       (widget-apply
 745        (cadr (assoc (concat "e" field) mairix-widgets))
 746        :deactivate)))
 747   (widget-setup))
 748
 749
 750 ;;;; Major mode for editing/deleting/saving searches
 751
 752 (defvar mairix-searches-mode-map
 753   (let ((map (make-keymap)))
 754     (define-key map [(return)] 'mairix-select-search)
 755     (define-key map [(down)] 'mairix-next-search)
 756     (define-key map [(up)] 'mairix-previous-search)
 757     (define-key map [(right)] 'mairix-next-search)
 758     (define-key map [(left)] 'mairix-previous-search)
 759     (define-key map "\C-p" 'mairix-previous-search)
 760     (define-key map "\C-n" 'mairix-next-search)
 761     (define-key map [(q)] 'mairix-select-quit)
 762     (define-key map [(e)] 'mairix-select-edit)
 763     (define-key map [(d)] 'mairix-select-delete)
 764     (define-key map [(s)] 'mairix-select-save)
 765     map)
 766   "`mairix-searches-mode' keymap.")
 767
 768 (defvar mairix-searches-mode-font-lock-keywords
 769   '(("^\\([0-9]+\\)"
 770      (1 font-lock-constant-face))
 771     ("^[0-9 ]+\\(Name:\\) \\(.*\\)"
 772      (1 font-lock-keyword-face) (2 font-lock-string-face))
 773     ("^[ ]+\\(Query:\\) \\(.*\\) , "
 774      (1 font-lock-keyword-face) (2 font-lock-string-face))
 775     (", \\(Threads:\\) \\(.*\\)"
 776      (1 font-lock-keyword-face) (2 font-lock-constant-face))
 777     ("^\\([A-Z].*\\)$"
 778      (1 font-lock-comment-face))
 779     ("^[ ]+\\(Folder:\\) \\(.*\\)"
 780      (1 font-lock-keyword-face) (2 font-lock-string-face))))
 781
 782 (define-derived-mode mairix-searches-mode fundamental-mode "mairix-searches"
 783   "Major mode for editing mairix searches."
 784   :syntax-table text-mode-syntax-table
 785   (setq-local font-lock-defaults '(mairix-searches-mode-font-lock-keywords)))
 786
 787 (defun mairix-build-search-list ()
 788   "Display saved searches in current buffer."
 789   (insert "These are your current saved mairix searches.\n\
 790 You may use the following keys in this buffer: \n\
 791 Return: execute search, e: edit, d: delete, s: save, q: quit\n\
 792 Use cursor keys or C-n,C-p to select next/previous search.\n\n")
 793   (let ((num 0)
 794         (beg (point))
 795         current)
 796     (while (< num (length mairix-saved-searches))
 797       (setq current (nth num mairix-saved-searches))
 798       (setq num (1+ num))
 799       (mairix-insert-search-line num current)
 800       (insert "\n"))
 801     (goto-char beg)))
 802
 803 (defun mairix-insert-search-line (number field)
 804   "Insert new mairix query with NUMBER and values FIELD in buffer."
 805   (insert
 806    (format "%d Name: %s\n   Query: %s , Threads: %s\n   Folder: %s\n"
 807            number
 808            (car field)
 809            (nth 1 field)
 810            (if (nth 3 field)
 811                "Yes"
 812              "No")
 813            (if (nth 2 field)
 814                (nth 2 field)
 815              "Default"))))
 816
 817 (defun mairix-select-search ()
 818   "Call mairix with currently selected search."
 819   (interactive)
 820   (beginning-of-line)
 821   (if (not (looking-at "[0-9]+ Name"))
 822       (progn
 823         (ding)
 824         (message "Put cursor on a line with a search name first"))
 825     (progn
 826       (let* ((query (nth
 827                     (1- (read (current-buffer)))
 828                     mairix-saved-searches))
 829             (folder (nth 2 query)))
 830         (when (not folder)
 831           (setq folder mairix-search-file))
 832         (mairix-call-mairix
 833          (split-string (nth 1 query))
 834          folder
 835          (car (last query)))
 836         (mairix-select-quit)
 837         (mairix-show-folder folder)))))
 838
 839 (defun mairix-next-search ()
 840   "Jump to next search."
 841   (interactive)
 842   (if (search-forward-regexp "^[0-9]+"
 843                              (point-max)
 844                              t
 845                              2)
 846       (beginning-of-line)
 847     (ding)))
 848
 849 (defun mairix-previous-search ()
 850   "Jump to previous search."
 851   (interactive)
 852   (if (search-backward-regexp "^[0-9]+"
 853                              (point-min)
 854                              t)
 855       (beginning-of-line)
 856     (ding)))
 857
 858 (defun mairix-select-quit ()
 859   "Quit mairix search mode."
 860   (interactive)
 861   (when mairix-searches-changed
 862     (mairix-select-save))
 863   (kill-buffer nil))
 864
 865 (defun mairix-select-save ()
 866   "Save current mairix searches."
 867   (interactive)
 868   (when (y-or-n-p "Save mairix searches permanently in your .emacs? ")
 869     (customize-save-variable 'mairix-saved-searches mairix-saved-searches)))
 870
 871 (defun mairix-select-edit ()
 872   "Edit currently selected mairix search."
 873   (interactive)
 874   (beginning-of-line)
 875   (if (not (looking-at "[0-9]+ Name"))
 876       (error "Put cursor on a line with a search name first")
 877     (progn
 878       (let* ((number (1- (read (current-buffer))))
 879              (query (nth number mairix-saved-searches))
 880              (folder (nth 2 query))
 881              newname newquery newfolder threads)
 882         (backward-char)
 883         (setq newname (read-string "Name of the search: " (car query)))
 884         (when (assoc newname (remq (nth number mairix-saved-searches)
 885                                    mairix-saved-searches))
 886           (error "This name does already exist"))
 887         (setq newquery (read-string "Query: " (nth 1 query)))
 888         (setq threads (y-or-n-p "Include whole threads? "))
 889         (setq newfolder
 890               (read-string "Mail folder (use empty string for default): "
 891                            folder))
 892         (when (zerop (length newfolder))
 893           (setq newfolder nil))
 894         ;; set new values
 895         (setcar (nth number mairix-saved-searches) newname)
 896         (setcdr (nth number mairix-saved-searches)
 897                 (list newquery newfolder threads))
 898         (setq mairix-searches-changed t)
 899         (let ((beg (point)))
 900           (forward-line 3)
 901           (end-of-line)
 902           (delete-region beg (point))
 903           (mairix-insert-search-line (1+ number)
 904                                      (nth number mairix-saved-searches))
 905           (goto-char beg))))))
 906
 907 (defun mairix-select-delete ()
 908   "Delete currently selected mairix search."
 909   (interactive)
 910   (if (not (looking-at "[0-9]+ Name"))
 911       (error "Put cursor on a line with a search name first")
 912     (progn
 913       (let* ((number (1- (read (current-buffer))))
 914              (query (nth number mairix-saved-searches))
 915              beg)
 916         (backward-char)
 917         (when (y-or-n-p (format "Delete search %s ? " (car query)))
 918           (setq mairix-saved-searches
 919                 (delq query mairix-saved-searches))
 920           (setq mairix-searches-changed t)
 921           (setq beg (point))
 922           (forward-line 4)
 923           (beginning-of-line)
 924           (delete-region beg (point))
 925           (while (search-forward-regexp "^[0-9]+"
 926                                         (point-max)
 927                                         t
 928                                         1)
 929             (replace-match (number-to-string
 930                             (setq number (1+ number)))))))
 931       (beginning-of-line))))
 932
 933 (defun mairix-widget-get-values ()
 934   "Create values for editable fields from current article."
 935   (let ((get-mail-header
 936          (cadr (assq mairix-mail-program mairix-get-mail-header-functions))))
 937     (if get-mail-header
 938         (save-excursion
 939           (save-restriction
 940             (mapcar
 941              (function
 942               (lambda (field)
 943                 (list (car (cddr field))
 944                       (if (car field)
 945                           (mairix-replace-invalid-chars
 946                            (funcall get-mail-header (car field)))
 947                         nil))))
 948              mairix-widget-fields-list)))
 949       (error "No function for obtaining mail header specified"))))
 950
 951
 952 (provide 'mairix)
 953
 954 ;;; mairix.el ends here