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          command highlight)
 105     (if (not matches)
 106         (progn
 107           (message "No ecomplete matches")
 108           nil)
 109       (if (not choose)
 110           (progn
 111             (message matches)
 112             nil)
 113         (setq highlight (ecomplete-highlight-match-line matches line))
 114         (while (not (memq (setq command (read-event highlight)) '(? return)))
 115           (cond
 116            ((eq command ?\M-n)
 117             (setq line (min (1+ line) max-lines)))
 118            ((eq command ?\M-p)
 119             (setq line (max (1- line) 0))))
 120           (setq highlight (ecomplete-highlight-match-line matches line)))
 121         (when (eq command 'return)
 122           (nth line (split-string matches "\n")))))))
 123
 124 (defun ecomplete-highlight-match-line (matches line)
 125   (with-temp-buffer
 126     (insert matches)
 127     (goto-char (point-min))
 128     (forward-line line)
 129     (save-restriction
 130       (narrow-to-region (point) (line-end-position))
 131       (while (not (eobp))
 132         ;; Put the 'region face on any charactes on this line that
 133         ;; aren't already highlighted.
 134         (unless (get-text-property (point) 'face)
 135           (put-text-property (point) (1+ (point)) 'face 'region))
 136         (forward-char 1)))
 137     (buffer-string)))
 138
 139 (provide 'ecomplete)
 140
 141 ;; arch-tag: 34622935-bb81-4711-a600-57b89c2ece72
 142 ;;; ecomplete.el ends here