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

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