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 ;;; Internal variables.
  41
  42 (defvar ecomplete-database nil)
  43
  44 ;;;###autoload
  45 (defun ecomplete-setup ()
  46   (when (file-exists-p ecomplete-database-file)
  47     (with-temp-buffer
  48       (insert-file-contents ecomplete-database-file)
  49       (setq ecomplete-database (read (current-buffer))))))
  50
  51 (defun ecomplete-add-item (type key text)
  52   (let ((elems (assq type ecomplete-database))
  53         (now (string-to-number
  54               (format "%.0f" (time-to-seconds (current-time)))))
  55         entry)
  56     (unless elems
  57       (push (setq elems (list type)) ecomplete-database))
  58     (if (setq entry (assoc key (cdr elems)))
  59         (setcdr entry (list (1+ (cadr entry)) now text))
  60       (nconc elems (list (list key 1 now text))))))
  61
  62 (defun ecomplete-get-item (type key)
  63   (assoc key (cdr (assq type ecomplete-database))))
  64
  65 (defun ecomplete-save ()
  66   (with-temp-buffer
  67     (insert "(")
  68     (loop for (type . elems) in ecomplete-database
  69           do
  70           (insert (format "(%s\n" type))
  71           (dolist (entry elems)
  72             (prin1 entry (current-buffer))
  73             (insert "\n"))
  74           (insert ")\n"))
  75     (insert ")")
  76     (write-region (point-min) (point-max) ecomplete-database-file nil 'silent)))
  77
  78 (defun ecomplete-get-matches (type match)
  79   (let* ((elems (cdr (assq type ecomplete-database)))
  80          (match (regexp-quote match))
  81          (candidates
  82           (sort
  83            (loop for (key count time text) in elems
  84                  when (string-match match text)
  85                  collect (list count time text))
  86            (lambda (l1 l2)
  87              (> (car l1) (car l2))))))
  88     (when (> (length candidates) 10)
  89       (setcdr (nthcdr 10 candidates) nil))
  90     (unless (zerop (length candidates))
  91       (with-temp-buffer
  92         (dolist (candidate candidates)
  93           (insert (caddr candidate) "\n"))
  94         (goto-char (point-min))
  95         (put-text-property (point) (1+ (point)) 'ecomplete t)
  96         (while (re-search-forward match nil t)
  97           (put-text-property (match-beginning 0) (match-end 0)
  98                              'face 'isearch))
  99         (buffer-string)))))
 100
 101 (defun ecomplete-display-matches (type word &optional choose)
 102   (let* ((matches (ecomplete-get-matches type word))
 103          (line 0)
 104          (max-lines (when matches (- (length (split-string matches "\n")) 2)))
 105          (message-log-max nil)
 106          command highlight)
 107     (if (not matches)
 108         (progn
 109           (message "No ecomplete matches")
 110           nil)
 111       (if (not choose)
 112           (progn
 113             (message matches)
 114             nil)
 115         (setq highlight (ecomplete-highlight-match-line matches line))
 116         (while (not (memq (setq command (read-event highlight)) '(? return)))
 117           (cond
 118            ((eq command ?\M-n)
 119             (setq line (min (1+ line) max-lines)))
 120            ((eq command ?\M-p)
 121             (setq line (max (1- line) 0))))
 122           (setq highlight (ecomplete-highlight-match-line matches line)))
 123         (when (eq command 'return)
 124           (nth line (split-string matches "\n")))))))
 125
 126 (defun ecomplete-highlight-match-line (matches line)
 127   (with-temp-buffer
 128     (insert matches)
 129     (goto-char (point-min))
 130     (forward-line line)
 131     (save-restriction
 132       (narrow-to-region (point) (line-end-position))
 133       (while (not (eobp))
 134         ;; Put the 'region face on any charactes on this line that
 135         ;; aren't already highlighted.
 136         (unless (get-text-property (point) 'face)
 137           (put-text-property (point) (1+ (point)) 'face 'region))
 138         (forward-char 1)))
 139     (buffer-string)))
 140
 141 (provide 'ecomplete)
 142
 143 ;; arch-tag: 34622935-bb81-4711-a600-57b89c2ece72
 144 ;;; ecomplete.el ends here