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