err.no Git - eweouz/blob - lisp/eweouz.el

   1 ;;; -*- Mode:Emacs-Lisp -*-
   2
   3 ;;; This file is the core of the eweouz, an interface to the
   4 ;;; evolution-data-server, somewhat similar to BBDB.
   5
   6 ;;;  copyright (c) 2008 Tollef Fog Heen <tfheen@err.no>
   7 ;;;
   8 ;;; eweouz is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License version 2 as
  10 ;;; published by the Free Software Foundation.
  11 ;;;
  12 ;;; eweouz is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;;; General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with this program; if not, write to the Free Software
  19 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  20 ;;; 02110-1301 USA.
  21 ;;;
  22
  23 (require 'cl)
  24
  25 (defconst eweouz-version "0.3")
  26 (defconst eweouz-buffer-name "*EWEOUZ*")
  27
  28 (setq eweouz-helper-dirs '("/usr/lib/eweouz" "/usr/local/lib/eweouz"))
  29
  30 (defvar eweouz-dump-path (locate-file "eweouz-dump-addressbook"
  31                                       eweouz-helper-dirs
  32                                       nil
  33                                       'executable))
  34
  35 (defvar eweouz-write-path (locate-file "eweouz-write-addressbook"
  36                                        eweouz-helper-dirs
  37                                        nil
  38                                        'executable))
  39
  40 (defvar eweouz-buffer nil)
  41 (defvar eweouz-pop-up-target-lines 5)
  42
  43 (defun eweouz-search-do (func string &optional max-matches)
  44   "Search for the simple string STRING in all fields"
  45   (let ((i 0))
  46     (with-temp-buffer
  47       (call-process eweouz-dump-path nil (list (current-buffer) nil) t string)
  48       (set-text-properties (point-min) (point-max) nil nil)
  49       (goto-char (point-min))
  50       (message (format "%s" (point)))
  51       (while (and (looking-at "\n*BEGIN:VCARD") (or (eq max-matches nil)
  52                                                  (< i max-matches)))
  53         (let ((m-start (point)))
  54           (incf i)
  55           (message (format "%s" (point)))
  56           (search-forward-regexp "^END:VCARD")
  57           (funcall func (vcard-parse-string (buffer-substring m-start (point)))))))))
  58
  59 ;;;###autoload
  60 (defun eweouz-complete (&optional start-pos)
  61   (interactive)
  62   (eweouz-erase-buffer)
  63   (let* ((end (point))
  64          (beg (or start-pos
  65                   (save-excursion
  66                     (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
  67                     (goto-char (match-end 0))
  68                     (point))))
  69          (typed (or (and (eq this-command last-command)
  70                          (get this-command 'typed))
  71                     (downcase (buffer-substring beg end))))
  72          (index (or (and (eq this-command last-command)
  73                          (get this-command 'index))
  74                     0))
  75          (match-recs '()))
  76     (eweouz-search-do '(lambda (x) (add-to-list 'match-recs x)) typed)
  77     (cond ((= 0 (length match-recs))
  78            (message "No matching records"))
  79           ((= 1 (length match-recs))
  80           ; Just one match; insert it
  81            (progn
  82              (delete-region beg end)
  83              (insert (vcard-format-sample-get-name (car match-recs)))))
  84           ((< 1 (length match-recs))
  85            ;; For now, just display the records and leave the user to
  86            ;; complete
  87            (if (eq this-command last-command)
  88                ;; Select next in list
  89                (progn
  90                  (delete-region beg end)
  91                  (insert (vcard-format-sample-get-name (nth index match-recs)))
  92                  (put this-command 'index (% (+ 1 index)
  93                                              (length match-recs))))
  94              (save-excursion
  95                (put this-command 'typed typed)
  96                (put this-command 'index 0)
  97                (set-buffer (get-buffer-create eweouz-buffer-name))
  98                (mapcar '(lambda (x) (insert (format "%s\n"
  99                                                   (vcard-format-sample-get-name x)))) match-recs)
 100                (eweouz-pop-up-eweouz-buffer)))))))
 101
 102 ;
 103 ; Mostly stolen from bbdb-pop-up-bbdb-buffer
 104
 105 (defun eweouz-pop-up-eweouz-buffer (&optional horiz-predicate)
 106  (let ((b (current-buffer)))
 107     (if (get-buffer-window eweouz-buffer-name)
 108         nil
 109       (let* ((first-window (selected-window))
 110              (tallest-window first-window)
 111              (window first-window))
 112         ;; find the tallest window...
 113         (while (not (eq (setq window (previous-window window)) first-window))
 114           (if (> (window-height window) (window-height tallest-window))
 115               (setq tallest-window window)))
 116         ;; select it and split it...
 117         (select-window tallest-window)
 118         (let ((size (min
 119                      (- (window-height tallest-window)
 120                         window-min-height 1)
 121                      (- (window-height tallest-window)
 122                         (max window-min-height
 123                              (1+ eweouz-pop-up-target-lines))))))
 124           (split-window tallest-window
 125                         (if (> size 0) size window-min-height)))
 126         (if (memq major-mode
 127                   '(gnus-Group-mode gnus-Subject-mode gnus-Article-mode))
 128             (goto-char (point-min)))  ; make gnus happy...
 129         ;; goto the bottom of the two...
 130         (select-window (next-window))
 131         ;; make it display *EWEOUZ*...
 132         (let ((pop-up-windows nil))
 133           (switch-to-buffer (get-buffer-create eweouz-buffer-name)))
 134         ;; select the original window we were in...
 135         (select-window first-window)))
 136     ;; and make sure the current buffer is correct as well.
 137     (set-buffer b)
 138     nil))
 139
 140 (defun eweouz-erase-buffer ()
 141   (save-excursion
 142     (set-buffer (get-buffer-create eweouz-buffer-name))
 143     (erase-buffer)))
 144
 145 ;;;###autoload
 146 (defun eweouz (string)
 147   (interactive "MSearch for: ")
 148   "Search all entries for the simple string STRING in all fields"
 149   (eweouz-erase-buffer)
 150   (eweouz-search-do 'eweouz-show string)
 151   (eweouz-pop-up-eweouz-buffer))
 152
 153 (defun eweouz-show (record)
 154   "Display an entry in the current buffer"
 155   (save-excursion
 156     (set-buffer (get-buffer-create eweouz-buffer-name))
 157     (insert (vcard-pretty-print record))))
 158
 159 (defun eweouz-add-sender-gnus ()
 160   "Add sender of current message"
 161   (interactive)
 162   (save-excursion
 163     (set-buffer gnus-article-buffer)
 164     (let* ((from (mail-header-parse-address (gnus-fetch-field "From")))
 165            (email (car from))
 166            (name (cdr from))
 167            (record (or (eweouz-search-do 'identity email 1)
 168                        (eweouz-search-do 'identity name 1))))
 169       (if record
 170           (eweouz-do-update record name email)
 171         (eweouz-do-add from)))))
 172
 173 (defun eweouz-do-update (record name email)
 174   (interactive)
 175   (let ((uid (cadr (assoc '("uid") record))))
 176     (message (format "%s %s %s" uid name email))
 177     (call-process eweouz-write-path nil nil nil "--id" uid "--full-name" name
 178                   "--emails" email)))
 179
 180 (defun eweouz-do-add (record)
 181   (interactive)
 182   (let* ((email (car record))
 183          (name (cdr record)))
 184     (message (format "%s" record))
 185     (call-process eweouz-write-path nil nil nil "--id" "new" "--full-name" name
 186                   "--emails" email)))
 187
 188 (defun eweouz-insinuate-gnus ()
 189   "Call this function to hook EWEOUZ into Gnus."
 190   (define-key gnus-summary-mode-map ":" 'eweouz-add-sender-gnus))
 191
 192 (defun eweouz-insinuate-sendmail ()
 193   "Call this function to hook EWEOUZ into sendmail (M-x mail)."
 194   (define-key mail-mode-map [C-tab] 'eweouz-complete))
 195
 196 (defun eweouz-insinuate-message ()
 197   "Call this function to hook EWEOUZ into message-mode."
 198   (define-key message-mode-map [C-tab] 'eweouz-complete))
 199
 200 (defun eweouz-insinuate-wl ()
 201   (define-key wl-draft-mode-map [C-tab] 'eweouz-complete)
 202   (define-key wl-summary-mode-map ":" 'eweouz-add-sender-wl))
 203
 204 (defun eweouz-add-sender-wl ()
 205   "Add sender of current message"
 206   (interactive)
 207   (wl-summary-set-message-buffer-or-redisplay)
 208   (set-buffer (wl-message-get-original-buffer))
 209   (let* ((from (std11-extract-address-components (std11-field-body "From")))
 210          (name (cadr from))
 211          (email (car from))
 212          (record (cons name email)))
 213     (eweouz-do-add record)))
 214
 215 (require 'vcard)
 216 (provide 'eweouz)
 217