X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lsdb.el;h=24f2f6736ba5d166c57a5c6013f0e37e6aac62ca;hb=3a24afba91883fdc132610e34b2067488dc3448e;hp=f67cc77d48508a502fa225b88a07f75faf2a08c6;hpb=0ba51e406b7d7db2c08ef23f74bc94e7382b5e05;p=elisp%2Flsdb.git diff --git a/lsdb.el b/lsdb.el index f67cc77..24f2f67 100644 --- a/lsdb.el +++ b/lsdb.el @@ -31,6 +31,9 @@ ;;; (add-hook 'message-setup-hook ;;; (lambda () ;;; (define-key message-mode-map "\M-\t" 'lsdb-complete-name))) +;;; (add-hook 'gnus-summary-mode-hook +;;; (lambda () +;;; (define-key gnus-summary-mode-map ":" 'lsdb-toggle-buffer))) ;;; For Wanderlust, put the following lines into your ~/.wl: ;;; (require 'lsdb) @@ -38,6 +41,9 @@ ;;; (add-hook 'wl-draft-mode-hook ;;; (lambda () ;;; (define-key wl-draft-mode-map "\M-\t" 'lsdb-complete-name))) +;;; (add-hook 'wl-summary-mode-hook +;;; (lambda () +;;; (define-key wl-summary-mode-map ":" 'lsdb-wl-toggle-buffer))) ;;; For Mew, put the following lines into your ~/.mew: ;;; (autoload 'lsdb-mew-insinuate "lsdb") @@ -45,6 +51,9 @@ ;;; (add-hook 'mew-draft-mode-hook ;;; (lambda () ;;; (define-key mew-draft-header-map "\M-I" 'lsdb-complete-name))) +;;; (add-hook 'mew-summary-mode-hook +;;; (lambda () +;;; (define-key mew-summary-mode-map "l" 'lsdb-toggle-buffer))) ;;; Code: @@ -106,7 +115,7 @@ where the last three elements are optional." (attribution 4 ?.) (organization 4) (www 4) - (aka 4) + (aka 4 ?,) (score -1) (x-face -1)) "Alist of entry types for presentation. @@ -158,6 +167,12 @@ The updated record is passed to each function as the argument." :group 'lsdb :type 'integer) +(defcustom lsdb-x-face-image-type nil + "A image type of displayed x-face. +If non-nil, supersedes the return value of `lsdb-x-face-available-image-type'." + :group 'lsdb + :type 'symbol) + (defcustom lsdb-x-face-command-alist '((pbm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale 0.5") (xpm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale 0.5 | ppmtoxpm")) @@ -188,7 +203,12 @@ The compressed face will be piped to this command." "A predicate to sort records." :group 'lsdb :type 'function) - + +(defcustom lsdb-pop-up-windows t + "Non-nil means LSDB should make new windows to display records." + :group 'lsdb + :type 'boolean) + (defgroup lsdb-edit-form nil "A mode for editing forms." :group 'lsdb) @@ -262,6 +282,12 @@ It represents address to full-name mapping.") (make-vector 29 0) "An obarray used to complete an entry name.") +(defvar lsdb-temp-buffer-show-function + #'lsdb-temp-buffer-show-function + "Non-nil means call as function to display a help buffer. +The function is called with one argument, the buffer to be displayed. +Overrides `temp-buffer-show-function'.") + ;;;_. Hash Table Emulation (if (and (fboundp 'make-hash-table) (subrp (symbol-function 'make-hash-table))) @@ -441,7 +467,11 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (defun lsdb-extract-address-components (string) (let ((components (std11-extract-address-components string))) - (if (nth 1 components) + (if (and (nth 1 components) + ;; When parsing a group address, + ;; std11-extract-address-components is likely to return + ;; the ("GROUP" "") form. + (not (equal (nth 1 components) ""))) (if (car components) (list (funcall lsdb-canonicalize-full-name-function (car components)) @@ -463,10 +493,10 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (set-buffer-multibyte multibyte)))) ;;;_. Record Management -(defun lsdb-maybe-load-secondary-hash-tables () +(defun lsdb-rebuild-secondary-hash-tables (&optional force) (let ((tables lsdb-secondary-hash-tables)) (while tables - (unless (symbol-value (car tables)) + (when (or force (not (symbol-value (car tables)))) (set (car tables) (lsdb-make-hash-table :test 'equal)) (lsdb-maphash (lambda (key value) @@ -482,7 +512,7 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (if (file-exists-p lsdb-file) (lsdb-load-hash-tables) (setq lsdb-hash-table (lsdb-make-hash-table :test 'equal))) - (lsdb-maybe-load-secondary-hash-tables))) + (lsdb-rebuild-secondary-hash-tables))) ;;;_ : Fallback Lookup Functions ;;;_ , #1 Address Cache @@ -627,27 +657,31 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." old) ;;;_. Display Management -(defun lsdb-temp-buffer-show-function (buffer) +(defun lsdb-fit-window-to-buffer (&optional window) (save-selected-window - (let ((window (or (get-buffer-window lsdb-buffer-name) - (progn - (select-window (get-largest-window)) - (split-window-vertically)))) - height) - (set-window-buffer window buffer) - (select-window window) - (unless (pos-visible-in-window-p (point-max)) - (enlarge-window (- lsdb-window-max-height (window-height)))) - (shrink-window-if-larger-than-buffer) - (if (> (setq height (window-height)) - lsdb-window-max-height) + (if window + (select-window window)) + (unless (pos-visible-in-window-p (point-max)) + (enlarge-window (- lsdb-window-max-height (window-height)))) + (shrink-window-if-larger-than-buffer) + (let ((height (window-height))) + (if (> height lsdb-window-max-height) (shrink-window (- height lsdb-window-max-height))) (set-window-start window (point-min))))) +(defun lsdb-temp-buffer-show-function (buffer) + (when lsdb-pop-up-windows + (save-selected-window + (let ((window (or (get-buffer-window lsdb-buffer-name) + (progn + (select-window (get-largest-window)) + (split-window-vertically))))) + (set-window-buffer window buffer) + (lsdb-fit-window-to-buffer window))))) + (defun lsdb-display-record (record) "Display only one RECORD, then shrink the window as possible." - (let ((temp-buffer-show-function - (function lsdb-temp-buffer-show-function))) + (let ((temp-buffer-show-function lsdb-temp-buffer-show-function)) (lsdb-display-records (list record)))) (defun lsdb-display-records (records) @@ -701,6 +735,7 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (defvar lsdb-last-completion nil) (defvar lsdb-last-candidates nil) (defvar lsdb-last-candidates-pointer nil) +(defvar lsdb-complete-marker nil) ;;;_ : Matching Highlight (defvar lsdb-last-highlight-overlay nil) @@ -715,12 +750,14 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (make-overlay (match-beginning 0) (match-end 0))) (overlay-put lsdb-last-highlight-overlay 'face (or (find-face 'isearch-secondary) + (find-face 'isearch-lazy-highlight-face) 'underline)))) (defun lsdb-complete-name-highlight-update () - (unless (eq 'this-command 'lsdb-complete-name) + (unless (eq this-command 'lsdb-complete-name) (if lsdb-last-highlight-overlay (delete-overlay lsdb-last-highlight-overlay)) + (set-marker lsdb-complete-marker nil) (remove-hook 'pre-command-hook 'lsdb-complete-name-highlight-update t))) @@ -729,11 +766,14 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." "Complete the user full-name or net-address before point" (interactive) (lsdb-maybe-load-hash-tables) + (unless (markerp lsdb-complete-marker) + (setq lsdb-complete-marker (make-marker))) (let* ((start - (save-excursion - (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*") - (goto-char (match-end 0)) - (point))) + (or (and (eq (marker-buffer lsdb-complete-marker) (current-buffer)) + (marker-position lsdb-complete-marker)) + (save-excursion + (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*") + (set-marker lsdb-complete-marker (match-end 0))))) pattern (case-fold-search t) (completion-ignore-case t)) @@ -854,6 +894,7 @@ Modify whole identification by side effect." (define-key keymap "a" 'lsdb-mode-add-entry) (define-key keymap "d" 'lsdb-mode-delete-entry) (define-key keymap "e" 'lsdb-mode-edit-entry) + (define-key keymap "l" 'lsdb-mode-load) (define-key keymap "s" 'lsdb-mode-save) (define-key keymap "q" 'lsdb-mode-quit-window) (define-key keymap "g" 'lsdb-mode-lookup) @@ -903,7 +944,7 @@ Modify whole identification by side effect." (let ((end (next-single-property-change (point) 'lsdb-record nil (point-max)))) (narrow-to-region - (previous-single-property-change (point) 'lsdb-record nil (point-min)) + (previous-single-property-change end 'lsdb-record nil (point-min)) end) (goto-char (point-min)))) @@ -1035,11 +1076,20 @@ the current record." (message "(No changes need to be saved)") (when (or (interactive-p) dont-ask - (y-or-n-p "Save the LSDB now?")) + (y-or-n-p "Save the LSDB now? ")) (lsdb-save-hash-tables) (setq lsdb-hash-tables-are-dirty nil) (message "The LSDB was saved successfully.")))) +(defun lsdb-mode-load () + "Load LSDB hash table from `lsdb-file'." + (interactive) + (let (lsdb-secondary-hash-tables) + (lsdb-load-hash-tables)) + (message "Rebuilding secondary hash tables...") + (lsdb-rebuild-secondary-hash-tables t) + (message "Rebuilding secondary hash tables...done")) + (defun lsdb-mode-quit-window (&optional kill window) "Quit the current buffer. It partially emulates the GNU Emacs' of `quit-window'." @@ -1053,14 +1103,42 @@ It partially emulates the GNU Emacs' of `quit-window'." (delete-window window)) (if kill (kill-buffer buffer) - (bury-buffer buffer)))) + (bury-buffer (unless (eq buffer (current-buffer)) buffer))))) -(defun lsdb-mode-hide-buffer () +(defun lsdb-hide-buffer () "Hide the LSDB window." (let ((window (get-buffer-window lsdb-buffer-name))) (if window (lsdb-mode-quit-window nil window)))) +(defun lsdb-show-buffer () + "Show the LSDB window." + (if (get-buffer lsdb-buffer-name) + (if lsdb-temp-buffer-show-function + (let ((lsdb-pop-up-windows t)) + (funcall lsdb-temp-buffer-show-function lsdb-buffer-name)) + (pop-to-buffer lsdb-buffer-name)))) + +(defun lsdb-toggle-buffer (&optional arg) + "Toggle hiding of the LSDB window. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 0))) + (unless arg ;called noninteractively? + (setq arg 0)) + (cond + ((or (< arg 0) + (and (zerop arg) + (not (get-buffer-window lsdb-buffer-name)))) + (lsdb-show-buffer)) + ((or (> arg 0) + (and (zerop arg) + (get-buffer-window lsdb-buffer-name))) + (lsdb-hide-buffer)))) + (defun lsdb-lookup-records (regexp &optional entry-name) "Return the all records in the LSDB matching the REGEXP. If the optional 2nd argument ENTRY-NAME is given, matching only @@ -1232,7 +1310,12 @@ of the buffer." (defun lsdb-wl-insinuate () "Call this function to hook LSDB into Wanderlust." (add-hook 'wl-message-redisplay-hook 'lsdb-wl-update-record) - (add-hook 'wl-summary-exit-hook 'lsdb-mode-hide-buffer) + (add-hook 'wl-summary-exit-hook 'lsdb-hide-buffer) + (add-hook 'wl-summary-toggle-disp-off-hook 'lsdb-hide-buffer) + (add-hook 'wl-summary-toggle-disp-folder-on-hook 'lsdb-hide-buffer) + (add-hook 'wl-summary-toggle-disp-folder-off-hook 'lsdb-hide-buffer) + (add-hook 'wl-summary-toggle-disp-folder-message-resumed-hook + 'lsdb-wl-show-buffer) (add-hook 'wl-exit-hook 'lsdb-mode-save) (add-hook 'wl-save-hook 'lsdb-mode-save)) @@ -1243,15 +1326,54 @@ of the buffer." (set-buffer (wl-message-get-original-buffer)) (let ((records (lsdb-update-records))) (when records - (lsdb-display-record (car records)))))) - -;;;_. Interface to Mew written by Hideyuki SHIRAI + (let ((lsdb-temp-buffer-show-function + #'lsdb-wl-temp-buffer-show-function)) + (lsdb-display-record (car records))))))) + +(defun lsdb-wl-toggle-buffer (&optional arg) + "Toggle hiding of the LSDB window for Wanderlust. +If given a negative prefix, always show; if given a positive prefix, +always hide." + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 0))) + (let ((lsdb-temp-buffer-show-function + #'lsdb-wl-temp-buffer-show-function)) + (lsdb-toggle-buffer arg))) + +(defun lsdb-wl-show-buffer () + (when lsdb-pop-up-windows + (let ((lsdb-temp-buffer-show-function + #'lsdb-wl-temp-buffer-show-function)) + (lsdb-show-buffer)))) + +(defvar wl-current-summary-buffer) +(defvar wl-message-buffer) +(defun lsdb-wl-temp-buffer-show-function (buffer) + (when lsdb-pop-up-windows + (save-selected-window + (let ((window (or (get-buffer-window lsdb-buffer-name) + (progn + (select-window + (or (save-excursion + (if (buffer-live-p wl-current-summary-buffer) + (set-buffer wl-current-summary-buffer)) + (get-buffer-window wl-message-buffer)) + (get-largest-window))) + (split-window-vertically))))) + (set-window-buffer window buffer) + (lsdb-fit-window-to-buffer window))))) + +;;;_. Interface to Mew written by Hideyuki SHIRAI (eval-when-compile (autoload 'mew-sinfo-get-disp-msg "mew") (autoload 'mew-current-get-fld "mew") (autoload 'mew-current-get-msg "mew") (autoload 'mew-frame-id "mew") - (autoload 'mew-cache-hit "mew")) + (autoload 'mew-cache-hit "mew") + (autoload 'mew-xinfo-get-decode-err "mew") + (autoload 'mew-xinfo-get-action "mew")) ;;;###autoload (defun lsdb-mew-insinuate () @@ -1260,25 +1382,36 @@ of the buffer." (add-hook 'mew-summary-toggle-disp-msg-hook (lambda () (unless (mew-sinfo-get-disp-msg) - (lsdb-mode-hide-buffer)))) - (add-hook 'mew-suspend-hook 'lsdb-mode-hide-buffer) + (lsdb-hide-buffer)))) + (add-hook 'mew-suspend-hook 'lsdb-hide-buffer) (add-hook 'mew-quit-hook 'lsdb-mode-save) - (add-hook 'kill-emacs-hook 'lsdb-mode-save)) + (add-hook 'kill-emacs-hook 'lsdb-mode-save) + (cond + ;; Mew 3 + ((fboundp 'mew-summary-visit-folder) + (defadvice mew-summary-visit-folder (before lsdb-hide-buffer activate) + (lsdb-hide-buffer))) + ;; Mew 2 + ((fboundp 'mew-summary-switch-to-folder) + (defadvice mew-summary-switch-to-folder (before lsdb-hide-buffer activate) + (lsdb-hide-buffer))))) (defun lsdb-mew-update-record () (let* ((fld (mew-current-get-fld (mew-frame-id))) (msg (mew-current-get-msg (mew-frame-id))) - (cache (mew-cache-hit fld msg 'must-hit)) + (cache (mew-cache-hit fld msg)) records) - (save-excursion - (set-buffer cache) - (make-local-variable 'lsdb-decode-field-body-function) - (setq lsdb-decode-field-body-function - (lambda (body name) - (set-text-properties 0 (length body) nil body) - body)) - (when (setq records (lsdb-update-records)) - (lsdb-display-record (car records)))))) + (when cache + (save-excursion + (set-buffer cache) + (unless (or (mew-xinfo-get-decode-err) (mew-xinfo-get-action)) + (make-local-variable 'lsdb-decode-field-body-function) + (setq lsdb-decode-field-body-function + (lambda (body name) + (set-text-properties 0 (length body) nil body) + body)) + (when (setq records (lsdb-update-records)) + (lsdb-display-record (car records)))))))) ;;;_. Interface to MU-CITE (eval-when-compile @@ -1429,7 +1562,8 @@ the user wants it." 'lsdb-record record))))) (defun lsdb-insert-x-face-asynchronously (x-face) - (let* ((type (lsdb-x-face-available-image-type)) + (let* ((type (or lsdb-x-face-image-type + (lsdb-x-face-available-image-type))) (shell-file-name lsdb-shell-file-name) (shell-command-switch lsdb-shell-command-switch) (process-connection-type nil) @@ -1465,7 +1599,7 @@ the user wants it." (provide 'lsdb) (product-provide 'lsdb - (product-define "LSDB" nil '(0 2))) + (product-define "LSDB" nil '(0 7))) ;;;_* Local emacs vars. ;;; The following `outline-layout' local variable setting: