cgit.sxemacs.org Git - gnus/blob - lisp/ecomplete.el

   1 ;;; ecomplete.el --- electric completion of addresses and the like
   2
   3 ;; Copyright (C) 2006, 2007  Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: mail
   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, or (at your option)
  13 ;; 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; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile
  30   (require 'cl))
  31
  32 (defgroup ecomplete nil
  33   "Electric completion of email addresses and the like."
  34   :group 'mail)
  35
  36 (defcustom ecomplete-database-file "~/.ecompleterc"
  37   "*The name of the file to store the ecomplete data."
  38   :group 'ecomplete
  39   :type 'file)
  40
  41 (defcustom ecomplete-database-file-coding-system 'iso-2022-7bit
  42   "Coding system used for writing the ecomplete database file."
  43   :type '(symbol :tag "Coding system")
  44   :group 'ecomplete)
  45
  46 ;;; Internal variables.
  47
  48 (defvar ecomplete-database nil)
  49
  50 ;;;###autoload
  51 (defun ecomplete-setup ()
  52   (when (file-exists-p ecomplete-database-file)
  53     (with-temp-buffer
  54       (let ((coding-system-for-read ecomplete-database-file-coding-system))
  55         (insert-file-contents ecomplete-database-file)
  56         (setq ecomplete-database (read (current-buffer)))))))
  57
  58 (defun ecomplete-add-item (type key text)
  59   (let ((elems (assq type ecomplete-database))
  60         (now (string-to-number
  61               (format "%.0f" (time-to-seconds (current-time)))))
  62         entry)
  63     (unless elems
  64       (push (setq elems (list type)) ecomplete-database))
  65     (if (setq entry (assoc key (cdr elems)))
  66         (setcdr entry (list (1+ (cadr entry)) now text))
  67       (nconc elems (list (list key 1 now text))))))
  68
  69 (defun ecomplete-get-item (type key)
  70   (assoc key (cdr (assq type ecomplete-database))))
  71
  72 (defun ecomplete-save ()
  73   (with-temp-buffer
  74     (let ((coding-system-for-write ecomplete-database-file-coding-system))
  75       (insert "(")
  76       (loop for (type . elems) in ecomplete-database
  77             do
  78             (insert (format "(%s\n" type))
  79             (dolist (entry elems)
  80               (prin1 entry (current-buffer))
  81               (insert "\n"))
  82             (insert ")\n"))
  83       (insert ")")
  84       (write-region (point-min) (point-max)
  85                     ecomplete-database-file nil 'silent))))
  86
  87 (defun ecomplete-get-matches (type match)
  88   (let* ((elems (cdr (assq type ecomplete-database)))
  89          (match (regexp-quote match))
  90          (candidates
  91           (sort
  92            (loop for (key count time text) in elems
  93                  when (string-match match text)
  94                  collect (list count time text))
  95            (lambda (l1 l2)
  96              (> (car l1) (car l2))))))
  97     (when (> (length candidates) 10)
  98       (setcdr (nthcdr 10 candidates) nil))
  99     (unless (zerop (length candidates))
 100       (with-temp-buffer
 101         (dolist (candidate candidates)
 102           (insert (caddr candidate) "\n"))
 103         (goto-char (point-min))
 104         (put-text-property (point) (1+ (point)) 'ecomplete t)
 105         (while (re-search-forward match nil t)
 106           (put-text-property (match-beginning 0) (match-end 0)
 107                              'face 'isearch))
 108         (buffer-string)))))
 109
 110 (defun ecomplete-display-matches (type word &optional choose)
 111   (let* ((matches (ecomplete-get-matches type word))
 112          (line 0)
 113          (max-lines (when matches (- (length (split-string matches "\n")) 2)))
 114          (message-log-max nil)
 115          command highlight)
 116     (if (not matches)
 117         (progn
 118           (message "No ecomplete matches")
 119           nil)
 120       (if (not choose)
 121           (progn
 122             (message matches)
 123             nil)
 124         (setq highlight (ecomplete-highlight-match-line matches line))
 125         (while (not (memq (setq command (read-event highlight)) '(? return)))
 126           (cond
 127            ((eq command ?\M-n)
 128             (setq line (min (1+ line) max-lines)))
 129            ((eq command ?\M-p)
 130             (setq line (max (1- line) 0))))
 131           (setq highlight (ecomplete-highlight-match-line matches line)))
 132         (when (eq command 'return)
 133           (nth line (split-string matches "\n")))))))
 134
 135 (defun ecomplete-highlight-match-line (matches line)
 136   (with-temp-buffer
 137     (insert matches)
 138     (goto-char (point-min))
 139     (forward-line line)
 140     (save-restriction
 141       (narrow-to-region (point) (point-at-eol))
 142       (while (not (eobp))
 143         ;; Put the 'region face on any charactes on this line that
 144         ;; aren't already highlighted.
 145         (unless (get-text-property (point) 'face)
 146           (put-text-property (point) (1+ (point)) 'face 'highlight))
 147         (forward-char 1)))
 148     (buffer-string)))
 149
 150 (provide 'ecomplete)
 151
 152 ;; arch-tag: 34622935-bb81-4711-a600-57b89c2ece72
 153 ;;; ecomplete.el ends here